Index: .fossil-settings/crlf-glob ================================================================== --- .fossil-settings/crlf-glob +++ .fossil-settings/crlf-glob @@ -5,16 +5,14 @@ compat/zlib/win32/*.txt compat/zlib/win64/*.txt libtommath/*.dsp libtommath/*.sln libtommath/*.vcproj -tools/tcl.hpj.in tools/tcl.wse.in win/buildall.vc.bat win/coffbase.txt win/makefile.vc win/rules.vc win/rules-ext.vc win/targets.vc win/tcl.dsp win/tcl.dsw -win/tcl.hpj.in Index: .fossil-settings/encoding-glob ================================================================== --- .fossil-settings/encoding-glob +++ .fossil-settings/encoding-glob @@ -1,9 +1,10 @@ tools/tcl.hpj.in tools/tcl.wse.in win/buildall.vc.bat win/coffbase.txt +win/makefile.bc win/makefile.vc win/rules.vc win/tcl.dsp win/tcl.dsw win/tcl.hpj.in Index: .fossil-settings/ignore-glob ================================================================== --- .fossil-settings/ignore-glob +++ .fossil-settings/ignore-glob @@ -22,11 +22,12 @@ */tclsh* */tcltest* */versions.vc */version.vc */libtcl.vfs -*/libtcl_*.zip +*/libtcl*.zip +*/tclUuid.h html libtommath/bn.ilg libtommath/bn.ind libtommath/pretty.build libtommath/tommath.src DELETED .github/ISSUE_TEMPLATE.md Index: .github/ISSUE_TEMPLATE.md ================================================================== --- .github/ISSUE_TEMPLATE.md +++ /dev/null @@ -1,3 +0,0 @@ -Important Note -========== -Please do not file issues with Tcl on Github. They are unlikely to be noticed in a timely fashion. Tcl issues are hosted in the [tcl fossil repository on core.tcl.tk](https://core.tcl.tk/tcl/tktnew); please post them there. DELETED .github/PULL_REQUEST_TEMPLATE.md Index: .github/PULL_REQUEST_TEMPLATE.md ================================================================== --- .github/PULL_REQUEST_TEMPLATE.md +++ /dev/null @@ -1,3 +0,0 @@ -Important Note -========== -Please do not file pull requests with Tcl on Github. They are unlikely to be noticed in a timely fashion. Tcl issues (including patches) are hosted in the [tcl fossil repository on core.tcl.tk](https://core.tcl.tk/tcl/tktnew); please post them there. Index: .gitignore ================================================================== --- .gitignore +++ .gitignore @@ -24,15 +24,16 @@ html manifest.uuid _FOSSIL_ */tclConfig.sh */tclsh* -*/tcltest* +*/tcltest */versions.vc */version.vc */libtcl.vfs -*/libtcl_*.zip +*/libtcl*.zip +*/tclUuid.h libtommath/bn.ilg libtommath/bn.ind libtommath/pretty.build libtommath/tommath.src libtommath/*.log Index: .project ================================================================== --- .project +++ .project @@ -1,8 +1,8 @@ - tcl9 + tcl8.5 DELETED .travis.yml Index: .travis.yml ================================================================== --- .travis.yml +++ /dev/null @@ -1,438 +0,0 @@ -language: c -addons: - apt: - sources: - - ubuntu-toolchain-r-test - packages: - - binutils-mingw-w64-i686 - - binutils-mingw-w64-x86-64 - - gcc-mingw-w64 - - gcc-mingw-w64-base - - gcc-mingw-w64-i686 - - gcc-mingw-w64-x86-64 - - gcc-multilib -jobs: - include: -# Testing on Linux GCC - - name: "Linux/GCC/Shared" - os: linux - dist: focal - compiler: gcc - env: - - BUILD_DIR=unix - - name: "Linux/GCC/Shared: UTF_MAX=3" - os: linux - dist: focal - compiler: gcc - env: - - BUILD_DIR=unix - - CFGOPT="CFLAGS=-DTCL_UTF_MAX=3" - - name: "Linux/GCC/Shared: NO_DEPRECATED" - os: linux - dist: focal - compiler: gcc - env: - - BUILD_DIR=unix - - CFGOPT="CFLAGS=-DTCL_NO_DEPRECATED=1" - - name: "Linux/GCC/Static" - os: linux - dist: focal - compiler: gcc - env: - - CFGOPT="--disable-shared" - - BUILD_DIR=unix - - name: "Linux/GCC/Debug" - os: linux - dist: focal - compiler: gcc - env: - - BUILD_DIR=unix - - CFGOPT="--enable-symbols" - - name: "Linux/GCC/Mem-Debug" - os: linux - dist: focal - compiler: gcc - env: - - BUILD_DIR=unix - - CFGOPT="--enable-symbols=mem" -# C++ build. - - name: "Linux/G++/Shared" - os: linux - dist: focal - compiler: g++ - env: - - BUILD_DIR=unix - - CFGOPT="CC=g++ CFLAGS=-Dregister=dont+use+register" -# Newer/Older versions of GCC - - name: "Linux/GCC 10/Shared" - os: linux - dist: focal - compiler: gcc-10 - addons: - apt: - packages: - - g++-10 - env: - - BUILD_DIR=unix - - name: "Linux/GCC 5/Shared" - os: linux - dist: bionic - compiler: gcc-5 - addons: - apt: - packages: - - g++-5 - env: - - BUILD_DIR=unix -# Testing on Linux Clang - - name: "Linux/Clang/Shared" - os: linux - dist: focal - compiler: clang - env: - - BUILD_DIR=unix - - name: "Linux/Clang/Static" - os: linux - dist: focal - compiler: clang - env: - - CFGOPT="--disable-shared" - - BUILD_DIR=unix - - name: "Linux/Clang/Debug" - os: linux - dist: focal - compiler: clang - env: - - BUILD_DIR=unix - - CFGOPT="--enable-symbols" - - name: "Linux/Clang/Mem-Debug" - os: linux - dist: focal - compiler: clang - env: - - BUILD_DIR=unix - - CFGOPT="--enable-symbols=mem" -# Testing on Mac, various styles - - name: "macOS/Clang/Xcode 12/Shared" - os: osx - osx_image: xcode12.2 - env: - - BUILD_DIR=macosx - install: [] - script: &mactest - - make all - # The styles=develop avoids some weird problems on OSX - - make test styles=develop - - name: "macOS/Clang/Xcode 12/Shared/Unix-like" - os: osx - osx_image: xcode12.2 - env: - - BUILD_DIR=unix - - CFGOPT="--enable-dtrace" - - name: "macOS/Clang/Xcode 12/Shared/libtommath" - os: osx - osx_image: xcode12.2 - env: - - BUILD_DIR=macosx - install: [] - script: *mactest - addons: - homebrew: - packages: - - libtommath - - name: "macOS/Clang++/Xcode 12/Shared" - os: osx - osx_image: xcode12.2 - env: - - BUILD_DIR=unix - - CFGOPT="CC=clang++ --enable-framework --enable-dtrace CFLAGS=-Dregister=dont+use+register CPPFLAGS=-D__private_extern__=extern" - script: - - make all tcltest -# Newer MacOS versions - - name: "macOS/Clang/Xcode 12/Universal Apps/Shared" - os: osx - osx_image: xcode12u - env: - - BUILD_DIR=macosx - install: [] - script: *mactest -# Older MacOS versions - - name: "macOS/Clang/Xcode 11/Shared" - os: osx - osx_image: xcode11.7 - env: - - BUILD_DIR=macosx - install: [] - script: *mactest - - name: "macOS/Clang/Xcode 10/Shared" - os: osx - osx_image: xcode10.3 - env: - - BUILD_DIR=macosx - install: [] - script: *mactest - - name: "macOS/Clang/Xcode 9/Shared" - os: osx - osx_image: xcode9.4 - env: - - BUILD_DIR=macosx - install: [] - script: *mactest - - name: "macOS/Clang/Xcode 8/Shared" - os: osx - osx_image: xcode8.3 - env: - - BUILD_DIR=macosx - install: [] - script: *mactest -# Test with mingw-w64 cross-compile -# Doesn't run tests because wine is only an imperfect Windows emulation - - name: "Linux-cross-Windows/GCC/Shared/no test" - os: linux - dist: focal - compiler: x86_64-w64-mingw32-gcc - env: - - BUILD_DIR=win - - CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit" - script: &crosstest - - make all tcltest - # Include a high visibility marker that tests are skipped outright - - > - echo "`tput setaf 3`SKIPPED TEST: CROSS COMPILING`tput sgr0`" -# Test with mingw-w64 (32 bit) cross-compile -# Doesn't run tests because wine is only an imperfect Windows emulation - - name: "Linux-cross-Windows-32/GCC/Shared/no test" - os: linux - dist: focal - compiler: i686-w64-mingw32-gcc - env: - - BUILD_DIR=win - - CFGOPT=--host=i686-w64-mingw32 - script: *crosstest -# Test on Windows with MSVC native - - name: "Windows/MSVC/Shared" - os: windows - compiler: cl - env: &vcenv - - BUILD_DIR=win - - VCDIR="/C/Program Files (x86)/Microsoft Visual Studio/2017/BuildTools/VC/Auxiliary/Build" - before_install: &vcpreinst - - rm -rf tests/safe-stock8*.test - - touch generic/tclStubInit.c generic/tclOOStubInit.c generic/tclOOScript.h - - PATH="$PATH:$VCDIR" - - cd ${BUILD_DIR} - install: [] - script: - - cmd.exe //C vcvarsall.bat x64 '&&' nmake '-f' makefile.vc all tcltest - - cmd.exe //C vcvarsall.bat x64 '&&' nmake '-f' makefile.vc test - - name: "Windows/MSVC/Shared: 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: 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 - - rm -rf tests/safe-stock8*.test - - touch generic/tclStubInit.c generic/tclOOStubInit.c generic/tclOOScript.h - - choco install -y make zip - - cd ${BUILD_DIR} - - name: "Windows/GCC/Shared: UTF_MAX=3" - os: windows - compiler: gcc - env: - - BUILD_DIR=win - - CFGOPT="--enable-64bit CFLAGS=-DTCL_UTF_MAX=3" - 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=3" - os: windows - compiler: gcc - env: - - BUILD_DIR=win - - CFGOPT="CFLAGS=-DTCL_UTF_MAX=3" - 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 -# "make dist" only - - name: "Linux: make dist" - os: linux - dist: focal - compiler: gcc - env: - - BUILD_DIR=unix - script: - - make dist -before_install: - - rm -rf tests/safe-stock8*.test - - touch generic/tclStubInit.c generic/tclOOStubInit.c generic/tclOOScript.h - - cd ${BUILD_DIR} -install: - - mkdir "$HOME/install dir" - - ./configure ${CFGOPT} "--prefix=$HOME/install dir" || (cat config.log && exit 1) -before_script: - - export ERROR_ON_FAILURES=1 -script: - - make all tcltest || echo "Something wrong, maybe a hickup, let's try again" - - make test - - make install Index: ChangeLog ================================================================== --- ChangeLog +++ ChangeLog @@ -5,71 +5,28 @@ Because of this, many Tcl developers are now out of the habit of maintaining this log file. You may still find useful things in it, but the Timeline is a better first place to look now. ============================================================================ -2013-09-19 Don Porter +2013-08-30 Don Porter - *** 8.6.1 TAGGED FOR RELEASE *** - - * generic/tcl.h: Bump version number to 8.6.1. + * generic/tcl.h: Bump to 8.5.15 for release. * library/init.tcl: + * tools/tcl.wse.in: * unix/configure.in: - * win/configure.in: * unix/tcl.spec: + * win/configure.in: * README: * unix/configure: autoconf-2.59 * win/configure: -2013-09-19 Donal Fellows - - * doc/next.n (METHOD SEARCH ORDER): Bug [3606943]: Corrected - description of method search order. - -2013-09-18 Donal Fellows - - Bump TclOO version to 1.0.1 for release. - -2013-09-17 Donal Fellows - - * generic/tclBinary.c (BinaryEncodeUu, BinaryDecodeUu): [Bug 2152292]: - Corrected implementation of the core of uuencode handling so that the - line length processing is correctly applied. - ***POTENTIAL INCOMPATIBILITY*** - Existing code that was using the old versions and working around the - limitations will now need to do far less. The -maxlen option now has - strict limits on the range of supported lengths; this is a limitation - of the format itself. - -2013-09-09 Donal Fellows - - * generic/tclOOMethod.c (CloneProcedureMethod): [Bug 3609693]: Strip - the internal representation of method bodies during cloning in order - to ensure that any bound references to instance variables are removed. - -2013-09-01 Donal Fellows - - * generic/tclBinary.c (BinaryDecodeHex): [Bug b98fa55285]: Ensure that - whitespace at the end of a string don't cause the decoder to drop the - last decoded byte. - -2013-08-03 Donal Fellows - - * library/auto.tcl: [Patch 3611643]: Allow TclOO classes to be found - by the autoloading mechanism. - -2013-08-02 Donal Fellows - - * generic/tclOODefineCmds.c (ClassSuperSet): Bug [9d61624b3d]: Stop - crashes when emptying the superclass slot, even when doing elaborate - things with metaclasses. - 2013-08-01 Harald Oehlmann - * tclUnixNotify.c (Tcl_InitNotifier): Bug [a0bc856dcd]: Start notifier - thread again if we were forked, to solve Rivet bug 55153. + * tclUnixNotify.c Tcl_InitNotifier: Bug [a0bc856dcd] + Start notifier thread again if we were forked, to solve Rivet bug + 55153. 2013-07-05 Kevin B. Kenny * library/tzdata/Africa/Casablanca: * library/tzdata/America/Asuncion: @@ -89,178 +46,122 @@ * unix/tcl.m4: Bug [32afa6e256]: dirent64 check is incorrect in tcl.m4 * unix/configure: (thanks to Brian Griffin) 2013-06-27 Jan Nijtmans - * generic/tclConfig.c: Bug [9b2e636361]: Tcl_CreateInterp() needs - * generic/tclMain.c: initialized encodings. + * generic/tclConfig.c: Bug [9b2e636361]: Tcl_CreateInterp() needs initialized + * generic/tclMain.c: encodings. 2013-06-18 Jan Nijtmans - * generic/tclEvent.c: Bug [3611974]: InitSubsystems multiple thread - issue. + * generic/tclEvent.c: Bug [3611974]: InitSubsystems multiple thread issue. 2013-06-17 Jan Nijtmans * generic/regc_locale.c: Bug [a876646efe]: re_expr character class [:cntrl:] should contain \u0000 - \u001f -2013-06-09 Donal K. Fellows - - * generic/tclCompCmdsSZ.c (TclCompileTryCmd): [Bug 779d38b996]: - Rewrote the [try] compiler to generate better code in some cases and - to behave correctly in others; when an error happens during the - processing of an exception-trap clause or a finally clause, the - *original* return options are now captured in a -during option, even - when fully compiled. - -2013-06-05 Donal K. Fellows - - * generic/tclExecute.c (INST_EXPAND_DROP): [Bugs 2835313, 3614226]: - New opcode to allow resetting the stack to get rid of an expansion, - restoring the stack to a known state in the process. - * generic/tclCompile.c, generic/tclCompCmds.c: Adjusted the compilers - for [break] and [continue] to get stack cleanup right in the majority - of cases. - * tests/for.test (for-7.*): Set of tests for these evil cases. - -2013-06-04 Jan Nijtmans - - * unix/tcl.m4: Eliminate NO_VIZ macro as current zlib uses HAVE_HIDDEN - instead. One more last-moment fix for FreeBSD by Pietro Cerutti - 2013-06-03 Miguel Sofer * generic/tclExecute.c: fix for perf bug detected by Kieran (https://groups.google.com/forum/?fromgroups#!topic/comp.lang.tcl/vfpI3bc-DkQ), diagnosed by dgp to be a close relative of [Bug 781585], which was fixed by commit [f46fb50cb3]. This bug was introduced by myself in commit [cbfe055d8c]. -2013-06-03 Donal K. Fellows - - * generic/tclCompCmds.c (TclCompileBreakCmd, TclCompileContinueCmd): - Added code to allow [break] and [continue] to be issued as a jump (in - the most common cases) rather than using the more expensive exception - processing path in the bytecode engine. [Bug 3614226]: Partial fix for - the issues relating to cleaning up the stack when dealing with [break] - and [continue]. - -2013-05-27 Harald Oehlmann +2013-05-28 Harald Oehlmann * library/msgcat/msgcat.tcl: [Bug 3036566]: Also get locale from - registry key HCU\Control Panel\Desktop : PreferredUILanguages to honor - installed language packs on Vista+. + registry key HCU\Control Panel\Desktop : PreferredUILanguages to + honor installed language packs on Vista+. Bumped msgcat version to 1.5.2 -2013-05-22 Andreas Kupries - - * tclCompile.c: Removed duplicate const qualifier causing the HP - native cc to error out. - 2013-05-22 Donal K. Fellows * generic/tclUtf.c (TclUtfCasecmp): [Bug 3613609]: Replace problematic uses of strcasecmp with a proper UTF-8-aware version. Affects both [lsearch -nocase] and [lsort -nocase]. -2013-05-22 Donal K. Fellows - - * doc/file.n: [Bug 3613671]: Added note to portability section on the - fact that [file owned] does not produce useful results on Windows. - -2013-05-20 Donal K. Fellows - - * unix/tclUnixFCmd.c (DefaultTempDir): [Bug 3613567]: Corrected logic - for checking return code of access() system call, which was inverted. - 2013-05-19 Jan Nijtmans * unix/tcl.m4: Fix for FreeBSD, and remove support for older * unix/configure: FreeBSD versions. Patch by Pietro Cerutti. -2013-05-18 Donal K. Fellows - - * generic/tclCompCmdsGR.c: Split tclCompCmds.c again to keep size of - code down. - 2013-05-16 Jan Nijtmans - * generic/tclBasic.c: Add panic in order to detect incompatible - mingw32 sys/stat.h and sys/time.h headers. - -2013-05-13 Jan Nijtmans - - * compat/zlib/*: Upgrade to zlib 1.2.8 - -2013-05-10 Donal K. Fellows - - Optimizations and general bytecode generation improvements. - * generic/tclCompCmds.c (TclCompileAppendCmd, TclCompileLappendCmd): - (TclCompileReturnCmd): Make these generate bytecode in more cases. - (TclCompileListCmd): Make this able to push a literal when it can. - * generic/tclCompile.c (TclSetByteCodeFromAny, PeepholeOptimize): - Added checks to see if we can apply some simple cross-command-boundary - optimizations, and defined a small number of such optimizations. - (TclCompileScript): Added the special ability to compile the list - command with expansion ([list {*}blah]) into bytecode that does not - call an external command. + * generic/tclBasic.c: Add panic in order to detect + incompatible mingw32 sys/stat.h and sys/time.h headers, 2013-05-06 Jan Nijtmans * generic/tclStubInit.c: Add support for Cygwin64, which has a 64-bit * generic/tclDecls.h: "long" type. Binary compatibility with win64 - requires that all stub entries use 32-bit long's, therefore the need - for various wrapper functions/macros. For Tcl 9 a better solution is - needed, but that cannot be done without introducing binary - incompatibility. + requires that all stub entries use 32-bit long's, therefore the + need for various wrapper functions/macros. For Tcl 9 a better + solution is needed, but that cannot be done without introducing + binary incompatibility. 2013-04-30 Andreas Kupries * library/platform/platform.tcl (::platform::LibcVersion): - * library/platform/pkgIndex.tcl: Followup to the 2013-01-30 change. - The RE become too restrictive again. SuSe added a timestamp after the - version. Loosened up a bit. Bumped package to version 1.0.12. - -2013-04-29 Donal K. Fellows - - * generic/tclCompCmds.c (TclCompileArraySetCmd): Generate better code - when the list of things to set is a literal. + * library/platform/pkgIndex.tcl: Followup to the 2013-01-30 + change. The RE become too restrictive again. SuSe added a + timestamp after the version. Loosened up a bit. Bumped package + to version 1.0.12. 2013-04-25 Jan Nijtmans * generic/tclDecls.h: Implement Tcl_NewBooleanObj, Tcl_DbNewBooleanObj and Tcl_SetBooleanObj as macros using Tcl_NewIntObj, Tcl_DbNewLongObj - and Tcl_SetIntObj. Starting with Tcl 8.5, this is exactly the same, it - only eliminates code duplication. - * generic/tclInt.h: Eliminate use of NO_WIDE_TYPE everywhere: It's - exactly the same as TCL_WIDE_INT_IS_LONG + and Tcl_SetIntObj. Starting with Tcl 8.5, this is exactly the same, + it only eliminates code duplication. 2013-04-19 Jan Nijtmans * generic/tclDecls.h: Implement many Tcl_*Var* functions and - Tcl_GetIndexFromObj as (faster/stack-saving) macros around resp their - Tcl_*Var*2 equivalent and Tcl_GetIndexFromObjStruct. + Tcl_GetIndexFromObj as (faster/stack-saving) macros around resp + their Tcl_*Var*2 equivalent and Tcl_GetIndexFromObjStruct. 2013-04-12 Jan Nijtmans * generic/tclDecls.h: Implement Tcl_Pkg* functions as (faster/stack-saving) macros around Tcl_Pkg*Ex functions. 2013-04-08 Don Porter - * generic/regc_color.c: [Bug 3610026]: Stop crash when the number of - * generic/regerrs.h: "colors" in a regular expression overflows a - * generic/regex.h: short int. Thanks to Heikki Linnakangas for - * generic/regguts.h: the report and the patch. + * generic/regc_color.c: [Bug 3610026] Stop crash when the number of + * generic/regerrs.h: "colors" in a regular expression overflows + * generic/regex.h: a short int. Thanks to Heikki Linnakangas + * generic/regguts.h: for the report and the patch. * tests/regexp.test: 2013-04-04 Reinhard Max - * library/http/http.tcl (http::geturl): Allow URLs that don't have a - path, but a query query, e.g. http://example.com?foo=bar - * Bump the http package to 2.8.7. + * library/http/http.tcl (http::geturl): Allow URLs that don't have + a path, but a query query, e.g. http://example.com?foo=bar . + * Bump the http package to 2.7.12. + +2013-04-03 Jan Nijtmans + + * unix/tclUnixInit.c: [Bug 3205320]: stack space detection + defeated by inlining. Now fixed in the cross-compile + case as well. + +2013-04-03 Don Porter + + *** 8.5.14 TAGGED FOR RELEASE *** + + * generic/tcl.h: Bump to 8.5.14 for release. + * library/init.tcl: + * tools/tcl.wse.in: + * unix/configure.in: + * unix/tcl.spec: + * win/configure.in: + * README: + + * unix/configure: autoconf-2.59 + * win/configure: 2013-03-22 Venkat Iyer * library/tzdata/Africa/Cairo: Update to tzdata2013b. * library/tzdata/Africa/Casablanca: * library/tzdata/Africa/Gaborone: @@ -287,22 +188,22 @@ * library/tzdata/Asia/Ust-Nera: (new) * library/tzdata/Europe/Busingen: (new) 2013-03-21 Don Porter - * library/auto.tcl: [Bug 2102614]: Add ensemble indexing support to - * tests/autoMkindex.test: [auto_mkindex]. Thanks Brian Griffin. + * library/auto.tcl: [Bug 2102614] Add ensemble indexing support + * tests/autoMkindex.test: to [auto_mkindex]. Thanks Brian Griffin. 2013-03-19 Don Porter - * generic/tclFCmd.c: [Bug 3597000]: Consistent [file copy] result. + * generic/tclFCmd.c: [Bug 3597000] Consistent [file copy] result. * tests/fileSystem.test: 2013-03-19 Jan Nijtmans - * win/tclWinFile.c: [Bug 3608360]: Incompatible behaviour of "file - exists". + * win/tclWinFile.c: [Bug 2893771]: file stat fails on locked files + on win32. 2013-03-18 Donal K. Fellows * tests/cmdAH.test (cmdAH-19.12): [Bug 3608360]: Added test to ensure that we never ever allow [file exists] to do globbing. @@ -310,78 +211,45 @@ 2013-03-12 Jan Nijtmans * unix/tcl.m4: Patch by Andrew Shadura, providing better support for three architectures they have in Debian. -2013-03-11 Don Porter - - * generic/tclCompile.c: [Bugs 3607246,3607372]: Unbalanced refcounts - * generic/tclLiteral.c: of literals in the global literal table. - 2013-03-06 Don Porter - * generic/regc_nfa.c: [Bugs 3604074,3606683]: Rewrite of the - * generic/regcomp.c: fixempties() routine (and supporting routines) - to completely eliminate the infinite loop hazard. Thanks to Tom Lane - for the much improved solution. - -2013-02-28 Don Porter - - * generic/tclLiteral.c: Revise TclReleaseLiteral() to tolerate a NULL - interp argument. - - * generic/tclCompile.c: Update callers and revise mistaken comments. - * generic/tclProc.c: + * generic/regc_nfa.c: [Bugs 3604074,3606683] Rewrite of the + * generic/regcomp.c: fixempties() routine (and supporting + routines) to completely eliminate the infinite loop hazard. + Thanks to Tom Lane for the much improved solution. 2013-02-27 Jan Nijtmans * generic/regcomp.c: [Bug 3606139]: missing error check allows * tests/regexp.test: regexp to crash Tcl. Thanks to Tom Lane for providing the test-case and the patch. -2013-02-26 Donal K. Fellows - - * tests/chanio.test (chan-io-28.7): [Bug 3605120]: Stop test from - hanging when run standalone. - 2013-02-26 Jan Nijtmans * generic/tclObj.c: Don't panic if Tcl_ConvertToType is called for a type that doesn't have a setFromAnyProc, create a proper error message. -2013-02-25 Donal K. Fellows - - * tests/binary.test (binary-41.*): [Bug 3605721]: Test independence - fixes. Thanks to Rolf Ade for pointing out the problem. - 2013-02-25 Don Porter * tests/assocd.test: [Bugs 3605719,3605720]: Test independence. * tests/basic.test: Thanks Rolf Ade for patches. -2013-02-23 Jan Nijtmans - - * compat/fake-rfc2553.c: [Bug 3599194]: compat/fake-rfc2553.c is - broken. - 2013-02-22 Don Porter - * generic/tclAssembly.c: Shift more burden of smart cleanup - * generic/tclCompile.c: onto the TclFreeCompileEnv() routine. - Stop crashes when the hookProc raises an error. + * generic/tclCompile.c: Shift more burden of smart cleanup onto the + TclFreeCompileEnv() routine. Stop crashes when the hookProc raises + an error. 2013-02-20 Don Porter * generic/tclNamesp.c: [Bug 3605447]: Make sure the -clear option * tests/namespace.test: to [namespace export] always clears, whether or not new export patterns are specified. -2013-02-20 Jan Nijtmans - - * win/tclWinDde.c: [Bug 3605401]: Compiler error with latest mingw-w64 - headers. - 2013-02-19 Jan Nijtmans * generic/tclTrace.c: [Bug 2438181]: Incorrect error reporting in * tests/trace.test: traces. Test-case and fix provided by Poor Yorick. @@ -396,34 +264,10 @@ * library/msgcat/msgcat.tcl: [Bug 3604576]: Catch missing registry entry "HCU\Control Panel\International". Bumped msgcat version to 1.5.1 -2013-02-11 Donal K. Fellows - - * generic/tclZlib.c (ZlibTransformOutput): [Bug 3603553]: Ensure that - data gets written to the underlying stream by compressing transforms - when the amount of data to be written is one buffer's-worth; problem - was particularly likely to occur when compressing large quantities of - not-very-compressible data. Many thanks to Piera Poggio (vampiera) for - reporting. - -2013-02-09 Donal K. Fellows - - * generic/tclOOBasic.c (TclOO_Object_VarName): [Bug 3603695]: Change - the way that the 'varname' method is implemented so that there are no - longer problems with interactions due to the resolver. Thanks to - Taylor Venable for identifying the problem. - -2013-02-08 Donal K. Fellows - - * generic/regc_nfa.c (duptraverse): [Bug 3603557]: Increase the - maximum depth of recursion used when duplicating an automaton in - response to encountering a "wild" RE that hit the previous limit. - Allow the limit (DUPTRAVERSE_MAX_DEPTH) to be set by defining its - value in the Makefile. Problem reported by Jonathan Mills. - 2013-02-05 Don Porter * win/tclWinFile.c: [Bug 3603434]: Make sure TclpObjNormalizePath() properly declares "a:/" to be normalized, even when no "A:" drive is present on the system. @@ -433,38 +277,18 @@ * generic/tclLoadNone.c (TclpLoadMemory): [Bug 3433012]: Added dummy version of this function to use in the event that a platform thinks it can load from memory but cannot actually do so due to it being disabled at configuration time. -2013-02-04 Donal K. Fellows - - * generic/tclCompCmds.c (TclCompileArraySetCmd): [Bug 3603163]: Stop - crash in weird case where [eval] is used to make [array set] get - confused about whether there is a local variable table or not. Thanks - to Poor Yorick for identifying a reproducible crashing case. - 2013-01-30 Andreas Kupries * library/platform/platform.tcl (::platform::LibcVersion): See * library/platform/pkgIndex.tcl: [Bug 3599098]: Fixed the RE * unix/Makefile.in: extracting the version to avoid issues with * win/Makefile.in: recent changes to the glibc banner. Now targeting a less variable part of the string. Bumped package to version 1.0.11. -2013-01-28 Donal K. Fellows - - * generic/tclCompCmds.c (TclCompileArraySetCmd) - (TclCompileArrayUnsetCmd, TclCompileDictAppendCmd) - (TclCompileDictCreateCmd, CompileDictEachCmd, TclCompileDictIncrCmd) - (TclCompileDictLappendCmd, TclCompileDictMergeCmd) - (TclCompileDictUnsetCmd, TclCompileDictUpdateCmd) - (TclCompileDictWithCmd, TclCompileInfoCommandsCmd): - * generic/tclCompCmdsSZ.c (TclCompileStringMatchCmd) - (TclCompileStringMapCmd): Improve the code generation in cases where - full compilation is impossible but a full ensemble invoke is provably - not necessary. - 2013-01-26 Jan Nijtmans * unix/tclUnixCompat.c: [Bug 3601804]: platformCPUID segmentation fault on Darwin. @@ -474,35 +298,15 @@ for connect to avoid reentrancy problems (except when operating without a -command option). Internally, this means that all sockets created by the http package will always be operated in asynchronous mode. -2013-01-21 Jan Nijtmans - - * generic/tclInt.decls: Put back Tcl[GS]etStartupScript(Path|FileName) - in private stub table, so extensions using this (like Tk 8.4) will - continue to work in all Tcl 8.x versions. Extensions using this - still cannot be compiled against Tcl 8.6 headers. - 2013-01-18 Jan Nijtmans * generic/tclPort.h: [Bug 3598300]: unix: tcl.h does not include sys/stat.h -2013-01-17 Donal K. Fellows - - * generic/tclCompCmds.c (PushVarName): [Bug 3600328]: Added mechanism - for suppressing compilation of variables when we couldn't cope with - the results. Useful for some [array] subcommands. - * generic/tclEnsemble.c (CompileToCompiledCommand): Must restore the - compilation environment when a command compiler fails. - -2013-01-16 Donal K. Fellows - - * generic/tclZlib.c (TclZlibInit): [Bug 3601086]: Register the config - info in the iso8859-1 encoding as that is guaranteed to be present. - 2013-01-16 Jan Nijtmans * Makefile.in: Allow win32 build with -DTCL_NO_DEPRECATED, just as * generic/tcl.h: in the UNIX build. Define Tcl_EvalObj and * generic/tclDecls.h: Tcl_GlobalEvalObj as macros, even when @@ -512,85 +316,34 @@ 2013-01-14 Jan Nijtmans * win/tcl.m4: More flexible search for win32 tclConfig.sh, backported from TEA (not actually used in Tcl, only for Tk) -2013-01-14 Jan Nijtmans - - * generic/tclInt.decls: Put back Tcl_[GS]etStartupScript in internal - stub table, so extensions using this, compiled against 8.5 headers - still run in Tcl 8.6. - -2013-01-13 Alexandre Ferrieux - - * doc/fileevent.n: [Bug 3436609]: Clarify readable fileevent "false - positives" in the case of multibyte encodings/transforms. - 2013-01-13 Jan Nijtmans * generic/tclIntDecls.h: If TCL_NO_DEPRECATED is defined, make sure that TIP #139 functions all are taken from the public stub table, even if the inclusion is through tclInt.h. -2013-01-12 Jan Nijtmans - - * generic/tclInt.decls: Put back TclBackgroundException in internal - stub table, so extensions using this, compiled against 8.5 headers - still run in Tcl 8.6. - 2013-01-09 Jan Nijtmans * library/http/http.tcl: [Bug 3599395]: http assumes status line is a proper Tcl list. + Bump http package to 2.7.11. 2013-01-08 Jan Nijtmans * win/tclWinFile.c: [Bug 3092089]: [file normalize] can remove path components. [Bug 3587096]: win vista/7: "can't find init.tcl" when called via junction without folder list access. 2013-01-07 Jan Nijtmans - * generic/tclOOStubLib.c: Restrict the stub library to only use - * generic/tclTomMathStubLib.c: Tcl_PkgRequireEx, Tcl_ResetResult and - Tcl_AppendResult, not any other function. This puts least restrictions - on eventual Tcl 9 stubs re-organization, and it works on the widest - range of Tcl versions. - -2013-01-06 Jan Nijtmans - - * library/http/http.tcl: Don't depend on Spencer-specific regexp - * tests/env.test: syntax (/u and /U) any more in unrelated places. - * tests/exec.test: - Bump http package to 2.8.6. - -2013-01-04 Donal K. Fellows - - * generic/tclEnsemble.c (CompileBasicNArgCommand): Added very simple - compiler (which just compiles to a normal invoke of the implementation - command) for many ensemble subcommands where we can prove that there - is no way for scripts to detect the difference even through error - handling or [info level]/[info frame]. This improves the code produced - from some ensembles (e.g., [info], [string]) to the point where the - ensemble is now not normally seen at the bytecode level at all. - -2013-01-04 Miguel Sofer - - * generic/tclInt.h: Insure that PURIFY builds cannot exploit the - * generic/tclExecute.c: Tcl stack to hide mem defects. - -2013-01-03 Donal K. Fellows - - * doc/fconfigure.n, doc/CrtChannel.3: Updated to reflect the fact that - the minimum buffer size is one byte, not ten. Identified by Schelte - Bron on the Tcler's Chat. - - * generic/tclExecute.c (TEBCresume:INST_INVOKE_REPLACE): - * generic/tclEnsemble.c (TclCompileEnsemble): Added new mechanism to - allow for more efficient dispatch of non-bytecode-compiled subcommands - of bytecode-compiled ensembles. This can provide substantial speed - benefits in some cases. + * generic/tcl.decls: Extend the public stub table with dummy NULL + entries, up to the size of the Tcl 8.6 stub tables. This makes it + easier to debug extensions which use Tcl 8.6 features but (erroneously) + are attempted to be loaded in Tcl 8.5. 2013-01-02 Miguel Sofer * generic/tclEnsemble.c: Remove stray calls to Tcl_Alloc and friends: * generic/tclExecute.c: the core should only use ckalloc to allow @@ -606,151 +359,55 @@ 2012-12-27 Jan Nijtmans * generic/tclListObj.c: [Bug 3598580]: Tcl_ListObjReplace may release deleted elements too early. -2012-12-22 Alexandre Ferrieux - - * generic/tclUtil.c: [Bug 3598150]: Stop leaking allocated space when - objifying a zero-length DString. Spotted by afredd. - 2012-12-21 Jan Nijtmans - * unix/dltest/pkgb.c: Inline compat Tcl_GetDefaultEncodingDir. + * unix/dltest/pkgb.c: Make pkgb.so loadable in Tcl 8.4 as well. * generic/tclStubLib.c: Eliminate unnecessary static HasStubSupport() and isDigit() functions, just do the same inline. -2012-12-18 Donal K. Fellows - - * generic/tclCompCmdsSZ.c (TclSubstCompile): Improved the sequence of - instructions issued for [subst] when dealing with simple variable - references. - -2012-12-14 Don Porter - - *** 8.6.0 TAGGED FOR RELEASE *** - - * changes: updates for 8.6.0 - -2012-12-13 Don Porter - - * generic/tclZlib.c: Repair same issue with misusing the - * tests/zlib.test: 'fire and forget' nature of Tcl_ObjSetVar2 - in the new TIP 400 implementation. - -2012-12-13 Miguel Sofer - - * generic/tclCmdAH.c: (CatchObjCmdCallback): do not decrRefCount - * tests/cmdAH.test: the newValuePtr sent to Tcl_ObjSetVar2: - TOSV2 is 'fire and forget', it decrs on its own. - Fix for [Bug 3595576], found by andrewsh. - 2012-12-13 Jan Nijtmans - * generic/tcl.h: Fix Tcl_DecrRefCount macro such that it doesn't - access its objPtr parameter twice any more. + * generic/tcl.h: Fix Tcl_DecrRefCount macro such that it + doesn't access its objPtr parameter twice any more. -2012-12-11 Don Porter +2012-12-07 Jan Nijtmans - * generic/tcl.h: Bump version number to 8.6.0. + * unix/dltest/pkgb.c: Turn pkgb.so into a Tcl9 interoperability test + library: Whatever Tcl9 looks like, loading pkgb.so in Tcl 9 should + either result in an error-message, either succeed, but never crash. + +2012-11-14 Donal K. Fellows + + * unix/tclUnixPipe.c (DefaultTempDir): [Bug 2933003]: Allow overriding + of the back-stop default temporary file location at compile time by + setting the TCL_TEMPORARY_FILE_DIRECTORY #def to a string containing + the directory name (defaults to "/tmp" as that is the most common + default). + +2012-11-13 Joe Mistachkin + + * win/tclWinInit.c: also search for the library directory (init.tcl, + encodings, etc) relative to the build directory associated with the + source checkout. + +2012-11-09 Don Porter + + *** 8.5.13 TAGGED FOR RELEASE *** + + * generic/tcl.h: Bump to 8.5.13 for release. * library/init.tcl: + * tools/tcl.wse.in: * unix/configure.in: * win/configure.in: * unix/tcl.spec: * README: * unix/configure: autoconf-2.59 * win/configure: - -2012-12-10 Donal K. Fellows - - * tools/tcltk-man2html.tcl (plus-pkgs): Increased robustness of - version number detection code to deal with packages whose names are - prefixes of other packages. - * unix/Makefile.in (dist): Added pkgs/package.list.txt to distribution - builds to ensure that 'make html' will work better. - -2012-12-09 Alexandre Ferrieux - - * tests/chan.test: Clean up unwanted eofchar side-effect of chan-4.6 - leading to a spurious "'" at end of chan.test under certain conditions - (see [Bug 3389289] and [Bug 3389251]). - - * doc/expr.n: [Bug 3594188]: Clarifications about commas. - -2012-12-08 Alexandre Ferrieux - - * generic/tclIO.c: Fix busyloop at exit under TCL_FINALIZE_ON_EXIT - when there are unflushed nonblocking channels. Thanks Miguel for - spotting. - -2012-12-07 Jan Nijtmans - - * unix/dltest/pkgb.c: Turn pkgb.so into a Tcl9 interoperability test - library: Whatever Tcl9 looks like, loading pkgb.so in Tcl 9 should - either result in an error-message, either succeed, but never crash. - -2012-11-28 Donal K. Fellows - - * generic/tclZlib.c (ZlibStreamSubcmd): [Bug 3590483]: Use a mechanism - for complex option resolution that has fewer problems with more - finicky compilers. - -2012-11-26 Reinhard Max - - * unix/tclUnixSock.c: Factor out creation of the -sockname and - -peername lists from TcpGetOptionProc() to TcpHostPortList(). Make it - robust against implementations of getnameinfo() that error out if - reverse mapping fails instead of falling back to the numeric - representation. - -2012-11-20 Donal K. Fellows - - * generic/tclBinary.c (BinaryDecode64): [Bug 3033307]: Corrected - handling of trailing whitespace when decoding base64. Thanks to Anton - Kovalenko for reporting, and Andy Goth for the fix and tests. - -2012-11-19 Donal K. Fellows - - * generic/tclExecute.c (INST_STR_RANGE_IMM): [Bug 3588366]: Corrected - implementation of bounds restriction for end-indexed compiled [string - range]. Thanks to Emiliano Gavilan for diagnosis and fix. - -2012-11-15 Jan Nijtmans - - IMPLEMENTATION OF TIP#416 - - New Options for 'load': -global and -lazy - - * generic/tcl.h: - * generic/tclLoad.c - * unix/tclLoadDl.c - * unix/tclLoadDyld.c - * tests/load.test - * doc/Load.3 - * doc/load.n - -2012-11-14 Donal K. Fellows - - * unix/tclUnixFCmd.c (TclUnixOpenTemporaryFile): [Bug 2933003]: Factor - out all the code to do temporary file creation so that it is possible - to make it correct in one place. Allow overriding of the back-stop - default temporary file location at compile time by setting the - TCL_TEMPORARY_FILE_DIRECTORY #def to a string containing the directory - name (defaults to "/tmp" as that is the most common default). - -2012-11-13 Joe Mistachkin - - * win/tclWinInit.c: also search for the library directory (init.tcl, - encodings, etc) relative to the build directory associated with the - source checkout. - -2012-11-10 Miguel Sofer - - * generic/tclBasic.c: re-enable bcc-tailcall, after fixing an - * generic/tclExecute.c: infinite loop in the TCL_COMPILE_DEBUG mode - 2012-11-07 Kevin B. Kenny * library/tzdata/Africa/Casablanca: * library/tzdata/America/Araguaina: @@ -762,187 +419,70 @@ * library/tzdata/Asia/Jerusalem: * library/tzdata/Pacific/Apia: * library/tzdata/Pacific/Fakaofo: * library/tzdata/Pacific/Fiji: Import tzdata2012i. +2012-11-07 Don Porter + + * win/tclWinSock.c: [Bug 3574493] Avoid hanging on exit due to + use of synchronization calls in routines called by DllMain(). + 2012-11-06 Donal K. Fellows * library/http/http.tcl (http::Finish): [Bug 3581754]: Ensure that callbacks are done at most once to prevent problems with timeouts on a keep-alive connection (combined with reentrant http package use) causing excessive stack growth. Not a fix for the underlying problem, but ensures that pain will be mostly kept away from users. - Bump http package to 2.8.5. - -2012-11-05 Donal K. Fellows - - Added bytecode compilation of many Tcl commands. Some of these are - total compilations and some are only partial (i.e., only compile in - some cases). The (sub-)commands affected are: - * array: exists, set, unset - * dict: create, exists, merge - * format: (simple cases only) - * info: commands, coroutine, level, object - * info object: class, isa object, namespace - * namespace: current, code, qualifiers, tail, which - * regsub: (only cases convertable to simple [string map]) - * self: (only no-argument and [self object] cases) - * string: first, last, map, range - * tailcall: - * yield: - - [This was work originally done on the 'dkf-compile-misc-info' branch.] - -2012-11-05 Jan Nijtmans - - IMPLEMENTATION OF TIP#413 - - Align the [string trim] and [string is space] commands, such that - [string trim] by default trims all characters for which [string is - space] returns 1, augmented with the NUL character. - - * generic/tclUtf.c: Add NEL, BOM and two more characters to [string is - space] - * generic/tclCmdMZ.c: Modify [string trim] for Unicode modifications. - * generic/regc_locale.c: Regexp engine must match [string is space] - * doc/string.n - * tests/string.test - ***POTENTIAL INCOMPATIBILITY*** - Code that relied on characters not previously trimmed being not - removed will notice a difference; it is believed that this is rare, - but a workaround to get the behavior in Tcl 8.5 is to use " \t\n\r" as - an explicit trim set. - -2012-10-31 Jan Nijtmans - - * win/Makefile.in: Dde version number to 1.4.0, ready for Tcl 8.6.0rc1 - * win/makefile.vc - * win/tclWinDde.c - * library/dde/pkgIndex.tcl - * tests/winDde.test - -2012-10-24 Donal K. Fellows - - * generic/tclCompCmds.c (TclCompileDictUnsetCmd): Added compilation of - the [dict unset] command (for scalar var in LVT only). + Bump http package to 2.7.10. 2012-10-23 Jan Nijtmans - * generic/tclInt.h: Add "flags" parameter from Tcl_LoadFile to - * generic/tclIOUtil.c: to various internal functions, so these - * generic/tclLoadNone.c: flags are available through the whole - * unix/tclLoad*.c: filesystem for (future) internal use. - * win/tclWinLoad.c: - -2012-10-17 Miguel Sofer - - * generic/tclBasic.c (TclNRCoroutineObjCmd): insure that numlevels - are properly set, fix bug discovered by dkf and reported at - http://code.activestate.com/lists/tcl-core/12213/ - -2012-10-16 Donal K. Fellows - - IMPLEMENTATION OF TIP#405 - - New commands for applying a transformation to the elements of a list - to produce another list (the [lmap] command) and to the mappings of a - dictionary to produce another dictionary (the [dict map] command). In - both cases, a [continue] will cause the skipping of an element/pair, - and a [break] will terminate the construction early and successfully. - - * generic/tclCmdAH.c (Tcl_LmapObjCmd, TclNRLmapCmd): Implementation of - the new [lmap] command, based on (and sharing much of) [foreach]. - * generic/tclDictObj.c (DictMapNRCmd): Implementation of the new [dict - map] subcommand, based on (and sharing much of) [dict for]. - * generic/tclCompCmds.c (TclCompileLmapCmd, TclCompileDictMapCmd): - Compilation engines for [lmap] and [dict map]. - - IMPLEMENTATION OF TIP#400 - - * generic/tclZlib.c: Allow the specification of a compression - dictionary (a binary blob used to seed the compression engine) in both - streams and channel transformations. Also some reorganization to allow - for getting gzip header dictionaries and controlling buffering levels - in channel transformations (allowing a trade-off between formal - correctness and speed). - (Tcl_ZlibStreamSetCompressionDictionary): New C API to allow setting - the compression dictionary without using a Tcl script. + * generic/tclInt.h: Remove unused TclpLoadFile function. + * generic/tclIOUtil.c 2012-10-14 Jan Nijtmans - * generic/tclDictObj.c: [Bug 3576509]: ::tcl::Bgerror crashes with - * generic/tclEvent.c: invalid arguments. Better fix, which helps - for all Tcl_DictObjGet() calls in Tcl's source code. + * generic/tclDictObj.c: [Bug 3576509]: tcl::Bgerror crashes with invalid + * generic/tclEvent.c: arguments. Better fix, which helps for all + Tcl_DictObjGet() calls in Tcl's source code. 2012-10-13 Jan Nijtmans * generic/tclEvent.c: [Bug 3576509]: tcl::Bgerror crashes with invalid arguments -2012-10-06 Jan Nijtmans - - * win/Makefile.in: [Bug 2459774]: tcl/win/Makefile.in not compatible - with msys 0.8. - 2012-10-03 Don Porter * generic/tclIO.c: When checking for std channels being closed, compare the channel state, not the channel itself so that stacked channels do not cause trouble. -2012-09-26 Reinhard Max - - * generic/tclIOSock.c (TclCreateSocketAddress): Work around a bug in - getaddrinfo() on OSX that caused name resolution to fail for [socket - -server foo -myaddr localhost 0]. - -2012-09-20 Jan Nijtmans - - * win/configure.in: New import libraries for zlib 1.2.7, usable for - * win/configure: all win32/win64 compilers - * compat/zlib/win32/zdll.lib: - * compat/zlib/win64/zdll.lib: - - * win/tclWinDde.c: [FRQ 3527238]: Full unicode support for dde. Dde - version is now 1.4.0b2. - ***POTENTIAL INCOMPATIBILITY*** - -2012-09-19 Jan Nijtmans - - * generic/tcl.h: Make Tcl_Interp a fully opaque structure if - TCL_NO_DEPRECATED is set (TIP 330 and 336). - * win/nmakehlp.c: Let "nmakehlp -V" start searching digits after the - found match (suggested by Harald Oehlmann). - -2012-09-19 Harald Oehlmann - - IMPLEMENTATION OF TIP#412. - - * library/msgcat/msgcat.tcl: dynamic locale change with mc file - * library/clock.tcl: load on locale change. - clock uses new msgcat features. - 2012-09-07 Harald Oehlmann - *** 8.6b3 TAGGED FOR RELEASE *** - IMPLEMENTATION OF TIP#404. - * library/msgcat/msgcat.tcl: [FRQ 3544988]: New commands [mcflset] - * library/msgcat/pkgIndex.tcl: and [mcflmset] to set mc entries with - * unix/Makefile.in: implicit message file locale. - * win/Makefile.in: Bump to 1.5.0. + * library/msgcat/msgcat.tcl: [FRQ 3544988]: (Backport from Tcl 8.6) + * library/msgcat/pkgIndex.tcl: New commands [mcflset] and [mcflmset] + * unix/Makefile.in: to set mc entries with implicit message + * win/Makefile.in: file locale. Bump to 1.5.0. + * tests/msgcat.test: + +2012-09-07 Alexandre Ferrieux + + * unix/tclUnixNotfy.c Backport of 2008-12-12 8.6 commit: Fix + missing CLOEXEC on internal pipes [2417695] 2012-08-25 Donal K. Fellows * library/msgs/uk.msg: [Bug 3561330]: Use the correct full name of March in Ukrainian. Thanks to Mikhail Teterin for reporting. 2012-08-23 Jan Nijtmans - * generic/tclBinary.c: [Bug 3496014]: Unecessary memset() in - Tcl_SetByteArrayObj(). + * generic/tclBinary.c: [Bug 3496014]: (Backport from Tcl 8.6) Protect + Tcl_SetByteArrayObj for invalid values. 2012-08-20 Don Porter * generic/tclPathObj.c: [Bug 3559678]: Fix bad filename normalization when the last component is the empty string. @@ -961,34 +501,18 @@ partial version numbers. 2012-08-15 Jan Nijtmans * win/buildall.vc.bat: Only build the threaded builds by default - * win/rules.vc: Some code cleanup + * win/rules.vc: Backport some improvements from Tcl 8.6 + * win/makefile.vc: 2010-08-13 Stuart Cassoff * unix/tclUnixCompat.c: [Bug 3555454]: Rearrange a bit to quash 'declared but never defined' compiler warnings. -2012-08-13 Jan Nijtmans - - * compat/zlib/win64/zlib1.dll: Add 64-bit build of zlib1.dll, and use - * compat/zlib/win64/zdll.lib: it for the dynamic mingw-w64 build. - * win/Makefile.in: - * win/configure.in: - * win/configure: - -2012-08-09 Reinhard Max - - * tests/http.test: Fix http-3.29 for machines without IPv6 support. - -2010-08-08 Stuart Cassoff - - * unix/tclUnixCompat.c: Change one '#ifdef' to '#if defined()' for - improved consistency within the file. - 2012-08-08 Jan Nijtmans * generic/tclfileName.c: [Bug #1536227]: Cygwin network pathname * tests/fileName.test: support @@ -995,29 +519,14 @@ 2012-08-07 Don Porter * generic/tclIOUtil.c: [Bug 3554250]: Overlooked one field of cleanup in the thread exit handler for the filesystem subsystem. -2012-07-31 Donal K. Fellows - - * generic/tclInterp.c (Tcl_GetInterpPath): - * unix/tclUnixPipe.c (TclGetAndDetachPids, Tcl_PidObjCmd): - * win/tclWinPipe.c (TclGetAndDetachPids, Tcl_PidObjCmd): - Purge use of Tcl_AppendElement, and corrected conversion of PIDs to - integer objects. - 2012-07-31 Jan Nijtmans - * win/nmakehlp.c: Add -Q option from sampleextension. - * win/Makefile.in: [FRQ 3544967]: Missing objectfiles in static lib - * win/makefile.vc: (Thanks to Jos Decoster). - -2012-07-29 Jan Nijtmans - - * win/Makefile.in: No longer build tcltest.exe to run the tests, - but use tclsh86.exe in combination with tcltest86.dll to do that. - * tests/*.test: load tcltest86.dll if necessary. + * win/nmakehlp.c: Backport from Tcl 8.6, but add -Q option from + sampleextension. 2012-07-28 Jan Nijtmans * tests/clock.test: [Bug 3549770]: Multiple test failures running * tests/registry.test: tcltest outside build tree @@ -1026,34 +535,26 @@ 2012-07-27 Jan Nijtmans * generic/tclUniData.c: Support Unicode 6.2 (Add Turkish lira sign) * generic/regc_locale.c: -2012-07-25 Alexandre Ferrieux - - * win/tclWinPipe.c: [Bug 3547994]: Abandon the synchronous Windows - pipe driver to its fate when needed to honour TIP#398. - -2012-07-24 Trevor Davel - - * win/tclWinSock.c: [Bug: 3545363]: Loop over multiple underlying file - descriptors for a socket where required (TcpCloseProc, SocketProc). - Refactor socket/descriptor setup to manage linked list operations in - one place. Fix memory leak in socket close (TcpCloseProc) and related - dangling pointers in SocketEventProc. - -2012-07-19 Reinhard Max - - * win/tclWinSock.c (TcpAccept): [Bug: 3545363]: Use a large enough - buffer for accept()ing IPv6 connections. Fix conversion of host and - port for passing to the accept proc to be independent of the IP - version. - -2012-07-23 Alexandre Ferrieux - - * generic/tclIO.c: [Bug 3545365]: Never try a bg-flush on a dead - channel, just like before 2011-08-17. +2012-07-24 Don Porter + + *** 8.5.12 TAGGED FOR RELEASE *** + + * generic/tcl.h: Bump to 8.5.12 for release. + * library/init.tcl: + * tools/tcl.wse.in: + * unix/configure.in: + * unix/tcl.spec: + * win/configure.in: + * README: + + * unix/configure: autoconf-2.59 + * win/configure: + + * changes: Update for 8.5.12 release. 2012-07-19 Joe Mistachkin * generic/tclTest.c: Fix several more missing mutex-locks in TestasyncCmd. @@ -1068,18 +569,16 @@ * win/makefile.vc: [Bug 3544932]: Visual studio compiler check fails 2012-07-16 Donal K. Fellows - * generic/tclUtil.c (UpdateStringOfEndOffset): [Bug 3544658]: Stop - 1-byte overrun in memcpy, that object placement rules made harmless - but which still caused compiler complaints. - -2012-07-16 Jan Nijtmans - - * library/reg/pkgIndex.tcl: Make registry 1.3 package dynamically - loadable when ::tcl::pkgconfig is available. + * unix/tclUnixCompat.c (TclpGetPwNam, TclpGetPwUid, TclpGetGrNam) + (TclpGetGrGid): [Bug 3544683]: Use the elaborate memory management + scheme outlined on http://www.opengroup.org/austin/docs/austin_328.txt + to handle Tcl's use of standard reentrant versions of the passwd/group + access functions so that everything can work on all BSDs. Problem + identified by Stuart Cassoff. 2012-07-11 Jan Nijtmans * win/tclWinReg.c: [Bug 3362446]: registry keys command fails with 8.5/8.6. Follow Microsofts example better in order to prevent @@ -1095,29 +594,15 @@ * win/tclWinSock.c (InitializeHostName): Corrected logic that extracted the name of the computer from the gethostname call so that it would use the name on success, not failure. Also ensured that the buffer size is exactly that recommended by Microsoft. -2012-07-08 Reinhard Max - - * library/http/http.tcl: [Bug 3531209]: Add fix and test for URLs that - * tests/http.test: contain literal IPv6 addresses. - 2012-07-05 Don Porter * unix/tclUnixPipe.c: [Bug 1189293]: Make "<<" binary safe. * win/tclWinPipe.c: -2012-07-03 Donal K. Fellows - - * generic/tclUtil.c (TclDStringAppendObj, TclDStringAppendDString): - * generic/tclInt.h (TclDStringAppendLiteral, TclDStringClear): - * generic/tclCompile.h (TclDStringAppendToken): Added wrappers to make - common cases of appending to Tcl_DStrings simpler to write. Prompted - by looking at [FRQ 1357401] (these are an _internal_ implementation of - that FRQ). - 2012-06-29 Jan Nijtmans * library/msgcat/msgcat.tcl: Add tn, ro_MO and ru_MO to msgcat. 2012-06-29 Harald Oehlmann @@ -1133,22 +618,10 @@ the tables of names to index over to be static, following posting to tcl-core by Brian Griffin about a bug caused by Tktreectrl not obeying this rule correctly. This does not represent a functionality change, merely a clearer documentation of a long-standing constraint. -2012-06-26 Jan Nijtmans - - * unix/tcl.m4: Let Cygwin shared build link with - * unix/configure.in: zlib1.dll, not cygz.dll (two less - * unix/configure: dependencies on cygwin-specific dll's) - * unix/Makefile.in: - -2012-06-26 Reinhard Max - - * generic/tclIOSock.c: Use EAI_SYSTEM only if it exists. - * unix/tclUnixSock.c: - 2012-06-25 Don Porter * generic/tclFileSystem.h: [Bug 3024359]: Make sure that the * generic/tclIOUtil.c: per-thread cache of the list of file systems * generic/tclPathObj.c: currently registered is only updated at times @@ -1161,27 +634,22 @@ thing when reporting errors with the number of arguments. 2012-06-25 Jan Nijtmans * generic/tclfileName.c: [Patch 1536227]: Cygwin network pathname - * tests/fileName.test: support. + * tests/fileName.test: support 2012-06-23 Jan Nijtmans * unix/tclUnixNotfy.c: [Bug 3508771]: Cygwin notifier for handling win32 events. -2012-06-22 Reinhard Max - - * generic/tclIOSock.c: Rework the error message generation of [socket], - * unix/tclUnixSock.c: so that the error code of getaddrinfo is used - * win/tclWinSock.c: instead of errno unless it is EAI_SYSTEM. - 2012-06-21 Jan Nijtmans * win/tclWinReg.c: [Bug 3362446]: registry keys command fails * tests/registry.test: with 8.5/8.6 + * library/reg/pkgIndex.tcl: registry version to 1.2.2 2012-06-11 Don Porter * generic/tclBasic.c: [Bug 3532959]: Make sure the lifetime * generic/tclProc.c: management of entries in the linePBodyPtr @@ -1196,74 +664,31 @@ * unix/tclUnixPort.h: [Bug 3530533]: Centralize #include * unix/tclUnixThrd.c: in the tclUnixPort.h header so that old unix systems that need inclusion in all compilation units are supported. -2012-06-08 Jan Nijtmans - - * win/tclWinDde.c: Revise the "null data" check: null strings are - possible, but empty binary arrays are not. - * tests/winDde.test: Add test-case (winDde-9.4) for transferring - null-strings with dde. Convert tests to tcltest-2 syntax. - -2012-06-06 Donal K. Fellows - - * generic/tclZlib.c (TclZlibInit): Declare that Tcl is publishing the - zlib package (version 2.0) as part of its bootstrap process. This will - have an impact on tclkit (which includes zlib 1.1) but otherwise be - very low impact. - 2012-06-06 Jan Nijtmans * unix/tclUnixInit.c: On Cygwin, use win32 API in stead of uname() to determine the tcl_platform variables. -2012-05-31 Jan Nijtmans - - * generic/tclZlib.c: [Bug 3530536]: zlib-7.4 fails on IRIX64 - * tests/zlib.test: - * doc/zlib.n: Document that [stream checksum] doesn't do - what's expected for "inflate" and "deflate" formats - 2012-05-31 Donal K. Fellows - * library/safe.tcl (safe::AliasFileSubcommand): Don't assume that - slaves have corresponding commands, as that is not true for - sub-subinterpreters (used in Tk's test suite). - * doc/safe.n: [Bug 1997845]: Corrected formatting so that generated - HTML can link properly. - - * tests/socket.test (socket*-13.1): Prevented intermittent test - failure due to race condition. + * tools/tcltk-man2html.tcl (cross-reference): HTML can link properly. 2012-05-29 Donal K. Fellows * doc/expr.n, doc/mathop.n: [Bug 2931407]: Clarified semantics of division and remainder operators. -2012-05-29 Jan Nijtmans - - * win/tclWinDde.c: [Bug 3525762]: Encoding handling in dde. - * win/Makefile.in: Fix "make genstubs" when cross-compiling on UNIX - -2012-05-28 Donal K. Fellows - - * library/safe.tcl (safe::AliasFileSubcommand): [Bug 3529949]: Made a - more sophisticated method for preventing information leakage; it - changes references to "~user" into "./~user", which is safe. - 2012-05-25 Donal K. Fellows * doc/namespace.n, doc/Ensemble.3: [Bug 3528418]: Document what is going on with respect to qualification of command prefixes in ensemble subcommand maps. - * generic/tclIO.h (SYNTHETIC_EVENT_TIME): Factored out the definition - of the amount of time that should be waited before firing a synthetic - event on a channel. - 2012-05-25 Jan Nijtmans * win/tclWinDde.c: [Bug 473946]: Special characters were not correctly sent, now for XTYP_EXECUTE as well as XTYP_REQUEST. * win/Makefile.in: Fix "make genstubs" when cross-compiling on UNIX @@ -1274,49 +699,26 @@ * generic/tcl*Decls.h: re-generated * generic/tclStubInit.c: Implement TclpIsAtty, Cygwin only. * doc/dde.n: Doc fix: "dde execute iexplore" doesn't work without -async, because iexplore doesn't return a value -2012-05-24 Jan Nijtmans +2012-05-22 Jan Nijtmans * tools/genStubs.tcl: Let cygwin share stub table with win32 + * win/Makefile.in: Don't hardcode dde and reg dll version numbers * win/tclWinSock.c: implement TclpInetNtoa for win32 - * generic/tclInt.decls: Revert most of [3caedf05df], since when + * generic/tclInt.decls: Revert most of [fcc5957e59], since when we let cygwin share the win32 stub table this is no longer necessary * generic/tcl*Decls.h: re-generated - * doc/dde.n: 1.3 -> 1.4 - -2012-05-23 Donal K. Fellows - - * generic/tclZlib.c (ZlibTransformInput): [Bug 3525907]: Ensure that - decompressed input is flushed through the transform correctly when the - input stream gets to the end. Thanks to Alexandre Ferrieux and Andreas - Kupries for their work on this. 2012-05-21 Don Porter - * generic/tclFileName.c: When using Tcl_SetObjLength() calls to - * generic/tclPathObj.c: grow and shrink the objPtr->bytes - buffer, care must be taken that the value cannot possibly become pure - Unicode. Calling Tcl_AppendToObj() has the possibility of making such - a conversion. Bug found while valgrinding the trunk. - -2012-05-21 Jan Nijtmans - - IMPLEMENTATION OF TIP#106 - - * win/tclWinDde.c: Added encoding-related abilities to - * library/dde/pkgIndex.tcl: the [dde] command. The dde package's - * tests/winDde.test: version is now 1.4.0. - * doc/dde.n: - -2012-05-20 Donal K. Fellows - - * generic/tclOOBasic.c (TclOO_Class_Constructor): [Bug 2023112]: Cut - the amount of hackiness in class constructors, and refactor some of - the error message handling from [oo::define] to be saner in the face - of odd happenings. + * generic/tclFileName.c: When using Tcl_SetObjLength() calls to grow + * generic/tclIOUtil.c: and shrink the objPtr->bytes buffer, care must + be taken that the value cannot possibly become pure Unicode. Calling + Tcl_AppendToObj() has the possibility of making such a conversion. Bug + found while valgrinding the trunk. 2012-05-17 Donal K. Fellows * generic/tclCmdMZ.c (Tcl_SwitchObjCmd): [Bug 3106532]: Corrected resulting indexes from -indexvar option to be usable with [string @@ -1334,18 +736,10 @@ * doc/expr.n: [Bug 3525462]: Corrected statement about what happens when comparing "0y" and "0x12"; the previously documented behavior was actually a subtle bug (now long-corrected). -2012-05-16 Donal K. Fellows - - * generic/tclCmdAH.c (TclMakeFileCommandSafe): [Bug 3445787]: Improve - the compatibility of safe interpreters' version of 'file' with that of - unsafe interpreters. - * library/safe.tcl (::safe::InterpInit): Teach the safe-interp scripts - about how to expose 'file' properly. - 2012-05-13 Jan Nijtmans * win/tclWinDde.c: Protect against receiving strings without ending \0, as external applications (or Tcl with TIP #106) could generate that. @@ -1353,69 +747,18 @@ 2012-05-10 Jan Nijtmans * win/tclWinDde.c: [Bug 473946]: Special characters not correctly sent * library/dde/pkgIndex.tcl: Increase version to 1.3.3 -2012-05-10 Alexandre Ferrieux - - * {win,unix}/configure{,.in}: [Bug 2812981]: Clean up bundled - packages' build directory from within Tcl's ./configure, to avoid - stale configuration. - -2012-05-09 Andreas Kupries - - * generic/tclIORChan.c: [Bug 3522560]: Fixed the crash, enabled the - test case. Modified [chan postevent] to properly inject the event(s) - into the owner thread's event queue for execution in the correct - context. Renamed the ForwardOpTo...Thread() function to match with our - terminology. - - * tests/ioCmd.test: [Bug 3522560]: Added a test which crashes the core - if it were not disabled as knownBug. For a reflected channel - transfered to a different thread the [chan postevent] run in the - handler thread tries to execute the owner threads's fileevent scripts - by itself, wrongly reaching across thread boundaries. - -2012-04-28 Alexandre Ferrieux - - * generic/tclIO.c: Properly close nonblocking channels even when - not flushing them. - -2012-05-03 Jan Nijtmans - - * compat/zlib/*: Upgrade to zlib 1.2.7 (pre-built dll is still 1.2.5, - will be upgraded as soon as the official build is available) - -2012-05-03 Don Porter - - * tests/socket.test: [Bug 3428754]: Test socket-14.2 tolerate - [socket -async] connection that connects synchronously. - - * unix/tclUnixSock.c: [Bug 3428753]: Fix [socket -async] connections - that manage to connect synchronously. - 2012-05-02 Jan Nijtmans - * generic/configure.in: Better detection and implementation for - * generic/configure: cpuid instruction on Intel-derived - * generic/tclUnixCompat.c: processors, both 32-bit and 64-bit. - * generic/tclTest.c: Move cpuid testcase from win-specific to - * win/tclWinTest.c: generic tests, as it should work on all - * tests/platform.test: Intel-related platforms now. - -2012-04-30 Alexandre Ferrieux - - * tests/ioCmd.test: [Bug 3522560]: Tame deadlocks in broken refchan - tests. - -2012-04-28 Alexandre Ferrieux - - IMPLEMENTATION OF TIP#398 - - * generic/tclIO.c: Quickly Exit with Non-Blocking Blocked Channels - * tests/io.test : *** POTENTIAL INCOMPATIBILITY *** - * doc/close.n : (compat flag available) + * generic/configure.in: Better detection and implementation for + * generic/configure: cpuid instruction on Intel-derived + * generic/tclUnixCompat.c: processors, both 32-bit and 64-bit. + * generic/tclTest.c: Move cpuid testcase from win-specific + * win/tclWinTest.c: to generic tests, as it should work on + * tests/platform.test: all Intel-related platforms now 2012-04-27 Jan Nijtmans * generic/tclPort.h: Move CYGWIN-specific stuff from tclPort.h to * generic/tclEnv.c: tclUnixPort.h, where it belongs. @@ -1427,34 +770,22 @@ * library/init.tcl (auto_execok): Allow shell builtins to be detected even if they are upper-cased. 2012-04-26 Jan Nijtmans - * generic/tclStubInit.c: Get rid of _ANSI_ARGS_ and CONST - * generic/tclIO.c: - * generic/tclIOCmd.c: - * generic/tclTest.c: - * unix/tclUnixChan.c: - -2012-04-25 Donal K. Fellows - - * generic/tclUtil.c (TclDStringToObj): Added internal function to make - the fairly-common operation of converting a DString into an Obj a more - efficient one; for long strings, it can just transfer the ownership of - the buffer directly. Replaces this: - obj=Tcl_NewStringObj(Tcl_DStringValue(&ds),Tcl_DStringLength(&ds)); - Tcl_DStringFree(&ds); - with this: - obj=TclDStringToObj(&ds); + * generic/tclStubInit.c: get rid of _ANSI_ARGS_ + * generic/tclIntPlatDecls.h + * unix/tclUnixPort.h + * unix/tclAppInit.c + * win/tclAppInit.c 2012-04-24 Jan Nijtmans - * generic/tclInt.decls: [Bug 3508771]: load tclreg.dll in cygwin - tclsh - * generic/tclIntPlatDecls.h: Implement TclWinGetSockOpt, - * generic/tclStubInit.c: TclWinGetServByName and TclWinCPUID for - * generic/tclUnixCompat.c: Cygwin. + * generic/tclInt.decls: [Bug 3508771]: load tclreg.dll in + * generic/tclIntPlatDecls.h: cygwin tclsh. Implement + * generic/tclStubInit.c: TclWinGetSockOpt, TclWinGetServByName + * generic/tclUnixCompat.c: and TclWinCPUID for Cygwin. * unix/configure.in: * unix/configure: * unix/tclUnixCompat.c: 2012-04-18 Kevin B. Kenny @@ -1470,67 +801,17 @@ * doc/FileSystem.3 (Tcl_FSOpenFileChannelProc): [Bug 3518244]: Fixed documentation of this filesystem callback function; it must not register its created channel - that's the responsibility of the caller of Tcl_FSOpenFileChannel - as that leads to reference leaks. -2012-04-15 Donal K. Fellows - - * generic/tclEnsemble.c (NsEnsembleImplementationCmdNR): - * generic/tclIOUtil.c (Tcl_FSEvalFileEx): Cut out levels of the C - stack by going direct to the relevant internal evaluation function. - - * generic/tclZlib.c (ZlibTransformSetOption): [Bug 3517696]: Make - flushing work correctly in a pushed compressing channel transform. - -2012-04-12 Jan Nijtmans - - * generic/tclInt.decls: [Bug 3514475]: Remove TclpGetTimeZone and - * generic/tclIntDecls.h: TclpGetTZName - * generic/tclIntPlatDecls.h: - * generic/tclStubInit.c: - * unix/tclUnixTime.c: - * unix/tclWinTilemc: - 2012-04-11 Jan Nijtmans * win/tclWinInit.c: [Bug 3448512]: clock scan "1958-01-01" fails * win/tcl.m4: only in debug compilation. * win/configure: * unix/tcl.m4: Use NDEBUG consistantly meaning: no debugging. * unix/configure: - * generic/tclBasic.c: - * library/dde/pkgIndex.tcl: Use [::tcl::pkgconfig get debug] instead - * library/reg/pkgIndex.tcl: of [info exists ::tcl_platform(debug)] - -2012-04-10 Donal K. Fellows - - * generic/tcl.h (TCL_DEPRECATED_API): [Bug 2458976]: Added macro that - can be used to mark parts of Tcl's API as deprecated. Currently only - used for fields of Tcl_Interp, which TIPs 330 and 336 have deprecated - with a migration strategy; we want to encourage people to move away - from those fields. - -2012-04-09 Donal K. Fellows - - * generic/tclOODefineCmds.c (ClassVarsSet, ObjVarsSet): [Bug 3396896]: - Ensure that the lists of variable names used to drive variable - resolution will never have the same name twice. - - * generic/tclVar.c (AppendLocals): [Bug 2712377]: Fix problem with - reporting of declared variables in methods. It's really a problem with - how [info vars] interacts with variable resolvers; this is just a bit - of a hack so it is no longer a big problem. - -2012-04-04 Donal K. Fellows - - * generic/tclOO.c (Tcl_NewObjectInstance, TclNRNewObjectInstance): - [Bug 3514761]: Fixed bogosity with automated argument description - handling when constructing an instance of a class that is itself a - member of an ensemble. Thanks to Andreas Kupries for identifying that - this was a problem case at all! - (Tcl_CopyObjectInstance): Fix potential bleed-over of ensemble - information into [oo::copy]. 2012-04-04 Jan Nijtmans * win/tclWinSock.c: [Bug 510001]: TclSockMinimumBuffers needs * generic/tclIOSock.c: platform implementation. @@ -1541,19 +822,13 @@ 2012-04-03 Jan Nijtmans * generic/tclStubInit.c: Remove the TclpGetTZName implementation for * generic/tclIntDecls.h: Cygwin (from 2012-04-02 commit), re-generated * generic/tclIntPlatDecls.h: - -2012-04-02 Donal K. Fellows - - IMPLEMENTATION OF TIP#396. - - * generic/tclBasic.c (builtInCmds, TclNRYieldToObjCmd): Convert the - formerly-unsupported yieldm and yieldTo commands into [yieldto]. - -2012-04-02 Jan Nijtmans + * generic/tcl.decls: cleanup unnecessary "generic" argument + +2012-03-30 Jan Nijtmans * generic/tclInt.decls: [Bug 3508771]: load tclreg.dll in cygwin tclsh * generic/tclIntPlatDecls.h: Implement TclWinGetTclInstance, * generic/tclStubInit.c: TclpGetTZName, and various more win32-specific internal functions for Cygwin, so win32 extensions @@ -1565,68 +840,16 @@ * unix/configure.in: This change allows to build the cygwin and * unix/tclUnixPort.h: mingw32 ports of Tcl/Tk to build out-of-the-box * win/tcl.m4: using a native or cross-compiler. * win/configure.in: * win/tclWinPort.h: - * win/README Document how to build win32 or win64 executables - with Linux, Cygwin or Darwin. - -2012-03-29 Jan Nijtmans - - * generic/tclCmdMZ.c (StringIsCmd): Faster mem-leak free - implementation of [string is entier]. - -2012-03-27 Donal K. Fellows - - IMPLEMENTATION OF TIP#395. - - * generic/tclCmdMZ.c (StringIsCmd): Implementation of the [string is - entier] check. Code by Jos Decoster. 2012-03-27 Jan Nijtmans * generic/tcl.h: [Bug 3508771]: Wrong Tcl_StatBuf used on MinGW. * generic/tclFCmd.c: [Bug 2015723]: Duplicate inodes from file stat - * generic/tclCmdAH.c: on windows (but now for cygwin as well). - * generic/tclOODefineCmds.c: minor gcc warning - * win/tclWinPort.h: Use lower numbers, preventing integer overflow. - Remove the workaround for mingw-w64 [Bug 3407992]. It's long fixed. - -2012-03-27 Donal K. Fellows - - IMPLEMENTATION OF TIP#397. - - * generic/tclOO.c (Tcl_CopyObjectInstance): [Bug 3474460]: Make the - target object name optional when copying classes. [RFE 3485060]: Add - callback method ("") so that scripted control over copying is - easier. - ***POTENTIAL INCOMPATIBILITY*** - If you'd previously been using the "" method name, this now - has a standard semantics and call interface. Only a problem if you are - also using [oo::copy]. - -2012-03-26 Donal K. Fellows - - IMPLEMENTATION OF TIP#380. - - * doc/define.n, doc/object.n, generic/tclOO.c, generic/tclOOBasic.c: - * generic/tclOOCall.c, generic/tclOODefineCmds.c, generic/tclOOInt.h: - * tests/oo.test: Switch definitions of lists of things in objects and - classes to a slot-based approach, which gives a lot more flexibility - and programmability at the script-level. Introduce new [::oo::Slot] - class which is the implementation of these things. - - ***POTENTIAL INCOMPATIBILITY*** - The unknown method handler now may be asked to deal with the case - where no method name is provided at all. The default implementation - generates a compatible error message, and any override that forces the - presence of a first argument (i.e., a method name) will continue to - function as at present as well, so this is a pretty small change. - - * generic/tclOOBasic.c (TclOO_Object_Destroy): Made it easier to do a - tailcall inside a normally-invoked destructor; prevented leakage out - to calling command. + on windows (but now for cygwin as well) 2012-03-25 Jan Nijtmans * generic/tclInt.decls: [Bug 3508771]: load tclreg.dll in cygwin * generic/tclIntPlatDecls.h: tclsh. Implement TclWinConvertError, @@ -1689,18 +912,10 @@ * library/tzdata/Atlantic/Stanley: * library/tzdata/Pacific/Easter: * library/tzdata/Pacific/Fakaofo: * library/tzdata/America/Creston: (new) -2012-03-19 Reinhard Max - - * unix/tclUnixSock.c (Tcl_OpenTcpServer): Use the values returned - by getaddrinfo() for all three arguments to socket() instead of - only using ai_family. Try to keep the most meaningful error while - iterating over the result list, because using the last error can - be misleading. - 2012-03-15 Jan Nijtmans * generic/tcl.h: [Bug 3288345]: Wrong Tcl_StatBuf used on Cygwin * unix/tclUnixFile.c: * unix/tclUnixPort.h: @@ -1710,24 +925,15 @@ 2012-03-12 Jan Nijtmans * win/tclWinFile.c: [Bug 3388350]: mingw64 compiler warnings -2012-03-11 Donal K. Fellows - - * doc/*.n, doc/*.3: A number of small spelling and wording fixes. - -2012-03-08 Donal K. Fellows - - * doc/info.n: Various minor fixes (prompted by Andreas Kupries - * doc/socket.n: detecting a spelling mistake). - 2012-03-07 Andreas Kupries * library/http/http.tcl: [Bug 3498327]: Generate upper-case * library/http/pkgIndex.tcl: hexadecimal output for compliance - * tests/http.test: with RFC 3986. Bumped version to 2.8.4. + * tests/http.test: with RFC 3986. Bumped version to 2.7.9. * unix/Makefile.in: * win/Makefile.in: 2012-03-06 Jan Nijtmans @@ -1737,62 +943,41 @@ * generic/tclLoad.c: Patch from the cygwin folks * unix/tcl.m4: * unix/configure: (re-generated) -2012-03-02 Donal K. Fellows - - * generic/tclBinary.c (Tcl_SetByteArrayObj): [Bug 3496014]: Only zero - out the memory block if it is not being immediately overwritten. (Our - caller might still overwrite, but we should at least avoid - known-useless work.) - 2012-02-29 Jan Nijtmans * generic/tclIOUtil.c: [Bug 3466099]: BOM in Unicode * generic/tclEncoding.c: * tests/source.test: 2012-02-23 Donal K. Fellows - * tests/reg.test (14.21-23): Add tests relating to Bug 1115587. Actual + * tests/reg.test (14.21-23): Add tests relating to bug 1115587. Actual bug is characterised by test marked with 'knownBug'. 2012-02-17 Jan Nijtmans * generic/tclIOUtil.c: [Bug 2233954]: AIX: compile error * unix/tclUnixPort.h: -2012-02-16 Donal K. Fellows - - * generic/tclExecute.c (INST_LIST_RANGE_IMM): Enhance implementation - so that shortening a (not multiply-referenced) list by lopping the end - off with [lrange] or [lreplace] is efficient. - 2012-02-15 Donal K. Fellows - * generic/tclCompCmds.c (TclCompileLreplaceCmd): Added a compilation - strategy for [lreplace] that tackles the cases which are equivalent to - a static [lrange]. - (TclCompileLrangeCmd): Add compiler for [lrange] with constant indices - so we can take advantage of existing TCL_LIST_RANGE_IMM opcode. - (TclCompileLindexCmd): Improve coverage of constant-index-style - compliation using technique developed for [lrange] above. - - (TclCompileDictForCmd): [Bug 3487626]: Fix crash in compilation of - [dict for] when its implementation command is used directly rather - than through the ensemble. + * generic/tclCompCmds.c (TclCompileDictForCmd): [Bug 3487626]: Fix + crash in compilation of [dict for] when its implementation command is + used directly rather than through the ensemble. 2012-02-09 Don Porter - * generic/tclStringObj.c: Converted the memcpy() calls in append - operations to memmove() calls. This adds safety in the case of - overlapping copies, and improves performance on some benchmarks. + * generic/tclStringObj.c: [Bug 3484402]: Correct Off-By-One + error appending unicode. Thanks to Poor Yorick. Also corrected test + for when growth is needed. 2012-02-06 Don Porter - * generic/tclEnsemble.c: [Bug 3485022]: TclCompileEnsemble() avoid + * generic/tclCompCmds.c: [Bug 3485022]: TclCompileEnsemble() avoid * tests/trace.test: compile when exec traces set. 2012-02-06 Miguel Sofer * generic/tclTrace.c: [Bug 3484621]: Ensure that execution traces on @@ -1815,36 +1000,16 @@ 2012-02-01 Donal K. Fellows * doc/AddErrInfo.3: [Bug 3482614]: Documentation nit. -2012-01-30 Donal K. Fellows - - * generic/tclCompCmds.c (TclCompileCatchCmd): Added a more efficient - bytecode generator for the case where 'catch' is used without any - variable arguments; don't capture the result just to discard it. - -2012-01-26 Don Porter - - * generic/tclCmdAH.c: [Bug 3479689]: New internal routine - * generic/tclFCmd.c: TclJoinPath(). Refactor all the - * generic/tclFileName.c: *Join*Path* routines to give them more - * generic/tclInt.h: useful interfaces that are easier to - * generic/tclPathObj.c: manage getting the refcounts right. - 2012-01-26 Don Porter * generic/tclPathObj.c: [Bug 3475569]: Add checks for unshared values before calls demanding them. [Bug 3479689]: Stop memory corruption when shimmering 0-refCount value to "path" type. -2012-01-25 Donal K. Fellows - - * generic/tclOO.c (Tcl_CopyObjectInstance): [Bug 3474460]: When - copying an object, make sure that the configuration of the variable - resolver is also duplicated. - 2012-01-22 Jan Nijtmans * 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 @@ -1874,20 +1039,23 @@ 2012-01-17 Donal K. Fellows * doc/dict.n (dict with): [Bug 3474512]: Explain better what is going on when a dictionary key and the dictionary variable collide. + +2012-01-17 Don Porter + + * library/http/http.tcl: Bump to version 2.7.8 + * library/http/pkgIndex.tcl: + * unix/Makefile.in: + * win/Makefile.in: 2012-01-13 Donal K. Fellows * library/http/http.tcl (http::Connect): [Bug 3472316]: Ensure that we only try to read the socket error exactly once. -2012-01-12 Donal K. Fellows - - * doc/tclvars.n: [Bug 3466506]: Document more environment variables. - 2012-01-09 Jan Nijtmans * generic/tclUtf.c: [Bug 3464428]: [string is graph \u0120] was * generic/regc_locale.c: wrong. Add table for Unicode [:cntrl:] class. * tools/uniClass.tcl: Generate Unicode [:cntrl:] class table. @@ -1919,16 +1087,10 @@ * generic/regc_locale.c: * tests/utf.test: * tools/uniParse.tcl: Clean up some unused stuff, and be more robust against changes in UnicodeData.txt syntax -2011-12-13 Andreas Kupries - - * generic/tclCompile.c (TclInitAuxDataTypeTable): Extended to register - the DictUpdateInfo structure as an AuxData type. For use by tbcload, - tclcompiler. - 2011-12-11 Jan Nijtmans * generic/regc_locale.c: [Bug 3457031]: Some Unicode 6.0 chars not * tests/utf.test: in [:print:] class @@ -1943,104 +1105,47 @@ * library/tcltest/tcltest.tcl: [Bug 967195]: Make tcltest work when tclsh is compiled without using the setargv() function on mingw. 2011-11-29 Jan Nijtmans + * doc/tclsh.1: Use the same shebang comment everywhere. + * tools/str2c + * tools/tcltk-man2html.tcl * win/Makefile.in: don't install tommath_(super)?class.h * unix/Makefile.in: don't install directories like 8.2 and 8.3 - * generic/tclTomMath.h: [Bug 2991415]: move include tclInt.h from - * generic/tclTomMathInt.h: tclTomMath.h to tclTomMathInt.h - -2011-11-25 Donal K. Fellows - - * library/history.tcl (history): Simplify the dance of variable - management used when chaining to the implementation command. - -2011-11-22 Donal K. Fellows - - * generic/tclExecute.c (TclCompileObj): Simplify and de-indent the - logic so that it is easier to comprehend. 2011-11-22 Jan Nijtmans * win/tclWinPort.h: [Bug 3354324]: Windows: [file mtime] sets wrong * win/tclWinFile.c: time (VS2005+ only). * generic/tclTest.c: -2011-11-20 Joe Mistachkin - - * tests/thread.test: Remove unnecessary [after] calls from the thread - tests. Make error message matching more robust for tests that may - have built-in race conditions. Test thread-7.26 must first unset all - thread testing related variables. Revise results of the thread-7.28 - through thread-7.31 tests to account for the fact they are canceled - via a script sent to the thread asynchronously, which then impacts the - error message handling. Attempt to manually drain the event queue for - the main thread after joining the test thread to make sure no stray - events are processed at the wrong time on the main thread. Revise all - the synchronization and comparison semantics related to the thread id - and error message. - -2011-11-18 Joe Mistachkin - - * tests/thread.test: Remove all use of thread::release from the thread - 7.x tests, replacing it with a script that can easily cause "stuck" - threads to self-destruct for those test cases that require it. Also, - make the error message handling far more robust by keeping track of - every asynchronous error. - -2011-11-17 Joe Mistachkin - - * tests/thread.test: Refactor all the remaining thread-7.x tests that - were using [testthread]. Note that this test file now requires the - very latest version of the Thread package to pass all tests. In - addition, the thread-7.18 and thread-7.19 tests have been flagged as - knownBug because they cannot pass without modifications to the [expr] - command, persuant to TIP #392. - -2011-11-17 Joe Mistachkin - - * generic/tclThreadTest.c: For [testthread cancel], avoid creating a - new Tcl_Obj when the default script cancellation result is desired. - -2011-11-11 Donal K. Fellows - - * win/tclWinConsole.c: Refactor common thread handling patterns. - -2011-11-11 Alexandre Ferrieux - - * tests/zlib.test: [Bug 3428756]: Use nonblocking writes in - single-threaded IO tests to avoid deadlocks when going beyond OS - buffers. Tidy up [chan configure] flags across zlib.test. - -2011-11-03 Donal K. Fellows - - * unix/tclUnixCompat.c (TclpGetPwNam, TclpGetPwUid, TclpGetGrNam) - (TclpGetGrGid): Use the elaborate memory management scheme outlined on - http://www.opengroup.org/austin/docs/austin_328.txt to handle Tcl's - use of standard reentrant versions of the passwd/group access - functions so that everything can work on all BSDs. Problem identified - by Stuart Cassoff. +2011-11-04 Don Porter + + *** 8.5.11 TAGGED FOR RELEASE *** + + * generic/tcl.h: Bump to 8.5.11 for release. + * library/init.tcl: + * tools/tcl.wse.in: + * unix/configure.in: + * unix/tcl.spec: + * win/configure.in: + * README: + + * unix/configure: autoconf-2.59 + * win/configure: + + * changes: Update for 8.5.11 release. 2011-10-20 Don Porter - * library/http/http.tcl: Bump to version 2.8.3 + * library/http/http.tcl: Bump to version 2.7.7 * library/http/pkgIndex.tcl: * unix/Makefile.in: * win/Makefile.in: - * changes: Updates toward 8.6b3 release. - -2011-10-20 Donal K. Fellows - - * generic/tclLiteral.c (TclInvalidateCmdLiteral): [Bug 3418547]: - Additional code for handling the invalidation of literals. - * generic/tclBasic.c (Tcl_CreateObjCommand, Tcl_CreateCommand) - (TclRenameCommand, Tcl_ExposeCommand): The four additional places that - need extra care when dealing with literals. - * generic/tclTest.c (TestInterpResolverCmd): Additional test machinery - for interpreter resolvers. + * changes: Updates for 8.5.11 release. 2011-10-18 Reinhard Max * library/clock.tcl (::tcl::clock::GetSystemTimeZone): Cache the time zone only if it was detected by one of the expensive methods. @@ -2056,33 +1161,16 @@ 2011-10-11 Jan Nijtmans * win/tclWinFile.c: [Bug 2935503]: Incorrect mode field returned by [file stat] command. -2011-10-09 Donal K. Fellows - - * generic/tclCompCmds.c (TclCompileDictWithCmd): Corrected handling of - qualified names, and added spacial cases for empty bodies (used when - [dict with] is just used for extracting variables). - 2011-10-07 Jan Nijtmans - * generic/tcl.h: Fix gcc warnings (discovered with latest - * generic/tclIORChan.c: mingw, based on gcc 4.6.1) - * tests/env.test: Fix env.test, when running under wine 1.3. - -2011-10-06 Donal K. Fellows - - * generic/tclDictObj.c (TclDictWithInit, TclDictWithFinish): - * generic/tclCompCmds.c (TclCompileDictWithCmd): Experimental - compilation for the [dict with] subcommand, using parts factored out - from the interpreted version of the command. - -2011-10-05 Jan Nijtmans - - * win/tclWinInt.h: Remove tclWinProcs, as it is no longer - * win/tclWin32Dll.c: being used. + * generic/tclIORChan.c: Fix gcc warning (discovered with latest + mingw, based on gcc 4.6.1) + * tests/env.test: Fix env.test running under wine 1.3 (partly + backported from Tcl 8.6) 2011-10-03 Venkat Iyer * library/tzdata/Africa/Dar_es_Salaam: Update to Olson's tzdata2011k * library/tzdata/Africa/Kampala: @@ -2094,117 +1182,10 @@ * library/tzdata/Europe/Simferopol: * library/tzdata/Europe/Uzhgorod: * library/tzdata/Europe/Zaporozhye: * library/tzdata/Pacific/Apia: -2011-09-29 Donal K. Fellows - - * tools/tcltk-man2html.tcl, tools/tcltk-man2html-utils.tcl: More - refactoring so that more of the utility code is decently out of the - way. Adjusted the header-material generator so that version numbers - are only included in locations where there is room. - -2011-09-28 Jan Nijtmans - - * generic/tclOO.h: [RFE 3010352]: make all TclOO API functions - * generic/tclOODecls.h: MODULE_SCOPE - * generic/tclOOIntDecls.h: - -2011-09-27 Donal K. Fellows - - * generic/tclIndexObj.c (Tcl_ParseArgsObjv): [Bug 3413857]: Corrected - the memory management for the code parsing arguments when returning - "large" numbers of arguments. Also unbroke the TCL_ARGV_AUTO_REST - macro in passing. - -2011-09-26 Donal K. Fellows - - * generic/tclCmdAH.c (TclMakeFileCommandSafe): [Bug 3211758]: Also - make the main [file] command hidden by default in safe interpreters, - because that's what existing code expects. This will reduce the amount - which the code breaks, but not necessarily eliminate it... - -2011-09-23 Don Porter - - * generic/tclIORTrans.c: More revisions to get finalization of - ReflectedTransforms correct, including adopting a "dead" field as was - done in tclIORChan.c. - - * tests/thread.test: Stop using the deprecated thread management - commands of the tcltest package. The test suite ought to provide - these tools for itself. They do not belong in a testing harness. - -2011-09-22 Don Porter - - * generic/tclCmdIL.c: Revise [info frame] so that it stops creating - cycles in the iPtr->cmdFramePtr stack. - -2011-09-22 Donal K. Fellows - - * doc/re_syntax.n: [Bug 2903743]: Add more magic so that we can do at - least something sane on Solaris. - * tools/tcltk-man2html-utils.tcl (process-text): Teach the HTML - generator how to handle this magic. - -2011-09-21 Don Porter - - * generic/tclThreadTest.c: Revise the thread exit handling of the - [testthread] command so that it properly maintains the per-process - data structures even when the thread exits for reasons other than the - [testthread exit] command. - -2011-09-21 Alexandre Ferrieux - - * unix/tclIO.c: [Bug 3412487]: Now short reads are allowed in - synchronous fcopy, avoid mistaking them as nonblocking ones. - -2011-09-21 Andreas Kupries - - * generic/tclIORTrans.c (ForwardOpToOwnerThread): Fixed the missing - initialization of the 'dsti' field. Reported by Don Porter, on chat. - -2011-09-20 Don Porter - - * generic/tclIORChan.c: Re-using the "interp" field to signal a dead - channel (via NULL value) interfered with conditional cleanup tasks - testing for "the right interp". Added a new field "dead" to perform - the dead channel signalling task so the corrupted logic is avoided. - - * generic/tclIORTrans.c: Revised ReflectClose() and - FreeReflectedTransform() so that we stop leaking ReflectedTransforms, - yet free all Tcl_Obj values in the same thread that alloced them. - -2011-09-19 Don Porter - - * tests/ioTrans.test: Conversion from [testthread] to Thread package - stops most memory leaks. - - * tests/thread.test: Plug most memory leaks in thread.test. - Constrain the rest to be skipped during `make valgrind'. Tests using - the [testthread cancel] testing command are leaky. Corrections wait - for either addition of [thread::cancel] to the Thread package, or - improvements to the [testthread] testing command to make leak-free - versions of these tests possible. - - * generic/tclIORChan.c: Plug all memory leaks in ioCmd.test exposed - * tests/ioCmd.test: by `make valgrind'. - * unix/Makefile.in: - -2011-09-16 Jan Nijtmans - - IMPLEMENTATION OF TIP #388 - - * doc/Tcl.n: - * doc/re_syntax.n: - * generic/regc_lex.c: - * generic/regcomp.c: - * generic/regcustom.h: - * generic/tcl.h: - * generic/tclParse.c: - * tests/reg.test: - * tests/utf.test: - 2011-09-16 Donal K. Fellows * generic/tclProc.c (ProcWrongNumArgs): [Bugs 3400658,3408830]: Corrected the handling of procedure error messages (found by TclOO). @@ -2213,25 +1194,15 @@ * generic/tcl.h: Don't change Tcl_UniChar type when * generic/regcustom.h: TCL_UTF_MAX == 4 (not supported anyway) 2011-09-16 Donal K. Fellows - * generic/tclProc.c (ProcWrongNumArgs): [Bugs 3400658,3408830]: - Ensemble-like rewriting of error messages is complex, and TclOO (in - combination with iTcl) hits the most tricky cases. - * library/http/http.tcl (http::geturl): [Bug 3391977]: Ensure that the -headers option overrides the -type option (important because -type has a default that is not always appropriate, and the header must not be duplicated). -2011-09-15 Don Porter - - * generic/tclCompExpr.c: [Bug 3408408]: Partial improvement by sharing - as literals the computed values of constant subexpressions when we can - do so without incurring the cost of string rep generation. - 2011-09-13 Don Porter * generic/tclUtil.c: [Bug 3390638]: Workaround broken Solaris Studio cc optimizer. Thanks to Wolfgang S. Kechel. @@ -2241,25 +1212,10 @@ 2011-09-12 Jan Nijtmans * win/tclWinPort.h: [Bug 3407070]: tclPosixStr.c won't build with EOVERFLOW==E2BIG -2011-09-11 Don Porter - - * tests/thread.test: Convert [testthread] use to Thread package use - in thread-6.1. Eliminates a memory leak in `make valgrind`. - - * tests/socket.test: [Bug 3390699]: Convert [testthread] use to - Thread package use in socket_*-13.1. Eliminates a memory leak in - `make valgrind`. - -2011-09-09 Don Porter - - * tests/chanio.test: [Bug 3389733]: Convert [testthread] use to - * tests/io.test: Thread package use in *io-70.1. Eliminates a - memory leak in `make valgrind`. - 2011-09-07 Don Porter * generic/tclCompExpr.c: [Bug 3401704]: Allow function names like * tests/parseExpr.test: influence(), nanobot(), and 99bottles() that have been parsed as missing operator syntax errors before with the @@ -2275,27 +1231,10 @@ * library/tzdata/Europe/Kaliningrad: * library/tzdata/Pacific/Apia: * library/tzdata/Pacific/Honolulu: * library/tzdata/Africa/Juba: (new) -2011-09-06 Jan Nijtmans - - * generic/tcl.h: [RFE 1711975]: Tcl_MainEx() (like Tk_MainEx()) - * generic/tclDecls.h: - * generic/tclMain.c: - -2011-09-02 Don Porter - - * tests/http.test: Convert [testthread] use to Thread package use. - Eliminates memory leak seen in `make valgrind`. - -2011-09-01 Alexandre Ferrieux - - * unix/tclUnixSock.c: [Bug 3401422]: Cache script-level changes to the - nonblocking flag of an async client socket in progress, and commit - them on completion. - 2011-09-01 Don Porter * generic/tclStrToD.c: [Bug 3402540]: Corrections to TclParseNumber() * tests/binary.test: to make it reject invalid Nan(Hex) strings. @@ -2307,248 +1246,78 @@ [Bug 3398794]: Ensure that low-level conditions in the limit API are enforced at the script level through errors, not a Tcl_Panic. This means that interpreters cannot read their own limits (writing already did not work). -2011-08-30 Reinhard Max - - * unix/tclUnixSock.c (TcpWatchProc): [Bug 3394732]: Put back the check - for server sockets. - -2011-08-29 Don Porter - - * generic/tclIORTrans.c: Leak of ReflectedTransformMap. - -2011-08-27 Don Porter - - * generic/tclStringObj.c: [RFE 3396731]: Revise the [string reverse] - * tests/string.test: implementation to operate on the representation - that comes in, avoid conversion to other reps. - -2011-08-23 Don Porter - - * generic/tclIORChan.c: [Bug 3396948]: Leak of ReflectedChannelMap. - -2011-08-19 Don Porter - - * generic/tclIORTrans.c: [Bugs 3393279, 3393280]: ReflectClose(.) is - missing Tcl_EventuallyFree() calls at some of its exits. - - * generic/tclIO.c: [Bugs 3394654, 3393276]: Revise FlushChannel() to - account for the possibility that the ChanWrite() call might recycle - the buffer out from under us. - - * generic/tclIO.c: Preserve the chanPtr during FlushChannel so that - channel drivers don't yank it away before we're done with it. - 2011-08-19 Alexandre Ferrieux * generic/tclTest.c: [Bug 2981154]: async-4.3 segfault. * tests/async.test: [Bug 1774689]: async-4.3 sometimes fails. -2011-08-18 Alexandre Ferrieux - - * generic/tclIO.c: [Bug 3096275]: Sync fcopy buffers input. - 2011-08-18 Jan Nijtmans * generic/tclUniData.c: [Bug 3393714]: Overflow in toupper delta * tools/uniParse.tcl: * tests/utf.test: -2011-08-17 Alexandre Ferrieux - - * generic/tclIO.c: [Bug 2946474]: Consistently resume backgrounded - * tests/ioCmd.test: flushes+closes when exiting. - -2011-08-17 Alexandre Ferrieux - - * doc/interp.n: Document TIP 378's one-way-ness. - 2011-08-17 Don Porter * generic/tclGet.c: [Bug 3393150]: Overlooked free of intreps. (It matters for bignums!) -2011-08-16 Don Porter - - * generic/tclCompile.c: [Bug 3392070]: More complete prevention of - Tcl_Obj reference cycles when producing an intrep of ByteCode. - -2011-08-16 Donal K. Fellows - - * generic/tclListObj.c (TclLindexList, TclLsetFlat): Silence warnings - about (unreachable) cases of uninitialized variables. - * generic/tclCmdIL.c (SelectObjFromSublist): Improve the generation of - * generic/tclIndexObj.c (Tcl_ParseArgsObjv): messages through the use - * generic/tclVar.c (ArrayStartSearchCmd): of Tcl_ObjPrintf. +2011-08-16 Jan Nijtmans + + * generic/tclCmdAH.c: [Bug 3388350]: mingw64 compiler warnings + * generic/tclFCmd.c In mingw, sys/stat.h must be included + * generic/tclFileName.c before winsock2.h, so make sure of that. + * generic/tclIOUtil.c + * generic/tclBasic.c + * generic/tclBinary.c + * generic/tclHash.c + * generic/tclTest.c + * win/tclWinChan.c + * win/tclWinConsole.c + * win/tclWinDde.c + * win/tclWinFile.c + * win/tclWinReg.c + * win/tclWinSerial.c + * win/tclWinSock.c + * win/tclWinThrd.c 2011-08-15 Don Porter * generic/tclBasic.c: [Bug 3390272]: Leak of [info script] value. 2011-08-15 Jan Nijtmans * generic/tclPosixStr.c: [Bug 3388350]: mingw64 compiler warnings + * generic/tclStrToD.c * win/tclWinPort.h: + * win/tclWinPipe.c: + * win/tclWinSock.c: * win/configure.in: * win/configure: -2011-08-14 Jan Nijtmans - - * doc/FindExec.3: [Patch 3124554]: Move WishPanic from Tk to Tcl - * doc/Panic.3 Added Documentation - 2011-08-12 Don Porter * generic/tclPathObj.c: [Bug 3389764]: Eliminate possibility that dup of a "path" value can create reference cycle. -2011-08-12 Donal K. Fellows - - * generic/tclZlib.c (ZlibTransformOutput): [Bug 3390073]: Return the - correct length of written data for a compressing transform. - -2011-08-10 Alexandre Ferrieux - - * generic/tclTestObj.c: [Bug 3386721]: Allow multiple [load]ing of the - Tcltest package. - -2011-08-09 Alexandre Ferrieux - - * generic/tclBasic.c: [Bug 2919042]: Restore "valgrindability" of Tcl - * generic/tclEvent.c: that was lost by the streamlining of [exit], by - * generic/tclExecute.c: conditionally forcing a full Finalize: - * generic/tclInt.h: use -DPURIFY or ::env(TCL_FINALIZE_ON_EXIT) - -2011-08-09 Alexandre Ferrieux - - * generic/tclCompCmds.c: [Bug 3386417]: Avoid a reference loop between - * generic/tclInt.h: the bytecode and its companion errostack - * generic/tclResult.c: when compiling a syntax error. - 2011-08-09 Jan Nijtmans * win/tclWinConsole.c: [Bug 3388350]: mingw64 compiler warnings * win/tclWinDde.c: * win/tclWinPipe.c: * win/tclWinSerial.c: -2011-08-09 Jan Nijtmans - - * generic/tclInt.h: Change the signature of TclParseHex(), such that - * generic/tclParse.c: it can now parse up to 8 hex characters. - -2011-08-08 Donal K. Fellows - - * generic/tclZlib.c (ZlibStreamCmd): Make the -buffersize option to - '$zstream add' function correctly instead of having its value just be - discarded unceremoniously. Also generate error codes from more of the - code, not just the low-level code but also the Tcl infrastructure. - -2011-08-07 Donal K. Fellows - - * generic/tclOOInfo.c (InfoClassCallCmd): [Bug 3387082]: Plug memory - leak in call chain introspection. - -2011-08-06 Kevin B, Kenny - - * generic/tclAssemnbly.c: [Bug 3384840]: Plug another memory leak. - * generic/tclStrToD.c: [Bug 3386975]: Plug another memory leak. - 2011-08-05 Kevin B. Kenny * generic/tclStrToD.c: [Bug 3386975]: Plugged a memory leak in double->string conversion. -2011-08-05 Don Porter - - *** 8.6b2 TAGGED FOR RELEASE *** - - * changes: Updates for 8.6b2 release. - -2011-08-05 Donal K. Fellows - - * generic/tclAssembly.c (AssembleOneLine): Ensure that memory isn't - leaked when an unknown instruction is encountered. Also simplify code - through use of Tcl_ObjPrintf in error message generation. - - * generic/tclZlib.c (ZlibTransformClose): [Bug 3386197]: Plug a memory - leak found by Miguel with valgrind, and ensure that the correct - direction's buffers are released. - -2011-08-04 Miguel Sofer - - * generic/tclVar.c (TclPtrSetVar): Fix valgrind-detected error when - newValuePtr is the interp's result obj. - -2011-08-04 Donal K. Fellows - - * generic/tclAssembly.c (FreeAssemblyEnv): [Bug 3384840]: Plug another - possible memory leak due to over-complex code for freeing the table of - labels. - -2011-08-04 Reinhard Max - - * generic/tclIOSock.c (TclCreateSocketAddress): Don't bother using - AI_ADDRCONFIG for now, as it was causing problems in various - situations. - -2011-08-04 Donal K. Fellows - - * generic/tclAssembly.c (AssembleOneLine, GetBooleanOperand) - (GetIntegerOperand, GetListIndexOperand, FindLocalVar): [Bug 3384840]: - A Tcl_Obj is allocated by GetNextOperand, so callers of it must not - hold a reference to one in the 'out' parameter when calling it. This - was causing a great many memory leaks. - * tests/assemble.test (assemble-51.*): Added group of memory leak - tests. - -2011-08-02 Don Porter - - * changes: Updates for 8.6b2 release. - * tools/tcltk-man2html.tcl: Variable substitution botch. - -2011-08-02 Donal K. Fellows - - * generic/tclObj.c (Tcl_DbIncrRefCount, Tcl_DbDecrRefCount) - (Tcl_DbIsShared): [Bug 3384007]: Fix the panic messages so they share - what should be shared and have the right number of spaces. - -2011-08-01 Miguel Sofer - - * generic/tclProc.c (TclProcCompileProc): [Bug 3383616]: Fix for leak - of resolveInfo when recompiling procs. Thanks go to Gustaf Neumann for - detecting the bug and providing the fix. - -2011-08-01 Donal K. Fellows - - * doc/tclvars.n (EXAMPLES): Added some examples of how some of the - standard global variables can be used, following prompting by a - request by Robert Hicks. - - * tools/tcltk-man2html.tcl (plus-pkgs): [Bug 3382474]: Added code to - determine the version number of contributed packages from their - directory names so that HTML documentation builds are less confusing. - -2011-07-29 Donal K. Fellows - - * tools/tcltk-man2html.tcl (ensemble_commands, remap_link_target): - Small enhancements to improve cross-linking with contributed packages. - * tools/tcltk-man2html-utils.tcl (insert-cross-references): Enhance to - cope with contributed packages' C API. - -2011-07-28 Reinhard Max - - * unix/tcl.m4 (SC_TCL_IPV6): Fix AC_DEFINE invocation for - NEED_FAKE_RFC2553. - * unix/configure: autoconf-2.59 - 2011-07-28 Don Porter - * changes: Updates for 8.6b2 release. - * library/tzdata/Asia/Anadyr: Update to Olson's tzdata2011h * library/tzdata/Asia/Irkutsk: * library/tzdata/Asia/Kamchatka: * library/tzdata/Asia/Krasnoyarsk: * library/tzdata/Asia/Magadan: @@ -2564,16 +1333,10 @@ * library/tzdata/Europe/Samara: * library/tzdata/Europe/Volgograd: * library/tzdata/America/Kralendijk: (new) * library/tzdata/America/Lower_Princes: (new) -2011-07-26 Donal K. Fellows - - * generic/tclOO.c (initScript): Ensure that TclOO is properly found by - all the various package mechanisms (by adding a dummy ifneeded script) - and not just some of them. - 2011-07-21 Jan Nijtmans * win/tclWinPort.h: [Bug 3372130]: Fix hypot math function with MSVC10 2011-07-19 Don Porter @@ -2580,70 +1343,19 @@ * generic/tclUtil.c: [Bug 3371644]: Repair failure to properly handle * tests/util.test: (length == -1) scanning in TclConvertElement(). Thanks to Thomas Sader and Alexandre Ferrieux. -2011-07-19 Donal K. Fellows - - * doc/*.3, doc/*.n: Many small fixes to documentation as part of - project to improve quality of generated HTML docs. - - * tools/tcltk-man2html.tcl (remap_link_target): More complete set of - definitions of link targets, especially for major C API types. - * tools/tcltk-man2html-utils.tcl (output-IP-list, cross-reference): - Update to generation to produce proper HTML bulleted and enumerated - lists. - -2011-07-19 Alexandre Ferrieux - - * doc/upvar.n: Undocument long gone limitation of [upvar]. - -2011-07-18 Don Porter - - * generic/tcl.h: Bump version number to 8.6b2. - * library/init.tcl: - * unix/configure.in: - * win/configure.in: - * unix/tcl.spec: - * tools/tcl.wse.in: - * README: - - * unix/configure: autoconf-2.59 - * win/configure: - 2011-07-15 Don Porter - * generic/tclCompile.c: Avoid segfaults when RecordByteCodeStats() is - called in a deleted interp. - - * generic/tclCompile.c: [Bug 467523, 3357771]: Prevent circular - references in values with ByteCode intreps. They can lead to memory - leaks. - -2011-07-14 Donal K. Fellows - - * generic/tclOOCall.c (TclOORenderCallChain): [Bug 3365156]: Remove - stray refcount bump that caused a memory leak. - -2011-07-12 Don Porter - - * generic/tclUnixSock.c: [Bug 3364777]: Stop segfault caused by - reading from struct after it had been freed. - -2011-07-11 Joe Mistachkin - - * generic/tclExecute.c: [Bug 3339502]: Correct cast for CURR_DEPTH to - silence compiler warning. + * generic/tclCompile.c: Avoid segfaults when RecordByteCodeStats() + is called in a deleted interp. 2011-07-08 Donal K. Fellows * doc/http.n: [FRQ 3358415]: State what RFC defines HTTP/1.1. -2011-07-07 Miguel Sofer - - * generic/tclBasic.c: Add missing INT2PTR - 2011-07-03 Donal K. Fellows * doc/FileSystem.3: Corrected statements about ctime field of 'struct stat'; that was always the time of the last metadata change, not the time of creation. @@ -2661,19 +1373,21 @@ * win/Makefile.vc: [Bug 3349507]: Fix a bug where bignum->double conversion is "round up" and not "round to nearest" (causing expr double(1[string repeat 0 23]) not to be 1e+23). -2011-06-28 Reinhard Max - - * unix/tclUnixSock.c (CreateClientSocket): [Bug 3325339]: Fix and - simplify posting of the writable fileevent at the end of an - asynchronous connection attempt. Improve comments for some of the - trickery around [socket -async]. - - * tests/socket.test: Adjust tests to the async code changes. Add more - tests for corner cases of async sockets. +2011-06-30 Reinhard Max + + * unix/configure.in: Add a volatile declaration to the test for + TCL_STACK_GROWS_UP to prevent gcc 4.6 from producing invalid + results due to aggressive optimisation. + +2011-06-23 Don Porter + + *** 8.5.10 TAGGED FOR RELEASE *** + + * changes: Update for 8.5.10 release. 2011-06-22 Andreas Kupries * library/platform/pkgIndex.tcl: Updated to platform 1.0.10. Added * library/platform/platform.tcl: handling of the DEB_HOST_MULTIARCH @@ -2681,49 +1395,30 @@ * win/Makefile.in: * generic/tclInt.h: Fixed the inadvertently committed disabling of stack checks, see my 2010-11-15 commit. -2011-06-22 Reinhard Max - - Merge from rmax-ipv6-branch: - * unix/tclUnixSock.c: Fix [socket -async], so that all addresses - returned by getaddrinfo() are tried, not just the first one. This - requires the event loop to be running while the async connection is in - progress. ***POTENTIAL INCOMPATIBILITY*** - * tests/socket.test: Add a test for the above. - * doc/socket: Document the fact that -async needs the event loop - * generic/tclIOSock.c: AI_ADDRCONFIG is broken on HP-UX - 2011-06-21 Don Porter + + * changes: Update for 8.5.10 release. + + * library/tcltest/tcltest.tcl (loadIntoSlaveInterpreter): + * library/tcltest/pkgIndex.tcl: Backport tcltest 2.3.3 for release + * unix/Makefile.in: with Tcl 8.5.*. + * win/Makefile.in: + + * tests/init.test: Update test files to use new command. + * tests/pkg.test: * generic/tclLink.c: [Bug 3317466]: Prevent multiple links to a single Tcl variable when calling Tcl_LinkVar(). 2011-06-13 Don Porter * generic/tclStrToD.c: [Bug 3315098]: Mem leak fix from Gustaf Neumann. -2011-06-08 Andreas Kupries - - * generic/tclExecute.c: Reverted the fix for [Bug 3274728] committed - on 2011-04-06 and replaced with one which is 64bit-safe. The existing - fix crashed tclsh on Windows 64bit. - -2011-06-08 Donal K. Fellows - - * tests/fileSystem.test: Reduce the amount of use of duplication of - complex code to perform common tests, and convert others to do the - test result check directly using Tcltest's own primitives. - -2011-06-06 Jan Nijtmans - - * tests/socket.test: Add test constraint, so 6.2 and 6.3 don't fail - when the machine does not have support for ip6. Follow-up to checkin - from 2011-05-11 by rmax. - 2011-06-02 Don Porter * generic/tclBasic.c: Removed TclCleanupLiteralTable(), and old * generic/tclInt.h: band-aid routine put in place while a fix for * generic/tclLiteral.c: [Bug 994838] took shape. No longer needed. @@ -2733,56 +1428,26 @@ * generic/tclInt.h (TclInvalidateNsCmdLookup): [Bug 3185407]: Extend the set of epochs that are potentially bumped when a command is created, for a slight performance drop (in some circumstances) and improved semantics. -2011-06-01 Miguel Sofer - - * generic/tclBasic.c: Using the two free data elements in NRCommand to - store objc and objv - useful for debugging. - 2011-06-01 Jan Nijtmans * generic/tclUtil.c: Fix for [Bug 3309871]: Valgrind finds: invalid read in TclMaxListLength(). -2011-05-31 Don Porter - - * generic/tclInt.h: Use a complete growth algorithm for lists so - * generic/tclListObj.c: that length limits do not overconstrain by a - * generic/tclStringObj.c: factor of 2. [Bug 3293874]: Fix includes - * generic/tclUtil.c: rooting all growth routines by default on a - common tunable parameter TCL_MIN_GROWTH. - 2011-05-25 Don Porter - * library/msgcat/msgcat.tcl: Bump to msgcat 1.4.4. - * library/msgcat/pkgIndex.tcl: - * unix/Makefile.in: - * win/Makefile.in: - -2011-05-25 Donal K. Fellows - - * generic/tclOO.h (TCLOO_VERSION): Bump version. - - IMPLEMENTATION OF TIP#381. - - * doc/next.n, doc/ooInfo.n, doc/self.n, generic/tclOO.c, - * generic/tclOOBasic.c, generic/tclOOCall.c, generic/tclOOInfo.c, - * generic/tclOOInt.h, tests/oo.test, tests/ooNext2.test: Added - introspection of call chains ([self call], [info object call], [info - class call]) and ability to skip ahead in chain ([nextto]). + * library/msgcat/msgcat.tcl: Backport improvements to msgcat + * library/msgcat/pkgIndex.tcl: package. Bump to 1.4.4 + * unix/Makefile.in + * win/Makefile.in 2011-05-24 Venkat Iyer * library/tzdata/Africa/Cairo: Update to Olson tzdata2011g -2011-05-24 Donal K. Fellows - - * library/msgcat/msgcat.tcl (msgcat::mcset, msgcat::mcmset): Remove - some useless code; [dict set] builds dictionary levels for us. - 2011-05-17 Andreas Kupries * generic/tclCompile.c (TclFixupForwardJump): Tracked down and fixed * generic/tclBasic.c (TclArgumentBCEnter): the cause of a violation of my assertion that 'ePtr->nline == objc' in TclArgumentBCEnter. When a @@ -2789,17 +1454,10 @@ bytecode was grown during jump fixup the pc -> command line mapping was not updated. When things aligned just wrong the mapping would direct command A to the data for command B, with a different number of arguments. -2011-05-11 Reinhard Max - - * unix/tclUnixSock.c (TcpWatchProc): No need to check for server - sockets here, as the generic server code already takes care of that. - * tests/socket.test (accept): Add tests to make sure that this remains - so. - 2011-05-10 Don Porter * generic/tclInt.h: New internal routines TclScanElement() and * generic/tclUtil.c: TclConvertElement() are rewritten guts of machinery to produce string rep of lists. The new routines avoid and @@ -2809,27 +1467,15 @@ * generic/tclIndexObj.c: * generic/tclListObj.c: * generic/tclUtil.c: * tests/list.test: -2011-05-09 Donal K. Fellows - - * generic/tclNamesp.c (NamespacePathCmd): Convert to use Tcl_Obj API - * generic/tclPkg.c (Tcl_PackageObjCmd): for result generation in - * generic/tclTimer.c (Tcl_AfterObjCmd): [after info], [namespace - path] and [package versions]. - 2011-05-09 Don Porter * generic/tclListObj.c: Revise empty string tests so that we avoid potentially expensive string rep generations, especially for dicts. -2011-05-07 Donal K. Fellows - - * generic/tclLoad.c (TclGetLoadedPackages): Convert to use Tcl_Obj API - for result generation. - 2011-05-07 Miguel Sofer * generic/tclInt.h: Fix USE_TCLALLOC so that it can be enabled without * unix/Makefile.in: editing the Makefile. @@ -2841,12 +1487,10 @@ 2011-05-03 Don Porter * generic/tclUtil.c: Tighten Tcl_SplitList(). * generic/tclListObj.c: Tighten SetListFromAny(). * generic/tclDictObj.c: Tighten SetDictFromAny(). - * tests/join.test: - * tests/mathop.test: 2011-05-02 Don Porter * generic/tclCmdMZ.c: Revised TclFindElement() interface. The final * generic/tclDictObj.c: argument had been bracePtr, the address of a @@ -2866,21 +1510,21 @@ scenario. Simply looking for the braces where they must be is the revision available to those callers, and it will backport cleanly. * tests/parse.test: Tests for expanded literals quoting detection. - * generic/tclCompCmdsSZ.c: New TclFindElement() is also a better + * generic/tclCompCmds.c: New TclFindElement() is also a better fit for the [switch] compiler. * generic/tclInt.h: Replace TclCountSpaceRuns() with * generic/tclListObj.c: TclMaxListLength() which is the function we * generic/tclUtil.c: actually want. - * generic/tclCompCmdsSZ.c: + * generic/tclCompCmds.c: - * generic/tclCompCmdsSZ.c: Rewrite of parts of the switch compiler to - better use the powers of TclFindElement() and do less parsing on its - own. + * generic/tclCompCmds.c: Rewrite of parts of the switch compiler to + better use the powers of TclFindElement() and do less parsing on + its own. 2011-04-28 Don Porter * generic/tclInt.h: New utility routines: * generic/tclParse.c: TclIsSpaceProc() and TclCountSpaceRuns() @@ -2890,35 +1534,35 @@ * generic/tclListObj.c: and their /* INTL */ risk. * generic/tclStrToD.c: * generic/tclUtf.c: * unix/tclUnixFile.c: - * generic/tclStringObj.c: Improved reaction to out of memory. - 2011-04-27 Don Porter - * generic/tclCmdMZ.c: TclFreeIntRep() correction & cleanup. - * generic/tclExecute.c: + * generic/tclListObj.c: FreeListInternalRep() cleanup. + + * generic/tclBinary.c: Backport fix for [Bug 2857044]. + * generic/tclDictObj.c: All freeIntRepProcs set typePtr to NULL. + * generic/tclEncoding.c: * generic/tclIndexObj.c: - * generic/tclInt.h: * generic/tclListObj.c: * generic/tclNamesp.c: - * generic/tclResult.c: + * generic/tclObj.c: + * generic/tclPathObj.c: + * generic/tclProc.c: + * generic/tclRegexp.c: * generic/tclStringObj.c: * generic/tclVar.c: - * generic/tclListObj.c: FreeListInternalRep() cleanup. - 2011-04-21 Don Porter * generic/tclInt.h: Use macro to set List intreps. * generic/tclListObj.c: * generic/tclCmdIL.c: Limits on list length were too strict. * generic/tclInt.h: Revised panics to errors where possible. * generic/tclListObj.c: - * tests/lrepeat.test: * generic/tclCompile.c: Make sure SetFooFromAny routines react * generic/tclIO.c: reasonably when passed a NULL interp. * generic/tclIndexObj.c: * generic/tclListObj.c: @@ -2932,10 +1576,18 @@ * generic/tcl.h: fix for [Bug 3288345]: Wrong Tcl_StatBuf * generic/tclInt.h: used on MinGW. Make sure that all _WIN32 * win/tclWinFile.c: compilers use exactly the same layout * win/configure.in: for Tcl_StatBuf - the one used by MSVC6 - * win/configure: in all situations. + +2011-04-20 Andreas Kupries + + * generic/tclFCmd.c (TclFileAttrsCmd): Added commands to reset the + typePtr of the Tcl_Obj* whose int-rep was just purged. Required to + prevent a dangling IndexRep* to reused, smashing the heap. See + also the entries at 2011-04-16 and 2011-03-24 for the history of + the problem. 2011-04-19 Don Porter * generic/tclConfig.c: Reduce internals access in the implementation of [::pkgconfig list]. @@ -2948,20 +1600,16 @@ * generic/tclInt.h: Define and use macros that test whether a Tcl * generic/tclBasic.c: list value is canonical. * generic/tclUtil.c: -2011-04-18 Donal K. Fellows - - * doc/dict.n: [Bug 3288696]: Command summary was confusingly wrong - when it came to [dict filter] with a 'value' filter. - 2011-04-16 Donal K. Fellows - * generic/tclFCmd.c (TclFileAttrsCmd): Add comments to make this code - easier to understand. Added a panic to handle the case where the VFS - layer does something odd. + * generic/tclFCmd.c (TclFileAttrsCmd): Tidied up the memory management + a bit to try to ensure that the dynamic and static cases don't get + confused while still promoting caching where possible. Added a panic + to trap problems in the case where an extension is misusing the API. 2011-04-13 Don Porter * generic/tclUtil.c: [Bug 3285375]: Rewrite of Tcl_Concat*() routines to prevent segfaults on buffer overflow. Build them out of @@ -2975,231 +1623,66 @@ 2011-04-13 Miguel Sofer * generic/tclVar.c: [Bug 2662380]: Fix crash caused by appending to a variable with a write trace that unsets it. -2011-04-13 Donal K. Fellows - - * generic/tclUtil.c (Tcl_ConcatObj): [Bug 3285375]: Make the crash - less mysterious through the judicious use of a panic. Not yet properly - fixed, but at least now clearer what the failure mode is. - 2011-04-12 Don Porter - * tests/string.test: Test for [Bug 3285472]. Not buggy in trunk. + * generic/tclStringObj.c: [Bug 3285472]: Repair corruption in + * tests/string.test: [string reverse] when string rep invalidation + failed to also reset the bytes allocated for string rep to zero. 2011-04-12 Venkat Iyer * library/tzdata/Atlantic/Stanley: Update to Olson tzdata2011f -2011-04-12 Miguel Sofer - - * generic/tclBasic.c: Fix for [Bug 2440625], kbk's patch - -2011-04-11 Miguel Sofer - - * generic/tclBasic.c: - * tests/coroutine.test: [Bug 3282869]: Ensure that 'coroutine eval' - runs the initial command in the proper context. - -2011-04-11 Jan Nijtmans - - * generic/tcl.h: Fix for [Bug 3281728]: Tcl sources from 2011-04-06 - * unix/tcl.m4: do not build on GCC9 (RH9) - * unix/configure: - -2011-04-08 Jan Nijtmans - - * win/tclWinPort.h: Fix for [Bug 3280043]: win2k: unresolved DLL - * win/configure.in: imports. - * win/configure - 2011-04-06 Miguel Sofer - * generic/tclExecute.c (TclCompileObj): Earlier return if Tip280 + * generic/tclExecute.c (TclCompEvalObj): Earlier return if Tip280 gymnastics not needed. - * generic/tclExecute.c: Fix for [Bug 3274728]: making *catchTop an - unsigned long. - -2011-04-06 Jan Nijtmans - - * unix/tclAppInit.c: Make symbols "main" and "Tcl_AppInit" - MODULE_SCOPE: there is absolutely no reason for exporting them. - * unix/tcl.m4: Don't use -fvisibility=hidden with static - * unix/configure libraries (--disable-shared) - -2011-04-06 Donal K. Fellows - - * generic/tclFCmd.c, macosx/tclMacOSXFCmd.c, unix/tclUnixChan.c, - * unix/tclUnixFCmd.c, win/tclWinChan.c, win/tclWinDde.c, - * win/tclWinFCmd.c, win/tclWinLoad.c, win/tclWinPipe.c, - * win/tclWinReg.c, win/tclWinSerial.c, win/tclWinSock.c: More - generation of error codes (most platform-specific parts not already - using Tcl_PosixError). - 2011-04-05 Venkat Iyer * library/tzdata/Africa/Casablanca: Update to Olson's tzdata2011e * library/tzdata/America/Santiago: * library/tzdata/Pacific/Easter: * library/tzdata/America/Metlakatla: (new) * library/tzdata/America/North_Dakota/Beulah: (new) * library/tzdata/America/Sitka: (new) -2011-04-04 Donal K. Fellows - - * generic/tclOO.c, generic/tclOOBasic.c, generic/tclOODefineCmds.c - * generic/tclOOInfo.c, generic/tclOOMethod.c: More generation of - error codes (TclOO miscellany). - - * generic/tclCmdAH.c, generic/tclCmdIL.c: More generation of error - codes (miscellaneous commands mostly already handled). - 2011-04-04 Don Porter * README: [Bug 3202030]: Updated README files, repairing broken * macosx/README:URLs and removing other bits that were clearly wrong. * unix/README: Still could use more eyeballs on the detailed build * win/README: advice on various plaforms. -2011-04-04 Donal K. Fellows - - * library/init.tcl (tcl::mathfunc::rmmadwiw): Disable by default to - make test suite work. - - * generic/tclBasic.c, generic/tclStringObj.c, generic/tclTimer.c, - * generic/tclTrace.c, generic/tclUtil.c: More generation of error - codes ([format], [after], [trace], RE optimizer). - -2011-04-04 Jan Nijtmans - - * generic/tclCmdAH.c: Better error-message in case of errors - * generic/tclCmdIL.c: related to setting a variable. This fixes - * generic/tclDictObj.c: a warning: "Why make your own error - * generic/tclScan.c: message? Why?" - * generic/tclTest.c: - * test/error.test: - * test/info.test: - * test/scan.test: - * unix/tclUnixThrd.h: Remove this unused header file. - -2011-04-03 Donal K. Fellows - - * generic/tclNamesp.c, generic/tclObj.c, generic/tclPathObj.c: - * generic/tclPipe.c, generic/tclPkg.c, generic/tclProc.c: - * generic/tclScan.c: More generation of error codes (namespace - creation, path normalization, pipeline creation, package handling, - procedures, [scan] formats) - 2011-04-02 Kevin B. Kenny * generic/tclStrToD.c (QuickConversion): Replaced another couple of 'double' declarations with 'volatile double' to work around misrounding issues in mingw-gcc 3.4.5. -2011-04-02 Donal K. Fellows - - * generic/tclInterp.c, generic/tclListObj.c, generic/tclLoad.c: - More generation of errorCodes ([interp], [lset], [load], [unload]). - - * generic/tclEvent.c, generic/tclFileName.c: More generation of - errorCode information (default [bgerror] and [glob]). - -2011-04-01 Reinhard Max - - * library/init.tcl: TIP#131 implementation. - -2011-03-31 Donal K. Fellows - - * generic/tclGetDate.y, generic/tclDate.c (TclClockOldscanObjCmd): - More generation of errorCode information. - -2011-03-28 Donal K. Fellows - - * generic/tclCmdMZ.c, generic/tclConfig.c, generic/tclUtil.c: More - generation of errorCode information, notably when lists are mis-parsed - - * generic/tclCmdMZ.c (Tcl_RegexpObjCmd, Tcl_RegsubObjCmd): Use the - error messages generated by the variable management code rather than - creating our own. - -2011-03-27 Miguel Sofer - - * generic/tclBasic.c (TclNREvalObjEx): fix performance issue, notably - apparent in tclbench's "LIST lset foreach". Many thanks to Twylite for - patiently researching the issue and explaining it to me: a missing - Tcl_ResetObjResult that causes unwanted sharing of the current result - Tcl_Obj. - -2011-03-26 Donal K. Fellows - - * generic/tclNamesp.c (Tcl_Export, Tcl_Import, DoImport): More - generation of errorCode information. - - * generic/tclCompExpr.c, generic/tclCompile.c, generic/tclExecute.c: - * generic/tclListObj.c, generic/tclNamesp.c, generic/tclObj.c: - * generic/tclStringObj.c, generic/tclUtil.c: Reduce the number of - casts used to manage Tcl_Obj internal representations. - -2011-03-24 Don Porter - - * generic/tcl.h (ckfree,etc.): Restored C++ usability to the memory - allocation and free macros. - 2011-03-24 Donal K. Fellows * generic/tclFCmd.c (TclFileAttrsCmd): Ensure that any reference to temporary index tables is squelched immediately rather than hanging around to trip us up in the future. -2011-03-23 Miguel Sofer - - * generic/tclObj.c: Exploit HAVE_FAST_TSD for the deletion context in - TclFreeObj() - -2011-03-22 Miguel Sofer - - * generic/tclThreadAlloc.c: Simpler initialization of Cache under - HAVE_FAST_TSD, from mig-alloc-reform. - 2011-03-21 Jan Nijtmans * unix/tclLoadDl.c: [Bug 3216070]: Loading extension libraries * unix/tclLoadDyld.c: from embedded Tcl applications. ***POTENTIAL INCOMPATIBILITY*** For extensions which rely on symbols from other extensions being present in the global symbol table. For an example and some discussion of workarounds, see http://stackoverflow.com/q/8330614/301832 -2011-03-21 Miguel Sofer - - * generic/tclCkAlloc.c: - * generic/tclInt.h: Remove one level of allocator indirection in - non-memdebug builds, imported from mig-alloc-reform. - -2011-03-20 Miguel Sofer - - * generic/tclThreadAlloc.c: Imported HAVE_FAST_TSD support from - mig-alloc-reform. The feature has to be enabled by hand: no autoconf - support has been added. It is not clear how universal a build using - this will be: it also requires some loader support. - -2011-03-17 Donal K. Fellows - - * generic/tclCompExpr.c (ParseExpr): Generate errorCode information on - failure to parse expressions. - -2011-03-17 Jan Nijtmans - - * generic/tclMain.c: [Patch 3124683]: Reorganize the platform-specific - stuff in (tcl|tk)Main.c. - 2011-03-16 Jan Nijtmans * generic/tclCkalloc.c: [Bug 3197864]: Pointer truncation on Win64 - TCL_MEM_DEBUG builds. + TCL_MEM_DEBUG builds 2011-03-16 Don Porter * generic/tclBasic.c: Some rewrites to eliminate calls to isspace() * generic/tclParse.c: and their /* INTL */ risk. @@ -3222,70 +1705,13 @@ * library/tzdata/Europe/Istanbul: * library/tzdata/Pacific/Apia: * library/tzdata/Pacific/Easter: * library/tzdata/Pacific/Honolulu: tzdata2011d - * generic/tclAssembly.c (BBEmitInstInt1): Changed parameter data types - in an effort to silence a MSVC warning reported by Ashok P. Nadkarni. - Unable to test, since both forms work on my machine in VC2005, 2008, - 2010, in both release and debug builds. - * tests/tclTest.c (TestdstringCmd): Restored MSVC buildability broken - by [5574bdd262], which changed the effective return type of 'ckalloc' - from 'char*' to 'void*'. - -2011-03-13 Miguel Sofer - - * generic/tclExecute.c: remove TEBCreturn() - -2011-03-12 Donal K. Fellows - - * generic/tcl.h (ckalloc,ckfree,ckrealloc): Moved casts into these - macro so that they work with VOID* (which is a void* on all platforms - which Tcl actually builds on) and unsigned int for the length - parameters, removing the need for MANY casts across the rest of Tcl. - Note that this is a strict source-level-only change, so size_t cannot - be used (would break binary compatibility on 64-bit platforms). - -2011-03-12 Jan Nijtmans - - * win/tclWinFile.c: [Bug 3185609]: File normalization corner case - of ... broken with -DUNICODE - -2011-03-11 Donal K. Fellows - - * tests/unixInit.test: Make better use of tcltest2. - -2011-03-10 Donal K. Fellows - - * generic/tclBasic.c, generic/tclCompCmds.c, generic/tclEnsemble.c: - * generic/tclInt.h, generic/tclNamesp.c, library/auto.tcl: - * tests/interp.test, tests/namespace.test, tests/nre.test: - Converted the [namespace] command into an ensemble. This has the - consequence of making it vital for Tcl code that wishes to work with - namespaces to _not_ delete the ::tcl namespace. - ***POTENTIAL INCOMPATIBILITY*** - - * library/tcltest/tcltest.tcl (loadIntoSlaveInterpreter): Added this - command to handle connecting tcltest to a slave interpreter. This adds - in the hook (inside the tcltest namespace) that allows the tests run - in the child interpreter to be reported as part of the main sequence - of test results. Bumped version of tcltest to 2.3.3. - * tests/init.test, tests/package.test: Adapted these test files to use - the new feature. - - * generic/tclAlloc.c, generic/tclCmdMZ.c, generic/tclCompExpr.c: - * generic/tclCompile.c, generic/tclEnv.c, generic/tclEvent.c: - * generic/tclIO.c, generic/tclIOCmd.c, generic/tclIORChan.c: - * generic/tclIORTrans.c, generic/tclLiteral.c, generic/tclNotify.c: - * generic/tclParse.c, generic/tclStringObj.c, generic/tclUtil.c: - * generic/tclZlib.c, unix/tclUnixFCmd.c, unix/tclUnixNotfy.c: - * unix/tclUnixPort.h, unix/tclXtNotify.c: Formatting fixes, mainly to - comments, so code better fits the style in the Engineering Manual. - -2011-03-09 Donal K. Fellows - - * tests/incr.test: Update more of the test suite to use Tcltest 2. + + * unix/configure.in: [Bug 3205320]: stack space detection defeated by inlining + * unix/configure: (autoconf-2.59) 2011-03-09 Don Porter * generic/tclNamesp.c: [Bug 3202171]: Tighten the detector of nested * tests/namespace.test: [namespace code] quoting that the quoted @@ -3292,42 +1718,26 @@ scripts function properly even in a namespace that contains a custom "namespace" command. * doc/tclvars.n: Formatting fix. Thanks to Pat Thotys. -2011-03-09 Donal K. Fellows - - * tests/dstring.test, tests/init.test, tests/link.test: Update more of - the test suite to use Tcltest 2. - 2011-03-08 Jan Nijtmans * generic/tclBasic.c: Fix gcc warnings: variable set but not used - * generic/tclProc.c: - * generic/tclIORChan.c: - * generic/tclIORTrans.c: - * generic/tclAssembly.c: Fix gcc warning: comparison between signed - and unsigned integer expressions 2011-03-08 Don Porter * generic/tclInt.h: Remove TclMarkList() routine, an experimental * generic/tclUtil.c: dead-end from the 8.5 alpha days. * generic/tclResult.c (ResetObjResult): [Bug 3202905]: Correct failure to clear invalid intrep. Thanks to Colin McDonald. -2011-03-08 Donal K. Fellows - - * generic/tclAssembly.c, tests/assemble.test: Migrate to use a style - more consistent with the rest of Tcl. - 2011-03-06 Don Porter * generic/tclBasic.c: More replacements of Tcl_UtfBackslash() calls * generic/tclCompile.c: with TclParseBackslash() where possible. - * generic/tclCompCmdsSZ.c: * generic/tclParse.c: * generic/tclUtil.c: * generic/tclUtil.c (TclFindElement): [Bug 3192636]: Guard escape sequence scans to not overrun the string end. @@ -3335,147 +1745,48 @@ 2011-03-05 Don Porter * generic/tclParse.c (TclParseBackslash): [Bug 3200987]: Correct * tests/parse.test: trunction checks in \x and \u substitutions. -2011-03-05 Miguel Sofer - - * generic/tclExecute.c (TclStackFree): insure that the execStack - satisfies "at most one free stack after the current one" when - consecutive reallocs caused the creation of intervening stacks. - -2011-03-05 Kevin B. Kenny - - * generic/tclAssembly.c (new file): - * generic/tclBasic.c (Tcl_CreateInterp): - * generic/tclInt.h: - * tests/assemble.test (new file): - * unix/Makefile.in: - * win/Makefile.in: - * win/makefile.vc: Merged dogeen-assembler-branch into HEAD. Since - all functional changes are in the tcl::unsupported namespace, there's - no reason to sequester this code on a separate branch. - -2011-03-05 Miguel Sofer - - * generic/tclExecute.c: Cleaner mem management for TEBCdata - - * generic/tclExecute.c: - * tests/nre.test: Renamed BottomData to TEBCdata, so that the name - refers to what it is rather than to its storage location. - - * generic/tclBasic.c: Renamed struct TEOV_callback to the more - * generic/tclCompExpr.c: descriptive NRE_callback. - * generic/tclCompile.c: - * generic/tclExecute.c: - * generic/tclInt.decls: - * generic/tclInt.h: - * generic/tclIntDecls.h: - * generic/tclTest.c: - -2011-03-04 Donal K. Fellows - - * generic/tclOOMethod.c (ProcedureMethodCompiledVarConnect) - (ProcedureMethodCompiledVarDelete): [Bug 3185009]: Keep references to - resolved object variables so that an unset doesn't leave any dangling - pointers for code to trip over. - -2011-03-01 Miguel Sofer - - * generic/tclBasic.c (TclNREvalObjv): Missing a variable declaration - in commented out non-optimised code, left for ref in checkin - [b97b771b6d] - -2011-03-03 Don Porter - - * generic/tclResult.c (Tcl_AppendResultVA): Use the directive - USE_INTERP_RESULT [TIP 330] to force compat with interp->result - access, instead of the improvised hack USE_DIRECT_INTERP_RESULT_ACCESS - from releases past. - -2011-03-01 Miguel Sofer - - * generic/tclCompCmdsSZ.c (TclCompileThrowCmd, TclCompileUnsetCmd): - fix leaks - - * generic/tclBasic.c: This is [Patch 3168398], - * generic/tclCompCmdsSZ.c: Joe Mistachkin's optimisation - * generic/tclExecute.c: of Tip #285 - * generic/tclInt.decls: - * generic/tclInt.h: - * generic/tclIntDecls.h: - * generic/tclInterp.c: - * generic/tclOODecls.h: - * generic/tclStubInit.c: - * win/makefile.vc: - - * generic/tclExecute.c (ExprObjCallback): Fix object leak - - * generic/tclExecute.c (TEBCresume): Store local var array and - constants in automatic vars to reduce indirection, slight perf - increase - - * generic/tclOOCall.c (TclOODeleteContext): Added missing '*' so that - trunk compiles. - - * generic/tclBasic.c (TclNRRunCallbacks): [Patch 3168229]: Don't do - the trampoline dance for commands that do not have an nreProc. - -2011-03-01 Donal K. Fellows - - * generic/tclOO.c (Tcl_NewObjectInstance, TclNRNewObjectInstance) - (TclOOObjectCmdCore, FinalizeObjectCall): - * generic/tclOOBasic.c (TclOO_Object_Destroy, AfterNRDestructor): - * generic/tclOOCall.c (TclOODeleteContext, TclOOGetCallContext): - Reorganization of call context reference count management so that code - is (mostly) simpler. - 2011-01-26 Donal K. Fellows * doc/RegExp.3: [Bug 3165108]: Corrected documentation of description of subexpression info in Tcl_RegExpInfo structure. 2011-01-25 Jan Nijtmans - * generic/tclPreserve.c: Don't miss 64-bit address bits in panic - message. - * win/tclWinChan.c: Fix various gcc-4.5.2 64-bit warning - * win/tclWinConsole.c: messages, e.g. by using full 64-bits for - * win/tclWinDde.c: socket fd's - * win/tclWinPipe.c: - * win/tclWinReg.c: - * win/tclWinSerial.c: - * win/tclWinSock.c: - * win/tclWinThrd.c: + * generic/tclCkalloc.c: [Bug 3129448]: Possible over-allocation on + * generic/tclHash.c: 64-bit platforms, part 2, backported + * generic/tclProc.c: strcpy->memcpy change but not change in any + struct. + +2011-01-19 Alexandre Ferrieux + + * generic/tclExecute.c: [Bug 3138178]: Backport of Miguel's 2010-09-22 + fix on 8.6 branch (decache stack info wherever ::errorInfo may be + updated, for trace sanity). 2011-01-19 Jan Nijtmans - * tools/genStubs.tcl: [FRQ 3159920]: Tcl_ObjPrintf() crashes with - * generic/tcl.decls bad format specifier. - * generic/tcl.h: - * generic/tclDecls.h: - -2011-01-18 Donal K. Fellows - - * generic/tclOOMethod.c (PushMethodCallFrame): [Bug 3001438]: Make - sure that the cmdPtr field of the procPtr is correct and relevant at - all times so that [info frame] can report sensible information about a - frame after a return to it from a recursive call, instead of probably - crashing (depending on what else has overwritten the Tcl stack!) + * tools/genStubs.tcl: Make sure to use CONST/VOID in stead of + * generic/tclIntDecls.h: const/void when appropriate. This allows to + * generic/tclIntPlatDecls.h:use const/void in the *.decls file always, + * generic/tclTomMathDecls.h:genStubs will do the right thing. 2011-01-18 Jan Nijtmans * generic/tclBasic.c: Various mismatches between Tcl_Panic * generic/tclCompCmds.c: format string and its arguments, - * generic/tclCompCmdsSZ.c: discovered thanks to [Bug 3159920] - * generic/tclCompExpr.c: - * generic/tclEnsemble.c: - * generic/tclPreserve.c: + * generic/tclCompExpr.c: discovered thanks to [Bug 3159920] + * generic/tclPreserve.c: (Backported) * generic/tclTest.c: 2011-01-17 Jan Nijtmans + * win/tcl.m4: handle --enable-64bit=ia64 for gcc. BACKPORT. + * win/configure: (autoconf-2.59) + * win/tclWin32Dll.c: [Patch 3059922]: fixes for mingw64 - gcc4.5.1 * generic/tclIOCmd.c: [Bug 3148192]: Commands "read/puts" incorrectly * tests/chanio.test: interpret parameters. Improved error-message * tests/io.test regarding legacy form. * tests/ioCmd.test @@ -3488,458 +1799,151 @@ compatibility for the formatting of floating point numbers when $::tcl_precision is not zero. Added compatibility tests to make sure that excess trailing zeroes are suppressed for all eight major code paths. -2011-01-12 Jan Nijtmans - - * win/tclWinFile.c: Use _vsnprintf in stead of vsnprintf, because - MSVC 6 doesn't have it. Reported by andreask. - * win/tcl.m4: handle --enable-64bit=ia64 for gcc - * win/configure.in: more accurate test for correct - * win/configure: (autoconf-2.59) - * win/tclWin32Dll.c: VS 2005 64-bit does not have intrin.h, and - * generic/tclPanic.c: does not need it. - -2011-01-07 Kevin B. Kenny - - * tests/util.test (util-15.*): Added test cases for floating point - conversion of the largest denormal and the smallest normal number, to - avoid any possibility of the failure suffered by PHP in the last - couple of days. (They didn't fail, so no actual functional change.) - -2011-01-05 Donal K. Fellows - - * tests/package.test, tests/pkg.test: Coalesce these tests into one - file that is concerned with the package system. Convert to use - tcltest2 properly. - * tests/autoMkindex.test, tests/pkgMkIndex.test: Convert to use - tcltest2 properly. - -2011-01-01 Donal K. Fellows - - * tests/cmdAH.test, tests/cmdMZ.test, tests/compExpr.test, - * tests/compile.test, tests/concat.test, tests/eval.test, - * tests/fileName.test, tests/fileSystem.test, tests/interp.test, - * tests/lsearch.test, tests/namespace-old.test, tests/namespace.test, - * tests/oo.test, tests/proc.test, tests/security.test, - * tests/switch.test, tests/unixInit.test, tests/var.test, - * tests/winDde.test, tests/winPipe.test: Clean up of tests and - conversion to tcltest 2. Target has been to get init and cleanup code - out of the test body and into the -setup/-cleanup stanzas. - - * tests/execute.test (execute-11.1): [Bug 3142026]: Added test that - fails (with a crash) in an unfixed memdebug build on 64-bit systems. - -2010-12-31 Donal K. Fellows - - * generic/tclCmdIL.c (SortElement): Use unions properly in the - definition of this structure so that there is no need to use nasty - int/pointer type punning. Made it clearer what the purposes of the - various parts of the structure are. - -2010-12-31 Jan Nijtmans - - * unix/dltest/*.c: [Bug 3148192]: Fix broken [load] tests by ensuring - that the affected files are never compiled with -DSTATIC_BUILD. - -2010-12-30 Miguel Sofer +2011-01-13 Miguel Sofer * generic/tclExecute.c (GrowEvaluationStack): Off-by-one error in sizing the new allocation - was ok in comment but wrong in the code. Triggered by [Bug 3142026] which happened to require exactly one more - than what was in existence. - -2010-12-26 Donal K. Fellows - - * generic/tclCmdIL.c (Tcl_LsortObjCmd): Fix crash when multiple -index - options are used. Simplified memory handling logic. - -2010-12-20 Jan Nijtmans - - * win/tclWin32Dll.c: [Patch 3059922]: fixes for mingw64 - gcc4.5.1 - tdm64-1: completed for all environments. - -2010-12-20 Jan Nijtmans - - * win/configure.in: Explicitely test for intrinsics support in - compiler, before assuming only MSVC has it. - * win/configure: (autoconf-2.59) - * generic/tclPanic.c: - -2010-12-19 Jan Nijtmans - - * win/tclWin32Dll.c: [Patch 3059922]: fixes for mingw64 - gcc4.5.1 - tdm64-1: Fixed for gcc, not yet for MSVC 64-bit. + than what was in existence. BACKPORT. + +2011-01-03 Jan Nijtmans + + * tools/genStubs.tcl: Fix "make genstubs", which was broken + since 2010-11-30, the TclDoubleDigits backport. + +2010-12-31 Jan Nijtmans + + * generic/tclHash.c: [Bug 3007895]: Tcl_(Find|Create)HashEntry + stub entries can never be called. They still cannot be called + (no change in functionality), but at least they now do + exactly the same as the Tcl_(Find|Create)HashEntry macro's, + so the confusion addressed in this Bug report is gone. + (Backported from Tcl 8.6) 2010-12-17 Stuart Cassoff * unix/Makefile.in: Remove unwanted/obsolete 'ddd' target. -2010-12-17 Stuart Cassoff - - * unix/Makefile.in: Clean up '.PHONY:' targets: Arrange those - common to Tcl and Tk as in Tk's Makefile.in, - add any missing ones and remove duplicates. - 2010-12-17 Stuart Cassoff * unix/Makefile.in: [Bug 2446711]: Remove 'allpatch' target. 2010-12-17 Stuart Cassoff * unix/Makefile.in: [Bug 2537626]: Use 'rpmbuild', not 'rpm'. -2010-12-16 Jan Nijtmans - - * generic/tclPanic.c: [Patch 3124554]: Move WishPanic from Tk to Tcl - * win/tclWinFile.c: Better communication with debugger, if present. - -2010-12-15 Kevin B. Kenny - - [dogeen-assembler-branch] - - * tclAssembly.c: - * assemble.test: Reworked beginCatch/endCatch handling to - enforce the more severe (but more correct) restrictions on catch - handling that appeared in the discussion of [Bug 3098302] and in - tcl-core traffic beginning about 2010-10-29. - -2010-12-15 Jan Nijtmans - - * generic/tclPanic.c: Restore abort() as it was before. - * win/tclWinFile.c: [Patch 3124554]: Use ExitProcess() here, like - in wish. - -2010-12-14 Jan Nijtmans - - * generic/tcl.h: [Bug 3137454]: Tcl CVS HEAD does not build on GCC 3. - -2010-12-14 Reinhard Max - - * win/tclWinSock.c (CreateSocket): Swap the loops over - * unix/tclUnixSock.c (CreateClientSocket): local and remote addresses, - so that the system's address preference for the remote side decides - which family gets tried first. Cleanup and clarify some of the - comments. - 2010-12-13 Jan Nijtmans - * generic/tcl.h: [Bug 3135271]: Link error due to hidden - * unix/tcl.m4: symbols (CentOS 4.2) - * unix/configure: (autoconf-2.59) - * win/tclWinFile.c: Undocumented feature, only meant to be used by - Tk_Main. See [Patch 3124554]: Move WishPanic from Tk to Tcl + * unix/tcl.m4: Cross-compile support for Win and UNIX (backported) + * unix/configure: (autoconf-2.59) + * win/tcl.m4: + * win/configure.in: + * win/configure: (autoconf-2.59) 2010-12-12 Stuart Cassoff * unix/tcl.m4: Better building on OpenBSD. * unix/configure: (autoconf-2.59) -2010-12-10 Jan Nijtmans - - * generic/tcl.h: [Bug 3129448]: Possible over-allocation on - * generic/tclCkalloc.c: 64-bit platforms, part 2 - * generic/tclCompile.c: - * generic/tclHash.c: - * generic/tclInt.h: - * generic/tclIO.h: - * generic/tclProc.c: - 2010-12-10 Alexandre Ferrieux - * generic/tclIO.c: Make sure [fcopy -size ... -command ...] always - * tests/io.test: calls the callback asynchronously, even for size - zero. - -2010-12-10 Jan Nijtmans - - * generic/tclBinary.c: Fix gcc -Wextra warning: missing initializer - * generic/tclCmdAH.c: - * generic/tclCmdIL.c: - * generic/tclCmdMZ.c: - * generic/tclDictObj.c: - * generic/tclIndexObj.c: - * generic/tclIOCmd.c: - * generic/tclVar.c: - * win/tcl.m4: Fix manifest-generation for 64-bit gcc - (mingw-w64) - * win/configure.in: Check for availability of intptr_t and - uintptr_t - * win/configure: (autoconf-2.59) - * generic/tclInt.decls: Change 1st param of TclSockMinimumBuffers - * generic/tclIntDecls.h: to ClientData, and TclWin(Get|Set)SockOpt - * generic/tclIntPlatDecls.h:to SOCKET, because on Win64 those are - * generic/tclIOSock.c: 64-bit, which does not fit. - * win/tclWinSock.c: - * unix/tclUnixSock.c: - -2010-12-09 Donal K. Fellows - - * tests/fCmd.test: Improve sanity of constraints now that we don't - support anything before Windows 2000. - - * generic/tclCmdAH.c (TclInitFileCmd, TclMakeFileCommandSafe, ...): - Break up [file] into an ensemble. Note that the ensemble is safe in - itself, but the majority of its subcommands are not. - * generic/tclFCmd.c (FileCopyRename,TclFileDeleteCmd,TclFileAttrsCmd) - (TclFileMakeDirsCmd): Adjust these subcommand implementations to work - inside an ensemble. - (TclFileLinkCmd, TclFileReadLinkCmd, TclFileTemporaryCmd): Move these - subcommand implementations from tclCmdAH.c, where they didn't really - belong. - * generic/tclIOCmd.c (TclChannelNamesCmd): Move to more appropriate - source file. - * generic/tclEnsemble.c (TclMakeEnsemble): Start of code to make - partially-safe ensembles. Currently does not function as expected due - to various shortcomings in how safe interpreters are constructed. - * tests/cmdAH.test, tests/fCmd.test, tests/interp.test: Test updates - to take into account systematization of error messages. - - * tests/append.test, tests/appendComp.test: Clean up tests so that - they don't leave things in the global environment (detected when doing - -singleproc testing). - -2010-12-07 Donal K. Fellows - - * tests/fCmd.test, tests/safe.test, tests/uplevel.test, - * tests/upvar.test, tests/var.test: Convert more tests to tcltest2 and - factor them to be easier to understand. - - * generic/tclStrToD.c: Tidy up code so that more #ifdef-fery is - quarantined at the front of the file and function headers follow the - modern Tcl style. - -2010-12-06 Jan Nijtmans - - * generic/tclBinary.c: [Bug 3129448]: Possible over-allocation on - * generic/tclCkalloc.c: 64-bit platforms. - * generic/tclTrace.c: - -2010-12-05 Jan Nijtmans - - * unix/tcl.m4: [Patch 3116490]: Cross-compile support for unix - * unix/configure: (autoconf-2.59) + * generic/tclIO.c: [backport] Make sure [fcopy -size ... -command ...] always + * tests/io.test: calls the callback asynchronously, even for size zero. 2010-12-03 Jeff Hobbs * generic/tclUtil.c (TclReToGlob): Add extra check for multiple inner *s that leads to poor recursive glob matching, defer to original RE instead. tclbench RE var backtrack. -2010-12-03 Jan Nijtmans - - * generic/tclUtil.c: Silence gcc warning when using -Wwrite-strings - * generic/tclStrToD.c: Silence gcc warning for non-IEEE platforms - * win/Makefile.in: [Patch 3116490]: Cross-compile Tcl mingw32 on unix - * win/tcl.m4: This makes it possible to cross-compile Tcl/Tk for - * win/configure.in: Windows (either 32-bit or 64-bit) out-of-the-box - * win/configure: on UNIX, using mingw-w64 build tools (If Itcl, - tdbc and Thread take over the latest tcl.m4, they can do that too). - 2010-12-01 Kevin B. Kenny * generic/tclStrToD.c (SetPrecisionLimits, TclDoubleDigits): [Bug 3124675]: Added meaningless initialization of 'i', 'ilim' and 'ilim1' to silence warnings from the C compiler about possible use of uninitialized variables, Added a panic to the 'switch' that assigns them, to assert that the 'default' case is impossible. -2010-12-01 Jan Nijtmans - - * generic/tclBasic.c: Fix gcc 64-bit warnings: cast from pointer to - * generic/tclHash.c: integer of different size. - * generic/tclTest.c: - * generic/tclThreadTest.c: - * generic/tclStrToD.c: Fix gcc(-4.5.2) warning: 'static' is not at - beginning of declaration. - * generic/tclPanic.c: Allow Tcl_Panic() to enter the debugger on win32 - * generic/tclCkalloc.c: Use Tcl_Panic() in stead of duplicating the - code. - -2010-11-30 Jeff Hobbs - - * generic/tclInt.decls, generic/tclInt.h, generic/tclIntDecls.h: - * generic/tclStubInit.c: TclFormatInt restored at slot 24 - * generic/tclUtil.c (TclFormatInt): restore TclFormatInt func from - 2005-07-05 macro-ization. Benchmarks indicate it is faster, as a key - int->string routine (e.g. int-indexed arrays). - -2010-11-29 Alexandre Ferrieux - - * generic/tclBasic.c: Patch by Miguel, providing a - [::tcl::unsupported::inject coroname command args], which prepends - ("injects") arbitrary code to a suspended coro's future resumption. - Neat for debugging complex coros without heavy instrumentation. - -2010-11-29 Kevin B. Kenny - - * generic/tclInt.decls: - * generic/tclInt.h: +2010-11-30 Andreas Kupries + + * generic/tclInt.decls: Backport of Kevin B. Kenny's work on + * generic/tclInt.h: the Tcl Head, with help from Jeff Hobbs. * generic/tclStrToD.c: * generic/tclTest.c: * generic/tclTomMath.decls: * generic/tclUtil.c: * tests/util.test: * unix/Makefile.in: * win/Makefile.in: - * win/makefile.vc: Rewrite of Tcl_PrintDouble and TclDoubleDigits that - (a) fixes a severe performance problem with floating point shimmering - reported by Karl Lehenbauer, (b) allows TclDoubleDigits to generate - the digit strings for 'e' and 'f' format, so that it can be used for - tcl_precision != 0 (and possibly later for [format]), (c) fixes [Bug - 3120139] by making TclPrintDouble inherently locale-independent, (d) - adds test cases to util.test for correct rounding in difficult cases - of TclDoubleDigits where fixed- precision results are requested. (e) - adds test cases to util.test for the controversial aspects of [Bug - 3105247]. As a side effect, two more modules from libtommath - (bn_mp_set_int.c and bn_mp_init_set_int.c) are brought into the build, - since the new code uses them. + * win/makefile.vc: Rewrite of Tcl_PrintDouble and TclDoubleDigits + that (a) fixes a severe performance problem with floating point + shimmering reported by Karl Lehenbauer, (b) allows TclDoubleDigits + to generate the digit strings for 'e' and 'f' format, so that it + can be used for tcl_precision != 0 (and possibly later for [format]), + (c) fixes [Bug 3120139] by making TclPrintDouble inherently + locale-independent, (d) adds test cases to util.test for + correct rounding in difficult cases of TclDoubleDigits where fixed- + precision results are requested. (e) adds test cases to util.test for + the controversial aspects of [Bug 3105247]. As a side effect, two + more modules from libtommath (bn_mp_set_int.c and bn_mp_init_set_int.c) + are brought into the build, since the new code uses them. * generic/tclIntDecls.h: * generic/tclStubInit.c: * generic/tclTomMathDecls.h: Regenerated. -2010-11-24 Donal K. Fellows - - * tests/chanio.test, tests/iogt.test, tests/ioTrans.test: Convert more - tests to tcltest2 and factor them to be easier to understand. - -2010-11-20 Donal K. Fellows - - * tests/chanio.test: Converted many tests to tcltest2 by marking the - setup and cleanup parts as such. +2010-11-30 Jeff Hobbs + + * generic/tclInt.decls, generic/tclInt.h, generic/tclIntDecls.h: + * generic/tclStubInit.c: TclFormatInt restored at slot 24 + * generic/tclUtil.c (TclFormatInt): restore TclFormatInt func from + 2005-07-05 macro-ization. Benchmarks indicate it is faster, as a + key int->string routine (e.g. int-indexed arrays). + +2010-11-23 Andreas Kupries + + * generic/tclVar.c (VarHashInvalidateEntry): Removed obsolete + patch for AIX defining this macro as function. This is not + necessary anymore. See ChangeLog entry 2010-07-28 (Bug 3037525) + for the actual bug and fix the patch was a workaround for. 2010-11-19 Jan Nijtmans - * win/tclWin32Dll.c: Fix gcc warnings: unused variable 'registration' + * generic/tclInterp.c: fix gcc warning: passing argument 3 of + 'Tcl_GetIndexFromObj' discards qualifiers from pointer target type + * generic/tclWinInit.c: fix gcc warning: dereferencing pointer + 'oemId' does break strict-aliasing rules + * win/tclWin32Dll.c: fix gcc warnings: unused variable 'registration' * win/tclWinChan.c: * win/tclWinFCmd.c: - -2010-11-18 Jan Nijtmans - - * win/tclAppInit.c: [FRQ 491789]: "setargv() doesn't support a unicode - cmdline" now implemented for cygwin and mingw32 too. - * tests/main.test: No longer disable tests Tcl_Main-1.4 and 1.6 on - Windows, because those now work on all supported platforms. - * win/configure.in: Set NO_VIZ=1 when zlib is compiled in libtcl, - this resolves compiler warnings in 64-bit and static builds. - * win/configure (regenerated) + * win/configure.in: Allow cross-compilation by default. (backported) + * win/tcl.m4: Use -pipe for gcc on win32 (backported) + * win/configure: (regenerated) 2010-11-18 Donal K. Fellows * doc/file.n: [Bug 3111298]: Typofix. - * tests/oo.test: [Bug 3111059]: Added testing that neatly trapped this - issue. - -2010-11-18 Miguel Sofer - - * generic/tclNamesp.c: [Bug 3111059]: Fix leak due to bad looping - construct. - -2010-11-17 Jan Nijtmans - - * win/tcl.m4: [FRQ 491789]: "setargv() doesn't support a unicode - cmdline" now implemented for mingw-w64 - * win/configure (re-generated) - 2010-11-16 Jan Nijtmans - * win/tclAppInit.c:Bring compilation under mingw-w64 a bit closer - * win/cat.c: to reality. See for what's missing: - * win/tcl.m4: - * win/configure: (re-generated) - * win/tclWinPort.h: [Bug 3110161]: Extensions using TCHAR don't + * generic/tclPlatDecls.h: [Bug 3110161]: Extensions using TCHAR don't compile on VS2005 SP1 2010-11-15 Andreas Kupries - * doc/interp.n: [Bug 3081184]: TIP #378. + * doc/interp.n: [Bug 3081184]: TIP #378 backport. * doc/tclvars.n: Performance fix for TIP #280. * generic/tclBasic.c: * generic/tclExecute.c: * generic/tclInt.h: * generic/tclInterp.c: * tests/info.test: * tests/interp.test: -2010-11-10 Andreas Kupries - - * changes: Updates for 8.6b2 release. - -2010-11-09 Donal K. Fellows - - * generic/tclOOMethod.c (ProcedureMethodVarResolver): [Bug 3105999]: - * tests/oo.test: Make sure that resolver structures that are - only temporarily needed get squelched. - -2010-11-05 Jan Nijtmans - - * generic/tclMain.c: Thanks, Kevin, for the fix, but this how it was - supposed to be (TCL_ASCII_MAIN is only supposed to be defined on - WIN32). - -2010-11-05 Kevin B. Kenny - - * generic/tclMain.c: Added missing conditional on _WIN32 around code - that messes around with the definition of _UNICODE, to correct a badly - broken Unix build from Jan's last commit. - -2010-11-04 Jan Nijtmans - - * generic/tclDecls.h: [FRQ 491789]: "setargv() doesn't support a - * generic/tclMain.c: unicode cmdline" implemented for Tcl on MSVC++ - * doc/Tcl_Main.3: - * win/tclAppInit.c: - * win/makefile.vc: - * win/Makefile.in: - * win/tclWin32Dll.c: Eliminate minor MSVC warning TCHAR -> char - conversion - -2010-11-04 Reinhard Max - - * tests/socket.test: Run the socket tests three times with the address - family set to any, inet, and inet6 respectively. Use constraints to - skip the tests if a family is found to be unsupported or not - configured on the local machine. Adjust the tests to dynamically adapt - to the address family that is being tested. - - Rework some of the tests to speed them up by avoiding (supposedly) - unneeded [after]s. - -2010-11-04 Stuart Cassoff - - * unix/Makefile.in: [Patch 3101127]: Installer Improvements. - * unix/install-sh: - -2010-11-04 Donal K. Fellows - - * tests/error.test (error-19.13): Another variation on testing for - issues in [try] compilation. - - * doc/Tcl.n (Variable substitution): [Bug 3099086]: Increase clarity - of explanation of what characters are actually permitted in variable - substitutions. Note that this does not constitute a change of - behavior; it is just an improvement of explanation. - -2010-11-04 Don Porter - - * changes: Updates for 8.6b2 release. (Thanks Andreas Kupries) - -2010-11-03 Jan Nijtmans - - * win/tclWinFcmd.c: [FRQ 2965056]: Windows build with -DUNICODE - * win/tclWinFile.c: (more clean-ups for pre-win2000 stuff) - * win/tclWinReg.c: - -2010-11-03 Donal K. Fellows - - * generic/tclCmdMZ.c (TryPostBody): Ensure that errors when setting - * tests/error.test (error-19.1[12]): message/opt capture variables get - reflected properly to the caller. - 2010-11-03 Kevin B. Kenny * generic/tclCompCmds.c (TclCompileCatchCmd): [Bug 3098302]: * tests/compile.test (compile-3.6): Reworked the compilation of the [catch] command so as to avoid placing any code that might throw an @@ -3957,203 +1961,25 @@ * library/tzdata/Asia/Hong_Kong: * library/tzdata/Pacific/Apia: * library/tzdata/Pacific/Fiji: Olson's tzdata2010o. -2010-10-29 Alexandre Ferrieux - - * generic/tclTimer.c: [Bug 2905784]: Stop small [after]s from - wasting CPU while keeping accuracy. - -2010-10-28 Kevin B. Kenny - - [dogeen-assembler-branch] - * generic/tclAssembly.c: - * tests/assembly.test (assemble-31.*): Added jump tables. - -2010-10-28 Don Porter - - * tests/http.test: [Bug 3097490]: Make http-4.15 pass in - isolation. - - * unix/tclUnixSock.c: [Bug 3093120]: Prevent calls of - freeaddrinfo(NULL) which can crash some - systems. Thanks Larry Virden. - -2010-10-26 Reinhard Max - - * Changelog.2008: Split off from Changelog. - * generic/tclIOSock.c (TclCreateSocketAddress): The interp != NULL - check is needed for ::tcl::unsupported::socketAF as well. - -2010-10-26 Donal K. Fellows - - * unix/tclUnixSock.c (TcpGetOptionProc): Prevent crash if interp is - * win/tclWinSock.c (TcpGetOptionProc): NULL (a legal situation). - -2010-10-26 Reinhard Max - - * unix/tclUnixSock.c (TcpGetOptionProc): Added support for - ::tcl::unsupported::noReverseDNS, which if set to any value, prevents - [fconfigure -sockname] and [fconfigure -peername] from doing - reverse DNS queries. - -2010-10-24 Kevin B. Kenny - - [dogeen-assembler-branch] - * generic/tclAssembly.c: - * tests/assembly.test (assemble-17.15): Reworked branch handling so - that forward branches can use jump1 (jumpTrue1, jumpFalse1). Added - test cases that the forward branches will expand to jump4, jumpTrue4, - jumpFalse4 when needed. - -2010-10-23 Kevin B. Kenny - - [dogeen-assembler-branch] - * generic/tclAssembly.h (removed): - Removed file that was included in only one - source file. - * generictclAssembly.c: Inlined tclAssembly.h. - -2010-10-17 Alexandre Ferrieux - - * doc/info.n: [Patch 2995655]: - * generic/tclBasic.c: Report inner contexts in [info errorstack] - * generic/tclCompCmds.c: - * generic/tclCompile.c: - * generic/tclCompile.h: - * generic/tclExecute.c: - * generic/tclInt.h: - * generic/tclNamesp.c: - * tests/error.test: - * tests/result.test: - -2010-10-20 Donal K. Fellows - - * generic/tclCompCmds.c (TclCompileDictForCmd): Update the compilation - * generic/tclCompile.c (tclInstructionTable): of [dict for] so that - * generic/tclExecute.c (TEBCresume): it no longer makes any - use of INST_DICT_DONE now that's not needed, and make it clearer in - the implementation of the instruction that it's just a deprecated form - of unset operation. Followup to my commit of 2010-10-16. - -2010-10-19 Donal K. Fellows - - * generic/tclZlib.c (Tcl_ZlibStreamGet): [Bug 3081008]: Ensure that - when a bytearray gets its internals entangled with zlib for more than - a passing moment, that bytearray will never be shimmered away. This - increases the amount of copying but is simple to get right, which is a - reasonable trade-off. - - * generic/tclStringObj.c (Tcl_AppendObjToObj): Added some special - cases so that most of the time when you build up a bytearray by - appending, it actually ends up being a bytearray rather than - shimmering back and forth to string. - - * tests/http11.test (check_crc): Use a simpler way to express the - functionality of this procedure. - - * generic/tclZlib.c: Purge code that wrote to the object returned by - Tcl_GetObjResult, as we don't want to do that anti-pattern no more. - -2010-10-18 Jan Nijtmans - - * tools/uniParse.tcl: [Bug 3085863]: tclUniData was 9 years old; - Ignore non-BMP characters and fix comment about UnicodeData.txt file. - * generic/regcomp.c: Fix comment - * tests/utf.test: Add some Unicode 6 testcases - -2010-10-17 Alexandre Ferrieux - - * doc/info.n: Document [info errorstack] faithfully. - -2010-10-16 Donal K. Fellows - - * generic/tclExecute.c (ReleaseDictIterator): Factored out the release - of the bytecode-level dictionary iterator information so that the - side-conditions on instruction issuing are simpler. - -2010-10-15 Jan Nijtmans - - * generic/reg_locale.c: [Bug 3085863]: tclUniData 9 years old: Updated - * generic/tclUniData.c: Unicode tables to latest UnicodeData.txt, - * tools/uniParse.tcl: corresponding with Unicode 6.0 (except for - out-of-range chars > 0xFFFF) - -2010-10-13 Don Porter - - * generic/tclCompile.c: Alternative fix for [Bugs 467523,983660] where - * generic/tclExecute.c: sharing of empty scripts is allowed again. - -2010-10-13 Jan Nijtmans - - * win/tclWinThrd.h: (removed) because it is just empty en used nowhere - * win/tcl.dsp - -2010-10-12 Jan Nijtmans - - * tools/uniClass.tcl: Spacing and comments: let uniClass.tcl - * generic/regc_locale.c: generation match better the current - (hand-modified) regc_locale.c - * tools/uniParse.tcl: Generate proper const qualifiers for - * generic/tclUniData.c: tclUniData.c - -2010-10-12 Reinhard Max - - * unix/tclUnixSock.c (CreateClientSocket): [Bug 3084338]: Fix a - memleak and refactor the calls to freeaddrinfo(). - -2010-10-11 Jan Nijtmans - - * win/tclWinDde.c: [FRQ 2965056]: Windows build with -DUNICODE - * win/tclWinReg.c: - * win/tclWinTest.c: More cleanups - * win/tclWinFile.c: Add netapi32 to the link line, so we no longer - * win/tcl.m4: have to use LoadLibrary to access those - functions. - * win/makefile.vc: - * win/configure: (Re-generate with autoconf-2.59) - * win/rules.vc Update for VS10 +2010-10-23 Jan Nijtmans + + * tools/uniParse.tcl: [Bug 3085863]: tclUniData 9 years old + * tools/uniClass.tcl: Upgrade everything to Unicode 6.0, except + * tests/utf.test: non-BMP characters > 0xFFFF + * generic/tclUniData.c: (re-generated) + * generic/regc_locale.c:(re-generated) + * generic/regcomp.c: fix comment + * win/rules.vc Update for VS10 2010-10-09 Miguel Sofer * generic/tclExecute.c: Fix overallocation of exec stack in TEBC (due to mixing numwords and numbytes) -2010-10-08 Jan Nijtmans - - * generic/tclIOSock.c: On Windows, use gai_strerrorA - -2010-10-06 Don Porter - - * tests/winPipe.test: Test hygiene with makeFile and removeFile. - - * generic/tclCompile.c: [Bug 3081065]: Prevent writing to the intrep - * tests/subst.test: fields of a freed Tcl_Obj. - -2010-10-06 Kevin B. Kenny - - [dogeen-assembler-branch] - - * generic/tclAssembly.c: - * generic/tclAssembly.h: - * tests/assemble.test: Added catches. Still needs a lot of testing. - -2010-10-02 Kevin B. Kenny - - [dogeen-assembler-branch] - - * generic/tclAssembly.c: - * generic/tclAssembly.h: - * tests/assemble.test: Added dictAppend, dictIncrImm, dictLappend, - dictSet, dictUnset, nop, regexp, nsupvar, upvar, and variable. - -2010-10-02 Donal K. Fellows - - * generic/tclExecute.c (TEBCresume): [Bug 3079830]: Added invalidation - of string representations of dictionaries in some cases. - 2010-10-01 Jeff Hobbs * generic/tclExecute.c (EvalStatsCmd): change 'evalstats' to return data to interp by default, or if given an arg, use that as filename to output to (accepts 'stdout' and 'stderr'). Fix output to print used @@ -4160,353 +1986,56 @@ inst count data. * generic/tclCkalloc.c: Change TclDumpMemoryInfo sig to allow objPtr * generic/tclInt.decls: as well as FILE* as output. * generic/tclIntDecls.h: -2010-10-01 Donal K. Fellows - - * generic/tclBasic.c, generic/tclClock.c, generic/tclEncoding.c, - * generic/tclEnv.c, generic/tclLoad.c, generic/tclNamesp.c, - * generic/tclObj.c, generic/tclRegexp.c, generic/tclResolve.c, - * generic/tclResult.c, generic/tclUtil.c, macosx/tclMacOSXFCmd.c: - More purging of strcpy() from locations where we already know the - length of the data being copied. - -2010-10-01 Kevin B. Kenny - - [dogeen-assembler-branch] - - * tests/assemble.test: - * generic/tclAssemble.h: - * generic/tclAssemble.c: Added listIn, listNotIn, and dictGet. - -2010-09-30 Kevin B. Kenny - - [dogeen-assembler-branch] - - * tests/assemble.test: Added tryCvtToNumeric and several more list - * generic/tclAssemble.c: operations. - * generic/tclAssemble.h: - -2010-09-29 Kevin B. Kenny - - [dogeen-assembler-branch] - - * tests/assemble.test: Completed conversion of tests to a - * generic/tclAssemble.c: "white box" structure that follows the - C code. Added missing safety checks on the operands of 'over' and - 'reverse' so that negative operand counts don't smash the stack. - -2010-09-29 Jan Nijtmans - - * unix/configure: Re-generate with autoconf-2.59 - * win/configure: - * generic/tclMain.c: Make compilable with -DUNICODE as well - -2010-09-28 Reinhard Max - - TIP #162 IMPLEMENTATION - - * doc/socket.n: Document the changes to the [socket] and - [fconfigure] commands. - - * generic/tclInt.h: Introduce TclCreateSocketAddress() as a - * generic/tclIOSock.c: replacement for the platform-dependent - * unix/tclUnixSock.c: TclpCreateSocketAddress() functions. Extend - * unix/tclUnixChan.c: the [socket] and [fconfigure] commands to - * unix/tclUnixPort.h: behave as proposed in TIP #162. This is the - * win/tclWinSock.c: core of what is required to support the use of - * win/tclWinPort.h: IPv6 sockets in Tcl. - - * compat/fake-rfc2553.c: A compat implementation of the APIs defined - * compat/fake-rfc2553.h: in RFC-2553 (getaddrinfo() and friends) on - top of the existing gethostbyname() etc. - * unix/configure.in: Test whether the fake-implementation is - * unix/tcl.m4: needed. - * unix/Makefile.in: Add a compile target for fake-rfc2553. - - * win/configure.in: Allow cross-compilation by default. - - * tests/socket.test: Improve the test suite to make more use of - * tests/remote.tcl: randomized ports to reduce interference with - tests running in parallel or other services on - the machine. - -2010-09-28 Kevin B. Kenny - - [dogeen-assembler-branch] - - * tests/assemble.test: Added more "white box" tests. - * generic/tclAssembly.c: Added the error checking and reporting - for undefined labels. Revised code so that no pointers into the - bytecode sequence are held (because the sequence can move!), - that no Tcl_HashEntry pointers are held (because the hash table - doesn't guarantee their stability!) and to eliminate the BBHash - table, which is merely additional information indexed by jump - labels and can just as easily be held in the 'label' structure. - Renamed shared structures to CamelCase, and renamed 'label' to - JumpLabel because other types of labels may eventually be possible. - -2010-09-27 Kevin B. Kenny - - [dogeen-assembler-branch] - - * tests/assemble.test: Added more "white box" tests. - * generic/tclAssembly.c: Fixed bugs exposed by the new tests. - (a) [eval] and [expr] had incorrect stack balance computed if - the arg was not a simple word. (b) [concat] accepted a negative - operand count. (c) [invoke] accepted a zero or negative operand - count. (d) more misspelt error messages. - Also replaced a funky NRCallTEBC with the new call - TclNRExecuteByteCode, necessitated by a merge with changes on the - HEAD. - -2010-09-26 Miguel Sofer - - * generic/tclBasic.c: [Patch 3072080] (minus the itcl - * generic/tclCmdIL.c: update): a saner NRE. - * generic/tclCompExpr.c: - * generic/tclCompile.c: This makes TclNRExecuteByteCode (ex TEBC) - * generic/tclCompile.h: to be a normal NRE citizen: it loses its - * generic/tclExecute.c: special status. - * generic/tclInt.decls: The logic flow within the BC engine is - * generic/tclInt.h: simplified considerably. - * generic/tclIntDecls.h: - * generic/tclObj.c: - * generic/tclProc.c: - * generic/tclTest.c: - - * generic/tclVar.c: Use the macro HasLocalVars everywhere - -2010-09-26 Miguel Sofer - - * generic/tclOOMethod.c (ProcedureMethodVarResolver): avoid code - duplication, let the runtime var resolver call the compiled var - resolver. - -2010-09-26 Kevin B. Kenny - - [dogeen-assembler-branch] - - * tests/assemble.test: Added many new tests moving toward a more - comprehensive test suite for the assembler. - * generic/tclAssembly.c: Fixed bugs exposed by the new tests: - (a) [bitnot] and [not] had incorrect operand counts. (b) - INST_CONCAT cannot concatenate zero objects. (c) misspelt error - messages. (d) the "assembly code" internal representation lacked - a duplicator, which caused double-frees of the Bytecode object - if assembly code ever was duplicated. - -2010-09-25 Kevin B. Kenny - - [dogeen-assembler-branch] - - * generic/tclAssembly.c: Massive refactoring of the assembler - * generic/tclAssembly.h: to use a Tcl-like syntax (and use - * tests/assemble.test: Tcl_ParseCommand to parse it). The - * tests/assemble1.bench: refactoring also ensures that - Tcl_Tokens in the assembler have string ranges inside the source - code, which allows for [eval] and [expr] assembler directives - that simply call TclCompileScript and TclCompileExpr recursively. - -2010-09-24 Jeff Hobbs - - * tests/stringComp.test: improved string eq/cmp test coverage - * generic/tclExecute.c (TclExecuteByteCode): merge INST_STR_CMP and - INST_STR_EQ/INST_STR_NEQ paths. Speeds up eq/ne/[string eq] with - obj-aware comparisons and eq/==/ne/!= with length equality check. - 2010-09-24 Andreas Kupries * tclWinsock.c: [Bug 3056775]: Fixed race condition between thread and internal co-thread access of a socket's structure because of the thread not using the socketListLock in TcpAccept(). Added documentation on how the module works to the top. -2010-09-23 Jan Nijtmans - - * generic/tclDecls.h: Make Tcl_SetPanicProc and Tcl_GetStringResult - * unix/tclAppInit.c: callable without stubs, just as Tcl_SetVar. - * win/tclAppInit.c: - 2010-09-23 Don Porter * generic/tclCmdAH.c: Fix cases where value returned by * generic/tclEvent.c: Tcl_GetReturnOptions() was leaked. * generic/tclMain.c: Thanks to Jeff Hobbs for discovery of the anti-pattern to seek and destroy. -2010-09-23 Jan Nijtmans - - * unix/tclAppInit.c: Make compilable with -DUNICODE (not activated - * win/tclAppInit.c: yet), many clean-ups in comments. - -2010-09-22 Miguel Sofer - - * generic/tclExecute: [Bug 3072640]: One more DECACHE_STACK_INFO() was - missing. - - * tests/execute.test: Added execute-10.3 for [Bug 3072640]. The test - causes a mem failure. - - * generic/tclExecute: Protect all possible writes to ::errorInfo or - ::errorCode with DECACHE_STACK_INFO(), as they could run traces. The - new calls to be protected are Tcl_ResetResult(), Tcl_SetErrorCode(), - IllegalExprOperandType(), TclExprFloatError(). The error was triggered - by [Patch 3072080]. - -2010-09-22 Jan Nijtmans - - * win/tcl.m4: Add kernel32 to LIBS, so the link line for - * win/configure: mingw is exactly the same as for MSVC++. - -2010-09-21 Jeff Hobbs - - * generic/tclExecute.c (TclExecuteByteCode): - * generic/tclOOMethod.c (ProcedureMethodCompiledVarConnect): - * generic/tclVar.c (TclLookupSimpleVar, CompareVarKeys): - * generic/tclPathObj.c (Tcl_FSGetNormalizedPath, Tcl_FSEqualPaths): - * generic/tclIOUtil.c (TclFSCwdPointerEquals): peephole opt - * generic/tclResult.c (TclMergeReturnOptions): Use memcmp where - applicable as possible speedup on some libc variants. - -2010-09-21 Kevin B. Kenny - - [BRANCH: dogeen-assembler-branch] - - * generic/tclAssembly.c (new file): - * generic/tclAssembly.h: - * generic/tclBasic.c (builtInCmds, Tcl_CreateInterp): - * generic/tclInt.h: - * tests/assemble.test (new file): - * tests/assemble1.bench (new file): - * unix/Makefile.in: - * win/Makefile.in: - * win/Makefile.vc: - Initial commit of Ozgur Dogan Ugurlu's (SF user: dogeen) - assembler for the Tcl bytecode language. - -2010-09-21 Jan Nijtmans - - * win/tclWinFile.c: Fix declaration after statement. - * win/tcl.m4: Add -Wdeclaration-after-statement, so this - * win/configure: mistake cannot happen again. - * win/tclWinFCmd.c: [Bug 3069278]: Breakage on head Windows - * win/tclWinPipe.c: triggered by install-tzdata, final fix - -2010-09-20 Jan Nijtmans - - * win/tclWinFCmd.c: Eliminate tclWinProcs->useWide everywhere, since - * win/tclWinFile.c: the value is always "1" on platforms >win95 - * win/tclWinPipe.c: - 2010-09-19 Donal K. Fellows * doc/file.n (file readlink): [Bug 3070580]: Typofix. -2010-09-18 Jan Nijtmans - - * win/tclWinFCmd.c [Bug 3069278]: Breakage on head Windows triggered - by install-tzdata. Temporary don't compile this with -DUNICODE, while - investigating this bug. - -2010-09-16 Jeff Hobbs - - * win/tclWinFile.c: Remove define of FINDEX_INFO_LEVELS as all - supported versions of compilers should now have it. - - * unix/Makefile.in: Do not pass current build env vars when using - NATIVE_TCLSH in targets. - -2010-09-16 Jan Nijtmans - - * generic/tclDecls.h: Make Tcl_FindExecutable() work in UNICODE - * generic/tclEncoding.c: compiles (windows-only) as well as ASCII. - * generic/tclStubInit.c: Needed for [FRQ 491789]: setargv() doesn't - support a unicode cmdline. - -2010-09-15 Donal K. Fellows - - * generic/tclBinary.c (TclAppendBytesToByteArray): [Bug 3067036]: Make - sure we never try to double zero repeatedly to get a buffer size. Also - added a check for sanity on the size of buffer being appended. - -2010-09-15 Don Porter - - * unix/Makefile.in: Revise `make dist` target to tolerate the - case of zero bundled packages. - -2010-09-15 Jan Nijtmans - - * tools/genStubs.tcl: [Patch 3034251]: Backport ttkGenStubs.tcl - * generic/tcl.decls: features to genStubs.tcl. Make the "generic" - * generic/tclInt.decls: argument in the *.decls files optional - * generic/tclOO.decls: (no change to any tcl*Decls.h files) - * generic/tclTomMath.decls: - This allows genStubs.tcl to generate the ttk stub files as well, while - keeping full compatibility with existing *.decls files. - -2010-09-14 Jan Nijtmans - - * win/tclWinPort.h: Allow all Win2000+ API entries in Tcl - * win/tclWin32Dll.c: Eliminate dynamical loading of advapi23 and - kernel32 symbols. - -2010-09-13 Jan Nijtmans - - * win/tclWinChan.c: Various clean-ups, converting from - * win/tclWinConsole.c: tclWinProc->xxxProc directly to Xxx - * win/tclWinInit.c: (no change in functionality) - * win/tclWinLoad.c: - * win/tclWinSerial.c: - * win/tclWinSock.c: - * tools/genStubs.tcl: Add scspec feature from ttkGenStubs.tcl - (no change in output for *Decls.h files) - -2010-09-10 Jan Nijtmans - - * win/tclWin32Dll.c: Partly revert yesterday's change, to make it work - on VC++ 6.0 again. - 2010-09-10 Donal K. Fellows * doc/regsub.n: [Bug 3063568]: Fix for gotcha in example due to Tcl's special handling of backslash-newline. Makes example slightly less pure, but more useful. -2010-09-09 Jan Nijtmans - - * win/makefile.vc: Mingw should always link with -ladvapi32. - * win/tcl.m4: - * win/configure: (regenerated) - * win/tclWinInt.h: Remove ascii variant of tkWinPocs table, it is - * win/tclWin32Dll.c: no longer necessary. Fix CreateProcess signature - * win/tclWinPipe.c: and remove unused GetModuleFileName and lstrcpy. - * win/tclWinPort.h: Mingw/cygwin fixes: should always be - included, and fix conflict in various macro values: Always force the - same values as in VC++. - -2010-09-08 Don Porter - - * win/tclWinChan.c: [Bug 3059922]: #ifdef protections to permit - * win/tclWinFCmd.c: builds with mingw on amd64 systems. Thanks to - "mescalinum" for reporting and testing. - 2010-09-08 Andreas Kupries + + *** 8.5.9 TAGGED FOR RELEASE *** * doc/tm.n: Added underscore to the set of characters accepted in module names. This is true for quite some time in the code, this change catches up the documentation. -2010-09-03 Donal K. Fellows - - * tools/tcltk-man2html.tcl (plus-pkgs): Improve the package - documentation search pattern to support the doctoos-generated - directory structure. - * tools/tcltk-man2html-utils.tcl (output-name): Made this more - resilient against misformatted NAME sections, induced by import of - Thread package documentation into Tcl doc tree. +2010-09-08 Don Porter + + * changes: Update for 8.5.9 release. + + * win/tclWin32Dll.c: #ifdef protections to permit builds with + * win/tclWinChan.c: mingw on amd64 systems. Thanks to "mescalinum" + * win/tclWinFCmd.c: for reporting and testing. + +2010-09-06 Stuart Cassoff + + * unix/configure.in, generic/tclIOUtil.c (Tcl_Stat): Updated so that + we do not assume that all unix systems have the POSIX blkcnt_t type, + since OpenBSD apparently does not. Backported from HEAD (2010-02-16). + * unix/configure: autoconf-2.59 2010-09-02 Andreas Kupries * doc/glob.n: Fixed documentation ambiguity regarding the handling of -join. @@ -4518,67 +2047,37 @@ 2010-09-01 Andreas Kupries * library/safe.tcl (safe::AliasGlob): Moved the command extending the actual glob command with a -directory flag to when we actually have a proper untranslated path, + +2010-09-01 Don Porter + + * changes: Update for 8.5.9 release. 2010-09-01 Andreas Kupries * generic/tclExecute.c: [Bug 3057639]: Applied patch by Jeff to make * generic/tclVar.c: the behaviour of lappend in bytecompiled mode * tests/append.test: consistent with direct-eval and 'append' * tests/appendComp.test: generally. Added tests (append*-9.*) showing the difference. - -2010-08-31 Jan Nijtmans - - * win/rules.vc: Typo (thanks to Twylite discovering - this) - * generic/tclStubLib.c: Revert to previous version: MSVC++ 6.0 - * generic/tclTomMathStubLib.c:cannot handle the new construct. - * generic/tcl.decls [Patch 2997642]: Many type casts needed - * generic/tclDecls.h: when using Tcl_Pkg* API. Remaining part. - * generic/tclPkg.c: - * generic/tclBasic.c: - * generic/tclTomMathInterface.c: - * doc/PkgRequire.3 + ***POTENTIAL INCOMPATIBILITY*** + +2010-09-01 Donal K. Fellows + + * tools/tcltk-man2html.tcl: Improve handling of cross-links for + options between Ttk manual pages. + + * doc/Tcl.n: Avoid nroff hazards when generating documentation. 2010-08-31 Andreas Kupries * win/tcl.m4: Applied patch by Jeff fixing issues with the manifest handling on Win64. * win/configure: Regenerated. -2010-08-30 Miguel Sofer - - * generic/tclBasic.c: [Bugs 3046594,3047235,3048771]: New - * generic/tclCmdAH.c: implementation for [tailcall] command: it now - * generic/tclCmdMZ.c: schedules the command and returns TCL_RETURN. - * generic/tclExecute.c: This fixes all issues with [catch] and [try]. - * generic/tclInt.h: Thanks dgp for exploring the dark corners. - * generic/tclNamesp.c: More thorough testing is required. - * tests/tailcall.test: - -2010-08-30 Jan Nijtmans - - * win/Makefile.in: [FRQ 2965056]: Windows build with -DUNICODE - * win/rules.vc: - * win/tclWinFCmd.c: Make sure that allocated TCHAR arrays are - * win/tclWinFile.c: always properly aligned as wchar_t, and - * win/tclWinPipe.c: not bigger than necessary. - * win/tclWinSock.c: - * win/tclWinDde.c: Those 3 files are not converted yet to be - * win/tclWinReg.c: built with -DUNICODE, so add a TODO. - * win/tclWinTest.c: - * generic/tcl.decls: [Patch 2997642]: Many type casts needed when - * generic/tclDecls.h: using Tcl_Pkg* API. Partly. - * generic/tclPkg.c: - * generic/tclStubLib.c: Demonstration how this change can benefit - code. - * generic/tclTomMathStubLib.c: - * doc/PkgRequire.3: - 2010-08-29 Donal K. Fellows * doc/dict.n: [Bug 3046999]: Corrected cross reference to array manpage to refer to (correct) existing subcommand. @@ -4592,116 +2091,36 @@ * win/configure, win/configure.in, win/tcl.m4: SC_EMBED_MANIFEST macro and --enable-embedded-manifest configure arg added to support manifest embedding where we know the magic. Help prevents DLL hell with MSVC8+. -2010-08-24 Jan Nijtmans - - * generic/tcl.decls: [Bug 3007895]: Tcl_(Find|Create)HashEntry - * generic/tclHash.c: stub entries can never be called. - * generic/tclDecls.h: - * generic/tclStubInit.c: [Patch 2994165]: Change signature of - Tcl_FSGetNativePath and TclpDeleteFile follow-up: move stub entry back - to original location. +2010-08-24 Don Porter + + * changes: Update for 8.5.9 release. 2010-08-23 Kevin B. Kenny * library/tzdata/Africa/Cairo: * library/tzdata/Asia/Gaza: Olson's tzdata2010l. -2010-08-22 Jan Nijtmans - - * generic/tclBasic.c: [Patch 3009403]: Signature of Tcl_GetHashKey, - * generic/tclBinary.c: Tcl_(Create|Find)HashEntry follow-up: - * generic/tclCmdIL.c: Remove many type casts which are no longer - * generic/tclCompile.c:necessary as a result of this signature change. - * generic/tclDictObj.c: - * generic/tclEncoding.c: - * generic/tclExecute.c: - * generic/tclInterp.c: - * generic/tclIOCmd.c: - * generic/tclObj.c: - * generic/tclProc.c: - * generic/tclTest.c: - * generic/tclTrace.c: - * generic/tclUtil.c: - * generic/tclVar.c: - -2010-08-21 Donal K. Fellows - - * doc/linsert.n: [Bug 3045123]: Make description of what is actually - happening more accurate. - -2010-08-21 Jan Nijtmans - - * tools/genStubs.tcl: [Patch 3034251]: Backport ttkGenStubs.tcl - features to genStubs.tcl, partly: Use void (*reserved$i)(void) = 0 - instead of void *reserved$i = NULL for unused stub entries, in case - pointer-to-function and pointer-to-object are different sizes. - * generic/tcl*Decls.h: (regenerated) - * generic/tcl*StubInit.c:(regenerated) - -2010-08-20 Jan Nijtmans - - * doc/Method.3: Fix definition of Tcl_MethodType. - 2010-08-19 Donal K. Fellows * generic/tclTrace.c (TraceExecutionObjCmd, TraceCommandObjCmd) (TraceVariableObjCmd): [Patch 3048354]: Use memcpy() instead of strcpy() to avoid buffer overflow; we have the correct length of data to copy anyway since we've just allocated the target buffer. -2010-08-18 Jan Nijtmans - - * tools/genStubs.tcl: [Patch 3034251]: Backport ttkGenStubs.tcl - features to genStubs.tcl, partly: remove unneeded ifdeffery and put - C++ guard around stubs pointer definition. - * generic/*Decls.h: (regenerated) - -2010-08-18 Miguel Sofer - - * generic/tclBasic.c: New redesign of [tailcall]: find - * generic/tclExecute.c: errors early on, so that errorInfo - * generic/tclInt.h: contains the proper info [Bug 3047235] - * generic/tclNamesp.c: - - * generic/tclCmdAH.c (TclNRTryObjCmd): [Bug 3046594]: Block - tailcalling out of the body of a non-bc'ed [try]. - - * generic/tclBasic.c: Redesign of [tailcall] to - * generic/tclCmdAH.c: (a) fix [Bug 3047235] - * generic/tclCompile.h: (b) enable fix for [Bug 3046594] - * generic/tclExecute.c: (c) enable recursive tailcalls - * generic/tclInt.h: - * generic/tclNamesp.c: - * tests/tailcall.test: - -2010-08-18 Donal K. Fellows - - * library/safe.tcl (AliasGlob): [Bug 3004191]: Restore safe [glob] to - working condition. - 2010-08-15 Donal K. Fellows * generic/tclProc.c (ProcWrongNumArgs): [Bug 3045010]: Make the handling of passing the wrong number of arguments to [apply] somewhat less verbose when a lambda term is present. -2010-08-14 Jan Nijtmans - - * compat/unicows: Remove completely, see [FRQ 2819611]. - * doc/FileSystem.3: [Patch 2994165]: Change signature of - * generic/tcl.decls Tcl_FSGetNativePath and TclpDeleteFile - * generic/tclDecls.h: - * generic/tclIOUtil.c: - * generic/tclStubInit.c: - * generic/tclInt.h: - * unix/tclUnixFCmd.c: - * win/tclWinFCmd.c: - * doc/Hash.3: [Patch 3009403]: Signature of Tcl_GetHashKey, - * generic/tcl.h: Tcl_(Create|Find)HashEntry +2010-08-12 Donal K. Fellows + + * generic/tclCmdMZ.c (Tcl_RegexpObjCmd): [Bug 2826551, Patch 2948425]: + Backport of updates to make handling of RE line anchors correct. 2010-08-11 Jeff Hobbs * unix/ldAix: Remove ancient (pre-4.2) AIX support * unix/configure: Regen with ac-2.59 @@ -4708,63 +2127,68 @@ * unix/configure.in, unix/tclConfig.sh.in, unix/Makefile.in: * unix/tcl.m4 (AIX): Remove the need for ldAIX, replace with -bexpall/-brtl. Remove TCL_EXP_FILE (export file) and other baggage that went with it. Remove pre-4 AIX build support. -2010-08-11 Miguel Sofer - - * generic/tclBasic.c (TclNRYieldToObjCmd): - * tests/coroutine.test: Fixed bad copypasta snafu. Thanks to Andy Goth - for finding the bug. - 2010-08-10 Jeff Hobbs * generic/tclUtil.c (TclByteArrayMatch): Patterns may not be null-terminated, so account for that. -2010-08-09 Don Porter +2010-08-05 Don Porter - * changes: Updates for 8.6b2 release. + * changes: Update for 8.5.9 release. 2010-08-04 Jeff Hobbs - * win/Makefile.in, win/makefile.bc, win/makefile.vc, win/tcl.dsp: - * win/tclWinPipe.c (TclpCreateProcess): - * win/stub16.c (removed): Removed Win9x tclpip8x.dll build and 16-bit - application loader stub support. Win9x is no longer supported. - - * win/tclWin32Dll.c (TclWinInit): Hard-enforce Windows 9x as an - unsupported platform with a panic. Code to support it still exists in - other files (to go away in time), but new APIs are being used that - don't exist on Win9x. - * unix/tclUnixFCmd.c: Adjust license header as per ftp://ftp.cs.berkeley.edu/pub/4bsd/README.Impt.License.Change * license.terms: Fix DFARs note for number-adjusted rights clause * win/tclWin32Dll.c (asciiProcs, unicodeProcs): * win/tclWinLoad.c (TclpDlopen): 'load' use LoadLibraryEx with * win/tclWinInt.h (TclWinProcs): LOAD_WITH_ALTERED_SEARCH_PATH to prefer dependent DLLs in same dir as loaded DLL. + ***POTENTIAL INCOMPATIBILITY*** * win/Makefile.in (%.${OBJEXT}): better implicit rules support + +2010-08-04 Don Porter + + * generic/tcl.h: Bump to 8.5.9 for release. + * library/init.tcl: + * tools/tcl.wse.in: + * unix/configure.in: + * unix/tcl.spec: + * win/configure.in: + * README: + + * unix/configure: autoconf-2.59 + * win/configure: + + * changes: Update for 8.5.9 release. 2010-08-04 Andreas Kupries - * generic/tclIORChan.c: [Bug 3034840]: Fixed reference counting in - * generic/tclIORTrans.c: InvokeTclMethod and callers. - * tests/ioTrans.test: + * generic/tclIORChan.c: [Bug 3034840]: Fixed reference counting + * tests/ioCmd.test: in InvokeTclMethod and callers. 2010-08-03 Andreas Kupries * tests/var.test (var-19.1): [Bug 3037525]: Added test demonstrating the local hashtable deletion crash and fix. - * tests/info.test (info-39.1): Added forward copy of test in 8.5 - branch about [Bug 2933089]. Should not fail, and doesn't, after - updating the line numbers to the changed position. + * tests/info.test (info-39.1, test_info_frame): Changed absolute to + relative frame adressing to handle difference between testing with + -singleproc 1 vs. the default -singleproc 0. Plus comment fix. The + test and issue are not relevant to the trunk, forward porting is not + required. + +2010-08-03 Don Porter + + * changes: Update for 8.5.9 release. 2010-08-02 Kevin B. Kenny * library/tzdata/America/Bahia_Banderas: * library/tzdata/Pacific/Chuuk: @@ -4773,136 +2197,53 @@ * library/tzdata/Europe/Helsinki: * library/tzdata/Pacific/Ponape: * library/tzdata/Pacific/Truk: * library/tzdata/Pacific/Yap: Olson's tzdata2010k. -2010-08-02 Miguel Sofer - - * generic/tclVar.c: Correcting bad port of [Bug 3037525] fix - 2010-07-28 Miguel Sofer * generic/tclVar.c: [Bug 3037525]: Lose fickle optimisation in TclDeleteVars (used for runtime-created locals) that caused crash. -2010-07-29 Jan Nijtmans - - * compat/zlib/win32/README.txt: Official build of zlib1.dll 1.2.5 is - * compat/zlib/win32/USAGE.txt: finally available, so put it in. - * compat/zlib/win32/zlib1.dll: - -2010-07-25 Donal K. Fellows - - * doc/http.n: Corrected description of location of one of the entries - in the state array. - -2010-07-24 Jan Nijtmans - - * generic/tclDecls.h: [Bug 3029891]: Functions that don't belong in - * generic/tclTest.c: the stub table. - * generic/tclBasic.c: From [Bug 3030870] make itcl 3.x built with - pre-8.6 work in 8.6: Relax the relation between Tcl_CallFrame and - CallFrame. - -2010-07-16 Donal K. Fellows - - * generic/tclBasic.c: Added more errorCode setting. - -2010-07-15 Donal K. Fellows - - * generic/tclExecute.c (TclExecuteByteCode): Ensure that [dict get] - * generic/tclDictObj.c (DictGetCmd): always generates an errorCode on - a failure to look up an entry. - -2010-07-11 Pat Thoyts - - * unix/configure: (regenerated) - * unix/configure.in: For the NATIVE_TCLSH variable use the autoconf - * unix/Makefile.in: SC_PROG_TCLSH to try and find a locally installed - native binary. This avoids manually fixing up when cross compiling. If - there is not one, revert to using the build product. - -2010-07-02 Don Porter - - * generic/tclInt.decs: Reverted to the original TIP 337 - implementation on what to do with the obsolete internal stub for - TclBackgroundException() (eliminate it!) - * generic/tclIntDecls.h: make genstubs - * generic/tclStubInit.c: - -2010-07-02 Jan Nijtmans - - * generic/tclInt.decls: [Bug 803489]: Tcl_FindNamespace problem in - * generic/tclIntDecls.h: the Stubs table - * generic/tclStubInit.c: +2010-07-25 Jan Nijtmans + + * generic/tclInt.h: [Bug 3030870]: Make itcl 3.x built with pre-8.6 + * generic/tclBasic.c: work in 8.6 revert tclInt.h to what it was + before, and relax the relation between Tcl_CallFrame and CallFrame. + +2010-07-17 Jan Nijtmans + + * generic/tcl.h: [Bug 3030870]: Make itcl 3.x built with pre-8.6 + * generic/tclInt.h: work in 8.6 2010-07-02 Donal K. Fellows * generic/tclExecute.c (IllegalExprOperandType): [Bug 3024379]: Made sure that errors caused by an argument to an operator being outside the domain of the operator all result in ::errorCode being ARITH DOMAIN and not NONE. -2010-07-01 Jan Nijtmans - - * win/rules.vc: [Bug 3020677]: wish can't link reg1.2 - * tools/checkLibraryDoc.tcl: formatting, spacing, cleanup unused - * tools/eolFix.tcl: variables; no change in generated output - * tools/fix_tommath_h.tcl: - * tools/genStubs.tcl: - * tools/index.tcl: - * tools/man2help2.tcl: - * tools/regexpTestLib.tcl: - * tools/tsdPerf.tcl: - * tools/uniClass.tcl: - * tools/uniParse.tcl: +2010-07-02 Jan Nijtmans + + * generic/tclIntDecls.h: [Bug 803489]: Tcl_FindNamespace problem in + the Stubs table. 2010-07-01 Donal K. Fellows * doc/mathop.n: [Bug 3023165]: Fix typo that was preventing proper rendering of the exclusive-or operator. 2010-06-28 Jan Nijtmans * generic/tclPosixStr.c: [Bug 3019634]: errno.h and tclWinPort.h have - conflicting definitions. Added messages for ENOTRECOVERABLE, EOTHER, - ECANCELED and EOWNERDEAD, and fixed various typing mistakes in other - messages. - -2010-06-25 Reinhard Max - - * tests/socket.test: Prevent a race condition during shutdown of the - remote test server that can cause a hang when the server is being run - in verbose mode. - -2010-06-24 Jan Nijtmans - - * win/tclWinPort.h: [Bug 3019634]: errno.h and tclWinPort.h have conflicting definitions. - ***POTENTIAL INCOMPATIBILITY*** - On win32, the correspondence between errno and the related error - message, as handled by Tcl_ErrnoMsg() changes. The error message is - kept the same, but the corresponding errno value might change. - 2010-06-22 Donal K. Fellows * generic/tclCmdIL.c (Tcl_LsetObjCmd): [Bug 3019351]: Corrected wrong args message. -2010-06-21 Jan Nijtmans - - * unix/tclLoadDl.c: Eliminate various unnecessary type casts, use - * unix/tclLoadNext.c: function typedefs whenever possible - * unix/tclUnixChan.c: - * unix/tclUnixFile.c: - * unix/tclUnixNotfy.c: - * unix/tclUnixSock.c: - * unix/tclUnixTest.c: - * unix/tclXtTest.c: - * generic/tclZlib.c: Remove hack needed for zlib 1.2.3 on win32 - 2010-06-18 Donal K. Fellows * library/init.tcl (auto_execok): [Bug 3017997]: Add .cmd to the default list of extensions that we can execute interactively. @@ -4909,269 +2250,63 @@ 2010-06-16 Jan Nijtmans * tools/loadICU.tcl: [Bug 3016135]: Traceback using clock format * library/msgs/he.msg: with locale of he_IL. - * generic/tcl.h: Simplify Tcl_AppInit and *_Init definitions, - * generic/tclInt.h: spacing. Change TclpThreadCreate and - * generic/tcl.decls: Tcl_CreateThread signature, making clear that - * generic/tclDecls.h: "proc" is a function pointer, as in all other - * generic/tclEvent.c: "proc" function parameters. - * generic/tclTestProcBodyObj.c: - * win/tclWinThrd.c: - * unix/tclUnixThrd.c: - * doc/Thread.3: - * doc/Class.3: Fix Tcl_ObjectMetadataType definition. - -2010-06-14 Jan Nijtmans - - * unix/Makefile.in: Fix compilation of xttest with 8.6 changes - * unix/tclXtNotify.c: - * unix/tclXtTest.c: - * generic/tclPipe.c: Fix gcc warning (with -fstrict-aliasing=2) - * library/auto.tcl: Spacing and style fixes. - * library/history.tcl: - * library/init.tcl: - * library/package.tcl: - * library/safe.tcl: - * library/tm.tcl: - -2010-06-13 Donal K. Fellows - - * tools/tcltk-man2html.tcl (make-man-pages): [Bug 3015327]: Make the - title of a manual page be stored relative to its resulting directory - name as well as its source filename. This was caused by both Tcl and a - contributed package ([incr Tcl]) defining an Object.3. Also corrected - the joining of strings in titles to avoid extra braces. - 2010-06-09 Andreas Kupries * library/platform/platform.tcl: Added OSX Intel 64bit * library/platform/pkgIndex.tcl: Package updated to version 1.0.9. * unix/Makefile.in: * win/Makefile.in: -2010-06-09 Jan Nijtmans - - * tools/tsdPerf.c: Fix export of symbol Tsdperf_Init, when using - -fvisibility=hidden. Make two functions static, eliminate some - unnecessary type casts. - * tools/configure.in: Update to Tcl 8.6 - * tools/configure: (regenerated) - * tools/.cvsignore new file - -2010-06-07 Alexandre Ferrieux - - * generic/tclExecute.c: Ensure proper reset of [info errorstack] even - * generic/tclNamesp.c: when compiling constant expr's with errors. - -2010-06-05 Miguel Sofer - - * generic/tclBasic.c: [Bug 3008307]: make callerPtr chains be - * generic/tclExecute.c: traversable accross coro boundaries. Add the - special coroutine CallFrame (partially reverting commit of - 2009-12-10), as it is needed for coroutines that do not push a CF, eg, - those with [eval] as command. Thanks to Colin McCormack (coldstore) - and Alexandre Ferrieux for the hard work on this. - -2010-06-03 Alexandre Ferrieux - - * generic/tclNamesp.c: Safer (and faster) computation of [uplevel] - * tests/error.test: offsets in TIP 348. Toplevel offsets no longer - * tests/result.test: overestimated. - -2010-06-02 Jan Nijtmans - - * generic/tclOO.h: BUILD_tcloo is never defined (leftover) - * win/makefile.bc: Don't set BUILD_tcloo (leftover) - See also entry below: 2008-06-01 Joe Mistachkin - -2010-06-01 Alexandre Ferrieux - - * generic/tclNamesp.c: Fix computation of [uplevel] offsets in TIP 348 - * tests/error.test: Only depend on callerPtr chaining now. - * tests/result.test: Needed for upcoming coro patch. - -2010-05-31 Jan Nijtmans - - * generic/tclVar.c: Eliminate some casts to (Tcl_HashTable *) - * generic/tclExecute.c: - * tests/fileSystem.test: Fix filesystem-5.1 test failure on CYGWIN - -2010-05-28 Jan Nijtmans - - * generic/tclInt.h: [Patch 3008541]: Order of TIP #348 fields in - Interp structure - -2010-05-28 Donal K. Fellows - - * generic/tclCompCmdsSZ.c (IssueTryFinallyInstructions): [3007374]: - Corrected error in handling of catch contexts to prevent crash with - chained handlers. - - * generic/tclExecute.c (TclExecuteByteCode): Restore correct operation - of instruction-level execution tracing (had been broken by NRE). - -2010-05-27 Jan Nijtmans - - * library/opt/optParse.tcl: Don't generate spaces at the end of a - * library/opt/pkgIndex.tcl: line, eliminate ';' at line end, bump to - * tools/uniParse.tcl: v0.4.6 - * generic/tclUniData.c: - * tests/opt.test: - * tests/safe.test: +2010-05-26 Donal K. Fellows + + * doc/socket.n: [Bug 3007442]: Server sockets never took a host + argument, so the list of options must precede the port argument. + +2010-05-25 Jan Nijtmans + + * unix/tclUnixPort.h: [Bug 2991415]: tclport.h #included before + * win/tclWinPort.h: limits.h + * generic/tclInt.h: 2010-05-21 Jan Nijtmans - * tools/installData.tcl: Make sure that copyDir only receives - normalized paths, otherwise it might result in a crash on CYGWIN. - Restyle according to the Tcl style guide. - * generic/tclStrToD.c: [Bug 3005233]: Fix for build on OpenBSD vax - -2010-05-19 Alexandre Ferrieux - - * tests/dict.test: Add missing tests for [Bug 3004007], fixed under - the radar on 2010-02-24 (dkf): EIAS violation in list-dict conversions - -2010-05-19 Jan Nijtmans - - * generic/regcomp.c: Don't use arrays of length 1, just use a - * generic/tclFileName.c: single element then, it makes code more - * generic/tclLoad.c: readable. (Here it even prevents a type cast) - -2010-05-17 Jan Nijtmans - - * generic/tclStrToD.c: [Bug 2996549]: Failure in expr.test on Win32 - -2010-05-17 Donal K. Fellows - - * generic/tclCmdIL.c (TclInfoFrame): Change this code to use - Tcl_GetCommandFullName rather than rolling its own. Discovered during - the hunting of [Bug 3001438] but unlikely to be a fix. - -2010-05-11 Jan Nijtmans - - * win/tclWinConsole.c: [Patch 2997087]: Unnecessary type casts. - * win/tclWinDde.c: - * win/tclWinLoad.c: + * tools/installData.tcl: Make sure that copyDir only receives + normalized paths. Backported from trunk. + * generic/tclPlatDecls.h: Fix inclusion for CYGWIN. + Backported from trunk (although for trunk this was moved to + tclWinPort.h) + * generic/tclPathObj.c: Fix Tcl_SetStringObj usage for CYGWIN. This + function can only be used with unshared objects. This causes a crash + on CYGWIN. (backported from trunk) + * generic/tclFileName.c: Don't declare cygwin_conv_to_win32_path here + * win/tclWinChan.c: Fix various minor other gcc warnings, like + * win/tclWinConsole.c: signed<->unsigned mismatch. Backported from + * win/tclWinDde.c: trunk. * win/tclWinNotify.c: - * win/tclWinSerial.c: - * win/tclWinSock.c: - * win/tclWinTime.c: - * win/tclWinPort.h: Don't duplicate CYGWIN timezone #define from - tclPort.h + * generic/tclStrToD.c: [Bug 3005233]: fix for build on OpenBSD vax + +2010-05-19 Alexandre Ferrieux + + * generic/tclDictObj.c: Backport of fix for [Bug 3004007], EIAS + * tests/dict.test: violation in list-dict conversions. 2010-05-07 Andreas Kupries * library/platform/platform.tcl: Fix cpu name for Solaris/Intel 64bit. * library/platform/pkgIndex.tcl: Package updated to version 1.0.8. * unix/Makefile.in: * win/Makefile.in: -2010-05-06 Jan Nijtmans - - * generic/tclPkg.c: Unnecessary type casts, see [Patch 2997087] - -2010-05-04 Jan Nijtmans - - * win/tclWinNotify.c: TCHAR-related fixes, making those two files - * win/tclWinSock.c: compile fine when TCHAR != char. Please see - comments in [FRQ 2965056] (2965056-1.patch). - -2010-05-03 Jan Nijtmans - - * generic/tclIORChan.c: Use "tclIO.h" and "tclTomMathDecls.h" - * generic/tclIORTrans.c: everywhere - * generic/tclTomMath.h: - * tools/fix_tommath_h.tcl: - * libtommath/tommath.h: Formatting (# should always be first char on - line) - * win/tclAppInit.c: For MINGW/CYGWIN, use GetCommandLineA - explicitly. - * unix/.cvsignore: Add pkg, *.dll - - * libtommath/tommath.h: CONSTify various useful internal - * libtommath/bn_mp_cmp_d.c: functions (TclBignumToDouble, TclCeil, - * libtommath/bn_mp_cmp_mag.c: TclFloor), and related tommath functions - * libtommath/bn_mp_cmp.c: - * libtommath/bn_mp_copy.c: - * libtommath/bn_mp_count_bits.c: - * libtommath/bn_mp_div_2d.c: - * libtommath/bn_mp_mod_2d.c: - * libtommath/bn_mp_mul_2d.c: - * libtommath/bn_mp_neg.c: - * generic/tclBasic.c: Handle TODO: const correctness ? - * generic/tclInt.h: - * generic/tclStrToD.c: - * generic/tclTomMath.decls: - * generic/tclTomMath.h: - * generic/tclTomMathDecls.h: - 2010-04-30 Don Porter - * generic/tcl.h: Bump patchlevel to 8.6b1.2 to distinguish - * library/init.tcl: CVS snapshots from earlier snapshots as well - * unix/configure.in: as the 8.6b1 and 8.6b2 releases. - * win/configure.in: - - * unix/configure: autoconf-2.59 - * win/configure: - - * generic/tclBinary.c (TclAppendBytesToByteArray): Add comments - * generic/tclInt.h (TclAppendBytesToByteArray): placing overflow - protection responsibility on caller. Convert "len" argument to signed - int which any value already vetted for overflow issues will fit into. - * generic/tclStringObj.c: Update caller; standardize panic msg. - - * generic/tclBinary.c (UpdateStringOfByteArray): [Bug 2994924]: Add + * generic/tclBinary.c (UpdateStringOfByteArray): [Bug 2994924]: Add panic when the generated string representation would grow beyond Tcl's size limits. -2010-04-30 Donal K. Fellows - - * generic/tclBinary.c (TclAppendBytesToByteArray): Add extra armour - against buffer overflows. - - * generic/tclBasic.c (NRInterpCoroutine): Corrected handling of - * tests/coroutine.test (coroutine-6.4): arguments to deal with - trickier cases. - -2010-04-30 Miguel Sofer - - * tests/coroutine.test: testing coroutine arguments after [yield]: - check that only 0/1 allowed - -2010-04-30 Donal K. Fellows - - * generic/tclBasic.c (NRInterpCoroutine): Corrected handling of - arguments to deal with trickier cases. - - * generic/tclCompCmds.c (TclCompileVariableCmd): Slightly tighter - issuing of instructions. - - * generic/tclExecute.c (TclExecuteByteCode): Add peephole optimization - of the fact that INST_DICT_FIRST and INST_DICT_NEXT always have a - conditional jump afterwards. - - * generic/tclBasic.c (TclNRYieldObjCmd, TclNRYieldmObjCmd) - (NRInterpCoroutine): Replace magic values for formal argument counts - for coroutine command implementations with #defines, for an increase - in readability. - -2010-04-30 Jan Nijtmans - - * generic/tclMain.c: Unnecessary TCL_STORAGE_CLASS re-definition. It - was used for an ancient dummy reference to Tcl_LinkVar(), but that's - already gone since 2002-05-29. - -2010-04-29 Miguel Sofer - - * generic/tclCompExpr.c: Slight change in the literal sharing - * generic/tclCompile.c: mechanism to avoid shimmering of - * generic/tclCompile.h: command names. - * generic/tclLiteral.c: - 2010-04-29 Andreas Kupries * library/platform/platform.tcl: Another stab at getting the /lib, * library/platform/pkgIndex.tcl: /lib64 difference right for linux. * unix/Makefile.in: Package updated to version 1.0.7. @@ -5196,289 +2331,46 @@ * library/tzdata/Europe/Samara: * library/tzdata/Pacific/Apia: * library/tzdata/Pacific/Easter: * library/tzdata/Pacific/Fiji: Olson's tzdata2010i. -2010-04-29 Donal K. Fellows - - * generic/tclBinary.c (TclAppendBytesToByteArray): [Bug 2992970]: Make - * generic/tclStringObj.c (Tcl_AppendObjToObj): an append of a byte - array to another into an efficent operation. The problem was the (lack - of) a proper growth management strategy for the byte array. - -2010-04-29 Jan Nijtmans - - * compat/dirent2.h: Include "tcl.h", not , like everywhere - * compat/dlfcn.h: else, to ensure that the version in the Tcl - * compat/stdlib.h: distribution is used, not some version from - * compat/string.h: somewhere else. - * compat/unistd.h: - -2010-04-28 Jan Nijtmans - - * win/Makefile.in: Remove unused @MAN2TCLFLAGS@ - * win/tclWinPort.h: Move include from tclInt.h to - * generic/tclInt.h: tclWinPort.h, and eliminate unneeded - * generic/tclEnv.c: , and , which - are already in tclInt.h - * generic/regcustom.h: Move "tclInt.h" from regcustom.h up to - * generic/regex.h: regex.h. - * generic/tclAlloc.c: Unneeded include. - * generic/tclExecute.c: Fix gcc warning: comparison between signed and - unsigned. - -2010-04-28 Donal K. Fellows - - * generic/tclInt.h (TclIsVarDirectUnsettable): Corrected flags so that - deletion of traces is not optimized out... - - * generic/tclExecute.c (ExecuteExtendedBinaryMathOp) - (TclCompareTwoNumbers,ExecuteExtendedUnaryMathOp,TclExecuteByteCode): - [Patch 2981677]: Move the less common arithmetic operations (i.e., - exponentiation and operations on non-longs) out of TEBC for a big drop - in the overall size of the stack frame for most code. Net effect on - speed is minimal (slightly faster overall in tclbench). Also extended - the number of places where TRESULT handling is replaced with a jump to - dedicated code. - -2010-04-27 Donal K. Fellows - - * generic/tclExecute.c (TclExecuteByteCode): Rearrange location of an - assignment to shorten the object code. - -2010-04-27 Jan Nijtmans - - * generic/tclIOUtil.c (Tcl_FSGetNativePath): [Bug 2992292]: - tclIOUtil.c assignment type mismatch compiler warning - * generic/regguts.h: If tclInt.h or tclPort.h is already - * generic/tclBasic.c: included, don't include - * generic/tclExecute.c: again. Follow-up to [Bug 2991415]: - * generic/tclIORChan.c: tclport.h #included before limits.h - * generic/tclIORTrans.c: See comments in [Bug 2991415] - * generic/tclObj.c: - * generic/tclOOInt.h: - * generic/tclStrToD.c: - * generic/tclTomMath.h: - * generic/tclTomMathInterface.c: - * generic/tclUtil.c: - * compat/strtod.c: - * compat/strtol.c: - -2010-04-27 Kevin B. Kenny - - * unix/tclLoadDl.c (FindSymbol): [Bug 2992295]: Simplified the logic - so that the casts added in Donal Fellows's change for the same bug are - no longer necessary. - -2010-04-26 Donal K. Fellows - - * unix/tclLoadDl.c (FindSymbol): [Bug 2992295]: Added an explicit cast - because auto-casting between function and non-function types is never - naturally warning-free. - - * generic/tclStubInit.c: Add a small amount of gcc-isms (with #ifdef - * generic/tclOOStubInit.c: guards) to ensure that warnings are issued - when these files are older than the various *.decls files. - -2010-04-25 Miguel Sofer - - * generic/tclBasic.c: Add unsupported [yieldm] command. Credit - * generic/tclInt.h: Lars Hellstrom for the basic idea. - -2010-04-24 Miguel Sofer - - * generic/tclBasic.c: Modify api of TclSpliceTailcall() to fix - * generic/tclExecute.c: [yieldTo], which had not survived the latest - * generic/tclInt.h: mods to tailcall. Thanks kbk for detecting - the problem. - -2010-04-23 Jan Nijtmans - - * unix/tclUnixPort.h: [Bug 2991415]: tclport.h #included before - limits.h - -2010-04-22 Jan Nijtmans - - * generic/tclPlatDecls.h: Move TCHAR fallback typedef from tcl.h to - * generic/tcl.h: tclPlatDecls.h (as suggested by dgp) - * generic/tclInt.h: fix typo - * generic/tclIOUtil.c: Eliminate various unnecessary - * unix/tclUnixFile.c: type casts. - * unix/tclUnixPipe.c: - * win/tclWinChan.c: - * win/tclWinFCmd.c: - * win/tclWinFile.c: - * win/tclWinLoad.c: - * win/tclWinPipe.c: - -2010-04-20 Jan Nijtmans - - * generic/tclTest.c: Use function prototypes from the FS API. - * compat/zlib/*: Upgrade to zlib 1.2.5 - -2010-04-19 Donal K. Fellows - - * generic/tclExecute.c (TclExecuteByteCode): Improve commenting and - reduce indentation for the Invocation Block. +2010-04-19 Jan Nijtmans + + * win/tclWinPort.h: [Patch 2986105]: Conditionally defining + * win/tclWinFile.c: strcasecmp/strncasecmp 2010-04-18 Donal K. Fellows * doc/unset.n: [Bug 2988940]: Fix typo. -2010-04-15 Jan Nijtmans - - * win/tclWinPort.h: Move inclusion of from - * generic/tcl.h: tclPlatDecls.h to tclWinPort.h, where it - * generic/tclPlatDecls.h: belongs. Add fallback in tcl.h, so TCHAR is - available in win32 always. - -2010-04-15 Donal K. Fellows - - * doc/try.n: [Bug 2987551]: Fix typo. - 2010-04-14 Andreas Kupries * library/platform/platform.tcl: Linux platform identification: * library/platform/pkgIndex.tcl: Check /lib64 for existence of files * unix/Makefile.in: matching libc* before accepting it as base * win/Makefile.in: directory. This can happen on weirdly installed 32bit systems which have an empty or partially filled /lib64 without an actual libc. Bumped to version 1.0.6. -2010-04-13 Jan Nijtmans - - * win/tclWinPort.h: Fix [Patch 2986105]: conditionally defining - * win/tclWinFile.c: strcasecmp/strncasecmp - * win/tclWinLoad.c: Fix gcc warning: comparison of unsigned expression - >= 0 is always true - -2010-04-08 Donal K. Fellows - - * generic/tclCompCmdsSZ.c (TclSubstCompile): If the first token does - not result in a *guaranteed* push of a Tcl_Obj on the stack, we must - push an empty object. Otherwise it is possible to get to a 'concat1' - or 'done' without enough values on the stack, resulting in a crash. - Thanks to Joe Mistachkin for identifying a script that could trigger - this case. - -2010-04-07 Donal K. Fellows - - * doc/catch.n, doc/info.n, doc/return.n: Formatting. - -2010-04-06 Donal K. Fellows - - * doc/Load.3: Minor corrections of formatting and cross links. - -2010-04-06 Jan Nijtmans - - * win/configure: (regenerate with autoconf-2.59) - * unix/configure: - * unix/installManPage: [Bug 2982540]: configure and install* script - * unix/install-sh: files should always have LF line ending. - * doc/Load.3: Fix signature of Tcl_LoadFile in documentation. - -2010-04-05 Alexandre Ferrieux - - TIP #348 IMPLEMENTATION - - * generic/tclBasic.c: [Patch 2868499]: Substituted error stack - * generic/tclCmdIL.c: - * generic/tclInt.h: - * generic/tclNamesp.c: - * generic/tclResult.c: - * doc/catch.n: - * doc/info.n: - * doc/return.n: - * tests/cmdMZ.test: - * tests/error.test: - * tests/execute.test: - * tests/info.test: - * tests/init.test: - * tests/result.test: - -2010-04-05 Donal K. Fellows - - * unix/tcl.m4 (SC_ENABLE_THREADS): Flip the default for whether to - * win/tcl.m4 (SC_ENABLE_THREADS): build in threaded mode. Part of - * win/rules.vc: TIP #364. - - * unix/tclLoadDyld.c (FindSymbol): Better human-readable error message - generation to match code in tclLoadDl.c. - -2010-04-04 Donal K. Fellows - - * generic/tclIOUtil.c, unix/tclLoadDl.c: Minor changes to enforce - Engineering Manual style rules. - - * doc/FileSystem.3, doc/Load.3: Documentation for TIP#357. - - * macosx/tclMacOSXBundle.c (OpenResourceMap): [Bug 2981528]: Only - define this function when HAVE_COREFOUNDATION is defined. - -2010-04-02 Jan Nijtmans - - * generic/tcl.decls (Tcl_LoadFile): Add missing "const" in signature, - * generic/tclIOUtil.c (Tcl_LoadFile): and some formatting fixes - * generic/tclDecls.h: (regenerated) - -2010-04-02 Donal K. Fellows - - * generic/tclIOUtil.c (Tcl_LoadFile): Corrections to previous commit - * unix/tclLoadDyld.c (TclpDlopen): to make it build on OSX. - -2010-04-02 Kevin B. Kenny - - TIP #357 IMPLEMENTATION - TIP #362 IMPLEMENTATION - - * generic/tclStrToD.c: [Bug 2952904]: Defer creation of the smallest - floating point number until it is actually used. (This change avoids a - bogus syslog message regarding a 'floating point software assist - fault' on SGI systems.) - - * library/reg/pkgIndex.tcl: [TIP #362]: Fixed first round of bugs - * tests/registry.test: resulting from the recent commits of - * win/tclWinReg.c: changes in support of the referenced - TIP. - - * generic/tcl.decls: [TIP #357]: First round of changes - * generic/tclDecls.h: to export Tcl_LoadFile, - * generic/tclIOUtil.c: Tcl_FindSymbol, and Tcl_FSUnloadFile - * generic/tclInt.h: to the public API. - * generic/tclLoad.c: - * generic/tclLoadNone.c: - * generic/tclStubInit.c: - * tests/fileSystem.test: - * tests/load.test: - * tests/unload.test: - * unix/tclLoadDl.c: - * unix/tclLoadDyld.c: - * unix/tclLoadNext.c: - * unix/tclLoadOSF.c: - * unix/tclLoadShl.c: - * unix/tclUnixPipe.c: - * win/Makefile.in: - * win/tclWinLoad.c: +2010-04-03 Zoran Vasiljevic + + * generic/tclStringObj.c: (SetStringFromAny): avoid trampling + over the tclEmptyStringRep as it is thread-shared. + + * generic/tclThreadStorage.c (ThreadStorageGetHashTable): + avoid accessing shared table index w/o mutex protection + if VALGRIND defined on compilation time. This rules out + helgrind complains about potential race-conditions at + that place. + + Thanks to Gustaf Neumann for the (hard) work. 2010-03-31 Donal K. Fellows - * doc/registry.n: Added missing documentation of TIP#362 flags. - * doc/package.n: [Bug 2980210]: Document the arguments taken by the [package present] command correctly. - * doc/Thread.3: Added some better documentation of how to create and - use a thread using the C-level thread API, based on realization that - no such tutorial appeared to exist. - -2010-03-31 Jan Nijtmans - - * test/cmdMZ.test: [FRQ 2974744]: share exception codes (ObjType?): - * test/error.test: Revised test cases, making sure that abbreviated - * test/proc-old.test: codes are checked resulting in an error, and - checking for the exact error message. - 2010-03-30 Andreas Kupries * generic/tclIORChan.c (ReflectClose, ReflectInput, ReflectOutput, (ReflectSeekWide, ReflectWatch, ReflectBlock, ReflectSetOption, (ReflectGetOption, ForwardProc): [Bug 2978773]: Preserve @@ -5490,172 +2382,41 @@ * generic/tclObj.c (Tcl_GetCommandFromObj): [Bug 2979402]: Reorder the validity tests on internal rep of a "cmdName" value to avoid invalid reads reported by valgrind. -2010-03-30 Jan Nijtmans - - * generic/tclIndexObj: [FRQ 2974744]: share exception codes - * generic/tclResult.c: further optimization, making use of indexType. - * generic/tclZlib.c: [Bug 2979399]: uninitialized value troubles - -2010-03-30 Donal K. Fellows - - TIP #362 IMPLEMENTATION - - * win/tclWinReg.c: [Patch 2960976]: Apply patch from Damon Courtney to - * tests/registry.test: allow the registry command to be told to work - * win/Makefile.in: with both 32-bit and 64-bit registries. Bump - * win/configure.in: version of registry package to 1.3. - * win/makefile.bc: - * win/makefile.vc: - * win/configure: autoconf-2.59 - -2010-03-29 Jan Nijtmans - - * unix/tcl.m4: Only test for -visibility=hidden with gcc - (Second remark in [Bug 2976508]) - * unix/configure: regen - 2010-03-29 Don Porter * generic/tclStringObj.c: Fix array overrun in test format-1.12 caught by valgrind testing. -2010-03-27 Jan Nijtmans - - * generic/tclInt.h: [FRQ 2974744]: share exception codes - * generic/tclResult.c: (ObjType?) - * generic/tclCmdMZ.c: - * generic/tclCompCmdsSZ.c: - -2010-03-26 Jan Nijtmans - - * generic/tclExecute.c: [Bug 2976508]: Tcl HEAD fails on HP-UX - 2010-03-25 Donal K. Fellows * unix/tclUnixFCmd.c (TclUnixCopyFile): [Bug 2976504]: Corrected number of arguments to fstatfs() call. - * macosx/tclMacOSXBundle.c, macosx/tclMacOSXFCmd.c: - * macosx/tclMacOSXNotify.c: Reduce the level of ifdeffery in the - functions of these files to improve readability. They need to be - audited for whether complexity can be removed based on the minimum - supported version of OSX, but that requires a real expert. - 2010-03-24 Don Porter * generic/tclResult.c: [Bug 2383005]: Revise [return -errorcode] so * tests/result.test: that it rejects illegal non-list values. -2010-03-24 Donal K. Fellows - - * generic/tclOOInfo.c (InfoObjectMethodTypeCmd) - (InfoClassMethodTypeCmd): Added introspection of method types so that - it is possible to find this info out without using errors. - * generic/tclOOMethod.c (procMethodType): Now that introspection can - reveal the name of method types, regularize the name of normal methods - to be the name of the definition type used to create them. - - * tests/async.test (async-4.*): Reduce obscurity of these tests by - putting the bulk of the code for them inside the test body with the - help of [apply]. - - * generic/tclCmdMZ.c (TryPostBody, TryPostHandler): Make sure that the - [try] command does not trap unwinding due to limits. - -2010-03-23 Don Porter - - * generic/tclCmdMZ.c: [Bug 2973361]: Revised fix for computing - indices of script arguments to [try]. - -2010-03-23 Jan Nijtmans - - * generic/tclCmdMZ.c: Make error message in "try" implementation - * generic/tclCompCmdsSZ.c: exactly the same as the one in "return" - * tests/error.test: - * libtommath/mtests/mpi.c: Single "const" addition - -2010-03-22 Don Porter - - * generic/tclCmdMZ.c: [Bug 2973361]: Compute the correct integer - values to identify the argument indices of the various script - arguments to [try]. Passing in -1 led to invalid memory reads. - 2010-03-20 Donal K. Fellows - * doc/exec.n: Make it a bit clearer that there is an option to run a - pipeline in the background. - - * generic/tclIOCmd.c (Tcl_FcopyObjCmd): Lift the restriction - * generic/tclIO.c (TclCopyChannel, CopyData): on the [fcopy] command - * generic/tclIO.h (CopyState): that forced it to only - copy up to 2GB per script-level callback. Now it is anything that can - fit in a (signed) 64-bit integer. Problem identified by Frederic - Bonnet on comp.lang.tcl. Note that individual low-level reads and - writes are still smaller as the optimal buffer size is smaller. - -2010-03-20 Jan Nijtmans - - * win/stub16.c: Don't hide that we use the ASCII API here. - (does someone still use that?) - * win/tclWinPipe.c: 2 unnecessary type casts. - -2010-03-19 Donal K. Fellows - - * generic/tclCompCmdsSZ.c (TclCompileThrowCmd): Added compilation for - the [throw] command. + * generic/tclIO.c (CopyData): Allow the total number of bytes copied + by [fcopy] to exceed 2GB. Can happen when no -size parameter given. 2010-03-18 Don Porter * generic/tclListObj.c: [Bug 2971669]: Prevent in overflow trouble in * generic/tclTestObj.c: ListObjReplace operations. Thanks to kbk for * tests/listObj.test: fix and test. -2010-03-18 Donal K. Fellows - - * generic/tclCompCmdsSZ.c (IssueTryFinallyInstructions): - [Bug 2971921]: Corrected jump so that it doesn't skip into the middle - of an instruction! Tightened the instruction issuing. Moved endCatch - calls closer to their point that they guard, ensuring correct ordering - of result values. - -2010-03-17 Andreas Kupries - - * generic/tclIORTrans.c (ReflectInput, ReflectOutput) - (ReflectSeekWide): [Bug 2921116]: Added missing TclEventuallyFree - calls for preserved ReflectedTransform* structures. Reworked - ReflectInput to preserve the structure for its whole life, not only in - InvokeTclMethod. - - * generic/tclIO.c (Tcl_GetsObj): [Bug 2921116]: Regenerate topChan, - may have been changed by a self-modifying transformation. - - * tests/ioTrans/test (iortrans-4.8, iortrans-4.9, iortrans-5.11) - (iortrans-7.4, iortrans-8.3): New test cases. - -2010-03-16 Jan Nijtmans - - * compat/zlib/*: Upgrade zlib to version 1.2.4. - * win/makefile.vc: - * unix/Makefile.in: - * win/tclWinChan.c: Don't cast away "const" without reason. - 2010-03-12 Jan Nijtmans * win/makefile.vc: [Bug 2967340]: Static build was failing. * win/.cvsignore: -2010-03-10 Jan Nijtmans - - * generic/tclTest.c: Remove unnecessary '&' decoration for - * generic/tclIOUtil.c: function pointers - * win/tclWin32Dll.c: Double declaration of TclNativeDupInternalRep - * unix/tclIOUtil.c: - * unix/dltest/.cvsignore: Ignore *.so here - 2010-03-09 Andreas Kupries * generic/tclIORChan.c: [Bug 2936225]: Thanks to Alexandre Ferrieux * doc/refchan.n: for debugging and * tests/ioCmd.test: fixing the problem. It is the write-side @@ -5673,224 +2434,28 @@ * library/tzdata/Antarctica/Mawson: * library/tzdata/Asia/Dhaka: * library/tzdata/Pacific/Fiji: Olson tzdata2010c. -2010-03-07 Jan Nijtmans - - * generic/tclTest.c: Test that tclOO stubs are present in stub - library - * generic/tclOOMethod.c: Applied missing part of [Patch 2961556] - * win/tclWinInt.h: Change all tclWinProcs signatures to use - * win/tclWin32Dll.c: TCHAR* in stead of WCHAR*. This is meant - * win/tclWinDde.c: as preparation to make [Enh 2965056] - * win/tclWinFCmd.c: possible at all. - * win/tclWinFile.c: - * win/tclWinPipe.c: - * win/tclWinSock.c: - -2010-03-06 Jan Nijtmans - - * generic/tclStubLib.c: Remove presence of tclTomMathStubsPtr here. - * generic/tclTest.c: Test that tommath stubs are present in stub - library. - -2010-03-05 Donal K. Fellows - - * generic/tclIORTrans.c (ForwardProc): [Bug 2964425]: When cleaning - the stables, it is sometimes necessary to do more than the minimum. In - this case, rationalizing the variables for a forwarded limit? method - required removing an extra Tcl_DecrRefCount too. - - * generic/tclOO.h, generic/tclOOInt.h: [Patch 2961556]: Change TclOO - to use the same style of function typedefs as Tcl, as this is about - the last chance to get this right. - - ***POTENTIAL INCOMPATIBILITY*** - Source code that uses function typedefs from TclOO will need to update - variables and argument definitions so that pointers to the function - values are used instead. Binary compatibility is not affected. - - * generic/*.c, generic/tclInt.h, unix/*.c, macosx/*.c: Applied results - of doing a Code Audit. Principal changes: - * Use do { ... } while (0) in macros - * Avoid shadowing one local variable with another - * Use clearer 'foo.bar++;' instead of '++foo.bar;' where result not - required (i.e., semantically equivalent); clarity is increased - because it is bar that is incremented, not foo. - * Follow Engineering Manual rules on spacing and declarations - -2010-03-04 Donal K. Fellows - - * generic/tclOO.c (ObjectRenamedTrace): [Bug 2962664]: Add special - handling so that when the class of classes is deleted, so is the class - of objects. Immediately. - - * generic/tclOOInt.h (ROOT_CLASS): Add new flag for specially marking - the root class. Simpler and more robust than the previous technique. - -2010-03-04 Jan Nijtmans - - * generic/tclGetDate.y: 3 unnecessary MODULE_SCOPE - * generic/tclDate.c: symbols - * generic/tclStubLib.c: Split tommath stub lib - * generic/tclTomMathStubLib.c: in separate file. - * win/makefile.bc: - * win/Makefile.in: - * win/makefile.vc: - * win/tcl.dsp: - * unix/Makefile.in: - * unix/tcl.m4: Cygwin only gives warning - * unix/configure: using -fvisibility=hidden - * compat/strncasecmp.c: A few more const's - * compat/strtod.c: - * compat/strtoul.c: - -2010-03-03 Andreas Kupries - - * doc/refchan.n: Followup to ChangeLog entry 2009-10-07 - (generic/tclIORChan.c). Fixed the documentation to explain that errno - numbers are operating system dependent, and reworked the associated - example. - -2010-03-02 Jan Nijtmans - - * unix/tcl.m4: [FRQ 2959069]: Support for -fvisibility=hidden - * unix/configure (regenerated with autoconf-2.59) - 2010-03-01 Alexandre Ferrieux - * unix/tclUnixSock.c: Refrain from a possibly lengthy reverse-DNS - lookup on 0.0.0.0 when calling [fconfigure -sockname] on an - universally-bound (default) server socket. - - * generic/tclIndexObj.c: fix [AT 86258]: special-casing of empty - tables when generating error messages for [::tcl::prefix match]. - -2010-02-28 Donal K. Fellows - - * generic/tclCmdIL.c: More additions of {TCL LOOKUP} error-code - generation to various subcommands of [info] as part of long-term - project to classify all Tcl's generated errors. - -2010-02-28 Jan Nijtmans - - * generic/tclStubInit.c: [Bug 2959713]: Link error with gcc 4.1 + * unix/tclUnixChan.c: [backported] Refrain from a possibly lengthy + reverse-DNS lookup on 0.0.0.0 when calling [fconfigure -sockname] + on an universally-bound (default) server socket. 2010-02-27 Donal K. Fellows * generic/tclCmdMZ.c (StringFirstCmd, StringLastCmd): [Bug 2960021]: Only search for the needle in the haystack when the needle isn't larger than the haystack. Prevents an odd crash from sometimes happening when things get mixed up (a common programming error). - * generic/tclMain.c (Tcl_Main): [Bug 801429]: Factor out the holding - of the client-installed main loop function into thread-specific data. - - ***POTENTIAL INCOMPATIBILITY*** - Code that previously tried to set the main loop from another thread - will now fail. On the other hand, there is a fairly high probability - that such programs would have been failing before due to the lack of - any kind of inter-thread memory barriers guarding accesses to this - part of Tcl's state. - -2010-02-26 Donal K. Fellows - - * generic/tclCompCmds.c: Split this file into two pieces to make it - * generic/tclCompCmdsSZ.c: easier to work with. It's still two very - long files even after the split. - -2010-02-26 Reinhard Max - - * doc/safe.n: Name the installed file after the command it documents. - Use "Safe Tcl" instead of the "Safe Base", "Safe Tcl" mixture. - -2010-02-26 Donal K. Fellows - - * unix/Makefile.in (NATIVE_TCLSH): Added this variable to allow for - better control of what tclsh to use for various scripts when doing - cross compiling. An imperfect solution, but works. - - * unix/installManPage: Remap non-alphanumeric sequences in filenames - to single underscores (especially colons). - -2010-02-26 Pat Thoyts - - * tests/zlib.test: Add tests for [Bug 2818131] which was crashing with - mismatched zlib algorithms used in combination with gets. This issue - has been fixed by Andreas's last commit. - -2010-02-25 Jan Nijtmans - - * generic/tclHash.c: [FRQ 2958832]: Further speed-up of the - * generic/tclLiteral.c: ouster-hash function. - * generic/tclObj.c: - * generic/tclCkalloc.c: Eliminate various unnecessary (ClientData) - * generic/tclTest.c: type casts. - * generic/tclTestObj.c: - * generic/tclTestProcBodyObj.c: - * unix/tclUnixTest.c: - * unix/tclUnixTime.c: - * unix/tclXtTest.c: - -2010-02-24 Donal K. Fellows - - * generic/tclDictObj.c (SetDictFromAny): Prevent the list<->dict - * generic/tclListObj.c (SetListFromAny): conversion code from taking - too many liberties. Stops loss of duplicate keys in some scenarios. - Many thanks to Jean-Claude Wippler for finding this. - - * generic/tclExecute.c (TclExecuteByteCode): Reduce ifdef-fery and - size of activation record. More variables shared across instructions - than before. - - * doc/socket.n: [Bug 2957688]: Clarified that [socket -server] works - with a command prefix. Extended example to show this in action. - -2010-02-22 Andreas Kupries - - * generic/tclZlib.c (ZlibTransformInput): [Bug 2762041]: Added a hack - to work around the general problem, early EOF recognition based on the - base-channel, instead of the data we have ready for reading in the - transform. Long-term we need a proper general fix (likely tracking EOF - on each level of the channel stack), with attendant complexity. - Furthermore, Z_BUF_ERROR can be ignored, and must be when feeding the - zlib code with single characters. - -2010-02-22 Jan Nijtmans - - * unix/tclUnixPort.h: Remove unnecessary EXTERN's, which already are - in the global stub table. - * unix/configure.in: Use @EXEEXT@ in stead of @EXT_SUFFIX@ - * unix/tcl.m4: - * unix/Makefile.in: Use -DBUILD_tcl for CYGWIN - * unix/configure: (regenerated) - * unix/dltest/pkg*.c: Use EXTERN to control CYGWIN exported symbols - * generic/tclCmdMZ.c: Remove some unnecessary type casts. - * generic/tclCompCmds.c: - * generic/tclTest.c: - * generic/tclUtil.c: - -2010-02-21 Mo DeJong - - * tests/regexp.test: Add test cases back ported from Jacl regexp work. - 2010-02-21 Jan Nijtmans - * generic/tclDate.c: Some more const tables. - * generic/tclGetDate.y: - * generic/regc_lex.c: - * generic/regerror.c: - * generic/tclStubLib.c: * generic/tclBasic.c: Fix [Bug 2954959] expr abs(0.0) is -0.0 * tests/expr.test: -2010-02-20 Donal K. Fellows - - * generic/tclCompCmds.c (TclCompileStringLenCmd): Make [string length] - of a constant string be handled better (i.e., handle backslashes too). - 2010-02-19 Stuart Cassoff * tcl.m4: Correct compiler/linker flags for threaded builds on OpenBSD. * configure: (regenerated). @@ -5899,330 +2464,77 @@ * unix/installManPage: [Bug 2954638]: Correct behaviour of manual page installer. Also added armouring to check that assumptions about the initial state are actually valid (e.g., look for existing input file). -2010-02-17 Donal K. Fellows - - * generic/tclHash.c (HashStringKey): Restore these hash functions - * generic/tclLiteral.c (HashString): to use the classic algorithm. - * generic/tclObj.c (TclHashObjKey): Community felt normal case - speed to be more important than resistance to malicious cases. For - now, hashes that need to deal with the malicious case can use a custom - hash table and install their own hash function, though that is not - functionality exposed to the script level. - - * generic/tclCompCmds.c (TclCompileDictUpdateCmd): Stack depth must be - correctly described when compiling a body to prevent crashes in some - debugging modes. - -2010-02-16 Jan Nijtmans - - * generic/tclInt.h: Change order of various struct members, - fixing potential binary incompatibility with Tcl 8.5 - -2010-02-16 Donal K. Fellows - - * unix/configure.in, generic/tclIOUtil.c (Tcl_Stat): Updated so that - we do not assume that all unix systems have the POSIX blkcnt_t type, - since OpenBSD apparently does not. - - * generic/tclLiteral.c (HashString): Missed updating to FNV in one - place; the literal table (a copy of the hash table code...) - -2010-02-15 Jan Nijtmans - - * tools/genStubs.tcl: Reverted earlier rename from tcl*Stubs to - * generic/tclBasic.c: tcl*ConstStubs, it's not necessary at all. - * generic/tclOO.c: - * generic/tclTomMathInterface.c: - * generic/tclStubInit.c: (regenerated) - * generic/tclOOStubInit.c: (regenerated) - * generic/tclEnsemble.c:Fix signed-unsigned mismatch - * win/tclWinInt.h: make tclWinProcs "const" - * win/tclWin32Dll.c: - * win/tclWinFCmd.c: Eliminate all internal Tcl_WinUtfToTChar - * win/tclWinFile.c: and Tcl_WinTCharToUtf calls, needed - * win/tclWinInit.c: for mslu support. - * win/tclWinLoad.c: - * win/tclWinPipe.c: - * win/tclWinSerial.c: - * win/.cvsignore: - * compat/unicows/readme.txt: [FRQ 2819611]: Add first part of MSLU - * compat/unicows/license.txt: support. - * compat/unicows/unicows.lib: - -2010-02-15 Donal K. Fellows - - * generic/tclOO.c (AllocObject, SquelchedNsFirst, ObjectRenamedTrace): - * generic/tclNamesp.c (Tcl_DeleteNamespace): [Bug 2950259]: Revised - the namespace deletion code to provide an additional internal callback - that gets triggered early enough in namespace deletion to allow TclOO - destructors to run sanely. Adjusted TclOO to take advantage of this, - so making tearing down an object by killing its namespace appear to - work seamlessly, which is needed for Itcl. (Note that this is not a - feature that will ever be backported to 8.5, and it remains not a - recommended way of deleting an object.) - -2010-02-13 Donal K. Fellows - - * generic/tclCompCmds.c (TclCompileSwitchCmd): Divided the [switch] - compiler into three pieces (after the model of [try]): a parser, an - instruction-issuer for chained tests, and an instruction-issuer for - jump tables. - - * generic/tclEnsemble.c: Split the ensemble engine out into its own - file rather than keeping it mashed together with the namespace code. - -2010-02-12 Jan Nijtmans - - * win/tcl.m4: Use -pipe for gcc on win32 - * win/configure: (mingw/cygwin) (regenerated) - * win/.cvsignore: Add .lib, .exp and .res here - -2010-02-11 Mo DeJong - - * tests/list.test: Add tests for explicit \0 in a string argument to - the list command. - 2010-02-11 Donal K. Fellows * generic/tclIOCmd.c (Tcl_OpenObjCmd): [Bug 2949740]: Make sure that we do not try to put a NULL pipeline channel into binary mode. -2010-02-11 Mo DeJong - - [Bug 2826551, Patch 2948425]: Assorted regexp bugs related to -all, - -line and -start options and newlines. - * generic/tclCmdMZ.c (Tcl_RegexpObjCmd): If -offset is given, treat it - as the start of the line if the previous character was a newline. Fix - nasty edge case where a zero length match would not advance the index. - * tests/regexp.test: Add regression tests back ported from Jacl. - Checks for a number of issues related to -line and newline handling. A - few of tests were broken before the patch and continue to be broken, - marked as knownBug. - -2010-02-11 Donal K. Fellows - - * generic/tclOO.c (ObjectRenamedTrace): [Bug 2949397]: Prevent - destructors from running on the two core class objects when the whole - interpreter is being destroyed. - -2010-02-09 Donal K. Fellows - - * generic/tclCompCmds.c (TclCompileTryCmd, IssueTryInstructions) - (IssueTryFinallyInstructions): Added compiler for the [try] command. - It is split into three pieces that handle the parsing of the tokens, - the issuing of instructions for finally-free [try], and the issuing of - instructions for [try] with finally; there are enough differences - between the all cases that it was easier to split the code rather than - have a single function do the whole thing. - -2010-02-09 Alexandre Ferrieux - - * tools/genStubs.tcl: Remove dependency on 8.5+ idiom "in" in - expressions. - -2010-02-08 Donal K. Fellows - - * generic/tclZlib.c (Tcl_ZlibDeflate, Tcl_ZlibInflate): [Bug 2947783]: - Make sure that the result is an unshared object before appending to it - so that nothing crashes if it is shared (use in Tcl code was not - affected by this, but use from C was an issue). - -2010-02-06 Donal K. Fellows - - * generic/tclHash.c (HashStringKey): Replace Tcl's crusty old hash - * generic/tclObj.c (TclHashObjKey): function with the algorithm - due to Fowler, Noll and Vo. This is slightly faster (assuming the - presence of hardware multiply) and has somewhat better distribution - properties of the resulting hash values. Note that we only ever used - the 32-bit version of the FNV algorithm; Tcl's core hash engine - assumes that hash values are simple unsigned ints. - - ***POTENTIAL INCOMPATIBILITY*** - Code that depends on hash iteration order (especially tests) may well - be disrupted by this. Where a definite order is required, the fix is - usually to just sort the results after extracting them from the hash. - Where this is insufficient, the code that has ceased working was - always wrong and was only working by chance. - -2010-02-05 Donal K. Fellows - - * generic/tclCompCmds.c (TclCompileErrorCmd): Added compilation of the - [error] command. No new bytecodes. - -2010-02-05 Jan Nijtmans - - * tools/genStubs.tcl: Follow-up to earlier commit today: - Eliminate the need for an extra Stubs Pointer for adressing - a static stub table: Just change the exported table from - static to MODULE_SCOPE. - * generic/tclBasic.c - * generic/tclOO.c - * generic/tclTomMathInterface.c - * generic/tcl*Decls.h (regenerated) - * generic/tclStubInit.c (regenerated) - * generic/tclOOStubInit.c (regenerated) - * generic/tclTest.c (minor formatting) - -2010-02-05 Donal K. Fellows - - * generic/tclVar.c: More consistency in errorcode generation. - - * generic/tclOOBasic.c (TclOO_Object_Destroy): Rewrote to be NRE-aware - when calling destructors. Note that there is no guarantee that - destructors will always be called in an NRE context; that's a feature - of the 'destroy' method only. - - * generic/tclEncoding.c: Add 'const' to many function-internal vars - that are never pointing to things that are written to. - -2010-02-05 Jan Nijtmans - - * tools/genStubs.tcl: Follow-up to [2010-01-29] commit: - prevent space within stub table function parameters if the - parameter type is a pointer. - * win/tclWinInt.h: Minor Formatting - * generic/tcl.h: VOID -> void and other formatting - * generic/tclInt.h: Minor formatting - * generic/tclInt.decls: Change signature of TclNRInterpProcCore, - * generic/tclOO.decls: and TclOONewProc(Instance|)MethodEx, - * generic/tclProc.c: indicating that errorProc is a function, - * generic/tclOOMethod.c:pointer, and other formatting - * generic/tcl*Decls.h: (regenerated) - * generic/tclVar.c: gcc warning(line 3703): 'pattern' may be used - uninitialized in this function - gcc warning(line 3788): 'matched' may be used - uninitialized in this function - -2010-02-04 Donal K. Fellows - - * generic/tclVar.c: Added more use of error-codes and reduced the - stack overhead of older interfaces. - (ArrayGetCmd): Stop silly crash when using a trivial pattern due to - error in conversion to ensemble. - (ArrayNamesCmd): Use the object RE interface for faster matching. +2010-02-07 Jan Nijtmans + + * tools/genStubs.tcl Backport various formatting (spacing) + * generic/tcl*.decls changes from HEAD, so diffing + * generic/tcl*Decls.h between 8.5.x and 8.6 shows the + * generic/tclStubInit.c real structural differences again. + (any signature change not backported!) 2010-02-03 Donal K. Fellows - * generic/tclVar.c (ArrayUnsetCmd): More corrections. + * generic/tclVar.c (Tcl_ArrayObjCmd): More corrections for the 'unset' + subcommand. + +2010-02-02 Andreas Kupries + + * generic/tclCompile.c: [Bug 2933089]: A literal sharing problem with + * generic/tclCompile.h: 'info frame' affects not only 8.6 but 8.5 as + * generic/tclExecute.h: well. Backported the fix done in 8.6, without + * tests/info.test: changes. New testcase info-39.1. 2010-02-02 Donal K. Fellows - * generic/tclVar.c: Turned the [array] command into a true ensemble. - - * generic/tclOO.c (AllocObject, MyDeleted): A slightly faster way to - handle the deletion of [my] is with a standard delete callback. This - is because it doesn't require an additional memory allocation during - object creation. Also reduced the amount of string manipulation - performed during object creation to further streamline memory - handling; this is not backported to the 8.5 package as it breaks a - number of abstractions. - - * generic/tclOOBasic.c (TclOO_Object_Destroy): [Bug 2944404]: Do not - crash when a destructor deletes the object that is executing that - destructor. - -2010-02-01 Donal K. Fellows - * generic/tclVar.c (Tcl_ArrayObjCmd): [Bug 2939073]: Stop the [array unset] command from having dangling pointer problems when an unset trace deletes the element that is going to be processed next. Many thanks to Alexandre Ferrieux for the bulk of this fix. + +2010-02-01 Donal K. Fellows * generic/regexec.c (ccondissect, crevdissect): [Bug 2942697]: Rework these functions so that certain pathological patterns are matched much more rapidly. Many thanks to Tom Lane for dianosing this issue and providing an initial patch. -2010-01-30 Donal K. Fellows - - * generic/tclCompile.c (tclInstructionTable): Bytecode instructions - * generic/tclCompCmds.c (TclCompileUnsetCmd): to allow the [unset] - * generic/tclExecute.c (TclExecuteByteCode): command to be compiled - with the compiler being a complete compilation for all compile-time - decidable uses. - - * generic/tclVar.c (TclPtrUnsetVar): Var reference version of the code - to unset a variable. Required for INST_UNSET bytecodes. +2010-02-01 Jan Nijtmans + + * generic/tclInt.decls: Various CYGWIN-related fixes + * generic/tclInt.h: backported from HEAD. Still + * generic/tclIntPlatDecls.h: configure script not modified, + * generic/tclPort.h: so CYGWIN build is still + * generic/tclTest.c: disabled. Reason: although the + * win/cat.c: build succeeds with those changes, + * win/tclWinDde.c: many tests still fail. + * win/tclWinError.c: + * win/tclWinFile.c: + * win/tclWinPipe.c: + * win/tclWinPort.h: + * win/tclWinReg.c: + * win/tclWinSerial.c: + * win/tclWinSock.c: + * win/tclWinTest.c: + * win/tclWinThrd.c: 2010-01-29 Jan Nijtmans - * generic/tcl.h: [Bug 2942081]: Reverted Tcl_ThreadDataKey type change - Changed some Tcl_CallFrame fields from "char *" - to "void *". This saves unnecessary space on - Cray's (and it's simply more correct). - - * tools/genStubs.tcl: No longer generate a space after "*" and - immediately after a function name, so the - format of function definitions in tcl*Decls.h - match all other tcl*.h header files. - * doc/ParseArgs.3: Change Tcl_ArgvFuncProc, Tcl_ArgvGenFuncProc - * generic/tcl.h: and GetFrameInfoValueProc to be function - * generic/tclInt.h: definitions, not pointers, for consistency - * generic/tclOOInt.h: with all other Tcl function definitions. - * generic/tclIndexObj.c: - * generic/regguts.h: CONST -> const - * generic/tcl.decls: Formatting - * generic/tclTomMath.decls: Formatting - * generic/tclDecls.h: (regenerated) - * generic/tclIntDecls.h: - * generic/tclIntPlatDecls.h: - * generic/tclOODecls.h: - * generic/tclOOIntDecls.h: - * generic/tclPlatDecls.h: - * generic/tclTomMathDecls.h: - -2010-01-28 Donal K. Fellows - - * generic/tclOOBasic.c (TclOO_Object_Destroy): Move the execution of - destructors to a point where they can produce an error. This will not - work for all destructors, but it does mean that more failing calls of - them will be caught. - * generic/tclOO.c (AllocObject, MyDeletedTrace, ObjectRenamedTrace): - (ObjectNamespaceDeleted): Stop various ways of getting at commands - with dangling pointers to the object. Also increases the reliability - of calling of destructors (though most destructors won't benefit; when - an object is deleted namespace-first, its destructors are not run in a - nice state as the namespace is partially gone). - -2010-01-25 Jan Nijtmans - - * generic/tclOOStubInit.c: Remove double includes (which causes a - * generic/tclOOStubLib.c: warning in CYGWIN compiles) - * unix/.cvsignore: add confdefs.h - -2010-01-22 Donal K. Fellows - - * doc/proc.n: [Bug 1970629]: Define a bit better what the current - namespace of a procedure is. - -2010-01-22 Jan Nijtmans - - * generic/tclInt.decls: Don't use DWORD and HANDLE here. - * generic/tclIntPlatDecls.h: - * generic/tcl.h: Revert [2009-12-21] change, instead - * generic/tclPort.h: resolve the CYGWIN inclusion problems by - * win/tclWinPort.h: re-arranging the inclusions at other - places. - * win/tclWinError.c - * win/tclWinPipe.c - * win/tcl.m4: Make cygwin configuration error into - * win/configure.in: a warning: CYGWIN compilation works - * win/configure: although there still are test failures. - -2010-01-22 Donal K. Fellows - - * generic/tclExecute.c (TclExecuteByteCode): Improve error code - generation from some of the tailcall-related bits of TEBC. - -2010-01-21 Miguel Sofer - - * generic/tclCompile.h: [Bug 2910748]: NRE-enable direct eval on BC - * generic/tclExecute.c: spoilage. - * tests/nre.test: + * generic/tcl.h: Use correct TCL_LL_MODIFIER for CYGWIN. + Formatting (all backported from HEAD) + * generic/rege_dfa.c: Fix macro conflict on CYGWIN: don't use + "small". + * generic/tclTest.c: Fix gcc 4.4 warning: ignoring return value of + * unix/tclUnixPipe.c: 'write' + * unix/tclUnixNotify.c: 2010-01-19 Donal K. Fellows * doc/dict.n: [Bug 2929546]: Clarify just what [dict with] and [dict update] are doing with variables. @@ -6241,77 +2553,26 @@ * generic/tclStringObj.c (Tcl_AppendFormatToObj): [Bug 2932421]: Stop the [format] command from causing argument objects to change their internal representation when not needed. Thanks to Alexandre Ferrieux for this fix. -2010-01-13 Donal K. Fellows - - * tools/tcltk-man2html.tcl: More factoring out of special cases - * tools/tcltk-man2html-utils.tcl: so that they are described outside - the engine file. Now there is only one real set of special cases in - there, to handle the .SO/.OP/.SE directives. - -2010-01-13 Jan Nijtmans - - * generic/tcl.h: Fix TCL_LL_MODIFIER for Cygwin - * generic/tclEnv.c: Fix CYGWIN compilation problems, - * generic/tclInt.h: and remove some unnecessary - * generic/tclPort.h: double includes. - * generic/tclPlatDecls.h: - * win/cat.c: - * win/tclWinConsole.c: - * win/tclWinFCmd.c: - * win/tclWinFile.c: - * win/tclWinPipe.c: - * win/tclWinSerial.c: - * win/tclWinThrd.c: - * win/tclWinPort.h: Put win32 includes first - * unix/tclUnixChan.c: Forgot one CONST change - -2010-01-12 Donal K. Fellows - - * tools/tcltk-man2html.tcl: Make the generation of the list of things - to process the docs from simpler and more flexible. Also factored out - the lists of special cases. - -2010-01-10 Jan Nijtmans - - * win/tclWinDde.c: VC++ 6.0 doesn't have - * win/tclWinReg.c: PDWORD_PTR - * win/tclWinThrd.c: Fix various minor gcc warnings. - * win/tclWinTime.c: - * win/tclWinConsole.c: Put channel type definitions - * win/tclWinChan.c: in static const memory - * win/tclWinPipe.c: - * win/tclWinSerial.c: - * win/tclWinSock.c: - * generic/tclIOGT.c: - * generic/tclIORChan.c: - * generic/tclIORTrans.c: - * unix/tclUnixChan.c: - * unix/tclUnixPipe.c: - * unix/tclUnixSock.c: - * unix/configure: (regenerated with autoconf 2.59) - * tests/info.test: Make test independant from - tcltest implementation. - -2010-01-10 Donal K. Fellows - - * tests/namespace.test (namespace-51.17): [Bug 2898722]: Demonstrate - that there are still bugs in the handling of resolution epochs. This - bug is not yet fixed. - - * tools/tcltk-man2html.tcl: Split the man->html converter into - * tools/tcltk-man2html-utils.tcl: two pieces for easier maintenance. - Also made it much less verbose in its printed messages by default. - -2010-01-09 Donal K. Fellows - - * tools/tcltk-man2html.tcl: Added basic support for building the docs - for contributed packages into the HTML versions. Prompted by question - on Tcler's Chat by Tom Krehbiel. Note that there remain problems in - the documentation generated due to errors in the contributed docs. +2010-01-06 Jan Nijtmans + + * generic/tclCompExpr.c: Warning: array subscript has type 'char' + * generic/tclPkg.c: + * libtommath/bn_mp_read_radix.c: + * unix/tclUnixCompat.c: Fix gcc warning: signed and unsigned type + in conditional expression. + * unix/tcl.m4: Add support for Haiku and CYGWIN dynamical loading + * unix/configure: (regenerated) + * unix/Makefile.in: + * unix/.cvsignore: + * tests/stack.test: Reduced minimum required C-stack size to 2034: + CYGWIN has this stack size and the test runs fine! + * generic/tclEnv.c: Fix environment tests under CYGWIN + * generic/tclPort.h: + * tests/env.test: 2010-01-05 Don Porter * generic/tclPathObj.c (TclPathPart): [Bug 2918610]: Correct * tests/fileName.test (filename-14.31): inconsistency between the @@ -6321,56 +2582,27 @@ 2010-01-03 Donal K. Fellows * unix/tcl.m4 (SC_CONFIG_CFLAGS): [Bug 1636685]: Use the configuration for modern FreeBSD suggested by the FreeBSD porter. -2010-01-03 Miguel Sofer - - * generic/tclBasic.c: [Bug 2724403]: Fix leak of coroutines on - * generic/tclCompile.h: namespace deletion. Added a test for this - * generic/tclNamesp.c: leak, and also a test for leaks on namespace - * tests/coroutine.test: deletion. - * tests/namespace.test: - 2009-12-30 Donal K. Fellows * library/safe.tcl (AliasSource): [Bug 2923613]: Make the safer * tests/safe.test (safe-8.9): [source] handle a [return] at the end of the file correctly. -2009-12-30 Miguel Sofer - - * library/init.tcl (unknown): [Bug 2824981]: Fix infinite recursion of - ::unknown when [set] is undefined. - 2009-12-29 Donal K. Fellows - * generic/tclHistory.c (Tcl_RecordAndEvalObj): Reduce the amount of - allocation and deallocation of memory by caching objects in the - interpreter assocData table. - - * generic/tclObj.c (Tcl_GetCommandFromObj): Rewrite the logic so that - it does not require making assignments part way through an 'if' - condition, which was deeply unclear. - * generic/tclInterp.c (Tcl_MakeSafe): [Bug 2895741]: Make sure that the min() and max() functions are supported in safe interpreters. -2009-12-29 Pat Thoyts - - * generic/tclBinary.c: [Bug 2922555]: Handle completely invalid input - * tests/binary.test: to the decode methods. - 2009-12-28 Donal K. Fellows - * unix/Makefile.in (trace-shell, trace-test): [FRQ 1083288]: Added - targets to allow easier tracing of shell and test invokations. - * unix/configure.in: [Bug 942170]: Detect the st_blocks field of * generic/tclCmdAH.c (StoreStatData): 'struct stat' correctly. - * generic/tclFileName.c (Tcl_GetBlocksFromStat): - * generic/tclIOUtil.c (Tcl_Stat): + * generic/tclIOUtil.c (Tcl_Stat, Tcl_FSStat): + * generic/tclTest.c (PretendTclpStat): * generic/tclInterp.c (TimeLimitCallback): [Bug 2891362]: Ensure that * tests/interp.test (interp-34.13): the granularity ticker is reset when we check limits because of the time limit event firing. @@ -6377,652 +2609,186 @@ 2009-12-27 Donal K. Fellows * doc/namespace.n (SCOPED SCRIPTS): [Bug 2921538]: Updated example to not be quite so ancient. -2009-12-25 Jan Nijtmans - - * generic/tclCmdMZ.c: CONST -> const - * generic/tclParse.c - 2009-12-23 Donal K. Fellows * library/safe.tcl (AliasSource, AliasExeName): [Bug 2913625]: Stop information about paths from leaking through [info script] and [info nameofexecutable]. -2009-12-23 Jan Nijtmans - - * unix/tcl.m4: Install libtcl8.6.dll in bin directory - * unix/Makefile.in: - * unix/configure: (regenerated) - -2009-12-22 Donal K. Fellows - - * generic/tclCmdIL.c (Tcl_LsortObjCmd): [Bug 2918962]: Stop crash when - -index and -stride are used together. - -2009-12-21 Jan Nijtmans - - * generic/tclThreadStorage.c: Fix gcc warning, using gcc-4.3.4 on - cygwin: missing initializer - * generic/tclOOInt.h: Prevent conflict with DUPLICATE - definition in WINAPI's nb30.h - * generic/rege_dfa.c: Fix macro conflict on CYGWIN: don't use - "small". - * generic/tcl.h: Include before on - CYGWIN - * generic/tclPathObj.c - * generic/tclPort.h - * tests/env.test: Don't unset WINDIR and TERM, it has a - special meaning on CYGWIN (both in UNIX - and WIN32 mode!) - * generic/tclPlatDecls.h: Include through tclPlatDecls.h - * win/tclWinPort.h: stricmp -> strcasecmp - * win/tclWinDde.c: _wcsicmp -> wcscasecmp - * win/tclWinFile.c - * win/tclWinPipe.c - * win/tclWinSock.c - * unix/tcl.m4: Add dynamic loading support to CYGWIN - * unix/configure (regenerated) - * unix/Makefile.in - -2009-12-19 Miguel Sofer - - * generic/tclBasic.c: [Bug 2917627]: Fix for bad cmd resolution by - * tests/coroutine.test: coroutines. Thanks to schelte for finding it. - 2009-12-16 Donal K. Fellows * library/safe.tcl (::safe::AliasGlob): Upgrade to correctly support a larger fraction of [glob] functionality, while being stricter about directory management. -2009-12-11 Jan Nijtmans - - * generic/tclTest.c: Fix gcc warning: ignoring return value of - * unix/tclUnixNotify.c: "write", declared with attribute - * unix/tclUnixPipe.c: warn_unused_result. - * generic/tclInt.decls: CONSTify functions TclpGetUserHome and - * generic/tclIntDecls.h:TclSetPreInitScript (TIP #27) - * generic/tclInterp.c: - * win/tclWinFile.c: - * unix/tclUnixFile.c: - -2009-12-16 Donal K. Fellows - * doc/tm.n: [Bug 1911342]: Formatting rewrite to avoid bogus crosslink to the list manpage when generating HTML. * library/msgcat/msgcat.tcl (Init): [Bug 2913616]: Do not use platform tests that are not needed and which don't work in safe interpreters. -2009-12-14 Donal K. Fellows - - * doc/file.n (file tempfile): [Bug 2388866]: Note that this only ever - creates files on the native filesystem. This is a design feature. - -2009-12-13 Miguel Sofer - - * generic/tclBasic.c: Release TclPopCallFrame() from its - * generic/tclExecute.c: tailcall-management duties - * generic/tclNamesp.c: - - * generic/tclBasic.c: Moving TclBCArgumentRelease call from - * generic/tclExecute.c: TclNRTailcallObjCmd to TEBC, so that the - pairing of the Enter and Release calls is clearer. - 2009-12-12 Donal K. Fellows * generic/tclTest.c (TestconcatobjCmd): [Bug 2895367]: Stop memory leak when testing. We don't need extra noise of this sort when tracking down real problems! -2009-12-11 Jan Nijtmans - - * generic/tclBinary.c: Fix gcc warning, using gcc-4.3.4 on cygwin - * generic/tclCompExpr.c:warning: array subscript has type 'char' - * generic/tclPkg.c: - * libtommath/bn_mp_read_radix.c: - * win/makefile.vc: [Bug 2912773]: Revert to version 1.203 - * unix/tclUnixCompat.c: Fix gcc warning: signed and unsigned type - in conditional expression. - -2009-12-11 Donal K. Fellows - - * tools/tcltk-man2html.tcl (long-toc, cross-reference): [FRQ 2897296]: - Added cross links to sections within manual pages. - -2009-12-11 Miguel Sofer - - * generic/tclBasic.c: [Bug 2806407]: Full nre-enabling of coroutines - * generic/tclExecute.c: - - * generic/tclBasic.c: Small cleanup - - * generic/tclExecute.c: Fix panic in http11.test caused by buggy - earlier commits in coroutine management. - 2009-12-10 Andreas Kupries * generic/tclObj.c (TclContinuationsEnter): [Bug 2895323]: Updated comments to describe when the function can be entered for the same Tcl_Obj* multiple times. This is a continuation of the 2009-11-10 entry where a memory leak was plugged, but where not sure if that was just a band-aid to paper over some other error. It isn't, this is a legal situation. -2009-12-10 Miguel Sofer - - * generic/tclBasic.c: Reducing the # of moving parts for coroutines - * generic/tclExecute.c: by delegating more to tebc; eliminate the - special coroutine CallFrame. - 2009-12-09 Andreas Kupries - * generic/tclIO.c: [Bug 2901998]: Applied Alexandre Ferrieux's patch - fixing the inconsistent buffered I/O. Tcl's I/O now flushes buffered - output before reading, discards buffered input before writing, etc. - -2009-12-09 Miguel Sofer - - * generic/tclBasic.c: Ensure right lifetime of varFrame's (objc,objv) - for coroutines. - - * generic/tclExecute.c: Code regrouping - -2009-12-09 Donal K. Fellows - - * generic/tclBasic.c: Added some of the missing setting of errorcode - values. - -2009-12-08 Miguel Sofer - - * generic/tclExecute.c (TclStackFree): Improved panic msg. - -2009-12-08 Miguel Sofer - - * generic/tclBasic.c: Partial nre-enabling of coroutines. The - * generic/tclExecute.c: initial call still requires its own - * generic/tclInt.h: instance of tebc, but on resume coros can - execute in the caller's tebc. - - * generic/tclExecute.c (TEBC): Silence warning about pcAdjustment. - -2009-12-08 Donal K. Fellows - - * generic/tclExecute.c (TclExecuteByteCode): Make the dict opcodes - more sparing in their use of C variables, to reduce size of TEBC - activiation record a little bit. - -2009-12-07 Miguel Sofer - - * generic/tclExecute.c (TEBC): Grouping "slow" variables into structs, - to reduce register pressure and help the compiler with variable - allocation. - -2009-12-07 Miguel Sofer - - * generic/tclExecute.c: Start cleaning the TEBC stables - * generic/tclInt.h: - - * generic/tclCmdIL.c: [Bug 2910094]: Fix by aku - * tests/coroutine.test: - - * generic/tclBasic.c: Arrange for [tailcall] to be created with the - other builtins: was being created in a separate call, leftover from - pre-tip days. + * library/safe.tcl: Backport of the streamlined safe base from + * tests/safe.test: head to the 8.5 branch (See head changelog entries + 2009-11-05, 2009-11-06, 2009-12-03). 2009-12-07 Don Porter - * generic/tclStrToD.c: [Bug 2902010]: Correct conditional compile + * generic/tclStrToD.c: [Bug 2902010]: Correct conditional compile directives to better detect the toolchain that needs extra work for proper underflow treatment instead of merely detecting the MIPS platform. -2009-12-07 Miguel Sofer - - * generic/tclBasic.c: [Patch 2910056]: Add ::tcl::unsupported::yieldTo - * generic/tclInt.h: - -2009-12-07 Donal K. Fellows - - * generic/tclCmdMZ.c (TryPostBody): [Bug 2910044]: Close off memory - leak in [try] when a variable-free handler clause is present. - -2009-12-05 Miguel Sofer - - * generic/tclBasic.c: Small changes for clarity in tailcall - * generic/tclExecute.c: and coroutine code. - * tests/coroutine.test: - - * tests/tailcall.test: Remove some old unused crud; improved the - stack depth tests. - - * generic/tclBasic.c: Fixed things so that you can tailcall - * generic/tclNamesp.c: properly out of a coroutine. - * tests/tailcall.test: - - * generic/tclInterp.c: Fixed tailcalls for same-interp aliases (no - test) - -2009-12-03 Donal K. Fellows - - * library/safe.tcl (::safe::AliasEncoding): Make the safe encoding - command behave more closely like the unsafe one (for safe ops). - (::safe::AliasGlob): [Bug 2906841]: Clamp down on evil use of [glob] - in safe interpreters. - * tests/safe.test: Rewrite to use tcltest2 better. - 2009-12-02 Jan Nijtmans - * tools/genStubs.tcl: Add support for win32 CALLBACK functions and - remove obsolete "emitStubs" and "genStubs" functions. - * win/Makefile.in: Use tcltest86.dll for all tests, and add - .PHONY rules to preemptively stop trouble that plagued Tk from hitting - Tcl too. - -2009-11-30 Jan Nijtmans - - * generic/tcl.h: Don't use EXPORT for Tcl_InitStubs - * win/Makefile.in: Better dependancies in case of static build. + * tools/genStubs.tcl: Add support for win32 CALLBACK functions (needed + for Tk bugfix). 2009-11-30 Donal K. Fellows * doc/Tcl.n: [Bug 2901433]: Improved description of expansion to mention that it is using list syntax. -2009-11-27 Kevin B. Kenny - - * win/tclAppInit.c (Tcl_AppInit): [Bug 2902965]: Reverted Jan's change - that added a call to Tcl_InitStubs. The 'tclsh' and 'tcltest' programs - are providers, not consumers of the Stubs table, and should not link - with the Stubs library, but only with the main Tcl library. (In any - case, the presence of Tcl_InitStubs broke the build.) - 2009-11-27 Donal K. Fellows - * doc/BoolObj.3, doc/Class.3, doc/CrtChannel.3, doc/DictObj.3: - * doc/DoubleObj.3, doc/Ensemble.3, doc/Environment.3: - * doc/FileSystem.3, doc/Hash.3, doc/IntObj.3, doc/Limit.3: - * doc/Method.3, doc/NRE.3, doc/ObjectType.3, doc/PkgRequire.3: + * doc/BoolObj.3, doc/CrtChannel.3, doc/DictObj.3, doc/DoubleObj.3: + * doc/Ensemble.3, doc/Environment.3, doc/FileSystem.3, doc/Hash.3: + * doc/IntObj.3, doc/Limit.3, doc/ObjectType.3, doc/PkgRequire.3: * doc/SetChanErr.3, doc/SetResult.3: [Patch 2903921]: Many small spelling fixes from Larry Virden. - BUMP VERSION OF TCLOO TO 0.6.2. Too many people need accumulated small - versions and bugfixes, so the version-bump removes confusion. - - * generic/tclOOBasic.c (TclOO_Object_LinkVar): [Bug 2903811]: Remove - unneeded restrictions on who can usefully call this method. - -2009-11-26 Donal K. Fellows - - * unix/Makefile.in: Add .PHONY rules and documentation to preemptively - stop trouble that plagued Tk from hitting Tcl too, and to make the - overall makefile easier to understand. Some reorganization too to move - related rules closer together. - -2009-11-26 Jan Nijtmans - - * win/Makefile.in: [Bug 2902965]: Fix stub related changes that - * win/makefile.vc: caused tclkit build to break. - * win/tclAppInit.c - * unix/tcl.m4 - * unix/Makefile.in - * unix/tclAppInit.c - * unix/configure: (regenerated) - -2009-11-25 Kevin B. Kenny - - * win/Makefile.in: Added a 'test-tcl' rule that is identical to - 'test' except that it does not go spelunking in 'pkgs/'. (This rule - has existed in unix/Makefile.in for some time.) - 2009-11-25 Stuart Cassoff * unix/configure.in: [Patch 2892871]: Remove unneeded * unix/tcl.m4: AC_STRUCT_TIMEZONE and use * unix/tclConfig.h.in: AC_CHECK_MEMBERS([struct stat.st_blksize]) * unix/tclUnixFCmd.c: instead of AC_STRUCT_ST_BLKSIZE. * unix/configure: Regenerated with autoconf-2.59. -2009-11-24 Andreas Kupries - - * library/tclIndex: Manually redone the part of tclIndex dealing with - safe.tcl and tm.tcl. This part passes the testsuite. Note that - automatic regeneration of this part is not possible because it wrongly - puts 'safe::Setup' on the list, and wrongly leaves out 'safe::Log' - which is more dynamically created than the generator expects. - - Further note that the file "clock.tcl" is explicitly loaded by - "init.tcl", the first time the clock command is invoked. The relevant - code can be found at line 172ff, roughly, the definition of the - procedure 'clock'. This means none of the procedures of this file - belong in the tclIndex. Another indicator that automatic regeneration - of tclIndex is ill-advised. - -2009-11-24 Donal K. Fellows - - * generic/tclOO.c (FinalizeAlloc, Tcl_NewObjectInstance): - [Bug 2903011]: Make it an error to destroy an object in a constructor, - and also make sure that an object is not deleted twice in the error - case. - -2009-11-24 Pat Thoyts - - * tests/fCmd.test: [Bug 2893771]: Teach [file stat] to handle locked - * win/tclWinFile.c: files so that [file exists] no longer lies. - -2009-11-23 Kevin Kenny - - * tests/fCmd.test (fCmd-30.1): Changed registry location of the 'My - Documents' folder to the one that's correct for Windows 2000, XP, - Server 2003, Vista, Server 2008, and Windows 7. (See - http://support.microsoft.com/kb/310746) - -2009-11-23 Jan Nijtmans - - * win/tclWinDde.c: #undef STATIC_BUILD, in order to make sure - * win/tclWinReg.c: that Xxxxx_Init is always exported even when - * generic/tclTest.c: Tcl is built static (otherwise we cannot - create a DLL). - * generic/tclThreadTest.c: Make all functions static, except - TclThread_Init. - * tests/fCmd.test: Enable fCmd-30.1 when registry is available. - * win/tcl.m4: Fix ${SHLIB_LD_LIBS} definition, fix conflicts - * win/Makefile.in: Simplifications related to tcl.m4 changes. - * win/configure.in: Between static libraries and import library on - windows. - * win/configure: (regenerated) - * win/makefile.vc: Add stub library to necessary link lines. - -2009-11-23 Kevin B. Kenny - - * generic/tclThreadTest.c (NewTestThread): [Bug 2901803]: Further - machinations to get NewTestThread actually to launch the thread, not - just compile. - -2009-11-22 Donal K. Fellows - - * generic/tclThreadTest.c (NewTestThread): [Bug 2901803]: Fix small - error in function naming which blocked a threaded test build. - -2009-11-19 Jan Nijtmans - - * win/Makefile.in: Create tcltest86.dll as dynamic Tcltest - package. - * generic/tclTest.c: Remove extraneous prototypes, follow-up to - * generic/tclTestObj.c: [Bug 2883850] - * tests/chanio.test: Test-cases for fixed [Bug 2849797] - * tests/io.test: - * tests/safe.test: Fix safe-10.1 and safe-10.4 test cases, making - the wrong assumption that Tcltest is a static - package. - * generic/tclEncoding.c:[Bug 2857044]: Updated freeIntRepProc routines - * generic/tclVar.c: so that they set the typePtr field to NULL so - that the Tcl_Obj is not left in an - inconsistent state. - * unix/tcl.m4: [Patch 2883533]: tcl.m4 support for Haiku OS - * unix/configure: autoconf-2.59 - -2009-11-19 Don Porter - - * unix/tclAppInit.c: [Bug 2883850, 2900542]: Repair broken build of - * win/tclAppInit.c: the tcltest executable. - -2009-11-19 Donal K. Fellows - - * library/auto.tcl (tcl_findLibrary): - * library/clock.tcl (MakeUniquePrefixRegexp, MakeParseCodeFromFields) - (SetupTimeZone, ProcessPosixTimeZone): Restored the use of a literal - * library/history.tcl (HistAdd): 'then' when following a multi- - * library/safe.tcl (interpConfigure): line test expresssion. It's an - * library/tm.tcl (UnknownHandler): aid to readability then. - -2009-11-19 Jan Nijtmans - - * generic/tclInt.h: Make all internal initialization - * generic/tclTest.c: routines MODULE_SCOPE - * generic/tclTestObj.c: - * generic/tclTestProcBodyObj.c: - * generic/tclThreadTest.c: - * unix/Makefile.in: Fix [Bug 2883850]: pkgIndex.tcl doesn't - * unix/tclAppInit.c: get created with static Tcl build - * unix/tclXtTest.c: - * unix/tclXtNotify.c: - * unix/tclUnixTest.c: - * win/Makefile.in: - * win/tcl.m4: - * win/configure: (regenerated) - * win/tclAppInit.c: - * win/tclWinDde.c: Always compile with Stubs. - * win/tclWinReg.c: - * win/tclWinTest.c: - -2009-11-18 Jan Nijtmans - - * doc/CrtChannel.3: [Bug 2849797]: Fix channel name inconsistences - * generic/tclIORChan.c: as suggested by DKF. - * generic/tclIO.c: Minor *** POTENTIAL INCOMPATIBILITY *** - because Tcl_CreateChannel() and derivatives - now sometimes ignore their "chanName" - argument. - - * generic/tclAsync.c: Eliminate various gcc warnings (with -Wextra) - * generic/tclBasic.c - * generic/tclBinary.c - * generic/tclCmdAH.c - * generic/tclCmdIL.c - * generic/tclCmdMZ.c - * generic/tclCompile.c - * generic/tclDate.c - * generic/tclExecute.c - * generic/tclDictObj.c - * generic/tclIndexObj.c - * generic/tclIOCmd.c - * generic/tclIOUtil.c - * generic/tclIORTrans.c - * generic/tclOO.c - * generic/tclZlib.c - * generic/tclGetDate.y - * win/tclWinInit.c - * win/tclWinChan.c - * win/tclWinConsole.c - * win/tclWinNotify.c - * win/tclWinReg.c - * library/auto.tcl: Eliminate "then" keyword - * library/clock.tcl - * library/history.tcl - * library/safe.tcl - * library/tm.tcl - * library/http/http.tcl: Eliminate unnecessary spaces - * library/http1.0/http.tcl - * library/msgcat/msgcat.tcl - * library/opt/optparse.tcl - * library/platform/platform.tcl - * tools/tcltk-man2html.tcl - * tools/tclZIC.tcl - * tools/tsdPerf.c - -2009-11-17 Andreas Kupries - - * unix/tclUnixChan.c (TtyParseMode): Partial undo of Donal's tidy-up - from a few days ago (2009-11-9, not in ChangeLog). It seems that - strchr is apparently a macro on AIX and reacts badly to pre-processor - directives in its arguments. - 2009-11-16 Alexandre Ferrieux - * generic/tclEncoding.c: [Bug 2891556]: Fix and improve test to - * generic/tclTest.c: detect similar manifestations in the future. - * tests/encoding.test: Add tcltest support for finalization. - -2009-11-15 Mo DeJong - - * win/tclWinDde.c: Avoid gcc compiler warning by explicitly casting - DdeCreateStringHandle argument. + * generic/tclEncoding.c: Fix [Bug 2891556] and improve test to detect + * tests/decoding.test: similar manifestations in the future. + +2009-11-12 Don Porter + + *** 8.5.8 TAGGED FOR RELEASE *** + + * changes: Update for 8.5.8 release. + + * generic/tclClock.c (TclClockInit): Do not create [clock] support + commands in safe interps. + + * tests/io.test: New test io-53.11 to test for [Bug 2895565]. 2009-11-12 Andreas Kupries * generic/tclIO.c (CopyData): [Bug 2895565]: Dropped bogosity which - * tests/io.test: used the number of _written_ bytes or character to - update the counters for the read bytes/characters. New test io-53.11. - This is a forward port from the 8.5 branch. + used the number of _written_ bytes or character to update the counters + for the read bytes/characters. See last entry for the test case. + +2009-11-11 Pat Thoyts + + * tests/fCmd.test: Fixed a number of issues for Vista and Win7 + * tests/registry.test: that are due to restricted permissions. + * tests/winFCmd.test: 2009-11-11 Don Porter - * generic/tclClock.c (TclClockInit): Do not create [clock] support - commands in safe interps. - -2009-11-11 Jan Nijtmans - - * library/http/http.tcl (http::geturl): [Bug 2891171]: URL checking - too strict when using multiple question marks. - * tests/http.test - * library/http/pkgIndex.tcl: Bump to http 2.8.2 - * unix/Makefile.in: - * win/Makefile.in: + * library/http/http.tcl: [Bug 2891171]: Update the URL syntax + check to RFC 3986 compliance on the subject of non-encoded question + mark characters. + + * library/http/pkgIndex.tcl: Bump to http 2.7.5 to avoid any + * unix/Makefile.in: confusion with snapshot "releases" + * win/Makefile.in: that might be in ActiveTcl, etc. 2009-11-11 Alexandre Ferrieux - * generic/tclIO.c: Fix [Bug 2888099] (close discards ENOSPC error) by - saving the errno from the first of two FlushChannel()s. Uneasy to - test; might need specific channel drivers. Four-hands with aku. - -2009-11-10 Pat Thoyts - - * tests/winFCmd.test: Cleanup directories that have been set chmod - 000. On Windows7 and Vista we really have no access and these were - getting left behind. - A few tests were changed to reflect the intent of the test where - setting a directory chmod 000 should prevent any modification. This - restriction was ignored on XP but is honoured on Vista - -2009-11-10 Andreas Kupries - - * generic/tclBasic.c: Plug another leak in TCL_EVAL_DIRECT evaluation. - Forward port from Tcl 8.5 branch, change by Don Porter. - - * generic/tclObj.c: [Bug 2895323]: Plug memory leak in - TclContinuationsEnter(). Forward port from Tcl 8.5 branch, change by - Don Porter. - -2009-11-09 Stuart Cassoff + * generic/tclIO.c: Fix [Bug 2888099] (close discards ENOSPC error) + by saving the errno from the first of two + FlushChannel()s. Uneasy to test; might need + specific channel drivers. Four-hands with aku. + +2009-11-10 Don Porter + + * generic/tclBasic.c: Plug another leak in TCL_EVAL_DIRECT + evaluation. + + * generic/tclObj.c: Plug memory leak in TclContinuationsEnter(). + [Bug 2895323] + +2009-11-09 Stuart Cassoff * win/README: [bug 2459744]: Removed outdated Msys + Mingw info. -2009-11-09 Andreas Kupries - - * generic/tclBasic.c (TclEvalObjEx): Moved the #280 decrement of - refCount for the file path out of the branch after the whole - conditional, closing a memory leak. Added clause on structure type to - prevent seg.faulting. Forward port from valgrinding the Tcl 8.5 - branch. - - * tests/info.test: Resolve ambiguous resolution of variable "res". - Forward port from 8.5 - -2009-11-08 Donal K. Fellows - - * doc/string.n (bytelength): Noted that this command is not a good - thing to use, and suggested a better alternatve. Also factored out the - description of the indices into its own section. - -2009-11-07 Pat Thoyts - - * tests/fCmd.test: [Bug 2891026]: Exclude tests using chmod 555 - directories on vista and win7. The current user has access denied and - so cannot rename the directory without admin privileges. - -2009-11-06 Andreas Kupries - - * library/safe.tcl (::safe::Setup): Added documentation of the - contents of the state array. Also killed the 'InterpState' procedure - with its upleveled variable/upvar combination, and replaced all uses - with 'namespace upvar'. - -2009-11-05 Andreas Kupries - - * library/safe.tcl: A series of patches which bring the SafeBase up to - date with code guidelines, Tcl's features, also eliminating a number - of inefficiencies along the way. - (1) Changed all procedure names to be fully qualified. - (2) Moved the procedures out of the namespace eval. Kept their - locations. IOW, broke the namespace eval apart into small sections not - covering the procedure definitions. - (3) Reindented the code. Just lots of whitespace changes. - Functionality unchanged. - (4) Moved the multiple namespace eval's around. Command export at the - top, everything else (var decls, argument parsing setup) at the - bottom. - (5) Moved the argument parsing setup into a procedure called when the - code is loaded. Easier management of temporary data. - (6) Replaced several uses of 'Set' with calls to the new procedure - 'InterpState' and direct access to the per-slave state array. - (7) Replaced the remaining uses of 'Set' and others outside of the - path/token handling, and deleted a number of procedures related to - state array access which are not used any longer. - (8) Converted the path token system to cache normalized paths and path - <-> token conversions. Removed more procedures not used any longer. - Removed the test cases 4.3 and 4.4 from safe.test. They were testing - the now deleted command "InterpStateName". - (9) Changed the log command setup so that logging is compiled out - completely when disabled (default). - (10) Misc. cleanup. Inlined IsInterp into CheckInterp, its only user. - Consistent 'return -code error' for error reporting. Updated to use - modern features (lassign, in/ni, dicts). The latter are used to keep a - reverse path -> token map and quicker check of existence. - (11) Fixed [Bug 2854929]: Recurse into all subdirs under all TM root - dirs and put them on the access path. - -2009-11-02 Kevin B. Kenny +2009-11-09 Don Porter + + * generic/tclBasic.c (TclEvalObjEx): Plug memory leak in + TCL_EVAL_DIRECT evaluation. + + * tests/info.test: Resolve ambiguous resolution of variable "res". + +2009-11-03 Don Porter + + * generic/tcl.h: Bump to 8.5.8 for release. + * library/init.tcl: + * tools/tcl.wse.in: + * unix/configure.in: + * unix/tcl.spec: + * win/configure.in: + * README: + + * unix/configure: autoconf-2.59 + * win/configure: + + * changes: Update for 8.5.8 release. + +2009-11-03 Andreas Kupries + + * library/safe.tcl (::safe::InterpSetConfig): [Bug 2854929]: Added + code to recursively find deeper paths which may contain modules. + Required to handle modules with names like 'platform::shell', which + translate into 'platform/shell-X.tm', i.e arbitrarily deep + subdirectories. + +2009-11-03 Kevin B. Kenny * library/tzdata/Asia/Novokuznetsk: New tzdata locale for Kemerovo oblast', which now keeps Novosibirsk time and not Kranoyarsk time. * library/tzdata/Asia/Damascus: Syrian DST changes. * library/tzdata/Asia/Hong_Kong: Hong Kong historic DST corrections. Olson tzdata2009q. -2009-11-02 Donal K. Fellows - - * doc/object.n (DESCRIPTION): Substantive revision to make it clearer - what the fundamental semantics of an object actually are. - -2009-11-01 Joe Mistachkin - - * doc/Cancel.3: Minor cosmetic fixes. - * win/makefile.vc: Make htmlhelp target work again. An extra set of - double quotes around the definition of the HTML help compiler tool - appears to be required. Previously, there was one set of double - quotes around the definition of the tool and one around the actual - invocation. This led to confusion because it was the only such tool - path to include double quotes around its invocation. Also, it was - somewhat inflexible in the event that somebody needed to override the - tool command to include arguments. Therefore, even though it may look - "wrong", there are now two double quotes on either side of the tool - path definition. This fixes the problem that currently prevents the - htmlhelp target from building and maintains flexibility in case - somebody needs to override it via the command line or an environment - variable. - -2009-11-01 Joe English - - * doc/Eval.3, doc/Cancel.3: Move TIP#285 routines out of Eval.3 into - their own manpage. +2009-11-03 Pat Thoyts + + * tests/tcltest.test: Backport permissions fix for Win7. 2009-10-31 Donal K. Fellows * generic/tclBasic.c (ExprRoundFunc): [Bug 2889593]: Correctly report the expected number of arguments when generating an error for round(). -2009-10-30 Pat Thoyts - - * tests/tcltest.test: When creating the notwritabledir we deny the - current user access to delete the file. We must grant this right when - we cleanup. Required on Windows 7 when the user does not automatically - have administrator rights. - 2009-10-29 Don Porter * generic/tcl.h: Changed the typedef for the mp_digit type from: typedef unsigned long mp_digit; @@ -7044,36 +2810,20 @@ 8.5.0 - 8.5.7. Such possibilities should be checked, and if such incompatibilities are present, suitable [package require] requirements on the Tcl release should be put in place to keep such built code [load]-ing only in Tcl interps that are compatible. -2009-10-29 Donal K. Fellows - - * tests/dict.test: Make variable-clean and simplify tests by utilizing - the fact that dictionaries have defined orders. - - * generic/tclZlib.c (TclZlibCmd): Remove accidental C99-ism which - reportedly makes the AIX native compiler choke. - 2009-10-29 Kevin B. Kenny * library/clock.tcl (LocalizeFormat): * tests/clock.test (clock-67.1): [Bug 2819334]: Corrected a problem where '%%' followed by a letter in a format group could expand recursively: %%R would turn into %%H:%M:%S 2009-10-28 Don Porter - * generic/tclLiteral.c: [Bug 2888044]: Fixed 2 bugs. - * tests/info.test: First, as noted in the comments of the - TclCleanupLiteralTable routine, since the teardown of the intrep of - one Tcl_Obj can cause the teardown of others in the same table, the - full table cleanup must be done with care, but the code did not - contain the same care demanded in the comment. Second, recent - additions to the info.test file had poor hygiene, leaving an array - variable ::a lying around, which breaks later interp.test tests during - a -singleproc 1 run of the test suite. + * generic/tclLiteral.c: Backport fix for [Bug 2888044]. 2009-10-28 Kevin B. Kenny * tests/fileName.test (fileName-20.[78]): Corrected poor test hygiene (failure to save and restore the working directory) that @@ -7096,15 +2846,10 @@ * library/tzdata/America/Argentina/Cordoba: * library/tzdata/America/Argentina/San_Luis: * library/tzdata/America/Argentina/Tucuman: New DST rules for Argentina. (Olson's tzdata2009p.) -2009-10-26 Don Porter - - * unix/Makefile.in: Remove $(PACKAGE).* and prototype from the - `make distclean` target. Completes 2009-10-20 commit. - 2009-10-24 Kevin B. Kenny * library/clock.tcl (ProcessPosixTimeZone): Corrected a regression in the fix to [Bug 2207436] that caused [clock] to apply EU daylight saving time rules in the US. @@ -7120,31 +2865,15 @@ * generic/tclIO.c (FlushChannel): Skip OutputProc for low-level 0-length writes. When closing pipes which have already been closed not skipping leads to spurious SIG_PIPE signals. Reported by Mikhail Teterin . -2009-10-22 Donal K. Fellows - - * generic/tclOOBasic.c (TclOO_Object_VarName): [Bug 2883857]: Allow - the passing of array element names through this method. - 2009-10-21 Donal K. Fellows * generic/tclPosixStr.c: [Bug 2882561]: Work around oddity on Haiku OS where SIGSEGV and SIGBUS are the same value. - * generic/tclTrace.c (StringTraceProc): [Bug 2881259]: Added back cast - to work around silly bug in MSVC's handling of auto-casting. - -2009-10-20 Don Porter - - * unix/Makefile.in: Removed the long outdated and broken targets - package-* that were for building Solaris packages. Appears that the - pieces needed for these targets to function have never been present in - the current era of Tcl development and belong completely to Tcl - pre-history. - 2009-10-19 Don Porter * generic/tclIO.c: [Patch 2107634]: Revised ReadChars and FilterInputBytes routines to permit reads to continue up to the string limits of Tcl values. Before revisions, large read attempts could @@ -7151,27 +2880,28 @@ panic when as little as half the limiting value length was reached. Thanks to Sean Morrison and Bob Parker for their roles in the fix. 2009-10-18 Joe Mistachkin - * generic/tclObj.c (TclDbDumpActiveObjects, TclDbInitNewObj) - (Tcl_DbIncrRefCount, Tcl_DbDecrRefCount, Tcl_DbIsShared): - [Bug 2871908]: Enforce separation of concerns between the lineCLPtr - and objThreadMap thread specific data members. - -2009-10-18 Joe Mistachkin - * tests/thread.test (thread-4.[345]): [Bug 1565466]: Correct tests to save their error state before the final call to threadReap just in case it triggers an "invalid thread id" error. This error can occur if one or more of the target threads has exited prior to the attempt to send it an asynchronous exit command. + + * doc/memory.n: [Bug 988703]: Add mechanism for finding what Tcl_Objs + * generic/tclCkalloc.c (MemoryCmd): are allocated when built for + * generic/tclInt.decls: memory debugging. This was previously + * generic/tclInt.h: backported from Tcl 8.6 with the corrections to + * generic/tclObj.c (ObjData, TclFinalizeThreadObjects): fix [Bug + 2871908]. However, there were key elements missing. These changes make + things consistent between branches. 2009-10-17 Donal K. Fellows - * generic/tclVar.c (UnsetVarStruct, TclDeleteNamespaceVars) - (TclDeleteCompiledLocalVars, DeleteArray): + * generic/tclVar.c (TclDeleteCompiledLocalVars, UnsetVarStruct) + (TclDeleteNamespaceVars): * generic/tclTrace.c (Tcl_UntraceVar2): [Bug 2629338]: Stop traces that are deleted part way through (a feature used by tdom) from causing freed memory to be accessed. 2009-10-08 Donal K. Fellows @@ -7192,32 +2922,22 @@ a different errno assignment and break with the hardwired number. Reported by emiliano on the chat. 2009-10-06 Don Porter - * generic/tclInterp.c (SlaveEval): Agressive stomping of internal reps - was added as part of the NRE patch of 2008-07-13. This doesn't appear - to actually be needed, and it hurts quite a bit when large lists lose - their intreps and require reparsing. Thanks to Ashok Nadkarni for - reporting the problem. - * generic/tclTomMathInt.h (new): Public header tclTomMath.h had * generic/tclTomMath.h: dependence on private headers, breaking use * generic/tommath.h: by extensions [Bug 1941434]. -2009-10-05 Andreas Kupries +2009-10-05 Don Porter - * library/safe.tcl (AliasGlob): Fixed conversion of catch to - try/finally, it had an 'on ok msg' branch missing, causing a silent - error immediately, and bogus glob results, breaking search for Tcl - modules. + * changes: Update for 8.5.8 release. 2009-10-04 Daniel Steffen - * macosx/tclMacOSXBundle.c: [Bug 2569449]: Workaround CF memory - * unix/tclUnixInit.c: managment bug in Mac OS X 10.4 & - earlier. + * macosx/tclMacOSXBundle.c: Workaround CF memory managment bug in + * unix/tclUnixInit.c: Mac OS X 10.4 & earlier. [Bug 2569449] 2009-10-02 Kevin B. Kenny * library/tzdata/Africa/Cairo: * library/tzdata/Asia/Gaza: @@ -7224,156 +2944,28 @@ * library/tzdata/Asia/Karachi: * library/tzdata/Pacific/Apia: Olson's tzdata2009n. 2009-09-29 Don Porter - * generic/tclDictObj.c: [Bug 2857044]: Updated freeIntRepProc - * generic/tclExecute.c: routines so that they set the typePtr - * generic/tclIO.c: field to NULL so that the Tcl_Obj is - * generic/tclIndexObj.c: not left in an inconsistent state. - * generic/tclInt.h: - * generic/tclListObj.c: - * generic/tclNamesp.c: - * generic/tclOOCall.c: - * generic/tclObj.c: - * generic/tclPathObj.c: - * generic/tclProc.c: - * generic/tclRegexp.c: - * generic/tclStringObj.c: - * generic/tclAlloc.c: Cleaned up various routines in the * generic/tclCkalloc.c: call stacks for memory allocation to * generic/tclInt.h: guarantee that any size values computed * generic/tclThreadAlloc.c: are within the domains of the routines they get passed to. [Bugs 2557696 and 2557796]. -2009-09-28 Don Porter - - * generic/tclCmdMZ.c: Replaced TclProcessReturn() calls with - * tests/error.test: Tcl_SetReturnOptions() calls as a simple fix - for [Bug 2855247]. Thanks to Anton Kovalenko for the report and fix. - Additional fixes for other failures demonstrated by new tests. - -2009-09-27 Don Porter - - * tests/error.test (error-15.8.*): Coverage tests illustrating - flaws in the propagation of return options by [try]. - -2009-09-26 Donal K. Fellows - - * unix/tclooConfig.sh, win/tclooConfig.sh: [Bug 2026844]: Added dummy - versions of tclooConfig.sh that make it easier to build extensions - against both Tcl8.5+TclOO-standalone and Tcl8.6. - -2009-09-24 Don Porter - - TIP #356 IMPLEMENTATION - - * generic/tcl.decls: Promote internal routine TclNRSubstObj() - * generic/tclCmdMZ.c: to public Tcl_NRSubstObj(). Still needs docs. - * generic/tclCompile.c: - * generic/tclInt.h: - - * generic/tclDecls.h: make genstubs - * generic/tclStubInit.c: - -2009-09-23 Miguel Sofer - - * doc/namespace.n: the description of [namespace unknown] failed - to mention [namespace path]: fixed. Thx emiliano. - -2009-09-21 Mo DeJong - - * tests/regexp.test: Added check for error message from - unbalanced [] in regexp. Added additional simple test cases - of basic regsub command. - -2009-09-21 Don Porter - - * generic/tclCompile.c: Correct botch in the conversion of - Tcl_SubstObj(). Thanks to Kevin Kenny for detection and report. - -2009-09-17 Don Porter - - * generic/tclCompile.c: Re-implement Tcl_SubstObj() as a simple - * generic/tclParse.c: wrapper around TclNRSubstObj(). This has - * tests/basic.test: the effect of caching compiled bytecode in - * tests/parse.test: the value to be substituted. Note that - Tcl_SubstObj() now exists only for extensions. Tcl itself no longer - makes any use of it. Note also that TclSubstTokens() is now reachable - only by Tcl_EvalEx() and Tcl_ParseVar() so tests aiming to test its - functioning needed adjustment to still have the intended effect. - -2009-09-16 Alexandre Ferrieux - - * generic/tclObj.c: Extended ::tcl::unsupported::representation. - 2009-09-11 Don Porter - * generic/tclBasic.c: Completed the NR-enabling of [subst]. - * generic/tclCmdMZ.c: [Bug 2314561]. - * generic/tclCompCmds.c: - * generic/tclCompile.c: - * generic/tclInt.h: - * tests/coroutine.test: - * tests/parse.test: - -2009-09-11 Donal K. Fellows - - * tests/http.test: Added in cleaning up of http tokens for each test - to reduce amount of global-variable pollution. + * library/http/http.tcl: Bump to http 2.7.4 to account for + * library/http/pkgIndex.tcl: [Bug 2849860] fix. + * unix/Makefile.in: + * win/Makefile.in: 2009-09-10 Donal K. Fellows * library/http/http.tcl (http::Event): [Bug 2849860]: Handle charset names in double quotes; some servers like generating them like that. -2009-09-07 Don Porter - - * generic/tclParse.c: [Bug 2850901]: Corrected line counting error - * tests/into.test: in multi-command script substitutions. - -2009-09-07 Daniel Steffen - - * generic/tclExecute.c: Fix potential uninitialized variable use and - * generic/tclFCmd.c: null dereference flagged by clang static - * generic/tclProc.c: analyzer. - * generic/tclTimer.c: - * generic/tclUtf.c: - - * generic/tclExecute.c: Silence false positives from clang static - * generic/tclIO.c: analyzer about potential null dereference. - * generic/tclScan.c: - * generic/tclCompExpr.c: - -2009-09-04 Don Porter - - * generic/tclCompCmds.c (TclCompileSubstCmd): [Bug 2314561]: - * generic/tclBasic.c: Added a bytecode compiler routine for the - * generic/tclCmdMZ.c: [subst] command. This is a partial solution to - * generic/tclCompile.c: the need to NR-enable [subst] since bytecode - * generic/tclCompile.h: execution is already NR-enabled. Two new - * generic/tclExecute.c: bytecode instructions, INST_NOP and - * generic/tclInt.h: INST_RETURN_CODE_BRANCH were added to support - * generic/tclParse.c: the new routine. INST_RETURN_CODE_BRANCH is - * tests/basic.test: likely to be useful in any future effort to - * tests/info.test: add a bytecode compiler routine for [try]. - * tests/parse.test: - -2009-09-03 Donal K. Fellows - - * doc/LinkVar.3: [Bug 2844962]: Added documentation of issues relating - to use of this API in a multi-threaded environment. - -2009-09-01 Andreas Kupries - - * generic/tclIORTrans.c (ReflectInput): Remove error response to - 0-result from method 'limit?' of transformations. Return the number of - copied bytes instead, which is possibly nothing. The latter then - triggers EOF handling in the higher layers, making the 0-result of - limit? the way to inject artificial EOF's into the data stream. - 2009-09-01 Don Porter * library/tcltest/tcltest.tcl: Bump to tcltest 2.3.2 after revision * library/tcltest/pkgIndex.tcl: to verbose error message. * unix/Makefile.in: @@ -7385,36 +2977,34 @@ overflow cases in [format]. 2009-08-25 Andreas Kupries * generic/tclBasic.c (Tcl_CreateInterp, Tcl_EvalTokensStandard) - (Tcl_EvalEx, TclEvalEx, TclAdvanceContinuations, TclNREvalObjEx): + (EvalTokensStandard, Tcl_EvalEx, EvalEx, TclAdvanceContinuations) + (TclEvalObjEx): * generic/tclCmdMZ.c (Tcl_SwitchObjCmd, TclListLines): * generic/tclCompCmds.c (*): * generic/tclCompile.c (TclSetByteCodeFromAny, TclInitCompileEnv) - (TclFreeCompileEnv, TclCompileScript, TclCompileTokens): + (TclFreeCompileEnv, TclCompileScript): * generic/tclCompile.h (CompileEnv): * generic/tclInt.h (ContLineLoc, Interp): * generic/tclObj.c (ThreadSpecificData, ContLineLocFree) - (TclThreadFinalizeObjects, TclInitObjSubsystem, TclContinuationsEnter, - (TclContinuationsEnterDerived, TclContinuationsCopy, TclFreeObj) - (TclContinuationsGet): + (TclThreadFinalizeObjects, TclInitObjSubsystem, TclContinuationsEnter) + (TclContinuationsEnterDerived, TclContinuationsCopy) + (TclContinuationsGet, TclFreeObj): * generic/tclParse.c (TclSubstTokens, Tcl_SubstObj): * generic/tclProc.c (TclCreateProc): * generic/tclVar.c (TclPtrSetVar): * tests/info.test (info-30.0-24): - Extended the parser, compiler, and execution engine with code and - attendant data structures tracking the position of continuation lines - which are not visible in the resulting script Tcl_Obj*'s, to properly - account for them while counting lines for #280. + Extended parser, compiler, and execution with code and attendant data + structures tracking the positions of continuation lines which are not + visible in script Tcl_Obj*'s, to properly account for them while + counting lines for #280. 2009-08-24 Daniel Steffen - * generic/tclInt.h: Annotate Tcl_Panic as noreturn for clang static - analyzer in PURIFY builds, replacing preprocessor/assert technique. - * macosx/tclMacOSXNotify.c: Fix multiple issues with nested event loops when CoreFoundation notifier is running in embedded mode. (Fixes problems in TkAqua Cocoa reported by Youness Alaoui on tcl-mac) 2009-08-21 Don Porter @@ -7434,150 +3024,53 @@ refactored to make an AppendPath() routine instead of the cut/paste stanzas that were littered throughout. 2009-08-20 Donal K. Fellows - * generic/tclCmdIL.c (TclNRIfObjCmd): [Bug 2823276]: Make [if] - NRE-safe on all arguments when interpreted. - (Tcl_LsortObjCmd): Close off memory leak. - -2009-08-19 Donal K. Fellows - - * generic/tclCmdAH.c (TclNRForObjCmd, etc.): [Bug 2823276]: Make [for] - and [while] into NRE-safe commands, even when interpreted. + * generic/tclCmdIL.c (Tcl_LsortObjCmd): Plug memory leak. 2009-08-18 Don Porter * generic/tclPathObj.c: [Bug 2837800]: Added NULL check to prevent * tests/fileName.test: crashes during [glob]. -2009-08-16 Jan Nijtmans - - * unix/dltest/pkge.c: const addition - * unix/tclUnixThrd.c: Use in stead of "pthread.h" - * win/tclWinDde.c: Eliminate some more gcc warnings - * win/tclWinReg.c: - * generic/tclInt.h: Change ForIterData, make it const-safe. - * generic/tclCmdAH.c: - -2009-08-12 Don Porter - - TIP #353 IMPLEMENTATION - - * doc/NRE.3: New public routine Tcl_NRExprObj() permits - * generic/tcl.decls: extension commands to evaluate Tcl expressions - * generic/tclBasic.c: in NR-enabled command procedures. - * generic/tclCmdAH.c: - * generic/tclExecute.c: - * generic/tclInt.h: - * generic/tclObj.c: - * tests/expr.test: - - * generic/tclDecls.h: make genstubs - * generic/tclStubInit.c: - 2009-08-06 Andreas Kupries * doc/refchan.n [Bug 2827000]: Extended the implementation of * generic/tclIORChan.c: reflective channels (TIP 219, method * tests/ioCmd.test: 'read'), enabling handlers to signal EAGAIN to indicate 'no data, but not at EOF either', and other system errors. Updated documentation, extended testsuite (New test cases iocmd*-23.{9,10}). -2009-08-02 Miguel Sofer - - * tests/coroutine.test: fix testfile cleanup - 2009-08-02 Donal K. Fellows - * generic/tclObj.c (Tcl_RepresentationCmd): Added an unsupported - command for reporting the representation of an object. Result string - is deliberately a bit obstructive so that people are not encouraged to - make code that depends on it; it's a debugging tool only! - * unix/tclUnixFCmd.c (GetOwnerAttribute, SetOwnerAttribute) (GetGroupAttribute, SetGroupAttribute): [Bug 1942222]: Stop calling * unix/tclUnixFile.c (TclpGetUserHome): endpwent() and endgrent(); they've been unnecessary for ages. -2009-08-02 Jan Nijtmans - - * win/tclWin32Dll.c: Eliminate TclWinResetInterfaceEncodings, since it - * win/tclWinInit.c: does exactly the same as TclWinEncodingsCleanup, - * win/tclWinInt.h: make sure that tclWinProcs and - tclWinTCharEncoding are always set and reset - concurrently. - * win/tclWinFCmd.c: Correct check for win95 - 2009-07-31 Don Porter * generic/tclStringObj.c: [Bug 2830354]: Corrected failure to * tests/format.test: grow buffer when format spec request large width floating point values. Thanks to Clemens Misch. -2009-07-26 Donal K. Fellows - - * library/auto.tcl (tcl_findLibrary, auto_mkindex): - * library/package.tcl (pkg_mkIndex, tclPkgUnknown, MacOSXPkgUnknown): - * library/safe.tcl (interpAddToAccessPath, interpDelete, AliasGlob): - (AliasSource, AliasLoad, AliasEncoding): - * library/tm.tcl (UnknownHandler): Simplify by swapping some [catch] - gymnastics for use of [try]. - -2009-07-26 Alexandre Ferrieux - - * tools/genStubs.tcl: Forced LF translation when generating .h's to - avoid spurious diffs when regenerating on a Windows box. - -2009-07-26 Jan Nijtmans - - * win/Makefile.in: [Bug 2827066]: msys build --enable-symbols broken - * win/tcl.m4: And modified the same for unicows.dll, as a - * win/configure: preparation for [Enh 2819611]. - -2009-07-25 Donal K. Fellows - - * library/history.tcl (history): Reworked the history mechanism in - terms of ensembles, rather than the ad hoc ensemble-lite mechanism - used previously. - -2009-07-24 Donal K. Fellows - - * doc/self.n (self class): [Bug 2704302]: Add some text to make it - clearer how to get the name of the current object's class. - -2009-07-23 Andreas Kupries +2009-07-24 Andreas Kupries * generic/tclIO.c (Tcl_GetChannelHandle): [Bug 2826248]: Do not crash * generic/tclPipe.c (FileForRedirect): for getHandleProc == NULL, this is allowed. Provide a nice error message in the bypass area. Updated caller to check the bypass for a mesage. Bug reported by Andy - Sonnenburg + Sonnenburg . Backported from CVS + head. 2009-07-23 Joe Mistachkin * generic/tclNotify.c: [Bug 2820349]: Ensure that queued events are freed once processed. -2009-07-22 Jan Nijtmans - - * macosx/tclMacOSXFCmd.c: CONST -> const - * generic/tclGetDate.y: - * generic/tclDate.c: - * generic/tclLiteral.c: (char *) cast in ckfree call - * generic/tclPanic.c: [Feature Request 2814786]: remove TclpPanic - * generic/tclInt.h - * unix/tclUnixPort.h - * win/tclWinPort.h - -2009-07-22 Alexandre Ferrieux - - * generic/tclEvent.c: [Bug 2001201 again]: Refined the 20090617 patch - on [exit] streamlining, so that it now correctly calls thread exit - handlers for the calling thread, including bindings in Tk. - 2009-07-21 Kevin B. Kenny * library/tzdata/Asia/Dhaka: * library/tzdata/Indian/Mauritius: Olson's tzdata2009k. @@ -7587,216 +3080,58 @@ more efficient when parsing things that are correct, at a cost of making the empty string test slightly more costly. With this, the cost of doing [string is integer -strict $x] matches [catch {expr {$x+0}}] in the successful case, and greatly outstrips it in the failing case. -2009-07-19 Donal K. Fellows - - * generic/tclOO.decls, generic/tclOO.c (Tcl_GetObjectName): Expose a - function for efficiently returning the current name of an object. - -2009-07-18 Daniel Steffen - - * unix/Makefile.in: Define NDEBUG in optimized (non-symbols) build to - disable NRE assert()s and threaded allocator range checks. - 2009-07-16 Don Porter - * generic/tclBinary.c: Removed unused variables. - * generic/tclCmdIL.c: + * generic/tclCmdIL.c: Removed unused variables. * generic/tclCompile.c: - * generic/tclExecute.c: - * generic/tclHash.c: - * generic/tclIOUtil.c: * generic/tclVar.c: + * unix/tclUnixChan.c: - * generic/tclBasic.c: Silence compiler warnings about ClientData. - * generic/tclProc.c: + * generic/tclScan.c: Typo in ACCEPT_NAN configuration. - * generic/tclScan.c: Typo in ACCEPT_NAN configuration. - - * generic/tclStrToD.c: [Bug 2819200]: Set floating point control + * generic/tclStrToD.c: [Bug 2819200]: Set floating point control register on MIPS systems so that the gradual underflow expected by Tcl is in effect. -2009-07-15 Donal K. Fellows - - * generic/tclInt.h (Namespace): Added machinery to allow - * generic/tclNamesp.c (many functions): reduction of memory used - * generic/tclResolve.c (BumpCmdRefEpochs): by namespaces. Currently - #ifdef'ed out because of compatibility concerns. - - * generic/tclInt.decls: Added four functions for better integration - with itcl-ng. - -2009-07-14 Kevin B. Kenny - - * generic/tclInt.h (TclNRSwitchObjCmd): - * generic/tclBasic.c (builtInCmds): - * generic/tclCmdMZ.c (Tcl_SwitchObjCmd): - * tests/switch.test (switch-15.1): - [Bug 2821401]: Make non-bytecoded [switch] command aware of NRE. - -2009-07-13 Andreas Kupries - - * generic/tclCompile.c (TclInitCompileEnv, EnterCmdWordIndex) - (TclCleanupByteCode, TclCompileScript): - * generic/tclExecute.c (TclCompileObj, TclExecuteByteCode): - * tclCompile.h (ExtCmdLoc): - * tclInt.h (ExtIndex, CFWordBC, CmdFrame): - * tclBasic.c (DeleteInterpProc, TclArgumentBCEnter) - (TclArgumentBCRelease, TclArgumentGet, SAVE_CONTEXT) - (RESTORE_CONTEXT, NRCoroutineExitCallback, TclNRCoroutineObjCmd): - * generic/tclCmdAH.c (TclNRForObjCmd, TclNRForIterCallback, - (ForNextCallback): - * generic/tclCmdMZ.c (TclNRWhileObjCmd): - - Extended the bytecode compiler initialization to recognize the - compilation of whole files (NRE enabled 'source' command) and switch - to the counting of absolute lines in that case. - - Further extended the bytecode compiler to track the start line in the - generated information, and modified the bytecode execution to - recompile an object if the location as per the calling context doesn't - match the location saved in the bytecode. This part could be optimized - more by using more memory to keep all possibilities which occur - around, or by just adjusting the location information instead of a - total recompile. +2009-07-14 Andreas Kupries + + * generic/tclBasic.c (DeleteInterpProc,TclArgumentBCEnter, + (TclArgumentBCRelease, TclArgumentGet): + * generic/tclCompile.c (EnterCmdWordIndex, TclCleanupByteCode, + (TclInitCompileEnv, TclCompileScript): + * generic/tclCompile.h (ExtCmdLoc): + * generic/tclExecute.c (TclExecuteByteCode): + * generic/tclInt.h (ExtIndex, CFWordBC): + * tests/info.test (info-39.0): + + Backport of some changes made to the Tcl head, to handle literal + sharing better. The code here is much simpler (trimmed down) compared + to the head as the 8.5 branch is not bytecode compiling whole files, + and doesn't compile eval'd code either. Reworked the handling of literal command arguments in bytecode to be saved (compiler) and used (execution) per command (See the TCL_INVOKE_STK* instructions), and not per the whole bytecode. This, and the previous change remove the problems with location data caused by literal sharing (across whole files, but also proc bodies). Simplified the associated datastructures (ExtIndex is gone, as is the function EnterCmdWordIndex). - The last change causes the hashtable 'lineLABCPtr' to be state which - has to be kept per coroutine, like the CmdFrame stack. Reworked the - coroutine support code to create, delete and switch the information as - needed. Further reworked the tailcall command as well, it has to pop - its own arguments when run in a bytecode context to keep a proper - stack in 'lineLABCPtr'. - - Fixed the mishandling of line information in the NRE-enabled 'for' and - 'while' commands introduced when both were made to share their - iteration callbacks without taking into account that the loop body is - found in different words of the command. Introduced a separate data - structure to hold all the callback information, as we went over the - limit of 4 direct client-data values for NRE callbacks. - - The above fixes [Bug 1605269]. - -2009-07-12 Donal K. Fellows - - * generic/tclCmdMZ.c (StringIndexCmd, StringEqualCmd, StringCmpCmd): - * generic/tclExecute.c (TclExecuteByteCode): [Bug 2637173]: Factor out - * generic/tclInt.h (TclIsPureByteArray): the code to determine if - * generic/tclUtil.c (TclStringMatchObj): it is safe to work with - byte arrays directly, so that we get the check correct _once_. - - * generic/tclOOCall.c (TclOOGetCallContext): [Bug 1895546]: Changed - * generic/tclOO.c (TclOOObjectCmdCore): the way that the cache is - managed so that when itcl does cunning things, those cunning things - can be cached properly. - -2009-07-11 Donal K. Fellows - - * doc/vwait.n: Substantially increased the discussion of issues and - work-arounds relating to nested vwaits, following discussion on the - tcl-core mailing list on the topic. - -2009-07-10 Pat Thoyts - - * tests/zlib.test: ZlibTransformClose may be called with a NULL - * generic/tclZlib.c: interpreter during finalization and - Tcl_SetChannelError requires a list. Added some tests to ensure error - propagation from the zlib library to the interp. - -2009-07-09 Pat Thoyts - - * tests/zlib.test: [Bug 2818131]: Added tests and fixed a typo that - broke [zlib push] for deflate format. - -2009-07-09 Donal K. Fellows - - * compat/mkstemp.c (mkstemp): [Bug 2819227]: Use rand() for random - numbers as it is more portable. - -2009-07-05 Donal K. Fellows - - * generic/tclZlib.c (ZlibTransformWatch): Correct the handling of - events so that channel transforms work with things like an asynch - [chan copy]. Problem reported by Pat Thoyts. - 2009-07-01 Pat Thoyts * win/tclWinInt.h: [Bug 2806622]: Handle the GetUserName API call * win/tclWin32Dll.c: via the tclWinProcs indirection structure. This * win/tclWinInit.c: fixes a problem obtaining the username when the USERNAME environment variable is unset. -2009-06-30 Daniel Steffen - - * generic/tclInt.h: Add assert macros for clang static - * generic/tclPanic.c: analyzer and redefine Tcl_Panic to - * generic/tclStubInit.c: assert after panic in clang PURIFY - builds. - - * generic/tclCmdIL.c: Add clang assert for false positive - from static analyzer. - -2009-06-26 Daniel Steffen - - * macosx/Tcl-Common.xcconfig: Update projects for Xcode 3.1 and - * macosx/Tcl.xcode/*: 3.2, standardize on gcc 4.2, remove - * macosx/Tcl.xcodeproj/*: obsolete configurations and pre-Xcode - * macosx/Tcl.pbproj/* (removed): project. - - * macosx/README: Update project docs, cleanup. - - * unix/Makefile.in: Update dist target for project - changes. - -2009-06-24 Donal K. Fellows - - * tests/oo.test (oo-19.1): [Bug 2811598]: Make more resilient. - -2009-06-24 Pat Thoyts - - * tests/http11.test: [Bug 2811492]: Clean up procs after testing. - -2009-06-18 Donal K. Fellows - - * generic/tclCkalloc.c (MemoryCmd): [Bug 988703]: - * generic/tclObj.c (ObjData, TclFinalizeThreadObjects): Add mechanism - for discovering what Tcl_Objs are allocated when built for memory - debugging. Developed by Joe Mistachkin. - -2009-06-17 Alexandre Ferrieux - - * generic/tclEvent.c: Applied a patch by George Peter Staplin - drastically reducing the ambition of [exit] wrt finalization, and - thus solving many multi-thread teardown issues. [Bugs 2001201, - 486399, and possibly 597575, 990457, 1437595, 2750491] - 2009-06-15 Don Porter * generic/tclStringObj.c: sprintf() -> Tcl_ObjPrintf() conversion. -2009-06-15 Reinhard Max - - * unix/tclUnixPort.h: Move all socket-related code from tclUnixChan.c - * unix/tclUnixChan.c: to tclUnixSock.c. - * unix/tclUnixSock.c: - -2009-06-15 Donal K. Fellows - - * tools/tcltk-man2html.tcl (make-man-pages): [Patch 557486]: Apply - last remaining meaningful part of this patch, a clean up of some - closing tags. - 2009-06-13 Don Porter * generic/tclCompile.c: [Bug 2802881]: The value stashed in * generic/tclProc.c: iPtr->compiledProcPtr when compiling a proc * tests/execute.test: survives too long. We only need it there long @@ -7815,14 +3150,10 @@ overflow the integer calculations computing the length of the %ll formats of really big integers. Also added protections so that [format]s that would produce results overflowing the maximum string length of Tcl values throw a normal Tcl error instead of a panic. - * generic/tclStringObj.c: [Bug 2803109]: Corrected failures to - deal with the "pure unicode" representation of an empty string. - Thanks to Julian Noble for reporting the problem. - 2006-06-09 Kevin B. Kenny * generic/tclGetDate.y: Fixed a thread safety bug in the generated * library/clock.tcl: Bison parser (needed a %pure-parser * tests/clock.test: declaration to avoid static variables). @@ -7835,14 +3166,10 @@ 2006-06-08 Kevin B. Kenny * library/tzdata/Asia/Dhaka: New DST rule for Bangladesh. (Olson's tzdata2009i.) -2009-06-08 Donal K. Fellows - - * doc/copy.n: Fix error in example spotted by Venkat Iyer. - 2009-06-02 Don Porter * generic/tclExecute.c: Replace dynamically-initialized table with a table of static constants in the lookup table for exponent operator computations that fit in a 64 bit integer result. @@ -7853,11 +3180,11 @@ 2009-06-01 Don Porter * tests/expr.test: [Bug 2798543]: Added many tests demonstrating the broken cases. -009-05-30 Kevin B. Kenny +2009-05-30 Kevin B. Kenny * library/tzdata/Africa/Cairo: * library/tzdata/Asia/Amman: Olson's tzdata2009h. 2009-05-29 Andreas Kupries @@ -7865,148 +3192,93 @@ * library/platform/platform.tcl: Fixed handling of cpu ia64, * library/platform/pkgIndex.tcl: taking ia64_32 into account * unix/Makefile.in: now. Bumped version to 1.0.5. Updated the * win/Makefile.in: installation commands. -2009-05-26 Alexandre Ferrieux - - * doc/expr.n: Fixed documentation of the right-associativity of - the ** operator. (spotted by kbk) - -2009-05-14 Donal K. Fellows - - * generic/tclOOInfo.c (InfoObjectNsCmd): Added introspection mechanism - for finding out what an object's namespace is. Experience suggests - that it is just too useful to be able to do without it. - -2009-05-12 Donal K. Fellows - - * doc/vwait.n: Added more words to make it clear just how bad it is to - nest [vwait]s. - - * compat/mkstemp.c: Add more headers to make this file build on IRIX - 6.5. Thanks to Larry McVoy for this. - -2009-05-08 Donal K. Fellows - - * generic/tclOO.c (TclNRNewObjectInstance): [Bug 2414858]: Add a - * generic/tclBasic.c (TclPushTailcallPoint): marker to the stack of - NRE callbacks at the right point so that tailcall works correctly in a - constructor. - - * tests/exec.test (cat): [Bug 2788468]: Adjust the scripted version of - cat so that it does not perform transformations on the data it is - working with, making it more like the standard Unix 'cat' program. - 2009-05-07 Miguel Sofer * generic/tclObj.c (Tcl_GetCommandFromObj): [Bug 2785893]: Ensure that a command in a deleted namespace can't be found through a cached name. - * generic/tclBasic.c: Let coroutines start with a much smaller - * generic/tclCompile.h: stack: 200 words (previously was 2000, the - * generic/tclExecute.c: same as interps). - -2009-05-07 Donal K. Fellows - - * tests/env.test (printenvScript, env-4.3, env-4.5): [Bug 1513659]: - * tests/exec.test (exec-2.6): These tests had subtle dependencies on - being on platforms that were either ISO 8859-1 or UTF-8. Stabilized - the results by forcing the encoding. - 2009-05-06 Don Porter * generic/tclCmdMZ.c: [Bug 2582327]: Improve overflow error message from [string repeat]. - * tests/interp.test: interp-20.50 test for Bug 2486550. - -2009-05-04 Donal K. Fellows - - * generic/tclOO.c (InitFoundation, AllocObject, AllocClass): - * generic/tclOODefineCmds.c (InitDefineContext): Make sure that when - support namespaces are deleted, nothing bad can subsequently happen. - Issue spotted by Don Porter. - -2009-05-03 Donal K. Fellows - - * doc/Tcl.n: [Bug 2538432]: Clarified exact treatment of ${arr(idx)} - form of variable substitution. This is not a change of behavior, just - an improved description of the current situation. - -2009-04-30 Miguel Sofer - - * generic/tclBasic.c (TclObjInvoke): [Bug 2486550]: Make sure that a - null objProc is not used, use Tcl_NRCallObjProc instead. - -2009-05-01 Jan Nijtmans - - * win/configure.in Fix 64-bit detection for zlib on Win64 - * win/configure (regenerated) - 2009-04-28 Jeff Hobbs - * unix/tcl.m4, unix/configure (SC_CONFIG_CFLAGS): harden the check to - add _r to CC on AIX with threads. + * unix/tcl.m4, unix/configure (SC_CONFIG_CFLAGS): harden the check + to add _r to CC on AIX with threads. + +2009-04-27 Alexandre Ferrieux + + * generic/tclInt.h: Backport fix for [Bug 1028264]: WSACleanup() too early. + * generic/tclEvent.c: The fix introduces "late exit handlers" + * win/tclWinSock.c: for similar late process-wide cleanups. + +2009-04-27 Alexandre Ferrieux + + * win/tclWinSock.c: Backport fix for [Bug 2446662]: resync Win + behavior on RST with that of unix (EOF). 2009-04-27 Donal K. Fellows * doc/concat.n (EXAMPLES): [Bug 2780680]: Rewrote so that the spacing of result messages is correct. (The exact way they were wrong was different when rendered through groff or as HTML, but it was still wrong both ways.) -2009-04-27 Jan Nijtmans - - * generic/tclIndexObj.c: Reset internal INTERP_ALTERNATE_WRONG_ARGS - * generic/tclIOCmd.c: flag inside the Tcl_WrongNumArgs function, - so the caller no longer has to do the reset. - -2009-04-24 Stuart Cassoff +2009-04-24 Stuart Cassoff * unix/Makefile.in: [Patch 2769530]: Don't chmod/exec installManPage. -2009-04-19 Pat Thoyts - - * library/http/http.tcl: [Bug 2715421]: Removed spurious newline added - * tests/http11.test: after POST and added tests to detect excess - * tests/httpd11.tcl: bytes being POSTed. - * library/http/pkgIndex.tcl: - * makefiles: package version now 2.8.1 - -2009-04-15 Donal K. Fellows - - * doc/chan.n, doc/close.n: Tidy up documentation of TIP #332. - -2009-04-14 Kevin B. Kenny +2009-04-15 Don Porter + + *** 8.5.7 TAGGED FOR RELEASE *** + + * generic/tclStringObj.c: AppendUnicodeToUnicodeRep failed + to set stringPtr->allocated to 0, leading to crashes. + + * changes: Update for 8.5.7 release. + +2009-04-14 Stuart Cassoff + + * unix/tcl.m4: Removed -Wno-implicit-int from CFLAGS_WARNING. + +2008-04-14 Kevin B. Kenny * library/tzdata/Asia/Karachi: Updated rules for Pakistan Summer Time (Olson's tzdata2009f) -2009-04-11 Donal K. Fellows - - * generic/tclOOMethod.c (InvokeForwardMethod): Clarify the resolution - behaviour of the name of the command that is forwarded to: it's now - resolved using the object's namespace as context, which is much more - useful than the previous (somewhat random) behaviour of using the - caller's current namespace. - -2009-04-10 Pat Thoyts - - * library/http/http.tcl: Improved HTTP/1.1 support and added - * library/http/pkgIndex.tcl: specific HTTP/1.1 testing to ensure - * tests/http11.test: we handle chunked+gzip for the various - * tests/httpd11.test: modes (normal, -channel and -handler) - * makefiles: package version set to 2.8.0 +2009-04-10 Don Porter + + * changes: Update for 8.5.7 release. + + * generic/tcl.h: Bump to 8.5.7 for release. + * library/init.tcl: + * tools/tcl.wse.in: + * unix/configure.in: + * unix/tcl.spec: + * win/configure.in: + * README: + + * unix/configure: autoconf-2.59 + * win/configure: + + * generic/tclStringObj.c (UpdateStringOfString): Fix bug detected + by compiler warning about undefined "dst". + + * tests/httpd: Backport new tests for http 2.7.3. + * tests/http.tcl: 2009-04-10 Daniel Steffen * unix/tclUnixChan.c: TclUnixWaitForFile(): use FD_* macros * macosx/tclMacOSXNotify.c: to manipulate select masks (Cassoff). - [FRQ 1960647] [Bug 3486554] + [Freq 1960647] [Bug 3486554] - * unix/tclLoadDyld.c: Use RTLD_GLOBAL instead of RTLD_LOCAL. + * unix/tclLoadDyld.c: use RTLD_GLOBAL instead of RTLD_LOCAL. [Bug 1961211] * macosx/tclMacOSXNotify.c: revise CoreFoundation notifier to allow embedding into applications that already have a CFRunLoop running and @@ -8032,29 +3304,21 @@ * unix/tclConfig.h.in: autoheader-2.59 * macosx/tclMacOSXBundle.c: on Mac OS X 10.4 and later, replace deprecated NSModule API by dlfcn API. -2009-04-10 Donal K. Fellows - - * doc/StringObj.3: [Bug 2089279]: Corrected example so that it works - on 64-bit machines as well. - -2009-04-10 Pat Thoyts - - * tests/http.test: [Bug 26245326]: Added specific check for problem - * tests/httpd: (return incomplete HTTP response header). - -2009-04-08 Kevin B. Kenny +2009-04-09 Kevin B. Kenny * tools/tclZIC.tcl: Always emit files with Unix line termination. * library/tzdata: Olson's tzdata2009e 2009-04-09 Don Porter - * library/http/http.tcl: [Bug 26245326]: Handle incomplete - lines in the "connecting" state. Thanks to Sergei Golovan. + * library/http/http.tcl: Backport http 2.7.3 from HEAD for + * library/http/pkgIndex.tcl: bundling with the Tcl 8.5.7 release. + * unix/Makefile.in: + * win/Makefile.in: 2009-04-08 Andreas Kupries * library/platform/platform.tcl: Extended the darwin sections to add * library/platform/pkgIndex.tcl: a kernel version number to the @@ -8071,632 +3335,95 @@ * unix/Makefile.in: => tcltest 2.3.1 * win/Makefile.in: 2009-04-07 Don Porter - * generic/tclStringObj.c: Correction so that value of - TCL_GROWTH_MIN_ALLOC is everywhere expressed in bytes as comment - claims. - -2009-04-04 Donal K. Fellows - - * doc/vwait.n: [Bug 1910136]: Extend description and examples to make - it clearer just how this command interprets variable names. + * generic/tclStringObj.c: Completed backports of fixes for + [Bug 2494093] and [Bug 2553906]. 2009-03-30 Don Porter * doc/Alloc.3: [Bug 2556263]: Size argument is "unsigned int". + + * generic/tclStringObj.c: Added protections from invalid memory + * generic/tclTestObj.c: accesses when we append (some part of) + * tests/stringObj.test: a Tcl_Obj to itself. Added the + appendself and appendself2 subcommands to the [teststringobj] testing + command and added tests to the test suite. [Bug 2603158] 2009-03-27 Don Porter * generic/tclPathObj.c (TclPathPart): [Bug 2710920]: TclPathPart() * tests/fileName.test: was computing the wrong results for both [file dirname] and [file tail] on "path" arguments with the PATHFLAGS != 0 intrep and with an empty string for the "joined-on" part. -2009-03-25 Jan Nijtmans - - * doc/tclsh.1: Bring doc and tools in line with - * tools/installData.tcl: http://wiki.tcl.tk/812 - * tools/str2c - * tools/tcltk-man2html.tcl - -2009-03-25 Donal K. Fellows - - * doc/coroutine.n: [Bug 2152285]: Added basic documentation for the - coroutine and yield commands. - -2009-03-24 Donal K. Fellows - - * generic/tclOOBasic.c (TclOOSelfObjCmd): [Bug 2704302]: Make 'self - class' better defined in the context of objects that change class. - - * generic/tclVar.c (Tcl_UpvarObjCmd): [Bug 2673163] (ferrieux) - * generic/tclProc.c (TclObjGetFrame): Make the upvar command more able - to handle its officially documented syntax. - -2009-03-22 Miguel Sofer - - * generic/tclBasic.c: [Bug 2502037]: NR-enable the handling of unknown - commands. - -2009-03-21 Miguel Sofer - - * generic/tclBasic.c: Fixed "leaks" in aliases, imports and - * generic/tclInt.h: ensembles. Only remaining known leak is in - * generic/tclInterp.c: ensemble unknown dispatch (as it not - * generic/tclNamesp.c: NR-enabled) - * tests/tailcall.test: - - * tclInt.h: comments - - * tests/tailcall.test: Added tests to show that [tailcall] does not - currently always execute in constant space: interp-alias, ns-imports - and ensembles "leak" as of this commit. - - * tests/nre.test: [foreach] has been NR-enabled for a while, the test - was marked 'knownBug': unmark it. - - * generic/tclBasic.c: Fix for (among others) [Bug 2699087] - * generic/tclCmdAH.c: Tailcalls now perform properly even from - * generic/tclExecute.c: within [eval]ed scripts. - * generic/tclInt.h: More tests missing, as well as proper - exploration and testing of the interaction with "redirectors" like - interp-alias (suspect that it does not happen in constant space) - and pure-eval commands. - - * generic/tclExecute.c: Proper fix for [Bug 2415422]. Reenabled - * tests/nre.test: the failing assertion that was disabled on - 2008-12-18: the assertion is correct, the fault was in the - management of expansions. - - * generic/tclExecute.c: Fix both test and code for tailcall - * tests/tailcall.test: from within a compiled [eval] body. - - * tests/tailcall.test: Slightly improved tests - 2009-03-20 Don Porter * tests/stringObj.test: [Bug 2597185]: Test stringObj-6.9 checks that Tcl_AppendStringsToObj() no longer crashes when operating on a pure unicode value. * generic/tclExecute.c (INST_CONCAT1): [Bug 2669109]: Panic when appends overflow the max length of a Tcl value. -2009-03-19 Miguel Sofer - - * generic/tcl.h: - * generic/tclInt.h: - * generic/tclBasic.c: - * generic/tclExecute.c: - * generic/tclNamesp.c (Tcl_PopCallFrame): Rewritten tailcall - implementation, ::unsupported::atProcExit is (temporarily?) gone. The - new approach is much simpler, and also closer to being correct. This - commit fixes [Bug 2649975] and [Bug 2695587]. - - * tests/coroutine.test: Moved the tests to their own files, - * tests/tailcall.test: removed the unsupported.test. Added - * tests/unsupported.test: tests for the fixed bugs. - -2009-03-19 Donal K. Fellows - - * doc/tailcall.n: Added documentation for tailcall command. - 2009-03-18 Don Porter * win/tclWinFile.c (TclpObjNormalizePath): [Bug 2688184]: Corrected Tcl_Obj leak. Thanks to Joe Mistachkin for detection and patch. - * generic/tclVar.c (TclLookupSimpleVar): [Bug 2689307]: Shift - all calls to Tcl_SetErrorCode() out of TclLookupSimpleVar and onto its - callers, where control with TCL_LEAVE_ERR_MSG flag is more easily - handled. - -2009-03-16 Donal K. Fellows - - * generic/tclCmdMZ.c (TryPostBody): [Bug 2688063]: Extract information - from list before getting rid of last reference to it. - -2009-03-15 Joe Mistachkin - - * generic/tclThread.c: [Bug 2687952]: Modify fix for TSD leak to match - * generic/tclThreadStorage.c: Tcl 8.5 (and prior) allocation semantics - 2009-03-15 Donal K. Fellows - * generic/tclThreadStorage.c (TSDTableDelete): [Bug 2687952]: Ensure - * generic/tclThread.c (Tcl_GetThreadData): that structures in - Tcl's TSD system are all freed. Use the correct matching allocator. - * generic/tclPosixStr.c (Tcl_SignalId,Tcl_SignalMsg): [Patch 1513655]: Added support for SIGINFO, which is present on BSD platforms. -2009-03-14 Donal K. Fellows - - * unix/tcl.pc.in (new file): [Patch 2243948] (hat0) - * unix/configure.in, unix/Makefile.in: Added support for reporting - Tcl's public build configuration via the pkg-config system. TEA is - still the official mechanism though, in part because pkg-config is not - universally supported across all Tcl's supported platforms. - -2009-03-11 Miguel Sofer - - * generic/tclBasic.c (TclNRCoroutineObjCmd): fix Tcl_Obj leak. - Diagnosis and fix thanks to GPS. - -2009-03-09 Donal K. Fellows - - * generic/tclCmdMZ.c (Tcl_TryObjCmd, TclNRTryObjCmd): Moved the - implementation of [try] from Tcl code into C. Still lacks a bytecode - version, but should be better than what was before. - -2009-03-04 Donal K. Fellows - - * generic/tclZlib.c (TclZlibCmd): Checksums are defined to be unsigned - 32-bit integers, use Tcl_WideInt to pass to scripts. [Bug 2662434] - (ZlibStreamCmd, ChanGetOption): A few other related corrections. - -2009-02-27 Jan Nijtmans - - * generic/tcl.decls: [Bug 218977]: Tcl_DbCkfree needs return value - * generic/tclCkalloc.c - * generic/tclDecls.h: (regenerated) - * generic/tclInt.decls: don't use CONST84/CONST86 here - * generic/tclCompile.h: don't use CONST86 here, comment fixing. - * generic/tclIO.h: don't use CONST86 here, comment fixing. - * generic/tclIntDecls.h (regenerated) - -2009-02-25 Don Porter - - * generic/tclUtil.c (TclStringMatchObj): [Bug 2637173]: Revised - the branching on the strObj->typePtr so that untyped values get - converted to the "string" type and pass through the Unicode matcher. - [Bug 2613766]: Also added checks to only perform "bytearray" - optimization on pure bytearray values. - - * generic/tclCmdMZ.c: Since Tcl_GetCharLength() has its own - * generic/tclExecute.c: optimizations for the tclByteArrayType, stop - having the callers do them. - -2009-02-24 Donal K. Fellows - - * doc/clock.n, doc/fblocked.n, doc/format.n, doc/lsort.n, - * doc/pkgMkIndex.n, doc/regsub.n, doc/scan.n, doc/tclvars.n: - General minor documentation improvements. - - * library/http/http.tcl (geturl, Eof): Added support for 8.6's built - in zlib routines. - -2009-02-22 Alexandre Ferrieux - - * tests/lrange.test: Revert commits of 2008-07-23. Those were speed - * tests/binary.test: tests, that are inherently brittle. - -2009-02-21 Don Porter - - * generic/tclStringObj.c: Several revisions to the shimmering - patterns between Unicode and UTF string reps. Most notably the - call: objPtr = Tcl_NewUnicodeObj(...,0); followed by a loop of calls: - Tcl_AppendUnicodeToObj(objPtr, u, n); will now grow and append to - the Unicode representation. Before this commit, the sequence would - convert each append to UTF and perform the append to the UTF rep. - This is puzzling and likely a bug. The performance of [string map] - is significantly improved by this change (according to the MAP - collection of benchmarks in tclbench). Just in case there was some - wisdom in the old ways that I missed, I left in the ability to restore - the old patterns with a #define COMPAT 1 at the top of the file. - 2009-02-20 Don Porter * generic/tclPathObj.c: [Bug 2571597]: Fixed mistaken logic in * tests/fileName.test: TclFSGetPathType() that assumed (not "absolute") => "relative". This is a false assumption on Windows, where "volumerelative" is another possibility. -2009-02-18 Don Porter - - * generic/tclStringObj.c: Simplify the logic of the - Tcl_*SetObjLength() routines. - - * generic/tclStringObj.c: Rewrite GrowStringBuffer() so that it - has parallel structure with GrowUnicodeBuffer(). The revision permits - allocation attempts to continue all the way up to failure, with no - gap. It also directly manipulates the String and Tcl_Obj internals - instead of inefficiently operating via Tcl_*SetObjLength() with all of - its extra protections and underdocumented special cases. - - * generic/tclStringObj.c: Another round of simplification on - the allocation macros. - 2009-02-17 Jeff Hobbs * win/tcl.m4, win/configure: Check if cl groks _WIN64 already to avoid CC manipulation that can screw up later configure checks. Use 'd'ebug runtime in 64-bit builds. -2009-02-17 Don Porter - - * generic/tclStringObj.c: Pare back the length of the unicode - array in a non-extended String struct to one Tcl_UniChar, meant to - hold the terminating NUL character. Non-empty unicode strings are - then stored by extending the String struct by stringPtr->maxChars - additional slots in that array with sizeof(Tcl_UniChar) bytes per - slot. This revision makes the allocation macros much simpler. - - * generic/tclStringObj.c: Factor out common GrowUnicodeBuffer() - and solve overflow and growth algorithm fallbacks in it. - - * generic/tclStringObj.c: Factor out common GrowStringBuffer(). - - * generic/tclStringObj.c: Convert Tcl_AppendStringsToObj into - * tests/stringObj.test: a radically simpler implementation - where we just loop over calls to Tcl_AppendToObj. This fixes [Bug - 2597185]. It also creates a *** POTENTIAL INCOMPATIBILITY *** in - that T_ASTO can now allocate more space than is strictly required, - like all the other Tcl_Append* routines. The incompatibility was - detected by test stringObj-6.5, which I've updated to reflect the - new behavior. - - * generic/tclStringObj.c: Revise buffer growth implementation - in ExtendStringRepWithUnicode. Use cheap checks to determine that - no reallocation is necessary without cost of computing the precise - number of bytes needed. Also make use of the string growth algortihm - in the case of repeated appends. - -2009-02-16 Jan Nijtmans - - * generic/tclZlib.c: Hack needed for official zlib1.dll build. - * win/configure.in: fix [Feature Request 2605263] use official - * win/Makefile.in: zlib build. - * win/configure: (regenerated) - * compat/zlib/zdll.lib: new files - * compat/zlib/zlib1.dll: - - * win/Makefile.in: [Bug 2605232]: tdbc doesn't build when Tcl is - compiled with --disable-shared. - -2009-02-15 Don Porter - - * generic/tclStringObj.c: [Bug 2603158]: Added protections from - * generic/tclTestObj.c: invalid memory accesses when we append - * tests/stringObj.test: (some part of) a Tcl_Obj to itself. - Added the appendself and appendself2 subcommands to the - [teststringobj] testing command and added tests to the test suite. - - * generic/tclStringObj.c: Factor out duplicate code from - Tcl_AppendObjToObj. - - * generic/tclStringObj.c: Replace the 'size_t uallocated' field - of the String struct, storing the number of bytes allocated to store - the Tcl_UniChar array, with an 'int maxChars' field, storing the - number of Tcl_UniChars that may be stored in the allocated space. - This reduces memory requirement a small bit, and makes some range - checks simpler to code. - * generic/tclTestObj.c: Replace the [teststringobj ualloc] testing - * tests/stringObj.test: command with [teststringobj maxchars] and - update the tests. - - * generic/tclStringObj.c: Removed limitation in - Tcl_AppendObjToObj where the char length of the result was only - computed if the appended string was all single byte characters. - This limitation was in place to dodge a bug in Tcl_GetUniChar. - With that bug gone, we can take advantage of always recording the - length of append results when we know it. - -2009-02-14 Don Porter - - * generic/tclStringObj.c: Revisions so that we avoid creating - the strange representation of an empty string with - objPtr->bytes == NULL and stringPtr->hasUnicode == 0. Instead in - the situations where that was being created, create a traditional - two-legged stork representation (objPtr->bytes = tclEmptyStringRep - and stringPtr->hasUnicode = 1). In the situations where the strange - rep was treated differently, continue to do so by testing - stringPtr->numChars == 0 to detect it. These changes make the code - more conventional so easier for new maintainers to pick up. Also - sets up further simplifications. - - * generic/tclTestObj.c: Revise updates to [teststringobj] so we don't - get blocked by MODULE_SCOPE limits. - -2009-02-12 Don Porter - - * generic/tclStringObj.c: Rewrites of the routines - Tcl_GetCharLength, Tcl_GetUniChar, Tcl_GetUnicodeFromObj, - Tcl_GetRange, and TclStringObjReverse to use the new macro, and - to more simply and clearly split the cases depending on whether - a valid unicode rep is present or needs to be created. - New utility routine UnicodeLength(), to compute the length of unicode - buffer arguments when no length is passed in, with built-in - overflow protection included. Update three callers to use it. - - * generic/tclInt.h: New macro TclNumUtfChars meant to be a faster - replacement for a full Tcl_NumUtfChars() call when the string has all - single-byte characters. - - * generic/tclStringObj.c: Simplified Tcl_GetCharLength by - * generic/tclTestObj.c: removing code that did nothing. - Added early returns from Tcl_*SetObjLength when the desired length - is already present; adapted test command to the change. - - * generic/tclStringObj.c: Re-implemented AppendUtfToUnicodeRep - so that we no longer pass through Tcl_DStrings which have their own - sets of problems when lengths overflow the int range. Now AUTUR and - FillUnicodeRep share a common core routine. - -2009-02-12 Donal K. Fellows - - * generic/tclOODefineCmds.c (TclOOGetDefineCmdContext): Use the - correct field in the Interp structure for retrieving the frame to get - the context object so that people can extend [oo::define] without deep - shenanigans. Bug found by Federico Ferri. - -2009-02-11 Don Porter - - * generic/tclStringObj.c: Re-implemented AppendUnicodeToUtfRep - so that we no longer pass through Tcl_DStrings which have their own - sets of problems when lengths overflow the int range. Now AUTUR and - UpdateStringOfString share a common core routine. - - * generic/tclStringObj.c: Changed type of the 'allocated' field - * generic/tclTestObj.c: of the String struct (and the - TestString counterpart) from size_t to int since only int values are - ever stored in it. - -2009-02-10 Jan Nijtmans - - * generic/tclEncoding.c: Eliminate some unnessary type casts - * generic/tclEvent.c: some internal const decorations - * generic/tclExecute.c: spacing - * generic/tclIndexObj.c: - * generic/tclInterp.c: - * generic/tclIO.c: - * generic/tclIOCmd.c: - * generic/tclIORChan.c: - * generic/tclIOUtil.c: - * generic/tclListObj.c: - * generic/tclLiteral.c: - * generic/tclNamesp.c: - * generic/tclObj.c: - * generic/tclOOBasic.c: - * generic/tclPathObj.c: - * generic/tclPkg.c: - * generic/tclProc.c: - * generic/tclRegexp.c: - * generic/tclScan.c: - * generic/tclStringObj.c: - * generic/tclTest.c: - * generic/tclTestProcBodyObj.c: - * generic/tclThread.c: - * generic/tclThreadTest.c: - * generic/tclTimer.c: - * generic/tclTrace.c: - * generic/tclUtil.c: - * generic/tclVar.c: - * generic/tclStubInit.c: (regenerated) - -2009-02-10 Jan Nijtmans - - * unix/tcl.m4: [Bug 2502365]: Building of head on HPUX is broken when - using the native CC. - * unix/configure: (autoconf-2.59) - -2009-02-10 Don Porter - - * generic/tclObj.c (Tcl_GetString): Added comments and validity - checks following the call to an UpdateStringProc. - - * generic/tclStringObj.c: Reduce code duplication in Tcl_GetUnicode*. - Restrict AppendUtfToUtfRep to non-negative length appends. - Convert all Tcl_InvalidateStringRep() calls into macros. - Simplify Tcl_AttemptSetObjLength by removing unreachable code. - Simplify SetStringFromAny() by removing unreachable and duplicate code. - Simplify Tcl_SetObjLength by removing unreachable code. - Removed handling of (objPtr->bytes != NULL) from UpdateStringOfString, - which is only called when objPtr->bytes is NULL. - -2009-02-09 Jan Nijtmans - - * generic/tclCompile.c: [Bug 2555129]: const compiler warning (as - error) in tclCompile.c - -2009-02-07 Donal K. Fellows - - * generic/tclZlib.c (TclZlibCmd): [Bug 2573172]: Ensure that when - invalid subcommand name is given, the list of valid subcommands is - produced. This gives a better experience when using the command - interactively. - -2009-02-05 Joe Mistachkin - - * generic/tclInterp.c: [Bug 2544618]: Fix argument checking for - [interp cancel]. - * unix/Makefile.in: Fix build issue with zlib on FreeBSD (and possibly - other platforms). - -2009-02-05 Donal K. Fellows - - * generic/tclCmdMZ.c (StringIndexCmd, StringRangeCmd, StringLenCmd): - Simplify the implementation of some commands now that the underlying - string API knows more about bytearrays. - - * generic/tclExecute.c (TclExecuteByteCode): [Bug 2568434]: Make sure - that INST_CONCAT1 will not lose string reps wrongly. - - * generic/tclStringObj.c (Tcl_AppendObjToObj): Special-case the - appending of one bytearray to another, which can be extremely rapid. - Part of scheme to address [Bug 1665628] by making the basic string - operations more efficient on byte arrays. - (Tcl_GetCharLength, Tcl_GetUniChar, Tcl_GetRange): More special casing - work for bytearrays. - -2009-02-04 Don Porter +2009-02-05 Don Porter * generic/tclStringObj.c: [Bug 2561794]: Added overflow protections to the AppendUtfToUtfRep routine to either avoid invalid arguments and crashes, or to replace them with controlled panics. - * generic/tclCmdMZ.c: [Bug 2561746]: Prevent crashes due to int - overflow of the length of the result of [string repeat]. - -2009-02-03 Jan Nijtmans - - * macosx/tclMacOSXFCmd.c: Eliminate some unnessary type casts - * unix/tclLoadDyld.c: some internal const decorations - * unix/tclUnixCompat.c: spacing - * unix/tclUnixFCmd.c - * unix/tclUnixFile.c - * win/tclWinDde.c - * win/tclWinFCmd.c - * win/tclWinInit.c - * win/tclWinLoad.c - * win/tclWinPipe.c - * win/tclWinReg.c - * win/tclWinTest.c - * generic/tclBasic.c - * generic/tclBinary.c - * generic/tclCmdAH.c - * generic/tclCmdIL.c - * generic/tclCmdMZ.c - * generic/tclCompCmds.c - * generic/tclDictObj.c - -2009-02-03 Donal K. Fellows - - * generic/tclObj.c (tclCmdNameType): [Bug 2558422]: Corrected the type - of this structure so that extensions that write it (yuk!) will still - be able to function correctly. - -2009-02-03 Don Porter +2009-02-04 Don Porter * generic/tclStringObj.c (SetUnicodeObj): [Bug 2561488]: Corrected failure of Tcl_SetUnicodeObj() to panic on a shared object. Also factored out common code to reduce duplication. - * generic/tclObj.c (Tcl_GetStringFromObj): Reduce code duplication. - -2009-02-02 Don Porter - - * generic/tclInterp.c: Reverted the conversion of [interp] into an - * tests/interp.test: ensemble. Such conversion is not necessary - * tests/nre.test: (or even all that helpful) in the NRE-enabling - of [interp invokehidden], and it has other implications -- including - significant forkage of the 8.5 and 8.6 implementations -- that are - better off avoided if there's no gain. - - * generic/tclStringObj.c (STRING_NOMEM): [Bug 2494093]: Add missing - cast of NULL to (char *) that upsets some compilers. - - * generic/tclStringObj.c (Tcl_(Attempt)SetObjLength): [Bug 2553906]: - Added protections against callers asking for negative lengths. It is - likely when this happens that an integer overflow is to blame. - -2009-02-01 David Gravereaux - - * win/makefile.vc: Allow nmake flags such as -a (rebuild all) to pass - down to the pkgs targets, too. - -2009-01-30 Donal K. Fellows - - * doc/chan.n: [Bug 1216074]: Added another extended example. - - * doc/refchan.n: Added an example of how to build a scripted channel. + * generic/tclCmdMZ.c: Prevent crashes due to int overflow of the + length of the result of [string repeat]. [Bug 2561746] 2009-01-29 Donal K. Fellows - * tests/stringObj.test: [Bug 2006888]: Remove non-ASCII chars from - non-comment locations in the file, making it work more reliably in - locales with a non-Latin-1 default encoding. - * generic/tclNamesp.c (Tcl_FindCommand): [Bug 2519474]: Ensure that the path is not searched when the TCL_NAMESPACE_ONLY flag is given. - * generic/tclOODecls.h (Tcl_OOInitStubs): [Bug 2537839]: Make the - declaration of this macro work correctly in the non-stub case. - -2009-01-29 Don Porter - - * generic/tclInterp.c: Convert the [interp] command into a - * tests/interp.test: [namespace ensemble]. Work in progress - * tests/nre.test: to NRE-enable the [interp invokehidden] - subcommand. - -2009-01-29 Donal K. Fellows - - * generic/tclNamesp.c (TclMakeEnsemble): [Bug 2529117]: Make this - function behave more sensibly when presented with a fully-qualified - name, rather than doing strange stuff. - -2009-01-28 Donal K. Fellows - - * generic/tclBasic.c (TclInvokeObjectCommand): Made this understand - what to do if it ends up being used on a command with no objProc; that - shouldn't happen, but... - - * generic/tclNamesp.c (TclMakeEnsemble): [Bug 2529157]: Made this - understand NRE command implementations better. - * generic/tclDictObj.c (DictForCmd): Eliminate unnecessary command - implementation. - -2009-01-27 Donal K. Fellows - - * generic/tclOODefineCmds.c (Tcl_ClassSetConstructor): - [Bug 2531577]: Ensure that caches of constructor chains are cleared - when the constructor is changed. - -2009-01-26 Alexandre Ferrieux - - * generic/tclInt.h: [Bug 1028264]: WSACleanup() too early. - * generic/tclEvent.c: The fix introduces "late exit handlers" for - * win/tclWinSock.c: similar late process-wide cleanups. - -2009-01-26 Alexandre Ferrieux - - * win/tclWinSock.c: [Bug 2446662]: Resync Win behavior on RST with - that of unix (EOF). - -2009-01-26 Donal K. Fellows - - * generic/tclZlib.c (ChanClose): [Bug 2536400]: Only generate error - messages in the interpreter when the thread is not being closed down. - -2009-01-23 Donal K. Fellows - - * doc/zlib.n: Added a note that 'zlib push' is reversed by 'chan pop'. - -2009-01-22 Jan Nijtmans - - * generic/tclCompile.h: CONSTify TclPrintInstruction (TIP #27) - * generic/tclCompile.c - * generic/tclInt.h: CONSTify TclpNativeJoinPath (TIP #27) - * generic/tclFileName.c - * generic/tcl.decls: {unix win} is equivalent to {generic} - * generic/tclInt.decls - * generic/tclDecls.h: (regenerated) - * generic/tclIntDecls.h - * generic/tclGetDate.y: Single internal const decoration. - * generic/tclDate.c: - 2009-01-22 Kevin B. Kenny * unix/tcl.m4: Corrected a typo ($(SHLIB_VERSION) should be ${SHLIB_VERSION}). * unix/configure: Autoconf 2.59 2009-01-21 Andreas Kupries - * generic/tclIORChan.c (ReflectClose): [Bug 2458202]: - * generic/tclIORTrans.c (ReflectClose): Closing a channel may supply - NULL for the 'interp'. Test for finalization needs to be different, - and one place has to pull the interp out of the channel instead. - -2009-01-21 Don Porter - - * generic/tclStringObj.c: New fix for [Bug 2494093] replaces the - flawed attempt committed 2009-01-09. + * generic/tclIORChan.c (ReflectClose): Fix for [Bug 2458202]. + Closing a channel may supply NULL for the 'interp'. Test for + finalization needs to be different, and one place has to pull the + interp out of the channel instead. 2009-01-19 Kevin B. Kenny * unix/Makefile.in: [Patch 907924]:Added a CONFIG_INSTALL_DIR * unix/tcl.m4: parameter so that distributors can control where @@ -8704,147 +3431,37 @@ actually being on an AIX system. Allowed for downstream packagers to customize SHLIB_VERSION on BSD-derived systems. Thanks to Stuart Cassoff for his help. * unix/configure: Autoconf 2.59 -2009-01-19 David Gravereaux - - * win/build.vc.bat: Improved tools detection and error message - * win/makefile.vc: Reorganized the $(TCLOBJ) file list into seperate - parts for easier maintenance. Matched all sources built using -GL to - both $(lib) and $(link) to use -LTCG and avoid a warning message. - Addressed the over-building nature of the htmlhelp target by moving - from a pseudo target to a real target dependent on the entire docs/ - directory contents. - * win/nmakehlp.c: Removed -g option and GrepForDefine() func as it - isn't being used anymore. The -V option method is much better. - -2009-01-16 Don Porter - - * generic/tcl.h: Bump patchlevel to 8.6b1.1 to distinguish - * library/init.tcl: CVS snapshots from the 8.6b1 and 8.6b2 releases - * unix/configure.in: and to deal with the fact that the 8.6b1 - * win/configure.in: version of init.tcl will not [source] in the - HEAD version of Tcl. - - * unix/configure: autoconf-2.59 - * win/configure: - -2009-01-14 Don Porter - - * generic/tclBasic.c (Tcl_DeleteCommandFromToken): Reverted most - of the substance of my 2009-01-12 commit. NULLing the objProc field of - a Command when deleting it is important so that tests for certain - classes of commands don't return false positives when applied to - deleted command tokens. Overall change is now just replacement of a - false comment with a true one. - -2009-01-13 Jan Nijtmans - - * unix/tcl.m4: [Bug 2502365]: Building of head on HPUX is broken when - using the native CC. - * unix/configure (autoconf-2.59) - -2009-01-13 Donal K. Fellows - - * generic/tclCmdMZ.c (Tcl_ThrowObjCmd): Move implementation of [throw] - * library/init.tcl (throw): to C from Tcl. - -2009-01-12 Don Porter - - * generic/tclBasic.c (Tcl_DeleteCommandFromToken): One consequence of - the NRE rewrite is that there are now situations where a NULL objProc - field in a Command struct is perfectly normal. Removed an outdated - comment in Tcl_DeleteCommandFromToken that claimed we use - cmdPtr->objPtr==NULL as a test of command validity. In fact we use - cmdPtr->flags&CMD_IS_DELETED to perform that test. Also removed the - setting to NULL, since any extension following the advice of the old - comment is going to be broken by NRE anyway, and needs to shift to - flag-based testing (or stop intruding into such internal matters). - Part of [Bug 2486550]. - 2009-01-09 Don Porter * generic/tclStringObj.c (STRING_SIZE): [Bug 2494093]: Corrected failure to limit memory allocation requests to the sizes that can be supported by Tcl's memory allocation routines. -2009-01-09 Donal K. Fellows - - * generic/tclNamesp.c (NamespaceEnsembleCmd): [Bug 1558654]: Error out - when someone gives wrong # of args to [namespace ensemble create]. - 2009-01-08 Don Porter * generic/tclStringObj.c (STRING_UALLOC): [Bug 2494093]: Added missing parens required to get correct results out of things like STRING_UALLOC(num + append). -2009-01-08 Donal K. Fellows - - * generic/tclDictObj.c, generic/tclIndexObj.c, generic/tclListObj.c, - * generic/tclObj.c, generic/tclStrToD.c, generic/tclUtil.c, - * generic/tclVar.c: Generate errorcodes for the error cases which - approximate to "I can't interpret that string as one of those" and - "You gave me the wrong number of arguments". - -2009-01-07 Donal K. Fellows - - * doc/dict.n: [Tk Bug 2491235]: Added more examples. - - * tests/oo.test (oo-22.1): Adjusted test to be less dependent on the - specifics of how [info frame] reports general frame information, and - instead to focus on what methods add to it; that's really what the - test is about anyway. - -2009-01-06 Don Porter - - * tests/stringObj.test: Revise tests that demand a NULL Tcl_ObjType - in certain values to construct those values with [testdstring] so - there's no lack of robustness depending on the shimmer history of - shared literals. - 2009-01-06 Donal K. Fellows * generic/tclDictObj.c (DictIncrCmd): Corrected twiddling in internals of dictionaries so that literals can't get destroyed. - * tests/expr.test: [Bug 2006879]: Eliminate non-ASCII char. - - * generic/tclOOInfo.c (InfoObjectMethodsCmd,InfoClassMethodsCmd): - [Bug 2489836]: Only delete pointers that were actually allocated! - - * generic/tclOO.c (TclNRNewObjectInstance, Tcl_NewObjectInstance): - [Bug 2481109]: Perform search for existing commands in right context. - -2009-01-05 Donal K. Fellows - - * generic/tclCmdMZ.c (TclNRSourceObjCmd): [Bug 2412068]: Make - * generic/tclIOUtil.c (TclNREvalFile): implementation of the - [source] command be NRE enabled so that [yield] inside a script - sourced in a coroutine can work. - -2009-01-04 Donal K. Fellows - - * generic/tclCmdAH.c: Tidy up spacing and code style. - -2009-01-03 Kevin B. Kenny + * tests/expr.test, tests/string.test: Eliminate non-ASCII characters. + [Bugs 2006884, 2006879] + +2009-01-03 Kevin B. Kenny : * library/clock.tcl (tcl::clock::add): Fixed error message formatting in the case where [clock add] is presented with a bad switch. * tests/clock.test (clock-65.1) Added a test case for the above problem [Bug 2481670]. -2009-01-02 Donal K. Fellows - - * unix/tcl.m4 (SC_CONFIG_CFLAGS): [Bug 878333]: Force the use of the - compatibility version of mkstemp() on IRIX. - * unix/configure.in, unix/Makefile.in (mkstemp.o): - * compat/mkstemp.c (new file): [Bug 741967]: Added a compatibility - implementation of the mkstemp() function, which is apparently needed - on some platforms. - ****************************************************************** *** CHANGELOG ENTRIES FOR 2008 IN "ChangeLog.2008" *** *** CHANGELOG ENTRIES FOR 2006-2007 IN "ChangeLog.2007" *** *** CHANGELOG ENTRIES FOR 2005 IN "ChangeLog.2005" *** *** CHANGELOG ENTRIES FOR 2004 IN "ChangeLog.2004" *** Index: ChangeLog.2000 ================================================================== --- ChangeLog.2000 +++ ChangeLog.2000 @@ -1777,11 +1777,11 @@ -all]. * generic/tclCmdMZ.c: Fixed infinite loop bug with [regexp -all] [Bug: 4981]. - * tests/*.test: Changed all occurrences of "namespace import + * tests/*.test: Changed all occurances of "namespace import ::tcltest" to "namespace import -force ::tcltest" [Bug: 3948]. 2000-04-09 Brent Welch * lib/httpd2.1/http.tcl: Worked on the "server closes before reading Index: ChangeLog.2001 ================================================================== --- ChangeLog.2001 +++ ChangeLog.2001 @@ -349,11 +349,11 @@ removed line continuation in #if clause as this breaks the mac resource compiler (note that *.r files include tcl.h) * mac/tclMacFile.c: fixed bug in permission checking code - * mac/tclMacLoad.c: corrected utf-8 handling, comparison of package + * mac/tclMacLoad.c: corrected utf8 handling, comparison of package names to code fragment names changed to only match on the length of package name, this allows for fragment names with version numbers appended. * mac/tclMacInt.h: @@ -3523,11 +3523,11 @@ 2001-03-06 Donal K. Fellows * generic/tclVar.c (Tcl_UnsetObjCmd): Rewrote argument parser to avoid a read off the end of the argument array that could occur when executing something like [unset -nocomplain] was executed. Improved - the error message given when not enough arguments are given (-nocomplain + the error message given when too few arguments are given (-nocomplain should obviously be *before* --, not after it) and also modified the test suite to take account of that and the documentation to use the same improvement. [Bug 405769] 2001-03-02 Donal K. Fellows Index: ChangeLog.2002 ================================================================== --- ChangeLog.2002 +++ ChangeLog.2002 @@ -1751,11 +1751,11 @@ * changes: added recent changes 2002-07-05 Reinhard Max - * generic/tclClock.c (FormatClock): Convert the format string to utf-8 + * generic/tclClock.c (FormatClock): Convert the format string to UTF8 before calling TclpStrftime, so that non-ASCII characters don't get mangled when the result string is being converted back. * tests/clock.test: Added a test for that. 2002-07-05 Donal K. Fellows Index: ChangeLog.2004 ================================================================== --- ChangeLog.2004 +++ ChangeLog.2004 @@ -2300,11 +2300,11 @@ * doc/OpenFileChnl.3: Added description of the behaviour of Tcl_ReadChars when its 'charsToRead' argument is set to -1. Fixes [Bug 934511]. * doc/CrtCommand.3: Added note that the arguments given to the command - proc of a Tcl_CreateCommand are in utf-8 since Tcl 8.1. Closing [Patch + proc of a Tcl_CreateCommand are in utf8 since Tcl 8.1. Closing [Patch 414778]. * doc/ChnlStack.3: Removed the declaration that the interp argument to Tcl_(un)StackChannel can be NULL. This fixes [Bug 881220], reported by Marco Maggi . @@ -2871,11 +2871,11 @@ for them. 2004-06-02 Jeff Hobbs * win/tclWinFile.c (TclpFindExecutable): when using GetModuleFileNameA - (Win9x), convert from CP_ACP to WCHAR then convert back to utf-8. + (Win9x), convert from CP_ACP to WCHAR then convert back to utf8. Adjunct to 2004-04-07 fix. 2004-06-02 David Gravereaux * tests/winPipe.test (winpipe-6.1): blocking set to 1 before closing Index: ChangeLog.2007 ================================================================== --- ChangeLog.2007 +++ ChangeLog.2007 @@ -1424,11 +1424,11 @@ * generic/tclCompCmds.c (TclCompileReturnCmd): Added crash protection to handle callers other than TclCompileScript() failing to meet the initialization assumptions of the TIP 280 code in CompileWord(). * generic/tclCompExpr.c: Suppress the attempt to convert to - numeric when pre-compiling a constant expression indicates an error. + numeric when pre-compiling a constant expresion indicates an error. 2007-08-22 Miguel Sofer * generic/tclExecute.c (TEBC): disable the new shortcut to frequent INSTs for debug builds. REVERTED (collision with alternative fix) @@ -5909,13 +5909,13 @@ services such as signal handlers should best be done with extensions to the core after discussions on c.l.t. about Roy Terry's tclsh children of a real windows service shell. ****************************************************************** - *** CHANGELOG ENTRIES FOR 2005 IN "ChangeLog.2005" *** - *** CHANGELOG ENTRIES FOR 2004 IN "ChangeLog.2004" *** - *** CHANGELOG ENTRIES FOR 2003 IN "ChangeLog.2003" *** - *** CHANGELOG ENTRIES FOR 2002 IN "ChangeLog.2002" *** - *** CHANGELOG ENTRIES FOR 2001 IN "ChangeLog.2001" *** - *** CHANGELOG ENTRIES FOR 2000 IN "ChangeLog.2000" *** + *** CHANGELOG ENTRIES FOR 2005 IN "ChangeLog.2005" *** + *** CHANGELOG ENTRIES FOR 2004 IN "ChangeLog.2004" *** + *** CHANGELOG ENTRIES FOR 2003 IN "ChangeLog.2003" *** + *** CHANGELOG ENTRIES FOR 2002 IN "ChangeLog.2002" *** + *** CHANGELOG ENTRIES FOR 2001 IN "ChangeLog.2001" *** + *** CHANGELOG ENTRIES FOR 2000 IN "ChangeLog.2000" *** *** CHANGELOG ENTRIES FOR 1999 AND EARLIER IN "ChangeLog.1999" *** ****************************************************************** Index: ChangeLog.2008 ================================================================== --- ChangeLog.2008 +++ ChangeLog.2008 @@ -1,678 +1,119 @@ -2008-12-31 Don Porter - - * unix/Makefile.in: Set TCLLIBPATH in SHELL_ENV so that targets - like `make shell` have access to builds of bundled packages. - -2008-12-28 Donal K. Fellows - - * generic/tclZlib.c (Tcl_ZlibStreamPut): Plug a memory leak. - -2008-12-27 Donal K. Fellows - - * generic/tclZlib.c (ZlibStreamCmd): Fix compilation consistency. [Bug - * generic/tcl.decls: 2470237] - - * generic/tclZlib.c (Tcl_ZlibStreamGet): Corrected the semantics of - this function to be useful to the PNG implementation. If the argument - object is empty, this gives the previous semantics. - (Tcl_ZlibStreamChecksum): Corrected name to be less misleading; it - only produced Adler-32 checksums when the stream was processing the - right type of compressed data format. - (Tcl_ZlibAdler32, Tcl_ZlibCRC32): Corrected types so that they work - naturally with the results of Tcl_GetByteArrayFromObj(). - *** POTENTIAL INCOMPATIBILITY *** for all above changes, but very - unlikely to be difficult for anyone to deal with. - -2008-12-26 Donal K. Fellows - - * generic/tcl.decls: Tidy up the commenting style, adding markers for - each of the big release points under TCT stewardship and noting the - general purpose of each TIP that added C API. Overall effect is to - make this file much more informative to read without having to spend - effort correlating with TIPs and ChangeLogs. - -2008-12-23 Jan Nijtmans - - * win/Makefile.in: Fix build of zlib objects with msvc - * win/tcl.m4: - * win/configure: autoconf-2.59 - -2008-12-23 Donal K. Fellows - - * win/Makefile.in: Handle file extensions correctly. [Bug 2459725] - -2008-12-22 Pat Thoyts - - *** 8.6b1 TAGGED FOR RELEASE *** - - * win/makefile.vc: Ensure pkgs directories are suitable and quote the - paths. [Bug 2458395] - -2008-12-22 Joe Mistachkin - - * tools/man2help2.tcl: Added support for "\(mi" nroff macro. [Bug - 2330040] - -2008-12-22 Pat Thoyts - - * win/makefile.vc: Support the pkgs tree in the NMAKE builds. - -2008-12-21 Daniel Steffen - - * unix/Makefile.in: Fix broken build of bundled packages when path - to build dir contains spaces by switching to - relative paths to toplevel build dir. - - * unix/configure.in: Preserve configure environment variables for - sub-configures of bundled packages; reuse - configure cache file for sub-configures. - - * unix/configure: autoconf-2.59 - -2008-12-21 Donal K. Fellows - - * doc/TclZlib.3: Fix minor typo. [Bug 2455165] - -2008-12-20 Kevin B. Kenny - - * win/Makefile.in: Renamed the static library libtcl86s.a to - * win/configure.in: have a name distinct from the import library - libtcl86.a. This renaming dodges an ancient - bug in the Makefile revealed by the last - commit where the $(TCL_LIB_FILE) rule can - fire to try to build the static library in a - --enable-shared build (and create a static - library that subsequently fails to link). - Revised the zlib objects so that they are - built directly into the build dir, without - building an intermediate static library. - *** POTENTIAL INCOMPATIBILITY *** for - embedders who link to the static library, but - I couldn't figure out how to sort this out - any other way. - * win/configure: Autoconf 2.59 - -2008-12-20 Donal K. Fellows - - * win/Makefile.in: Minor updates to make building work better with - msys on Windows. (Apparently the gcc used doesn't like a / at the end - of a -I argument...) - -2008-12-20 Don Porter - - * changes: Updates for 8.6b1 release. - -2008-12-20 Daniel Steffen - - * unix/Makefile.in: Make package install directory of bundled - * unix/configure.in: packages configurable via PACKAGE_DIR makefile - variable (set to platform-specific default). - - * unix/Makefile.in (*-packages): Ensure toplevel targets fail if - sub-make/configure fails; fix quoting when - builddir path contains spaces. - - * macosx/GNUmakefile: Add install-packages to install targets. - - * unix/configure: autoconf-2.59 - -2008-12-19 Don Porter - - * doc/NRE.3: Formatting errors found by `make html` - * doc/Tcl_Main.3: - * doc/zlib.n: - - * tests/chanio.test: Add missing [removeFile] cleanups. - * tests/io.test: Add missing [close $f] to io-73.2. - - * unix/Makefile.in: Update `make dist' target to include the files - from the compat/zlib directory as well as all the bundled packages - found under the pkgs directory, according to their individual `make - dist' targets. Change includes breaking a `configure-packages' target - out of the `packages` target. - - * README: Bump version number to 8.6b1 - * generic/tcl.h: + +2008-12-21 Don Porter + + *** 8.5.6 TAGGED FOR RELEASE *** + + * generic/tcl.h: Bump to 8.5.6 for release. * library/init.tcl: * tools/tcl.wse.in: * unix/configure.in: * unix/tcl.spec: * win/configure.in: + * README: * unix/configure: autoconf-2.59 * win/configure: -2008-12-19 Jan Nijtmans - - * generic/tclInt.decls: CONSTify TclGetLoadedPackages second param - * generic/tclLoad.c - * generic/tclIntDecls.h (regenerated) - -2008-12-19 Kevin Kenny - - * generic/tclExecute.c: Fix compile warnings when --enable-symbols=all - - * win/configure.in: - * win/Makefile.in: Added build of packages in the 'pkgs/' directory. - * win/configure: Autoconf 2.59 - -2008-12-19 Pat Thoyts - - * win/makefile.vc: Added build of compat/zlib - -2008-12-18 Andreas Kupries - - * generic/tclIO.c (Tcl_CloseEx, CloseWrite, CloseChannelPart) - (ChanCloseHalf): Rewrite the half-close to properly flush the channel, - like is done for a full close, going through FlushChannel, and using - the flag BG_FLUSH_SCHEDULED (async flush during close). New functions - CloseWrite, CloseChannelPart, new flag CHANNEL_CLOSEDWRITE. - - * tests/chanio.test (chanio-28.[67]): Reactivated these tests. - Replaced tclsh -> [interpreter] to get correct executable for the pipe - process, and added after cancel to kill the fail timers when we are - done. Removed the explicits calls to [flush], now that [close] handles - this correctly. - -2008-12-18 Don Porter - - * tests/chanio.test: Replaced [chan event] handlers that returned - TCL_RETURN return code, with more conventional ones that return TCL_OK - to suppress otherwise strange writes of outdated $::errorInfo values - to stderr. [Bug 2444274] - - * generic/tclExecute.c: Disabled apparently faulty assertion. [Bug - 2415422] - -2008-12-18 Donal K. Fellows - - * unix/configure.in, unix/Makefile.in: Autoconf wizardry. - * compat/zlib/*: Import of zlib 1.2.3. The license is directly - compatible with Tcl's. This import omits the obsolete and contributed - parts (i.e. selected directories) and the supplied examples. - - * generic/tclZlib.c: First implementation of the compressing and - * doc/zlib.n: decompressing channel transformations. - * tests/zlib.test (zlib-8.*): - -2008-12-18 Jan Nijtmans - - * generic/tcl.decls: VOID -> void - * generic/tclInt.decls: - * compat/dlfcn.h: - * generic/tclDecls.h: (regenerated) - * generic/tclIntDecls.h: - -2008-12-18 Alexandre Ferrieux - - TIP #332 IMPLEMENTATION - Half-Close for Bidirectional Channels - - * doc/close.n, generic/tclIO.c, generic/tclIOCmd.c: - * unix/tclUnixChan.c, unix/tclUnixPipe.c, win/tclWinSock.c: - * generic/tcl.decls, generic/tclDecls.h, generic/tclStubInit.c: - * tests/chan.test, tests/chanio.test, tests/ioCmd.test: - -2008-12-17 Donal K. Fellows - - * doc/SetChanErr.3: General improvements in nroff rendering and some - corrections to language issues. - -2008-12-17 Jan Nijtmans - - * generic/tclResult.c: Move variable "length" inside if() - * generic/tclStringObj.c: Don't use ckfree((void *)...) but - * generic/tclVar.c: ckfree((char *)...) - * generic/tclZlib.c - * generic/tclBasic.c - -2008-12-17 Donal K. Fellows - - * tests/namespace.test (namespace-28.1): Make tests not - * tests/namespace-old.test (namespace-old-9.5): dependent on the - global namespace's particular imports. [Bug 2433936] - -2008-12-17 Don Porter - - * unix/Makefile.in: Modify the distclean-packages target so that - empty build directories are deleted. - - * unix/Makefile.in: Add build support for collections of TEA - * unix/configure.in: packages found under the pkgs directory. - [Patch 1163406]. Still needs porting to Windows. - - * unix/configure: autoconf-2.59 - -2008-12-17 Donal K. Fellows - - * generic/tcl.h, generic/tclZlib.c: Removed undocumented flag. - -2008-12-16 Jan Nijtmans - - * generic/tclThreadTest.c: Eliminate -Wwrite-strings warnings in - --enable-threads build. - * generic/tclExecute.c: Use TclNewLiteralStringObj() - * unix/tclUnixFCmd.c: Use TclNewLiteralStringObj() - * win/tclWinFCmd.c: Use TclNewLiteralStringObj() - -2008-12-16 Donal K. Fellows - - TIP #329 IMPLEMENTATION - - * tests/error.test: Tests for the new commands. - * doc/throw.n, doc/try.n: Documentation of the new commands. - * library/init.tcl (throw, try): Implementation of commands documented - in TIP. This implementation is in Tcl and is a stop-gap until - higher-performance ones can be written. - -2008-12-16 Don Porter - - * generic/tcl.h: Add TIP 338 routines to stub table. - * generic/tcl.decls: [Bug 2431338] - - * generic/tclDecls.h: make genstubs - * generic/tclStubInit.c: + * changes: Update for 8.5.6 release. + + * library/tclIndex: Removed reference to no-longer-extant procedure + 'tclLdAout'. + * doc/library.n: Corrected mention of 'auto_exec' to 'auto_execok'. + [Patch 2114900] thanks to Stu Cassoff + Backport of 2008-11-26 commit from Kevin Kenny. + + * win/tclWinThrd.c (TclpThreadCreate): We need to initialize the + thread id variable to 0 as on 64 bit windows this is a pointer sized + field while windows only fills it with a 32 bit value. The result is + an inability to join the threads as the ids cannot be matched. + Backport of 2008-10-13 commit from Pat Thoyts. 2008-12-15 Donal K. Fellows * generic/tclExecute.c (TEBC:INST_DICT_GET): Make sure that the result is empty when generating an error message. [Bug 2431847] -2008-12-15 Alexandre Ferrieux - - * generic/tclBinary.c: Redefine non-strict decoding to ignore only - * doc/binary.n: whitespace. [Bug 2380293] - * tests/binary.test: - -2008-12-15 Don Porter - - * doc/AddErrInfo.3: Documented Tcl_(Set|Get)ErrorLine (TIP 336). - * doc/CrtCommand.3: Various other documentation updates to - * doc/CrtInterp.3: reflect the lack of access to Tcl_Interp - * doc/Interp.3: fields by default. - * doc/SetResult.3: - * doc/tcl.decls: - - TIP #338 IMPLEMENTATION - - * doc/AppInit.c: Made routines Tcl_SetStartupScript and - * doc/Tcl_Main.3: Tcl_GetStartupScript public. Removed all - * generic/tcl.h: internal stub access to Tcl*Startup* routines, - * generic/tclInt.decls: and removed their implementations. Their - * generic/tclMain.c: function can now be completely performed with - the new public interface. - *** POTENTIAL INCOMPATIBILITY for callers of the internal - Tcl*Startup* routines. *** - - * generic/tclIntDecls.h: make genstubs - * generic/tclStubInit.c: - * generic/tclDecls.h: - -2008-12-14 Donal K. Fellows - - * tests/zlib.test: Added constraint so that tests don't fail where - they cannot work due to zlib support being missing. - - * unix/configure.in, win/configure.in: Improve the autodetection code. - * win/tcl.m4 (SC_CONFIG_CFLAGS): Remove the assumption of the presence - of zlib library on Windows. - * win/makefile.vc, win/makefile.bc: Add support for building tclZlib.o - but only in stubbed-out mode for now. - -2008-12-13 Donal K. Fellows - - * doc/TclZlib.3: Basic documentation of the C-level API. - * doc/zlib.n: Substantially improve documentation of Tcl-level API. - * generic/tclZlib.c (ZlibCmd): Flesh out the argument parsing for the - command to integrate with channels. - 2008-12-12 Jan Nijtmans - * generic/tclZlib.c (Tcl_ZlibInflate): Change PATH_MAX to MAXPATHLEN, - since MSVC doesn't have PATH_MAX. - - * doc/clock.n: Document new DST fallback rules. * library/clock.tcl (ProcessPosixTimeZone): Fix time change in Eastern Europe (not 3:00 but 4:00 local time). [Bug 2207436] -2008-12-12 Donal K. Fellows - - * generic/tclZlib.c, unix/configure.in: Added stubs to use when the - version of zlib is not capable enough, and automagic to detect when - that is the case. [Bug 2421265] - -2008-12-12 Alexandre Ferrieux - - * unix/tclUnixNotfy.c: Fix missing CLOEXEC on internal pipes [2417695] - * unix/tclUnixPipe.c: Fix missing CLOEXEC on [chan pipe] fds. - -2008-12-12 Donal K. Fellows - - * generic/tclZlib.c (Tcl_ZlibDeflate): Add a bit of extra space for - the gzip header. [Bug 2419061] - (Tcl_ZlibInflate): Ensure that gzip header extraction is done - correctly. - -2008-12-12 Kevin Kenny - - TIP #322 IMPLEMENTATION - - * doc/NRE.3 (new file): Added documentation of the published API for - Non-Recursive Evaluation (NRE). - -2008-12-11 Jan Nijtmans - - * generic/tclZlib.c: Eliminate warning: different 'const' qualifiers - with msvc compiler. A few more 'const' optimizations. - * win/tcl.m4: Fix Windows build (msvc) for TIP #234 implementation - * win/Makefile.in: - * win/configure: - 2008-12-11 Andreas Kupries * generic/tclIO.c (SetChannelFromAny and related): Modified the * tests/io.test: internal representation of the tclChannelType to contain not only the ChannelState pointer, but also a reference to the interpreter it was made in. Invalidate and recompute the internal representation when it is used in a different interpreter, like cmdName intrep's. Added testcase. [Bug 2407783] -2008-12-11 Donal K. Fellows - - * generic/tclZlib.c (ConvertError): Factor out code to turn zlib - errors into Tcl errors. - - * doc/zlib.n: Added a start at the documentation. Still very rough. - -2008-12-11 Jan Nijtmans - - * win/Makefile.in: Fix Windows build (mingw) for TIP #234 - implementation (additionally, first make sure that zlib is available, - and rename the standard zdll.lib to libz.a, but at least this works so - far). - -2008-12-11 Donal K. Fellows - - * tests/zlib.test: Start of test suite for zlib command. - 2008-12-11 Jan Nijtmans * library/clock.tcl (ProcessPosixTimeZone): Fallback to European time zone DST rules, when the timezone is between 0 and -12. [Bug 2207436] * tests/clock.test (clock-52.[23]): Test cases for [Bug 2207436] -2008-12-11 Donal K. Fellows - - TIP #234 IMPLEMENTATION - - * generic/tclZlib.c: A very preliminary hack at an interface to the - zlib library, based on code from Pascal Scheffers. - WARNING! The C API may be subect to change without much warning! USE - AT YOUR OWN RISK! - 2008-12-10 Kevin B. Kenny * library/tzdata/*: Update from Olson's tzdata2008i. -2008-12-10 Alexandre Ferrieux - - TIP #343 IMPLEMENTATION - A Binary Specifier for [format/scan] - - * doc/format.n - * doc/scan.n - * generic/tclInt.h - * generic/tclScan.c - * generic/tclStrToD.c - * generic/tclStringObj.c - * tests/format.test - * tests/scan.test - -2008-12-10 Donal K. Fellows - - TIP #341 IMPLEMENTATION - - * generic/tclDictObj.c (DictFilterCmd): Made key and value filtering - * tests/dict.test, doc/dict.n: accept arbitrary numbers of - glob arguments. - -2008-12-09 Jan Nijtmans - - * generic/tclInt.decls: Restore source and binary compatibility for - TIP #337 implementation. (When it is _that_ - simple, there is no excuse not to do it! :-)) - * generic/tclIntDecls.h: make genstubs - * generic/tclStubInit.c: - -2008-12-09 Don Porter - - TIP #337 IMPLEMENTATION - - * doc/BackgdErr.3: Converted internal routine - * doc/interp.n: TclBackgroundException() into public routine - * generic/tcl.decls: Tcl_BackgroundException(). - * generic/tclEvent.c: - * generic/tclInt.decls: - - * generic/tclDecls.h: make genstubs - * generic/tclIntDecls.h: - * generic/tclStubInit.c: - - * generic/tclIO.c: Update callers. - * generic/tclIOCmd.c: - * generic/tclInterp.c: - * generic/tclTimer.c: - *** POTENTIAL INCOMPATIBILITY only for extensions using the converted - internal routine *** - -2008-12-09 Donal K. Fellows - - * generic/tclIO.c (ChanClose,ChanRead,...): Factored out some of the - code to connect to channel drivers that was common in multiple - locations so as to make code more readable. - -2008-12-06 Donal K. Fellows - - * generic/tclCmdAH.c (FileTempfileCmd): Force temporary files to be - created in the native filesystem. Attempting to provide a template - that puts it elsewhere will result in the directory part of the - template being ignored. Partial address of [Bug 2388866] concerns. - -2008-12-05 Donal K. Fellows - - TIP #335 IMPLEMENTATION - - * generic/tclBasic.c (Tcl_InterpActive): Added function for working - * doc/CrtInterp.3: out if an interp is in use. - - TIP #307 IMPLEMENTATION - - * generic/tclResult.c (Tcl_TransferResult): Renamed function from - * generic/tcl.decls: TclTransferResult. Added - * doc/SetResult.3: to public stubs table. - 2008-12-04 Don Porter * generic/tclPathObj.c (Tcl_FSGetNormalizedPath): Added another flag value TCLPATH_NEEDNORM to mark those intreps which need more complete normalization attention for correct results. [Bug 2385549] -2008-12-03 Donal K. Fellows - - * win/tclWinPipe.c (TclpOpenTemporaryFile): Avoid an infinite loop due - to GetTempFileName/CreateFile interaction. [Bug 2380318] - 2008-12-03 Don Porter * generic/tclFileName.c (DoGlob): One of the Tcl_FSMatchInDirectory calls did not have its return code checked. This caused error messages returned by some Tcl_Filesystem drivers to be swallowed. -2008-12-02 Don Porter - - TIP #336 IMPLEMENTATION - - * generic/tcl.decls: New routines Tcl_(Get|Set)ErrorLine. - * generic/tcl.h: Dropped default access to interp->errorLine. - * generic/tclCmdAH.c: Restore it with -DUSE_INTERP_ERRORLINE. - * generic/tclCmdMZ.c: Updated callers. - * generic/tclDictObj.c: - * generic/tclIOUtil.c: - * generic/tclNamesp.c: - * generic/tclOOBasic.c: - * generic/tclOODefinedCmds.c: - * generic/tclOOMethod.c: - * generic/tclProc.c: - * generic/tclResult.c: - *** POTENTIAL INCOMPATIBILITY for C code directly using the - interp->errorLine field *** - - * generic/tclDecls.h: make genstubs - * generic/tclStubInit.c: - 2008-12-02 Andreas Kupries * generic/tclIO.c (TclFinalizeIOSubsystem): Replaced Alexandre Ferrieux's first patch for [Bug 2270477] with a gentler version, also supplied by him. -2008-12-01 Don Porter - - * generic/tclParse.c: Coding standards fixups. - -2008-12-01 Donal K. Fellows - - * tests/cmdAH.test (cmdAH-32.6): Test was not portable; depended on a - C API function not universally available. [Bug 2371623] +2008-12-01 Don Porter + + * generic/tclParse.c: Backport fix for [Bug 2251175]. 2008-11-30 Kevin B. Kenny * library/clock.tcl (format, ParseClockScanFormat): Added a [string map] to get rid of namespace delimiters before caching a scan or format procedure. [Bug 2362156] * tests/clock.test (clock-64.[12]): Added test cases for the bug that was tickled by a namespace delimiter inside a format string. -2008-11-29 Donal K. Fellows - - TIP #210 IMPLEMENTATION - - * generic/tclCmdAH.c (FileTempfileCmd): - * unix/tclUnixFCmd.c (TclpOpenTemporaryFile, DefaultTempDir): - * win/tclWinPipe.c (TclpOpenTemporaryFile): - * doc/file.n, tests/cmdAH.test: Implementation of [file tempfile]. I - do not claim that this is a brilliant implementation, especially on - Windows, but it covers the main points. - - * generic/tclThreadStorage.c: General revisions to make code clearer - and more like the style used in the rest of the core. Includes adding - more comments and explanation of what is going on. Reduce the amount - of locking required. - -2008-11-27 Alexandre Ferrieux - - * generic/tcl.h: Alternate fix for [Bug 2251175]: missing - * generic/tclCompile.c: backslash substitution on expanded literals. - * generic/tclParse.c: - * generic/tclTest.c: - * tests/parse.test: - -2008-11-26 Jan Nijtmans - - * generic/tclIndexObj.c: Eliminate warning: unused variable - * generic/tclTest.c: A few more (harmless) Tcl_SetResult - eliminations. - -2008-11-26 Kevin B. Kenny - - * library/tclIndex: Removed reference to no-longer-extant procedure - 'tclLdAout'. - * doc/library.n: Corrected mention of 'auto_exec' to 'auto_execok'. - [Patch 2114900] thanks to Stuart Cassoff - -2008-11-25 Jan Nijtmans - - * generic/tclIndexObj.c: Eliminate 3 calls to Tcl_SetResult, as - * generic/tclIO.c: examples how it should have been done. - * generic/tclTestObj.c: purpose: contribute in the TIP #340 - discussion. - 2008-11-25 Andreas Kupries * generic/tclIO.c (TclFinalizeIOSubsystem): Applied Alexandre Ferrieux's patch for [Bug 2270477] to prevent infinite looping during finalization of channels not bound to interpreters. -2008-11-25 Jan Nijtmans - - * generic/tclTest.c: Don't assume that Tcl_SetResult sets - interp->result, especially not in a DString test, in preparation for - TIP #340 - -2008-11-24 Donal K. Fellows - - * tools/tcltk-man2html.tcl: Improvements to tackle tricky aspects of - cross references and new entities to map. [Bug 2330040] - -2008-11-19 Jan Nijtmans - - * generic/tclThreadTest.c: Convert Tcl_SetResult(......, TCL_DYNAMIC) - to Tcl_SetResult(......, TCL_VOLATILE), in preparation for TIP #340 - -2008-11-17 Jan Nijtmans +2008-08-23 Andreas Kupries + + * generic/tclIO.c: Backport of fix for [Bug 2333466]. + +2008-11-18 Jan Nijtmans * generic/tcl.decls: Fix signature and implementation of * generic/tclDecls.h: Tcl_HashStats, such that it conforms to the * generic/tclHash.c: documentation. [Bug 2308236] - * generic/tclVar.c: * doc/Hash.3: - * generic/tclDictObj.c: Convert Tcl_SetResult call to - Tcl_SetObjResult. - -2008-11-17 Alexandre Ferrieux - - * tests/for.test: Check for uncompiled-for-continue [Bug 2186888] - fixed earlier. - - * generic/tcl.h: Fix [Bug 2251175]: missing backslash - * generic/tclCompCmds.c: substitution on expanded literals. - * generic/tclCompile.c - * generic/tclParse.c - * generic/tclTest.c - * tests/compile.test - * tests/parse.test - -2008-11-16 Jan Nijtmans - - * generic/tclTest.c: Replace two times Tcl_SetResult with - Tcl_SetObjResult, a little simplification in preparation for the TIP - #340 patch. 2008-11-13 Jan Nijtmans * generic/tclInt.h: Rename static function FSUnloadTempFile to * generic/tclIOUtil.c: TclFSUnloadTempFile, needed in tclLoad.c * generic/tclLoad.c: Fixed [Bug 2269431]: Load of shared objects leaves temporary files on windows. -2008-11-12 Pat Thoyts - - * tests/registry.test: Use HKCU to avoid requiring admin access for - registry testing on Vista/Server2008 - -2008-11-11 Jan Nijtmans - - * generic/tclNamesp.c: Eliminate warning: passing arg 4 of - Tcl_SplitList from incompatible pointer type. - * win/tcl.m4: Reverted change from 2008-11-06 (was under the - impression that "-Wno-implicit-int" added an extra - warning) - * win/configure: (regenerated) - * unix/tcl.m4: Use -O2 as gcc optimization compiler flag, and get rid - of -Wno-implicit-int for UNIX. - * unix/configure: (regenerated) - 2008-11-10 Andreas Kupries * doc/platform_shell.n: Fixed [Bug 2255235], reported by Ulrich * library/platform/pkgIndex.tcl: Ring . * library/platform/shell.tcl: Updated the LOCATE command in the @@ -679,291 +120,62 @@ * library/tm.tcl: package 'platform::shell' to handle the new form * unix/Makefile.in: of 'provide' commands generated by tm.tcl. Bumped * win/Makefile.in: package to version 1.1.4. Added cross-references to the relevant parts of the code to avoid future desynchronization. -2008-11-07 Pat Thoyts - - * generic/tclInt.h: Applied [Patch 2215022] from Duoas to clean up - * generic/tclBinary.c: the binary ensemble initiailization code. - * generic/tclNamesp.c: Extends the TclMakeEnsemble to do - * doc/ByteArrObj.3: sub-ensembles from tables. - -2008-11-06 Jan Nijtmans - - * win/tcl.m4: Add "-Wno-implicit-int" flag for gcc, as on UNIX - * win/configure: (regenerated) - * generic/tclIO.c: Eliminate an 'array index out of bounds' warning - on HP-UX. - 2008-11-04 Jeff Hobbs * generic/tclPort.h: Remove the ../win/ header dir as the build system already has it, and it confuses builds when used with private headers installed. -2008-11-01 Donal K. Fellows - - * generic/tclOO.h (TCLOO_VERSION): Bump version of TclOO. - -2008-10-31 Donal K. Fellows - - * generic/tclOOBasic.c (TclOONRUpcatch): Reworked the code that does - * generic/tclOO.c (InitFoundation): class constructor handling so - that it is more robust and runs the constructor call in the context of - the caller of the class's constructor method. Needed because the - previously used code did not work at all after applying the fix below; - no Tcl existing command could reliably do what was needed any more. - - * generic/tclOODefineCmds.c (GetClassInOuterContext): Rework and - factor out the code to resolve class names in definitions so that - classes are resolved from the perspective of the caller of the - [oo::define] command, rather than from the oo::define namespace! This - makes much code simpler by reducing how often fully-qualified names - are required (previously always in practice, so no back-compat issues - exist). [Bug 2200824] - -2008-10-28 Jan Nijtmans - - * generic/tclCompile.h: CONSTify TclDTraceInfo - * generic/tclBasic.c: - * generic/tclProc.c: - * generic/tclEnv.c: Eliminate some -Wwrite-strings warnings - * generic/tclLink.c: - -2008-10-27 Don Porter - - * generic/tclEncoding.c: Use "iso8859-1" and not "identity" as - the default and original [encoding system] value. Since "iso8859-1" is - built in to the C source code for Tcl now, there's no availability - issue, and it has the good feature of "identity" that we must have - ("bytes in" == "bytes out") without the bad feature of "identity" - ("broken as designed") that makes us want to abandon it. [RFE 2008609] - *** POTENTIAL INCOMPATIBILITY for older releases of Tclkit and any - other code expecting a particular value for Tcl's default system - encoding *** - 2008-10-24 Pat Thoyts - * library/http/http.tcl: Fixed a failure to read SHOUTcast streams - with the new 2.7 package. Introduced a new intial state as the first - response may not be HTTP*. - -2008-10-23 Miguel Sofer - - * generic/tclCmdAH.c (ForNextCallback): handle TCL_CONTINUE in the for - body. [Bug 2186888] - -2008-10-22 Jan Nijtmans - - * generic/tcl.h: CONST -> const and white-spacing - * generic/tclCompile.h: - * generic/tclEncoding.c: - * generic/tclStubInit.c: - * generic/tclStubLib.c: - * generic/tcl.decls - * generic/tclInt.decls - * generic/tclTomMath.decls - * generic/tclDecls.h: (regenerated) - * generic/tclIntDecls.h: (regenerated) - * generic/tclIntPlatDecls.h: (regenerated) - * generic/tclOODecls.h: (regenerated) - * generic/tclOOIntDecls.h: (regenerated) - * generic/tclPlatDecls.h: (regenerated) - * generic/tclTomMathDecls.h: (regenerated) - * generic/tclIntDecls.h: (regenerated) - * tools/genStubs.tcl: CONST -> const and white-spacing + * library/http/http.tcl: Backported a fix for reading HTTP-like + protocols that used to work and were broken with http 2.7. Now http + 2.7.2 + +2008-10-23 Don Porter + + * generic/tcl.h: Bump version number to 8.5.6b1 to distinguish + * library/init.tcl: CVS development snapshots from the 8.5.5 and + * unix/configure.in: 8.5.6 releases. + * unix/tcl.spec: + * win/configure.in: + * tools/tcl.wse.in: + * README + + * unix/configure: autoconf (2.59) + * win/configure: 2008-10-19 Don Porter * generic/tclProc.c: Reset -level and -code values to defaults after they are used. [Bug 2152286] -2008-10-19 Donal K. Fellows - - * generic/tclBasic.c (TclInfoCoroutineCmd): Added code to make this - check for being invoked in a syntactically correct way. - - * doc/info.n: Added documentation of [info coroutine]. - - * doc/prefix.n: Improved the documentation by fixing formatting, - adding good-practice recommendations and cross-references, etc. - -2008-10-17 Jan Nijtmans - - * generic/tclOO.decls: CONST -> const. - * generic/tclOODecls.h: (regenerated) - * generic/tclOOIntDecls.h: (regenerated) - -2008-10-17 Andreas Kupries - - * generic/tclIORTrans.c (DeleteReflectedTransformMap): Removed debug - output in C++ comment. - -2008-10-17 Don Porter - - * generic/tclCompile.h: Declare the internal tclInstructionTable to - * generic/tclExecute.c: simply be "const", not CONST86. - - * generic/tclCmdAH.c: whitespace. - * generic/tclCmdIL.c: Uninitialized variable warning. - * generic/tclTest.c: const correctness warning. - -2008-10-17 Donal K. Fellows - - * doc/*: Many very small formatting fixes. - * doc/{glob,http,if}.n: More substantial reformatting for clarity. - * doc/split.n: Remove mention of defunct c.l.t.announce - -2008-10-16 Jan Nijtmans - - * generic/regc_locale.c: Add "const" to many internal const tables. - * generic/tclClock.c: No functional or API change. - * generic/tclCmdIL.c - * generic/tclConfig.c - * generic/tclDate.c - * generic/tclEncoding.c - * generic/tclEvent.c - * generic/tclExecute.c - * generic/tclFileName.c - * generic/tclGetDate.y - * generic/tclInterp.c - * generic/tclIO.c - * generic/tclIOCmd.c - * generic/tclIORChan.c - * generic/tclIORTrans.c - * generic/tclLoad.c - * generic/tclObj.c - * generic/tclOOBasic.c - * generic/tclOOCall.c - * generic/tclOOInfo.c - * generic/tclPathObj.c - * generic/tclPkg.c - * generic/tclResult.c - * generic/tclStringObj.c - * generic/tclTest.c - * generic/tclTestObj.c - * generic/tclThreadTest.c - * generic/tclTimer.c - * generic/tclTrace.c - * macosx/tclMacOSXFCmd.c - * win/cat.c - * win/tclWinInit.c - * win/tclWinTest.c - 2008-10-16 Don Porter * library/init.tcl: Revised [unknown] so that it carefully preserves the state of the ::errorInfo and ::errorCode variables at the start of auto-loading and restores that state before the autoloaded command is evaluated. [Bug 2140628] -2008-10-15 Jan Nijtmans - - * generic/tclInt.h: Add "const" to many internal const tables, so - * generic/tclBinary.c: those will be put by the C-compiler in the - * generic/tclCompile.c: TEXT segment in stead of the DATA segment. - * generic/tclDictObj.c: This makes those tables sharable in shared - * generic/tclHash.c: libraries. - * generic/tclListObj.c: - * generic/tclNamesp.c: - * generic/tclObj.c: - * generic/tclProc.c: - * generic/tclRegexp.c: - * generic/tclStringObj.c: - * generic/tclUtil.c: - * generic/tclVar.c: - -2008-10-14 Jan Nijtmans - - * generic/tclCmdAH.c: Fix minor compiler warnings when compiling - * generic/tclCmdMZ.c: with -Wwrite-strings. - * generic/tclIndexObj.c: - * generic/tclProc.c: - * generic/tclStubLib.c: - * generic/tclUtil.c: - * win/tclWinChan.c: - * win/tclWinDde.c: - * win/tclWinInit.c: - * win/tclWinReg.c: - * win/tclWinSerial.c: - -2008-10-14 Donal K. Fellows - - * doc/binary.n: Formatting fix. - -2008-10-14 Don Porter - - * README: Bump version number to 8.6a4 - * generic/tcl.h: +2008-10-10 Don Porter + + *** 8.5.5 TAGGED FOR RELEASE *** + + * generic/tcl.h: Bump to 8.5.5 for release. * library/init.tcl: * tools/tcl.wse.in: * unix/configure.in: * unix/tcl.spec: * win/configure.in: * unix/configure: autoconf-2.59 * win/configure: - * generic/tclExecute.c: Fix compile warnings when --enable-symbols=all - - * generic/tclCmdIL.c: Fix write to unallocated memory whenever - [lrepeat] returns an empty list. - -2008-10-14 Donal K. Fellows - - * doc/chan.n, doc/fconfigure.n: Added even more emphatic text to - direct people to the correct manual pages for specific channel types, - suitable for the hard-of-reading. Following discussion on tcl-core. - -2008-10-13 Pat Thoyts - - * win/tclWinThrd.c (TclpThreadCreate): We need to initialize the - thread id variable to 0 as on 64 bit windows this is a pointer sized - field while windows only fills it with a 32 bit value. The result is - an inability to join the threads as the ids cannot be matched. - - * generic/tclTest.c (TestNRELevels): Set array to the right size. - -2008-10-13 Donal K. Fellows - - * generic/tclOOInfo.c (InfoClassDestrCmd): Handle error case. - - * generic/tclOOInt.h: Added macro magic to make things work with - Objective C. [Bug 2163447] - -2008-10-12 Miguel Sofer - - * generic/tclCompile.c: Fix bug in srcDelta encoding within ByteCodes. - The bug can only be triggered under conditions that cannot happen in - Tcl, but were met during development of L. Thanks go to Robert Netzer - for diagnosis and fix. - -2008-10-10 Don Porter - - *** 8.6a3 TAGGED FOR RELEASE *** - - * changes: Updates for 8.6a3 release. - -2008-10-10 Donal K. Fellows - - * generic/tclOODefineCmds.c (TclOODefineUnexportObjCmd) - (TclOODefineExportObjCmd): Corrected export/unexport record synthesis. - [Bug 2155658] - -2008-10-08 Jan Nijtmans - - * unix/tclUnixChan.c: Fix minor compiler warning. - * unix/tcl.m4: Fix for [Bug 2073255] - * unix/configure: Regenerated - -2008-10-08 Miguel Sofer - - * generic/tclBasic (TclInfoCoroutineCmd): - * tests/unsupported.test: Arrange for [info coroutine] to return {} - when a coroutine is running but the resume command has been deleted. - [Bug 2153080] + * changes: Update for 8.5.5 release. 2008-10-08 Don Porter * generic/tclTrace.c: Corrected handling of errors returned by variable traces so that the errorInfo value contains the original @@ -971,372 +183,46 @@ * generic/tclVar.c: Revised implementation of TclObjVarErrMsg so that error message construction does not disturb an existing iPtr->errorInfo that may be in progress. -2008-10-07 Donal K. Fellows - - * doc/binary.n: Added better documentation of the [binary encode] and - [binary decode] subcommands. - -2008-10-07 Miguel Sofer - - TIP #327,#328 IMPLEMENTATIONS - - * generic/tclBasic.c: Move [tailcall], [coroutine] and - * generic/tclCmdIL.c: [yield] out of ::tcl::unsupported - * tclInt.h: - * tests/info.test: and into global scope: TIPs #327 - * tests/unsupported.test: and #328 - -2008-10-07 Donal K. Fellows - - * doc/chan.n, doc/transchan.n: Documented the channel transformation - API of TIP #230. - -2008-10-06 Pat Thoyts - - * tests/winFCmd.test: Fixed some erroneous tests on Vista+. - * generic/tclFCmd.c: Fix constness for msvc of last commit +2008-10-06 Jan Nijtmans + + * tclWinTest.c: Fix compiler warning when compiling this file with + mingw gcc: + tclWinTest.c:706: warning: dereferencing type-punned pointer will + break strict-aliasing rules + * generic/tclLoad.c: Make sure that any library which doesn't have an + unloadproc is only really unloaded when no library code is executed + yet. [Bug 2059262] 2008-10-06 Joe Mistachkin * tools/man2tcl.c: Added missing line from patch by Harald Oehlmann. [Bug 1934200] -2008-10-05 Jan Nijtmans - - * doc/FileSystem.3: CONSTified Tcl_FSFileAttrStringsProc - * generic/tclFCmd.c: and tclpFileAttrStrings. This allows - * generic/tclIOUtil.c: FileSystems to report their attributes - * generic/tclTest.c: as const strings, without worrying that - * unix/tclUnixFCmd.c: Tcl modifies them (which Tcl should not - * win/tclWinFCmd.c: do anyway, but the API didn't indicate that) - * generic/tcl.decls - * generic/tclDecls.h: regenerated - * generic/tcl.h: Make sure that if CONST84 is defined as empty, - CONST86 should be defined as empty as well - (unless overridden). This change complies with - TIP #27 - *** POTENTIAL INCOMPATIBILITY *** - 2008-10-05 Kevin B, Kenny * libtommath/bn_mp_sqrt.c (bn_mp_sqrt): Handle the case where a * tests/expr.test (expr-47.13): number's square root is between n< - - * generic/tclInt.decls: CONSTified the AuxDataType argument - * generic/tclCompCmds.c: of TclCreateAuxData and - * generic/tclCompile.c: TclRegisterAuxDataType and the return - * generic/tclCompile.h: values of TclGetAuxDataType and - * generic/tclExecute.c: TclGetInstructionTable - * generic/tclIntDecls.h: regenerated - This change complies with TIP #27 (even though it only involves - internal function, so this is not even necessary). - -2008-10-05 Donal K. Fellows - - * generic/tclIndexObj.c (TclInitPrefixCmd): Make the [tcl::prefix] - into an exported command. [Bug 2144595] - -2008-10-04 Donal K. Fellows - - * generic/tclCmdIL.c (InfoFrameCmd): Improved hygiene of result - * generic/tclRegexp.c (TclRegAbout): handling. - -2008-10-04 Jan Nijtmans - - * generic/tclLoad.c: Make sure that any library which doesn't have an - unloadproc is only really unloaded when no library code is executed - yet. [Bug 2059262] - -2008-10-04 Donal K. Fellows - - * generic/tclOOInfo.c (GetClassFromObj): Factor out the code to parse - a Tcl_Obj and get a class. Also make result handling hygienic. - * generic/tclOOBasic.c (TclOOSelfObjCmd): Better hygiene of results, - and stop allocating quite so much memory by sharing special "method" - names. - -2008-10-04 Jan Nijtmans - - * doc/ChnlStack.3: CONSTified the typePtr argument - * doc/CrtChannel.3: of Tcl_CreateChannel and Tcl_StackChannel - * generic/tcl.decls: and the return value of Tcl_GetChannelType - * generic/tcl.h - * generic/tclIO.h - * generic/tclIO.c - * generic/tclDecls.h: regenerated - This change complies with TIP #27. - - * doc/Hash.3: CONSTified the typePtr argument - * generic/tcl.decls: of Tcl_InitCustomHashTable. - * generic/tcl.h - * generic/tclHash.c - * generic/tclDecls.h: regenerated - This change complies with TIP #27. - - * doc/RegConfig.3: CONSTified the configuration argument - * generic/tcl.decls: of Tcl_RegisterConfig. - * generic/tcl.h - * generic/tclConfig.c - * generic/tclPkgConfig.c - * generic/tclDecls.h: regenerated - This change complies with TIP #27. - - * doc/GetIndex.3: CONSTified the tablePtr argument - * generic/tcl.decls: of Tcl_GetIndexFromObj. - * generic/tclIndexObj.c - * generic/tclDecls.h: regenerated - This change complies with TIP #27. - -2008-10-03 Miguel Sofer - - * tests/stack.test: - * unix/tclUnixTest.c: Removed test command teststacklimit and the - corresponding constraint: it is not needed with NRE - -2008-10-03 Donal K. Fellows - - TIP #195 IMPLEMENTATION - - * generic/tclIndexObj.c (TclGetIndexFromObjList, PrefixMatchObjCmd) - * doc/prefix.n, tests/string.test: Added [tcl::prefix] command for - working with prefixes of strings at the Tcl level. [Patch 1040206] - - TIP #265 IMPLEMENTATION - - * generic/tclIndexObj.c (Tcl_ParseArgsObjv, PrintUsage): - * generic/tcl.h (Tcl_ArgvInfo): Added function for simple parsing of - * doc/ParseArgs.3 (new file): optional arguments to commands. Still - needs tests and the like. [FRQ 1446696] Note that some of the type - signatures are changed a bit from the proposed implementation so that - they better reflect codified good practice for argument order. - -2008-10-02 Andreas Kupries - - * tests/info.test (info-23.3): Updated output of the test to handle - the NRE-enabled eval and the proper propagation of location - information through it. [Bug 2017632] - - * doc/info.n: Rephrased the documentation of 'info frame' for positive - numbers as level argument. [Bug 2134049] - - * tests/info.test (info-22.8): Made pattern for file containing - tcltest less specific to accept both .tcl and .tm variants of the file - during matching. [Bug 2129828] - -2008-10-02 Don Porter - - TIP #330 IMPLEMENTATION - - * generic/tcl.h: Remove the "result" and "freeProc" fields - * generic/tclBasic.c: from the default public declaration of the - * generic/tclResult.c: Tcl_Interp struct. Code should no longer - * generic/tclStubLib.c: be accessing these fields. Access can be - * generic/tclTest.c: restored by defining USE_INTERP_RESULT, but - * generic/tclUtil.c: that should only be a temporary migration aid. - *** POTENTIAL INCOMPATIBILITY *** - 2008-10-02 Joe Mistachkin - * doc/info.n: Fix unmatched font change. - * doc/tclvars.n: Fix unmatched font change. - * doc/variable.n: Fix unmatched font change. - * tools/man2help2.tcl: Integrated patch from Harald Oehlmann. - [Bug 1934272] - * tools/man2tcl.c: Increase MAX_LINE_SIZE to fix "Too long line" error. - * win/buildall.vc.bat: Prefer the HtmlHelp target over the WinHelp - target. [Bug 2072891] - * win/makefile.vc: Fix the HtmlHelp and WinHelp targets to not be - mutually exclusive. - -2008-09-29 Don Porter - - TIP #323 IMPLEMENTATION (partial) - - * doc/glob.n: Revise [glob] to accept zero patterns. - * generic/tclFileName.c: - * tests fileName.test: - - * doc/linsert.n: Revise [linsert] to accept zero elements. - * generic/tclCmdIL.c: - * tests/linsert.test: - -2008-09-29 Donal K. Fellows - - TIP #326 IMPLEMENTATION - - * generic/tclCmdIL.c (Tcl_LsortObjCmd): Added -stride option to carry - * doc/lsort.n, tests/cmdIL.test: out sorting of lists where the - elements are grouped. Adapted from [Patch 2082681] - - TIP #313 IMPLEMENTATION - - * generic/tclCmdIL.c (Tcl_LsearchObjCmd): Added -bisect option to - * doc/lsearch.n, tests/lsearch.test: allow the finding of the - place to insert an element in a sorted list when that element is - not already there. [Patch 1894241] - - TIP #318 IMPLEMENTATION - - * generic/tclCmdMZ.c (StringTrimCmd,StringTrimLCmd,StringTrimRCmd): - Update the default set of trimmed characters to include some from the - larger UNICODE space. Factor out the default trim set into a macro so - that it is easier to keep them in synch. - -2008-09-28 Donal K. Fellows - - TIP #314 IMPLEMENTATION - - * generic/tclCompCmds.c (TclCompileEnsemble) - * generic/tclNamesp.c (NamespaceEnsembleCmd) - (Tcl_SetEnsembleParameterList, Tcl_GetEnsembleParameterList) - (NsEnsembleImplementationCmdNR): - * generic/tcl.decls, doc/Ensemble.3, doc/namespace.n - * tests/namespace.test: Allow the handling of a (fixed) number of - formal parameters between an ensemble's command and subcommand at - invokation time. [Patch 1901783] - -2008-09-28 Miguel Sofer - - * generic/tclBasic.c: Fix the numLevels computations on - * generic/tclInt.h: coroutine yield/resume - * tests/unsupported.test: + * tools/man2help2.tcl: Integrated patches from Harald Oehlmann. + * tools/man2tcl.c: [Bug 1934200, 1934272] 2008-09-27 Donal K. Fellows - * generic/tclFileName.c (Tcl_GetBlock*FromStat): Made this work - acceptably when working with OSes that don't support reporting the - block size from the stat() call. [Bug 2130726] - * generic/tclCmdIL.c (Tcl_LrepeatObjCmd): Improve the handling of the case where the combination of number of elements and repeat count causes the resulting list to be too large. [Bug 2130992] -2008-09-26 Don Porter - - TIP #323 IMPLEMENTATION (partial) - - * doc/lrepeat.n: Revise [lrepeat] to accept both zero - * generic/tclCmdIL.c: repetitions and zero elements to be repeated. - * tests/lrepeat.test: - - * doc/object.n: Revise standard oo method [my variable] to - * generic/tclOOBasic.c: accept zero variable names. - * tests/oo.test: - - * doc/tm.n: Revise [tcl::tm::path add] and - * library/tm.tcl: [tcl::tm::path remove] to accept zero paths. - * tests/tm.test: - - * doc/namespace.n: Revise [namespace upvar] to accept zero - * generic/tclNamesp.c: variable names. - * tests/upvar.test: - - * doc/lassign.n: Revise [lassign] to accept zero variable names. - * generic/tclCmdIL.c: - * tests/cmdIL.test: - -2008-09-26 Donal K. Fellows - - * generic/tclOO.h (TCLOO_VERSION): Bump the version. - -2008-09-25 Don Porter - - TIP #323 IMPLEMENTATION (partial) - - * doc/global.n: Revise [global] to accept zero variable names. - * doc/variable.n: Revise [variable] likewise. - * generic/tclVar.c: - * tests/proc-old.test: - * tests/var.test: - - * doc/global.n: Correct false claim about [info locals]. - -2008-09-25 Donal K. Fellows - - TIP #315 IMPLEMENTATION - - * tests/platform.test: Update tests to expect revised results - * tests/safe.test: corresponding to the TIP 315 change. - - * unix/tclUnixInit.c, win/tclWinInit.c (TclpSetVariables): - * doc/tclvars.n (tcl_platform): Define what character is used for - separating PATH-like lists. Forms part of the tcl_platform array. - - * generic/tclOOCall.c (InitCallChain, IsStillValid): - * tests/oo.test (oo-25.2): Revise call chain cache management so that - it takes into account class-wide caching correctly. [Bug 2120903] - -2008-09-24 Don Porter - - TIP #323 IMPLEMENTATION (partial) - - * doc/file.n: Revise [file delete] and [file mkdir] to - * generic/tclCmdAH.c: accept zero "pathname" arguments (the - * generic/tclFCmd.c: no-op case). - * tests/cmdAH.test: - * tests/fCmd.test: - -2008-09-24 Donal K. Fellows - - * generic/tclOOMethod.c (DBPRINT): Remove obsolete debugging macro. - [Bug 2124814] - - TIP #316 IMPLEMENTATION - - * generic/tcl.decls, generic/tclFileName.c (Tcl_GetSizeFromStat, etc): - * doc/FileSystem.3: Added reader functions for Tcl_StatBuf. - -2008-09-23 Donal K. Fellows - - * doc/Method.3: Corrected documentation. [Patch 2082450] - - * doc/lreverse.n, mathop.n, regexp.n, regsub.n: Make sure that the - initial line of the manpage includes nothing that chokes old versions - of man. [Bug 2118123] - -2008-09-22 Donal K. Fellows - - TIP #320 IMPLEMENTATION - - * generic/tclOODefineCmds.c (TclOODefineVariablesObjCmd): - * generic/tclOOInfo.c (InfoObjectVariablesCmd, InfoClassVariablesCmd): - * generic/tclOOMethod.c (TclOOSetupVariableResolver, etc): - * doc/define.n, doc/ooInfo.n, benchmarks/cps.tcl: - * tests/oo.test (oo-26.*): Allow the declaration of the common - variables used in methods of a class or object. These are then mapped - in using a variable resolver. This makes many class declarations much - simpler overall, encourages good usage of variable names, and also - boosts speed a bit. - - * generic/tclOOMethod.c (TclOOGetMethodBody): Factor out the code to - get the body of a procedure-like method. Reduces the amount of "poking - inside the abstraction" that is done by the introspection code. - -2008-09-22 Alexandre Ferrieux - - * doc/chan.n: Clean up paragraph order. - -2008-09-18 Miguel Sofer - - * generic/tclExecute.c (NEXT_INST_F): - * generic/tclInt.h (TCL_CT_ASSERT): New compile-time assertions, - adapted from www.pixelbeat.org/programming/gcc/static_assert.html +2008-09-25 Don Porter + + * doc/global.n: Correct false claim about [info locals]. 2008-09-17 Don Porter * generic/tclInt.h: Correct the TclGetLongFromObj, TclGetIntFromObj, and TclGetIntForIndexM macros so that they retrieve the longValue @@ -1346,353 +232,105 @@ 2008-09-17 Miguel Sofer * library/init.tcl: Export min and max commands from the mathfunc namespace. [Bug 2116053] -2008-09-16 Joe Mistachkin - - * generic/tclParse.c: Move TclResetCancellation to be called on - returning to level 0, as opposed to it being called on starting a - substitution at level 0. - -2008-09-16 Miguel Sofer - - * generic/tclBasic.c: Move TclResetCancellation to be called on - returning to level 0, as opposed to it being called on starting a - command at level 0. Add a call on returning via Tcl_EvalObjEx to fix - [Bug 2114165]. - -2008-09-10 Donal K. Fellows - - * doc/binary.n: Added partial documentation of [binary encode] and - [binary decode]. - - * tests/binary.test,cmdAH.test,cmdIL.test,cmdMZ.test,fileSystem.test: - More use of tcltest2 to simplify the tests as exposed to people. - * tests/compile.test (compile-18.*): Added *some* tests of the - disassmbler, though not of its output format. - -2008-09-10 Miguel Sofer - - * tests/nre.test: Add missing constraints; enable test of foreach - recursion. - - * generic/tclBasic.c: - * generic/tclCompile.h: - * generic/tclExecute.c (INST_EVAL_STK): Wrong numLevels when evaling a - canonical list. [Bug 2102930] - 2008-09-10 Donal K. Fellows * generic/tclListObj.c (Tcl_ListObjGetElements): Make this list->dict transformation - encountered when using [foreach] with dicts - not as expensive as it was before. Spotted by Kieran Elby and reported on tcl-core. -2008-09-08 Donal K. Fellows - - * tests/append.test, appendComp.test, cmdAH.test: Use the powers of - tcltest2 to make these files simpler. - -2008-09-07 Miguel Sofer - - * generic/tclCompile.c (TclCompileTokens): - * generic/tclExecute.c (CompileExprObj): Fix a perf bug (found by Alex - Ferrieux) where some variables in the LVT where not being accessed by - index. Fix missing localCache management in compiled expressions found - while analyzing the bug. - 2008-09-07 Miguel Sofer * doc/namespace.n: Fix [Bug 2098441] -2008-09-04 Miguel Sofer - - * generic/tclTrace.test (TraceVarProc): - * generic/unsupported.test: Insure that unset traces are run even when - the coroutine is unwinding. [Bug 2093947] - - * generic/tclExecute.c (CACHE_STACK_INFO): - * tests/unsupported.test: Restore execEnv's bottomPtr. [Bug 2093188] - -2008-09-02 Don Porter - - * generic/tcl.h: Stripped "callers" of the _ANSI_ARGS_ macro - * compat/dirent2.h: to support a TCL_NO_DEPRECATED build. - * compat/dlfcn.h: - * unix/tclUnixPort.h: - - * generic/tcl.h: Removed the conditional #define of - _ANSI_ARGS_ that would support pre-prototype C compilers. Since - _ANSI_ARGS_ is no longer used in tclDecls.h, it's clear no one - compiling against Tcl 8.5 headers is making use of a -DNO_PROTOTYPES - configuration. - -2008-09-02 Donal K. Fellows - - * tests/socket.test: Rewrote so as to use tcltest2 better. - -2008-09-01 Miguel Sofer - - * generic/tclCmdAH.c: NRE-enabling [eval]; eval scripts are now - * generic/tclOOBasic.c: bytecompiled. Adapted recursion limit tests - * tests/interp.test: that were relying on eval not being - * tests/nre.test: compiled. Part of the [Bug 2017632] project. - * tests/unsupported.test: - -2008-09-01 Donal K. Fellows - - * generic/tclOOMethod.c (InvokeProcedureMethod): - * generic/tclOO.c (ObjectRenamedTrace): Arrange for only methods that - involve callbacks into the Tcl interpreter to be skipped when the - interpreter is being torn down. Allows the semantics of destructors in - a dying interpreter to be more useful when they're implemented in C. - -2008-08-29 Donal K. Fellows - - * unix/Makefile.in: Ensure that all TclOO headers get installed. - * win/Makefile.in: [Bug 2082299] - * win/makefile.bc: - * win/makefile.vc: - 2008-08-28 Don Porter - * README: Bump version number to 8.6a3 - * generic/tcl.h: - * library/init.tcl: + * generic/tcl.h: Bump version number to 8.5.5b1 to distinguish + * library/init.tcl: CVS development snapshots from the 8.5.4 and + * unix/configure.in: 8.5.5 releases. + * unix/tcl.spec: + * win/configure.in: * tools/tcl.wse.in: - * unix/configure.in: - * unix/tcl.spec: - * win/configure.in: + * README * unix/configure: autoconf-2.59 * win/configure: -2008-08-27 Donal K. Fellows - - * doc/tclvars.n, doc/library.n: Ensured that these two manual pages - properly cross-reference each other. Issue reported on Tcler's Chat. - -2008-08-26 Miguel Sofer - - * generic/tclBasic.c (InfoCoroutine): - * tests/unsupported.test: New command that returns the FQN of the - currently executing coroutine. Lives as infoCoroutine under - unsupported, but is designed to become a subcommand of [info] - -2008-08-23 Miguel Sofer - - * generic/tclBasic.c (NRInterpCoroutine): Store the caller's eePtr, - stop assuming the coroutine is invoked from the same execEnv where it - was created. - -2008-08-24 Donal K. Fellows - - * generic/tclCmdAH.c (TclNRForeachCmd): Converted the [foreach] - command to have an NRE-aware non-compiled implementation. Part of the - [Bug 2017632] project. Also restructured the code so as to manage its - temporary memory more efficiently. - -2008-08-23 Miguel Sofer - - * generic/tclBasic.c: Removed unused var; fixed function pointer - * generic/tclOOInt.h: declarations (why did gcc start complaining - * generic/tclOOMethod.c: all of a sudden?) - * generic/tclProc.c: - -2008-08-23 Donal K. Fellows - - * generic/tclInt.h (EnsembleImplMap): Added extra field to make it - * generic/tclNamesp.c (TclMakeEnsemble): easier to build non-recursive - ensembles in the core. - - * generic/tclDictObj.c (DictForNRCmd): Converted the [dict for] - command to have an NRE-aware non-compiled implementation. Part of the - [Bug 2017632] project. - -2008-08-22 Miguel Sofer - - * generic/tclBasic.c: - * generic/tclExecute.c: Set special errocodes: COROUTINE_BUSY, - COROUTINE_CANT_YIELD, COROUTINE_ILLEGAL_YIELD. - 2008-08-22 Don Porter - *** 8.6a2 TAGGED FOR RELEASE *** - - * changes: Updates for 8.6a2 release. - - * generic/tcl.h: Drop use of USE_COMPAT85_CONST. That added - indirection without value. Use -DCONST86="" to engage source compat - support for code written for 8.5 headers. - * generic/tclUtil.c (TclReToGlob): Added missing set of the *exactPtr value to really fix [Bug 2065115]. Also avoid possible DString overflow. * tests/regexpComp.test: Correct duplicate test names. -2008-08-21 Miguel Sofer - - * generic/tclBasic.c: Previous fix, now done right. - * generic/tclCmdIL.c: - * generic/tclInt.h: - * tests/unsupported.test: - 2008-08-21 Jeff Hobbs * tests/regexp.test, tests/regexpComp.test: Correct re2glob ***= * generic/tclUtil.c (TclReToGlob): translation from exact to anywhere-in-string match. [Bug 2065115] -2008-08-21 Don Porter - - * generic/tcl.h: Reduced the use of CONST86 and eliminated - * generic/tcl.decls: the use of CONST86_RETURN to support source - code compatibility with Tcl 8.5 on those public routines passing - (Tcl_Filesystem *), (Tcl_Timer *), and (Tcl_Objtype *) values which - have been const-ified. What remains is the minimum configurability - needed to support code written for pre-8.6 headers via the new - -DUSE_COMPAT85_CONST compiler directive. - *** POTENTIAL INCOMPATIBILITY *** - - * generic/tclDecls.h: make genstubs - -2008-08-21 Miguel Sofer - - * generic/tclBasic.c: Fix the cmdFrame level count in - * generic/tclCmdIL.c: coroutines. Fix small bug on coroutine - * generic/tclInt.h: rewind. - -2008-08-21 Donal K. Fellows - - * generic/tclProc.c (Tcl_DisassembleObjCmd): Added ability to - disassemble TclOO methods. The code to do this is very ugly. - -2008-08-21 Pat Thoyts - - * generic/tclOOMethod.c: Added casts to make MSVC happy - * generic/tclBasic.c: - -2008-08-20 Donal K. Fellows - - * generic/tclOO.c (AllocObject): Suppress compilation of commands in - the namespace allocated for each object. - * generic/tclOOMethod.c (PushMethodCallFrame): Restore some of the - hackery that makes calling methods of classes fast. Fixes performance - problem introduced by the fix of [Bug 2037727]. - - * generic/tclCompile.c (TclCompileScript): Allow the suppression of - * generic/tclInt.h (NS_SUPPRESS_COMPILATION): compilation of commands - * generic/tclNamesp.c (Tcl_CreateNamespace): from a namespace or its - children. - 2008-08-20 Daniel Steffen * generic/tclTest.c (TestconcatobjCmd): Fix use of internal-only TclInvalidateStringRep macro. [Bug 2057479] 2008-08-17 Miguel Sofer - * generic/tclBasic.c: Implementation of [coroutine] and [yield] - * generic/tclCmdAH.c: commands (in tcl::unsupported). - * generic/tclCompile.h: - * generic/tclExecute.c: - * generic/tclInt.h: - * tests/unsupported.test: - * generic/tclTest.c (TestconcatobjCmd): * generic/tclUtil.c (Tcl_ConcatObj): * tests/util.test (util-4.7): Fix [Bug 1447328]; the original "fix" turned Tcl_ConcatObj() into a hairy monster. This was exposed by [Bug 2055782]. Additionally, Tcl_ConcatObj could corrupt its input under certain conditions! *** NASTY BUG FIXED *** -2008-08-16 Miguel Sofer - - * generic/tclExecute.c: Better cmdFrame management - 2008-08-14 Don Porter + + *** 8.5.4 TAGGED FOR RELEASE *** * tests/fileName.test: Revise new tests for portability to case insensitive filesystems. 2008-08-14 Daniel Steffen - * generic/tclBasic.c (TclNREvalObjv, Tcl_NRCallObjProc): - * generic/tclProc.c (TclNRInterpProcCore, InterpProcNR2): - DTrace probes for NRE. [Bug 2017160] - - * generic/tclBasic.c (TclDTraceInfo): Add two extra arguments to - * generic/tclCompile.h: DTrace 'info' probes for tclOO - * generic/tclDTrace.d: method & class/object info. - - * generic/tclCompile.h: Add support for debug logging of DTrace - * generic/tclBasic.c: 'proc', 'cmd' and 'inst' probes (does _not_ - require a platform with DTrace). + * generic/tclCompile.h: Add support for debug logging of DTrace + * generic/tclBasic.c: 'proc', 'cmd' and 'inst' probes (does + _not_ require a platform with DTrace). * generic/tclCmdIL.c (TclInfoFrame): Check fPtr->line before dereferencing as line info may not exists when TclInfoFrame() is called from a DTrace probe. + + * tests/msgcat.test: Fix for ::tcl::mac::locale with + @modifier (HEAD backport 2008-06-01). * tests/fCmd.test (fCmd-6.23): Made result matching robust when test workdir and /tmp are not on same FS. - * unix/tclUnixThrd.c: Remove unused TclpThreadGetStackSize() - * generic/tclInt.h: and related ifdefs and autoconf tests. - * unix/tclUnixPort.h: [Bug 2017264] (jenglish) - * unix/tcl.m4: - * unix/Makefile.in: Ensure Makefile shell is /bin/bash for * unix/configure.in (SunOS): DTrace-enabled build on Solaris. (followup to 2008-06-12) [Bug 2016584] * unix/tcl.m4 (SC_PATH_X): Check for libX11.dylib in addition to libX11.so et al. - * unix/configure: autoconf-2.59 - * unix/tclConfig.h.in: autoheader-2.59 - -2008-08-13 Miguel Sofer - - * tests/nre.test: Added test for large {*}-expansion effects + * unix/configure: autoconf-2.59 2008-08-13 Don Porter * generic/tclFileName.c: Fix for errors handling -types {} * tests/fileName.test: option to [glob]. [Bug 1750300] Thanks to Matthias Kraft and George Peter Staplin. -2008-08-12 Jeff Hobbs - - * generic/tclOOInfo.c (InfoObjectDefnCmd, InfoObjectMixinsCmd): - Fix # args displayed. [Bug 2048676] - -2008-08-08 Don Porter - - * generic/tclOOMethod.c (PushMethodCallFrame): Added missing check - for bytecode validity. [Bug 2037727] - - * generic/tclProc.c (TclProcCompileProc): On recompile of a - proc, clear away any entries on the CompiledLocal list from the - previous compile. This will prevent compile of temporary variables in - the proc body from growing the localCache arbitrarily large. - - * README: Bump version number to 8.6a2 - * generic/tcl.h: - * library/init.tcl: - * tools/tcl.wse.in: - * unix/configure.in: - * unix/tcl.spec: - * win/configure.in: - - * unix/configure: autoconf-2.59 - * win/configure: - - * changes: Updates for 8.6a2 release. +2008-08-12 Don Porter + + * changes: Update for 8.5.4 release. 2008-08-11 Pat Thoyts * library/http/http.tcl: Remove 8.5 requirement. * library/http/pkgIndex.tcl: @@ -1726,35 +364,23 @@ 2008-08-11 Pat Thoyts * library/http/http.tcl: CRC field from zlib data should be treated as unsigned for 64bit support. [Bug 2046846] -2008-08-10 Miguel Sofer - - * generic/tclProc.c: Completely removed ProcCompileProc, which was a - fix for [Bug 1482718]. This is not needed at least since varReform, - where the local variable data at runtime is read from the CallFrame - and/or the LocalCache. - -2008-08-09 Miguel Sofer - - * generic/tclBasic.c: Slight cleanup - * generic/tclCompile.h: - * generic/tclExecute.c: - -2008-08-09 Daniel Steffen - - * generic/tclExecute.c: Fix warnings. - - * generic/tclOOMethod.c (PushMethodCallFrame): Fix uninitialized efi - name field. - - * tests/lrange.test (lrange-1.17): Add test cleanup; whitespace. - 2008-08-08 Don Porter - * changes: Updates for 8.6a2 release. + * generic/tcl.h: Bump to 8.5.4 for release. + * library/init.tcl: + * tools/tcl.wse.in: + * unix/configure.in: + * unix/tcl.spec: + * win/configure.in: + + * unix/configure: autoconf-2.59 + * win/configure: + + * changes: Update for 8.5.4 release. 2008-08-08 Kevin Kenny * library/tzdata/CET: * library/tzdata/MET: @@ -1768,265 +394,63 @@ * library/tzdata/Europe/Berlin: * library/tzdata/Europe/Budapest: * library/tzdata/Europe/Sofia: * library/tzdata/Indian/Mauritius: Olson's tzdata2008e. -2008-08-07 Miguel Sofer - - * generic/tclBasic.c: Fix tailcalls falling out of tebc into - * generic/tclExecute.c: Tcl_EvalEx. [Bug 2017946] - * generic/tclInt.h: - 2008-08-06 Don Porter - * generic/tclOO.c: Revised TclOO's check for an interp being - deleted during handling of object command deletion. The old code was - relying on documented features of command delete traces that do not in - fact work. [Bug 2039178] - - * tests/oo.test (oo-26.*): Added tests that demonstrate failure - of TclOO to check for various kinds of invalid bytecode during method - dispatch. [Bug 2037727] - -2008-08-06 Miguel Sofer - - * generic/tclVar.c (TclLookupSimpleVar): Fix bug that the core could - not trigger before TclOO: the number of locals was being read from the - Proc, which can under some circumstance be out of sync with the - localCache's. Found by dgp while investigating [Bug 2037727]. - - * library/init.tcl (::unknown): Removed the [namespace inscope] - hack that was maintained for Itcl - - *** POTENTIAL INCOMPATIBILITY *** for Itcl - Itcl users will need a new release with Itcl's [Patch 2040295], or - else load the tiny script in that patch by themselves (rewrite - ::unknown). Note that it is a script-only patch. - -2008-08-05 Joe English - - * unix/tclUnixChan.c: Streamline async connect logic [Patch 1994512] - -2008-08-05 Miguel Sofer - - * generic/tclExecute.c: Fix for [Bug 2038069] by dgp. - * tests/execute.test: - -2008-08-04 Miguel Sofer - - * tests/nre.test: Added tests for [if], [while] and [for]. A test - for [foreach] has been added and marked as knownbug, awaiting for it - to be NR-enabled. - - * generic/tclBasic.c: Made atProcExit commands run - * generic/tclCompile.h: unconditionally, streamlined - * generic/tclExecute.c: atProcExit/tailcall processing in TEBC. - * generic/tclProc.c: - * tests/unsupported.test: + * generic/tclVar.c (TclLookupSimpleVar): Retrieve the number of + locals in the localCache from the CallFrame and not from the Proc + which may have been mangled by a (broken?) recompile. Backport from + the HEAD. 2008-08-04 Don Porter * generic/tclExecute.c: Stopped faulty double-logging of errors to * tests/execute.test: stack trace when a compile epoch bump triggers fallback to direct evaluation of commands in a compiled script. [Bug 2037338] -2008-08-03 Miguel Sofer - - * generic/tclBasic.c: New unsupported command atProcExit that - * generic/tclCompile.h: shares the implementation with tailcall. - * generic/tclExecute.c: Fixed a segfault in tailcalls. Tests added. - * generic/tclInt.h: - * generic/tclInterp.c: - * generic/tclNamesp.c: - * tests/unsupported.test: - -2008-08-02 Miguel Sofer - - * tests/NRE.test (removed): Migrated tests to standard locations, - * tests/nre.test (new): separating core functionality from the - * tests/unsupported.test (new): experimental commands. - -2008-08-01 Jeff Hobbs - - * doc/Exit.3: Do not call Tcl_Finalize implicitly - * generic/tclEvent.c: on DLL_PROCESS_DETACH as it may lead - * win/tclWin32Dll.c (DllMain): to issues and the user should be - explicitly calling Tcl_Finalize before unloading regardless. Clarify - the docs to note the explicit need in embedded use. - -2008-08-01 Don Porter - - * generic/tclBasic.c: Revised timing of the CmdFrame stack - * tests/info.test: management in TclEvalEx so that the CmdFrame - will still be on the stack at the time Tcl_LogCommandInfo is called to - append another level of -errorinfo information. Sets the stage to add - file and line data to the stack trace. Added test to check that [info - frame] functioning remains unchanged by the revision. - -2008-07-31 Miguel Sofer - - * tests/NRE.test: Replaced all deep-recursing tests by shallower - tests that actually measure the C-stack depth. This makes them - bearable again (even under memdebug) and avoid crashing on failure. - - * generic/tclBasic.c: NR-enabling [catch], [if] and [for] and - * generic/tclCmdAH.c: [while] (the script, not the tests) - * generic/tclCmdIL.c: - * generic/tclCmdMZ.c: - * generic/tclInt.h: - * tests/NRE.test: - - * generic/tclBasic.c: Moved the few remaining defs from tclNRE.h to - * generic/tclDictObj.c: tclInt.h, eliminated inclusion of tclNRE.h - * generic/tclExecute.c: everywhere. - * generic/tclInt.h: - * generic/tclInterp.c: - * generic/tclNRE.h (removed): - * generic/tclNamesp.c: - * generic/tclOOBasic.c: - * generic/tclOOInt.h: - * generic/tclProc.c: - * generic/tclTest.c: - * unix/Makefile.in: - -2008-07-30 Miguel Sofer - - * generic/tclBasic.c: Improved tailcalls. - * generic/tclCompile.h: - * generic/tclExecute.c: - * generic/tclTest.c: - * tests/NRE.test: - - * generic/tclBasic.c (TclNREvalObjEx): New comments and code reorg - to clarify what is happening. - - * generic/tclBasic.c: Guard against the value of iPtr->evalFlags - changing between the times where TEOV and TEOV_exception run. Thanks - dgp for catching this. +2008-07-30 Don Porter + + * generic/tclBasic.c: Corrected the timing of when the flag + TCL_ALLOW_EXCEPTIONS is tested. 2008-07-29 Miguel Sofer - * tests/NRE.test: New tests that went MIA in the NRE revamping - - * generic/tclBasic.c: Clean up - * generic/tclNRE.h: - * generic/tclExecute.c: - - * generic/tclBasic.c: Made use of the thread's alloc cache stored in - * generic/tclInt.h: the ekeko at interp creation to avoid hitting - * generic/tclNRE.h: the TSD each time an NRE callback is pushed or - * generic/tclThreadAlloc.c: pulled; the approach is suitably general - to extend to every other obj allocation where an interp is know; this - is left for some other time, requires a lot of grunt work. - - * generic/tclExecute.c: Fix [Bug 2030670] that cause TclStackRealloc - to panic on rare corner cases. Thx ajpasadyn for diagnose and patch. - - * generic/tcl.decls: Completely revamped NRE implementation, with - * generic/tclBasic.c: (almost) unchanged API. - * generic/tclCompile.h: - * generic/tclExecute.c: TEBC will require a bit of a facelift, but - * generic/tclInt.decls: TEOV at least looks great now. There are new - * generic/tclInt.h: tests (incomplete!) to verify that execution - * generic/tclInterp.c: is indeed in the same TEBC instance, at the - * generic/tclNRE.h: same level in all stacks involved. Tailcalls - * generic/tclNamesp.c: are still a bit leaky, still deserving to be - * generic/tclOOBasic.c: in tcl::unsupported. - * generic/tclOOMethod.c: - * generic/tclProc.c: Uninit'd var warnings in TEBC with -O2, no - * generic/tclTest.c: warnings otherwise. - -2008-07-28 Jan Nijtmans - - * doc/FileSystem.3: CONSTified many functions using - * generic/tcl.decls: Tcl_FileSystem which all are supposed - * generic/tclDecls.h: to be a constant, but this was not - * generic/tclFileSystem.h: reflected in the API: Tcl_FSData, - * generic/tclIOUtil.c: Tcl_FSGetInternalRep, Tcl_FSRegister, - * generic/tclPathObj.c: Tcl_FSNewNativePath, Tcl_FSUnregister, - * generic/tclTest.c: Tcl_FSGetFileSystemForPath ... - This change complies with TIP #27. - ***POTENTIAL INCOMPATIBILITY*** + * generic/tclExecute.c: fix [Bug 2030670] that cause + TclStackRealloc to panic on rare corner cases. Thx ajpasadyn for + diagnose and patch. 2008-07-28 Andreas Kupries * generic/tclBasic.c: Added missing ref count when creating an empty string as path (TclEvalEx). In 8.4 the missing code caused panics in the testsuite. It doesn't in 8.5. I am guessing that the code path with the missing the incr-refcount is not invoked any longer. Because the bug in itself is certainly the same. -2008-07-27 Donal K. Fellows - - * generic/tclOOMethod.c (PushMethodCallFrame): Remove hack that should - have gone when this code was merged into Tcl. - -2008-07-27 Jan Nijtmans - - * doc/Object.3: CONSTified 3 functions using Tcl_ObjType - * doc/ObjectType.3: which all are supposed to be a constant, but - * generic/tcl.decls: this was not reflected in the API: - * generic/tcl.h: Tcl_RegisterObjType, Tcl_ConvertToType, - * generic/tclDecls.h: Tcl_GetObjType - * generic/tclObj.c: Introduced a CONST86_RETURN, so extensions - * generic/tclCompCmds.c: which use Tcl_ObjType directly can be - * generic/tclOOMethod.c: modified to compile against both Tcl 8.5 and - * generic/tclTestobj.c: Tcl 8.6. tclDecls.h regenerated - This change complies with TIP #27. - ***POTENTIAL INCOMPATIBILITY*** - -2008-07-25 Andreas Kupries - - * test/info.test: More work on singleTestInterp usability. [1605269] - - * tests/info.test: Tests 38.* added, exactly testing the tracking of - location for uplevel scripts. Resolved merge conflict on info-37.0, - switched !singleTestInterp constraint to glob matching instead. Ditto - info-22.8, removed constraint, more glob matching, and reduced the - depth of the stack we check. More is coming, right now I want to - commit the bug fixes. - - * tests/oo.test: Updated oo-22.1 for expanded location tracking. - - * generic/tclCompile.c (TclInitCompileEnv): Reorganized the - initialization of the #280 location information to match the flow in - TclEvalObjEx to get more absolute contexts. - - * generic/tclBasic.c (TclEvalObjEx): Added missing cleanup of extended - location information. - 2008-07-25 Daniel Steffen * tests/info.test (info-37.0): Add !singleTestInterp constraint; (info-22.8, info-23.0): switch to glob matching to avoid sensitivity to tcltest.tcl line number changes, remove knownBug constraint, fix expected result. [Bug 1605269] -2008-07-24 Jan Nijtmans - - * doc/Notifier.3: CONSTified 4 functions in the Notifier which - * doc/Thread.3: all have a Tcl_Time* in it which is supposed - * generic/tcl.decls: to be a constant, but this was not reflected - * generic/tcl.h: reflected in the API: - * generic/tclDecls.h: Tcl_SetTimer, Tcl_WaitForEvent, - * generic/tclNotify.c: Tcl_ConditionWait, Tcl_SetMaxBlockTime - * macosx/tclMacOSXNotify.c: - * generic/tclThread.c: Introduced a CONST86, so extensions which have - * unix/tclUnixNotfy.c: have their own Notifier (are there any?) can - * unix/tclUnixThrd.c: can be modified to compile against both Tcl - * win/tclWinNotify.c: Tcl 8.5 and Tcl 8.6 - * win/tclWinThrd.c: Regenerated tclDecls.h with "make stubs". - This change complies with TIP #27 - ***POTENTIAL INCOMPATIBILITY*** - -2008-07-23 Alexandre Ferrieux - - * tests/lrange.test: Added relative speed test to check for lrange - in-place optimization committed 2008-06-30. - * tests/binary.test: Added relative speed test to check for pure byte - array CONCAT1 optimization committed 2008-06-30. +2008-07-25 Andreas Kupries + + * tests/info.test: Tests 38.* added, exactly testing the tracking of + location for uplevel scripts. + + * generic/tclCompile.c (TclInitCompileEnv): Reorganized the + initialization of the #280 location information to match the flow in + TclEvalObjEx to get more absolute contexts. + + * generic/tclBasic.c (TclEvalObjEx): Moved the pure-list optimization + out of the eval-direct code path to be done always, i.e. even when a + compile is requested. This way we do not loose the association between + #280 location information and the list elements, if any. 2008-07-23 Andreas Kupries * tests/info.test: Reordered the tests to have monotonously increasing numbers. @@ -2038,96 +462,44 @@ eval'ing a pure list. Updated the users of the line information to special case this based on the frame type (i.e. TCL_LOCATION_EVAL_LIST). Added a testcase demonstrating the new behaviour. -2008-07-23 Miguel Sofer - - * generic/tclBasic.c (GetCommandSource): Added comment with - explanation and warning for waintainers. - 2008-07-22 Andreas Kupries - * generic/tclCompile.c: Made the new TclEnterCmdWordIndex static, and - * generic/tclCompile.h: ansified. + * generic/tclBasic.c: Added missing function comments. - * generic/tclBasic.c: Ansified the new functions. Added missing - function comments. + * generic/tclCompile.c: Made the new TclEnterCmdWordIndex + * generic/tclCompile.h: static, and ansified. * generic/tclBasic.c: Reworked the handling of bytecode literals for * generic/tclCompile.c: #280 to fix the abysmal performance for deep * generic/tclCompile.h: recursion, replaced the linear search through * generic/tclExecute.c: the whole stack with another hashtable and * generic/tclInt.h: simplified the data structure used by the compiler by using an array instead of a hashtable. Incidentially this also fixes the memory leak reported via [Bug 2024937]. -2008-07-22 Miguel Sofer +2008-07-21 Don Porter - * generic/tclBasic.c: Added numLevels field to CommandFrame, let - * generic/tclExecute.c: GetCommandSource use it. This solves [Bug - * generic/tclInt.h: 2017146]. Thx dgp for the analysis. + * tests/encoding.test: Make failing tests pass again. [Bug 1972867] -2008-07-21 Andreas Kupries +2008-07-21 Andreas Kupries * generic/tclBasic.c: Extended the existing TIP #280 system (info - * generic/tclCmdAH.c: frame), added the ability to track the absolute - * generic/tclCompCmds.c: location of literal procedure arguments, and - * generic/tclCompile.c: making this information available to uplevel - * generic/tclCompile.h: eval, and siblings. This allows proper - * generic/tclInterp.c: tracking of absolute location through custom - * generic/tclInt.h: (Tcl-coded) control structures based on uplevel, - * generic/tclNamesp.c: etc. + * generic/tclCmdAH.c: frame), added the ability to track the + * generic/tclCompCmds.c: absolute location of literal procedure + * generic/tclCompile.c: arguments, and making this information + * generic/tclCompile.h: available to uplevel, eval, and + * generic/tclInterp.c: siblings. This allows proper tracking of + * generic/tclInt.h: absolute location through custom (Tcl-coded) + * generic/tclNamesp.c: control structures based on uplevel, etc. * generic/tclProc.c: - * tests/info.test: - -2008-07-21 Jan Nijtmans - - * generic/*.c: Fix [2021443] inconsistant "wrong # args" messages - * win/tclWinReg.c - * win/tclWinTest.c - * tests/*.test - -2008-07-21 Alexandre Ferrieux - - TIP #304 IMPLEMENTATION - - * generic/tcl.decls: Public API - * generic/tclIOCmds.c: Generic part - * unix/tclUnixPipe.c: OS part - * win/tclWinPipe.c: OS part - * tests/chan.test: [chan pipe] tests - * tests/ioCmd.test: Modernized checks - * tests/ioTrans.test: 2008-07-21 Pat Thoyts - * generic/tclFCmd.c: Inodes on windows are unreliable. [Bug 2015723] - * tests/winFCmd.test: test rename with inode collision - -2008-07-21 Miguel Sofer - - * generic/tcl.decls: Changed the implementation of - * generic/tclBasic.c: [namespace import]; removed - * generic/tclDecls.h: Tcl_NRObjProc, replaced with - * generic/tclExecute.c: Tcl_NRCmdSwap (proposed public - * generic/tclInt.h: NRE API). This should fix - * generic/tclNRE.h: [Bug 582506]. - * generic/tclNamesp.c: - * generic/tclStubInit.c: - - * generic/tclBasic.c: NRE: enabled calling NR commands - * generic/tclExecute.c: from the callbacks. Completely - * generic/tclInt.h: redone tailcall implementation - * generic/tclNRE.h: using the new feature. [Bug 2021489] - * generic/tclProc.c: - * tests/NRE.test: - -2008-07-20 Kevin B. Kenny - - * tests/fileName.test: Repaired the failing test fileName-15.7 from - dkf's commit earlier today. + * generic/tclFCmd.c: Inodes on windows are unreliable [Bug 2015723] 2008-07-20 Donal K. Fellows * generic/tclDictObj.c (SetDictFromAny): Make the list->dict transformation a bit more efficient; modern dicts are ordered and so @@ -2134,217 +506,17 @@ we can round-trip through lists without needing the string rep at all. * generic/tclListObj.c (SetListFromAny): Make the dict->list transformation not lossy of internal representations and hence more efficient. [Bug 2008248] (ajpasadyn) but using a more efficient patch. - * tests/fileName.test: Revise to reduce the obscurity of tests. In - particular, all tests should now produce informative messages on - failure and the quantity of [catch]-based obscurity is now greatly - reduced; non-erroring is now checked for directly. - -2008-07-19 Donal K. Fellows - - * tests/env.test: Add LANG to the list of variables that are not - touched by the environment variable tests, so that subprocesses can - get their system encoding correct. - - * tests/exec.test, tests/env.test: Rewrite so that non-ASCII - characters are not used in the final comparison. Part of fixing [Bug - 1513659]. - -2008-07-18 Miguel Sofer - - * generic/tclBasic.c: Optimization: replace calls to - * generic/tclDictObj.c: Tcl_NRAddCallback with the macro - * generic/tclExecute.c: TclNRAddCallback. - * generic/tclInterp.c: - * generic/tclNRE.h: - * generic/tclNamesp.c: - * generic/tclOO.c: - * generic/tclOOBasic.c: - * generic/tclOOCall.c: - * generic/tclOOInt.h: - * generic/tclOOMethod.c: - * generic/tclProc.c: - -2008-07-18 Donal K. Fellows - - * generic/tclOO.c (TclNRNewObjectInstance, FinalizeAlloc): - * generic/tclOOBasic.c (TclOO_Class_Create, TclOO_Class_CreateNs) - (TclOO_Class_New, FinalizeConstruction, AddConstructionFinalizer): - NRE-enablement of the class construction methods. - -2008-07-18 Miguel Sofer - - * tests/NRE.test: Added basic tests for deep TclOO calls - - * generic/tcl.decls: Change the public api prefix from - * generic/tcl.h: TclNR_foo to Tcl_NRfoo - * generic/tclBasic.c: - * generic/tclDecls.h: - * generic/tclDictObj.c: - * generic/tclExecute.c: - * generic/tclInterp.c: - * generic/tclNRE.h: - * generic/tclNamesp.c: - * generic/tclOO.c: - * generic/tclOOBasic.c: - * generic/tclOOCall.c: - * generic/tclOOMethod.c: - * generic/tclProc.c: - * generic/tclStubInit.c: - -2008-07-18 Donal K. Fellows - - * generic/tclOOBasic.c (TclOO_Object_Eval, FinalizeEval): NRE-enable - the oo::object.eval method. - -2008-07-18 Miguel Sofer - - * generic/tclDictObj.c (DictWithCmd, DictUpdateCmd): Fix refcounting - bugs that caused crashes [Bug 2017857]. - - * generic/tclBasic.c (TclNREvalObjEx): Streamline the management of - the command frame (opt). - -2008-07-17 Donal K. Fellows - - * generic/tclDictObj.c (DictWithCmd, FinalizeDictWith): Split the - implementation of [dict with] so that it works with NRE. - (DictUpdateCmd, FinalizeDictUpdate): Similarly for the non-compiled - version of [dict update]. - -2008-07-16 George Peter Staplin - - * win/tclWinThrd.c: Test for TLS_OUT_OF_INDEXES to make certain that - thread key creation is successful. - -2008-07-16 Donal K. Fellows - - * generic/tclOO.c, generic/tclOOInt.h, generic/tclOOBasic.c: - * generic/tclOOCall.c, generic/tclOOMethod.c: NRE-enable the TclOO - implementation in Tcl. No change to public APIs, except that method - implementations can now be NRE-aware if they choose (which normal - methods and forwards are). On the other hand, callers of - TclOOInvokeObject (which is only in the internal stub table) will need - to deal with the fact that it's only safe to call inside an NRE-aware - context. - ***POTENTIAL INCOMPATIBILITY*** - -2008-07-15 Miguel Sofer - - * tests/NRE.test: Better constraint for testing the existence of - * tests/stack.test: teststacklimit, to insure that the test suite - runs under tclsh. - - * generic/tclParse.c: Fixing incomplete reversion of "fix" for [Bug - 2017583], missing TclResetCancellation call. - 2008-07-15 Donal K. Fellows - * generic/tclBasic.c (Tcl_CancelEval): Fix blunder. [Bug 2018603] - * doc/DictObj.3: Fix error in example. [Bug 2016740] - * generic/tclNamesp.c (EnsembleUnknownCallback): Factor out some of - the more complex parts of the ensemble code to make it easier to - understand and hence to permit tighter compilation of code on the - critical path. - -2008-07-14 Miguel Sofer - - * generic/tclParse.c: Reverting the "fix" for [Bug 2017583], numLevel - * tests/parse.test: management and TclInterpReady check seems to be - necessary after all. - -2008-07-14 Donal K. Fellows - - * generic/tclProc.c (TclNRApplyObjCmd, TclObjInterpProcCore): - * generic/tclBasic.c (TclNR_AddCallback, TclEvalObjv_NR2): - * generic/tclNRE.h (TEOV_callback): Change the callback storage type - to use an array, so guaranteeing correct inter-member spacing and - memory layout. - -2008-07-14 Miguel Sofer - - * generic/tclExecute.c: Remove unneeded TclInterpReady calls - * generic/tclParse.c: - - * generic/tclBasic.c.: Embedded Tcl_Canceled() calls into - * generic/tclExecute.c: TclInterpReady(). - * generic/tclParse.c: - - * generic/tclVar.c: Fix error message - - * generic/tclParse.c: Remove unnecessary numLevel management - * tests/parse.test: [Bug 2017583] - - * generic/tclBasic.c.: NRE left too many calls to - * generic/tclExecute.c: TclResetCancellation lying around: it - * generic/tclProc.c: only needs to be called prior to any - iPtr->numLevels++. Thanks mistachkin. - - * generic/tclBasic.c: TclResetCancellation() calls were misplaced - (merge mishap); stray //. Thanks patthoyts. - - * generic/tclInt.h: The new macros TclSmallAlloc and TclSmallFree - were badly defined under mem debugging [Bug 2017240] (thx das) - -2008-07-13 Miguel Sofer - - NRE implementation [Patch 2017110] - - * generic/tcl.decls: The NRE infrastructure - * generic/tcl.h: - * generic/tclBasic.c: - * generic/tclCmdAH.c: - * generic/tclCompile.h: - * generic/tclDecls.h: - * generic/tclExecute.c: - * generic/tclHistory.c: - * generic/tclInt.decls: - * generic/tclInt.h: - * generic/tclIntDecls.h: - * generic/tclNRE.h: - * generic/tclStubInit.c: - * unix/Makefile.in: - - * generic/tclInterp.c: NRE-enabling: procs, lambdas, uplevel, - * generic/tclNamesp.c: same-interp aliases, ensembles, imports - * generic/tclProc.c: and namespace_eval. - - * generic/tclTestProcBodyObj.c: New NRE specific tests (few, but - * tests/NRE.test: note that the thing is actually - tested by the whole testsuite. - - * tests/interp.test: Fixed numLevel counting. - * tests/parse.test: - * tests/stack.test: - - * unix/configure: Removing support for the hacky nonportable - * unix/configure.in: stack check: it is not needed anymore, Tcl - * unix/tclConfig.h.in: is very thrifty on the C stack. - * unix/tclUnixInit.c: - * unix/tclUnixTest.c: - * win/tclWin32Dll.c: - 2008-07-08 Don Porter - * generic/tclGet.c: Corrected out of date comments and removed - * generic/tclInt.decls: internal routine TclGetLong() that's no - longer used. If an extension is using this from the internal stubs - table, it can shift to the public routine Tcl_GetLongFromObj() or - can request addition of a public Tcl_GetLong(). - ***POTENTIAL INCOMPATIBILITY*** - - * generic/tclIntDecls.h: make genstubs - * generic/tclStubInit.c: - -2008-07-08 Donal K. Fellows - - * doc/CrtInterp.3: Tighten up the descriptions of behaviour to make - this page easier to read for a "Tcl 8.6" audience. + * generic/tclGet.c: Corrected out of date comments. 2008-07-07 Andreas Kupries * generic/tclCmdIL.c (InfoFrameCmd): Fixed unsafe idiom of setting the interp result found by Don Porter. @@ -2351,13 +523,15 @@ 2008-07-07 Donal K. Fellows * doc/regexp.n, doc/regsub.n: Correct examples. [Bug 1982642] -2008-07-06 Donal K. Fellows +2008-07-04 Joe English - * doc/lindex.n: Improve examples. + * generic/tclEncoding.c(UtfToUtfProc): Avoid unwanted sign extension + when converting incomplete UTF-8 sequences. See [Bug 1908443] for + details. 2008-07-03 Andreas Kupries * generic/tclIORChan.c (InvokeTclMethod): Fixed the memory leak reported in [Bug 1987821]. Thanks to Miguel for the report and Don @@ -2369,55 +543,29 @@ [tclPkgUnknown] and friends. We find out soon enough whether a file is readable when we try to [source] it, and not testing before allows us to workaround the bugs on some common filesystems where [file readable] lies to us. [Patch 1969717] -2008-07-01 Donal K. Fellows - - * generic/regc_nfa.c (duptraverse): Impose a maximum stack depth on - the single most recursive part of the RE engine. The actual maximum - may need tuning, but that needs a system with a small stack to carry - out. [Bug 1905562] - - * tests/string.test: Eliminate non-ASCII characters from the actual - test script. [Bug 2006884] - -2008-06-30 Donal K. Fellows - - * doc/ObjectType.3: Clean up typedef formatting. - -2008-06-30 Don Porter +2008-06-29 Don Porter + + *** 8.5.3 TAGGED FOR RELEASE *** + + * generic/tcl.h: Bump to 8.5.3 for release. + * library/init.tcl: + * tools/tcl.wse.in: + * unix/configure.in: + * unix/tcl.spec: + * win/configure.in: + + * unix/configure: autoconf-2.59 + * win/configure: * doc/ObjectType.3: Updated documentation of the Tcl_ObjType - struct to match expectations of Tcl 8.5. [Bug 1917650] - -2008-06-30 Alexandre Ferrieux - - * generic/tclCmdIL.c: Lrange cleanup and in-place optimization. [Patch - 1890831] - - * generic/tclExecute.c: Avoid useless String conversion for CONCAT1 of - pure byte arrays. [Patch 1953758] - -2008-06-29 Donal K. Fellows - - * doc/*.1, doc/*.3, doc/*.n: Many small updates, purging out of date - change bars and cleaning up the formatting of typedefs. Added a few - missing bits of documentation in the process. - -2008-06-29 Don Porter - - * generic/tclPathObj.c: Plug memory leak in [Bug 1999176] fix. Thanks - to Rolf Ade for detecting. - -2008-06-29 Donal K. Fellows - - * doc/interp.n: Corrected order of subcommands. [Bug 2004256] - Removed obsolete (i.e. 8.5) .VS/.VE pairs. - - * doc/object.n (EXAMPLES): Fix incorrect usage of oo::define to be - done with oo::objdefine instead. [Bug 2004480] + struct to match expectations of Tcl 8.5 [Bug 1917650]. + + * generic/tclPathObj.c: Plug memory leak in [Bug 1999176] fix. Thanks + Rolf Ade for detecting. 2008-06-28 Don Porter * generic/tclPathObj.c: Plug memory leak in [Bug 1972879] fix. Thanks to Rolf Ade for detecting and Dan Steffen for the fix. [Bug 2004654] @@ -2429,15 +577,11 @@ conditional on interpreter safeness as well. Thanks to Daniel Steffen for reminding me of that code. 2008-06-25 Don Porter - *** 8.6a1 TAGGED FOR RELEASE *** - - * changes: Updates for 8.6a1 release. - - * generic/tclOO.h: Bump to TclOO 0.5. + * changes: Update for 8.5.3 release. 2008-06-25 Andreas Kupries * library/tm.tcl: Modified the handling of Tcl Modules and of the * library/safe.tcl: Safe Base to interact nicely with each other, @@ -2444,73 +588,42 @@ * library/init.tcl: enabling requiring Tcl Modules in safe * tests/safe.test: interpreters. [Bug 1999119] 2008-06-25 Pat Thoyts - * win/rules.vc: Fix versions of dde and registry dlls - * win/makefile.vc: Fix problem building with staticpkg option + * win/rules.vc: Backported fix for dde/registry versions and + * win/makefile.vc: the staticpkg build option 2008-06-24 Don Porter * generic/tclPathObj.c: Fixed some internals management in the "path" Tcl_ObjType for the empty string value. Problem led to a crash in the command [glob -dir {} a]. [Bug 1999176] -2008-06-24 Pat Thoyts - - * doc/fileevent.n: Fix examples and comment on eof use. [Bug 1995063] - 2008-06-23 Don Porter * generic/tclPathObj.c: Fixed bug in Tcl_GetTranslatedPath() when operating on the "Special path" variant of the "path" Tcl_ObjType intrep. A full normalization was getting done, in particular, coercing relative paths to absolute, contrary to what the function of producing the "translated path" is supposed to do. [Bug 1972879] -2008-06-20 Don Porter +2008-06-19 Don Porter - * changes: Updates for 8.6a1 release. + * changes: Update for 8.5.3 release. * generic/tclInterp.c: Fixed completely boneheaded mistake that * tests/interp.test: [interp bgerror $slave] and [$slave bgerror] would always act like [interp bgerror {}]. [Bug 1999035] * tests/chanio.test: Corrected flawed tests revealed by a -debug 1 - * tests/cmdAH.test: -singleproc 1 test suite run. - * tests/event.test: - * tests/interp.test: + * tests/event.test: -singleproc 1 test suite run. * tests/io.test: - * tests/ioTrans.test: - * tests/namespace.test: - - * tests/encoding.test: Make failing tests pass again. [Bug 1972867] - -2008-06-19 Donal K. Fellows - - * generic/tclOO.c (Tcl_ObjectContextInvokeNext): Corrected 'next' (at - * tests/oo.test (oo-7.8): end of a call chain) to make it - * doc/next.n: consistent with the TIP. [Bug 1998244] - - * generic/tclOOCall.c (AddSimpleClassChainToCallContext): Make sure - * tests/oo.test (oo-14.8): that class mixins are processed in the - documented order. [Bug 1998221] 2008-06-19 Don Porter - * changes: Updates for 8.6a1 release. - - * README: Bump version number to 8.6a1 - * generic/tcl.h: - * library/init.tcl: - * tools/tcl.wse.in: - * unix/configure.in: - * unix/tcl.spec: - * win/configure.in: - - * unix/configure: autoconf-2.59 - * win/configure: + * changes: Updates for 8.5.3 release. 2008-06-17 Andreas Kupries * generic/tclClock.c (ClockConvertlocaltoutcObjCmd): Removed left over debug output. @@ -2530,282 +643,38 @@ the 'localSeconds' key. To the best of my knowledge, the bug was not observable in the [clock] command itself. 2008-06-16 Andreas Kupries - * generic/tclCmdIL.c (TclInfoFrame): Moved the code looking up the - * tests/info.test: information for key 'proc' out of the - TCL_LOCATION_BC branch to after the switch, this is common to all - frame types. Updated the testsuite to match. This was exposed by the - 2008-06-08 commit (Miguel), switching uplevel from direct eval to - compilation. [Bug 1987851] - -2008-06-16 Andreas Kupries - - * tests/ioTrans.test (iortrans-11.*): Fixed same issue as for - iortrans.tf-11.*, cleanup of temp file, making this a followup to the - entry on 2008-06-10 by myself. - -2008-06-13 David Gravereaux - - * win/rules.vc: SYMBOLS macro is now being set to zero when $(OPTS) is - not available. - * win/makefile.vc: The Stubs source files (tclStubLib.c and - tclOOStubLib.c) should not be compiled with the -GL flag. - -2008-06-13 Joe Mistachkin - - TIP #285 IMPLEMENTATION - - * doc/Eval.3: Added documentation for the Tcl_CancelEval and - Tcl_Canceled functions and the TCL_CANCEL_UNWIND flag bit. - * doc/after.n: Corrected the spelling of 'canceled' in the - documentation. - * doc/interp.n: Added documentation for [interp cancel]. - * generic/tcl.decls: Added the Tcl_CancelEval and Tcl_Canceled - functions to the stubs table. - * generic/tcl.h: Added the TCL_CANCEL_UNWIND flag bit. - * generic/tclBasic.c: The bulk of the script cancellation - functionality is defined here. Added code to initialize and manage the - script cancellation hash table in a thread-safe manner. Reset script - cancellation flags prior to increasing the nesting level (if the - nesting level is currently zero) and always cooperatively check for - script cancellation near the start of TclEvalObjvInternal and after - invoking async handlers. - * generic/tclDecls.h: Regenerated. - * generic/tclEvent.c: Call TclFinalizeEvaluation during finalization - to cleanup the script cancellation hash table. During [vwait], always - cooperatively check for script cancellation. Corrected the spelling of - 'canceled' in comments to be consistent with the documentation. - * generic/tclExecute.c: Reset script cancellation flags prior to - increasing the nesting level (if the nesting level is currently zero) - and always cooperatively check for script cancellation after invoking - async handlers. Prevent [catch] from catching script cancellation when - the TCL_CANCEL_UNWIND flag is set (similar to the manner used by TIP - 143 when a limit has been exceeded). - * generic/tclInt.decls: Added TclResetCancellation to the internal - stubs table. - * generic/tclInt.h: Added asyncCancel and asyncCancelMsg fields to the - private Interp structure. Added private interp flag value CANCELED to - help control script cancellation. - * generic/tclIntDecls.h: Regenerated. - * generic/tclInterp.c (Tcl_InterpObjCmd): Added [interp cancel] - subcommand. - * generic/tclNotify.c (Tcl_DeleteEventSource): Corrected the spelling - of 'canceled' in comments to be consistent with the documentation. - * generic/tclParse.c: Reset script cancellation flags prior to - * generic/tclProc.c: increasing the nesting level (if the nesting - level is currently zero) and cooperatively check for script - cancellation prior to evaluating commands. - * generic/tclStubInit.c: Regenerated. - * generic/tclThreadTest.c (Tcl_ThreadObjCmd): Added script - cancellation support ([testthread cancel]). - Modified [testthread id] to allow querying of the 'main' thread ID. - Corrected comments to reflect the actual command syntax. Made - [testthread wait] cooperatively check for script cancellation. Added - [testthread event] to allow for processing one pending event without - blocking. - * generic/tclTimer.c: Delay for a maximum of 500 milliseconds prior to - checking for async handlers and script cancellation. - * tests/cmdAH.test: Changed [interp c] to [interp create]. - * tests/interp.test: Added and fixed tests for [interp cancel]. - * tests/thread.test: Added tests for script cancellation via - [testthread cancel]. - * tools/man2help2.tcl: Fixed problems with WinHelp target (see - * tools/man2tcl.c: [Bug 1934200], [Bug 1934265], and [Bug 1934272]). - * win/makefile.vc: Added 'pdbs' option for Windows build rules to - * win/rules.vc: allow for non-debug builds with full symbols. - * win/tcl.hpj.in: Corrected version for WinHelp target. - * win/tclWinNotify.c: Used SleepEx and WaitForSingleObjectEx on - * win/tclWinThrd.c: Windows because they are alertable. + * generic/tclCmdIL.c (TclInfoFrame): Backport of fix made on the + * tests/info.test: head branch :: Moved the code looking up the + information for key 'proc' out of the TCL_LOCATION_BC branch to + after the switch, this is common to all frame types. Updated the + testsuite to match. This was exposed by the 2008-06-08 commit + (Miguel), switching uplevel from direct eval to compilation. Fixes + [Bug 1987851]. 2008-06-12 Daniel Steffen * unix/Makefile.in: Add complete deps on tclDTrace.h. - * generic/tclOO.c: Use TclOOStubs hooks field to retrieve - * generic/tclOODecls.h: TclOOIntStubs pointer. [Bug 1980953] - * generic/tclOOIntDecls.h: - * generic/tclOOStubInit.c: - * generic/tclOOStubLib.c: - - * generic/tclIORTrans.c: Fix signed <-> unsigned cast warnings. - * unix/Makefile.in: Clean generated tclDTrace.h file. * unix/configure.in (SunOS): Fix static DTrace-enabled build. * unix/tcl.m4 (SunOS-5.11): Fix 64bit amd64 support with gcc & Sun cc. * unix/configure: autoconf-2.59 - * macosx/Tcl.xcodeproj/project.pbxproj: Add tclIORTrans.c; updates and - cleanup for Xcode 3.1/Leopard. + * macosx/Tcl.xcodeproj/project.pbxproj: Add debug configs with gcov, + and with corefoundation disabled; updates and cleanup for Xcode 3.1 and + for Leopard. * macosx/Tcl.xcode/project.pbxproj: Sync Tcl.xcodeproj changes. * macosx/README: Document new build configs. -2008-06-10 Joe English - - * generic/tclEncoding.c(UtfToUtfProc): Avoid unwanted sign extension - when converting incomplete UTF-8 sequences. See [Bug 1908443] for - details. - -2008-06-10 Andreas Kupries - - * tests/ioTrans.test (iortrans.tf-6.1): Fixed the [Bug 1988552], - reported by Kevin. Have to close the channel before removal of the - file. Fixed same bug in test 'iortrans.tf-11.0', after fixing missing - cleanup of the file in 'iortrans.tf-11.*'. Lastly fixed the names of - the threaded tests 'iortrans-8.*' to the correct 'iortrans.tf-8.*'. - -2008-06-09 Andreas Kupries - - * generic/tclIORTrans.c (ReflectInput): Fixed a bug triggered by Pat - Thoyts . Reset the EOF flag after - draining the Tcl level into the result buffer, to make sure that the - result buffer will be drained as well by repeated calls to - ReflectInput should it contain more than one buffer-full of data. - Without that reset the higher I/O system will not call on ReflectInput - anymore due to the assumed EOF, thus losing the data which did not fit - in the buffer of the call which caused the eof and drain. - -2008-06-09 Donal K. Fellows - - * generic/tclOOCall.c (TclOOGetSortedMethodList): Plug memory leak - that occurred when all methods were hidden. [Bug 1987817] - -2008-06-08 Miguel Sofer - - * generic/tclBasic.c: Compilation of uplevel scripts, allow - * generic/tclCompCmds.c: non-body compiled scripts to access the - * generic/tclCompile.c: LVT (but not to extend it) and enable the - * generic/tclCompile.h: canonical list opt to sidestep the - * generic/tclExecute.c: compiler. [Patch 1973096] - * generic/tclProc.c: - * tests/uplevel.test: - -2008-06-06 Andreas Kupries - - TIP #230 IMPLEMENTATION - - * generic/tclIOCmd.c: Integration of transform commands into 'chan' - ensemble. - * generic/tclInt.h: Definitions of the transform commands. - * generic/tclIORTrans.c: Implementation of the reflection transforms. - * tests/chan.test: Tests updated for new sub-commands of 'chan'. - * tests/ioCmd.test: Tests updated for new sub-commands of 'chan'. - * tests/ioTrans.test: Whole new set of tests for the reflection - transform. - * unix/Makefile.in: Integration of new files into build rules. - * win/Makefile.in: Integration of new files into build rules. - * win/makefile.vc: Integration of new files into build rules. - - NOTE: The file 'tclIORTrans.c' has a lot of code in common with the - file 'tclIORChan.c', as that made it much easier to develop the - reference implementation as a separate module. Now that the - transforms have been committed the one thing left to do is to go - over both modules and see which of the common parts we can - factor out and share. - -2008-06-04 Pat Thoyts - - * generic/tclBinary.c: TIP #317 implementation - * tests/binary.test: - -2008-06-02 Kevin B. Kenny - - * generic/tclOO.c (ReleaseClassContents): Fix the one remaining - valgrind complaint about oo.test, caused by failing to protect the - Object as well as the Class corresponding to a subclass being deleted - and hence getting a freed-memory read when attempting to delete the - class command. [Bug 1981001] - -2008-06-01 Donal K. Fellows - - * generic/tclOOMethod.c (Tcl_NewMethod): Complete the fix of [Bug - 1981001], previous fix was incomplete though helpful in telling me - where to look. - -2008-06-01 Joe Mistachkin - - * win/Makefile.in: Add tclOO genstubs to Windows makefiles and remove - * win/makefile.vc: -DBUILD_tcloo because it is no longer required. - -2008-06-01 Kevin B. Kenny - - * generic/tclOODecls.h: Added the swizzling of DLLEXPORT and - * generic/tclOOIntDecls.h: DLLIMPORT needed to make EXTERN work. - - * generic/tclDictObj.c: Added missing initializers to the ensemble - map to silence a compiler warning. Thanks to - George Peter Staplin for the report. - - * generic/tclOOMethod.c: Fix a bug where the refcount of a method was - reset if the method was redefined while there - was an active invocation. [Bug 1981001] - -2008-06-01 Donal K. Fellows - - * generic/tclOO.decls, unix/Makefile.in (genstubs): Make generation of - stub tables correct. - * generic/tclOO{Decls.h,IntDecls.h,StubInit.c,StubLib.c}: Fixes to - make the generation work correctly, removing subtle differences - between output of different versions of stub generator. - -2008-06-01 Daniel Steffen - - * generic/tclOOStubLib.c: Ensure use of tcl stubs; include in - * unix/Makefile.in: stub lib; disable broken tclOO - genstubs - - * generic/tclOO.c: Make tclOO stubs tables 'static const' - * generic/tclOODecls.h: and stub table pointers MODULE_SCOPE - * generic/tclOOIntDecls.h: (change generated files manually - * generic/tclOOStubInit.c: pending genstubs support for tclOO). - * generic/tclOOStubLib.c: - - * generic/tclOO.c: Fix warnings for 'int<->ptr - * generic/tclOOCall.c: conversion' and 'signed vs unsigned - * generic/tclOOMethod.c: comparison'. - - * tests/msgcat.test: Fix for ::tcl::mac::locale with @modifier. - - * tools/tsdPerf.tcl: Use [info sharedlibextension] - - * unix/tclConfig.h.in: autoheader-2.59 - - * macosx/Tcl.xcodeproj/project.pbxproj: Add new tclOO files; add debug - * macosx/README: configs with corefoundation - disabled and with gcov; update - to Xcode 3.1. - -2008-05-31 Donal K. Fellows - - * generic/tclOO.c (InitFoundation): Correct reference counting for - strings used when creating the constructor for classes. - * generic/tclOOMethod.c (TclOODelMethodRef): Correct fencepost error - in reference counting of method implementation structures. - * tests/oo.test (oo-0.5): Added a test to detect a memory leak problem - relating to disposal of the core object system. - - TIP#257 IMPLEMENTATION - - * generic/tclBasic.c, generic/tclOOInt.h: Correct declarations. - * win/Makefile.in, win/makefile.bc, win/makefile.vc: Build support for - Win32, from Joe Mistachkin. [Patch 1980861] - - * generic/tclOO*, doc/*, tests/oo.test: Port of implementation of - TclOO to sit directly inside Tcl. Note that this is incomplete (e.g. - no build support yet for Windows). - 2008-05-26 Jeff Hobbs * tests/io.test (io-53.9): Need to close chan before removing file. -2008-05-26 Donal K. Fellows - - * win/makefile.bc: Remove deprecated winhelp target. - * win/Makefile.in, win/makefile.vc: It didn't work correctly anyway. - 2008-05-23 Andreas Kupries * win/tclWinChan.c (FileWideSeekProc): Accepted a patch by Alexandre Ferrieux to fix the [Bug 1965787]. 'tell' now works for locations > 2 GB as well instead of going @@ -2829,11 +698,11 @@ * tests/parse.test (parse-15.60): routine has no mechanism to return the "incomplete" status of "\\\n" so calling this routine anywhere that can be reached within a Tcl_ParseCommand() call is a mistake. In particular, ParseComment() must not use it. [Bug 1968882] -2008-05-20 Donal K. Fellows +2008-05-21 Donal K. Fellows * generic/tclNamesp.c (Tcl_SetNamespaceUnknownHandler): Corrected odd logic for handling installation of namespace unknown handlers which could lead too very strange things happening in the error case. @@ -2840,67 +709,16 @@ 2008-05-16 Miguel Sofer * generic/tclCompile.c: Fix crash with tcl_traceExec. Found and fixed by Alexander Pasadyn. [Bug 1964803] -2008-05-15 Pat Thoyts - - * win/makefile.vc: We should use the thread allocator for threaded - * win/rules.vc: builds. Added 'tclalloc' option to disable. - -2008-05-09 George Peter Staplin - - * tools/tsdPerf.c: A loadable Tcl extension for testing TSD - performance. - * tools/tsdPerf.tcl: A simplistic tool that uses the thread - extension and tsdPerf.so to get some performance metrics by, - simulating, simple TSD contention. - -2008-05-09 George Peter Staplin - - * generic/tcl.h: Make Tcl_ThreadDataKey a void *. - * generic/tclInt.h: Change around some function names and add some - new per-platform declarations for thread-specific data functions. - * generic/tclThread.c: Make use of of the new function names that no - longer have a Tclp prefix. - * generic/tclThreadStorage.c: Replace the core thread-specific data - (TSD) mechanism with an array offset solution that eliminates the hash - tables, and only uses one slot of native TSD. Many thanks to Kevin B. - Kenny for his help with this. - - * unix/tclUnixThrd.c: Add platform-specific TSD functions for use by - * win/tclWinThrd.c: tclThreadStorage.c. - -2008-05-09 Kevin B. Kenny - - * tests/dict.test (dict-19.2): Corrected a bug where the test was - changed to use [apply] instead of a temporary proc, but the cleanup - script still attempted to delete the temporary proc. - -2008-05-07 Donal K. Fellows +2008-05-07 Donal K. Fellows * generic/tclCompCmds.c (TclCompileDictAppendCmd): Fix silly off-by one error that caused a crash every time a compiled 'dict append' with more than one argument was used. Found by Colin McCormack. -2008-05-02 Pat Thoyts - - * generic/tclBasic.c: Converted the [binary] command into an - * generic/tclBinary.c: ensemble. - * generic/tclInt.h: - * test/binary.test: Updated the error tests for ensemble errors. - - * generic/tclFileName.c: Reverted accidental commit of TIP 316 APIs. - -2008-04-27 Donal K. Fellows - - * */*.c: A large tranche of getting rid of pre-C89-isms; if your - compiler doesn't support things like proper function declarations, - 'void' and 'const', borrow a proper one when building Tcl. (The header - files allow building things that link against Tcl with really ancient - compilers still; the requirement is just when building Tcl itself.) - 2008-04-26 Zoran Vasiljevic * generic/tclAsync.c: Tcl_AsyncDelete(): panic if attempt to locate handler token fails. Happens when some other thread attempts to delete somebody else's token. @@ -2918,62 +736,38 @@ different interpreter/thread.) * generic/tclIORChan.c: Fixed the bugs exposed by the new testcases, redone most of the cleanup and exit handling. -2008-04-21 Don Porter - - * generic/tclIOUtil.c: Removed all code delimited by - * generic/tclTest.c: USE_OBSOLETE_FS_HOOKS, completing - * tests/ioCmd.test: the deprecation path for these - * tests/ioUtil.test (removed): obsolete interfaces. (Code was active - in Tcl 8.4, present but enabled only by customized compile switch in - Tcl 8.5, and now completely gone for Tcl 8.6). Also removed all tests - relevant only to the removed interfaces. - -2008-04-19 George Peter Staplin - - * doc/Ensemble.3: Fix a typo: s/defiend/defined/ - Thanks to hat0 for spotting this. - -2008-04-16 Daniel Steffen - - * generic/tclInt.h: Make stubs tables 'static const' and - * generic/tclStubInit.c: export only module-scope pointers to - * generic/tclStubLib.c: the main stubs tables (for package - * tools/genStubs.tcl: initialization). [Patch 1938497] - * generic/tclBasic.c (Tcl_CreateInterp): - * generic/tclTomMathInterface.c (TclTommath_Init): - - * generic/tclInt.h: Revise Tcl_SetNotifier() to use a - * generic/tclNotify.c: module-scope hooks table instead of - * generic/tclStubInit.c: runtime stubs-table modification; - * macosx/tclMacOSXNotify.c: ensure all hookable notifier functions - * win/tclWinNotify.c: check for hooks; remove hook checks in - * unix/tclUnixNotfy.c: notifier API callers. [Patch 1938497] - 2008-04-15 Andreas Kupries * generic/tclIO.c (CopyData): Applied another patch by Alexandre * io.test (io-53.8a): Ferrieux , * chanio.test (chan-io-53.8a): to shift EOF handling to the async part of the command if a callback is specified, should the channel be at EOF already when fcopy is called. Testcase by myself. -2008-04-15 Daniel Steffen - - * unix/Makefile.in: Adjust tclDTrace.h dependencies for removal - of tclStubLib.o from TCL_OBJS. [Bug 1942795] - 2008-04-14 Kevin B. Kenny * unix/tclUnixTime.c (NativeGetTime): Removed obsolete use of 'struct timezone' in the call to 'gettimeofday'. [Bug 1942197] * tests/clock.test (clock-33.5, clock-33.5a, clock-33.8, clock-33.8a): Added comments to the test that it can fail on a heavily loaded system. + +2008-04-11 Don Porter + + * generic/tcl.h: Bump version number to 8.5.3b1 to distinguish + * library/init.tcl: CVS development snapshots from the 8.5.2 and + * unix/configure.in: 8.5.3 releases. + * unix/tcl.spec: + * win/configure.in: + * README + + * unix/configure: autoconf (2.59) + * win/configure: 2008-04-10 Andreas Kupries * generic/tclIOCmd.c (Tcl_FcopyObjCmd): Keeping check for negative values, changed to not be an error, but behave like the special value @@ -2984,84 +778,63 @@ * tests/io.test (io-52.5{,a,b}): Reverted last change, added * tests/chanio.test (chan-io-52.5{,a,b}): comment regarding the meaning of -1, added two more testcases for other negative values, and input wrapped to negative. -2008-04-09 Donal K. Fellows - - * tests/{fCmd,unixFCmd,winFCmd,winFile}.test: Tidying up of the test - suite to make better use of tcltest2 and be clearer about what is - being tested. - - * win/Makefile.in (html): Added target for doing convenient - documentation builds, mirroring the one from unix/Makefile. - 2008-04-09 Andreas Kupries * tests/chanio.test (chan-io-52.5): Removed '-size -1' from test, * tests/io.test (io-52.5): does not seem to have any bearing, and was - an illegal value. Test case is not affected by the value of -size, - test flag restoration and that evrything was properly copied. + an illegal value. * generic/tclIOCmd.c (Tcl_FcopyObjCmd): Added checking of -size value * tests/ioCmd.test (iocmd-15.{13,14}): to reject negative values, and values overflowing 32-bit signed. Basic patch by Alexandre Ferrieux , with modifications from me to separate overflow from true negative value. Extended testsuite. [Bug 1557855] +2008-04-08 Andreas Kupries + + * tests/io.test (io-53.8): Fixed ordering of vwait and after + cancel. cancel has to be done after the vwait completes. + 2008-04-09 Daniel Steffen - * tests/chanio.test (chan-io-53.8,53.9,53.10): Fix typo & quoting for - * tests/io.test (io-53.8,53.9,53.10): spaces in builddir path - -2008-04-08 Miguel Sofer - - * generic/tclExecute.c: Added comments to the alignment macros used in - GrowEvaluationStack() and friends. - -2008-04-08 Daniel Steffen - - * tools/genStubs.tcl: Revert erroneous 2008-04-02 change marking - *StubsPtr as EXTERN instead of extern. - - * generic/tclDecls.h: make genstubs - * generic/tclIntDecls.h: - * generic/tclIntPlatDecls.h: - * generic/tclPlatDecls.h: - * generic/tclTomMathDecls.h: + * tests/chanio.test (chan-io-53.8,53.9,53.10): fix typo & quoting for + * tests/io.test (io-53.8,53.9,53.10): spaces in builddir path + +2008-04-07 Andreas Kupries + + * tests/io.test (io-53.10): Testcase for bi-directionaly fcopy. + * tests/chanio.test: + * generic/tclIO.c: Additional changes to data structures for fcopy + * generic/tclIO.h: and channels to perform proper cleanup in case + of a channel having two background copy operations running as is + now possible. + + * tests/io.test (io-53.10): Testcase for bi-directionaly fcopy. + * generic/tclIO.c: Additional changes to data structures for fcopy + and channels to perform proper cleanup in case of a channel having + two background copy operations running as is now possible. 2008-04-07 Andreas Kupries - * tests/io.test (io-53.10): Testcase for bi-directional fcopy. - * tests/chanio.test: - * generic/tclIO.c: Additional changes to data structures for fcopy and - * generic/tclIO.h: channels to perform proper cleanup in case of a - channel having two background copy operations running as is now - possible. - - * generic/tclIO.c (BUSY_STATE, CheckChannelErrors, TclCopyChannel): - New macro, and the places using it. This change allows for - bi-directional fcopy on channels. Thanks to Alexandre Ferrieux - for the patch. [Bug 1350564] + * generic/tclIO.c (BUSY_STATE, CheckChannelErrors, + TclCopyChannel): New macro, and the places using it. This change + allows for bi-directional fcopy on channels. [Bug 1350564]. Thanks + to Alexandre Ferrieux for the + patch. 2008-04-07 Reinhard Max * generic/tclStringObj.c (Tcl_AppendFormatToObj): Fix [format {% d}] so that it behaves the same way as in 8.4 and as C's printf(). * tests/format.test: Add a test for '% d' and '%+d'. 2008-04-05 Kevin B. Kenny - * win/tclWinFile.c: (WinSymLinkDirectory): Fixed a problem that Tcl - was creating an NTFS junction point (IO_REPARSE_TAG_MOUNT_POINT) but - filling in the union member for a Vista symbolic link. We had gotten - away with this error because the union member - (SymbolicLinkReparseBuffer) was misdefined in this file and in the - 'winnt.h' in early versions of MinGW. MinGW 3.4.2 has the correct - definition of SymbolicLinkReparseBuffer, exposing the mismatch, and - making tests cmdAH-19.4.1, fCmd-28.*, and filename-11.* fail. * tests/chanio.test (chan-io-53.9): * tests/io.test (io-53.9): Made test cleanup robust against the possibility of slow process shutdown on Windows. * win/tcl.m4: Added -D_CRT_SECURE_NO_DEPRECATE and @@ -3068,10 +841,19 @@ -DCRT_NONSTDC_NO_DEPRECATE to the MSVC compilation flags so that the compilation doesn't barf on perfectly reasonable Posix system calls. * win/configure: Manually patched (don't have the right autoconf to hand). + * win/tclWinFile.c: (WinSymLinkDirectory): Fixed a problem that + Tcl was creating an NTFS junction point (IO_REPARSE_TAG_MOUNT_POINT) + but filling in the union member for a Vista symbolic link. We had + gotten away with this error because the union member + (SymbolicLinkReparseBuffer) was misdefined in this file and in the + 'winnt.h' in early versions of MinGW. MinGW 3.4.2 has the correct + definition of SymbolicLinkReparseBuffer, exposing the mismatch, + and making tests cmdAH-19.4.1, fCmd-28.*, and filename-11.* fail. + 2008-04-04 Andreas Kupries * tests/io.test (io-53.9): Added testcase for [Bug 780533], based * tests/chanio.test: on Alexandre's test script. Also fixed problem with timer in preceding test, was not canceled properly in the ok case @@ -3096,27 +878,10 @@ * generic/tclIO.c (CopyData): Applied patch [Bug 1932639] to * tests/io.test: prevent fcopy from calling -command synchronously * tests/chanio.test: the first time. Thanks to Alexandre Ferrieux for report and patch. -2008-04-02 Daniel Steffen - - * generic/tcl.decls: Remove 'export' declarations of symbols now - only in libtclstub and no longer in libtcl. - - * generic/tclStubLib.c: Make symbols in libtclstub.a MODULE_SCOPE to - * tools/genStubs.tcl: avoid exporting them from libraries that link - with -ltclstub; constify tcl*StubsPtr and stub - table hook pointers. [Bug 1819422] - - * generic/tclDecls.h: make genstubs - * generic/tclIntDecls.h: - * generic/tclIntPlatDecls.h: - * generic/tclPlatDecls.h: - * generic/tclStubInit.c: - * generic/tclTomMathDecls.h: - 2008-04-02 Andreas Kupries * generic/tclIO.c (CopyData): Applied patch for fcopy problem [Bug 780533], with many thanks to Alexandre Ferrieux for tracking it down and providing a @@ -3125,49 +890,17 @@ 2008-04-01 Andreas Kupries * generic/tclStrToD.c: Applied patch for [Bug 1839067] (fp rounding * unix/tcl.m4: setup on solaris x86, native cc), provided by - Michael Schlenker. + * unix/configure: Michael Schlenker. configure regen'd. 2008-04-01 Don Porter - * generic/tclStubLib.c: Removed needless #ifdef complexity. - * generic/tclStubLib.c (Tcl_InitStubs): Added missing error message. * generic/tclPkg.c (Tcl_PkgInitStubsCheck): - * README: Bump version number to 8.6a0 - * generic/tcl.h: - * library/init.tcl: - * macosx/Tcl-Common.xcconfig: - * macosx/Tcl.pbproj/default.pbxuser: - * macosx/Tcl.pbproj/project.pbxproj: - * tools/tcl.wse.in: - * unix/configure.in: - * unix/tcl.spec: - * win/README: - * win/configure.in: - * win/makefile.bc: - * win/tcl.m4: - - * unix/configure: autoconf-2.59 - * win/configure: - - * generic/tclBasic.c: Revised stubs-generation tool and interp - * tools/genStubs.tcl: creation so that "tclStubsPtr" is not present - * unix/Makefile.in: in libtcl.so, but is present only in - * win/Makefile.in: libtclstub.a. This tightens up the rules for - * win/makefile.bc: users of the stubs interfaces. [Bug 1819422] - * win/makefile.vc: - - * generic/tclDecls.h: make genstubs - * generic/tclIntDecls.h: - * generic/tclIntPlatDecls.h: - * generic/tclPlatDecls.h: - * generic/tclTomMathDecls.h: - 2008-03-30 Kevin Kenny * generic/tclInt.h (TclIsNaN): * unix/configure.in: Added code to the configurator to check for a standard isnan() macro and use it if one is @@ -3783,14 +1516,14 @@ * unix/configure: autoconf (2.59) * win/configure: ****************************************************************** - *** CHANGELOG ENTRIES FOR 2006-2007 IN "ChangeLog.2007" *** - *** CHANGELOG ENTRIES FOR 2005 IN "ChangeLog.2005" *** - *** CHANGELOG ENTRIES FOR 2004 IN "ChangeLog.2004" *** - *** CHANGELOG ENTRIES FOR 2003 IN "ChangeLog.2003" *** - *** CHANGELOG ENTRIES FOR 2002 IN "ChangeLog.2002" *** - *** CHANGELOG ENTRIES FOR 2001 IN "ChangeLog.2001" *** - *** CHANGELOG ENTRIES FOR 2000 IN "ChangeLog.2000" *** + *** CHANGELOG ENTRIES FOR 2006-2007 IN "ChangeLog.2007" *** + *** CHANGELOG ENTRIES FOR 2005 IN "ChangeLog.2005" *** + *** CHANGELOG ENTRIES FOR 2004 IN "ChangeLog.2004" *** + *** CHANGELOG ENTRIES FOR 2003 IN "ChangeLog.2003" *** + *** CHANGELOG ENTRIES FOR 2002 IN "ChangeLog.2002" *** + *** CHANGELOG ENTRIES FOR 2001 IN "ChangeLog.2001" *** + *** CHANGELOG ENTRIES FOR 2000 IN "ChangeLog.2000" *** *** CHANGELOG ENTRIES FOR 1999 AND EARLIER IN "ChangeLog.1999" *** ****************************************************************** Index: README.md ================================================================== --- README.md +++ README.md @@ -1,13 +1,15 @@ # README: Tcl -This is the **Tcl 9.0a2** source distribution. +This is the **Tcl 8.5.19** source distribution. You can get any source release of Tcl from [our distribution site](https://sourceforge.net/projects/tcl/files/Tcl/). -[![Build Status](https://travis-ci.org/tcltk/tcl.svg?branch=master)](https://travis-ci.org/tcltk/tcl) +[![Build Status](https://github.com/tcltk/tcl/workflows/Linux/badge.svg?branch=core-8-5-branch)](https://github.com/tcltk/tcl/actions?query=workflow%3A%22Linux%22+branch%3Acore-8-5-branch) +[![Build Status](https://github.com/tcltk/tcl/workflows/Windows/badge.svg?branch=core-8-5-branch)](https://github.com/tcltk/tcl/actions?query=workflow%3A%22Windows%22+branch%3Acore-8-5-branch) +[![Build Status](https://github.com/tcltk/tcl/workflows/macOS/badge.svg?branch=core-8-5-branch)](https://github.com/tcltk/tcl/actions?query=workflow%3A%22macOS%22+branch%3Acore-8-5-branch) ## Contents 1. [Introduction](#intro) 2. [Documentation](#doc) 3. [Compiling and installing Tcl](#build) @@ -41,22 +43,22 @@ `license.terms` for complete information. ## 2. 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/9.0.html). +[here](https://www.tcl.tk/software/tcltk/8.5.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 9.0 is [online, -here](https://www.tcl-lang.org/man/tcl9.0/). +The complete set of reference manual entries for Tcl 8.5 is [online, +here](https://www.tcl-lang.org/man/tcl8.5/). ### 2a. 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 Index: changes ================================================================== --- changes +++ changes @@ -7189,323 +7189,133 @@ --- Released 8.5.2, March 28, 2008 --- See ChangeLog for details --- 2008-03-30 (bug fix)[1783544] more robust TclIsNaN() (kenny,teterin) -2008-04-01 (interface)[1819422] tclStubsPtr no longer in libtcl (porter) - *** POTENTIAL INCOMPATIBILITY *** - 2008-04-01 (bug fix)[1839067] FP round fix for Solaris/x86 (kupries,schlenker) 2008-04-02 (bug fix)[780533,1932639] [fcopy] callbacks unreliable (ferrieux) -2008-04-02 (interface)[1819422] libtclstub symbols MODULE_SCOPE (steffen) - 2008-04-04 (bug fix) [chan postevent] crash (kupries) 2008-04-07 (bug fix) Fix broken [format {% d}] (max) 2008-04-07 (bug fix)[1350564] Bi-directional [fcopy] now supported (ferrieux) -2008-04-16 (bug fix)[1938497] Tcl_SetNotifier() fixes (steffen) - -2008-04-16 (interface)[1938497] make stubs tables 'static const' (steffen) - -2008-05-02 (new feature) [binary] is now a [namespace ensemble] (thoyts) - 2008-05-07 (bug fix) [dict append] crash (mccormack,fellows) 2008-05-21 (bug fix)[1968882] [info complete "\\\n"] => 0 (porter) 2008-05-22 (bug fix)[1968245] Tcl_LogCommandInfo() accept length=-1 (darroch) 2008-05-23 (bug fix)[1965787] 32-bit overflow in [tell] result (ferrieux) -2008-05-31 (new feature)[TIP 257] [oo::*] commands from TclOO (fellows) - -2008-06-04 (new feature)[TIP 317] [binary encode]; [binary decode] (thoyts) - -2008-06-06 (new feature)[TIP 230] [chan push]; [chan pop] (kupries) - -2008-06-08 (enhancement)[1973096] bytecompiled [uplevel] scripts (sofer) - 2008-06-12 (platform support) Solaris static build with DTrace (steffen) 2008-06-12 (platform support) Solaris/amd64 gcc 64bit support (steffen) -2008-06-13 (new feature)[TIP 285] [interp cancel]; Tcl_CancelEval() (mistachkin) - 2008-06-20 (bug fix)[1999035] make [interp bgerror $i] act in $i (porter) 2008-06-23 (bug fix)[1972879] bad path intrep caching (porter) 2008-06-24 (bug fix)[1999176] crash in [glob -dir {} a] (porter) 2008-06-25 (bug fix)[1999119] Support TM packages in Safe Base (kupries) ---- Released 8.6a1, June 25, 2008 --- See ChangeLog for details --- - -2008-06-29 (bug fix)[2004480] plug memory leaks (ade,porter,steffen) - -2008-07-01 (enhancement)[1905562] embed recursion limit in RE engine (fellows) +--- Released 8.5.3, June 30, 2008 --- See ChangeLog for details --- 2008-07-03 (bug fix)[1969717] fix package finding on Samba shares (jos) 2008-07-03 (bug fix)[1987821] mem leak in [seek] on reflected chan (kupries) -2008-07-13 (enhancement)[2017110] new Non-Recursive Evaluation implementation -enables deep Tcl evaluation stacks without deep C stacks. (sofer) - 2008-07-20 (enhancement)[2008248] dict->list preserve item intreps (pasadyn) -2008-07-21 (bug fix)[582506] imported cmds now fire execution traces (sofer) - 2008-07-21 (bug fix)[2015723] [file] bad use of inodes on Windows (thoyts) -2008-07-21 (new feature)[TIP 304] [chan pipe] (ferrieux) - -2008-07-21 (bug fix)[2021443] more consistent "wrong # args" msgs (nijtmans) - 2008-07-21 (enhancement) [info frame] returns file data in more cases (kupries) 2008-07-29 (bug fix)[2030670] fix rare panic in TclStackFree (pasadyn,sofer) -2008-08-01 Tcl_Finalize() no longer called implicitly on DLL_PROCESS_DETACH. - -2008-08-05 (enhancement)[1994512] async connect logic simplified (jenglish) - -2008-08-06 (bug fix)[2040295] stopped supplying a workaround for bugs -in Itcl's use of [namespace code]. Itcl now supplies its own workaround. - *** POTENTIAL INCOMPATIBILITY for older Itcl releases *** - -2008-08-06 (bug fix)[2039178] repaired guard against dispatching oo methods -in a deleted interp. (porter) - 2008-08-08 tzdata updated to Olson's tzdata2008e (kenny) 2008-08-11 (bug fix)[2046846] 64bit support for http zlib crc (thoyts) => http 2.7.1 2008-08-11 (enhancement) automatic [package provide] for TMs (kupries) -2008-08-17 (bug fix)[2055782] crash involving Tcl_ConcatObj (sofer) - -2008-08-21 (new feature) CONST-ified Tcl routines passing (Tcl_ObjType *), -(Tcl_Filesystem *), or (Tcl_Timer *) arguments (nijtmans,porter) - *** POTENTIAL INCOMPATIBILITY *** - -2008-08-21 (bug fix)[2065115] Restored ***= regexp functioning (hobbs,porter) - ---- Released 8.6a2, August 25, 2008 --- See ChangeLog for details --- - -2008-08-29 (bug fix)[2082299] Install TclOO header files (fellows) - -2008-09-01 oo methods called during interp deletion no longer skipped if -they do not need the dying interp (fellows) - -2008-09-02 (support) Dropped support for pre-ANSI compilers. (porter) - -2008-09-04 (bug fix)[2093947] var unset trace in coroutine (fellows,sofer) +--- Released 8.5.4, August 15, 2008 --- See ChangeLog for details --- + +2008-08-14 (bug fix)[2055782] fix crash in [namespace inscope] (sofer) + +2008-08-21 (bug fix)[2065115] correct handling of ***= RE's (hobbs,porter) 2008-09-10 (enhancement) efficient list->dict conversion (elby,fellows) -2008-09-10 (bug fix)[2102930] faulty numLevels count (madden,sofer) - -2008-09-16 (bug fix)[2114165] eval failure following cancel (sofer) - 2008-09-17 (bug fix)[2116053] export [min] and [max] from tcl::mathfunc (sofer) -2008-09-22 (new feature)[TIP 320] oo common variable declaration (fellows) - -2008-09-24 (new feature)[TIP 316] portable access to Tcl_StatBuf (fellows) - -2008-09-24 (new feature)[TIP 323] [file delete], [file mkdir] zero pathNames (porter) - -2008-09-25 (new feature)[TIP 315] new var: tcl_platform(pathSeparator) (vu,fellows) - -2008-09-25 (new feature)[TIP 323] [global], [variable] zero varNames (porter) - -2008-09-26 (new feature)[TIP 323] [lassign], [namespace upvar], [my variable] zero varNames (porter) - -2008-09-26 (new feature)[TIP 323] [tcl::tm::path add|remove] zero pathNames (porter) - -2008-09-26 (new feature)[TIP 323] [lrepeat] zero elements; zero repeats (porter) - 2008-09-27 (bug fix)[2130992] prevent overflow crash in [lrepeat] (fellows) -2008-09-28 (new feature)[TIP 314] ensemble parameters before subcommand (hellström,fellows) - -2008-09-29 (new feature)[TIP 318] revised defaults for [string trim] (poser) - *** POTENTIAL INCOMPATIBILITY *** - -2008-09-29 (new feature)[TIP 313] [lsearch -bisect] (spjuth) - -2008-09-29 (new feature)[TIP 326] [lsort -stride] (elby) - -2008-09-29 (new feature)[TIP 323] [linsert] zero elements (porter) - -2008-09-29 (new feature)[TIP 323] [glob] zero patterns (porter) - -2008-10-02 (new feature)[TIP 330] interp->result access disabled (kenny) - *** POTENTIAL INCOMPATIBILITY *** - -2008-10-03 (new feature)[TIP 265] Tcl_ParseArgv() (bromley) - -2008-10-03 (new feature)[TIP 195] [tcl::prefix] (spjuth) - -2008-10-04 (new feature) CONST-ified Tcl routines Tcl_GetIndexFromObj, -Tcl_RegisterConfig, Tcl_InitCustomHashTable, and routines passing -(Tcl_ChannelType *). (nijtmans) - *** POTENTIAL INCOMPATIBILITY *** - -2008-10-04 (bug fix)[2059262] unload only libraries marked unloadable (nijtmans) - *** POTENTIAL INCOMPATIBILITY *** - -2008-10-05 (new feature)[TIP 331] [lset listVar end+1 $value] (kenny) - 2008-10-05 (bug fix)[2143288] correct bad isqrt() results (boffey,kenny) -2008-10-05 (new feature) CONST-ified return value of the -Tcl_FSFileAttrStringsProc prototype. (nijtmans) - *** POTENTIAL INCOMPATIBILITY for Tcl_Filesystems *** - -2008-10-07 (new feature)[TIP 327] [tailcall] (sofer) - -2008-10-07 (new feature)[TIP 328] [coroutine],[yield],[info coroutine] (sofer) - 2008-10-08 (bug fix)[2151707] fix stack trace from variable trace (porter) -2008-10-10 (bug fix)[2155658] crash in oo method export (fellows) - ---- Released 8.6a3, October 10, 2008 --- See ChangeLog for details --- - -2008-10-13 (bug fix) Fix ability to join threads on 64-bit Windows (thoyts) - -2008-10-23 (bug fix)[2186888] Direct-eval [for] handling of [continue] was -broken by NRE reform (sofer,porter) +--- Released 8.5.5, October 15, 2008 --- See ChangeLog for details --- 2008-10-24 (bug fix) fix failure to read SHOUTcast streams (thoyts) => http 2.7.2 -2008-10-27 (enhancement) system encoding at startup is now "iso8859-1", and -no longer "identity". Use of identity encoding minimized (porter) - *** POTENTIAL INCOMPATIBILITY *** - -2008-10-31 (bug fix)[2200824] revised [oo::define] to include caller -context when resolving names. (nassau,fellows) - 2008-11-10 (bug fix)[2255235] [platform::shell::LOCATE] update (ring,kupries) => platform::shell 1.1.4 2008-11-13 (bug fix)[2269431] VFS [load] -> tempfile litter (ficicchia,nijtmans) -2008-11-26 (bug fix)[2114900] updated tclIndex file (cassoff,kenny) - -2008-11-27 (bug fix)[2251175] [{*}{\{}] errors (hellström,ferrieux,porter) - -2008-11-29 (new feature)[TIP 210] [file tempfile] (techentin,fellows) - 2008-11-30 (bug fix)[2362156] [clock]: colon in format string (mizuno,kenny) + +2008-12-01 (bug fix)[2251175] [{*}{\{}] errors (hellström,ferrieux,porter) 2008-12-02 (bug fix)[2270477] hang in channel finalization (ferrieux,kupries) -2008-12-02 (new feature)[TIP 336] Tcl_*ErrorLine() routines. Direct access -to the errorLine field of the interp struct denied by default. (porter) - *** POTENTIAL INCOMPATIBILITY *** - *** Define USE_INTERP_ERRORLINE to restore access for legacy code *** - 2008-12-04 (bug fix)[2385549] [file normalize] failed on some paths (porter) -2008-12-05 (new feature)[TIP 307] Tcl_TransferResult() (leunissen,fellows) - -2008-12-05 (new feature)[TIP 335] Tcl_InterpActive() (mistachkin,fellows) - -2008-12-09 (new feature)[TIP 337] Tcl_BackgroundException() (porter) - -2008-12-10 (new feature)[TIP 341] >1 [dict filter] patterns (hellström,fellows) - -2008-12-10 (new feature)[TIP 343] [format %b $n] [scan $s %b] (ferrieux) - 2008-12-10 tzdata updated to Olson's tzdata2008i (kenny) -2008-12-11 (new feature)[TIP 234] [zlib] and Tcl_Zlib*() (sheffers,fellows) - 2008-12-11 (bug fix)[2407783] spoil ChannelState when channel name passes among multiple interps (kupries) -2008-12-12 (new feature)[TIP 322] Tcl_NR*() routines to enabled non-recursive -evaluation in extensions (sofer,kenny) - -2008-12-09 (new feature)[TIP 338] Tcl_*StartupScript() (porter) - *** POTENTIAL INCOMPATIBILITY for callers of Tcl*Startup* routines *** - -2008-12-16 (new feature)[TIP 329] [try] [throw] (davel,fellows) - -2008-12-17 (new feature)[TIP 308] package tdbc 1.0b1 (kenny) - -2008-12-18 (new feature)[TIP 332] [close $chan read|write] (ferrieux) - -2008-12-18 (bug fix)[2444274] panic in long commands from {*} (goth,porter) - ---- Released 8.6b1, December 19, 2008 --- See ChangeLog for details --- - -2008-12-27 [TIP 234] Tcl_Zlib* interface revisions (fellows) - *** INCOMPATIBILITY with interface of 8.6b1 *** - -2009-01-02 (platform support)[878333] IRIX compat for mkstemp() (fellows) +2008-12-21 (bug fix) Fix ability to join threads on 64-bit Windows (thoyts) + +2008-12-21 (bug fix)[2114900] updated tclIndex file (cassoff,kenny) + +--- Released 8.5.6, December 21, 2008 --- See ChangeLog for details --- 2009-01-03 (bug fix)[2481670] [clock add] error message (talvo) -2009-01-05 (bug fix)[2412068] NR-enable [source] (fellows) - -2009-01-06 (bug fix)[2489836] crash unknown method dispatch (nadkarni,fellows) - -2009-01-06 (bug fix)[2481109] fix context of instance name check (fellows) - -2009-01-08 (enhancement) more -errorcode values (fellows) - 2009-01-19 (new feature) CONFIG_INSTALL_DIR - where tclConfig.sh goes (cassoff) 2009-01-19 (platform support) better tools for BSD ports (cassoff) 2009-01-21 (bug fix)[2458202] exit crash with [chan create]d channel (kupries) -2009-01-26 (bug fix)[2446662] uniformly declare EOF on RST on sockets (ferrieux) - -2009-01-26 (bug fix)[1028264] delay WSACleanup() from under our feet (ferrieux) - 2009-01-29 (bug fix)[2519474] Tcl_FindCommand() bug exposed by oo (fellows) -2009-01-29 (bug fix)[2537939] Fix Tcl_OOInitStubs() for no-stubs build (fellows) - 2009-02-04 (bug fix)[2561746] [string repeat] overflow crash (porter) -2009-02-05 (enhancement) optimize string operations on bytearrays (fellows) - -2009-02-12 (bug fix) enable simpler [oo::define] extension (ferri,fellows) - -2009-02-15 (bug fix)[2603158] Tcl_AppendObjToObj: append to self crash (porter) - 2009-02-17 (platform support) MSVC and _WIN64 (hobbs) 2009-02-20 (bug fix)[2571597] [file pathtype /a] wrong result (nadkarni,porter) -2009-03-03 (bug fix)[2662434] [zlib crc32] result now unsigned (gavilan,fellows) - 2009-03-15 (platform support) translate SIGINFO where defined (BSD) (teterin) -2009-03-15 (bug fix)[2687952] TSD struct memleak (mistachkin) - 2009-03-18 (bug fix)[2688184] memleak in [file normalize] (mistachkin) 2009-03-20 (bug fix)[2597185] crash in Tcl_AppendStringToObj (porter) -2009-03-20 (bug fix)[2561794,2669109,2494093,2553906] string overflow (porter) - -2009-03-22 (bug fix)[2502037] NR-enable [namespace unknown] (sofer) - 2009-03-27 (bug fix)[2710920] [file dirname|tail /foo/] errors (epler,porter) + +2009-03-30 (bug fix)[2603158] Tcl_AppendObjToObj: append to self crash (porter) + +2009-04-07 (bug fix)[2561794,2669109,2494093,2553906] string overflow (porter) 2009-04-08 (bug fix)[2570363] unsafe [eval]s in tcltest (bron,porter) => tcltest 2.3.1 2009-04-08 (platform support) more Darwin kernel patterns (steffen) @@ -7516,73 +7326,41 @@ 2009-04-10 (new feature) Darwin: embeddable CoreFoundation notifier (steffen) 2009-04-10 (bug fix)[1961211] Darwin [load] back-compatibility (steffen) -2009-04-09 (new feature) http chunked+gzip modes (thoyts) -=> http 2.8.0 - -2009-04-11 (enhancement) clarified cmd name resolution in oo forwards (fellows) - -20009-04-19 (bug fix)[2715421] http: excess bytes after POST (thoyts) -=> http 2.8.1 - -2009-04-30 (bug fix)[2486550] coroutine in [interp invokehidden] (sofer) +2009-04-14 tzdata updated to Olson's tzdata2009f (kenny) + +--- Released 8.5.7, April 15, 2009 --- See ChangeLog for details --- + +2009-04-27 (bug fix)[2446662] uniformly declare EOF on RST on sockets (ferrieux) + +2009-04-27 (bug fix)[1028264] delay WSACleanup() from under our feet (ferrieux) 2009-05-07 (bug fix)[2785893] find command in deleted namespace (sofer) -2009-05-08 (bug fix)[2414858] tailcall in oo constructor (fellows) - -2009-05-14 (new subcommand)[TIP 354] [info object namespace] (fellows) - 2009-05-29 (platform support) account for ia64_32 (kupries) => platform 1.0.5 2009-06-02 (bug fix)[2798543] incorrect [expr] integer ** results (porter) 2009-06-10 (bug fix)[2801413] overflow in [format] (porter) 2009-06-13 (bug fix)[2802881] corrected compile env context (tasada,porter) -2009-06-17 (redesign) reduced ambition of [exit] finalization with aim to -avoid otherwise very tricky multi-thread finalization bugs. (staplin,ferrieux) - *** POTENTIAL INCOMPATIBILITY for exit handlers *** - -2009-06-26 (platform support) updates for Xcode 3.1 & 3.2 (steffen) - -2009-06-30 (platform support) clang static analyzer macros (steffen) - 2009-07-01 (bug fix)[2806622] Win: bad tcl_platform(user) value (thoyts) -2009-07-05 (bug fix) zlib support asynch [chan copy] on chan transform (fellows) - -2009-07-12 (bug fix)[1895546] TclOO support for Itcl 4 method caching (fellows) - -2009-07-13 (bug fix)[1605269] NR-related [info frame] fixes (kupries) - -2009-07-14 (bug fix)[2821401] NR-enable direct eval [switch] (kenny) - 2009-07-16 (bug fix)[2819200] underflow settings on MIPS systems (porter) -2009-07-19 (interface)[TIP 354] new routine Tcl_GetObjectName() (fellows) - -2009-07-20 (performance) favor [string is] success cases over empty (fellows) - -2009-07-22 (interface) removed TclpPanic() routine (nijtmans) - 2009-07-23 (bug fix)[2820349] plug event leak in notifier (mistachkin) 2009-07-24 (bug fix)[2826248] crash in Tcl_GetChannelHandle (sonnenburg,kupries) 2009-07-31 (bug fix)[2830354] overflow in [format] (misch,porter) 2009-08-06 (bug fix)[2827000] reflected channels can signal EGAIN (kupries) -2009-08-12 (new feature)[TIP 353] Tcl_NRExprObj() (porter) - -2009-08-20 (bug fix)[2823276] NR-enable [if], [for], [while] (fellows) - 2009-08-20 (bug fix)[2806250] EIAS violation in ~foo pathnames (porter) 2009-08-21 (bug fix)[2837800] [glob */foo] return ./~x/foo (porter) 2009-08-24 (bug fix) nested event loop notifier w/TkAqua Cocoa (alaoui,steffen) @@ -7595,19 +7373,12 @@ => tcltest 2.3.2 2009-09-11 (bug fix)[2849860] http handle "quoted" charset value (fellows) => http 2.7.4 -2009-09-11 (enhancement)[2314561] [subst] now bytecompiled, NR-enabled (porter) - -2009-09-24 (new feature)[TIP 356] Tcl_NRSubstObj() (porter) - 2009-10-04 (bug fix)[2569449] Core Foundation memory bug in Tiger (steffen) -2009-10-06 (bug fix) repair intrep loss in slave interp evaluations -introduced by first versions of the NRE conversion (nadkarni,porter) - 2009-10-06 (bug fix)[1941434] broken tclTomMath.h includes (porter) 2009-10-07 (bug fix)[2871908] leaked hash table (mistachkin,kupries) 2009-10-08 (bug fix)[2874678] bignum leak in [dict incr] (fellows) @@ -7617,311 +7388,135 @@ 2009-10-19 (bug fix)[2107634] extend [read] and [gets] to Tcl string limits (morrison,parker,porter) 2009-10-21 (bug fix)[2882561] Haiku OS signal support (morrison,fellows) -2009-10-22 (bug fix)[2883857] [my varname arr(index)] (boudaillier,fellows) - -2009-10-23 (bug fix) 0-length writes: spurious SIG_PIPE (teterin,kupries) - 2009-10-24 Broken DST applied EU rules to US zones (lehenbauer,kenny) 2009-10-29 (bug fix)[2800740] halved bignum memory on 64-bit systems (porter) - *** POTENTIAL INCOMPATIBILITY *** + *** POTENTIAL INCOMPATIBILITY *** -2009-11-05 (bug fix)[2854929] TM search path support in Safe Base (kupries) +2009-11-03 tzdata updated to Olson's tzdata2009q (kenny) -2009-11-05 (enhancement) rewrite of the Safe Base commands (kupries) +2009-11-03 (bug fix)[2854929] TM search path support in Safe Base (kupries) 2009-11-11 (bug fix)[2888099] [close] loses ENOSPC error (khomoutov,ferrieux) 2009-11-11 (bug fix)[2891171] RFC 3986 compliance for ? in URL (nijtmans) -=> http 2.8.2 +=> http 2.7.5 2009-11-12 (bug fix)[2895565] [fcopy -size] miscounts when converting encodings (kupries) + +--- Released 8.5.8, November 16, 2009 --- See ChangeLog for details --- 2009-11-16 (bug fix)[2891556] encoding finalization crash (mistachkin,ferrieux) -2009-11-18 (bug fix)[2849797] consistent names for std chans (nijtmans,fellows) - *** POTENTIAL INCOMPATIBILITY *** - -2009-11-19 (enhancement) [load]able Tcltest extension (nijtmans) - -2009-11-24 (bug fix)[2893771] [file stat] on Win locked files (thoyts) - -2009-11-24 (bug fix)[2903011] crash call destructor from constructor (fellows) - -2009-12-03 (bug fix)[2906841] Safe Base [glob ../*] fixes (fellows) - -2009-12-09 (bug fix)[2901998] consistent I/O buffering (ferrieux,kupries) - -2009-12-11 (bug fix)[2806407] NR-enabled coroutines (sofer) +2009-12-09 (enhancement) rewrite of the Safe Base commands (kupries) 2009-12-16 (bug fix)[2913616] msgcat: improved safe interp support (fellows) => msgcat 1.4.3 -2009-12-22 (bug fix)[2918962] [lsort -index -stride] crash (moore,fellows) - 2009-12-23 (bug fix)[2913625] [info script/nameof] in safe interps (fellows) 2009-12-28 (bug fix)[2891362] enable time limit in child interps (fellows) -2009-12-29 (bug fix)[2922555] [binary decode hex { }] crash (thoyts) - -2009-12-29 (bug fix)[2895741] enable min(), max() in safe interps (fellows) - -2009-12-30 (bug fix)[2824981] guard [unknown] against [set] undef (sofer) +2009-12-28 (bug fix)[2895741] enable min(), max() in safe interps (fellows) 2010-01-05 (bug fix)[2918610] [file rootname] corruption (magerya,porter) + +2010-01-06 (enhancement) Haiku, CYGWIN support improvements (nijtmans) 2010-01-18 (bug fix)[2932421] less [format %s] shimmer (ferrieux) 2010-01-18 (bug fix)[2918110] [chan postevent] crash (bron,kupries) -2010-01-21 (bug fix)[2910748] NR-enable epoch fallback direct eval (sofer) - -2010-01-30 (enhancement) [unset] now bytecompiled (fellows) - 2010-02-01 (bug fix)[2942697] faster match: some pathological regexp patterns (lane,fellows) -2010-02-01 (bug fix)[2939073] [array unset] unset trace crash (ferrieux) - -2010-02-02 (bug fix)[2944404] crash in oo destructor (fellows) - -2010-02-02 (new feature) [array] is now a [namespace ensemble] (fellows) - -2010-02-05 (enhancement) [error] now bytecompiled (fellows) - -2010-02-08 (bug fix)[2947783] Tcl_Zlib*flate fail on shared values (fellows) - -2010-02-09 (enhancement) [try] now bytecompiled (fellows) - -2010-02-11 (bug fix)[2826551] line-sensitive matching in regexp (dejong) +2010-02-02 (bug fix)[2939073] [array unset] unset trace crash (ferrieux) + +2010-02-02 (bug fix)[2933089] [info frame] shared lit trouble (kupries) 2010-02-11 (bug fix)[2949740] [open |noSuch rb] crash (kovalenko,fellows) -2010-02-15 (bug fix)[2950259] harden (delete obj ns -> delete obj) (fellows) - -2010-02-21 (bug fix)[2954959] get sign of abs($zero) right (nijtmans) - -2010-02-22 (bug fix)[2762041] zlib chan transforms read EOF too early (kupries) - -2010-02-27 (bug fix)[801429] Tcl_SetMainLoop() thread safety (fellows) - *** POTENTIAL INCOMPATIBILITY *** - -2010-03-02 (enhancement) -fvisibility-hidden build support (nijtmans) - -2010-03-04 (bug fix)[2962664] [oo::class destroy] crash (fellows) - -2010-03-05 (interface) TclOO typedefs for function pointers (fellows) - *** POTENTIAL INCOMPATIBILITY *** +2010-02-11 (bug fix)[2954959] get sign of abs($zero) right (nijtmans) 2010-03-09 (bug fix)[2936225] stop [chan copy] to slow channel consuming all memory with buffer backup (ferrieux) -2010-03-17 (bug fix)[2921116] crash in chan transfrom teardown (kupries) - -2010-03-19 (enhancement) [throw] now bytecompiled (fellows) - 2010-03-20 (enhancement) permit [fcopy] of > 2**31 bytes (fellows) -2010-03-24 (new feature) [info object methodtype] (fellows) - 2010-03-24 (bug fix)[2383005] [return -errorcode] reject non-list (porter) 2010-03-25 (bug fix)[2976504] broken fstatfs() call (reeuwijk,fellows) -2010-03-30 (new feature)[TIP 362] [registry -32bit|-64bit] (courtney,fellows) -=> registry 1.3 - 2010-03-30 (bug fix)[2978773] refchan mem preservation (kupries) -2010-04-02 (new feature)[TIP 357] Tcl_LoadFile, Tcl_FindSymbol, etc. (kenny) - -2010-04-05 (configure change)[TIP 364] default build: --enable-threads (fellows) - *** POTENTIAL INCOMPATIBILITY *** - -2010-04-02 (new feature)[TIP 348] [info errorstack], [return -errorstack] -(ferrieux) - -2010-04-20 (enhancement) update bundled zlib to 1.2.5 (nijtmans) - -2010-04-29 (enhancement)[2992970] optimize bytearray appends (fellows) - 2010-05-19 (bug fix)[3004007] dict/list shimmer w/o string rep loss (fellows) 2010-06-09 (bug fixes) platform: several fixes for 64 bit systems (kupries) => platform 1.0.9 2010-06-16 (bug fix)[3016135] [clock format] in he_IL locale (nijtmans) -2010-06-18 (bug fix)[3017997] Add .cmd to file extensions for [exec] (fellows) - 2010-06-28 (bug fix)[3019634] support errno.h changes in MSVC++ 2010 (nijtmans) - *** POTENTIAL INCOMPATIBILITY *** 2010-07-02 (enhancement) -errorcode for [expr] domain errors (fellows) 2010-07-28 (bug fix)[3037525] crash deleting vars @ callframe pop (sofer) 2010-08-04 (bug fix)[3034840] mem corrupt when refchan loses interp (kupries) 2010-08-04 (enhancement) Win [load] use LOAD_WITH_ALTERED_SEARCH_PATH (hobbs) - -2010-08-04 (platform support) panic on detection of win9x system (hobbs) - *** POTENTIAL INCOMPATIBILITY *** - -2010-08-10 (fix) Handle non-null-terminated bytearrys in glob matching (hobbs) - -2010-08-11 (fix) copy-paste bug in [yield] implementation (sofer, goth) - -2010-08-11 (platform) Drop pre-aix 4.2 support, ldAix (hobbs) - -2010-08-14 (frq)[2819611] changed signatures of hash fnctions, delete-file, and get-native-path (nijtmans) - *** POTENTIAL INCOMPATIBILITY *** - -2010-08-15 (bug fix)[3045010] tweaked error message for wrong#args of lambda's (fellows) - -2010-08-18 (bug fix)[3004191] fixed safe [glob] (fellows) - -2010-08-21 (patch)[3034251] genStubs steal features of ttkGenStubs (nijtmans) - -2010-08-26 (bug fix)[1230554] configure, OSF-1 problems, windows manifest issues (hobbs) - -2010-08-30 (bug fix) [3046594,3047235,3048771] reimplemented tailcall (sofer) - -2010-08-31 fixed manifest handling on windows (hobbs, kupries) - -2010-08-31 windows makefile and stub changes (nijtmans) - -2010-09-01 (bug fix)[3057639] compiled lappend trace consistency (hobbs,kupries) - *** POTENTIAL INCOMPATIBILITY *** - -2010-09-01 fixed safe glob handling of -directory (kupries) - -2010-09-02 fixed safe glob handling of -join (kupries) - -2010-09-08 (bug fix)[3059922] build with mingw on amd64 (porter, mescalinum) - -2010-09-15 (bug fix)[3067036] stop hang in bytearray append (fellows) - -2010-09-22 unified set of link libraries between mingw and vc (nijtmans) - -2010-09-22 (bug fix)[3072640] protect writes to ::error* variables (sofer) - -2010-09-23 fix leak of return options [catch $err m constant] (porter, hobbs) - -2010-09-24 (bugfix)[3056775] fixed race condition in windows sockets (kupries) - -2010-09-24 (performance) string eq/cmp (hobbs) - -2010-09-26 (patch)[3072080] rewritten NRE core (sofer) - -2010-09-28 (new feature)[TIP 162] implementation of ipv6 sockets (max) - -2010-10-02 (bug fix)[3079830] properly invalidate string rep of dicts (fellows) - -2010-10-06 (bug fix)[3081065] fix writing to freed Tcl_Obj (porter) - -2010-10-08 fix in ipv6 code on windows (nijtmans) - -2010-10-09 fixed overallocation of execution stack (sofer) - -2010-10-11 windows unicode changes (nijtmans) - -2010-10-12 (bug fix)[3084338] fixed meamleak in ipv6 code (max) - -2010-10-13 (bug fix)[467523,983660] alt fix allows empty literal share (porter) - -2010-10-15 (bugfix)[3085863] updated unicode tables (nijtmans) - *** POTENTIAL INCOMPATIBILITY *** - -2010-10-16 refactored implementation of dict iteration (fellows) - -2010-10-17 (patch)[2995655] report inner contexts on error stack (ferrieux) - -2010-10-19 (bug fix)[3081008] fixed bytearray zlib interaction (fellows) - -2010-10-19 improved crc, appending to bytearray (fellows) - -2010-10-20 improved compilation of [dict for] (fellows) - -2010-10-26 Added private support to disable reverse dns (max) - -2010-10-26 Prevent crashes when querying socket options (fellows, max) - -2010-10-28 (bug fix)[3093120] prevent freeaddrinfo(NULL) (porter, virden) - -2010-10-29 (bug fix)[2905784] stop cycle waste in short [after] (ferrieux) - -2010-11-01 tzdata updated to Olson's tzdata2010o (kenny) - -2010-11-04 (bug fix)[3099086] Clarified docs of var substitution (fellows) - -2010-11-04 improved install targets (cassof) - -2010-11-04 improved testing of sockets (max) - -2010-11-05 (frq)[491789] setargv/unicode cmdline for MSVC (nijtmans) - -2010-11-09 (bug fix)[3105999] fixed memleak in OO var resolver (fellows) + *** POTENTIAL INCOMPATIBILITY *** + +2010-08-12 (bug fix)[2826551] line-sensitive matching in regexp (dejong) + +2010-08-19 (bug fix)[3048354] buffer overflow detect in Fortify build (fellows) + +2010-08-23 tzdata updated to Olson's tzdata2010l (kenny) + +2010-09-01 (bug fix)[3057639] no read traces [lappend arr(elem) ...] (hobbs) + *** POTENTIAL INCOMPATIBILITY *** + +--- Released 8.5.9, September 8, 2010 --- See ChangeLog for details --- + +2010-09-24 (bug fix)[3056775] race condition in Win sockets (twylite,kupries) + +2010-10-23 (update)[3085863] Update Unicode data to 6.0 (nijtmans) + +2010-11-02 Safe Tcl handling of empty path lists (cassoff) + +2010-11-03 (bug fix)[3098302] crash in compiled [catch] (kenny) 2010-11-15 (TIP 378)[3081184] improved TIP 280 performance (kupries) -2010-11-16 (platform) VS 2005 SP1 MSVC compiler (nijtmans) - -2010-11-18 (bug fix)[3111059] leak in [namespace delete] w coroutines (sofer) - -2010-11-28 [3120139,3105247] Tcl_PrintDouble improvements (kenny) - -2010-11-29 (new cmd) [tcl::unsupported::inject] (ferrieux,sofer) - 2010-11-30 (enhancement) Restore TclFormatInt for performance (hobbs) -2010-12-09 (new feature) [file] is now a [namespace ensemble] (fellows) - -2010-12-19 (bug fix) [fcopy -size 1 -command] asynchronous (ferrieux) +2010-11-30 (enhancement) Tcl_PrintDouble performance improvements (kenny) 2010-12-12 (platform) OpenBSD build improvements (cassoff) 2010-12-17 (platform) Revisions to support rpm 4.4.2 (cassoff) -2010-12-27 (bug fix) crash in [lsort] w multiple -index options (fellows) - -2010-12-30 (bug fix)[3142026] GrowEvaluationStack OBOE (harder,sofer) - -2011-01-18 (bug fix)[3001438] [info frame -1] crash (mccormack,fellows) - -2011-03-01 (performance)[3168398] optimize [interp cancel] (mistachkin) - -2011-03-05 (bug fix)[3185009] crash in OO variables (danckaert,fellows) - -2011-03-05 (new cmd) [tcl::unsupported::assemble] (ugurlu,kenny) +2011-01-13 (bug fix)[3142026] GrowEvaluationStack OBOE (harder,sofer) + +2011-01-19 (bug fix)[3072640] protect writes to ::error* variables (sofer) 2011-03-06 (bug fix)[3200987,3192636] parser buffer overruns (porter) 2011-03-08 (bug fix)[3202905] failed intrep release of interp result (mccormack) 2011-03-09 (bug fix)[3202171] repair [namespace inscope] optimizer (porter) -2011-03-10 (new version) better tcltest reporting from child interps (fellows) -=> tcltest 2.3.3 - -2011-03-10 (new feature) [namespace] is now a [namespace ensemble] (fellows) - -2011-03-12 (interface) reduce casting by ckalloc(), ckfree() callers (fellows) - 2011-03-14 (bug fix) Fixes from libtommath 0.42.0 release (fellows) 2011-03-21 (bug fix)[3216070] [load] extension from embed Tcl apps (nijtmans) ***POTENTIAL INCOMPATIBILITY*** -2011-03-27 (performance) NRE: LIST lset foreach benchmark (twylite) - -2011-04-11 (bug fix)[3282869] coroutine + eval + locals crash (ferrieux,sofer) +2011-04-12 (bug fix)[3285472] intrep corruption in [string reverse] (porter) 2011-04-13 (bug fix)[2662380] crash when variable append trace unsets (sofer) 2011-04-13 (bug fix)[3285375] Buffer overflow in [concat] (porter) @@ -7930,33 +7525,29 @@ 2011-05-05 (enhancement) dict->list w/o string rep generation (porter) 2011-05-10 (bug fix)[3173086] Crash parsing long lists (rogers,porter) -2011-05-24 (enhancement) msgcat internal improvements (fellows) +2011-05-12 (bug fix)[2715421] surplus \n in POST (passadyn,thoyts) +=> http 2.7.6 + +2011-05-24 tzdata updated to Olson's tzdata2011g (iyer) + +2011-05-25 (enhancement) msgcat internal improvements (fellows) => msgcat 1.4.4 -2011-05-25 (TIP 381) [info object|class call] [self call] [nextto] (fellows) - -2011-05-31 (bug fix)[3293874] let lists grow all the way to the limit (porter) - 2011-06-02 (bug fix)[3185407] cmd resolution epoch flaw (nadkarni,fellows) 2011-06-13 (bug fix)[3315098] mem leak generating double string rep (neumann) + +2011-06-21 (new cmd) [tcltest::loadIntoSlaveInterpreter] (fellows) +=> tcltest 2.3.3 2011-06-22 (new feature) DEB_HOST_MULTIARCH support (kupries) => platform 1.0.10 -2011-07-15 (bug fix)[3357771] Prevent circular refs in bytecode (porter) - -2011-07-28 tzdata updated to Olson's tzdata2011h (porter) - -2011-08-01 (bug fix)[3383616] memleak exposed by XOTcl (neumann,sofer) - -Many more Tcl built-in command errors now set an -errorcode. - ---- Released 8.6b2, August 8, 2011 --- See ChangeLog for details --- +--- Released 8.5.10, June 23, 2011 --- See ChangeLog for details --- 2011-07-02 (bug fix)[3349507] correct double(1[string repeat 0 23]) (kenny) 2011-07-19 (bug fix)[3371644] Tcl_ConvertElement() segfault (sader, ferrieux) @@ -7974,28 +7565,24 @@ 2011-09-08 (bug fix)[3401704] revised expr parser to permit function names like "nano()" instead of parsing as "nan o()" with missing op (duquette,porter) *** POTENTIAL INCOMPATIBILITY *** -2011-09-10 (bug fix)[3400658] wrong num args msg with TclOO (rsooltan,fellows) - 2011-09-13 (bug fix)[3390638] solaris studio cc workaround (kechel,porter) 2011-09-13 (bug fix)[3405652] DTrace workaround (michelson,porter) 2011-09-16 (bug fix)[3391977] -headers overrides -type (ziegenhagen,fellows) -=> http 2.8.3 +=> http 2.7.7 -2011-09-16 (TIP 388) New \Uhhhhhhhh syntax (nijtmans) - -2011-10-06 (enhancement) bytecode compile [dict with] (fellows) +2011-09-16 (bug fix)[3400658] wrong num args msg with TclOO (rsooltan,fellows) 2011-10-11 (bug fix)[2935503] [file stat] returns bad mode (nadkarni,nijtmans) -2011-10-20 (bug fix)[3418547] cmd lits and custom resolvers (soberning,fellows) +2011-10-15 tzdata updated to Olson's tzdata2011l (iyer) -2011-10-31 (bug fix)[3414754] EIAS violation in fs paths (porter) +--- Released 8.5.11, November 4, 2011 --- See ChangeLog for details --- 2011-11-22 (bug fix)[3354324] Win: [file mtime] sets wrong time (nijtmans) 2011-11-30 (bug fix)[967195] Simply args passed to child processes (nijtmans) => tcltest 2.3.4 @@ -8007,364 +7594,242 @@ 2011-12-24 (bug fix)[3464428] fix [string is graph \u0120] (nijtmans) 2012-01-08 (bug fix)[3470928] zoneinfo trouble with Windhoek data file (kenny) 2012-01-13 (bug fix)[3472316] fix retrieval of socket error (fellows) +=> http 2.7.8 2012-01-21 (bug fix)[3475667] [regexp] buffer read overflow (sebres) 2012-01-22 (bug fix)[3475264] [dict exists] return 0, not error (fellows) -2012-01-25 (bug fix)[3474460] [oo::copy] var resolution list (fellows) - 2012-01-26 (bug fix)[3475569,3479689] mem corrupt in fs path (sebres,porter) -2012-01-30 (enhancement) improve bytecode compile of [catch] (fellows) - 2012-02-02 (bug fix)[2974459,2879351,1951574,1852572,1661378,1613456] Fix problems where [file *able] would return false results on Win/Samba (porter) + +2012-02-02 (update)[3464401] Support Unicode 6.1 (nijtmans) 2012-02-06 (bug fix)[3484621] bump bytecode epoch on exec traces (kuhn,sofer) +2012-02-09 (bug fix)[3484402] mem corrupt OBOE in unicode append (porter) + 2012-02-15 (bug fix)[3487626] crash compiling [dict for] (fellows) -2012-02-15 (enhancement) bytecode compile [lrange],[lreplace] (fellows) - 2012-02-17 (bug fix)[2233954] compile problem on AIX & Android (nijtmans) 2012-02-29 (bug fix)[3466099] BOM in Unicode (nijtmans) 2012-03-07 (bug fix)[3498327] RFC 3986 compliance (kupries) - -2012-03-26 (TIP 380) New builtin class [oo::Slot] (fellows) - *** POTENTIAL INCOMPATIBILITY *** - -2012-03-27 (TIP 397) method to extend [oo::copy] (fellows) - *** POTENTIAL INCOMPATIBILITY *** - -2012-03-27 (TIP 395) New subcommand [string is entier] (fellows) - -2012-04-02 (TIP 396) New command [yieldto] (fellows) - -2012-04-04 (bug fix)[3514761] crash combining objects and ensembles (fellows) - -2012-04-09 (bug fix)[2712377] [info vars] and oo variables (fellows) - -2012-04-09 (bug fix)[3396896] no dups in oo var lists (fellows) +=> http 2.7.9 2012-04-11 (bug fix)[3448512] [clock scan 1958-01-01] fail on Win (nijtmans) -2012-04-15 (bug fix)[3517696] fix flush of zlib chan xform (fellows) - 2012-04-18 tzdata updated to Olson's tzdata2012c (kenny) -2012-04-28 (TIP 398) exit non-blocking chan without flush (ferrieux) - *** POTENTIAL INCOMPATIBILITY *** - 2012-05-02 (enhancement) Better use of Intel cpuid instruction (nijtmans) -2012-05-03 (bug fix)[3428753] Unbreak synchronous [socket -async] (porter) - -2012-05-10 (bug fix)[2812981] force consistent config of Tcl+pkgs (ferrieux) - 2012-05-10 (bug fix)[473946] correct send of special characters (nijtmans) - -2012-05-17 (bug fix)[3445787] fix [file] ensemble in Safe Base (fellows) +=> dde 1.3.3 2012-05-17 (bug fix)[2964715] fix [glob] in Safe Base (fellows) 2012-05-17 (bug fix)[3106532] proper [switch -indexvar] values (fellows) *** POTENTIAL INCOMPATIBILITY *** -2012-05-21 (TIP 106) New -binary option to [dde execute|poke] (oehlmann) -=> dde 1.4.0 - -2012-05-23 (bug fix)[3525907] [zlib push decompress] & [chan event] -(fellows,ferrieux,kupries) - -2012-05-28 (bug fix)[3529949] Protect ~ paths in Safe Base (fellows) - -2012-06-21 (bug fix)[3362446] [registry keys] failure (nijtmans) -=> registry 1.3.0 - 2012-06-25 (bug fix)[3537605] [encoding dirs a b] error message (fellows) 2012-06-25 (bug fix)[3024359] crash when multi-thread concurrent [file system] and Tcl_FSMountsChanged(). (porter) 2012-06-29 (bug fix)[3536888] fix locale guessing (oehlmann,nijtmans) +=> msgcat 1.4.5 2012-07-05 (bug fix)[1189293] make "<<" redirect binary safe (porter) -2012-07-08 (bug fix)[3531209] accept IPv6 URLs (max) -=> http 2.8.4 +2012-07-11 (bug fix)[3362446] [registry keys] failure (nijtmans) +=> registry 1.2.2 + +2012-07-16 (bug fix)[3544683] reentrant syscalls on BSD (cassoff,fellows) 2012-07-24 (bug fix) stop mem corruption in stacked channel events (max,porter) 2012-07-25 (bug fix)[3546275] [auto_execok] search match [exec] (danckaert) +Many revisions to better support a Cygwin environment (nijtmans) + +--- Released 8.5.12, July 27, 2012 --- See ChangeLog for details --- + 2012-07-27 (update)[3464401] Support Unicode 6.2 (nijtmans) + +2012-08-07 (bug fix)[3554250] fs segfault in thread exit handler (porter) + +2012-08-08 (update)[1536227] Cygwin network pathname support (nijtmans) 2012-08-20 (bug fix)[3559678] [file normalize] EIAS failure (phao,dgp) 2012-08-25 (bug fix)[3561330] Ukranian translation of "March" (teterin) -2012-09-07 (TIP 404) New msgcat commands [mcflset], [mcflmset] (oehlmann) +2012-09-11 (bug fix)[3564735] mem corruption w/ Itcl's [variable] (porter) + +2012-09-25 (TIP 404) New msgcat commands [mcflset], [mcflmset] (oehlmann) => msgcat 1.5.0 -Many revisions to better support a Cygwin environment (nijtmans) - -Dropped support for OS X versions less than 10.4 (Tiger) (fellows) - ---- Released 8.6b3, September 18, 2012 --- See ChangeLog for details --- - -2012-09-20 (enhancement) full Unicode support (nijtmans) -=> dde 1.4.0 - -2012-09-20 (enhancement) update bundled zlib to 1.2.7 (nijtmans) - 2012-10-03 (bug fix) exit panic on stacked std channel (griffin,porter) 2012-10-14 (bug fix) [tcl::Bgerror] crash on non-dict options (nijtmans) -2012-10-16 (TIP 400) New [zlib] options to set compression dict (fellows) - -2012-10-16 (TIP 405) New commands [lmap] and [dict map] (fellows) - -2012-10-24 (enhancement) [dict unset] now bytecompiled (fellows) - -2012-11-05 (TIP 413) Revisions to default [string trim*] trimset (nijtmans) - *** POTENTIAL INCOMPATIBILITY *** - -2012-11-05 (enhancement) Now bytecompiled: [array exists], [array set], -[array unset], [dict create], [dict exists], [dict merge], [format], -[info commands], [info coroutine], [info level], [info object], -[namespace current], [namespace code], [namespace qualifiers], [namespace tail], -[namespace which], [regsub], [self], [string first], [string last], -[string map], [string range], [tailcall], [yield]. (fellows) - 2012-11-06 (bug fix)[3581754] avoid multiple callback on keep-alive (fellows) -=> http 2.8.5 +=> http 2.7.10 + +2012-11-07 (bug fix)[3574493] hang in Windows socket finalization (fassel) 2012-11-07 tzdata updated to Olson's tzdata2012i (kenny) -2012-11-13 (bug fix)[3567063] thread fp settings from master (mistachkin) - -2012-11-14 (bug fix)[2933003] tempfile creation in $TMPDIR (fellows) - -2012-11-15 (TIP 416) New [load] options -global and -lazy (nijtmans) - -2012-11-20 (bug fix)[3033307] base64 trail whitespace (kovalenko,goth) - -2012-12-03 (bug fix) [configure] query broke init from argv (porter) +--- Released 8.5.13, November 12, 2012 --- See ChangeLog for details --- + +2012-11-13 (enhancement)[360894] Threads inherit floating point from creator. + +2012-11-14 (enhancement)[2933003] compile setting: TCL_TEMPORARY_FILE_DIRECTORY + +2012-11-16 (bug fix)[3587651] [info functions] returns complete set. (porter) + +2012-12-03 (bug fix) tcltest: Correct legacy auto-init fom $::argv (porter) => tcltest 2.3.5 -2012-12-13 (bug fix)[3595576] crash: [catch {} -> noSuchNs::var] (sofer,porter) +2012-12-06 (bug fix) Tcl_InitStubs("8.5",1) must reject 8.50. (porter) -2012-12-13 (bug fix) crash: [zlib gunzip $data -header noSuchNs::var] (porter) - ---- Released 8.6.0, December 20, 2012 --- See ChangeLog for details --- - -2012-12-22 (bug fix)[3598150] DString to Tcl_Obj memleak (afredd) +2012-12-13 (bug fix)[3595576] mem flaw in [catch {} -> no-such-ns::v] (porter) 2012-12-27 (bug fix)[3598580] Tcl_ListObjReplace() refcount fix (nijtmans) -2013-01-04 (bug fix) memleak in [format] compiler (fellows) - 2013-01-08 (bug fix)[3092089,3587096] [file normalize] on junction points 2013-01-09 (bug fix)[3599395] status line processing (nijtmans) 2013-01-23 (bug fix)[2911139] repair async connection management (fellows) -=> http 2.8.6 - -2013-01-26 (bug fix)[3601804] Darwin segfault platformCPUID (nijtmans) - -2013-01-28 (enhancement) improve ensemble bytecode (fellows) - -2013-01-30 (enhancement) selected script code improvements (fradin) -=> tcltest 2.3.6 +=> http 2.7.11 2013-01-30 (bug fix)[3599098] update to handle glibc banner changes (kupries) => platform 1.0.11 -2013-01-31 (bug fix)[3598282] make install DESTDIR support (cassoff) - 2013-02-05 (bug fix)[3603434] [file normalize a:/] flaw in VFS (porter,griffin) -2013-02-09 (bug fix)[3603695] $obj varname resolution rules (venable,fellows) - -2013-02-11 (bug fix)[3603553] zlib flushing errors (vampiera,fellows) - 2013-02-14 (bug fix)[3604576] msgcat use of Windows registry (oehlmann,nijtmans) => msgcat 1.5.1 2013-02-19 (bug fix)[2438181] report errors in trace handlers (yorick) 2013-02-21 (bug fix)[3605447] unbreak [namespace export -clear] (porter) -2013-02-23 (bug fix)[3599194] fallback IPv6 routines (afredd,max) - 2013-02-27 (bug fix)[3606139] stop crash in [regexp] (lane) -2013-03-03 (bug fix)[3606258] major serial port update (english) - 2013-03-06 (bug fix)[3606683] [regexp (((((a)*)*)*)*)* {}] hangs (grathwohl,lane,porter) 2013-03-12 (enhancement) better build support for Debian arch (shadura) 2013-03-19 (bug fix)[2893771] [file stat] on locked files (thoyts,nijtmans) 2013-03-21 (bug fix)[2102614] [auto_mkindex] ensemble support (griffin) -2013-03-27 Tcl_Zlib*() routines tolerate NULL interps (porter +2013-03-22 tzdata updated to Olson's tzdata2013b (venkat) + +--- Released 8.5.14, April 3, 2013 --- See ChangeLog for details --- + +2013-04-03 (bug fix)[3205320] outsmart gcc on powerpc detect stack direction 2013-04-04 (bug fix) Support URLs with query but no path (max) -=> http 2.8.7 +=> http 2.7.12 2013-04-08 (bug fix)[3610026] regexp crash on color overflow (linnakangas) -2013-04-29 (enhancement) [array set] compile improvement (fellows) +2013-04-16 (bug fix)[3610404] crash in enter traces (found with TclOO) (porter) 2013-04-30 (enhancement) broaden glibc version detection (kupries) => platform 1.0.12 +2013-05-01 (bug fix)[2901998] inconsistent I/O buffering (ferrieux) + 2013-05-06 (platform support) Cygwin64 (nijtmans) -2013-05-15 (enhancement) Improved [list {*}...] compile (fellows) - 2013-05-16 (platform support) mingw-4.0 (nijtmans) 2013-05-19 (platform support) FreeBSD updates (cerutti) -2013-05-20 (bug fix)[3613567] access error temp file creation (keene) - -2013-05-20 (bug fix)[3613569] temp file open fail can crash [load] (keene) - 2013-05-22 (bug fix)[3613609] [lsort -nocase] failed on non-ASCII (fellows) 2013-05-28 (bug fix)[3036566] Use language packs (Vista+) locale (oehlmann) => msgcat 1.5.2 -2013-05-29 (bug fix)[3614102] [apply {{} {list [if 1]}}] stack woes (porter) - 2013-06-03 Restored lost performance appending to long strings (elby,porter) -2013-06-05 (bug fix)[2835313] [while 1 {foo [continue]}] crash (fellows) - 2013-06-17 (bug fix)[a876646] [:cntrl:] includes \x00 to \x1f (nijtmans) + +2013-06-17 [string is space \u180e] => 1 (nijtmans) 2013-06-27 (bug fix)[983509] missing encodings for config values (nijtmans) 2013-06-27 (bug fix)[34538b] apply DST in 2099 (lang) 2013-07-02 (bug fix)[32afa6] corrected dirent64 check (griffin) 2013-07-06 tzdata updated to Olson's tzdata2013d (kenny) -2013-07-10 (bug fix)[86fb5e] [info frame] in compiled ensembles (porter) - -2013-07-18 (bug fix)[1c17fb] revisd syntax errorinfo that shows error (porter) - 2013-07-26 (bug fix)[6585b2] regexp {(\w).*?\1} abb (lane) 2013-07-29 [string is space \u202f] => 1 (nijtmans) 2013-08-01 [a0bc85] Limited support for fork with threads (for Rivet) (nijtmans) -2013-08-01 (bug fix)[1905562] RE recursion limit increased to support -reported usage of large expressions (porter) - -2013-08-02 (bug fix)[9d6162] superclass slot empty crash (vdgoot,fellows) - -2013-08-03 (enhancement)[3611643] [auto_mkindex] support TclOO (fellows) - 2013-08-14 (bug fix)[a16752] Missing command delete callbacks (porter) -2013-08-15 (bug fix)[3610404] reresolve traced forwards (porter) - 2013-08-15 Errors from execution traces become errors of the command (porter) -2013-08-23 (bug fix)[8ff0cb9] Tcl_NR*Eval*() schedule only, as doc'd (porter) - -2013-08-29 (bug fix)[2486550] enable [interp invokehidden {} yield] (porter) - -2013-09-01 (bug fix)[b98fa55] [binary decode] fail on whitespace (reche,fellows) +2013-09-07 (bug fix) stop crashes in tclcompiler (kupries,porter) 2013-09-07 (bug fix)[86ceb4] have tm path favor first provider (neumann,porter) -2013-09-09 (bug fix)[3609693] copied object member variable confusion (fellows) -=> TclOO 1.0.1 +2013-09-13 (bug fix)[bdd91c] crash in exec stack mem management (azazel) -2013-09-17 (bug fix)[2152292] [binary encode uuencode] corrected (fellows) +--- Released 8.5.15, September 16, 2013 --- https://core.tcl-lang.org/tcl/ for details 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-09-19 (bug fix) [info frame] line OBOEs in bytecode (porter) + +2013-09-25 (bug fix)[d614d63] namespace matching *:: deletion fail (fellows) 2013-10-22 (bug fix)[3556215] [scan %E%G%X] support (fellows) 2013-10-25 (bug fix)[3eb2ec1] upper case scheme names in url. (nijtmans) -=> http 2.8.8 +=> http 2.7.13 2013-10-29 (bug fix)[414d103] HP-UX: restore [exec] in threaded Tcl (nijtmans) 2013-11-04 (bug fix) C++ friendly stubs struct declarations (nijtmans) 2013-11-05 (bug fix)[426679e] OpenBSD man page rendering (nijtmans) -2013-11-12 (bug fix)[5425f2c] [fconfigure -error] breaks [socket -async] - 2013-11-20 (bug fix) Improved environment variable management (nijtmans) => tcltest 2.3.7 2013-11-21 (platforms) Support for Windows 8.1 (nijtmans) -2013-12-06 (RFE) improved [foreach] bytecode (fellows) - -2013-12-10 (RFE) improved [lmap] bytecode (sofer) - -2013-12-11 (RFE) improved [catch] bytecode (sofer) - -2013-12-18 (bug fix)[0b874c3] SEGV [coroutine X coroutine Y info frame] (porter) - -2013-12-20 (RFE) reduced numeric conversion in bytecode (sofer) - -2014-01-07 (RFE) compilers for [concat], [linsert], [namespace origin], -[next], [string replace], [string tolower], [string totitle], [string toupper], -[string trim], [string trimleft], [string trimright] (fellows) - -2014-01-22 (RFE) compilers for [nextto], [yieldto] (fellows) - -2014-02-02 (RFE) compiler for [string is] (fellows) - 2014-02-06 (bug fix)[a4494e2] panic in test namespace-13.2 (porter) + +2014-02-24 (bug fix)[2413550] Win: avoid serial double open (schroeter) 2014-03-20 (bug fix)[2f7cbd0] FreeBSD 10.0 build failure (nijtmans) -2014-03-26 (RFE)[b42b208] Cygwin: [file attr -readonly -archive -hidden -system] -(nijtmans) - 2014-03-27 (bug fix) segfault iocmd-23.11 (porter) -2014-04-02 (bug fix)[581937a] Win: readable event on async connect failure +2014-04-02 (bug fix)[336441e] Win: async socket connect stall (oehlmann) 2014-04-04 (bug fix)[581937a,97069ea] async socket connect fail (oehlmann) 2014-04-10 (bug fix)[792641f] Win: no \ in normalized path (nijtmans) -2014-04-11 (bug fix)[3118489] protect NUL in filenames (nijtmans) - 2014-04-15 (bug fix)[88aef05] segfault iocmd-21.20 (porter) 2014-04-16 (update) Win: use Winsock 2.2 (nijtmans) 2014-04-16 (bug fix)[d19a30d] segfault clock-67.[23] (sebres) @@ -8373,770 +7838,143 @@ 2014-04-22 (bug fix) segfault iogt-2.4 (porter) 2014-04-23 (bug fix)[3493120] memleak in thread exit -2014-05-08 refactoring of core I/O functions (porter) +2014-04-30 (bug fix) segfault iocmd-21.2[34] (porter) + +2014-05-01 (bug fix)[0e92c40] bytearray optimization validity (nijtmans) + +2014-05-06 (bug fix) segfault iogt-2.5 (porter) + +2014-05-06 (memleaks) io-29.27 io-29.34 io-33.7 (porter) + +2014-05-07 (memleaks) io-53.5, cloned Tcl_ChannelTypes (porter) + +2014-05-08 (memleak) iocmd-21.22 (porter) -2014-05-09 (bug fix)[3389978] Win: extended paths support (nijtmans) +2014-05-08 refactoring of core I/O functions (porter) 2014-05-09 (bug fix) segfault iocmd-32.1 (porter) -2014-05-11 (bug fix)[6d2f249] nested ensemble compile failure (fellows) +2014-05-15 (bug fix)[3118489] protect NUL in filenames (nijtmans) -2014-05-17 (RFE)[47d6625] wideint support in [lsearch -integer] [lsort -integer] (nijtmans) - *** POTENTIAL INCOMPATIBILITY *** +2014-05-16 (bug fix) Fix for failing tests *io-32.11* (porter) 2014-05-20 (bug fix) Stop eof and blocked state leaking thru stacks (porter) - *** POTENTIAL INCOMPATIBILITY *** + *** POTENTIAL INCOMPATIBILITY *** -2014-05-20 (bug fix)[13d3af3] Win: socket -async tried only first IP address - -2014-05-28 (platforms) work around systems that fail when a shared library +2014-05-22 (platforms) work around systems that fail when a shared library is deleted after it is [load]ed (kupries) 2014-05-31 (bug fix) chan events on pipes must be on proper ends (porter) 2014-06-04 (bug fix) socket-2.12 (porter) 2014-06-05 (bug fix) io-12.6 (kupries,porter) -2014-06-15 (RFE)[1b0266d] [dict replace|remove] return canonical dict (fellows) - *** POTENTIAL INCOMPATIBILITY *** - 2014-06-16 (bug fix) socket-2.13 workaround broken select() (porter) 2014-06-20 (bug fix)[b47b176] iortrans.tf-11.0 (porter) 2014-06-22 (RFE)[2f9df4c] -cleanup scripts before -out compare (nijtmans) 2014-07-04 (update) Update Unicode data to 7.0 (nijtmans) - *** POTENTIAL INCOMPATIBILITY *** - -2014-07-08 (bug) [chan push] converts blocked writes to error (aspect,porter) + *** POTENTIAL INCOMPATIBILITY *** 2014-07-10 (bug fix)[7368d2] memleak Tcl_SetVar2(..,TCL_APPEND_VALUE) (porter) - *** POTENTIAL INCOMPATIBILITY *** - -2014-07-11 (bug) leaks in SetFsPathFromAny, [info frame] (porter) - -2014-07-15 (bug) compress dict leak in zlib xform channel close (porter) - -2014-07-17 (bug fix)[9969cf8] leak trace data in coroutine deletion (porter) - -2014-07-18 (RFE)[b43f2b4] fix [lappend] multi performance collapse (fellows) - -2014-07-19 (bug fix)[75b8433] memleak managing oo instance lists (porter) - -2014-07-21 (bug fix)[e6477e1] memleak in AtForkChild() (porter) - -2014-07-22 (bug fix)[12b0997] memleak in iocmd.tf-32.0 (porter) - -2014-07-28 (RFE) Optimized binary [chan copy] by moving buffers (porter) - -2014-07-30 (enhancement) use refcounts, not Tcl_Preserve to manage lifetime + *** POTENTIAL INCOMPATIBILITY *** + +2014-08-01 (enhancement) use refcounts, not Tcl_Preserve to manage lifetime of Tcl_Channel (porter) - *** POTENTIAL INCOMPATIBILITY *** - -2014-07-31 (bug fix)[a84a720] double free in oo chain deletion (porter) - -2014-08-01 (bug fix)[e75faba] SEGV [apply {{} {namespace upvar a b [x]}}] (porter) + *** POTENTIAL INCOMPATIBILITY *** 2014-08-01 (update) "macosx*-i386-x86_64" "macosx-universal" no longer compatible (kupries) => platform 1.0.13 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) - -2014-09-08 (bug) Crash regression in [oo::class destroy] (porter) - -2014-09-09 (bug)[84af11] Regress [regsub -all {\(.*} a(b) {}] (fellows) - -2014-09-10 (bug)[cee90e] [try {} on ok {} - on return {} {}] panic (porter) - -2014-09-20 (feature) [tcl::unsupported::getbytecode] disassember (fellows) - -2014-09-27 (enhancement) [string cat] bytecode optimization (leitgeb,ferrieux) - -2014-09-27 (bug)[82521b] segfault in mangled bytecode (ogilvie,sofer) +--- Released 8.5.16, August 25, 2014 --- https://core.tcl-lang.org/tcl/ for details 2014-10-02 (bug)[bc5b79] Hang in some [read]s of limited size (rogers,porter) -2014-10-03 (bug)[bc1a96] segfault in [array set] of traced array (tab,porter) - 2014-10-08 (bug)[59a2e7] MSVC14 compile support (dower,nijtmans) 2014-10-10 (bug)[ed29c4] [fcopy] treats [blocked] as error (rowen,porter) 2014-10-10 (bug)[bf7135] regression in Tcl_Write() interface (porter) 2014-10-18 (bug)[10dc6d] fix [gets] on non-blocking channels (fassel,porter) +--- Released 8.5.17, October 25, 2014 --- https://core.tcl-lang.org/tcl/ for details + 2014-10-26 Support for Windows 10 (nijtmans) 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) 2014-12-04 (bug)[d2ffcc] Limit $... and bareword parsing to ASCII (ladayaroslav,porter) - *** POTENTIAL INCOMPATIBILITY *** - -2014-12-06 (bug)[c6cd4a] Win: hang in async socket connection (shults,nadkarni) + *** POTENTIAL INCOMPATIBILITY *** 2014-12-10 tzdata updated to Olson's tzdata2014j (venkat) -2014-12-13 fix header files installation on OS X (houben) - -2014-12-17 (TIP 427) [fconfigure $h -connecting, -peername, -sockname] (oehlmann,rmax) - -2014-12-18 (bug)[af08c8] Crash in full finalize encoding teardown (porter) - -2014-12-18 (bug)[7c187a] [chan copy] crash (io-53.17) (benno,porter) - 2015-01-26 (bug)[df0848] Trouble with INFINITY macro (dower,nijtmans) 2015-01-29 (bug) Stop crashes when extension var resolvers misbehave (porter) -2015-01-29 (bug)[088727] [read] past EOF (io-73.4) (fenugrec,porter) +2015-02-05 (bug) Plug stacked channel memleak (porter) 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) +--- Released 8.5.18, March 6, 2015 --- https://core.tcl-lang.org/tcl/ for details + +2015-03-10 (bug)[3028676] Refinement in OS X notifier (steffen,walzer,lars_h) 2015-04-23 (bug)[19ea02] Win: shared read from linked dirs (bogdan,oehhar) 2015-04-24 (bug)[879a07] Incomplete chars @ buffer ends (leunissen,porter) 2015-04-29 (bug)[894da1] Hang flushing blocking channels (yorick) -2015-05-14 (enhance)[b9d043] Default use of gzip transfer encoding (fellows) -=> http 2.8.9 - *** POTENTIAL INCOMPATIBILITY *** - -2015-05-15 (bug)[9dd1bd] destructor [self] after failed constructor (calvo,fellows) - -2015-05-15 (bug)[0f42ff] [tailcall] combined with [next] (aspect,fellows) - -2015-05-18 (bug)[c11a51] http: race condition in -accept option (fellows) - -2015-05-19 (enhance) More pure lists from compiled [list] (porter,fellows) - 2015-05-27 (enhancement) Relax memdebug constraint on extensions (kupries) -2015-06-03 (bug)[268b23] crash in traced [expr] (execute-11.2)(tomkinson,porter) - -2015-06-11 (bug)[478c44] Memleak in zlib compresion errors (mistachkin) - 2015-06-16 (bug)[e770d9] Higher baud on serial channels (woods,nijtmans) 2015-06-18 (update) Update Unicode data to 8.0 (nijtmans) - *** POTENTIAL INCOMPATIBILITY *** - -2015-06-18 (bug)[a4cb3f] compiled [lreplace] handling of end (bron,aspect) - -2015-06-23 (enhance) Use Unicode SendMessageTimeout() (nijtmans) -=> registry 1.3.1 - -2015-06-25 (TIP 412) msgcat dynamic locale change and package private locale (oehlmann) -=> msgcat 1.6.0 - -2015-07-05 (bug)[a0ece9] crash in traced [expr] (execute-11.3) (hans,porter) - -2015-07-10 (TIP 436) [info object isa] favors 'false' over error (fellows) -=> TclOO 1.0.4 + *** POTENTIAL INCOMPATIBILITY *** 2015-07-15 (bug)[b1534b][9bad63] writes beyond buffer bounds (hanno,porter) -2015-07-18 (bug)[a3309d] Memleak in compiled [unset a($i)] (jeff,porter) - -2015-07-23 (bug)[57945b] lock in forking/multi-threading (neumann,mistachkin) - 2015-07-29 (bug)[3e7eca] Allocation overflow in expr parsing (rickyb,porter) -2015-07-30 (bug)[f00009] Win: Memleak in [file] (rp,sebres) - -2015-07-31 (bug) Correct problems found in Coverity audit (sofer) +2015-08-12 tzdata updated to Olson's tzdata2015f (venkat) 2015-08-19 (bug)[00189c] MSVC 14: semi-static UCRT support (dower,nijtmans) 2015-08-26 (bug)[0df7a1] Tolerate getcwd() failures (cato,nijtmans) -2015-09-21 (bug)[1115587][a3c350][d7ea9f][0e0e15][187d7f] Many fixes and -improvements to regexp engine from Postgres (lane,porter,fellows,seltenreich) - -2015-09-23 (enhance) hash lookup microoptimization (hipp) - 2015-09-23 (bug)[e0a7b3] Input buffer draining & file events (griffin,porter) + +2015-09-24 (bug)[57945b] lock in forking/multi-threading (neumann,mistachkin) 2015-09-29 (bug)[219866] Cygwin support error (yorick,nijtmans) => platform 1.0.14 2015-10-06 (bug)[b42a85] Win: [file normalize ~user] wrong dir (nadkarni) -2015-10-21 (bug)[1080042][8f2450] More regexp from Postgres (lane,porter) - -2015-10-23 (bug)[4a0c16] [clock] react to msgcat locale change (oehlmann) +2015-10-21 (bug)[818a1a][a3c350][d7ea9f][8f2450][1080042] Many fixes and +improvements to regexp engine from Postgres (lane,porter,fellows,seltenreich) 2015-11-10 (bug)[261a8a] Overflow segfault in I/O translation (brooks,porter) -2015-11-20 (bug)[40f628] ListObjReplace callers fail to detect max (porter) +2015-11-20 (bug)[3293874] let lists grow all the way to the limit (porter) -2015-11-30 (enhance)[32c574] Improve list growth performance (brooks,porter) +2015-11-20 (bug)[40f628] ListObjReplace callers fail to detect max (porter) 2015-12-11 (bug)[c9eb6b] tolerate unset ::env(TZ) (gahr, nijtmans) 2016-01-29 (TIP 440) tcl_platform(engine) -- Tcl implementation (mistachkin) -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) - -2016-03-17 (enhancement)[1a25fd] compile [variable ${ns}::v] (porter) - -2016-03-20 (bug)[1af8de] crash in compiled [string replace] (harder,fellows) - -2016-03-21 (bug)[d30718] segv in notifier finalize (hirofumi,nijtmans) - -2016-03-23 (enhancement)[7d0db7] parallel make (yarda,nijtmans) - -2016-03-23 [f12535] enable test bindings customization (vogel,nijtmans) - -2016-04-04 (bug)[47ac84] compiled [lreplace] fixes (aspect,ferrieux,fellows) - *** POTENTIAL INCOMPATIBILITY *** - -2016-04-08 (bug)[866368] RE \w includes 'Punctuation Connector' (nijtmans) - -2016-04-08 (bug)[2538f3] Win crash Tcl_OpenTcpServer() (griffin) - -2016-04-10 [07d13d] Restore TclBlend support lost in 8.6.1 (buratti) - -2016-05-13 (bug)[3154ea] Mem corruption in assembler exceptions (tkob,kenny) - -2016-05-13 (bug) registry package support any Unicode env (nijtmans) -=> registry 1.3.2 - -2016-05-21 (bug)[f7d4e] [namespace delete] performance (fellows) - -2016-06-02 (TIP 447) execution time verbosity option (cerutti) -=> tcltest 2.4.0 - -2016-06-16 (bug)[16828b] crash due to [vwait] trace undo fail (dah,porter) - -2016-06-16 (enhancement)[4b61af] good [info frame] from more cases (beric) - -2016-06-21 (bug)[c383eb] crash in [glob -path a] (oehlmann,porter) - -2016-06-21 (update) Update Unicode data to 9.0 (nijtmans) - *** POTENTIAL INCOMPATIBILITY *** - -2016-06-22 (bug)[16896d] Tcl_DString tolerate append to self. (dah,porter) - -2016-06-23 (bug)[d55322] crash in [dict update] (yorick,fellows) - -2016-06-27 (bug)[dd260a] crash in [chan configure -dictionary] (madden,aspect) - -2016-07-02 (bug)[f961d7] usage message with parameters with spaces (porter) - *** POTENTIAL INCOMPATIBILITY *** - -2016-07-02 (enhancement)[09fabc] Sort order of -relateddir (lanam) - -2016-07-07 (bug)[5d7ca0] Win: [file executable] for .cmd and .ps1 (nadkarni) - *** POTENTIAL INCOMPATIBILITY *** - -2016-07-08 (bug)[a47641] [file normalize] & Windows junctions (nadkarni) - -2016-07-09 [ae61a6] [file] handling of Win hardcoded names (CON) (nadkarni) - *** POTENTIAL INCOMPATIBILITY *** - -2016-07-09 [3613671] [file owned] (more) useful on Win (nadkarni) - -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 *** - -2016-10-04 (bug)[4d5ae7] Crash in async connects host no address (gahr,fellows) - -2016-10-08 (bug)[838e99] treat application/xml as text (gahr,fellows) -=> http 2.8.10 - -2016-10-11 (bug)[3cc1d9] Thread finalization crash in zippy (neumann) - -2016-10-12 (bug)[be003d] Fix [scan 0x1 %b], [scan 0x1 %o] (porter) - -2016-10-14 (bug)[eb6b68] Fix stringComp-14.5 (porter) - -2016-10-30 (bug)[b26e38] Fix zlib-7.8 (fellows) - -2016-10-30 (bug)[1ae129] Fix memleak in [history] destruction (fellows) - -2016-11-04 (feature) Provisional Tcl 9 support in msgcat and tcltest (nijtmans) -=> msgcat 1.6.1 -=> tcltest 2.4.1 - -2016-11-04 (bug)[824752] Crash in Tcl_ListObjReplace() (gahr,porter) - -2016-11-11 (bug)[79614f] invalidate VFS mounts on sytem encoding change (yorick) - -2016-11-14 OSX: End panic() as legacy support macro; system conflicts (nijtmans) - *** POTENTIAL INCOMPATIBILITY *** - -2016-11-15 (bug) TclOO fix stops crash mixing Itcl and snit (fellows) - -2016-11-17 (update) Reconcile libtommath updates; purge unused files (nijtmans) - *** POTENTIAL INCOMPATIBILITY *** - -2017-01-09 (bug)[b87ad7] Repair drifts in timer clock (sebres) - -2017-01-17 (update) => zlib 1.2.11 (nijtmans) - -2017-01-31 (bug)[39f630] Revise Tcl_LinkVar to tolerate some prefixes (nijtmans) - *** POTENTIAL INCOMPATIBILITY *** - -2017-02-01 (bug)[d0f7ba] Improper NAN optimization. expr-22.1[01] (aspect) - -2017-02-26 (bug)[25842c] zlib stream finalization (aspect) - -2017-03-07 (deprecate) Remove unmaintained makefile.bc file (nijtmans) - *** POTENTIAL INCOMPATIBILITY *** - -2017-03-14 (enhancement) [clock] and [encoding] are now ensembles (kenny) - -2017-03-15 (enhancement) several [clock] subcommands bytecoded (kenny) - -2017-03-23 tzdata updated to Olson's tzdata2017b (jima) - -2017-03-29 (bug)[900cb0] Fix OO unexport introspection (napier) - -2017-04-12 (bug)[42202b] Nesting imbalance in coro injection (nadkarni,sebres) - -2017-04-18 (bug)[bc4322] http package support for safe interps (nash,nijtmans) - -2017-04-28 (bug)[f34cf8] [file join a //b] => /b (neumann,porter) - -2017-05-01 (bug)[8bd13f] Windows threads and pipes (sebres,nijtmans) - -2017-05-01 (bug)[f9fe90] [file join //a b] EIAS violation (aspect,porter) - -2017-05-04 (bug) Make test filesystem-1.52 pass on Windows (nijtmans) - -2017-05-05 (bug)[601522] [binary] field spec overflow -> segfault (porter) - -2017-05-08 (bug)[6ca52a] http memleak handling keep-alive (aspect,nijtmans) -=> http 2.8.11 - -2017-05-29 (bug)[a3fb33] crash in [lsort] on long lists (sebres) - -2017-06-05 (bug)[67aa9a] Tcl_UtfToUniChar() revised handling invalid UTF-8 (nijtmans) - *** POTENTIAL INCOMPATIBILITY *** - -2017-06-08 (bug)[2738427] Tcl_NumUtfChars() corner case utf-4.9 (nijtmans) - -2017-06-22 (update) Update Unicode data to 10.0 (nijtmans) - *** POTENTIAL INCOMPATIBILITY *** - -2017-06-22 (TIP 473) Let [oo::copy] specify target namespace (fellows) - -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) - -2017-08-31 (bug)[2a9465] http state 100 continue handling broken (oehlmann) -=> http 2.8.12 - -2017-09-02 (bug)[0e4d88] replace command, delete trace kills namespace (porter) - -2017-10-19 (bug)[1a5655] [info * methods] includes mixins (fellows) - -2017-10-23 tzdata updated to Olson's tzdata2017c (jima) - -2017-10-24 (bug)[fc1409] segfault in method cloning, oo-15.15 (coulter,fellows) - -2017-11-03 (bug)[6f2f83] More robust [load] for ReactOS (werner) - -2017-11-08 (bug)[3298012] Stop crash when hash tables overflow 32 bits (porter) - -2017-11-14 (bug)[5d6de6] Close failing case of [package prefer stable] (kupries) - -2017-11-17 (bug)[fab924] Fix misleading [load] message on Windows (oehlmann) - -2017-12-05 (bug)[4f6a1e] Crash when ensemble map and list are same (sebres) - -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) - -2018-02-14 (bug)[3c32a3] crash deleting object with class mixed in (coulter) - -2018-02-15 (platform) stop using -lieee, removed from glibc-2.27 (porter) -***POTENTIAL INCOMPATIBILITY for math programs that embed Tcl*** - -2018-02-23 (bug)[8e6a9a] bad binary [string match], test string-11.55 (porter) - -2018-03-05 (bug)[1873ea] repair multi-thread std channel init (sebres) - -2018-03-09 (bug)[db36fa] broken bytecode for index values (porter) - -2018-03-13 (bug) broken compiled [string replace], test string-14.19 (porter) - -2018-03-14 (bug) [string trim*] engine crashed on invalid UTF (sebres) - -2018-04-17 (bug) missing trace in compiled [array set], test var-20.11 (porter) - -2018-04-22 (bug)[46a241] crash in unset array with search, var-13.[23] (goth) - -2018-04-30 (bug)[27b682] race made [file delete] raise "no such file" (sebres) - -2018-06-04 (bug)[925643] 32/64 cleanup of filesystem DIR operations (sebres) - -2018-06-18 (bug) leaks in TclSetEnv and env cache (coulter) - -2018-06-24 (bug)[3592747] [yieldto] dying namespace, tailcall-14.1 (coulter) - -2018-07-09 (bug)[270f78] race in [file mkdir] (sebres) - -2018-07-12 (bug)[3f7af0] [file delete] raised "permission denied" (sebres) - -2018-07-26 (bug)[d051b7] overflow crash in [format] (sebres) - -2018-08-29 revised quoting of [exec] args in generated command line (sebres) -***POTENTIAL INCOMPATIBILITY*** - -2018-09-20 HTTP Keep-Alive with pipelined requests (nash) -=> http 2.9.0 - -2018-09-27 (new)[TIP 505] [lreplace] accepts all out of range indices (porter) - -2018-10-04 (bug) Prevent crash from NULL keyName (nijtmans) -=> registry 1.3.3 - -2018-10-26 (enhance) advance dde version (nijtmans) -=> dde 1.4.1 - -2018-10-27 tzdata updated to Olson's tzdata2018g (jima) - -2018-10-29 Update tcltest package for Travis support (fellows) -=> tcltest 2.5.0 - -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 9.0a1 include all changes to the 8.7 line through 8.7a3, -plus the following, which focuses on the high-level feature changes -in this changeset (new minor version) rather than bug fixes: - -2017-11-03 [TIP 114] Leading zero integer no longer means octal - -2017-11-03 [TIP 278] Revise variable name resolution, solve "Creative Writing" - -2017-11-03 [TIPs 330,336] Encapsulate struct Tcl_Interp - -2017-11-17 [TIP 422] Remove all Tcl_*VA() routines - -2017-12-15 [TIP 488] Disable magic $::tcl_precision - -2018-10-08 [TIP 494] Increased support for size_t value ranges - -2019-05-31 [TIP 537] 64-bit indices in regexp matching - -- Released 9.0a1, Nov 25, 2019 --- http://core.tcl-lang.org/tcl/ for details - +--- Released 8.5.19, February 12, 2016 --- https://core.tcl-lang.org/tcl/ for details DELETED compat/fake-rfc2553.c Index: compat/fake-rfc2553.c ================================================================== --- compat/fake-rfc2553.c +++ /dev/null @@ -1,267 +0,0 @@ -/* - * Copyright (C) 2000-2003 Damien Miller. All rights reserved. - * Copyright (C) 1999 WIDE Project. 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. Neither the name of the project nor the names of its contributors - * may be used to endorse or promote products derived from this software - * without specific prior written permission. - * - * THIS SOFTWARE IS PROVIDED BY THE PROJECT AND CONTRIBUTORS ``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 PROJECT OR CONTRIBUTORS 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. - */ - -/* - * Pseudo-implementation of RFC2553 name / address resolution functions - * - * But these functions are not implemented correctly. The minimum subset - * is implemented for ssh use only. For example, this routine assumes - * that ai_family is AF_INET. Don't use it for another purpose. - */ -#include "tclInt.h" - -TCL_DECLARE_MUTEX(netdbMutex) - -#ifndef HAVE_GETNAMEINFO -#ifndef HAVE_STRLCPY -static size_t -strlcpy(char *dst, const char *src, size_t siz) -{ - char *d = dst; - const char *s = src; - size_t n = siz; - - /* Copy as many bytes as will fit */ - if (n != 0 && --n != 0) { - do { - if ((*d++ = *s++) == 0) - break; - } while (--n != 0); - } - - /* Not enough room in dst, add NUL and traverse rest of src */ - if (n == 0) { - if (siz != 0) - *d = '\0'; /* NUL-terminate dst */ - while (*s++) - ; - } - - return(s - src - 1); /* count does not include NUL */ -} -#endif - -int fake_getnameinfo(const struct sockaddr *sa, size_t salen, char *host, - size_t hostlen, char *serv, size_t servlen, int flags) -{ - struct sockaddr_in *sin = (struct sockaddr_in *)sa; - struct hostent *hp; - char tmpserv[16]; - (void)salen; - - if (sa->sa_family != AF_UNSPEC && sa->sa_family != AF_INET) - return (EAI_FAMILY); - if (serv != NULL) { - snprintf(tmpserv, sizeof(tmpserv), "%d", ntohs(sin->sin_port)); - if (strlcpy(serv, tmpserv, servlen) >= servlen) - return (EAI_MEMORY); - } - - if (host != NULL) { - if (flags & NI_NUMERICHOST) { - size_t len; - Tcl_MutexLock(&netdbMutex); - len = strlcpy(host, inet_ntoa(sin->sin_addr), hostlen); - Tcl_MutexUnlock(&netdbMutex); - if (len >= hostlen) { - return (EAI_MEMORY); - } else { - return (0); - } - } else { - int ret; - Tcl_MutexLock(&netdbMutex); - hp = gethostbyaddr((char *)&sin->sin_addr, - sizeof(struct in_addr), AF_INET); - if (hp == NULL) { - ret = EAI_NODATA; - } else if (strlcpy(host, hp->h_name, hostlen) - >= hostlen) { - ret = EAI_MEMORY; - } else { - ret = 0; - } - Tcl_MutexUnlock(&netdbMutex); - return ret; - } - } - return (0); -} -#endif /* !HAVE_GETNAMEINFO */ - -#ifndef HAVE_GAI_STRERROR -const char * -fake_gai_strerror(int err) -{ - switch (err) { - case EAI_NODATA: - return ("no address associated with name"); - case EAI_MEMORY: - return ("memory allocation failure."); - case EAI_NONAME: - return ("nodename nor servname provided, or not known"); - case EAI_FAMILY: - return ("ai_family not supported"); - default: - return ("unknown/invalid error."); - } -} -#endif /* !HAVE_GAI_STRERROR */ - -#ifndef HAVE_FREEADDRINFO -void -fake_freeaddrinfo(struct addrinfo *ai) -{ - struct addrinfo *next; - - for(; ai != NULL;) { - next = ai->ai_next; - free(ai); - ai = next; - } -} -#endif /* !HAVE_FREEADDRINFO */ - -#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 */ - ai->ai_addrlen = sizeof(struct sockaddr_in); - ai->ai_addr->sa_family = ai->ai_family = AF_INET; - - ((struct sockaddr_in *)(ai)->ai_addr)->sin_port = port; - ((struct sockaddr_in *)(ai)->ai_addr)->sin_addr.s_addr = addr; - - /* XXX: the following is not generally correct, but does what we want */ - if (hints->ai_socktype) - ai->ai_socktype = hints->ai_socktype; - else - ai->ai_socktype = SOCK_STREAM; - - if (hints->ai_protocol) - ai->ai_protocol = hints->ai_protocol; - - return (ai); -} - -int -fake_getaddrinfo(const char *hostname, const char *servname, - const struct addrinfo *hints, struct addrinfo **res) -{ - struct hostent *hp; - struct servent *sp; - struct in_addr in; - int i; - long int port; - u_long addr; - - port = 0; - if (hints && hints->ai_family != AF_UNSPEC && - hints->ai_family != AF_INET) - return (EAI_FAMILY); - if (servname != NULL) { - char *cp; - - port = strtol(servname, &cp, 10); - if (port > 0 && port <= 65535 && *cp == '\0') - port = htons((unsigned short)port); - else if ((sp = getservbyname(servname, NULL)) != NULL) - port = sp->s_port; - else - port = 0; - } - - if (hints && hints->ai_flags & AI_PASSIVE) { - addr = htonl(0x00000000); - if (hostname && inet_aton(hostname, &in) != 0) - addr = in.s_addr; - *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); - if (*res == NULL) - return (EAI_MEMORY); - return (0); - } - - /* Don't try DNS if AI_NUMERICHOST is set */ - if (hints && hints->ai_flags & AI_NUMERICHOST) - return (EAI_NONAME); - - Tcl_MutexLock(&netdbMutex); - hp = gethostbyname(hostname); - if (hp && hp->h_name && hp->h_name[0] && hp->h_addr_list[0]) { - struct addrinfo *cur, *prev; - - cur = prev = *res = NULL; - for (i = 0; hp->h_addr_list[i]; i++) { - struct in_addr *in = (struct in_addr *)hp->h_addr_list[i]; - - cur = malloc_ai(port, in->s_addr, hints); - if (cur == NULL) { - if (*res != NULL) - freeaddrinfo(*res); - Tcl_MutexUnlock(&netdbMutex); - return (EAI_MEMORY); - } - if (prev) - prev->ai_next = cur; - else - *res = cur; - - prev = cur; - } - Tcl_MutexUnlock(&netdbMutex); - return (0); - } - Tcl_MutexUnlock(&netdbMutex); - return (EAI_NODATA); -} -#endif /* !HAVE_GETADDRINFO */ DELETED compat/fake-rfc2553.h Index: compat/fake-rfc2553.h ================================================================== --- compat/fake-rfc2553.h +++ /dev/null @@ -1,170 +0,0 @@ -/* - * Copyright (C) 2000-2003 Damien Miller. All rights reserved. - * Copyright (C) 1999 WIDE Project. 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. Neither the name of the project nor the names of its contributors - * may be used to endorse or promote products derived from this software - * without specific prior written permission. - * - * THIS SOFTWARE IS PROVIDED BY THE PROJECT AND CONTRIBUTORS ``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 PROJECT OR CONTRIBUTORS 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. - */ - -/* - * Pseudo-implementation of RFC2553 name / address resolution functions - * - * But these functions are not implemented correctly. The minimum subset - * is implemented for ssh use only. For example, this routine assumes - * that ai_family is AF_INET. Don't use it for another purpose. - */ - -#ifndef _FAKE_RFC2553_H -#define _FAKE_RFC2553_H - -/* - * First, socket and INET6 related definitions - */ -#ifndef HAVE_STRUCT_SOCKADDR_STORAGE -# define _SS_MAXSIZE 128 /* Implementation specific max size */ -# define _SS_PADSIZE (_SS_MAXSIZE - sizeof (struct sockaddr)) -struct sockaddr_storage { - struct sockaddr ss_sa; - char __ss_pad2[_SS_PADSIZE]; -}; -# define ss_family ss_sa.sa_family -#endif /* !HAVE_STRUCT_SOCKADDR_STORAGE */ - -#ifndef IN6_IS_ADDR_LOOPBACK -# define IN6_IS_ADDR_LOOPBACK(a) \ - (((uint32_t *)(a))[0] == 0 && ((uint32_t *)(a))[1] == 0 && \ - ((uint32_t *)(a))[2] == 0 && ((uint32_t *)(a))[3] == htonl(1)) -#endif /* !IN6_IS_ADDR_LOOPBACK */ - -#ifndef HAVE_STRUCT_IN6_ADDR -struct in6_addr { - uint8_t s6_addr[16]; -}; -#endif /* !HAVE_STRUCT_IN6_ADDR */ - -#ifndef HAVE_STRUCT_SOCKADDR_IN6 -struct sockaddr_in6 { - unsigned short sin6_family; - uint16_t sin6_port; - uint32_t sin6_flowinfo; - struct in6_addr sin6_addr; - uint32_t sin6_scope_id; -}; -#endif /* !HAVE_STRUCT_SOCKADDR_IN6 */ - -#ifndef AF_INET6 -/* Define it to something that should never appear */ -#define AF_INET6 AF_MAX -#endif - -/* - * Next, RFC2553 name / address resolution API - */ - -#ifndef NI_NUMERICHOST -# define NI_NUMERICHOST (1) -#endif -#ifndef NI_NAMEREQD -# define NI_NAMEREQD (1<<1) -#endif -#ifndef NI_NUMERICSERV -# define NI_NUMERICSERV (1<<2) -#endif - -#ifndef AI_PASSIVE -# define AI_PASSIVE (1) -#endif -#ifndef AI_CANONNAME -# define AI_CANONNAME (1<<1) -#endif -#ifndef AI_NUMERICHOST -# define AI_NUMERICHOST (1<<2) -#endif - -#ifndef NI_MAXSERV -# define NI_MAXSERV 32 -#endif /* !NI_MAXSERV */ -#ifndef NI_MAXHOST -# define NI_MAXHOST 1025 -#endif /* !NI_MAXHOST */ - -#ifndef EAI_NODATA -# define EAI_NODATA (INT_MAX - 1) -#endif -#ifndef EAI_MEMORY -# define EAI_MEMORY (INT_MAX - 2) -#endif -#ifndef EAI_NONAME -# define EAI_NONAME (INT_MAX - 3) -#endif -#ifndef EAI_SYSTEM -# define EAI_SYSTEM (INT_MAX - 4) -#endif -#ifndef EAI_FAMILY -# define EAI_FAMILY (INT_MAX - 5) -#endif -#ifndef EAI_SERVICE -# define EAI_SERVICE -8 /* SERVICE not supported for `ai_socktype'. */ -#endif - -#ifndef HAVE_STRUCT_ADDRINFO -struct addrinfo { - int ai_flags; /* AI_PASSIVE, AI_CANONNAME */ - int ai_family; /* PF_xxx */ - int ai_socktype; /* SOCK_xxx */ - int ai_protocol; /* 0 or IPPROTO_xxx for IPv4 and IPv6 */ - size_t ai_addrlen; /* length of ai_addr */ - char *ai_canonname; /* canonical name for hostname */ - struct sockaddr *ai_addr; /* binary address */ - struct addrinfo *ai_next; /* next structure in linked list */ -}; -#endif /* !HAVE_STRUCT_ADDRINFO */ - -#ifndef HAVE_GETADDRINFO -#ifdef getaddrinfo -# undef getaddrinfo -#endif -#define getaddrinfo(a,b,c,d) (fake_getaddrinfo(a,b,c,d)) -int getaddrinfo(const char *, const char *, - const struct addrinfo *, struct addrinfo **); -#endif /* !HAVE_GETADDRINFO */ - -#ifndef HAVE_GAI_STRERROR -#define gai_strerror(a) (fake_gai_strerror(a)) -const char *gai_strerror(int); -#endif /* !HAVE_GAI_STRERROR */ - -#ifndef HAVE_FREEADDRINFO -#define freeaddrinfo(a) (fake_freeaddrinfo(a)) -void freeaddrinfo(struct addrinfo *); -#endif /* !HAVE_FREEADDRINFO */ - -#ifndef HAVE_GETNAMEINFO -#define getnameinfo(a,b,c,d,e,f,g) (fake_getnameinfo(a,b,c,d,e,f,g)) -int getnameinfo(const struct sockaddr *, size_t, char *, size_t, - char *, size_t, int); -#endif /* !HAVE_GETNAMEINFO */ - - -#endif /* !_FAKE_RFC2553_H */ ADDED compat/fixstrtod.c Index: compat/fixstrtod.c ================================================================== --- /dev/null +++ compat/fixstrtod.c @@ -0,0 +1,36 @@ +/* + * fixstrtod.c -- + * + * Source code for the "fixstrtod" procedure. This procedure is + * used in place of strtod under Solaris 2.4, in order to fix + * a bug where the "end" pointer gets set incorrectly. + * + * 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 + +#undef strtod + +/* + * Declare strtod explicitly rather than including stdlib.h, since in + * somes systems (e.g. SunOS 4.1.4) stdlib.h doesn't declare strtod. + */ + +extern double strtod(char *, char **); + +double +fixstrtod( + char *string, + char **endPtr) +{ + double d; + d = strtod(string, endPtr); + if ((endPtr != NULL) && (*endPtr != string) && ((*endPtr)[-1] == 0)) { + *endPtr -= 1; + } + return d; +} ADDED compat/float.h Index: compat/float.h ================================================================== --- /dev/null +++ compat/float.h @@ -0,0 +1,14 @@ +/* + * float.h -- + * + * This is a dummy header file to #include in Tcl when there + * is no float.h in /usr/include. Right now this file is empty: + * Tcl contains #ifdefs to deal with the lack of definitions; + * all it needs is for the #include statement to work. + * + * Copyright (c) 1993 The Regents of the University of California. + * Copyright (c) 1994 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ ADDED compat/limits.h Index: compat/limits.h ================================================================== --- /dev/null +++ compat/limits.h @@ -0,0 +1,22 @@ +/* + * limits.h -- + * + * This is a dummy header file to #include in Tcl when there + * is no limits.h in /usr/include. There are only a few + * definitions here; also see tclPort.h, which already + * #defines some of the things here if they're not arleady + * defined. + * + * Copyright (c) 1991 The Regents of the University of California. + * Copyright (c) 1994 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#define LONG_MIN 0x80000000 +#define LONG_MAX 0x7fffffff +#define INT_MIN 0x80000000 +#define INT_MAX 0x7fffffff +#define SHRT_MIN 0x8000 +#define SHRT_MAX 0x7fff DELETED compat/mkstemp.c Index: compat/mkstemp.c ================================================================== --- compat/mkstemp.c +++ /dev/null @@ -1,79 +0,0 @@ -/* - * mkstemp.c -- - * - * Source code for the "mkstemp" library routine. - * - * 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. - */ - -#include -#include -#include -#include -#include - -/* - *---------------------------------------------------------------------- - * - * 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. - */ - - count = 10; - do { - /* - * Replace the X's in the original template with random alphanumeric - * digits. - */ - - for (b=a ; *b ; b++) { - float r = rand() / ((float) RAND_MAX); - - *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; -} Index: compat/opendir.c ================================================================== --- compat/opendir.c +++ compat/opendir.c @@ -26,11 +26,11 @@ myname = ((*name == '\0') ? "." : name); if ((fd = open(myname, 0, 0)) == -1) { return NULL; } - dirp = (DIR *) Tcl_Alloc(sizeof(DIR)); + dirp = (DIR *) ckalloc(sizeof(DIR)); if (dirp == NULL) { /* unreachable? */ close(fd); return NULL; } @@ -104,7 +104,7 @@ DIR *dirp) { close(dirp->dd_fd); dirp->dd_fd = -1; dirp->dd_loc = 0; - Tcl_Free(dirp); + ckfree(dirp); } DELETED compat/stdint.h Index: compat/stdint.h ================================================================== --- compat/stdint.h +++ /dev/null @@ -1,919 +0,0 @@ -/* 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 -#include -#include - -/* - * 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 -#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 -#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 -# 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 -#include -#include - -#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 Index: compat/stdlib.h ================================================================== --- compat/stdlib.h +++ compat/stdlib.h @@ -3,11 +3,11 @@ * * 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). + * all the procedures needed here (such as strtod). * * 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 @@ -27,9 +27,10 @@ extern char * getenv(const char *name); extern char * malloc(unsigned int numBytes); extern void qsort(void *base, int n, int size, int (*compar)( const void *element1, const void *element2)); extern char * realloc(char *ptr, unsigned int numBytes); +extern double strtod(const char *string, char **endPtr); extern long strtol(const char *string, char **endPtr, int base); extern unsigned long strtoul(const char *string, char **endPtr, int base); #endif /* _STDLIB */ Index: compat/string.h ================================================================== --- compat/string.h +++ compat/string.h @@ -19,19 +19,23 @@ * 4.0.2, so I'm trying sys/types.h now.... hopefully it exists everywhere) */ #include +#ifdef __APPLE__ extern void * memchr(const void *s, int c, size_t n); +#else +extern char * memchr(const void *s, int c, size_t n); +#endif extern int memcmp(const void *s1, const void *s2, size_t n); -extern void * memcpy(void *t, const void *f, size_t n); +extern char * memcpy(void *t, const void *f, size_t n); #ifdef NO_MEMMOVE #define memmove(d,s,n) (bcopy((s), (d), (n))) #else extern char * memmove(void *t, const void *f, size_t n); #endif -extern void * memset(void *s, int c, size_t n); +extern char * memset(void *s, int c, size_t n); extern int strcasecmp(const char *s1, const char *s2); extern char * strcat(char *dst, const char *src); extern char * strchr(const char *string, int c); extern int strcmp(const char *s1, const char *s2); ADDED compat/strtod.c Index: compat/strtod.c ================================================================== --- /dev/null +++ compat/strtod.c @@ -0,0 +1,252 @@ +/* + * strtod.c -- + * + * Source code for the "strtod" library procedure. + * + * Copyright (c) 1988-1993 The Regents of the University of California. + * Copyright (c) 1994 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclInt.h" +#include + +#ifndef TRUE +#define TRUE 1 +#define FALSE 0 +#endif +#ifndef NULL +#define NULL 0 +#endif + +static int maxExponent = 511; /* Largest possible base 10 exponent. Any + * exponent larger than this will already + * produce underflow or overflow, so there's + * no need to worry about additional digits. + */ +static double powersOf10[] = { /* Table giving binary powers of 10. Entry */ + 10., /* is 10^2^i. Used to convert decimal */ + 100., /* exponents into floating-point numbers. */ + 1.0e4, + 1.0e8, + 1.0e16, + 1.0e32, + 1.0e64, + 1.0e128, + 1.0e256 +}; + +/* + *---------------------------------------------------------------------- + * + * strtod -- + * + * This procedure converts a floating-point number from an ASCII + * decimal representation to internal double-precision format. + * + * Results: + * The return value is the double-precision floating-point + * representation of the characters in string. If endPtr isn't + * NULL, then *endPtr is filled in with the address of the + * next character after the last one that was part of the + * floating-point number. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +double +strtod( + const char *string, /* A decimal ASCII floating-point number, + * optionally preceded by white space. Must + * have form "-I.FE-X", where I is the integer + * part of the mantissa, F is the fractional + * part of the mantissa, and X is the + * exponent. Either of the signs may be "+", + * "-", or omitted. Either I or F may be + * omitted, or both. The decimal point isn't + * necessary unless F is present. The "E" may + * actually be an "e". E and X may both be + * omitted (but not just one). */ + char **endPtr) /* If non-NULL, store terminating character's + * address here. */ +{ + int sign, expSign = FALSE; + double fraction, dblExp, *d; + const char *p; + int c; + int exp = 0; /* Exponent read from "EX" field. */ + int fracExp = 0; /* Exponent that derives from the fractional + * part. Under normal circumstatnces, it is + * the negative of the number of digits in F. + * However, if I is very long, the last digits + * of I get dropped (otherwise a long I with a + * large negative exponent could cause an + * unnecessary overflow on I alone). In this + * case, fracExp is incremented one for each + * dropped digit. */ + int mantSize; /* Number of digits in mantissa. */ + int decPt; /* Number of mantissa digits BEFORE decimal + * point. */ + const char *pExp; /* Temporarily holds location of exponent in + * string. */ + + /* + * Strip off leading blanks and check for a sign. + */ + + p = string; + while (isspace(UCHAR(*p))) { + p += 1; + } + if (*p == '-') { + sign = TRUE; + p += 1; + } else { + if (*p == '+') { + p += 1; + } + sign = FALSE; + } + + /* + * Count the number of digits in the mantissa (including the decimal + * point), and also locate the decimal point. + */ + + decPt = -1; + for (mantSize = 0; ; mantSize += 1) + { + c = *p; + if (!isdigit(c)) { + if ((c != '.') || (decPt >= 0)) { + break; + } + decPt = mantSize; + } + p += 1; + } + + /* + * Now suck up the digits in the mantissa. Use two integers to collect 9 + * digits each (this is faster than using floating-point). If the mantissa + * has more than 18 digits, ignore the extras, since they can't affect the + * value anyway. + */ + + pExp = p; + p -= mantSize; + if (decPt < 0) { + decPt = mantSize; + } else { + mantSize -= 1; /* One of the digits was the point. */ + } + if (mantSize > 18) { + fracExp = decPt - 18; + mantSize = 18; + } else { + fracExp = decPt - mantSize; + } + if (mantSize == 0) { + fraction = 0.0; + p = string; + goto done; + } else { + int frac1, frac2; + + frac1 = 0; + for ( ; mantSize > 9; mantSize -= 1) { + c = *p; + p += 1; + if (c == '.') { + c = *p; + p += 1; + } + frac1 = 10*frac1 + (c - '0'); + } + frac2 = 0; + for (; mantSize > 0; mantSize -= 1) { + c = *p; + p += 1; + if (c == '.') { + c = *p; + p += 1; + } + frac2 = 10*frac2 + (c - '0'); + } + fraction = (1.0e9 * frac1) + frac2; + } + + /* + * Skim off the exponent. + */ + + p = pExp; + if ((*p == 'E') || (*p == 'e')) { + p += 1; + if (*p == '-') { + expSign = TRUE; + p += 1; + } else { + if (*p == '+') { + p += 1; + } + expSign = FALSE; + } + if (!isdigit(UCHAR(*p))) { + p = pExp; + goto done; + } + while (isdigit(UCHAR(*p))) { + exp = exp * 10 + (*p - '0'); + p += 1; + } + } + if (expSign) { + exp = fracExp - exp; + } else { + exp = fracExp + exp; + } + + /* + * Generate a floating-point number that represents the exponent. Do this + * by processing the exponent one bit at a time to combine many powers of + * 2 of 10. Then combine the exponent with the fraction. + */ + + if (exp < 0) { + expSign = TRUE; + exp = -exp; + } else { + expSign = FALSE; + } + if (exp > maxExponent) { + exp = maxExponent; + errno = ERANGE; + } + dblExp = 1.0; + for (d = powersOf10; exp != 0; exp >>= 1, d += 1) { + if (exp & 01) { + dblExp *= *d; + } + } + if (expSign) { + fraction /= dblExp; + } else { + fraction *= dblExp; + } + + done: + if (endPtr != NULL) { + *endPtr = (char *) p; + } + + if (sign) { + return -fraction; + } + return fraction; +} ADDED compat/unistd.h Index: compat/unistd.h ================================================================== --- /dev/null +++ compat/unistd.h @@ -0,0 +1,76 @@ +/* + * unistd.h -- + * + * Macros, constants and prototypes for Posix conformance. + * + * Copyright 1989 Regents of the University of California Permission to use, + * copy, modify, and distribute this software and its documentation for any + * purpose and without fee is hereby granted, provided that the above + * copyright notice appear in all copies. The University of California makes + * no representations about the suitability of this software for any purpose. + * It is provided "as is" without express or implied warranty. + */ + +#ifndef _UNISTD +#define _UNISTD + +#include + +#ifndef NULL +#define NULL 0 +#endif + +/* + * Strict POSIX stuff goes here. Extensions go down below, in the ifndef + * _POSIX_SOURCE section. + */ + +extern void _exit(int status); +extern int access(const char *path, int mode); +extern int chdir(const char *path); +extern int chown(const char *path, uid_t owner, gid_t group); +extern int close(int fd); +extern int dup(int oldfd); +extern int dup2(int oldfd, int newfd); +extern int execl(const char *path, ...); +extern int execle(const char *path, ...); +extern int execlp(const char *file, ...); +extern int execv(const char *path, char **argv); +extern int execve(const char *path, char **argv, char **envp); +extern int execvpw(const char *file, char **argv); +extern pid_t fork(void); +extern char * getcwd(char *buf, size_t size); +extern gid_t getegid(void); +extern uid_t geteuid(void); +extern gid_t getgid(void); +extern int getgroups(int bufSize, int *buffer); +extern pid_t getpid(void); +extern uid_t getuid(void); +extern int isatty(int fd); +extern long lseek(int fd, long offset, int whence); +extern int pipe(int *fildes); +extern int read(int fd, char *buf, size_t size); +extern int setgid(gid_t group); +extern int setuid(uid_t user); +extern unsigned sleep(unsigned seconds); +extern char * ttyname(int fd); +extern int unlink(const char *path); +extern int write(int fd, const char *buf, size_t size); + +#ifndef _POSIX_SOURCE +extern char * crypt(const char *, const char *); +extern int fchown(int fd, uid_t owner, gid_t group); +extern int flock(int fd, int operation); +extern int ftruncate(int fd, unsigned long length); +extern int ioctl(int fd, int request, ...); +extern int readlink(const char *path, char *buf, int bufsize); +extern int setegid(gid_t group); +extern int seteuidw(uid_t user); +extern int setreuid(int ruid, int euid); +extern int symlink(const char *, const char *); +extern int ttyslot(void); +extern int truncate(const char *path, unsigned long length); +extern int vfork(void); +#endif /* _POSIX_SOURCE */ + +#endif /* _UNISTD */ Index: compat/waitpid.c ================================================================== --- compat/waitpid.c +++ compat/waitpid.c @@ -98,11 +98,11 @@ if (prevPtr == NULL) { deadList = waitPtr->nextPtr; } else { prevPtr->nextPtr = waitPtr->nextPtr; } - Tcl_Free(waitPtr); + ckfree((char *) waitPtr); return result; } /* * Wait for any process to stop or exit. If it's an acceptable one then @@ -154,15 +154,15 @@ if (waitPtr->pid == result) { waitPtr->status = status; goto waitAgain; } } - waitPtr = (WaitInfo *) Tcl_Alloc(sizeof(WaitInfo)); + waitPtr = (WaitInfo *) ckalloc(sizeof(WaitInfo)); waitPtr->pid = result; waitPtr->status = status; waitPtr->nextPtr = deadList; deadList = waitPtr; waitAgain: continue; } } DELETED compat/zlib/CMakeLists.txt Index: compat/zlib/CMakeLists.txt ================================================================== --- compat/zlib/CMakeLists.txt +++ /dev/null @@ -1,249 +0,0 @@ -cmake_minimum_required(VERSION 2.4.4) -set(CMAKE_ALLOW_LOOSE_LOOP_CONSTRUCTS ON) - -project(zlib C) - -set(VERSION "1.2.11") - -option(ASM686 "Enable building i686 assembly implementation") -option(AMD64 "Enable building amd64 assembly implementation") - -set(INSTALL_BIN_DIR "${CMAKE_INSTALL_PREFIX}/bin" CACHE PATH "Installation directory for executables") -set(INSTALL_LIB_DIR "${CMAKE_INSTALL_PREFIX}/lib" CACHE PATH "Installation directory for libraries") -set(INSTALL_INC_DIR "${CMAKE_INSTALL_PREFIX}/include" CACHE PATH "Installation directory for headers") -set(INSTALL_MAN_DIR "${CMAKE_INSTALL_PREFIX}/share/man" CACHE PATH "Installation directory for manual pages") -set(INSTALL_PKGCONFIG_DIR "${CMAKE_INSTALL_PREFIX}/share/pkgconfig" CACHE PATH "Installation directory for pkgconfig (.pc) files") - -include(CheckTypeSize) -include(CheckFunctionExists) -include(CheckIncludeFile) -include(CheckCSourceCompiles) -enable_testing() - -check_include_file(sys/types.h HAVE_SYS_TYPES_H) -check_include_file(stdint.h HAVE_STDINT_H) -check_include_file(stddef.h HAVE_STDDEF_H) - -# -# Check to see if we have large file support -# -set(CMAKE_REQUIRED_DEFINITIONS -D_LARGEFILE64_SOURCE=1) -# We add these other definitions here because CheckTypeSize.cmake -# in CMake 2.4.x does not automatically do so and we want -# compatibility with CMake 2.4.x. -if(HAVE_SYS_TYPES_H) - list(APPEND CMAKE_REQUIRED_DEFINITIONS -DHAVE_SYS_TYPES_H) -endif() -if(HAVE_STDINT_H) - list(APPEND CMAKE_REQUIRED_DEFINITIONS -DHAVE_STDINT_H) -endif() -if(HAVE_STDDEF_H) - list(APPEND CMAKE_REQUIRED_DEFINITIONS -DHAVE_STDDEF_H) -endif() -check_type_size(off64_t OFF64_T) -if(HAVE_OFF64_T) - add_definitions(-D_LARGEFILE64_SOURCE=1) -endif() -set(CMAKE_REQUIRED_DEFINITIONS) # clear variable - -# -# Check for fseeko -# -check_function_exists(fseeko HAVE_FSEEKO) -if(NOT HAVE_FSEEKO) - add_definitions(-DNO_FSEEKO) -endif() - -# -# Check for unistd.h -# -check_include_file(unistd.h Z_HAVE_UNISTD_H) - -if(MSVC) - set(CMAKE_DEBUG_POSTFIX "d") - add_definitions(-D_CRT_SECURE_NO_DEPRECATE) - add_definitions(-D_CRT_NONSTDC_NO_DEPRECATE) - include_directories(${CMAKE_CURRENT_SOURCE_DIR}) -endif() - -if(NOT CMAKE_CURRENT_SOURCE_DIR STREQUAL CMAKE_CURRENT_BINARY_DIR) - # If we're doing an out of source build and the user has a zconf.h - # in their source tree... - if(EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/zconf.h) - message(STATUS "Renaming") - message(STATUS " ${CMAKE_CURRENT_SOURCE_DIR}/zconf.h") - message(STATUS "to 'zconf.h.included' because this file is included with zlib") - message(STATUS "but CMake generates it automatically in the build directory.") - file(RENAME ${CMAKE_CURRENT_SOURCE_DIR}/zconf.h ${CMAKE_CURRENT_SOURCE_DIR}/zconf.h.included) - endif() -endif() - -set(ZLIB_PC ${CMAKE_CURRENT_BINARY_DIR}/zlib.pc) -configure_file( ${CMAKE_CURRENT_SOURCE_DIR}/zlib.pc.cmakein - ${ZLIB_PC} @ONLY) -configure_file( ${CMAKE_CURRENT_SOURCE_DIR}/zconf.h.cmakein - ${CMAKE_CURRENT_BINARY_DIR}/zconf.h @ONLY) -include_directories(${CMAKE_CURRENT_BINARY_DIR} ${CMAKE_SOURCE_DIR}) - - -#============================================================================ -# zlib -#============================================================================ - -set(ZLIB_PUBLIC_HDRS - ${CMAKE_CURRENT_BINARY_DIR}/zconf.h - zlib.h -) -set(ZLIB_PRIVATE_HDRS - crc32.h - deflate.h - gzguts.h - inffast.h - inffixed.h - inflate.h - inftrees.h - trees.h - zutil.h -) -set(ZLIB_SRCS - adler32.c - compress.c - crc32.c - deflate.c - gzclose.c - gzlib.c - gzread.c - gzwrite.c - inflate.c - infback.c - inftrees.c - inffast.c - trees.c - uncompr.c - zutil.c -) - -if(NOT MINGW) - set(ZLIB_DLL_SRCS - win32/zlib1.rc # If present will override custom build rule below. - ) -endif() - -if(CMAKE_COMPILER_IS_GNUCC) - if(ASM686) - set(ZLIB_ASMS contrib/asm686/match.S) - elseif (AMD64) - set(ZLIB_ASMS contrib/amd64/amd64-match.S) - endif () - - if(ZLIB_ASMS) - add_definitions(-DASMV) - set_source_files_properties(${ZLIB_ASMS} PROPERTIES LANGUAGE C COMPILE_FLAGS -DNO_UNDERLINE) - endif() -endif() - -if(MSVC) - if(ASM686) - ENABLE_LANGUAGE(ASM_MASM) - set(ZLIB_ASMS - contrib/masmx86/inffas32.asm - contrib/masmx86/match686.asm - ) - elseif (AMD64) - ENABLE_LANGUAGE(ASM_MASM) - set(ZLIB_ASMS - contrib/masmx64/gvmat64.asm - contrib/masmx64/inffasx64.asm - ) - endif() - - if(ZLIB_ASMS) - add_definitions(-DASMV -DASMINF) - endif() -endif() - -# parse the full version number from zlib.h and include in ZLIB_FULL_VERSION -file(READ ${CMAKE_CURRENT_SOURCE_DIR}/zlib.h _zlib_h_contents) -string(REGEX REPLACE ".*#define[ \t]+ZLIB_VERSION[ \t]+\"([-0-9A-Za-z.]+)\".*" - "\\1" ZLIB_FULL_VERSION ${_zlib_h_contents}) - -if(MINGW) - # This gets us DLL resource information when compiling on MinGW. - if(NOT CMAKE_RC_COMPILER) - set(CMAKE_RC_COMPILER windres.exe) - endif() - - add_custom_command(OUTPUT ${CMAKE_CURRENT_BINARY_DIR}/zlib1rc.obj - COMMAND ${CMAKE_RC_COMPILER} - -D GCC_WINDRES - -I ${CMAKE_CURRENT_SOURCE_DIR} - -I ${CMAKE_CURRENT_BINARY_DIR} - -o ${CMAKE_CURRENT_BINARY_DIR}/zlib1rc.obj - -i ${CMAKE_CURRENT_SOURCE_DIR}/win32/zlib1.rc) - set(ZLIB_DLL_SRCS ${CMAKE_CURRENT_BINARY_DIR}/zlib1rc.obj) -endif(MINGW) - -add_library(zlib SHARED ${ZLIB_SRCS} ${ZLIB_ASMS} ${ZLIB_DLL_SRCS} ${ZLIB_PUBLIC_HDRS} ${ZLIB_PRIVATE_HDRS}) -add_library(zlibstatic STATIC ${ZLIB_SRCS} ${ZLIB_ASMS} ${ZLIB_PUBLIC_HDRS} ${ZLIB_PRIVATE_HDRS}) -set_target_properties(zlib PROPERTIES DEFINE_SYMBOL ZLIB_DLL) -set_target_properties(zlib PROPERTIES SOVERSION 1) - -if(NOT CYGWIN) - # This property causes shared libraries on Linux to have the full version - # encoded into their final filename. We disable this on Cygwin because - # it causes cygz-${ZLIB_FULL_VERSION}.dll to be created when cygz.dll - # seems to be the default. - # - # This has no effect with MSVC, on that platform the version info for - # the DLL comes from the resource file win32/zlib1.rc - set_target_properties(zlib PROPERTIES VERSION ${ZLIB_FULL_VERSION}) -endif() - -if(UNIX) - # On unix-like platforms the library is almost always called libz - set_target_properties(zlib zlibstatic PROPERTIES OUTPUT_NAME z) - if(NOT APPLE) - set_target_properties(zlib PROPERTIES LINK_FLAGS "-Wl,--version-script,\"${CMAKE_CURRENT_SOURCE_DIR}/zlib.map\"") - endif() -elseif(BUILD_SHARED_LIBS AND WIN32) - # Creates zlib1.dll when building shared library version - set_target_properties(zlib PROPERTIES SUFFIX "1.dll") -endif() - -if(NOT SKIP_INSTALL_LIBRARIES AND NOT SKIP_INSTALL_ALL ) - install(TARGETS zlib zlibstatic - RUNTIME DESTINATION "${INSTALL_BIN_DIR}" - ARCHIVE DESTINATION "${INSTALL_LIB_DIR}" - LIBRARY DESTINATION "${INSTALL_LIB_DIR}" ) -endif() -if(NOT SKIP_INSTALL_HEADERS AND NOT SKIP_INSTALL_ALL ) - install(FILES ${ZLIB_PUBLIC_HDRS} DESTINATION "${INSTALL_INC_DIR}") -endif() -if(NOT SKIP_INSTALL_FILES AND NOT SKIP_INSTALL_ALL ) - install(FILES zlib.3 DESTINATION "${INSTALL_MAN_DIR}/man3") -endif() -if(NOT SKIP_INSTALL_FILES AND NOT SKIP_INSTALL_ALL ) - install(FILES ${ZLIB_PC} DESTINATION "${INSTALL_PKGCONFIG_DIR}") -endif() - -#============================================================================ -# Example binaries -#============================================================================ - -add_executable(example test/example.c) -target_link_libraries(example zlib) -add_test(example example) - -add_executable(minigzip test/minigzip.c) -target_link_libraries(minigzip zlib) - -if(HAVE_OFF64_T) - add_executable(example64 test/example.c) - target_link_libraries(example64 zlib) - set_target_properties(example64 PROPERTIES COMPILE_FLAGS "-D_FILE_OFFSET_BITS=64") - add_test(example64 example64) - - add_executable(minigzip64 test/minigzip.c) - target_link_libraries(minigzip64 zlib) - set_target_properties(minigzip64 PROPERTIES COMPILE_FLAGS "-D_FILE_OFFSET_BITS=64") -endif() DELETED compat/zlib/ChangeLog Index: compat/zlib/ChangeLog ================================================================== --- compat/zlib/ChangeLog +++ /dev/null @@ -1,1515 +0,0 @@ - - ChangeLog file for zlib - -Changes in 1.2.11 (15 Jan 2017) -- Fix deflate stored bug when pulling last block from window -- Permit immediate deflateParams changes before any deflate input - -Changes in 1.2.10 (2 Jan 2017) -- Avoid warnings on snprintf() return value -- Fix bug in deflate_stored() for zero-length input -- Fix bug in gzwrite.c that produced corrupt gzip files -- Remove files to be installed before copying them in Makefile.in -- Add warnings when compiling with assembler code - -Changes in 1.2.9 (31 Dec 2016) -- Fix contrib/minizip to permit unzipping with desktop API [Zouzou] -- Improve contrib/blast to return unused bytes -- Assure that gzoffset() is correct when appending -- Improve compress() and uncompress() to support large lengths -- Fix bug in test/example.c where error code not saved -- Remedy Coverity warning [Randers-Pehrson] -- Improve speed of gzprintf() in transparent mode -- Fix inflateInit2() bug when windowBits is 16 or 32 -- Change DEBUG macro to ZLIB_DEBUG -- Avoid uninitialized access by gzclose_w() -- Allow building zlib outside of the source directory -- Fix bug that accepted invalid zlib header when windowBits is zero -- Fix gzseek() problem on MinGW due to buggy _lseeki64 there -- Loop on write() calls in gzwrite.c in case of non-blocking I/O -- Add --warn (-w) option to ./configure for more compiler warnings -- Reject a window size of 256 bytes if not using the zlib wrapper -- Fix bug when level 0 used with Z_HUFFMAN or Z_RLE -- Add --debug (-d) option to ./configure to define ZLIB_DEBUG -- Fix bugs in creating a very large gzip header -- Add uncompress2() function, which returns the input size used -- Assure that deflateParams() will not switch functions mid-block -- Dramatically speed up deflation for level 0 (storing) -- Add gzfread(), duplicating the interface of fread() -- Add gzfwrite(), duplicating the interface of fwrite() -- Add deflateGetDictionary() function -- Use snprintf() for later versions of Microsoft C -- Fix *Init macros to use z_ prefix when requested -- Replace as400 with os400 for OS/400 support [Monnerat] -- Add crc32_z() and adler32_z() functions with size_t lengths -- Update Visual Studio project files [AraHaan] - -Changes in 1.2.8 (28 Apr 2013) -- Update contrib/minizip/iowin32.c for Windows RT [Vollant] -- Do not force Z_CONST for C++ -- Clean up contrib/vstudio [Roß] -- Correct spelling error in zlib.h -- Fix mixed line endings in contrib/vstudio - -Changes in 1.2.7.3 (13 Apr 2013) -- Fix version numbers and DLL names in contrib/vstudio/*/zlib.rc - -Changes in 1.2.7.2 (13 Apr 2013) -- Change check for a four-byte type back to hexadecimal -- Fix typo in win32/Makefile.msc -- Add casts in gzwrite.c for pointer differences - -Changes in 1.2.7.1 (24 Mar 2013) -- Replace use of unsafe string functions with snprintf if available -- Avoid including stddef.h on Windows for Z_SOLO compile [Niessink] -- Fix gzgetc undefine when Z_PREFIX set [Turk] -- Eliminate use of mktemp in Makefile (not always available) -- Fix bug in 'F' mode for gzopen() -- Add inflateGetDictionary() function -- Correct comment in deflate.h -- Use _snprintf for snprintf in Microsoft C -- On Darwin, only use /usr/bin/libtool if libtool is not Apple -- Delete "--version" file if created by "ar --version" [Richard G.] -- Fix configure check for veracity of compiler error return codes -- Fix CMake compilation of static lib for MSVC2010 x64 -- Remove unused variable in infback9.c -- Fix argument checks in gzlog_compress() and gzlog_write() -- Clean up the usage of z_const and respect const usage within zlib -- Clean up examples/gzlog.[ch] comparisons of different types -- Avoid shift equal to bits in type (caused endless loop) -- Fix uninitialized value bug in gzputc() introduced by const patches -- Fix memory allocation error in examples/zran.c [Nor] -- Fix bug where gzopen(), gzclose() would write an empty file -- Fix bug in gzclose() when gzwrite() runs out of memory -- Check for input buffer malloc failure in examples/gzappend.c -- Add note to contrib/blast to use binary mode in stdio -- Fix comparisons of differently signed integers in contrib/blast -- Check for invalid code length codes in contrib/puff -- Fix serious but very rare decompression bug in inftrees.c -- Update inflateBack() comments, since inflate() can be faster -- Use underscored I/O function names for WINAPI_FAMILY -- Add _tr_flush_bits to the external symbols prefixed by --zprefix -- Add contrib/vstudio/vc10 pre-build step for static only -- Quote --version-script argument in CMakeLists.txt -- Don't specify --version-script on Apple platforms in CMakeLists.txt -- Fix casting error in contrib/testzlib/testzlib.c -- Fix types in contrib/minizip to match result of get_crc_table() -- Simplify contrib/vstudio/vc10 with 'd' suffix -- Add TOP support to win32/Makefile.msc -- Suport i686 and amd64 assembler builds in CMakeLists.txt -- Fix typos in the use of _LARGEFILE64_SOURCE in zconf.h -- Add vc11 and vc12 build files to contrib/vstudio -- Add gzvprintf() as an undocumented function in zlib -- Fix configure for Sun shell -- Remove runtime check in configure for four-byte integer type -- Add casts and consts to ease user conversion to C++ -- Add man pages for minizip and miniunzip -- In Makefile uninstall, don't rm if preceding cd fails -- Do not return Z_BUF_ERROR if deflateParam() has nothing to write - -Changes in 1.2.7 (2 May 2012) -- Replace use of memmove() with a simple copy for portability -- Test for existence of strerror -- Restore gzgetc_ for backward compatibility with 1.2.6 -- Fix build with non-GNU make on Solaris -- Require gcc 4.0 or later on Mac OS X to use the hidden attribute -- Include unistd.h for Watcom C -- Use __WATCOMC__ instead of __WATCOM__ -- Do not use the visibility attribute if NO_VIZ defined -- Improve the detection of no hidden visibility attribute -- Avoid using __int64 for gcc or solo compilation -- Cast to char * in gzprintf to avoid warnings [Zinser] -- Fix make_vms.com for VAX [Zinser] -- Don't use library or built-in byte swaps -- Simplify test and use of gcc hidden attribute -- Fix bug in gzclose_w() when gzwrite() fails to allocate memory -- Add "x" (O_EXCL) and "e" (O_CLOEXEC) modes support to gzopen() -- Fix bug in test/minigzip.c for configure --solo -- Fix contrib/vstudio project link errors [Mohanathas] -- Add ability to choose the builder in make_vms.com [Schweda] -- Add DESTDIR support to mingw32 win32/Makefile.gcc -- Fix comments in win32/Makefile.gcc for proper usage -- Allow overriding the default install locations for cmake -- Generate and install the pkg-config file with cmake -- Build both a static and a shared version of zlib with cmake -- Include version symbols for cmake builds -- If using cmake with MSVC, add the source directory to the includes -- Remove unneeded EXTRA_CFLAGS from win32/Makefile.gcc [Truta] -- Move obsolete emx makefile to old [Truta] -- Allow the use of -Wundef when compiling or using zlib -- Avoid the use of the -u option with mktemp -- Improve inflate() documentation on the use of Z_FINISH -- Recognize clang as gcc -- Add gzopen_w() in Windows for wide character path names -- Rename zconf.h in CMakeLists.txt to move it out of the way -- Add source directory in CMakeLists.txt for building examples -- Look in build directory for zlib.pc in CMakeLists.txt -- Remove gzflags from zlibvc.def in vc9 and vc10 -- Fix contrib/minizip compilation in the MinGW environment -- Update ./configure for Solaris, support --64 [Mooney] -- Remove -R. from Solaris shared build (possible security issue) -- Avoid race condition for parallel make (-j) running example -- Fix type mismatch between get_crc_table() and crc_table -- Fix parsing of version with "-" in CMakeLists.txt [Snider, Ziegler] -- Fix the path to zlib.map in CMakeLists.txt -- Force the native libtool in Mac OS X to avoid GNU libtool [Beebe] -- Add instructions to win32/Makefile.gcc for shared install [Torri] - -Changes in 1.2.6.1 (12 Feb 2012) -- Avoid the use of the Objective-C reserved name "id" -- Include io.h in gzguts.h for Microsoft compilers -- Fix problem with ./configure --prefix and gzgetc macro -- Include gz_header definition when compiling zlib solo -- Put gzflags() functionality back in zutil.c -- Avoid library header include in crc32.c for Z_SOLO -- Use name in GCC_CLASSIC as C compiler for coverage testing, if set -- Minor cleanup in contrib/minizip/zip.c [Vollant] -- Update make_vms.com [Zinser] -- Remove unnecessary gzgetc_ function -- Use optimized byte swap operations for Microsoft and GNU [Snyder] -- Fix minor typo in zlib.h comments [Rzesniowiecki] - -Changes in 1.2.6 (29 Jan 2012) -- Update the Pascal interface in contrib/pascal -- Fix function numbers for gzgetc_ in zlibvc.def files -- Fix configure.ac for contrib/minizip [Schiffer] -- Fix large-entry detection in minizip on 64-bit systems [Schiffer] -- Have ./configure use the compiler return code for error indication -- Fix CMakeLists.txt for cross compilation [McClure] -- Fix contrib/minizip/zip.c for 64-bit architectures [Dalsnes] -- Fix compilation of contrib/minizip on FreeBSD [Marquez] -- Correct suggested usages in win32/Makefile.msc [Shachar, Horvath] -- Include io.h for Turbo C / Borland C on all platforms [Truta] -- Make version explicit in contrib/minizip/configure.ac [Bosmans] -- Avoid warning for no encryption in contrib/minizip/zip.c [Vollant] -- Minor cleanup up contrib/minizip/unzip.c [Vollant] -- Fix bug when compiling minizip with C++ [Vollant] -- Protect for long name and extra fields in contrib/minizip [Vollant] -- Avoid some warnings in contrib/minizip [Vollant] -- Add -I../.. -L../.. to CFLAGS for minizip and miniunzip -- Add missing libs to minizip linker command -- Add support for VPATH builds in contrib/minizip -- Add an --enable-demos option to contrib/minizip/configure -- Add the generation of configure.log by ./configure -- Exit when required parameters not provided to win32/Makefile.gcc -- Have gzputc return the character written instead of the argument -- Use the -m option on ldconfig for BSD systems [Tobias] -- Correct in zlib.map when deflateResetKeep was added - -Changes in 1.2.5.3 (15 Jan 2012) -- Restore gzgetc function for binary compatibility -- Do not use _lseeki64 under Borland C++ [Truta] -- Update win32/Makefile.msc to build test/*.c [Truta] -- Remove old/visualc6 given CMakefile and other alternatives -- Update AS400 build files and documentation [Monnerat] -- Update win32/Makefile.gcc to build test/*.c [Truta] -- Permit stronger flushes after Z_BLOCK flushes -- Avoid extraneous empty blocks when doing empty flushes -- Permit Z_NULL arguments to deflatePending -- Allow deflatePrime() to insert bits in the middle of a stream -- Remove second empty static block for Z_PARTIAL_FLUSH -- Write out all of the available bits when using Z_BLOCK -- Insert the first two strings in the hash table after a flush - -Changes in 1.2.5.2 (17 Dec 2011) -- fix ld error: unable to find version dependency 'ZLIB_1.2.5' -- use relative symlinks for shared libs -- Avoid searching past window for Z_RLE strategy -- Assure that high-water mark initialization is always applied in deflate -- Add assertions to fill_window() in deflate.c to match comments -- Update python link in README -- Correct spelling error in gzread.c -- Fix bug in gzgets() for a concatenated empty gzip stream -- Correct error in comment for gz_make() -- Change gzread() and related to ignore junk after gzip streams -- Allow gzread() and related to continue after gzclearerr() -- Allow gzrewind() and gzseek() after a premature end-of-file -- Simplify gzseek() now that raw after gzip is ignored -- Change gzgetc() to a macro for speed (~40% speedup in testing) -- Fix gzclose() to return the actual error last encountered -- Always add large file support for windows -- Include zconf.h for windows large file support -- Include zconf.h.cmakein for windows large file support -- Update zconf.h.cmakein on make distclean -- Merge vestigial vsnprintf determination from zutil.h to gzguts.h -- Clarify how gzopen() appends in zlib.h comments -- Correct documentation of gzdirect() since junk at end now ignored -- Add a transparent write mode to gzopen() when 'T' is in the mode -- Update python link in zlib man page -- Get inffixed.h and MAKEFIXED result to match -- Add a ./config --solo option to make zlib subset with no library use -- Add undocumented inflateResetKeep() function for CAB file decoding -- Add --cover option to ./configure for gcc coverage testing -- Add #define ZLIB_CONST option to use const in the z_stream interface -- Add comment to gzdopen() in zlib.h to use dup() when using fileno() -- Note behavior of uncompress() to provide as much data as it can -- Add files in contrib/minizip to aid in building libminizip -- Split off AR options in Makefile.in and configure -- Change ON macro to Z_ARG to avoid application conflicts -- Facilitate compilation with Borland C++ for pragmas and vsnprintf -- Include io.h for Turbo C / Borland C++ -- Move example.c and minigzip.c to test/ -- Simplify incomplete code table filling in inflate_table() -- Remove code from inflate.c and infback.c that is impossible to execute -- Test the inflate code with full coverage -- Allow deflateSetDictionary, inflateSetDictionary at any time (in raw) -- Add deflateResetKeep and fix inflateResetKeep to retain dictionary -- Fix gzwrite.c to accommodate reduced memory zlib compilation -- Have inflate() with Z_FINISH avoid the allocation of a window -- Do not set strm->adler when doing raw inflate -- Fix gzeof() to behave just like feof() when read is not past end of file -- Fix bug in gzread.c when end-of-file is reached -- Avoid use of Z_BUF_ERROR in gz* functions except for premature EOF -- Document gzread() capability to read concurrently written files -- Remove hard-coding of resource compiler in CMakeLists.txt [Blammo] - -Changes in 1.2.5.1 (10 Sep 2011) -- Update FAQ entry on shared builds (#13) -- Avoid symbolic argument to chmod in Makefile.in -- Fix bug and add consts in contrib/puff [Oberhumer] -- Update contrib/puff/zeros.raw test file to have all block types -- Add full coverage test for puff in contrib/puff/Makefile -- Fix static-only-build install in Makefile.in -- Fix bug in unzGetCurrentFileInfo() in contrib/minizip [Kuno] -- Add libz.a dependency to shared in Makefile.in for parallel builds -- Spell out "number" (instead of "nb") in zlib.h for total_in, total_out -- Replace $(...) with `...` in configure for non-bash sh [Bowler] -- Add darwin* to Darwin* and solaris* to SunOS\ 5* in configure [Groffen] -- Add solaris* to Linux* in configure to allow gcc use [Groffen] -- Add *bsd* to Linux* case in configure [Bar-Lev] -- Add inffast.obj to dependencies in win32/Makefile.msc -- Correct spelling error in deflate.h [Kohler] -- Change libzdll.a again to libz.dll.a (!) in win32/Makefile.gcc -- Add test to configure for GNU C looking for gcc in output of $cc -v -- Add zlib.pc generation to win32/Makefile.gcc [Weigelt] -- Fix bug in zlib.h for _FILE_OFFSET_BITS set and _LARGEFILE64_SOURCE not -- Add comment in zlib.h that adler32_combine with len2 < 0 makes no sense -- Make NO_DIVIDE option in adler32.c much faster (thanks to John Reiser) -- Make stronger test in zconf.h to include unistd.h for LFS -- Apply Darwin patches for 64-bit file offsets to contrib/minizip [Slack] -- Fix zlib.h LFS support when Z_PREFIX used -- Add updated as400 support (removed from old) [Monnerat] -- Avoid deflate sensitivity to volatile input data -- Avoid division in adler32_combine for NO_DIVIDE -- Clarify the use of Z_FINISH with deflateBound() amount of space -- Set binary for output file in puff.c -- Use u4 type for crc_table to avoid conversion warnings -- Apply casts in zlib.h to avoid conversion warnings -- Add OF to prototypes for adler32_combine_ and crc32_combine_ [Miller] -- Improve inflateSync() documentation to note indeterminancy -- Add deflatePending() function to return the amount of pending output -- Correct the spelling of "specification" in FAQ [Randers-Pehrson] -- Add a check in configure for stdarg.h, use for gzprintf() -- Check that pointers fit in ints when gzprint() compiled old style -- Add dummy name before $(SHAREDLIBV) in Makefile [Bar-Lev, Bowler] -- Delete line in configure that adds -L. libz.a to LDFLAGS [Weigelt] -- Add debug records in assmebler code [Londer] -- Update RFC references to use http://tools.ietf.org/html/... [Li] -- Add --archs option, use of libtool to configure for Mac OS X [Borstel] - -Changes in 1.2.5 (19 Apr 2010) -- Disable visibility attribute in win32/Makefile.gcc [Bar-Lev] -- Default to libdir as sharedlibdir in configure [Nieder] -- Update copyright dates on modified source files -- Update trees.c to be able to generate modified trees.h -- Exit configure for MinGW, suggesting win32/Makefile.gcc -- Check for NULL path in gz_open [Homurlu] - -Changes in 1.2.4.5 (18 Apr 2010) -- Set sharedlibdir in configure [Torok] -- Set LDFLAGS in Makefile.in [Bar-Lev] -- Avoid mkdir objs race condition in Makefile.in [Bowler] -- Add ZLIB_INTERNAL in front of internal inter-module functions and arrays -- Define ZLIB_INTERNAL to hide internal functions and arrays for GNU C -- Don't use hidden attribute when it is a warning generator (e.g. Solaris) - -Changes in 1.2.4.4 (18 Apr 2010) -- Fix CROSS_PREFIX executable testing, CHOST extract, mingw* [Torok] -- Undefine _LARGEFILE64_SOURCE in zconf.h if it is zero, but not if empty -- Try to use bash or ksh regardless of functionality of /bin/sh -- Fix configure incompatibility with NetBSD sh -- Remove attempt to run under bash or ksh since have better NetBSD fix -- Fix win32/Makefile.gcc for MinGW [Bar-Lev] -- Add diagnostic messages when using CROSS_PREFIX in configure -- Added --sharedlibdir option to configure [Weigelt] -- Use hidden visibility attribute when available [Frysinger] - -Changes in 1.2.4.3 (10 Apr 2010) -- Only use CROSS_PREFIX in configure for ar and ranlib if they exist -- Use CROSS_PREFIX for nm [Bar-Lev] -- Assume _LARGEFILE64_SOURCE defined is equivalent to true -- Avoid use of undefined symbols in #if with && and || -- Make *64 prototypes in gzguts.h consistent with functions -- Add -shared load option for MinGW in configure [Bowler] -- Move z_off64_t to public interface, use instead of off64_t -- Remove ! from shell test in configure (not portable to Solaris) -- Change +0 macro tests to -0 for possibly increased portability - -Changes in 1.2.4.2 (9 Apr 2010) -- Add consistent carriage returns to readme.txt's in masmx86 and masmx64 -- Really provide prototypes for *64 functions when building without LFS -- Only define unlink() in minigzip.c if unistd.h not included -- Update README to point to contrib/vstudio project files -- Move projects/vc6 to old/ and remove projects/ -- Include stdlib.h in minigzip.c for setmode() definition under WinCE -- Clean up assembler builds in win32/Makefile.msc [Rowe] -- Include sys/types.h for Microsoft for off_t definition -- Fix memory leak on error in gz_open() -- Symbolize nm as $NM in configure [Weigelt] -- Use TEST_LDSHARED instead of LDSHARED to link test programs [Weigelt] -- Add +0 to _FILE_OFFSET_BITS and _LFS64_LARGEFILE in case not defined -- Fix bug in gzeof() to take into account unused input data -- Avoid initialization of structures with variables in puff.c -- Updated win32/README-WIN32.txt [Rowe] - -Changes in 1.2.4.1 (28 Mar 2010) -- Remove the use of [a-z] constructs for sed in configure [gentoo 310225] -- Remove $(SHAREDLIB) from LIBS in Makefile.in [Creech] -- Restore "for debugging" comment on sprintf() in gzlib.c -- Remove fdopen for MVS from gzguts.h -- Put new README-WIN32.txt in win32 [Rowe] -- Add check for shell to configure and invoke another shell if needed -- Fix big fat stinking bug in gzseek() on uncompressed files -- Remove vestigial F_OPEN64 define in zutil.h -- Set and check the value of _LARGEFILE_SOURCE and _LARGEFILE64_SOURCE -- Avoid errors on non-LFS systems when applications define LFS macros -- Set EXE to ".exe" in configure for MINGW [Kahle] -- Match crc32() in crc32.c exactly to the prototype in zlib.h [Sherrill] -- Add prefix for cross-compilation in win32/makefile.gcc [Bar-Lev] -- Add DLL install in win32/makefile.gcc [Bar-Lev] -- Allow Linux* or linux* from uname in configure [Bar-Lev] -- Allow ldconfig to be redefined in configure and Makefile.in [Bar-Lev] -- Add cross-compilation prefixes to configure [Bar-Lev] -- Match type exactly in gz_load() invocation in gzread.c -- Match type exactly of zcalloc() in zutil.c to zlib.h alloc_func -- Provide prototypes for *64 functions when building zlib without LFS -- Don't use -lc when linking shared library on MinGW -- Remove errno.h check in configure and vestigial errno code in zutil.h - -Changes in 1.2.4 (14 Mar 2010) -- Fix VER3 extraction in configure for no fourth subversion -- Update zlib.3, add docs to Makefile.in to make .pdf out of it -- Add zlib.3.pdf to distribution -- Don't set error code in gzerror() if passed pointer is NULL -- Apply destination directory fixes to CMakeLists.txt [Lowman] -- Move #cmakedefine's to a new zconf.in.cmakein -- Restore zconf.h for builds that don't use configure or cmake -- Add distclean to dummy Makefile for convenience -- Update and improve INDEX, README, and FAQ -- Update CMakeLists.txt for the return of zconf.h [Lowman] -- Update contrib/vstudio/vc9 and vc10 [Vollant] -- Change libz.dll.a back to libzdll.a in win32/Makefile.gcc -- Apply license and readme changes to contrib/asm686 [Raiter] -- Check file name lengths and add -c option in minigzip.c [Li] -- Update contrib/amd64 and contrib/masmx86/ [Vollant] -- Avoid use of "eof" parameter in trees.c to not shadow library variable -- Update make_vms.com for removal of zlibdefs.h [Zinser] -- Update assembler code and vstudio projects in contrib [Vollant] -- Remove outdated assembler code contrib/masm686 and contrib/asm586 -- Remove old vc7 and vc8 from contrib/vstudio -- Update win32/Makefile.msc, add ZLIB_VER_SUBREVISION [Rowe] -- Fix memory leaks in gzclose_r() and gzclose_w(), file leak in gz_open() -- Add contrib/gcc_gvmat64 for longest_match and inflate_fast [Vollant] -- Remove *64 functions from win32/zlib.def (they're not 64-bit yet) -- Fix bug in void-returning vsprintf() case in gzwrite.c -- Fix name change from inflate.h in contrib/inflate86/inffas86.c -- Check if temporary file exists before removing in make_vms.com [Zinser] -- Fix make install and uninstall for --static option -- Fix usage of _MSC_VER in gzguts.h and zutil.h [Truta] -- Update readme.txt in contrib/masmx64 and masmx86 to assemble - -Changes in 1.2.3.9 (21 Feb 2010) -- Expunge gzio.c -- Move as400 build information to old -- Fix updates in contrib/minizip and contrib/vstudio -- Add const to vsnprintf test in configure to avoid warnings [Weigelt] -- Delete zconf.h (made by configure) [Weigelt] -- Change zconf.in.h to zconf.h.in per convention [Weigelt] -- Check for NULL buf in gzgets() -- Return empty string for gzgets() with len == 1 (like fgets()) -- Fix description of gzgets() in zlib.h for end-of-file, NULL return -- Update minizip to 1.1 [Vollant] -- Avoid MSVC loss of data warnings in gzread.c, gzwrite.c -- Note in zlib.h that gzerror() should be used to distinguish from EOF -- Remove use of snprintf() from gzlib.c -- Fix bug in gzseek() -- Update contrib/vstudio, adding vc9 and vc10 [Kuno, Vollant] -- Fix zconf.h generation in CMakeLists.txt [Lowman] -- Improve comments in zconf.h where modified by configure - -Changes in 1.2.3.8 (13 Feb 2010) -- Clean up text files (tabs, trailing whitespace, etc.) [Oberhumer] -- Use z_off64_t in gz_zero() and gz_skip() to match state->skip -- Avoid comparison problem when sizeof(int) == sizeof(z_off64_t) -- Revert to Makefile.in from 1.2.3.6 (live with the clutter) -- Fix missing error return in gzflush(), add zlib.h note -- Add *64 functions to zlib.map [Levin] -- Fix signed/unsigned comparison in gz_comp() -- Use SFLAGS when testing shared linking in configure -- Add --64 option to ./configure to use -m64 with gcc -- Fix ./configure --help to correctly name options -- Have make fail if a test fails [Levin] -- Avoid buffer overrun in contrib/masmx64/gvmat64.asm [Simpson] -- Remove assembler object files from contrib - -Changes in 1.2.3.7 (24 Jan 2010) -- Always gzopen() with O_LARGEFILE if available -- Fix gzdirect() to work immediately after gzopen() or gzdopen() -- Make gzdirect() more precise when the state changes while reading -- Improve zlib.h documentation in many places -- Catch memory allocation failure in gz_open() -- Complete close operation if seek forward in gzclose_w() fails -- Return Z_ERRNO from gzclose_r() if close() fails -- Return Z_STREAM_ERROR instead of EOF for gzclose() being passed NULL -- Return zero for gzwrite() errors to match zlib.h description -- Return -1 on gzputs() error to match zlib.h description -- Add zconf.in.h to allow recovery from configure modification [Weigelt] -- Fix static library permissions in Makefile.in [Weigelt] -- Avoid warnings in configure tests that hide functionality [Weigelt] -- Add *BSD and DragonFly to Linux case in configure [gentoo 123571] -- Change libzdll.a to libz.dll.a in win32/Makefile.gcc [gentoo 288212] -- Avoid access of uninitialized data for first inflateReset2 call [Gomes] -- Keep object files in subdirectories to reduce the clutter somewhat -- Remove default Makefile and zlibdefs.h, add dummy Makefile -- Add new external functions to Z_PREFIX, remove duplicates, z_z_ -> z_ -- Remove zlibdefs.h completely -- modify zconf.h instead - -Changes in 1.2.3.6 (17 Jan 2010) -- Avoid void * arithmetic in gzread.c and gzwrite.c -- Make compilers happier with const char * for gz_error message -- Avoid unused parameter warning in inflate.c -- Avoid signed-unsigned comparison warning in inflate.c -- Indent #pragma's for traditional C -- Fix usage of strwinerror() in glib.c, change to gz_strwinerror() -- Correct email address in configure for system options -- Update make_vms.com and add make_vms.com to contrib/minizip [Zinser] -- Update zlib.map [Brown] -- Fix Makefile.in for Solaris 10 make of example64 and minizip64 [Torok] -- Apply various fixes to CMakeLists.txt [Lowman] -- Add checks on len in gzread() and gzwrite() -- Add error message for no more room for gzungetc() -- Remove zlib version check in gzwrite() -- Defer compression of gzprintf() result until need to -- Use snprintf() in gzdopen() if available -- Remove USE_MMAP configuration determination (only used by minigzip) -- Remove examples/pigz.c (available separately) -- Update examples/gun.c to 1.6 - -Changes in 1.2.3.5 (8 Jan 2010) -- Add space after #if in zutil.h for some compilers -- Fix relatively harmless bug in deflate_fast() [Exarevsky] -- Fix same problem in deflate_slow() -- Add $(SHAREDLIBV) to LIBS in Makefile.in [Brown] -- Add deflate_rle() for faster Z_RLE strategy run-length encoding -- Add deflate_huff() for faster Z_HUFFMAN_ONLY encoding -- Change name of "write" variable in inffast.c to avoid library collisions -- Fix premature EOF from gzread() in gzio.c [Brown] -- Use zlib header window size if windowBits is 0 in inflateInit2() -- Remove compressBound() call in deflate.c to avoid linking compress.o -- Replace use of errno in gz* with functions, support WinCE [Alves] -- Provide alternative to perror() in minigzip.c for WinCE [Alves] -- Don't use _vsnprintf on later versions of MSVC [Lowman] -- Add CMake build script and input file [Lowman] -- Update contrib/minizip to 1.1 [Svensson, Vollant] -- Moved nintendods directory from contrib to . -- Replace gzio.c with a new set of routines with the same functionality -- Add gzbuffer(), gzoffset(), gzclose_r(), gzclose_w() as part of above -- Update contrib/minizip to 1.1b -- Change gzeof() to return 0 on error instead of -1 to agree with zlib.h - -Changes in 1.2.3.4 (21 Dec 2009) -- Use old school .SUFFIXES in Makefile.in for FreeBSD compatibility -- Update comments in configure and Makefile.in for default --shared -- Fix test -z's in configure [Marquess] -- Build examplesh and minigzipsh when not testing -- Change NULL's to Z_NULL's in deflate.c and in comments in zlib.h -- Import LDFLAGS from the environment in configure -- Fix configure to populate SFLAGS with discovered CFLAGS options -- Adapt make_vms.com to the new Makefile.in [Zinser] -- Add zlib2ansi script for C++ compilation [Marquess] -- Add _FILE_OFFSET_BITS=64 test to make test (when applicable) -- Add AMD64 assembler code for longest match to contrib [Teterin] -- Include options from $SFLAGS when doing $LDSHARED -- Simplify 64-bit file support by introducing z_off64_t type -- Make shared object files in objs directory to work around old Sun cc -- Use only three-part version number for Darwin shared compiles -- Add rc option to ar in Makefile.in for when ./configure not run -- Add -WI,-rpath,. to LDFLAGS for OSF 1 V4* -- Set LD_LIBRARYN32_PATH for SGI IRIX shared compile -- Protect against _FILE_OFFSET_BITS being defined when compiling zlib -- Rename Makefile.in targets allstatic to static and allshared to shared -- Fix static and shared Makefile.in targets to be independent -- Correct error return bug in gz_open() by setting state [Brown] -- Put spaces before ;;'s in configure for better sh compatibility -- Add pigz.c (parallel implementation of gzip) to examples/ -- Correct constant in crc32.c to UL [Leventhal] -- Reject negative lengths in crc32_combine() -- Add inflateReset2() function to work like inflateEnd()/inflateInit2() -- Include sys/types.h for _LARGEFILE64_SOURCE [Brown] -- Correct typo in doc/algorithm.txt [Janik] -- Fix bug in adler32_combine() [Zhu] -- Catch missing-end-of-block-code error in all inflates and in puff - Assures that random input to inflate eventually results in an error -- Added enough.c (calculation of ENOUGH for inftrees.h) to examples/ -- Update ENOUGH and its usage to reflect discovered bounds -- Fix gzerror() error report on empty input file [Brown] -- Add ush casts in trees.c to avoid pedantic runtime errors -- Fix typo in zlib.h uncompress() description [Reiss] -- Correct inflate() comments with regard to automatic header detection -- Remove deprecation comment on Z_PARTIAL_FLUSH (it stays) -- Put new version of gzlog (2.0) in examples with interruption recovery -- Add puff compile option to permit invalid distance-too-far streams -- Add puff TEST command options, ability to read piped input -- Prototype the *64 functions in zlib.h when _FILE_OFFSET_BITS == 64, but - _LARGEFILE64_SOURCE not defined -- Fix Z_FULL_FLUSH to truly erase the past by resetting s->strstart -- Fix deflateSetDictionary() to use all 32K for output consistency -- Remove extraneous #define MIN_LOOKAHEAD in deflate.c (in deflate.h) -- Clear bytes after deflate lookahead to avoid use of uninitialized data -- Change a limit in inftrees.c to be more transparent to Coverity Prevent -- Update win32/zlib.def with exported symbols from zlib.h -- Correct spelling errors in zlib.h [Willem, Sobrado] -- Allow Z_BLOCK for deflate() to force a new block -- Allow negative bits in inflatePrime() to delete existing bit buffer -- Add Z_TREES flush option to inflate() to return at end of trees -- Add inflateMark() to return current state information for random access -- Add Makefile for NintendoDS to contrib [Costa] -- Add -w in configure compile tests to avoid spurious warnings [Beucler] -- Fix typos in zlib.h comments for deflateSetDictionary() -- Fix EOF detection in transparent gzread() [Maier] - -Changes in 1.2.3.3 (2 October 2006) -- Make --shared the default for configure, add a --static option -- Add compile option to permit invalid distance-too-far streams -- Add inflateUndermine() function which is required to enable above -- Remove use of "this" variable name for C++ compatibility [Marquess] -- Add testing of shared library in make test, if shared library built -- Use ftello() and fseeko() if available instead of ftell() and fseek() -- Provide two versions of all functions that use the z_off_t type for - binary compatibility -- a normal version and a 64-bit offset version, - per the Large File Support Extension when _LARGEFILE64_SOURCE is - defined; use the 64-bit versions by default when _FILE_OFFSET_BITS - is defined to be 64 -- Add a --uname= option to configure to perhaps help with cross-compiling - -Changes in 1.2.3.2 (3 September 2006) -- Turn off silly Borland warnings [Hay] -- Use off64_t and define _LARGEFILE64_SOURCE when present -- Fix missing dependency on inffixed.h in Makefile.in -- Rig configure --shared to build both shared and static [Teredesai, Truta] -- Remove zconf.in.h and instead create a new zlibdefs.h file -- Fix contrib/minizip/unzip.c non-encrypted after encrypted [Vollant] -- Add treebuild.xml (see http://treebuild.metux.de/) [Weigelt] - -Changes in 1.2.3.1 (16 August 2006) -- Add watcom directory with OpenWatcom make files [Daniel] -- Remove #undef of FAR in zconf.in.h for MVS [Fedtke] -- Update make_vms.com [Zinser] -- Use -fPIC for shared build in configure [Teredesai, Nicholson] -- Use only major version number for libz.so on IRIX and OSF1 [Reinholdtsen] -- Use fdopen() (not _fdopen()) for Interix in zutil.h [Bäck] -- Add some FAQ entries about the contrib directory -- Update the MVS question in the FAQ -- Avoid extraneous reads after EOF in gzio.c [Brown] -- Correct spelling of "successfully" in gzio.c [Randers-Pehrson] -- Add comments to zlib.h about gzerror() usage [Brown] -- Set extra flags in gzip header in gzopen() like deflate() does -- Make configure options more compatible with double-dash conventions - [Weigelt] -- Clean up compilation under Solaris SunStudio cc [Rowe, Reinholdtsen] -- Fix uninstall target in Makefile.in [Truta] -- Add pkgconfig support [Weigelt] -- Use $(DESTDIR) macro in Makefile.in [Reinholdtsen, Weigelt] -- Replace set_data_type() with a more accurate detect_data_type() in - trees.c, according to the txtvsbin.txt document [Truta] -- Swap the order of #include and #include "zlib.h" in - gzio.c, example.c and minigzip.c [Truta] -- Shut up annoying VS2005 warnings about standard C deprecation [Rowe, - Truta] (where?) -- Fix target "clean" from win32/Makefile.bor [Truta] -- Create .pdb and .manifest files in win32/makefile.msc [Ziegler, Rowe] -- Update zlib www home address in win32/DLL_FAQ.txt [Truta] -- Update contrib/masmx86/inffas32.asm for VS2005 [Vollant, Van Wassenhove] -- Enable browse info in the "Debug" and "ASM Debug" configurations in - the Visual C++ 6 project, and set (non-ASM) "Debug" as default [Truta] -- Add pkgconfig support [Weigelt] -- Add ZLIB_VER_MAJOR, ZLIB_VER_MINOR and ZLIB_VER_REVISION in zlib.h, - for use in win32/zlib1.rc [Polushin, Rowe, Truta] -- Add a document that explains the new text detection scheme to - doc/txtvsbin.txt [Truta] -- Add rfc1950.txt, rfc1951.txt and rfc1952.txt to doc/ [Truta] -- Move algorithm.txt into doc/ [Truta] -- Synchronize FAQ with website -- Fix compressBound(), was low for some pathological cases [Fearnley] -- Take into account wrapper variations in deflateBound() -- Set examples/zpipe.c input and output to binary mode for Windows -- Update examples/zlib_how.html with new zpipe.c (also web site) -- Fix some warnings in examples/gzlog.c and examples/zran.c (it seems - that gcc became pickier in 4.0) -- Add zlib.map for Linux: "All symbols from zlib-1.1.4 remain - un-versioned, the patch adds versioning only for symbols introduced in - zlib-1.2.0 or later. It also declares as local those symbols which are - not designed to be exported." [Levin] -- Update Z_PREFIX list in zconf.in.h, add --zprefix option to configure -- Do not initialize global static by default in trees.c, add a response - NO_INIT_GLOBAL_POINTERS to initialize them if needed [Marquess] -- Don't use strerror() in gzio.c under WinCE [Yakimov] -- Don't use errno.h in zutil.h under WinCE [Yakimov] -- Move arguments for AR to its usage to allow replacing ar [Marot] -- Add HAVE_VISIBILITY_PRAGMA in zconf.in.h for Mozilla [Randers-Pehrson] -- Improve inflateInit() and inflateInit2() documentation -- Fix structure size comment in inflate.h -- Change configure help option from --h* to --help [Santos] - -Changes in 1.2.3 (18 July 2005) -- Apply security vulnerability fixes to contrib/infback9 as well -- Clean up some text files (carriage returns, trailing space) -- Update testzlib, vstudio, masmx64, and masmx86 in contrib [Vollant] - -Changes in 1.2.2.4 (11 July 2005) -- Add inflatePrime() function for starting inflation at bit boundary -- Avoid some Visual C warnings in deflate.c -- Avoid more silly Visual C warnings in inflate.c and inftrees.c for 64-bit - compile -- Fix some spelling errors in comments [Betts] -- Correct inflateInit2() error return documentation in zlib.h -- Add zran.c example of compressed data random access to examples - directory, shows use of inflatePrime() -- Fix cast for assignments to strm->state in inflate.c and infback.c -- Fix zlibCompileFlags() in zutil.c to use 1L for long shifts [Oberhumer] -- Move declarations of gf2 functions to right place in crc32.c [Oberhumer] -- Add cast in trees.c t avoid a warning [Oberhumer] -- Avoid some warnings in fitblk.c, gun.c, gzjoin.c in examples [Oberhumer] -- Update make_vms.com [Zinser] -- Initialize state->write in inflateReset() since copied in inflate_fast() -- Be more strict on incomplete code sets in inflate_table() and increase - ENOUGH and MAXD -- this repairs a possible security vulnerability for - invalid inflate input. Thanks to Tavis Ormandy and Markus Oberhumer for - discovering the vulnerability and providing test cases. -- Add ia64 support to configure for HP-UX [Smith] -- Add error return to gzread() for format or i/o error [Levin] -- Use malloc.h for OS/2 [Necasek] - -Changes in 1.2.2.3 (27 May 2005) -- Replace 1U constants in inflate.c and inftrees.c for 64-bit compile -- Typecast fread() return values in gzio.c [Vollant] -- Remove trailing space in minigzip.c outmode (VC++ can't deal with it) -- Fix crc check bug in gzread() after gzungetc() [Heiner] -- Add the deflateTune() function to adjust internal compression parameters -- Add a fast gzip decompressor, gun.c, to examples (use of inflateBack) -- Remove an incorrect assertion in examples/zpipe.c -- Add C++ wrapper in infback9.h [Donais] -- Fix bug in inflateCopy() when decoding fixed codes -- Note in zlib.h how much deflateSetDictionary() actually uses -- Remove USE_DICT_HEAD in deflate.c (would mess up inflate if used) -- Add _WIN32_WCE to define WIN32 in zconf.in.h [Spencer] -- Don't include stderr.h or errno.h for _WIN32_WCE in zutil.h [Spencer] -- Add gzdirect() function to indicate transparent reads -- Update contrib/minizip [Vollant] -- Fix compilation of deflate.c when both ASMV and FASTEST [Oberhumer] -- Add casts in crc32.c to avoid warnings [Oberhumer] -- Add contrib/masmx64 [Vollant] -- Update contrib/asm586, asm686, masmx86, testzlib, vstudio [Vollant] - -Changes in 1.2.2.2 (30 December 2004) -- Replace structure assignments in deflate.c and inflate.c with zmemcpy to - avoid implicit memcpy calls (portability for no-library compilation) -- Increase sprintf() buffer size in gzdopen() to allow for large numbers -- Add INFLATE_STRICT to check distances against zlib header -- Improve WinCE errno handling and comments [Chang] -- Remove comment about no gzip header processing in FAQ -- Add Z_FIXED strategy option to deflateInit2() to force fixed trees -- Add updated make_vms.com [Coghlan], update README -- Create a new "examples" directory, move gzappend.c there, add zpipe.c, - fitblk.c, gzlog.[ch], gzjoin.c, and zlib_how.html. -- Add FAQ entry and comments in deflate.c on uninitialized memory access -- Add Solaris 9 make options in configure [Gilbert] -- Allow strerror() usage in gzio.c for STDC -- Fix DecompressBuf in contrib/delphi/ZLib.pas [ManChesTer] -- Update contrib/masmx86/inffas32.asm and gvmat32.asm [Vollant] -- Use z_off_t for adler32_combine() and crc32_combine() lengths -- Make adler32() much faster for small len -- Use OS_CODE in deflate() default gzip header - -Changes in 1.2.2.1 (31 October 2004) -- Allow inflateSetDictionary() call for raw inflate -- Fix inflate header crc check bug for file names and comments -- Add deflateSetHeader() and gz_header structure for custom gzip headers -- Add inflateGetheader() to retrieve gzip headers -- Add crc32_combine() and adler32_combine() functions -- Add alloc_func, free_func, in_func, out_func to Z_PREFIX list -- Use zstreamp consistently in zlib.h (inflate_back functions) -- Remove GUNZIP condition from definition of inflate_mode in inflate.h - and in contrib/inflate86/inffast.S [Truta, Anderson] -- Add support for AMD64 in contrib/inflate86/inffas86.c [Anderson] -- Update projects/README.projects and projects/visualc6 [Truta] -- Update win32/DLL_FAQ.txt [Truta] -- Avoid warning under NO_GZCOMPRESS in gzio.c; fix typo [Truta] -- Deprecate Z_ASCII; use Z_TEXT instead [Truta] -- Use a new algorithm for setting strm->data_type in trees.c [Truta] -- Do not define an exit() prototype in zutil.c unless DEBUG defined -- Remove prototype of exit() from zutil.c, example.c, minigzip.c [Truta] -- Add comment in zlib.h for Z_NO_FLUSH parameter to deflate() -- Fix Darwin build version identification [Peterson] - -Changes in 1.2.2 (3 October 2004) -- Update zlib.h comments on gzip in-memory processing -- Set adler to 1 in inflateReset() to support Java test suite [Walles] -- Add contrib/dotzlib [Ravn] -- Update win32/DLL_FAQ.txt [Truta] -- Update contrib/minizip [Vollant] -- Move contrib/visual-basic.txt to old/ [Truta] -- Fix assembler builds in projects/visualc6/ [Truta] - -Changes in 1.2.1.2 (9 September 2004) -- Update INDEX file -- Fix trees.c to update strm->data_type (no one ever noticed!) -- Fix bug in error case in inflate.c, infback.c, and infback9.c [Brown] -- Add "volatile" to crc table flag declaration (for DYNAMIC_CRC_TABLE) -- Add limited multitasking protection to DYNAMIC_CRC_TABLE -- Add NO_vsnprintf for VMS in zutil.h [Mozilla] -- Don't declare strerror() under VMS [Mozilla] -- Add comment to DYNAMIC_CRC_TABLE to use get_crc_table() to initialize -- Update contrib/ada [Anisimkov] -- Update contrib/minizip [Vollant] -- Fix configure to not hardcode directories for Darwin [Peterson] -- Fix gzio.c to not return error on empty files [Brown] -- Fix indentation; update version in contrib/delphi/ZLib.pas and - contrib/pascal/zlibpas.pas [Truta] -- Update mkasm.bat in contrib/masmx86 [Truta] -- Update contrib/untgz [Truta] -- Add projects/README.projects [Truta] -- Add project for MS Visual C++ 6.0 in projects/visualc6 [Cadieux, Truta] -- Update win32/DLL_FAQ.txt [Truta] -- Update list of Z_PREFIX symbols in zconf.h [Randers-Pehrson, Truta] -- Remove an unnecessary assignment to curr in inftrees.c [Truta] -- Add OS/2 to exe builds in configure [Poltorak] -- Remove err dummy parameter in zlib.h [Kientzle] - -Changes in 1.2.1.1 (9 January 2004) -- Update email address in README -- Several FAQ updates -- Fix a big fat bug in inftrees.c that prevented decoding valid - dynamic blocks with only literals and no distance codes -- - Thanks to "Hot Emu" for the bug report and sample file -- Add a note to puff.c on no distance codes case. - -Changes in 1.2.1 (17 November 2003) -- Remove a tab in contrib/gzappend/gzappend.c -- Update some interfaces in contrib for new zlib functions -- Update zlib version number in some contrib entries -- Add Windows CE definition for ptrdiff_t in zutil.h [Mai, Truta] -- Support shared libraries on Hurd and KFreeBSD [Brown] -- Fix error in NO_DIVIDE option of adler32.c - -Changes in 1.2.0.8 (4 November 2003) -- Update version in contrib/delphi/ZLib.pas and contrib/pascal/zlibpas.pas -- Add experimental NO_DIVIDE #define in adler32.c - - Possibly faster on some processors (let me know if it is) -- Correct Z_BLOCK to not return on first inflate call if no wrap -- Fix strm->data_type on inflate() return to correctly indicate EOB -- Add deflatePrime() function for appending in the middle of a byte -- Add contrib/gzappend for an example of appending to a stream -- Update win32/DLL_FAQ.txt [Truta] -- Delete Turbo C comment in README [Truta] -- Improve some indentation in zconf.h [Truta] -- Fix infinite loop on bad input in configure script [Church] -- Fix gzeof() for concatenated gzip files [Johnson] -- Add example to contrib/visual-basic.txt [Michael B.] -- Add -p to mkdir's in Makefile.in [vda] -- Fix configure to properly detect presence or lack of printf functions -- Add AS400 support [Monnerat] -- Add a little Cygwin support [Wilson] - -Changes in 1.2.0.7 (21 September 2003) -- Correct some debug formats in contrib/infback9 -- Cast a type in a debug statement in trees.c -- Change search and replace delimiter in configure from % to # [Beebe] -- Update contrib/untgz to 0.2 with various fixes [Truta] -- Add build support for Amiga [Nikl] -- Remove some directories in old that have been updated to 1.2 -- Add dylib building for Mac OS X in configure and Makefile.in -- Remove old distribution stuff from Makefile -- Update README to point to DLL_FAQ.txt, and add comment on Mac OS X -- Update links in README - -Changes in 1.2.0.6 (13 September 2003) -- Minor FAQ updates -- Update contrib/minizip to 1.00 [Vollant] -- Remove test of gz functions in example.c when GZ_COMPRESS defined [Truta] -- Update POSTINC comment for 68060 [Nikl] -- Add contrib/infback9 with deflate64 decoding (unsupported) -- For MVS define NO_vsnprintf and undefine FAR [van Burik] -- Add pragma for fdopen on MVS [van Burik] - -Changes in 1.2.0.5 (8 September 2003) -- Add OF to inflateBackEnd() declaration in zlib.h -- Remember start when using gzdopen in the middle of a file -- Use internal off_t counters in gz* functions to properly handle seeks -- Perform more rigorous check for distance-too-far in inffast.c -- Add Z_BLOCK flush option to return from inflate at block boundary -- Set strm->data_type on return from inflate - - Indicate bits unused, if at block boundary, and if in last block -- Replace size_t with ptrdiff_t in crc32.c, and check for correct size -- Add condition so old NO_DEFLATE define still works for compatibility -- FAQ update regarding the Windows DLL [Truta] -- INDEX update: add qnx entry, remove aix entry [Truta] -- Install zlib.3 into mandir [Wilson] -- Move contrib/zlib_dll_FAQ.txt to win32/DLL_FAQ.txt; update [Truta] -- Adapt the zlib interface to the new DLL convention guidelines [Truta] -- Introduce ZLIB_WINAPI macro to allow the export of functions using - the WINAPI calling convention, for Visual Basic [Vollant, Truta] -- Update msdos and win32 scripts and makefiles [Truta] -- Export symbols by name, not by ordinal, in win32/zlib.def [Truta] -- Add contrib/ada [Anisimkov] -- Move asm files from contrib/vstudio/vc70_32 to contrib/asm386 [Truta] -- Rename contrib/asm386 to contrib/masmx86 [Truta, Vollant] -- Add contrib/masm686 [Truta] -- Fix offsets in contrib/inflate86 and contrib/masmx86/inffas32.asm - [Truta, Vollant] -- Update contrib/delphi; rename to contrib/pascal; add example [Truta] -- Remove contrib/delphi2; add a new contrib/delphi [Truta] -- Avoid inclusion of the nonstandard in contrib/iostream, - and fix some method prototypes [Truta] -- Fix the ZCR_SEED2 constant to avoid warnings in contrib/minizip - [Truta] -- Avoid the use of backslash (\) in contrib/minizip [Vollant] -- Fix file time handling in contrib/untgz; update makefiles [Truta] -- Update contrib/vstudio/vc70_32 to comply with the new DLL guidelines - [Vollant] -- Remove contrib/vstudio/vc15_16 [Vollant] -- Rename contrib/vstudio/vc70_32 to contrib/vstudio/vc7 [Truta] -- Update README.contrib [Truta] -- Invert the assignment order of match_head and s->prev[...] in - INSERT_STRING [Truta] -- Compare TOO_FAR with 32767 instead of 32768, to avoid 16-bit warnings - [Truta] -- Compare function pointers with 0, not with NULL or Z_NULL [Truta] -- Fix prototype of syncsearch in inflate.c [Truta] -- Introduce ASMINF macro to be enabled when using an ASM implementation - of inflate_fast [Truta] -- Change NO_DEFLATE to NO_GZCOMPRESS [Truta] -- Modify test_gzio in example.c to take a single file name as a - parameter [Truta] -- Exit the example.c program if gzopen fails [Truta] -- Add type casts around strlen in example.c [Truta] -- Remove casting to sizeof in minigzip.c; give a proper type - to the variable compared with SUFFIX_LEN [Truta] -- Update definitions of STDC and STDC99 in zconf.h [Truta] -- Synchronize zconf.h with the new Windows DLL interface [Truta] -- Use SYS16BIT instead of __32BIT__ to distinguish between - 16- and 32-bit platforms [Truta] -- Use far memory allocators in small 16-bit memory models for - Turbo C [Truta] -- Add info about the use of ASMV, ASMINF and ZLIB_WINAPI in - zlibCompileFlags [Truta] -- Cygwin has vsnprintf [Wilson] -- In Windows16, OS_CODE is 0, as in MSDOS [Truta] -- In Cygwin, OS_CODE is 3 (Unix), not 11 (Windows32) [Wilson] - -Changes in 1.2.0.4 (10 August 2003) -- Minor FAQ updates -- Be more strict when checking inflateInit2's windowBits parameter -- Change NO_GUNZIP compile option to NO_GZIP to cover deflate as well -- Add gzip wrapper option to deflateInit2 using windowBits -- Add updated QNX rule in configure and qnx directory [Bonnefoy] -- Make inflate distance-too-far checks more rigorous -- Clean up FAR usage in inflate -- Add casting to sizeof() in gzio.c and minigzip.c - -Changes in 1.2.0.3 (19 July 2003) -- Fix silly error in gzungetc() implementation [Vollant] -- Update contrib/minizip and contrib/vstudio [Vollant] -- Fix printf format in example.c -- Correct cdecl support in zconf.in.h [Anisimkov] -- Minor FAQ updates - -Changes in 1.2.0.2 (13 July 2003) -- Add ZLIB_VERNUM in zlib.h for numerical preprocessor comparisons -- Attempt to avoid warnings in crc32.c for pointer-int conversion -- Add AIX to configure, remove aix directory [Bakker] -- Add some casts to minigzip.c -- Improve checking after insecure sprintf() or vsprintf() calls -- Remove #elif's from crc32.c -- Change leave label to inf_leave in inflate.c and infback.c to avoid - library conflicts -- Remove inflate gzip decoding by default--only enable gzip decoding by - special request for stricter backward compatibility -- Add zlibCompileFlags() function to return compilation information -- More typecasting in deflate.c to avoid warnings -- Remove leading underscore from _Capital #defines [Truta] -- Fix configure to link shared library when testing -- Add some Windows CE target adjustments [Mai] -- Remove #define ZLIB_DLL in zconf.h [Vollant] -- Add zlib.3 [Rodgers] -- Update RFC URL in deflate.c and algorithm.txt [Mai] -- Add zlib_dll_FAQ.txt to contrib [Truta] -- Add UL to some constants [Truta] -- Update minizip and vstudio [Vollant] -- Remove vestigial NEED_DUMMY_RETURN from zconf.in.h -- Expand use of NO_DUMMY_DECL to avoid all dummy structures -- Added iostream3 to contrib [Schwardt] -- Replace rewind() with fseek() for WinCE [Truta] -- Improve setting of zlib format compression level flags - - Report 0 for huffman and rle strategies and for level == 0 or 1 - - Report 2 only for level == 6 -- Only deal with 64K limit when necessary at compile time [Truta] -- Allow TOO_FAR check to be turned off at compile time [Truta] -- Add gzclearerr() function [Souza] -- Add gzungetc() function - -Changes in 1.2.0.1 (17 March 2003) -- Add Z_RLE strategy for run-length encoding [Truta] - - When Z_RLE requested, restrict matches to distance one - - Update zlib.h, minigzip.c, gzopen(), gzdopen() for Z_RLE -- Correct FASTEST compilation to allow level == 0 -- Clean up what gets compiled for FASTEST -- Incorporate changes to zconf.in.h [Vollant] - - Refine detection of Turbo C need for dummy returns - - Refine ZLIB_DLL compilation - - Include additional header file on VMS for off_t typedef -- Try to use _vsnprintf where it supplants vsprintf [Vollant] -- Add some casts in inffast.c -- Enchance comments in zlib.h on what happens if gzprintf() tries to - write more than 4095 bytes before compression -- Remove unused state from inflateBackEnd() -- Remove exit(0) from minigzip.c, example.c -- Get rid of all those darn tabs -- Add "check" target to Makefile.in that does the same thing as "test" -- Add "mostlyclean" and "maintainer-clean" targets to Makefile.in -- Update contrib/inflate86 [Anderson] -- Update contrib/testzlib, contrib/vstudio, contrib/minizip [Vollant] -- Add msdos and win32 directories with makefiles [Truta] -- More additions and improvements to the FAQ - -Changes in 1.2.0 (9 March 2003) -- New and improved inflate code - - About 20% faster - - Does not allocate 32K window unless and until needed - - Automatically detects and decompresses gzip streams - - Raw inflate no longer needs an extra dummy byte at end - - Added inflateBack functions using a callback interface--even faster - than inflate, useful for file utilities (gzip, zip) - - Added inflateCopy() function to record state for random access on - externally generated deflate streams (e.g. in gzip files) - - More readable code (I hope) -- New and improved crc32() - - About 50% faster, thanks to suggestions from Rodney Brown -- Add deflateBound() and compressBound() functions -- Fix memory leak in deflateInit2() -- Permit setting dictionary for raw deflate (for parallel deflate) -- Fix const declaration for gzwrite() -- Check for some malloc() failures in gzio.c -- Fix bug in gzopen() on single-byte file 0x1f -- Fix bug in gzread() on concatenated file with 0x1f at end of buffer - and next buffer doesn't start with 0x8b -- Fix uncompress() to return Z_DATA_ERROR on truncated input -- Free memory at end of example.c -- Remove MAX #define in trees.c (conflicted with some libraries) -- Fix static const's in deflate.c, gzio.c, and zutil.[ch] -- Declare malloc() and free() in gzio.c if STDC not defined -- Use malloc() instead of calloc() in zutil.c if int big enough -- Define STDC for AIX -- Add aix/ with approach for compiling shared library on AIX -- Add HP-UX support for shared libraries in configure -- Add OpenUNIX support for shared libraries in configure -- Use $cc instead of gcc to build shared library -- Make prefix directory if needed when installing -- Correct Macintosh avoidance of typedef Byte in zconf.h -- Correct Turbo C memory allocation when under Linux -- Use libz.a instead of -lz in Makefile (assure use of compiled library) -- Update configure to check for snprintf or vsnprintf functions and their - return value, warn during make if using an insecure function -- Fix configure problem with compile-time knowledge of HAVE_UNISTD_H that - is lost when library is used--resolution is to build new zconf.h -- Documentation improvements (in zlib.h): - - Document raw deflate and inflate - - Update RFCs URL - - Point out that zlib and gzip formats are different - - Note that Z_BUF_ERROR is not fatal - - Document string limit for gzprintf() and possible buffer overflow - - Note requirement on avail_out when flushing - - Note permitted values of flush parameter of inflate() -- Add some FAQs (and even answers) to the FAQ -- Add contrib/inflate86/ for x86 faster inflate -- Add contrib/blast/ for PKWare Data Compression Library decompression -- Add contrib/puff/ simple inflate for deflate format description - -Changes in 1.1.4 (11 March 2002) -- ZFREE was repeated on same allocation on some error conditions. - This creates a security problem described in - http://www.zlib.org/advisory-2002-03-11.txt -- Returned incorrect error (Z_MEM_ERROR) on some invalid data -- Avoid accesses before window for invalid distances with inflate window - less than 32K. -- force windowBits > 8 to avoid a bug in the encoder for a window size - of 256 bytes. (A complete fix will be available in 1.1.5). - -Changes in 1.1.3 (9 July 1998) -- fix "an inflate input buffer bug that shows up on rare but persistent - occasions" (Mark) -- fix gzread and gztell for concatenated .gz files (Didier Le Botlan) -- fix gzseek(..., SEEK_SET) in write mode -- fix crc check after a gzeek (Frank Faubert) -- fix miniunzip when the last entry in a zip file is itself a zip file - (J Lillge) -- add contrib/asm586 and contrib/asm686 (Brian Raiter) - See http://www.muppetlabs.com/~breadbox/software/assembly.html -- add support for Delphi 3 in contrib/delphi (Bob Dellaca) -- add support for C++Builder 3 and Delphi 3 in contrib/delphi2 (Davide Moretti) -- do not exit prematurely in untgz if 0 at start of block (Magnus Holmgren) -- use macro EXTERN instead of extern to support DLL for BeOS (Sander Stoks) -- added a FAQ file - -- Support gzdopen on Mac with Metrowerks (Jason Linhart) -- Do not redefine Byte on Mac (Brad Pettit & Jason Linhart) -- define SEEK_END too if SEEK_SET is not defined (Albert Chin-A-Young) -- avoid some warnings with Borland C (Tom Tanner) -- fix a problem in contrib/minizip/zip.c for 16-bit MSDOS (Gilles Vollant) -- emulate utime() for WIN32 in contrib/untgz (Gilles Vollant) -- allow several arguments to configure (Tim Mooney, Frodo Looijaard) -- use libdir and includedir in Makefile.in (Tim Mooney) -- support shared libraries on OSF1 V4 (Tim Mooney) -- remove so_locations in "make clean" (Tim Mooney) -- fix maketree.c compilation error (Glenn, Mark) -- Python interface to zlib now in Python 1.5 (Jeremy Hylton) -- new Makefile.riscos (Rich Walker) -- initialize static descriptors in trees.c for embedded targets (Nick Smith) -- use "foo-gz" in example.c for RISCOS and VMS (Nick Smith) -- add the OS/2 files in Makefile.in too (Andrew Zabolotny) -- fix fdopen and halloc macros for Microsoft C 6.0 (Tom Lane) -- fix maketree.c to allow clean compilation of inffixed.h (Mark) -- fix parameter check in deflateCopy (Gunther Nikl) -- cleanup trees.c, use compressed_len only in debug mode (Christian Spieler) -- Many portability patches by Christian Spieler: - . zutil.c, zutil.h: added "const" for zmem* - . Make_vms.com: fixed some typos - . Make_vms.com: msdos/Makefile.*: removed zutil.h from some dependency lists - . msdos/Makefile.msc: remove "default rtl link library" info from obj files - . msdos/Makefile.*: use model-dependent name for the built zlib library - . msdos/Makefile.emx, nt/Makefile.emx, nt/Makefile.gcc: - new makefiles, for emx (DOS/OS2), emx&rsxnt and mingw32 (Windows 9x / NT) -- use define instead of typedef for Bytef also for MSC small/medium (Tom Lane) -- replace __far with _far for better portability (Christian Spieler, Tom Lane) -- fix test for errno.h in configure (Tim Newsham) - -Changes in 1.1.2 (19 March 98) -- added contrib/minzip, mini zip and unzip based on zlib (Gilles Vollant) - See http://www.winimage.com/zLibDll/unzip.html -- preinitialize the inflate tables for fixed codes, to make the code - completely thread safe (Mark) -- some simplifications and slight speed-up to the inflate code (Mark) -- fix gzeof on non-compressed files (Allan Schrum) -- add -std1 option in configure for OSF1 to fix gzprintf (Martin Mokrejs) -- use default value of 4K for Z_BUFSIZE for 16-bit MSDOS (Tim Wegner + Glenn) -- added os2/Makefile.def and os2/zlib.def (Andrew Zabolotny) -- add shared lib support for UNIX_SV4.2MP (MATSUURA Takanori) -- do not wrap extern "C" around system includes (Tom Lane) -- mention zlib binding for TCL in README (Andreas Kupries) -- added amiga/Makefile.pup for Amiga powerUP SAS/C PPC (Andreas Kleinert) -- allow "make install prefix=..." even after configure (Glenn Randers-Pehrson) -- allow "configure --prefix $HOME" (Tim Mooney) -- remove warnings in example.c and gzio.c (Glenn Randers-Pehrson) -- move Makefile.sas to amiga/Makefile.sas - -Changes in 1.1.1 (27 Feb 98) -- fix macros _tr_tally_* in deflate.h for debug mode (Glenn Randers-Pehrson) -- remove block truncation heuristic which had very marginal effect for zlib - (smaller lit_bufsize than in gzip 1.2.4) and degraded a little the - compression ratio on some files. This also allows inlining _tr_tally for - matches in deflate_slow. -- added msdos/Makefile.w32 for WIN32 Microsoft Visual C++ (Bob Frazier) - -Changes in 1.1.0 (24 Feb 98) -- do not return STREAM_END prematurely in inflate (John Bowler) -- revert to the zlib 1.0.8 inflate to avoid the gcc 2.8.0 bug (Jeremy Buhler) -- compile with -DFASTEST to get compression code optimized for speed only -- in minigzip, try mmap'ing the input file first (Miguel Albrecht) -- increase size of I/O buffers in minigzip.c and gzio.c (not a big gain - on Sun but significant on HP) - -- add a pointer to experimental unzip library in README (Gilles Vollant) -- initialize variable gcc in configure (Chris Herborth) - -Changes in 1.0.9 (17 Feb 1998) -- added gzputs and gzgets functions -- do not clear eof flag in gzseek (Mark Diekhans) -- fix gzseek for files in transparent mode (Mark Diekhans) -- do not assume that vsprintf returns the number of bytes written (Jens Krinke) -- replace EXPORT with ZEXPORT to avoid conflict with other programs -- added compress2 in zconf.h, zlib.def, zlib.dnt -- new asm code from Gilles Vollant in contrib/asm386 -- simplify the inflate code (Mark): - . Replace ZALLOC's in huft_build() with single ZALLOC in inflate_blocks_new() - . ZALLOC the length list in inflate_trees_fixed() instead of using stack - . ZALLOC the value area for huft_build() instead of using stack - . Simplify Z_FINISH check in inflate() - -- Avoid gcc 2.8.0 comparison bug a little differently than zlib 1.0.8 -- in inftrees.c, avoid cc -O bug on HP (Farshid Elahi) -- in zconf.h move the ZLIB_DLL stuff earlier to avoid problems with - the declaration of FAR (Gilles VOllant) -- install libz.so* with mode 755 (executable) instead of 644 (Marc Lehmann) -- read_buf buf parameter of type Bytef* instead of charf* -- zmemcpy parameters are of type Bytef*, not charf* (Joseph Strout) -- do not redeclare unlink in minigzip.c for WIN32 (John Bowler) -- fix check for presence of directories in "make install" (Ian Willis) - -Changes in 1.0.8 (27 Jan 1998) -- fixed offsets in contrib/asm386/gvmat32.asm (Gilles Vollant) -- fix gzgetc and gzputc for big endian systems (Markus Oberhumer) -- added compress2() to allow setting the compression level -- include sys/types.h to get off_t on some systems (Marc Lehmann & QingLong) -- use constant arrays for the static trees in trees.c instead of computing - them at run time (thanks to Ken Raeburn for this suggestion). To create - trees.h, compile with GEN_TREES_H and run "make test". -- check return code of example in "make test" and display result -- pass minigzip command line options to file_compress -- simplifying code of inflateSync to avoid gcc 2.8 bug - -- support CC="gcc -Wall" in configure -s (QingLong) -- avoid a flush caused by ftell in gzopen for write mode (Ken Raeburn) -- fix test for shared library support to avoid compiler warnings -- zlib.lib -> zlib.dll in msdos/zlib.rc (Gilles Vollant) -- check for TARGET_OS_MAC in addition to MACOS (Brad Pettit) -- do not use fdopen for Metrowerks on Mac (Brad Pettit)) -- add checks for gzputc and gzputc in example.c -- avoid warnings in gzio.c and deflate.c (Andreas Kleinert) -- use const for the CRC table (Ken Raeburn) -- fixed "make uninstall" for shared libraries -- use Tracev instead of Trace in infblock.c -- in example.c use correct compressed length for test_sync -- suppress +vnocompatwarnings in configure for HPUX (not always supported) - -Changes in 1.0.7 (20 Jan 1998) -- fix gzseek which was broken in write mode -- return error for gzseek to negative absolute position -- fix configure for Linux (Chun-Chung Chen) -- increase stack space for MSC (Tim Wegner) -- get_crc_table and inflateSyncPoint are EXPORTed (Gilles Vollant) -- define EXPORTVA for gzprintf (Gilles Vollant) -- added man page zlib.3 (Rick Rodgers) -- for contrib/untgz, fix makedir() and improve Makefile - -- check gzseek in write mode in example.c -- allocate extra buffer for seeks only if gzseek is actually called -- avoid signed/unsigned comparisons (Tim Wegner, Gilles Vollant) -- add inflateSyncPoint in zconf.h -- fix list of exported functions in nt/zlib.dnt and mdsos/zlib.def - -Changes in 1.0.6 (19 Jan 1998) -- add functions gzprintf, gzputc, gzgetc, gztell, gzeof, gzseek, gzrewind and - gzsetparams (thanks to Roland Giersig and Kevin Ruland for some of this code) -- Fix a deflate bug occurring only with compression level 0 (thanks to - Andy Buckler for finding this one). -- In minigzip, pass transparently also the first byte for .Z files. -- return Z_BUF_ERROR instead of Z_OK if output buffer full in uncompress() -- check Z_FINISH in inflate (thanks to Marc Schluper) -- Implement deflateCopy (thanks to Adam Costello) -- make static libraries by default in configure, add --shared option. -- move MSDOS or Windows specific files to directory msdos -- suppress the notion of partial flush to simplify the interface - (but the symbol Z_PARTIAL_FLUSH is kept for compatibility with 1.0.4) -- suppress history buffer provided by application to simplify the interface - (this feature was not implemented anyway in 1.0.4) -- next_in and avail_in must be initialized before calling inflateInit or - inflateInit2 -- add EXPORT in all exported functions (for Windows DLL) -- added Makefile.nt (thanks to Stephen Williams) -- added the unsupported "contrib" directory: - contrib/asm386/ by Gilles Vollant - 386 asm code replacing longest_match(). - contrib/iostream/ by Kevin Ruland - A C++ I/O streams interface to the zlib gz* functions - contrib/iostream2/ by Tyge Løvset - Another C++ I/O streams interface - contrib/untgz/ by "Pedro A. Aranda Guti\irrez" - A very simple tar.gz file extractor using zlib - contrib/visual-basic.txt by Carlos Rios - How to use compress(), uncompress() and the gz* functions from VB. -- pass params -f (filtered data), -h (huffman only), -1 to -9 (compression - level) in minigzip (thanks to Tom Lane) - -- use const for rommable constants in deflate -- added test for gzseek and gztell in example.c -- add undocumented function inflateSyncPoint() (hack for Paul Mackerras) -- add undocumented function zError to convert error code to string - (for Tim Smithers) -- Allow compilation of gzio with -DNO_DEFLATE to avoid the compression code. -- Use default memcpy for Symantec MSDOS compiler. -- Add EXPORT keyword for check_func (needed for Windows DLL) -- add current directory to LD_LIBRARY_PATH for "make test" -- create also a link for libz.so.1 -- added support for FUJITSU UXP/DS (thanks to Toshiaki Nomura) -- use $(SHAREDLIB) instead of libz.so in Makefile.in (for HPUX) -- added -soname for Linux in configure (Chun-Chung Chen, -- assign numbers to the exported functions in zlib.def (for Windows DLL) -- add advice in zlib.h for best usage of deflateSetDictionary -- work around compiler bug on Atari (cast Z_NULL in call of s->checkfn) -- allow compilation with ANSI keywords only enabled for TurboC in large model -- avoid "versionString"[0] (Borland bug) -- add NEED_DUMMY_RETURN for Borland -- use variable z_verbose for tracing in debug mode (L. Peter Deutsch). -- allow compilation with CC -- defined STDC for OS/2 (David Charlap) -- limit external names to 8 chars for MVS (Thomas Lund) -- in minigzip.c, use static buffers only for 16-bit systems -- fix suffix check for "minigzip -d foo.gz" -- do not return an error for the 2nd of two consecutive gzflush() (Felix Lee) -- use _fdopen instead of fdopen for MSC >= 6.0 (Thomas Fanslau) -- added makelcc.bat for lcc-win32 (Tom St Denis) -- in Makefile.dj2, use copy and del instead of install and rm (Frank Donahoe) -- Avoid expanded $Id$. Use "rcs -kb" or "cvs admin -kb" to avoid Id expansion. -- check for unistd.h in configure (for off_t) -- remove useless check parameter in inflate_blocks_free -- avoid useless assignment of s->check to itself in inflate_blocks_new -- do not flush twice in gzclose (thanks to Ken Raeburn) -- rename FOPEN as F_OPEN to avoid clash with /usr/include/sys/file.h -- use NO_ERRNO_H instead of enumeration of operating systems with errno.h -- work around buggy fclose on pipes for HP/UX -- support zlib DLL with BORLAND C++ 5.0 (thanks to Glenn Randers-Pehrson) -- fix configure if CC is already equal to gcc - -Changes in 1.0.5 (3 Jan 98) -- Fix inflate to terminate gracefully when fed corrupted or invalid data -- Use const for rommable constants in inflate -- Eliminate memory leaks on error conditions in inflate -- Removed some vestigial code in inflate -- Update web address in README - -Changes in 1.0.4 (24 Jul 96) -- In very rare conditions, deflate(s, Z_FINISH) could fail to produce an EOF - bit, so the decompressor could decompress all the correct data but went - on to attempt decompressing extra garbage data. This affected minigzip too. -- zlibVersion and gzerror return const char* (needed for DLL) -- port to RISCOS (no fdopen, no multiple dots, no unlink, no fileno) -- use z_error only for DEBUG (avoid problem with DLLs) - -Changes in 1.0.3 (2 Jul 96) -- use z_streamp instead of z_stream *, which is now a far pointer in MSDOS - small and medium models; this makes the library incompatible with previous - versions for these models. (No effect in large model or on other systems.) -- return OK instead of BUF_ERROR if previous deflate call returned with - avail_out as zero but there is nothing to do -- added memcmp for non STDC compilers -- define NO_DUMMY_DECL for more Mac compilers (.h files merged incorrectly) -- define __32BIT__ if __386__ or i386 is defined (pb. with Watcom and SCO) -- better check for 16-bit mode MSC (avoids problem with Symantec) - -Changes in 1.0.2 (23 May 96) -- added Windows DLL support -- added a function zlibVersion (for the DLL support) -- fixed declarations using Bytef in infutil.c (pb with MSDOS medium model) -- Bytef is define's instead of typedef'd only for Borland C -- avoid reading uninitialized memory in example.c -- mention in README that the zlib format is now RFC1950 -- updated Makefile.dj2 -- added algorithm.doc - -Changes in 1.0.1 (20 May 96) [1.0 skipped to avoid confusion] -- fix array overlay in deflate.c which sometimes caused bad compressed data -- fix inflate bug with empty stored block -- fix MSDOS medium model which was broken in 0.99 -- fix deflateParams() which could generate bad compressed data. -- Bytef is define'd instead of typedef'ed (work around Borland bug) -- added an INDEX file -- new makefiles for DJGPP (Makefile.dj2), 32-bit Borland (Makefile.b32), - Watcom (Makefile.wat), Amiga SAS/C (Makefile.sas) -- speed up adler32 for modern machines without auto-increment -- added -ansi for IRIX in configure -- static_init_done in trees.c is an int -- define unlink as delete for VMS -- fix configure for QNX -- add configure branch for SCO and HPUX -- avoid many warnings (unused variables, dead assignments, etc...) -- no fdopen for BeOS -- fix the Watcom fix for 32 bit mode (define FAR as empty) -- removed redefinition of Byte for MKWERKS -- work around an MWKERKS bug (incorrect merge of all .h files) - -Changes in 0.99 (27 Jan 96) -- allow preset dictionary shared between compressor and decompressor -- allow compression level 0 (no compression) -- add deflateParams in zlib.h: allow dynamic change of compression level - and compression strategy. -- test large buffers and deflateParams in example.c -- add optional "configure" to build zlib as a shared library -- suppress Makefile.qnx, use configure instead -- fixed deflate for 64-bit systems (detected on Cray) -- fixed inflate_blocks for 64-bit systems (detected on Alpha) -- declare Z_DEFLATED in zlib.h (possible parameter for deflateInit2) -- always return Z_BUF_ERROR when deflate() has nothing to do -- deflateInit and inflateInit are now macros to allow version checking -- prefix all global functions and types with z_ with -DZ_PREFIX -- make falloc completely reentrant (inftrees.c) -- fixed very unlikely race condition in ct_static_init -- free in reverse order of allocation to help memory manager -- use zlib-1.0/* instead of zlib/* inside the tar.gz -- make zlib warning-free with "gcc -O3 -Wall -Wwrite-strings -Wpointer-arith - -Wconversion -Wstrict-prototypes -Wmissing-prototypes" -- allow gzread on concatenated .gz files -- deflateEnd now returns Z_DATA_ERROR if it was premature -- deflate is finally (?) fully deterministic (no matches beyond end of input) -- Document Z_SYNC_FLUSH -- add uninstall in Makefile -- Check for __cpluplus in zlib.h -- Better test in ct_align for partial flush -- avoid harmless warnings for Borland C++ -- initialize hash_head in deflate.c -- avoid warning on fdopen (gzio.c) for HP cc -Aa -- include stdlib.h for STDC compilers -- include errno.h for Cray -- ignore error if ranlib doesn't exist -- call ranlib twice for NeXTSTEP -- use exec_prefix instead of prefix for libz.a -- renamed ct_* as _tr_* to avoid conflict with applications -- clear z->msg in inflateInit2 before any error return -- initialize opaque in example.c, gzio.c, deflate.c and inflate.c -- fixed typo in zconf.h (_GNUC__ => __GNUC__) -- check for WIN32 in zconf.h and zutil.c (avoid farmalloc in 32-bit mode) -- fix typo in Make_vms.com (f$trnlnm -> f$getsyi) -- in fcalloc, normalize pointer if size > 65520 bytes -- don't use special fcalloc for 32 bit Borland C++ -- use STDC instead of __GO32__ to avoid redeclaring exit, calloc, etc... -- use Z_BINARY instead of BINARY -- document that gzclose after gzdopen will close the file -- allow "a" as mode in gzopen. -- fix error checking in gzread -- allow skipping .gz extra-field on pipes -- added reference to Perl interface in README -- put the crc table in FAR data (I dislike more and more the medium model :) -- added get_crc_table -- added a dimension to all arrays (Borland C can't count). -- workaround Borland C bug in declaration of inflate_codes_new & inflate_fast -- guard against multiple inclusion of *.h (for precompiled header on Mac) -- Watcom C pretends to be Microsoft C small model even in 32 bit mode. -- don't use unsized arrays to avoid silly warnings by Visual C++: - warning C4746: 'inflate_mask' : unsized array treated as '__far' - (what's wrong with far data in far model?). -- define enum out of inflate_blocks_state to allow compilation with C++ - -Changes in 0.95 (16 Aug 95) -- fix MSDOS small and medium model (now easier to adapt to any compiler) -- inlined send_bits -- fix the final (:-) bug for deflate with flush (output was correct but - not completely flushed in rare occasions). -- default window size is same for compression and decompression - (it's now sufficient to set MAX_WBITS in zconf.h). -- voidp -> voidpf and voidnp -> voidp (for consistency with other - typedefs and because voidnp was not near in large model). - -Changes in 0.94 (13 Aug 95) -- support MSDOS medium model -- fix deflate with flush (could sometimes generate bad output) -- fix deflateReset (zlib header was incorrectly suppressed) -- added support for VMS -- allow a compression level in gzopen() -- gzflush now calls fflush -- For deflate with flush, flush even if no more input is provided. -- rename libgz.a as libz.a -- avoid complex expression in infcodes.c triggering Turbo C bug -- work around a problem with gcc on Alpha (in INSERT_STRING) -- don't use inline functions (problem with some gcc versions) -- allow renaming of Byte, uInt, etc... with #define. -- avoid warning about (unused) pointer before start of array in deflate.c -- avoid various warnings in gzio.c, example.c, infblock.c, adler32.c, zutil.c -- avoid reserved word 'new' in trees.c - -Changes in 0.93 (25 June 95) -- temporarily disable inline functions -- make deflate deterministic -- give enough lookahead for PARTIAL_FLUSH -- Set binary mode for stdin/stdout in minigzip.c for OS/2 -- don't even use signed char in inflate (not portable enough) -- fix inflate memory leak for segmented architectures - -Changes in 0.92 (3 May 95) -- don't assume that char is signed (problem on SGI) -- Clear bit buffer when starting a stored block -- no memcpy on Pyramid -- suppressed inftest.c -- optimized fill_window, put longest_match inline for gcc -- optimized inflate on stored blocks. -- untabify all sources to simplify patches - -Changes in 0.91 (2 May 95) -- Default MEM_LEVEL is 8 (not 9 for Unix) as documented in zlib.h -- Document the memory requirements in zconf.h -- added "make install" -- fix sync search logic in inflateSync -- deflate(Z_FULL_FLUSH) now works even if output buffer too short -- after inflateSync, don't scare people with just "lo world" -- added support for DJGPP - -Changes in 0.9 (1 May 95) -- don't assume that zalloc clears the allocated memory (the TurboC bug - was Mark's bug after all :) -- let again gzread copy uncompressed data unchanged (was working in 0.71) -- deflate(Z_FULL_FLUSH), inflateReset and inflateSync are now fully implemented -- added a test of inflateSync in example.c -- moved MAX_WBITS to zconf.h because users might want to change that. -- document explicitly that zalloc(64K) on MSDOS must return a normalized - pointer (zero offset) -- added Makefiles for Microsoft C, Turbo C, Borland C++ -- faster crc32() - -Changes in 0.8 (29 April 95) -- added fast inflate (inffast.c) -- deflate(Z_FINISH) now returns Z_STREAM_END when done. Warning: this - is incompatible with previous versions of zlib which returned Z_OK. -- work around a TurboC compiler bug (bad code for b << 0, see infutil.h) - (actually that was not a compiler bug, see 0.81 above) -- gzread no longer reads one extra byte in certain cases -- In gzio destroy(), don't reference a freed structure -- avoid many warnings for MSDOS -- avoid the ERROR symbol which is used by MS Windows - -Changes in 0.71 (14 April 95) -- Fixed more MSDOS compilation problems :( There is still a bug with - TurboC large model. - -Changes in 0.7 (14 April 95) -- Added full inflate support. -- Simplified the crc32() interface. The pre- and post-conditioning - (one's complement) is now done inside crc32(). WARNING: this is - incompatible with previous versions; see zlib.h for the new usage. - -Changes in 0.61 (12 April 95) -- workaround for a bug in TurboC. example and minigzip now work on MSDOS. - -Changes in 0.6 (11 April 95) -- added minigzip.c -- added gzdopen to reopen a file descriptor as gzFile -- added transparent reading of non-gziped files in gzread. -- fixed bug in gzread (don't read crc as data) -- fixed bug in destroy (gzio.c) (don't return Z_STREAM_END for gzclose). -- don't allocate big arrays in the stack (for MSDOS) -- fix some MSDOS compilation problems - -Changes in 0.5: -- do real compression in deflate.c. Z_PARTIAL_FLUSH is supported but - not yet Z_FULL_FLUSH. -- support decompression but only in a single step (forced Z_FINISH) -- added opaque object for zalloc and zfree. -- added deflateReset and inflateReset -- added a variable zlib_version for consistency checking. -- renamed the 'filter' parameter of deflateInit2 as 'strategy'. - Added Z_FILTERED and Z_HUFFMAN_ONLY constants. - -Changes in 0.4: -- avoid "zip" everywhere, use zlib instead of ziplib. -- suppress Z_BLOCK_FLUSH, interpret Z_PARTIAL_FLUSH as block flush - if compression method == 8. -- added adler32 and crc32 -- renamed deflateOptions as deflateInit2, call one or the other but not both -- added the method parameter for deflateInit2. -- added inflateInit2 -- simplied considerably deflateInit and inflateInit by not supporting - user-provided history buffer. This is supported only in deflateInit2 - and inflateInit2. - -Changes in 0.3: -- prefix all macro names with Z_ -- use Z_FINISH instead of deflateEnd to finish compression. -- added Z_HUFFMAN_ONLY -- added gzerror() DELETED compat/zlib/FAQ Index: compat/zlib/FAQ ================================================================== --- compat/zlib/FAQ +++ /dev/null @@ -1,368 +0,0 @@ - - Frequently Asked Questions about zlib - - -If your question is not there, please check the zlib home page -http://zlib.net/ which may have more recent information. -The lastest zlib FAQ is at http://zlib.net/zlib_faq.html - - - 1. Is zlib Y2K-compliant? - - Yes. zlib doesn't handle dates. - - 2. Where can I get a Windows DLL version? - - The zlib sources can be compiled without change to produce a DLL. See the - file win32/DLL_FAQ.txt in the zlib distribution. Pointers to the - precompiled DLL are found in the zlib web site at http://zlib.net/ . - - 3. Where can I get a Visual Basic interface to zlib? - - See - * http://marknelson.us/1997/01/01/zlib-engine/ - * win32/DLL_FAQ.txt in the zlib distribution - - 4. compress() returns Z_BUF_ERROR. - - Make sure that before the call of compress(), the length of the compressed - buffer is equal to the available size of the compressed buffer and not - zero. For Visual Basic, check that this parameter is passed by reference - ("as any"), not by value ("as long"). - - 5. deflate() or inflate() returns Z_BUF_ERROR. - - Before making the call, make sure that avail_in and avail_out are not zero. - When setting the parameter flush equal to Z_FINISH, also make sure that - avail_out is big enough to allow processing all pending input. Note that a - Z_BUF_ERROR is not fatal--another call to deflate() or inflate() can be - made with more input or output space. A Z_BUF_ERROR may in fact be - unavoidable depending on how the functions are used, since it is not - possible to tell whether or not there is more output pending when - strm.avail_out returns with zero. See http://zlib.net/zlib_how.html for a - heavily annotated example. - - 6. Where's the zlib documentation (man pages, etc.)? - - It's in zlib.h . Examples of zlib usage are in the files test/example.c - and test/minigzip.c, with more in examples/ . - - 7. Why don't you use GNU autoconf or libtool or ...? - - Because we would like to keep zlib as a very small and simple package. - zlib is rather portable and doesn't need much configuration. - - 8. I found a bug in zlib. - - Most of the time, such problems are due to an incorrect usage of zlib. - Please try to reproduce the problem with a small program and send the - corresponding source to us at zlib@gzip.org . Do not send multi-megabyte - data files without prior agreement. - - 9. Why do I get "undefined reference to gzputc"? - - If "make test" produces something like - - example.o(.text+0x154): undefined reference to `gzputc' - - check that you don't have old files libz.* in /usr/lib, /usr/local/lib or - /usr/X11R6/lib. Remove any old versions, then do "make install". - -10. I need a Delphi interface to zlib. - - See the contrib/delphi directory in the zlib distribution. - -11. Can zlib handle .zip archives? - - Not by itself, no. See the directory contrib/minizip in the zlib - distribution. - -12. Can zlib handle .Z files? - - No, sorry. You have to spawn an uncompress or gunzip subprocess, or adapt - the code of uncompress on your own. - -13. How can I make a Unix shared library? - - By default a shared (and a static) library is built for Unix. So: - - make distclean - ./configure - make - -14. How do I install a shared zlib library on Unix? - - After the above, then: - - make install - - However, many flavors of Unix come with a shared zlib already installed. - Before going to the trouble of compiling a shared version of zlib and - trying to install it, you may want to check if it's already there! If you - can #include , it's there. The -lz option will probably link to - it. You can check the version at the top of zlib.h or with the - ZLIB_VERSION symbol defined in zlib.h . - -15. I have a question about OttoPDF. - - We are not the authors of OttoPDF. The real author is on the OttoPDF web - site: Joel Hainley, jhainley@myndkryme.com. - -16. Can zlib decode Flate data in an Adobe PDF file? - - Yes. See http://www.pdflib.com/ . To modify PDF forms, see - http://sourceforge.net/projects/acroformtool/ . - -17. Why am I getting this "register_frame_info not found" error on Solaris? - - After installing zlib 1.1.4 on Solaris 2.6, running applications using zlib - generates an error such as: - - ld.so.1: rpm: fatal: relocation error: file /usr/local/lib/libz.so: - symbol __register_frame_info: referenced symbol not found - - The symbol __register_frame_info is not part of zlib, it is generated by - the C compiler (cc or gcc). You must recompile applications using zlib - which have this problem. This problem is specific to Solaris. See - http://www.sunfreeware.com for Solaris versions of zlib and applications - using zlib. - -18. Why does gzip give an error on a file I make with compress/deflate? - - The compress and deflate functions produce data in the zlib format, which - is different and incompatible with the gzip format. The gz* functions in - zlib on the other hand use the gzip format. Both the zlib and gzip formats - use the same compressed data format internally, but have different headers - and trailers around the compressed data. - -19. Ok, so why are there two different formats? - - The gzip format was designed to retain the directory information about a - single file, such as the name and last modification date. The zlib format - on the other hand was designed for in-memory and communication channel - applications, and has a much more compact header and trailer and uses a - faster integrity check than gzip. - -20. Well that's nice, but how do I make a gzip file in memory? - - You can request that deflate write the gzip format instead of the zlib - format using deflateInit2(). You can also request that inflate decode the - gzip format using inflateInit2(). Read zlib.h for more details. - -21. Is zlib thread-safe? - - Yes. However any library routines that zlib uses and any application- - provided memory allocation routines must also be thread-safe. zlib's gz* - functions use stdio library routines, and most of zlib's functions use the - library memory allocation routines by default. zlib's *Init* functions - allow for the application to provide custom memory allocation routines. - - Of course, you should only operate on any given zlib or gzip stream from a - single thread at a time. - -22. Can I use zlib in my commercial application? - - Yes. Please read the license in zlib.h. - -23. Is zlib under the GNU license? - - No. Please read the license in zlib.h. - -24. The license says that altered source versions must be "plainly marked". So - what exactly do I need to do to meet that requirement? - - You need to change the ZLIB_VERSION and ZLIB_VERNUM #defines in zlib.h. In - particular, the final version number needs to be changed to "f", and an - identification string should be appended to ZLIB_VERSION. Version numbers - x.x.x.f are reserved for modifications to zlib by others than the zlib - maintainers. For example, if the version of the base zlib you are altering - is "1.2.3.4", then in zlib.h you should change ZLIB_VERNUM to 0x123f, and - ZLIB_VERSION to something like "1.2.3.f-zachary-mods-v3". You can also - update the version strings in deflate.c and inftrees.c. - - For altered source distributions, you should also note the origin and - nature of the changes in zlib.h, as well as in ChangeLog and README, along - with the dates of the alterations. The origin should include at least your - name (or your company's name), and an email address to contact for help or - issues with the library. - - Note that distributing a compiled zlib library along with zlib.h and - zconf.h is also a source distribution, and so you should change - ZLIB_VERSION and ZLIB_VERNUM and note the origin and nature of the changes - in zlib.h as you would for a full source distribution. - -25. Will zlib work on a big-endian or little-endian architecture, and can I - exchange compressed data between them? - - Yes and yes. - -26. Will zlib work on a 64-bit machine? - - Yes. It has been tested on 64-bit machines, and has no dependence on any - data types being limited to 32-bits in length. If you have any - difficulties, please provide a complete problem report to zlib@gzip.org - -27. Will zlib decompress data from the PKWare Data Compression Library? - - No. The PKWare DCL uses a completely different compressed data format than - does PKZIP and zlib. However, you can look in zlib's contrib/blast - directory for a possible solution to your problem. - -28. Can I access data randomly in a compressed stream? - - No, not without some preparation. If when compressing you periodically use - Z_FULL_FLUSH, carefully write all the pending data at those points, and - keep an index of those locations, then you can start decompression at those - points. You have to be careful to not use Z_FULL_FLUSH too often, since it - can significantly degrade compression. Alternatively, you can scan a - deflate stream once to generate an index, and then use that index for - random access. See examples/zran.c . - -29. Does zlib work on MVS, OS/390, CICS, etc.? - - It has in the past, but we have not heard of any recent evidence. There - were working ports of zlib 1.1.4 to MVS, but those links no longer work. - If you know of recent, successful applications of zlib on these operating - systems, please let us know. Thanks. - -30. Is there some simpler, easier to read version of inflate I can look at to - understand the deflate format? - - First off, you should read RFC 1951. Second, yes. Look in zlib's - contrib/puff directory. - -31. Does zlib infringe on any patents? - - As far as we know, no. In fact, that was originally the whole point behind - zlib. Look here for some more information: - - http://www.gzip.org/#faq11 - -32. Can zlib work with greater than 4 GB of data? - - Yes. inflate() and deflate() will process any amount of data correctly. - Each call of inflate() or deflate() is limited to input and output chunks - of the maximum value that can be stored in the compiler's "unsigned int" - type, but there is no limit to the number of chunks. Note however that the - strm.total_in and strm_total_out counters may be limited to 4 GB. These - counters are provided as a convenience and are not used internally by - inflate() or deflate(). The application can easily set up its own counters - updated after each call of inflate() or deflate() to count beyond 4 GB. - compress() and uncompress() may be limited to 4 GB, since they operate in a - single call. gzseek() and gztell() may be limited to 4 GB depending on how - zlib is compiled. See the zlibCompileFlags() function in zlib.h. - - The word "may" appears several times above since there is a 4 GB limit only - if the compiler's "long" type is 32 bits. If the compiler's "long" type is - 64 bits, then the limit is 16 exabytes. - -33. Does zlib have any security vulnerabilities? - - The only one that we are aware of is potentially in gzprintf(). If zlib is - compiled to use sprintf() or vsprintf(), then there is no protection - against a buffer overflow of an 8K string space (or other value as set by - gzbuffer()), other than the caller of gzprintf() assuring that the output - will not exceed 8K. On the other hand, if zlib is compiled to use - snprintf() or vsnprintf(), which should normally be the case, then there is - no vulnerability. The ./configure script will display warnings if an - insecure variation of sprintf() will be used by gzprintf(). Also the - zlibCompileFlags() function will return information on what variant of - sprintf() is used by gzprintf(). - - If you don't have snprintf() or vsnprintf() and would like one, you can - find a portable implementation here: - - http://www.ijs.si/software/snprintf/ - - Note that you should be using the most recent version of zlib. Versions - 1.1.3 and before were subject to a double-free vulnerability, and versions - 1.2.1 and 1.2.2 were subject to an access exception when decompressing - invalid compressed data. - -34. Is there a Java version of zlib? - - Probably what you want is to use zlib in Java. zlib is already included - as part of the Java SDK in the java.util.zip package. If you really want - a version of zlib written in the Java language, look on the zlib home - page for links: http://zlib.net/ . - -35. I get this or that compiler or source-code scanner warning when I crank it - up to maximally-pedantic. Can't you guys write proper code? - - Many years ago, we gave up attempting to avoid warnings on every compiler - in the universe. It just got to be a waste of time, and some compilers - were downright silly as well as contradicted each other. So now, we simply - make sure that the code always works. - -36. Valgrind (or some similar memory access checker) says that deflate is - performing a conditional jump that depends on an uninitialized value. - Isn't that a bug? - - No. That is intentional for performance reasons, and the output of deflate - is not affected. This only started showing up recently since zlib 1.2.x - uses malloc() by default for allocations, whereas earlier versions used - calloc(), which zeros out the allocated memory. Even though the code was - correct, versions 1.2.4 and later was changed to not stimulate these - checkers. - -37. Will zlib read the (insert any ancient or arcane format here) compressed - data format? - - Probably not. Look in the comp.compression FAQ for pointers to various - formats and associated software. - -38. How can I encrypt/decrypt zip files with zlib? - - zlib doesn't support encryption. The original PKZIP encryption is very - weak and can be broken with freely available programs. To get strong - encryption, use GnuPG, http://www.gnupg.org/ , which already includes zlib - compression. For PKZIP compatible "encryption", look at - http://www.info-zip.org/ - -39. What's the difference between the "gzip" and "deflate" HTTP 1.1 encodings? - - "gzip" is the gzip format, and "deflate" is the zlib format. They should - probably have called the second one "zlib" instead to avoid confusion with - the raw deflate compressed data format. While the HTTP 1.1 RFC 2616 - correctly points to the zlib specification in RFC 1950 for the "deflate" - transfer encoding, there have been reports of servers and browsers that - incorrectly produce or expect raw deflate data per the deflate - specification in RFC 1951, most notably Microsoft. So even though the - "deflate" transfer encoding using the zlib format would be the more - efficient approach (and in fact exactly what the zlib format was designed - for), using the "gzip" transfer encoding is probably more reliable due to - an unfortunate choice of name on the part of the HTTP 1.1 authors. - - Bottom line: use the gzip format for HTTP 1.1 encoding. - -40. Does zlib support the new "Deflate64" format introduced by PKWare? - - No. PKWare has apparently decided to keep that format proprietary, since - they have not documented it as they have previous compression formats. In - any case, the compression improvements are so modest compared to other more - modern approaches, that it's not worth the effort to implement. - -41. I'm having a problem with the zip functions in zlib, can you help? - - There are no zip functions in zlib. You are probably using minizip by - Giles Vollant, which is found in the contrib directory of zlib. It is not - part of zlib. In fact none of the stuff in contrib is part of zlib. The - files in there are not supported by the zlib authors. You need to contact - the authors of the respective contribution for help. - -42. The match.asm code in contrib is under the GNU General Public License. - Since it's part of zlib, doesn't that mean that all of zlib falls under the - GNU GPL? - - No. The files in contrib are not part of zlib. They were contributed by - other authors and are provided as a convenience to the user within the zlib - distribution. Each item in contrib has its own license. - -43. Is zlib subject to export controls? What is its ECCN? - - zlib is not subject to export controls, and so is classified as EAR99. - -44. Can you please sign these lengthy legal documents and fax them back to us - so that we can use your software in our product? - - No. Go away. Shoo. DELETED compat/zlib/INDEX Index: compat/zlib/INDEX ================================================================== --- compat/zlib/INDEX +++ /dev/null @@ -1,68 +0,0 @@ -CMakeLists.txt cmake build file -ChangeLog history of changes -FAQ Frequently Asked Questions about zlib -INDEX this file -Makefile dummy Makefile that tells you to ./configure -Makefile.in template for Unix Makefile -README guess what -configure configure script for Unix -make_vms.com makefile for VMS -test/example.c zlib usages examples for build testing -test/minigzip.c minimal gzip-like functionality for build testing -test/infcover.c inf*.c code coverage for build coverage testing -treebuild.xml XML description of source file dependencies -zconf.h.cmakein zconf.h template for cmake -zconf.h.in zconf.h template for configure -zlib.3 Man page for zlib -zlib.3.pdf Man page in PDF format -zlib.map Linux symbol information -zlib.pc.in Template for pkg-config descriptor -zlib.pc.cmakein zlib.pc template for cmake -zlib2ansi perl script to convert source files for C++ compilation - -amiga/ makefiles for Amiga SAS C -as400/ makefiles for AS/400 -doc/ documentation for formats and algorithms -msdos/ makefiles for MSDOS -nintendods/ makefile for Nintendo DS -old/ makefiles for various architectures and zlib documentation - files that have not yet been updated for zlib 1.2.x -qnx/ makefiles for QNX -watcom/ makefiles for OpenWatcom -win32/ makefiles for Windows - - zlib public header files (required for library use): -zconf.h -zlib.h - - private source files used to build the zlib library: -adler32.c -compress.c -crc32.c -crc32.h -deflate.c -deflate.h -gzclose.c -gzguts.h -gzlib.c -gzread.c -gzwrite.c -infback.c -inffast.c -inffast.h -inffixed.h -inflate.c -inflate.h -inftrees.c -inftrees.h -trees.c -trees.h -uncompr.c -zutil.c -zutil.h - - source files for sample programs -See examples/README.examples - - unsupported contributions by third parties -See contrib/README.contrib DELETED compat/zlib/Makefile Index: compat/zlib/Makefile ================================================================== --- compat/zlib/Makefile +++ /dev/null @@ -1,5 +0,0 @@ -all: - -@echo "Please use ./configure first. Thank you." - -distclean: - make -f Makefile.in distclean DELETED compat/zlib/Makefile.in Index: compat/zlib/Makefile.in ================================================================== --- compat/zlib/Makefile.in +++ /dev/null @@ -1,410 +0,0 @@ -# Makefile for zlib -# Copyright (C) 1995-2017 Jean-loup Gailly, Mark Adler -# For conditions of distribution and use, see copyright notice in zlib.h - -# To compile and test, type: -# ./configure; make test -# Normally configure builds both a static and a shared library. -# If you want to build just a static library, use: ./configure --static - -# To use the asm code, type: -# cp contrib/asm?86/match.S ./match.S -# make LOC=-DASMV OBJA=match.o - -# To install /usr/local/lib/libz.* and /usr/local/include/zlib.h, type: -# make install -# To install in $HOME instead of /usr/local, use: -# make install prefix=$HOME - -CC=cc - -CFLAGS=-O -#CFLAGS=-O -DMAX_WBITS=14 -DMAX_MEM_LEVEL=7 -#CFLAGS=-g -DZLIB_DEBUG -#CFLAGS=-O3 -Wall -Wwrite-strings -Wpointer-arith -Wconversion \ -# -Wstrict-prototypes -Wmissing-prototypes - -SFLAGS=-O -LDFLAGS= -TEST_LDFLAGS=-L. libz.a -LDSHARED=$(CC) -CPP=$(CC) -E - -STATICLIB=libz.a -SHAREDLIB=libz.so -SHAREDLIBV=libz.so.1.2.11 -SHAREDLIBM=libz.so.1 -LIBS=$(STATICLIB) $(SHAREDLIBV) - -AR=ar -ARFLAGS=rc -RANLIB=ranlib -LDCONFIG=ldconfig -LDSHAREDLIBC=-lc -TAR=tar -SHELL=/bin/sh -EXE= - -prefix = /usr/local -exec_prefix = ${prefix} -libdir = ${exec_prefix}/lib -sharedlibdir = ${libdir} -includedir = ${prefix}/include -mandir = ${prefix}/share/man -man3dir = ${mandir}/man3 -pkgconfigdir = ${libdir}/pkgconfig -SRCDIR= -ZINC= -ZINCOUT=-I. - -OBJZ = adler32.o crc32.o deflate.o infback.o inffast.o inflate.o inftrees.o trees.o zutil.o -OBJG = compress.o uncompr.o gzclose.o gzlib.o gzread.o gzwrite.o -OBJC = $(OBJZ) $(OBJG) - -PIC_OBJZ = adler32.lo crc32.lo deflate.lo infback.lo inffast.lo inflate.lo inftrees.lo trees.lo zutil.lo -PIC_OBJG = compress.lo uncompr.lo gzclose.lo gzlib.lo gzread.lo gzwrite.lo -PIC_OBJC = $(PIC_OBJZ) $(PIC_OBJG) - -# to use the asm code: make OBJA=match.o, PIC_OBJA=match.lo -OBJA = -PIC_OBJA = - -OBJS = $(OBJC) $(OBJA) - -PIC_OBJS = $(PIC_OBJC) $(PIC_OBJA) - -all: static shared - -static: example$(EXE) minigzip$(EXE) - -shared: examplesh$(EXE) minigzipsh$(EXE) - -all64: example64$(EXE) minigzip64$(EXE) - -check: test - -test: all teststatic testshared - -teststatic: static - @TMPST=tmpst_$$; \ - if echo hello world | ./minigzip | ./minigzip -d && ./example $$TMPST ; then \ - echo ' *** zlib test OK ***'; \ - else \ - echo ' *** zlib test FAILED ***'; false; \ - fi; \ - rm -f $$TMPST - -testshared: shared - @LD_LIBRARY_PATH=`pwd`:$(LD_LIBRARY_PATH) ; export LD_LIBRARY_PATH; \ - LD_LIBRARYN32_PATH=`pwd`:$(LD_LIBRARYN32_PATH) ; export LD_LIBRARYN32_PATH; \ - DYLD_LIBRARY_PATH=`pwd`:$(DYLD_LIBRARY_PATH) ; export DYLD_LIBRARY_PATH; \ - SHLIB_PATH=`pwd`:$(SHLIB_PATH) ; export SHLIB_PATH; \ - TMPSH=tmpsh_$$; \ - if echo hello world | ./minigzipsh | ./minigzipsh -d && ./examplesh $$TMPSH; then \ - echo ' *** zlib shared test OK ***'; \ - else \ - echo ' *** zlib shared test FAILED ***'; false; \ - fi; \ - rm -f $$TMPSH - -test64: all64 - @TMP64=tmp64_$$; \ - if echo hello world | ./minigzip64 | ./minigzip64 -d && ./example64 $$TMP64; then \ - echo ' *** zlib 64-bit test OK ***'; \ - else \ - echo ' *** zlib 64-bit test FAILED ***'; false; \ - fi; \ - rm -f $$TMP64 - -infcover.o: $(SRCDIR)test/infcover.c $(SRCDIR)zlib.h zconf.h - $(CC) $(CFLAGS) $(ZINCOUT) -c -o $@ $(SRCDIR)test/infcover.c - -infcover: infcover.o libz.a - $(CC) $(CFLAGS) -o $@ infcover.o libz.a - -cover: infcover - rm -f *.gcda - ./infcover - gcov inf*.c - -libz.a: $(OBJS) - $(AR) $(ARFLAGS) $@ $(OBJS) - -@ ($(RANLIB) $@ || true) >/dev/null 2>&1 - -match.o: match.S - $(CPP) match.S > _match.s - $(CC) -c _match.s - mv _match.o match.o - rm -f _match.s - -match.lo: match.S - $(CPP) match.S > _match.s - $(CC) -c -fPIC _match.s - mv _match.o match.lo - rm -f _match.s - -example.o: $(SRCDIR)test/example.c $(SRCDIR)zlib.h zconf.h - $(CC) $(CFLAGS) $(ZINCOUT) -c -o $@ $(SRCDIR)test/example.c - -minigzip.o: $(SRCDIR)test/minigzip.c $(SRCDIR)zlib.h zconf.h - $(CC) $(CFLAGS) $(ZINCOUT) -c -o $@ $(SRCDIR)test/minigzip.c - -example64.o: $(SRCDIR)test/example.c $(SRCDIR)zlib.h zconf.h - $(CC) $(CFLAGS) $(ZINCOUT) -D_FILE_OFFSET_BITS=64 -c -o $@ $(SRCDIR)test/example.c - -minigzip64.o: $(SRCDIR)test/minigzip.c $(SRCDIR)zlib.h zconf.h - $(CC) $(CFLAGS) $(ZINCOUT) -D_FILE_OFFSET_BITS=64 -c -o $@ $(SRCDIR)test/minigzip.c - - -adler32.o: $(SRCDIR)adler32.c - $(CC) $(CFLAGS) $(ZINC) -c -o $@ $(SRCDIR)adler32.c - -crc32.o: $(SRCDIR)crc32.c - $(CC) $(CFLAGS) $(ZINC) -c -o $@ $(SRCDIR)crc32.c - -deflate.o: $(SRCDIR)deflate.c - $(CC) $(CFLAGS) $(ZINC) -c -o $@ $(SRCDIR)deflate.c - -infback.o: $(SRCDIR)infback.c - $(CC) $(CFLAGS) $(ZINC) -c -o $@ $(SRCDIR)infback.c - -inffast.o: $(SRCDIR)inffast.c - $(CC) $(CFLAGS) $(ZINC) -c -o $@ $(SRCDIR)inffast.c - -inflate.o: $(SRCDIR)inflate.c - $(CC) $(CFLAGS) $(ZINC) -c -o $@ $(SRCDIR)inflate.c - -inftrees.o: $(SRCDIR)inftrees.c - $(CC) $(CFLAGS) $(ZINC) -c -o $@ $(SRCDIR)inftrees.c - -trees.o: $(SRCDIR)trees.c - $(CC) $(CFLAGS) $(ZINC) -c -o $@ $(SRCDIR)trees.c - -zutil.o: $(SRCDIR)zutil.c - $(CC) $(CFLAGS) $(ZINC) -c -o $@ $(SRCDIR)zutil.c - -compress.o: $(SRCDIR)compress.c - $(CC) $(CFLAGS) $(ZINC) -c -o $@ $(SRCDIR)compress.c - -uncompr.o: $(SRCDIR)uncompr.c - $(CC) $(CFLAGS) $(ZINC) -c -o $@ $(SRCDIR)uncompr.c - -gzclose.o: $(SRCDIR)gzclose.c - $(CC) $(CFLAGS) $(ZINC) -c -o $@ $(SRCDIR)gzclose.c - -gzlib.o: $(SRCDIR)gzlib.c - $(CC) $(CFLAGS) $(ZINC) -c -o $@ $(SRCDIR)gzlib.c - -gzread.o: $(SRCDIR)gzread.c - $(CC) $(CFLAGS) $(ZINC) -c -o $@ $(SRCDIR)gzread.c - -gzwrite.o: $(SRCDIR)gzwrite.c - $(CC) $(CFLAGS) $(ZINC) -c -o $@ $(SRCDIR)gzwrite.c - - -adler32.lo: $(SRCDIR)adler32.c - -@mkdir objs 2>/dev/null || test -d objs - $(CC) $(SFLAGS) $(ZINC) -DPIC -c -o objs/adler32.o $(SRCDIR)adler32.c - -@mv objs/adler32.o $@ - -crc32.lo: $(SRCDIR)crc32.c - -@mkdir objs 2>/dev/null || test -d objs - $(CC) $(SFLAGS) $(ZINC) -DPIC -c -o objs/crc32.o $(SRCDIR)crc32.c - -@mv objs/crc32.o $@ - -deflate.lo: $(SRCDIR)deflate.c - -@mkdir objs 2>/dev/null || test -d objs - $(CC) $(SFLAGS) $(ZINC) -DPIC -c -o objs/deflate.o $(SRCDIR)deflate.c - -@mv objs/deflate.o $@ - -infback.lo: $(SRCDIR)infback.c - -@mkdir objs 2>/dev/null || test -d objs - $(CC) $(SFLAGS) $(ZINC) -DPIC -c -o objs/infback.o $(SRCDIR)infback.c - -@mv objs/infback.o $@ - -inffast.lo: $(SRCDIR)inffast.c - -@mkdir objs 2>/dev/null || test -d objs - $(CC) $(SFLAGS) $(ZINC) -DPIC -c -o objs/inffast.o $(SRCDIR)inffast.c - -@mv objs/inffast.o $@ - -inflate.lo: $(SRCDIR)inflate.c - -@mkdir objs 2>/dev/null || test -d objs - $(CC) $(SFLAGS) $(ZINC) -DPIC -c -o objs/inflate.o $(SRCDIR)inflate.c - -@mv objs/inflate.o $@ - -inftrees.lo: $(SRCDIR)inftrees.c - -@mkdir objs 2>/dev/null || test -d objs - $(CC) $(SFLAGS) $(ZINC) -DPIC -c -o objs/inftrees.o $(SRCDIR)inftrees.c - -@mv objs/inftrees.o $@ - -trees.lo: $(SRCDIR)trees.c - -@mkdir objs 2>/dev/null || test -d objs - $(CC) $(SFLAGS) $(ZINC) -DPIC -c -o objs/trees.o $(SRCDIR)trees.c - -@mv objs/trees.o $@ - -zutil.lo: $(SRCDIR)zutil.c - -@mkdir objs 2>/dev/null || test -d objs - $(CC) $(SFLAGS) $(ZINC) -DPIC -c -o objs/zutil.o $(SRCDIR)zutil.c - -@mv objs/zutil.o $@ - -compress.lo: $(SRCDIR)compress.c - -@mkdir objs 2>/dev/null || test -d objs - $(CC) $(SFLAGS) $(ZINC) -DPIC -c -o objs/compress.o $(SRCDIR)compress.c - -@mv objs/compress.o $@ - -uncompr.lo: $(SRCDIR)uncompr.c - -@mkdir objs 2>/dev/null || test -d objs - $(CC) $(SFLAGS) $(ZINC) -DPIC -c -o objs/uncompr.o $(SRCDIR)uncompr.c - -@mv objs/uncompr.o $@ - -gzclose.lo: $(SRCDIR)gzclose.c - -@mkdir objs 2>/dev/null || test -d objs - $(CC) $(SFLAGS) $(ZINC) -DPIC -c -o objs/gzclose.o $(SRCDIR)gzclose.c - -@mv objs/gzclose.o $@ - -gzlib.lo: $(SRCDIR)gzlib.c - -@mkdir objs 2>/dev/null || test -d objs - $(CC) $(SFLAGS) $(ZINC) -DPIC -c -o objs/gzlib.o $(SRCDIR)gzlib.c - -@mv objs/gzlib.o $@ - -gzread.lo: $(SRCDIR)gzread.c - -@mkdir objs 2>/dev/null || test -d objs - $(CC) $(SFLAGS) $(ZINC) -DPIC -c -o objs/gzread.o $(SRCDIR)gzread.c - -@mv objs/gzread.o $@ - -gzwrite.lo: $(SRCDIR)gzwrite.c - -@mkdir objs 2>/dev/null || test -d objs - $(CC) $(SFLAGS) $(ZINC) -DPIC -c -o objs/gzwrite.o $(SRCDIR)gzwrite.c - -@mv objs/gzwrite.o $@ - - -placebo $(SHAREDLIBV): $(PIC_OBJS) libz.a - $(LDSHARED) $(SFLAGS) -o $@ $(PIC_OBJS) $(LDSHAREDLIBC) $(LDFLAGS) - rm -f $(SHAREDLIB) $(SHAREDLIBM) - ln -s $@ $(SHAREDLIB) - ln -s $@ $(SHAREDLIBM) - -@rmdir objs - -example$(EXE): example.o $(STATICLIB) - $(CC) $(CFLAGS) -o $@ example.o $(TEST_LDFLAGS) - -minigzip$(EXE): minigzip.o $(STATICLIB) - $(CC) $(CFLAGS) -o $@ minigzip.o $(TEST_LDFLAGS) - -examplesh$(EXE): example.o $(SHAREDLIBV) - $(CC) $(CFLAGS) -o $@ example.o -L. $(SHAREDLIBV) - -minigzipsh$(EXE): minigzip.o $(SHAREDLIBV) - $(CC) $(CFLAGS) -o $@ minigzip.o -L. $(SHAREDLIBV) - -example64$(EXE): example64.o $(STATICLIB) - $(CC) $(CFLAGS) -o $@ example64.o $(TEST_LDFLAGS) - -minigzip64$(EXE): minigzip64.o $(STATICLIB) - $(CC) $(CFLAGS) -o $@ minigzip64.o $(TEST_LDFLAGS) - -install-libs: $(LIBS) - -@if [ ! -d $(DESTDIR)$(exec_prefix) ]; then mkdir -p $(DESTDIR)$(exec_prefix); fi - -@if [ ! -d $(DESTDIR)$(libdir) ]; then mkdir -p $(DESTDIR)$(libdir); fi - -@if [ ! -d $(DESTDIR)$(sharedlibdir) ]; then mkdir -p $(DESTDIR)$(sharedlibdir); fi - -@if [ ! -d $(DESTDIR)$(man3dir) ]; then mkdir -p $(DESTDIR)$(man3dir); fi - -@if [ ! -d $(DESTDIR)$(pkgconfigdir) ]; then mkdir -p $(DESTDIR)$(pkgconfigdir); fi - rm -f $(DESTDIR)$(libdir)/$(STATICLIB) - cp $(STATICLIB) $(DESTDIR)$(libdir) - chmod 644 $(DESTDIR)$(libdir)/$(STATICLIB) - -@($(RANLIB) $(DESTDIR)$(libdir)/libz.a || true) >/dev/null 2>&1 - -@if test -n "$(SHAREDLIBV)"; then \ - rm -f $(DESTDIR)$(sharedlibdir)/$(SHAREDLIBV); \ - cp $(SHAREDLIBV) $(DESTDIR)$(sharedlibdir); \ - echo "cp $(SHAREDLIBV) $(DESTDIR)$(sharedlibdir)"; \ - chmod 755 $(DESTDIR)$(sharedlibdir)/$(SHAREDLIBV); \ - echo "chmod 755 $(DESTDIR)$(sharedlibdir)/$(SHAREDLIBV)"; \ - rm -f $(DESTDIR)$(sharedlibdir)/$(SHAREDLIB) $(DESTDIR)$(sharedlibdir)/$(SHAREDLIBM); \ - ln -s $(SHAREDLIBV) $(DESTDIR)$(sharedlibdir)/$(SHAREDLIB); \ - ln -s $(SHAREDLIBV) $(DESTDIR)$(sharedlibdir)/$(SHAREDLIBM); \ - ($(LDCONFIG) || true) >/dev/null 2>&1; \ - fi - rm -f $(DESTDIR)$(man3dir)/zlib.3 - cp $(SRCDIR)zlib.3 $(DESTDIR)$(man3dir) - chmod 644 $(DESTDIR)$(man3dir)/zlib.3 - rm -f $(DESTDIR)$(pkgconfigdir)/zlib.pc - cp zlib.pc $(DESTDIR)$(pkgconfigdir) - chmod 644 $(DESTDIR)$(pkgconfigdir)/zlib.pc -# The ranlib in install is needed on NeXTSTEP which checks file times -# ldconfig is for Linux - -install: install-libs - -@if [ ! -d $(DESTDIR)$(includedir) ]; then mkdir -p $(DESTDIR)$(includedir); fi - rm -f $(DESTDIR)$(includedir)/zlib.h $(DESTDIR)$(includedir)/zconf.h - cp $(SRCDIR)zlib.h zconf.h $(DESTDIR)$(includedir) - chmod 644 $(DESTDIR)$(includedir)/zlib.h $(DESTDIR)$(includedir)/zconf.h - -uninstall: - cd $(DESTDIR)$(includedir) && rm -f zlib.h zconf.h - cd $(DESTDIR)$(libdir) && rm -f libz.a; \ - if test -n "$(SHAREDLIBV)" -a -f $(SHAREDLIBV); then \ - rm -f $(SHAREDLIBV) $(SHAREDLIB) $(SHAREDLIBM); \ - fi - cd $(DESTDIR)$(man3dir) && rm -f zlib.3 - cd $(DESTDIR)$(pkgconfigdir) && rm -f zlib.pc - -docs: zlib.3.pdf - -zlib.3.pdf: $(SRCDIR)zlib.3 - groff -mandoc -f H -T ps $(SRCDIR)zlib.3 | ps2pdf - $@ - -zconf.h.cmakein: $(SRCDIR)zconf.h.in - -@ TEMPFILE=zconfh_$$; \ - echo "/#define ZCONF_H/ a\\\\\n#cmakedefine Z_PREFIX\\\\\n#cmakedefine Z_HAVE_UNISTD_H\n" >> $$TEMPFILE &&\ - sed -f $$TEMPFILE $(SRCDIR)zconf.h.in > $@ &&\ - touch -r $(SRCDIR)zconf.h.in $@ &&\ - rm $$TEMPFILE - -zconf: $(SRCDIR)zconf.h.in - cp -p $(SRCDIR)zconf.h.in zconf.h - -mostlyclean: clean -clean: - rm -f *.o *.lo *~ \ - example$(EXE) minigzip$(EXE) examplesh$(EXE) minigzipsh$(EXE) \ - example64$(EXE) minigzip64$(EXE) \ - infcover \ - libz.* foo.gz so_locations \ - _match.s maketree contrib/infback9/*.o - rm -rf objs - rm -f *.gcda *.gcno *.gcov - rm -f contrib/infback9/*.gcda contrib/infback9/*.gcno contrib/infback9/*.gcov - -maintainer-clean: distclean -distclean: clean zconf zconf.h.cmakein docs - rm -f Makefile zlib.pc configure.log - -@rm -f .DS_Store - @if [ -f Makefile.in ]; then \ - printf 'all:\n\t-@echo "Please use ./configure first. Thank you."\n' > Makefile ; \ - printf '\ndistclean:\n\tmake -f Makefile.in distclean\n' >> Makefile ; \ - touch -r $(SRCDIR)Makefile.in Makefile ; fi - @if [ ! -f zconf.h.in ]; then rm -f zconf.h zconf.h.cmakein ; fi - @if [ ! -f zlib.3 ]; then rm -f zlib.3.pdf ; fi - -tags: - etags $(SRCDIR)*.[ch] - -adler32.o zutil.o: $(SRCDIR)zutil.h $(SRCDIR)zlib.h zconf.h -gzclose.o gzlib.o gzread.o gzwrite.o: $(SRCDIR)zlib.h zconf.h $(SRCDIR)gzguts.h -compress.o example.o minigzip.o uncompr.o: $(SRCDIR)zlib.h zconf.h -crc32.o: $(SRCDIR)zutil.h $(SRCDIR)zlib.h zconf.h $(SRCDIR)crc32.h -deflate.o: $(SRCDIR)deflate.h $(SRCDIR)zutil.h $(SRCDIR)zlib.h zconf.h -infback.o inflate.o: $(SRCDIR)zutil.h $(SRCDIR)zlib.h zconf.h $(SRCDIR)inftrees.h $(SRCDIR)inflate.h $(SRCDIR)inffast.h $(SRCDIR)inffixed.h -inffast.o: $(SRCDIR)zutil.h $(SRCDIR)zlib.h zconf.h $(SRCDIR)inftrees.h $(SRCDIR)inflate.h $(SRCDIR)inffast.h -inftrees.o: $(SRCDIR)zutil.h $(SRCDIR)zlib.h zconf.h $(SRCDIR)inftrees.h -trees.o: $(SRCDIR)deflate.h $(SRCDIR)zutil.h $(SRCDIR)zlib.h zconf.h $(SRCDIR)trees.h - -adler32.lo zutil.lo: $(SRCDIR)zutil.h $(SRCDIR)zlib.h zconf.h -gzclose.lo gzlib.lo gzread.lo gzwrite.lo: $(SRCDIR)zlib.h zconf.h $(SRCDIR)gzguts.h -compress.lo example.lo minigzip.lo uncompr.lo: $(SRCDIR)zlib.h zconf.h -crc32.lo: $(SRCDIR)zutil.h $(SRCDIR)zlib.h zconf.h $(SRCDIR)crc32.h -deflate.lo: $(SRCDIR)deflate.h $(SRCDIR)zutil.h $(SRCDIR)zlib.h zconf.h -infback.lo inflate.lo: $(SRCDIR)zutil.h $(SRCDIR)zlib.h zconf.h $(SRCDIR)inftrees.h $(SRCDIR)inflate.h $(SRCDIR)inffast.h $(SRCDIR)inffixed.h -inffast.lo: $(SRCDIR)zutil.h $(SRCDIR)zlib.h zconf.h $(SRCDIR)inftrees.h $(SRCDIR)inflate.h $(SRCDIR)inffast.h -inftrees.lo: $(SRCDIR)zutil.h $(SRCDIR)zlib.h zconf.h $(SRCDIR)inftrees.h -trees.lo: $(SRCDIR)deflate.h $(SRCDIR)zutil.h $(SRCDIR)zlib.h zconf.h $(SRCDIR)trees.h DELETED compat/zlib/README Index: compat/zlib/README ================================================================== --- compat/zlib/README +++ /dev/null @@ -1,115 +0,0 @@ -ZLIB DATA COMPRESSION LIBRARY - -zlib 1.2.11 is a general purpose data compression library. All the code is -thread safe. The data format used by the zlib library is described by RFCs -(Request for Comments) 1950 to 1952 in the files -http://tools.ietf.org/html/rfc1950 (zlib format), rfc1951 (deflate format) and -rfc1952 (gzip format). - -All functions of the compression library are documented in the file zlib.h -(volunteer to write man pages welcome, contact zlib@gzip.org). A usage example -of the library is given in the file test/example.c which also tests that -the library is working correctly. Another example is given in the file -test/minigzip.c. The compression library itself is composed of all source -files in the root directory. - -To compile all files and run the test program, follow the instructions given at -the top of Makefile.in. In short "./configure; make test", and if that goes -well, "make install" should work for most flavors of Unix. For Windows, use -one of the special makefiles in win32/ or contrib/vstudio/ . For VMS, use -make_vms.com. - -Questions about zlib should be sent to , or to Gilles Vollant - for the Windows DLL version. The zlib home page is -http://zlib.net/ . Before reporting a problem, please check this site to -verify that you have the latest version of zlib; otherwise get the latest -version and check whether the problem still exists or not. - -PLEASE read the zlib FAQ http://zlib.net/zlib_faq.html before asking for help. - -Mark Nelson wrote an article about zlib for the Jan. 1997 -issue of Dr. Dobb's Journal; a copy of the article is available at -http://marknelson.us/1997/01/01/zlib-engine/ . - -The changes made in version 1.2.11 are documented in the file ChangeLog. - -Unsupported third party contributions are provided in directory contrib/ . - -zlib is available in Java using the java.util.zip package, documented at -http://java.sun.com/developer/technicalArticles/Programming/compression/ . - -A Perl interface to zlib written by Paul Marquess is available -at CPAN (Comprehensive Perl Archive Network) sites, including -http://search.cpan.org/~pmqs/IO-Compress-Zlib/ . - -A Python interface to zlib written by A.M. Kuchling is -available in Python 1.5 and later versions, see -http://docs.python.org/library/zlib.html . - -zlib is built into tcl: http://wiki.tcl.tk/4610 . - -An experimental package to read and write files in .zip format, written on top -of zlib by Gilles Vollant , is available in the -contrib/minizip directory of zlib. - - -Notes for some targets: - -- For Windows DLL versions, please see win32/DLL_FAQ.txt - -- For 64-bit Irix, deflate.c must be compiled without any optimization. With - -O, one libpng test fails. The test works in 32 bit mode (with the -n32 - compiler flag). The compiler bug has been reported to SGI. - -- zlib doesn't work with gcc 2.6.3 on a DEC 3000/300LX under OSF/1 2.1 it works - when compiled with cc. - -- On Digital Unix 4.0D (formely OSF/1) on AlphaServer, the cc option -std1 is - necessary to get gzprintf working correctly. This is done by configure. - -- zlib doesn't work on HP-UX 9.05 with some versions of /bin/cc. It works with - other compilers. Use "make test" to check your compiler. - -- gzdopen is not supported on RISCOS or BEOS. - -- For PalmOs, see http://palmzlib.sourceforge.net/ - - -Acknowledgments: - - The deflate format used by zlib was defined by Phil Katz. The deflate and - zlib specifications were written by L. Peter Deutsch. Thanks to all the - people who reported problems and suggested various improvements in zlib; they - are too numerous to cite here. - -Copyright notice: - - (C) 1995-2017 Jean-loup Gailly and Mark Adler - - This software is provided 'as-is', without any express or implied - warranty. In no event will the authors be held liable for any damages - arising from the use of this software. - - Permission is granted to anyone to use this software for any purpose, - including commercial applications, and to alter it and redistribute it - freely, subject to the following restrictions: - - 1. The origin of this software must not be misrepresented; you must not - claim that you wrote the original software. If you use this software - in a product, an acknowledgment in the product documentation would be - appreciated but is not required. - 2. Altered source versions must be plainly marked as such, and must not be - misrepresented as being the original software. - 3. This notice may not be removed or altered from any source distribution. - - Jean-loup Gailly Mark Adler - jloup@gzip.org madler@alumni.caltech.edu - -If you use the zlib library in a product, we would appreciate *not* receiving -lengthy legal documents to sign. The sources are provided for free but without -warranty of any kind. The library has been entirely written by Jean-loup -Gailly and Mark Adler; it does not include third-party code. - -If you redistribute modified sources, we would appreciate that you include in -the file ChangeLog history information documenting your changes. Please read -the FAQ for more information on the distribution of modified source versions. DELETED compat/zlib/adler32.c Index: compat/zlib/adler32.c ================================================================== --- compat/zlib/adler32.c +++ /dev/null @@ -1,186 +0,0 @@ -/* adler32.c -- compute the Adler-32 checksum of a data stream - * Copyright (C) 1995-2011, 2016 Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -/* @(#) $Id$ */ - -#include "zutil.h" - -local uLong adler32_combine_ OF((uLong adler1, uLong adler2, z_off64_t len2)); - -#define BASE 65521U /* largest prime smaller than 65536 */ -#define NMAX 5552 -/* NMAX is the largest n such that 255n(n+1)/2 + (n+1)(BASE-1) <= 2^32-1 */ - -#define DO1(buf,i) {adler += (buf)[i]; sum2 += adler;} -#define DO2(buf,i) DO1(buf,i); DO1(buf,i+1); -#define DO4(buf,i) DO2(buf,i); DO2(buf,i+2); -#define DO8(buf,i) DO4(buf,i); DO4(buf,i+4); -#define DO16(buf) DO8(buf,0); DO8(buf,8); - -/* use NO_DIVIDE if your processor does not do division in hardware -- - try it both ways to see which is faster */ -#ifdef NO_DIVIDE -/* note that this assumes BASE is 65521, where 65536 % 65521 == 15 - (thank you to John Reiser for pointing this out) */ -# define CHOP(a) \ - do { \ - unsigned long tmp = a >> 16; \ - a &= 0xffffUL; \ - a += (tmp << 4) - tmp; \ - } while (0) -# define MOD28(a) \ - do { \ - CHOP(a); \ - if (a >= BASE) a -= BASE; \ - } while (0) -# define MOD(a) \ - do { \ - CHOP(a); \ - MOD28(a); \ - } while (0) -# define MOD63(a) \ - do { /* this assumes a is not negative */ \ - z_off64_t tmp = a >> 32; \ - a &= 0xffffffffL; \ - a += (tmp << 8) - (tmp << 5) + tmp; \ - tmp = a >> 16; \ - a &= 0xffffL; \ - a += (tmp << 4) - tmp; \ - tmp = a >> 16; \ - a &= 0xffffL; \ - a += (tmp << 4) - tmp; \ - if (a >= BASE) a -= BASE; \ - } while (0) -#else -# define MOD(a) a %= BASE -# define MOD28(a) a %= BASE -# define MOD63(a) a %= BASE -#endif - -/* ========================================================================= */ -uLong ZEXPORT adler32_z(adler, buf, len) - uLong adler; - const Bytef *buf; - z_size_t len; -{ - unsigned long sum2; - unsigned n; - - /* split Adler-32 into component sums */ - sum2 = (adler >> 16) & 0xffff; - adler &= 0xffff; - - /* in case user likes doing a byte at a time, keep it fast */ - if (len == 1) { - adler += buf[0]; - if (adler >= BASE) - adler -= BASE; - sum2 += adler; - if (sum2 >= BASE) - sum2 -= BASE; - return adler | (sum2 << 16); - } - - /* initial Adler-32 value (deferred check for len == 1 speed) */ - if (buf == Z_NULL) - return 1L; - - /* in case short lengths are provided, keep it somewhat fast */ - if (len < 16) { - while (len--) { - adler += *buf++; - sum2 += adler; - } - if (adler >= BASE) - adler -= BASE; - MOD28(sum2); /* only added so many BASE's */ - return adler | (sum2 << 16); - } - - /* do length NMAX blocks -- requires just one modulo operation */ - while (len >= NMAX) { - len -= NMAX; - n = NMAX / 16; /* NMAX is divisible by 16 */ - do { - DO16(buf); /* 16 sums unrolled */ - buf += 16; - } while (--n); - MOD(adler); - MOD(sum2); - } - - /* do remaining bytes (less than NMAX, still just one modulo) */ - if (len) { /* avoid modulos if none remaining */ - while (len >= 16) { - len -= 16; - DO16(buf); - buf += 16; - } - while (len--) { - adler += *buf++; - sum2 += adler; - } - MOD(adler); - MOD(sum2); - } - - /* return recombined sums */ - return adler | (sum2 << 16); -} - -/* ========================================================================= */ -uLong ZEXPORT adler32(adler, buf, len) - uLong adler; - const Bytef *buf; - uInt len; -{ - return adler32_z(adler, buf, len); -} - -/* ========================================================================= */ -local uLong adler32_combine_(adler1, adler2, len2) - uLong adler1; - uLong adler2; - z_off64_t len2; -{ - unsigned long sum1; - unsigned long sum2; - unsigned rem; - - /* for negative len, return invalid adler32 as a clue for debugging */ - if (len2 < 0) - return 0xffffffffUL; - - /* the derivation of this formula is left as an exercise for the reader */ - MOD63(len2); /* assumes len2 >= 0 */ - rem = (unsigned)len2; - sum1 = adler1 & 0xffff; - sum2 = rem * sum1; - MOD(sum2); - sum1 += (adler2 & 0xffff) + BASE - 1; - sum2 += ((adler1 >> 16) & 0xffff) + ((adler2 >> 16) & 0xffff) + BASE - rem; - if (sum1 >= BASE) sum1 -= BASE; - if (sum1 >= BASE) sum1 -= BASE; - if (sum2 >= ((unsigned long)BASE << 1)) sum2 -= ((unsigned long)BASE << 1); - if (sum2 >= BASE) sum2 -= BASE; - return sum1 | (sum2 << 16); -} - -/* ========================================================================= */ -uLong ZEXPORT adler32_combine(adler1, adler2, len2) - uLong adler1; - uLong adler2; - z_off_t len2; -{ - return adler32_combine_(adler1, adler2, len2); -} - -uLong ZEXPORT adler32_combine64(adler1, adler2, len2) - uLong adler1; - uLong adler2; - z_off64_t len2; -{ - return adler32_combine_(adler1, adler2, len2); -} DELETED compat/zlib/amiga/Makefile.pup Index: compat/zlib/amiga/Makefile.pup ================================================================== --- compat/zlib/amiga/Makefile.pup +++ /dev/null @@ -1,69 +0,0 @@ -# Amiga powerUP (TM) Makefile -# makefile for libpng and SAS C V6.58/7.00 PPC compiler -# Copyright (C) 1998 by Andreas R. Kleinert - -LIBNAME = libzip.a - -CC = scppc -CFLAGS = NOSTKCHK NOSINT OPTIMIZE OPTGO OPTPEEP OPTINLOCAL OPTINL \ - OPTLOOP OPTRDEP=8 OPTDEP=8 OPTCOMP=8 NOVER -AR = ppc-amigaos-ar cr -RANLIB = ppc-amigaos-ranlib -LD = ppc-amigaos-ld -r -LDFLAGS = -o -LDLIBS = LIB:scppc.a LIB:end.o -RM = delete quiet - -OBJS = adler32.o compress.o crc32.o gzclose.o gzlib.o gzread.o gzwrite.o \ - uncompr.o deflate.o trees.o zutil.o inflate.o infback.o inftrees.o inffast.o - -TEST_OBJS = example.o minigzip.o - -all: example minigzip - -check: test -test: all - example - echo hello world | minigzip | minigzip -d - -$(LIBNAME): $(OBJS) - $(AR) $@ $(OBJS) - -$(RANLIB) $@ - -example: example.o $(LIBNAME) - $(LD) $(LDFLAGS) $@ LIB:c_ppc.o $@.o $(LIBNAME) $(LDLIBS) - -minigzip: minigzip.o $(LIBNAME) - $(LD) $(LDFLAGS) $@ LIB:c_ppc.o $@.o $(LIBNAME) $(LDLIBS) - -mostlyclean: clean -clean: - $(RM) *.o example minigzip $(LIBNAME) foo.gz - -zip: - zip -ul9 zlib README ChangeLog Makefile Make????.??? Makefile.?? \ - descrip.mms *.[ch] - -tgz: - cd ..; tar cfz zlib/zlib.tgz zlib/README zlib/ChangeLog zlib/Makefile \ - zlib/Make????.??? zlib/Makefile.?? zlib/descrip.mms zlib/*.[ch] - -# DO NOT DELETE THIS LINE -- make depend depends on it. - -adler32.o: zlib.h zconf.h -compress.o: zlib.h zconf.h -crc32.o: crc32.h zlib.h zconf.h -deflate.o: deflate.h zutil.h zlib.h zconf.h -example.o: zlib.h zconf.h -gzclose.o: zlib.h zconf.h gzguts.h -gzlib.o: zlib.h zconf.h gzguts.h -gzread.o: zlib.h zconf.h gzguts.h -gzwrite.o: zlib.h zconf.h gzguts.h -inffast.o: zutil.h zlib.h zconf.h inftrees.h inflate.h inffast.h -inflate.o: zutil.h zlib.h zconf.h inftrees.h inflate.h inffast.h -infback.o: zutil.h zlib.h zconf.h inftrees.h inflate.h inffast.h -inftrees.o: zutil.h zlib.h zconf.h inftrees.h -minigzip.o: zlib.h zconf.h -trees.o: deflate.h zutil.h zlib.h zconf.h trees.h -uncompr.o: zlib.h zconf.h -zutil.o: zutil.h zlib.h zconf.h DELETED compat/zlib/amiga/Makefile.sas Index: compat/zlib/amiga/Makefile.sas ================================================================== --- compat/zlib/amiga/Makefile.sas +++ /dev/null @@ -1,68 +0,0 @@ -# SMakefile for zlib -# Modified from the standard UNIX Makefile Copyright Jean-loup Gailly -# Osma Ahvenlampi -# Amiga, SAS/C 6.56 & Smake - -CC=sc -CFLAGS=OPT -#CFLAGS=OPT CPU=68030 -#CFLAGS=DEBUG=LINE -LDFLAGS=LIB z.lib - -SCOPTIONS=OPTSCHED OPTINLINE OPTALIAS OPTTIME OPTINLOCAL STRMERGE \ - NOICONS PARMS=BOTH NOSTACKCHECK UTILLIB NOVERSION ERRORREXX \ - DEF=POSTINC - -OBJS = adler32.o compress.o crc32.o gzclose.o gzlib.o gzread.o gzwrite.o \ - uncompr.o deflate.o trees.o zutil.o inflate.o infback.o inftrees.o inffast.o - -TEST_OBJS = example.o minigzip.o - -all: SCOPTIONS example minigzip - -check: test -test: all - example - echo hello world | minigzip | minigzip -d - -install: z.lib - copy clone zlib.h zconf.h INCLUDE: - copy clone z.lib LIB: - -z.lib: $(OBJS) - oml z.lib r $(OBJS) - -example: example.o z.lib - $(CC) $(CFLAGS) LINK TO $@ example.o $(LDFLAGS) - -minigzip: minigzip.o z.lib - $(CC) $(CFLAGS) LINK TO $@ minigzip.o $(LDFLAGS) - -mostlyclean: clean -clean: - -delete force quiet example minigzip *.o z.lib foo.gz *.lnk SCOPTIONS - -SCOPTIONS: Makefile.sas - copy to $@ (uLong)max ? max : (uInt)left; - left -= stream.avail_out; - } - if (stream.avail_in == 0) { - stream.avail_in = sourceLen > (uLong)max ? max : (uInt)sourceLen; - sourceLen -= stream.avail_in; - } - err = deflate(&stream, sourceLen ? Z_NO_FLUSH : Z_FINISH); - } while (err == Z_OK); - - *destLen = stream.total_out; - deflateEnd(&stream); - return err == Z_STREAM_END ? Z_OK : err; -} - -/* =========================================================================== - */ -int ZEXPORT compress (dest, destLen, source, sourceLen) - Bytef *dest; - uLongf *destLen; - const Bytef *source; - uLong sourceLen; -{ - return compress2(dest, destLen, source, sourceLen, Z_DEFAULT_COMPRESSION); -} - -/* =========================================================================== - If the default memLevel or windowBits for deflateInit() is changed, then - this function needs to be updated. - */ -uLong ZEXPORT compressBound (sourceLen) - uLong sourceLen; -{ - return sourceLen + (sourceLen >> 12) + (sourceLen >> 14) + - (sourceLen >> 25) + 13; -} DELETED compat/zlib/configure Index: compat/zlib/configure ================================================================== --- compat/zlib/configure +++ /dev/null @@ -1,921 +0,0 @@ -#!/bin/sh -# configure script for zlib. -# -# Normally configure builds both a static and a shared library. -# If you want to build just a static library, use: ./configure --static -# -# To impose specific compiler or flags or install directory, use for example: -# prefix=$HOME CC=cc CFLAGS="-O4" ./configure -# or for csh/tcsh users: -# (setenv prefix $HOME; setenv CC cc; setenv CFLAGS "-O4"; ./configure) - -# Incorrect settings of CC or CFLAGS may prevent creating a shared library. -# If you have problems, try without defining CC and CFLAGS before reporting -# an error. - -# start off configure.log -echo -------------------- >> configure.log -echo $0 $* >> configure.log -date >> configure.log - -# get source directory -SRCDIR=`dirname $0` -if test $SRCDIR = "."; then - ZINC="" - ZINCOUT="-I." - SRCDIR="" -else - ZINC='-include zconf.h' - ZINCOUT='-I. -I$(SRCDIR)' - SRCDIR="$SRCDIR/" -fi - -# set command prefix for cross-compilation -if [ -n "${CHOST}" ]; then - uname="`echo "${CHOST}" | sed -e 's/^[^-]*-\([^-]*\)$/\1/' -e 's/^[^-]*-[^-]*-\([^-]*\)$/\1/' -e 's/^[^-]*-[^-]*-\([^-]*\)-.*$/\1/'`" - CROSS_PREFIX="${CHOST}-" -fi - -# destination name for static library -STATICLIB=libz.a - -# extract zlib version numbers from zlib.h -VER=`sed -n -e '/VERSION "/s/.*"\(.*\)".*/\1/p' < ${SRCDIR}zlib.h` -VER3=`sed -n -e '/VERSION "/s/.*"\([0-9]*\\.[0-9]*\\.[0-9]*\).*/\1/p' < ${SRCDIR}zlib.h` -VER2=`sed -n -e '/VERSION "/s/.*"\([0-9]*\\.[0-9]*\)\\..*/\1/p' < ${SRCDIR}zlib.h` -VER1=`sed -n -e '/VERSION "/s/.*"\([0-9]*\)\\..*/\1/p' < ${SRCDIR}zlib.h` - -# establish commands for library building -if "${CROSS_PREFIX}ar" --version >/dev/null 2>/dev/null || test $? -lt 126; then - AR=${AR-"${CROSS_PREFIX}ar"} - test -n "${CROSS_PREFIX}" && echo Using ${AR} | tee -a configure.log -else - AR=${AR-"ar"} - test -n "${CROSS_PREFIX}" && echo Using ${AR} | tee -a configure.log -fi -ARFLAGS=${ARFLAGS-"rc"} -if "${CROSS_PREFIX}ranlib" --version >/dev/null 2>/dev/null || test $? -lt 126; then - RANLIB=${RANLIB-"${CROSS_PREFIX}ranlib"} - test -n "${CROSS_PREFIX}" && echo Using ${RANLIB} | tee -a configure.log -else - RANLIB=${RANLIB-"ranlib"} -fi -if "${CROSS_PREFIX}nm" --version >/dev/null 2>/dev/null || test $? -lt 126; then - NM=${NM-"${CROSS_PREFIX}nm"} - test -n "${CROSS_PREFIX}" && echo Using ${NM} | tee -a configure.log -else - NM=${NM-"nm"} -fi - -# set defaults before processing command line options -LDCONFIG=${LDCONFIG-"ldconfig"} -LDSHAREDLIBC="${LDSHAREDLIBC--lc}" -ARCHS= -prefix=${prefix-/usr/local} -exec_prefix=${exec_prefix-'${prefix}'} -libdir=${libdir-'${exec_prefix}/lib'} -sharedlibdir=${sharedlibdir-'${libdir}'} -includedir=${includedir-'${prefix}/include'} -mandir=${mandir-'${prefix}/share/man'} -shared_ext='.so' -shared=1 -solo=0 -cover=0 -zprefix=0 -zconst=0 -build64=0 -gcc=0 -warn=0 -debug=0 -old_cc="$CC" -old_cflags="$CFLAGS" -OBJC='$(OBJZ) $(OBJG)' -PIC_OBJC='$(PIC_OBJZ) $(PIC_OBJG)' - -# leave this script, optionally in a bad way -leave() -{ - if test "$*" != "0"; then - echo "** $0 aborting." | tee -a configure.log - fi - rm -f $test.[co] $test $test$shared_ext $test.gcno ./--version - echo -------------------- >> configure.log - echo >> configure.log - echo >> configure.log - exit $1 -} - -# process command line options -while test $# -ge 1 -do -case "$1" in - -h* | --help) - echo 'usage:' | tee -a configure.log - echo ' configure [--const] [--zprefix] [--prefix=PREFIX] [--eprefix=EXPREFIX]' | tee -a configure.log - echo ' [--static] [--64] [--libdir=LIBDIR] [--sharedlibdir=LIBDIR]' | tee -a configure.log - echo ' [--includedir=INCLUDEDIR] [--archs="-arch i386 -arch x86_64"]' | tee -a configure.log - exit 0 ;; - -p*=* | --prefix=*) prefix=`echo $1 | sed 's/.*=//'`; shift ;; - -e*=* | --eprefix=*) exec_prefix=`echo $1 | sed 's/.*=//'`; shift ;; - -l*=* | --libdir=*) libdir=`echo $1 | sed 's/.*=//'`; shift ;; - --sharedlibdir=*) sharedlibdir=`echo $1 | sed 's/.*=//'`; shift ;; - -i*=* | --includedir=*) includedir=`echo $1 | sed 's/.*=//'`;shift ;; - -u*=* | --uname=*) uname=`echo $1 | sed 's/.*=//'`;shift ;; - -p* | --prefix) prefix="$2"; shift; shift ;; - -e* | --eprefix) exec_prefix="$2"; shift; shift ;; - -l* | --libdir) libdir="$2"; shift; shift ;; - -i* | --includedir) includedir="$2"; shift; shift ;; - -s* | --shared | --enable-shared) shared=1; shift ;; - -t | --static) shared=0; shift ;; - --solo) solo=1; shift ;; - --cover) cover=1; shift ;; - -z* | --zprefix) zprefix=1; shift ;; - -6* | --64) build64=1; shift ;; - -a*=* | --archs=*) ARCHS=`echo $1 | sed 's/.*=//'`; shift ;; - --sysconfdir=*) echo "ignored option: --sysconfdir" | tee -a configure.log; shift ;; - --localstatedir=*) echo "ignored option: --localstatedir" | tee -a configure.log; shift ;; - -c* | --const) zconst=1; shift ;; - -w* | --warn) warn=1; shift ;; - -d* | --debug) debug=1; shift ;; - *) - echo "unknown option: $1" | tee -a configure.log - echo "$0 --help for help" | tee -a configure.log - leave 1;; - esac -done - -# temporary file name -test=ztest$$ - -# put arguments in log, also put test file in log if used in arguments -show() -{ - case "$*" in - *$test.c*) - echo === $test.c === >> configure.log - cat $test.c >> configure.log - echo === >> configure.log;; - esac - echo $* >> configure.log -} - -# check for gcc vs. cc and set compile and link flags based on the system identified by uname -cat > $test.c <&1` in - *gcc*) gcc=1 ;; - *clang*) gcc=1 ;; -esac - -show $cc -c $test.c -if test "$gcc" -eq 1 && ($cc -c $test.c) >> configure.log 2>&1; then - echo ... using gcc >> configure.log - CC="$cc" - CFLAGS="${CFLAGS--O3}" - SFLAGS="${CFLAGS--O3} -fPIC" - if test "$ARCHS"; then - CFLAGS="${CFLAGS} ${ARCHS}" - LDFLAGS="${LDFLAGS} ${ARCHS}" - fi - if test $build64 -eq 1; then - CFLAGS="${CFLAGS} -m64" - SFLAGS="${SFLAGS} -m64" - fi - if test "$warn" -eq 1; then - if test "$zconst" -eq 1; then - CFLAGS="${CFLAGS} -Wall -Wextra -Wcast-qual -pedantic -DZLIB_CONST" - else - CFLAGS="${CFLAGS} -Wall -Wextra -pedantic" - fi - fi - if test $debug -eq 1; then - CFLAGS="${CFLAGS} -DZLIB_DEBUG" - SFLAGS="${SFLAGS} -DZLIB_DEBUG" - fi - if test -z "$uname"; then - uname=`(uname -s || echo unknown) 2>/dev/null` - fi - case "$uname" in - Linux* | linux* | GNU | GNU/* | solaris*) - LDSHARED=${LDSHARED-"$cc -shared -Wl,-soname,libz.so.1,--version-script,${SRCDIR}zlib.map"} ;; - *BSD | *bsd* | DragonFly) - LDSHARED=${LDSHARED-"$cc -shared -Wl,-soname,libz.so.1,--version-script,${SRCDIR}zlib.map"} - LDCONFIG="ldconfig -m" ;; - CYGWIN* | Cygwin* | cygwin* | OS/2*) - EXE='.exe' ;; - MINGW* | mingw*) -# temporary bypass - rm -f $test.[co] $test $test$shared_ext - echo "Please use win32/Makefile.gcc instead." | tee -a configure.log - leave 1 - LDSHARED=${LDSHARED-"$cc -shared"} - LDSHAREDLIBC="" - EXE='.exe' ;; - QNX*) # This is for QNX6. I suppose that the QNX rule below is for QNX2,QNX4 - # (alain.bonnefoy@icbt.com) - LDSHARED=${LDSHARED-"$cc -shared -Wl,-hlibz.so.1"} ;; - HP-UX*) - LDSHARED=${LDSHARED-"$cc -shared $SFLAGS"} - case `(uname -m || echo unknown) 2>/dev/null` in - ia64) - shared_ext='.so' - SHAREDLIB='libz.so' ;; - *) - shared_ext='.sl' - SHAREDLIB='libz.sl' ;; - esac ;; - Darwin* | darwin*) - shared_ext='.dylib' - SHAREDLIB=libz$shared_ext - SHAREDLIBV=libz.$VER$shared_ext - SHAREDLIBM=libz.$VER1$shared_ext - LDSHARED=${LDSHARED-"$cc -dynamiclib -install_name $libdir/$SHAREDLIBM -compatibility_version $VER1 -current_version $VER3"} - if libtool -V 2>&1 | grep Apple > /dev/null; then - AR="libtool" - else - AR="/usr/bin/libtool" - fi - ARFLAGS="-o" ;; - *) LDSHARED=${LDSHARED-"$cc -shared"} ;; - esac -else - # find system name and corresponding cc options - CC=${CC-cc} - gcc=0 - echo ... using $CC >> configure.log - if test -z "$uname"; then - uname=`(uname -sr || echo unknown) 2>/dev/null` - fi - case "$uname" in - HP-UX*) SFLAGS=${CFLAGS-"-O +z"} - CFLAGS=${CFLAGS-"-O"} -# LDSHARED=${LDSHARED-"ld -b +vnocompatwarnings"} - LDSHARED=${LDSHARED-"ld -b"} - case `(uname -m || echo unknown) 2>/dev/null` in - ia64) - shared_ext='.so' - SHAREDLIB='libz.so' ;; - *) - shared_ext='.sl' - SHAREDLIB='libz.sl' ;; - esac ;; - IRIX*) SFLAGS=${CFLAGS-"-ansi -O2 -rpath ."} - CFLAGS=${CFLAGS-"-ansi -O2"} - LDSHARED=${LDSHARED-"cc -shared -Wl,-soname,libz.so.1"} ;; - OSF1\ V4*) SFLAGS=${CFLAGS-"-O -std1"} - CFLAGS=${CFLAGS-"-O -std1"} - LDFLAGS="${LDFLAGS} -Wl,-rpath,." - LDSHARED=${LDSHARED-"cc -shared -Wl,-soname,libz.so -Wl,-msym -Wl,-rpath,$(libdir) -Wl,-set_version,${VER}:1.0"} ;; - OSF1*) SFLAGS=${CFLAGS-"-O -std1"} - CFLAGS=${CFLAGS-"-O -std1"} - LDSHARED=${LDSHARED-"cc -shared -Wl,-soname,libz.so.1"} ;; - QNX*) SFLAGS=${CFLAGS-"-4 -O"} - CFLAGS=${CFLAGS-"-4 -O"} - LDSHARED=${LDSHARED-"cc"} - RANLIB=${RANLIB-"true"} - AR="cc" - ARFLAGS="-A" ;; - SCO_SV\ 3.2*) SFLAGS=${CFLAGS-"-O3 -dy -KPIC "} - CFLAGS=${CFLAGS-"-O3"} - LDSHARED=${LDSHARED-"cc -dy -KPIC -G"} ;; - SunOS\ 5* | solaris*) - LDSHARED=${LDSHARED-"cc -G -h libz$shared_ext.$VER1"} - SFLAGS=${CFLAGS-"-fast -KPIC"} - CFLAGS=${CFLAGS-"-fast"} - if test $build64 -eq 1; then - # old versions of SunPRO/Workshop/Studio don't support -m64, - # but newer ones do. Check for it. - flag64=`$CC -flags | egrep -- '^-m64'` - if test x"$flag64" != x"" ; then - CFLAGS="${CFLAGS} -m64" - SFLAGS="${SFLAGS} -m64" - else - case `(uname -m || echo unknown) 2>/dev/null` in - i86*) - SFLAGS="$SFLAGS -xarch=amd64" - CFLAGS="$CFLAGS -xarch=amd64" ;; - *) - SFLAGS="$SFLAGS -xarch=v9" - CFLAGS="$CFLAGS -xarch=v9" ;; - esac - fi - fi - if test -n "$ZINC"; then - ZINC='-I- -I. -I$(SRCDIR)' - fi - ;; - SunOS\ 4*) SFLAGS=${CFLAGS-"-O2 -PIC"} - CFLAGS=${CFLAGS-"-O2"} - LDSHARED=${LDSHARED-"ld"} ;; - SunStudio\ 9*) SFLAGS=${CFLAGS-"-fast -xcode=pic32 -xtarget=ultra3 -xarch=v9b"} - CFLAGS=${CFLAGS-"-fast -xtarget=ultra3 -xarch=v9b"} - LDSHARED=${LDSHARED-"cc -xarch=v9b"} ;; - UNIX_System_V\ 4.2.0) - SFLAGS=${CFLAGS-"-KPIC -O"} - CFLAGS=${CFLAGS-"-O"} - LDSHARED=${LDSHARED-"cc -G"} ;; - UNIX_SV\ 4.2MP) - SFLAGS=${CFLAGS-"-Kconform_pic -O"} - CFLAGS=${CFLAGS-"-O"} - LDSHARED=${LDSHARED-"cc -G"} ;; - OpenUNIX\ 5) - SFLAGS=${CFLAGS-"-KPIC -O"} - CFLAGS=${CFLAGS-"-O"} - LDSHARED=${LDSHARED-"cc -G"} ;; - AIX*) # Courtesy of dbakker@arrayasolutions.com - SFLAGS=${CFLAGS-"-O -qmaxmem=8192"} - CFLAGS=${CFLAGS-"-O -qmaxmem=8192"} - LDSHARED=${LDSHARED-"xlc -G"} ;; - # send working options for other systems to zlib@gzip.org - *) SFLAGS=${CFLAGS-"-O"} - CFLAGS=${CFLAGS-"-O"} - LDSHARED=${LDSHARED-"cc -shared"} ;; - esac -fi - -# destination names for shared library if not defined above -SHAREDLIB=${SHAREDLIB-"libz$shared_ext"} -SHAREDLIBV=${SHAREDLIBV-"libz$shared_ext.$VER"} -SHAREDLIBM=${SHAREDLIBM-"libz$shared_ext.$VER1"} - -echo >> configure.log - -# define functions for testing compiler and library characteristics and logging the results - -cat > $test.c </dev/null; then - try() - { - show $* - test "`( $* ) 2>&1 | tee -a configure.log`" = "" - } - echo - using any output from compiler to indicate an error >> configure.log -else - try() - { - show $* - ( $* ) >> configure.log 2>&1 - ret=$? - if test $ret -ne 0; then - echo "(exit code "$ret")" >> configure.log - fi - return $ret - } -fi - -tryboth() -{ - show $* - got=`( $* ) 2>&1` - ret=$? - printf %s "$got" >> configure.log - if test $ret -ne 0; then - return $ret - fi - test "$got" = "" -} - -cat > $test.c << EOF -int foo() { return 0; } -EOF -echo "Checking for obsessive-compulsive compiler options..." >> configure.log -if try $CC -c $CFLAGS $test.c; then - : -else - echo "Compiler error reporting is too harsh for $0 (perhaps remove -Werror)." | tee -a configure.log - leave 1 -fi - -echo >> configure.log - -# see if shared library build supported -cat > $test.c <> configure.log - show "$NM $test.o | grep _hello" - if test "`$NM $test.o | grep _hello | tee -a configure.log`" = ""; then - CPP="$CPP -DNO_UNDERLINE" - echo Checking for underline in external names... No. | tee -a configure.log - else - echo Checking for underline in external names... Yes. | tee -a configure.log - fi ;; -esac - -echo >> configure.log - -# check for size_t -cat > $test.c < -#include -size_t dummy = 0; -EOF -if try $CC -c $CFLAGS $test.c; then - echo "Checking for size_t... Yes." | tee -a configure.log - need_sizet=0 -else - echo "Checking for size_t... No." | tee -a configure.log - need_sizet=1 -fi - -echo >> configure.log - -# find the size_t integer type, if needed -if test $need_sizet -eq 1; then - cat > $test.c < $test.c < -int main(void) { - if (sizeof(void *) <= sizeof(int)) puts("int"); - else if (sizeof(void *) <= sizeof(long)) puts("long"); - else puts("z_longlong"); - return 0; -} -EOF - else - echo "Checking for long long... No." | tee -a configure.log - cat > $test.c < -int main(void) { - if (sizeof(void *) <= sizeof(int)) puts("int"); - else puts("long"); - return 0; -} -EOF - fi - if try $CC $CFLAGS -o $test $test.c; then - sizet=`./$test` - echo "Checking for a pointer-size integer type..." $sizet"." | tee -a configure.log - else - echo "Failed to find a pointer-size integer type." | tee -a configure.log - leave 1 - fi -fi - -if test $need_sizet -eq 1; then - CFLAGS="${CFLAGS} -DNO_SIZE_T=${sizet}" - SFLAGS="${SFLAGS} -DNO_SIZE_T=${sizet}" -fi - -echo >> configure.log - -# check for large file support, and if none, check for fseeko() -cat > $test.c < -off64_t dummy = 0; -EOF -if try $CC -c $CFLAGS -D_LARGEFILE64_SOURCE=1 $test.c; then - CFLAGS="${CFLAGS} -D_LARGEFILE64_SOURCE=1" - SFLAGS="${SFLAGS} -D_LARGEFILE64_SOURCE=1" - ALL="${ALL} all64" - TEST="${TEST} test64" - echo "Checking for off64_t... Yes." | tee -a configure.log - echo "Checking for fseeko... Yes." | tee -a configure.log -else - echo "Checking for off64_t... No." | tee -a configure.log - echo >> configure.log - cat > $test.c < -int main(void) { - fseeko(NULL, 0, 0); - return 0; -} -EOF - if try $CC $CFLAGS -o $test $test.c; then - echo "Checking for fseeko... Yes." | tee -a configure.log - else - CFLAGS="${CFLAGS} -DNO_FSEEKO" - SFLAGS="${SFLAGS} -DNO_FSEEKO" - echo "Checking for fseeko... No." | tee -a configure.log - fi -fi - -echo >> configure.log - -# check for strerror() for use by gz* functions -cat > $test.c < -#include -int main() { return strlen(strerror(errno)); } -EOF -if try $CC $CFLAGS -o $test $test.c; then - echo "Checking for strerror... Yes." | tee -a configure.log -else - CFLAGS="${CFLAGS} -DNO_STRERROR" - SFLAGS="${SFLAGS} -DNO_STRERROR" - echo "Checking for strerror... No." | tee -a configure.log -fi - -# copy clean zconf.h for subsequent edits -cp -p ${SRCDIR}zconf.h.in zconf.h - -echo >> configure.log - -# check for unistd.h and save result in zconf.h -cat > $test.c < -int main() { return 0; } -EOF -if try $CC -c $CFLAGS $test.c; then - sed < zconf.h "/^#ifdef HAVE_UNISTD_H.* may be/s/def HAVE_UNISTD_H\(.*\) may be/ 1\1 was/" > zconf.temp.h - mv zconf.temp.h zconf.h - echo "Checking for unistd.h... Yes." | tee -a configure.log -else - echo "Checking for unistd.h... No." | tee -a configure.log -fi - -echo >> configure.log - -# check for stdarg.h and save result in zconf.h -cat > $test.c < -int main() { return 0; } -EOF -if try $CC -c $CFLAGS $test.c; then - sed < zconf.h "/^#ifdef HAVE_STDARG_H.* may be/s/def HAVE_STDARG_H\(.*\) may be/ 1\1 was/" > zconf.temp.h - mv zconf.temp.h zconf.h - echo "Checking for stdarg.h... Yes." | tee -a configure.log -else - echo "Checking for stdarg.h... No." | tee -a configure.log -fi - -# if the z_ prefix was requested, save that in zconf.h -if test $zprefix -eq 1; then - sed < zconf.h "/#ifdef Z_PREFIX.* may be/s/def Z_PREFIX\(.*\) may be/ 1\1 was/" > zconf.temp.h - mv zconf.temp.h zconf.h - echo >> configure.log - echo "Using z_ prefix on all symbols." | tee -a configure.log -fi - -# if --solo compilation was requested, save that in zconf.h and remove gz stuff from object lists -if test $solo -eq 1; then - sed '/#define ZCONF_H/a\ -#define Z_SOLO - -' < zconf.h > zconf.temp.h - mv zconf.temp.h zconf.h -OBJC='$(OBJZ)' -PIC_OBJC='$(PIC_OBJZ)' -fi - -# if code coverage testing was requested, use older gcc if defined, e.g. "gcc-4.2" on Mac OS X -if test $cover -eq 1; then - CFLAGS="${CFLAGS} -fprofile-arcs -ftest-coverage" - if test -n "$GCC_CLASSIC"; then - CC=$GCC_CLASSIC - fi -fi - -echo >> configure.log - -# conduct a series of tests to resolve eight possible cases of using "vs" or "s" printf functions -# (using stdarg or not), with or without "n" (proving size of buffer), and with or without a -# return value. The most secure result is vsnprintf() with a return value. snprintf() with a -# return value is secure as well, but then gzprintf() will be limited to 20 arguments. -cat > $test.c < -#include -#include "zconf.h" -int main() -{ -#ifndef STDC - choke me -#endif - return 0; -} -EOF -if try $CC -c $CFLAGS $test.c; then - echo "Checking whether to use vs[n]printf() or s[n]printf()... using vs[n]printf()." | tee -a configure.log - - echo >> configure.log - cat > $test.c < -#include -int mytest(const char *fmt, ...) -{ - char buf[20]; - va_list ap; - va_start(ap, fmt); - vsnprintf(buf, sizeof(buf), fmt, ap); - va_end(ap); - return 0; -} -int main() -{ - return (mytest("Hello%d\n", 1)); -} -EOF - if try $CC $CFLAGS -o $test $test.c; then - echo "Checking for vsnprintf() in stdio.h... Yes." | tee -a configure.log - - echo >> configure.log - cat >$test.c < -#include -int mytest(const char *fmt, ...) -{ - int n; - char buf[20]; - va_list ap; - va_start(ap, fmt); - n = vsnprintf(buf, sizeof(buf), fmt, ap); - va_end(ap); - return n; -} -int main() -{ - return (mytest("Hello%d\n", 1)); -} -EOF - - if try $CC -c $CFLAGS $test.c; then - echo "Checking for return value of vsnprintf()... Yes." | tee -a configure.log - else - CFLAGS="$CFLAGS -DHAS_vsnprintf_void" - SFLAGS="$SFLAGS -DHAS_vsnprintf_void" - echo "Checking for return value of vsnprintf()... No." | tee -a configure.log - echo " WARNING: apparently vsnprintf() does not return a value. zlib" | tee -a configure.log - echo " can build but will be open to possible string-format security" | tee -a configure.log - echo " vulnerabilities." | tee -a configure.log - fi - else - CFLAGS="$CFLAGS -DNO_vsnprintf" - SFLAGS="$SFLAGS -DNO_vsnprintf" - echo "Checking for vsnprintf() in stdio.h... No." | tee -a configure.log - echo " WARNING: vsnprintf() not found, falling back to vsprintf(). zlib" | tee -a configure.log - echo " can build but will be open to possible buffer-overflow security" | tee -a configure.log - echo " vulnerabilities." | tee -a configure.log - - echo >> configure.log - cat >$test.c < -#include -int mytest(const char *fmt, ...) -{ - int n; - char buf[20]; - va_list ap; - va_start(ap, fmt); - n = vsprintf(buf, fmt, ap); - va_end(ap); - return n; -} -int main() -{ - return (mytest("Hello%d\n", 1)); -} -EOF - - if try $CC -c $CFLAGS $test.c; then - echo "Checking for return value of vsprintf()... Yes." | tee -a configure.log - else - CFLAGS="$CFLAGS -DHAS_vsprintf_void" - SFLAGS="$SFLAGS -DHAS_vsprintf_void" - echo "Checking for return value of vsprintf()... No." | tee -a configure.log - echo " WARNING: apparently vsprintf() does not return a value. zlib" | tee -a configure.log - echo " can build but will be open to possible string-format security" | tee -a configure.log - echo " vulnerabilities." | tee -a configure.log - fi - fi -else - echo "Checking whether to use vs[n]printf() or s[n]printf()... using s[n]printf()." | tee -a configure.log - - echo >> configure.log - cat >$test.c < -int mytest() -{ - char buf[20]; - snprintf(buf, sizeof(buf), "%s", "foo"); - return 0; -} -int main() -{ - return (mytest()); -} -EOF - - if try $CC $CFLAGS -o $test $test.c; then - echo "Checking for snprintf() in stdio.h... Yes." | tee -a configure.log - - echo >> configure.log - cat >$test.c < -int mytest() -{ - char buf[20]; - return snprintf(buf, sizeof(buf), "%s", "foo"); -} -int main() -{ - return (mytest()); -} -EOF - - if try $CC -c $CFLAGS $test.c; then - echo "Checking for return value of snprintf()... Yes." | tee -a configure.log - else - CFLAGS="$CFLAGS -DHAS_snprintf_void" - SFLAGS="$SFLAGS -DHAS_snprintf_void" - echo "Checking for return value of snprintf()... No." | tee -a configure.log - echo " WARNING: apparently snprintf() does not return a value. zlib" | tee -a configure.log - echo " can build but will be open to possible string-format security" | tee -a configure.log - echo " vulnerabilities." | tee -a configure.log - fi - else - CFLAGS="$CFLAGS -DNO_snprintf" - SFLAGS="$SFLAGS -DNO_snprintf" - echo "Checking for snprintf() in stdio.h... No." | tee -a configure.log - echo " WARNING: snprintf() not found, falling back to sprintf(). zlib" | tee -a configure.log - echo " can build but will be open to possible buffer-overflow security" | tee -a configure.log - echo " vulnerabilities." | tee -a configure.log - - echo >> configure.log - cat >$test.c < -int mytest() -{ - char buf[20]; - return sprintf(buf, "%s", "foo"); -} -int main() -{ - return (mytest()); -} -EOF - - if try $CC -c $CFLAGS $test.c; then - echo "Checking for return value of sprintf()... Yes." | tee -a configure.log - else - CFLAGS="$CFLAGS -DHAS_sprintf_void" - SFLAGS="$SFLAGS -DHAS_sprintf_void" - echo "Checking for return value of sprintf()... No." | tee -a configure.log - echo " WARNING: apparently sprintf() does not return a value. zlib" | tee -a configure.log - echo " can build but will be open to possible string-format security" | tee -a configure.log - echo " vulnerabilities." | tee -a configure.log - fi - fi -fi - -# see if we can hide zlib internal symbols that are linked between separate source files -if test "$gcc" -eq 1; then - echo >> configure.log - cat > $test.c <> configure.log -echo ALL = $ALL >> configure.log -echo AR = $AR >> configure.log -echo ARFLAGS = $ARFLAGS >> configure.log -echo CC = $CC >> configure.log -echo CFLAGS = $CFLAGS >> configure.log -echo CPP = $CPP >> configure.log -echo EXE = $EXE >> configure.log -echo LDCONFIG = $LDCONFIG >> configure.log -echo LDFLAGS = $LDFLAGS >> configure.log -echo LDSHARED = $LDSHARED >> configure.log -echo LDSHAREDLIBC = $LDSHAREDLIBC >> configure.log -echo OBJC = $OBJC >> configure.log -echo PIC_OBJC = $PIC_OBJC >> configure.log -echo RANLIB = $RANLIB >> configure.log -echo SFLAGS = $SFLAGS >> configure.log -echo SHAREDLIB = $SHAREDLIB >> configure.log -echo SHAREDLIBM = $SHAREDLIBM >> configure.log -echo SHAREDLIBV = $SHAREDLIBV >> configure.log -echo STATICLIB = $STATICLIB >> configure.log -echo TEST = $TEST >> configure.log -echo VER = $VER >> configure.log -echo Z_U4 = $Z_U4 >> configure.log -echo SRCDIR = $SRCDIR >> configure.log -echo exec_prefix = $exec_prefix >> configure.log -echo includedir = $includedir >> configure.log -echo libdir = $libdir >> configure.log -echo mandir = $mandir >> configure.log -echo prefix = $prefix >> configure.log -echo sharedlibdir = $sharedlibdir >> configure.log -echo uname = $uname >> configure.log - -# udpate Makefile with the configure results -sed < ${SRCDIR}Makefile.in " -/^CC *=/s#=.*#=$CC# -/^CFLAGS *=/s#=.*#=$CFLAGS# -/^SFLAGS *=/s#=.*#=$SFLAGS# -/^LDFLAGS *=/s#=.*#=$LDFLAGS# -/^LDSHARED *=/s#=.*#=$LDSHARED# -/^CPP *=/s#=.*#=$CPP# -/^STATICLIB *=/s#=.*#=$STATICLIB# -/^SHAREDLIB *=/s#=.*#=$SHAREDLIB# -/^SHAREDLIBV *=/s#=.*#=$SHAREDLIBV# -/^SHAREDLIBM *=/s#=.*#=$SHAREDLIBM# -/^AR *=/s#=.*#=$AR# -/^ARFLAGS *=/s#=.*#=$ARFLAGS# -/^RANLIB *=/s#=.*#=$RANLIB# -/^LDCONFIG *=/s#=.*#=$LDCONFIG# -/^LDSHAREDLIBC *=/s#=.*#=$LDSHAREDLIBC# -/^EXE *=/s#=.*#=$EXE# -/^SRCDIR *=/s#=.*#=$SRCDIR# -/^ZINC *=/s#=.*#=$ZINC# -/^ZINCOUT *=/s#=.*#=$ZINCOUT# -/^prefix *=/s#=.*#=$prefix# -/^exec_prefix *=/s#=.*#=$exec_prefix# -/^libdir *=/s#=.*#=$libdir# -/^sharedlibdir *=/s#=.*#=$sharedlibdir# -/^includedir *=/s#=.*#=$includedir# -/^mandir *=/s#=.*#=$mandir# -/^OBJC *=/s#=.*#= $OBJC# -/^PIC_OBJC *=/s#=.*#= $PIC_OBJC# -/^all: */s#:.*#: $ALL# -/^test: */s#:.*#: $TEST# -" > Makefile - -# create zlib.pc with the configure results -sed < ${SRCDIR}zlib.pc.in " -/^CC *=/s#=.*#=$CC# -/^CFLAGS *=/s#=.*#=$CFLAGS# -/^CPP *=/s#=.*#=$CPP# -/^LDSHARED *=/s#=.*#=$LDSHARED# -/^STATICLIB *=/s#=.*#=$STATICLIB# -/^SHAREDLIB *=/s#=.*#=$SHAREDLIB# -/^SHAREDLIBV *=/s#=.*#=$SHAREDLIBV# -/^SHAREDLIBM *=/s#=.*#=$SHAREDLIBM# -/^AR *=/s#=.*#=$AR# -/^ARFLAGS *=/s#=.*#=$ARFLAGS# -/^RANLIB *=/s#=.*#=$RANLIB# -/^EXE *=/s#=.*#=$EXE# -/^prefix *=/s#=.*#=$prefix# -/^exec_prefix *=/s#=.*#=$exec_prefix# -/^libdir *=/s#=.*#=$libdir# -/^sharedlibdir *=/s#=.*#=$sharedlibdir# -/^includedir *=/s#=.*#=$includedir# -/^mandir *=/s#=.*#=$mandir# -/^LDFLAGS *=/s#=.*#=$LDFLAGS# -" | sed -e " -s/\@VERSION\@/$VER/g; -" > zlib.pc - -# done -leave 0 DELETED compat/zlib/contrib/README.contrib Index: compat/zlib/contrib/README.contrib ================================================================== --- compat/zlib/contrib/README.contrib +++ /dev/null @@ -1,78 +0,0 @@ -All files under this contrib directory are UNSUPPORTED. There were -provided by users of zlib and were not tested by the authors of zlib. -Use at your own risk. Please contact the authors of the contributions -for help about these, not the zlib authors. Thanks. - - -ada/ by Dmitriy Anisimkov - Support for Ada - See http://zlib-ada.sourceforge.net/ - -amd64/ by Mikhail Teterin - asm code for AMD64 - See patch at http://www.freebsd.org/cgi/query-pr.cgi?pr=bin/96393 - -asm686/ by Brian Raiter - asm code for Pentium and PPro/PII, using the AT&T (GNU as) syntax - See http://www.muppetlabs.com/~breadbox/software/assembly.html - -blast/ by Mark Adler - Decompressor for output of PKWare Data Compression Library (DCL) - -delphi/ by Cosmin Truta - Support for Delphi and C++ Builder - -dotzlib/ by Henrik Ravn - Support for Microsoft .Net and Visual C++ .Net - -gcc_gvmat64/by Gilles Vollant - GCC Version of x86 64-bit (AMD64 and Intel EM64t) code for x64 - assembler to replace longest_match() and inflate_fast() - -infback9/ by Mark Adler - Unsupported diffs to infback to decode the deflate64 format - -inflate86/ by Chris Anderson - Tuned x86 gcc asm code to replace inflate_fast() - -iostream/ by Kevin Ruland - A C++ I/O streams interface to the zlib gz* functions - -iostream2/ by Tyge Løvset - Another C++ I/O streams interface - -iostream3/ by Ludwig Schwardt - and Kevin Ruland - Yet another C++ I/O streams interface - -masmx64/ by Gilles Vollant - x86 64-bit (AMD64 and Intel EM64t) code for x64 assembler to - replace longest_match() and inflate_fast(), also masm x86 - 64-bits translation of Chris Anderson inflate_fast() - -masmx86/ by Gilles Vollant - x86 asm code to replace longest_match() and inflate_fast(), - for Visual C++ and MASM (32 bits). - Based on Brian Raiter (asm686) and Chris Anderson (inflate86) - -minizip/ by Gilles Vollant - Mini zip and unzip based on zlib - Includes Zip64 support by Mathias Svensson - See http://www.winimage.com/zLibDll/minizip.html - -pascal/ by Bob Dellaca et al. - Support for Pascal - -puff/ by Mark Adler - Small, low memory usage inflate. Also serves to provide an - unambiguous description of the deflate format. - -testzlib/ by Gilles Vollant - Example of the use of zlib - -untgz/ by Pedro A. Aranda Gutierrez - A very simple tar.gz file extractor using zlib - -vstudio/ by Gilles Vollant - Building a minizip-enhanced zlib with Microsoft Visual Studio - Includes vc11 from kreuzerkrieg and vc12 from davispuh DELETED compat/zlib/contrib/ada/buffer_demo.adb Index: compat/zlib/contrib/ada/buffer_demo.adb ================================================================== --- compat/zlib/contrib/ada/buffer_demo.adb +++ /dev/null @@ -1,106 +0,0 @@ ----------------------------------------------------------------- --- ZLib for Ada thick binding. -- --- -- --- Copyright (C) 2002-2004 Dmitriy Anisimkov -- --- -- --- Open source license information is in the zlib.ads file. -- ----------------------------------------------------------------- --- --- $Id: buffer_demo.adb,v 1.3 2004/09/06 06:55:35 vagul Exp $ - --- This demo program provided by Dr Steve Sangwine --- --- Demonstration of a problem with Zlib-Ada (already fixed) when a buffer --- of exactly the correct size is used for decompressed data, and the last --- few bytes passed in to Zlib are checksum bytes. - --- This program compresses a string of text, and then decompresses the --- compressed text into a buffer of the same size as the original text. - -with Ada.Streams; use Ada.Streams; -with Ada.Text_IO; - -with ZLib; use ZLib; - -procedure Buffer_Demo is - EOL : Character renames ASCII.LF; - Text : constant String - := "Four score and seven years ago our fathers brought forth," & EOL & - "upon this continent, a new nation, conceived in liberty," & EOL & - "and dedicated to the proposition that `all men are created equal'."; - - Source : Stream_Element_Array (1 .. Text'Length); - for Source'Address use Text'Address; - -begin - Ada.Text_IO.Put (Text); - Ada.Text_IO.New_Line; - Ada.Text_IO.Put_Line - ("Uncompressed size : " & Positive'Image (Text'Length) & " bytes"); - - declare - Compressed_Data : Stream_Element_Array (1 .. Text'Length); - L : Stream_Element_Offset; - begin - Compress : declare - Compressor : Filter_Type; - I : Stream_Element_Offset; - begin - Deflate_Init (Compressor); - - -- Compress the whole of T at once. - - Translate (Compressor, Source, I, Compressed_Data, L, Finish); - pragma Assert (I = Source'Last); - - Close (Compressor); - - Ada.Text_IO.Put_Line - ("Compressed size : " - & Stream_Element_Offset'Image (L) & " bytes"); - end Compress; - - -- Now we decompress the data, passing short blocks of data to Zlib - -- (because this demonstrates the problem - the last block passed will - -- contain checksum information and there will be no output, only a - -- check inside Zlib that the checksum is correct). - - Decompress : declare - Decompressor : Filter_Type; - - Uncompressed_Data : Stream_Element_Array (1 .. Text'Length); - - Block_Size : constant := 4; - -- This makes sure that the last block contains - -- only Adler checksum data. - - P : Stream_Element_Offset := Compressed_Data'First - 1; - O : Stream_Element_Offset; - begin - Inflate_Init (Decompressor); - - loop - Translate - (Decompressor, - Compressed_Data - (P + 1 .. Stream_Element_Offset'Min (P + Block_Size, L)), - P, - Uncompressed_Data - (Total_Out (Decompressor) + 1 .. Uncompressed_Data'Last), - O, - No_Flush); - - Ada.Text_IO.Put_Line - ("Total in : " & Count'Image (Total_In (Decompressor)) & - ", out : " & Count'Image (Total_Out (Decompressor))); - - exit when P = L; - end loop; - - Ada.Text_IO.New_Line; - Ada.Text_IO.Put_Line - ("Decompressed text matches original text : " - & Boolean'Image (Uncompressed_Data = Source)); - end Decompress; - end; -end Buffer_Demo; DELETED compat/zlib/contrib/ada/mtest.adb Index: compat/zlib/contrib/ada/mtest.adb ================================================================== --- compat/zlib/contrib/ada/mtest.adb +++ /dev/null @@ -1,156 +0,0 @@ ----------------------------------------------------------------- --- ZLib for Ada thick binding. -- --- -- --- Copyright (C) 2002-2003 Dmitriy Anisimkov -- --- -- --- Open source license information is in the zlib.ads file. -- ----------------------------------------------------------------- --- Continuous test for ZLib multithreading. If the test would fail --- we should provide thread safe allocation routines for the Z_Stream. --- --- $Id: mtest.adb,v 1.4 2004/07/23 07:49:54 vagul Exp $ - -with ZLib; -with Ada.Streams; -with Ada.Numerics.Discrete_Random; -with Ada.Text_IO; -with Ada.Exceptions; -with Ada.Task_Identification; - -procedure MTest is - use Ada.Streams; - use ZLib; - - Stop : Boolean := False; - - pragma Atomic (Stop); - - subtype Visible_Symbols is Stream_Element range 16#20# .. 16#7E#; - - package Random_Elements is - new Ada.Numerics.Discrete_Random (Visible_Symbols); - - task type Test_Task; - - task body Test_Task is - Buffer : Stream_Element_Array (1 .. 100_000); - Gen : Random_Elements.Generator; - - Buffer_First : Stream_Element_Offset; - Compare_First : Stream_Element_Offset; - - Deflate : Filter_Type; - Inflate : Filter_Type; - - procedure Further (Item : in Stream_Element_Array); - - procedure Read_Buffer - (Item : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); - - ------------- - -- Further -- - ------------- - - procedure Further (Item : in Stream_Element_Array) is - - procedure Compare (Item : in Stream_Element_Array); - - ------------- - -- Compare -- - ------------- - - procedure Compare (Item : in Stream_Element_Array) is - Next_First : Stream_Element_Offset := Compare_First + Item'Length; - begin - if Buffer (Compare_First .. Next_First - 1) /= Item then - raise Program_Error; - end if; - - Compare_First := Next_First; - end Compare; - - procedure Compare_Write is new ZLib.Write (Write => Compare); - begin - Compare_Write (Inflate, Item, No_Flush); - end Further; - - ----------------- - -- Read_Buffer -- - ----------------- - - procedure Read_Buffer - (Item : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) - is - Buff_Diff : Stream_Element_Offset := Buffer'Last - Buffer_First; - Next_First : Stream_Element_Offset; - begin - if Item'Length <= Buff_Diff then - Last := Item'Last; - - Next_First := Buffer_First + Item'Length; - - Item := Buffer (Buffer_First .. Next_First - 1); - - Buffer_First := Next_First; - else - Last := Item'First + Buff_Diff; - Item (Item'First .. Last) := Buffer (Buffer_First .. Buffer'Last); - Buffer_First := Buffer'Last + 1; - end if; - end Read_Buffer; - - procedure Translate is new Generic_Translate - (Data_In => Read_Buffer, - Data_Out => Further); - - begin - Random_Elements.Reset (Gen); - - Buffer := (others => 20); - - Main : loop - for J in Buffer'Range loop - Buffer (J) := Random_Elements.Random (Gen); - - Deflate_Init (Deflate); - Inflate_Init (Inflate); - - Buffer_First := Buffer'First; - Compare_First := Buffer'First; - - Translate (Deflate); - - if Compare_First /= Buffer'Last + 1 then - raise Program_Error; - end if; - - Ada.Text_IO.Put_Line - (Ada.Task_Identification.Image - (Ada.Task_Identification.Current_Task) - & Stream_Element_Offset'Image (J) - & ZLib.Count'Image (Total_Out (Deflate))); - - Close (Deflate); - Close (Inflate); - - exit Main when Stop; - end loop; - end loop Main; - exception - when E : others => - Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); - Stop := True; - end Test_Task; - - Test : array (1 .. 4) of Test_Task; - - pragma Unreferenced (Test); - - Dummy : Character; - -begin - Ada.Text_IO.Get_Immediate (Dummy); - Stop := True; -end MTest; DELETED compat/zlib/contrib/ada/read.adb Index: compat/zlib/contrib/ada/read.adb ================================================================== --- compat/zlib/contrib/ada/read.adb +++ /dev/null @@ -1,156 +0,0 @@ ----------------------------------------------------------------- --- ZLib for Ada thick binding. -- --- -- --- Copyright (C) 2002-2003 Dmitriy Anisimkov -- --- -- --- Open source license information is in the zlib.ads file. -- ----------------------------------------------------------------- - --- $Id: read.adb,v 1.8 2004/05/31 10:53:40 vagul Exp $ - --- Test/demo program for the generic read interface. - -with Ada.Numerics.Discrete_Random; -with Ada.Streams; -with Ada.Text_IO; - -with ZLib; - -procedure Read is - - use Ada.Streams; - - ------------------------------------ - -- Test configuration parameters -- - ------------------------------------ - - File_Size : Stream_Element_Offset := 100_000; - - Continuous : constant Boolean := False; - -- If this constant is True, the test would be repeated again and again, - -- with increment File_Size for every iteration. - - Header : constant ZLib.Header_Type := ZLib.Default; - -- Do not use Header other than Default in ZLib versions 1.1.4 and older. - - Init_Random : constant := 8; - -- We are using the same random sequence, in case of we catch bug, - -- so we would be able to reproduce it. - - -- End -- - - Pack_Size : Stream_Element_Offset; - Offset : Stream_Element_Offset; - - Filter : ZLib.Filter_Type; - - subtype Visible_Symbols - is Stream_Element range 16#20# .. 16#7E#; - - package Random_Elements is new - Ada.Numerics.Discrete_Random (Visible_Symbols); - - Gen : Random_Elements.Generator; - Period : constant Stream_Element_Offset := 200; - -- Period constant variable for random generator not to be very random. - -- Bigger period, harder random. - - Read_Buffer : Stream_Element_Array (1 .. 2048); - Read_First : Stream_Element_Offset; - Read_Last : Stream_Element_Offset; - - procedure Reset; - - procedure Read - (Item : out Stream_Element_Array; - Last : out Stream_Element_Offset); - -- this procedure is for generic instantiation of - -- ZLib.Read - -- reading data from the File_In. - - procedure Read is new ZLib.Read - (Read, - Read_Buffer, - Rest_First => Read_First, - Rest_Last => Read_Last); - - ---------- - -- Read -- - ---------- - - procedure Read - (Item : out Stream_Element_Array; - Last : out Stream_Element_Offset) is - begin - Last := Stream_Element_Offset'Min - (Item'Last, - Item'First + File_Size - Offset); - - for J in Item'First .. Last loop - if J < Item'First + Period then - Item (J) := Random_Elements.Random (Gen); - else - Item (J) := Item (J - Period); - end if; - - Offset := Offset + 1; - end loop; - end Read; - - ----------- - -- Reset -- - ----------- - - procedure Reset is - begin - Random_Elements.Reset (Gen, Init_Random); - Pack_Size := 0; - Offset := 1; - Read_First := Read_Buffer'Last + 1; - Read_Last := Read_Buffer'Last; - end Reset; - -begin - Ada.Text_IO.Put_Line ("ZLib " & ZLib.Version); - - loop - for Level in ZLib.Compression_Level'Range loop - - Ada.Text_IO.Put ("Level =" - & ZLib.Compression_Level'Image (Level)); - - -- Deflate using generic instantiation. - - ZLib.Deflate_Init - (Filter, - Level, - Header => Header); - - Reset; - - Ada.Text_IO.Put - (Stream_Element_Offset'Image (File_Size) & " ->"); - - loop - declare - Buffer : Stream_Element_Array (1 .. 1024); - Last : Stream_Element_Offset; - begin - Read (Filter, Buffer, Last); - - Pack_Size := Pack_Size + Last - Buffer'First + 1; - - exit when Last < Buffer'Last; - end; - end loop; - - Ada.Text_IO.Put_Line (Stream_Element_Offset'Image (Pack_Size)); - - ZLib.Close (Filter); - end loop; - - exit when not Continuous; - - File_Size := File_Size + 1; - end loop; -end Read; DELETED compat/zlib/contrib/ada/readme.txt Index: compat/zlib/contrib/ada/readme.txt ================================================================== --- compat/zlib/contrib/ada/readme.txt +++ /dev/null @@ -1,65 +0,0 @@ - ZLib for Ada thick binding (ZLib.Ada) - Release 1.3 - -ZLib.Ada is a thick binding interface to the popular ZLib data -compression library, available at http://www.gzip.org/zlib/. -It provides Ada-style access to the ZLib C library. - - - Here are the main changes since ZLib.Ada 1.2: - -- Attension: ZLib.Read generic routine have a initialization requirement - for Read_Last parameter now. It is a bit incompartible with previous version, - but extends functionality, we could use new parameters Allow_Read_Some and - Flush now. - -- Added Is_Open routines to ZLib and ZLib.Streams packages. - -- Add pragma Assert to check Stream_Element is 8 bit. - -- Fix extraction to buffer with exact known decompressed size. Error reported by - Steve Sangwine. - -- Fix definition of ULong (changed to unsigned_long), fix regression on 64 bits - computers. Patch provided by Pascal Obry. - -- Add Status_Error exception definition. - -- Add pragma Assertion that Ada.Streams.Stream_Element size is 8 bit. - - - How to build ZLib.Ada under GNAT - -You should have the ZLib library already build on your computer, before -building ZLib.Ada. Make the directory of ZLib.Ada sources current and -issue the command: - - gnatmake test -largs -L -lz - -Or use the GNAT project file build for GNAT 3.15 or later: - - gnatmake -Pzlib.gpr -L - - - How to build ZLib.Ada under Aonix ObjectAda for Win32 7.2.2 - -1. Make a project with all *.ads and *.adb files from the distribution. -2. Build the libz.a library from the ZLib C sources. -3. Rename libz.a to z.lib. -4. Add the library z.lib to the project. -5. Add the libc.lib library from the ObjectAda distribution to the project. -6. Build the executable using test.adb as a main procedure. - - - How to use ZLib.Ada - -The source files test.adb and read.adb are small demo programs that show -the main functionality of ZLib.Ada. - -The routines from the package specifications are commented. - - -Homepage: http://zlib-ada.sourceforge.net/ -Author: Dmitriy Anisimkov - -Contributors: Pascal Obry , Steve Sangwine DELETED compat/zlib/contrib/ada/test.adb Index: compat/zlib/contrib/ada/test.adb ================================================================== --- compat/zlib/contrib/ada/test.adb +++ /dev/null @@ -1,463 +0,0 @@ ----------------------------------------------------------------- --- ZLib for Ada thick binding. -- --- -- --- Copyright (C) 2002-2003 Dmitriy Anisimkov -- --- -- --- Open source license information is in the zlib.ads file. -- ----------------------------------------------------------------- - --- $Id: test.adb,v 1.17 2003/08/12 12:13:30 vagul Exp $ - --- The program has a few aims. --- 1. Test ZLib.Ada95 thick binding functionality. --- 2. Show the example of use main functionality of the ZLib.Ada95 binding. --- 3. Build this program automatically compile all ZLib.Ada95 packages under --- GNAT Ada95 compiler. - -with ZLib.Streams; -with Ada.Streams.Stream_IO; -with Ada.Numerics.Discrete_Random; - -with Ada.Text_IO; - -with Ada.Calendar; - -procedure Test is - - use Ada.Streams; - use Stream_IO; - - ------------------------------------ - -- Test configuration parameters -- - ------------------------------------ - - File_Size : Count := 100_000; - Continuous : constant Boolean := False; - - Header : constant ZLib.Header_Type := ZLib.Default; - -- ZLib.None; - -- ZLib.Auto; - -- ZLib.GZip; - -- Do not use Header other then Default in ZLib versions 1.1.4 - -- and older. - - Strategy : constant ZLib.Strategy_Type := ZLib.Default_Strategy; - Init_Random : constant := 10; - - -- End -- - - In_File_Name : constant String := "testzlib.in"; - -- Name of the input file - - Z_File_Name : constant String := "testzlib.zlb"; - -- Name of the compressed file. - - Out_File_Name : constant String := "testzlib.out"; - -- Name of the decompressed file. - - File_In : File_Type; - File_Out : File_Type; - File_Back : File_Type; - File_Z : ZLib.Streams.Stream_Type; - - Filter : ZLib.Filter_Type; - - Time_Stamp : Ada.Calendar.Time; - - procedure Generate_File; - -- Generate file of spetsified size with some random data. - -- The random data is repeatable, for the good compression. - - procedure Compare_Streams - (Left, Right : in out Root_Stream_Type'Class); - -- The procedure compearing data in 2 streams. - -- It is for compare data before and after compression/decompression. - - procedure Compare_Files (Left, Right : String); - -- Compare files. Based on the Compare_Streams. - - procedure Copy_Streams - (Source, Target : in out Root_Stream_Type'Class; - Buffer_Size : in Stream_Element_Offset := 1024); - -- Copying data from one stream to another. It is for test stream - -- interface of the library. - - procedure Data_In - (Item : out Stream_Element_Array; - Last : out Stream_Element_Offset); - -- this procedure is for generic instantiation of - -- ZLib.Generic_Translate. - -- reading data from the File_In. - - procedure Data_Out (Item : in Stream_Element_Array); - -- this procedure is for generic instantiation of - -- ZLib.Generic_Translate. - -- writing data to the File_Out. - - procedure Stamp; - -- Store the timestamp to the local variable. - - procedure Print_Statistic (Msg : String; Data_Size : ZLib.Count); - -- Print the time statistic with the message. - - procedure Translate is new ZLib.Generic_Translate - (Data_In => Data_In, - Data_Out => Data_Out); - -- This procedure is moving data from File_In to File_Out - -- with compression or decompression, depend on initialization of - -- Filter parameter. - - ------------------- - -- Compare_Files -- - ------------------- - - procedure Compare_Files (Left, Right : String) is - Left_File, Right_File : File_Type; - begin - Open (Left_File, In_File, Left); - Open (Right_File, In_File, Right); - Compare_Streams (Stream (Left_File).all, Stream (Right_File).all); - Close (Left_File); - Close (Right_File); - end Compare_Files; - - --------------------- - -- Compare_Streams -- - --------------------- - - procedure Compare_Streams - (Left, Right : in out Ada.Streams.Root_Stream_Type'Class) - is - Left_Buffer, Right_Buffer : Stream_Element_Array (0 .. 16#FFF#); - Left_Last, Right_Last : Stream_Element_Offset; - begin - loop - Read (Left, Left_Buffer, Left_Last); - Read (Right, Right_Buffer, Right_Last); - - if Left_Last /= Right_Last then - Ada.Text_IO.Put_Line ("Compare error :" - & Stream_Element_Offset'Image (Left_Last) - & " /= " - & Stream_Element_Offset'Image (Right_Last)); - - raise Constraint_Error; - - elsif Left_Buffer (0 .. Left_Last) - /= Right_Buffer (0 .. Right_Last) - then - Ada.Text_IO.Put_Line ("ERROR: IN and OUT files is not equal."); - raise Constraint_Error; - - end if; - - exit when Left_Last < Left_Buffer'Last; - end loop; - end Compare_Streams; - - ------------------ - -- Copy_Streams -- - ------------------ - - procedure Copy_Streams - (Source, Target : in out Ada.Streams.Root_Stream_Type'Class; - Buffer_Size : in Stream_Element_Offset := 1024) - is - Buffer : Stream_Element_Array (1 .. Buffer_Size); - Last : Stream_Element_Offset; - begin - loop - Read (Source, Buffer, Last); - Write (Target, Buffer (1 .. Last)); - - exit when Last < Buffer'Last; - end loop; - end Copy_Streams; - - ------------- - -- Data_In -- - ------------- - - procedure Data_In - (Item : out Stream_Element_Array; - Last : out Stream_Element_Offset) is - begin - Read (File_In, Item, Last); - end Data_In; - - -------------- - -- Data_Out -- - -------------- - - procedure Data_Out (Item : in Stream_Element_Array) is - begin - Write (File_Out, Item); - end Data_Out; - - ------------------- - -- Generate_File -- - ------------------- - - procedure Generate_File is - subtype Visible_Symbols is Stream_Element range 16#20# .. 16#7E#; - - package Random_Elements is - new Ada.Numerics.Discrete_Random (Visible_Symbols); - - Gen : Random_Elements.Generator; - Buffer : Stream_Element_Array := (1 .. 77 => 16#20#) & 10; - - Buffer_Count : constant Count := File_Size / Buffer'Length; - -- Number of same buffers in the packet. - - Density : constant Count := 30; -- from 0 to Buffer'Length - 2; - - procedure Fill_Buffer (J, D : in Count); - -- Change the part of the buffer. - - ----------------- - -- Fill_Buffer -- - ----------------- - - procedure Fill_Buffer (J, D : in Count) is - begin - for K in 0 .. D loop - Buffer - (Stream_Element_Offset ((J + K) mod (Buffer'Length - 1) + 1)) - := Random_Elements.Random (Gen); - - end loop; - end Fill_Buffer; - - begin - Random_Elements.Reset (Gen, Init_Random); - - Create (File_In, Out_File, In_File_Name); - - Fill_Buffer (1, Buffer'Length - 2); - - for J in 1 .. Buffer_Count loop - Write (File_In, Buffer); - - Fill_Buffer (J, Density); - end loop; - - -- fill remain size. - - Write - (File_In, - Buffer - (1 .. Stream_Element_Offset - (File_Size - Buffer'Length * Buffer_Count))); - - Flush (File_In); - Close (File_In); - end Generate_File; - - --------------------- - -- Print_Statistic -- - --------------------- - - procedure Print_Statistic (Msg : String; Data_Size : ZLib.Count) is - use Ada.Calendar; - use Ada.Text_IO; - - package Count_IO is new Integer_IO (ZLib.Count); - - Curr_Dur : Duration := Clock - Time_Stamp; - begin - Put (Msg); - - Set_Col (20); - Ada.Text_IO.Put ("size ="); - - Count_IO.Put - (Data_Size, - Width => Stream_IO.Count'Image (File_Size)'Length); - - Put_Line (" duration =" & Duration'Image (Curr_Dur)); - end Print_Statistic; - - ----------- - -- Stamp -- - ----------- - - procedure Stamp is - begin - Time_Stamp := Ada.Calendar.Clock; - end Stamp; - -begin - Ada.Text_IO.Put_Line ("ZLib " & ZLib.Version); - - loop - Generate_File; - - for Level in ZLib.Compression_Level'Range loop - - Ada.Text_IO.Put_Line ("Level =" - & ZLib.Compression_Level'Image (Level)); - - -- Test generic interface. - Open (File_In, In_File, In_File_Name); - Create (File_Out, Out_File, Z_File_Name); - - Stamp; - - -- Deflate using generic instantiation. - - ZLib.Deflate_Init - (Filter => Filter, - Level => Level, - Strategy => Strategy, - Header => Header); - - Translate (Filter); - Print_Statistic ("Generic compress", ZLib.Total_Out (Filter)); - ZLib.Close (Filter); - - Close (File_In); - Close (File_Out); - - Open (File_In, In_File, Z_File_Name); - Create (File_Out, Out_File, Out_File_Name); - - Stamp; - - -- Inflate using generic instantiation. - - ZLib.Inflate_Init (Filter, Header => Header); - - Translate (Filter); - Print_Statistic ("Generic decompress", ZLib.Total_Out (Filter)); - - ZLib.Close (Filter); - - Close (File_In); - Close (File_Out); - - Compare_Files (In_File_Name, Out_File_Name); - - -- Test stream interface. - - -- Compress to the back stream. - - Open (File_In, In_File, In_File_Name); - Create (File_Back, Out_File, Z_File_Name); - - Stamp; - - ZLib.Streams.Create - (Stream => File_Z, - Mode => ZLib.Streams.Out_Stream, - Back => ZLib.Streams.Stream_Access - (Stream (File_Back)), - Back_Compressed => True, - Level => Level, - Strategy => Strategy, - Header => Header); - - Copy_Streams - (Source => Stream (File_In).all, - Target => File_Z); - - -- Flushing internal buffers to the back stream. - - ZLib.Streams.Flush (File_Z, ZLib.Finish); - - Print_Statistic ("Write compress", - ZLib.Streams.Write_Total_Out (File_Z)); - - ZLib.Streams.Close (File_Z); - - Close (File_In); - Close (File_Back); - - -- Compare reading from original file and from - -- decompression stream. - - Open (File_In, In_File, In_File_Name); - Open (File_Back, In_File, Z_File_Name); - - ZLib.Streams.Create - (Stream => File_Z, - Mode => ZLib.Streams.In_Stream, - Back => ZLib.Streams.Stream_Access - (Stream (File_Back)), - Back_Compressed => True, - Header => Header); - - Stamp; - Compare_Streams (Stream (File_In).all, File_Z); - - Print_Statistic ("Read decompress", - ZLib.Streams.Read_Total_Out (File_Z)); - - ZLib.Streams.Close (File_Z); - Close (File_In); - Close (File_Back); - - -- Compress by reading from compression stream. - - Open (File_Back, In_File, In_File_Name); - Create (File_Out, Out_File, Z_File_Name); - - ZLib.Streams.Create - (Stream => File_Z, - Mode => ZLib.Streams.In_Stream, - Back => ZLib.Streams.Stream_Access - (Stream (File_Back)), - Back_Compressed => False, - Level => Level, - Strategy => Strategy, - Header => Header); - - Stamp; - Copy_Streams - (Source => File_Z, - Target => Stream (File_Out).all); - - Print_Statistic ("Read compress", - ZLib.Streams.Read_Total_Out (File_Z)); - - ZLib.Streams.Close (File_Z); - - Close (File_Out); - Close (File_Back); - - -- Decompress to decompression stream. - - Open (File_In, In_File, Z_File_Name); - Create (File_Back, Out_File, Out_File_Name); - - ZLib.Streams.Create - (Stream => File_Z, - Mode => ZLib.Streams.Out_Stream, - Back => ZLib.Streams.Stream_Access - (Stream (File_Back)), - Back_Compressed => False, - Header => Header); - - Stamp; - - Copy_Streams - (Source => Stream (File_In).all, - Target => File_Z); - - Print_Statistic ("Write decompress", - ZLib.Streams.Write_Total_Out (File_Z)); - - ZLib.Streams.Close (File_Z); - Close (File_In); - Close (File_Back); - - Compare_Files (In_File_Name, Out_File_Name); - end loop; - - Ada.Text_IO.Put_Line (Count'Image (File_Size) & " Ok."); - - exit when not Continuous; - - File_Size := File_Size + 1; - end loop; -end Test; DELETED compat/zlib/contrib/ada/zlib-streams.adb Index: compat/zlib/contrib/ada/zlib-streams.adb ================================================================== --- compat/zlib/contrib/ada/zlib-streams.adb +++ /dev/null @@ -1,225 +0,0 @@ ----------------------------------------------------------------- --- ZLib for Ada thick binding. -- --- -- --- Copyright (C) 2002-2003 Dmitriy Anisimkov -- --- -- --- Open source license information is in the zlib.ads file. -- ----------------------------------------------------------------- - --- $Id: zlib-streams.adb,v 1.10 2004/05/31 10:53:40 vagul Exp $ - -with Ada.Unchecked_Deallocation; - -package body ZLib.Streams is - - ----------- - -- Close -- - ----------- - - procedure Close (Stream : in out Stream_Type) is - procedure Free is new Ada.Unchecked_Deallocation - (Stream_Element_Array, Buffer_Access); - begin - if Stream.Mode = Out_Stream or Stream.Mode = Duplex then - -- We should flush the data written by the writer. - - Flush (Stream, Finish); - - Close (Stream.Writer); - end if; - - if Stream.Mode = In_Stream or Stream.Mode = Duplex then - Close (Stream.Reader); - Free (Stream.Buffer); - end if; - end Close; - - ------------ - -- Create -- - ------------ - - procedure Create - (Stream : out Stream_Type; - Mode : in Stream_Mode; - Back : in Stream_Access; - Back_Compressed : in Boolean; - Level : in Compression_Level := Default_Compression; - Strategy : in Strategy_Type := Default_Strategy; - Header : in Header_Type := Default; - Read_Buffer_Size : in Ada.Streams.Stream_Element_Offset - := Default_Buffer_Size; - Write_Buffer_Size : in Ada.Streams.Stream_Element_Offset - := Default_Buffer_Size) - is - - subtype Buffer_Subtype is Stream_Element_Array (1 .. Read_Buffer_Size); - - procedure Init_Filter - (Filter : in out Filter_Type; - Compress : in Boolean); - - ----------------- - -- Init_Filter -- - ----------------- - - procedure Init_Filter - (Filter : in out Filter_Type; - Compress : in Boolean) is - begin - if Compress then - Deflate_Init - (Filter, Level, Strategy, Header => Header); - else - Inflate_Init (Filter, Header => Header); - end if; - end Init_Filter; - - begin - Stream.Back := Back; - Stream.Mode := Mode; - - if Mode = Out_Stream or Mode = Duplex then - Init_Filter (Stream.Writer, Back_Compressed); - Stream.Buffer_Size := Write_Buffer_Size; - else - Stream.Buffer_Size := 0; - end if; - - if Mode = In_Stream or Mode = Duplex then - Init_Filter (Stream.Reader, not Back_Compressed); - - Stream.Buffer := new Buffer_Subtype; - Stream.Rest_First := Stream.Buffer'Last + 1; - Stream.Rest_Last := Stream.Buffer'Last; - end if; - end Create; - - ----------- - -- Flush -- - ----------- - - procedure Flush - (Stream : in out Stream_Type; - Mode : in Flush_Mode := Sync_Flush) - is - Buffer : Stream_Element_Array (1 .. Stream.Buffer_Size); - Last : Stream_Element_Offset; - begin - loop - Flush (Stream.Writer, Buffer, Last, Mode); - - Ada.Streams.Write (Stream.Back.all, Buffer (1 .. Last)); - - exit when Last < Buffer'Last; - end loop; - end Flush; - - ------------- - -- Is_Open -- - ------------- - - function Is_Open (Stream : Stream_Type) return Boolean is - begin - return Is_Open (Stream.Reader) or else Is_Open (Stream.Writer); - end Is_Open; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : in out Stream_Type; - Item : out Stream_Element_Array; - Last : out Stream_Element_Offset) - is - - procedure Read - (Item : out Stream_Element_Array; - Last : out Stream_Element_Offset); - - ---------- - -- Read -- - ---------- - - procedure Read - (Item : out Stream_Element_Array; - Last : out Stream_Element_Offset) is - begin - Ada.Streams.Read (Stream.Back.all, Item, Last); - end Read; - - procedure Read is new ZLib.Read - (Read => Read, - Buffer => Stream.Buffer.all, - Rest_First => Stream.Rest_First, - Rest_Last => Stream.Rest_Last); - - begin - Read (Stream.Reader, Item, Last); - end Read; - - ------------------- - -- Read_Total_In -- - ------------------- - - function Read_Total_In (Stream : in Stream_Type) return Count is - begin - return Total_In (Stream.Reader); - end Read_Total_In; - - -------------------- - -- Read_Total_Out -- - -------------------- - - function Read_Total_Out (Stream : in Stream_Type) return Count is - begin - return Total_Out (Stream.Reader); - end Read_Total_Out; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : in out Stream_Type; - Item : in Stream_Element_Array) - is - - procedure Write (Item : in Stream_Element_Array); - - ----------- - -- Write -- - ----------- - - procedure Write (Item : in Stream_Element_Array) is - begin - Ada.Streams.Write (Stream.Back.all, Item); - end Write; - - procedure Write is new ZLib.Write - (Write => Write, - Buffer_Size => Stream.Buffer_Size); - - begin - Write (Stream.Writer, Item, No_Flush); - end Write; - - -------------------- - -- Write_Total_In -- - -------------------- - - function Write_Total_In (Stream : in Stream_Type) return Count is - begin - return Total_In (Stream.Writer); - end Write_Total_In; - - --------------------- - -- Write_Total_Out -- - --------------------- - - function Write_Total_Out (Stream : in Stream_Type) return Count is - begin - return Total_Out (Stream.Writer); - end Write_Total_Out; - -end ZLib.Streams; DELETED compat/zlib/contrib/ada/zlib-streams.ads Index: compat/zlib/contrib/ada/zlib-streams.ads ================================================================== --- compat/zlib/contrib/ada/zlib-streams.ads +++ /dev/null @@ -1,114 +0,0 @@ ----------------------------------------------------------------- --- ZLib for Ada thick binding. -- --- -- --- Copyright (C) 2002-2003 Dmitriy Anisimkov -- --- -- --- Open source license information is in the zlib.ads file. -- ----------------------------------------------------------------- - --- $Id: zlib-streams.ads,v 1.12 2004/05/31 10:53:40 vagul Exp $ - -package ZLib.Streams is - - type Stream_Mode is (In_Stream, Out_Stream, Duplex); - - type Stream_Access is access all Ada.Streams.Root_Stream_Type'Class; - - type Stream_Type is - new Ada.Streams.Root_Stream_Type with private; - - procedure Read - (Stream : in out Stream_Type; - Item : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); - - procedure Write - (Stream : in out Stream_Type; - Item : in Ada.Streams.Stream_Element_Array); - - procedure Flush - (Stream : in out Stream_Type; - Mode : in Flush_Mode := Sync_Flush); - -- Flush the written data to the back stream, - -- all data placed to the compressor is flushing to the Back stream. - -- Should not be used until necessary, because it is decreasing - -- compression. - - function Read_Total_In (Stream : in Stream_Type) return Count; - pragma Inline (Read_Total_In); - -- Return total number of bytes read from back stream so far. - - function Read_Total_Out (Stream : in Stream_Type) return Count; - pragma Inline (Read_Total_Out); - -- Return total number of bytes read so far. - - function Write_Total_In (Stream : in Stream_Type) return Count; - pragma Inline (Write_Total_In); - -- Return total number of bytes written so far. - - function Write_Total_Out (Stream : in Stream_Type) return Count; - pragma Inline (Write_Total_Out); - -- Return total number of bytes written to the back stream. - - procedure Create - (Stream : out Stream_Type; - Mode : in Stream_Mode; - Back : in Stream_Access; - Back_Compressed : in Boolean; - Level : in Compression_Level := Default_Compression; - Strategy : in Strategy_Type := Default_Strategy; - Header : in Header_Type := Default; - Read_Buffer_Size : in Ada.Streams.Stream_Element_Offset - := Default_Buffer_Size; - Write_Buffer_Size : in Ada.Streams.Stream_Element_Offset - := Default_Buffer_Size); - -- Create the Comression/Decompression stream. - -- If mode is In_Stream then Write operation is disabled. - -- If mode is Out_Stream then Read operation is disabled. - - -- If Back_Compressed is true then - -- Data written to the Stream is compressing to the Back stream - -- and data read from the Stream is decompressed data from the Back stream. - - -- If Back_Compressed is false then - -- Data written to the Stream is decompressing to the Back stream - -- and data read from the Stream is compressed data from the Back stream. - - -- !!! When the Need_Header is False ZLib-Ada is using undocumented - -- ZLib 1.1.4 functionality to do not create/wait for ZLib headers. - - function Is_Open (Stream : Stream_Type) return Boolean; - - procedure Close (Stream : in out Stream_Type); - -private - - use Ada.Streams; - - type Buffer_Access is access all Stream_Element_Array; - - type Stream_Type - is new Root_Stream_Type with - record - Mode : Stream_Mode; - - Buffer : Buffer_Access; - Rest_First : Stream_Element_Offset; - Rest_Last : Stream_Element_Offset; - -- Buffer for Read operation. - -- We need to have this buffer in the record - -- because not all read data from back stream - -- could be processed during the read operation. - - Buffer_Size : Stream_Element_Offset; - -- Buffer size for write operation. - -- We do not need to have this buffer - -- in the record because all data could be - -- processed in the write operation. - - Back : Stream_Access; - Reader : Filter_Type; - Writer : Filter_Type; - end record; - -end ZLib.Streams; DELETED compat/zlib/contrib/ada/zlib-thin.adb Index: compat/zlib/contrib/ada/zlib-thin.adb ================================================================== --- compat/zlib/contrib/ada/zlib-thin.adb +++ /dev/null @@ -1,141 +0,0 @@ ----------------------------------------------------------------- --- ZLib for Ada thick binding. -- --- -- --- Copyright (C) 2002-2003 Dmitriy Anisimkov -- --- -- --- Open source license information is in the zlib.ads file. -- ----------------------------------------------------------------- - --- $Id: zlib-thin.adb,v 1.8 2003/12/14 18:27:31 vagul Exp $ - -package body ZLib.Thin is - - ZLIB_VERSION : constant Chars_Ptr := zlibVersion; - - Z_Stream_Size : constant Int := Z_Stream'Size / System.Storage_Unit; - - -------------- - -- Avail_In -- - -------------- - - function Avail_In (Strm : in Z_Stream) return UInt is - begin - return Strm.Avail_In; - end Avail_In; - - --------------- - -- Avail_Out -- - --------------- - - function Avail_Out (Strm : in Z_Stream) return UInt is - begin - return Strm.Avail_Out; - end Avail_Out; - - ------------------ - -- Deflate_Init -- - ------------------ - - function Deflate_Init - (strm : Z_Streamp; - level : Int; - method : Int; - windowBits : Int; - memLevel : Int; - strategy : Int) - return Int is - begin - return deflateInit2 - (strm, - level, - method, - windowBits, - memLevel, - strategy, - ZLIB_VERSION, - Z_Stream_Size); - end Deflate_Init; - - ------------------ - -- Inflate_Init -- - ------------------ - - function Inflate_Init (strm : Z_Streamp; windowBits : Int) return Int is - begin - return inflateInit2 (strm, windowBits, ZLIB_VERSION, Z_Stream_Size); - end Inflate_Init; - - ------------------------ - -- Last_Error_Message -- - ------------------------ - - function Last_Error_Message (Strm : in Z_Stream) return String is - use Interfaces.C.Strings; - begin - if Strm.msg = Null_Ptr then - return ""; - else - return Value (Strm.msg); - end if; - end Last_Error_Message; - - ------------ - -- Set_In -- - ------------ - - procedure Set_In - (Strm : in out Z_Stream; - Buffer : in Voidp; - Size : in UInt) is - begin - Strm.Next_In := Buffer; - Strm.Avail_In := Size; - end Set_In; - - ------------------ - -- Set_Mem_Func -- - ------------------ - - procedure Set_Mem_Func - (Strm : in out Z_Stream; - Opaque : in Voidp; - Alloc : in alloc_func; - Free : in free_func) is - begin - Strm.opaque := Opaque; - Strm.zalloc := Alloc; - Strm.zfree := Free; - end Set_Mem_Func; - - ------------- - -- Set_Out -- - ------------- - - procedure Set_Out - (Strm : in out Z_Stream; - Buffer : in Voidp; - Size : in UInt) is - begin - Strm.Next_Out := Buffer; - Strm.Avail_Out := Size; - end Set_Out; - - -------------- - -- Total_In -- - -------------- - - function Total_In (Strm : in Z_Stream) return ULong is - begin - return Strm.Total_In; - end Total_In; - - --------------- - -- Total_Out -- - --------------- - - function Total_Out (Strm : in Z_Stream) return ULong is - begin - return Strm.Total_Out; - end Total_Out; - -end ZLib.Thin; DELETED compat/zlib/contrib/ada/zlib-thin.ads Index: compat/zlib/contrib/ada/zlib-thin.ads ================================================================== --- compat/zlib/contrib/ada/zlib-thin.ads +++ /dev/null @@ -1,450 +0,0 @@ ----------------------------------------------------------------- --- ZLib for Ada thick binding. -- --- -- --- Copyright (C) 2002-2003 Dmitriy Anisimkov -- --- -- --- Open source license information is in the zlib.ads file. -- ----------------------------------------------------------------- - --- $Id: zlib-thin.ads,v 1.11 2004/07/23 06:33:11 vagul Exp $ - -with Interfaces.C.Strings; - -with System; - -private package ZLib.Thin is - - -- From zconf.h - - MAX_MEM_LEVEL : constant := 9; -- zconf.h:105 - -- zconf.h:105 - MAX_WBITS : constant := 15; -- zconf.h:115 - -- 32K LZ77 window - -- zconf.h:115 - SEEK_SET : constant := 8#0000#; -- zconf.h:244 - -- Seek from beginning of file. - -- zconf.h:244 - SEEK_CUR : constant := 1; -- zconf.h:245 - -- Seek from current position. - -- zconf.h:245 - SEEK_END : constant := 2; -- zconf.h:246 - -- Set file pointer to EOF plus "offset" - -- zconf.h:246 - - type Byte is new Interfaces.C.unsigned_char; -- 8 bits - -- zconf.h:214 - type UInt is new Interfaces.C.unsigned; -- 16 bits or more - -- zconf.h:216 - type Int is new Interfaces.C.int; - - type ULong is new Interfaces.C.unsigned_long; -- 32 bits or more - -- zconf.h:217 - subtype Chars_Ptr is Interfaces.C.Strings.chars_ptr; - - type ULong_Access is access ULong; - type Int_Access is access Int; - - subtype Voidp is System.Address; -- zconf.h:232 - - subtype Byte_Access is Voidp; - - Nul : constant Voidp := System.Null_Address; - -- end from zconf - - Z_NO_FLUSH : constant := 8#0000#; -- zlib.h:125 - -- zlib.h:125 - Z_PARTIAL_FLUSH : constant := 1; -- zlib.h:126 - -- will be removed, use - -- Z_SYNC_FLUSH instead - -- zlib.h:126 - Z_SYNC_FLUSH : constant := 2; -- zlib.h:127 - -- zlib.h:127 - Z_FULL_FLUSH : constant := 3; -- zlib.h:128 - -- zlib.h:128 - Z_FINISH : constant := 4; -- zlib.h:129 - -- zlib.h:129 - Z_OK : constant := 8#0000#; -- zlib.h:132 - -- zlib.h:132 - Z_STREAM_END : constant := 1; -- zlib.h:133 - -- zlib.h:133 - Z_NEED_DICT : constant := 2; -- zlib.h:134 - -- zlib.h:134 - Z_ERRNO : constant := -1; -- zlib.h:135 - -- zlib.h:135 - Z_STREAM_ERROR : constant := -2; -- zlib.h:136 - -- zlib.h:136 - Z_DATA_ERROR : constant := -3; -- zlib.h:137 - -- zlib.h:137 - Z_MEM_ERROR : constant := -4; -- zlib.h:138 - -- zlib.h:138 - Z_BUF_ERROR : constant := -5; -- zlib.h:139 - -- zlib.h:139 - Z_VERSION_ERROR : constant := -6; -- zlib.h:140 - -- zlib.h:140 - Z_NO_COMPRESSION : constant := 8#0000#; -- zlib.h:145 - -- zlib.h:145 - Z_BEST_SPEED : constant := 1; -- zlib.h:146 - -- zlib.h:146 - Z_BEST_COMPRESSION : constant := 9; -- zlib.h:147 - -- zlib.h:147 - Z_DEFAULT_COMPRESSION : constant := -1; -- zlib.h:148 - -- zlib.h:148 - Z_FILTERED : constant := 1; -- zlib.h:151 - -- zlib.h:151 - Z_HUFFMAN_ONLY : constant := 2; -- zlib.h:152 - -- zlib.h:152 - Z_DEFAULT_STRATEGY : constant := 8#0000#; -- zlib.h:153 - -- zlib.h:153 - Z_BINARY : constant := 8#0000#; -- zlib.h:156 - -- zlib.h:156 - Z_ASCII : constant := 1; -- zlib.h:157 - -- zlib.h:157 - Z_UNKNOWN : constant := 2; -- zlib.h:158 - -- zlib.h:158 - Z_DEFLATED : constant := 8; -- zlib.h:161 - -- zlib.h:161 - Z_NULL : constant := 8#0000#; -- zlib.h:164 - -- for initializing zalloc, zfree, opaque - -- zlib.h:164 - type gzFile is new Voidp; -- zlib.h:646 - - type Z_Stream is private; - - type Z_Streamp is access all Z_Stream; -- zlib.h:89 - - type alloc_func is access function - (Opaque : Voidp; - Items : UInt; - Size : UInt) - return Voidp; -- zlib.h:63 - - type free_func is access procedure (opaque : Voidp; address : Voidp); - - function zlibVersion return Chars_Ptr; - - function Deflate (strm : Z_Streamp; flush : Int) return Int; - - function DeflateEnd (strm : Z_Streamp) return Int; - - function Inflate (strm : Z_Streamp; flush : Int) return Int; - - function InflateEnd (strm : Z_Streamp) return Int; - - function deflateSetDictionary - (strm : Z_Streamp; - dictionary : Byte_Access; - dictLength : UInt) - return Int; - - function deflateCopy (dest : Z_Streamp; source : Z_Streamp) return Int; - -- zlib.h:478 - - function deflateReset (strm : Z_Streamp) return Int; -- zlib.h:495 - - function deflateParams - (strm : Z_Streamp; - level : Int; - strategy : Int) - return Int; -- zlib.h:506 - - function inflateSetDictionary - (strm : Z_Streamp; - dictionary : Byte_Access; - dictLength : UInt) - return Int; -- zlib.h:548 - - function inflateSync (strm : Z_Streamp) return Int; -- zlib.h:565 - - function inflateReset (strm : Z_Streamp) return Int; -- zlib.h:580 - - function compress - (dest : Byte_Access; - destLen : ULong_Access; - source : Byte_Access; - sourceLen : ULong) - return Int; -- zlib.h:601 - - function compress2 - (dest : Byte_Access; - destLen : ULong_Access; - source : Byte_Access; - sourceLen : ULong; - level : Int) - return Int; -- zlib.h:615 - - function uncompress - (dest : Byte_Access; - destLen : ULong_Access; - source : Byte_Access; - sourceLen : ULong) - return Int; - - function gzopen (path : Chars_Ptr; mode : Chars_Ptr) return gzFile; - - function gzdopen (fd : Int; mode : Chars_Ptr) return gzFile; - - function gzsetparams - (file : gzFile; - level : Int; - strategy : Int) - return Int; - - function gzread - (file : gzFile; - buf : Voidp; - len : UInt) - return Int; - - function gzwrite - (file : in gzFile; - buf : in Voidp; - len : in UInt) - return Int; - - function gzprintf (file : in gzFile; format : in Chars_Ptr) return Int; - - function gzputs (file : in gzFile; s : in Chars_Ptr) return Int; - - function gzgets - (file : gzFile; - buf : Chars_Ptr; - len : Int) - return Chars_Ptr; - - function gzputc (file : gzFile; char : Int) return Int; - - function gzgetc (file : gzFile) return Int; - - function gzflush (file : gzFile; flush : Int) return Int; - - function gzseek - (file : gzFile; - offset : Int; - whence : Int) - return Int; - - function gzrewind (file : gzFile) return Int; - - function gztell (file : gzFile) return Int; - - function gzeof (file : gzFile) return Int; - - function gzclose (file : gzFile) return Int; - - function gzerror (file : gzFile; errnum : Int_Access) return Chars_Ptr; - - function adler32 - (adler : ULong; - buf : Byte_Access; - len : UInt) - return ULong; - - function crc32 - (crc : ULong; - buf : Byte_Access; - len : UInt) - return ULong; - - function deflateInit - (strm : Z_Streamp; - level : Int; - version : Chars_Ptr; - stream_size : Int) - return Int; - - function deflateInit2 - (strm : Z_Streamp; - level : Int; - method : Int; - windowBits : Int; - memLevel : Int; - strategy : Int; - version : Chars_Ptr; - stream_size : Int) - return Int; - - function Deflate_Init - (strm : Z_Streamp; - level : Int; - method : Int; - windowBits : Int; - memLevel : Int; - strategy : Int) - return Int; - pragma Inline (Deflate_Init); - - function inflateInit - (strm : Z_Streamp; - version : Chars_Ptr; - stream_size : Int) - return Int; - - function inflateInit2 - (strm : in Z_Streamp; - windowBits : in Int; - version : in Chars_Ptr; - stream_size : in Int) - return Int; - - function inflateBackInit - (strm : in Z_Streamp; - windowBits : in Int; - window : in Byte_Access; - version : in Chars_Ptr; - stream_size : in Int) - return Int; - -- Size of window have to be 2**windowBits. - - function Inflate_Init (strm : Z_Streamp; windowBits : Int) return Int; - pragma Inline (Inflate_Init); - - function zError (err : Int) return Chars_Ptr; - - function inflateSyncPoint (z : Z_Streamp) return Int; - - function get_crc_table return ULong_Access; - - -- Interface to the available fields of the z_stream structure. - -- The application must update next_in and avail_in when avail_in has - -- dropped to zero. It must update next_out and avail_out when avail_out - -- has dropped to zero. The application must initialize zalloc, zfree and - -- opaque before calling the init function. - - procedure Set_In - (Strm : in out Z_Stream; - Buffer : in Voidp; - Size : in UInt); - pragma Inline (Set_In); - - procedure Set_Out - (Strm : in out Z_Stream; - Buffer : in Voidp; - Size : in UInt); - pragma Inline (Set_Out); - - procedure Set_Mem_Func - (Strm : in out Z_Stream; - Opaque : in Voidp; - Alloc : in alloc_func; - Free : in free_func); - pragma Inline (Set_Mem_Func); - - function Last_Error_Message (Strm : in Z_Stream) return String; - pragma Inline (Last_Error_Message); - - function Avail_Out (Strm : in Z_Stream) return UInt; - pragma Inline (Avail_Out); - - function Avail_In (Strm : in Z_Stream) return UInt; - pragma Inline (Avail_In); - - function Total_In (Strm : in Z_Stream) return ULong; - pragma Inline (Total_In); - - function Total_Out (Strm : in Z_Stream) return ULong; - pragma Inline (Total_Out); - - function inflateCopy - (dest : in Z_Streamp; - Source : in Z_Streamp) - return Int; - - function compressBound (Source_Len : in ULong) return ULong; - - function deflateBound - (Strm : in Z_Streamp; - Source_Len : in ULong) - return ULong; - - function gzungetc (C : in Int; File : in gzFile) return Int; - - function zlibCompileFlags return ULong; - -private - - type Z_Stream is record -- zlib.h:68 - Next_In : Voidp := Nul; -- next input byte - Avail_In : UInt := 0; -- number of bytes available at next_in - Total_In : ULong := 0; -- total nb of input bytes read so far - Next_Out : Voidp := Nul; -- next output byte should be put there - Avail_Out : UInt := 0; -- remaining free space at next_out - Total_Out : ULong := 0; -- total nb of bytes output so far - msg : Chars_Ptr; -- last error message, NULL if no error - state : Voidp; -- not visible by applications - zalloc : alloc_func := null; -- used to allocate the internal state - zfree : free_func := null; -- used to free the internal state - opaque : Voidp; -- private data object passed to - -- zalloc and zfree - data_type : Int; -- best guess about the data type: - -- ascii or binary - adler : ULong; -- adler32 value of the uncompressed - -- data - reserved : ULong; -- reserved for future use - end record; - - pragma Convention (C, Z_Stream); - - pragma Import (C, zlibVersion, "zlibVersion"); - pragma Import (C, Deflate, "deflate"); - pragma Import (C, DeflateEnd, "deflateEnd"); - pragma Import (C, Inflate, "inflate"); - pragma Import (C, InflateEnd, "inflateEnd"); - pragma Import (C, deflateSetDictionary, "deflateSetDictionary"); - pragma Import (C, deflateCopy, "deflateCopy"); - pragma Import (C, deflateReset, "deflateReset"); - pragma Import (C, deflateParams, "deflateParams"); - pragma Import (C, inflateSetDictionary, "inflateSetDictionary"); - pragma Import (C, inflateSync, "inflateSync"); - pragma Import (C, inflateReset, "inflateReset"); - pragma Import (C, compress, "compress"); - pragma Import (C, compress2, "compress2"); - pragma Import (C, uncompress, "uncompress"); - pragma Import (C, gzopen, "gzopen"); - pragma Import (C, gzdopen, "gzdopen"); - pragma Import (C, gzsetparams, "gzsetparams"); - pragma Import (C, gzread, "gzread"); - pragma Import (C, gzwrite, "gzwrite"); - pragma Import (C, gzprintf, "gzprintf"); - pragma Import (C, gzputs, "gzputs"); - pragma Import (C, gzgets, "gzgets"); - pragma Import (C, gzputc, "gzputc"); - pragma Import (C, gzgetc, "gzgetc"); - pragma Import (C, gzflush, "gzflush"); - pragma Import (C, gzseek, "gzseek"); - pragma Import (C, gzrewind, "gzrewind"); - pragma Import (C, gztell, "gztell"); - pragma Import (C, gzeof, "gzeof"); - pragma Import (C, gzclose, "gzclose"); - pragma Import (C, gzerror, "gzerror"); - pragma Import (C, adler32, "adler32"); - pragma Import (C, crc32, "crc32"); - pragma Import (C, deflateInit, "deflateInit_"); - pragma Import (C, inflateInit, "inflateInit_"); - pragma Import (C, deflateInit2, "deflateInit2_"); - pragma Import (C, inflateInit2, "inflateInit2_"); - pragma Import (C, zError, "zError"); - pragma Import (C, inflateSyncPoint, "inflateSyncPoint"); - pragma Import (C, get_crc_table, "get_crc_table"); - - -- since zlib 1.2.0: - - pragma Import (C, inflateCopy, "inflateCopy"); - pragma Import (C, compressBound, "compressBound"); - pragma Import (C, deflateBound, "deflateBound"); - pragma Import (C, gzungetc, "gzungetc"); - pragma Import (C, zlibCompileFlags, "zlibCompileFlags"); - - pragma Import (C, inflateBackInit, "inflateBackInit_"); - - -- I stopped binding the inflateBack routines, because realize that - -- it does not support zlib and gzip headers for now, and have no - -- symmetric deflateBack routines. - -- ZLib-Ada is symmetric regarding deflate/inflate data transformation - -- and has a similar generic callback interface for the - -- deflate/inflate transformation based on the regular Deflate/Inflate - -- routines. - - -- pragma Import (C, inflateBack, "inflateBack"); - -- pragma Import (C, inflateBackEnd, "inflateBackEnd"); - -end ZLib.Thin; DELETED compat/zlib/contrib/ada/zlib.adb Index: compat/zlib/contrib/ada/zlib.adb ================================================================== --- compat/zlib/contrib/ada/zlib.adb +++ /dev/null @@ -1,701 +0,0 @@ ----------------------------------------------------------------- --- ZLib for Ada thick binding. -- --- -- --- Copyright (C) 2002-2004 Dmitriy Anisimkov -- --- -- --- Open source license information is in the zlib.ads file. -- ----------------------------------------------------------------- - --- $Id: zlib.adb,v 1.31 2004/09/06 06:53:19 vagul Exp $ - -with Ada.Exceptions; -with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; - -with Interfaces.C.Strings; - -with ZLib.Thin; - -package body ZLib is - - use type Thin.Int; - - type Z_Stream is new Thin.Z_Stream; - - type Return_Code_Enum is - (OK, - STREAM_END, - NEED_DICT, - ERRNO, - STREAM_ERROR, - DATA_ERROR, - MEM_ERROR, - BUF_ERROR, - VERSION_ERROR); - - type Flate_Step_Function is access - function (Strm : in Thin.Z_Streamp; Flush : in Thin.Int) return Thin.Int; - pragma Convention (C, Flate_Step_Function); - - type Flate_End_Function is access - function (Ctrm : in Thin.Z_Streamp) return Thin.Int; - pragma Convention (C, Flate_End_Function); - - type Flate_Type is record - Step : Flate_Step_Function; - Done : Flate_End_Function; - end record; - - subtype Footer_Array is Stream_Element_Array (1 .. 8); - - Simple_GZip_Header : constant Stream_Element_Array (1 .. 10) - := (16#1f#, 16#8b#, -- Magic header - 16#08#, -- Z_DEFLATED - 16#00#, -- Flags - 16#00#, 16#00#, 16#00#, 16#00#, -- Time - 16#00#, -- XFlags - 16#03# -- OS code - ); - -- The simplest gzip header is not for informational, but just for - -- gzip format compatibility. - -- Note that some code below is using assumption - -- Simple_GZip_Header'Last > Footer_Array'Last, so do not make - -- Simple_GZip_Header'Last <= Footer_Array'Last. - - Return_Code : constant array (Thin.Int range <>) of Return_Code_Enum - := (0 => OK, - 1 => STREAM_END, - 2 => NEED_DICT, - -1 => ERRNO, - -2 => STREAM_ERROR, - -3 => DATA_ERROR, - -4 => MEM_ERROR, - -5 => BUF_ERROR, - -6 => VERSION_ERROR); - - Flate : constant array (Boolean) of Flate_Type - := (True => (Step => Thin.Deflate'Access, - Done => Thin.DeflateEnd'Access), - False => (Step => Thin.Inflate'Access, - Done => Thin.InflateEnd'Access)); - - Flush_Finish : constant array (Boolean) of Flush_Mode - := (True => Finish, False => No_Flush); - - procedure Raise_Error (Stream : in Z_Stream); - pragma Inline (Raise_Error); - - procedure Raise_Error (Message : in String); - pragma Inline (Raise_Error); - - procedure Check_Error (Stream : in Z_Stream; Code : in Thin.Int); - - procedure Free is new Ada.Unchecked_Deallocation - (Z_Stream, Z_Stream_Access); - - function To_Thin_Access is new Ada.Unchecked_Conversion - (Z_Stream_Access, Thin.Z_Streamp); - - procedure Translate_GZip - (Filter : in out Filter_Type; - In_Data : in Ada.Streams.Stream_Element_Array; - In_Last : out Ada.Streams.Stream_Element_Offset; - Out_Data : out Ada.Streams.Stream_Element_Array; - Out_Last : out Ada.Streams.Stream_Element_Offset; - Flush : in Flush_Mode); - -- Separate translate routine for make gzip header. - - procedure Translate_Auto - (Filter : in out Filter_Type; - In_Data : in Ada.Streams.Stream_Element_Array; - In_Last : out Ada.Streams.Stream_Element_Offset; - Out_Data : out Ada.Streams.Stream_Element_Array; - Out_Last : out Ada.Streams.Stream_Element_Offset; - Flush : in Flush_Mode); - -- translate routine without additional headers. - - ----------------- - -- Check_Error -- - ----------------- - - procedure Check_Error (Stream : in Z_Stream; Code : in Thin.Int) is - use type Thin.Int; - begin - if Code /= Thin.Z_OK then - Raise_Error - (Return_Code_Enum'Image (Return_Code (Code)) - & ": " & Last_Error_Message (Stream)); - end if; - end Check_Error; - - ----------- - -- Close -- - ----------- - - procedure Close - (Filter : in out Filter_Type; - Ignore_Error : in Boolean := False) - is - Code : Thin.Int; - begin - if not Ignore_Error and then not Is_Open (Filter) then - raise Status_Error; - end if; - - Code := Flate (Filter.Compression).Done (To_Thin_Access (Filter.Strm)); - - if Ignore_Error or else Code = Thin.Z_OK then - Free (Filter.Strm); - else - declare - Error_Message : constant String - := Last_Error_Message (Filter.Strm.all); - begin - Free (Filter.Strm); - Ada.Exceptions.Raise_Exception - (ZLib_Error'Identity, - Return_Code_Enum'Image (Return_Code (Code)) - & ": " & Error_Message); - end; - end if; - end Close; - - ----------- - -- CRC32 -- - ----------- - - function CRC32 - (CRC : in Unsigned_32; - Data : in Ada.Streams.Stream_Element_Array) - return Unsigned_32 - is - use Thin; - begin - return Unsigned_32 (crc32 (ULong (CRC), - Data'Address, - Data'Length)); - end CRC32; - - procedure CRC32 - (CRC : in out Unsigned_32; - Data : in Ada.Streams.Stream_Element_Array) is - begin - CRC := CRC32 (CRC, Data); - end CRC32; - - ------------------ - -- Deflate_Init -- - ------------------ - - procedure Deflate_Init - (Filter : in out Filter_Type; - Level : in Compression_Level := Default_Compression; - Strategy : in Strategy_Type := Default_Strategy; - Method : in Compression_Method := Deflated; - Window_Bits : in Window_Bits_Type := Default_Window_Bits; - Memory_Level : in Memory_Level_Type := Default_Memory_Level; - Header : in Header_Type := Default) - is - use type Thin.Int; - Win_Bits : Thin.Int := Thin.Int (Window_Bits); - begin - if Is_Open (Filter) then - raise Status_Error; - end if; - - -- We allow ZLib to make header only in case of default header type. - -- Otherwise we would either do header by ourselfs, or do not do - -- header at all. - - if Header = None or else Header = GZip then - Win_Bits := -Win_Bits; - end if; - - -- For the GZip CRC calculation and make headers. - - if Header = GZip then - Filter.CRC := 0; - Filter.Offset := Simple_GZip_Header'First; - else - Filter.Offset := Simple_GZip_Header'Last + 1; - end if; - - Filter.Strm := new Z_Stream; - Filter.Compression := True; - Filter.Stream_End := False; - Filter.Header := Header; - - if Thin.Deflate_Init - (To_Thin_Access (Filter.Strm), - Level => Thin.Int (Level), - method => Thin.Int (Method), - windowBits => Win_Bits, - memLevel => Thin.Int (Memory_Level), - strategy => Thin.Int (Strategy)) /= Thin.Z_OK - then - Raise_Error (Filter.Strm.all); - end if; - end Deflate_Init; - - ----------- - -- Flush -- - ----------- - - procedure Flush - (Filter : in out Filter_Type; - Out_Data : out Ada.Streams.Stream_Element_Array; - Out_Last : out Ada.Streams.Stream_Element_Offset; - Flush : in Flush_Mode) - is - No_Data : Stream_Element_Array := (1 .. 0 => 0); - Last : Stream_Element_Offset; - begin - Translate (Filter, No_Data, Last, Out_Data, Out_Last, Flush); - end Flush; - - ----------------------- - -- Generic_Translate -- - ----------------------- - - procedure Generic_Translate - (Filter : in out ZLib.Filter_Type; - In_Buffer_Size : in Integer := Default_Buffer_Size; - Out_Buffer_Size : in Integer := Default_Buffer_Size) - is - In_Buffer : Stream_Element_Array - (1 .. Stream_Element_Offset (In_Buffer_Size)); - Out_Buffer : Stream_Element_Array - (1 .. Stream_Element_Offset (Out_Buffer_Size)); - Last : Stream_Element_Offset; - In_Last : Stream_Element_Offset; - In_First : Stream_Element_Offset; - Out_Last : Stream_Element_Offset; - begin - Main : loop - Data_In (In_Buffer, Last); - - In_First := In_Buffer'First; - - loop - Translate - (Filter => Filter, - In_Data => In_Buffer (In_First .. Last), - In_Last => In_Last, - Out_Data => Out_Buffer, - Out_Last => Out_Last, - Flush => Flush_Finish (Last < In_Buffer'First)); - - if Out_Buffer'First <= Out_Last then - Data_Out (Out_Buffer (Out_Buffer'First .. Out_Last)); - end if; - - exit Main when Stream_End (Filter); - - -- The end of in buffer. - - exit when In_Last = Last; - - In_First := In_Last + 1; - end loop; - end loop Main; - - end Generic_Translate; - - ------------------ - -- Inflate_Init -- - ------------------ - - procedure Inflate_Init - (Filter : in out Filter_Type; - Window_Bits : in Window_Bits_Type := Default_Window_Bits; - Header : in Header_Type := Default) - is - use type Thin.Int; - Win_Bits : Thin.Int := Thin.Int (Window_Bits); - - procedure Check_Version; - -- Check the latest header types compatibility. - - procedure Check_Version is - begin - if Version <= "1.1.4" then - Raise_Error - ("Inflate header type " & Header_Type'Image (Header) - & " incompatible with ZLib version " & Version); - end if; - end Check_Version; - - begin - if Is_Open (Filter) then - raise Status_Error; - end if; - - case Header is - when None => - Check_Version; - - -- Inflate data without headers determined - -- by negative Win_Bits. - - Win_Bits := -Win_Bits; - when GZip => - Check_Version; - - -- Inflate gzip data defined by flag 16. - - Win_Bits := Win_Bits + 16; - when Auto => - Check_Version; - - -- Inflate with automatic detection - -- of gzip or native header defined by flag 32. - - Win_Bits := Win_Bits + 32; - when Default => null; - end case; - - Filter.Strm := new Z_Stream; - Filter.Compression := False; - Filter.Stream_End := False; - Filter.Header := Header; - - if Thin.Inflate_Init - (To_Thin_Access (Filter.Strm), Win_Bits) /= Thin.Z_OK - then - Raise_Error (Filter.Strm.all); - end if; - end Inflate_Init; - - ------------- - -- Is_Open -- - ------------- - - function Is_Open (Filter : in Filter_Type) return Boolean is - begin - return Filter.Strm /= null; - end Is_Open; - - ----------------- - -- Raise_Error -- - ----------------- - - procedure Raise_Error (Message : in String) is - begin - Ada.Exceptions.Raise_Exception (ZLib_Error'Identity, Message); - end Raise_Error; - - procedure Raise_Error (Stream : in Z_Stream) is - begin - Raise_Error (Last_Error_Message (Stream)); - end Raise_Error; - - ---------- - -- Read -- - ---------- - - procedure Read - (Filter : in out Filter_Type; - Item : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset; - Flush : in Flush_Mode := No_Flush) - is - In_Last : Stream_Element_Offset; - Item_First : Ada.Streams.Stream_Element_Offset := Item'First; - V_Flush : Flush_Mode := Flush; - - begin - pragma Assert (Rest_First in Buffer'First .. Buffer'Last + 1); - pragma Assert (Rest_Last in Buffer'First - 1 .. Buffer'Last); - - loop - if Rest_Last = Buffer'First - 1 then - V_Flush := Finish; - - elsif Rest_First > Rest_Last then - Read (Buffer, Rest_Last); - Rest_First := Buffer'First; - - if Rest_Last < Buffer'First then - V_Flush := Finish; - end if; - end if; - - Translate - (Filter => Filter, - In_Data => Buffer (Rest_First .. Rest_Last), - In_Last => In_Last, - Out_Data => Item (Item_First .. Item'Last), - Out_Last => Last, - Flush => V_Flush); - - Rest_First := In_Last + 1; - - exit when Stream_End (Filter) - or else Last = Item'Last - or else (Last >= Item'First and then Allow_Read_Some); - - Item_First := Last + 1; - end loop; - end Read; - - ---------------- - -- Stream_End -- - ---------------- - - function Stream_End (Filter : in Filter_Type) return Boolean is - begin - if Filter.Header = GZip and Filter.Compression then - return Filter.Stream_End - and then Filter.Offset = Footer_Array'Last + 1; - else - return Filter.Stream_End; - end if; - end Stream_End; - - -------------- - -- Total_In -- - -------------- - - function Total_In (Filter : in Filter_Type) return Count is - begin - return Count (Thin.Total_In (To_Thin_Access (Filter.Strm).all)); - end Total_In; - - --------------- - -- Total_Out -- - --------------- - - function Total_Out (Filter : in Filter_Type) return Count is - begin - return Count (Thin.Total_Out (To_Thin_Access (Filter.Strm).all)); - end Total_Out; - - --------------- - -- Translate -- - --------------- - - procedure Translate - (Filter : in out Filter_Type; - In_Data : in Ada.Streams.Stream_Element_Array; - In_Last : out Ada.Streams.Stream_Element_Offset; - Out_Data : out Ada.Streams.Stream_Element_Array; - Out_Last : out Ada.Streams.Stream_Element_Offset; - Flush : in Flush_Mode) is - begin - if Filter.Header = GZip and then Filter.Compression then - Translate_GZip - (Filter => Filter, - In_Data => In_Data, - In_Last => In_Last, - Out_Data => Out_Data, - Out_Last => Out_Last, - Flush => Flush); - else - Translate_Auto - (Filter => Filter, - In_Data => In_Data, - In_Last => In_Last, - Out_Data => Out_Data, - Out_Last => Out_Last, - Flush => Flush); - end if; - end Translate; - - -------------------- - -- Translate_Auto -- - -------------------- - - procedure Translate_Auto - (Filter : in out Filter_Type; - In_Data : in Ada.Streams.Stream_Element_Array; - In_Last : out Ada.Streams.Stream_Element_Offset; - Out_Data : out Ada.Streams.Stream_Element_Array; - Out_Last : out Ada.Streams.Stream_Element_Offset; - Flush : in Flush_Mode) - is - use type Thin.Int; - Code : Thin.Int; - - begin - if not Is_Open (Filter) then - raise Status_Error; - end if; - - if Out_Data'Length = 0 and then In_Data'Length = 0 then - raise Constraint_Error; - end if; - - Set_Out (Filter.Strm.all, Out_Data'Address, Out_Data'Length); - Set_In (Filter.Strm.all, In_Data'Address, In_Data'Length); - - Code := Flate (Filter.Compression).Step - (To_Thin_Access (Filter.Strm), - Thin.Int (Flush)); - - if Code = Thin.Z_STREAM_END then - Filter.Stream_End := True; - else - Check_Error (Filter.Strm.all, Code); - end if; - - In_Last := In_Data'Last - - Stream_Element_Offset (Avail_In (Filter.Strm.all)); - Out_Last := Out_Data'Last - - Stream_Element_Offset (Avail_Out (Filter.Strm.all)); - end Translate_Auto; - - -------------------- - -- Translate_GZip -- - -------------------- - - procedure Translate_GZip - (Filter : in out Filter_Type; - In_Data : in Ada.Streams.Stream_Element_Array; - In_Last : out Ada.Streams.Stream_Element_Offset; - Out_Data : out Ada.Streams.Stream_Element_Array; - Out_Last : out Ada.Streams.Stream_Element_Offset; - Flush : in Flush_Mode) - is - Out_First : Stream_Element_Offset; - - procedure Add_Data (Data : in Stream_Element_Array); - -- Add data to stream from the Filter.Offset till necessary, - -- used for add gzip headr/footer. - - procedure Put_32 - (Item : in out Stream_Element_Array; - Data : in Unsigned_32); - pragma Inline (Put_32); - - -------------- - -- Add_Data -- - -------------- - - procedure Add_Data (Data : in Stream_Element_Array) is - Data_First : Stream_Element_Offset renames Filter.Offset; - Data_Last : Stream_Element_Offset; - Data_Len : Stream_Element_Offset; -- -1 - Out_Len : Stream_Element_Offset; -- -1 - begin - Out_First := Out_Last + 1; - - if Data_First > Data'Last then - return; - end if; - - Data_Len := Data'Last - Data_First; - Out_Len := Out_Data'Last - Out_First; - - if Data_Len <= Out_Len then - Out_Last := Out_First + Data_Len; - Data_Last := Data'Last; - else - Out_Last := Out_Data'Last; - Data_Last := Data_First + Out_Len; - end if; - - Out_Data (Out_First .. Out_Last) := Data (Data_First .. Data_Last); - - Data_First := Data_Last + 1; - Out_First := Out_Last + 1; - end Add_Data; - - ------------ - -- Put_32 -- - ------------ - - procedure Put_32 - (Item : in out Stream_Element_Array; - Data : in Unsigned_32) - is - D : Unsigned_32 := Data; - begin - for J in Item'First .. Item'First + 3 loop - Item (J) := Stream_Element (D and 16#FF#); - D := Shift_Right (D, 8); - end loop; - end Put_32; - - begin - Out_Last := Out_Data'First - 1; - - if not Filter.Stream_End then - Add_Data (Simple_GZip_Header); - - Translate_Auto - (Filter => Filter, - In_Data => In_Data, - In_Last => In_Last, - Out_Data => Out_Data (Out_First .. Out_Data'Last), - Out_Last => Out_Last, - Flush => Flush); - - CRC32 (Filter.CRC, In_Data (In_Data'First .. In_Last)); - end if; - - if Filter.Stream_End and then Out_Last <= Out_Data'Last then - -- This detection method would work only when - -- Simple_GZip_Header'Last > Footer_Array'Last - - if Filter.Offset = Simple_GZip_Header'Last + 1 then - Filter.Offset := Footer_Array'First; - end if; - - declare - Footer : Footer_Array; - begin - Put_32 (Footer, Filter.CRC); - Put_32 (Footer (Footer'First + 4 .. Footer'Last), - Unsigned_32 (Total_In (Filter))); - Add_Data (Footer); - end; - end if; - end Translate_GZip; - - ------------- - -- Version -- - ------------- - - function Version return String is - begin - return Interfaces.C.Strings.Value (Thin.zlibVersion); - end Version; - - ----------- - -- Write -- - ----------- - - procedure Write - (Filter : in out Filter_Type; - Item : in Ada.Streams.Stream_Element_Array; - Flush : in Flush_Mode := No_Flush) - is - Buffer : Stream_Element_Array (1 .. Buffer_Size); - In_Last : Stream_Element_Offset; - Out_Last : Stream_Element_Offset; - In_First : Stream_Element_Offset := Item'First; - begin - if Item'Length = 0 and Flush = No_Flush then - return; - end if; - - loop - Translate - (Filter => Filter, - In_Data => Item (In_First .. Item'Last), - In_Last => In_Last, - Out_Data => Buffer, - Out_Last => Out_Last, - Flush => Flush); - - if Out_Last >= Buffer'First then - Write (Buffer (1 .. Out_Last)); - end if; - - exit when In_Last = Item'Last or Stream_End (Filter); - - In_First := In_Last + 1; - end loop; - end Write; - -end ZLib; DELETED compat/zlib/contrib/ada/zlib.ads Index: compat/zlib/contrib/ada/zlib.ads ================================================================== --- compat/zlib/contrib/ada/zlib.ads +++ /dev/null @@ -1,328 +0,0 @@ ------------------------------------------------------------------------------- --- ZLib for Ada thick binding. -- --- -- --- Copyright (C) 2002-2004 Dmitriy Anisimkov -- --- -- --- This library is free software; you can redistribute it and/or modify -- --- it under the terms of the GNU General Public License as published by -- --- the Free Software Foundation; either version 2 of the License, or (at -- --- your option) any later version. -- --- -- --- This library is distributed in the hope that it will be useful, but -- --- WITHOUT ANY WARRANTY; without even the implied warranty of -- --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- --- General Public License for more details. -- --- -- --- You should have received a copy of the GNU General Public License -- --- along with this library; if not, write to the Free Software Foundation, -- --- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- ------------------------------------------------------------------------------- - --- $Id: zlib.ads,v 1.26 2004/09/06 06:53:19 vagul Exp $ - -with Ada.Streams; - -with Interfaces; - -package ZLib is - - ZLib_Error : exception; - Status_Error : exception; - - type Compression_Level is new Integer range -1 .. 9; - - type Flush_Mode is private; - - type Compression_Method is private; - - type Window_Bits_Type is new Integer range 8 .. 15; - - type Memory_Level_Type is new Integer range 1 .. 9; - - type Unsigned_32 is new Interfaces.Unsigned_32; - - type Strategy_Type is private; - - type Header_Type is (None, Auto, Default, GZip); - -- Header type usage have a some limitation for inflate. - -- See comment for Inflate_Init. - - subtype Count is Ada.Streams.Stream_Element_Count; - - Default_Memory_Level : constant Memory_Level_Type := 8; - Default_Window_Bits : constant Window_Bits_Type := 15; - - ---------------------------------- - -- Compression method constants -- - ---------------------------------- - - Deflated : constant Compression_Method; - -- Only one method allowed in this ZLib version - - --------------------------------- - -- Compression level constants -- - --------------------------------- - - No_Compression : constant Compression_Level := 0; - Best_Speed : constant Compression_Level := 1; - Best_Compression : constant Compression_Level := 9; - Default_Compression : constant Compression_Level := -1; - - -------------------------- - -- Flush mode constants -- - -------------------------- - - No_Flush : constant Flush_Mode; - -- Regular way for compression, no flush - - Partial_Flush : constant Flush_Mode; - -- Will be removed, use Z_SYNC_FLUSH instead - - Sync_Flush : constant Flush_Mode; - -- All pending output is flushed to the output buffer and the output - -- is aligned on a byte boundary, so that the decompressor can get all - -- input data available so far. (In particular avail_in is zero after the - -- call if enough output space has been provided before the call.) - -- Flushing may degrade compression for some compression algorithms and so - -- it should be used only when necessary. - - Block_Flush : constant Flush_Mode; - -- Z_BLOCK requests that inflate() stop - -- if and when it get to the next deflate block boundary. When decoding the - -- zlib or gzip format, this will cause inflate() to return immediately - -- after the header and before the first block. When doing a raw inflate, - -- inflate() will go ahead and process the first block, and will return - -- when it gets to the end of that block, or when it runs out of data. - - Full_Flush : constant Flush_Mode; - -- All output is flushed as with SYNC_FLUSH, and the compression state - -- is reset so that decompression can restart from this point if previous - -- compressed data has been damaged or if random access is desired. Using - -- Full_Flush too often can seriously degrade the compression. - - Finish : constant Flush_Mode; - -- Just for tell the compressor that input data is complete. - - ------------------------------------ - -- Compression strategy constants -- - ------------------------------------ - - -- RLE stategy could be used only in version 1.2.0 and later. - - Filtered : constant Strategy_Type; - Huffman_Only : constant Strategy_Type; - RLE : constant Strategy_Type; - Default_Strategy : constant Strategy_Type; - - Default_Buffer_Size : constant := 4096; - - type Filter_Type is tagged limited private; - -- The filter is for compression and for decompression. - -- The usage of the type is depend of its initialization. - - function Version return String; - pragma Inline (Version); - -- Return string representation of the ZLib version. - - procedure Deflate_Init - (Filter : in out Filter_Type; - Level : in Compression_Level := Default_Compression; - Strategy : in Strategy_Type := Default_Strategy; - Method : in Compression_Method := Deflated; - Window_Bits : in Window_Bits_Type := Default_Window_Bits; - Memory_Level : in Memory_Level_Type := Default_Memory_Level; - Header : in Header_Type := Default); - -- Compressor initialization. - -- When Header parameter is Auto or Default, then default zlib header - -- would be provided for compressed data. - -- When Header is GZip, then gzip header would be set instead of - -- default header. - -- When Header is None, no header would be set for compressed data. - - procedure Inflate_Init - (Filter : in out Filter_Type; - Window_Bits : in Window_Bits_Type := Default_Window_Bits; - Header : in Header_Type := Default); - -- Decompressor initialization. - -- Default header type mean that ZLib default header is expecting in the - -- input compressed stream. - -- Header type None mean that no header is expecting in the input stream. - -- GZip header type mean that GZip header is expecting in the - -- input compressed stream. - -- Auto header type mean that header type (GZip or Native) would be - -- detected automatically in the input stream. - -- Note that header types parameter values None, GZip and Auto are - -- supported for inflate routine only in ZLib versions 1.2.0.2 and later. - -- Deflate_Init is supporting all header types. - - function Is_Open (Filter : in Filter_Type) return Boolean; - pragma Inline (Is_Open); - -- Is the filter opened for compression or decompression. - - procedure Close - (Filter : in out Filter_Type; - Ignore_Error : in Boolean := False); - -- Closing the compression or decompressor. - -- If stream is closing before the complete and Ignore_Error is False, - -- The exception would be raised. - - generic - with procedure Data_In - (Item : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); - with procedure Data_Out - (Item : in Ada.Streams.Stream_Element_Array); - procedure Generic_Translate - (Filter : in out Filter_Type; - In_Buffer_Size : in Integer := Default_Buffer_Size; - Out_Buffer_Size : in Integer := Default_Buffer_Size); - -- Compress/decompress data fetch from Data_In routine and pass the result - -- to the Data_Out routine. User should provide Data_In and Data_Out - -- for compression/decompression data flow. - -- Compression or decompression depend on Filter initialization. - - function Total_In (Filter : in Filter_Type) return Count; - pragma Inline (Total_In); - -- Returns total number of input bytes read so far - - function Total_Out (Filter : in Filter_Type) return Count; - pragma Inline (Total_Out); - -- Returns total number of bytes output so far - - function CRC32 - (CRC : in Unsigned_32; - Data : in Ada.Streams.Stream_Element_Array) - return Unsigned_32; - pragma Inline (CRC32); - -- Compute CRC32, it could be necessary for make gzip format - - procedure CRC32 - (CRC : in out Unsigned_32; - Data : in Ada.Streams.Stream_Element_Array); - pragma Inline (CRC32); - -- Compute CRC32, it could be necessary for make gzip format - - ------------------------------------------------- - -- Below is more complex low level routines. -- - ------------------------------------------------- - - procedure Translate - (Filter : in out Filter_Type; - In_Data : in Ada.Streams.Stream_Element_Array; - In_Last : out Ada.Streams.Stream_Element_Offset; - Out_Data : out Ada.Streams.Stream_Element_Array; - Out_Last : out Ada.Streams.Stream_Element_Offset; - Flush : in Flush_Mode); - -- Compress/decompress the In_Data buffer and place the result into - -- Out_Data. In_Last is the index of last element from In_Data accepted by - -- the Filter. Out_Last is the last element of the received data from - -- Filter. To tell the filter that incoming data are complete put the - -- Flush parameter to Finish. - - function Stream_End (Filter : in Filter_Type) return Boolean; - pragma Inline (Stream_End); - -- Return the true when the stream is complete. - - procedure Flush - (Filter : in out Filter_Type; - Out_Data : out Ada.Streams.Stream_Element_Array; - Out_Last : out Ada.Streams.Stream_Element_Offset; - Flush : in Flush_Mode); - pragma Inline (Flush); - -- Flushing the data from the compressor. - - generic - with procedure Write - (Item : in Ada.Streams.Stream_Element_Array); - -- User should provide this routine for accept - -- compressed/decompressed data. - - Buffer_Size : in Ada.Streams.Stream_Element_Offset - := Default_Buffer_Size; - -- Buffer size for Write user routine. - - procedure Write - (Filter : in out Filter_Type; - Item : in Ada.Streams.Stream_Element_Array; - Flush : in Flush_Mode := No_Flush); - -- Compress/Decompress data from Item to the generic parameter procedure - -- Write. Output buffer size could be set in Buffer_Size generic parameter. - - generic - with procedure Read - (Item : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); - -- User should provide data for compression/decompression - -- thru this routine. - - Buffer : in out Ada.Streams.Stream_Element_Array; - -- Buffer for keep remaining data from the previous - -- back read. - - Rest_First, Rest_Last : in out Ada.Streams.Stream_Element_Offset; - -- Rest_First have to be initialized to Buffer'Last + 1 - -- Rest_Last have to be initialized to Buffer'Last - -- before usage. - - Allow_Read_Some : in Boolean := False; - -- Is it allowed to return Last < Item'Last before end of data. - - procedure Read - (Filter : in out Filter_Type; - Item : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset; - Flush : in Flush_Mode := No_Flush); - -- Compress/Decompress data from generic parameter procedure Read to the - -- Item. User should provide Buffer and initialized Rest_First, Rest_Last - -- indicators. If Allow_Read_Some is True, Read routines could return - -- Last < Item'Last only at end of stream. - -private - - use Ada.Streams; - - pragma Assert (Ada.Streams.Stream_Element'Size = 8); - pragma Assert (Ada.Streams.Stream_Element'Modulus = 2**8); - - type Flush_Mode is new Integer range 0 .. 5; - - type Compression_Method is new Integer range 8 .. 8; - - type Strategy_Type is new Integer range 0 .. 3; - - No_Flush : constant Flush_Mode := 0; - Partial_Flush : constant Flush_Mode := 1; - Sync_Flush : constant Flush_Mode := 2; - Full_Flush : constant Flush_Mode := 3; - Finish : constant Flush_Mode := 4; - Block_Flush : constant Flush_Mode := 5; - - Filtered : constant Strategy_Type := 1; - Huffman_Only : constant Strategy_Type := 2; - RLE : constant Strategy_Type := 3; - Default_Strategy : constant Strategy_Type := 0; - - Deflated : constant Compression_Method := 8; - - type Z_Stream; - - type Z_Stream_Access is access all Z_Stream; - - type Filter_Type is tagged limited record - Strm : Z_Stream_Access; - Compression : Boolean; - Stream_End : Boolean; - Header : Header_Type; - CRC : Unsigned_32; - Offset : Stream_Element_Offset; - -- Offset for gzip header/footer output. - end record; - -end ZLib; DELETED compat/zlib/contrib/ada/zlib.gpr Index: compat/zlib/contrib/ada/zlib.gpr ================================================================== --- compat/zlib/contrib/ada/zlib.gpr +++ /dev/null @@ -1,20 +0,0 @@ -project Zlib is - - for Languages use ("Ada"); - for Source_Dirs use ("."); - for Object_Dir use "."; - for Main use ("test.adb", "mtest.adb", "read.adb", "buffer_demo"); - - package Compiler is - for Default_Switches ("ada") use ("-gnatwcfilopru", "-gnatVcdfimorst", "-gnatyabcefhiklmnoprst"); - end Compiler; - - package Linker is - for Default_Switches ("ada") use ("-lz"); - end Linker; - - package Builder is - for Default_Switches ("ada") use ("-s", "-gnatQ"); - end Builder; - -end Zlib; DELETED compat/zlib/contrib/amd64/amd64-match.S Index: compat/zlib/contrib/amd64/amd64-match.S ================================================================== --- compat/zlib/contrib/amd64/amd64-match.S +++ /dev/null @@ -1,452 +0,0 @@ -/* - * match.S -- optimized version of longest_match() - * based on the similar work by Gilles Vollant, and Brian Raiter, written 1998 - * - * This is free software; you can redistribute it and/or modify it - * under the terms of the BSD License. Use by owners of Che Guevarra - * parafernalia is prohibited, where possible, and highly discouraged - * elsewhere. - */ - -#ifndef NO_UNDERLINE -# define match_init _match_init -# define longest_match _longest_match -#endif - -#define scanend ebx -#define scanendw bx -#define chainlenwmask edx /* high word: current chain len low word: s->wmask */ -#define curmatch rsi -#define curmatchd esi -#define windowbestlen r8 -#define scanalign r9 -#define scanalignd r9d -#define window r10 -#define bestlen r11 -#define bestlend r11d -#define scanstart r12d -#define scanstartw r12w -#define scan r13 -#define nicematch r14d -#define limit r15 -#define limitd r15d -#define prev rcx - -/* - * The 258 is a "magic number, not a parameter -- changing it - * breaks the hell loose - */ -#define MAX_MATCH (258) -#define MIN_MATCH (3) -#define MIN_LOOKAHEAD (MAX_MATCH + MIN_MATCH + 1) -#define MAX_MATCH_8 ((MAX_MATCH + 7) & ~7) - -/* stack frame offsets */ -#define LocalVarsSize (112) -#define _chainlenwmask ( 8-LocalVarsSize)(%rsp) -#define _windowbestlen (16-LocalVarsSize)(%rsp) -#define save_r14 (24-LocalVarsSize)(%rsp) -#define save_rsi (32-LocalVarsSize)(%rsp) -#define save_rbx (40-LocalVarsSize)(%rsp) -#define save_r12 (56-LocalVarsSize)(%rsp) -#define save_r13 (64-LocalVarsSize)(%rsp) -#define save_r15 (80-LocalVarsSize)(%rsp) - - -.globl match_init, longest_match - -/* - * On AMD64 the first argument of a function (in our case -- the pointer to - * deflate_state structure) is passed in %rdi, hence our offsets below are - * all off of that. - */ - -/* you can check the structure offset by running - -#include -#include -#include "deflate.h" - -void print_depl() -{ -deflate_state ds; -deflate_state *s=&ds; -printf("size pointer=%u\n",(int)sizeof(void*)); - -printf("#define dsWSize (%3u)(%%rdi)\n",(int)(((char*)&(s->w_size))-((char*)s))); -printf("#define dsWMask (%3u)(%%rdi)\n",(int)(((char*)&(s->w_mask))-((char*)s))); -printf("#define dsWindow (%3u)(%%rdi)\n",(int)(((char*)&(s->window))-((char*)s))); -printf("#define dsPrev (%3u)(%%rdi)\n",(int)(((char*)&(s->prev))-((char*)s))); -printf("#define dsMatchLen (%3u)(%%rdi)\n",(int)(((char*)&(s->match_length))-((char*)s))); -printf("#define dsPrevMatch (%3u)(%%rdi)\n",(int)(((char*)&(s->prev_match))-((char*)s))); -printf("#define dsStrStart (%3u)(%%rdi)\n",(int)(((char*)&(s->strstart))-((char*)s))); -printf("#define dsMatchStart (%3u)(%%rdi)\n",(int)(((char*)&(s->match_start))-((char*)s))); -printf("#define dsLookahead (%3u)(%%rdi)\n",(int)(((char*)&(s->lookahead))-((char*)s))); -printf("#define dsPrevLen (%3u)(%%rdi)\n",(int)(((char*)&(s->prev_length))-((char*)s))); -printf("#define dsMaxChainLen (%3u)(%%rdi)\n",(int)(((char*)&(s->max_chain_length))-((char*)s))); -printf("#define dsGoodMatch (%3u)(%%rdi)\n",(int)(((char*)&(s->good_match))-((char*)s))); -printf("#define dsNiceMatch (%3u)(%%rdi)\n",(int)(((char*)&(s->nice_match))-((char*)s))); -} - -*/ - - -/* - to compile for XCode 3.2 on MacOSX x86_64 - - run "gcc -g -c -DXCODE_MAC_X64_STRUCTURE amd64-match.S" - */ - - -#ifndef CURRENT_LINX_XCODE_MAC_X64_STRUCTURE -#define dsWSize ( 68)(%rdi) -#define dsWMask ( 76)(%rdi) -#define dsWindow ( 80)(%rdi) -#define dsPrev ( 96)(%rdi) -#define dsMatchLen (144)(%rdi) -#define dsPrevMatch (148)(%rdi) -#define dsStrStart (156)(%rdi) -#define dsMatchStart (160)(%rdi) -#define dsLookahead (164)(%rdi) -#define dsPrevLen (168)(%rdi) -#define dsMaxChainLen (172)(%rdi) -#define dsGoodMatch (188)(%rdi) -#define dsNiceMatch (192)(%rdi) - -#else - -#ifndef STRUCT_OFFSET -# define STRUCT_OFFSET (0) -#endif - - -#define dsWSize ( 56 + STRUCT_OFFSET)(%rdi) -#define dsWMask ( 64 + STRUCT_OFFSET)(%rdi) -#define dsWindow ( 72 + STRUCT_OFFSET)(%rdi) -#define dsPrev ( 88 + STRUCT_OFFSET)(%rdi) -#define dsMatchLen (136 + STRUCT_OFFSET)(%rdi) -#define dsPrevMatch (140 + STRUCT_OFFSET)(%rdi) -#define dsStrStart (148 + STRUCT_OFFSET)(%rdi) -#define dsMatchStart (152 + STRUCT_OFFSET)(%rdi) -#define dsLookahead (156 + STRUCT_OFFSET)(%rdi) -#define dsPrevLen (160 + STRUCT_OFFSET)(%rdi) -#define dsMaxChainLen (164 + STRUCT_OFFSET)(%rdi) -#define dsGoodMatch (180 + STRUCT_OFFSET)(%rdi) -#define dsNiceMatch (184 + STRUCT_OFFSET)(%rdi) - -#endif - - - - -.text - -/* uInt longest_match(deflate_state *deflatestate, IPos curmatch) */ - -longest_match: -/* - * Retrieve the function arguments. %curmatch will hold cur_match - * throughout the entire function (passed via rsi on amd64). - * rdi will hold the pointer to the deflate_state (first arg on amd64) - */ - mov %rsi, save_rsi - mov %rbx, save_rbx - mov %r12, save_r12 - mov %r13, save_r13 - mov %r14, save_r14 - mov %r15, save_r15 - -/* uInt wmask = s->w_mask; */ -/* unsigned chain_length = s->max_chain_length; */ -/* if (s->prev_length >= s->good_match) { */ -/* chain_length >>= 2; */ -/* } */ - - movl dsPrevLen, %eax - movl dsGoodMatch, %ebx - cmpl %ebx, %eax - movl dsWMask, %eax - movl dsMaxChainLen, %chainlenwmask - jl LastMatchGood - shrl $2, %chainlenwmask -LastMatchGood: - -/* chainlen is decremented once beforehand so that the function can */ -/* use the sign flag instead of the zero flag for the exit test. */ -/* It is then shifted into the high word, to make room for the wmask */ -/* value, which it will always accompany. */ - - decl %chainlenwmask - shll $16, %chainlenwmask - orl %eax, %chainlenwmask - -/* if ((uInt)nice_match > s->lookahead) nice_match = s->lookahead; */ - - movl dsNiceMatch, %eax - movl dsLookahead, %ebx - cmpl %eax, %ebx - jl LookaheadLess - movl %eax, %ebx -LookaheadLess: movl %ebx, %nicematch - -/* register Bytef *scan = s->window + s->strstart; */ - - mov dsWindow, %window - movl dsStrStart, %limitd - lea (%limit, %window), %scan - -/* Determine how many bytes the scan ptr is off from being */ -/* dword-aligned. */ - - mov %scan, %scanalign - negl %scanalignd - andl $3, %scanalignd - -/* IPos limit = s->strstart > (IPos)MAX_DIST(s) ? */ -/* s->strstart - (IPos)MAX_DIST(s) : NIL; */ - - movl dsWSize, %eax - subl $MIN_LOOKAHEAD, %eax - xorl %ecx, %ecx - subl %eax, %limitd - cmovng %ecx, %limitd - -/* int best_len = s->prev_length; */ - - movl dsPrevLen, %bestlend - -/* Store the sum of s->window + best_len in %windowbestlen locally, and in memory. */ - - lea (%window, %bestlen), %windowbestlen - mov %windowbestlen, _windowbestlen - -/* register ush scan_start = *(ushf*)scan; */ -/* register ush scan_end = *(ushf*)(scan+best_len-1); */ -/* Posf *prev = s->prev; */ - - movzwl (%scan), %scanstart - movzwl -1(%scan, %bestlen), %scanend - mov dsPrev, %prev - -/* Jump into the main loop. */ - - movl %chainlenwmask, _chainlenwmask - jmp LoopEntry - -.balign 16 - -/* do { - * match = s->window + cur_match; - * if (*(ushf*)(match+best_len-1) != scan_end || - * *(ushf*)match != scan_start) continue; - * [...] - * } while ((cur_match = prev[cur_match & wmask]) > limit - * && --chain_length != 0); - * - * Here is the inner loop of the function. The function will spend the - * majority of its time in this loop, and majority of that time will - * be spent in the first ten instructions. - */ -LookupLoop: - andl %chainlenwmask, %curmatchd - movzwl (%prev, %curmatch, 2), %curmatchd - cmpl %limitd, %curmatchd - jbe LeaveNow - subl $0x00010000, %chainlenwmask - js LeaveNow -LoopEntry: cmpw -1(%windowbestlen, %curmatch), %scanendw - jne LookupLoop - cmpw %scanstartw, (%window, %curmatch) - jne LookupLoop - -/* Store the current value of chainlen. */ - movl %chainlenwmask, _chainlenwmask - -/* %scan is the string under scrutiny, and %prev to the string we */ -/* are hoping to match it up with. In actuality, %esi and %edi are */ -/* both pointed (MAX_MATCH_8 - scanalign) bytes ahead, and %edx is */ -/* initialized to -(MAX_MATCH_8 - scanalign). */ - - mov $(-MAX_MATCH_8), %rdx - lea (%curmatch, %window), %windowbestlen - lea MAX_MATCH_8(%windowbestlen, %scanalign), %windowbestlen - lea MAX_MATCH_8(%scan, %scanalign), %prev - -/* the prefetching below makes very little difference... */ - prefetcht1 (%windowbestlen, %rdx) - prefetcht1 (%prev, %rdx) - -/* - * Test the strings for equality, 8 bytes at a time. At the end, - * adjust %rdx so that it is offset to the exact byte that mismatched. - * - * It should be confessed that this loop usually does not represent - * much of the total running time. Replacing it with a more - * straightforward "rep cmpsb" would not drastically degrade - * performance -- unrolling it, for example, makes no difference. - */ - -#undef USE_SSE /* works, but is 6-7% slower, than non-SSE... */ - -LoopCmps: -#ifdef USE_SSE - /* Preload the SSE registers */ - movdqu (%windowbestlen, %rdx), %xmm1 - movdqu (%prev, %rdx), %xmm2 - pcmpeqb %xmm2, %xmm1 - movdqu 16(%windowbestlen, %rdx), %xmm3 - movdqu 16(%prev, %rdx), %xmm4 - pcmpeqb %xmm4, %xmm3 - movdqu 32(%windowbestlen, %rdx), %xmm5 - movdqu 32(%prev, %rdx), %xmm6 - pcmpeqb %xmm6, %xmm5 - movdqu 48(%windowbestlen, %rdx), %xmm7 - movdqu 48(%prev, %rdx), %xmm8 - pcmpeqb %xmm8, %xmm7 - - /* Check the comparisions' results */ - pmovmskb %xmm1, %rax - notw %ax - bsfw %ax, %ax - jnz LeaveLoopCmps - - /* this is the only iteration of the loop with a possibility of having - incremented rdx by 0x108 (each loop iteration add 16*4 = 0x40 - and (0x40*4)+8=0x108 */ - add $8, %rdx - jz LenMaximum - add $8, %rdx - - - pmovmskb %xmm3, %rax - notw %ax - bsfw %ax, %ax - jnz LeaveLoopCmps - - - add $16, %rdx - - - pmovmskb %xmm5, %rax - notw %ax - bsfw %ax, %ax - jnz LeaveLoopCmps - - add $16, %rdx - - - pmovmskb %xmm7, %rax - notw %ax - bsfw %ax, %ax - jnz LeaveLoopCmps - - add $16, %rdx - - jmp LoopCmps -LeaveLoopCmps: add %rax, %rdx -#else - mov (%windowbestlen, %rdx), %rax - xor (%prev, %rdx), %rax - jnz LeaveLoopCmps - - mov 8(%windowbestlen, %rdx), %rax - xor 8(%prev, %rdx), %rax - jnz LeaveLoopCmps8 - - mov 16(%windowbestlen, %rdx), %rax - xor 16(%prev, %rdx), %rax - jnz LeaveLoopCmps16 - - add $24, %rdx - jnz LoopCmps - jmp LenMaximum -# if 0 -/* - * This three-liner is tantalizingly simple, but bsf is a slow instruction, - * and the complicated alternative down below is quite a bit faster. Sad... - */ - -LeaveLoopCmps: bsf %rax, %rax /* find the first non-zero bit */ - shrl $3, %eax /* divide by 8 to get the byte */ - add %rax, %rdx -# else -LeaveLoopCmps16: - add $8, %rdx -LeaveLoopCmps8: - add $8, %rdx -LeaveLoopCmps: testl $0xFFFFFFFF, %eax /* Check the first 4 bytes */ - jnz Check16 - add $4, %rdx - shr $32, %rax -Check16: testw $0xFFFF, %ax - jnz LenLower - add $2, %rdx - shrl $16, %eax -LenLower: subb $1, %al - adc $0, %rdx -# endif -#endif - -/* Calculate the length of the match. If it is longer than MAX_MATCH, */ -/* then automatically accept it as the best possible match and leave. */ - - lea (%prev, %rdx), %rax - sub %scan, %rax - cmpl $MAX_MATCH, %eax - jge LenMaximum - -/* If the length of the match is not longer than the best match we */ -/* have so far, then forget it and return to the lookup loop. */ - - cmpl %bestlend, %eax - jg LongerMatch - mov _windowbestlen, %windowbestlen - mov dsPrev, %prev - movl _chainlenwmask, %edx - jmp LookupLoop - -/* s->match_start = cur_match; */ -/* best_len = len; */ -/* if (len >= nice_match) break; */ -/* scan_end = *(ushf*)(scan+best_len-1); */ - -LongerMatch: - movl %eax, %bestlend - movl %curmatchd, dsMatchStart - cmpl %nicematch, %eax - jge LeaveNow - - lea (%window, %bestlen), %windowbestlen - mov %windowbestlen, _windowbestlen - - movzwl -1(%scan, %rax), %scanend - mov dsPrev, %prev - movl _chainlenwmask, %chainlenwmask - jmp LookupLoop - -/* Accept the current string, with the maximum possible length. */ - -LenMaximum: - movl $MAX_MATCH, %bestlend - movl %curmatchd, dsMatchStart - -/* if ((uInt)best_len <= s->lookahead) return (uInt)best_len; */ -/* return s->lookahead; */ - -LeaveNow: - movl dsLookahead, %eax - cmpl %eax, %bestlend - cmovngl %bestlend, %eax -LookaheadRet: - -/* Restore the registers and return from whence we came. */ - - mov save_rsi, %rsi - mov save_rbx, %rbx - mov save_r12, %r12 - mov save_r13, %r13 - mov save_r14, %r14 - mov save_r15, %r15 - - ret - -match_init: ret DELETED compat/zlib/contrib/asm686/README.686 Index: compat/zlib/contrib/asm686/README.686 ================================================================== --- compat/zlib/contrib/asm686/README.686 +++ /dev/null @@ -1,51 +0,0 @@ -This is a patched version of zlib, modified to use -Pentium-Pro-optimized assembly code in the deflation algorithm. The -files changed/added by this patch are: - -README.686 -match.S - -The speedup that this patch provides varies, depending on whether the -compiler used to build the original version of zlib falls afoul of the -PPro's speed traps. My own tests show a speedup of around 10-20% at -the default compression level, and 20-30% using -9, against a version -compiled using gcc 2.7.2.3. Your mileage may vary. - -Note that this code has been tailored for the PPro/PII in particular, -and will not perform particuarly well on a Pentium. - -If you are using an assembler other than GNU as, you will have to -translate match.S to use your assembler's syntax. (Have fun.) - -Brian Raiter -breadbox@muppetlabs.com -April, 1998 - - -Added for zlib 1.1.3: - -The patches come from -http://www.muppetlabs.com/~breadbox/software/assembly.html - -To compile zlib with this asm file, copy match.S to the zlib directory -then do: - -CFLAGS="-O3 -DASMV" ./configure -make OBJA=match.o - - -Update: - -I've been ignoring these assembly routines for years, believing that -gcc's generated code had caught up with it sometime around gcc 2.95 -and the major rearchitecting of the Pentium 4. However, I recently -learned that, despite what I believed, this code still has some life -in it. On the Pentium 4 and AMD64 chips, it continues to run about 8% -faster than the code produced by gcc 4.1. - -In acknowledgement of its continuing usefulness, I've altered the -license to match that of the rest of zlib. Share and Enjoy! - -Brian Raiter -breadbox@muppetlabs.com -April, 2007 DELETED compat/zlib/contrib/asm686/match.S Index: compat/zlib/contrib/asm686/match.S ================================================================== --- compat/zlib/contrib/asm686/match.S +++ /dev/null @@ -1,357 +0,0 @@ -/* match.S -- x86 assembly version of the zlib longest_match() function. - * Optimized for the Intel 686 chips (PPro and later). - * - * Copyright (C) 1998, 2007 Brian Raiter - * - * This software is provided 'as-is', without any express or implied - * warranty. In no event will the author be held liable for any damages - * arising from the use of this software. - * - * Permission is granted to anyone to use this software for any purpose, - * including commercial applications, and to alter it and redistribute it - * freely, subject to the following restrictions: - * - * 1. The origin of this software must not be misrepresented; you must not - * claim that you wrote the original software. If you use this software - * in a product, an acknowledgment in the product documentation would be - * appreciated but is not required. - * 2. Altered source versions must be plainly marked as such, and must not be - * misrepresented as being the original software. - * 3. This notice may not be removed or altered from any source distribution. - */ - -#ifndef NO_UNDERLINE -#define match_init _match_init -#define longest_match _longest_match -#endif - -#define MAX_MATCH (258) -#define MIN_MATCH (3) -#define MIN_LOOKAHEAD (MAX_MATCH + MIN_MATCH + 1) -#define MAX_MATCH_8 ((MAX_MATCH + 7) & ~7) - -/* stack frame offsets */ - -#define chainlenwmask 0 /* high word: current chain len */ - /* low word: s->wmask */ -#define window 4 /* local copy of s->window */ -#define windowbestlen 8 /* s->window + bestlen */ -#define scanstart 16 /* first two bytes of string */ -#define scanend 12 /* last two bytes of string */ -#define scanalign 20 /* dword-misalignment of string */ -#define nicematch 24 /* a good enough match size */ -#define bestlen 28 /* size of best match so far */ -#define scan 32 /* ptr to string wanting match */ - -#define LocalVarsSize (36) -/* saved ebx 36 */ -/* saved edi 40 */ -/* saved esi 44 */ -/* saved ebp 48 */ -/* return address 52 */ -#define deflatestate 56 /* the function arguments */ -#define curmatch 60 - -/* All the +zlib1222add offsets are due to the addition of fields - * in zlib in the deflate_state structure since the asm code was first written - * (if you compile with zlib 1.0.4 or older, use "zlib1222add equ (-4)"). - * (if you compile with zlib between 1.0.5 and 1.2.2.1, use "zlib1222add equ 0"). - * if you compile with zlib 1.2.2.2 or later , use "zlib1222add equ 8"). - */ - -#define zlib1222add (8) - -#define dsWSize (36+zlib1222add) -#define dsWMask (44+zlib1222add) -#define dsWindow (48+zlib1222add) -#define dsPrev (56+zlib1222add) -#define dsMatchLen (88+zlib1222add) -#define dsPrevMatch (92+zlib1222add) -#define dsStrStart (100+zlib1222add) -#define dsMatchStart (104+zlib1222add) -#define dsLookahead (108+zlib1222add) -#define dsPrevLen (112+zlib1222add) -#define dsMaxChainLen (116+zlib1222add) -#define dsGoodMatch (132+zlib1222add) -#define dsNiceMatch (136+zlib1222add) - - -.file "match.S" - -.globl match_init, longest_match - -.text - -/* uInt longest_match(deflate_state *deflatestate, IPos curmatch) */ -.cfi_sections .debug_frame - -longest_match: - -.cfi_startproc -/* Save registers that the compiler may be using, and adjust %esp to */ -/* make room for our stack frame. */ - - pushl %ebp - .cfi_def_cfa_offset 8 - .cfi_offset ebp, -8 - pushl %edi - .cfi_def_cfa_offset 12 - pushl %esi - .cfi_def_cfa_offset 16 - pushl %ebx - .cfi_def_cfa_offset 20 - subl $LocalVarsSize, %esp - .cfi_def_cfa_offset LocalVarsSize+20 - -/* Retrieve the function arguments. %ecx will hold cur_match */ -/* throughout the entire function. %edx will hold the pointer to the */ -/* deflate_state structure during the function's setup (before */ -/* entering the main loop). */ - - movl deflatestate(%esp), %edx - movl curmatch(%esp), %ecx - -/* uInt wmask = s->w_mask; */ -/* unsigned chain_length = s->max_chain_length; */ -/* if (s->prev_length >= s->good_match) { */ -/* chain_length >>= 2; */ -/* } */ - - movl dsPrevLen(%edx), %eax - movl dsGoodMatch(%edx), %ebx - cmpl %ebx, %eax - movl dsWMask(%edx), %eax - movl dsMaxChainLen(%edx), %ebx - jl LastMatchGood - shrl $2, %ebx -LastMatchGood: - -/* chainlen is decremented once beforehand so that the function can */ -/* use the sign flag instead of the zero flag for the exit test. */ -/* It is then shifted into the high word, to make room for the wmask */ -/* value, which it will always accompany. */ - - decl %ebx - shll $16, %ebx - orl %eax, %ebx - movl %ebx, chainlenwmask(%esp) - -/* if ((uInt)nice_match > s->lookahead) nice_match = s->lookahead; */ - - movl dsNiceMatch(%edx), %eax - movl dsLookahead(%edx), %ebx - cmpl %eax, %ebx - jl LookaheadLess - movl %eax, %ebx -LookaheadLess: movl %ebx, nicematch(%esp) - -/* register Bytef *scan = s->window + s->strstart; */ - - movl dsWindow(%edx), %esi - movl %esi, window(%esp) - movl dsStrStart(%edx), %ebp - lea (%esi,%ebp), %edi - movl %edi, scan(%esp) - -/* Determine how many bytes the scan ptr is off from being */ -/* dword-aligned. */ - - movl %edi, %eax - negl %eax - andl $3, %eax - movl %eax, scanalign(%esp) - -/* IPos limit = s->strstart > (IPos)MAX_DIST(s) ? */ -/* s->strstart - (IPos)MAX_DIST(s) : NIL; */ - - movl dsWSize(%edx), %eax - subl $MIN_LOOKAHEAD, %eax - subl %eax, %ebp - jg LimitPositive - xorl %ebp, %ebp -LimitPositive: - -/* int best_len = s->prev_length; */ - - movl dsPrevLen(%edx), %eax - movl %eax, bestlen(%esp) - -/* Store the sum of s->window + best_len in %esi locally, and in %esi. */ - - addl %eax, %esi - movl %esi, windowbestlen(%esp) - -/* register ush scan_start = *(ushf*)scan; */ -/* register ush scan_end = *(ushf*)(scan+best_len-1); */ -/* Posf *prev = s->prev; */ - - movzwl (%edi), %ebx - movl %ebx, scanstart(%esp) - movzwl -1(%edi,%eax), %ebx - movl %ebx, scanend(%esp) - movl dsPrev(%edx), %edi - -/* Jump into the main loop. */ - - movl chainlenwmask(%esp), %edx - jmp LoopEntry - -.balign 16 - -/* do { - * match = s->window + cur_match; - * if (*(ushf*)(match+best_len-1) != scan_end || - * *(ushf*)match != scan_start) continue; - * [...] - * } while ((cur_match = prev[cur_match & wmask]) > limit - * && --chain_length != 0); - * - * Here is the inner loop of the function. The function will spend the - * majority of its time in this loop, and majority of that time will - * be spent in the first ten instructions. - * - * Within this loop: - * %ebx = scanend - * %ecx = curmatch - * %edx = chainlenwmask - i.e., ((chainlen << 16) | wmask) - * %esi = windowbestlen - i.e., (window + bestlen) - * %edi = prev - * %ebp = limit - */ -LookupLoop: - andl %edx, %ecx - movzwl (%edi,%ecx,2), %ecx - cmpl %ebp, %ecx - jbe LeaveNow - subl $0x00010000, %edx - js LeaveNow -LoopEntry: movzwl -1(%esi,%ecx), %eax - cmpl %ebx, %eax - jnz LookupLoop - movl window(%esp), %eax - movzwl (%eax,%ecx), %eax - cmpl scanstart(%esp), %eax - jnz LookupLoop - -/* Store the current value of chainlen. */ - - movl %edx, chainlenwmask(%esp) - -/* Point %edi to the string under scrutiny, and %esi to the string we */ -/* are hoping to match it up with. In actuality, %esi and %edi are */ -/* both pointed (MAX_MATCH_8 - scanalign) bytes ahead, and %edx is */ -/* initialized to -(MAX_MATCH_8 - scanalign). */ - - movl window(%esp), %esi - movl scan(%esp), %edi - addl %ecx, %esi - movl scanalign(%esp), %eax - movl $(-MAX_MATCH_8), %edx - lea MAX_MATCH_8(%edi,%eax), %edi - lea MAX_MATCH_8(%esi,%eax), %esi - -/* Test the strings for equality, 8 bytes at a time. At the end, - * adjust %edx so that it is offset to the exact byte that mismatched. - * - * We already know at this point that the first three bytes of the - * strings match each other, and they can be safely passed over before - * starting the compare loop. So what this code does is skip over 0-3 - * bytes, as much as necessary in order to dword-align the %edi - * pointer. (%esi will still be misaligned three times out of four.) - * - * It should be confessed that this loop usually does not represent - * much of the total running time. Replacing it with a more - * straightforward "rep cmpsb" would not drastically degrade - * performance. - */ -LoopCmps: - movl (%esi,%edx), %eax - xorl (%edi,%edx), %eax - jnz LeaveLoopCmps - movl 4(%esi,%edx), %eax - xorl 4(%edi,%edx), %eax - jnz LeaveLoopCmps4 - addl $8, %edx - jnz LoopCmps - jmp LenMaximum -LeaveLoopCmps4: addl $4, %edx -LeaveLoopCmps: testl $0x0000FFFF, %eax - jnz LenLower - addl $2, %edx - shrl $16, %eax -LenLower: subb $1, %al - adcl $0, %edx - -/* Calculate the length of the match. If it is longer than MAX_MATCH, */ -/* then automatically accept it as the best possible match and leave. */ - - lea (%edi,%edx), %eax - movl scan(%esp), %edi - subl %edi, %eax - cmpl $MAX_MATCH, %eax - jge LenMaximum - -/* If the length of the match is not longer than the best match we */ -/* have so far, then forget it and return to the lookup loop. */ - - movl deflatestate(%esp), %edx - movl bestlen(%esp), %ebx - cmpl %ebx, %eax - jg LongerMatch - movl windowbestlen(%esp), %esi - movl dsPrev(%edx), %edi - movl scanend(%esp), %ebx - movl chainlenwmask(%esp), %edx - jmp LookupLoop - -/* s->match_start = cur_match; */ -/* best_len = len; */ -/* if (len >= nice_match) break; */ -/* scan_end = *(ushf*)(scan+best_len-1); */ - -LongerMatch: movl nicematch(%esp), %ebx - movl %eax, bestlen(%esp) - movl %ecx, dsMatchStart(%edx) - cmpl %ebx, %eax - jge LeaveNow - movl window(%esp), %esi - addl %eax, %esi - movl %esi, windowbestlen(%esp) - movzwl -1(%edi,%eax), %ebx - movl dsPrev(%edx), %edi - movl %ebx, scanend(%esp) - movl chainlenwmask(%esp), %edx - jmp LookupLoop - -/* Accept the current string, with the maximum possible length. */ - -LenMaximum: movl deflatestate(%esp), %edx - movl $MAX_MATCH, bestlen(%esp) - movl %ecx, dsMatchStart(%edx) - -/* if ((uInt)best_len <= s->lookahead) return (uInt)best_len; */ -/* return s->lookahead; */ - -LeaveNow: - movl deflatestate(%esp), %edx - movl bestlen(%esp), %ebx - movl dsLookahead(%edx), %eax - cmpl %eax, %ebx - jg LookaheadRet - movl %ebx, %eax -LookaheadRet: - -/* Restore the stack and return from whence we came. */ - - addl $LocalVarsSize, %esp - .cfi_def_cfa_offset 20 - popl %ebx - .cfi_def_cfa_offset 16 - popl %esi - .cfi_def_cfa_offset 12 - popl %edi - .cfi_def_cfa_offset 8 - popl %ebp - .cfi_def_cfa_offset 4 -.cfi_endproc -match_init: ret DELETED compat/zlib/contrib/blast/Makefile Index: compat/zlib/contrib/blast/Makefile ================================================================== --- compat/zlib/contrib/blast/Makefile +++ /dev/null @@ -1,8 +0,0 @@ -blast: blast.c blast.h - cc -DTEST -o blast blast.c - -test: blast - blast < test.pk | cmp - test.txt - -clean: - rm -f blast blast.o DELETED compat/zlib/contrib/blast/README Index: compat/zlib/contrib/blast/README ================================================================== --- compat/zlib/contrib/blast/README +++ /dev/null @@ -1,4 +0,0 @@ -Read blast.h for purpose and usage. - -Mark Adler -madler@alumni.caltech.edu DELETED compat/zlib/contrib/blast/blast.c Index: compat/zlib/contrib/blast/blast.c ================================================================== --- compat/zlib/contrib/blast/blast.c +++ /dev/null @@ -1,466 +0,0 @@ -/* blast.c - * Copyright (C) 2003, 2012, 2013 Mark Adler - * For conditions of distribution and use, see copyright notice in blast.h - * version 1.3, 24 Aug 2013 - * - * blast.c decompresses data compressed by the PKWare Compression Library. - * This function provides functionality similar to the explode() function of - * the PKWare library, hence the name "blast". - * - * This decompressor is based on the excellent format description provided by - * Ben Rudiak-Gould in comp.compression on August 13, 2001. Interestingly, the - * example Ben provided in the post is incorrect. The distance 110001 should - * instead be 111000. When corrected, the example byte stream becomes: - * - * 00 04 82 24 25 8f 80 7f - * - * which decompresses to "AIAIAIAIAIAIA" (without the quotes). - */ - -/* - * Change history: - * - * 1.0 12 Feb 2003 - First version - * 1.1 16 Feb 2003 - Fixed distance check for > 4 GB uncompressed data - * 1.2 24 Oct 2012 - Add note about using binary mode in stdio - * - Fix comparisons of differently signed integers - * 1.3 24 Aug 2013 - Return unused input from blast() - * - Fix test code to correctly report unused input - * - Enable the provision of initial input to blast() - */ - -#include /* for NULL */ -#include /* for setjmp(), longjmp(), and jmp_buf */ -#include "blast.h" /* prototype for blast() */ - -#define local static /* for local function definitions */ -#define MAXBITS 13 /* maximum code length */ -#define MAXWIN 4096 /* maximum window size */ - -/* input and output state */ -struct state { - /* input state */ - blast_in infun; /* input function provided by user */ - void *inhow; /* opaque information passed to infun() */ - unsigned char *in; /* next input location */ - unsigned left; /* available input at in */ - int bitbuf; /* bit buffer */ - int bitcnt; /* number of bits in bit buffer */ - - /* input limit error return state for bits() and decode() */ - jmp_buf env; - - /* output state */ - blast_out outfun; /* output function provided by user */ - void *outhow; /* opaque information passed to outfun() */ - unsigned next; /* index of next write location in out[] */ - int first; /* true to check distances (for first 4K) */ - unsigned char out[MAXWIN]; /* output buffer and sliding window */ -}; - -/* - * Return need bits from the input stream. This always leaves less than - * eight bits in the buffer. bits() works properly for need == 0. - * - * Format notes: - * - * - Bits are stored in bytes from the least significant bit to the most - * significant bit. Therefore bits are dropped from the bottom of the bit - * buffer, using shift right, and new bytes are appended to the top of the - * bit buffer, using shift left. - */ -local int bits(struct state *s, int need) -{ - int val; /* bit accumulator */ - - /* load at least need bits into val */ - val = s->bitbuf; - while (s->bitcnt < need) { - if (s->left == 0) { - s->left = s->infun(s->inhow, &(s->in)); - if (s->left == 0) longjmp(s->env, 1); /* out of input */ - } - val |= (int)(*(s->in)++) << s->bitcnt; /* load eight bits */ - s->left--; - s->bitcnt += 8; - } - - /* drop need bits and update buffer, always zero to seven bits left */ - s->bitbuf = val >> need; - s->bitcnt -= need; - - /* return need bits, zeroing the bits above that */ - return val & ((1 << need) - 1); -} - -/* - * Huffman code decoding tables. count[1..MAXBITS] is the number of symbols of - * each length, which for a canonical code are stepped through in order. - * symbol[] are the symbol values in canonical order, where the number of - * entries is the sum of the counts in count[]. The decoding process can be - * seen in the function decode() below. - */ -struct huffman { - short *count; /* number of symbols of each length */ - short *symbol; /* canonically ordered symbols */ -}; - -/* - * Decode a code from the stream s using huffman table h. Return the symbol or - * a negative value if there is an error. If all of the lengths are zero, i.e. - * an empty code, or if the code is incomplete and an invalid code is received, - * then -9 is returned after reading MAXBITS bits. - * - * Format notes: - * - * - The codes as stored in the compressed data are bit-reversed relative to - * a simple integer ordering of codes of the same lengths. Hence below the - * bits are pulled from the compressed data one at a time and used to - * build the code value reversed from what is in the stream in order to - * permit simple integer comparisons for decoding. - * - * - The first code for the shortest length is all ones. Subsequent codes of - * the same length are simply integer decrements of the previous code. When - * moving up a length, a one bit is appended to the code. For a complete - * code, the last code of the longest length will be all zeros. To support - * this ordering, the bits pulled during decoding are inverted to apply the - * more "natural" ordering starting with all zeros and incrementing. - */ -local int decode(struct state *s, struct huffman *h) -{ - int len; /* current number of bits in code */ - int code; /* len bits being decoded */ - int first; /* first code of length len */ - int count; /* number of codes of length len */ - int index; /* index of first code of length len in symbol table */ - int bitbuf; /* bits from stream */ - int left; /* bits left in next or left to process */ - short *next; /* next number of codes */ - - bitbuf = s->bitbuf; - left = s->bitcnt; - code = first = index = 0; - len = 1; - next = h->count + 1; - while (1) { - while (left--) { - code |= (bitbuf & 1) ^ 1; /* invert code */ - bitbuf >>= 1; - count = *next++; - if (code < first + count) { /* if length len, return symbol */ - s->bitbuf = bitbuf; - s->bitcnt = (s->bitcnt - len) & 7; - return h->symbol[index + (code - first)]; - } - index += count; /* else update for next length */ - first += count; - first <<= 1; - code <<= 1; - len++; - } - left = (MAXBITS+1) - len; - if (left == 0) break; - if (s->left == 0) { - s->left = s->infun(s->inhow, &(s->in)); - if (s->left == 0) longjmp(s->env, 1); /* out of input */ - } - bitbuf = *(s->in)++; - s->left--; - if (left > 8) left = 8; - } - return -9; /* ran out of codes */ -} - -/* - * Given a list of repeated code lengths rep[0..n-1], where each byte is a - * count (high four bits + 1) and a code length (low four bits), generate the - * list of code lengths. This compaction reduces the size of the object code. - * Then given the list of code lengths length[0..n-1] representing a canonical - * Huffman code for n symbols, construct the tables required to decode those - * codes. Those tables are the number of codes of each length, and the symbols - * sorted by length, retaining their original order within each length. The - * return value is zero for a complete code set, negative for an over- - * subscribed code set, and positive for an incomplete code set. The tables - * can be used if the return value is zero or positive, but they cannot be used - * if the return value is negative. If the return value is zero, it is not - * possible for decode() using that table to return an error--any stream of - * enough bits will resolve to a symbol. If the return value is positive, then - * it is possible for decode() using that table to return an error for received - * codes past the end of the incomplete lengths. - */ -local int construct(struct huffman *h, const unsigned char *rep, int n) -{ - int symbol; /* current symbol when stepping through length[] */ - int len; /* current length when stepping through h->count[] */ - int left; /* number of possible codes left of current length */ - short offs[MAXBITS+1]; /* offsets in symbol table for each length */ - short length[256]; /* code lengths */ - - /* convert compact repeat counts into symbol bit length list */ - symbol = 0; - do { - len = *rep++; - left = (len >> 4) + 1; - len &= 15; - do { - length[symbol++] = len; - } while (--left); - } while (--n); - n = symbol; - - /* count number of codes of each length */ - for (len = 0; len <= MAXBITS; len++) - h->count[len] = 0; - for (symbol = 0; symbol < n; symbol++) - (h->count[length[symbol]])++; /* assumes lengths are within bounds */ - if (h->count[0] == n) /* no codes! */ - return 0; /* complete, but decode() will fail */ - - /* check for an over-subscribed or incomplete set of lengths */ - left = 1; /* one possible code of zero length */ - for (len = 1; len <= MAXBITS; len++) { - left <<= 1; /* one more bit, double codes left */ - left -= h->count[len]; /* deduct count from possible codes */ - if (left < 0) return left; /* over-subscribed--return negative */ - } /* left > 0 means incomplete */ - - /* generate offsets into symbol table for each length for sorting */ - offs[1] = 0; - for (len = 1; len < MAXBITS; len++) - offs[len + 1] = offs[len] + h->count[len]; - - /* - * put symbols in table sorted by length, by symbol order within each - * length - */ - for (symbol = 0; symbol < n; symbol++) - if (length[symbol] != 0) - h->symbol[offs[length[symbol]]++] = symbol; - - /* return zero for complete set, positive for incomplete set */ - return left; -} - -/* - * Decode PKWare Compression Library stream. - * - * Format notes: - * - * - First byte is 0 if literals are uncoded or 1 if they are coded. Second - * byte is 4, 5, or 6 for the number of extra bits in the distance code. - * This is the base-2 logarithm of the dictionary size minus six. - * - * - Compressed data is a combination of literals and length/distance pairs - * terminated by an end code. Literals are either Huffman coded or - * uncoded bytes. A length/distance pair is a coded length followed by a - * coded distance to represent a string that occurs earlier in the - * uncompressed data that occurs again at the current location. - * - * - A bit preceding a literal or length/distance pair indicates which comes - * next, 0 for literals, 1 for length/distance. - * - * - If literals are uncoded, then the next eight bits are the literal, in the - * normal bit order in the stream, i.e. no bit-reversal is needed. Similarly, - * no bit reversal is needed for either the length extra bits or the distance - * extra bits. - * - * - Literal bytes are simply written to the output. A length/distance pair is - * an instruction to copy previously uncompressed bytes to the output. The - * copy is from distance bytes back in the output stream, copying for length - * bytes. - * - * - Distances pointing before the beginning of the output data are not - * permitted. - * - * - Overlapped copies, where the length is greater than the distance, are - * allowed and common. For example, a distance of one and a length of 518 - * simply copies the last byte 518 times. A distance of four and a length of - * twelve copies the last four bytes three times. A simple forward copy - * ignoring whether the length is greater than the distance or not implements - * this correctly. - */ -local int decomp(struct state *s) -{ - int lit; /* true if literals are coded */ - int dict; /* log2(dictionary size) - 6 */ - int symbol; /* decoded symbol, extra bits for distance */ - int len; /* length for copy */ - unsigned dist; /* distance for copy */ - int copy; /* copy counter */ - unsigned char *from, *to; /* copy pointers */ - static int virgin = 1; /* build tables once */ - static short litcnt[MAXBITS+1], litsym[256]; /* litcode memory */ - static short lencnt[MAXBITS+1], lensym[16]; /* lencode memory */ - static short distcnt[MAXBITS+1], distsym[64]; /* distcode memory */ - static struct huffman litcode = {litcnt, litsym}; /* length code */ - static struct huffman lencode = {lencnt, lensym}; /* length code */ - static struct huffman distcode = {distcnt, distsym};/* distance code */ - /* bit lengths of literal codes */ - static const unsigned char litlen[] = { - 11, 124, 8, 7, 28, 7, 188, 13, 76, 4, 10, 8, 12, 10, 12, 10, 8, 23, 8, - 9, 7, 6, 7, 8, 7, 6, 55, 8, 23, 24, 12, 11, 7, 9, 11, 12, 6, 7, 22, 5, - 7, 24, 6, 11, 9, 6, 7, 22, 7, 11, 38, 7, 9, 8, 25, 11, 8, 11, 9, 12, - 8, 12, 5, 38, 5, 38, 5, 11, 7, 5, 6, 21, 6, 10, 53, 8, 7, 24, 10, 27, - 44, 253, 253, 253, 252, 252, 252, 13, 12, 45, 12, 45, 12, 61, 12, 45, - 44, 173}; - /* bit lengths of length codes 0..15 */ - static const unsigned char lenlen[] = {2, 35, 36, 53, 38, 23}; - /* bit lengths of distance codes 0..63 */ - static const unsigned char distlen[] = {2, 20, 53, 230, 247, 151, 248}; - static const short base[16] = { /* base for length codes */ - 3, 2, 4, 5, 6, 7, 8, 9, 10, 12, 16, 24, 40, 72, 136, 264}; - static const char extra[16] = { /* extra bits for length codes */ - 0, 0, 0, 0, 0, 0, 0, 0, 1, 2, 3, 4, 5, 6, 7, 8}; - - /* set up decoding tables (once--might not be thread-safe) */ - if (virgin) { - construct(&litcode, litlen, sizeof(litlen)); - construct(&lencode, lenlen, sizeof(lenlen)); - construct(&distcode, distlen, sizeof(distlen)); - virgin = 0; - } - - /* read header */ - lit = bits(s, 8); - if (lit > 1) return -1; - dict = bits(s, 8); - if (dict < 4 || dict > 6) return -2; - - /* decode literals and length/distance pairs */ - do { - if (bits(s, 1)) { - /* get length */ - symbol = decode(s, &lencode); - len = base[symbol] + bits(s, extra[symbol]); - if (len == 519) break; /* end code */ - - /* get distance */ - symbol = len == 2 ? 2 : dict; - dist = decode(s, &distcode) << symbol; - dist += bits(s, symbol); - dist++; - if (s->first && dist > s->next) - return -3; /* distance too far back */ - - /* copy length bytes from distance bytes back */ - do { - to = s->out + s->next; - from = to - dist; - copy = MAXWIN; - if (s->next < dist) { - from += copy; - copy = dist; - } - copy -= s->next; - if (copy > len) copy = len; - len -= copy; - s->next += copy; - do { - *to++ = *from++; - } while (--copy); - if (s->next == MAXWIN) { - if (s->outfun(s->outhow, s->out, s->next)) return 1; - s->next = 0; - s->first = 0; - } - } while (len != 0); - } - else { - /* get literal and write it */ - symbol = lit ? decode(s, &litcode) : bits(s, 8); - s->out[s->next++] = symbol; - if (s->next == MAXWIN) { - if (s->outfun(s->outhow, s->out, s->next)) return 1; - s->next = 0; - s->first = 0; - } - } - } while (1); - return 0; -} - -/* See comments in blast.h */ -int blast(blast_in infun, void *inhow, blast_out outfun, void *outhow, - unsigned *left, unsigned char **in) -{ - struct state s; /* input/output state */ - int err; /* return value */ - - /* initialize input state */ - s.infun = infun; - s.inhow = inhow; - if (left != NULL && *left) { - s.left = *left; - s.in = *in; - } - else - s.left = 0; - s.bitbuf = 0; - s.bitcnt = 0; - - /* initialize output state */ - s.outfun = outfun; - s.outhow = outhow; - s.next = 0; - s.first = 1; - - /* return if bits() or decode() tries to read past available input */ - if (setjmp(s.env) != 0) /* if came back here via longjmp(), */ - err = 2; /* then skip decomp(), return error */ - else - err = decomp(&s); /* decompress */ - - /* return unused input */ - if (left != NULL) - *left = s.left; - if (in != NULL) - *in = s.left ? s.in : NULL; - - /* write any leftover output and update the error code if needed */ - if (err != 1 && s.next && s.outfun(s.outhow, s.out, s.next) && err == 0) - err = 1; - return err; -} - -#ifdef TEST -/* Example of how to use blast() */ -#include -#include - -#define CHUNK 16384 - -local unsigned inf(void *how, unsigned char **buf) -{ - static unsigned char hold[CHUNK]; - - *buf = hold; - return fread(hold, 1, CHUNK, (FILE *)how); -} - -local int outf(void *how, unsigned char *buf, unsigned len) -{ - return fwrite(buf, 1, len, (FILE *)how) != len; -} - -/* Decompress a PKWare Compression Library stream from stdin to stdout */ -int main(void) -{ - int ret; - unsigned left; - - /* decompress to stdout */ - left = 0; - ret = blast(inf, stdin, outf, stdout, &left, NULL); - if (ret != 0) - fprintf(stderr, "blast error: %d\n", ret); - - /* count any leftover bytes */ - while (getchar() != EOF) - left++; - if (left) - fprintf(stderr, "blast warning: %u unused bytes of input\n", left); - - /* return blast() error code */ - return ret; -} -#endif DELETED compat/zlib/contrib/blast/blast.h Index: compat/zlib/contrib/blast/blast.h ================================================================== --- compat/zlib/contrib/blast/blast.h +++ /dev/null @@ -1,83 +0,0 @@ -/* blast.h -- interface for blast.c - Copyright (C) 2003, 2012, 2013 Mark Adler - version 1.3, 24 Aug 2013 - - This software is provided 'as-is', without any express or implied - warranty. In no event will the author be held liable for any damages - arising from the use of this software. - - Permission is granted to anyone to use this software for any purpose, - including commercial applications, and to alter it and redistribute it - freely, subject to the following restrictions: - - 1. The origin of this software must not be misrepresented; you must not - claim that you wrote the original software. If you use this software - in a product, an acknowledgment in the product documentation would be - appreciated but is not required. - 2. Altered source versions must be plainly marked as such, and must not be - misrepresented as being the original software. - 3. This notice may not be removed or altered from any source distribution. - - Mark Adler madler@alumni.caltech.edu - */ - - -/* - * blast() decompresses the PKWare Data Compression Library (DCL) compressed - * format. It provides the same functionality as the explode() function in - * that library. (Note: PKWare overused the "implode" verb, and the format - * used by their library implode() function is completely different and - * incompatible with the implode compression method supported by PKZIP.) - * - * The binary mode for stdio functions should be used to assure that the - * compressed data is not corrupted when read or written. For example: - * fopen(..., "rb") and fopen(..., "wb"). - */ - - -typedef unsigned (*blast_in)(void *how, unsigned char **buf); -typedef int (*blast_out)(void *how, unsigned char *buf, unsigned len); -/* Definitions for input/output functions passed to blast(). See below for - * what the provided functions need to do. - */ - - -int blast(blast_in infun, void *inhow, blast_out outfun, void *outhow, - unsigned *left, unsigned char **in); -/* Decompress input to output using the provided infun() and outfun() calls. - * On success, the return value of blast() is zero. If there is an error in - * the source data, i.e. it is not in the proper format, then a negative value - * is returned. If there is not enough input available or there is not enough - * output space, then a positive error is returned. - * - * The input function is invoked: len = infun(how, &buf), where buf is set by - * infun() to point to the input buffer, and infun() returns the number of - * available bytes there. If infun() returns zero, then blast() returns with - * an input error. (blast() only asks for input if it needs it.) inhow is for - * use by the application to pass an input descriptor to infun(), if desired. - * - * If left and in are not NULL and *left is not zero when blast() is called, - * then the *left bytes are *in are consumed for input before infun() is used. - * - * The output function is invoked: err = outfun(how, buf, len), where the bytes - * to be written are buf[0..len-1]. If err is not zero, then blast() returns - * with an output error. outfun() is always called with len <= 4096. outhow - * is for use by the application to pass an output descriptor to outfun(), if - * desired. - * - * If there is any unused input, *left is set to the number of bytes that were - * read and *in points to them. Otherwise *left is set to zero and *in is set - * to NULL. If left or in are NULL, then they are not set. - * - * The return codes are: - * - * 2: ran out of input before completing decompression - * 1: output error before completing decompression - * 0: successful decompression - * -1: literal flag not zero or one - * -2: dictionary size not in 4..6 - * -3: distance is too far back - * - * At the bottom of blast.c is an example program that uses blast() that can be - * compiled to produce a command-line decompression filter by defining TEST. - */ DELETED compat/zlib/contrib/blast/test.pk Index: compat/zlib/contrib/blast/test.pk ================================================================== --- compat/zlib/contrib/blast/test.pk +++ /dev/null cannot compute difference between binary files DELETED compat/zlib/contrib/blast/test.txt Index: compat/zlib/contrib/blast/test.txt ================================================================== --- compat/zlib/contrib/blast/test.txt +++ /dev/null @@ -1,1 +0,0 @@ -AIAIAIAIAIAIA DELETED compat/zlib/contrib/delphi/ZLib.pas Index: compat/zlib/contrib/delphi/ZLib.pas ================================================================== --- compat/zlib/contrib/delphi/ZLib.pas +++ /dev/null @@ -1,557 +0,0 @@ -{*******************************************************} -{ } -{ Borland Delphi Supplemental Components } -{ ZLIB Data Compression Interface Unit } -{ } -{ Copyright (c) 1997,99 Borland Corporation } -{ } -{*******************************************************} - -{ Updated for zlib 1.2.x by Cosmin Truta } - -unit ZLib; - -interface - -uses SysUtils, Classes; - -type - TAlloc = function (AppData: Pointer; Items, Size: Integer): Pointer; cdecl; - TFree = procedure (AppData, Block: Pointer); cdecl; - - // Internal structure. Ignore. - TZStreamRec = packed record - next_in: PChar; // next input byte - avail_in: Integer; // number of bytes available at next_in - total_in: Longint; // total nb of input bytes read so far - - next_out: PChar; // next output byte should be put here - avail_out: Integer; // remaining free space at next_out - total_out: Longint; // total nb of bytes output so far - - msg: PChar; // last error message, NULL if no error - internal: Pointer; // not visible by applications - - zalloc: TAlloc; // used to allocate the internal state - zfree: TFree; // used to free the internal state - AppData: Pointer; // private data object passed to zalloc and zfree - - data_type: Integer; // best guess about the data type: ascii or binary - adler: Longint; // adler32 value of the uncompressed data - reserved: Longint; // reserved for future use - end; - - // Abstract ancestor class - TCustomZlibStream = class(TStream) - private - FStrm: TStream; - FStrmPos: Integer; - FOnProgress: TNotifyEvent; - FZRec: TZStreamRec; - FBuffer: array [Word] of Char; - protected - procedure Progress(Sender: TObject); dynamic; - property OnProgress: TNotifyEvent read FOnProgress write FOnProgress; - constructor Create(Strm: TStream); - end; - -{ TCompressionStream compresses data on the fly as data is written to it, and - stores the compressed data to another stream. - - TCompressionStream is write-only and strictly sequential. Reading from the - stream will raise an exception. Using Seek to move the stream pointer - will raise an exception. - - Output data is cached internally, written to the output stream only when - the internal output buffer is full. All pending output data is flushed - when the stream is destroyed. - - The Position property returns the number of uncompressed bytes of - data that have been written to the stream so far. - - CompressionRate returns the on-the-fly percentage by which the original - data has been compressed: (1 - (CompressedBytes / UncompressedBytes)) * 100 - If raw data size = 100 and compressed data size = 25, the CompressionRate - is 75% - - The OnProgress event is called each time the output buffer is filled and - written to the output stream. This is useful for updating a progress - indicator when you are writing a large chunk of data to the compression - stream in a single call.} - - - TCompressionLevel = (clNone, clFastest, clDefault, clMax); - - TCompressionStream = class(TCustomZlibStream) - private - function GetCompressionRate: Single; - public - constructor Create(CompressionLevel: TCompressionLevel; Dest: TStream); - destructor Destroy; override; - function Read(var Buffer; Count: Longint): Longint; override; - function Write(const Buffer; Count: Longint): Longint; override; - function Seek(Offset: Longint; Origin: Word): Longint; override; - property CompressionRate: Single read GetCompressionRate; - property OnProgress; - end; - -{ TDecompressionStream decompresses data on the fly as data is read from it. - - Compressed data comes from a separate source stream. TDecompressionStream - is read-only and unidirectional; you can seek forward in the stream, but not - backwards. The special case of setting the stream position to zero is - allowed. Seeking forward decompresses data until the requested position in - the uncompressed data has been reached. Seeking backwards, seeking relative - to the end of the stream, requesting the size of the stream, and writing to - the stream will raise an exception. - - The Position property returns the number of bytes of uncompressed data that - have been read from the stream so far. - - The OnProgress event is called each time the internal input buffer of - compressed data is exhausted and the next block is read from the input stream. - This is useful for updating a progress indicator when you are reading a - large chunk of data from the decompression stream in a single call.} - - TDecompressionStream = class(TCustomZlibStream) - public - constructor Create(Source: TStream); - destructor Destroy; override; - function Read(var Buffer; Count: Longint): Longint; override; - function Write(const Buffer; Count: Longint): Longint; override; - function Seek(Offset: Longint; Origin: Word): Longint; override; - property OnProgress; - end; - - - -{ CompressBuf compresses data, buffer to buffer, in one call. - In: InBuf = ptr to compressed data - InBytes = number of bytes in InBuf - Out: OutBuf = ptr to newly allocated buffer containing decompressed data - OutBytes = number of bytes in OutBuf } -procedure CompressBuf(const InBuf: Pointer; InBytes: Integer; - out OutBuf: Pointer; out OutBytes: Integer); - - -{ DecompressBuf decompresses data, buffer to buffer, in one call. - In: InBuf = ptr to compressed data - InBytes = number of bytes in InBuf - OutEstimate = zero, or est. size of the decompressed data - Out: OutBuf = ptr to newly allocated buffer containing decompressed data - OutBytes = number of bytes in OutBuf } -procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer; - OutEstimate: Integer; out OutBuf: Pointer; out OutBytes: Integer); - -{ DecompressToUserBuf decompresses data, buffer to buffer, in one call. - In: InBuf = ptr to compressed data - InBytes = number of bytes in InBuf - Out: OutBuf = ptr to user-allocated buffer to contain decompressed data - BufSize = number of bytes in OutBuf } -procedure DecompressToUserBuf(const InBuf: Pointer; InBytes: Integer; - const OutBuf: Pointer; BufSize: Integer); - -const - zlib_version = '1.2.11'; - -type - EZlibError = class(Exception); - ECompressionError = class(EZlibError); - EDecompressionError = class(EZlibError); - -implementation - -uses ZLibConst; - -const - Z_NO_FLUSH = 0; - Z_PARTIAL_FLUSH = 1; - Z_SYNC_FLUSH = 2; - Z_FULL_FLUSH = 3; - Z_FINISH = 4; - - Z_OK = 0; - Z_STREAM_END = 1; - Z_NEED_DICT = 2; - Z_ERRNO = (-1); - Z_STREAM_ERROR = (-2); - Z_DATA_ERROR = (-3); - Z_MEM_ERROR = (-4); - Z_BUF_ERROR = (-5); - Z_VERSION_ERROR = (-6); - - Z_NO_COMPRESSION = 0; - Z_BEST_SPEED = 1; - Z_BEST_COMPRESSION = 9; - Z_DEFAULT_COMPRESSION = (-1); - - Z_FILTERED = 1; - Z_HUFFMAN_ONLY = 2; - Z_RLE = 3; - Z_DEFAULT_STRATEGY = 0; - - Z_BINARY = 0; - Z_ASCII = 1; - Z_UNKNOWN = 2; - - Z_DEFLATED = 8; - - -{$L adler32.obj} -{$L compress.obj} -{$L crc32.obj} -{$L deflate.obj} -{$L infback.obj} -{$L inffast.obj} -{$L inflate.obj} -{$L inftrees.obj} -{$L trees.obj} -{$L uncompr.obj} -{$L zutil.obj} - -procedure adler32; external; -procedure compressBound; external; -procedure crc32; external; -procedure deflateInit2_; external; -procedure deflateParams; external; - -function _malloc(Size: Integer): Pointer; cdecl; -begin - Result := AllocMem(Size); -end; - -procedure _free(Block: Pointer); cdecl; -begin - FreeMem(Block); -end; - -procedure _memset(P: Pointer; B: Byte; count: Integer); cdecl; -begin - FillChar(P^, count, B); -end; - -procedure _memcpy(dest, source: Pointer; count: Integer); cdecl; -begin - Move(source^, dest^, count); -end; - - - -// deflate compresses data -function deflateInit_(var strm: TZStreamRec; level: Integer; version: PChar; - recsize: Integer): Integer; external; -function deflate(var strm: TZStreamRec; flush: Integer): Integer; external; -function deflateEnd(var strm: TZStreamRec): Integer; external; - -// inflate decompresses data -function inflateInit_(var strm: TZStreamRec; version: PChar; - recsize: Integer): Integer; external; -function inflate(var strm: TZStreamRec; flush: Integer): Integer; external; -function inflateEnd(var strm: TZStreamRec): Integer; external; -function inflateReset(var strm: TZStreamRec): Integer; external; - - -function zlibAllocMem(AppData: Pointer; Items, Size: Integer): Pointer; cdecl; -begin -// GetMem(Result, Items*Size); - Result := AllocMem(Items * Size); -end; - -procedure zlibFreeMem(AppData, Block: Pointer); cdecl; -begin - FreeMem(Block); -end; - -{function zlibCheck(code: Integer): Integer; -begin - Result := code; - if code < 0 then - raise EZlibError.Create('error'); //!! -end;} - -function CCheck(code: Integer): Integer; -begin - Result := code; - if code < 0 then - raise ECompressionError.Create('error'); //!! -end; - -function DCheck(code: Integer): Integer; -begin - Result := code; - if code < 0 then - raise EDecompressionError.Create('error'); //!! -end; - -procedure CompressBuf(const InBuf: Pointer; InBytes: Integer; - out OutBuf: Pointer; out OutBytes: Integer); -var - strm: TZStreamRec; - P: Pointer; -begin - FillChar(strm, sizeof(strm), 0); - strm.zalloc := zlibAllocMem; - strm.zfree := zlibFreeMem; - OutBytes := ((InBytes + (InBytes div 10) + 12) + 255) and not 255; - GetMem(OutBuf, OutBytes); - try - strm.next_in := InBuf; - strm.avail_in := InBytes; - strm.next_out := OutBuf; - strm.avail_out := OutBytes; - CCheck(deflateInit_(strm, Z_BEST_COMPRESSION, zlib_version, sizeof(strm))); - try - while CCheck(deflate(strm, Z_FINISH)) <> Z_STREAM_END do - begin - P := OutBuf; - Inc(OutBytes, 256); - ReallocMem(OutBuf, OutBytes); - strm.next_out := PChar(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P))); - strm.avail_out := 256; - end; - finally - CCheck(deflateEnd(strm)); - end; - ReallocMem(OutBuf, strm.total_out); - OutBytes := strm.total_out; - except - FreeMem(OutBuf); - raise - end; -end; - - -procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer; - OutEstimate: Integer; out OutBuf: Pointer; out OutBytes: Integer); -var - strm: TZStreamRec; - P: Pointer; - BufInc: Integer; -begin - FillChar(strm, sizeof(strm), 0); - strm.zalloc := zlibAllocMem; - strm.zfree := zlibFreeMem; - BufInc := (InBytes + 255) and not 255; - if OutEstimate = 0 then - OutBytes := BufInc - else - OutBytes := OutEstimate; - GetMem(OutBuf, OutBytes); - try - strm.next_in := InBuf; - strm.avail_in := InBytes; - strm.next_out := OutBuf; - strm.avail_out := OutBytes; - DCheck(inflateInit_(strm, zlib_version, sizeof(strm))); - try - while DCheck(inflate(strm, Z_NO_FLUSH)) <> Z_STREAM_END do - begin - P := OutBuf; - Inc(OutBytes, BufInc); - ReallocMem(OutBuf, OutBytes); - strm.next_out := PChar(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P))); - strm.avail_out := BufInc; - end; - finally - DCheck(inflateEnd(strm)); - end; - ReallocMem(OutBuf, strm.total_out); - OutBytes := strm.total_out; - except - FreeMem(OutBuf); - raise - end; -end; - -procedure DecompressToUserBuf(const InBuf: Pointer; InBytes: Integer; - const OutBuf: Pointer; BufSize: Integer); -var - strm: TZStreamRec; -begin - FillChar(strm, sizeof(strm), 0); - strm.zalloc := zlibAllocMem; - strm.zfree := zlibFreeMem; - strm.next_in := InBuf; - strm.avail_in := InBytes; - strm.next_out := OutBuf; - strm.avail_out := BufSize; - DCheck(inflateInit_(strm, zlib_version, sizeof(strm))); - try - if DCheck(inflate(strm, Z_FINISH)) <> Z_STREAM_END then - raise EZlibError.CreateRes(@sTargetBufferTooSmall); - finally - DCheck(inflateEnd(strm)); - end; -end; - -// TCustomZlibStream - -constructor TCustomZLibStream.Create(Strm: TStream); -begin - inherited Create; - FStrm := Strm; - FStrmPos := Strm.Position; - FZRec.zalloc := zlibAllocMem; - FZRec.zfree := zlibFreeMem; -end; - -procedure TCustomZLibStream.Progress(Sender: TObject); -begin - if Assigned(FOnProgress) then FOnProgress(Sender); -end; - - -// TCompressionStream - -constructor TCompressionStream.Create(CompressionLevel: TCompressionLevel; - Dest: TStream); -const - Levels: array [TCompressionLevel] of ShortInt = - (Z_NO_COMPRESSION, Z_BEST_SPEED, Z_DEFAULT_COMPRESSION, Z_BEST_COMPRESSION); -begin - inherited Create(Dest); - FZRec.next_out := FBuffer; - FZRec.avail_out := sizeof(FBuffer); - CCheck(deflateInit_(FZRec, Levels[CompressionLevel], zlib_version, sizeof(FZRec))); -end; - -destructor TCompressionStream.Destroy; -begin - FZRec.next_in := nil; - FZRec.avail_in := 0; - try - if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos; - while (CCheck(deflate(FZRec, Z_FINISH)) <> Z_STREAM_END) - and (FZRec.avail_out = 0) do - begin - FStrm.WriteBuffer(FBuffer, sizeof(FBuffer)); - FZRec.next_out := FBuffer; - FZRec.avail_out := sizeof(FBuffer); - end; - if FZRec.avail_out < sizeof(FBuffer) then - FStrm.WriteBuffer(FBuffer, sizeof(FBuffer) - FZRec.avail_out); - finally - deflateEnd(FZRec); - end; - inherited Destroy; -end; - -function TCompressionStream.Read(var Buffer; Count: Longint): Longint; -begin - raise ECompressionError.CreateRes(@sInvalidStreamOp); -end; - -function TCompressionStream.Write(const Buffer; Count: Longint): Longint; -begin - FZRec.next_in := @Buffer; - FZRec.avail_in := Count; - if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos; - while (FZRec.avail_in > 0) do - begin - CCheck(deflate(FZRec, 0)); - if FZRec.avail_out = 0 then - begin - FStrm.WriteBuffer(FBuffer, sizeof(FBuffer)); - FZRec.next_out := FBuffer; - FZRec.avail_out := sizeof(FBuffer); - FStrmPos := FStrm.Position; - Progress(Self); - end; - end; - Result := Count; -end; - -function TCompressionStream.Seek(Offset: Longint; Origin: Word): Longint; -begin - if (Offset = 0) and (Origin = soFromCurrent) then - Result := FZRec.total_in - else - raise ECompressionError.CreateRes(@sInvalidStreamOp); -end; - -function TCompressionStream.GetCompressionRate: Single; -begin - if FZRec.total_in = 0 then - Result := 0 - else - Result := (1.0 - (FZRec.total_out / FZRec.total_in)) * 100.0; -end; - - -// TDecompressionStream - -constructor TDecompressionStream.Create(Source: TStream); -begin - inherited Create(Source); - FZRec.next_in := FBuffer; - FZRec.avail_in := 0; - DCheck(inflateInit_(FZRec, zlib_version, sizeof(FZRec))); -end; - -destructor TDecompressionStream.Destroy; -begin - FStrm.Seek(-FZRec.avail_in, 1); - inflateEnd(FZRec); - inherited Destroy; -end; - -function TDecompressionStream.Read(var Buffer; Count: Longint): Longint; -begin - FZRec.next_out := @Buffer; - FZRec.avail_out := Count; - if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos; - while (FZRec.avail_out > 0) do - begin - if FZRec.avail_in = 0 then - begin - FZRec.avail_in := FStrm.Read(FBuffer, sizeof(FBuffer)); - if FZRec.avail_in = 0 then - begin - Result := Count - FZRec.avail_out; - Exit; - end; - FZRec.next_in := FBuffer; - FStrmPos := FStrm.Position; - Progress(Self); - end; - CCheck(inflate(FZRec, 0)); - end; - Result := Count; -end; - -function TDecompressionStream.Write(const Buffer; Count: Longint): Longint; -begin - raise EDecompressionError.CreateRes(@sInvalidStreamOp); -end; - -function TDecompressionStream.Seek(Offset: Longint; Origin: Word): Longint; -var - I: Integer; - Buf: array [0..4095] of Char; -begin - if (Offset = 0) and (Origin = soFromBeginning) then - begin - DCheck(inflateReset(FZRec)); - FZRec.next_in := FBuffer; - FZRec.avail_in := 0; - FStrm.Position := 0; - FStrmPos := 0; - end - else if ( (Offset >= 0) and (Origin = soFromCurrent)) or - ( ((Offset - FZRec.total_out) > 0) and (Origin = soFromBeginning)) then - begin - if Origin = soFromBeginning then Dec(Offset, FZRec.total_out); - if Offset > 0 then - begin - for I := 1 to Offset div sizeof(Buf) do - ReadBuffer(Buf, sizeof(Buf)); - ReadBuffer(Buf, Offset mod sizeof(Buf)); - end; - end - else - raise EDecompressionError.CreateRes(@sInvalidStreamOp); - Result := FZRec.total_out; -end; - - -end. DELETED compat/zlib/contrib/delphi/ZLibConst.pas Index: compat/zlib/contrib/delphi/ZLibConst.pas ================================================================== --- compat/zlib/contrib/delphi/ZLibConst.pas +++ /dev/null @@ -1,11 +0,0 @@ -unit ZLibConst; - -interface - -resourcestring - sTargetBufferTooSmall = 'ZLib error: target buffer may be too small'; - sInvalidStreamOp = 'Invalid stream operation'; - -implementation - -end. DELETED compat/zlib/contrib/delphi/readme.txt Index: compat/zlib/contrib/delphi/readme.txt ================================================================== --- compat/zlib/contrib/delphi/readme.txt +++ /dev/null @@ -1,76 +0,0 @@ - -Overview -======== - -This directory contains an update to the ZLib interface unit, -distributed by Borland as a Delphi supplemental component. - -The original ZLib unit is Copyright (c) 1997,99 Borland Corp., -and is based on zlib version 1.0.4. There are a series of bugs -and security problems associated with that old zlib version, and -we recommend the users to update their ZLib unit. - - -Summary of modifications -======================== - -- Improved makefile, adapted to zlib version 1.2.1. - -- Some field types from TZStreamRec are changed from Integer to - Longint, for consistency with the zlib.h header, and for 64-bit - readiness. - -- The zlib_version constant is updated. - -- The new Z_RLE strategy has its corresponding symbolic constant. - -- The allocation and deallocation functions and function types - (TAlloc, TFree, zlibAllocMem and zlibFreeMem) are now cdecl, - and _malloc and _free are added as C RTL stubs. As a result, - the original C sources of zlib can be compiled out of the box, - and linked to the ZLib unit. - - -Suggestions for improvements -============================ - -Currently, the ZLib unit provides only a limited wrapper around -the zlib library, and much of the original zlib functionality is -missing. Handling compressed file formats like ZIP/GZIP or PNG -cannot be implemented without having this functionality. -Applications that handle these formats are either using their own, -duplicated code, or not using the ZLib unit at all. - -Here are a few suggestions: - -- Checksum class wrappers around adler32() and crc32(), similar - to the Java classes that implement the java.util.zip.Checksum - interface. - -- The ability to read and write raw deflate streams, without the - zlib stream header and trailer. Raw deflate streams are used - in the ZIP file format. - -- The ability to read and write gzip streams, used in the GZIP - file format, and normally produced by the gzip program. - -- The ability to select a different compression strategy, useful - to PNG and MNG image compression, and to multimedia compression - in general. Besides the compression level - - TCompressionLevel = (clNone, clFastest, clDefault, clMax); - - which, in fact, could have used the 'z' prefix and avoided - TColor-like symbols - - TCompressionLevel = (zcNone, zcFastest, zcDefault, zcMax); - - there could be a compression strategy - - TCompressionStrategy = (zsDefault, zsFiltered, zsHuffmanOnly, zsRle); - -- ZIP and GZIP stream handling via TStreams. - - --- -Cosmin Truta DELETED compat/zlib/contrib/delphi/zlibd32.mak Index: compat/zlib/contrib/delphi/zlibd32.mak ================================================================== --- compat/zlib/contrib/delphi/zlibd32.mak +++ /dev/null @@ -1,99 +0,0 @@ -# Makefile for zlib -# For use with Delphi and C++ Builder under Win32 -# Updated for zlib 1.2.x by Cosmin Truta - -# ------------ Borland C++ ------------ - -# This project uses the Delphi (fastcall/register) calling convention: -LOC = -DZEXPORT=__fastcall -DZEXPORTVA=__cdecl - -CC = bcc32 -LD = bcc32 -AR = tlib -# do not use "-pr" in CFLAGS -CFLAGS = -a -d -k- -O2 $(LOC) -LDFLAGS = - - -# variables -ZLIB_LIB = zlib.lib - -OBJ1 = adler32.obj compress.obj crc32.obj deflate.obj gzclose.obj gzlib.obj gzread.obj -OBJ2 = gzwrite.obj infback.obj inffast.obj inflate.obj inftrees.obj trees.obj uncompr.obj zutil.obj -OBJP1 = +adler32.obj+compress.obj+crc32.obj+deflate.obj+gzclose.obj+gzlib.obj+gzread.obj -OBJP2 = +gzwrite.obj+infback.obj+inffast.obj+inflate.obj+inftrees.obj+trees.obj+uncompr.obj+zutil.obj - - -# targets -all: $(ZLIB_LIB) example.exe minigzip.exe - -.c.obj: - $(CC) -c $(CFLAGS) $*.c - -adler32.obj: adler32.c zlib.h zconf.h - -compress.obj: compress.c zlib.h zconf.h - -crc32.obj: crc32.c zlib.h zconf.h crc32.h - -deflate.obj: deflate.c deflate.h zutil.h zlib.h zconf.h - -gzclose.obj: gzclose.c zlib.h zconf.h gzguts.h - -gzlib.obj: gzlib.c zlib.h zconf.h gzguts.h - -gzread.obj: gzread.c zlib.h zconf.h gzguts.h - -gzwrite.obj: gzwrite.c zlib.h zconf.h gzguts.h - -infback.obj: infback.c zutil.h zlib.h zconf.h inftrees.h inflate.h \ - inffast.h inffixed.h - -inffast.obj: inffast.c zutil.h zlib.h zconf.h inftrees.h inflate.h \ - inffast.h - -inflate.obj: inflate.c zutil.h zlib.h zconf.h inftrees.h inflate.h \ - inffast.h inffixed.h - -inftrees.obj: inftrees.c zutil.h zlib.h zconf.h inftrees.h - -trees.obj: trees.c zutil.h zlib.h zconf.h deflate.h trees.h - -uncompr.obj: uncompr.c zlib.h zconf.h - -zutil.obj: zutil.c zutil.h zlib.h zconf.h - -example.obj: test/example.c zlib.h zconf.h - -minigzip.obj: test/minigzip.c zlib.h zconf.h - - -# For the sake of the old Borland make, -# the command line is cut to fit in the MS-DOS 128 byte limit: -$(ZLIB_LIB): $(OBJ1) $(OBJ2) - -del $(ZLIB_LIB) - $(AR) $(ZLIB_LIB) $(OBJP1) - $(AR) $(ZLIB_LIB) $(OBJP2) - - -# testing -test: example.exe minigzip.exe - example - echo hello world | minigzip | minigzip -d - -example.exe: example.obj $(ZLIB_LIB) - $(LD) $(LDFLAGS) example.obj $(ZLIB_LIB) - -minigzip.exe: minigzip.obj $(ZLIB_LIB) - $(LD) $(LDFLAGS) minigzip.obj $(ZLIB_LIB) - - -# cleanup -clean: - -del *.obj - -del *.exe - -del *.lib - -del *.tds - -del zlib.bak - -del foo.gz - DELETED compat/zlib/contrib/dotzlib/DotZLib.build Index: compat/zlib/contrib/dotzlib/DotZLib.build ================================================================== --- compat/zlib/contrib/dotzlib/DotZLib.build +++ /dev/null @@ -1,33 +0,0 @@ - - - A .Net wrapper library around ZLib1.dll - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DELETED compat/zlib/contrib/dotzlib/DotZLib.chm Index: compat/zlib/contrib/dotzlib/DotZLib.chm ================================================================== --- compat/zlib/contrib/dotzlib/DotZLib.chm +++ /dev/null cannot compute difference between binary files DELETED compat/zlib/contrib/dotzlib/DotZLib.sln Index: compat/zlib/contrib/dotzlib/DotZLib.sln ================================================================== --- compat/zlib/contrib/dotzlib/DotZLib.sln +++ /dev/null @@ -1,21 +0,0 @@ -Microsoft Visual Studio Solution File, Format Version 8.00 -Project("{FAE04EC0-301F-11D3-BF4B-00C04F79EFBC}") = "DotZLib", "DotZLib\DotZLib.csproj", "{BB1EE0B1-1808-46CB-B786-949D91117FC5}" - ProjectSection(ProjectDependencies) = postProject - EndProjectSection -EndProject -Global - GlobalSection(SolutionConfiguration) = preSolution - Debug = Debug - Release = Release - EndGlobalSection - GlobalSection(ProjectConfiguration) = postSolution - {BB1EE0B1-1808-46CB-B786-949D91117FC5}.Debug.ActiveCfg = Debug|.NET - {BB1EE0B1-1808-46CB-B786-949D91117FC5}.Debug.Build.0 = Debug|.NET - {BB1EE0B1-1808-46CB-B786-949D91117FC5}.Release.ActiveCfg = Release|.NET - {BB1EE0B1-1808-46CB-B786-949D91117FC5}.Release.Build.0 = Release|.NET - EndGlobalSection - GlobalSection(ExtensibilityGlobals) = postSolution - EndGlobalSection - GlobalSection(ExtensibilityAddIns) = postSolution - EndGlobalSection -EndGlobal DELETED compat/zlib/contrib/dotzlib/DotZLib/AssemblyInfo.cs Index: compat/zlib/contrib/dotzlib/DotZLib/AssemblyInfo.cs ================================================================== --- compat/zlib/contrib/dotzlib/DotZLib/AssemblyInfo.cs +++ /dev/null @@ -1,58 +0,0 @@ -using System.Reflection; -using System.Runtime.CompilerServices; - -// -// General Information about an assembly is controlled through the following -// set of attributes. Change these attribute values to modify the information -// associated with an assembly. -// -[assembly: AssemblyTitle("DotZLib")] -[assembly: AssemblyDescription(".Net bindings for ZLib compression dll 1.2.x")] -[assembly: AssemblyConfiguration("")] -[assembly: AssemblyCompany("Henrik Ravn")] -[assembly: AssemblyProduct("")] -[assembly: AssemblyCopyright("(c) 2004 by Henrik Ravn")] -[assembly: AssemblyTrademark("")] -[assembly: AssemblyCulture("")] - -// -// Version information for an assembly consists of the following four values: -// -// Major Version -// Minor Version -// Build Number -// Revision -// -// You can specify all the values or you can default the Revision and Build Numbers -// by using the '*' as shown below: - -[assembly: AssemblyVersion("1.0.*")] - -// -// In order to sign your assembly you must specify a key to use. Refer to the -// Microsoft .NET Framework documentation for more information on assembly signing. -// -// Use the attributes below to control which key is used for signing. -// -// Notes: -// (*) If no key is specified, the assembly is not signed. -// (*) KeyName refers to a key that has been installed in the Crypto Service -// Provider (CSP) on your machine. KeyFile refers to a file which contains -// a key. -// (*) If the KeyFile and the KeyName values are both specified, the -// following processing occurs: -// (1) If the KeyName can be found in the CSP, that key is used. -// (2) If the KeyName does not exist and the KeyFile does exist, the key -// in the KeyFile is installed into the CSP and used. -// (*) In order to create a KeyFile, you can use the sn.exe (Strong Name) utility. -// When specifying the KeyFile, the location of the KeyFile should be -// relative to the project output directory which is -// %Project Directory%\obj\. For example, if your KeyFile is -// located in the project directory, you would specify the AssemblyKeyFile -// attribute as [assembly: AssemblyKeyFile("..\\..\\mykey.snk")] -// (*) Delay Signing is an advanced option - see the Microsoft .NET Framework -// documentation for more information on this. -// -[assembly: AssemblyDelaySign(false)] -[assembly: AssemblyKeyFile("")] -[assembly: AssemblyKeyName("")] DELETED compat/zlib/contrib/dotzlib/DotZLib/ChecksumImpl.cs Index: compat/zlib/contrib/dotzlib/DotZLib/ChecksumImpl.cs ================================================================== --- compat/zlib/contrib/dotzlib/DotZLib/ChecksumImpl.cs +++ /dev/null @@ -1,202 +0,0 @@ -// -// © Copyright Henrik Ravn 2004 -// -// Use, modification and distribution are subject to the Boost Software License, Version 1.0. -// (See accompanying file LICENSE_1_0.txt or copy at http://www.boost.org/LICENSE_1_0.txt) -// - -using System; -using System.Runtime.InteropServices; -using System.Text; - - -namespace DotZLib -{ - #region ChecksumGeneratorBase - /// - /// Implements the common functionality needed for all s - /// - /// - public abstract class ChecksumGeneratorBase : ChecksumGenerator - { - /// - /// The value of the current checksum - /// - protected uint _current; - - /// - /// Initializes a new instance of the checksum generator base - the current checksum is - /// set to zero - /// - public ChecksumGeneratorBase() - { - _current = 0; - } - - /// - /// Initializes a new instance of the checksum generator basewith a specified value - /// - /// The value to set the current checksum to - public ChecksumGeneratorBase(uint initialValue) - { - _current = initialValue; - } - - /// - /// Resets the current checksum to zero - /// - public void Reset() { _current = 0; } - - /// - /// Gets the current checksum value - /// - public uint Value { get { return _current; } } - - /// - /// Updates the current checksum with part of an array of bytes - /// - /// The data to update the checksum with - /// Where in data to start updating - /// The number of bytes from data to use - /// The sum of offset and count is larger than the length of data - /// data is a null reference - /// Offset or count is negative. - /// All the other Update methods are implmeneted in terms of this one. - /// This is therefore the only method a derived class has to implement - public abstract void Update(byte[] data, int offset, int count); - - /// - /// Updates the current checksum with an array of bytes. - /// - /// The data to update the checksum with - public void Update(byte[] data) - { - Update(data, 0, data.Length); - } - - /// - /// Updates the current checksum with the data from a string - /// - /// The string to update the checksum with - /// The characters in the string are converted by the UTF-8 encoding - public void Update(string data) - { - Update(Encoding.UTF8.GetBytes(data)); - } - - /// - /// Updates the current checksum with the data from a string, using a specific encoding - /// - /// The string to update the checksum with - /// The encoding to use - public void Update(string data, Encoding encoding) - { - Update(encoding.GetBytes(data)); - } - - } - #endregion - - #region CRC32 - /// - /// Implements a CRC32 checksum generator - /// - public sealed class CRC32Checksum : ChecksumGeneratorBase - { - #region DLL imports - - [DllImport("ZLIB1.dll", CallingConvention=CallingConvention.Cdecl)] - private static extern uint crc32(uint crc, int data, uint length); - - #endregion - - /// - /// Initializes a new instance of the CRC32 checksum generator - /// - public CRC32Checksum() : base() {} - - /// - /// Initializes a new instance of the CRC32 checksum generator with a specified value - /// - /// The value to set the current checksum to - public CRC32Checksum(uint initialValue) : base(initialValue) {} - - /// - /// Updates the current checksum with part of an array of bytes - /// - /// The data to update the checksum with - /// Where in data to start updating - /// The number of bytes from data to use - /// The sum of offset and count is larger than the length of data - /// data is a null reference - /// Offset or count is negative. - public override void Update(byte[] data, int offset, int count) - { - if (offset < 0 || count < 0) throw new ArgumentOutOfRangeException(); - if ((offset+count) > data.Length) throw new ArgumentException(); - GCHandle hData = GCHandle.Alloc(data, GCHandleType.Pinned); - try - { - _current = crc32(_current, hData.AddrOfPinnedObject().ToInt32()+offset, (uint)count); - } - finally - { - hData.Free(); - } - } - - } - #endregion - - #region Adler - /// - /// Implements a checksum generator that computes the Adler checksum on data - /// - public sealed class AdlerChecksum : ChecksumGeneratorBase - { - #region DLL imports - - [DllImport("ZLIB1.dll", CallingConvention=CallingConvention.Cdecl)] - private static extern uint adler32(uint adler, int data, uint length); - - #endregion - - /// - /// Initializes a new instance of the Adler checksum generator - /// - public AdlerChecksum() : base() {} - - /// - /// Initializes a new instance of the Adler checksum generator with a specified value - /// - /// The value to set the current checksum to - public AdlerChecksum(uint initialValue) : base(initialValue) {} - - /// - /// Updates the current checksum with part of an array of bytes - /// - /// The data to update the checksum with - /// Where in data to start updating - /// The number of bytes from data to use - /// The sum of offset and count is larger than the length of data - /// data is a null reference - /// Offset or count is negative. - public override void Update(byte[] data, int offset, int count) - { - if (offset < 0 || count < 0) throw new ArgumentOutOfRangeException(); - if ((offset+count) > data.Length) throw new ArgumentException(); - GCHandle hData = GCHandle.Alloc(data, GCHandleType.Pinned); - try - { - _current = adler32(_current, hData.AddrOfPinnedObject().ToInt32()+offset, (uint)count); - } - finally - { - hData.Free(); - } - } - - } - #endregion - -} DELETED compat/zlib/contrib/dotzlib/DotZLib/CircularBuffer.cs Index: compat/zlib/contrib/dotzlib/DotZLib/CircularBuffer.cs ================================================================== --- compat/zlib/contrib/dotzlib/DotZLib/CircularBuffer.cs +++ /dev/null @@ -1,83 +0,0 @@ -// -// © Copyright Henrik Ravn 2004 -// -// Use, modification and distribution are subject to the Boost Software License, Version 1.0. -// (See accompanying file LICENSE_1_0.txt or copy at http://www.boost.org/LICENSE_1_0.txt) -// - -using System; -using System.Diagnostics; - -namespace DotZLib -{ - - /// - /// This class implements a circular buffer - /// - internal class CircularBuffer - { - #region Private data - private int _capacity; - private int _head; - private int _tail; - private int _size; - private byte[] _buffer; - #endregion - - public CircularBuffer(int capacity) - { - Debug.Assert( capacity > 0 ); - _buffer = new byte[capacity]; - _capacity = capacity; - _head = 0; - _tail = 0; - _size = 0; - } - - public int Size { get { return _size; } } - - public int Put(byte[] source, int offset, int count) - { - Debug.Assert( count > 0 ); - int trueCount = Math.Min(count, _capacity - Size); - for (int i = 0; i < trueCount; ++i) - _buffer[(_tail+i) % _capacity] = source[offset+i]; - _tail += trueCount; - _tail %= _capacity; - _size += trueCount; - return trueCount; - } - - public bool Put(byte b) - { - if (Size == _capacity) // no room - return false; - _buffer[_tail++] = b; - _tail %= _capacity; - ++_size; - return true; - } - - public int Get(byte[] destination, int offset, int count) - { - int trueCount = Math.Min(count,Size); - for (int i = 0; i < trueCount; ++i) - destination[offset + i] = _buffer[(_head+i) % _capacity]; - _head += trueCount; - _head %= _capacity; - _size -= trueCount; - return trueCount; - } - - public int Get() - { - if (Size == 0) - return -1; - - int result = (int)_buffer[_head++ % _capacity]; - --_size; - return result; - } - - } -} DELETED compat/zlib/contrib/dotzlib/DotZLib/CodecBase.cs Index: compat/zlib/contrib/dotzlib/DotZLib/CodecBase.cs ================================================================== --- compat/zlib/contrib/dotzlib/DotZLib/CodecBase.cs +++ /dev/null @@ -1,198 +0,0 @@ -// -// © Copyright Henrik Ravn 2004 -// -// Use, modification and distribution are subject to the Boost Software License, Version 1.0. -// (See accompanying file LICENSE_1_0.txt or copy at http://www.boost.org/LICENSE_1_0.txt) -// - -using System; -using System.Runtime.InteropServices; - -namespace DotZLib -{ - /// - /// Implements the common functionality needed for all s - /// - public abstract class CodecBase : Codec, IDisposable - { - - #region Data members - - /// - /// Instance of the internal zlib buffer structure that is - /// passed to all functions in the zlib dll - /// - internal ZStream _ztream = new ZStream(); - - /// - /// True if the object instance has been disposed, false otherwise - /// - protected bool _isDisposed = false; - - /// - /// The size of the internal buffers - /// - protected const int kBufferSize = 16384; - - private byte[] _outBuffer = new byte[kBufferSize]; - private byte[] _inBuffer = new byte[kBufferSize]; - - private GCHandle _hInput; - private GCHandle _hOutput; - - private uint _checksum = 0; - - #endregion - - /// - /// Initializes a new instance of the CodeBase class. - /// - public CodecBase() - { - try - { - _hInput = GCHandle.Alloc(_inBuffer, GCHandleType.Pinned); - _hOutput = GCHandle.Alloc(_outBuffer, GCHandleType.Pinned); - } - catch (Exception) - { - CleanUp(false); - throw; - } - } - - - #region Codec Members - - /// - /// Occurs when more processed data are available. - /// - public event DataAvailableHandler DataAvailable; - - /// - /// Fires the event - /// - protected void OnDataAvailable() - { - if (_ztream.total_out > 0) - { - if (DataAvailable != null) - DataAvailable( _outBuffer, 0, (int)_ztream.total_out); - resetOutput(); - } - } - - /// - /// Adds more data to the codec to be processed. - /// - /// Byte array containing the data to be added to the codec - /// Adding data may, or may not, raise the DataAvailable event - public void Add(byte[] data) - { - Add(data,0,data.Length); - } - - /// - /// Adds more data to the codec to be processed. - /// - /// Byte array containing the data to be added to the codec - /// The index of the first byte to add from data - /// The number of bytes to add - /// Adding data may, or may not, raise the DataAvailable event - /// This must be implemented by a derived class - public abstract void Add(byte[] data, int offset, int count); - - /// - /// Finishes up any pending data that needs to be processed and handled. - /// - /// This must be implemented by a derived class - public abstract void Finish(); - - /// - /// Gets the checksum of the data that has been added so far - /// - public uint Checksum { get { return _checksum; } } - - #endregion - - #region Destructor & IDisposable stuff - - /// - /// Destroys this instance - /// - ~CodecBase() - { - CleanUp(false); - } - - /// - /// Releases any unmanaged resources and calls the method of the derived class - /// - public void Dispose() - { - CleanUp(true); - } - - /// - /// Performs any codec specific cleanup - /// - /// This must be implemented by a derived class - protected abstract void CleanUp(); - - // performs the release of the handles and calls the dereived CleanUp() - private void CleanUp(bool isDisposing) - { - if (!_isDisposed) - { - CleanUp(); - if (_hInput.IsAllocated) - _hInput.Free(); - if (_hOutput.IsAllocated) - _hOutput.Free(); - - _isDisposed = true; - } - } - - - #endregion - - #region Helper methods - - /// - /// Copies a number of bytes to the internal codec buffer - ready for proccesing - /// - /// The byte array that contains the data to copy - /// The index of the first byte to copy - /// The number of bytes to copy from data - protected void copyInput(byte[] data, int startIndex, int count) - { - Array.Copy(data, startIndex, _inBuffer,0, count); - _ztream.next_in = _hInput.AddrOfPinnedObject(); - _ztream.total_in = 0; - _ztream.avail_in = (uint)count; - - } - - /// - /// Resets the internal output buffers to a known state - ready for processing - /// - protected void resetOutput() - { - _ztream.total_out = 0; - _ztream.avail_out = kBufferSize; - _ztream.next_out = _hOutput.AddrOfPinnedObject(); - } - - /// - /// Updates the running checksum property - /// - /// The new checksum value - protected void setChecksum(uint newSum) - { - _checksum = newSum; - } - #endregion - - } -} DELETED compat/zlib/contrib/dotzlib/DotZLib/Deflater.cs Index: compat/zlib/contrib/dotzlib/DotZLib/Deflater.cs ================================================================== --- compat/zlib/contrib/dotzlib/DotZLib/Deflater.cs +++ /dev/null @@ -1,106 +0,0 @@ -// -// © Copyright Henrik Ravn 2004 -// -// Use, modification and distribution are subject to the Boost Software License, Version 1.0. -// (See accompanying file LICENSE_1_0.txt or copy at http://www.boost.org/LICENSE_1_0.txt) -// - -using System; -using System.Diagnostics; -using System.Runtime.InteropServices; - -namespace DotZLib -{ - - /// - /// Implements a data compressor, using the deflate algorithm in the ZLib dll - /// - public sealed class Deflater : CodecBase - { - #region Dll imports - [DllImport("ZLIB1.dll", CallingConvention=CallingConvention.Cdecl, CharSet=CharSet.Ansi)] - private static extern int deflateInit_(ref ZStream sz, int level, string vs, int size); - - [DllImport("ZLIB1.dll", CallingConvention=CallingConvention.Cdecl)] - private static extern int deflate(ref ZStream sz, int flush); - - [DllImport("ZLIB1.dll", CallingConvention=CallingConvention.Cdecl)] - private static extern int deflateReset(ref ZStream sz); - - [DllImport("ZLIB1.dll", CallingConvention=CallingConvention.Cdecl)] - private static extern int deflateEnd(ref ZStream sz); - #endregion - - /// - /// Constructs an new instance of the Deflater - /// - /// The compression level to use for this Deflater - public Deflater(CompressLevel level) : base() - { - int retval = deflateInit_(ref _ztream, (int)level, Info.Version, Marshal.SizeOf(_ztream)); - if (retval != 0) - throw new ZLibException(retval, "Could not initialize deflater"); - - resetOutput(); - } - - /// - /// Adds more data to the codec to be processed. - /// - /// Byte array containing the data to be added to the codec - /// The index of the first byte to add from data - /// The number of bytes to add - /// Adding data may, or may not, raise the DataAvailable event - public override void Add(byte[] data, int offset, int count) - { - if (data == null) throw new ArgumentNullException(); - if (offset < 0 || count < 0) throw new ArgumentOutOfRangeException(); - if ((offset+count) > data.Length) throw new ArgumentException(); - - int total = count; - int inputIndex = offset; - int err = 0; - - while (err >= 0 && inputIndex < total) - { - copyInput(data, inputIndex, Math.Min(total - inputIndex, kBufferSize)); - while (err >= 0 && _ztream.avail_in > 0) - { - err = deflate(ref _ztream, (int)FlushTypes.None); - if (err == 0) - while (_ztream.avail_out == 0) - { - OnDataAvailable(); - err = deflate(ref _ztream, (int)FlushTypes.None); - } - inputIndex += (int)_ztream.total_in; - } - } - setChecksum( _ztream.adler ); - } - - - /// - /// Finishes up any pending data that needs to be processed and handled. - /// - public override void Finish() - { - int err; - do - { - err = deflate(ref _ztream, (int)FlushTypes.Finish); - OnDataAvailable(); - } - while (err == 0); - setChecksum( _ztream.adler ); - deflateReset(ref _ztream); - resetOutput(); - } - - /// - /// Closes the internal zlib deflate stream - /// - protected override void CleanUp() { deflateEnd(ref _ztream); } - - } -} DELETED compat/zlib/contrib/dotzlib/DotZLib/DotZLib.cs Index: compat/zlib/contrib/dotzlib/DotZLib/DotZLib.cs ================================================================== --- compat/zlib/contrib/dotzlib/DotZLib/DotZLib.cs +++ /dev/null @@ -1,288 +0,0 @@ -// -// © Copyright Henrik Ravn 2004 -// -// Use, modification and distribution are subject to the Boost Software License, Version 1.0. -// (See accompanying file LICENSE_1_0.txt or copy at http://www.boost.org/LICENSE_1_0.txt) -// - -using System; -using System.IO; -using System.Runtime.InteropServices; -using System.Text; - - -namespace DotZLib -{ - - #region Internal types - - /// - /// Defines constants for the various flush types used with zlib - /// - internal enum FlushTypes - { - None, Partial, Sync, Full, Finish, Block - } - - #region ZStream structure - // internal mapping of the zlib zstream structure for marshalling - [StructLayoutAttribute(LayoutKind.Sequential, Pack=4, Size=0, CharSet=CharSet.Ansi)] - internal struct ZStream - { - public IntPtr next_in; - public uint avail_in; - public uint total_in; - - public IntPtr next_out; - public uint avail_out; - public uint total_out; - - [MarshalAs(UnmanagedType.LPStr)] - string msg; - uint state; - - uint zalloc; - uint zfree; - uint opaque; - - int data_type; - public uint adler; - uint reserved; - } - - #endregion - - #endregion - - #region Public enums - /// - /// Defines constants for the available compression levels in zlib - /// - public enum CompressLevel : int - { - /// - /// The default compression level with a reasonable compromise between compression and speed - /// - Default = -1, - /// - /// No compression at all. The data are passed straight through. - /// - None = 0, - /// - /// The maximum compression rate available. - /// - Best = 9, - /// - /// The fastest available compression level. - /// - Fastest = 1 - } - #endregion - - #region Exception classes - /// - /// The exception that is thrown when an error occurs on the zlib dll - /// - public class ZLibException : ApplicationException - { - /// - /// Initializes a new instance of the class with a specified - /// error message and error code - /// - /// The zlib error code that caused the exception - /// A message that (hopefully) describes the error - public ZLibException(int errorCode, string msg) : base(String.Format("ZLib error {0} {1}", errorCode, msg)) - { - } - - /// - /// Initializes a new instance of the class with a specified - /// error code - /// - /// The zlib error code that caused the exception - public ZLibException(int errorCode) : base(String.Format("ZLib error {0}", errorCode)) - { - } - } - #endregion - - #region Interfaces - - /// - /// Declares methods and properties that enables a running checksum to be calculated - /// - public interface ChecksumGenerator - { - /// - /// Gets the current value of the checksum - /// - uint Value { get; } - - /// - /// Clears the current checksum to 0 - /// - void Reset(); - - /// - /// Updates the current checksum with an array of bytes - /// - /// The data to update the checksum with - void Update(byte[] data); - - /// - /// Updates the current checksum with part of an array of bytes - /// - /// The data to update the checksum with - /// Where in data to start updating - /// The number of bytes from data to use - /// The sum of offset and count is larger than the length of data - /// data is a null reference - /// Offset or count is negative. - void Update(byte[] data, int offset, int count); - - /// - /// Updates the current checksum with the data from a string - /// - /// The string to update the checksum with - /// The characters in the string are converted by the UTF-8 encoding - void Update(string data); - - /// - /// Updates the current checksum with the data from a string, using a specific encoding - /// - /// The string to update the checksum with - /// The encoding to use - void Update(string data, Encoding encoding); - } - - - /// - /// Represents the method that will be called from a codec when new data - /// are available. - /// - /// The byte array containing the processed data - /// The index of the first processed byte in data - /// The number of processed bytes available - /// On return from this method, the data may be overwritten, so grab it while you can. - /// You cannot assume that startIndex will be zero. - /// - public delegate void DataAvailableHandler(byte[] data, int startIndex, int count); - - /// - /// Declares methods and events for implementing compressors/decompressors - /// - public interface Codec - { - /// - /// Occurs when more processed data are available. - /// - event DataAvailableHandler DataAvailable; - - /// - /// Adds more data to the codec to be processed. - /// - /// Byte array containing the data to be added to the codec - /// Adding data may, or may not, raise the DataAvailable event - void Add(byte[] data); - - /// - /// Adds more data to the codec to be processed. - /// - /// Byte array containing the data to be added to the codec - /// The index of the first byte to add from data - /// The number of bytes to add - /// Adding data may, or may not, raise the DataAvailable event - void Add(byte[] data, int offset, int count); - - /// - /// Finishes up any pending data that needs to be processed and handled. - /// - void Finish(); - - /// - /// Gets the checksum of the data that has been added so far - /// - uint Checksum { get; } - - - } - - #endregion - - #region Classes - /// - /// Encapsulates general information about the ZLib library - /// - public class Info - { - #region DLL imports - [DllImport("ZLIB1.dll", CallingConvention=CallingConvention.Cdecl)] - private static extern uint zlibCompileFlags(); - - [DllImport("ZLIB1.dll", CallingConvention=CallingConvention.Cdecl)] - private static extern string zlibVersion(); - #endregion - - #region Private stuff - private uint _flags; - - // helper function that unpacks a bitsize mask - private static int bitSize(uint bits) - { - switch (bits) - { - case 0: return 16; - case 1: return 32; - case 2: return 64; - } - return -1; - } - #endregion - - /// - /// Constructs an instance of the Info class. - /// - public Info() - { - _flags = zlibCompileFlags(); - } - - /// - /// True if the library is compiled with debug info - /// - public bool HasDebugInfo { get { return 0 != (_flags & 0x100); } } - - /// - /// True if the library is compiled with assembly optimizations - /// - public bool UsesAssemblyCode { get { return 0 != (_flags & 0x200); } } - - /// - /// Gets the size of the unsigned int that was compiled into Zlib - /// - public int SizeOfUInt { get { return bitSize(_flags & 3); } } - - /// - /// Gets the size of the unsigned long that was compiled into Zlib - /// - public int SizeOfULong { get { return bitSize((_flags >> 2) & 3); } } - - /// - /// Gets the size of the pointers that were compiled into Zlib - /// - public int SizeOfPointer { get { return bitSize((_flags >> 4) & 3); } } - - /// - /// Gets the size of the z_off_t type that was compiled into Zlib - /// - public int SizeOfOffset { get { return bitSize((_flags >> 6) & 3); } } - - /// - /// Gets the version of ZLib as a string, e.g. "1.2.1" - /// - public static string Version { get { return zlibVersion(); } } - } - - #endregion - -} DELETED compat/zlib/contrib/dotzlib/DotZLib/DotZLib.csproj Index: compat/zlib/contrib/dotzlib/DotZLib/DotZLib.csproj ================================================================== --- compat/zlib/contrib/dotzlib/DotZLib/DotZLib.csproj +++ /dev/null @@ -1,141 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DELETED compat/zlib/contrib/dotzlib/DotZLib/GZipStream.cs Index: compat/zlib/contrib/dotzlib/DotZLib/GZipStream.cs ================================================================== --- compat/zlib/contrib/dotzlib/DotZLib/GZipStream.cs +++ /dev/null @@ -1,301 +0,0 @@ -// -// © Copyright Henrik Ravn 2004 -// -// Use, modification and distribution are subject to the Boost Software License, Version 1.0. -// (See accompanying file LICENSE_1_0.txt or copy at http://www.boost.org/LICENSE_1_0.txt) -// - -using System; -using System.IO; -using System.Runtime.InteropServices; - -namespace DotZLib -{ - /// - /// Implements a compressed , in GZip (.gz) format. - /// - public class GZipStream : Stream, IDisposable - { - #region Dll Imports - [DllImport("ZLIB1.dll", CallingConvention=CallingConvention.Cdecl, CharSet=CharSet.Ansi)] - private static extern IntPtr gzopen(string name, string mode); - - [DllImport("ZLIB1.dll", CallingConvention=CallingConvention.Cdecl)] - private static extern int gzclose(IntPtr gzFile); - - [DllImport("ZLIB1.dll", CallingConvention=CallingConvention.Cdecl)] - private static extern int gzwrite(IntPtr gzFile, int data, int length); - - [DllImport("ZLIB1.dll", CallingConvention=CallingConvention.Cdecl)] - private static extern int gzread(IntPtr gzFile, int data, int length); - - [DllImport("ZLIB1.dll", CallingConvention=CallingConvention.Cdecl)] - private static extern int gzgetc(IntPtr gzFile); - - [DllImport("ZLIB1.dll", CallingConvention=CallingConvention.Cdecl)] - private static extern int gzputc(IntPtr gzFile, int c); - - #endregion - - #region Private data - private IntPtr _gzFile; - private bool _isDisposed = false; - private bool _isWriting; - #endregion - - #region Constructors - /// - /// Creates a new file as a writeable GZipStream - /// - /// The name of the compressed file to create - /// The compression level to use when adding data - /// If an error occurred in the internal zlib function - public GZipStream(string fileName, CompressLevel level) - { - _isWriting = true; - _gzFile = gzopen(fileName, String.Format("wb{0}", (int)level)); - if (_gzFile == IntPtr.Zero) - throw new ZLibException(-1, "Could not open " + fileName); - } - - /// - /// Opens an existing file as a readable GZipStream - /// - /// The name of the file to open - /// If an error occurred in the internal zlib function - public GZipStream(string fileName) - { - _isWriting = false; - _gzFile = gzopen(fileName, "rb"); - if (_gzFile == IntPtr.Zero) - throw new ZLibException(-1, "Could not open " + fileName); - - } - #endregion - - #region Access properties - /// - /// Returns true of this stream can be read from, false otherwise - /// - public override bool CanRead - { - get - { - return !_isWriting; - } - } - - - /// - /// Returns false. - /// - public override bool CanSeek - { - get - { - return false; - } - } - - /// - /// Returns true if this tsream is writeable, false otherwise - /// - public override bool CanWrite - { - get - { - return _isWriting; - } - } - #endregion - - #region Destructor & IDispose stuff - - /// - /// Destroys this instance - /// - ~GZipStream() - { - cleanUp(false); - } - - /// - /// Closes the external file handle - /// - public void Dispose() - { - cleanUp(true); - } - - // Does the actual closing of the file handle. - private void cleanUp(bool isDisposing) - { - if (!_isDisposed) - { - gzclose(_gzFile); - _isDisposed = true; - } - } - #endregion - - #region Basic reading and writing - /// - /// Attempts to read a number of bytes from the stream. - /// - /// The destination data buffer - /// The index of the first destination byte in buffer - /// The number of bytes requested - /// The number of bytes read - /// If buffer is null - /// If count or offset are negative - /// If offset + count is > buffer.Length - /// If this stream is not readable. - /// If this stream has been disposed. - public override int Read(byte[] buffer, int offset, int count) - { - if (!CanRead) throw new NotSupportedException(); - if (buffer == null) throw new ArgumentNullException(); - if (offset < 0 || count < 0) throw new ArgumentOutOfRangeException(); - if ((offset+count) > buffer.Length) throw new ArgumentException(); - if (_isDisposed) throw new ObjectDisposedException("GZipStream"); - - GCHandle h = GCHandle.Alloc(buffer, GCHandleType.Pinned); - int result; - try - { - result = gzread(_gzFile, h.AddrOfPinnedObject().ToInt32() + offset, count); - if (result < 0) - throw new IOException(); - } - finally - { - h.Free(); - } - return result; - } - - /// - /// Attempts to read a single byte from the stream. - /// - /// The byte that was read, or -1 in case of error or End-Of-File - public override int ReadByte() - { - if (!CanRead) throw new NotSupportedException(); - if (_isDisposed) throw new ObjectDisposedException("GZipStream"); - return gzgetc(_gzFile); - } - - /// - /// Writes a number of bytes to the stream - /// - /// - /// - /// - /// If buffer is null - /// If count or offset are negative - /// If offset + count is > buffer.Length - /// If this stream is not writeable. - /// If this stream has been disposed. - public override void Write(byte[] buffer, int offset, int count) - { - if (!CanWrite) throw new NotSupportedException(); - if (buffer == null) throw new ArgumentNullException(); - if (offset < 0 || count < 0) throw new ArgumentOutOfRangeException(); - if ((offset+count) > buffer.Length) throw new ArgumentException(); - if (_isDisposed) throw new ObjectDisposedException("GZipStream"); - - GCHandle h = GCHandle.Alloc(buffer, GCHandleType.Pinned); - try - { - int result = gzwrite(_gzFile, h.AddrOfPinnedObject().ToInt32() + offset, count); - if (result < 0) - throw new IOException(); - } - finally - { - h.Free(); - } - } - - /// - /// Writes a single byte to the stream - /// - /// The byte to add to the stream. - /// If this stream is not writeable. - /// If this stream has been disposed. - public override void WriteByte(byte value) - { - if (!CanWrite) throw new NotSupportedException(); - if (_isDisposed) throw new ObjectDisposedException("GZipStream"); - - int result = gzputc(_gzFile, (int)value); - if (result < 0) - throw new IOException(); - } - #endregion - - #region Position & length stuff - /// - /// Not supported. - /// - /// - /// Always thrown - public override void SetLength(long value) - { - throw new NotSupportedException(); - } - - /// - /// Not suppported. - /// - /// - /// - /// - /// Always thrown - public override long Seek(long offset, SeekOrigin origin) - { - throw new NotSupportedException(); - } - - /// - /// Flushes the GZipStream. - /// - /// In this implementation, this method does nothing. This is because excessive - /// flushing may degrade the achievable compression rates. - public override void Flush() - { - // left empty on purpose - } - - /// - /// Gets/sets the current position in the GZipStream. Not suppported. - /// - /// In this implementation this property is not supported - /// Always thrown - public override long Position - { - get - { - throw new NotSupportedException(); - } - set - { - throw new NotSupportedException(); - } - } - - /// - /// Gets the size of the stream. Not suppported. - /// - /// In this implementation this property is not supported - /// Always thrown - public override long Length - { - get - { - throw new NotSupportedException(); - } - } - #endregion - } -} DELETED compat/zlib/contrib/dotzlib/DotZLib/Inflater.cs Index: compat/zlib/contrib/dotzlib/DotZLib/Inflater.cs ================================================================== --- compat/zlib/contrib/dotzlib/DotZLib/Inflater.cs +++ /dev/null @@ -1,105 +0,0 @@ -// -// © Copyright Henrik Ravn 2004 -// -// Use, modification and distribution are subject to the Boost Software License, Version 1.0. -// (See accompanying file LICENSE_1_0.txt or copy at http://www.boost.org/LICENSE_1_0.txt) -// - -using System; -using System.Diagnostics; -using System.Runtime.InteropServices; - -namespace DotZLib -{ - - /// - /// Implements a data decompressor, using the inflate algorithm in the ZLib dll - /// - public class Inflater : CodecBase - { - #region Dll imports - [DllImport("ZLIB1.dll", CallingConvention=CallingConvention.Cdecl, CharSet=CharSet.Ansi)] - private static extern int inflateInit_(ref ZStream sz, string vs, int size); - - [DllImport("ZLIB1.dll", CallingConvention=CallingConvention.Cdecl)] - private static extern int inflate(ref ZStream sz, int flush); - - [DllImport("ZLIB1.dll", CallingConvention=CallingConvention.Cdecl)] - private static extern int inflateReset(ref ZStream sz); - - [DllImport("ZLIB1.dll", CallingConvention=CallingConvention.Cdecl)] - private static extern int inflateEnd(ref ZStream sz); - #endregion - - /// - /// Constructs an new instance of the Inflater - /// - public Inflater() : base() - { - int retval = inflateInit_(ref _ztream, Info.Version, Marshal.SizeOf(_ztream)); - if (retval != 0) - throw new ZLibException(retval, "Could not initialize inflater"); - - resetOutput(); - } - - - /// - /// Adds more data to the codec to be processed. - /// - /// Byte array containing the data to be added to the codec - /// The index of the first byte to add from data - /// The number of bytes to add - /// Adding data may, or may not, raise the DataAvailable event - public override void Add(byte[] data, int offset, int count) - { - if (data == null) throw new ArgumentNullException(); - if (offset < 0 || count < 0) throw new ArgumentOutOfRangeException(); - if ((offset+count) > data.Length) throw new ArgumentException(); - - int total = count; - int inputIndex = offset; - int err = 0; - - while (err >= 0 && inputIndex < total) - { - copyInput(data, inputIndex, Math.Min(total - inputIndex, kBufferSize)); - err = inflate(ref _ztream, (int)FlushTypes.None); - if (err == 0) - while (_ztream.avail_out == 0) - { - OnDataAvailable(); - err = inflate(ref _ztream, (int)FlushTypes.None); - } - - inputIndex += (int)_ztream.total_in; - } - setChecksum( _ztream.adler ); - } - - - /// - /// Finishes up any pending data that needs to be processed and handled. - /// - public override void Finish() - { - int err; - do - { - err = inflate(ref _ztream, (int)FlushTypes.Finish); - OnDataAvailable(); - } - while (err == 0); - setChecksum( _ztream.adler ); - inflateReset(ref _ztream); - resetOutput(); - } - - /// - /// Closes the internal zlib inflate stream - /// - protected override void CleanUp() { inflateEnd(ref _ztream); } - - - } -} DELETED compat/zlib/contrib/dotzlib/DotZLib/UnitTests.cs Index: compat/zlib/contrib/dotzlib/DotZLib/UnitTests.cs ================================================================== --- compat/zlib/contrib/dotzlib/DotZLib/UnitTests.cs +++ /dev/null @@ -1,274 +0,0 @@ -// -// © Copyright Henrik Ravn 2004 -// -// Use, modification and distribution are subject to the Boost Software License, Version 1.0. -// (See accompanying file LICENSE_1_0.txt or copy at http://www.boost.org/LICENSE_1_0.txt) -// - -using System; -using System.Collections; -using System.IO; - -// uncomment the define below to include unit tests -//#define nunit -#if nunit -using NUnit.Framework; - -// Unit tests for the DotZLib class library -// ---------------------------------------- -// -// Use this with NUnit 2 from http://www.nunit.org -// - -namespace DotZLibTests -{ - using DotZLib; - - // helper methods - internal class Utils - { - public static bool byteArrEqual( byte[] lhs, byte[] rhs ) - { - if (lhs.Length != rhs.Length) - return false; - for (int i = lhs.Length-1; i >= 0; --i) - if (lhs[i] != rhs[i]) - return false; - return true; - } - - } - - - [TestFixture] - public class CircBufferTests - { - #region Circular buffer tests - [Test] - public void SinglePutGet() - { - CircularBuffer buf = new CircularBuffer(10); - Assert.AreEqual( 0, buf.Size ); - Assert.AreEqual( -1, buf.Get() ); - - Assert.IsTrue(buf.Put( 1 )); - Assert.AreEqual( 1, buf.Size ); - Assert.AreEqual( 1, buf.Get() ); - Assert.AreEqual( 0, buf.Size ); - Assert.AreEqual( -1, buf.Get() ); - } - - [Test] - public void BlockPutGet() - { - CircularBuffer buf = new CircularBuffer(10); - byte[] arr = {1,2,3,4,5,6,7,8,9,10}; - Assert.AreEqual( 10, buf.Put(arr,0,10) ); - Assert.AreEqual( 10, buf.Size ); - Assert.IsFalse( buf.Put(11) ); - Assert.AreEqual( 1, buf.Get() ); - Assert.IsTrue( buf.Put(11) ); - - byte[] arr2 = (byte[])arr.Clone(); - Assert.AreEqual( 9, buf.Get(arr2,1,9) ); - Assert.IsTrue( Utils.byteArrEqual(arr,arr2) ); - } - - #endregion - } - - [TestFixture] - public class ChecksumTests - { - #region CRC32 Tests - [Test] - public void CRC32_Null() - { - CRC32Checksum crc32 = new CRC32Checksum(); - Assert.AreEqual( 0, crc32.Value ); - - crc32 = new CRC32Checksum(1); - Assert.AreEqual( 1, crc32.Value ); - - crc32 = new CRC32Checksum(556); - Assert.AreEqual( 556, crc32.Value ); - } - - [Test] - public void CRC32_Data() - { - CRC32Checksum crc32 = new CRC32Checksum(); - byte[] data = { 1,2,3,4,5,6,7 }; - crc32.Update(data); - Assert.AreEqual( 0x70e46888, crc32.Value ); - - crc32 = new CRC32Checksum(); - crc32.Update("penguin"); - Assert.AreEqual( 0x0e5c1a120, crc32.Value ); - - crc32 = new CRC32Checksum(1); - crc32.Update("penguin"); - Assert.AreEqual(0x43b6aa94, crc32.Value); - - } - #endregion - - #region Adler tests - - [Test] - public void Adler_Null() - { - AdlerChecksum adler = new AdlerChecksum(); - Assert.AreEqual(0, adler.Value); - - adler = new AdlerChecksum(1); - Assert.AreEqual( 1, adler.Value ); - - adler = new AdlerChecksum(556); - Assert.AreEqual( 556, adler.Value ); - } - - [Test] - public void Adler_Data() - { - AdlerChecksum adler = new AdlerChecksum(1); - byte[] data = { 1,2,3,4,5,6,7 }; - adler.Update(data); - Assert.AreEqual( 0x5b001d, adler.Value ); - - adler = new AdlerChecksum(); - adler.Update("penguin"); - Assert.AreEqual(0x0bcf02f6, adler.Value ); - - adler = new AdlerChecksum(1); - adler.Update("penguin"); - Assert.AreEqual(0x0bd602f7, adler.Value); - - } - #endregion - } - - [TestFixture] - public class InfoTests - { - #region Info tests - [Test] - public void Info_Version() - { - Info info = new Info(); - Assert.AreEqual("1.2.11", Info.Version); - Assert.AreEqual(32, info.SizeOfUInt); - Assert.AreEqual(32, info.SizeOfULong); - Assert.AreEqual(32, info.SizeOfPointer); - Assert.AreEqual(32, info.SizeOfOffset); - } - #endregion - } - - [TestFixture] - public class DeflateInflateTests - { - #region Deflate tests - [Test] - public void Deflate_Init() - { - using (Deflater def = new Deflater(CompressLevel.Default)) - { - } - } - - private ArrayList compressedData = new ArrayList(); - private uint adler1; - - private ArrayList uncompressedData = new ArrayList(); - private uint adler2; - - public void CDataAvail(byte[] data, int startIndex, int count) - { - for (int i = 0; i < count; ++i) - compressedData.Add(data[i+startIndex]); - } - - [Test] - public void Deflate_Compress() - { - compressedData.Clear(); - - byte[] testData = new byte[35000]; - for (int i = 0; i < testData.Length; ++i) - testData[i] = 5; - - using (Deflater def = new Deflater((CompressLevel)5)) - { - def.DataAvailable += new DataAvailableHandler(CDataAvail); - def.Add(testData); - def.Finish(); - adler1 = def.Checksum; - } - } - #endregion - - #region Inflate tests - [Test] - public void Inflate_Init() - { - using (Inflater inf = new Inflater()) - { - } - } - - private void DDataAvail(byte[] data, int startIndex, int count) - { - for (int i = 0; i < count; ++i) - uncompressedData.Add(data[i+startIndex]); - } - - [Test] - public void Inflate_Expand() - { - uncompressedData.Clear(); - - using (Inflater inf = new Inflater()) - { - inf.DataAvailable += new DataAvailableHandler(DDataAvail); - inf.Add((byte[])compressedData.ToArray(typeof(byte))); - inf.Finish(); - adler2 = inf.Checksum; - } - Assert.AreEqual( adler1, adler2 ); - } - #endregion - } - - [TestFixture] - public class GZipStreamTests - { - #region GZipStream test - [Test] - public void GZipStream_WriteRead() - { - using (GZipStream gzOut = new GZipStream("gzstream.gz", CompressLevel.Best)) - { - BinaryWriter writer = new BinaryWriter(gzOut); - writer.Write("hi there"); - writer.Write(Math.PI); - writer.Write(42); - } - - using (GZipStream gzIn = new GZipStream("gzstream.gz")) - { - BinaryReader reader = new BinaryReader(gzIn); - string s = reader.ReadString(); - Assert.AreEqual("hi there",s); - double d = reader.ReadDouble(); - Assert.AreEqual(Math.PI, d); - int i = reader.ReadInt32(); - Assert.AreEqual(42,i); - } - - } - #endregion - } -} - -#endif DELETED compat/zlib/contrib/dotzlib/LICENSE_1_0.txt Index: compat/zlib/contrib/dotzlib/LICENSE_1_0.txt ================================================================== --- compat/zlib/contrib/dotzlib/LICENSE_1_0.txt +++ /dev/null @@ -1,23 +0,0 @@ -Boost Software License - Version 1.0 - August 17th, 2003 - -Permission is hereby granted, free of charge, to any person or organization -obtaining a copy of the software and accompanying documentation covered by -this license (the "Software") to use, reproduce, display, distribute, -execute, and transmit the Software, and to prepare derivative works of the -Software, and to permit third-parties to whom the Software is furnished to -do so, all subject to the following: - -The copyright notices in the Software and this entire statement, including -the above license grant, this restriction and the following disclaimer, -must be included in all copies of the Software, in whole or in part, and -all derivative works of the Software, unless such copies or derivative -works are solely in the form of machine-executable object code generated by -a source language processor. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE, TITLE AND NON-INFRINGEMENT. IN NO EVENT -SHALL THE COPYRIGHT HOLDERS OR ANYONE DISTRIBUTING THE SOFTWARE BE LIABLE -FOR ANY DAMAGES OR OTHER LIABILITY, WHETHER IN CONTRACT, TORT OR OTHERWISE, -ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER -DEALINGS IN THE SOFTWARE. DELETED compat/zlib/contrib/dotzlib/readme.txt Index: compat/zlib/contrib/dotzlib/readme.txt ================================================================== --- compat/zlib/contrib/dotzlib/readme.txt +++ /dev/null @@ -1,58 +0,0 @@ -This directory contains a .Net wrapper class library for the ZLib1.dll - -The wrapper includes support for inflating/deflating memory buffers, -.Net streaming wrappers for the gz streams part of zlib, and wrappers -for the checksum parts of zlib. See DotZLib/UnitTests.cs for examples. - -Directory structure: --------------------- - -LICENSE_1_0.txt - License file. -readme.txt - This file. -DotZLib.chm - Class library documentation -DotZLib.build - NAnt build file -DotZLib.sln - Microsoft Visual Studio 2003 solution file - -DotZLib\*.cs - Source files for the class library - -Unit tests: ------------ -The file DotZLib/UnitTests.cs contains unit tests for use with NUnit 2.1 or higher. -To include unit tests in the build, define nunit before building. - - -Build instructions: -------------------- - -1. Using Visual Studio.Net 2003: - Open DotZLib.sln in VS.Net and build from there. Output file (DotZLib.dll) - will be found ./DotZLib/bin/release or ./DotZLib/bin/debug, depending on - you are building the release or debug version of the library. Check - DotZLib/UnitTests.cs for instructions on how to include unit tests in the - build. - -2. Using NAnt: - Open a command prompt with access to the build environment and run nant - in the same directory as the DotZLib.build file. - You can define 2 properties on the nant command-line to control the build: - debug={true|false} to toggle between release/debug builds (default=true). - nunit={true|false} to include or esclude unit tests (default=true). - Also the target clean will remove binaries. - Output file (DotZLib.dll) will be found in either ./DotZLib/bin/release - or ./DotZLib/bin/debug, depending on whether you are building the release - or debug version of the library. - - Examples: - nant -D:debug=false -D:nunit=false - will build a release mode version of the library without unit tests. - nant - will build a debug version of the library with unit tests - nant clean - will remove all previously built files. - - ---------------------------------- -Copyright (c) Henrik Ravn 2004 - -Use, modification and distribution are subject to the Boost Software License, Version 1.0. -(See accompanying file LICENSE_1_0.txt or copy at http://www.boost.org/LICENSE_1_0.txt) DELETED compat/zlib/contrib/gcc_gvmat64/gvmat64.S Index: compat/zlib/contrib/gcc_gvmat64/gvmat64.S ================================================================== --- compat/zlib/contrib/gcc_gvmat64/gvmat64.S +++ /dev/null @@ -1,574 +0,0 @@ -/* -;uInt longest_match_x64( -; deflate_state *s, -; IPos cur_match); // current match - -; gvmat64.S -- Asm portion of the optimized longest_match for 32 bits x86_64 -; (AMD64 on Athlon 64, Opteron, Phenom -; and Intel EM64T on Pentium 4 with EM64T, Pentium D, Core 2 Duo, Core I5/I7) -; this file is translation from gvmat64.asm to GCC 4.x (for Linux, Mac XCode) -; Copyright (C) 1995-2010 Jean-loup Gailly, Brian Raiter and Gilles Vollant. -; -; File written by Gilles Vollant, by converting to assembly the longest_match -; from Jean-loup Gailly in deflate.c of zLib and infoZip zip. -; and by taking inspiration on asm686 with masm, optimised assembly code -; from Brian Raiter, written 1998 -; -; This software is provided 'as-is', without any express or implied -; warranty. In no event will the authors be held liable for any damages -; arising from the use of this software. -; -; Permission is granted to anyone to use this software for any purpose, -; including commercial applications, and to alter it and redistribute it -; freely, subject to the following restrictions: -; -; 1. The origin of this software must not be misrepresented; you must not -; claim that you wrote the original software. If you use this software -; in a product, an acknowledgment in the product documentation would be -; appreciated but is not required. -; 2. Altered source versions must be plainly marked as such, and must not be -; misrepresented as being the original software -; 3. This notice may not be removed or altered from any source distribution. -; -; http://www.zlib.net -; http://www.winimage.com/zLibDll -; http://www.muppetlabs.com/~breadbox/software/assembly.html -; -; to compile this file for zLib, I use option: -; gcc -c -arch x86_64 gvmat64.S - - -;uInt longest_match(s, cur_match) -; deflate_state *s; -; IPos cur_match; // current match / -; -; with XCode for Mac, I had strange error with some jump on intel syntax -; this is why BEFORE_JMP and AFTER_JMP are used - */ - - -#define BEFORE_JMP .att_syntax -#define AFTER_JMP .intel_syntax noprefix - -#ifndef NO_UNDERLINE -# define match_init _match_init -# define longest_match _longest_match -#endif - -.intel_syntax noprefix - -.globl match_init, longest_match -.text -longest_match: - - - -#define LocalVarsSize 96 -/* -; register used : rax,rbx,rcx,rdx,rsi,rdi,r8,r9,r10,r11,r12 -; free register : r14,r15 -; register can be saved : rsp -*/ - -#define chainlenwmask (rsp + 8 - LocalVarsSize) -#define nicematch (rsp + 16 - LocalVarsSize) - -#define save_rdi (rsp + 24 - LocalVarsSize) -#define save_rsi (rsp + 32 - LocalVarsSize) -#define save_rbx (rsp + 40 - LocalVarsSize) -#define save_rbp (rsp + 48 - LocalVarsSize) -#define save_r12 (rsp + 56 - LocalVarsSize) -#define save_r13 (rsp + 64 - LocalVarsSize) -#define save_r14 (rsp + 72 - LocalVarsSize) -#define save_r15 (rsp + 80 - LocalVarsSize) - - -/* -; all the +4 offsets are due to the addition of pending_buf_size (in zlib -; in the deflate_state structure since the asm code was first written -; (if you compile with zlib 1.0.4 or older, remove the +4). -; Note : these value are good with a 8 bytes boundary pack structure -*/ - -#define MAX_MATCH 258 -#define MIN_MATCH 3 -#define MIN_LOOKAHEAD (MAX_MATCH+MIN_MATCH+1) - -/* -;;; Offsets for fields in the deflate_state structure. These numbers -;;; are calculated from the definition of deflate_state, with the -;;; assumption that the compiler will dword-align the fields. (Thus, -;;; changing the definition of deflate_state could easily cause this -;;; program to crash horribly, without so much as a warning at -;;; compile time. Sigh.) - -; all the +zlib1222add offsets are due to the addition of fields -; in zlib in the deflate_state structure since the asm code was first written -; (if you compile with zlib 1.0.4 or older, use "zlib1222add equ (-4)"). -; (if you compile with zlib between 1.0.5 and 1.2.2.1, use "zlib1222add equ 0"). -; if you compile with zlib 1.2.2.2 or later , use "zlib1222add equ 8"). -*/ - - - -/* you can check the structure offset by running - -#include -#include -#include "deflate.h" - -void print_depl() -{ -deflate_state ds; -deflate_state *s=&ds; -printf("size pointer=%u\n",(int)sizeof(void*)); - -printf("#define dsWSize %u\n",(int)(((char*)&(s->w_size))-((char*)s))); -printf("#define dsWMask %u\n",(int)(((char*)&(s->w_mask))-((char*)s))); -printf("#define dsWindow %u\n",(int)(((char*)&(s->window))-((char*)s))); -printf("#define dsPrev %u\n",(int)(((char*)&(s->prev))-((char*)s))); -printf("#define dsMatchLen %u\n",(int)(((char*)&(s->match_length))-((char*)s))); -printf("#define dsPrevMatch %u\n",(int)(((char*)&(s->prev_match))-((char*)s))); -printf("#define dsStrStart %u\n",(int)(((char*)&(s->strstart))-((char*)s))); -printf("#define dsMatchStart %u\n",(int)(((char*)&(s->match_start))-((char*)s))); -printf("#define dsLookahead %u\n",(int)(((char*)&(s->lookahead))-((char*)s))); -printf("#define dsPrevLen %u\n",(int)(((char*)&(s->prev_length))-((char*)s))); -printf("#define dsMaxChainLen %u\n",(int)(((char*)&(s->max_chain_length))-((char*)s))); -printf("#define dsGoodMatch %u\n",(int)(((char*)&(s->good_match))-((char*)s))); -printf("#define dsNiceMatch %u\n",(int)(((char*)&(s->nice_match))-((char*)s))); -} -*/ - -#define dsWSize 68 -#define dsWMask 76 -#define dsWindow 80 -#define dsPrev 96 -#define dsMatchLen 144 -#define dsPrevMatch 148 -#define dsStrStart 156 -#define dsMatchStart 160 -#define dsLookahead 164 -#define dsPrevLen 168 -#define dsMaxChainLen 172 -#define dsGoodMatch 188 -#define dsNiceMatch 192 - -#define window_size [ rcx + dsWSize] -#define WMask [ rcx + dsWMask] -#define window_ad [ rcx + dsWindow] -#define prev_ad [ rcx + dsPrev] -#define strstart [ rcx + dsStrStart] -#define match_start [ rcx + dsMatchStart] -#define Lookahead [ rcx + dsLookahead] //; 0ffffffffh on infozip -#define prev_length [ rcx + dsPrevLen] -#define max_chain_length [ rcx + dsMaxChainLen] -#define good_match [ rcx + dsGoodMatch] -#define nice_match [ rcx + dsNiceMatch] - -/* -; windows: -; parameter 1 in rcx(deflate state s), param 2 in rdx (cur match) - -; see http://weblogs.asp.net/oldnewthing/archive/2004/01/14/58579.aspx and -; http://msdn.microsoft.com/library/en-us/kmarch/hh/kmarch/64bitAMD_8e951dd2-ee77-4728-8702-55ce4b5dd24a.xml.asp -; -; All registers must be preserved across the call, except for -; rax, rcx, rdx, r8, r9, r10, and r11, which are scratch. - -; -; gcc on macosx-linux: -; see http://www.x86-64.org/documentation/abi-0.99.pdf -; param 1 in rdi, param 2 in rsi -; rbx, rsp, rbp, r12 to r15 must be preserved - -;;; Save registers that the compiler may be using, and adjust esp to -;;; make room for our stack frame. - - -;;; Retrieve the function arguments. r8d will hold cur_match -;;; throughout the entire function. edx will hold the pointer to the -;;; deflate_state structure during the function's setup (before -;;; entering the main loop. - -; ms: parameter 1 in rcx (deflate_state* s), param 2 in edx -> r8 (cur match) -; mac: param 1 in rdi, param 2 rsi -; this clear high 32 bits of r8, which can be garbage in both r8 and rdx -*/ - mov [save_rbx],rbx - mov [save_rbp],rbp - - - mov rcx,rdi - - mov r8d,esi - - - mov [save_r12],r12 - mov [save_r13],r13 - mov [save_r14],r14 - mov [save_r15],r15 - - -//;;; uInt wmask = s->w_mask; -//;;; unsigned chain_length = s->max_chain_length; -//;;; if (s->prev_length >= s->good_match) { -//;;; chain_length >>= 2; -//;;; } - - - mov edi, prev_length - mov esi, good_match - mov eax, WMask - mov ebx, max_chain_length - cmp edi, esi - jl LastMatchGood - shr ebx, 2 -LastMatchGood: - -//;;; chainlen is decremented once beforehand so that the function can -//;;; use the sign flag instead of the zero flag for the exit test. -//;;; It is then shifted into the high word, to make room for the wmask -//;;; value, which it will always accompany. - - dec ebx - shl ebx, 16 - or ebx, eax - -//;;; on zlib only -//;;; if ((uInt)nice_match > s->lookahead) nice_match = s->lookahead; - - - - mov eax, nice_match - mov [chainlenwmask], ebx - mov r10d, Lookahead - cmp r10d, eax - cmovnl r10d, eax - mov [nicematch],r10d - - - -//;;; register Bytef *scan = s->window + s->strstart; - mov r10, window_ad - mov ebp, strstart - lea r13, [r10 + rbp] - -//;;; Determine how many bytes the scan ptr is off from being -//;;; dword-aligned. - - mov r9,r13 - neg r13 - and r13,3 - -//;;; IPos limit = s->strstart > (IPos)MAX_DIST(s) ? -//;;; s->strstart - (IPos)MAX_DIST(s) : NIL; - - - mov eax, window_size - sub eax, MIN_LOOKAHEAD - - - xor edi,edi - sub ebp, eax - - mov r11d, prev_length - - cmovng ebp,edi - -//;;; int best_len = s->prev_length; - - -//;;; Store the sum of s->window + best_len in esi locally, and in esi. - - lea rsi,[r10+r11] - -//;;; register ush scan_start = *(ushf*)scan; -//;;; register ush scan_end = *(ushf*)(scan+best_len-1); -//;;; Posf *prev = s->prev; - - movzx r12d,word ptr [r9] - movzx ebx, word ptr [r9 + r11 - 1] - - mov rdi, prev_ad - -//;;; Jump into the main loop. - - mov edx, [chainlenwmask] - - cmp bx,word ptr [rsi + r8 - 1] - jz LookupLoopIsZero - - - -LookupLoop1: - and r8d, edx - - movzx r8d, word ptr [rdi + r8*2] - cmp r8d, ebp - jbe LeaveNow - - - - sub edx, 0x00010000 - BEFORE_JMP - js LeaveNow - AFTER_JMP - -LoopEntry1: - cmp bx,word ptr [rsi + r8 - 1] - BEFORE_JMP - jz LookupLoopIsZero - AFTER_JMP - -LookupLoop2: - and r8d, edx - - movzx r8d, word ptr [rdi + r8*2] - cmp r8d, ebp - BEFORE_JMP - jbe LeaveNow - AFTER_JMP - sub edx, 0x00010000 - BEFORE_JMP - js LeaveNow - AFTER_JMP - -LoopEntry2: - cmp bx,word ptr [rsi + r8 - 1] - BEFORE_JMP - jz LookupLoopIsZero - AFTER_JMP - -LookupLoop4: - and r8d, edx - - movzx r8d, word ptr [rdi + r8*2] - cmp r8d, ebp - BEFORE_JMP - jbe LeaveNow - AFTER_JMP - sub edx, 0x00010000 - BEFORE_JMP - js LeaveNow - AFTER_JMP - -LoopEntry4: - - cmp bx,word ptr [rsi + r8 - 1] - BEFORE_JMP - jnz LookupLoop1 - jmp LookupLoopIsZero - AFTER_JMP -/* -;;; do { -;;; match = s->window + cur_match; -;;; if (*(ushf*)(match+best_len-1) != scan_end || -;;; *(ushf*)match != scan_start) continue; -;;; [...] -;;; } while ((cur_match = prev[cur_match & wmask]) > limit -;;; && --chain_length != 0); -;;; -;;; Here is the inner loop of the function. The function will spend the -;;; majority of its time in this loop, and majority of that time will -;;; be spent in the first ten instructions. -;;; -;;; Within this loop: -;;; ebx = scanend -;;; r8d = curmatch -;;; edx = chainlenwmask - i.e., ((chainlen << 16) | wmask) -;;; esi = windowbestlen - i.e., (window + bestlen) -;;; edi = prev -;;; ebp = limit -*/ -.balign 16 -LookupLoop: - and r8d, edx - - movzx r8d, word ptr [rdi + r8*2] - cmp r8d, ebp - BEFORE_JMP - jbe LeaveNow - AFTER_JMP - sub edx, 0x00010000 - BEFORE_JMP - js LeaveNow - AFTER_JMP - -LoopEntry: - - cmp bx,word ptr [rsi + r8 - 1] - BEFORE_JMP - jnz LookupLoop1 - AFTER_JMP -LookupLoopIsZero: - cmp r12w, word ptr [r10 + r8] - BEFORE_JMP - jnz LookupLoop1 - AFTER_JMP - - -//;;; Store the current value of chainlen. - mov [chainlenwmask], edx -/* -;;; Point edi to the string under scrutiny, and esi to the string we -;;; are hoping to match it up with. In actuality, esi and edi are -;;; both pointed (MAX_MATCH_8 - scanalign) bytes ahead, and edx is -;;; initialized to -(MAX_MATCH_8 - scanalign). -*/ - lea rsi,[r8+r10] - mov rdx, 0xfffffffffffffef8 //; -(MAX_MATCH_8) - lea rsi, [rsi + r13 + 0x0108] //;MAX_MATCH_8] - lea rdi, [r9 + r13 + 0x0108] //;MAX_MATCH_8] - - prefetcht1 [rsi+rdx] - prefetcht1 [rdi+rdx] - -/* -;;; Test the strings for equality, 8 bytes at a time. At the end, -;;; adjust rdx so that it is offset to the exact byte that mismatched. -;;; -;;; We already know at this point that the first three bytes of the -;;; strings match each other, and they can be safely passed over before -;;; starting the compare loop. So what this code does is skip over 0-3 -;;; bytes, as much as necessary in order to dword-align the edi -;;; pointer. (rsi will still be misaligned three times out of four.) -;;; -;;; It should be confessed that this loop usually does not represent -;;; much of the total running time. Replacing it with a more -;;; straightforward "rep cmpsb" would not drastically degrade -;;; performance. -*/ - -LoopCmps: - mov rax, [rsi + rdx] - xor rax, [rdi + rdx] - jnz LeaveLoopCmps - - mov rax, [rsi + rdx + 8] - xor rax, [rdi + rdx + 8] - jnz LeaveLoopCmps8 - - - mov rax, [rsi + rdx + 8+8] - xor rax, [rdi + rdx + 8+8] - jnz LeaveLoopCmps16 - - add rdx,8+8+8 - - BEFORE_JMP - jnz LoopCmps - jmp LenMaximum - AFTER_JMP - -LeaveLoopCmps16: add rdx,8 -LeaveLoopCmps8: add rdx,8 -LeaveLoopCmps: - - test eax, 0x0000FFFF - jnz LenLower - - test eax,0xffffffff - - jnz LenLower32 - - add rdx,4 - shr rax,32 - or ax,ax - BEFORE_JMP - jnz LenLower - AFTER_JMP - -LenLower32: - shr eax,16 - add rdx,2 - -LenLower: - sub al, 1 - adc rdx, 0 -//;;; Calculate the length of the match. If it is longer than MAX_MATCH, -//;;; then automatically accept it as the best possible match and leave. - - lea rax, [rdi + rdx] - sub rax, r9 - cmp eax, MAX_MATCH - BEFORE_JMP - jge LenMaximum - AFTER_JMP -/* -;;; If the length of the match is not longer than the best match we -;;; have so far, then forget it and return to the lookup loop. -;/////////////////////////////////// -*/ - cmp eax, r11d - jg LongerMatch - - lea rsi,[r10+r11] - - mov rdi, prev_ad - mov edx, [chainlenwmask] - BEFORE_JMP - jmp LookupLoop - AFTER_JMP -/* -;;; s->match_start = cur_match; -;;; best_len = len; -;;; if (len >= nice_match) break; -;;; scan_end = *(ushf*)(scan+best_len-1); -*/ -LongerMatch: - mov r11d, eax - mov match_start, r8d - cmp eax, [nicematch] - BEFORE_JMP - jge LeaveNow - AFTER_JMP - - lea rsi,[r10+rax] - - movzx ebx, word ptr [r9 + rax - 1] - mov rdi, prev_ad - mov edx, [chainlenwmask] - BEFORE_JMP - jmp LookupLoop - AFTER_JMP - -//;;; Accept the current string, with the maximum possible length. - -LenMaximum: - mov r11d,MAX_MATCH - mov match_start, r8d - -//;;; if ((uInt)best_len <= s->lookahead) return (uInt)best_len; -//;;; return s->lookahead; - -LeaveNow: - mov eax, Lookahead - cmp r11d, eax - cmovng eax, r11d - - - -//;;; Restore the stack and return from whence we came. - - -// mov rsi,[save_rsi] -// mov rdi,[save_rdi] - mov rbx,[save_rbx] - mov rbp,[save_rbp] - mov r12,[save_r12] - mov r13,[save_r13] - mov r14,[save_r14] - mov r15,[save_r15] - - - ret 0 -//; please don't remove this string ! -//; Your can freely use gvmat64 in any free or commercial app -//; but it is far better don't remove the string in the binary! - // db 0dh,0ah,"asm686 with masm, optimised assembly code from Brian Raiter, written 1998, converted to amd 64 by Gilles Vollant 2005",0dh,0ah,0 - - -match_init: - ret 0 - - DELETED compat/zlib/contrib/infback9/README Index: compat/zlib/contrib/infback9/README ================================================================== --- compat/zlib/contrib/infback9/README +++ /dev/null @@ -1,1 +0,0 @@ -See infback9.h for what this is and how to use it. DELETED compat/zlib/contrib/infback9/infback9.c Index: compat/zlib/contrib/infback9/infback9.c ================================================================== --- compat/zlib/contrib/infback9/infback9.c +++ /dev/null @@ -1,615 +0,0 @@ -/* infback9.c -- inflate deflate64 data using a call-back interface - * Copyright (C) 1995-2008 Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -#include "zutil.h" -#include "infback9.h" -#include "inftree9.h" -#include "inflate9.h" - -#define WSIZE 65536UL - -/* - strm provides memory allocation functions in zalloc and zfree, or - Z_NULL to use the library memory allocation functions. - - window is a user-supplied window and output buffer that is 64K bytes. - */ -int ZEXPORT inflateBack9Init_(strm, window, version, stream_size) -z_stream FAR *strm; -unsigned char FAR *window; -const char *version; -int stream_size; -{ - struct inflate_state FAR *state; - - if (version == Z_NULL || version[0] != ZLIB_VERSION[0] || - stream_size != (int)(sizeof(z_stream))) - return Z_VERSION_ERROR; - if (strm == Z_NULL || window == Z_NULL) - return Z_STREAM_ERROR; - strm->msg = Z_NULL; /* in case we return an error */ - if (strm->zalloc == (alloc_func)0) { - strm->zalloc = zcalloc; - strm->opaque = (voidpf)0; - } - if (strm->zfree == (free_func)0) strm->zfree = zcfree; - state = (struct inflate_state FAR *)ZALLOC(strm, 1, - sizeof(struct inflate_state)); - if (state == Z_NULL) return Z_MEM_ERROR; - Tracev((stderr, "inflate: allocated\n")); - strm->state = (voidpf)state; - state->window = window; - return Z_OK; -} - -/* - Build and output length and distance decoding tables for fixed code - decoding. - */ -#ifdef MAKEFIXED -#include - -void makefixed9(void) -{ - unsigned sym, bits, low, size; - code *next, *lenfix, *distfix; - struct inflate_state state; - code fixed[544]; - - /* literal/length table */ - sym = 0; - while (sym < 144) state.lens[sym++] = 8; - while (sym < 256) state.lens[sym++] = 9; - while (sym < 280) state.lens[sym++] = 7; - while (sym < 288) state.lens[sym++] = 8; - next = fixed; - lenfix = next; - bits = 9; - inflate_table9(LENS, state.lens, 288, &(next), &(bits), state.work); - - /* distance table */ - sym = 0; - while (sym < 32) state.lens[sym++] = 5; - distfix = next; - bits = 5; - inflate_table9(DISTS, state.lens, 32, &(next), &(bits), state.work); - - /* write tables */ - puts(" /* inffix9.h -- table for decoding deflate64 fixed codes"); - puts(" * Generated automatically by makefixed9()."); - puts(" */"); - puts(""); - puts(" /* WARNING: this file should *not* be used by applications."); - puts(" It is part of the implementation of this library and is"); - puts(" subject to change. Applications should only use zlib.h."); - puts(" */"); - puts(""); - size = 1U << 9; - printf(" static const code lenfix[%u] = {", size); - low = 0; - for (;;) { - if ((low % 6) == 0) printf("\n "); - printf("{%u,%u,%d}", lenfix[low].op, lenfix[low].bits, - lenfix[low].val); - if (++low == size) break; - putchar(','); - } - puts("\n };"); - size = 1U << 5; - printf("\n static const code distfix[%u] = {", size); - low = 0; - for (;;) { - if ((low % 5) == 0) printf("\n "); - printf("{%u,%u,%d}", distfix[low].op, distfix[low].bits, - distfix[low].val); - if (++low == size) break; - putchar(','); - } - puts("\n };"); -} -#endif /* MAKEFIXED */ - -/* Macros for inflateBack(): */ - -/* Clear the input bit accumulator */ -#define INITBITS() \ - do { \ - hold = 0; \ - bits = 0; \ - } while (0) - -/* Assure that some input is available. If input is requested, but denied, - then return a Z_BUF_ERROR from inflateBack(). */ -#define PULL() \ - do { \ - if (have == 0) { \ - have = in(in_desc, &next); \ - if (have == 0) { \ - next = Z_NULL; \ - ret = Z_BUF_ERROR; \ - goto inf_leave; \ - } \ - } \ - } while (0) - -/* Get a byte of input into the bit accumulator, or return from inflateBack() - with an error if there is no input available. */ -#define PULLBYTE() \ - do { \ - PULL(); \ - have--; \ - hold += (unsigned long)(*next++) << bits; \ - bits += 8; \ - } while (0) - -/* Assure that there are at least n bits in the bit accumulator. If there is - not enough available input to do that, then return from inflateBack() with - an error. */ -#define NEEDBITS(n) \ - do { \ - while (bits < (unsigned)(n)) \ - PULLBYTE(); \ - } while (0) - -/* Return the low n bits of the bit accumulator (n <= 16) */ -#define BITS(n) \ - ((unsigned)hold & ((1U << (n)) - 1)) - -/* Remove n bits from the bit accumulator */ -#define DROPBITS(n) \ - do { \ - hold >>= (n); \ - bits -= (unsigned)(n); \ - } while (0) - -/* Remove zero to seven bits as needed to go to a byte boundary */ -#define BYTEBITS() \ - do { \ - hold >>= bits & 7; \ - bits -= bits & 7; \ - } while (0) - -/* Assure that some output space is available, by writing out the window - if it's full. If the write fails, return from inflateBack() with a - Z_BUF_ERROR. */ -#define ROOM() \ - do { \ - if (left == 0) { \ - put = window; \ - left = WSIZE; \ - wrap = 1; \ - if (out(out_desc, put, (unsigned)left)) { \ - ret = Z_BUF_ERROR; \ - goto inf_leave; \ - } \ - } \ - } while (0) - -/* - strm provides the memory allocation functions and window buffer on input, - and provides information on the unused input on return. For Z_DATA_ERROR - returns, strm will also provide an error message. - - in() and out() are the call-back input and output functions. When - inflateBack() needs more input, it calls in(). When inflateBack() has - filled the window with output, or when it completes with data in the - window, it calls out() to write out the data. The application must not - change the provided input until in() is called again or inflateBack() - returns. The application must not change the window/output buffer until - inflateBack() returns. - - in() and out() are called with a descriptor parameter provided in the - inflateBack() call. This parameter can be a structure that provides the - information required to do the read or write, as well as accumulated - information on the input and output such as totals and check values. - - in() should return zero on failure. out() should return non-zero on - failure. If either in() or out() fails, than inflateBack() returns a - Z_BUF_ERROR. strm->next_in can be checked for Z_NULL to see whether it - was in() or out() that caused in the error. Otherwise, inflateBack() - returns Z_STREAM_END on success, Z_DATA_ERROR for an deflate format - error, or Z_MEM_ERROR if it could not allocate memory for the state. - inflateBack() can also return Z_STREAM_ERROR if the input parameters - are not correct, i.e. strm is Z_NULL or the state was not initialized. - */ -int ZEXPORT inflateBack9(strm, in, in_desc, out, out_desc) -z_stream FAR *strm; -in_func in; -void FAR *in_desc; -out_func out; -void FAR *out_desc; -{ - struct inflate_state FAR *state; - z_const unsigned char FAR *next; /* next input */ - unsigned char FAR *put; /* next output */ - unsigned have; /* available input */ - unsigned long left; /* available output */ - inflate_mode mode; /* current inflate mode */ - int lastblock; /* true if processing last block */ - int wrap; /* true if the window has wrapped */ - unsigned char FAR *window; /* allocated sliding window, if needed */ - unsigned long hold; /* bit buffer */ - unsigned bits; /* bits in bit buffer */ - unsigned extra; /* extra bits needed */ - unsigned long length; /* literal or length of data to copy */ - unsigned long offset; /* distance back to copy string from */ - unsigned long copy; /* number of stored or match bytes to copy */ - unsigned char FAR *from; /* where to copy match bytes from */ - code const FAR *lencode; /* starting table for length/literal codes */ - code const FAR *distcode; /* starting table for distance codes */ - unsigned lenbits; /* index bits for lencode */ - unsigned distbits; /* index bits for distcode */ - code here; /* current decoding table entry */ - code last; /* parent table entry */ - unsigned len; /* length to copy for repeats, bits to drop */ - int ret; /* return code */ - static const unsigned short order[19] = /* permutation of code lengths */ - {16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15}; -#include "inffix9.h" - - /* Check that the strm exists and that the state was initialized */ - if (strm == Z_NULL || strm->state == Z_NULL) - return Z_STREAM_ERROR; - state = (struct inflate_state FAR *)strm->state; - - /* Reset the state */ - strm->msg = Z_NULL; - mode = TYPE; - lastblock = 0; - wrap = 0; - window = state->window; - next = strm->next_in; - have = next != Z_NULL ? strm->avail_in : 0; - hold = 0; - bits = 0; - put = window; - left = WSIZE; - lencode = Z_NULL; - distcode = Z_NULL; - - /* Inflate until end of block marked as last */ - for (;;) - switch (mode) { - case TYPE: - /* determine and dispatch block type */ - if (lastblock) { - BYTEBITS(); - mode = DONE; - break; - } - NEEDBITS(3); - lastblock = BITS(1); - DROPBITS(1); - switch (BITS(2)) { - case 0: /* stored block */ - Tracev((stderr, "inflate: stored block%s\n", - lastblock ? " (last)" : "")); - mode = STORED; - break; - case 1: /* fixed block */ - lencode = lenfix; - lenbits = 9; - distcode = distfix; - distbits = 5; - Tracev((stderr, "inflate: fixed codes block%s\n", - lastblock ? " (last)" : "")); - mode = LEN; /* decode codes */ - break; - case 2: /* dynamic block */ - Tracev((stderr, "inflate: dynamic codes block%s\n", - lastblock ? " (last)" : "")); - mode = TABLE; - break; - case 3: - strm->msg = (char *)"invalid block type"; - mode = BAD; - } - DROPBITS(2); - break; - - case STORED: - /* get and verify stored block length */ - BYTEBITS(); /* go to byte boundary */ - NEEDBITS(32); - if ((hold & 0xffff) != ((hold >> 16) ^ 0xffff)) { - strm->msg = (char *)"invalid stored block lengths"; - mode = BAD; - break; - } - length = (unsigned)hold & 0xffff; - Tracev((stderr, "inflate: stored length %lu\n", - length)); - INITBITS(); - - /* copy stored block from input to output */ - while (length != 0) { - copy = length; - PULL(); - ROOM(); - if (copy > have) copy = have; - if (copy > left) copy = left; - zmemcpy(put, next, copy); - have -= copy; - next += copy; - left -= copy; - put += copy; - length -= copy; - } - Tracev((stderr, "inflate: stored end\n")); - mode = TYPE; - break; - - case TABLE: - /* get dynamic table entries descriptor */ - NEEDBITS(14); - state->nlen = BITS(5) + 257; - DROPBITS(5); - state->ndist = BITS(5) + 1; - DROPBITS(5); - state->ncode = BITS(4) + 4; - DROPBITS(4); - if (state->nlen > 286) { - strm->msg = (char *)"too many length symbols"; - mode = BAD; - break; - } - Tracev((stderr, "inflate: table sizes ok\n")); - - /* get code length code lengths (not a typo) */ - state->have = 0; - while (state->have < state->ncode) { - NEEDBITS(3); - state->lens[order[state->have++]] = (unsigned short)BITS(3); - DROPBITS(3); - } - while (state->have < 19) - state->lens[order[state->have++]] = 0; - state->next = state->codes; - lencode = (code const FAR *)(state->next); - lenbits = 7; - ret = inflate_table9(CODES, state->lens, 19, &(state->next), - &(lenbits), state->work); - if (ret) { - strm->msg = (char *)"invalid code lengths set"; - mode = BAD; - break; - } - Tracev((stderr, "inflate: code lengths ok\n")); - - /* get length and distance code code lengths */ - state->have = 0; - while (state->have < state->nlen + state->ndist) { - for (;;) { - here = lencode[BITS(lenbits)]; - if ((unsigned)(here.bits) <= bits) break; - PULLBYTE(); - } - if (here.val < 16) { - NEEDBITS(here.bits); - DROPBITS(here.bits); - state->lens[state->have++] = here.val; - } - else { - if (here.val == 16) { - NEEDBITS(here.bits + 2); - DROPBITS(here.bits); - if (state->have == 0) { - strm->msg = (char *)"invalid bit length repeat"; - mode = BAD; - break; - } - len = (unsigned)(state->lens[state->have - 1]); - copy = 3 + BITS(2); - DROPBITS(2); - } - else if (here.val == 17) { - NEEDBITS(here.bits + 3); - DROPBITS(here.bits); - len = 0; - copy = 3 + BITS(3); - DROPBITS(3); - } - else { - NEEDBITS(here.bits + 7); - DROPBITS(here.bits); - len = 0; - copy = 11 + BITS(7); - DROPBITS(7); - } - if (state->have + copy > state->nlen + state->ndist) { - strm->msg = (char *)"invalid bit length repeat"; - mode = BAD; - break; - } - while (copy--) - state->lens[state->have++] = (unsigned short)len; - } - } - - /* handle error breaks in while */ - if (mode == BAD) break; - - /* check for end-of-block code (better have one) */ - if (state->lens[256] == 0) { - strm->msg = (char *)"invalid code -- missing end-of-block"; - mode = BAD; - break; - } - - /* build code tables -- note: do not change the lenbits or distbits - values here (9 and 6) without reading the comments in inftree9.h - concerning the ENOUGH constants, which depend on those values */ - state->next = state->codes; - lencode = (code const FAR *)(state->next); - lenbits = 9; - ret = inflate_table9(LENS, state->lens, state->nlen, - &(state->next), &(lenbits), state->work); - if (ret) { - strm->msg = (char *)"invalid literal/lengths set"; - mode = BAD; - break; - } - distcode = (code const FAR *)(state->next); - distbits = 6; - ret = inflate_table9(DISTS, state->lens + state->nlen, - state->ndist, &(state->next), &(distbits), - state->work); - if (ret) { - strm->msg = (char *)"invalid distances set"; - mode = BAD; - break; - } - Tracev((stderr, "inflate: codes ok\n")); - mode = LEN; - - case LEN: - /* get a literal, length, or end-of-block code */ - for (;;) { - here = lencode[BITS(lenbits)]; - if ((unsigned)(here.bits) <= bits) break; - PULLBYTE(); - } - if (here.op && (here.op & 0xf0) == 0) { - last = here; - for (;;) { - here = lencode[last.val + - (BITS(last.bits + last.op) >> last.bits)]; - if ((unsigned)(last.bits + here.bits) <= bits) break; - PULLBYTE(); - } - DROPBITS(last.bits); - } - DROPBITS(here.bits); - length = (unsigned)here.val; - - /* process literal */ - if (here.op == 0) { - Tracevv((stderr, here.val >= 0x20 && here.val < 0x7f ? - "inflate: literal '%c'\n" : - "inflate: literal 0x%02x\n", here.val)); - ROOM(); - *put++ = (unsigned char)(length); - left--; - mode = LEN; - break; - } - - /* process end of block */ - if (here.op & 32) { - Tracevv((stderr, "inflate: end of block\n")); - mode = TYPE; - break; - } - - /* invalid code */ - if (here.op & 64) { - strm->msg = (char *)"invalid literal/length code"; - mode = BAD; - break; - } - - /* length code -- get extra bits, if any */ - extra = (unsigned)(here.op) & 31; - if (extra != 0) { - NEEDBITS(extra); - length += BITS(extra); - DROPBITS(extra); - } - Tracevv((stderr, "inflate: length %lu\n", length)); - - /* get distance code */ - for (;;) { - here = distcode[BITS(distbits)]; - if ((unsigned)(here.bits) <= bits) break; - PULLBYTE(); - } - if ((here.op & 0xf0) == 0) { - last = here; - for (;;) { - here = distcode[last.val + - (BITS(last.bits + last.op) >> last.bits)]; - if ((unsigned)(last.bits + here.bits) <= bits) break; - PULLBYTE(); - } - DROPBITS(last.bits); - } - DROPBITS(here.bits); - if (here.op & 64) { - strm->msg = (char *)"invalid distance code"; - mode = BAD; - break; - } - offset = (unsigned)here.val; - - /* get distance extra bits, if any */ - extra = (unsigned)(here.op) & 15; - if (extra != 0) { - NEEDBITS(extra); - offset += BITS(extra); - DROPBITS(extra); - } - if (offset > WSIZE - (wrap ? 0: left)) { - strm->msg = (char *)"invalid distance too far back"; - mode = BAD; - break; - } - Tracevv((stderr, "inflate: distance %lu\n", offset)); - - /* copy match from window to output */ - do { - ROOM(); - copy = WSIZE - offset; - if (copy < left) { - from = put + copy; - copy = left - copy; - } - else { - from = put - offset; - copy = left; - } - if (copy > length) copy = length; - length -= copy; - left -= copy; - do { - *put++ = *from++; - } while (--copy); - } while (length != 0); - break; - - case DONE: - /* inflate stream terminated properly -- write leftover output */ - ret = Z_STREAM_END; - if (left < WSIZE) { - if (out(out_desc, window, (unsigned)(WSIZE - left))) - ret = Z_BUF_ERROR; - } - goto inf_leave; - - case BAD: - ret = Z_DATA_ERROR; - goto inf_leave; - - default: /* can't happen, but makes compilers happy */ - ret = Z_STREAM_ERROR; - goto inf_leave; - } - - /* Return unused input */ - inf_leave: - strm->next_in = next; - strm->avail_in = have; - return ret; -} - -int ZEXPORT inflateBack9End(strm) -z_stream FAR *strm; -{ - if (strm == Z_NULL || strm->state == Z_NULL || strm->zfree == (free_func)0) - return Z_STREAM_ERROR; - ZFREE(strm, strm->state); - strm->state = Z_NULL; - Tracev((stderr, "inflate: end\n")); - return Z_OK; -} DELETED compat/zlib/contrib/infback9/infback9.h Index: compat/zlib/contrib/infback9/infback9.h ================================================================== --- compat/zlib/contrib/infback9/infback9.h +++ /dev/null @@ -1,37 +0,0 @@ -/* infback9.h -- header for using inflateBack9 functions - * Copyright (C) 2003 Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -/* - * This header file and associated patches provide a decoder for PKWare's - * undocumented deflate64 compression method (method 9). Use with infback9.c, - * inftree9.h, inftree9.c, and inffix9.h. These patches are not supported. - * This should be compiled with zlib, since it uses zutil.h and zutil.o. - * This code has not yet been tested on 16-bit architectures. See the - * comments in zlib.h for inflateBack() usage. These functions are used - * identically, except that there is no windowBits parameter, and a 64K - * window must be provided. Also if int's are 16 bits, then a zero for - * the third parameter of the "out" function actually means 65536UL. - * zlib.h must be included before this header file. - */ - -#ifdef __cplusplus -extern "C" { -#endif - -ZEXTERN int ZEXPORT inflateBack9 OF((z_stream FAR *strm, - in_func in, void FAR *in_desc, - out_func out, void FAR *out_desc)); -ZEXTERN int ZEXPORT inflateBack9End OF((z_stream FAR *strm)); -ZEXTERN int ZEXPORT inflateBack9Init_ OF((z_stream FAR *strm, - unsigned char FAR *window, - const char *version, - int stream_size)); -#define inflateBack9Init(strm, window) \ - inflateBack9Init_((strm), (window), \ - ZLIB_VERSION, sizeof(z_stream)) - -#ifdef __cplusplus -} -#endif DELETED compat/zlib/contrib/infback9/inffix9.h Index: compat/zlib/contrib/infback9/inffix9.h ================================================================== --- compat/zlib/contrib/infback9/inffix9.h +++ /dev/null @@ -1,107 +0,0 @@ - /* inffix9.h -- table for decoding deflate64 fixed codes - * Generated automatically by makefixed9(). - */ - - /* WARNING: this file should *not* be used by applications. - It is part of the implementation of this library and is - subject to change. Applications should only use zlib.h. - */ - - static const code lenfix[512] = { - {96,7,0},{0,8,80},{0,8,16},{132,8,115},{130,7,31},{0,8,112}, - {0,8,48},{0,9,192},{128,7,10},{0,8,96},{0,8,32},{0,9,160}, - {0,8,0},{0,8,128},{0,8,64},{0,9,224},{128,7,6},{0,8,88}, - {0,8,24},{0,9,144},{131,7,59},{0,8,120},{0,8,56},{0,9,208}, - {129,7,17},{0,8,104},{0,8,40},{0,9,176},{0,8,8},{0,8,136}, - {0,8,72},{0,9,240},{128,7,4},{0,8,84},{0,8,20},{133,8,227}, - {131,7,43},{0,8,116},{0,8,52},{0,9,200},{129,7,13},{0,8,100}, - {0,8,36},{0,9,168},{0,8,4},{0,8,132},{0,8,68},{0,9,232}, - {128,7,8},{0,8,92},{0,8,28},{0,9,152},{132,7,83},{0,8,124}, - {0,8,60},{0,9,216},{130,7,23},{0,8,108},{0,8,44},{0,9,184}, - {0,8,12},{0,8,140},{0,8,76},{0,9,248},{128,7,3},{0,8,82}, - {0,8,18},{133,8,163},{131,7,35},{0,8,114},{0,8,50},{0,9,196}, - {129,7,11},{0,8,98},{0,8,34},{0,9,164},{0,8,2},{0,8,130}, - {0,8,66},{0,9,228},{128,7,7},{0,8,90},{0,8,26},{0,9,148}, - {132,7,67},{0,8,122},{0,8,58},{0,9,212},{130,7,19},{0,8,106}, - {0,8,42},{0,9,180},{0,8,10},{0,8,138},{0,8,74},{0,9,244}, - {128,7,5},{0,8,86},{0,8,22},{65,8,0},{131,7,51},{0,8,118}, - {0,8,54},{0,9,204},{129,7,15},{0,8,102},{0,8,38},{0,9,172}, - {0,8,6},{0,8,134},{0,8,70},{0,9,236},{128,7,9},{0,8,94}, - {0,8,30},{0,9,156},{132,7,99},{0,8,126},{0,8,62},{0,9,220}, - {130,7,27},{0,8,110},{0,8,46},{0,9,188},{0,8,14},{0,8,142}, - {0,8,78},{0,9,252},{96,7,0},{0,8,81},{0,8,17},{133,8,131}, - {130,7,31},{0,8,113},{0,8,49},{0,9,194},{128,7,10},{0,8,97}, - {0,8,33},{0,9,162},{0,8,1},{0,8,129},{0,8,65},{0,9,226}, - {128,7,6},{0,8,89},{0,8,25},{0,9,146},{131,7,59},{0,8,121}, - {0,8,57},{0,9,210},{129,7,17},{0,8,105},{0,8,41},{0,9,178}, - {0,8,9},{0,8,137},{0,8,73},{0,9,242},{128,7,4},{0,8,85}, - {0,8,21},{144,8,3},{131,7,43},{0,8,117},{0,8,53},{0,9,202}, - {129,7,13},{0,8,101},{0,8,37},{0,9,170},{0,8,5},{0,8,133}, - {0,8,69},{0,9,234},{128,7,8},{0,8,93},{0,8,29},{0,9,154}, - {132,7,83},{0,8,125},{0,8,61},{0,9,218},{130,7,23},{0,8,109}, - {0,8,45},{0,9,186},{0,8,13},{0,8,141},{0,8,77},{0,9,250}, - {128,7,3},{0,8,83},{0,8,19},{133,8,195},{131,7,35},{0,8,115}, - {0,8,51},{0,9,198},{129,7,11},{0,8,99},{0,8,35},{0,9,166}, - {0,8,3},{0,8,131},{0,8,67},{0,9,230},{128,7,7},{0,8,91}, - {0,8,27},{0,9,150},{132,7,67},{0,8,123},{0,8,59},{0,9,214}, - {130,7,19},{0,8,107},{0,8,43},{0,9,182},{0,8,11},{0,8,139}, - {0,8,75},{0,9,246},{128,7,5},{0,8,87},{0,8,23},{77,8,0}, - {131,7,51},{0,8,119},{0,8,55},{0,9,206},{129,7,15},{0,8,103}, - {0,8,39},{0,9,174},{0,8,7},{0,8,135},{0,8,71},{0,9,238}, - {128,7,9},{0,8,95},{0,8,31},{0,9,158},{132,7,99},{0,8,127}, - {0,8,63},{0,9,222},{130,7,27},{0,8,111},{0,8,47},{0,9,190}, - {0,8,15},{0,8,143},{0,8,79},{0,9,254},{96,7,0},{0,8,80}, - {0,8,16},{132,8,115},{130,7,31},{0,8,112},{0,8,48},{0,9,193}, - {128,7,10},{0,8,96},{0,8,32},{0,9,161},{0,8,0},{0,8,128}, - {0,8,64},{0,9,225},{128,7,6},{0,8,88},{0,8,24},{0,9,145}, - {131,7,59},{0,8,120},{0,8,56},{0,9,209},{129,7,17},{0,8,104}, - {0,8,40},{0,9,177},{0,8,8},{0,8,136},{0,8,72},{0,9,241}, - {128,7,4},{0,8,84},{0,8,20},{133,8,227},{131,7,43},{0,8,116}, - {0,8,52},{0,9,201},{129,7,13},{0,8,100},{0,8,36},{0,9,169}, - {0,8,4},{0,8,132},{0,8,68},{0,9,233},{128,7,8},{0,8,92}, - {0,8,28},{0,9,153},{132,7,83},{0,8,124},{0,8,60},{0,9,217}, - {130,7,23},{0,8,108},{0,8,44},{0,9,185},{0,8,12},{0,8,140}, - {0,8,76},{0,9,249},{128,7,3},{0,8,82},{0,8,18},{133,8,163}, - {131,7,35},{0,8,114},{0,8,50},{0,9,197},{129,7,11},{0,8,98}, - {0,8,34},{0,9,165},{0,8,2},{0,8,130},{0,8,66},{0,9,229}, - {128,7,7},{0,8,90},{0,8,26},{0,9,149},{132,7,67},{0,8,122}, - {0,8,58},{0,9,213},{130,7,19},{0,8,106},{0,8,42},{0,9,181}, - {0,8,10},{0,8,138},{0,8,74},{0,9,245},{128,7,5},{0,8,86}, - {0,8,22},{65,8,0},{131,7,51},{0,8,118},{0,8,54},{0,9,205}, - {129,7,15},{0,8,102},{0,8,38},{0,9,173},{0,8,6},{0,8,134}, - {0,8,70},{0,9,237},{128,7,9},{0,8,94},{0,8,30},{0,9,157}, - {132,7,99},{0,8,126},{0,8,62},{0,9,221},{130,7,27},{0,8,110}, - {0,8,46},{0,9,189},{0,8,14},{0,8,142},{0,8,78},{0,9,253}, - {96,7,0},{0,8,81},{0,8,17},{133,8,131},{130,7,31},{0,8,113}, - {0,8,49},{0,9,195},{128,7,10},{0,8,97},{0,8,33},{0,9,163}, - {0,8,1},{0,8,129},{0,8,65},{0,9,227},{128,7,6},{0,8,89}, - {0,8,25},{0,9,147},{131,7,59},{0,8,121},{0,8,57},{0,9,211}, - {129,7,17},{0,8,105},{0,8,41},{0,9,179},{0,8,9},{0,8,137}, - {0,8,73},{0,9,243},{128,7,4},{0,8,85},{0,8,21},{144,8,3}, - {131,7,43},{0,8,117},{0,8,53},{0,9,203},{129,7,13},{0,8,101}, - {0,8,37},{0,9,171},{0,8,5},{0,8,133},{0,8,69},{0,9,235}, - {128,7,8},{0,8,93},{0,8,29},{0,9,155},{132,7,83},{0,8,125}, - {0,8,61},{0,9,219},{130,7,23},{0,8,109},{0,8,45},{0,9,187}, - {0,8,13},{0,8,141},{0,8,77},{0,9,251},{128,7,3},{0,8,83}, - {0,8,19},{133,8,195},{131,7,35},{0,8,115},{0,8,51},{0,9,199}, - {129,7,11},{0,8,99},{0,8,35},{0,9,167},{0,8,3},{0,8,131}, - {0,8,67},{0,9,231},{128,7,7},{0,8,91},{0,8,27},{0,9,151}, - {132,7,67},{0,8,123},{0,8,59},{0,9,215},{130,7,19},{0,8,107}, - {0,8,43},{0,9,183},{0,8,11},{0,8,139},{0,8,75},{0,9,247}, - {128,7,5},{0,8,87},{0,8,23},{77,8,0},{131,7,51},{0,8,119}, - {0,8,55},{0,9,207},{129,7,15},{0,8,103},{0,8,39},{0,9,175}, - {0,8,7},{0,8,135},{0,8,71},{0,9,239},{128,7,9},{0,8,95}, - {0,8,31},{0,9,159},{132,7,99},{0,8,127},{0,8,63},{0,9,223}, - {130,7,27},{0,8,111},{0,8,47},{0,9,191},{0,8,15},{0,8,143}, - {0,8,79},{0,9,255} - }; - - static const code distfix[32] = { - {128,5,1},{135,5,257},{131,5,17},{139,5,4097},{129,5,5}, - {137,5,1025},{133,5,65},{141,5,16385},{128,5,3},{136,5,513}, - {132,5,33},{140,5,8193},{130,5,9},{138,5,2049},{134,5,129}, - {142,5,32769},{128,5,2},{135,5,385},{131,5,25},{139,5,6145}, - {129,5,7},{137,5,1537},{133,5,97},{141,5,24577},{128,5,4}, - {136,5,769},{132,5,49},{140,5,12289},{130,5,13},{138,5,3073}, - {134,5,193},{142,5,49153} - }; DELETED compat/zlib/contrib/infback9/inflate9.h Index: compat/zlib/contrib/infback9/inflate9.h ================================================================== --- compat/zlib/contrib/infback9/inflate9.h +++ /dev/null @@ -1,47 +0,0 @@ -/* inflate9.h -- internal inflate state definition - * Copyright (C) 1995-2003 Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -/* WARNING: this file should *not* be used by applications. It is - part of the implementation of the compression library and is - subject to change. Applications should only use zlib.h. - */ - -/* Possible inflate modes between inflate() calls */ -typedef enum { - TYPE, /* i: waiting for type bits, including last-flag bit */ - STORED, /* i: waiting for stored size (length and complement) */ - TABLE, /* i: waiting for dynamic block table lengths */ - LEN, /* i: waiting for length/lit code */ - DONE, /* finished check, done -- remain here until reset */ - BAD /* got a data error -- remain here until reset */ -} inflate_mode; - -/* - State transitions between above modes - - - (most modes can go to the BAD mode -- not shown for clarity) - - Read deflate blocks: - TYPE -> STORED or TABLE or LEN or DONE - STORED -> TYPE - TABLE -> LENLENS -> CODELENS -> LEN - Read deflate codes: - LEN -> LEN or TYPE - */ - -/* state maintained between inflate() calls. Approximately 7K bytes. */ -struct inflate_state { - /* sliding window */ - unsigned char FAR *window; /* allocated sliding window, if needed */ - /* dynamic table building */ - unsigned ncode; /* number of code length code lengths */ - unsigned nlen; /* number of length code lengths */ - unsigned ndist; /* number of distance code lengths */ - unsigned have; /* number of code lengths in lens[] */ - code FAR *next; /* next available space in codes[] */ - unsigned short lens[320]; /* temporary storage for code lengths */ - unsigned short work[288]; /* work area for code table building */ - code codes[ENOUGH]; /* space for code tables */ -}; DELETED compat/zlib/contrib/infback9/inftree9.c Index: compat/zlib/contrib/infback9/inftree9.c ================================================================== --- compat/zlib/contrib/infback9/inftree9.c +++ /dev/null @@ -1,324 +0,0 @@ -/* inftree9.c -- generate Huffman trees for efficient decoding - * Copyright (C) 1995-2017 Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -#include "zutil.h" -#include "inftree9.h" - -#define MAXBITS 15 - -const char inflate9_copyright[] = - " inflate9 1.2.11 Copyright 1995-2017 Mark Adler "; -/* - If you use the zlib library in a product, an acknowledgment is welcome - in the documentation of your product. If for some reason you cannot - include such an acknowledgment, I would appreciate that you keep this - copyright string in the executable of your product. - */ - -/* - Build a set of tables to decode the provided canonical Huffman code. - The code lengths are lens[0..codes-1]. The result starts at *table, - whose indices are 0..2^bits-1. work is a writable array of at least - lens shorts, which is used as a work area. type is the type of code - to be generated, CODES, LENS, or DISTS. On return, zero is success, - -1 is an invalid code, and +1 means that ENOUGH isn't enough. table - on return points to the next available entry's address. bits is the - requested root table index bits, and on return it is the actual root - table index bits. It will differ if the request is greater than the - longest code or if it is less than the shortest code. - */ -int inflate_table9(type, lens, codes, table, bits, work) -codetype type; -unsigned short FAR *lens; -unsigned codes; -code FAR * FAR *table; -unsigned FAR *bits; -unsigned short FAR *work; -{ - unsigned len; /* a code's length in bits */ - unsigned sym; /* index of code symbols */ - unsigned min, max; /* minimum and maximum code lengths */ - unsigned root; /* number of index bits for root table */ - unsigned curr; /* number of index bits for current table */ - unsigned drop; /* code bits to drop for sub-table */ - int left; /* number of prefix codes available */ - unsigned used; /* code entries in table used */ - unsigned huff; /* Huffman code */ - unsigned incr; /* for incrementing code, index */ - unsigned fill; /* index for replicating entries */ - unsigned low; /* low bits for current root entry */ - unsigned mask; /* mask for low root bits */ - code this; /* table entry for duplication */ - code FAR *next; /* next available space in table */ - const unsigned short FAR *base; /* base value table to use */ - const unsigned short FAR *extra; /* extra bits table to use */ - int end; /* use base and extra for symbol > end */ - unsigned short count[MAXBITS+1]; /* number of codes of each length */ - unsigned short offs[MAXBITS+1]; /* offsets in table for each length */ - static const unsigned short lbase[31] = { /* Length codes 257..285 base */ - 3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 15, 17, - 19, 23, 27, 31, 35, 43, 51, 59, 67, 83, 99, 115, - 131, 163, 195, 227, 3, 0, 0}; - static const unsigned short lext[31] = { /* Length codes 257..285 extra */ - 128, 128, 128, 128, 128, 128, 128, 128, 129, 129, 129, 129, - 130, 130, 130, 130, 131, 131, 131, 131, 132, 132, 132, 132, - 133, 133, 133, 133, 144, 77, 202}; - static const unsigned short dbase[32] = { /* Distance codes 0..31 base */ - 1, 2, 3, 4, 5, 7, 9, 13, 17, 25, 33, 49, - 65, 97, 129, 193, 257, 385, 513, 769, 1025, 1537, 2049, 3073, - 4097, 6145, 8193, 12289, 16385, 24577, 32769, 49153}; - static const unsigned short dext[32] = { /* Distance codes 0..31 extra */ - 128, 128, 128, 128, 129, 129, 130, 130, 131, 131, 132, 132, - 133, 133, 134, 134, 135, 135, 136, 136, 137, 137, 138, 138, - 139, 139, 140, 140, 141, 141, 142, 142}; - - /* - Process a set of code lengths to create a canonical Huffman code. The - code lengths are lens[0..codes-1]. Each length corresponds to the - symbols 0..codes-1. The Huffman code is generated by first sorting the - symbols by length from short to long, and retaining the symbol order - for codes with equal lengths. Then the code starts with all zero bits - for the first code of the shortest length, and the codes are integer - increments for the same length, and zeros are appended as the length - increases. For the deflate format, these bits are stored backwards - from their more natural integer increment ordering, and so when the - decoding tables are built in the large loop below, the integer codes - are incremented backwards. - - This routine assumes, but does not check, that all of the entries in - lens[] are in the range 0..MAXBITS. The caller must assure this. - 1..MAXBITS is interpreted as that code length. zero means that that - symbol does not occur in this code. - - The codes are sorted by computing a count of codes for each length, - creating from that a table of starting indices for each length in the - sorted table, and then entering the symbols in order in the sorted - table. The sorted table is work[], with that space being provided by - the caller. - - The length counts are used for other purposes as well, i.e. finding - the minimum and maximum length codes, determining if there are any - codes at all, checking for a valid set of lengths, and looking ahead - at length counts to determine sub-table sizes when building the - decoding tables. - */ - - /* accumulate lengths for codes (assumes lens[] all in 0..MAXBITS) */ - for (len = 0; len <= MAXBITS; len++) - count[len] = 0; - for (sym = 0; sym < codes; sym++) - count[lens[sym]]++; - - /* bound code lengths, force root to be within code lengths */ - root = *bits; - for (max = MAXBITS; max >= 1; max--) - if (count[max] != 0) break; - if (root > max) root = max; - if (max == 0) return -1; /* no codes! */ - for (min = 1; min <= MAXBITS; min++) - if (count[min] != 0) break; - if (root < min) root = min; - - /* check for an over-subscribed or incomplete set of lengths */ - left = 1; - for (len = 1; len <= MAXBITS; len++) { - left <<= 1; - left -= count[len]; - if (left < 0) return -1; /* over-subscribed */ - } - if (left > 0 && (type == CODES || max != 1)) - return -1; /* incomplete set */ - - /* generate offsets into symbol table for each length for sorting */ - offs[1] = 0; - for (len = 1; len < MAXBITS; len++) - offs[len + 1] = offs[len] + count[len]; - - /* sort symbols by length, by symbol order within each length */ - for (sym = 0; sym < codes; sym++) - if (lens[sym] != 0) work[offs[lens[sym]]++] = (unsigned short)sym; - - /* - Create and fill in decoding tables. In this loop, the table being - filled is at next and has curr index bits. The code being used is huff - with length len. That code is converted to an index by dropping drop - bits off of the bottom. For codes where len is less than drop + curr, - those top drop + curr - len bits are incremented through all values to - fill the table with replicated entries. - - root is the number of index bits for the root table. When len exceeds - root, sub-tables are created pointed to by the root entry with an index - of the low root bits of huff. This is saved in low to check for when a - new sub-table should be started. drop is zero when the root table is - being filled, and drop is root when sub-tables are being filled. - - When a new sub-table is needed, it is necessary to look ahead in the - code lengths to determine what size sub-table is needed. The length - counts are used for this, and so count[] is decremented as codes are - entered in the tables. - - used keeps track of how many table entries have been allocated from the - provided *table space. It is checked for LENS and DIST tables against - the constants ENOUGH_LENS and ENOUGH_DISTS to guard against changes in - the initial root table size constants. See the comments in inftree9.h - for more information. - - sym increments through all symbols, and the loop terminates when - all codes of length max, i.e. all codes, have been processed. This - routine permits incomplete codes, so another loop after this one fills - in the rest of the decoding tables with invalid code markers. - */ - - /* set up for code type */ - switch (type) { - case CODES: - base = extra = work; /* dummy value--not used */ - end = 19; - break; - case LENS: - base = lbase; - base -= 257; - extra = lext; - extra -= 257; - end = 256; - break; - default: /* DISTS */ - base = dbase; - extra = dext; - end = -1; - } - - /* initialize state for loop */ - huff = 0; /* starting code */ - sym = 0; /* starting code symbol */ - len = min; /* starting code length */ - next = *table; /* current table to fill in */ - curr = root; /* current table index bits */ - drop = 0; /* current bits to drop from code for index */ - low = (unsigned)(-1); /* trigger new sub-table when len > root */ - used = 1U << root; /* use root table entries */ - mask = used - 1; /* mask for comparing low */ - - /* check available table space */ - if ((type == LENS && used >= ENOUGH_LENS) || - (type == DISTS && used >= ENOUGH_DISTS)) - return 1; - - /* process all codes and make table entries */ - for (;;) { - /* create table entry */ - this.bits = (unsigned char)(len - drop); - if ((int)(work[sym]) < end) { - this.op = (unsigned char)0; - this.val = work[sym]; - } - else if ((int)(work[sym]) > end) { - this.op = (unsigned char)(extra[work[sym]]); - this.val = base[work[sym]]; - } - else { - this.op = (unsigned char)(32 + 64); /* end of block */ - this.val = 0; - } - - /* replicate for those indices with low len bits equal to huff */ - incr = 1U << (len - drop); - fill = 1U << curr; - do { - fill -= incr; - next[(huff >> drop) + fill] = this; - } while (fill != 0); - - /* backwards increment the len-bit code huff */ - incr = 1U << (len - 1); - while (huff & incr) - incr >>= 1; - if (incr != 0) { - huff &= incr - 1; - huff += incr; - } - else - huff = 0; - - /* go to next symbol, update count, len */ - sym++; - if (--(count[len]) == 0) { - if (len == max) break; - len = lens[work[sym]]; - } - - /* create new sub-table if needed */ - if (len > root && (huff & mask) != low) { - /* if first time, transition to sub-tables */ - if (drop == 0) - drop = root; - - /* increment past last table */ - next += 1U << curr; - - /* determine length of next table */ - curr = len - drop; - left = (int)(1 << curr); - while (curr + drop < max) { - left -= count[curr + drop]; - if (left <= 0) break; - curr++; - left <<= 1; - } - - /* check for enough space */ - used += 1U << curr; - if ((type == LENS && used >= ENOUGH_LENS) || - (type == DISTS && used >= ENOUGH_DISTS)) - return 1; - - /* point entry in root table to sub-table */ - low = huff & mask; - (*table)[low].op = (unsigned char)curr; - (*table)[low].bits = (unsigned char)root; - (*table)[low].val = (unsigned short)(next - *table); - } - } - - /* - Fill in rest of table for incomplete codes. This loop is similar to the - loop above in incrementing huff for table indices. It is assumed that - len is equal to curr + drop, so there is no loop needed to increment - through high index bits. When the current sub-table is filled, the loop - drops back to the root table to fill in any remaining entries there. - */ - this.op = (unsigned char)64; /* invalid code marker */ - this.bits = (unsigned char)(len - drop); - this.val = (unsigned short)0; - while (huff != 0) { - /* when done with sub-table, drop back to root table */ - if (drop != 0 && (huff & mask) != low) { - drop = 0; - len = root; - next = *table; - curr = root; - this.bits = (unsigned char)len; - } - - /* put invalid code marker in table */ - next[huff >> drop] = this; - - /* backwards increment the len-bit code huff */ - incr = 1U << (len - 1); - while (huff & incr) - incr >>= 1; - if (incr != 0) { - huff &= incr - 1; - huff += incr; - } - else - huff = 0; - } - - /* set return parameters */ - *table += used; - *bits = root; - return 0; -} DELETED compat/zlib/contrib/infback9/inftree9.h Index: compat/zlib/contrib/infback9/inftree9.h ================================================================== --- compat/zlib/contrib/infback9/inftree9.h +++ /dev/null @@ -1,61 +0,0 @@ -/* inftree9.h -- header to use inftree9.c - * Copyright (C) 1995-2008 Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -/* WARNING: this file should *not* be used by applications. It is - part of the implementation of the compression library and is - subject to change. Applications should only use zlib.h. - */ - -/* Structure for decoding tables. Each entry provides either the - information needed to do the operation requested by the code that - indexed that table entry, or it provides a pointer to another - table that indexes more bits of the code. op indicates whether - the entry is a pointer to another table, a literal, a length or - distance, an end-of-block, or an invalid code. For a table - pointer, the low four bits of op is the number of index bits of - that table. For a length or distance, the low four bits of op - is the number of extra bits to get after the code. bits is - the number of bits in this code or part of the code to drop off - of the bit buffer. val is the actual byte to output in the case - of a literal, the base length or distance, or the offset from - the current table to the next table. Each entry is four bytes. */ -typedef struct { - unsigned char op; /* operation, extra bits, table bits */ - unsigned char bits; /* bits in this part of the code */ - unsigned short val; /* offset in table or code value */ -} code; - -/* op values as set by inflate_table(): - 00000000 - literal - 0000tttt - table link, tttt != 0 is the number of table index bits - 100eeeee - length or distance, eeee is the number of extra bits - 01100000 - end of block - 01000000 - invalid code - */ - -/* Maximum size of the dynamic table. The maximum number of code structures is - 1446, which is the sum of 852 for literal/length codes and 594 for distance - codes. These values were found by exhaustive searches using the program - examples/enough.c found in the zlib distribtution. The arguments to that - program are the number of symbols, the initial root table size, and the - maximum bit length of a code. "enough 286 9 15" for literal/length codes - returns returns 852, and "enough 32 6 15" for distance codes returns 594. - The initial root table size (9 or 6) is found in the fifth argument of the - inflate_table() calls in infback9.c. If the root table size is changed, - then these maximum sizes would be need to be recalculated and updated. */ -#define ENOUGH_LENS 852 -#define ENOUGH_DISTS 594 -#define ENOUGH (ENOUGH_LENS+ENOUGH_DISTS) - -/* Type of code to build for inflate_table9() */ -typedef enum { - CODES, - LENS, - DISTS -} codetype; - -extern int inflate_table9 OF((codetype type, unsigned short FAR *lens, - unsigned codes, code FAR * FAR *table, - unsigned FAR *bits, unsigned short FAR *work)); DELETED compat/zlib/contrib/inflate86/inffas86.c Index: compat/zlib/contrib/inflate86/inffas86.c ================================================================== --- compat/zlib/contrib/inflate86/inffas86.c +++ /dev/null @@ -1,1157 +0,0 @@ -/* inffas86.c is a hand tuned assembler version of - * - * inffast.c -- fast decoding - * Copyright (C) 1995-2003 Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - * - * Copyright (C) 2003 Chris Anderson - * Please use the copyright conditions above. - * - * Dec-29-2003 -- I added AMD64 inflate asm support. This version is also - * slightly quicker on x86 systems because, instead of using rep movsb to copy - * data, it uses rep movsw, which moves data in 2-byte chunks instead of single - * bytes. I've tested the AMD64 code on a Fedora Core 1 + the x86_64 updates - * from http://fedora.linux.duke.edu/fc1_x86_64 - * which is running on an Athlon 64 3000+ / Gigabyte GA-K8VT800M system with - * 1GB ram. The 64-bit version is about 4% faster than the 32-bit version, - * when decompressing mozilla-source-1.3.tar.gz. - * - * Mar-13-2003 -- Most of this is derived from inffast.S which is derived from - * the gcc -S output of zlib-1.2.0/inffast.c. Zlib-1.2.0 is in beta release at - * the moment. I have successfully compiled and tested this code with gcc2.96, - * gcc3.2, icc5.0, msvc6.0. It is very close to the speed of inffast.S - * compiled with gcc -DNO_MMX, but inffast.S is still faster on the P3 with MMX - * enabled. I will attempt to merge the MMX code into this version. Newer - * versions of this and inffast.S can be found at - * http://www.eetbeetee.com/zlib/ and http://www.charm.net/~christop/zlib/ - */ - -#include "zutil.h" -#include "inftrees.h" -#include "inflate.h" -#include "inffast.h" - -/* Mark Adler's comments from inffast.c: */ - -/* - Decode literal, length, and distance codes and write out the resulting - literal and match bytes until either not enough input or output is - available, an end-of-block is encountered, or a data error is encountered. - When large enough input and output buffers are supplied to inflate(), for - example, a 16K input buffer and a 64K output buffer, more than 95% of the - inflate execution time is spent in this routine. - - Entry assumptions: - - state->mode == LEN - strm->avail_in >= 6 - strm->avail_out >= 258 - start >= strm->avail_out - state->bits < 8 - - On return, state->mode is one of: - - LEN -- ran out of enough output space or enough available input - TYPE -- reached end of block code, inflate() to interpret next block - BAD -- error in block data - - Notes: - - - The maximum input bits used by a length/distance pair is 15 bits for the - length code, 5 bits for the length extra, 15 bits for the distance code, - and 13 bits for the distance extra. This totals 48 bits, or six bytes. - Therefore if strm->avail_in >= 6, then there is enough input to avoid - checking for available input while decoding. - - - The maximum bytes that a single length/distance pair can output is 258 - bytes, which is the maximum length that can be coded. inflate_fast() - requires strm->avail_out >= 258 for each loop to avoid checking for - output space. - */ -void inflate_fast(strm, start) -z_streamp strm; -unsigned start; /* inflate()'s starting value for strm->avail_out */ -{ - struct inflate_state FAR *state; - struct inffast_ar { -/* 64 32 x86 x86_64 */ -/* ar offset register */ -/* 0 0 */ void *esp; /* esp save */ -/* 8 4 */ void *ebp; /* ebp save */ -/* 16 8 */ unsigned char FAR *in; /* esi rsi local strm->next_in */ -/* 24 12 */ unsigned char FAR *last; /* r9 while in < last */ -/* 32 16 */ unsigned char FAR *out; /* edi rdi local strm->next_out */ -/* 40 20 */ unsigned char FAR *beg; /* inflate()'s init next_out */ -/* 48 24 */ unsigned char FAR *end; /* r10 while out < end */ -/* 56 28 */ unsigned char FAR *window;/* size of window, wsize!=0 */ -/* 64 32 */ code const FAR *lcode; /* ebp rbp local strm->lencode */ -/* 72 36 */ code const FAR *dcode; /* r11 local strm->distcode */ -/* 80 40 */ unsigned long hold; /* edx rdx local strm->hold */ -/* 88 44 */ unsigned bits; /* ebx rbx local strm->bits */ -/* 92 48 */ unsigned wsize; /* window size */ -/* 96 52 */ unsigned write; /* window write index */ -/*100 56 */ unsigned lmask; /* r12 mask for lcode */ -/*104 60 */ unsigned dmask; /* r13 mask for dcode */ -/*108 64 */ unsigned len; /* r14 match length */ -/*112 68 */ unsigned dist; /* r15 match distance */ -/*116 72 */ unsigned status; /* set when state chng*/ - } ar; - -#if defined( __GNUC__ ) && defined( __amd64__ ) && ! defined( __i386 ) -#define PAD_AVAIL_IN 6 -#define PAD_AVAIL_OUT 258 -#else -#define PAD_AVAIL_IN 5 -#define PAD_AVAIL_OUT 257 -#endif - - /* copy state to local variables */ - state = (struct inflate_state FAR *)strm->state; - ar.in = strm->next_in; - ar.last = ar.in + (strm->avail_in - PAD_AVAIL_IN); - ar.out = strm->next_out; - ar.beg = ar.out - (start - strm->avail_out); - ar.end = ar.out + (strm->avail_out - PAD_AVAIL_OUT); - ar.wsize = state->wsize; - ar.write = state->wnext; - ar.window = state->window; - ar.hold = state->hold; - ar.bits = state->bits; - ar.lcode = state->lencode; - ar.dcode = state->distcode; - ar.lmask = (1U << state->lenbits) - 1; - ar.dmask = (1U << state->distbits) - 1; - - /* decode literals and length/distances until end-of-block or not enough - input data or output space */ - - /* align in on 1/2 hold size boundary */ - while (((unsigned long)(void *)ar.in & (sizeof(ar.hold) / 2 - 1)) != 0) { - ar.hold += (unsigned long)*ar.in++ << ar.bits; - ar.bits += 8; - } - -#if defined( __GNUC__ ) && defined( __amd64__ ) && ! defined( __i386 ) - __asm__ __volatile__ ( -" leaq %0, %%rax\n" -" movq %%rbp, 8(%%rax)\n" /* save regs rbp and rsp */ -" movq %%rsp, (%%rax)\n" -" movq %%rax, %%rsp\n" /* make rsp point to &ar */ -" movq 16(%%rsp), %%rsi\n" /* rsi = in */ -" movq 32(%%rsp), %%rdi\n" /* rdi = out */ -" movq 24(%%rsp), %%r9\n" /* r9 = last */ -" movq 48(%%rsp), %%r10\n" /* r10 = end */ -" movq 64(%%rsp), %%rbp\n" /* rbp = lcode */ -" movq 72(%%rsp), %%r11\n" /* r11 = dcode */ -" movq 80(%%rsp), %%rdx\n" /* rdx = hold */ -" movl 88(%%rsp), %%ebx\n" /* ebx = bits */ -" movl 100(%%rsp), %%r12d\n" /* r12d = lmask */ -" movl 104(%%rsp), %%r13d\n" /* r13d = dmask */ - /* r14d = len */ - /* r15d = dist */ -" cld\n" -" cmpq %%rdi, %%r10\n" -" je .L_one_time\n" /* if only one decode left */ -" cmpq %%rsi, %%r9\n" -" je .L_one_time\n" -" jmp .L_do_loop\n" - -".L_one_time:\n" -" movq %%r12, %%r8\n" /* r8 = lmask */ -" cmpb $32, %%bl\n" -" ja .L_get_length_code_one_time\n" - -" lodsl\n" /* eax = *(uint *)in++ */ -" movb %%bl, %%cl\n" /* cl = bits, needs it for shifting */ -" addb $32, %%bl\n" /* bits += 32 */ -" shlq %%cl, %%rax\n" -" orq %%rax, %%rdx\n" /* hold |= *((uint *)in)++ << bits */ -" jmp .L_get_length_code_one_time\n" - -".align 32,0x90\n" -".L_while_test:\n" -" cmpq %%rdi, %%r10\n" -" jbe .L_break_loop\n" -" cmpq %%rsi, %%r9\n" -" jbe .L_break_loop\n" - -".L_do_loop:\n" -" movq %%r12, %%r8\n" /* r8 = lmask */ -" cmpb $32, %%bl\n" -" ja .L_get_length_code\n" /* if (32 < bits) */ - -" lodsl\n" /* eax = *(uint *)in++ */ -" movb %%bl, %%cl\n" /* cl = bits, needs it for shifting */ -" addb $32, %%bl\n" /* bits += 32 */ -" shlq %%cl, %%rax\n" -" orq %%rax, %%rdx\n" /* hold |= *((uint *)in)++ << bits */ - -".L_get_length_code:\n" -" andq %%rdx, %%r8\n" /* r8 &= hold */ -" movl (%%rbp,%%r8,4), %%eax\n" /* eax = lcode[hold & lmask] */ - -" movb %%ah, %%cl\n" /* cl = this.bits */ -" subb %%ah, %%bl\n" /* bits -= this.bits */ -" shrq %%cl, %%rdx\n" /* hold >>= this.bits */ - -" testb %%al, %%al\n" -" jnz .L_test_for_length_base\n" /* if (op != 0) 45.7% */ - -" movq %%r12, %%r8\n" /* r8 = lmask */ -" shrl $16, %%eax\n" /* output this.val char */ -" stosb\n" - -".L_get_length_code_one_time:\n" -" andq %%rdx, %%r8\n" /* r8 &= hold */ -" movl (%%rbp,%%r8,4), %%eax\n" /* eax = lcode[hold & lmask] */ - -".L_dolen:\n" -" movb %%ah, %%cl\n" /* cl = this.bits */ -" subb %%ah, %%bl\n" /* bits -= this.bits */ -" shrq %%cl, %%rdx\n" /* hold >>= this.bits */ - -" testb %%al, %%al\n" -" jnz .L_test_for_length_base\n" /* if (op != 0) 45.7% */ - -" shrl $16, %%eax\n" /* output this.val char */ -" stosb\n" -" jmp .L_while_test\n" - -".align 32,0x90\n" -".L_test_for_length_base:\n" -" movl %%eax, %%r14d\n" /* len = this */ -" shrl $16, %%r14d\n" /* len = this.val */ -" movb %%al, %%cl\n" - -" testb $16, %%al\n" -" jz .L_test_for_second_level_length\n" /* if ((op & 16) == 0) 8% */ -" andb $15, %%cl\n" /* op &= 15 */ -" jz .L_decode_distance\n" /* if (!op) */ - -".L_add_bits_to_len:\n" -" subb %%cl, %%bl\n" -" xorl %%eax, %%eax\n" -" incl %%eax\n" -" shll %%cl, %%eax\n" -" decl %%eax\n" -" andl %%edx, %%eax\n" /* eax &= hold */ -" shrq %%cl, %%rdx\n" -" addl %%eax, %%r14d\n" /* len += hold & mask[op] */ - -".L_decode_distance:\n" -" movq %%r13, %%r8\n" /* r8 = dmask */ -" cmpb $32, %%bl\n" -" ja .L_get_distance_code\n" /* if (32 < bits) */ - -" lodsl\n" /* eax = *(uint *)in++ */ -" movb %%bl, %%cl\n" /* cl = bits, needs it for shifting */ -" addb $32, %%bl\n" /* bits += 32 */ -" shlq %%cl, %%rax\n" -" orq %%rax, %%rdx\n" /* hold |= *((uint *)in)++ << bits */ - -".L_get_distance_code:\n" -" andq %%rdx, %%r8\n" /* r8 &= hold */ -" movl (%%r11,%%r8,4), %%eax\n" /* eax = dcode[hold & dmask] */ - -".L_dodist:\n" -" movl %%eax, %%r15d\n" /* dist = this */ -" shrl $16, %%r15d\n" /* dist = this.val */ -" movb %%ah, %%cl\n" -" subb %%ah, %%bl\n" /* bits -= this.bits */ -" shrq %%cl, %%rdx\n" /* hold >>= this.bits */ -" movb %%al, %%cl\n" /* cl = this.op */ - -" testb $16, %%al\n" /* if ((op & 16) == 0) */ -" jz .L_test_for_second_level_dist\n" -" andb $15, %%cl\n" /* op &= 15 */ -" jz .L_check_dist_one\n" - -".L_add_bits_to_dist:\n" -" subb %%cl, %%bl\n" -" xorl %%eax, %%eax\n" -" incl %%eax\n" -" shll %%cl, %%eax\n" -" decl %%eax\n" /* (1 << op) - 1 */ -" andl %%edx, %%eax\n" /* eax &= hold */ -" shrq %%cl, %%rdx\n" -" addl %%eax, %%r15d\n" /* dist += hold & ((1 << op) - 1) */ - -".L_check_window:\n" -" movq %%rsi, %%r8\n" /* save in so from can use it's reg */ -" movq %%rdi, %%rax\n" -" subq 40(%%rsp), %%rax\n" /* nbytes = out - beg */ - -" cmpl %%r15d, %%eax\n" -" jb .L_clip_window\n" /* if (dist > nbytes) 4.2% */ - -" movl %%r14d, %%ecx\n" /* ecx = len */ -" movq %%rdi, %%rsi\n" -" subq %%r15, %%rsi\n" /* from = out - dist */ - -" sarl %%ecx\n" -" jnc .L_copy_two\n" /* if len % 2 == 0 */ - -" rep movsw\n" -" movb (%%rsi), %%al\n" -" movb %%al, (%%rdi)\n" -" incq %%rdi\n" - -" movq %%r8, %%rsi\n" /* move in back to %rsi, toss from */ -" jmp .L_while_test\n" - -".L_copy_two:\n" -" rep movsw\n" -" movq %%r8, %%rsi\n" /* move in back to %rsi, toss from */ -" jmp .L_while_test\n" - -".align 32,0x90\n" -".L_check_dist_one:\n" -" cmpl $1, %%r15d\n" /* if dist 1, is a memset */ -" jne .L_check_window\n" -" cmpq %%rdi, 40(%%rsp)\n" /* if out == beg, outside window */ -" je .L_check_window\n" - -" movl %%r14d, %%ecx\n" /* ecx = len */ -" movb -1(%%rdi), %%al\n" -" movb %%al, %%ah\n" - -" sarl %%ecx\n" -" jnc .L_set_two\n" -" movb %%al, (%%rdi)\n" -" incq %%rdi\n" - -".L_set_two:\n" -" rep stosw\n" -" jmp .L_while_test\n" - -".align 32,0x90\n" -".L_test_for_second_level_length:\n" -" testb $64, %%al\n" -" jnz .L_test_for_end_of_block\n" /* if ((op & 64) != 0) */ - -" xorl %%eax, %%eax\n" -" incl %%eax\n" -" shll %%cl, %%eax\n" -" decl %%eax\n" -" andl %%edx, %%eax\n" /* eax &= hold */ -" addl %%r14d, %%eax\n" /* eax += len */ -" movl (%%rbp,%%rax,4), %%eax\n" /* eax = lcode[val+(hold&mask[op])]*/ -" jmp .L_dolen\n" - -".align 32,0x90\n" -".L_test_for_second_level_dist:\n" -" testb $64, %%al\n" -" jnz .L_invalid_distance_code\n" /* if ((op & 64) != 0) */ - -" xorl %%eax, %%eax\n" -" incl %%eax\n" -" shll %%cl, %%eax\n" -" decl %%eax\n" -" andl %%edx, %%eax\n" /* eax &= hold */ -" addl %%r15d, %%eax\n" /* eax += dist */ -" movl (%%r11,%%rax,4), %%eax\n" /* eax = dcode[val+(hold&mask[op])]*/ -" jmp .L_dodist\n" - -".align 32,0x90\n" -".L_clip_window:\n" -" movl %%eax, %%ecx\n" /* ecx = nbytes */ -" movl 92(%%rsp), %%eax\n" /* eax = wsize, prepare for dist cmp */ -" negl %%ecx\n" /* nbytes = -nbytes */ - -" cmpl %%r15d, %%eax\n" -" jb .L_invalid_distance_too_far\n" /* if (dist > wsize) */ - -" addl %%r15d, %%ecx\n" /* nbytes = dist - nbytes */ -" cmpl $0, 96(%%rsp)\n" -" jne .L_wrap_around_window\n" /* if (write != 0) */ - -" movq 56(%%rsp), %%rsi\n" /* from = window */ -" subl %%ecx, %%eax\n" /* eax -= nbytes */ -" addq %%rax, %%rsi\n" /* from += wsize - nbytes */ - -" movl %%r14d, %%eax\n" /* eax = len */ -" cmpl %%ecx, %%r14d\n" -" jbe .L_do_copy\n" /* if (nbytes >= len) */ - -" subl %%ecx, %%eax\n" /* eax -= nbytes */ -" rep movsb\n" -" movq %%rdi, %%rsi\n" -" subq %%r15, %%rsi\n" /* from = &out[ -dist ] */ -" jmp .L_do_copy\n" - -".align 32,0x90\n" -".L_wrap_around_window:\n" -" movl 96(%%rsp), %%eax\n" /* eax = write */ -" cmpl %%eax, %%ecx\n" -" jbe .L_contiguous_in_window\n" /* if (write >= nbytes) */ - -" movl 92(%%rsp), %%esi\n" /* from = wsize */ -" addq 56(%%rsp), %%rsi\n" /* from += window */ -" addq %%rax, %%rsi\n" /* from += write */ -" subq %%rcx, %%rsi\n" /* from -= nbytes */ -" subl %%eax, %%ecx\n" /* nbytes -= write */ - -" movl %%r14d, %%eax\n" /* eax = len */ -" cmpl %%ecx, %%eax\n" -" jbe .L_do_copy\n" /* if (nbytes >= len) */ - -" subl %%ecx, %%eax\n" /* len -= nbytes */ -" rep movsb\n" -" movq 56(%%rsp), %%rsi\n" /* from = window */ -" movl 96(%%rsp), %%ecx\n" /* nbytes = write */ -" cmpl %%ecx, %%eax\n" -" jbe .L_do_copy\n" /* if (nbytes >= len) */ - -" subl %%ecx, %%eax\n" /* len -= nbytes */ -" rep movsb\n" -" movq %%rdi, %%rsi\n" -" subq %%r15, %%rsi\n" /* from = out - dist */ -" jmp .L_do_copy\n" - -".align 32,0x90\n" -".L_contiguous_in_window:\n" -" movq 56(%%rsp), %%rsi\n" /* rsi = window */ -" addq %%rax, %%rsi\n" -" subq %%rcx, %%rsi\n" /* from += write - nbytes */ - -" movl %%r14d, %%eax\n" /* eax = len */ -" cmpl %%ecx, %%eax\n" -" jbe .L_do_copy\n" /* if (nbytes >= len) */ - -" subl %%ecx, %%eax\n" /* len -= nbytes */ -" rep movsb\n" -" movq %%rdi, %%rsi\n" -" subq %%r15, %%rsi\n" /* from = out - dist */ -" jmp .L_do_copy\n" /* if (nbytes >= len) */ - -".align 32,0x90\n" -".L_do_copy:\n" -" movl %%eax, %%ecx\n" /* ecx = len */ -" rep movsb\n" - -" movq %%r8, %%rsi\n" /* move in back to %esi, toss from */ -" jmp .L_while_test\n" - -".L_test_for_end_of_block:\n" -" testb $32, %%al\n" -" jz .L_invalid_literal_length_code\n" -" movl $1, 116(%%rsp)\n" -" jmp .L_break_loop_with_status\n" - -".L_invalid_literal_length_code:\n" -" movl $2, 116(%%rsp)\n" -" jmp .L_break_loop_with_status\n" - -".L_invalid_distance_code:\n" -" movl $3, 116(%%rsp)\n" -" jmp .L_break_loop_with_status\n" - -".L_invalid_distance_too_far:\n" -" movl $4, 116(%%rsp)\n" -" jmp .L_break_loop_with_status\n" - -".L_break_loop:\n" -" movl $0, 116(%%rsp)\n" - -".L_break_loop_with_status:\n" -/* put in, out, bits, and hold back into ar and pop esp */ -" movq %%rsi, 16(%%rsp)\n" /* in */ -" movq %%rdi, 32(%%rsp)\n" /* out */ -" movl %%ebx, 88(%%rsp)\n" /* bits */ -" movq %%rdx, 80(%%rsp)\n" /* hold */ -" movq (%%rsp), %%rax\n" /* restore rbp and rsp */ -" movq 8(%%rsp), %%rbp\n" -" movq %%rax, %%rsp\n" - : - : "m" (ar) - : "memory", "%rax", "%rbx", "%rcx", "%rdx", "%rsi", "%rdi", - "%r8", "%r9", "%r10", "%r11", "%r12", "%r13", "%r14", "%r15" - ); -#elif ( defined( __GNUC__ ) || defined( __ICC ) ) && defined( __i386 ) - __asm__ __volatile__ ( -" leal %0, %%eax\n" -" movl %%esp, (%%eax)\n" /* save esp, ebp */ -" movl %%ebp, 4(%%eax)\n" -" movl %%eax, %%esp\n" -" movl 8(%%esp), %%esi\n" /* esi = in */ -" movl 16(%%esp), %%edi\n" /* edi = out */ -" movl 40(%%esp), %%edx\n" /* edx = hold */ -" movl 44(%%esp), %%ebx\n" /* ebx = bits */ -" movl 32(%%esp), %%ebp\n" /* ebp = lcode */ - -" cld\n" -" jmp .L_do_loop\n" - -".align 32,0x90\n" -".L_while_test:\n" -" cmpl %%edi, 24(%%esp)\n" /* out < end */ -" jbe .L_break_loop\n" -" cmpl %%esi, 12(%%esp)\n" /* in < last */ -" jbe .L_break_loop\n" - -".L_do_loop:\n" -" cmpb $15, %%bl\n" -" ja .L_get_length_code\n" /* if (15 < bits) */ - -" xorl %%eax, %%eax\n" -" lodsw\n" /* al = *(ushort *)in++ */ -" movb %%bl, %%cl\n" /* cl = bits, needs it for shifting */ -" addb $16, %%bl\n" /* bits += 16 */ -" shll %%cl, %%eax\n" -" orl %%eax, %%edx\n" /* hold |= *((ushort *)in)++ << bits */ - -".L_get_length_code:\n" -" movl 56(%%esp), %%eax\n" /* eax = lmask */ -" andl %%edx, %%eax\n" /* eax &= hold */ -" movl (%%ebp,%%eax,4), %%eax\n" /* eax = lcode[hold & lmask] */ - -".L_dolen:\n" -" movb %%ah, %%cl\n" /* cl = this.bits */ -" subb %%ah, %%bl\n" /* bits -= this.bits */ -" shrl %%cl, %%edx\n" /* hold >>= this.bits */ - -" testb %%al, %%al\n" -" jnz .L_test_for_length_base\n" /* if (op != 0) 45.7% */ - -" shrl $16, %%eax\n" /* output this.val char */ -" stosb\n" -" jmp .L_while_test\n" - -".align 32,0x90\n" -".L_test_for_length_base:\n" -" movl %%eax, %%ecx\n" /* len = this */ -" shrl $16, %%ecx\n" /* len = this.val */ -" movl %%ecx, 64(%%esp)\n" /* save len */ -" movb %%al, %%cl\n" - -" testb $16, %%al\n" -" jz .L_test_for_second_level_length\n" /* if ((op & 16) == 0) 8% */ -" andb $15, %%cl\n" /* op &= 15 */ -" jz .L_decode_distance\n" /* if (!op) */ -" cmpb %%cl, %%bl\n" -" jae .L_add_bits_to_len\n" /* if (op <= bits) */ - -" movb %%cl, %%ch\n" /* stash op in ch, freeing cl */ -" xorl %%eax, %%eax\n" -" lodsw\n" /* al = *(ushort *)in++ */ -" movb %%bl, %%cl\n" /* cl = bits, needs it for shifting */ -" addb $16, %%bl\n" /* bits += 16 */ -" shll %%cl, %%eax\n" -" orl %%eax, %%edx\n" /* hold |= *((ushort *)in)++ << bits */ -" movb %%ch, %%cl\n" /* move op back to ecx */ - -".L_add_bits_to_len:\n" -" subb %%cl, %%bl\n" -" xorl %%eax, %%eax\n" -" incl %%eax\n" -" shll %%cl, %%eax\n" -" decl %%eax\n" -" andl %%edx, %%eax\n" /* eax &= hold */ -" shrl %%cl, %%edx\n" -" addl %%eax, 64(%%esp)\n" /* len += hold & mask[op] */ - -".L_decode_distance:\n" -" cmpb $15, %%bl\n" -" ja .L_get_distance_code\n" /* if (15 < bits) */ - -" xorl %%eax, %%eax\n" -" lodsw\n" /* al = *(ushort *)in++ */ -" movb %%bl, %%cl\n" /* cl = bits, needs it for shifting */ -" addb $16, %%bl\n" /* bits += 16 */ -" shll %%cl, %%eax\n" -" orl %%eax, %%edx\n" /* hold |= *((ushort *)in)++ << bits */ - -".L_get_distance_code:\n" -" movl 60(%%esp), %%eax\n" /* eax = dmask */ -" movl 36(%%esp), %%ecx\n" /* ecx = dcode */ -" andl %%edx, %%eax\n" /* eax &= hold */ -" movl (%%ecx,%%eax,4), %%eax\n"/* eax = dcode[hold & dmask] */ - -".L_dodist:\n" -" movl %%eax, %%ebp\n" /* dist = this */ -" shrl $16, %%ebp\n" /* dist = this.val */ -" movb %%ah, %%cl\n" -" subb %%ah, %%bl\n" /* bits -= this.bits */ -" shrl %%cl, %%edx\n" /* hold >>= this.bits */ -" movb %%al, %%cl\n" /* cl = this.op */ - -" testb $16, %%al\n" /* if ((op & 16) == 0) */ -" jz .L_test_for_second_level_dist\n" -" andb $15, %%cl\n" /* op &= 15 */ -" jz .L_check_dist_one\n" -" cmpb %%cl, %%bl\n" -" jae .L_add_bits_to_dist\n" /* if (op <= bits) 97.6% */ - -" movb %%cl, %%ch\n" /* stash op in ch, freeing cl */ -" xorl %%eax, %%eax\n" -" lodsw\n" /* al = *(ushort *)in++ */ -" movb %%bl, %%cl\n" /* cl = bits, needs it for shifting */ -" addb $16, %%bl\n" /* bits += 16 */ -" shll %%cl, %%eax\n" -" orl %%eax, %%edx\n" /* hold |= *((ushort *)in)++ << bits */ -" movb %%ch, %%cl\n" /* move op back to ecx */ - -".L_add_bits_to_dist:\n" -" subb %%cl, %%bl\n" -" xorl %%eax, %%eax\n" -" incl %%eax\n" -" shll %%cl, %%eax\n" -" decl %%eax\n" /* (1 << op) - 1 */ -" andl %%edx, %%eax\n" /* eax &= hold */ -" shrl %%cl, %%edx\n" -" addl %%eax, %%ebp\n" /* dist += hold & ((1 << op) - 1) */ - -".L_check_window:\n" -" movl %%esi, 8(%%esp)\n" /* save in so from can use it's reg */ -" movl %%edi, %%eax\n" -" subl 20(%%esp), %%eax\n" /* nbytes = out - beg */ - -" cmpl %%ebp, %%eax\n" -" jb .L_clip_window\n" /* if (dist > nbytes) 4.2% */ - -" movl 64(%%esp), %%ecx\n" /* ecx = len */ -" movl %%edi, %%esi\n" -" subl %%ebp, %%esi\n" /* from = out - dist */ - -" sarl %%ecx\n" -" jnc .L_copy_two\n" /* if len % 2 == 0 */ - -" rep movsw\n" -" movb (%%esi), %%al\n" -" movb %%al, (%%edi)\n" -" incl %%edi\n" - -" movl 8(%%esp), %%esi\n" /* move in back to %esi, toss from */ -" movl 32(%%esp), %%ebp\n" /* ebp = lcode */ -" jmp .L_while_test\n" - -".L_copy_two:\n" -" rep movsw\n" -" movl 8(%%esp), %%esi\n" /* move in back to %esi, toss from */ -" movl 32(%%esp), %%ebp\n" /* ebp = lcode */ -" jmp .L_while_test\n" - -".align 32,0x90\n" -".L_check_dist_one:\n" -" cmpl $1, %%ebp\n" /* if dist 1, is a memset */ -" jne .L_check_window\n" -" cmpl %%edi, 20(%%esp)\n" -" je .L_check_window\n" /* out == beg, if outside window */ - -" movl 64(%%esp), %%ecx\n" /* ecx = len */ -" movb -1(%%edi), %%al\n" -" movb %%al, %%ah\n" - -" sarl %%ecx\n" -" jnc .L_set_two\n" -" movb %%al, (%%edi)\n" -" incl %%edi\n" - -".L_set_two:\n" -" rep stosw\n" -" movl 32(%%esp), %%ebp\n" /* ebp = lcode */ -" jmp .L_while_test\n" - -".align 32,0x90\n" -".L_test_for_second_level_length:\n" -" testb $64, %%al\n" -" jnz .L_test_for_end_of_block\n" /* if ((op & 64) != 0) */ - -" xorl %%eax, %%eax\n" -" incl %%eax\n" -" shll %%cl, %%eax\n" -" decl %%eax\n" -" andl %%edx, %%eax\n" /* eax &= hold */ -" addl 64(%%esp), %%eax\n" /* eax += len */ -" movl (%%ebp,%%eax,4), %%eax\n" /* eax = lcode[val+(hold&mask[op])]*/ -" jmp .L_dolen\n" - -".align 32,0x90\n" -".L_test_for_second_level_dist:\n" -" testb $64, %%al\n" -" jnz .L_invalid_distance_code\n" /* if ((op & 64) != 0) */ - -" xorl %%eax, %%eax\n" -" incl %%eax\n" -" shll %%cl, %%eax\n" -" decl %%eax\n" -" andl %%edx, %%eax\n" /* eax &= hold */ -" addl %%ebp, %%eax\n" /* eax += dist */ -" movl 36(%%esp), %%ecx\n" /* ecx = dcode */ -" movl (%%ecx,%%eax,4), %%eax\n" /* eax = dcode[val+(hold&mask[op])]*/ -" jmp .L_dodist\n" - -".align 32,0x90\n" -".L_clip_window:\n" -" movl %%eax, %%ecx\n" -" movl 48(%%esp), %%eax\n" /* eax = wsize */ -" negl %%ecx\n" /* nbytes = -nbytes */ -" movl 28(%%esp), %%esi\n" /* from = window */ - -" cmpl %%ebp, %%eax\n" -" jb .L_invalid_distance_too_far\n" /* if (dist > wsize) */ - -" addl %%ebp, %%ecx\n" /* nbytes = dist - nbytes */ -" cmpl $0, 52(%%esp)\n" -" jne .L_wrap_around_window\n" /* if (write != 0) */ - -" subl %%ecx, %%eax\n" -" addl %%eax, %%esi\n" /* from += wsize - nbytes */ - -" movl 64(%%esp), %%eax\n" /* eax = len */ -" cmpl %%ecx, %%eax\n" -" jbe .L_do_copy\n" /* if (nbytes >= len) */ - -" subl %%ecx, %%eax\n" /* len -= nbytes */ -" rep movsb\n" -" movl %%edi, %%esi\n" -" subl %%ebp, %%esi\n" /* from = out - dist */ -" jmp .L_do_copy\n" - -".align 32,0x90\n" -".L_wrap_around_window:\n" -" movl 52(%%esp), %%eax\n" /* eax = write */ -" cmpl %%eax, %%ecx\n" -" jbe .L_contiguous_in_window\n" /* if (write >= nbytes) */ - -" addl 48(%%esp), %%esi\n" /* from += wsize */ -" addl %%eax, %%esi\n" /* from += write */ -" subl %%ecx, %%esi\n" /* from -= nbytes */ -" subl %%eax, %%ecx\n" /* nbytes -= write */ - -" movl 64(%%esp), %%eax\n" /* eax = len */ -" cmpl %%ecx, %%eax\n" -" jbe .L_do_copy\n" /* if (nbytes >= len) */ - -" subl %%ecx, %%eax\n" /* len -= nbytes */ -" rep movsb\n" -" movl 28(%%esp), %%esi\n" /* from = window */ -" movl 52(%%esp), %%ecx\n" /* nbytes = write */ -" cmpl %%ecx, %%eax\n" -" jbe .L_do_copy\n" /* if (nbytes >= len) */ - -" subl %%ecx, %%eax\n" /* len -= nbytes */ -" rep movsb\n" -" movl %%edi, %%esi\n" -" subl %%ebp, %%esi\n" /* from = out - dist */ -" jmp .L_do_copy\n" - -".align 32,0x90\n" -".L_contiguous_in_window:\n" -" addl %%eax, %%esi\n" -" subl %%ecx, %%esi\n" /* from += write - nbytes */ - -" movl 64(%%esp), %%eax\n" /* eax = len */ -" cmpl %%ecx, %%eax\n" -" jbe .L_do_copy\n" /* if (nbytes >= len) */ - -" subl %%ecx, %%eax\n" /* len -= nbytes */ -" rep movsb\n" -" movl %%edi, %%esi\n" -" subl %%ebp, %%esi\n" /* from = out - dist */ -" jmp .L_do_copy\n" /* if (nbytes >= len) */ - -".align 32,0x90\n" -".L_do_copy:\n" -" movl %%eax, %%ecx\n" -" rep movsb\n" - -" movl 8(%%esp), %%esi\n" /* move in back to %esi, toss from */ -" movl 32(%%esp), %%ebp\n" /* ebp = lcode */ -" jmp .L_while_test\n" - -".L_test_for_end_of_block:\n" -" testb $32, %%al\n" -" jz .L_invalid_literal_length_code\n" -" movl $1, 72(%%esp)\n" -" jmp .L_break_loop_with_status\n" - -".L_invalid_literal_length_code:\n" -" movl $2, 72(%%esp)\n" -" jmp .L_break_loop_with_status\n" - -".L_invalid_distance_code:\n" -" movl $3, 72(%%esp)\n" -" jmp .L_break_loop_with_status\n" - -".L_invalid_distance_too_far:\n" -" movl 8(%%esp), %%esi\n" -" movl $4, 72(%%esp)\n" -" jmp .L_break_loop_with_status\n" - -".L_break_loop:\n" -" movl $0, 72(%%esp)\n" - -".L_break_loop_with_status:\n" -/* put in, out, bits, and hold back into ar and pop esp */ -" movl %%esi, 8(%%esp)\n" /* save in */ -" movl %%edi, 16(%%esp)\n" /* save out */ -" movl %%ebx, 44(%%esp)\n" /* save bits */ -" movl %%edx, 40(%%esp)\n" /* save hold */ -" movl 4(%%esp), %%ebp\n" /* restore esp, ebp */ -" movl (%%esp), %%esp\n" - : - : "m" (ar) - : "memory", "%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi" - ); -#elif defined( _MSC_VER ) && ! defined( _M_AMD64 ) - __asm { - lea eax, ar - mov [eax], esp /* save esp, ebp */ - mov [eax+4], ebp - mov esp, eax - mov esi, [esp+8] /* esi = in */ - mov edi, [esp+16] /* edi = out */ - mov edx, [esp+40] /* edx = hold */ - mov ebx, [esp+44] /* ebx = bits */ - mov ebp, [esp+32] /* ebp = lcode */ - - cld - jmp L_do_loop - -ALIGN 4 -L_while_test: - cmp [esp+24], edi - jbe L_break_loop - cmp [esp+12], esi - jbe L_break_loop - -L_do_loop: - cmp bl, 15 - ja L_get_length_code /* if (15 < bits) */ - - xor eax, eax - lodsw /* al = *(ushort *)in++ */ - mov cl, bl /* cl = bits, needs it for shifting */ - add bl, 16 /* bits += 16 */ - shl eax, cl - or edx, eax /* hold |= *((ushort *)in)++ << bits */ - -L_get_length_code: - mov eax, [esp+56] /* eax = lmask */ - and eax, edx /* eax &= hold */ - mov eax, [ebp+eax*4] /* eax = lcode[hold & lmask] */ - -L_dolen: - mov cl, ah /* cl = this.bits */ - sub bl, ah /* bits -= this.bits */ - shr edx, cl /* hold >>= this.bits */ - - test al, al - jnz L_test_for_length_base /* if (op != 0) 45.7% */ - - shr eax, 16 /* output this.val char */ - stosb - jmp L_while_test - -ALIGN 4 -L_test_for_length_base: - mov ecx, eax /* len = this */ - shr ecx, 16 /* len = this.val */ - mov [esp+64], ecx /* save len */ - mov cl, al - - test al, 16 - jz L_test_for_second_level_length /* if ((op & 16) == 0) 8% */ - and cl, 15 /* op &= 15 */ - jz L_decode_distance /* if (!op) */ - cmp bl, cl - jae L_add_bits_to_len /* if (op <= bits) */ - - mov ch, cl /* stash op in ch, freeing cl */ - xor eax, eax - lodsw /* al = *(ushort *)in++ */ - mov cl, bl /* cl = bits, needs it for shifting */ - add bl, 16 /* bits += 16 */ - shl eax, cl - or edx, eax /* hold |= *((ushort *)in)++ << bits */ - mov cl, ch /* move op back to ecx */ - -L_add_bits_to_len: - sub bl, cl - xor eax, eax - inc eax - shl eax, cl - dec eax - and eax, edx /* eax &= hold */ - shr edx, cl - add [esp+64], eax /* len += hold & mask[op] */ - -L_decode_distance: - cmp bl, 15 - ja L_get_distance_code /* if (15 < bits) */ - - xor eax, eax - lodsw /* al = *(ushort *)in++ */ - mov cl, bl /* cl = bits, needs it for shifting */ - add bl, 16 /* bits += 16 */ - shl eax, cl - or edx, eax /* hold |= *((ushort *)in)++ << bits */ - -L_get_distance_code: - mov eax, [esp+60] /* eax = dmask */ - mov ecx, [esp+36] /* ecx = dcode */ - and eax, edx /* eax &= hold */ - mov eax, [ecx+eax*4]/* eax = dcode[hold & dmask] */ - -L_dodist: - mov ebp, eax /* dist = this */ - shr ebp, 16 /* dist = this.val */ - mov cl, ah - sub bl, ah /* bits -= this.bits */ - shr edx, cl /* hold >>= this.bits */ - mov cl, al /* cl = this.op */ - - test al, 16 /* if ((op & 16) == 0) */ - jz L_test_for_second_level_dist - and cl, 15 /* op &= 15 */ - jz L_check_dist_one - cmp bl, cl - jae L_add_bits_to_dist /* if (op <= bits) 97.6% */ - - mov ch, cl /* stash op in ch, freeing cl */ - xor eax, eax - lodsw /* al = *(ushort *)in++ */ - mov cl, bl /* cl = bits, needs it for shifting */ - add bl, 16 /* bits += 16 */ - shl eax, cl - or edx, eax /* hold |= *((ushort *)in)++ << bits */ - mov cl, ch /* move op back to ecx */ - -L_add_bits_to_dist: - sub bl, cl - xor eax, eax - inc eax - shl eax, cl - dec eax /* (1 << op) - 1 */ - and eax, edx /* eax &= hold */ - shr edx, cl - add ebp, eax /* dist += hold & ((1 << op) - 1) */ - -L_check_window: - mov [esp+8], esi /* save in so from can use it's reg */ - mov eax, edi - sub eax, [esp+20] /* nbytes = out - beg */ - - cmp eax, ebp - jb L_clip_window /* if (dist > nbytes) 4.2% */ - - mov ecx, [esp+64] /* ecx = len */ - mov esi, edi - sub esi, ebp /* from = out - dist */ - - sar ecx, 1 - jnc L_copy_two - - rep movsw - mov al, [esi] - mov [edi], al - inc edi - - mov esi, [esp+8] /* move in back to %esi, toss from */ - mov ebp, [esp+32] /* ebp = lcode */ - jmp L_while_test - -L_copy_two: - rep movsw - mov esi, [esp+8] /* move in back to %esi, toss from */ - mov ebp, [esp+32] /* ebp = lcode */ - jmp L_while_test - -ALIGN 4 -L_check_dist_one: - cmp ebp, 1 /* if dist 1, is a memset */ - jne L_check_window - cmp [esp+20], edi - je L_check_window /* out == beg, if outside window */ - - mov ecx, [esp+64] /* ecx = len */ - mov al, [edi-1] - mov ah, al - - sar ecx, 1 - jnc L_set_two - mov [edi], al /* memset out with from[-1] */ - inc edi - -L_set_two: - rep stosw - mov ebp, [esp+32] /* ebp = lcode */ - jmp L_while_test - -ALIGN 4 -L_test_for_second_level_length: - test al, 64 - jnz L_test_for_end_of_block /* if ((op & 64) != 0) */ - - xor eax, eax - inc eax - shl eax, cl - dec eax - and eax, edx /* eax &= hold */ - add eax, [esp+64] /* eax += len */ - mov eax, [ebp+eax*4] /* eax = lcode[val+(hold&mask[op])]*/ - jmp L_dolen - -ALIGN 4 -L_test_for_second_level_dist: - test al, 64 - jnz L_invalid_distance_code /* if ((op & 64) != 0) */ - - xor eax, eax - inc eax - shl eax, cl - dec eax - and eax, edx /* eax &= hold */ - add eax, ebp /* eax += dist */ - mov ecx, [esp+36] /* ecx = dcode */ - mov eax, [ecx+eax*4] /* eax = dcode[val+(hold&mask[op])]*/ - jmp L_dodist - -ALIGN 4 -L_clip_window: - mov ecx, eax - mov eax, [esp+48] /* eax = wsize */ - neg ecx /* nbytes = -nbytes */ - mov esi, [esp+28] /* from = window */ - - cmp eax, ebp - jb L_invalid_distance_too_far /* if (dist > wsize) */ - - add ecx, ebp /* nbytes = dist - nbytes */ - cmp dword ptr [esp+52], 0 - jne L_wrap_around_window /* if (write != 0) */ - - sub eax, ecx - add esi, eax /* from += wsize - nbytes */ - - mov eax, [esp+64] /* eax = len */ - cmp eax, ecx - jbe L_do_copy /* if (nbytes >= len) */ - - sub eax, ecx /* len -= nbytes */ - rep movsb - mov esi, edi - sub esi, ebp /* from = out - dist */ - jmp L_do_copy - -ALIGN 4 -L_wrap_around_window: - mov eax, [esp+52] /* eax = write */ - cmp ecx, eax - jbe L_contiguous_in_window /* if (write >= nbytes) */ - - add esi, [esp+48] /* from += wsize */ - add esi, eax /* from += write */ - sub esi, ecx /* from -= nbytes */ - sub ecx, eax /* nbytes -= write */ - - mov eax, [esp+64] /* eax = len */ - cmp eax, ecx - jbe L_do_copy /* if (nbytes >= len) */ - - sub eax, ecx /* len -= nbytes */ - rep movsb - mov esi, [esp+28] /* from = window */ - mov ecx, [esp+52] /* nbytes = write */ - cmp eax, ecx - jbe L_do_copy /* if (nbytes >= len) */ - - sub eax, ecx /* len -= nbytes */ - rep movsb - mov esi, edi - sub esi, ebp /* from = out - dist */ - jmp L_do_copy - -ALIGN 4 -L_contiguous_in_window: - add esi, eax - sub esi, ecx /* from += write - nbytes */ - - mov eax, [esp+64] /* eax = len */ - cmp eax, ecx - jbe L_do_copy /* if (nbytes >= len) */ - - sub eax, ecx /* len -= nbytes */ - rep movsb - mov esi, edi - sub esi, ebp /* from = out - dist */ - jmp L_do_copy - -ALIGN 4 -L_do_copy: - mov ecx, eax - rep movsb - - mov esi, [esp+8] /* move in back to %esi, toss from */ - mov ebp, [esp+32] /* ebp = lcode */ - jmp L_while_test - -L_test_for_end_of_block: - test al, 32 - jz L_invalid_literal_length_code - mov dword ptr [esp+72], 1 - jmp L_break_loop_with_status - -L_invalid_literal_length_code: - mov dword ptr [esp+72], 2 - jmp L_break_loop_with_status - -L_invalid_distance_code: - mov dword ptr [esp+72], 3 - jmp L_break_loop_with_status - -L_invalid_distance_too_far: - mov esi, [esp+4] - mov dword ptr [esp+72], 4 - jmp L_break_loop_with_status - -L_break_loop: - mov dword ptr [esp+72], 0 - -L_break_loop_with_status: -/* put in, out, bits, and hold back into ar and pop esp */ - mov [esp+8], esi /* save in */ - mov [esp+16], edi /* save out */ - mov [esp+44], ebx /* save bits */ - mov [esp+40], edx /* save hold */ - mov ebp, [esp+4] /* restore esp, ebp */ - mov esp, [esp] - } -#else -#error "x86 architecture not defined" -#endif - - if (ar.status > 1) { - if (ar.status == 2) - strm->msg = "invalid literal/length code"; - else if (ar.status == 3) - strm->msg = "invalid distance code"; - else - strm->msg = "invalid distance too far back"; - state->mode = BAD; - } - else if ( ar.status == 1 ) { - state->mode = TYPE; - } - - /* return unused bytes (on entry, bits < 8, so in won't go too far back) */ - ar.len = ar.bits >> 3; - ar.in -= ar.len; - ar.bits -= ar.len << 3; - ar.hold &= (1U << ar.bits) - 1; - - /* update state and return */ - strm->next_in = ar.in; - strm->next_out = ar.out; - strm->avail_in = (unsigned)(ar.in < ar.last ? - PAD_AVAIL_IN + (ar.last - ar.in) : - PAD_AVAIL_IN - (ar.in - ar.last)); - strm->avail_out = (unsigned)(ar.out < ar.end ? - PAD_AVAIL_OUT + (ar.end - ar.out) : - PAD_AVAIL_OUT - (ar.out - ar.end)); - state->hold = ar.hold; - state->bits = ar.bits; - return; -} - DELETED compat/zlib/contrib/inflate86/inffast.S Index: compat/zlib/contrib/inflate86/inffast.S ================================================================== --- compat/zlib/contrib/inflate86/inffast.S +++ /dev/null @@ -1,1368 +0,0 @@ -/* - * inffast.S is a hand tuned assembler version of: - * - * inffast.c -- fast decoding - * Copyright (C) 1995-2003 Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - * - * Copyright (C) 2003 Chris Anderson - * Please use the copyright conditions above. - * - * This version (Jan-23-2003) of inflate_fast was coded and tested under - * GNU/Linux on a pentium 3, using the gcc-3.2 compiler distribution. On that - * machine, I found that gzip style archives decompressed about 20% faster than - * the gcc-3.2 -O3 -fomit-frame-pointer compiled version. Your results will - * depend on how large of a buffer is used for z_stream.next_in & next_out - * (8K-32K worked best for my 256K cpu cache) and how much overhead there is in - * stream processing I/O and crc32/addler32. In my case, this routine used - * 70% of the cpu time and crc32 used 20%. - * - * I am confident that this version will work in the general case, but I have - * not tested a wide variety of datasets or a wide variety of platforms. - * - * Jan-24-2003 -- Added -DUSE_MMX define for slightly faster inflating. - * It should be a runtime flag instead of compile time flag... - * - * Jan-26-2003 -- Added runtime check for MMX support with cpuid instruction. - * With -DUSE_MMX, only MMX code is compiled. With -DNO_MMX, only non-MMX code - * is compiled. Without either option, runtime detection is enabled. Runtime - * detection should work on all modern cpus and the recomended algorithm (flip - * ID bit on eflags and then use the cpuid instruction) is used in many - * multimedia applications. Tested under win2k with gcc-2.95 and gas-2.12 - * distributed with cygwin3. Compiling with gcc-2.95 -c inffast.S -o - * inffast.obj generates a COFF object which can then be linked with MSVC++ - * compiled code. Tested under FreeBSD 4.7 with gcc-2.95. - * - * Jan-28-2003 -- Tested Athlon XP... MMX mode is slower than no MMX (and - * slower than compiler generated code). Adjusted cpuid check to use the MMX - * code only for Pentiums < P4 until I have more data on the P4. Speed - * improvment is only about 15% on the Athlon when compared with code generated - * with MSVC++. Not sure yet, but I think the P4 will also be slower using the - * MMX mode because many of it's x86 ALU instructions execute in .5 cycles and - * have less latency than MMX ops. Added code to buffer the last 11 bytes of - * the input stream since the MMX code grabs bits in chunks of 32, which - * differs from the inffast.c algorithm. I don't think there would have been - * read overruns where a page boundary was crossed (a segfault), but there - * could have been overruns when next_in ends on unaligned memory (unintialized - * memory read). - * - * Mar-13-2003 -- P4 MMX is slightly slower than P4 NO_MMX. I created a C - * version of the non-MMX code so that it doesn't depend on zstrm and zstate - * structure offsets which are hard coded in this file. This was last tested - * with zlib-1.2.0 which is currently in beta testing, newer versions of this - * and inffas86.c can be found at http://www.eetbeetee.com/zlib/ and - * http://www.charm.net/~christop/zlib/ - */ - - -/* - * if you have underscore linking problems (_inflate_fast undefined), try - * using -DGAS_COFF - */ -#if ! defined( GAS_COFF ) && ! defined( GAS_ELF ) - -#if defined( WIN32 ) || defined( __CYGWIN__ ) -#define GAS_COFF /* windows object format */ -#else -#define GAS_ELF -#endif - -#endif /* ! GAS_COFF && ! GAS_ELF */ - - -#if defined( GAS_COFF ) - -/* coff externals have underscores */ -#define inflate_fast _inflate_fast -#define inflate_fast_use_mmx _inflate_fast_use_mmx - -#endif /* GAS_COFF */ - - -.file "inffast.S" - -.globl inflate_fast - -.text -.align 4,0 -.L_invalid_literal_length_code_msg: -.string "invalid literal/length code" - -.align 4,0 -.L_invalid_distance_code_msg: -.string "invalid distance code" - -.align 4,0 -.L_invalid_distance_too_far_msg: -.string "invalid distance too far back" - -#if ! defined( NO_MMX ) -.align 4,0 -.L_mask: /* mask[N] = ( 1 << N ) - 1 */ -.long 0 -.long 1 -.long 3 -.long 7 -.long 15 -.long 31 -.long 63 -.long 127 -.long 255 -.long 511 -.long 1023 -.long 2047 -.long 4095 -.long 8191 -.long 16383 -.long 32767 -.long 65535 -.long 131071 -.long 262143 -.long 524287 -.long 1048575 -.long 2097151 -.long 4194303 -.long 8388607 -.long 16777215 -.long 33554431 -.long 67108863 -.long 134217727 -.long 268435455 -.long 536870911 -.long 1073741823 -.long 2147483647 -.long 4294967295 -#endif /* NO_MMX */ - -.text - -/* - * struct z_stream offsets, in zlib.h - */ -#define next_in_strm 0 /* strm->next_in */ -#define avail_in_strm 4 /* strm->avail_in */ -#define next_out_strm 12 /* strm->next_out */ -#define avail_out_strm 16 /* strm->avail_out */ -#define msg_strm 24 /* strm->msg */ -#define state_strm 28 /* strm->state */ - -/* - * struct inflate_state offsets, in inflate.h - */ -#define mode_state 0 /* state->mode */ -#define wsize_state 32 /* state->wsize */ -#define write_state 40 /* state->write */ -#define window_state 44 /* state->window */ -#define hold_state 48 /* state->hold */ -#define bits_state 52 /* state->bits */ -#define lencode_state 68 /* state->lencode */ -#define distcode_state 72 /* state->distcode */ -#define lenbits_state 76 /* state->lenbits */ -#define distbits_state 80 /* state->distbits */ - -/* - * inflate_fast's activation record - */ -#define local_var_size 64 /* how much local space for vars */ -#define strm_sp 88 /* first arg: z_stream * (local_var_size + 24) */ -#define start_sp 92 /* second arg: unsigned int (local_var_size + 28) */ - -/* - * offsets for local vars on stack - */ -#define out 60 /* unsigned char* */ -#define window 56 /* unsigned char* */ -#define wsize 52 /* unsigned int */ -#define write 48 /* unsigned int */ -#define in 44 /* unsigned char* */ -#define beg 40 /* unsigned char* */ -#define buf 28 /* char[ 12 ] */ -#define len 24 /* unsigned int */ -#define last 20 /* unsigned char* */ -#define end 16 /* unsigned char* */ -#define dcode 12 /* code* */ -#define lcode 8 /* code* */ -#define dmask 4 /* unsigned int */ -#define lmask 0 /* unsigned int */ - -/* - * typedef enum inflate_mode consts, in inflate.h - */ -#define INFLATE_MODE_TYPE 11 /* state->mode flags enum-ed in inflate.h */ -#define INFLATE_MODE_BAD 26 - - -#if ! defined( USE_MMX ) && ! defined( NO_MMX ) - -#define RUN_TIME_MMX - -#define CHECK_MMX 1 -#define DO_USE_MMX 2 -#define DONT_USE_MMX 3 - -.globl inflate_fast_use_mmx - -.data - -.align 4,0 -inflate_fast_use_mmx: /* integer flag for run time control 1=check,2=mmx,3=no */ -.long CHECK_MMX - -#if defined( GAS_ELF ) -/* elf info */ -.type inflate_fast_use_mmx,@object -.size inflate_fast_use_mmx,4 -#endif - -#endif /* RUN_TIME_MMX */ - -#if defined( GAS_COFF ) -/* coff info: scl 2 = extern, type 32 = function */ -.def inflate_fast; .scl 2; .type 32; .endef -#endif - -.text - -.align 32,0x90 -inflate_fast: - pushl %edi - pushl %esi - pushl %ebp - pushl %ebx - pushf /* save eflags (strm_sp, state_sp assumes this is 32 bits) */ - subl $local_var_size, %esp - cld - -#define strm_r %esi -#define state_r %edi - - movl strm_sp(%esp), strm_r - movl state_strm(strm_r), state_r - - /* in = strm->next_in; - * out = strm->next_out; - * last = in + strm->avail_in - 11; - * beg = out - (start - strm->avail_out); - * end = out + (strm->avail_out - 257); - */ - movl avail_in_strm(strm_r), %edx - movl next_in_strm(strm_r), %eax - - addl %eax, %edx /* avail_in += next_in */ - subl $11, %edx /* avail_in -= 11 */ - - movl %eax, in(%esp) - movl %edx, last(%esp) - - movl start_sp(%esp), %ebp - movl avail_out_strm(strm_r), %ecx - movl next_out_strm(strm_r), %ebx - - subl %ecx, %ebp /* start -= avail_out */ - negl %ebp /* start = -start */ - addl %ebx, %ebp /* start += next_out */ - - subl $257, %ecx /* avail_out -= 257 */ - addl %ebx, %ecx /* avail_out += out */ - - movl %ebx, out(%esp) - movl %ebp, beg(%esp) - movl %ecx, end(%esp) - - /* wsize = state->wsize; - * write = state->write; - * window = state->window; - * hold = state->hold; - * bits = state->bits; - * lcode = state->lencode; - * dcode = state->distcode; - * lmask = ( 1 << state->lenbits ) - 1; - * dmask = ( 1 << state->distbits ) - 1; - */ - - movl lencode_state(state_r), %eax - movl distcode_state(state_r), %ecx - - movl %eax, lcode(%esp) - movl %ecx, dcode(%esp) - - movl $1, %eax - movl lenbits_state(state_r), %ecx - shll %cl, %eax - decl %eax - movl %eax, lmask(%esp) - - movl $1, %eax - movl distbits_state(state_r), %ecx - shll %cl, %eax - decl %eax - movl %eax, dmask(%esp) - - movl wsize_state(state_r), %eax - movl write_state(state_r), %ecx - movl window_state(state_r), %edx - - movl %eax, wsize(%esp) - movl %ecx, write(%esp) - movl %edx, window(%esp) - - movl hold_state(state_r), %ebp - movl bits_state(state_r), %ebx - -#undef strm_r -#undef state_r - -#define in_r %esi -#define from_r %esi -#define out_r %edi - - movl in(%esp), in_r - movl last(%esp), %ecx - cmpl in_r, %ecx - ja .L_align_long /* if in < last */ - - addl $11, %ecx /* ecx = &in[ avail_in ] */ - subl in_r, %ecx /* ecx = avail_in */ - movl $12, %eax - subl %ecx, %eax /* eax = 12 - avail_in */ - leal buf(%esp), %edi - rep movsb /* memcpy( buf, in, avail_in ) */ - movl %eax, %ecx - xorl %eax, %eax - rep stosb /* memset( &buf[ avail_in ], 0, 12 - avail_in ) */ - leal buf(%esp), in_r /* in = buf */ - movl in_r, last(%esp) /* last = in, do just one iteration */ - jmp .L_is_aligned - - /* align in_r on long boundary */ -.L_align_long: - testl $3, in_r - jz .L_is_aligned - xorl %eax, %eax - movb (in_r), %al - incl in_r - movl %ebx, %ecx - addl $8, %ebx - shll %cl, %eax - orl %eax, %ebp - jmp .L_align_long - -.L_is_aligned: - movl out(%esp), out_r - -#if defined( NO_MMX ) - jmp .L_do_loop -#endif - -#if defined( USE_MMX ) - jmp .L_init_mmx -#endif - -/*** Runtime MMX check ***/ - -#if defined( RUN_TIME_MMX ) -.L_check_mmx: - cmpl $DO_USE_MMX, inflate_fast_use_mmx - je .L_init_mmx - ja .L_do_loop /* > 2 */ - - pushl %eax - pushl %ebx - pushl %ecx - pushl %edx - pushf - movl (%esp), %eax /* copy eflags to eax */ - xorl $0x200000, (%esp) /* try toggling ID bit of eflags (bit 21) - * to see if cpu supports cpuid... - * ID bit method not supported by NexGen but - * bios may load a cpuid instruction and - * cpuid may be disabled on Cyrix 5-6x86 */ - popf - pushf - popl %edx /* copy new eflags to edx */ - xorl %eax, %edx /* test if ID bit is flipped */ - jz .L_dont_use_mmx /* not flipped if zero */ - xorl %eax, %eax - cpuid - cmpl $0x756e6547, %ebx /* check for GenuineIntel in ebx,ecx,edx */ - jne .L_dont_use_mmx - cmpl $0x6c65746e, %ecx - jne .L_dont_use_mmx - cmpl $0x49656e69, %edx - jne .L_dont_use_mmx - movl $1, %eax - cpuid /* get cpu features */ - shrl $8, %eax - andl $15, %eax - cmpl $6, %eax /* check for Pentium family, is 0xf for P4 */ - jne .L_dont_use_mmx - testl $0x800000, %edx /* test if MMX feature is set (bit 23) */ - jnz .L_use_mmx - jmp .L_dont_use_mmx -.L_use_mmx: - movl $DO_USE_MMX, inflate_fast_use_mmx - jmp .L_check_mmx_pop -.L_dont_use_mmx: - movl $DONT_USE_MMX, inflate_fast_use_mmx -.L_check_mmx_pop: - popl %edx - popl %ecx - popl %ebx - popl %eax - jmp .L_check_mmx -#endif - - -/*** Non-MMX code ***/ - -#if defined ( NO_MMX ) || defined( RUN_TIME_MMX ) - -#define hold_r %ebp -#define bits_r %bl -#define bitslong_r %ebx - -.align 32,0x90 -.L_while_test: - /* while (in < last && out < end) - */ - cmpl out_r, end(%esp) - jbe .L_break_loop /* if (out >= end) */ - - cmpl in_r, last(%esp) - jbe .L_break_loop - -.L_do_loop: - /* regs: %esi = in, %ebp = hold, %bl = bits, %edi = out - * - * do { - * if (bits < 15) { - * hold |= *((unsigned short *)in)++ << bits; - * bits += 16 - * } - * this = lcode[hold & lmask] - */ - cmpb $15, bits_r - ja .L_get_length_code /* if (15 < bits) */ - - xorl %eax, %eax - lodsw /* al = *(ushort *)in++ */ - movb bits_r, %cl /* cl = bits, needs it for shifting */ - addb $16, bits_r /* bits += 16 */ - shll %cl, %eax - orl %eax, hold_r /* hold |= *((ushort *)in)++ << bits */ - -.L_get_length_code: - movl lmask(%esp), %edx /* edx = lmask */ - movl lcode(%esp), %ecx /* ecx = lcode */ - andl hold_r, %edx /* edx &= hold */ - movl (%ecx,%edx,4), %eax /* eax = lcode[hold & lmask] */ - -.L_dolen: - /* regs: %esi = in, %ebp = hold, %bl = bits, %edi = out - * - * dolen: - * bits -= this.bits; - * hold >>= this.bits - */ - movb %ah, %cl /* cl = this.bits */ - subb %ah, bits_r /* bits -= this.bits */ - shrl %cl, hold_r /* hold >>= this.bits */ - - /* check if op is a literal - * if (op == 0) { - * PUP(out) = this.val; - * } - */ - testb %al, %al - jnz .L_test_for_length_base /* if (op != 0) 45.7% */ - - shrl $16, %eax /* output this.val char */ - stosb - jmp .L_while_test - -.L_test_for_length_base: - /* regs: %esi = in, %ebp = hold, %bl = bits, %edi = out, %edx = len - * - * else if (op & 16) { - * len = this.val - * op &= 15 - * if (op) { - * if (op > bits) { - * hold |= *((unsigned short *)in)++ << bits; - * bits += 16 - * } - * len += hold & mask[op]; - * bits -= op; - * hold >>= op; - * } - */ -#define len_r %edx - movl %eax, len_r /* len = this */ - shrl $16, len_r /* len = this.val */ - movb %al, %cl - - testb $16, %al - jz .L_test_for_second_level_length /* if ((op & 16) == 0) 8% */ - andb $15, %cl /* op &= 15 */ - jz .L_save_len /* if (!op) */ - cmpb %cl, bits_r - jae .L_add_bits_to_len /* if (op <= bits) */ - - movb %cl, %ch /* stash op in ch, freeing cl */ - xorl %eax, %eax - lodsw /* al = *(ushort *)in++ */ - movb bits_r, %cl /* cl = bits, needs it for shifting */ - addb $16, bits_r /* bits += 16 */ - shll %cl, %eax - orl %eax, hold_r /* hold |= *((ushort *)in)++ << bits */ - movb %ch, %cl /* move op back to ecx */ - -.L_add_bits_to_len: - movl $1, %eax - shll %cl, %eax - decl %eax - subb %cl, bits_r - andl hold_r, %eax /* eax &= hold */ - shrl %cl, hold_r - addl %eax, len_r /* len += hold & mask[op] */ - -.L_save_len: - movl len_r, len(%esp) /* save len */ -#undef len_r - -.L_decode_distance: - /* regs: %esi = in, %ebp = hold, %bl = bits, %edi = out, %edx = dist - * - * if (bits < 15) { - * hold |= *((unsigned short *)in)++ << bits; - * bits += 16 - * } - * this = dcode[hold & dmask]; - * dodist: - * bits -= this.bits; - * hold >>= this.bits; - * op = this.op; - */ - - cmpb $15, bits_r - ja .L_get_distance_code /* if (15 < bits) */ - - xorl %eax, %eax - lodsw /* al = *(ushort *)in++ */ - movb bits_r, %cl /* cl = bits, needs it for shifting */ - addb $16, bits_r /* bits += 16 */ - shll %cl, %eax - orl %eax, hold_r /* hold |= *((ushort *)in)++ << bits */ - -.L_get_distance_code: - movl dmask(%esp), %edx /* edx = dmask */ - movl dcode(%esp), %ecx /* ecx = dcode */ - andl hold_r, %edx /* edx &= hold */ - movl (%ecx,%edx,4), %eax /* eax = dcode[hold & dmask] */ - -#define dist_r %edx -.L_dodist: - movl %eax, dist_r /* dist = this */ - shrl $16, dist_r /* dist = this.val */ - movb %ah, %cl - subb %ah, bits_r /* bits -= this.bits */ - shrl %cl, hold_r /* hold >>= this.bits */ - - /* if (op & 16) { - * dist = this.val - * op &= 15 - * if (op > bits) { - * hold |= *((unsigned short *)in)++ << bits; - * bits += 16 - * } - * dist += hold & mask[op]; - * bits -= op; - * hold >>= op; - */ - movb %al, %cl /* cl = this.op */ - - testb $16, %al /* if ((op & 16) == 0) */ - jz .L_test_for_second_level_dist - andb $15, %cl /* op &= 15 */ - jz .L_check_dist_one - cmpb %cl, bits_r - jae .L_add_bits_to_dist /* if (op <= bits) 97.6% */ - - movb %cl, %ch /* stash op in ch, freeing cl */ - xorl %eax, %eax - lodsw /* al = *(ushort *)in++ */ - movb bits_r, %cl /* cl = bits, needs it for shifting */ - addb $16, bits_r /* bits += 16 */ - shll %cl, %eax - orl %eax, hold_r /* hold |= *((ushort *)in)++ << bits */ - movb %ch, %cl /* move op back to ecx */ - -.L_add_bits_to_dist: - movl $1, %eax - shll %cl, %eax - decl %eax /* (1 << op) - 1 */ - subb %cl, bits_r - andl hold_r, %eax /* eax &= hold */ - shrl %cl, hold_r - addl %eax, dist_r /* dist += hold & ((1 << op) - 1) */ - jmp .L_check_window - -.L_check_window: - /* regs: %esi = from, %ebp = hold, %bl = bits, %edi = out, %edx = dist - * %ecx = nbytes - * - * nbytes = out - beg; - * if (dist <= nbytes) { - * from = out - dist; - * do { - * PUP(out) = PUP(from); - * } while (--len > 0) { - * } - */ - - movl in_r, in(%esp) /* save in so from can use it's reg */ - movl out_r, %eax - subl beg(%esp), %eax /* nbytes = out - beg */ - - cmpl dist_r, %eax - jb .L_clip_window /* if (dist > nbytes) 4.2% */ - - movl len(%esp), %ecx - movl out_r, from_r - subl dist_r, from_r /* from = out - dist */ - - subl $3, %ecx - movb (from_r), %al - movb %al, (out_r) - movb 1(from_r), %al - movb 2(from_r), %dl - addl $3, from_r - movb %al, 1(out_r) - movb %dl, 2(out_r) - addl $3, out_r - rep movsb - - movl in(%esp), in_r /* move in back to %esi, toss from */ - jmp .L_while_test - -.align 16,0x90 -.L_check_dist_one: - cmpl $1, dist_r - jne .L_check_window - cmpl out_r, beg(%esp) - je .L_check_window - - decl out_r - movl len(%esp), %ecx - movb (out_r), %al - subl $3, %ecx - - movb %al, 1(out_r) - movb %al, 2(out_r) - movb %al, 3(out_r) - addl $4, out_r - rep stosb - - jmp .L_while_test - -.align 16,0x90 -.L_test_for_second_level_length: - /* else if ((op & 64) == 0) { - * this = lcode[this.val + (hold & mask[op])]; - * } - */ - testb $64, %al - jnz .L_test_for_end_of_block /* if ((op & 64) != 0) */ - - movl $1, %eax - shll %cl, %eax - decl %eax - andl hold_r, %eax /* eax &= hold */ - addl %edx, %eax /* eax += this.val */ - movl lcode(%esp), %edx /* edx = lcode */ - movl (%edx,%eax,4), %eax /* eax = lcode[val + (hold&mask[op])] */ - jmp .L_dolen - -.align 16,0x90 -.L_test_for_second_level_dist: - /* else if ((op & 64) == 0) { - * this = dcode[this.val + (hold & mask[op])]; - * } - */ - testb $64, %al - jnz .L_invalid_distance_code /* if ((op & 64) != 0) */ - - movl $1, %eax - shll %cl, %eax - decl %eax - andl hold_r, %eax /* eax &= hold */ - addl %edx, %eax /* eax += this.val */ - movl dcode(%esp), %edx /* edx = dcode */ - movl (%edx,%eax,4), %eax /* eax = dcode[val + (hold&mask[op])] */ - jmp .L_dodist - -.align 16,0x90 -.L_clip_window: - /* regs: %esi = from, %ebp = hold, %bl = bits, %edi = out, %edx = dist - * %ecx = nbytes - * - * else { - * if (dist > wsize) { - * invalid distance - * } - * from = window; - * nbytes = dist - nbytes; - * if (write == 0) { - * from += wsize - nbytes; - */ -#define nbytes_r %ecx - movl %eax, nbytes_r - movl wsize(%esp), %eax /* prepare for dist compare */ - negl nbytes_r /* nbytes = -nbytes */ - movl window(%esp), from_r /* from = window */ - - cmpl dist_r, %eax - jb .L_invalid_distance_too_far /* if (dist > wsize) */ - - addl dist_r, nbytes_r /* nbytes = dist - nbytes */ - cmpl $0, write(%esp) - jne .L_wrap_around_window /* if (write != 0) */ - - subl nbytes_r, %eax - addl %eax, from_r /* from += wsize - nbytes */ - - /* regs: %esi = from, %ebp = hold, %bl = bits, %edi = out, %edx = dist - * %ecx = nbytes, %eax = len - * - * if (nbytes < len) { - * len -= nbytes; - * do { - * PUP(out) = PUP(from); - * } while (--nbytes); - * from = out - dist; - * } - * } - */ -#define len_r %eax - movl len(%esp), len_r - cmpl nbytes_r, len_r - jbe .L_do_copy1 /* if (nbytes >= len) */ - - subl nbytes_r, len_r /* len -= nbytes */ - rep movsb - movl out_r, from_r - subl dist_r, from_r /* from = out - dist */ - jmp .L_do_copy1 - - cmpl nbytes_r, len_r - jbe .L_do_copy1 /* if (nbytes >= len) */ - - subl nbytes_r, len_r /* len -= nbytes */ - rep movsb - movl out_r, from_r - subl dist_r, from_r /* from = out - dist */ - jmp .L_do_copy1 - -.L_wrap_around_window: - /* regs: %esi = from, %ebp = hold, %bl = bits, %edi = out, %edx = dist - * %ecx = nbytes, %eax = write, %eax = len - * - * else if (write < nbytes) { - * from += wsize + write - nbytes; - * nbytes -= write; - * if (nbytes < len) { - * len -= nbytes; - * do { - * PUP(out) = PUP(from); - * } while (--nbytes); - * from = window; - * nbytes = write; - * if (nbytes < len) { - * len -= nbytes; - * do { - * PUP(out) = PUP(from); - * } while(--nbytes); - * from = out - dist; - * } - * } - * } - */ -#define write_r %eax - movl write(%esp), write_r - cmpl write_r, nbytes_r - jbe .L_contiguous_in_window /* if (write >= nbytes) */ - - addl wsize(%esp), from_r - addl write_r, from_r - subl nbytes_r, from_r /* from += wsize + write - nbytes */ - subl write_r, nbytes_r /* nbytes -= write */ -#undef write_r - - movl len(%esp), len_r - cmpl nbytes_r, len_r - jbe .L_do_copy1 /* if (nbytes >= len) */ - - subl nbytes_r, len_r /* len -= nbytes */ - rep movsb - movl window(%esp), from_r /* from = window */ - movl write(%esp), nbytes_r /* nbytes = write */ - cmpl nbytes_r, len_r - jbe .L_do_copy1 /* if (nbytes >= len) */ - - subl nbytes_r, len_r /* len -= nbytes */ - rep movsb - movl out_r, from_r - subl dist_r, from_r /* from = out - dist */ - jmp .L_do_copy1 - -.L_contiguous_in_window: - /* regs: %esi = from, %ebp = hold, %bl = bits, %edi = out, %edx = dist - * %ecx = nbytes, %eax = write, %eax = len - * - * else { - * from += write - nbytes; - * if (nbytes < len) { - * len -= nbytes; - * do { - * PUP(out) = PUP(from); - * } while (--nbytes); - * from = out - dist; - * } - * } - */ -#define write_r %eax - addl write_r, from_r - subl nbytes_r, from_r /* from += write - nbytes */ -#undef write_r - - movl len(%esp), len_r - cmpl nbytes_r, len_r - jbe .L_do_copy1 /* if (nbytes >= len) */ - - subl nbytes_r, len_r /* len -= nbytes */ - rep movsb - movl out_r, from_r - subl dist_r, from_r /* from = out - dist */ - -.L_do_copy1: - /* regs: %esi = from, %esi = in, %ebp = hold, %bl = bits, %edi = out - * %eax = len - * - * while (len > 0) { - * PUP(out) = PUP(from); - * len--; - * } - * } - * } while (in < last && out < end); - */ -#undef nbytes_r -#define in_r %esi - movl len_r, %ecx - rep movsb - - movl in(%esp), in_r /* move in back to %esi, toss from */ - jmp .L_while_test - -#undef len_r -#undef dist_r - -#endif /* NO_MMX || RUN_TIME_MMX */ - - -/*** MMX code ***/ - -#if defined( USE_MMX ) || defined( RUN_TIME_MMX ) - -.align 32,0x90 -.L_init_mmx: - emms - -#undef bits_r -#undef bitslong_r -#define bitslong_r %ebp -#define hold_mm %mm0 - movd %ebp, hold_mm - movl %ebx, bitslong_r - -#define used_mm %mm1 -#define dmask2_mm %mm2 -#define lmask2_mm %mm3 -#define lmask_mm %mm4 -#define dmask_mm %mm5 -#define tmp_mm %mm6 - - movd lmask(%esp), lmask_mm - movq lmask_mm, lmask2_mm - movd dmask(%esp), dmask_mm - movq dmask_mm, dmask2_mm - pxor used_mm, used_mm - movl lcode(%esp), %ebx /* ebx = lcode */ - jmp .L_do_loop_mmx - -.align 32,0x90 -.L_while_test_mmx: - /* while (in < last && out < end) - */ - cmpl out_r, end(%esp) - jbe .L_break_loop /* if (out >= end) */ - - cmpl in_r, last(%esp) - jbe .L_break_loop - -.L_do_loop_mmx: - psrlq used_mm, hold_mm /* hold_mm >>= last bit length */ - - cmpl $32, bitslong_r - ja .L_get_length_code_mmx /* if (32 < bits) */ - - movd bitslong_r, tmp_mm - movd (in_r), %mm7 - addl $4, in_r - psllq tmp_mm, %mm7 - addl $32, bitslong_r - por %mm7, hold_mm /* hold_mm |= *((uint *)in)++ << bits */ - -.L_get_length_code_mmx: - pand hold_mm, lmask_mm - movd lmask_mm, %eax - movq lmask2_mm, lmask_mm - movl (%ebx,%eax,4), %eax /* eax = lcode[hold & lmask] */ - -.L_dolen_mmx: - movzbl %ah, %ecx /* ecx = this.bits */ - movd %ecx, used_mm - subl %ecx, bitslong_r /* bits -= this.bits */ - - testb %al, %al - jnz .L_test_for_length_base_mmx /* if (op != 0) 45.7% */ - - shrl $16, %eax /* output this.val char */ - stosb - jmp .L_while_test_mmx - -.L_test_for_length_base_mmx: -#define len_r %edx - movl %eax, len_r /* len = this */ - shrl $16, len_r /* len = this.val */ - - testb $16, %al - jz .L_test_for_second_level_length_mmx /* if ((op & 16) == 0) 8% */ - andl $15, %eax /* op &= 15 */ - jz .L_decode_distance_mmx /* if (!op) */ - - psrlq used_mm, hold_mm /* hold_mm >>= last bit length */ - movd %eax, used_mm - movd hold_mm, %ecx - subl %eax, bitslong_r - andl .L_mask(,%eax,4), %ecx - addl %ecx, len_r /* len += hold & mask[op] */ - -.L_decode_distance_mmx: - psrlq used_mm, hold_mm /* hold_mm >>= last bit length */ - - cmpl $32, bitslong_r - ja .L_get_dist_code_mmx /* if (32 < bits) */ - - movd bitslong_r, tmp_mm - movd (in_r), %mm7 - addl $4, in_r - psllq tmp_mm, %mm7 - addl $32, bitslong_r - por %mm7, hold_mm /* hold_mm |= *((uint *)in)++ << bits */ - -.L_get_dist_code_mmx: - movl dcode(%esp), %ebx /* ebx = dcode */ - pand hold_mm, dmask_mm - movd dmask_mm, %eax - movq dmask2_mm, dmask_mm - movl (%ebx,%eax,4), %eax /* eax = dcode[hold & lmask] */ - -.L_dodist_mmx: -#define dist_r %ebx - movzbl %ah, %ecx /* ecx = this.bits */ - movl %eax, dist_r - shrl $16, dist_r /* dist = this.val */ - subl %ecx, bitslong_r /* bits -= this.bits */ - movd %ecx, used_mm - - testb $16, %al /* if ((op & 16) == 0) */ - jz .L_test_for_second_level_dist_mmx - andl $15, %eax /* op &= 15 */ - jz .L_check_dist_one_mmx - -.L_add_bits_to_dist_mmx: - psrlq used_mm, hold_mm /* hold_mm >>= last bit length */ - movd %eax, used_mm /* save bit length of current op */ - movd hold_mm, %ecx /* get the next bits on input stream */ - subl %eax, bitslong_r /* bits -= op bits */ - andl .L_mask(,%eax,4), %ecx /* ecx = hold & mask[op] */ - addl %ecx, dist_r /* dist += hold & mask[op] */ - -.L_check_window_mmx: - movl in_r, in(%esp) /* save in so from can use it's reg */ - movl out_r, %eax - subl beg(%esp), %eax /* nbytes = out - beg */ - - cmpl dist_r, %eax - jb .L_clip_window_mmx /* if (dist > nbytes) 4.2% */ - - movl len_r, %ecx - movl out_r, from_r - subl dist_r, from_r /* from = out - dist */ - - subl $3, %ecx - movb (from_r), %al - movb %al, (out_r) - movb 1(from_r), %al - movb 2(from_r), %dl - addl $3, from_r - movb %al, 1(out_r) - movb %dl, 2(out_r) - addl $3, out_r - rep movsb - - movl in(%esp), in_r /* move in back to %esi, toss from */ - movl lcode(%esp), %ebx /* move lcode back to %ebx, toss dist */ - jmp .L_while_test_mmx - -.align 16,0x90 -.L_check_dist_one_mmx: - cmpl $1, dist_r - jne .L_check_window_mmx - cmpl out_r, beg(%esp) - je .L_check_window_mmx - - decl out_r - movl len_r, %ecx - movb (out_r), %al - subl $3, %ecx - - movb %al, 1(out_r) - movb %al, 2(out_r) - movb %al, 3(out_r) - addl $4, out_r - rep stosb - - movl lcode(%esp), %ebx /* move lcode back to %ebx, toss dist */ - jmp .L_while_test_mmx - -.align 16,0x90 -.L_test_for_second_level_length_mmx: - testb $64, %al - jnz .L_test_for_end_of_block /* if ((op & 64) != 0) */ - - andl $15, %eax - psrlq used_mm, hold_mm /* hold_mm >>= last bit length */ - movd hold_mm, %ecx - andl .L_mask(,%eax,4), %ecx - addl len_r, %ecx - movl (%ebx,%ecx,4), %eax /* eax = lcode[hold & lmask] */ - jmp .L_dolen_mmx - -.align 16,0x90 -.L_test_for_second_level_dist_mmx: - testb $64, %al - jnz .L_invalid_distance_code /* if ((op & 64) != 0) */ - - andl $15, %eax - psrlq used_mm, hold_mm /* hold_mm >>= last bit length */ - movd hold_mm, %ecx - andl .L_mask(,%eax,4), %ecx - movl dcode(%esp), %eax /* ecx = dcode */ - addl dist_r, %ecx - movl (%eax,%ecx,4), %eax /* eax = lcode[hold & lmask] */ - jmp .L_dodist_mmx - -.align 16,0x90 -.L_clip_window_mmx: -#define nbytes_r %ecx - movl %eax, nbytes_r - movl wsize(%esp), %eax /* prepare for dist compare */ - negl nbytes_r /* nbytes = -nbytes */ - movl window(%esp), from_r /* from = window */ - - cmpl dist_r, %eax - jb .L_invalid_distance_too_far /* if (dist > wsize) */ - - addl dist_r, nbytes_r /* nbytes = dist - nbytes */ - cmpl $0, write(%esp) - jne .L_wrap_around_window_mmx /* if (write != 0) */ - - subl nbytes_r, %eax - addl %eax, from_r /* from += wsize - nbytes */ - - cmpl nbytes_r, len_r - jbe .L_do_copy1_mmx /* if (nbytes >= len) */ - - subl nbytes_r, len_r /* len -= nbytes */ - rep movsb - movl out_r, from_r - subl dist_r, from_r /* from = out - dist */ - jmp .L_do_copy1_mmx - - cmpl nbytes_r, len_r - jbe .L_do_copy1_mmx /* if (nbytes >= len) */ - - subl nbytes_r, len_r /* len -= nbytes */ - rep movsb - movl out_r, from_r - subl dist_r, from_r /* from = out - dist */ - jmp .L_do_copy1_mmx - -.L_wrap_around_window_mmx: -#define write_r %eax - movl write(%esp), write_r - cmpl write_r, nbytes_r - jbe .L_contiguous_in_window_mmx /* if (write >= nbytes) */ - - addl wsize(%esp), from_r - addl write_r, from_r - subl nbytes_r, from_r /* from += wsize + write - nbytes */ - subl write_r, nbytes_r /* nbytes -= write */ -#undef write_r - - cmpl nbytes_r, len_r - jbe .L_do_copy1_mmx /* if (nbytes >= len) */ - - subl nbytes_r, len_r /* len -= nbytes */ - rep movsb - movl window(%esp), from_r /* from = window */ - movl write(%esp), nbytes_r /* nbytes = write */ - cmpl nbytes_r, len_r - jbe .L_do_copy1_mmx /* if (nbytes >= len) */ - - subl nbytes_r, len_r /* len -= nbytes */ - rep movsb - movl out_r, from_r - subl dist_r, from_r /* from = out - dist */ - jmp .L_do_copy1_mmx - -.L_contiguous_in_window_mmx: -#define write_r %eax - addl write_r, from_r - subl nbytes_r, from_r /* from += write - nbytes */ -#undef write_r - - cmpl nbytes_r, len_r - jbe .L_do_copy1_mmx /* if (nbytes >= len) */ - - subl nbytes_r, len_r /* len -= nbytes */ - rep movsb - movl out_r, from_r - subl dist_r, from_r /* from = out - dist */ - -.L_do_copy1_mmx: -#undef nbytes_r -#define in_r %esi - movl len_r, %ecx - rep movsb - - movl in(%esp), in_r /* move in back to %esi, toss from */ - movl lcode(%esp), %ebx /* move lcode back to %ebx, toss dist */ - jmp .L_while_test_mmx - -#undef hold_r -#undef bitslong_r - -#endif /* USE_MMX || RUN_TIME_MMX */ - - -/*** USE_MMX, NO_MMX, and RUNTIME_MMX from here on ***/ - -.L_invalid_distance_code: - /* else { - * strm->msg = "invalid distance code"; - * state->mode = BAD; - * } - */ - movl $.L_invalid_distance_code_msg, %ecx - movl $INFLATE_MODE_BAD, %edx - jmp .L_update_stream_state - -.L_test_for_end_of_block: - /* else if (op & 32) { - * state->mode = TYPE; - * break; - * } - */ - testb $32, %al - jz .L_invalid_literal_length_code /* if ((op & 32) == 0) */ - - movl $0, %ecx - movl $INFLATE_MODE_TYPE, %edx - jmp .L_update_stream_state - -.L_invalid_literal_length_code: - /* else { - * strm->msg = "invalid literal/length code"; - * state->mode = BAD; - * } - */ - movl $.L_invalid_literal_length_code_msg, %ecx - movl $INFLATE_MODE_BAD, %edx - jmp .L_update_stream_state - -.L_invalid_distance_too_far: - /* strm->msg = "invalid distance too far back"; - * state->mode = BAD; - */ - movl in(%esp), in_r /* from_r has in's reg, put in back */ - movl $.L_invalid_distance_too_far_msg, %ecx - movl $INFLATE_MODE_BAD, %edx - jmp .L_update_stream_state - -.L_update_stream_state: - /* set strm->msg = %ecx, strm->state->mode = %edx */ - movl strm_sp(%esp), %eax - testl %ecx, %ecx /* if (msg != NULL) */ - jz .L_skip_msg - movl %ecx, msg_strm(%eax) /* strm->msg = msg */ -.L_skip_msg: - movl state_strm(%eax), %eax /* state = strm->state */ - movl %edx, mode_state(%eax) /* state->mode = edx (BAD | TYPE) */ - jmp .L_break_loop - -.align 32,0x90 -.L_break_loop: - -/* - * Regs: - * - * bits = %ebp when mmx, and in %ebx when non-mmx - * hold = %hold_mm when mmx, and in %ebp when non-mmx - * in = %esi - * out = %edi - */ - -#if defined( USE_MMX ) || defined( RUN_TIME_MMX ) - -#if defined( RUN_TIME_MMX ) - - cmpl $DO_USE_MMX, inflate_fast_use_mmx - jne .L_update_next_in - -#endif /* RUN_TIME_MMX */ - - movl %ebp, %ebx - -.L_update_next_in: - -#endif - -#define strm_r %eax -#define state_r %edx - - /* len = bits >> 3; - * in -= len; - * bits -= len << 3; - * hold &= (1U << bits) - 1; - * state->hold = hold; - * state->bits = bits; - * strm->next_in = in; - * strm->next_out = out; - */ - movl strm_sp(%esp), strm_r - movl %ebx, %ecx - movl state_strm(strm_r), state_r - shrl $3, %ecx - subl %ecx, in_r - shll $3, %ecx - subl %ecx, %ebx - movl out_r, next_out_strm(strm_r) - movl %ebx, bits_state(state_r) - movl %ebx, %ecx - - leal buf(%esp), %ebx - cmpl %ebx, last(%esp) - jne .L_buf_not_used /* if buf != last */ - - subl %ebx, in_r /* in -= buf */ - movl next_in_strm(strm_r), %ebx - movl %ebx, last(%esp) /* last = strm->next_in */ - addl %ebx, in_r /* in += strm->next_in */ - movl avail_in_strm(strm_r), %ebx - subl $11, %ebx - addl %ebx, last(%esp) /* last = &strm->next_in[ avail_in - 11 ] */ - -.L_buf_not_used: - movl in_r, next_in_strm(strm_r) - - movl $1, %ebx - shll %cl, %ebx - decl %ebx - -#if defined( USE_MMX ) || defined( RUN_TIME_MMX ) - -#if defined( RUN_TIME_MMX ) - - cmpl $DO_USE_MMX, inflate_fast_use_mmx - jne .L_update_hold - -#endif /* RUN_TIME_MMX */ - - psrlq used_mm, hold_mm /* hold_mm >>= last bit length */ - movd hold_mm, %ebp - - emms - -.L_update_hold: - -#endif /* USE_MMX || RUN_TIME_MMX */ - - andl %ebx, %ebp - movl %ebp, hold_state(state_r) - -#define last_r %ebx - - /* strm->avail_in = in < last ? 11 + (last - in) : 11 - (in - last) */ - movl last(%esp), last_r - cmpl in_r, last_r - jbe .L_last_is_smaller /* if (in >= last) */ - - subl in_r, last_r /* last -= in */ - addl $11, last_r /* last += 11 */ - movl last_r, avail_in_strm(strm_r) - jmp .L_fixup_out -.L_last_is_smaller: - subl last_r, in_r /* in -= last */ - negl in_r /* in = -in */ - addl $11, in_r /* in += 11 */ - movl in_r, avail_in_strm(strm_r) - -#undef last_r -#define end_r %ebx - -.L_fixup_out: - /* strm->avail_out = out < end ? 257 + (end - out) : 257 - (out - end)*/ - movl end(%esp), end_r - cmpl out_r, end_r - jbe .L_end_is_smaller /* if (out >= end) */ - - subl out_r, end_r /* end -= out */ - addl $257, end_r /* end += 257 */ - movl end_r, avail_out_strm(strm_r) - jmp .L_done -.L_end_is_smaller: - subl end_r, out_r /* out -= end */ - negl out_r /* out = -out */ - addl $257, out_r /* out += 257 */ - movl out_r, avail_out_strm(strm_r) - -#undef end_r -#undef strm_r -#undef state_r - -.L_done: - addl $local_var_size, %esp - popf - popl %ebx - popl %ebp - popl %esi - popl %edi - ret - -#if defined( GAS_ELF ) -/* elf info */ -.type inflate_fast,@function -.size inflate_fast,.-inflate_fast -#endif DELETED compat/zlib/contrib/iostream/test.cpp Index: compat/zlib/contrib/iostream/test.cpp ================================================================== --- compat/zlib/contrib/iostream/test.cpp +++ /dev/null @@ -1,24 +0,0 @@ - -#include "zfstream.h" - -int main() { - - // Construct a stream object with this filebuffer. Anything sent - // to this stream will go to standard out. - gzofstream os( 1, ios::out ); - - // This text is getting compressed and sent to stdout. - // To prove this, run 'test | zcat'. - os << "Hello, Mommy" << endl; - - os << setcompressionlevel( Z_NO_COMPRESSION ); - os << "hello, hello, hi, ho!" << endl; - - setcompressionlevel( os, Z_DEFAULT_COMPRESSION ) - << "I'm compressing again" << endl; - - os.close(); - - return 0; - -} DELETED compat/zlib/contrib/iostream/zfstream.cpp Index: compat/zlib/contrib/iostream/zfstream.cpp ================================================================== --- compat/zlib/contrib/iostream/zfstream.cpp +++ /dev/null @@ -1,329 +0,0 @@ - -#include "zfstream.h" - -gzfilebuf::gzfilebuf() : - file(NULL), - mode(0), - own_file_descriptor(0) -{ } - -gzfilebuf::~gzfilebuf() { - - sync(); - if ( own_file_descriptor ) - close(); - -} - -gzfilebuf *gzfilebuf::open( const char *name, - int io_mode ) { - - if ( is_open() ) - return NULL; - - char char_mode[10]; - char *p = char_mode; - - if ( io_mode & ios::in ) { - mode = ios::in; - *p++ = 'r'; - } else if ( io_mode & ios::app ) { - mode = ios::app; - *p++ = 'a'; - } else { - mode = ios::out; - *p++ = 'w'; - } - - if ( io_mode & ios::binary ) { - mode |= ios::binary; - *p++ = 'b'; - } - - // Hard code the compression level - if ( io_mode & (ios::out|ios::app )) { - *p++ = '9'; - } - - // Put the end-of-string indicator - *p = '\0'; - - if ( (file = gzopen(name, char_mode)) == NULL ) - return NULL; - - own_file_descriptor = 1; - - return this; - -} - -gzfilebuf *gzfilebuf::attach( int file_descriptor, - int io_mode ) { - - if ( is_open() ) - return NULL; - - char char_mode[10]; - char *p = char_mode; - - if ( io_mode & ios::in ) { - mode = ios::in; - *p++ = 'r'; - } else if ( io_mode & ios::app ) { - mode = ios::app; - *p++ = 'a'; - } else { - mode = ios::out; - *p++ = 'w'; - } - - if ( io_mode & ios::binary ) { - mode |= ios::binary; - *p++ = 'b'; - } - - // Hard code the compression level - if ( io_mode & (ios::out|ios::app )) { - *p++ = '9'; - } - - // Put the end-of-string indicator - *p = '\0'; - - if ( (file = gzdopen(file_descriptor, char_mode)) == NULL ) - return NULL; - - own_file_descriptor = 0; - - return this; - -} - -gzfilebuf *gzfilebuf::close() { - - if ( is_open() ) { - - sync(); - gzclose( file ); - file = NULL; - - } - - return this; - -} - -int gzfilebuf::setcompressionlevel( int comp_level ) { - - return gzsetparams(file, comp_level, -2); - -} - -int gzfilebuf::setcompressionstrategy( int comp_strategy ) { - - return gzsetparams(file, -2, comp_strategy); - -} - - -streampos gzfilebuf::seekoff( streamoff off, ios::seek_dir dir, int which ) { - - return streampos(EOF); - -} - -int gzfilebuf::underflow() { - - // If the file hasn't been opened for reading, error. - if ( !is_open() || !(mode & ios::in) ) - return EOF; - - // if a buffer doesn't exists, allocate one. - if ( !base() ) { - - if ( (allocate()) == EOF ) - return EOF; - setp(0,0); - - } else { - - if ( in_avail() ) - return (unsigned char) *gptr(); - - if ( out_waiting() ) { - if ( flushbuf() == EOF ) - return EOF; - } - - } - - // Attempt to fill the buffer. - - int result = fillbuf(); - if ( result == EOF ) { - // disable get area - setg(0,0,0); - return EOF; - } - - return (unsigned char) *gptr(); - -} - -int gzfilebuf::overflow( int c ) { - - if ( !is_open() || !(mode & ios::out) ) - return EOF; - - if ( !base() ) { - if ( allocate() == EOF ) - return EOF; - setg(0,0,0); - } else { - if (in_avail()) { - return EOF; - } - if (out_waiting()) { - if (flushbuf() == EOF) - return EOF; - } - } - - int bl = blen(); - setp( base(), base() + bl); - - if ( c != EOF ) { - - *pptr() = c; - pbump(1); - - } - - return 0; - -} - -int gzfilebuf::sync() { - - if ( !is_open() ) - return EOF; - - if ( out_waiting() ) - return flushbuf(); - - return 0; - -} - -int gzfilebuf::flushbuf() { - - int n; - char *q; - - q = pbase(); - n = pptr() - q; - - if ( gzwrite( file, q, n) < n ) - return EOF; - - setp(0,0); - - return 0; - -} - -int gzfilebuf::fillbuf() { - - int required; - char *p; - - p = base(); - - required = blen(); - - int t = gzread( file, p, required ); - - if ( t <= 0) return EOF; - - setg( base(), base(), base()+t); - - return t; - -} - -gzfilestream_common::gzfilestream_common() : - ios( gzfilestream_common::rdbuf() ) -{ } - -gzfilestream_common::~gzfilestream_common() -{ } - -void gzfilestream_common::attach( int fd, int io_mode ) { - - if ( !buffer.attach( fd, io_mode) ) - clear( ios::failbit | ios::badbit ); - else - clear(); - -} - -void gzfilestream_common::open( const char *name, int io_mode ) { - - if ( !buffer.open( name, io_mode ) ) - clear( ios::failbit | ios::badbit ); - else - clear(); - -} - -void gzfilestream_common::close() { - - if ( !buffer.close() ) - clear( ios::failbit | ios::badbit ); - -} - -gzfilebuf *gzfilestream_common::rdbuf() -{ - return &buffer; -} - -gzifstream::gzifstream() : - ios( gzfilestream_common::rdbuf() ) -{ - clear( ios::badbit ); -} - -gzifstream::gzifstream( const char *name, int io_mode ) : - ios( gzfilestream_common::rdbuf() ) -{ - gzfilestream_common::open( name, io_mode ); -} - -gzifstream::gzifstream( int fd, int io_mode ) : - ios( gzfilestream_common::rdbuf() ) -{ - gzfilestream_common::attach( fd, io_mode ); -} - -gzifstream::~gzifstream() { } - -gzofstream::gzofstream() : - ios( gzfilestream_common::rdbuf() ) -{ - clear( ios::badbit ); -} - -gzofstream::gzofstream( const char *name, int io_mode ) : - ios( gzfilestream_common::rdbuf() ) -{ - gzfilestream_common::open( name, io_mode ); -} - -gzofstream::gzofstream( int fd, int io_mode ) : - ios( gzfilestream_common::rdbuf() ) -{ - gzfilestream_common::attach( fd, io_mode ); -} - -gzofstream::~gzofstream() { } DELETED compat/zlib/contrib/iostream/zfstream.h Index: compat/zlib/contrib/iostream/zfstream.h ================================================================== --- compat/zlib/contrib/iostream/zfstream.h +++ /dev/null @@ -1,128 +0,0 @@ - -#ifndef zfstream_h -#define zfstream_h - -#include -#include "zlib.h" - -class gzfilebuf : public streambuf { - -public: - - gzfilebuf( ); - virtual ~gzfilebuf(); - - gzfilebuf *open( const char *name, int io_mode ); - gzfilebuf *attach( int file_descriptor, int io_mode ); - gzfilebuf *close(); - - int setcompressionlevel( int comp_level ); - int setcompressionstrategy( int comp_strategy ); - - inline int is_open() const { return (file !=NULL); } - - virtual streampos seekoff( streamoff, ios::seek_dir, int ); - - virtual int sync(); - -protected: - - virtual int underflow(); - virtual int overflow( int = EOF ); - -private: - - gzFile file; - short mode; - short own_file_descriptor; - - int flushbuf(); - int fillbuf(); - -}; - -class gzfilestream_common : virtual public ios { - - friend class gzifstream; - friend class gzofstream; - friend gzofstream &setcompressionlevel( gzofstream &, int ); - friend gzofstream &setcompressionstrategy( gzofstream &, int ); - -public: - virtual ~gzfilestream_common(); - - void attach( int fd, int io_mode ); - void open( const char *name, int io_mode ); - void close(); - -protected: - gzfilestream_common(); - -private: - gzfilebuf *rdbuf(); - - gzfilebuf buffer; - -}; - -class gzifstream : public gzfilestream_common, public istream { - -public: - - gzifstream(); - gzifstream( const char *name, int io_mode = ios::in ); - gzifstream( int fd, int io_mode = ios::in ); - - virtual ~gzifstream(); - -}; - -class gzofstream : public gzfilestream_common, public ostream { - -public: - - gzofstream(); - gzofstream( const char *name, int io_mode = ios::out ); - gzofstream( int fd, int io_mode = ios::out ); - - virtual ~gzofstream(); - -}; - -template class gzomanip { - friend gzofstream &operator<<(gzofstream &, const gzomanip &); -public: - gzomanip(gzofstream &(*f)(gzofstream &, T), T v) : func(f), val(v) { } -private: - gzofstream &(*func)(gzofstream &, T); - T val; -}; - -template gzofstream &operator<<(gzofstream &s, const gzomanip &m) -{ - return (*m.func)(s, m.val); -} - -inline gzofstream &setcompressionlevel( gzofstream &s, int l ) -{ - (s.rdbuf())->setcompressionlevel(l); - return s; -} - -inline gzofstream &setcompressionstrategy( gzofstream &s, int l ) -{ - (s.rdbuf())->setcompressionstrategy(l); - return s; -} - -inline gzomanip setcompressionlevel(int l) -{ - return gzomanip(&setcompressionlevel,l); -} - -inline gzomanip setcompressionstrategy(int l) -{ - return gzomanip(&setcompressionstrategy,l); -} - -#endif DELETED compat/zlib/contrib/iostream2/zstream.h Index: compat/zlib/contrib/iostream2/zstream.h ================================================================== --- compat/zlib/contrib/iostream2/zstream.h +++ /dev/null @@ -1,307 +0,0 @@ -/* - * - * Copyright (c) 1997 - * Christian Michelsen Research AS - * Advanced Computing - * Fantoftvegen 38, 5036 BERGEN, Norway - * http://www.cmr.no - * - * Permission to use, copy, modify, distribute and sell this software - * and its documentation for any purpose is hereby granted without fee, - * provided that the above copyright notice appear in all copies and - * that both that copyright notice and this permission notice appear - * in supporting documentation. Christian Michelsen Research AS makes no - * representations about the suitability of this software for any - * purpose. It is provided "as is" without express or implied warranty. - * - */ - -#ifndef ZSTREAM__H -#define ZSTREAM__H - -/* - * zstream.h - C++ interface to the 'zlib' general purpose compression library - * $Id: zstream.h 1.1 1997-06-25 12:00:56+02 tyge Exp tyge $ - */ - -#include -#include -#include -#include "zlib.h" - -#if defined(_WIN32) -# include -# include -# define SET_BINARY_MODE(file) setmode(fileno(file), O_BINARY) -#else -# define SET_BINARY_MODE(file) -#endif - -class zstringlen { -public: - zstringlen(class izstream&); - zstringlen(class ozstream&, const char*); - size_t value() const { return val.word; } -private: - struct Val { unsigned char byte; size_t word; } val; -}; - -// ----------------------------- izstream ----------------------------- - -class izstream -{ - public: - izstream() : m_fp(0) {} - izstream(FILE* fp) : m_fp(0) { open(fp); } - izstream(const char* name) : m_fp(0) { open(name); } - ~izstream() { close(); } - - /* Opens a gzip (.gz) file for reading. - * open() can be used to read a file which is not in gzip format; - * in this case read() will directly read from the file without - * decompression. errno can be checked to distinguish two error - * cases (if errno is zero, the zlib error is Z_MEM_ERROR). - */ - void open(const char* name) { - if (m_fp) close(); - m_fp = ::gzopen(name, "rb"); - } - - void open(FILE* fp) { - SET_BINARY_MODE(fp); - if (m_fp) close(); - m_fp = ::gzdopen(fileno(fp), "rb"); - } - - /* Flushes all pending input if necessary, closes the compressed file - * and deallocates all the (de)compression state. The return value is - * the zlib error number (see function error() below). - */ - int close() { - int r = ::gzclose(m_fp); - m_fp = 0; return r; - } - - /* Binary read the given number of bytes from the compressed file. - */ - int read(void* buf, size_t len) { - return ::gzread(m_fp, buf, len); - } - - /* Returns the error message for the last error which occurred on the - * given compressed file. errnum is set to zlib error number. If an - * error occurred in the file system and not in the compression library, - * errnum is set to Z_ERRNO and the application may consult errno - * to get the exact error code. - */ - const char* error(int* errnum) { - return ::gzerror(m_fp, errnum); - } - - gzFile fp() { return m_fp; } - - private: - gzFile m_fp; -}; - -/* - * Binary read the given (array of) object(s) from the compressed file. - * If the input file was not in gzip format, read() copies the objects number - * of bytes into the buffer. - * returns the number of uncompressed bytes actually read - * (0 for end of file, -1 for error). - */ -template -inline int read(izstream& zs, T* x, Items items) { - return ::gzread(zs.fp(), x, items*sizeof(T)); -} - -/* - * Binary input with the '>' operator. - */ -template -inline izstream& operator>(izstream& zs, T& x) { - ::gzread(zs.fp(), &x, sizeof(T)); - return zs; -} - - -inline zstringlen::zstringlen(izstream& zs) { - zs > val.byte; - if (val.byte == 255) zs > val.word; - else val.word = val.byte; -} - -/* - * Read length of string + the string with the '>' operator. - */ -inline izstream& operator>(izstream& zs, char* x) { - zstringlen len(zs); - ::gzread(zs.fp(), x, len.value()); - x[len.value()] = '\0'; - return zs; -} - -inline char* read_string(izstream& zs) { - zstringlen len(zs); - char* x = new char[len.value()+1]; - ::gzread(zs.fp(), x, len.value()); - x[len.value()] = '\0'; - return x; -} - -// ----------------------------- ozstream ----------------------------- - -class ozstream -{ - public: - ozstream() : m_fp(0), m_os(0) { - } - ozstream(FILE* fp, int level = Z_DEFAULT_COMPRESSION) - : m_fp(0), m_os(0) { - open(fp, level); - } - ozstream(const char* name, int level = Z_DEFAULT_COMPRESSION) - : m_fp(0), m_os(0) { - open(name, level); - } - ~ozstream() { - close(); - } - - /* Opens a gzip (.gz) file for writing. - * The compression level parameter should be in 0..9 - * errno can be checked to distinguish two error cases - * (if errno is zero, the zlib error is Z_MEM_ERROR). - */ - void open(const char* name, int level = Z_DEFAULT_COMPRESSION) { - char mode[4] = "wb\0"; - if (level != Z_DEFAULT_COMPRESSION) mode[2] = '0'+level; - if (m_fp) close(); - m_fp = ::gzopen(name, mode); - } - - /* open from a FILE pointer. - */ - void open(FILE* fp, int level = Z_DEFAULT_COMPRESSION) { - SET_BINARY_MODE(fp); - char mode[4] = "wb\0"; - if (level != Z_DEFAULT_COMPRESSION) mode[2] = '0'+level; - if (m_fp) close(); - m_fp = ::gzdopen(fileno(fp), mode); - } - - /* Flushes all pending output if necessary, closes the compressed file - * and deallocates all the (de)compression state. The return value is - * the zlib error number (see function error() below). - */ - int close() { - if (m_os) { - ::gzwrite(m_fp, m_os->str(), m_os->pcount()); - delete[] m_os->str(); delete m_os; m_os = 0; - } - int r = ::gzclose(m_fp); m_fp = 0; return r; - } - - /* Binary write the given number of bytes into the compressed file. - */ - int write(const void* buf, size_t len) { - return ::gzwrite(m_fp, (voidp) buf, len); - } - - /* Flushes all pending output into the compressed file. The parameter - * _flush is as in the deflate() function. The return value is the zlib - * error number (see function gzerror below). flush() returns Z_OK if - * the flush_ parameter is Z_FINISH and all output could be flushed. - * flush() should be called only when strictly necessary because it can - * degrade compression. - */ - int flush(int _flush) { - os_flush(); - return ::gzflush(m_fp, _flush); - } - - /* Returns the error message for the last error which occurred on the - * given compressed file. errnum is set to zlib error number. If an - * error occurred in the file system and not in the compression library, - * errnum is set to Z_ERRNO and the application may consult errno - * to get the exact error code. - */ - const char* error(int* errnum) { - return ::gzerror(m_fp, errnum); - } - - gzFile fp() { return m_fp; } - - ostream& os() { - if (m_os == 0) m_os = new ostrstream; - return *m_os; - } - - void os_flush() { - if (m_os && m_os->pcount()>0) { - ostrstream* oss = new ostrstream; - oss->fill(m_os->fill()); - oss->flags(m_os->flags()); - oss->precision(m_os->precision()); - oss->width(m_os->width()); - ::gzwrite(m_fp, m_os->str(), m_os->pcount()); - delete[] m_os->str(); delete m_os; m_os = oss; - } - } - - private: - gzFile m_fp; - ostrstream* m_os; -}; - -/* - * Binary write the given (array of) object(s) into the compressed file. - * returns the number of uncompressed bytes actually written - * (0 in case of error). - */ -template -inline int write(ozstream& zs, const T* x, Items items) { - return ::gzwrite(zs.fp(), (voidp) x, items*sizeof(T)); -} - -/* - * Binary output with the '<' operator. - */ -template -inline ozstream& operator<(ozstream& zs, const T& x) { - ::gzwrite(zs.fp(), (voidp) &x, sizeof(T)); - return zs; -} - -inline zstringlen::zstringlen(ozstream& zs, const char* x) { - val.byte = 255; val.word = ::strlen(x); - if (val.word < 255) zs < (val.byte = val.word); - else zs < val; -} - -/* - * Write length of string + the string with the '<' operator. - */ -inline ozstream& operator<(ozstream& zs, const char* x) { - zstringlen len(zs, x); - ::gzwrite(zs.fp(), (voidp) x, len.value()); - return zs; -} - -#ifdef _MSC_VER -inline ozstream& operator<(ozstream& zs, char* const& x) { - return zs < (const char*) x; -} -#endif - -/* - * Ascii write with the << operator; - */ -template -inline ostream& operator<<(ozstream& zs, const T& x) { - zs.os_flush(); - return zs.os() << x; -} - -#endif DELETED compat/zlib/contrib/iostream2/zstream_test.cpp Index: compat/zlib/contrib/iostream2/zstream_test.cpp ================================================================== --- compat/zlib/contrib/iostream2/zstream_test.cpp +++ /dev/null @@ -1,25 +0,0 @@ -#include "zstream.h" -#include -#include -#include - -void main() { - char h[256] = "Hello"; - char* g = "Goodbye"; - ozstream out("temp.gz"); - out < "This works well" < h < g; - out.close(); - - izstream in("temp.gz"); // read it back - char *x = read_string(in), *y = new char[256], z[256]; - in > y > z; - in.close(); - cout << x << endl << y << endl << z << endl; - - out.open("temp.gz"); // try ascii output; zcat temp.gz to see the results - out << setw(50) << setfill('#') << setprecision(20) << x << endl << y << endl << z << endl; - out << z << endl << y << endl << x << endl; - out << 1.1234567890123456789 << endl; - - delete[] x; delete[] y; -} DELETED compat/zlib/contrib/iostream3/README Index: compat/zlib/contrib/iostream3/README ================================================================== --- compat/zlib/contrib/iostream3/README +++ /dev/null @@ -1,35 +0,0 @@ -These classes provide a C++ stream interface to the zlib library. It allows you -to do things like: - - gzofstream outf("blah.gz"); - outf << "These go into the gzip file " << 123 << endl; - -It does this by deriving a specialized stream buffer for gzipped files, which is -the way Stroustrup would have done it. :-> - -The gzifstream and gzofstream classes were originally written by Kevin Ruland -and made available in the zlib contrib/iostream directory. The older version still -compiles under gcc 2.xx, but not under gcc 3.xx, which sparked the development of -this version. - -The new classes are as standard-compliant as possible, closely following the -approach of the standard library's fstream classes. It compiles under gcc versions -3.2 and 3.3, but not under gcc 2.xx. This is mainly due to changes in the standard -library naming scheme. The new version of gzifstream/gzofstream/gzfilebuf differs -from the previous one in the following respects: -- added showmanyc -- added setbuf, with support for unbuffered output via setbuf(0,0) -- a few bug fixes of stream behavior -- gzipped output file opened with default compression level instead of maximum level -- setcompressionlevel()/strategy() members replaced by single setcompression() - -The code is provided "as is", with the permission to use, copy, modify, distribute -and sell it for any purpose without fee. - -Ludwig Schwardt - - -DSP Lab -Electrical & Electronic Engineering Department -University of Stellenbosch -South Africa DELETED compat/zlib/contrib/iostream3/TODO Index: compat/zlib/contrib/iostream3/TODO ================================================================== --- compat/zlib/contrib/iostream3/TODO +++ /dev/null @@ -1,17 +0,0 @@ -Possible upgrades to gzfilebuf: - -- The ability to do putback (e.g. putbackfail) - -- The ability to seek (zlib supports this, but could be slow/tricky) - -- Simultaneous read/write access (does it make sense?) - -- Support for ios_base::ate open mode - -- Locale support? - -- Check public interface to see which calls give problems - (due to dependence on library internals) - -- Override operator<<(ostream&, gzfilebuf*) to allow direct copying - of stream buffer to stream ( i.e. os << is.rdbuf(); ) DELETED compat/zlib/contrib/iostream3/test.cc Index: compat/zlib/contrib/iostream3/test.cc ================================================================== --- compat/zlib/contrib/iostream3/test.cc +++ /dev/null @@ -1,50 +0,0 @@ -/* - * Test program for gzifstream and gzofstream - * - * by Ludwig Schwardt - * original version by Kevin Ruland - */ - -#include "zfstream.h" -#include // for cout - -int main() { - - gzofstream outf; - gzifstream inf; - char buf[80]; - - outf.open("test1.txt.gz"); - outf << "The quick brown fox sidestepped the lazy canine\n" - << 1.3 << "\nPlan " << 9 << std::endl; - outf.close(); - std::cout << "Wrote the following message to 'test1.txt.gz' (check with zcat or zless):\n" - << "The quick brown fox sidestepped the lazy canine\n" - << 1.3 << "\nPlan " << 9 << std::endl; - - std::cout << "\nReading 'test1.txt.gz' (buffered) produces:\n"; - inf.open("test1.txt.gz"); - while (inf.getline(buf,80,'\n')) { - std::cout << buf << "\t(" << inf.rdbuf()->in_avail() << " chars left in buffer)\n"; - } - inf.close(); - - outf.rdbuf()->pubsetbuf(0,0); - outf.open("test2.txt.gz"); - outf << setcompression(Z_NO_COMPRESSION) - << "The quick brown fox sidestepped the lazy canine\n" - << 1.3 << "\nPlan " << 9 << std::endl; - outf.close(); - std::cout << "\nWrote the same message to 'test2.txt.gz' in uncompressed form"; - - std::cout << "\nReading 'test2.txt.gz' (unbuffered) produces:\n"; - inf.rdbuf()->pubsetbuf(0,0); - inf.open("test2.txt.gz"); - while (inf.getline(buf,80,'\n')) { - std::cout << buf << "\t(" << inf.rdbuf()->in_avail() << " chars left in buffer)\n"; - } - inf.close(); - - return 0; - -} DELETED compat/zlib/contrib/iostream3/zfstream.cc Index: compat/zlib/contrib/iostream3/zfstream.cc ================================================================== --- compat/zlib/contrib/iostream3/zfstream.cc +++ /dev/null @@ -1,479 +0,0 @@ -/* - * A C++ I/O streams interface to the zlib gz* functions - * - * by Ludwig Schwardt - * original version by Kevin Ruland - * - * This version is standard-compliant and compatible with gcc 3.x. - */ - -#include "zfstream.h" -#include // for strcpy, strcat, strlen (mode strings) -#include // for BUFSIZ - -// Internal buffer sizes (default and "unbuffered" versions) -#define BIGBUFSIZE BUFSIZ -#define SMALLBUFSIZE 1 - -/*****************************************************************************/ - -// Default constructor -gzfilebuf::gzfilebuf() -: file(NULL), io_mode(std::ios_base::openmode(0)), own_fd(false), - buffer(NULL), buffer_size(BIGBUFSIZE), own_buffer(true) -{ - // No buffers to start with - this->disable_buffer(); -} - -// Destructor -gzfilebuf::~gzfilebuf() -{ - // Sync output buffer and close only if responsible for file - // (i.e. attached streams should be left open at this stage) - this->sync(); - if (own_fd) - this->close(); - // Make sure internal buffer is deallocated - this->disable_buffer(); -} - -// Set compression level and strategy -int -gzfilebuf::setcompression(int comp_level, - int comp_strategy) -{ - return gzsetparams(file, comp_level, comp_strategy); -} - -// Open gzipped file -gzfilebuf* -gzfilebuf::open(const char *name, - std::ios_base::openmode mode) -{ - // Fail if file already open - if (this->is_open()) - return NULL; - // Don't support simultaneous read/write access (yet) - if ((mode & std::ios_base::in) && (mode & std::ios_base::out)) - return NULL; - - // Build mode string for gzopen and check it [27.8.1.3.2] - char char_mode[6] = "\0\0\0\0\0"; - if (!this->open_mode(mode, char_mode)) - return NULL; - - // Attempt to open file - if ((file = gzopen(name, char_mode)) == NULL) - return NULL; - - // On success, allocate internal buffer and set flags - this->enable_buffer(); - io_mode = mode; - own_fd = true; - return this; -} - -// Attach to gzipped file -gzfilebuf* -gzfilebuf::attach(int fd, - std::ios_base::openmode mode) -{ - // Fail if file already open - if (this->is_open()) - return NULL; - // Don't support simultaneous read/write access (yet) - if ((mode & std::ios_base::in) && (mode & std::ios_base::out)) - return NULL; - - // Build mode string for gzdopen and check it [27.8.1.3.2] - char char_mode[6] = "\0\0\0\0\0"; - if (!this->open_mode(mode, char_mode)) - return NULL; - - // Attempt to attach to file - if ((file = gzdopen(fd, char_mode)) == NULL) - return NULL; - - // On success, allocate internal buffer and set flags - this->enable_buffer(); - io_mode = mode; - own_fd = false; - return this; -} - -// Close gzipped file -gzfilebuf* -gzfilebuf::close() -{ - // Fail immediately if no file is open - if (!this->is_open()) - return NULL; - // Assume success - gzfilebuf* retval = this; - // Attempt to sync and close gzipped file - if (this->sync() == -1) - retval = NULL; - if (gzclose(file) < 0) - retval = NULL; - // File is now gone anyway (postcondition [27.8.1.3.8]) - file = NULL; - own_fd = false; - // Destroy internal buffer if it exists - this->disable_buffer(); - return retval; -} - -/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ - -// Convert int open mode to mode string -bool -gzfilebuf::open_mode(std::ios_base::openmode mode, - char* c_mode) const -{ - bool testb = mode & std::ios_base::binary; - bool testi = mode & std::ios_base::in; - bool testo = mode & std::ios_base::out; - bool testt = mode & std::ios_base::trunc; - bool testa = mode & std::ios_base::app; - - // Check for valid flag combinations - see [27.8.1.3.2] (Table 92) - // Original zfstream hardcoded the compression level to maximum here... - // Double the time for less than 1% size improvement seems - // excessive though - keeping it at the default level - // To change back, just append "9" to the next three mode strings - if (!testi && testo && !testt && !testa) - strcpy(c_mode, "w"); - if (!testi && testo && !testt && testa) - strcpy(c_mode, "a"); - if (!testi && testo && testt && !testa) - strcpy(c_mode, "w"); - if (testi && !testo && !testt && !testa) - strcpy(c_mode, "r"); - // No read/write mode yet -// if (testi && testo && !testt && !testa) -// strcpy(c_mode, "r+"); -// if (testi && testo && testt && !testa) -// strcpy(c_mode, "w+"); - - // Mode string should be empty for invalid combination of flags - if (strlen(c_mode) == 0) - return false; - if (testb) - strcat(c_mode, "b"); - return true; -} - -// Determine number of characters in internal get buffer -std::streamsize -gzfilebuf::showmanyc() -{ - // Calls to underflow will fail if file not opened for reading - if (!this->is_open() || !(io_mode & std::ios_base::in)) - return -1; - // Make sure get area is in use - if (this->gptr() && (this->gptr() < this->egptr())) - return std::streamsize(this->egptr() - this->gptr()); - else - return 0; -} - -// Fill get area from gzipped file -gzfilebuf::int_type -gzfilebuf::underflow() -{ - // If something is left in the get area by chance, return it - // (this shouldn't normally happen, as underflow is only supposed - // to be called when gptr >= egptr, but it serves as error check) - if (this->gptr() && (this->gptr() < this->egptr())) - return traits_type::to_int_type(*(this->gptr())); - - // If the file hasn't been opened for reading, produce error - if (!this->is_open() || !(io_mode & std::ios_base::in)) - return traits_type::eof(); - - // Attempt to fill internal buffer from gzipped file - // (buffer must be guaranteed to exist...) - int bytes_read = gzread(file, buffer, buffer_size); - // Indicates error or EOF - if (bytes_read <= 0) - { - // Reset get area - this->setg(buffer, buffer, buffer); - return traits_type::eof(); - } - // Make all bytes read from file available as get area - this->setg(buffer, buffer, buffer + bytes_read); - - // Return next character in get area - return traits_type::to_int_type(*(this->gptr())); -} - -// Write put area to gzipped file -gzfilebuf::int_type -gzfilebuf::overflow(int_type c) -{ - // Determine whether put area is in use - if (this->pbase()) - { - // Double-check pointer range - if (this->pptr() > this->epptr() || this->pptr() < this->pbase()) - return traits_type::eof(); - // Add extra character to buffer if not EOF - if (!traits_type::eq_int_type(c, traits_type::eof())) - { - *(this->pptr()) = traits_type::to_char_type(c); - this->pbump(1); - } - // Number of characters to write to file - int bytes_to_write = this->pptr() - this->pbase(); - // Overflow doesn't fail if nothing is to be written - if (bytes_to_write > 0) - { - // If the file hasn't been opened for writing, produce error - if (!this->is_open() || !(io_mode & std::ios_base::out)) - return traits_type::eof(); - // If gzipped file won't accept all bytes written to it, fail - if (gzwrite(file, this->pbase(), bytes_to_write) != bytes_to_write) - return traits_type::eof(); - // Reset next pointer to point to pbase on success - this->pbump(-bytes_to_write); - } - } - // Write extra character to file if not EOF - else if (!traits_type::eq_int_type(c, traits_type::eof())) - { - // If the file hasn't been opened for writing, produce error - if (!this->is_open() || !(io_mode & std::ios_base::out)) - return traits_type::eof(); - // Impromptu char buffer (allows "unbuffered" output) - char_type last_char = traits_type::to_char_type(c); - // If gzipped file won't accept this character, fail - if (gzwrite(file, &last_char, 1) != 1) - return traits_type::eof(); - } - - // If you got here, you have succeeded (even if c was EOF) - // The return value should therefore be non-EOF - if (traits_type::eq_int_type(c, traits_type::eof())) - return traits_type::not_eof(c); - else - return c; -} - -// Assign new buffer -std::streambuf* -gzfilebuf::setbuf(char_type* p, - std::streamsize n) -{ - // First make sure stuff is sync'ed, for safety - if (this->sync() == -1) - return NULL; - // If buffering is turned off on purpose via setbuf(0,0), still allocate one... - // "Unbuffered" only really refers to put [27.8.1.4.10], while get needs at - // least a buffer of size 1 (very inefficient though, therefore make it bigger?) - // This follows from [27.5.2.4.3]/12 (gptr needs to point at something, it seems) - if (!p || !n) - { - // Replace existing buffer (if any) with small internal buffer - this->disable_buffer(); - buffer = NULL; - buffer_size = 0; - own_buffer = true; - this->enable_buffer(); - } - else - { - // Replace existing buffer (if any) with external buffer - this->disable_buffer(); - buffer = p; - buffer_size = n; - own_buffer = false; - this->enable_buffer(); - } - return this; -} - -// Write put area to gzipped file (i.e. ensures that put area is empty) -int -gzfilebuf::sync() -{ - return traits_type::eq_int_type(this->overflow(), traits_type::eof()) ? -1 : 0; -} - -/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ - -// Allocate internal buffer -void -gzfilebuf::enable_buffer() -{ - // If internal buffer required, allocate one - if (own_buffer && !buffer) - { - // Check for buffered vs. "unbuffered" - if (buffer_size > 0) - { - // Allocate internal buffer - buffer = new char_type[buffer_size]; - // Get area starts empty and will be expanded by underflow as need arises - this->setg(buffer, buffer, buffer); - // Setup entire internal buffer as put area. - // The one-past-end pointer actually points to the last element of the buffer, - // so that overflow(c) can safely add the extra character c to the sequence. - // These pointers remain in place for the duration of the buffer - this->setp(buffer, buffer + buffer_size - 1); - } - else - { - // Even in "unbuffered" case, (small?) get buffer is still required - buffer_size = SMALLBUFSIZE; - buffer = new char_type[buffer_size]; - this->setg(buffer, buffer, buffer); - // "Unbuffered" means no put buffer - this->setp(0, 0); - } - } - else - { - // If buffer already allocated, reset buffer pointers just to make sure no - // stale chars are lying around - this->setg(buffer, buffer, buffer); - this->setp(buffer, buffer + buffer_size - 1); - } -} - -// Destroy internal buffer -void -gzfilebuf::disable_buffer() -{ - // If internal buffer exists, deallocate it - if (own_buffer && buffer) - { - // Preserve unbuffered status by zeroing size - if (!this->pbase()) - buffer_size = 0; - delete[] buffer; - buffer = NULL; - this->setg(0, 0, 0); - this->setp(0, 0); - } - else - { - // Reset buffer pointers to initial state if external buffer exists - this->setg(buffer, buffer, buffer); - if (buffer) - this->setp(buffer, buffer + buffer_size - 1); - else - this->setp(0, 0); - } -} - -/*****************************************************************************/ - -// Default constructor initializes stream buffer -gzifstream::gzifstream() -: std::istream(NULL), sb() -{ this->init(&sb); } - -// Initialize stream buffer and open file -gzifstream::gzifstream(const char* name, - std::ios_base::openmode mode) -: std::istream(NULL), sb() -{ - this->init(&sb); - this->open(name, mode); -} - -// Initialize stream buffer and attach to file -gzifstream::gzifstream(int fd, - std::ios_base::openmode mode) -: std::istream(NULL), sb() -{ - this->init(&sb); - this->attach(fd, mode); -} - -// Open file and go into fail() state if unsuccessful -void -gzifstream::open(const char* name, - std::ios_base::openmode mode) -{ - if (!sb.open(name, mode | std::ios_base::in)) - this->setstate(std::ios_base::failbit); - else - this->clear(); -} - -// Attach to file and go into fail() state if unsuccessful -void -gzifstream::attach(int fd, - std::ios_base::openmode mode) -{ - if (!sb.attach(fd, mode | std::ios_base::in)) - this->setstate(std::ios_base::failbit); - else - this->clear(); -} - -// Close file -void -gzifstream::close() -{ - if (!sb.close()) - this->setstate(std::ios_base::failbit); -} - -/*****************************************************************************/ - -// Default constructor initializes stream buffer -gzofstream::gzofstream() -: std::ostream(NULL), sb() -{ this->init(&sb); } - -// Initialize stream buffer and open file -gzofstream::gzofstream(const char* name, - std::ios_base::openmode mode) -: std::ostream(NULL), sb() -{ - this->init(&sb); - this->open(name, mode); -} - -// Initialize stream buffer and attach to file -gzofstream::gzofstream(int fd, - std::ios_base::openmode mode) -: std::ostream(NULL), sb() -{ - this->init(&sb); - this->attach(fd, mode); -} - -// Open file and go into fail() state if unsuccessful -void -gzofstream::open(const char* name, - std::ios_base::openmode mode) -{ - if (!sb.open(name, mode | std::ios_base::out)) - this->setstate(std::ios_base::failbit); - else - this->clear(); -} - -// Attach to file and go into fail() state if unsuccessful -void -gzofstream::attach(int fd, - std::ios_base::openmode mode) -{ - if (!sb.attach(fd, mode | std::ios_base::out)) - this->setstate(std::ios_base::failbit); - else - this->clear(); -} - -// Close file -void -gzofstream::close() -{ - if (!sb.close()) - this->setstate(std::ios_base::failbit); -} DELETED compat/zlib/contrib/iostream3/zfstream.h Index: compat/zlib/contrib/iostream3/zfstream.h ================================================================== --- compat/zlib/contrib/iostream3/zfstream.h +++ /dev/null @@ -1,466 +0,0 @@ -/* - * A C++ I/O streams interface to the zlib gz* functions - * - * by Ludwig Schwardt - * original version by Kevin Ruland - * - * This version is standard-compliant and compatible with gcc 3.x. - */ - -#ifndef ZFSTREAM_H -#define ZFSTREAM_H - -#include // not iostream, since we don't need cin/cout -#include -#include "zlib.h" - -/*****************************************************************************/ - -/** - * @brief Gzipped file stream buffer class. - * - * This class implements basic_filebuf for gzipped files. It doesn't yet support - * seeking (allowed by zlib but slow/limited), putback and read/write access - * (tricky). Otherwise, it attempts to be a drop-in replacement for the standard - * file streambuf. -*/ -class gzfilebuf : public std::streambuf -{ -public: - // Default constructor. - gzfilebuf(); - - // Destructor. - virtual - ~gzfilebuf(); - - /** - * @brief Set compression level and strategy on the fly. - * @param comp_level Compression level (see zlib.h for allowed values) - * @param comp_strategy Compression strategy (see zlib.h for allowed values) - * @return Z_OK on success, Z_STREAM_ERROR otherwise. - * - * Unfortunately, these parameters cannot be modified separately, as the - * previous zfstream version assumed. Since the strategy is seldom changed, - * it can default and setcompression(level) then becomes like the old - * setcompressionlevel(level). - */ - int - setcompression(int comp_level, - int comp_strategy = Z_DEFAULT_STRATEGY); - - /** - * @brief Check if file is open. - * @return True if file is open. - */ - bool - is_open() const { return (file != NULL); } - - /** - * @brief Open gzipped file. - * @param name File name. - * @param mode Open mode flags. - * @return @c this on success, NULL on failure. - */ - gzfilebuf* - open(const char* name, - std::ios_base::openmode mode); - - /** - * @brief Attach to already open gzipped file. - * @param fd File descriptor. - * @param mode Open mode flags. - * @return @c this on success, NULL on failure. - */ - gzfilebuf* - attach(int fd, - std::ios_base::openmode mode); - - /** - * @brief Close gzipped file. - * @return @c this on success, NULL on failure. - */ - gzfilebuf* - close(); - -protected: - /** - * @brief Convert ios open mode int to mode string used by zlib. - * @return True if valid mode flag combination. - */ - bool - open_mode(std::ios_base::openmode mode, - char* c_mode) const; - - /** - * @brief Number of characters available in stream buffer. - * @return Number of characters. - * - * This indicates number of characters in get area of stream buffer. - * These characters can be read without accessing the gzipped file. - */ - virtual std::streamsize - showmanyc(); - - /** - * @brief Fill get area from gzipped file. - * @return First character in get area on success, EOF on error. - * - * This actually reads characters from gzipped file to stream - * buffer. Always buffered. - */ - virtual int_type - underflow(); - - /** - * @brief Write put area to gzipped file. - * @param c Extra character to add to buffer contents. - * @return Non-EOF on success, EOF on error. - * - * This actually writes characters in stream buffer to - * gzipped file. With unbuffered output this is done one - * character at a time. - */ - virtual int_type - overflow(int_type c = traits_type::eof()); - - /** - * @brief Installs external stream buffer. - * @param p Pointer to char buffer. - * @param n Size of external buffer. - * @return @c this on success, NULL on failure. - * - * Call setbuf(0,0) to enable unbuffered output. - */ - virtual std::streambuf* - setbuf(char_type* p, - std::streamsize n); - - /** - * @brief Flush stream buffer to file. - * @return 0 on success, -1 on error. - * - * This calls underflow(EOF) to do the job. - */ - virtual int - sync(); - -// -// Some future enhancements -// -// virtual int_type uflow(); -// virtual int_type pbackfail(int_type c = traits_type::eof()); -// virtual pos_type -// seekoff(off_type off, -// std::ios_base::seekdir way, -// std::ios_base::openmode mode = std::ios_base::in|std::ios_base::out); -// virtual pos_type -// seekpos(pos_type sp, -// std::ios_base::openmode mode = std::ios_base::in|std::ios_base::out); - -private: - /** - * @brief Allocate internal buffer. - * - * This function is safe to call multiple times. It will ensure - * that a proper internal buffer exists if it is required. If the - * buffer already exists or is external, the buffer pointers will be - * reset to their original state. - */ - void - enable_buffer(); - - /** - * @brief Destroy internal buffer. - * - * This function is safe to call multiple times. It will ensure - * that the internal buffer is deallocated if it exists. In any - * case, it will also reset the buffer pointers. - */ - void - disable_buffer(); - - /** - * Underlying file pointer. - */ - gzFile file; - - /** - * Mode in which file was opened. - */ - std::ios_base::openmode io_mode; - - /** - * @brief True if this object owns file descriptor. - * - * This makes the class responsible for closing the file - * upon destruction. - */ - bool own_fd; - - /** - * @brief Stream buffer. - * - * For simplicity this remains allocated on the free store for the - * entire life span of the gzfilebuf object, unless replaced by setbuf. - */ - char_type* buffer; - - /** - * @brief Stream buffer size. - * - * Defaults to system default buffer size (typically 8192 bytes). - * Modified by setbuf. - */ - std::streamsize buffer_size; - - /** - * @brief True if this object owns stream buffer. - * - * This makes the class responsible for deleting the buffer - * upon destruction. - */ - bool own_buffer; -}; - -/*****************************************************************************/ - -/** - * @brief Gzipped file input stream class. - * - * This class implements ifstream for gzipped files. Seeking and putback - * is not supported yet. -*/ -class gzifstream : public std::istream -{ -public: - // Default constructor - gzifstream(); - - /** - * @brief Construct stream on gzipped file to be opened. - * @param name File name. - * @param mode Open mode flags (forced to contain ios::in). - */ - explicit - gzifstream(const char* name, - std::ios_base::openmode mode = std::ios_base::in); - - /** - * @brief Construct stream on already open gzipped file. - * @param fd File descriptor. - * @param mode Open mode flags (forced to contain ios::in). - */ - explicit - gzifstream(int fd, - std::ios_base::openmode mode = std::ios_base::in); - - /** - * Obtain underlying stream buffer. - */ - gzfilebuf* - rdbuf() const - { return const_cast(&sb); } - - /** - * @brief Check if file is open. - * @return True if file is open. - */ - bool - is_open() { return sb.is_open(); } - - /** - * @brief Open gzipped file. - * @param name File name. - * @param mode Open mode flags (forced to contain ios::in). - * - * Stream will be in state good() if file opens successfully; - * otherwise in state fail(). This differs from the behavior of - * ifstream, which never sets the state to good() and therefore - * won't allow you to reuse the stream for a second file unless - * you manually clear() the state. The choice is a matter of - * convenience. - */ - void - open(const char* name, - std::ios_base::openmode mode = std::ios_base::in); - - /** - * @brief Attach to already open gzipped file. - * @param fd File descriptor. - * @param mode Open mode flags (forced to contain ios::in). - * - * Stream will be in state good() if attach succeeded; otherwise - * in state fail(). - */ - void - attach(int fd, - std::ios_base::openmode mode = std::ios_base::in); - - /** - * @brief Close gzipped file. - * - * Stream will be in state fail() if close failed. - */ - void - close(); - -private: - /** - * Underlying stream buffer. - */ - gzfilebuf sb; -}; - -/*****************************************************************************/ - -/** - * @brief Gzipped file output stream class. - * - * This class implements ofstream for gzipped files. Seeking and putback - * is not supported yet. -*/ -class gzofstream : public std::ostream -{ -public: - // Default constructor - gzofstream(); - - /** - * @brief Construct stream on gzipped file to be opened. - * @param name File name. - * @param mode Open mode flags (forced to contain ios::out). - */ - explicit - gzofstream(const char* name, - std::ios_base::openmode mode = std::ios_base::out); - - /** - * @brief Construct stream on already open gzipped file. - * @param fd File descriptor. - * @param mode Open mode flags (forced to contain ios::out). - */ - explicit - gzofstream(int fd, - std::ios_base::openmode mode = std::ios_base::out); - - /** - * Obtain underlying stream buffer. - */ - gzfilebuf* - rdbuf() const - { return const_cast(&sb); } - - /** - * @brief Check if file is open. - * @return True if file is open. - */ - bool - is_open() { return sb.is_open(); } - - /** - * @brief Open gzipped file. - * @param name File name. - * @param mode Open mode flags (forced to contain ios::out). - * - * Stream will be in state good() if file opens successfully; - * otherwise in state fail(). This differs from the behavior of - * ofstream, which never sets the state to good() and therefore - * won't allow you to reuse the stream for a second file unless - * you manually clear() the state. The choice is a matter of - * convenience. - */ - void - open(const char* name, - std::ios_base::openmode mode = std::ios_base::out); - - /** - * @brief Attach to already open gzipped file. - * @param fd File descriptor. - * @param mode Open mode flags (forced to contain ios::out). - * - * Stream will be in state good() if attach succeeded; otherwise - * in state fail(). - */ - void - attach(int fd, - std::ios_base::openmode mode = std::ios_base::out); - - /** - * @brief Close gzipped file. - * - * Stream will be in state fail() if close failed. - */ - void - close(); - -private: - /** - * Underlying stream buffer. - */ - gzfilebuf sb; -}; - -/*****************************************************************************/ - -/** - * @brief Gzipped file output stream manipulator class. - * - * This class defines a two-argument manipulator for gzofstream. It is used - * as base for the setcompression(int,int) manipulator. -*/ -template - class gzomanip2 - { - public: - // Allows insertor to peek at internals - template - friend gzofstream& - operator<<(gzofstream&, - const gzomanip2&); - - // Constructor - gzomanip2(gzofstream& (*f)(gzofstream&, T1, T2), - T1 v1, - T2 v2); - private: - // Underlying manipulator function - gzofstream& - (*func)(gzofstream&, T1, T2); - - // Arguments for manipulator function - T1 val1; - T2 val2; - }; - -/*****************************************************************************/ - -// Manipulator function thunks through to stream buffer -inline gzofstream& -setcompression(gzofstream &gzs, int l, int s = Z_DEFAULT_STRATEGY) -{ - (gzs.rdbuf())->setcompression(l, s); - return gzs; -} - -// Manipulator constructor stores arguments -template - inline - gzomanip2::gzomanip2(gzofstream &(*f)(gzofstream &, T1, T2), - T1 v1, - T2 v2) - : func(f), val1(v1), val2(v2) - { } - -// Insertor applies underlying manipulator function to stream -template - inline gzofstream& - operator<<(gzofstream& s, const gzomanip2& m) - { return (*m.func)(s, m.val1, m.val2); } - -// Insert this onto stream to simplify setting of compression level -inline gzomanip2 -setcompression(int l, int s = Z_DEFAULT_STRATEGY) -{ return gzomanip2(&setcompression, l, s); } - -#endif // ZFSTREAM_H DELETED compat/zlib/contrib/masmx64/bld_ml64.bat Index: compat/zlib/contrib/masmx64/bld_ml64.bat ================================================================== --- compat/zlib/contrib/masmx64/bld_ml64.bat +++ /dev/null @@ -1,2 +0,0 @@ -ml64.exe /Flinffasx64 /c /Zi inffasx64.asm -ml64.exe /Flgvmat64 /c /Zi gvmat64.asm DELETED compat/zlib/contrib/masmx64/gvmat64.asm Index: compat/zlib/contrib/masmx64/gvmat64.asm ================================================================== --- compat/zlib/contrib/masmx64/gvmat64.asm +++ /dev/null @@ -1,553 +0,0 @@ -;uInt longest_match_x64( -; deflate_state *s, -; IPos cur_match); /* current match */ - -; gvmat64.asm -- Asm portion of the optimized longest_match for 32 bits x86_64 -; (AMD64 on Athlon 64, Opteron, Phenom -; and Intel EM64T on Pentium 4 with EM64T, Pentium D, Core 2 Duo, Core I5/I7) -; Copyright (C) 1995-2010 Jean-loup Gailly, Brian Raiter and Gilles Vollant. -; -; File written by Gilles Vollant, by converting to assembly the longest_match -; from Jean-loup Gailly in deflate.c of zLib and infoZip zip. -; -; and by taking inspiration on asm686 with masm, optimised assembly code -; from Brian Raiter, written 1998 -; -; This software is provided 'as-is', without any express or implied -; warranty. In no event will the authors be held liable for any damages -; arising from the use of this software. -; -; Permission is granted to anyone to use this software for any purpose, -; including commercial applications, and to alter it and redistribute it -; freely, subject to the following restrictions: -; -; 1. The origin of this software must not be misrepresented; you must not -; claim that you wrote the original software. If you use this software -; in a product, an acknowledgment in the product documentation would be -; appreciated but is not required. -; 2. Altered source versions must be plainly marked as such, and must not be -; misrepresented as being the original software -; 3. This notice may not be removed or altered from any source distribution. -; -; -; -; http://www.zlib.net -; http://www.winimage.com/zLibDll -; http://www.muppetlabs.com/~breadbox/software/assembly.html -; -; to compile this file for infozip Zip, I use option: -; ml64.exe /Flgvmat64 /c /Zi /DINFOZIP gvmat64.asm -; -; to compile this file for zLib, I use option: -; ml64.exe /Flgvmat64 /c /Zi gvmat64.asm -; Be carrefull to adapt zlib1222add below to your version of zLib -; (if you use a version of zLib before 1.0.4 or after 1.2.2.2, change -; value of zlib1222add later) -; -; This file compile with Microsoft Macro Assembler (x64) for AMD64 -; -; ml64.exe is given with Visual Studio 2005/2008/2010 and Windows WDK -; -; (you can get Windows WDK with ml64 for AMD64 from -; http://www.microsoft.com/whdc/Devtools/wdk/default.mspx for low price) -; - - -;uInt longest_match(s, cur_match) -; deflate_state *s; -; IPos cur_match; /* current match */ -.code -longest_match PROC - - -;LocalVarsSize equ 88 - LocalVarsSize equ 72 - -; register used : rax,rbx,rcx,rdx,rsi,rdi,r8,r9,r10,r11,r12 -; free register : r14,r15 -; register can be saved : rsp - - chainlenwmask equ rsp + 8 - LocalVarsSize ; high word: current chain len - ; low word: s->wmask -;window equ rsp + xx - LocalVarsSize ; local copy of s->window ; stored in r10 -;windowbestlen equ rsp + xx - LocalVarsSize ; s->window + bestlen , use r10+r11 -;scanstart equ rsp + xx - LocalVarsSize ; first two bytes of string ; stored in r12w -;scanend equ rsp + xx - LocalVarsSize ; last two bytes of string use ebx -;scanalign equ rsp + xx - LocalVarsSize ; dword-misalignment of string r13 -;bestlen equ rsp + xx - LocalVarsSize ; size of best match so far -> r11d -;scan equ rsp + xx - LocalVarsSize ; ptr to string wanting match -> r9 -IFDEF INFOZIP -ELSE - nicematch equ (rsp + 16 - LocalVarsSize) ; a good enough match size -ENDIF - -save_rdi equ rsp + 24 - LocalVarsSize -save_rsi equ rsp + 32 - LocalVarsSize -save_rbx equ rsp + 40 - LocalVarsSize -save_rbp equ rsp + 48 - LocalVarsSize -save_r12 equ rsp + 56 - LocalVarsSize -save_r13 equ rsp + 64 - LocalVarsSize -;save_r14 equ rsp + 72 - LocalVarsSize -;save_r15 equ rsp + 80 - LocalVarsSize - - -; summary of register usage -; scanend ebx -; scanendw bx -; chainlenwmask edx -; curmatch rsi -; curmatchd esi -; windowbestlen r8 -; scanalign r9 -; scanalignd r9d -; window r10 -; bestlen r11 -; bestlend r11d -; scanstart r12d -; scanstartw r12w -; scan r13 -; nicematch r14d -; limit r15 -; limitd r15d -; prev rcx - -; all the +4 offsets are due to the addition of pending_buf_size (in zlib -; in the deflate_state structure since the asm code was first written -; (if you compile with zlib 1.0.4 or older, remove the +4). -; Note : these value are good with a 8 bytes boundary pack structure - - - MAX_MATCH equ 258 - MIN_MATCH equ 3 - MIN_LOOKAHEAD equ (MAX_MATCH+MIN_MATCH+1) - - -;;; Offsets for fields in the deflate_state structure. These numbers -;;; are calculated from the definition of deflate_state, with the -;;; assumption that the compiler will dword-align the fields. (Thus, -;;; changing the definition of deflate_state could easily cause this -;;; program to crash horribly, without so much as a warning at -;;; compile time. Sigh.) - -; all the +zlib1222add offsets are due to the addition of fields -; in zlib in the deflate_state structure since the asm code was first written -; (if you compile with zlib 1.0.4 or older, use "zlib1222add equ (-4)"). -; (if you compile with zlib between 1.0.5 and 1.2.2.1, use "zlib1222add equ 0"). -; if you compile with zlib 1.2.2.2 or later , use "zlib1222add equ 8"). - - -IFDEF INFOZIP - -_DATA SEGMENT -COMM window_size:DWORD -; WMask ; 7fff -COMM window:BYTE:010040H -COMM prev:WORD:08000H -; MatchLen : unused -; PrevMatch : unused -COMM strstart:DWORD -COMM match_start:DWORD -; Lookahead : ignore -COMM prev_length:DWORD ; PrevLen -COMM max_chain_length:DWORD -COMM good_match:DWORD -COMM nice_match:DWORD -prev_ad equ OFFSET prev -window_ad equ OFFSET window -nicematch equ nice_match -_DATA ENDS -WMask equ 07fffh - -ELSE - - IFNDEF zlib1222add - zlib1222add equ 8 - ENDIF -dsWSize equ 56+zlib1222add+(zlib1222add/2) -dsWMask equ 64+zlib1222add+(zlib1222add/2) -dsWindow equ 72+zlib1222add -dsPrev equ 88+zlib1222add -dsMatchLen equ 128+zlib1222add -dsPrevMatch equ 132+zlib1222add -dsStrStart equ 140+zlib1222add -dsMatchStart equ 144+zlib1222add -dsLookahead equ 148+zlib1222add -dsPrevLen equ 152+zlib1222add -dsMaxChainLen equ 156+zlib1222add -dsGoodMatch equ 172+zlib1222add -dsNiceMatch equ 176+zlib1222add - -window_size equ [ rcx + dsWSize] -WMask equ [ rcx + dsWMask] -window_ad equ [ rcx + dsWindow] -prev_ad equ [ rcx + dsPrev] -strstart equ [ rcx + dsStrStart] -match_start equ [ rcx + dsMatchStart] -Lookahead equ [ rcx + dsLookahead] ; 0ffffffffh on infozip -prev_length equ [ rcx + dsPrevLen] -max_chain_length equ [ rcx + dsMaxChainLen] -good_match equ [ rcx + dsGoodMatch] -nice_match equ [ rcx + dsNiceMatch] -ENDIF - -; parameter 1 in r8(deflate state s), param 2 in rdx (cur match) - -; see http://weblogs.asp.net/oldnewthing/archive/2004/01/14/58579.aspx and -; http://msdn.microsoft.com/library/en-us/kmarch/hh/kmarch/64bitAMD_8e951dd2-ee77-4728-8702-55ce4b5dd24a.xml.asp -; -; All registers must be preserved across the call, except for -; rax, rcx, rdx, r8, r9, r10, and r11, which are scratch. - - - -;;; Save registers that the compiler may be using, and adjust esp to -;;; make room for our stack frame. - - -;;; Retrieve the function arguments. r8d will hold cur_match -;;; throughout the entire function. edx will hold the pointer to the -;;; deflate_state structure during the function's setup (before -;;; entering the main loop. - -; parameter 1 in rcx (deflate_state* s), param 2 in edx -> r8 (cur match) - -; this clear high 32 bits of r8, which can be garbage in both r8 and rdx - - mov [save_rdi],rdi - mov [save_rsi],rsi - mov [save_rbx],rbx - mov [save_rbp],rbp -IFDEF INFOZIP - mov r8d,ecx -ELSE - mov r8d,edx -ENDIF - mov [save_r12],r12 - mov [save_r13],r13 -; mov [save_r14],r14 -; mov [save_r15],r15 - - -;;; uInt wmask = s->w_mask; -;;; unsigned chain_length = s->max_chain_length; -;;; if (s->prev_length >= s->good_match) { -;;; chain_length >>= 2; -;;; } - - mov edi, prev_length - mov esi, good_match - mov eax, WMask - mov ebx, max_chain_length - cmp edi, esi - jl LastMatchGood - shr ebx, 2 -LastMatchGood: - -;;; chainlen is decremented once beforehand so that the function can -;;; use the sign flag instead of the zero flag for the exit test. -;;; It is then shifted into the high word, to make room for the wmask -;;; value, which it will always accompany. - - dec ebx - shl ebx, 16 - or ebx, eax - -;;; on zlib only -;;; if ((uInt)nice_match > s->lookahead) nice_match = s->lookahead; - -IFDEF INFOZIP - mov [chainlenwmask], ebx -; on infozip nice_match = [nice_match] -ELSE - mov eax, nice_match - mov [chainlenwmask], ebx - mov r10d, Lookahead - cmp r10d, eax - cmovnl r10d, eax - mov [nicematch],r10d -ENDIF - -;;; register Bytef *scan = s->window + s->strstart; - mov r10, window_ad - mov ebp, strstart - lea r13, [r10 + rbp] - -;;; Determine how many bytes the scan ptr is off from being -;;; dword-aligned. - - mov r9,r13 - neg r13 - and r13,3 - -;;; IPos limit = s->strstart > (IPos)MAX_DIST(s) ? -;;; s->strstart - (IPos)MAX_DIST(s) : NIL; -IFDEF INFOZIP - mov eax,07efah ; MAX_DIST = (WSIZE-MIN_LOOKAHEAD) (0x8000-(3+8+1)) -ELSE - mov eax, window_size - sub eax, MIN_LOOKAHEAD -ENDIF - xor edi,edi - sub ebp, eax - - mov r11d, prev_length - - cmovng ebp,edi - -;;; int best_len = s->prev_length; - - -;;; Store the sum of s->window + best_len in esi locally, and in esi. - - lea rsi,[r10+r11] - -;;; register ush scan_start = *(ushf*)scan; -;;; register ush scan_end = *(ushf*)(scan+best_len-1); -;;; Posf *prev = s->prev; - - movzx r12d,word ptr [r9] - movzx ebx, word ptr [r9 + r11 - 1] - - mov rdi, prev_ad - -;;; Jump into the main loop. - - mov edx, [chainlenwmask] - - cmp bx,word ptr [rsi + r8 - 1] - jz LookupLoopIsZero - -LookupLoop1: - and r8d, edx - - movzx r8d, word ptr [rdi + r8*2] - cmp r8d, ebp - jbe LeaveNow - sub edx, 00010000h - js LeaveNow - -LoopEntry1: - cmp bx,word ptr [rsi + r8 - 1] - jz LookupLoopIsZero - -LookupLoop2: - and r8d, edx - - movzx r8d, word ptr [rdi + r8*2] - cmp r8d, ebp - jbe LeaveNow - sub edx, 00010000h - js LeaveNow - -LoopEntry2: - cmp bx,word ptr [rsi + r8 - 1] - jz LookupLoopIsZero - -LookupLoop4: - and r8d, edx - - movzx r8d, word ptr [rdi + r8*2] - cmp r8d, ebp - jbe LeaveNow - sub edx, 00010000h - js LeaveNow - -LoopEntry4: - - cmp bx,word ptr [rsi + r8 - 1] - jnz LookupLoop1 - jmp LookupLoopIsZero - - -;;; do { -;;; match = s->window + cur_match; -;;; if (*(ushf*)(match+best_len-1) != scan_end || -;;; *(ushf*)match != scan_start) continue; -;;; [...] -;;; } while ((cur_match = prev[cur_match & wmask]) > limit -;;; && --chain_length != 0); -;;; -;;; Here is the inner loop of the function. The function will spend the -;;; majority of its time in this loop, and majority of that time will -;;; be spent in the first ten instructions. -;;; -;;; Within this loop: -;;; ebx = scanend -;;; r8d = curmatch -;;; edx = chainlenwmask - i.e., ((chainlen << 16) | wmask) -;;; esi = windowbestlen - i.e., (window + bestlen) -;;; edi = prev -;;; ebp = limit - -LookupLoop: - and r8d, edx - - movzx r8d, word ptr [rdi + r8*2] - cmp r8d, ebp - jbe LeaveNow - sub edx, 00010000h - js LeaveNow - -LoopEntry: - - cmp bx,word ptr [rsi + r8 - 1] - jnz LookupLoop1 -LookupLoopIsZero: - cmp r12w, word ptr [r10 + r8] - jnz LookupLoop1 - - -;;; Store the current value of chainlen. - mov [chainlenwmask], edx - -;;; Point edi to the string under scrutiny, and esi to the string we -;;; are hoping to match it up with. In actuality, esi and edi are -;;; both pointed (MAX_MATCH_8 - scanalign) bytes ahead, and edx is -;;; initialized to -(MAX_MATCH_8 - scanalign). - - lea rsi,[r8+r10] - mov rdx, 0fffffffffffffef8h; -(MAX_MATCH_8) - lea rsi, [rsi + r13 + 0108h] ;MAX_MATCH_8] - lea rdi, [r9 + r13 + 0108h] ;MAX_MATCH_8] - - prefetcht1 [rsi+rdx] - prefetcht1 [rdi+rdx] - - -;;; Test the strings for equality, 8 bytes at a time. At the end, -;;; adjust rdx so that it is offset to the exact byte that mismatched. -;;; -;;; We already know at this point that the first three bytes of the -;;; strings match each other, and they can be safely passed over before -;;; starting the compare loop. So what this code does is skip over 0-3 -;;; bytes, as much as necessary in order to dword-align the edi -;;; pointer. (rsi will still be misaligned three times out of four.) -;;; -;;; It should be confessed that this loop usually does not represent -;;; much of the total running time. Replacing it with a more -;;; straightforward "rep cmpsb" would not drastically degrade -;;; performance. - - -LoopCmps: - mov rax, [rsi + rdx] - xor rax, [rdi + rdx] - jnz LeaveLoopCmps - - mov rax, [rsi + rdx + 8] - xor rax, [rdi + rdx + 8] - jnz LeaveLoopCmps8 - - - mov rax, [rsi + rdx + 8+8] - xor rax, [rdi + rdx + 8+8] - jnz LeaveLoopCmps16 - - add rdx,8+8+8 - - jnz short LoopCmps - jmp short LenMaximum -LeaveLoopCmps16: add rdx,8 -LeaveLoopCmps8: add rdx,8 -LeaveLoopCmps: - - test eax, 0000FFFFh - jnz LenLower - - test eax,0ffffffffh - - jnz LenLower32 - - add rdx,4 - shr rax,32 - or ax,ax - jnz LenLower - -LenLower32: - shr eax,16 - add rdx,2 -LenLower: sub al, 1 - adc rdx, 0 -;;; Calculate the length of the match. If it is longer than MAX_MATCH, -;;; then automatically accept it as the best possible match and leave. - - lea rax, [rdi + rdx] - sub rax, r9 - cmp eax, MAX_MATCH - jge LenMaximum - -;;; If the length of the match is not longer than the best match we -;;; have so far, then forget it and return to the lookup loop. -;/////////////////////////////////// - - cmp eax, r11d - jg LongerMatch - - lea rsi,[r10+r11] - - mov rdi, prev_ad - mov edx, [chainlenwmask] - jmp LookupLoop - -;;; s->match_start = cur_match; -;;; best_len = len; -;;; if (len >= nice_match) break; -;;; scan_end = *(ushf*)(scan+best_len-1); - -LongerMatch: - mov r11d, eax - mov match_start, r8d - cmp eax, [nicematch] - jge LeaveNow - - lea rsi,[r10+rax] - - movzx ebx, word ptr [r9 + rax - 1] - mov rdi, prev_ad - mov edx, [chainlenwmask] - jmp LookupLoop - -;;; Accept the current string, with the maximum possible length. - -LenMaximum: - mov r11d,MAX_MATCH - mov match_start, r8d - -;;; if ((uInt)best_len <= s->lookahead) return (uInt)best_len; -;;; return s->lookahead; - -LeaveNow: -IFDEF INFOZIP - mov eax,r11d -ELSE - mov eax, Lookahead - cmp r11d, eax - cmovng eax, r11d -ENDIF - -;;; Restore the stack and return from whence we came. - - - mov rsi,[save_rsi] - mov rdi,[save_rdi] - mov rbx,[save_rbx] - mov rbp,[save_rbp] - mov r12,[save_r12] - mov r13,[save_r13] -; mov r14,[save_r14] -; mov r15,[save_r15] - - - ret 0 -; please don't remove this string ! -; Your can freely use gvmat64 in any free or commercial app -; but it is far better don't remove the string in the binary! - db 0dh,0ah,"asm686 with masm, optimised assembly code from Brian Raiter, written 1998, converted to amd 64 by Gilles Vollant 2005",0dh,0ah,0 -longest_match ENDP - -match_init PROC - ret 0 -match_init ENDP - - -END DELETED compat/zlib/contrib/masmx64/inffas8664.c Index: compat/zlib/contrib/masmx64/inffas8664.c ================================================================== --- compat/zlib/contrib/masmx64/inffas8664.c +++ /dev/null @@ -1,186 +0,0 @@ -/* inffas8664.c is a hand tuned assembler version of inffast.c - fast decoding - * version for AMD64 on Windows using Microsoft C compiler - * - * Copyright (C) 1995-2003 Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - * - * Copyright (C) 2003 Chris Anderson - * Please use the copyright conditions above. - * - * 2005 - Adaptation to Microsoft C Compiler for AMD64 by Gilles Vollant - * - * inffas8664.c call function inffas8664fnc in inffasx64.asm - * inffasx64.asm is automatically convert from AMD64 portion of inffas86.c - * - * Dec-29-2003 -- I added AMD64 inflate asm support. This version is also - * slightly quicker on x86 systems because, instead of using rep movsb to copy - * data, it uses rep movsw, which moves data in 2-byte chunks instead of single - * bytes. I've tested the AMD64 code on a Fedora Core 1 + the x86_64 updates - * from http://fedora.linux.duke.edu/fc1_x86_64 - * which is running on an Athlon 64 3000+ / Gigabyte GA-K8VT800M system with - * 1GB ram. The 64-bit version is about 4% faster than the 32-bit version, - * when decompressing mozilla-source-1.3.tar.gz. - * - * Mar-13-2003 -- Most of this is derived from inffast.S which is derived from - * the gcc -S output of zlib-1.2.0/inffast.c. Zlib-1.2.0 is in beta release at - * the moment. I have successfully compiled and tested this code with gcc2.96, - * gcc3.2, icc5.0, msvc6.0. It is very close to the speed of inffast.S - * compiled with gcc -DNO_MMX, but inffast.S is still faster on the P3 with MMX - * enabled. I will attempt to merge the MMX code into this version. Newer - * versions of this and inffast.S can be found at - * http://www.eetbeetee.com/zlib/ and http://www.charm.net/~christop/zlib/ - * - */ - -#include -#include "zutil.h" -#include "inftrees.h" -#include "inflate.h" -#include "inffast.h" - -/* Mark Adler's comments from inffast.c: */ - -/* - Decode literal, length, and distance codes and write out the resulting - literal and match bytes until either not enough input or output is - available, an end-of-block is encountered, or a data error is encountered. - When large enough input and output buffers are supplied to inflate(), for - example, a 16K input buffer and a 64K output buffer, more than 95% of the - inflate execution time is spent in this routine. - - Entry assumptions: - - state->mode == LEN - strm->avail_in >= 6 - strm->avail_out >= 258 - start >= strm->avail_out - state->bits < 8 - - On return, state->mode is one of: - - LEN -- ran out of enough output space or enough available input - TYPE -- reached end of block code, inflate() to interpret next block - BAD -- error in block data - - Notes: - - - The maximum input bits used by a length/distance pair is 15 bits for the - length code, 5 bits for the length extra, 15 bits for the distance code, - and 13 bits for the distance extra. This totals 48 bits, or six bytes. - Therefore if strm->avail_in >= 6, then there is enough input to avoid - checking for available input while decoding. - - - The maximum bytes that a single length/distance pair can output is 258 - bytes, which is the maximum length that can be coded. inflate_fast() - requires strm->avail_out >= 258 for each loop to avoid checking for - output space. - */ - - - - typedef struct inffast_ar { -/* 64 32 x86 x86_64 */ -/* ar offset register */ -/* 0 0 */ void *esp; /* esp save */ -/* 8 4 */ void *ebp; /* ebp save */ -/* 16 8 */ unsigned char FAR *in; /* esi rsi local strm->next_in */ -/* 24 12 */ unsigned char FAR *last; /* r9 while in < last */ -/* 32 16 */ unsigned char FAR *out; /* edi rdi local strm->next_out */ -/* 40 20 */ unsigned char FAR *beg; /* inflate()'s init next_out */ -/* 48 24 */ unsigned char FAR *end; /* r10 while out < end */ -/* 56 28 */ unsigned char FAR *window;/* size of window, wsize!=0 */ -/* 64 32 */ code const FAR *lcode; /* ebp rbp local strm->lencode */ -/* 72 36 */ code const FAR *dcode; /* r11 local strm->distcode */ -/* 80 40 */ size_t /*unsigned long */hold; /* edx rdx local strm->hold */ -/* 88 44 */ unsigned bits; /* ebx rbx local strm->bits */ -/* 92 48 */ unsigned wsize; /* window size */ -/* 96 52 */ unsigned write; /* window write index */ -/*100 56 */ unsigned lmask; /* r12 mask for lcode */ -/*104 60 */ unsigned dmask; /* r13 mask for dcode */ -/*108 64 */ unsigned len; /* r14 match length */ -/*112 68 */ unsigned dist; /* r15 match distance */ -/*116 72 */ unsigned status; /* set when state chng*/ - } type_ar; -#ifdef ASMINF - -void inflate_fast(strm, start) -z_streamp strm; -unsigned start; /* inflate()'s starting value for strm->avail_out */ -{ - struct inflate_state FAR *state; - type_ar ar; - void inffas8664fnc(struct inffast_ar * par); - - - -#if (defined( __GNUC__ ) && defined( __amd64__ ) && ! defined( __i386 )) || (defined(_MSC_VER) && defined(_M_AMD64)) -#define PAD_AVAIL_IN 6 -#define PAD_AVAIL_OUT 258 -#else -#define PAD_AVAIL_IN 5 -#define PAD_AVAIL_OUT 257 -#endif - - /* copy state to local variables */ - state = (struct inflate_state FAR *)strm->state; - - ar.in = strm->next_in; - ar.last = ar.in + (strm->avail_in - PAD_AVAIL_IN); - ar.out = strm->next_out; - ar.beg = ar.out - (start - strm->avail_out); - ar.end = ar.out + (strm->avail_out - PAD_AVAIL_OUT); - ar.wsize = state->wsize; - ar.write = state->wnext; - ar.window = state->window; - ar.hold = state->hold; - ar.bits = state->bits; - ar.lcode = state->lencode; - ar.dcode = state->distcode; - ar.lmask = (1U << state->lenbits) - 1; - ar.dmask = (1U << state->distbits) - 1; - - /* decode literals and length/distances until end-of-block or not enough - input data or output space */ - - /* align in on 1/2 hold size boundary */ - while (((size_t)(void *)ar.in & (sizeof(ar.hold) / 2 - 1)) != 0) { - ar.hold += (unsigned long)*ar.in++ << ar.bits; - ar.bits += 8; - } - - inffas8664fnc(&ar); - - if (ar.status > 1) { - if (ar.status == 2) - strm->msg = "invalid literal/length code"; - else if (ar.status == 3) - strm->msg = "invalid distance code"; - else - strm->msg = "invalid distance too far back"; - state->mode = BAD; - } - else if ( ar.status == 1 ) { - state->mode = TYPE; - } - - /* return unused bytes (on entry, bits < 8, so in won't go too far back) */ - ar.len = ar.bits >> 3; - ar.in -= ar.len; - ar.bits -= ar.len << 3; - ar.hold &= (1U << ar.bits) - 1; - - /* update state and return */ - strm->next_in = ar.in; - strm->next_out = ar.out; - strm->avail_in = (unsigned)(ar.in < ar.last ? - PAD_AVAIL_IN + (ar.last - ar.in) : - PAD_AVAIL_IN - (ar.in - ar.last)); - strm->avail_out = (unsigned)(ar.out < ar.end ? - PAD_AVAIL_OUT + (ar.end - ar.out) : - PAD_AVAIL_OUT - (ar.out - ar.end)); - state->hold = (unsigned long)ar.hold; - state->bits = ar.bits; - return; -} - -#endif DELETED compat/zlib/contrib/masmx64/inffasx64.asm Index: compat/zlib/contrib/masmx64/inffasx64.asm ================================================================== --- compat/zlib/contrib/masmx64/inffasx64.asm +++ /dev/null @@ -1,396 +0,0 @@ -; inffasx64.asm is a hand tuned assembler version of inffast.c - fast decoding -; version for AMD64 on Windows using Microsoft C compiler -; -; inffasx64.asm is automatically convert from AMD64 portion of inffas86.c -; inffasx64.asm is called by inffas8664.c, which contain more info. - - -; to compile this file, I use option -; ml64.exe /Flinffasx64 /c /Zi inffasx64.asm -; with Microsoft Macro Assembler (x64) for AMD64 -; - -; This file compile with Microsoft Macro Assembler (x64) for AMD64 -; -; ml64.exe is given with Visual Studio 2005/2008/2010 and Windows WDK -; -; (you can get Windows WDK with ml64 for AMD64 from -; http://www.microsoft.com/whdc/Devtools/wdk/default.mspx for low price) -; - - -.code -inffas8664fnc PROC - -; see http://weblogs.asp.net/oldnewthing/archive/2004/01/14/58579.aspx and -; http://msdn.microsoft.com/library/en-us/kmarch/hh/kmarch/64bitAMD_8e951dd2-ee77-4728-8702-55ce4b5dd24a.xml.asp -; -; All registers must be preserved across the call, except for -; rax, rcx, rdx, r8, r-9, r10, and r11, which are scratch. - - - mov [rsp-8],rsi - mov [rsp-16],rdi - mov [rsp-24],r12 - mov [rsp-32],r13 - mov [rsp-40],r14 - mov [rsp-48],r15 - mov [rsp-56],rbx - - mov rax,rcx - - mov [rax+8], rbp ; /* save regs rbp and rsp */ - mov [rax], rsp - - mov rsp, rax ; /* make rsp point to &ar */ - - mov rsi, [rsp+16] ; /* rsi = in */ - mov rdi, [rsp+32] ; /* rdi = out */ - mov r9, [rsp+24] ; /* r9 = last */ - mov r10, [rsp+48] ; /* r10 = end */ - mov rbp, [rsp+64] ; /* rbp = lcode */ - mov r11, [rsp+72] ; /* r11 = dcode */ - mov rdx, [rsp+80] ; /* rdx = hold */ - mov ebx, [rsp+88] ; /* ebx = bits */ - mov r12d, [rsp+100] ; /* r12d = lmask */ - mov r13d, [rsp+104] ; /* r13d = dmask */ - ; /* r14d = len */ - ; /* r15d = dist */ - - - cld - cmp r10, rdi - je L_one_time ; /* if only one decode left */ - cmp r9, rsi - - jne L_do_loop - - -L_one_time: - mov r8, r12 ; /* r8 = lmask */ - cmp bl, 32 - ja L_get_length_code_one_time - - lodsd ; /* eax = *(uint *)in++ */ - mov cl, bl ; /* cl = bits, needs it for shifting */ - add bl, 32 ; /* bits += 32 */ - shl rax, cl - or rdx, rax ; /* hold |= *((uint *)in)++ << bits */ - jmp L_get_length_code_one_time - -ALIGN 4 -L_while_test: - cmp r10, rdi - jbe L_break_loop - cmp r9, rsi - jbe L_break_loop - -L_do_loop: - mov r8, r12 ; /* r8 = lmask */ - cmp bl, 32 - ja L_get_length_code ; /* if (32 < bits) */ - - lodsd ; /* eax = *(uint *)in++ */ - mov cl, bl ; /* cl = bits, needs it for shifting */ - add bl, 32 ; /* bits += 32 */ - shl rax, cl - or rdx, rax ; /* hold |= *((uint *)in)++ << bits */ - -L_get_length_code: - and r8, rdx ; /* r8 &= hold */ - mov eax, [rbp+r8*4] ; /* eax = lcode[hold & lmask] */ - - mov cl, ah ; /* cl = this.bits */ - sub bl, ah ; /* bits -= this.bits */ - shr rdx, cl ; /* hold >>= this.bits */ - - test al, al - jnz L_test_for_length_base ; /* if (op != 0) 45.7% */ - - mov r8, r12 ; /* r8 = lmask */ - shr eax, 16 ; /* output this.val char */ - stosb - -L_get_length_code_one_time: - and r8, rdx ; /* r8 &= hold */ - mov eax, [rbp+r8*4] ; /* eax = lcode[hold & lmask] */ - -L_dolen: - mov cl, ah ; /* cl = this.bits */ - sub bl, ah ; /* bits -= this.bits */ - shr rdx, cl ; /* hold >>= this.bits */ - - test al, al - jnz L_test_for_length_base ; /* if (op != 0) 45.7% */ - - shr eax, 16 ; /* output this.val char */ - stosb - jmp L_while_test - -ALIGN 4 -L_test_for_length_base: - mov r14d, eax ; /* len = this */ - shr r14d, 16 ; /* len = this.val */ - mov cl, al - - test al, 16 - jz L_test_for_second_level_length ; /* if ((op & 16) == 0) 8% */ - and cl, 15 ; /* op &= 15 */ - jz L_decode_distance ; /* if (!op) */ - -L_add_bits_to_len: - sub bl, cl - xor eax, eax - inc eax - shl eax, cl - dec eax - and eax, edx ; /* eax &= hold */ - shr rdx, cl - add r14d, eax ; /* len += hold & mask[op] */ - -L_decode_distance: - mov r8, r13 ; /* r8 = dmask */ - cmp bl, 32 - ja L_get_distance_code ; /* if (32 < bits) */ - - lodsd ; /* eax = *(uint *)in++ */ - mov cl, bl ; /* cl = bits, needs it for shifting */ - add bl, 32 ; /* bits += 32 */ - shl rax, cl - or rdx, rax ; /* hold |= *((uint *)in)++ << bits */ - -L_get_distance_code: - and r8, rdx ; /* r8 &= hold */ - mov eax, [r11+r8*4] ; /* eax = dcode[hold & dmask] */ - -L_dodist: - mov r15d, eax ; /* dist = this */ - shr r15d, 16 ; /* dist = this.val */ - mov cl, ah - sub bl, ah ; /* bits -= this.bits */ - shr rdx, cl ; /* hold >>= this.bits */ - mov cl, al ; /* cl = this.op */ - - test al, 16 ; /* if ((op & 16) == 0) */ - jz L_test_for_second_level_dist - and cl, 15 ; /* op &= 15 */ - jz L_check_dist_one - -L_add_bits_to_dist: - sub bl, cl - xor eax, eax - inc eax - shl eax, cl - dec eax ; /* (1 << op) - 1 */ - and eax, edx ; /* eax &= hold */ - shr rdx, cl - add r15d, eax ; /* dist += hold & ((1 << op) - 1) */ - -L_check_window: - mov r8, rsi ; /* save in so from can use it's reg */ - mov rax, rdi - sub rax, [rsp+40] ; /* nbytes = out - beg */ - - cmp eax, r15d - jb L_clip_window ; /* if (dist > nbytes) 4.2% */ - - mov ecx, r14d ; /* ecx = len */ - mov rsi, rdi - sub rsi, r15 ; /* from = out - dist */ - - sar ecx, 1 - jnc L_copy_two ; /* if len % 2 == 0 */ - - rep movsw - mov al, [rsi] - mov [rdi], al - inc rdi - - mov rsi, r8 ; /* move in back to %rsi, toss from */ - jmp L_while_test - -L_copy_two: - rep movsw - mov rsi, r8 ; /* move in back to %rsi, toss from */ - jmp L_while_test - -ALIGN 4 -L_check_dist_one: - cmp r15d, 1 ; /* if dist 1, is a memset */ - jne L_check_window - cmp [rsp+40], rdi ; /* if out == beg, outside window */ - je L_check_window - - mov ecx, r14d ; /* ecx = len */ - mov al, [rdi-1] - mov ah, al - - sar ecx, 1 - jnc L_set_two - mov [rdi], al - inc rdi - -L_set_two: - rep stosw - jmp L_while_test - -ALIGN 4 -L_test_for_second_level_length: - test al, 64 - jnz L_test_for_end_of_block ; /* if ((op & 64) != 0) */ - - xor eax, eax - inc eax - shl eax, cl - dec eax - and eax, edx ; /* eax &= hold */ - add eax, r14d ; /* eax += len */ - mov eax, [rbp+rax*4] ; /* eax = lcode[val+(hold&mask[op])]*/ - jmp L_dolen - -ALIGN 4 -L_test_for_second_level_dist: - test al, 64 - jnz L_invalid_distance_code ; /* if ((op & 64) != 0) */ - - xor eax, eax - inc eax - shl eax, cl - dec eax - and eax, edx ; /* eax &= hold */ - add eax, r15d ; /* eax += dist */ - mov eax, [r11+rax*4] ; /* eax = dcode[val+(hold&mask[op])]*/ - jmp L_dodist - -ALIGN 4 -L_clip_window: - mov ecx, eax ; /* ecx = nbytes */ - mov eax, [rsp+92] ; /* eax = wsize, prepare for dist cmp */ - neg ecx ; /* nbytes = -nbytes */ - - cmp eax, r15d - jb L_invalid_distance_too_far ; /* if (dist > wsize) */ - - add ecx, r15d ; /* nbytes = dist - nbytes */ - cmp dword ptr [rsp+96], 0 - jne L_wrap_around_window ; /* if (write != 0) */ - - mov rsi, [rsp+56] ; /* from = window */ - sub eax, ecx ; /* eax -= nbytes */ - add rsi, rax ; /* from += wsize - nbytes */ - - mov eax, r14d ; /* eax = len */ - cmp r14d, ecx - jbe L_do_copy ; /* if (nbytes >= len) */ - - sub eax, ecx ; /* eax -= nbytes */ - rep movsb - mov rsi, rdi - sub rsi, r15 ; /* from = &out[ -dist ] */ - jmp L_do_copy - -ALIGN 4 -L_wrap_around_window: - mov eax, [rsp+96] ; /* eax = write */ - cmp ecx, eax - jbe L_contiguous_in_window ; /* if (write >= nbytes) */ - - mov esi, [rsp+92] ; /* from = wsize */ - add rsi, [rsp+56] ; /* from += window */ - add rsi, rax ; /* from += write */ - sub rsi, rcx ; /* from -= nbytes */ - sub ecx, eax ; /* nbytes -= write */ - - mov eax, r14d ; /* eax = len */ - cmp eax, ecx - jbe L_do_copy ; /* if (nbytes >= len) */ - - sub eax, ecx ; /* len -= nbytes */ - rep movsb - mov rsi, [rsp+56] ; /* from = window */ - mov ecx, [rsp+96] ; /* nbytes = write */ - cmp eax, ecx - jbe L_do_copy ; /* if (nbytes >= len) */ - - sub eax, ecx ; /* len -= nbytes */ - rep movsb - mov rsi, rdi - sub rsi, r15 ; /* from = out - dist */ - jmp L_do_copy - -ALIGN 4 -L_contiguous_in_window: - mov rsi, [rsp+56] ; /* rsi = window */ - add rsi, rax - sub rsi, rcx ; /* from += write - nbytes */ - - mov eax, r14d ; /* eax = len */ - cmp eax, ecx - jbe L_do_copy ; /* if (nbytes >= len) */ - - sub eax, ecx ; /* len -= nbytes */ - rep movsb - mov rsi, rdi - sub rsi, r15 ; /* from = out - dist */ - jmp L_do_copy ; /* if (nbytes >= len) */ - -ALIGN 4 -L_do_copy: - mov ecx, eax ; /* ecx = len */ - rep movsb - - mov rsi, r8 ; /* move in back to %esi, toss from */ - jmp L_while_test - -L_test_for_end_of_block: - test al, 32 - jz L_invalid_literal_length_code - mov dword ptr [rsp+116], 1 - jmp L_break_loop_with_status - -L_invalid_literal_length_code: - mov dword ptr [rsp+116], 2 - jmp L_break_loop_with_status - -L_invalid_distance_code: - mov dword ptr [rsp+116], 3 - jmp L_break_loop_with_status - -L_invalid_distance_too_far: - mov dword ptr [rsp+116], 4 - jmp L_break_loop_with_status - -L_break_loop: - mov dword ptr [rsp+116], 0 - -L_break_loop_with_status: -; /* put in, out, bits, and hold back into ar and pop esp */ - mov [rsp+16], rsi ; /* in */ - mov [rsp+32], rdi ; /* out */ - mov [rsp+88], ebx ; /* bits */ - mov [rsp+80], rdx ; /* hold */ - - mov rax, [rsp] ; /* restore rbp and rsp */ - mov rbp, [rsp+8] - mov rsp, rax - - - - mov rsi,[rsp-8] - mov rdi,[rsp-16] - mov r12,[rsp-24] - mov r13,[rsp-32] - mov r14,[rsp-40] - mov r15,[rsp-48] - mov rbx,[rsp-56] - - ret 0 -; : -; : "m" (ar) -; : "memory", "%rax", "%rbx", "%rcx", "%rdx", "%rsi", "%rdi", -; "%r8", "%r9", "%r10", "%r11", "%r12", "%r13", "%r14", "%r15" -; ); - -inffas8664fnc ENDP -;_TEXT ENDS -END DELETED compat/zlib/contrib/masmx64/readme.txt Index: compat/zlib/contrib/masmx64/readme.txt ================================================================== --- compat/zlib/contrib/masmx64/readme.txt +++ /dev/null @@ -1,31 +0,0 @@ -Summary -------- -This directory contains ASM implementations of the functions -longest_match() and inflate_fast(), for 64 bits x86 (both AMD64 and Intel EM64t), -for use with Microsoft Macro Assembler (x64) for AMD64 and Microsoft C++ 64 bits. - -gvmat64.asm is written by Gilles Vollant (2005), by using Brian Raiter 686/32 bits - assembly optimized version from Jean-loup Gailly original longest_match function - -inffasx64.asm and inffas8664.c were written by Chris Anderson, by optimizing - original function from Mark Adler - -Use instructions ----------------- -Assemble the .asm files using MASM and put the object files into the zlib source -directory. You can also get object files here: - - http://www.winimage.com/zLibDll/zlib124_masm_obj.zip - -define ASMV and ASMINF in your project. Include inffas8664.c in your source tree, -and inffasx64.obj and gvmat64.obj as object to link. - - -Build instructions ------------------- -run bld_64.bat with Microsoft Macro Assembler (x64) for AMD64 (ml64.exe) - -ml64.exe is given with Visual Studio 2005, Windows 2003 server DDK - -You can get Windows 2003 server DDK with ml64 and cl for AMD64 from - http://www.microsoft.com/whdc/devtools/ddk/default.mspx for low price) DELETED compat/zlib/contrib/masmx86/bld_ml32.bat Index: compat/zlib/contrib/masmx86/bld_ml32.bat ================================================================== --- compat/zlib/contrib/masmx86/bld_ml32.bat +++ /dev/null @@ -1,2 +0,0 @@ -ml /coff /Zi /c /Flmatch686.lst match686.asm -ml /coff /Zi /c /Flinffas32.lst inffas32.asm DELETED compat/zlib/contrib/masmx86/inffas32.asm Index: compat/zlib/contrib/masmx86/inffas32.asm ================================================================== --- compat/zlib/contrib/masmx86/inffas32.asm +++ /dev/null @@ -1,1080 +0,0 @@ -;/* inffas32.asm is a hand tuned assembler version of inffast.c -- fast decoding -; * -; * inffas32.asm is derivated from inffas86.c, with translation of assembly code -; * -; * Copyright (C) 1995-2003 Mark Adler -; * For conditions of distribution and use, see copyright notice in zlib.h -; * -; * Copyright (C) 2003 Chris Anderson -; * Please use the copyright conditions above. -; * -; * Mar-13-2003 -- Most of this is derived from inffast.S which is derived from -; * the gcc -S output of zlib-1.2.0/inffast.c. Zlib-1.2.0 is in beta release at -; * the moment. I have successfully compiled and tested this code with gcc2.96, -; * gcc3.2, icc5.0, msvc6.0. It is very close to the speed of inffast.S -; * compiled with gcc -DNO_MMX, but inffast.S is still faster on the P3 with MMX -; * enabled. I will attempt to merge the MMX code into this version. Newer -; * versions of this and inffast.S can be found at -; * http://www.eetbeetee.com/zlib/ and http://www.charm.net/~christop/zlib/ -; * -; * 2005 : modification by Gilles Vollant -; */ -; For Visual C++ 4.x and higher and ML 6.x and higher -; ml.exe is in directory \MASM611C of Win95 DDK -; ml.exe is also distributed in http://www.masm32.com/masmdl.htm -; and in VC++2003 toolkit at http://msdn.microsoft.com/visualc/vctoolkit2003/ -; -; -; compile with command line option -; ml /coff /Zi /c /Flinffas32.lst inffas32.asm - -; if you define NO_GZIP (see inflate.h), compile with -; ml /coff /Zi /c /Flinffas32.lst /DNO_GUNZIP inffas32.asm - - -; zlib122sup is 0 fort zlib 1.2.2.1 and lower -; zlib122sup is 8 fort zlib 1.2.2.2 and more (with addition of dmax and head -; in inflate_state in inflate.h) -zlib1222sup equ 8 - - -IFDEF GUNZIP - INFLATE_MODE_TYPE equ 11 - INFLATE_MODE_BAD equ 26 -ELSE - IFNDEF NO_GUNZIP - INFLATE_MODE_TYPE equ 11 - INFLATE_MODE_BAD equ 26 - ELSE - INFLATE_MODE_TYPE equ 3 - INFLATE_MODE_BAD equ 17 - ENDIF -ENDIF - - -; 75 "inffast.S" -;FILE "inffast.S" - -;;;GLOBAL _inflate_fast - -;;;SECTION .text - - - - .586p - .mmx - - name inflate_fast_x86 - .MODEL FLAT - -_DATA segment -inflate_fast_use_mmx: - dd 1 - - -_TEXT segment - - - -ALIGN 4 - db 'Fast decoding Code from Chris Anderson' - db 0 - -ALIGN 4 -invalid_literal_length_code_msg: - db 'invalid literal/length code' - db 0 - -ALIGN 4 -invalid_distance_code_msg: - db 'invalid distance code' - db 0 - -ALIGN 4 -invalid_distance_too_far_msg: - db 'invalid distance too far back' - db 0 - - -ALIGN 4 -inflate_fast_mask: -dd 0 -dd 1 -dd 3 -dd 7 -dd 15 -dd 31 -dd 63 -dd 127 -dd 255 -dd 511 -dd 1023 -dd 2047 -dd 4095 -dd 8191 -dd 16383 -dd 32767 -dd 65535 -dd 131071 -dd 262143 -dd 524287 -dd 1048575 -dd 2097151 -dd 4194303 -dd 8388607 -dd 16777215 -dd 33554431 -dd 67108863 -dd 134217727 -dd 268435455 -dd 536870911 -dd 1073741823 -dd 2147483647 -dd 4294967295 - - -mode_state equ 0 ;/* state->mode */ -wsize_state equ (32+zlib1222sup) ;/* state->wsize */ -write_state equ (36+4+zlib1222sup) ;/* state->write */ -window_state equ (40+4+zlib1222sup) ;/* state->window */ -hold_state equ (44+4+zlib1222sup) ;/* state->hold */ -bits_state equ (48+4+zlib1222sup) ;/* state->bits */ -lencode_state equ (64+4+zlib1222sup) ;/* state->lencode */ -distcode_state equ (68+4+zlib1222sup) ;/* state->distcode */ -lenbits_state equ (72+4+zlib1222sup) ;/* state->lenbits */ -distbits_state equ (76+4+zlib1222sup) ;/* state->distbits */ - - -;;SECTION .text -; 205 "inffast.S" -;GLOBAL inflate_fast_use_mmx - -;SECTION .data - - -; GLOBAL inflate_fast_use_mmx:object -;.size inflate_fast_use_mmx, 4 -; 226 "inffast.S" -;SECTION .text - -ALIGN 4 -_inflate_fast proc near -.FPO (16, 4, 0, 0, 1, 0) - push edi - push esi - push ebp - push ebx - pushfd - sub esp,64 - cld - - - - - mov esi, [esp+88] - mov edi, [esi+28] - - - - - - - - mov edx, [esi+4] - mov eax, [esi+0] - - add edx,eax - sub edx,11 - - mov [esp+44],eax - mov [esp+20],edx - - mov ebp, [esp+92] - mov ecx, [esi+16] - mov ebx, [esi+12] - - sub ebp,ecx - neg ebp - add ebp,ebx - - sub ecx,257 - add ecx,ebx - - mov [esp+60],ebx - mov [esp+40],ebp - mov [esp+16],ecx -; 285 "inffast.S" - mov eax, [edi+lencode_state] - mov ecx, [edi+distcode_state] - - mov [esp+8],eax - mov [esp+12],ecx - - mov eax,1 - mov ecx, [edi+lenbits_state] - shl eax,cl - dec eax - mov [esp+0],eax - - mov eax,1 - mov ecx, [edi+distbits_state] - shl eax,cl - dec eax - mov [esp+4],eax - - mov eax, [edi+wsize_state] - mov ecx, [edi+write_state] - mov edx, [edi+window_state] - - mov [esp+52],eax - mov [esp+48],ecx - mov [esp+56],edx - - mov ebp, [edi+hold_state] - mov ebx, [edi+bits_state] -; 321 "inffast.S" - mov esi, [esp+44] - mov ecx, [esp+20] - cmp ecx,esi - ja L_align_long - - add ecx,11 - sub ecx,esi - mov eax,12 - sub eax,ecx - lea edi, [esp+28] - rep movsb - mov ecx,eax - xor eax,eax - rep stosb - lea esi, [esp+28] - mov [esp+20],esi - jmp L_is_aligned - - -L_align_long: - test esi,3 - jz L_is_aligned - xor eax,eax - mov al, [esi] - inc esi - mov ecx,ebx - add ebx,8 - shl eax,cl - or ebp,eax - jmp L_align_long - -L_is_aligned: - mov edi, [esp+60] -; 366 "inffast.S" -L_check_mmx: - cmp dword ptr [inflate_fast_use_mmx],2 - je L_init_mmx - ja L_do_loop - - push eax - push ebx - push ecx - push edx - pushfd - mov eax, [esp] - xor dword ptr [esp],0200000h - - - - - popfd - pushfd - pop edx - xor edx,eax - jz L_dont_use_mmx - xor eax,eax - cpuid - cmp ebx,0756e6547h - jne L_dont_use_mmx - cmp ecx,06c65746eh - jne L_dont_use_mmx - cmp edx,049656e69h - jne L_dont_use_mmx - mov eax,1 - cpuid - shr eax,8 - and eax,15 - cmp eax,6 - jne L_dont_use_mmx - test edx,0800000h - jnz L_use_mmx - jmp L_dont_use_mmx -L_use_mmx: - mov dword ptr [inflate_fast_use_mmx],2 - jmp L_check_mmx_pop -L_dont_use_mmx: - mov dword ptr [inflate_fast_use_mmx],3 -L_check_mmx_pop: - pop edx - pop ecx - pop ebx - pop eax - jmp L_check_mmx -; 426 "inffast.S" -ALIGN 4 -L_do_loop: -; 437 "inffast.S" - cmp bl,15 - ja L_get_length_code - - xor eax,eax - lodsw - mov cl,bl - add bl,16 - shl eax,cl - or ebp,eax - -L_get_length_code: - mov edx, [esp+0] - mov ecx, [esp+8] - and edx,ebp - mov eax, [ecx+edx*4] - -L_dolen: - - - - - - - mov cl,ah - sub bl,ah - shr ebp,cl - - - - - - - test al,al - jnz L_test_for_length_base - - shr eax,16 - stosb - -L_while_test: - - - cmp [esp+16],edi - jbe L_break_loop - - cmp [esp+20],esi - ja L_do_loop - jmp L_break_loop - -L_test_for_length_base: -; 502 "inffast.S" - mov edx,eax - shr edx,16 - mov cl,al - - test al,16 - jz L_test_for_second_level_length - and cl,15 - jz L_save_len - cmp bl,cl - jae L_add_bits_to_len - - mov ch,cl - xor eax,eax - lodsw - mov cl,bl - add bl,16 - shl eax,cl - or ebp,eax - mov cl,ch - -L_add_bits_to_len: - mov eax,1 - shl eax,cl - dec eax - sub bl,cl - and eax,ebp - shr ebp,cl - add edx,eax - -L_save_len: - mov [esp+24],edx - - -L_decode_distance: -; 549 "inffast.S" - cmp bl,15 - ja L_get_distance_code - - xor eax,eax - lodsw - mov cl,bl - add bl,16 - shl eax,cl - or ebp,eax - -L_get_distance_code: - mov edx, [esp+4] - mov ecx, [esp+12] - and edx,ebp - mov eax, [ecx+edx*4] - - -L_dodist: - mov edx,eax - shr edx,16 - mov cl,ah - sub bl,ah - shr ebp,cl -; 584 "inffast.S" - mov cl,al - - test al,16 - jz L_test_for_second_level_dist - and cl,15 - jz L_check_dist_one - cmp bl,cl - jae L_add_bits_to_dist - - mov ch,cl - xor eax,eax - lodsw - mov cl,bl - add bl,16 - shl eax,cl - or ebp,eax - mov cl,ch - -L_add_bits_to_dist: - mov eax,1 - shl eax,cl - dec eax - sub bl,cl - and eax,ebp - shr ebp,cl - add edx,eax - jmp L_check_window - -L_check_window: -; 625 "inffast.S" - mov [esp+44],esi - mov eax,edi - sub eax, [esp+40] - - cmp eax,edx - jb L_clip_window - - mov ecx, [esp+24] - mov esi,edi - sub esi,edx - - sub ecx,3 - mov al, [esi] - mov [edi],al - mov al, [esi+1] - mov dl, [esi+2] - add esi,3 - mov [edi+1],al - mov [edi+2],dl - add edi,3 - rep movsb - - mov esi, [esp+44] - jmp L_while_test - -ALIGN 4 -L_check_dist_one: - cmp edx,1 - jne L_check_window - cmp [esp+40],edi - je L_check_window - - dec edi - mov ecx, [esp+24] - mov al, [edi] - sub ecx,3 - - mov [edi+1],al - mov [edi+2],al - mov [edi+3],al - add edi,4 - rep stosb - - jmp L_while_test - -ALIGN 4 -L_test_for_second_level_length: - - - - - test al,64 - jnz L_test_for_end_of_block - - mov eax,1 - shl eax,cl - dec eax - and eax,ebp - add eax,edx - mov edx, [esp+8] - mov eax, [edx+eax*4] - jmp L_dolen - -ALIGN 4 -L_test_for_second_level_dist: - - - - - test al,64 - jnz L_invalid_distance_code - - mov eax,1 - shl eax,cl - dec eax - and eax,ebp - add eax,edx - mov edx, [esp+12] - mov eax, [edx+eax*4] - jmp L_dodist - -ALIGN 4 -L_clip_window: -; 721 "inffast.S" - mov ecx,eax - mov eax, [esp+52] - neg ecx - mov esi, [esp+56] - - cmp eax,edx - jb L_invalid_distance_too_far - - add ecx,edx - cmp dword ptr [esp+48],0 - jne L_wrap_around_window - - sub eax,ecx - add esi,eax -; 749 "inffast.S" - mov eax, [esp+24] - cmp eax,ecx - jbe L_do_copy1 - - sub eax,ecx - rep movsb - mov esi,edi - sub esi,edx - jmp L_do_copy1 - - cmp eax,ecx - jbe L_do_copy1 - - sub eax,ecx - rep movsb - mov esi,edi - sub esi,edx - jmp L_do_copy1 - -L_wrap_around_window: -; 793 "inffast.S" - mov eax, [esp+48] - cmp ecx,eax - jbe L_contiguous_in_window - - add esi, [esp+52] - add esi,eax - sub esi,ecx - sub ecx,eax - - - mov eax, [esp+24] - cmp eax,ecx - jbe L_do_copy1 - - sub eax,ecx - rep movsb - mov esi, [esp+56] - mov ecx, [esp+48] - cmp eax,ecx - jbe L_do_copy1 - - sub eax,ecx - rep movsb - mov esi,edi - sub esi,edx - jmp L_do_copy1 - -L_contiguous_in_window: -; 836 "inffast.S" - add esi,eax - sub esi,ecx - - - mov eax, [esp+24] - cmp eax,ecx - jbe L_do_copy1 - - sub eax,ecx - rep movsb - mov esi,edi - sub esi,edx - -L_do_copy1: -; 862 "inffast.S" - mov ecx,eax - rep movsb - - mov esi, [esp+44] - jmp L_while_test -; 878 "inffast.S" -ALIGN 4 -L_init_mmx: - emms - - - - - - movd mm0,ebp - mov ebp,ebx -; 896 "inffast.S" - movd mm4,dword ptr [esp+0] - movq mm3,mm4 - movd mm5,dword ptr [esp+4] - movq mm2,mm5 - pxor mm1,mm1 - mov ebx, [esp+8] - jmp L_do_loop_mmx - -ALIGN 4 -L_do_loop_mmx: - psrlq mm0,mm1 - - cmp ebp,32 - ja L_get_length_code_mmx - - movd mm6,ebp - movd mm7,dword ptr [esi] - add esi,4 - psllq mm7,mm6 - add ebp,32 - por mm0,mm7 - -L_get_length_code_mmx: - pand mm4,mm0 - movd eax,mm4 - movq mm4,mm3 - mov eax, [ebx+eax*4] - -L_dolen_mmx: - movzx ecx,ah - movd mm1,ecx - sub ebp,ecx - - test al,al - jnz L_test_for_length_base_mmx - - shr eax,16 - stosb - -L_while_test_mmx: - - - cmp [esp+16],edi - jbe L_break_loop - - cmp [esp+20],esi - ja L_do_loop_mmx - jmp L_break_loop - -L_test_for_length_base_mmx: - - mov edx,eax - shr edx,16 - - test al,16 - jz L_test_for_second_level_length_mmx - and eax,15 - jz L_decode_distance_mmx - - psrlq mm0,mm1 - movd mm1,eax - movd ecx,mm0 - sub ebp,eax - and ecx, [inflate_fast_mask+eax*4] - add edx,ecx - -L_decode_distance_mmx: - psrlq mm0,mm1 - - cmp ebp,32 - ja L_get_dist_code_mmx - - movd mm6,ebp - movd mm7,dword ptr [esi] - add esi,4 - psllq mm7,mm6 - add ebp,32 - por mm0,mm7 - -L_get_dist_code_mmx: - mov ebx, [esp+12] - pand mm5,mm0 - movd eax,mm5 - movq mm5,mm2 - mov eax, [ebx+eax*4] - -L_dodist_mmx: - - movzx ecx,ah - mov ebx,eax - shr ebx,16 - sub ebp,ecx - movd mm1,ecx - - test al,16 - jz L_test_for_second_level_dist_mmx - and eax,15 - jz L_check_dist_one_mmx - -L_add_bits_to_dist_mmx: - psrlq mm0,mm1 - movd mm1,eax - movd ecx,mm0 - sub ebp,eax - and ecx, [inflate_fast_mask+eax*4] - add ebx,ecx - -L_check_window_mmx: - mov [esp+44],esi - mov eax,edi - sub eax, [esp+40] - - cmp eax,ebx - jb L_clip_window_mmx - - mov ecx,edx - mov esi,edi - sub esi,ebx - - sub ecx,3 - mov al, [esi] - mov [edi],al - mov al, [esi+1] - mov dl, [esi+2] - add esi,3 - mov [edi+1],al - mov [edi+2],dl - add edi,3 - rep movsb - - mov esi, [esp+44] - mov ebx, [esp+8] - jmp L_while_test_mmx - -ALIGN 4 -L_check_dist_one_mmx: - cmp ebx,1 - jne L_check_window_mmx - cmp [esp+40],edi - je L_check_window_mmx - - dec edi - mov ecx,edx - mov al, [edi] - sub ecx,3 - - mov [edi+1],al - mov [edi+2],al - mov [edi+3],al - add edi,4 - rep stosb - - mov ebx, [esp+8] - jmp L_while_test_mmx - -ALIGN 4 -L_test_for_second_level_length_mmx: - test al,64 - jnz L_test_for_end_of_block - - and eax,15 - psrlq mm0,mm1 - movd ecx,mm0 - and ecx, [inflate_fast_mask+eax*4] - add ecx,edx - mov eax, [ebx+ecx*4] - jmp L_dolen_mmx - -ALIGN 4 -L_test_for_second_level_dist_mmx: - test al,64 - jnz L_invalid_distance_code - - and eax,15 - psrlq mm0,mm1 - movd ecx,mm0 - and ecx, [inflate_fast_mask+eax*4] - mov eax, [esp+12] - add ecx,ebx - mov eax, [eax+ecx*4] - jmp L_dodist_mmx - -ALIGN 4 -L_clip_window_mmx: - - mov ecx,eax - mov eax, [esp+52] - neg ecx - mov esi, [esp+56] - - cmp eax,ebx - jb L_invalid_distance_too_far - - add ecx,ebx - cmp dword ptr [esp+48],0 - jne L_wrap_around_window_mmx - - sub eax,ecx - add esi,eax - - cmp edx,ecx - jbe L_do_copy1_mmx - - sub edx,ecx - rep movsb - mov esi,edi - sub esi,ebx - jmp L_do_copy1_mmx - - cmp edx,ecx - jbe L_do_copy1_mmx - - sub edx,ecx - rep movsb - mov esi,edi - sub esi,ebx - jmp L_do_copy1_mmx - -L_wrap_around_window_mmx: - - mov eax, [esp+48] - cmp ecx,eax - jbe L_contiguous_in_window_mmx - - add esi, [esp+52] - add esi,eax - sub esi,ecx - sub ecx,eax - - - cmp edx,ecx - jbe L_do_copy1_mmx - - sub edx,ecx - rep movsb - mov esi, [esp+56] - mov ecx, [esp+48] - cmp edx,ecx - jbe L_do_copy1_mmx - - sub edx,ecx - rep movsb - mov esi,edi - sub esi,ebx - jmp L_do_copy1_mmx - -L_contiguous_in_window_mmx: - - add esi,eax - sub esi,ecx - - - cmp edx,ecx - jbe L_do_copy1_mmx - - sub edx,ecx - rep movsb - mov esi,edi - sub esi,ebx - -L_do_copy1_mmx: - - - mov ecx,edx - rep movsb - - mov esi, [esp+44] - mov ebx, [esp+8] - jmp L_while_test_mmx -; 1174 "inffast.S" -L_invalid_distance_code: - - - - - - mov ecx, invalid_distance_code_msg - mov edx,INFLATE_MODE_BAD - jmp L_update_stream_state - -L_test_for_end_of_block: - - - - - - test al,32 - jz L_invalid_literal_length_code - - mov ecx,0 - mov edx,INFLATE_MODE_TYPE - jmp L_update_stream_state - -L_invalid_literal_length_code: - - - - - - mov ecx, invalid_literal_length_code_msg - mov edx,INFLATE_MODE_BAD - jmp L_update_stream_state - -L_invalid_distance_too_far: - - - - mov esi, [esp+44] - mov ecx, invalid_distance_too_far_msg - mov edx,INFLATE_MODE_BAD - jmp L_update_stream_state - -L_update_stream_state: - - mov eax, [esp+88] - test ecx,ecx - jz L_skip_msg - mov [eax+24],ecx -L_skip_msg: - mov eax, [eax+28] - mov [eax+mode_state],edx - jmp L_break_loop - -ALIGN 4 -L_break_loop: -; 1243 "inffast.S" - cmp dword ptr [inflate_fast_use_mmx],2 - jne L_update_next_in - - - - mov ebx,ebp - -L_update_next_in: -; 1266 "inffast.S" - mov eax, [esp+88] - mov ecx,ebx - mov edx, [eax+28] - shr ecx,3 - sub esi,ecx - shl ecx,3 - sub ebx,ecx - mov [eax+12],edi - mov [edx+bits_state],ebx - mov ecx,ebx - - lea ebx, [esp+28] - cmp [esp+20],ebx - jne L_buf_not_used - - sub esi,ebx - mov ebx, [eax+0] - mov [esp+20],ebx - add esi,ebx - mov ebx, [eax+4] - sub ebx,11 - add [esp+20],ebx - -L_buf_not_used: - mov [eax+0],esi - - mov ebx,1 - shl ebx,cl - dec ebx - - - - - - cmp dword ptr [inflate_fast_use_mmx],2 - jne L_update_hold - - - - psrlq mm0,mm1 - movd ebp,mm0 - - emms - -L_update_hold: - - - - and ebp,ebx - mov [edx+hold_state],ebp - - - - - mov ebx, [esp+20] - cmp ebx,esi - jbe L_last_is_smaller - - sub ebx,esi - add ebx,11 - mov [eax+4],ebx - jmp L_fixup_out -L_last_is_smaller: - sub esi,ebx - neg esi - add esi,11 - mov [eax+4],esi - - - - -L_fixup_out: - - mov ebx, [esp+16] - cmp ebx,edi - jbe L_end_is_smaller - - sub ebx,edi - add ebx,257 - mov [eax+16],ebx - jmp L_done -L_end_is_smaller: - sub edi,ebx - neg edi - add edi,257 - mov [eax+16],edi - - - - - -L_done: - add esp,64 - popfd - pop ebx - pop ebp - pop esi - pop edi - ret -_inflate_fast endp - -_TEXT ends -end DELETED compat/zlib/contrib/masmx86/match686.asm Index: compat/zlib/contrib/masmx86/match686.asm ================================================================== --- compat/zlib/contrib/masmx86/match686.asm +++ /dev/null @@ -1,479 +0,0 @@ -; match686.asm -- Asm portion of the optimized longest_match for 32 bits x86 -; Copyright (C) 1995-1996 Jean-loup Gailly, Brian Raiter and Gilles Vollant. -; File written by Gilles Vollant, by converting match686.S from Brian Raiter -; for MASM. This is as assembly version of longest_match -; from Jean-loup Gailly in deflate.c -; -; http://www.zlib.net -; http://www.winimage.com/zLibDll -; http://www.muppetlabs.com/~breadbox/software/assembly.html -; -; For Visual C++ 4.x and higher and ML 6.x and higher -; ml.exe is distributed in -; http://www.microsoft.com/downloads/details.aspx?FamilyID=7a1c9da0-0510-44a2-b042-7ef370530c64 -; -; this file contain two implementation of longest_match -; -; this longest_match was written by Brian raiter (1998), optimized for Pentium Pro -; (and the faster known version of match_init on modern Core 2 Duo and AMD Phenom) -; -; for using an assembly version of longest_match, you need define ASMV in project -; -; compile the asm file running -; ml /coff /Zi /c /Flmatch686.lst match686.asm -; and do not include match686.obj in your project -; -; note: contrib of zLib 1.2.3 and earlier contained both a deprecated version for -; Pentium (prior Pentium Pro) and this version for Pentium Pro and modern processor -; with autoselect (with cpu detection code) -; if you want support the old pentium optimization, you can still use these version -; -; this file is not optimized for old pentium, but it compatible with all x86 32 bits -; processor (starting 80386) -; -; -; see below : zlib1222add must be adjuster if you use a zlib version < 1.2.2.2 - -;uInt longest_match(s, cur_match) -; deflate_state *s; -; IPos cur_match; /* current match */ - - NbStack equ 76 - cur_match equ dword ptr[esp+NbStack-0] - str_s equ dword ptr[esp+NbStack-4] -; 5 dword on top (ret,ebp,esi,edi,ebx) - adrret equ dword ptr[esp+NbStack-8] - pushebp equ dword ptr[esp+NbStack-12] - pushedi equ dword ptr[esp+NbStack-16] - pushesi equ dword ptr[esp+NbStack-20] - pushebx equ dword ptr[esp+NbStack-24] - - chain_length equ dword ptr [esp+NbStack-28] - limit equ dword ptr [esp+NbStack-32] - best_len equ dword ptr [esp+NbStack-36] - window equ dword ptr [esp+NbStack-40] - prev equ dword ptr [esp+NbStack-44] - scan_start equ word ptr [esp+NbStack-48] - wmask equ dword ptr [esp+NbStack-52] - match_start_ptr equ dword ptr [esp+NbStack-56] - nice_match equ dword ptr [esp+NbStack-60] - scan equ dword ptr [esp+NbStack-64] - - windowlen equ dword ptr [esp+NbStack-68] - match_start equ dword ptr [esp+NbStack-72] - strend equ dword ptr [esp+NbStack-76] - NbStackAdd equ (NbStack-24) - - .386p - - name gvmatch - .MODEL FLAT - - - -; all the +zlib1222add offsets are due to the addition of fields -; in zlib in the deflate_state structure since the asm code was first written -; (if you compile with zlib 1.0.4 or older, use "zlib1222add equ (-4)"). -; (if you compile with zlib between 1.0.5 and 1.2.2.1, use "zlib1222add equ 0"). -; if you compile with zlib 1.2.2.2 or later , use "zlib1222add equ 8"). - - zlib1222add equ 8 - -; Note : these value are good with a 8 bytes boundary pack structure - dep_chain_length equ 74h+zlib1222add - dep_window equ 30h+zlib1222add - dep_strstart equ 64h+zlib1222add - dep_prev_length equ 70h+zlib1222add - dep_nice_match equ 88h+zlib1222add - dep_w_size equ 24h+zlib1222add - dep_prev equ 38h+zlib1222add - dep_w_mask equ 2ch+zlib1222add - dep_good_match equ 84h+zlib1222add - dep_match_start equ 68h+zlib1222add - dep_lookahead equ 6ch+zlib1222add - - -_TEXT segment - -IFDEF NOUNDERLINE - public longest_match - public match_init -ELSE - public _longest_match - public _match_init -ENDIF - - MAX_MATCH equ 258 - MIN_MATCH equ 3 - MIN_LOOKAHEAD equ (MAX_MATCH+MIN_MATCH+1) - - - -MAX_MATCH equ 258 -MIN_MATCH equ 3 -MIN_LOOKAHEAD equ (MAX_MATCH + MIN_MATCH + 1) -MAX_MATCH_8_ equ ((MAX_MATCH + 7) AND 0FFF0h) - - -;;; stack frame offsets - -chainlenwmask equ esp + 0 ; high word: current chain len - ; low word: s->wmask -window equ esp + 4 ; local copy of s->window -windowbestlen equ esp + 8 ; s->window + bestlen -scanstart equ esp + 16 ; first two bytes of string -scanend equ esp + 12 ; last two bytes of string -scanalign equ esp + 20 ; dword-misalignment of string -nicematch equ esp + 24 ; a good enough match size -bestlen equ esp + 28 ; size of best match so far -scan equ esp + 32 ; ptr to string wanting match - -LocalVarsSize equ 36 -; saved ebx byte esp + 36 -; saved edi byte esp + 40 -; saved esi byte esp + 44 -; saved ebp byte esp + 48 -; return address byte esp + 52 -deflatestate equ esp + 56 ; the function arguments -curmatch equ esp + 60 - -;;; Offsets for fields in the deflate_state structure. These numbers -;;; are calculated from the definition of deflate_state, with the -;;; assumption that the compiler will dword-align the fields. (Thus, -;;; changing the definition of deflate_state could easily cause this -;;; program to crash horribly, without so much as a warning at -;;; compile time. Sigh.) - -dsWSize equ 36+zlib1222add -dsWMask equ 44+zlib1222add -dsWindow equ 48+zlib1222add -dsPrev equ 56+zlib1222add -dsMatchLen equ 88+zlib1222add -dsPrevMatch equ 92+zlib1222add -dsStrStart equ 100+zlib1222add -dsMatchStart equ 104+zlib1222add -dsLookahead equ 108+zlib1222add -dsPrevLen equ 112+zlib1222add -dsMaxChainLen equ 116+zlib1222add -dsGoodMatch equ 132+zlib1222add -dsNiceMatch equ 136+zlib1222add - - -;;; match686.asm -- Pentium-Pro-optimized version of longest_match() -;;; Written for zlib 1.1.2 -;;; Copyright (C) 1998 Brian Raiter -;;; You can look at http://www.muppetlabs.com/~breadbox/software/assembly.html -;;; -;; -;; This software is provided 'as-is', without any express or implied -;; warranty. In no event will the authors be held liable for any damages -;; arising from the use of this software. -;; -;; Permission is granted to anyone to use this software for any purpose, -;; including commercial applications, and to alter it and redistribute it -;; freely, subject to the following restrictions: -;; -;; 1. The origin of this software must not be misrepresented; you must not -;; claim that you wrote the original software. If you use this software -;; in a product, an acknowledgment in the product documentation would be -;; appreciated but is not required. -;; 2. Altered source versions must be plainly marked as such, and must not be -;; misrepresented as being the original software -;; 3. This notice may not be removed or altered from any source distribution. -;; - -;GLOBAL _longest_match, _match_init - - -;SECTION .text - -;;; uInt longest_match(deflate_state *deflatestate, IPos curmatch) - -;_longest_match: - IFDEF NOUNDERLINE - longest_match proc near - ELSE - _longest_match proc near - ENDIF -.FPO (9, 4, 0, 0, 1, 0) - -;;; Save registers that the compiler may be using, and adjust esp to -;;; make room for our stack frame. - - push ebp - push edi - push esi - push ebx - sub esp, LocalVarsSize - -;;; Retrieve the function arguments. ecx will hold cur_match -;;; throughout the entire function. edx will hold the pointer to the -;;; deflate_state structure during the function's setup (before -;;; entering the main loop. - - mov edx, [deflatestate] - mov ecx, [curmatch] - -;;; uInt wmask = s->w_mask; -;;; unsigned chain_length = s->max_chain_length; -;;; if (s->prev_length >= s->good_match) { -;;; chain_length >>= 2; -;;; } - - mov eax, [edx + dsPrevLen] - mov ebx, [edx + dsGoodMatch] - cmp eax, ebx - mov eax, [edx + dsWMask] - mov ebx, [edx + dsMaxChainLen] - jl LastMatchGood - shr ebx, 2 -LastMatchGood: - -;;; chainlen is decremented once beforehand so that the function can -;;; use the sign flag instead of the zero flag for the exit test. -;;; It is then shifted into the high word, to make room for the wmask -;;; value, which it will always accompany. - - dec ebx - shl ebx, 16 - or ebx, eax - mov [chainlenwmask], ebx - -;;; if ((uInt)nice_match > s->lookahead) nice_match = s->lookahead; - - mov eax, [edx + dsNiceMatch] - mov ebx, [edx + dsLookahead] - cmp ebx, eax - jl LookaheadLess - mov ebx, eax -LookaheadLess: mov [nicematch], ebx - -;;; register Bytef *scan = s->window + s->strstart; - - mov esi, [edx + dsWindow] - mov [window], esi - mov ebp, [edx + dsStrStart] - lea edi, [esi + ebp] - mov [scan], edi - -;;; Determine how many bytes the scan ptr is off from being -;;; dword-aligned. - - mov eax, edi - neg eax - and eax, 3 - mov [scanalign], eax - -;;; IPos limit = s->strstart > (IPos)MAX_DIST(s) ? -;;; s->strstart - (IPos)MAX_DIST(s) : NIL; - - mov eax, [edx + dsWSize] - sub eax, MIN_LOOKAHEAD - sub ebp, eax - jg LimitPositive - xor ebp, ebp -LimitPositive: - -;;; int best_len = s->prev_length; - - mov eax, [edx + dsPrevLen] - mov [bestlen], eax - -;;; Store the sum of s->window + best_len in esi locally, and in esi. - - add esi, eax - mov [windowbestlen], esi - -;;; register ush scan_start = *(ushf*)scan; -;;; register ush scan_end = *(ushf*)(scan+best_len-1); -;;; Posf *prev = s->prev; - - movzx ebx, word ptr [edi] - mov [scanstart], ebx - movzx ebx, word ptr [edi + eax - 1] - mov [scanend], ebx - mov edi, [edx + dsPrev] - -;;; Jump into the main loop. - - mov edx, [chainlenwmask] - jmp short LoopEntry - -align 4 - -;;; do { -;;; match = s->window + cur_match; -;;; if (*(ushf*)(match+best_len-1) != scan_end || -;;; *(ushf*)match != scan_start) continue; -;;; [...] -;;; } while ((cur_match = prev[cur_match & wmask]) > limit -;;; && --chain_length != 0); -;;; -;;; Here is the inner loop of the function. The function will spend the -;;; majority of its time in this loop, and majority of that time will -;;; be spent in the first ten instructions. -;;; -;;; Within this loop: -;;; ebx = scanend -;;; ecx = curmatch -;;; edx = chainlenwmask - i.e., ((chainlen << 16) | wmask) -;;; esi = windowbestlen - i.e., (window + bestlen) -;;; edi = prev -;;; ebp = limit - -LookupLoop: - and ecx, edx - movzx ecx, word ptr [edi + ecx*2] - cmp ecx, ebp - jbe LeaveNow - sub edx, 00010000h - js LeaveNow -LoopEntry: movzx eax, word ptr [esi + ecx - 1] - cmp eax, ebx - jnz LookupLoop - mov eax, [window] - movzx eax, word ptr [eax + ecx] - cmp eax, [scanstart] - jnz LookupLoop - -;;; Store the current value of chainlen. - - mov [chainlenwmask], edx - -;;; Point edi to the string under scrutiny, and esi to the string we -;;; are hoping to match it up with. In actuality, esi and edi are -;;; both pointed (MAX_MATCH_8 - scanalign) bytes ahead, and edx is -;;; initialized to -(MAX_MATCH_8 - scanalign). - - mov esi, [window] - mov edi, [scan] - add esi, ecx - mov eax, [scanalign] - mov edx, 0fffffef8h; -(MAX_MATCH_8) - lea edi, [edi + eax + 0108h] ;MAX_MATCH_8] - lea esi, [esi + eax + 0108h] ;MAX_MATCH_8] - -;;; Test the strings for equality, 8 bytes at a time. At the end, -;;; adjust edx so that it is offset to the exact byte that mismatched. -;;; -;;; We already know at this point that the first three bytes of the -;;; strings match each other, and they can be safely passed over before -;;; starting the compare loop. So what this code does is skip over 0-3 -;;; bytes, as much as necessary in order to dword-align the edi -;;; pointer. (esi will still be misaligned three times out of four.) -;;; -;;; It should be confessed that this loop usually does not represent -;;; much of the total running time. Replacing it with a more -;;; straightforward "rep cmpsb" would not drastically degrade -;;; performance. - -LoopCmps: - mov eax, [esi + edx] - xor eax, [edi + edx] - jnz LeaveLoopCmps - mov eax, [esi + edx + 4] - xor eax, [edi + edx + 4] - jnz LeaveLoopCmps4 - add edx, 8 - jnz LoopCmps - jmp short LenMaximum -LeaveLoopCmps4: add edx, 4 -LeaveLoopCmps: test eax, 0000FFFFh - jnz LenLower - add edx, 2 - shr eax, 16 -LenLower: sub al, 1 - adc edx, 0 - -;;; Calculate the length of the match. If it is longer than MAX_MATCH, -;;; then automatically accept it as the best possible match and leave. - - lea eax, [edi + edx] - mov edi, [scan] - sub eax, edi - cmp eax, MAX_MATCH - jge LenMaximum - -;;; If the length of the match is not longer than the best match we -;;; have so far, then forget it and return to the lookup loop. - - mov edx, [deflatestate] - mov ebx, [bestlen] - cmp eax, ebx - jg LongerMatch - mov esi, [windowbestlen] - mov edi, [edx + dsPrev] - mov ebx, [scanend] - mov edx, [chainlenwmask] - jmp LookupLoop - -;;; s->match_start = cur_match; -;;; best_len = len; -;;; if (len >= nice_match) break; -;;; scan_end = *(ushf*)(scan+best_len-1); - -LongerMatch: mov ebx, [nicematch] - mov [bestlen], eax - mov [edx + dsMatchStart], ecx - cmp eax, ebx - jge LeaveNow - mov esi, [window] - add esi, eax - mov [windowbestlen], esi - movzx ebx, word ptr [edi + eax - 1] - mov edi, [edx + dsPrev] - mov [scanend], ebx - mov edx, [chainlenwmask] - jmp LookupLoop - -;;; Accept the current string, with the maximum possible length. - -LenMaximum: mov edx, [deflatestate] - mov dword ptr [bestlen], MAX_MATCH - mov [edx + dsMatchStart], ecx - -;;; if ((uInt)best_len <= s->lookahead) return (uInt)best_len; -;;; return s->lookahead; - -LeaveNow: - mov edx, [deflatestate] - mov ebx, [bestlen] - mov eax, [edx + dsLookahead] - cmp ebx, eax - jg LookaheadRet - mov eax, ebx -LookaheadRet: - -;;; Restore the stack and return from whence we came. - - add esp, LocalVarsSize - pop ebx - pop esi - pop edi - pop ebp - - ret -; please don't remove this string ! -; Your can freely use match686 in any free or commercial app if you don't remove the string in the binary! - db 0dh,0ah,"asm686 with masm, optimised assembly code from Brian Raiter, written 1998",0dh,0ah - - - IFDEF NOUNDERLINE - longest_match endp - ELSE - _longest_match endp - ENDIF - - IFDEF NOUNDERLINE - match_init proc near - ret - match_init endp - ELSE - _match_init proc near - ret - _match_init endp - ENDIF - - -_TEXT ends -end DELETED compat/zlib/contrib/masmx86/readme.txt Index: compat/zlib/contrib/masmx86/readme.txt ================================================================== --- compat/zlib/contrib/masmx86/readme.txt +++ /dev/null @@ -1,27 +0,0 @@ - -Summary -------- -This directory contains ASM implementations of the functions -longest_match() and inflate_fast(). - - -Use instructions ----------------- -Assemble using MASM, and copy the object files into the zlib source -directory, then run the appropriate makefile, as suggested below. You can -donwload MASM from here: - - http://www.microsoft.com/downloads/details.aspx?displaylang=en&FamilyID=7a1c9da0-0510-44a2-b042-7ef370530c64 - -You can also get objects files here: - - http://www.winimage.com/zLibDll/zlib124_masm_obj.zip - -Build instructions ------------------- -* With Microsoft C and MASM: -nmake -f win32/Makefile.msc LOC="-DASMV -DASMINF" OBJA="match686.obj inffas32.obj" - -* With Borland C and TASM: -make -f win32/Makefile.bor LOCAL_ZLIB="-DASMV -DASMINF" OBJA="match686.obj inffas32.obj" OBJPA="+match686c.obj+match686.obj+inffas32.obj" - DELETED compat/zlib/contrib/minizip/Makefile Index: compat/zlib/contrib/minizip/Makefile ================================================================== --- compat/zlib/contrib/minizip/Makefile +++ /dev/null @@ -1,25 +0,0 @@ -CC=cc -CFLAGS=-O -I../.. - -UNZ_OBJS = miniunz.o unzip.o ioapi.o ../../libz.a -ZIP_OBJS = minizip.o zip.o ioapi.o ../../libz.a - -.c.o: - $(CC) -c $(CFLAGS) $*.c - -all: miniunz minizip - -miniunz: $(UNZ_OBJS) - $(CC) $(CFLAGS) -o $@ $(UNZ_OBJS) - -minizip: $(ZIP_OBJS) - $(CC) $(CFLAGS) -o $@ $(ZIP_OBJS) - -test: miniunz minizip - ./minizip test readme.txt - ./miniunz -l test.zip - mv readme.txt readme.old - ./miniunz test.zip - -clean: - /bin/rm -f *.o *~ minizip miniunz DELETED compat/zlib/contrib/minizip/Makefile.am Index: compat/zlib/contrib/minizip/Makefile.am ================================================================== --- compat/zlib/contrib/minizip/Makefile.am +++ /dev/null @@ -1,45 +0,0 @@ -lib_LTLIBRARIES = libminizip.la - -if COND_DEMOS -bin_PROGRAMS = miniunzip minizip -endif - -zlib_top_srcdir = $(top_srcdir)/../.. -zlib_top_builddir = $(top_builddir)/../.. - -AM_CPPFLAGS = -I$(zlib_top_srcdir) -AM_LDFLAGS = -L$(zlib_top_builddir) - -if WIN32 -iowin32_src = iowin32.c -iowin32_h = iowin32.h -endif - -libminizip_la_SOURCES = \ - ioapi.c \ - mztools.c \ - unzip.c \ - zip.c \ - ${iowin32_src} - -libminizip_la_LDFLAGS = $(AM_LDFLAGS) -version-info 1:0:0 -lz - -minizip_includedir = $(includedir)/minizip -minizip_include_HEADERS = \ - crypt.h \ - ioapi.h \ - mztools.h \ - unzip.h \ - zip.h \ - ${iowin32_h} - -pkgconfigdir = $(libdir)/pkgconfig -pkgconfig_DATA = minizip.pc - -EXTRA_PROGRAMS = miniunzip minizip - -miniunzip_SOURCES = miniunz.c -miniunzip_LDADD = libminizip.la - -minizip_SOURCES = minizip.c -minizip_LDADD = libminizip.la -lz DELETED compat/zlib/contrib/minizip/MiniZip64_Changes.txt Index: compat/zlib/contrib/minizip/MiniZip64_Changes.txt ================================================================== --- compat/zlib/contrib/minizip/MiniZip64_Changes.txt +++ /dev/null @@ -1,6 +0,0 @@ - -MiniZip 1.1 was derrived from MiniZip at version 1.01f - -Change in 1.0 (Okt 2009) - - **TODO - Add history** - DELETED compat/zlib/contrib/minizip/MiniZip64_info.txt Index: compat/zlib/contrib/minizip/MiniZip64_info.txt ================================================================== --- compat/zlib/contrib/minizip/MiniZip64_info.txt +++ /dev/null @@ -1,74 +0,0 @@ -MiniZip - Copyright (c) 1998-2010 - by Gilles Vollant - version 1.1 64 bits from Mathias Svensson - -Introduction ---------------------- -MiniZip 1.1 is built from MiniZip 1.0 by Gilles Vollant ( http://www.winimage.com/zLibDll/minizip.html ) - -When adding ZIP64 support into minizip it would result into risk of breaking compatibility with minizip 1.0. -All possible work was done for compatibility. - - -Background ---------------------- -When adding ZIP64 support Mathias Svensson found that Even Rouault have added ZIP64 -support for unzip.c into minizip for a open source project called gdal ( http://www.gdal.org/ ) - -That was used as a starting point. And after that ZIP64 support was added to zip.c -some refactoring and code cleanup was also done. - - -Changed from MiniZip 1.0 to MiniZip 1.1 ---------------------------------------- -* Added ZIP64 support for unzip ( by Even Rouault ) -* Added ZIP64 support for zip ( by Mathias Svensson ) -* Reverted some changed that Even Rouault did. -* Bunch of patches received from Gulles Vollant that he received for MiniZip from various users. -* Added unzip patch for BZIP Compression method (patch create by Daniel Borca) -* Added BZIP Compress method for zip -* Did some refactoring and code cleanup - - -Credits - - Gilles Vollant - Original MiniZip author - Even Rouault - ZIP64 unzip Support - Daniel Borca - BZip Compression method support in unzip - Mathias Svensson - ZIP64 zip support - Mathias Svensson - BZip Compression method support in zip - - Resources - - ZipLayout http://result42.com/projects/ZipFileLayout - Command line tool for Windows that shows the layout and information of the headers in a zip archive. - Used when debugging and validating the creation of zip files using MiniZip64 - - - ZIP App Note http://www.pkware.com/documents/casestudies/APPNOTE.TXT - Zip File specification - - -Notes. - * To be able to use BZip compression method in zip64.c or unzip64.c the BZIP2 lib is needed and HAVE_BZIP2 need to be defined. - -License ----------------------------------------------------------- - Condition of use and distribution are the same than zlib : - - This software is provided 'as-is', without any express or implied - warranty. In no event will the authors be held liable for any damages - arising from the use of this software. - - Permission is granted to anyone to use this software for any purpose, - including commercial applications, and to alter it and redistribute it - freely, subject to the following restrictions: - - 1. The origin of this software must not be misrepresented; you must not - claim that you wrote the original software. If you use this software - in a product, an acknowledgment in the product documentation would be - appreciated but is not required. - 2. Altered source versions must be plainly marked as such, and must not be - misrepresented as being the original software. - 3. This notice may not be removed or altered from any source distribution. - ----------------------------------------------------------- - DELETED compat/zlib/contrib/minizip/configure.ac Index: compat/zlib/contrib/minizip/configure.ac ================================================================== --- compat/zlib/contrib/minizip/configure.ac +++ /dev/null @@ -1,32 +0,0 @@ -# -*- Autoconf -*- -# Process this file with autoconf to produce a configure script. - -AC_INIT([minizip], [1.2.11], [bugzilla.redhat.com]) -AC_CONFIG_SRCDIR([minizip.c]) -AM_INIT_AUTOMAKE([foreign]) -LT_INIT - -AC_MSG_CHECKING([whether to build example programs]) -AC_ARG_ENABLE([demos], AC_HELP_STRING([--enable-demos], [build example programs])) -AM_CONDITIONAL([COND_DEMOS], [test "$enable_demos" = yes]) -if test "$enable_demos" = yes -then - AC_MSG_RESULT([yes]) -else - AC_MSG_RESULT([no]) -fi - -case "${host}" in - *-mingw* | mingw*) - WIN32="yes" - ;; - *) - ;; -esac -AM_CONDITIONAL([WIN32], [test "${WIN32}" = "yes"]) - - -AC_SUBST([HAVE_UNISTD_H], [0]) -AC_CHECK_HEADER([unistd.h], [HAVE_UNISTD_H=1], []) -AC_CONFIG_FILES([Makefile minizip.pc]) -AC_OUTPUT DELETED compat/zlib/contrib/minizip/crypt.h Index: compat/zlib/contrib/minizip/crypt.h ================================================================== --- compat/zlib/contrib/minizip/crypt.h +++ /dev/null @@ -1,132 +0,0 @@ -/* crypt.h -- base code for crypt/uncrypt ZIPfile - - - Version 1.01e, February 12th, 2005 - - Copyright (C) 1998-2005 Gilles Vollant - - This code is a modified version of crypting code in Infozip distribution - - The encryption/decryption parts of this source code (as opposed to the - non-echoing password parts) were originally written in Europe. The - whole source package can be freely distributed, including from the USA. - (Prior to January 2000, re-export from the US was a violation of US law.) - - This encryption code is a direct transcription of the algorithm from - Roger Schlafly, described by Phil Katz in the file appnote.txt. This - file (appnote.txt) is distributed with the PKZIP program (even in the - version without encryption capabilities). - - If you don't need crypting in your application, just define symbols - NOCRYPT and NOUNCRYPT. - - This code support the "Traditional PKWARE Encryption". - - 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; -} - - -/*********************************************************************** - * Initialize the encryption keys and the random header according to - * the given password. - */ -static void init_keys(const char* passwd,unsigned long* pkeys,const z_crc_t* pcrc_32_tab) -{ - *(pkeys+0) = 305419896L; - *(pkeys+1) = 591751049L; - *(pkeys+2) = 878082192L; - while (*passwd != '\0') { - update_keys(pkeys,pcrc_32_tab,(int)*passwd); - passwd++; - } -} - -#define zdecode(pkeys,pcrc_32_tab,c) \ - (update_keys(pkeys,pcrc_32_tab,c ^= decrypt_byte(pkeys,pcrc_32_tab))) - -#define zencode(pkeys,pcrc_32_tab,c,t) \ - (t=decrypt_byte(pkeys,pcrc_32_tab), update_keys(pkeys,pcrc_32_tab,c), t^(c)) - -#ifdef INCLUDECRYPTINGCODE_IFCRYPTALLOWED - -#define RAND_HEAD_LEN 12 - /* "last resort" source for second part of crypt seed pattern */ -# ifndef ZCR_SEED2 -# define ZCR_SEED2 3141592654UL /* use PI as default pattern */ -# endif - -static int crypthead(const char* passwd, /* password string */ - unsigned char* buf, /* where to write header */ - int bufSize, - unsigned long* pkeys, - const z_crc_t* pcrc_32_tab, - unsigned long crcForCrypting) -{ - int n; /* index in random header */ - int t; /* temporary */ - int c; /* random byte */ - unsigned char header[RAND_HEAD_LEN-2]; /* random header */ - static unsigned calls = 0; /* ensure different random header each time */ - - if (bufSize> 7) & 0xff; - header[n] = (unsigned char)zencode(pkeys, pcrc_32_tab, c, t); - } - /* Encrypt random header (last two bytes is high word of crc) */ - init_keys(passwd, pkeys, pcrc_32_tab); - for (n = 0; n < RAND_HEAD_LEN-2; n++) - { - buf[n] = (unsigned char)zencode(pkeys, pcrc_32_tab, header[n], t); - } - buf[n++] = (unsigned char)zencode(pkeys, pcrc_32_tab, (int)(crcForCrypting >> 16) & 0xff, t); - buf[n++] = (unsigned char)zencode(pkeys, pcrc_32_tab, (int)(crcForCrypting >> 24) & 0xff, t); - return n; -} - -#endif DELETED compat/zlib/contrib/minizip/ioapi.c Index: compat/zlib/contrib/minizip/ioapi.c ================================================================== --- compat/zlib/contrib/minizip/ioapi.c +++ /dev/null @@ -1,251 +0,0 @@ -/* ioapi.h -- IO base function header for compress/uncompress .zip - part of the MiniZip project - ( http://www.winimage.com/zLibDll/minizip.html ) - - Copyright (C) 1998-2010 Gilles Vollant (minizip) ( http://www.winimage.com/zLibDll/minizip.html ) - - Modifications for Zip64 support - Copyright (C) 2009-2010 Mathias Svensson ( http://result42.com ) - - For more info read MiniZip_info.txt - -*/ - -#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) -#define FSEEKO_FUNC(stream, offset, origin) fseeko64(stream, offset, origin) -#endif - - -#include "ioapi.h" - -voidpf call_zopen64 (const zlib_filefunc64_32_def* pfilefunc,const void*filename,int mode) -{ - if (pfilefunc->zfile_func64.zopen64_file != NULL) - return (*(pfilefunc->zfile_func64.zopen64_file)) (pfilefunc->zfile_func64.opaque,filename,mode); - else - { - return (*(pfilefunc->zopen32_file))(pfilefunc->zfile_func64.opaque,(const char*)filename,mode); - } -} - -long call_zseek64 (const zlib_filefunc64_32_def* pfilefunc,voidpf filestream, ZPOS64_T offset, int origin) -{ - if (pfilefunc->zfile_func64.zseek64_file != NULL) - return (*(pfilefunc->zfile_func64.zseek64_file)) (pfilefunc->zfile_func64.opaque,filestream,offset,origin); - else - { - uLong offsetTruncated = (uLong)offset; - if (offsetTruncated != offset) - return -1; - else - return (*(pfilefunc->zseek32_file))(pfilefunc->zfile_func64.opaque,filestream,offsetTruncated,origin); - } -} - -ZPOS64_T call_ztell64 (const zlib_filefunc64_32_def* pfilefunc,voidpf filestream) -{ - if (pfilefunc->zfile_func64.zseek64_file != NULL) - return (*(pfilefunc->zfile_func64.ztell64_file)) (pfilefunc->zfile_func64.opaque,filestream); - else - { - uLong tell_uLong = (*(pfilefunc->ztell32_file))(pfilefunc->zfile_func64.opaque,filestream); - if ((tell_uLong) == MAXU32) - return (ZPOS64_T)-1; - else - return tell_uLong; - } -} - -void fill_zlib_filefunc64_32_def_from_filefunc32(zlib_filefunc64_32_def* p_filefunc64_32,const zlib_filefunc_def* p_filefunc32) -{ - p_filefunc64_32->zfile_func64.zopen64_file = NULL; - p_filefunc64_32->zopen32_file = p_filefunc32->zopen_file; - p_filefunc64_32->zfile_func64.zerror_file = p_filefunc32->zerror_file; - p_filefunc64_32->zfile_func64.zread_file = p_filefunc32->zread_file; - p_filefunc64_32->zfile_func64.zwrite_file = p_filefunc32->zwrite_file; - p_filefunc64_32->zfile_func64.ztell64_file = NULL; - p_filefunc64_32->zfile_func64.zseek64_file = NULL; - p_filefunc64_32->zfile_func64.zclose_file = p_filefunc32->zclose_file; - p_filefunc64_32->zfile_func64.zerror_file = p_filefunc32->zerror_file; - p_filefunc64_32->zfile_func64.opaque = p_filefunc32->opaque; - p_filefunc64_32->zseek32_file = p_filefunc32->zseek_file; - p_filefunc64_32->ztell32_file = p_filefunc32->ztell_file; -} - - - -static voidpf ZCALLBACK fopen_file_func OF((voidpf opaque, const char* filename, int mode)); -static uLong ZCALLBACK fread_file_func OF((voidpf opaque, voidpf stream, void* buf, uLong size)); -static uLong ZCALLBACK fwrite_file_func OF((voidpf opaque, voidpf stream, const void* buf,uLong size)); -static ZPOS64_T ZCALLBACK ftell64_file_func OF((voidpf opaque, voidpf stream)); -static long ZCALLBACK fseek64_file_func OF((voidpf opaque, voidpf stream, ZPOS64_T offset, int origin)); -static int ZCALLBACK fclose_file_func OF((voidpf opaque, voidpf stream)); -static int ZCALLBACK ferror_file_func OF((voidpf opaque, voidpf stream)); - -static voidpf ZCALLBACK fopen_file_func (voidpf opaque, const char* filename, int mode) -{ - FILE* file = NULL; - const char* mode_fopen = NULL; - if ((mode & ZLIB_FILEFUNC_MODE_READWRITEFILTER)==ZLIB_FILEFUNC_MODE_READ) - mode_fopen = "rb"; - else - if (mode & ZLIB_FILEFUNC_MODE_EXISTING) - mode_fopen = "r+b"; - else - if (mode & ZLIB_FILEFUNC_MODE_CREATE) - mode_fopen = "wb"; - - if ((filename!=NULL) && (mode_fopen != NULL)) - file = fopen(filename, mode_fopen); - return file; -} - -static voidpf ZCALLBACK fopen64_file_func (voidpf opaque, const void* filename, int mode) -{ - FILE* file = NULL; - const char* mode_fopen = NULL; - if ((mode & ZLIB_FILEFUNC_MODE_READWRITEFILTER)==ZLIB_FILEFUNC_MODE_READ) - mode_fopen = "rb"; - else - if (mode & ZLIB_FILEFUNC_MODE_EXISTING) - mode_fopen = "r+b"; - else - if (mode & ZLIB_FILEFUNC_MODE_CREATE) - mode_fopen = "wb"; - - if ((filename!=NULL) && (mode_fopen != NULL)) - file = FOPEN_FUNC((const char*)filename, mode_fopen); - return file; -} - - -static uLong ZCALLBACK fread_file_func (voidpf opaque, voidpf stream, void* buf, uLong size) -{ - uLong ret; - ret = (uLong)fread(buf, 1, (size_t)size, (FILE *)stream); - return ret; -} - -static uLong ZCALLBACK fwrite_file_func (voidpf opaque, voidpf stream, const void* buf, uLong size) -{ - uLong ret; - ret = (uLong)fwrite(buf, 1, (size_t)size, (FILE *)stream); - return ret; -} - -static long ZCALLBACK ftell_file_func (voidpf opaque, voidpf stream) -{ - long ret; - ret = ftell((FILE *)stream); - return ret; -} - - -static ZPOS64_T ZCALLBACK ftell64_file_func (voidpf opaque, voidpf stream) -{ - ZPOS64_T ret; - ret = FTELLO_FUNC((FILE *)stream); - return ret; -} - -static long ZCALLBACK fseek_file_func (voidpf opaque, voidpf stream, uLong offset, int origin) -{ - int fseek_origin=0; - long ret; - switch (origin) - { - case ZLIB_FILEFUNC_SEEK_CUR : - fseek_origin = SEEK_CUR; - break; - case ZLIB_FILEFUNC_SEEK_END : - fseek_origin = SEEK_END; - break; - case ZLIB_FILEFUNC_SEEK_SET : - fseek_origin = SEEK_SET; - break; - default: return -1; - } - ret = 0; - if (fseek((FILE *)stream, offset, fseek_origin) != 0) - ret = -1; - return ret; -} - -static long ZCALLBACK fseek64_file_func (voidpf opaque, voidpf stream, ZPOS64_T offset, int origin) -{ - int fseek_origin=0; - long ret; - switch (origin) - { - case ZLIB_FILEFUNC_SEEK_CUR : - fseek_origin = SEEK_CUR; - break; - case ZLIB_FILEFUNC_SEEK_END : - fseek_origin = SEEK_END; - break; - case ZLIB_FILEFUNC_SEEK_SET : - fseek_origin = SEEK_SET; - break; - default: return -1; - } - ret = 0; - - if(FSEEKO_FUNC((FILE *)stream, offset, fseek_origin) != 0) - ret = -1; - - return ret; -} - - -static int ZCALLBACK fclose_file_func (voidpf opaque, voidpf stream) -{ - int ret; - ret = fclose((FILE *)stream); - return ret; -} - -static int ZCALLBACK ferror_file_func (voidpf opaque, voidpf stream) -{ - int ret; - ret = ferror((FILE *)stream); - return ret; -} - -void fill_fopen_filefunc (pzlib_filefunc_def) - zlib_filefunc_def* pzlib_filefunc_def; -{ - pzlib_filefunc_def->zopen_file = fopen_file_func; - pzlib_filefunc_def->zread_file = fread_file_func; - pzlib_filefunc_def->zwrite_file = fwrite_file_func; - pzlib_filefunc_def->ztell_file = ftell_file_func; - pzlib_filefunc_def->zseek_file = fseek_file_func; - pzlib_filefunc_def->zclose_file = fclose_file_func; - pzlib_filefunc_def->zerror_file = ferror_file_func; - pzlib_filefunc_def->opaque = NULL; -} - -void fill_fopen64_filefunc (zlib_filefunc64_def* pzlib_filefunc_def) -{ - pzlib_filefunc_def->zopen64_file = fopen64_file_func; - pzlib_filefunc_def->zread_file = fread_file_func; - pzlib_filefunc_def->zwrite_file = fwrite_file_func; - pzlib_filefunc_def->ztell64_file = ftell64_file_func; - pzlib_filefunc_def->zseek64_file = fseek64_file_func; - pzlib_filefunc_def->zclose_file = fclose_file_func; - pzlib_filefunc_def->zerror_file = ferror_file_func; - pzlib_filefunc_def->opaque = NULL; -} DELETED compat/zlib/contrib/minizip/ioapi.h Index: compat/zlib/contrib/minizip/ioapi.h ================================================================== --- compat/zlib/contrib/minizip/ioapi.h +++ /dev/null @@ -1,208 +0,0 @@ -/* ioapi.h -- IO base function header for compress/uncompress .zip - part of the MiniZip project - ( http://www.winimage.com/zLibDll/minizip.html ) - - Copyright (C) 1998-2010 Gilles Vollant (minizip) ( http://www.winimage.com/zLibDll/minizip.html ) - - Modifications for Zip64 support - Copyright (C) 2009-2010 Mathias Svensson ( http://result42.com ) - - For more info read MiniZip_info.txt - - Changes - - Oct-2009 - Defined ZPOS64_T to fpos_t on windows and u_int64_t on linux. (might need to find a better why for this) - Oct-2009 - Change to fseeko64, ftello64 and fopen64 so large files would work on linux. - More if/def section may be needed to support other platforms - Oct-2009 - Defined fxxxx64 calls to normal fopen/ftell/fseek so they would compile on windows. - (but you should use iowin32.c for windows instead) - -*/ - -#ifndef _ZLIBIOAPI64_H -#define _ZLIBIOAPI64_H - -#if (!defined(_WIN32)) && (!defined(WIN32)) && (!defined(__APPLE__)) - - // Linux needs this to support file operation on files larger then 4+GB - // But might need better if/def to select just the platforms that needs them. - - #ifndef __USE_FILE_OFFSET64 - #define __USE_FILE_OFFSET64 - #endif - #ifndef __USE_LARGEFILE64 - #define __USE_LARGEFILE64 - #endif - #ifndef _LARGEFILE64_SOURCE - #define _LARGEFILE64_SOURCE - #endif - #ifndef _FILE_OFFSET_BIT - #define _FILE_OFFSET_BIT 64 - #endif - -#endif - -#include -#include -#include "zlib.h" - -#if defined(USE_FILE32API) -#define fopen64 fopen -#define ftello64 ftell -#define fseeko64 fseek -#else -#ifdef __FreeBSD__ -#define fopen64 fopen -#define ftello64 ftello -#define fseeko64 fseeko -#endif -#ifdef _MSC_VER - #define fopen64 fopen - #if (_MSC_VER >= 1400) && (!(defined(NO_MSCVER_FILE64_FUNC))) - #define ftello64 _ftelli64 - #define fseeko64 _fseeki64 - #else // old MSC - #define ftello64 ftell - #define fseeko64 fseek - #endif -#endif -#endif - -/* -#ifndef ZPOS64_T - #ifdef _WIN32 - #define ZPOS64_T fpos_t - #else - #include - #define ZPOS64_T uint64_t - #endif -#endif -*/ - -#ifdef HAVE_MINIZIP64_CONF_H -#include "mz64conf.h" -#endif - -/* a type choosen by DEFINE */ -#ifdef HAVE_64BIT_INT_CUSTOM -typedef 64BIT_INT_CUSTOM_TYPE ZPOS64_T; -#else -#ifdef HAS_STDINT_H -#include "stdint.h" -typedef uint64_t ZPOS64_T; -#else - -/* Maximum unsigned 32-bit value used as placeholder for zip64 */ -#define MAXU32 0xffffffff - -#if defined(_MSC_VER) || defined(__BORLANDC__) -typedef unsigned __int64 ZPOS64_T; -#else -typedef unsigned long long int ZPOS64_T; -#endif -#endif -#endif - - - -#ifdef __cplusplus -extern "C" { -#endif - - -#define ZLIB_FILEFUNC_SEEK_CUR (1) -#define ZLIB_FILEFUNC_SEEK_END (2) -#define ZLIB_FILEFUNC_SEEK_SET (0) - -#define ZLIB_FILEFUNC_MODE_READ (1) -#define ZLIB_FILEFUNC_MODE_WRITE (2) -#define ZLIB_FILEFUNC_MODE_READWRITEFILTER (3) - -#define ZLIB_FILEFUNC_MODE_EXISTING (4) -#define ZLIB_FILEFUNC_MODE_CREATE (8) - - -#ifndef ZCALLBACK - #if (defined(WIN32) || defined(_WIN32) || defined (WINDOWS) || defined (_WINDOWS)) && defined(CALLBACK) && defined (USEWINDOWS_CALLBACK) - #define ZCALLBACK CALLBACK - #else - #define ZCALLBACK - #endif -#endif - - - - -typedef voidpf (ZCALLBACK *open_file_func) OF((voidpf opaque, const char* filename, int mode)); -typedef uLong (ZCALLBACK *read_file_func) OF((voidpf opaque, voidpf stream, void* buf, uLong size)); -typedef uLong (ZCALLBACK *write_file_func) OF((voidpf opaque, voidpf stream, const void* buf, uLong size)); -typedef int (ZCALLBACK *close_file_func) OF((voidpf opaque, voidpf stream)); -typedef int (ZCALLBACK *testerror_file_func) OF((voidpf opaque, voidpf stream)); - -typedef long (ZCALLBACK *tell_file_func) OF((voidpf opaque, voidpf stream)); -typedef long (ZCALLBACK *seek_file_func) OF((voidpf opaque, voidpf stream, uLong offset, int origin)); - - -/* here is the "old" 32 bits structure structure */ -typedef struct zlib_filefunc_def_s -{ - open_file_func zopen_file; - read_file_func zread_file; - write_file_func zwrite_file; - tell_file_func ztell_file; - seek_file_func zseek_file; - close_file_func zclose_file; - testerror_file_func zerror_file; - voidpf opaque; -} zlib_filefunc_def; - -typedef ZPOS64_T (ZCALLBACK *tell64_file_func) OF((voidpf opaque, voidpf stream)); -typedef long (ZCALLBACK *seek64_file_func) OF((voidpf opaque, voidpf stream, ZPOS64_T offset, int origin)); -typedef voidpf (ZCALLBACK *open64_file_func) OF((voidpf opaque, const void* filename, int mode)); - -typedef struct zlib_filefunc64_def_s -{ - open64_file_func zopen64_file; - read_file_func zread_file; - write_file_func zwrite_file; - tell64_file_func ztell64_file; - seek64_file_func zseek64_file; - close_file_func zclose_file; - testerror_file_func zerror_file; - voidpf opaque; -} zlib_filefunc64_def; - -void fill_fopen64_filefunc OF((zlib_filefunc64_def* pzlib_filefunc_def)); -void fill_fopen_filefunc OF((zlib_filefunc_def* pzlib_filefunc_def)); - -/* now internal definition, only for zip.c and unzip.h */ -typedef struct zlib_filefunc64_32_def_s -{ - zlib_filefunc64_def zfile_func64; - open_file_func zopen32_file; - tell_file_func ztell32_file; - seek_file_func zseek32_file; -} zlib_filefunc64_32_def; - - -#define ZREAD64(filefunc,filestream,buf,size) ((*((filefunc).zfile_func64.zread_file)) ((filefunc).zfile_func64.opaque,filestream,buf,size)) -#define ZWRITE64(filefunc,filestream,buf,size) ((*((filefunc).zfile_func64.zwrite_file)) ((filefunc).zfile_func64.opaque,filestream,buf,size)) -//#define ZTELL64(filefunc,filestream) ((*((filefunc).ztell64_file)) ((filefunc).opaque,filestream)) -//#define ZSEEK64(filefunc,filestream,pos,mode) ((*((filefunc).zseek64_file)) ((filefunc).opaque,filestream,pos,mode)) -#define ZCLOSE64(filefunc,filestream) ((*((filefunc).zfile_func64.zclose_file)) ((filefunc).zfile_func64.opaque,filestream)) -#define ZERROR64(filefunc,filestream) ((*((filefunc).zfile_func64.zerror_file)) ((filefunc).zfile_func64.opaque,filestream)) - -voidpf call_zopen64 OF((const zlib_filefunc64_32_def* pfilefunc,const void*filename,int mode)); -long call_zseek64 OF((const zlib_filefunc64_32_def* pfilefunc,voidpf filestream, ZPOS64_T offset, int origin)); -ZPOS64_T call_ztell64 OF((const zlib_filefunc64_32_def* pfilefunc,voidpf filestream)); - -void fill_zlib_filefunc64_32_def_from_filefunc32(zlib_filefunc64_32_def* p_filefunc64_32,const zlib_filefunc_def* p_filefunc32); - -#define ZOPEN64(filefunc,filename,mode) (call_zopen64((&(filefunc)),(filename),(mode))) -#define ZTELL64(filefunc,filestream) (call_ztell64((&(filefunc)),(filestream))) -#define ZSEEK64(filefunc,filestream,pos,mode) (call_zseek64((&(filefunc)),(filestream),(pos),(mode))) - -#ifdef __cplusplus -} -#endif - -#endif DELETED compat/zlib/contrib/minizip/iowin32.c Index: compat/zlib/contrib/minizip/iowin32.c ================================================================== --- compat/zlib/contrib/minizip/iowin32.c +++ /dev/null @@ -1,462 +0,0 @@ -/* iowin32.c -- IO base function header for compress/uncompress .zip - Version 1.1, February 14h, 2010 - part of the MiniZip project - ( http://www.winimage.com/zLibDll/minizip.html ) - - Copyright (C) 1998-2010 Gilles Vollant (minizip) ( http://www.winimage.com/zLibDll/minizip.html ) - - Modifications for Zip64 support - Copyright (C) 2009-2010 Mathias Svensson ( http://result42.com ) - - For more info read MiniZip_info.txt - -*/ - -#include - -#include "zlib.h" -#include "ioapi.h" -#include "iowin32.h" - -#ifndef INVALID_HANDLE_VALUE -#define INVALID_HANDLE_VALUE (0xFFFFFFFF) -#endif - -#ifndef INVALID_SET_FILE_POINTER -#define INVALID_SET_FILE_POINTER ((DWORD)-1) -#endif - - -// see Include/shared/winapifamily.h in the Windows Kit -#if defined(WINAPI_FAMILY_PARTITION) && (!(defined(IOWIN32_USING_WINRT_API))) -#if WINAPI_FAMILY_ONE_PARTITION(WINAPI_FAMILY, WINAPI_PARTITION_APP) -#define IOWIN32_USING_WINRT_API 1 -#endif -#endif - -voidpf ZCALLBACK win32_open_file_func OF((voidpf opaque, const char* filename, int mode)); -uLong ZCALLBACK win32_read_file_func OF((voidpf opaque, voidpf stream, void* buf, uLong size)); -uLong ZCALLBACK win32_write_file_func OF((voidpf opaque, voidpf stream, const void* buf, uLong size)); -ZPOS64_T ZCALLBACK win32_tell64_file_func OF((voidpf opaque, voidpf stream)); -long ZCALLBACK win32_seek64_file_func OF((voidpf opaque, voidpf stream, ZPOS64_T offset, int origin)); -int ZCALLBACK win32_close_file_func OF((voidpf opaque, voidpf stream)); -int ZCALLBACK win32_error_file_func OF((voidpf opaque, voidpf stream)); - -typedef struct -{ - HANDLE hf; - int error; -} WIN32FILE_IOWIN; - - -static void win32_translate_open_mode(int mode, - DWORD* lpdwDesiredAccess, - DWORD* lpdwCreationDisposition, - DWORD* lpdwShareMode, - DWORD* lpdwFlagsAndAttributes) -{ - *lpdwDesiredAccess = *lpdwShareMode = *lpdwFlagsAndAttributes = *lpdwCreationDisposition = 0; - - if ((mode & ZLIB_FILEFUNC_MODE_READWRITEFILTER)==ZLIB_FILEFUNC_MODE_READ) - { - *lpdwDesiredAccess = GENERIC_READ; - *lpdwCreationDisposition = OPEN_EXISTING; - *lpdwShareMode = FILE_SHARE_READ; - } - else if (mode & ZLIB_FILEFUNC_MODE_EXISTING) - { - *lpdwDesiredAccess = GENERIC_WRITE | GENERIC_READ; - *lpdwCreationDisposition = OPEN_EXISTING; - } - else if (mode & ZLIB_FILEFUNC_MODE_CREATE) - { - *lpdwDesiredAccess = GENERIC_WRITE | GENERIC_READ; - *lpdwCreationDisposition = CREATE_ALWAYS; - } -} - -static voidpf win32_build_iowin(HANDLE hFile) -{ - voidpf ret=NULL; - - if ((hFile != NULL) && (hFile != INVALID_HANDLE_VALUE)) - { - WIN32FILE_IOWIN w32fiow; - w32fiow.hf = hFile; - w32fiow.error = 0; - ret = malloc(sizeof(WIN32FILE_IOWIN)); - - if (ret==NULL) - CloseHandle(hFile); - else - *((WIN32FILE_IOWIN*)ret) = w32fiow; - } - return ret; -} - -voidpf ZCALLBACK win32_open64_file_func (voidpf opaque,const void* filename,int mode) -{ - const char* mode_fopen = NULL; - DWORD dwDesiredAccess,dwCreationDisposition,dwShareMode,dwFlagsAndAttributes ; - HANDLE hFile = NULL; - - win32_translate_open_mode(mode,&dwDesiredAccess,&dwCreationDisposition,&dwShareMode,&dwFlagsAndAttributes); - -#ifdef IOWIN32_USING_WINRT_API -#ifdef UNICODE - if ((filename!=NULL) && (dwDesiredAccess != 0)) - hFile = CreateFile2((LPCTSTR)filename, dwDesiredAccess, dwShareMode, dwCreationDisposition, NULL); -#else - if ((filename!=NULL) && (dwDesiredAccess != 0)) - { - WCHAR filenameW[FILENAME_MAX + 0x200 + 1]; - MultiByteToWideChar(CP_ACP,0,(const char*)filename,-1,filenameW,FILENAME_MAX + 0x200); - hFile = CreateFile2(filenameW, dwDesiredAccess, dwShareMode, dwCreationDisposition, NULL); - } -#endif -#else - if ((filename!=NULL) && (dwDesiredAccess != 0)) - hFile = CreateFile((LPCTSTR)filename, dwDesiredAccess, dwShareMode, NULL, dwCreationDisposition, dwFlagsAndAttributes, NULL); -#endif - - return win32_build_iowin(hFile); -} - - -voidpf ZCALLBACK win32_open64_file_funcA (voidpf opaque,const void* filename,int mode) -{ - const char* mode_fopen = NULL; - DWORD dwDesiredAccess,dwCreationDisposition,dwShareMode,dwFlagsAndAttributes ; - HANDLE hFile = NULL; - - win32_translate_open_mode(mode,&dwDesiredAccess,&dwCreationDisposition,&dwShareMode,&dwFlagsAndAttributes); - -#ifdef IOWIN32_USING_WINRT_API - if ((filename!=NULL) && (dwDesiredAccess != 0)) - { - WCHAR filenameW[FILENAME_MAX + 0x200 + 1]; - MultiByteToWideChar(CP_ACP,0,(const char*)filename,-1,filenameW,FILENAME_MAX + 0x200); - hFile = CreateFile2(filenameW, dwDesiredAccess, dwShareMode, dwCreationDisposition, NULL); - } -#else - if ((filename!=NULL) && (dwDesiredAccess != 0)) - hFile = CreateFileA((LPCSTR)filename, dwDesiredAccess, dwShareMode, NULL, dwCreationDisposition, dwFlagsAndAttributes, NULL); -#endif - - return win32_build_iowin(hFile); -} - - -voidpf ZCALLBACK win32_open64_file_funcW (voidpf opaque,const void* filename,int mode) -{ - const char* mode_fopen = NULL; - DWORD dwDesiredAccess,dwCreationDisposition,dwShareMode,dwFlagsAndAttributes ; - HANDLE hFile = NULL; - - win32_translate_open_mode(mode,&dwDesiredAccess,&dwCreationDisposition,&dwShareMode,&dwFlagsAndAttributes); - -#ifdef IOWIN32_USING_WINRT_API - if ((filename!=NULL) && (dwDesiredAccess != 0)) - hFile = CreateFile2((LPCWSTR)filename, dwDesiredAccess, dwShareMode, dwCreationDisposition,NULL); -#else - if ((filename!=NULL) && (dwDesiredAccess != 0)) - hFile = CreateFileW((LPCWSTR)filename, dwDesiredAccess, dwShareMode, NULL, dwCreationDisposition, dwFlagsAndAttributes, NULL); -#endif - - return win32_build_iowin(hFile); -} - - -voidpf ZCALLBACK win32_open_file_func (voidpf opaque,const char* filename,int mode) -{ - const char* mode_fopen = NULL; - DWORD dwDesiredAccess,dwCreationDisposition,dwShareMode,dwFlagsAndAttributes ; - HANDLE hFile = NULL; - - win32_translate_open_mode(mode,&dwDesiredAccess,&dwCreationDisposition,&dwShareMode,&dwFlagsAndAttributes); - -#ifdef IOWIN32_USING_WINRT_API -#ifdef UNICODE - if ((filename!=NULL) && (dwDesiredAccess != 0)) - hFile = CreateFile2((LPCTSTR)filename, dwDesiredAccess, dwShareMode, dwCreationDisposition, NULL); -#else - if ((filename!=NULL) && (dwDesiredAccess != 0)) - { - WCHAR filenameW[FILENAME_MAX + 0x200 + 1]; - MultiByteToWideChar(CP_ACP,0,(const char*)filename,-1,filenameW,FILENAME_MAX + 0x200); - hFile = CreateFile2(filenameW, dwDesiredAccess, dwShareMode, dwCreationDisposition, NULL); - } -#endif -#else - if ((filename!=NULL) && (dwDesiredAccess != 0)) - hFile = CreateFile((LPCTSTR)filename, dwDesiredAccess, dwShareMode, NULL, dwCreationDisposition, dwFlagsAndAttributes, NULL); -#endif - - return win32_build_iowin(hFile); -} - - -uLong ZCALLBACK win32_read_file_func (voidpf opaque, voidpf stream, void* buf,uLong size) -{ - uLong ret=0; - HANDLE hFile = NULL; - if (stream!=NULL) - hFile = ((WIN32FILE_IOWIN*)stream) -> hf; - - if (hFile != NULL) - { - if (!ReadFile(hFile, buf, size, &ret, NULL)) - { - DWORD dwErr = GetLastError(); - if (dwErr == ERROR_HANDLE_EOF) - dwErr = 0; - ((WIN32FILE_IOWIN*)stream) -> error=(int)dwErr; - } - } - - return ret; -} - - -uLong ZCALLBACK win32_write_file_func (voidpf opaque,voidpf stream,const void* buf,uLong size) -{ - uLong ret=0; - HANDLE hFile = NULL; - if (stream!=NULL) - hFile = ((WIN32FILE_IOWIN*)stream) -> hf; - - if (hFile != NULL) - { - if (!WriteFile(hFile, buf, size, &ret, NULL)) - { - DWORD dwErr = GetLastError(); - if (dwErr == ERROR_HANDLE_EOF) - dwErr = 0; - ((WIN32FILE_IOWIN*)stream) -> error=(int)dwErr; - } - } - - return ret; -} - -static BOOL MySetFilePointerEx(HANDLE hFile, LARGE_INTEGER pos, LARGE_INTEGER *newPos, DWORD dwMoveMethod) -{ -#ifdef IOWIN32_USING_WINRT_API - return SetFilePointerEx(hFile, pos, newPos, dwMoveMethod); -#else - LONG lHigh = pos.HighPart; - DWORD dwNewPos = SetFilePointer(hFile, pos.LowPart, &lHigh, dwMoveMethod); - BOOL fOk = TRUE; - if (dwNewPos == 0xFFFFFFFF) - if (GetLastError() != NO_ERROR) - fOk = FALSE; - if ((newPos != NULL) && (fOk)) - { - newPos->LowPart = dwNewPos; - newPos->HighPart = lHigh; - } - return fOk; -#endif -} - -long ZCALLBACK win32_tell_file_func (voidpf opaque,voidpf stream) -{ - long ret=-1; - HANDLE hFile = NULL; - if (stream!=NULL) - hFile = ((WIN32FILE_IOWIN*)stream) -> hf; - if (hFile != NULL) - { - LARGE_INTEGER pos; - pos.QuadPart = 0; - - if (!MySetFilePointerEx(hFile, pos, &pos, FILE_CURRENT)) - { - DWORD dwErr = GetLastError(); - ((WIN32FILE_IOWIN*)stream) -> error=(int)dwErr; - ret = -1; - } - else - ret=(long)pos.LowPart; - } - return ret; -} - -ZPOS64_T ZCALLBACK win32_tell64_file_func (voidpf opaque, voidpf stream) -{ - ZPOS64_T ret= (ZPOS64_T)-1; - HANDLE hFile = NULL; - if (stream!=NULL) - hFile = ((WIN32FILE_IOWIN*)stream)->hf; - - if (hFile) - { - LARGE_INTEGER pos; - pos.QuadPart = 0; - - if (!MySetFilePointerEx(hFile, pos, &pos, FILE_CURRENT)) - { - DWORD dwErr = GetLastError(); - ((WIN32FILE_IOWIN*)stream) -> error=(int)dwErr; - ret = (ZPOS64_T)-1; - } - else - ret=pos.QuadPart; - } - return ret; -} - - -long ZCALLBACK win32_seek_file_func (voidpf opaque,voidpf stream,uLong offset,int origin) -{ - DWORD dwMoveMethod=0xFFFFFFFF; - HANDLE hFile = NULL; - - long ret=-1; - if (stream!=NULL) - hFile = ((WIN32FILE_IOWIN*)stream) -> hf; - switch (origin) - { - case ZLIB_FILEFUNC_SEEK_CUR : - dwMoveMethod = FILE_CURRENT; - break; - case ZLIB_FILEFUNC_SEEK_END : - dwMoveMethod = FILE_END; - break; - case ZLIB_FILEFUNC_SEEK_SET : - dwMoveMethod = FILE_BEGIN; - break; - default: return -1; - } - - if (hFile != NULL) - { - LARGE_INTEGER pos; - pos.QuadPart = offset; - if (!MySetFilePointerEx(hFile, pos, NULL, dwMoveMethod)) - { - DWORD dwErr = GetLastError(); - ((WIN32FILE_IOWIN*)stream) -> error=(int)dwErr; - ret = -1; - } - else - ret=0; - } - return ret; -} - -long ZCALLBACK win32_seek64_file_func (voidpf opaque, voidpf stream,ZPOS64_T offset,int origin) -{ - DWORD dwMoveMethod=0xFFFFFFFF; - HANDLE hFile = NULL; - long ret=-1; - - if (stream!=NULL) - hFile = ((WIN32FILE_IOWIN*)stream)->hf; - - switch (origin) - { - case ZLIB_FILEFUNC_SEEK_CUR : - dwMoveMethod = FILE_CURRENT; - break; - case ZLIB_FILEFUNC_SEEK_END : - dwMoveMethod = FILE_END; - break; - case ZLIB_FILEFUNC_SEEK_SET : - dwMoveMethod = FILE_BEGIN; - break; - default: return -1; - } - - if (hFile) - { - LARGE_INTEGER pos; - pos.QuadPart = offset; - if (!MySetFilePointerEx(hFile, pos, NULL, dwMoveMethod)) - { - DWORD dwErr = GetLastError(); - ((WIN32FILE_IOWIN*)stream) -> error=(int)dwErr; - ret = -1; - } - else - ret=0; - } - return ret; -} - -int ZCALLBACK win32_close_file_func (voidpf opaque, voidpf stream) -{ - int ret=-1; - - if (stream!=NULL) - { - HANDLE hFile; - hFile = ((WIN32FILE_IOWIN*)stream) -> hf; - if (hFile != NULL) - { - CloseHandle(hFile); - ret=0; - } - free(stream); - } - return ret; -} - -int ZCALLBACK win32_error_file_func (voidpf opaque,voidpf stream) -{ - int ret=-1; - if (stream!=NULL) - { - ret = ((WIN32FILE_IOWIN*)stream) -> error; - } - return ret; -} - -void fill_win32_filefunc (zlib_filefunc_def* pzlib_filefunc_def) -{ - pzlib_filefunc_def->zopen_file = win32_open_file_func; - pzlib_filefunc_def->zread_file = win32_read_file_func; - pzlib_filefunc_def->zwrite_file = win32_write_file_func; - pzlib_filefunc_def->ztell_file = win32_tell_file_func; - pzlib_filefunc_def->zseek_file = win32_seek_file_func; - pzlib_filefunc_def->zclose_file = win32_close_file_func; - pzlib_filefunc_def->zerror_file = win32_error_file_func; - pzlib_filefunc_def->opaque = NULL; -} - -void fill_win32_filefunc64(zlib_filefunc64_def* pzlib_filefunc_def) -{ - pzlib_filefunc_def->zopen64_file = win32_open64_file_func; - pzlib_filefunc_def->zread_file = win32_read_file_func; - pzlib_filefunc_def->zwrite_file = win32_write_file_func; - pzlib_filefunc_def->ztell64_file = win32_tell64_file_func; - pzlib_filefunc_def->zseek64_file = win32_seek64_file_func; - pzlib_filefunc_def->zclose_file = win32_close_file_func; - pzlib_filefunc_def->zerror_file = win32_error_file_func; - pzlib_filefunc_def->opaque = NULL; -} - - -void fill_win32_filefunc64A(zlib_filefunc64_def* pzlib_filefunc_def) -{ - pzlib_filefunc_def->zopen64_file = win32_open64_file_funcA; - pzlib_filefunc_def->zread_file = win32_read_file_func; - pzlib_filefunc_def->zwrite_file = win32_write_file_func; - pzlib_filefunc_def->ztell64_file = win32_tell64_file_func; - pzlib_filefunc_def->zseek64_file = win32_seek64_file_func; - pzlib_filefunc_def->zclose_file = win32_close_file_func; - pzlib_filefunc_def->zerror_file = win32_error_file_func; - pzlib_filefunc_def->opaque = NULL; -} - - -void fill_win32_filefunc64W(zlib_filefunc64_def* pzlib_filefunc_def) -{ - pzlib_filefunc_def->zopen64_file = win32_open64_file_funcW; - pzlib_filefunc_def->zread_file = win32_read_file_func; - pzlib_filefunc_def->zwrite_file = win32_write_file_func; - pzlib_filefunc_def->ztell64_file = win32_tell64_file_func; - pzlib_filefunc_def->zseek64_file = win32_seek64_file_func; - pzlib_filefunc_def->zclose_file = win32_close_file_func; - pzlib_filefunc_def->zerror_file = win32_error_file_func; - pzlib_filefunc_def->opaque = NULL; -} DELETED compat/zlib/contrib/minizip/iowin32.h Index: compat/zlib/contrib/minizip/iowin32.h ================================================================== --- compat/zlib/contrib/minizip/iowin32.h +++ /dev/null @@ -1,28 +0,0 @@ -/* iowin32.h -- IO base function header for compress/uncompress .zip - Version 1.1, February 14h, 2010 - part of the MiniZip project - ( http://www.winimage.com/zLibDll/minizip.html ) - - Copyright (C) 1998-2010 Gilles Vollant (minizip) ( http://www.winimage.com/zLibDll/minizip.html ) - - Modifications for Zip64 support - Copyright (C) 2009-2010 Mathias Svensson ( http://result42.com ) - - For more info read MiniZip_info.txt - -*/ - -#include - - -#ifdef __cplusplus -extern "C" { -#endif - -void fill_win32_filefunc OF((zlib_filefunc_def* pzlib_filefunc_def)); -void fill_win32_filefunc64 OF((zlib_filefunc64_def* pzlib_filefunc_def)); -void fill_win32_filefunc64A OF((zlib_filefunc64_def* pzlib_filefunc_def)); -void fill_win32_filefunc64W OF((zlib_filefunc64_def* pzlib_filefunc_def)); - -#ifdef __cplusplus -} -#endif DELETED compat/zlib/contrib/minizip/make_vms.com Index: compat/zlib/contrib/minizip/make_vms.com ================================================================== --- compat/zlib/contrib/minizip/make_vms.com +++ /dev/null @@ -1,25 +0,0 @@ -$ if f$search("ioapi.h_orig") .eqs. "" then copy ioapi.h ioapi.h_orig -$ open/write zdef vmsdefs.h -$ copy sys$input: zdef -$ deck -#define unix -#define fill_zlib_filefunc64_32_def_from_filefunc32 fillzffunc64from -#define Write_Zip64EndOfCentralDirectoryLocator Write_Zip64EoDLocator -#define Write_Zip64EndOfCentralDirectoryRecord Write_Zip64EoDRecord -#define Write_EndOfCentralDirectoryRecord Write_EoDRecord -$ eod -$ close zdef -$ copy vmsdefs.h,ioapi.h_orig ioapi.h -$ cc/include=[--]/prefix=all ioapi.c -$ cc/include=[--]/prefix=all miniunz.c -$ cc/include=[--]/prefix=all unzip.c -$ cc/include=[--]/prefix=all minizip.c -$ cc/include=[--]/prefix=all zip.c -$ link miniunz,unzip,ioapi,[--]libz.olb/lib -$ link minizip,zip,ioapi,[--]libz.olb/lib -$ mcr []minizip test minizip_info.txt -$ mcr []miniunz -l test.zip -$ rename minizip_info.txt; minizip_info.txt_old -$ mcr []miniunz test.zip -$ delete test.zip;* -$exit DELETED compat/zlib/contrib/minizip/miniunz.c Index: compat/zlib/contrib/minizip/miniunz.c ================================================================== --- compat/zlib/contrib/minizip/miniunz.c +++ /dev/null @@ -1,660 +0,0 @@ -/* - miniunz.c - Version 1.1, February 14h, 2010 - sample part of the MiniZip project - ( http://www.winimage.com/zLibDll/minizip.html ) - - Copyright (C) 1998-2010 Gilles Vollant (minizip) ( http://www.winimage.com/zLibDll/minizip.html ) - - Modifications of Unzip for Zip64 - Copyright (C) 2007-2008 Even Rouault - - Modifications for Zip64 support on both zip and unzip - Copyright (C) 2009-2010 Mathias Svensson ( http://result42.com ) -*/ - -#if (!defined(_WIN32)) && (!defined(WIN32)) && (!defined(__APPLE__)) - #ifndef __USE_FILE_OFFSET64 - #define __USE_FILE_OFFSET64 - #endif - #ifndef __USE_LARGEFILE64 - #define __USE_LARGEFILE64 - #endif - #ifndef _LARGEFILE64_SOURCE - #define _LARGEFILE64_SOURCE - #endif - #ifndef _FILE_OFFSET_BIT - #define _FILE_OFFSET_BIT 64 - #endif -#endif - -#ifdef __APPLE__ -// 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) -#define FSEEKO_FUNC(stream, offset, origin) fseeko64(stream, offset, origin) -#endif - - -#include -#include -#include -#include -#include -#include - -#ifdef _WIN32 -# include -# include -#else -# include -# include -#endif - - -#include "unzip.h" - -#define CASESENSITIVITY (0) -#define WRITEBUFFERSIZE (8192) -#define MAXFILENAME (256) - -#ifdef _WIN32 -#define USEWIN32IOAPI -#include "iowin32.h" -#endif -/* - mini unzip, demo of unzip package - - usage : - Usage : miniunz [-exvlo] file.zip [file_to_extract] [-d extractdir] - - list the file in the zipfile, and print the content of FILE_ID.ZIP or README.TXT - if it exists -*/ - - -/* change_file_date : change the date/time of a file - filename : the filename of the file where date/time must be modified - dosdate : the new date at the MSDos format (4 bytes) - tmu_date : the SAME new date at the tm_unz format */ -void change_file_date(filename,dosdate,tmu_date) - const char *filename; - uLong dosdate; - tm_unz tmu_date; -{ -#ifdef _WIN32 - HANDLE hFile; - FILETIME ftm,ftLocal,ftCreate,ftLastAcc,ftLastWrite; - - hFile = CreateFileA(filename,GENERIC_READ | GENERIC_WRITE, - 0,NULL,OPEN_EXISTING,0,NULL); - GetFileTime(hFile,&ftCreate,&ftLastAcc,&ftLastWrite); - DosDateTimeToFileTime((WORD)(dosdate>>16),(WORD)dosdate,&ftLocal); - LocalFileTimeToFileTime(&ftLocal,&ftm); - SetFileTime(hFile,&ftm,&ftLastAcc,&ftm); - CloseHandle(hFile); -#else -#if defined(unix) || defined(__APPLE__) - struct utimbuf ut; - struct tm newdate; - newdate.tm_sec = tmu_date.tm_sec; - newdate.tm_min=tmu_date.tm_min; - newdate.tm_hour=tmu_date.tm_hour; - newdate.tm_mday=tmu_date.tm_mday; - newdate.tm_mon=tmu_date.tm_mon; - if (tmu_date.tm_year > 1900) - newdate.tm_year=tmu_date.tm_year - 1900; - else - newdate.tm_year=tmu_date.tm_year ; - newdate.tm_isdst=-1; - - ut.actime=ut.modtime=mktime(&newdate); - utime(filename,&ut); -#endif -#endif -} - - -/* mymkdir and change_file_date are not 100 % portable - As I don't know well Unix, I wait feedback for the unix portion */ - -int mymkdir(dirname) - const char* dirname; -{ - int ret=0; -#ifdef _WIN32 - ret = _mkdir(dirname); -#elif unix - ret = mkdir (dirname,0775); -#elif __APPLE__ - ret = mkdir (dirname,0775); -#endif - return ret; -} - -int makedir (newdir) - char *newdir; -{ - char *buffer ; - char *p; - int len = (int)strlen(newdir); - - if (len <= 0) - return 0; - - buffer = (char*)malloc(len+1); - if (buffer==NULL) - { - printf("Error allocating memory\n"); - return UNZ_INTERNALERROR; - } - strcpy(buffer,newdir); - - if (buffer[len-1] == '/') { - buffer[len-1] = '\0'; - } - if (mymkdir(buffer) == 0) - { - free(buffer); - return 1; - } - - p = buffer+1; - while (1) - { - char hold; - - while(*p && *p != '\\' && *p != '/') - p++; - hold = *p; - *p = 0; - if ((mymkdir(buffer) == -1) && (errno == ENOENT)) - { - printf("couldn't create directory %s\n",buffer); - free(buffer); - return 0; - } - if (hold == 0) - break; - *p++ = hold; - } - free(buffer); - return 1; -} - -void do_banner() -{ - printf("MiniUnz 1.01b, demo of zLib + Unz package written by Gilles Vollant\n"); - printf("more info at http://www.winimage.com/zLibDll/unzip.html\n\n"); -} - -void do_help() -{ - printf("Usage : miniunz [-e] [-x] [-v] [-l] [-o] [-p password] file.zip [file_to_extr.] [-d extractdir]\n\n" \ - " -e Extract without pathname (junk paths)\n" \ - " -x Extract with pathname\n" \ - " -v list files\n" \ - " -l list files\n" \ - " -d directory to extract into\n" \ - " -o overwrite files without prompting\n" \ - " -p extract crypted file using password\n\n"); -} - -void Display64BitsSize(ZPOS64_T n, int size_char) -{ - /* to avoid compatibility problem , we do here the conversion */ - char number[21]; - int offset=19; - int pos_string = 19; - number[20]=0; - for (;;) { - number[offset]=(char)((n%10)+'0'); - if (number[offset] != '0') - pos_string=offset; - n/=10; - if (offset==0) - break; - offset--; - } - { - int size_display_string = 19-pos_string; - while (size_char > size_display_string) - { - size_char--; - printf(" "); - } - } - - printf("%s",&number[pos_string]); -} - -int do_list(uf) - unzFile uf; -{ - uLong i; - unz_global_info64 gi; - int err; - - err = unzGetGlobalInfo64(uf,&gi); - if (err!=UNZ_OK) - printf("error %d with zipfile in unzGetGlobalInfo \n",err); - printf(" Length Method Size Ratio Date Time CRC-32 Name\n"); - printf(" ------ ------ ---- ----- ---- ---- ------ ----\n"); - for (i=0;i0) - ratio = (uLong)((file_info.compressed_size*100)/file_info.uncompressed_size); - - /* display a '*' if the file is crypted */ - if ((file_info.flag & 1) != 0) - charCrypt='*'; - - if (file_info.compression_method==0) - string_method="Stored"; - else - if (file_info.compression_method==Z_DEFLATED) - { - uInt iLevel=(uInt)((file_info.flag & 0x6)/2); - if (iLevel==0) - string_method="Defl:N"; - else if (iLevel==1) - string_method="Defl:X"; - else if ((iLevel==2) || (iLevel==3)) - string_method="Defl:F"; /* 2:fast , 3 : extra fast*/ - } - else - if (file_info.compression_method==Z_BZIP2ED) - { - string_method="BZip2 "; - } - else - string_method="Unkn. "; - - Display64BitsSize(file_info.uncompressed_size,7); - printf(" %6s%c",string_method,charCrypt); - Display64BitsSize(file_info.compressed_size,7); - printf(" %3lu%% %2.2lu-%2.2lu-%2.2lu %2.2lu:%2.2lu %8.8lx %s\n", - ratio, - (uLong)file_info.tmu_date.tm_mon + 1, - (uLong)file_info.tmu_date.tm_mday, - (uLong)file_info.tmu_date.tm_year % 100, - (uLong)file_info.tmu_date.tm_hour,(uLong)file_info.tmu_date.tm_min, - (uLong)file_info.crc,filename_inzip); - if ((i+1)='a') && (rep<='z')) - rep -= 0x20; - } - while ((rep!='Y') && (rep!='N') && (rep!='A')); - } - - if (rep == 'N') - skip = 1; - - if (rep == 'A') - *popt_overwrite=1; - } - - if ((skip==0) && (err==UNZ_OK)) - { - fout=FOPEN_FUNC(write_filename,"wb"); - /* some zipfile don't contain directory alone before file */ - if ((fout==NULL) && ((*popt_extract_without_path)==0) && - (filename_withoutpath!=(char*)filename_inzip)) - { - char c=*(filename_withoutpath-1); - *(filename_withoutpath-1)='\0'; - makedir(write_filename); - *(filename_withoutpath-1)=c; - fout=FOPEN_FUNC(write_filename,"wb"); - } - - if (fout==NULL) - { - printf("error opening %s\n",write_filename); - } - } - - if (fout!=NULL) - { - printf(" extracting: %s\n",write_filename); - - do - { - err = unzReadCurrentFile(uf,buf,size_buf); - if (err<0) - { - printf("error %d with zipfile in unzReadCurrentFile\n",err); - break; - } - if (err>0) - if (fwrite(buf,err,1,fout)!=1) - { - printf("error in writing extracted file\n"); - err=UNZ_ERRNO; - break; - } - } - while (err>0); - if (fout) - fclose(fout); - - if (err==0) - change_file_date(write_filename,file_info.dosDate, - file_info.tmu_date); - } - - if (err==UNZ_OK) - { - err = unzCloseCurrentFile (uf); - if (err!=UNZ_OK) - { - printf("error %d with zipfile in unzCloseCurrentFile\n",err); - } - } - else - unzCloseCurrentFile(uf); /* don't lose the error */ - } - - free(buf); - return err; -} - - -int do_extract(uf,opt_extract_without_path,opt_overwrite,password) - unzFile uf; - int opt_extract_without_path; - int opt_overwrite; - const char* password; -{ - uLong i; - unz_global_info64 gi; - int err; - FILE* fout=NULL; - - err = unzGetGlobalInfo64(uf,&gi); - if (err!=UNZ_OK) - printf("error %d with zipfile in unzGetGlobalInfo \n",err); - - for (i=0;i insert n+1 empty lines -.\" for manpage-specific macros, see man(7) -.SH NAME -miniunzip - uncompress and examine ZIP archives -.SH SYNOPSIS -.B miniunzip -.RI [ -exvlo ] -zipfile [ files_to_extract ] [-d tempdir] -.SH DESCRIPTION -.B minizip -is a simple tool which allows the extraction of compressed file -archives in the ZIP format used by the MS-DOS utility PKZIP. It was -written as a demonstration of the -.IR zlib (3) -library and therefore lack many of the features of the -.IR unzip (1) -program. -.SH OPTIONS -A number of options are supported. With the exception of -.BI \-d\ tempdir -these must be supplied before any -other arguments and are: -.TP -.BI \-l\ ,\ \-\-v -List the files in the archive without extracting them. -.TP -.B \-o -Overwrite files without prompting for confirmation. -.TP -.B \-x -Extract files (default). -.PP -The -.I zipfile -argument is the name of the archive to process. The next argument can be used -to specify a single file to extract from the archive. - -Lastly, the following option can be specified at the end of the command-line: -.TP -.BI \-d\ tempdir -Extract the archive in the directory -.I tempdir -rather than the current directory. -.SH SEE ALSO -.BR minizip (1), -.BR zlib (3), -.BR unzip (1). -.SH AUTHOR -This program was written by Gilles Vollant. This manual page was -written by Mark Brown . The -d tempdir option -was added by Dirk Eddelbuettel . DELETED compat/zlib/contrib/minizip/minizip.1 Index: compat/zlib/contrib/minizip/minizip.1 ================================================================== --- compat/zlib/contrib/minizip/minizip.1 +++ /dev/null @@ -1,46 +0,0 @@ -.\" Hey, EMACS: -*- nroff -*- -.TH minizip 1 "May 2, 2001" -.\" Please adjust this date whenever revising the manpage. -.\" -.\" Some roff macros, for reference: -.\" .nh disable hyphenation -.\" .hy enable hyphenation -.\" .ad l left justify -.\" .ad b justify to both left and right margins -.\" .nf disable filling -.\" .fi enable filling -.\" .br insert line break -.\" .sp insert n+1 empty lines -.\" for manpage-specific macros, see man(7) -.SH NAME -minizip - create ZIP archives -.SH SYNOPSIS -.B minizip -.RI [ -o ] -zipfile [ " files" ... ] -.SH DESCRIPTION -.B minizip -is a simple tool which allows the creation of compressed file archives -in the ZIP format used by the MS-DOS utility PKZIP. It was written as -a demonstration of the -.IR zlib (3) -library and therefore lack many of the features of the -.IR zip (1) -program. -.SH OPTIONS -The first argument supplied is the name of the ZIP archive to create or -.RI -o -in which case it is ignored and the second argument treated as the -name of the ZIP file. If the ZIP file already exists it will be -overwritten. -.PP -Subsequent arguments specify a list of files to place in the ZIP -archive. If none are specified then an empty archive will be created. -.SH SEE ALSO -.BR miniunzip (1), -.BR zlib (3), -.BR zip (1). -.SH AUTHOR -This program was written by Gilles Vollant. This manual page was -written by Mark Brown . - DELETED compat/zlib/contrib/minizip/minizip.c Index: compat/zlib/contrib/minizip/minizip.c ================================================================== --- compat/zlib/contrib/minizip/minizip.c +++ /dev/null @@ -1,562 +0,0 @@ -/* - minizip.c - Version 1.1, February 14h, 2010 - sample part of the MiniZip project - ( http://www.winimage.com/zLibDll/minizip.html ) - - Copyright (C) 1998-2010 Gilles Vollant (minizip) ( http://www.winimage.com/zLibDll/minizip.html ) - - Modifications of Unzip for Zip64 - Copyright (C) 2007-2008 Even Rouault - - Modifications for Zip64 support on both zip and unzip - Copyright (C) 2009-2010 Mathias Svensson ( http://result42.com ) -*/ - -#if (!defined(_WIN32)) && (!defined(WIN32)) && (!defined(__APPLE__)) - #ifndef __USE_FILE_OFFSET64 - #define __USE_FILE_OFFSET64 - #endif - #ifndef __USE_LARGEFILE64 - #define __USE_LARGEFILE64 - #endif - #ifndef _LARGEFILE64_SOURCE - #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) -#define FSEEKO_FUNC(stream, offset, origin) fseeko64(stream, offset, origin) -#endif - -#include "tinydir.h" -#include -#include -#include -#include -#include -#include - -#ifdef _WIN32 -# include -# include -#else -# include -# include -# include -# include -#endif - -#include "zip.h" - -#ifdef _WIN32 - #define USEWIN32IOAPI - #include "iowin32.h" -#endif - - - -#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; - - hFind = FindFirstFileA(f,&ff32); - if (hFind != INVALID_HANDLE_VALUE) - { - FileTimeToLocalFileTime(&(ff32.ftLastWriteTime),&ftLocal); - FileTimeToDosDateTime(&ftLocal,((LPWORD)dt)+1,((LPWORD)dt)+0); - FindClose(hFind); - ret = 1; - } - } - 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; - - if (strcmp(f,"-")!=0) - { - char name[MAXFILENAME+1]; - int len = strlen(f); - if (len > MAXFILENAME) - len = MAXFILENAME; - - strncpy(name, f,MAXFILENAME-1); - /* strncpy doesnt append the trailing NULL, of the string is too long. */ - name[ MAXFILENAME ] = '\0'; - - if (name[len - 1] == '/') - name[len - 1] = '\0'; - /* not all systems allow stat'ing a file with / appended */ - if (stat(name,&s)==0) - { - tm_t = s.st_mtime; - ret = 1; - } - } - filedate = localtime(&tm_t); - - tmzip->tm_sec = filedate->tm_sec; - tmzip->tm_min = filedate->tm_min; - tmzip->tm_hour = filedate->tm_hour; - tmzip->tm_mday = filedate->tm_mday; - 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 - - - - -int check_exist_file(filename) - const char* filename; -{ - FILE* ftestexist; - int ret = 1; - ftestexist = FOPEN_FUNC(filename,"rb"); - if (ftestexist==NULL) - ret = 0; - else - fclose(ftestexist); - return ret; -} - -void do_banner() -{ - printf("MiniZip 1.1, demo of zLib + MiniZip64 package, written by Gilles Vollant\n"); - printf("more info on MiniZip at http://www.winimage.com/zLibDll/minizip.html\n\n"); -} - -void do_help() -{ - printf("Usage : minizip [-o] [-a] [-0 to -9] [-p password] [-j] file.zip [files_to_add]\n\n" \ - " -r Scan directories recursively\n" \ - " -o Overwrite existing file.zip\n" \ - " -a Append to existing file.zip\n" \ - " -0 Store only\n" \ - " -1 Compress faster\n" \ - " -9 Compress better\n\n" \ - " -j exclude path. store only the file name.\n\n"); -} - -/* calculate the CRC32 of a file, - because to encrypt a file, we need known the CRC32 of the file before */ -int getFileCrc(const char* filenameinzip,void*buf,unsigned long size_buf,unsigned long* result_crc) -{ - unsigned long calculate_crc=0; - int err=ZIP_OK; - FILE * fin = FOPEN_FUNC(filenameinzip,"rb"); - - unsigned long size_read = 0; - unsigned long total_read = 0; - if (fin==NULL) - { - err = ZIP_ERRNO; - } - - if (err == ZIP_OK) - do - { - err = ZIP_OK; - size_read = (int)fread(buf,1,size_buf,fin); - if (size_read < size_buf) - if (feof(fin)==0) - { - printf("error in reading %s\n",filenameinzip); - err = ZIP_ERRNO; - } - - if (size_read>0) - calculate_crc = crc32(calculate_crc,buf,size_read); - total_read += size_read; - - } while ((err == ZIP_OK) && (size_read>0)); - - if (fin) - fclose(fin); - - *result_crc=calculate_crc; - printf("file %s crc %lx\n", filenameinzip, calculate_crc); - return err; -} - -int isLargeFile(const char* filename) -{ - int largeFile = 0; - ZPOS64_T pos = 0; - FILE* pFile = FOPEN_FUNC(filename, "rb"); - - if(pFile != NULL) - { - int n = FSEEKO_FUNC(pFile, 0, SEEK_END); - pos = FTELLO_FUNC(pFile); - - printf("File : %s is %lld bytes\n", filename, pos); - - if(pos >= 0xffffffff) - largeFile = 1; - - fclose(pFile); - } - - return largeFile; -} - -void addFileToZip(zipFile zf, const char *filenameinzip, const char *password, int opt_exclude_path,int opt_compress_level) { - FILE * fin; - int size_read; - const char *savefilenameinzip; - zip_fileinfo zi; - unsigned long crcFile=0; - int zip64 = 0; - int err=0; - int size_buf=WRITEBUFFERSIZE; - unsigned char buf[WRITEBUFFERSIZE]; - zi.tmz_date.tm_sec = zi.tmz_date.tm_min = zi.tmz_date.tm_hour = - zi.tmz_date.tm_mday = zi.tmz_date.tm_mon = zi.tmz_date.tm_year = 0; - zi.dosDate = 0; - zi.internal_fa = 0; - zi.external_fa = 0; - filetime(filenameinzip,&zi.tmz_date,&zi.dosDate); - -/* - err = zipOpenNewFileInZip(zf,filenameinzip,&zi, - NULL,0,NULL,0,NULL / * comment * /, - (opt_compress_level != 0) ? Z_DEFLATED : 0, - opt_compress_level); -*/ - if ((password != NULL) && (err==ZIP_OK)) - err = getFileCrc(filenameinzip,buf,size_buf,&crcFile); - - zip64 = isLargeFile(filenameinzip); - - /* The path name saved, should not include a leading slash. */ - /*if it did, windows/xp and dynazip couldn't read the zip file. */ - savefilenameinzip = filenameinzip; - while( savefilenameinzip[0] == '\\' || savefilenameinzip[0] == '/' ) - { - savefilenameinzip++; - } - - /*should the zip file contain any path at all?*/ - if( opt_exclude_path ) - { - const char *tmpptr; - const char *lastslash = 0; - for( tmpptr = savefilenameinzip; *tmpptr; tmpptr++) - { - if( *tmpptr == '\\' || *tmpptr == '/') - { - lastslash = tmpptr; - } - } - if( lastslash != NULL ) - { - savefilenameinzip = lastslash+1; // base filename follows last slash. - } - } - - /**/ - err = zipOpenNewFileInZip3_64(zf,savefilenameinzip,&zi, - NULL,0,NULL,0,NULL /* comment*/, - (opt_compress_level != 0) ? Z_DEFLATED : 0, - opt_compress_level,0, - /* -MAX_WBITS, DEF_MEM_LEVEL, Z_DEFAULT_STRATEGY, */ - -MAX_WBITS, DEF_MEM_LEVEL, Z_DEFAULT_STRATEGY, - password,crcFile, zip64); - - if (err != ZIP_OK) - printf("error in opening %s in zipfile\n",filenameinzip); - else - { - fin = FOPEN_FUNC(filenameinzip,"rb"); - if (fin==NULL) - { - err=ZIP_ERRNO; - printf("error in opening %s for reading\n",filenameinzip); - } - } - - if (err == ZIP_OK) - do - { - err = ZIP_OK; - size_read = (int)fread(buf,1,size_buf,fin); - if (size_read < size_buf) - if (feof(fin)==0) - { - printf("error in reading %s\n",filenameinzip); - err = ZIP_ERRNO; - } - - if (size_read>0) - { - err = zipWriteInFileInZip (zf,buf,size_read); - if (err<0) - { - printf("error in writing %s in the zipfile\n", - filenameinzip); - } - - } - } while ((err == ZIP_OK) && (size_read>0)); - - if (fin) - fclose(fin); - - if (err<0) - err=ZIP_ERRNO; - else - { - err = zipCloseFileInZip(zf); - if (err!=ZIP_OK) - printf("error in closing %s in the zipfile\n", - filenameinzip); - } -} - - -void addPathToZip(zipFile zf, const char *filenameinzip, const char *password, int opt_exclude_path,int opt_compress_level) { - tinydir_dir dir; - int i; - char newname[512]; - - tinydir_open_sorted(&dir, filenameinzip); - - for (i = 0; i < dir.n_files; i++) - { - tinydir_file file; - tinydir_readfile_n(&dir, &file, i); - if(strcmp(file.name,".")==0) continue; - if(strcmp(file.name,"..")==0) continue; - sprintf(newname,"%s/%s",dir.path,file.name); - if (file.is_dir) - { - addPathToZip(zf,newname,password,opt_exclude_path,opt_compress_level); - } else { - addFileToZip(zf,newname,password,opt_exclude_path,opt_compress_level); - } - } - - tinydir_close(&dir); -} - - -int main(argc,argv) - int argc; - char *argv[]; -{ - int i; - int opt_recursive=0; - int opt_overwrite=1; - int opt_compress_level=Z_DEFAULT_COMPRESSION; - int opt_exclude_path=0; - int zipfilenamearg = 0; - char filename_try[MAXFILENAME+16]; - int zipok; - int err=0; - int size_buf=0; - void* buf=NULL; - const char* password=NULL; - - - do_banner(); - if (argc==1) - { - do_help(); - return 0; - } - else - { - for (i=1;i='0') && (c<='9')) - opt_compress_level = c-'0'; - if ((c=='j') || (c=='J')) - opt_exclude_path = 1; - if ((c=='r') || (c=='R')) - opt_recursive = 1; - if (((c=='p') || (c=='P')) && (i+1='a') && (rep<='z')) - rep -= 0x20; - } - while ((rep!='Y') && (rep!='N') && (rep!='A')); - if (rep=='N') - zipok = 0; - if (rep=='A') - opt_overwrite = 2; - } - } - - if (zipok==1) - { - zipFile zf; - int errclose; -# ifdef USEWIN32IOAPI - zlib_filefunc64_def ffunc; - fill_win32_filefunc64A(&ffunc); - zf = zipOpen2_64(filename_try,(opt_overwrite==2) ? 2 : 0,NULL,&ffunc); -# else - zf = zipOpen64(filename_try,(opt_overwrite==2) ? 2 : 0); -# endif - - if (zf == NULL) - { - printf("error opening %s\n",filename_try); - err= ZIP_ERRNO; - } - else - printf("creating %s\n",filename_try); - - for (i=zipfilenamearg+1;(i='0') || (argv[i][1]<='9'))) && - (strlen(argv[i]) == 2))) - { - if(opt_recursive) { - addPathToZip(zf,argv[i],password,opt_exclude_path,opt_compress_level); - } else { - addFileToZip(zf,argv[i],password,opt_exclude_path,opt_compress_level); - } - } - } - errclose = zipClose(zf,NULL); - if (errclose != ZIP_OK) - printf("error in closing %s\n",filename_try); - } - else - { - do_help(); - } - - free(buf); - return 0; -} DELETED compat/zlib/contrib/minizip/minizip.pc.in Index: compat/zlib/contrib/minizip/minizip.pc.in ================================================================== --- compat/zlib/contrib/minizip/minizip.pc.in +++ /dev/null @@ -1,12 +0,0 @@ -prefix=@prefix@ -exec_prefix=@exec_prefix@ -libdir=@libdir@ -includedir=@includedir@/minizip - -Name: minizip -Description: Minizip zip file manipulation library -Requires: -Version: @PACKAGE_VERSION@ -Libs: -L${libdir} -lminizip -Libs.private: -lz -Cflags: -I${includedir} DELETED compat/zlib/contrib/minizip/mztools.c Index: compat/zlib/contrib/minizip/mztools.c ================================================================== --- compat/zlib/contrib/minizip/mztools.c +++ /dev/null @@ -1,291 +0,0 @@ -/* - Additional tools for Minizip - Code: Xavier Roche '2004 - License: Same as ZLIB (www.gzip.org) -*/ - -/* Code */ -#include -#include -#include -#include "zlib.h" -#include "unzip.h" - -#define READ_8(adr) ((unsigned char)*(adr)) -#define READ_16(adr) ( READ_8(adr) | (READ_8(adr+1) << 8) ) -#define READ_32(adr) ( READ_16(adr) | (READ_16((adr)+2) << 16) ) - -#define WRITE_8(buff, n) do { \ - *((unsigned char*)(buff)) = (unsigned char) ((n) & 0xff); \ -} while(0) -#define WRITE_16(buff, n) do { \ - WRITE_8((unsigned char*)(buff), n); \ - WRITE_8(((unsigned char*)(buff)) + 1, (n) >> 8); \ -} while(0) -#define WRITE_32(buff, n) do { \ - WRITE_16((unsigned char*)(buff), (n) & 0xffff); \ - WRITE_16((unsigned char*)(buff) + 2, (n) >> 16); \ -} while(0) - -extern int ZEXPORT unzRepair(file, fileOut, fileOutTmp, nRecovered, bytesRecovered) -const char* file; -const char* fileOut; -const char* fileOutTmp; -uLong* nRecovered; -uLong* bytesRecovered; -{ - int err = Z_OK; - FILE* fpZip = fopen(file, "rb"); - FILE* fpOut = fopen(fileOut, "wb"); - FILE* fpOutCD = fopen(fileOutTmp, "wb"); - if (fpZip != NULL && fpOut != NULL) { - int entries = 0; - uLong totalBytes = 0; - char header[30]; - char filename[1024]; - char extra[1024]; - int offset = 0; - int offsetCD = 0; - while ( fread(header, 1, 30, fpZip) == 30 ) { - int currentOffset = offset; - - /* File entry */ - if (READ_32(header) == 0x04034b50) { - unsigned int version = READ_16(header + 4); - unsigned int gpflag = READ_16(header + 6); - unsigned int method = READ_16(header + 8); - unsigned int filetime = READ_16(header + 10); - unsigned int filedate = READ_16(header + 12); - unsigned int crc = READ_32(header + 14); /* crc */ - unsigned int cpsize = READ_32(header + 18); /* compressed size */ - unsigned int uncpsize = READ_32(header + 22); /* uncompressed sz */ - unsigned int fnsize = READ_16(header + 26); /* file name length */ - unsigned int extsize = READ_16(header + 28); /* extra field length */ - filename[0] = extra[0] = '\0'; - - /* Header */ - if (fwrite(header, 1, 30, fpOut) == 30) { - offset += 30; - } else { - err = Z_ERRNO; - break; - } - - /* Filename */ - if (fnsize > 0) { - if (fnsize < sizeof(filename)) { - if (fread(filename, 1, fnsize, fpZip) == fnsize) { - if (fwrite(filename, 1, fnsize, fpOut) == fnsize) { - offset += fnsize; - } else { - err = Z_ERRNO; - break; - } - } else { - err = Z_ERRNO; - break; - } - } else { - err = Z_ERRNO; - break; - } - } else { - err = Z_STREAM_ERROR; - break; - } - - /* Extra field */ - if (extsize > 0) { - if (extsize < sizeof(extra)) { - if (fread(extra, 1, extsize, fpZip) == extsize) { - if (fwrite(extra, 1, extsize, fpOut) == extsize) { - offset += extsize; - } else { - err = Z_ERRNO; - break; - } - } else { - err = Z_ERRNO; - break; - } - } else { - err = Z_ERRNO; - break; - } - } - - /* Data */ - { - int dataSize = cpsize; - if (dataSize == 0) { - dataSize = uncpsize; - } - if (dataSize > 0) { - char* data = malloc(dataSize); - if (data != NULL) { - if ((int)fread(data, 1, dataSize, fpZip) == dataSize) { - if ((int)fwrite(data, 1, dataSize, fpOut) == dataSize) { - offset += dataSize; - totalBytes += dataSize; - } else { - err = Z_ERRNO; - } - } else { - err = Z_ERRNO; - } - free(data); - if (err != Z_OK) { - break; - } - } else { - err = Z_MEM_ERROR; - break; - } - } - } - - /* Central directory entry */ - { - char header[46]; - char* comment = ""; - int comsize = (int) strlen(comment); - WRITE_32(header, 0x02014b50); - WRITE_16(header + 4, version); - WRITE_16(header + 6, version); - WRITE_16(header + 8, gpflag); - WRITE_16(header + 10, method); - WRITE_16(header + 12, filetime); - WRITE_16(header + 14, filedate); - WRITE_32(header + 16, crc); - WRITE_32(header + 20, cpsize); - WRITE_32(header + 24, uncpsize); - WRITE_16(header + 28, fnsize); - WRITE_16(header + 30, extsize); - WRITE_16(header + 32, comsize); - WRITE_16(header + 34, 0); /* disk # */ - WRITE_16(header + 36, 0); /* int attrb */ - WRITE_32(header + 38, 0); /* ext attrb */ - WRITE_32(header + 42, currentOffset); - /* Header */ - if (fwrite(header, 1, 46, fpOutCD) == 46) { - offsetCD += 46; - - /* Filename */ - if (fnsize > 0) { - if (fwrite(filename, 1, fnsize, fpOutCD) == fnsize) { - offsetCD += fnsize; - } else { - err = Z_ERRNO; - break; - } - } else { - err = Z_STREAM_ERROR; - break; - } - - /* Extra field */ - if (extsize > 0) { - if (fwrite(extra, 1, extsize, fpOutCD) == extsize) { - offsetCD += extsize; - } else { - err = Z_ERRNO; - break; - } - } - - /* Comment field */ - if (comsize > 0) { - if ((int)fwrite(comment, 1, comsize, fpOutCD) == comsize) { - offsetCD += comsize; - } else { - err = Z_ERRNO; - break; - } - } - - - } else { - err = Z_ERRNO; - break; - } - } - - /* Success */ - entries++; - - } else { - break; - } - } - - /* Final central directory */ - { - int entriesZip = entries; - char header[22]; - char* comment = ""; // "ZIP File recovered by zlib/minizip/mztools"; - int comsize = (int) strlen(comment); - if (entriesZip > 0xffff) { - entriesZip = 0xffff; - } - WRITE_32(header, 0x06054b50); - WRITE_16(header + 4, 0); /* disk # */ - WRITE_16(header + 6, 0); /* disk # */ - WRITE_16(header + 8, entriesZip); /* hack */ - WRITE_16(header + 10, entriesZip); /* hack */ - WRITE_32(header + 12, offsetCD); /* size of CD */ - WRITE_32(header + 16, offset); /* offset to CD */ - WRITE_16(header + 20, comsize); /* comment */ - - /* Header */ - if (fwrite(header, 1, 22, fpOutCD) == 22) { - - /* Comment field */ - if (comsize > 0) { - if ((int)fwrite(comment, 1, comsize, fpOutCD) != comsize) { - err = Z_ERRNO; - } - } - - } else { - err = Z_ERRNO; - } - } - - /* Final merge (file + central directory) */ - fclose(fpOutCD); - if (err == Z_OK) { - fpOutCD = fopen(fileOutTmp, "rb"); - if (fpOutCD != NULL) { - int nRead; - char buffer[8192]; - while ( (nRead = (int)fread(buffer, 1, sizeof(buffer), fpOutCD)) > 0) { - if ((int)fwrite(buffer, 1, nRead, fpOut) != nRead) { - err = Z_ERRNO; - break; - } - } - fclose(fpOutCD); - } - } - - /* Close */ - fclose(fpZip); - fclose(fpOut); - - /* Wipe temporary file */ - (void)remove(fileOutTmp); - - /* Number of recovered entries */ - if (err == Z_OK) { - if (nRecovered != NULL) { - *nRecovered = entries; - } - if (bytesRecovered != NULL) { - *bytesRecovered = totalBytes; - } - } - } else { - err = Z_STREAM_ERROR; - } - return err; -} DELETED compat/zlib/contrib/minizip/mztools.h Index: compat/zlib/contrib/minizip/mztools.h ================================================================== --- compat/zlib/contrib/minizip/mztools.h +++ /dev/null @@ -1,37 +0,0 @@ -/* - Additional tools for Minizip - Code: Xavier Roche '2004 - License: Same as ZLIB (www.gzip.org) -*/ - -#ifndef _zip_tools_H -#define _zip_tools_H - -#ifdef __cplusplus -extern "C" { -#endif - -#ifndef _ZLIB_H -#include "zlib.h" -#endif - -#include "unzip.h" - -/* Repair a ZIP file (missing central directory) - file: file to recover - fileOut: output file after recovery - fileOutTmp: temporary file name used for recovery -*/ -extern int ZEXPORT unzRepair(const char* file, - const char* fileOut, - const char* fileOutTmp, - uLong* nRecovered, - uLong* bytesRecovered); - - -#ifdef __cplusplus -} -#endif - - -#endif DELETED compat/zlib/contrib/minizip/tinydir.h Index: compat/zlib/contrib/minizip/tinydir.h ================================================================== --- compat/zlib/contrib/minizip/tinydir.h +++ /dev/null @@ -1,816 +0,0 @@ -/* -Copyright (c) 2013-2017, tinydir authors: -- Cong Xu -- Lautis Sun -- Baudouin Feildel -- Andargor -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. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "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 COPYRIGHT OWNER OR CONTRIBUTORS 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. -*/ -#ifndef TINYDIR_H -#define TINYDIR_H - -#ifdef __cplusplus -extern "C" { -#endif - -#if ((defined _UNICODE) && !(defined UNICODE)) -#define UNICODE -#endif - -#if ((defined UNICODE) && !(defined _UNICODE)) -#define _UNICODE -#endif - -#include -#include -#include -#ifdef _MSC_VER -# define WIN32_LEAN_AND_MEAN -# include -# include -# pragma warning(push) -# pragma warning (disable : 4996) -#else -# include -# include -# include -# include -#endif -#ifdef __MINGW32__ -# include -#endif - - -/* types */ - -/* Windows UNICODE wide character support */ -#if defined _MSC_VER || defined __MINGW32__ -# define _tinydir_char_t TCHAR -# define TINYDIR_STRING(s) _TEXT(s) -# define _tinydir_strlen _tcslen -# define _tinydir_strcpy _tcscpy -# define _tinydir_strcat _tcscat -# define _tinydir_strcmp _tcscmp -# define _tinydir_strrchr _tcsrchr -# define _tinydir_strncmp _tcsncmp -#else -# define _tinydir_char_t char -# define TINYDIR_STRING(s) s -# define _tinydir_strlen strlen -# define _tinydir_strcpy strcpy -# define _tinydir_strcat strcat -# define _tinydir_strcmp strcmp -# define _tinydir_strrchr strrchr -# define _tinydir_strncmp strncmp -#endif - -#if (defined _MSC_VER || defined __MINGW32__) -# include -# define _TINYDIR_PATH_MAX MAX_PATH -#elif defined __linux__ -# include -# define _TINYDIR_PATH_MAX PATH_MAX -#elif defined(__unix__) || (defined(__APPLE__) && defined(__MACH__)) -# include -# if defined(BSD) -# include -# define _TINYDIR_PATH_MAX PATH_MAX -# endif -#endif - -#ifndef _TINYDIR_PATH_MAX -#define _TINYDIR_PATH_MAX 4096 -#endif - -#ifdef _MSC_VER -/* extra chars for the "\\*" mask */ -# define _TINYDIR_PATH_EXTRA 2 -#else -# define _TINYDIR_PATH_EXTRA 0 -#endif - -#define _TINYDIR_FILENAME_MAX 256 - -#if (defined _MSC_VER || defined __MINGW32__) -#define _TINYDIR_DRIVE_MAX 3 -#endif - -#ifdef _MSC_VER -# define _TINYDIR_FUNC static __inline -#elif !defined __STDC_VERSION__ || __STDC_VERSION__ < 199901L -# define _TINYDIR_FUNC static __inline__ -#else -# define _TINYDIR_FUNC static inline -#endif - -/* readdir_r usage; define TINYDIR_USE_READDIR_R to use it (if supported) */ -#ifdef TINYDIR_USE_READDIR_R - -/* readdir_r is a POSIX-only function, and may not be available under various - * environments/settings, e.g. MinGW. Use readdir fallback */ -#if _POSIX_C_SOURCE >= 1 || _XOPEN_SOURCE || _BSD_SOURCE || _SVID_SOURCE ||\ - _POSIX_SOURCE -# define _TINYDIR_HAS_READDIR_R -#endif -#if _POSIX_C_SOURCE >= 200112L -# define _TINYDIR_HAS_FPATHCONF -# include -#endif -#if _BSD_SOURCE || _SVID_SOURCE || \ - (_POSIX_C_SOURCE >= 200809L || _XOPEN_SOURCE >= 700) -# define _TINYDIR_HAS_DIRFD -# include -#endif -#if defined _TINYDIR_HAS_FPATHCONF && defined _TINYDIR_HAS_DIRFD &&\ - defined _PC_NAME_MAX -# define _TINYDIR_USE_FPATHCONF -#endif -#if defined __MINGW32__ || !defined _TINYDIR_HAS_READDIR_R ||\ - !(defined _TINYDIR_USE_FPATHCONF || defined NAME_MAX) -# define _TINYDIR_USE_READDIR -#endif - -/* Use readdir by default */ -#else -# define _TINYDIR_USE_READDIR -#endif - -/* MINGW32 has two versions of dirent, ASCII and UNICODE*/ -#ifndef _MSC_VER -#if (defined __MINGW32__) && (defined _UNICODE) -#define _TINYDIR_DIR _WDIR -#define _tinydir_dirent _wdirent -#define _tinydir_opendir _wopendir -#define _tinydir_readdir _wreaddir -#define _tinydir_closedir _wclosedir -#else -#define _TINYDIR_DIR DIR -#define _tinydir_dirent dirent -#define _tinydir_opendir opendir -#define _tinydir_readdir readdir -#define _tinydir_closedir closedir -#endif -#endif - -/* Allow user to use a custom allocator by defining _TINYDIR_MALLOC and _TINYDIR_FREE. */ -#if defined(_TINYDIR_MALLOC) && defined(_TINYDIR_FREE) -#elif !defined(_TINYDIR_MALLOC) && !defined(_TINYDIR_FREE) -#else -#error "Either define both alloc and free or none of them!" -#endif - -#if !defined(_TINYDIR_MALLOC) - #define _TINYDIR_MALLOC(_size) malloc(_size) - #define _TINYDIR_FREE(_ptr) free(_ptr) -#endif /* !defined(_TINYDIR_MALLOC) */ - -typedef struct tinydir_file -{ - _tinydir_char_t path[_TINYDIR_PATH_MAX]; - _tinydir_char_t name[_TINYDIR_FILENAME_MAX]; - _tinydir_char_t *extension; - int is_dir; - int is_reg; - -#ifndef _MSC_VER -#ifdef __MINGW32__ - struct _stat _s; -#else - struct stat _s; -#endif -#endif -} tinydir_file; - -typedef struct tinydir_dir -{ - _tinydir_char_t path[_TINYDIR_PATH_MAX]; - int has_next; - size_t n_files; - - tinydir_file *_files; -#ifdef _MSC_VER - HANDLE _h; - WIN32_FIND_DATA _f; -#else - _TINYDIR_DIR *_d; - struct _tinydir_dirent *_e; -#ifndef _TINYDIR_USE_READDIR - struct _tinydir_dirent *_ep; -#endif -#endif -} tinydir_dir; - - -/* declarations */ - -_TINYDIR_FUNC -int tinydir_open(tinydir_dir *dir, const _tinydir_char_t *path); -_TINYDIR_FUNC -int tinydir_open_sorted(tinydir_dir *dir, const _tinydir_char_t *path); -_TINYDIR_FUNC -void tinydir_close(tinydir_dir *dir); - -_TINYDIR_FUNC -int tinydir_next(tinydir_dir *dir); -_TINYDIR_FUNC -int tinydir_readfile(const tinydir_dir *dir, tinydir_file *file); -_TINYDIR_FUNC -int tinydir_readfile_n(const tinydir_dir *dir, tinydir_file *file, size_t i); -_TINYDIR_FUNC -int tinydir_open_subdir_n(tinydir_dir *dir, size_t i); - -_TINYDIR_FUNC -int tinydir_file_open(tinydir_file *file, const _tinydir_char_t *path); -_TINYDIR_FUNC -void _tinydir_get_ext(tinydir_file *file); -_TINYDIR_FUNC -int _tinydir_file_cmp(const void *a, const void *b); -#ifndef _MSC_VER -#ifndef _TINYDIR_USE_READDIR -_TINYDIR_FUNC -size_t _tinydir_dirent_buf_size(_TINYDIR_DIR *dirp); -#endif -#endif - - -/* definitions*/ - -_TINYDIR_FUNC -int tinydir_open(tinydir_dir *dir, const _tinydir_char_t *path) -{ -#ifndef _MSC_VER -#ifndef _TINYDIR_USE_READDIR - int error; - int size; /* using int size */ -#endif -#else - _tinydir_char_t path_buf[_TINYDIR_PATH_MAX]; -#endif - _tinydir_char_t *pathp; - - if (dir == NULL || path == NULL || _tinydir_strlen(path) == 0) - { - errno = EINVAL; - return -1; - } - if (_tinydir_strlen(path) + _TINYDIR_PATH_EXTRA >= _TINYDIR_PATH_MAX) - { - errno = ENAMETOOLONG; - return -1; - } - - /* initialise dir */ - dir->_files = NULL; -#ifdef _MSC_VER - dir->_h = INVALID_HANDLE_VALUE; -#else - dir->_d = NULL; -#ifndef _TINYDIR_USE_READDIR - dir->_ep = NULL; -#endif -#endif - tinydir_close(dir); - - _tinydir_strcpy(dir->path, path); - /* Remove trailing slashes */ - pathp = &dir->path[_tinydir_strlen(dir->path) - 1]; - while (pathp != dir->path && (*pathp == TINYDIR_STRING('\\') || *pathp == TINYDIR_STRING('/'))) - { - *pathp = TINYDIR_STRING('\0'); - pathp++; - } -#ifdef _MSC_VER - _tinydir_strcpy(path_buf, dir->path); - _tinydir_strcat(path_buf, TINYDIR_STRING("\\*")); -#if (defined WINAPI_FAMILY) && (WINAPI_FAMILY != WINAPI_FAMILY_DESKTOP_APP) - dir->_h = FindFirstFileEx(path_buf, FindExInfoStandard, &dir->_f, FindExSearchNameMatch, NULL, 0); -#else - dir->_h = FindFirstFile(path_buf, &dir->_f); -#endif - if (dir->_h == INVALID_HANDLE_VALUE) - { - errno = ENOENT; -#else - dir->_d = _tinydir_opendir(path); - if (dir->_d == NULL) - { -#endif - goto bail; - } - - /* read first file */ - dir->has_next = 1; -#ifndef _MSC_VER -#ifdef _TINYDIR_USE_READDIR - dir->_e = _tinydir_readdir(dir->_d); -#else - /* allocate dirent buffer for readdir_r */ - size = _tinydir_dirent_buf_size(dir->_d); /* conversion to int */ - if (size == -1) return -1; - dir->_ep = (struct _tinydir_dirent*)_TINYDIR_MALLOC(size); - if (dir->_ep == NULL) return -1; - - error = readdir_r(dir->_d, dir->_ep, &dir->_e); - if (error != 0) return -1; -#endif - if (dir->_e == NULL) - { - dir->has_next = 0; - } -#endif - - return 0; - -bail: - tinydir_close(dir); - return -1; -} - -_TINYDIR_FUNC -int tinydir_open_sorted(tinydir_dir *dir, const _tinydir_char_t *path) -{ - /* Count the number of files first, to pre-allocate the files array */ - size_t n_files = 0; - if (tinydir_open(dir, path) == -1) - { - return -1; - } - while (dir->has_next) - { - n_files++; - if (tinydir_next(dir) == -1) - { - goto bail; - } - } - tinydir_close(dir); - - if (tinydir_open(dir, path) == -1) - { - return -1; - } - - dir->n_files = 0; - dir->_files = (tinydir_file *)_TINYDIR_MALLOC(sizeof *dir->_files * n_files); - if (dir->_files == NULL) - { - goto bail; - } - while (dir->has_next) - { - tinydir_file *p_file; - dir->n_files++; - - p_file = &dir->_files[dir->n_files - 1]; - if (tinydir_readfile(dir, p_file) == -1) - { - goto bail; - } - - if (tinydir_next(dir) == -1) - { - goto bail; - } - - /* Just in case the number of files has changed between the first and - second reads, terminate without writing into unallocated memory */ - if (dir->n_files == n_files) - { - break; - } - } - - qsort(dir->_files, dir->n_files, sizeof(tinydir_file), _tinydir_file_cmp); - - return 0; - -bail: - tinydir_close(dir); - return -1; -} - -_TINYDIR_FUNC -void tinydir_close(tinydir_dir *dir) -{ - if (dir == NULL) - { - return; - } - - memset(dir->path, 0, sizeof(dir->path)); - dir->has_next = 0; - dir->n_files = 0; - _TINYDIR_FREE(dir->_files); - dir->_files = NULL; -#ifdef _MSC_VER - if (dir->_h != INVALID_HANDLE_VALUE) - { - FindClose(dir->_h); - } - dir->_h = INVALID_HANDLE_VALUE; -#else - if (dir->_d) - { - _tinydir_closedir(dir->_d); - } - dir->_d = NULL; - dir->_e = NULL; -#ifndef _TINYDIR_USE_READDIR - _TINYDIR_FREE(dir->_ep); - dir->_ep = NULL; -#endif -#endif -} - -_TINYDIR_FUNC -int tinydir_next(tinydir_dir *dir) -{ - if (dir == NULL) - { - errno = EINVAL; - return -1; - } - if (!dir->has_next) - { - errno = ENOENT; - return -1; - } - -#ifdef _MSC_VER - if (FindNextFile(dir->_h, &dir->_f) == 0) -#else -#ifdef _TINYDIR_USE_READDIR - dir->_e = _tinydir_readdir(dir->_d); -#else - if (dir->_ep == NULL) - { - return -1; - } - if (readdir_r(dir->_d, dir->_ep, &dir->_e) != 0) - { - return -1; - } -#endif - if (dir->_e == NULL) -#endif - { - dir->has_next = 0; -#ifdef _MSC_VER - if (GetLastError() != ERROR_SUCCESS && - GetLastError() != ERROR_NO_MORE_FILES) - { - tinydir_close(dir); - errno = EIO; - return -1; - } -#endif - } - - return 0; -} - -_TINYDIR_FUNC -int tinydir_readfile(const tinydir_dir *dir, tinydir_file *file) -{ - if (dir == NULL || file == NULL) - { - errno = EINVAL; - return -1; - } -#ifdef _MSC_VER - if (dir->_h == INVALID_HANDLE_VALUE) -#else - if (dir->_e == NULL) -#endif - { - errno = ENOENT; - return -1; - } - if (_tinydir_strlen(dir->path) + - _tinydir_strlen( -#ifdef _MSC_VER - dir->_f.cFileName -#else - dir->_e->d_name -#endif - ) + 1 + _TINYDIR_PATH_EXTRA >= - _TINYDIR_PATH_MAX) - { - /* the path for the file will be too long */ - errno = ENAMETOOLONG; - return -1; - } - if (_tinydir_strlen( -#ifdef _MSC_VER - dir->_f.cFileName -#else - dir->_e->d_name -#endif - ) >= _TINYDIR_FILENAME_MAX) - { - errno = ENAMETOOLONG; - return -1; - } - - _tinydir_strcpy(file->path, dir->path); - _tinydir_strcat(file->path, TINYDIR_STRING("/")); - _tinydir_strcpy(file->name, -#ifdef _MSC_VER - dir->_f.cFileName -#else - dir->_e->d_name -#endif - ); - _tinydir_strcat(file->path, file->name); -#ifndef _MSC_VER -#ifdef __MINGW32__ - if (_tstat( -#else - if (stat( -#endif - file->path, &file->_s) == -1) - { - return -1; - } -#endif - _tinydir_get_ext(file); - - file->is_dir = -#ifdef _MSC_VER - !!(dir->_f.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY); -#else - S_ISDIR(file->_s.st_mode); -#endif - file->is_reg = -#ifdef _MSC_VER - !!(dir->_f.dwFileAttributes & FILE_ATTRIBUTE_NORMAL) || - ( - !(dir->_f.dwFileAttributes & FILE_ATTRIBUTE_DEVICE) && - !(dir->_f.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) && - !(dir->_f.dwFileAttributes & FILE_ATTRIBUTE_ENCRYPTED) && -#ifdef FILE_ATTRIBUTE_INTEGRITY_STREAM - !(dir->_f.dwFileAttributes & FILE_ATTRIBUTE_INTEGRITY_STREAM) && -#endif -#ifdef FILE_ATTRIBUTE_NO_SCRUB_DATA - !(dir->_f.dwFileAttributes & FILE_ATTRIBUTE_NO_SCRUB_DATA) && -#endif - !(dir->_f.dwFileAttributes & FILE_ATTRIBUTE_OFFLINE) && - !(dir->_f.dwFileAttributes & FILE_ATTRIBUTE_TEMPORARY)); -#else - S_ISREG(file->_s.st_mode); -#endif - - return 0; -} - -_TINYDIR_FUNC -int tinydir_readfile_n(const tinydir_dir *dir, tinydir_file *file, size_t i) -{ - if (dir == NULL || file == NULL) - { - errno = EINVAL; - return -1; - } - if (i >= dir->n_files) - { - errno = ENOENT; - return -1; - } - - memcpy(file, &dir->_files[i], sizeof(tinydir_file)); - _tinydir_get_ext(file); - - return 0; -} - -_TINYDIR_FUNC -int tinydir_open_subdir_n(tinydir_dir *dir, size_t i) -{ - _tinydir_char_t path[_TINYDIR_PATH_MAX]; - if (dir == NULL) - { - errno = EINVAL; - return -1; - } - if (i >= dir->n_files || !dir->_files[i].is_dir) - { - errno = ENOENT; - return -1; - } - - _tinydir_strcpy(path, dir->_files[i].path); - tinydir_close(dir); - if (tinydir_open_sorted(dir, path) == -1) - { - return -1; - } - - return 0; -} - -/* Open a single file given its path */ -_TINYDIR_FUNC -int tinydir_file_open(tinydir_file *file, const _tinydir_char_t *path) -{ - tinydir_dir dir; - int result = 0; - int found = 0; - _tinydir_char_t dir_name_buf[_TINYDIR_PATH_MAX]; - _tinydir_char_t file_name_buf[_TINYDIR_FILENAME_MAX]; - _tinydir_char_t *dir_name; - _tinydir_char_t *base_name; -#if (defined _MSC_VER || defined __MINGW32__) - _tinydir_char_t drive_buf[_TINYDIR_PATH_MAX]; - _tinydir_char_t ext_buf[_TINYDIR_FILENAME_MAX]; -#endif - - if (file == NULL || path == NULL || _tinydir_strlen(path) == 0) - { - errno = EINVAL; - return -1; - } - if (_tinydir_strlen(path) + _TINYDIR_PATH_EXTRA >= _TINYDIR_PATH_MAX) - { - errno = ENAMETOOLONG; - return -1; - } - - /* Get the parent path */ -#if (defined _MSC_VER || defined __MINGW32__) -#if ((defined _MSC_VER) && (_MSC_VER >= 1400)) - _tsplitpath_s( - path, - drive_buf, _TINYDIR_DRIVE_MAX, - dir_name_buf, _TINYDIR_FILENAME_MAX, - file_name_buf, _TINYDIR_FILENAME_MAX, - ext_buf, _TINYDIR_FILENAME_MAX); -#else - _tsplitpath( - path, - drive_buf, - dir_name_buf, - file_name_buf, - ext_buf); -#endif - -/* _splitpath_s not work fine with only filename and widechar support */ -#ifdef _UNICODE - if (drive_buf[0] == L'\xFEFE') - drive_buf[0] = '\0'; - if (dir_name_buf[0] == L'\xFEFE') - dir_name_buf[0] = '\0'; -#endif - - if (errno) - { - errno = EINVAL; - return -1; - } - /* Emulate the behavior of dirname by returning "." for dir name if it's - empty */ - if (drive_buf[0] == '\0' && dir_name_buf[0] == '\0') - { - _tinydir_strcpy(dir_name_buf, TINYDIR_STRING(".")); - } - /* Concatenate the drive letter and dir name to form full dir name */ - _tinydir_strcat(drive_buf, dir_name_buf); - dir_name = drive_buf; - /* Concatenate the file name and extension to form base name */ - _tinydir_strcat(file_name_buf, ext_buf); - base_name = file_name_buf; -#else - _tinydir_strcpy(dir_name_buf, path); - dir_name = dirname(dir_name_buf); - _tinydir_strcpy(file_name_buf, path); - base_name =basename(file_name_buf); -#endif - - /* Open the parent directory */ - if (tinydir_open(&dir, dir_name) == -1) - { - return -1; - } - - /* Read through the parent directory and look for the file */ - while (dir.has_next) - { - if (tinydir_readfile(&dir, file) == -1) - { - result = -1; - goto bail; - } - if (_tinydir_strcmp(file->name, base_name) == 0) - { - /* File found */ - found = 1; - break; - } - tinydir_next(&dir); - } - if (!found) - { - result = -1; - errno = ENOENT; - } - -bail: - tinydir_close(&dir); - return result; -} - -_TINYDIR_FUNC -void _tinydir_get_ext(tinydir_file *file) -{ - _tinydir_char_t *period = _tinydir_strrchr(file->name, TINYDIR_STRING('.')); - if (period == NULL) - { - file->extension = &(file->name[_tinydir_strlen(file->name)]); - } - else - { - file->extension = period + 1; - } -} - -_TINYDIR_FUNC -int _tinydir_file_cmp(const void *a, const void *b) -{ - const tinydir_file *fa = (const tinydir_file *)a; - const tinydir_file *fb = (const tinydir_file *)b; - if (fa->is_dir != fb->is_dir) - { - return -(fa->is_dir - fb->is_dir); - } - return _tinydir_strncmp(fa->name, fb->name, _TINYDIR_FILENAME_MAX); -} - -#ifndef _MSC_VER -#ifndef _TINYDIR_USE_READDIR -/* -The following authored by Ben Hutchings -from https://womble.decadent.org.uk/readdir_r-advisory.html -*/ -/* Calculate the required buffer size (in bytes) for directory * -* entries read from the given directory handle. Return -1 if this * -* this cannot be done. * -* * -* This code does not trust values of NAME_MAX that are less than * -* 255, since some systems (including at least HP-UX) incorrectly * -* define it to be a smaller value. */ -_TINYDIR_FUNC -size_t _tinydir_dirent_buf_size(_TINYDIR_DIR *dirp) -{ - long name_max; - size_t name_end; - /* parameter may be unused */ - (void)dirp; - -#if defined _TINYDIR_USE_FPATHCONF - name_max = fpathconf(dirfd(dirp), _PC_NAME_MAX); - if (name_max == -1) -#if defined(NAME_MAX) - name_max = (NAME_MAX > 255) ? NAME_MAX : 255; -#else - return (size_t)(-1); -#endif -#elif defined(NAME_MAX) - name_max = (NAME_MAX > 255) ? NAME_MAX : 255; -#else -#error "buffer size for readdir_r cannot be determined" -#endif - name_end = (size_t)offsetof(struct _tinydir_dirent, d_name) + name_max + 1; - return (name_end > sizeof(struct _tinydir_dirent) ? - name_end : sizeof(struct _tinydir_dirent)); -} -#endif -#endif - -#ifdef __cplusplus -} -#endif - -# if defined (_MSC_VER) -# pragma warning(pop) -# endif - -#endif DELETED compat/zlib/contrib/minizip/unzip.c Index: compat/zlib/contrib/minizip/unzip.c ================================================================== --- compat/zlib/contrib/minizip/unzip.c +++ /dev/null @@ -1,2125 +0,0 @@ -/* unzip.c -- IO for uncompress .zip files using zlib - Version 1.1, February 14h, 2010 - part of the MiniZip project - ( http://www.winimage.com/zLibDll/minizip.html ) - - Copyright (C) 1998-2010 Gilles Vollant (minizip) ( http://www.winimage.com/zLibDll/minizip.html ) - - Modifications of Unzip for Zip64 - Copyright (C) 2007-2008 Even Rouault - - Modifications for Zip64 support on both zip and unzip - Copyright (C) 2009-2010 Mathias Svensson ( http://result42.com ) - - For more info read MiniZip_info.txt - - - ------------------------------------------------------------------------------------ - Decryption code comes from crypt.c by Info-ZIP but has been greatly reduced in terms of - compatibility with older software. The following is from the original crypt.c. - Code woven in by Terry Thorsen 1/2003. - - Copyright (c) 1990-2000 Info-ZIP. All rights reserved. - - See the accompanying file LICENSE, version 2000-Apr-09 or later - (the contents of which are also included in zip.h) for terms of use. - If, for some reason, all these files are missing, the Info-ZIP license - also may be found at: ftp://ftp.info-zip.org/pub/infozip/license.html - - crypt.c (full version) by Info-ZIP. Last revised: [see crypt.h] - - The encryption/decryption parts of this source code (as opposed to the - non-echoing password parts) were originally written in Europe. The - whole source package can be freely distributed, including from the USA. - (Prior to January 2000, re-export from the US was a violation of US law.) - - This encryption code is a direct transcription of the algorithm from - Roger Schlafly, described by Phil Katz in the file appnote.txt. This - file (appnote.txt) is distributed with the PKZIP program (even in the - version without encryption capabilities). - - ------------------------------------------------------------------------------------ - - Changes in unzip.c - - 2007-2008 - Even Rouault - Addition of cpl_unzGetCurrentFileZStreamPos - 2007-2008 - Even Rouault - Decoration of symbol names unz* -> cpl_unz* - 2007-2008 - Even Rouault - Remove old C style function prototypes - 2007-2008 - Even Rouault - Add unzip support for ZIP64 - - Copyright (C) 2007-2008 Even Rouault - - - Oct-2009 - Mathias Svensson - Removed cpl_* from symbol names (Even Rouault added them but since this is now moved to a new project (minizip64) I renamed them again). - Oct-2009 - Mathias Svensson - Fixed problem if uncompressed size was > 4G and compressed size was <4G - should only read the compressed/uncompressed size from the Zip64 format if - the size from normal header was 0xFFFFFFFF - Oct-2009 - Mathias Svensson - Applied some bug fixes from paches recived from Gilles Vollant - Oct-2009 - Mathias Svensson - Applied support to unzip files with compression mathod BZIP2 (bzip2 lib is required) - Patch created by Daniel Borca - - Jan-2010 - back to unzip and minizip 1.0 name scheme, with compatibility layer - - Copyright (C) 1998 - 2010 Gilles Vollant, Even Rouault, Mathias Svensson - -*/ - - -#include -#include -#include - -#ifndef NOUNCRYPT - #define NOUNCRYPT -#endif - -#include "zlib.h" -#include "unzip.h" - -#ifdef STDC -# include -# include -# include -#endif -#ifdef NO_ERRNO_H - extern int errno; -#else -# include -#endif - - -#ifndef local -# define local static -#endif -/* compile with -Dlocal if your debugger can't find static symbols */ - - -#ifndef CASESENSITIVITYDEFAULT_NO -# if !defined(unix) && !defined(CASESENSITIVITYDEFAULT_YES) -# define CASESENSITIVITYDEFAULT_NO -# endif -#endif - - -#ifndef UNZ_BUFSIZE -#define UNZ_BUFSIZE (16384) -#endif - -#ifndef UNZ_MAXFILENAMEINZIP -#define UNZ_MAXFILENAMEINZIP (256) -#endif - -#ifndef ALLOC -# define ALLOC(size) (malloc(size)) -#endif -#ifndef TRYFREE -# define TRYFREE(p) {if (p) free(p);} -#endif - -#define SIZECENTRALDIRITEM (0x2e) -#define SIZEZIPLOCALHEADER (0x1e) - - -const char unz_copyright[] = - " unzip 1.01 Copyright 1998-2004 Gilles Vollant - http://www.winimage.com/zLibDll"; - -/* unz_file_info_interntal contain internal info about a file in zipfile*/ -typedef struct unz_file_info64_internal_s -{ - ZPOS64_T offset_curfile;/* relative offset of local header 8 bytes */ -} unz_file_info64_internal; - - -/* file_in_zip_read_info_s contain internal information about a file in zipfile, - when reading and decompress it */ -typedef struct -{ - char *read_buffer; /* internal buffer for compressed data */ - z_stream stream; /* zLib stream structure for inflate */ - -#ifdef HAVE_BZIP2 - bz_stream bstream; /* bzLib stream structure for bziped */ -#endif - - ZPOS64_T pos_in_zipfile; /* position in byte on the zipfile, for fseek*/ - uLong stream_initialised; /* flag set if stream structure is initialised*/ - - ZPOS64_T offset_local_extrafield;/* offset of the local extra field */ - uInt size_local_extrafield;/* size of the local extra field */ - ZPOS64_T pos_local_extrafield; /* position in the local extra field in read*/ - ZPOS64_T total_out_64; - - uLong crc32; /* crc32 of all data uncompressed */ - uLong crc32_wait; /* crc32 we must obtain after decompress all */ - ZPOS64_T rest_read_compressed; /* number of byte to be decompressed */ - ZPOS64_T rest_read_uncompressed;/*number of byte to be obtained after decomp*/ - zlib_filefunc64_32_def z_filefunc; - voidpf filestream; /* io structore of the zipfile */ - uLong compression_method; /* compression method (0==store) */ - ZPOS64_T byte_before_the_zipfile;/* byte before the zipfile, (>0 for sfx)*/ - int raw; -} file_in_zip64_read_info_s; - - -/* unz64_s contain internal information about the zipfile -*/ -typedef struct -{ - zlib_filefunc64_32_def z_filefunc; - int is64bitOpenFunction; - voidpf filestream; /* io structore of the zipfile */ - unz_global_info64 gi; /* public global information */ - ZPOS64_T byte_before_the_zipfile;/* byte before the zipfile, (>0 for sfx)*/ - ZPOS64_T num_file; /* number of the current file in the zipfile*/ - ZPOS64_T pos_in_central_dir; /* pos of the current file in the central dir*/ - ZPOS64_T current_file_ok; /* flag about the usability of the current file*/ - ZPOS64_T central_pos; /* position of the beginning of the central dir*/ - - ZPOS64_T size_central_dir; /* size of the central directory */ - ZPOS64_T offset_central_dir; /* offset of start of central directory with - respect to the starting disk number */ - - unz_file_info64 cur_file_info; /* public info about the current file in zip*/ - unz_file_info64_internal cur_file_info_internal; /* private info about it*/ - file_in_zip64_read_info_s* pfile_in_zip_read; /* structure about the current - file if we are decompressing it */ - int encrypted; - - int isZip64; - -# ifndef NOUNCRYPT - unsigned long keys[3]; /* keys defining the pseudo-random sequence */ - const z_crc_t* pcrc_32_tab; -# endif -} unz64_s; - - -#ifndef NOUNCRYPT -#include "crypt.h" -#endif - -/* =========================================================================== - Read a byte from a gz_stream; update next_in and avail_in. Return EOF - for end of file. - IN assertion: the stream s has been successfully opened for reading. -*/ - - -local int unz64local_getByte OF(( - const zlib_filefunc64_32_def* pzlib_filefunc_def, - voidpf filestream, - int *pi)); - -local int unz64local_getByte(const zlib_filefunc64_32_def* pzlib_filefunc_def, voidpf filestream, int *pi) -{ - unsigned char c; - int err = (int)ZREAD64(*pzlib_filefunc_def,filestream,&c,1); - if (err==1) - { - *pi = (int)c; - return UNZ_OK; - } - else - { - if (ZERROR64(*pzlib_filefunc_def,filestream)) - return UNZ_ERRNO; - else - return UNZ_EOF; - } -} - - -/* =========================================================================== - Reads a long in LSB order from the given gz_stream. Sets -*/ -local int unz64local_getShort OF(( - const zlib_filefunc64_32_def* pzlib_filefunc_def, - voidpf filestream, - uLong *pX)); - -local int unz64local_getShort (const zlib_filefunc64_32_def* pzlib_filefunc_def, - voidpf filestream, - uLong *pX) -{ - uLong x ; - int i = 0; - int err; - - err = unz64local_getByte(pzlib_filefunc_def,filestream,&i); - x = (uLong)i; - - if (err==UNZ_OK) - err = unz64local_getByte(pzlib_filefunc_def,filestream,&i); - x |= ((uLong)i)<<8; - - if (err==UNZ_OK) - *pX = x; - else - *pX = 0; - return err; -} - -local int unz64local_getLong OF(( - const zlib_filefunc64_32_def* pzlib_filefunc_def, - voidpf filestream, - uLong *pX)); - -local int unz64local_getLong (const zlib_filefunc64_32_def* pzlib_filefunc_def, - voidpf filestream, - uLong *pX) -{ - uLong x ; - int i = 0; - int err; - - err = unz64local_getByte(pzlib_filefunc_def,filestream,&i); - x = (uLong)i; - - if (err==UNZ_OK) - err = unz64local_getByte(pzlib_filefunc_def,filestream,&i); - x |= ((uLong)i)<<8; - - if (err==UNZ_OK) - err = unz64local_getByte(pzlib_filefunc_def,filestream,&i); - x |= ((uLong)i)<<16; - - if (err==UNZ_OK) - err = unz64local_getByte(pzlib_filefunc_def,filestream,&i); - x += ((uLong)i)<<24; - - if (err==UNZ_OK) - *pX = x; - else - *pX = 0; - return err; -} - -local int unz64local_getLong64 OF(( - const zlib_filefunc64_32_def* pzlib_filefunc_def, - voidpf filestream, - ZPOS64_T *pX)); - - -local int unz64local_getLong64 (const zlib_filefunc64_32_def* pzlib_filefunc_def, - voidpf filestream, - ZPOS64_T *pX) -{ - ZPOS64_T x ; - int i = 0; - int err; - - err = unz64local_getByte(pzlib_filefunc_def,filestream,&i); - x = (ZPOS64_T)i; - - if (err==UNZ_OK) - err = unz64local_getByte(pzlib_filefunc_def,filestream,&i); - x |= ((ZPOS64_T)i)<<8; - - if (err==UNZ_OK) - err = unz64local_getByte(pzlib_filefunc_def,filestream,&i); - x |= ((ZPOS64_T)i)<<16; - - if (err==UNZ_OK) - err = unz64local_getByte(pzlib_filefunc_def,filestream,&i); - x |= ((ZPOS64_T)i)<<24; - - if (err==UNZ_OK) - err = unz64local_getByte(pzlib_filefunc_def,filestream,&i); - x |= ((ZPOS64_T)i)<<32; - - if (err==UNZ_OK) - err = unz64local_getByte(pzlib_filefunc_def,filestream,&i); - x |= ((ZPOS64_T)i)<<40; - - if (err==UNZ_OK) - err = unz64local_getByte(pzlib_filefunc_def,filestream,&i); - x |= ((ZPOS64_T)i)<<48; - - if (err==UNZ_OK) - err = unz64local_getByte(pzlib_filefunc_def,filestream,&i); - x |= ((ZPOS64_T)i)<<56; - - if (err==UNZ_OK) - *pX = x; - else - *pX = 0; - return err; -} - -/* My own strcmpi / strcasecmp */ -local int strcmpcasenosensitive_internal (const char* fileName1, const char* fileName2) -{ - for (;;) - { - char c1=*(fileName1++); - char c2=*(fileName2++); - if ((c1>='a') && (c1<='z')) - c1 -= 0x20; - if ((c2>='a') && (c2<='z')) - c2 -= 0x20; - if (c1=='\0') - return ((c2=='\0') ? 0 : -1); - if (c2=='\0') - return 1; - if (c1c2) - return 1; - } -} - - -#ifdef CASESENSITIVITYDEFAULT_NO -#define CASESENSITIVITYDEFAULTVALUE 2 -#else -#define CASESENSITIVITYDEFAULTVALUE 1 -#endif - -#ifndef STRCMPCASENOSENTIVEFUNCTION -#define STRCMPCASENOSENTIVEFUNCTION strcmpcasenosensitive_internal -#endif - -/* - Compare two filename (fileName1,fileName2). - If iCaseSenisivity = 1, comparision is case sensitivity (like strcmp) - If iCaseSenisivity = 2, comparision is not case sensitivity (like strcmpi - or strcasecmp) - If iCaseSenisivity = 0, case sensitivity is defaut of your operating system - (like 1 on Unix, 2 on Windows) - -*/ -extern int ZEXPORT unzStringFileNameCompare (const char* fileName1, - const char* fileName2, - int iCaseSensitivity) - -{ - if (iCaseSensitivity==0) - iCaseSensitivity=CASESENSITIVITYDEFAULTVALUE; - - if (iCaseSensitivity==1) - return strcmp(fileName1,fileName2); - - return STRCMPCASENOSENTIVEFUNCTION(fileName1,fileName2); -} - -#ifndef BUFREADCOMMENT -#define BUFREADCOMMENT (0x400) -#endif - -/* - Locate the Central directory of a zipfile (at the end, just before - the global comment) -*/ -local ZPOS64_T unz64local_SearchCentralDir OF((const zlib_filefunc64_32_def* pzlib_filefunc_def, voidpf filestream)); -local ZPOS64_T unz64local_SearchCentralDir(const zlib_filefunc64_32_def* pzlib_filefunc_def, voidpf filestream) -{ - unsigned char* buf; - ZPOS64_T uSizeFile; - ZPOS64_T uBackRead; - ZPOS64_T uMaxBack=0xffff; /* maximum size of global comment */ - ZPOS64_T uPosFound=0; - - if (ZSEEK64(*pzlib_filefunc_def,filestream,0,ZLIB_FILEFUNC_SEEK_END) != 0) - return 0; - - - uSizeFile = ZTELL64(*pzlib_filefunc_def,filestream); - - if (uMaxBack>uSizeFile) - uMaxBack = uSizeFile; - - buf = (unsigned char*)ALLOC(BUFREADCOMMENT+4); - if (buf==NULL) - return 0; - - uBackRead = 4; - while (uBackReaduMaxBack) - uBackRead = uMaxBack; - else - uBackRead+=BUFREADCOMMENT; - uReadPos = uSizeFile-uBackRead ; - - uReadSize = ((BUFREADCOMMENT+4) < (uSizeFile-uReadPos)) ? - (BUFREADCOMMENT+4) : (uLong)(uSizeFile-uReadPos); - if (ZSEEK64(*pzlib_filefunc_def,filestream,uReadPos,ZLIB_FILEFUNC_SEEK_SET)!=0) - break; - - if (ZREAD64(*pzlib_filefunc_def,filestream,buf,uReadSize)!=uReadSize) - break; - - for (i=(int)uReadSize-3; (i--)>0;) - if (((*(buf+i))==0x50) && ((*(buf+i+1))==0x4b) && - ((*(buf+i+2))==0x05) && ((*(buf+i+3))==0x06)) - { - uPosFound = uReadPos+i; - break; - } - - if (uPosFound!=0) - break; - } - TRYFREE(buf); - return uPosFound; -} - - -/* - Locate the Central directory 64 of a zipfile (at the end, just before - the global comment) -*/ -local ZPOS64_T unz64local_SearchCentralDir64 OF(( - const zlib_filefunc64_32_def* pzlib_filefunc_def, - voidpf filestream)); - -local ZPOS64_T unz64local_SearchCentralDir64(const zlib_filefunc64_32_def* pzlib_filefunc_def, - voidpf filestream) -{ - unsigned char* buf; - ZPOS64_T uSizeFile; - ZPOS64_T uBackRead; - ZPOS64_T uMaxBack=0xffff; /* maximum size of global comment */ - ZPOS64_T uPosFound=0; - uLong uL; - ZPOS64_T relativeOffset; - - if (ZSEEK64(*pzlib_filefunc_def,filestream,0,ZLIB_FILEFUNC_SEEK_END) != 0) - return 0; - - - uSizeFile = ZTELL64(*pzlib_filefunc_def,filestream); - - if (uMaxBack>uSizeFile) - uMaxBack = uSizeFile; - - buf = (unsigned char*)ALLOC(BUFREADCOMMENT+4); - if (buf==NULL) - return 0; - - uBackRead = 4; - while (uBackReaduMaxBack) - uBackRead = uMaxBack; - else - uBackRead+=BUFREADCOMMENT; - uReadPos = uSizeFile-uBackRead ; - - uReadSize = ((BUFREADCOMMENT+4) < (uSizeFile-uReadPos)) ? - (BUFREADCOMMENT+4) : (uLong)(uSizeFile-uReadPos); - if (ZSEEK64(*pzlib_filefunc_def,filestream,uReadPos,ZLIB_FILEFUNC_SEEK_SET)!=0) - break; - - if (ZREAD64(*pzlib_filefunc_def,filestream,buf,uReadSize)!=uReadSize) - break; - - for (i=(int)uReadSize-3; (i--)>0;) - if (((*(buf+i))==0x50) && ((*(buf+i+1))==0x4b) && - ((*(buf+i+2))==0x06) && ((*(buf+i+3))==0x07)) - { - uPosFound = uReadPos+i; - break; - } - - if (uPosFound!=0) - break; - } - TRYFREE(buf); - if (uPosFound == 0) - return 0; - - /* Zip64 end of central directory locator */ - if (ZSEEK64(*pzlib_filefunc_def,filestream, uPosFound,ZLIB_FILEFUNC_SEEK_SET)!=0) - return 0; - - /* the signature, already checked */ - if (unz64local_getLong(pzlib_filefunc_def,filestream,&uL)!=UNZ_OK) - return 0; - - /* number of the disk with the start of the zip64 end of central directory */ - if (unz64local_getLong(pzlib_filefunc_def,filestream,&uL)!=UNZ_OK) - return 0; - if (uL != 0) - return 0; - - /* relative offset of the zip64 end of central directory record */ - if (unz64local_getLong64(pzlib_filefunc_def,filestream,&relativeOffset)!=UNZ_OK) - return 0; - - /* total number of disks */ - if (unz64local_getLong(pzlib_filefunc_def,filestream,&uL)!=UNZ_OK) - return 0; - if (uL != 1) - return 0; - - /* Goto end of central directory record */ - if (ZSEEK64(*pzlib_filefunc_def,filestream, relativeOffset,ZLIB_FILEFUNC_SEEK_SET)!=0) - return 0; - - /* the signature */ - if (unz64local_getLong(pzlib_filefunc_def,filestream,&uL)!=UNZ_OK) - return 0; - - if (uL != 0x06064b50) - return 0; - - return relativeOffset; -} - -/* - Open a Zip file. path contain the full pathname (by example, - on a Windows NT computer "c:\\test\\zlib114.zip" or on an Unix computer - "zlib/zlib114.zip". - If the zipfile cannot be opened (file doesn't exist or in not valid), the - return value is NULL. - Else, the return value is a unzFile Handle, usable with other function - of this unzip package. -*/ -local unzFile unzOpenInternal (const void *path, - zlib_filefunc64_32_def* pzlib_filefunc64_32_def, - int is64bitOpenFunction) -{ - unz64_s us; - unz64_s *s; - ZPOS64_T central_pos; - uLong uL; - - uLong number_disk; /* number of the current dist, used for - spaning ZIP, unsupported, always 0*/ - uLong number_disk_with_CD; /* number the the disk with central dir, used - for spaning ZIP, unsupported, always 0*/ - ZPOS64_T number_entry_CD; /* total number of entries in - the central dir - (same than number_entry on nospan) */ - - int err=UNZ_OK; - - if (unz_copyright[0]!=' ') - return NULL; - - us.z_filefunc.zseek32_file = NULL; - us.z_filefunc.ztell32_file = NULL; - if (pzlib_filefunc64_32_def==NULL) - fill_fopen64_filefunc(&us.z_filefunc.zfile_func64); - else - us.z_filefunc = *pzlib_filefunc64_32_def; - us.is64bitOpenFunction = is64bitOpenFunction; - - - - us.filestream = ZOPEN64(us.z_filefunc, - path, - ZLIB_FILEFUNC_MODE_READ | - ZLIB_FILEFUNC_MODE_EXISTING); - if (us.filestream==NULL) - return NULL; - - central_pos = unz64local_SearchCentralDir64(&us.z_filefunc,us.filestream); - if (central_pos) - { - uLong uS; - ZPOS64_T uL64; - - us.isZip64 = 1; - - if (ZSEEK64(us.z_filefunc, us.filestream, - central_pos,ZLIB_FILEFUNC_SEEK_SET)!=0) - err=UNZ_ERRNO; - - /* the signature, already checked */ - if (unz64local_getLong(&us.z_filefunc, us.filestream,&uL)!=UNZ_OK) - err=UNZ_ERRNO; - - /* size of zip64 end of central directory record */ - if (unz64local_getLong64(&us.z_filefunc, us.filestream,&uL64)!=UNZ_OK) - err=UNZ_ERRNO; - - /* version made by */ - if (unz64local_getShort(&us.z_filefunc, us.filestream,&uS)!=UNZ_OK) - err=UNZ_ERRNO; - - /* version needed to extract */ - if (unz64local_getShort(&us.z_filefunc, us.filestream,&uS)!=UNZ_OK) - err=UNZ_ERRNO; - - /* number of this disk */ - if (unz64local_getLong(&us.z_filefunc, us.filestream,&number_disk)!=UNZ_OK) - err=UNZ_ERRNO; - - /* number of the disk with the start of the central directory */ - if (unz64local_getLong(&us.z_filefunc, us.filestream,&number_disk_with_CD)!=UNZ_OK) - err=UNZ_ERRNO; - - /* total number of entries in the central directory on this disk */ - if (unz64local_getLong64(&us.z_filefunc, us.filestream,&us.gi.number_entry)!=UNZ_OK) - err=UNZ_ERRNO; - - /* total number of entries in the central directory */ - if (unz64local_getLong64(&us.z_filefunc, us.filestream,&number_entry_CD)!=UNZ_OK) - err=UNZ_ERRNO; - - if ((number_entry_CD!=us.gi.number_entry) || - (number_disk_with_CD!=0) || - (number_disk!=0)) - err=UNZ_BADZIPFILE; - - /* size of the central directory */ - if (unz64local_getLong64(&us.z_filefunc, us.filestream,&us.size_central_dir)!=UNZ_OK) - err=UNZ_ERRNO; - - /* offset of start of central directory with respect to the - starting disk number */ - if (unz64local_getLong64(&us.z_filefunc, us.filestream,&us.offset_central_dir)!=UNZ_OK) - err=UNZ_ERRNO; - - us.gi.size_comment = 0; - } - else - { - central_pos = unz64local_SearchCentralDir(&us.z_filefunc,us.filestream); - if (central_pos==0) - err=UNZ_ERRNO; - - us.isZip64 = 0; - - if (ZSEEK64(us.z_filefunc, us.filestream, - central_pos,ZLIB_FILEFUNC_SEEK_SET)!=0) - err=UNZ_ERRNO; - - /* the signature, already checked */ - if (unz64local_getLong(&us.z_filefunc, us.filestream,&uL)!=UNZ_OK) - err=UNZ_ERRNO; - - /* number of this disk */ - if (unz64local_getShort(&us.z_filefunc, us.filestream,&number_disk)!=UNZ_OK) - err=UNZ_ERRNO; - - /* number of the disk with the start of the central directory */ - if (unz64local_getShort(&us.z_filefunc, us.filestream,&number_disk_with_CD)!=UNZ_OK) - err=UNZ_ERRNO; - - /* total number of entries in the central dir on this disk */ - if (unz64local_getShort(&us.z_filefunc, us.filestream,&uL)!=UNZ_OK) - err=UNZ_ERRNO; - us.gi.number_entry = uL; - - /* total number of entries in the central dir */ - if (unz64local_getShort(&us.z_filefunc, us.filestream,&uL)!=UNZ_OK) - err=UNZ_ERRNO; - number_entry_CD = uL; - - if ((number_entry_CD!=us.gi.number_entry) || - (number_disk_with_CD!=0) || - (number_disk!=0)) - err=UNZ_BADZIPFILE; - - /* size of the central directory */ - if (unz64local_getLong(&us.z_filefunc, us.filestream,&uL)!=UNZ_OK) - err=UNZ_ERRNO; - us.size_central_dir = uL; - - /* offset of start of central directory with respect to the - starting disk number */ - if (unz64local_getLong(&us.z_filefunc, us.filestream,&uL)!=UNZ_OK) - err=UNZ_ERRNO; - us.offset_central_dir = uL; - - /* zipfile comment length */ - if (unz64local_getShort(&us.z_filefunc, us.filestream,&us.gi.size_comment)!=UNZ_OK) - err=UNZ_ERRNO; - } - - if ((central_pospfile_in_zip_read!=NULL) - unzCloseCurrentFile(file); - - ZCLOSE64(s->z_filefunc, s->filestream); - TRYFREE(s); - return UNZ_OK; -} - - -/* - Write info about the ZipFile in the *pglobal_info structure. - No preparation of the structure is needed - return UNZ_OK if there is no problem. */ -extern int ZEXPORT unzGetGlobalInfo64 (unzFile file, unz_global_info64* pglobal_info) -{ - unz64_s* s; - if (file==NULL) - return UNZ_PARAMERROR; - s=(unz64_s*)file; - *pglobal_info=s->gi; - return UNZ_OK; -} - -extern int ZEXPORT unzGetGlobalInfo (unzFile file, unz_global_info* pglobal_info32) -{ - unz64_s* s; - if (file==NULL) - return UNZ_PARAMERROR; - s=(unz64_s*)file; - /* to do : check if number_entry is not truncated */ - pglobal_info32->number_entry = (uLong)s->gi.number_entry; - pglobal_info32->size_comment = s->gi.size_comment; - return UNZ_OK; -} -/* - Translate date/time from Dos format to tm_unz (readable more easilty) -*/ -local void unz64local_DosDateToTmuDate (ZPOS64_T ulDosDate, tm_unz* ptm) -{ - ZPOS64_T uDate; - uDate = (ZPOS64_T)(ulDosDate>>16); - ptm->tm_mday = (uInt)(uDate&0x1f) ; - ptm->tm_mon = (uInt)((((uDate)&0x1E0)/0x20)-1) ; - ptm->tm_year = (uInt)(((uDate&0x0FE00)/0x0200)+1980) ; - - ptm->tm_hour = (uInt) ((ulDosDate &0xF800)/0x800); - ptm->tm_min = (uInt) ((ulDosDate&0x7E0)/0x20) ; - ptm->tm_sec = (uInt) (2*(ulDosDate&0x1f)) ; -} - -/* - Get Info about the current file in the zipfile, with internal only info -*/ -local int unz64local_GetCurrentFileInfoInternal OF((unzFile file, - unz_file_info64 *pfile_info, - unz_file_info64_internal - *pfile_info_internal, - char *szFileName, - uLong fileNameBufferSize, - void *extraField, - uLong extraFieldBufferSize, - char *szComment, - uLong commentBufferSize)); - -local int unz64local_GetCurrentFileInfoInternal (unzFile file, - unz_file_info64 *pfile_info, - unz_file_info64_internal - *pfile_info_internal, - char *szFileName, - uLong fileNameBufferSize, - void *extraField, - uLong extraFieldBufferSize, - char *szComment, - uLong commentBufferSize) -{ - unz64_s* s; - unz_file_info64 file_info; - unz_file_info64_internal file_info_internal; - int err=UNZ_OK; - uLong uMagic; - long lSeek=0; - uLong uL; - - if (file==NULL) - return UNZ_PARAMERROR; - s=(unz64_s*)file; - if (ZSEEK64(s->z_filefunc, s->filestream, - s->pos_in_central_dir+s->byte_before_the_zipfile, - ZLIB_FILEFUNC_SEEK_SET)!=0) - err=UNZ_ERRNO; - - - /* we check the magic */ - if (err==UNZ_OK) - { - if (unz64local_getLong(&s->z_filefunc, s->filestream,&uMagic) != UNZ_OK) - err=UNZ_ERRNO; - else if (uMagic!=0x02014b50) - err=UNZ_BADZIPFILE; - } - - if (unz64local_getShort(&s->z_filefunc, s->filestream,&file_info.version) != UNZ_OK) - err=UNZ_ERRNO; - - if (unz64local_getShort(&s->z_filefunc, s->filestream,&file_info.version_needed) != UNZ_OK) - err=UNZ_ERRNO; - - if (unz64local_getShort(&s->z_filefunc, s->filestream,&file_info.flag) != UNZ_OK) - err=UNZ_ERRNO; - - if (unz64local_getShort(&s->z_filefunc, s->filestream,&file_info.compression_method) != UNZ_OK) - err=UNZ_ERRNO; - - if (unz64local_getLong(&s->z_filefunc, s->filestream,&file_info.dosDate) != UNZ_OK) - err=UNZ_ERRNO; - - unz64local_DosDateToTmuDate(file_info.dosDate,&file_info.tmu_date); - - if (unz64local_getLong(&s->z_filefunc, s->filestream,&file_info.crc) != UNZ_OK) - err=UNZ_ERRNO; - - if (unz64local_getLong(&s->z_filefunc, s->filestream,&uL) != UNZ_OK) - err=UNZ_ERRNO; - file_info.compressed_size = uL; - - if (unz64local_getLong(&s->z_filefunc, s->filestream,&uL) != UNZ_OK) - err=UNZ_ERRNO; - file_info.uncompressed_size = uL; - - if (unz64local_getShort(&s->z_filefunc, s->filestream,&file_info.size_filename) != UNZ_OK) - err=UNZ_ERRNO; - - if (unz64local_getShort(&s->z_filefunc, s->filestream,&file_info.size_file_extra) != UNZ_OK) - err=UNZ_ERRNO; - - if (unz64local_getShort(&s->z_filefunc, s->filestream,&file_info.size_file_comment) != UNZ_OK) - err=UNZ_ERRNO; - - if (unz64local_getShort(&s->z_filefunc, s->filestream,&file_info.disk_num_start) != UNZ_OK) - err=UNZ_ERRNO; - - if (unz64local_getShort(&s->z_filefunc, s->filestream,&file_info.internal_fa) != UNZ_OK) - err=UNZ_ERRNO; - - if (unz64local_getLong(&s->z_filefunc, s->filestream,&file_info.external_fa) != UNZ_OK) - err=UNZ_ERRNO; - - // relative offset of local header - if (unz64local_getLong(&s->z_filefunc, s->filestream,&uL) != UNZ_OK) - err=UNZ_ERRNO; - file_info_internal.offset_curfile = uL; - - lSeek+=file_info.size_filename; - if ((err==UNZ_OK) && (szFileName!=NULL)) - { - uLong uSizeRead ; - if (file_info.size_filename0) && (fileNameBufferSize>0)) - if (ZREAD64(s->z_filefunc, s->filestream,szFileName,uSizeRead)!=uSizeRead) - err=UNZ_ERRNO; - lSeek -= uSizeRead; - } - - // Read extrafield - if ((err==UNZ_OK) && (extraField!=NULL)) - { - ZPOS64_T uSizeRead ; - if (file_info.size_file_extraz_filefunc, s->filestream,lSeek,ZLIB_FILEFUNC_SEEK_CUR)==0) - lSeek=0; - else - err=UNZ_ERRNO; - } - - if ((file_info.size_file_extra>0) && (extraFieldBufferSize>0)) - if (ZREAD64(s->z_filefunc, s->filestream,extraField,(uLong)uSizeRead)!=uSizeRead) - err=UNZ_ERRNO; - - lSeek += file_info.size_file_extra - (uLong)uSizeRead; - } - else - lSeek += file_info.size_file_extra; - - - if ((err==UNZ_OK) && (file_info.size_file_extra != 0)) - { - uLong acc = 0; - - // since lSeek now points to after the extra field we need to move back - lSeek -= file_info.size_file_extra; - - if (lSeek!=0) - { - if (ZSEEK64(s->z_filefunc, s->filestream,lSeek,ZLIB_FILEFUNC_SEEK_CUR)==0) - lSeek=0; - else - err=UNZ_ERRNO; - } - - while(acc < file_info.size_file_extra) - { - uLong headerId; - uLong dataSize; - - if (unz64local_getShort(&s->z_filefunc, s->filestream,&headerId) != UNZ_OK) - err=UNZ_ERRNO; - - if (unz64local_getShort(&s->z_filefunc, s->filestream,&dataSize) != UNZ_OK) - err=UNZ_ERRNO; - - /* ZIP64 extra fields */ - if (headerId == 0x0001) - { - uLong uL; - - if(file_info.uncompressed_size == MAXU32) - { - if (unz64local_getLong64(&s->z_filefunc, s->filestream,&file_info.uncompressed_size) != UNZ_OK) - err=UNZ_ERRNO; - } - - if(file_info.compressed_size == MAXU32) - { - if (unz64local_getLong64(&s->z_filefunc, s->filestream,&file_info.compressed_size) != UNZ_OK) - err=UNZ_ERRNO; - } - - if(file_info_internal.offset_curfile == MAXU32) - { - /* Relative Header offset */ - if (unz64local_getLong64(&s->z_filefunc, s->filestream,&file_info_internal.offset_curfile) != UNZ_OK) - err=UNZ_ERRNO; - } - - if(file_info.disk_num_start == MAXU32) - { - /* Disk Start Number */ - if (unz64local_getLong(&s->z_filefunc, s->filestream,&uL) != UNZ_OK) - err=UNZ_ERRNO; - } - - } - else - { - if (ZSEEK64(s->z_filefunc, s->filestream,dataSize,ZLIB_FILEFUNC_SEEK_CUR)!=0) - err=UNZ_ERRNO; - } - - acc += 2 + 2 + dataSize; - } - } - - if ((err==UNZ_OK) && (szComment!=NULL)) - { - uLong uSizeRead ; - if (file_info.size_file_commentz_filefunc, s->filestream,lSeek,ZLIB_FILEFUNC_SEEK_CUR)==0) - lSeek=0; - else - err=UNZ_ERRNO; - } - - if ((file_info.size_file_comment>0) && (commentBufferSize>0)) - if (ZREAD64(s->z_filefunc, s->filestream,szComment,uSizeRead)!=uSizeRead) - err=UNZ_ERRNO; - lSeek+=file_info.size_file_comment - uSizeRead; - } - else - lSeek+=file_info.size_file_comment; - - - if ((err==UNZ_OK) && (pfile_info!=NULL)) - *pfile_info=file_info; - - if ((err==UNZ_OK) && (pfile_info_internal!=NULL)) - *pfile_info_internal=file_info_internal; - - return err; -} - - - -/* - Write info about the ZipFile in the *pglobal_info structure. - No preparation of the structure is needed - return UNZ_OK if there is no problem. -*/ -extern int ZEXPORT unzGetCurrentFileInfo64 (unzFile file, - unz_file_info64 * pfile_info, - char * szFileName, uLong fileNameBufferSize, - void *extraField, uLong extraFieldBufferSize, - char* szComment, uLong commentBufferSize) -{ - return unz64local_GetCurrentFileInfoInternal(file,pfile_info,NULL, - szFileName,fileNameBufferSize, - extraField,extraFieldBufferSize, - szComment,commentBufferSize); -} - -extern int ZEXPORT unzGetCurrentFileInfo (unzFile file, - unz_file_info * pfile_info, - char * szFileName, uLong fileNameBufferSize, - void *extraField, uLong extraFieldBufferSize, - char* szComment, uLong commentBufferSize) -{ - int err; - unz_file_info64 file_info64; - err = unz64local_GetCurrentFileInfoInternal(file,&file_info64,NULL, - szFileName,fileNameBufferSize, - extraField,extraFieldBufferSize, - szComment,commentBufferSize); - if ((err==UNZ_OK) && (pfile_info != NULL)) - { - pfile_info->version = file_info64.version; - pfile_info->version_needed = file_info64.version_needed; - pfile_info->flag = file_info64.flag; - pfile_info->compression_method = file_info64.compression_method; - pfile_info->dosDate = file_info64.dosDate; - pfile_info->crc = file_info64.crc; - - pfile_info->size_filename = file_info64.size_filename; - pfile_info->size_file_extra = file_info64.size_file_extra; - pfile_info->size_file_comment = file_info64.size_file_comment; - - pfile_info->disk_num_start = file_info64.disk_num_start; - pfile_info->internal_fa = file_info64.internal_fa; - pfile_info->external_fa = file_info64.external_fa; - - pfile_info->tmu_date = file_info64.tmu_date, - - - pfile_info->compressed_size = (uLong)file_info64.compressed_size; - pfile_info->uncompressed_size = (uLong)file_info64.uncompressed_size; - - } - return err; -} -/* - Set the current file of the zipfile to the first file. - return UNZ_OK if there is no problem -*/ -extern int ZEXPORT unzGoToFirstFile (unzFile file) -{ - int err=UNZ_OK; - unz64_s* s; - if (file==NULL) - return UNZ_PARAMERROR; - s=(unz64_s*)file; - s->pos_in_central_dir=s->offset_central_dir; - s->num_file=0; - err=unz64local_GetCurrentFileInfoInternal(file,&s->cur_file_info, - &s->cur_file_info_internal, - NULL,0,NULL,0,NULL,0); - s->current_file_ok = (err == UNZ_OK); - return err; -} - -/* - Set the current file of the zipfile to the next file. - return UNZ_OK if there is no problem - return UNZ_END_OF_LIST_OF_FILE if the actual file was the latest. -*/ -extern int ZEXPORT unzGoToNextFile (unzFile file) -{ - unz64_s* s; - int err; - - if (file==NULL) - return UNZ_PARAMERROR; - s=(unz64_s*)file; - if (!s->current_file_ok) - return UNZ_END_OF_LIST_OF_FILE; - if (s->gi.number_entry != 0xffff) /* 2^16 files overflow hack */ - if (s->num_file+1==s->gi.number_entry) - return UNZ_END_OF_LIST_OF_FILE; - - s->pos_in_central_dir += SIZECENTRALDIRITEM + s->cur_file_info.size_filename + - s->cur_file_info.size_file_extra + s->cur_file_info.size_file_comment ; - s->num_file++; - err = unz64local_GetCurrentFileInfoInternal(file,&s->cur_file_info, - &s->cur_file_info_internal, - NULL,0,NULL,0,NULL,0); - s->current_file_ok = (err == UNZ_OK); - return err; -} - - -/* - Try locate the file szFileName in the zipfile. - For the iCaseSensitivity signification, see unzStringFileNameCompare - - return value : - UNZ_OK if the file is found. It becomes the current file. - UNZ_END_OF_LIST_OF_FILE if the file is not found -*/ -extern int ZEXPORT unzLocateFile (unzFile file, const char *szFileName, int iCaseSensitivity) -{ - unz64_s* s; - int err; - - /* We remember the 'current' position in the file so that we can jump - * back there if we fail. - */ - unz_file_info64 cur_file_infoSaved; - unz_file_info64_internal cur_file_info_internalSaved; - ZPOS64_T num_fileSaved; - ZPOS64_T pos_in_central_dirSaved; - - - if (file==NULL) - return UNZ_PARAMERROR; - - if (strlen(szFileName)>=UNZ_MAXFILENAMEINZIP) - return UNZ_PARAMERROR; - - s=(unz64_s*)file; - if (!s->current_file_ok) - return UNZ_END_OF_LIST_OF_FILE; - - /* Save the current state */ - num_fileSaved = s->num_file; - pos_in_central_dirSaved = s->pos_in_central_dir; - cur_file_infoSaved = s->cur_file_info; - cur_file_info_internalSaved = s->cur_file_info_internal; - - err = unzGoToFirstFile(file); - - while (err == UNZ_OK) - { - char szCurrentFileName[UNZ_MAXFILENAMEINZIP+1]; - err = unzGetCurrentFileInfo64(file,NULL, - szCurrentFileName,sizeof(szCurrentFileName)-1, - NULL,0,NULL,0); - if (err == UNZ_OK) - { - if (unzStringFileNameCompare(szCurrentFileName, - szFileName,iCaseSensitivity)==0) - return UNZ_OK; - err = unzGoToNextFile(file); - } - } - - /* We failed, so restore the state of the 'current file' to where we - * were. - */ - s->num_file = num_fileSaved ; - s->pos_in_central_dir = pos_in_central_dirSaved ; - s->cur_file_info = cur_file_infoSaved; - s->cur_file_info_internal = cur_file_info_internalSaved; - return err; -} - - -/* -/////////////////////////////////////////// -// Contributed by Ryan Haksi (mailto://cryogen@infoserve.net) -// I need random access -// -// Further optimization could be realized by adding an ability -// to cache the directory in memory. The goal being a single -// comprehensive file read to put the file I need in a memory. -*/ - -/* -typedef struct unz_file_pos_s -{ - ZPOS64_T pos_in_zip_directory; // offset in file - ZPOS64_T num_of_file; // # of file -} unz_file_pos; -*/ - -extern int ZEXPORT unzGetFilePos64(unzFile file, unz64_file_pos* file_pos) -{ - unz64_s* s; - - if (file==NULL || file_pos==NULL) - return UNZ_PARAMERROR; - s=(unz64_s*)file; - if (!s->current_file_ok) - return UNZ_END_OF_LIST_OF_FILE; - - file_pos->pos_in_zip_directory = s->pos_in_central_dir; - file_pos->num_of_file = s->num_file; - - return UNZ_OK; -} - -extern int ZEXPORT unzGetFilePos( - unzFile file, - unz_file_pos* file_pos) -{ - unz64_file_pos file_pos64; - int err = unzGetFilePos64(file,&file_pos64); - if (err==UNZ_OK) - { - file_pos->pos_in_zip_directory = (uLong)file_pos64.pos_in_zip_directory; - file_pos->num_of_file = (uLong)file_pos64.num_of_file; - } - return err; -} - -extern int ZEXPORT unzGoToFilePos64(unzFile file, const unz64_file_pos* file_pos) -{ - unz64_s* s; - int err; - - if (file==NULL || file_pos==NULL) - return UNZ_PARAMERROR; - s=(unz64_s*)file; - - /* jump to the right spot */ - s->pos_in_central_dir = file_pos->pos_in_zip_directory; - s->num_file = file_pos->num_of_file; - - /* set the current file */ - err = unz64local_GetCurrentFileInfoInternal(file,&s->cur_file_info, - &s->cur_file_info_internal, - NULL,0,NULL,0,NULL,0); - /* return results */ - s->current_file_ok = (err == UNZ_OK); - return err; -} - -extern int ZEXPORT unzGoToFilePos( - unzFile file, - unz_file_pos* file_pos) -{ - unz64_file_pos file_pos64; - if (file_pos == NULL) - return UNZ_PARAMERROR; - - file_pos64.pos_in_zip_directory = file_pos->pos_in_zip_directory; - file_pos64.num_of_file = file_pos->num_of_file; - return unzGoToFilePos64(file,&file_pos64); -} - -/* -// Unzip Helper Functions - should be here? -/////////////////////////////////////////// -*/ - -/* - Read the local header of the current zipfile - Check the coherency of the local header and info in the end of central - directory about this file - store in *piSizeVar the size of extra info in local header - (filename and size of extra field data) -*/ -local int unz64local_CheckCurrentFileCoherencyHeader (unz64_s* s, uInt* piSizeVar, - ZPOS64_T * poffset_local_extrafield, - uInt * psize_local_extrafield) -{ - uLong uMagic,uData,uFlags; - uLong size_filename; - uLong size_extra_field; - int err=UNZ_OK; - - *piSizeVar = 0; - *poffset_local_extrafield = 0; - *psize_local_extrafield = 0; - - if (ZSEEK64(s->z_filefunc, s->filestream,s->cur_file_info_internal.offset_curfile + - s->byte_before_the_zipfile,ZLIB_FILEFUNC_SEEK_SET)!=0) - return UNZ_ERRNO; - - - if (err==UNZ_OK) - { - if (unz64local_getLong(&s->z_filefunc, s->filestream,&uMagic) != UNZ_OK) - err=UNZ_ERRNO; - else if (uMagic!=0x04034b50) - err=UNZ_BADZIPFILE; - } - - if (unz64local_getShort(&s->z_filefunc, s->filestream,&uData) != UNZ_OK) - err=UNZ_ERRNO; -/* - else if ((err==UNZ_OK) && (uData!=s->cur_file_info.wVersion)) - err=UNZ_BADZIPFILE; -*/ - if (unz64local_getShort(&s->z_filefunc, s->filestream,&uFlags) != UNZ_OK) - err=UNZ_ERRNO; - - if (unz64local_getShort(&s->z_filefunc, s->filestream,&uData) != UNZ_OK) - err=UNZ_ERRNO; - else if ((err==UNZ_OK) && (uData!=s->cur_file_info.compression_method)) - err=UNZ_BADZIPFILE; - - if ((err==UNZ_OK) && (s->cur_file_info.compression_method!=0) && -/* #ifdef HAVE_BZIP2 */ - (s->cur_file_info.compression_method!=Z_BZIP2ED) && -/* #endif */ - (s->cur_file_info.compression_method!=Z_DEFLATED)) - err=UNZ_BADZIPFILE; - - if (unz64local_getLong(&s->z_filefunc, s->filestream,&uData) != UNZ_OK) /* date/time */ - err=UNZ_ERRNO; - - if (unz64local_getLong(&s->z_filefunc, s->filestream,&uData) != UNZ_OK) /* crc */ - err=UNZ_ERRNO; - else if ((err==UNZ_OK) && (uData!=s->cur_file_info.crc) && ((uFlags & 8)==0)) - err=UNZ_BADZIPFILE; - - if (unz64local_getLong(&s->z_filefunc, s->filestream,&uData) != UNZ_OK) /* size compr */ - err=UNZ_ERRNO; - else if (uData != 0xFFFFFFFF && (err==UNZ_OK) && (uData!=s->cur_file_info.compressed_size) && ((uFlags & 8)==0)) - err=UNZ_BADZIPFILE; - - if (unz64local_getLong(&s->z_filefunc, s->filestream,&uData) != UNZ_OK) /* size uncompr */ - err=UNZ_ERRNO; - else if (uData != 0xFFFFFFFF && (err==UNZ_OK) && (uData!=s->cur_file_info.uncompressed_size) && ((uFlags & 8)==0)) - err=UNZ_BADZIPFILE; - - if (unz64local_getShort(&s->z_filefunc, s->filestream,&size_filename) != UNZ_OK) - err=UNZ_ERRNO; - else if ((err==UNZ_OK) && (size_filename!=s->cur_file_info.size_filename)) - err=UNZ_BADZIPFILE; - - *piSizeVar += (uInt)size_filename; - - if (unz64local_getShort(&s->z_filefunc, s->filestream,&size_extra_field) != UNZ_OK) - err=UNZ_ERRNO; - *poffset_local_extrafield= s->cur_file_info_internal.offset_curfile + - SIZEZIPLOCALHEADER + size_filename; - *psize_local_extrafield = (uInt)size_extra_field; - - *piSizeVar += (uInt)size_extra_field; - - return err; -} - -/* - Open for reading data the current file in the zipfile. - If there is no error and the file is opened, the return value is UNZ_OK. -*/ -extern int ZEXPORT unzOpenCurrentFile3 (unzFile file, int* method, - int* level, int raw, const char* password) -{ - int err=UNZ_OK; - uInt iSizeVar; - unz64_s* s; - file_in_zip64_read_info_s* pfile_in_zip_read_info; - ZPOS64_T offset_local_extrafield; /* offset of the local extra field */ - uInt size_local_extrafield; /* size of the local extra field */ -# ifndef NOUNCRYPT - char source[12]; -# else - if (password != NULL) - return UNZ_PARAMERROR; -# endif - - if (file==NULL) - return UNZ_PARAMERROR; - s=(unz64_s*)file; - if (!s->current_file_ok) - return UNZ_PARAMERROR; - - if (s->pfile_in_zip_read != NULL) - unzCloseCurrentFile(file); - - if (unz64local_CheckCurrentFileCoherencyHeader(s,&iSizeVar, &offset_local_extrafield,&size_local_extrafield)!=UNZ_OK) - return UNZ_BADZIPFILE; - - pfile_in_zip_read_info = (file_in_zip64_read_info_s*)ALLOC(sizeof(file_in_zip64_read_info_s)); - if (pfile_in_zip_read_info==NULL) - return UNZ_INTERNALERROR; - - pfile_in_zip_read_info->read_buffer=(char*)ALLOC(UNZ_BUFSIZE); - pfile_in_zip_read_info->offset_local_extrafield = offset_local_extrafield; - pfile_in_zip_read_info->size_local_extrafield = size_local_extrafield; - pfile_in_zip_read_info->pos_local_extrafield=0; - pfile_in_zip_read_info->raw=raw; - - if (pfile_in_zip_read_info->read_buffer==NULL) - { - TRYFREE(pfile_in_zip_read_info); - return UNZ_INTERNALERROR; - } - - pfile_in_zip_read_info->stream_initialised=0; - - if (method!=NULL) - *method = (int)s->cur_file_info.compression_method; - - if (level!=NULL) - { - *level = 6; - switch (s->cur_file_info.flag & 0x06) - { - case 6 : *level = 1; break; - case 4 : *level = 2; break; - case 2 : *level = 9; break; - } - } - - if ((s->cur_file_info.compression_method!=0) && -/* #ifdef HAVE_BZIP2 */ - (s->cur_file_info.compression_method!=Z_BZIP2ED) && -/* #endif */ - (s->cur_file_info.compression_method!=Z_DEFLATED)) - - err=UNZ_BADZIPFILE; - - pfile_in_zip_read_info->crc32_wait=s->cur_file_info.crc; - pfile_in_zip_read_info->crc32=0; - pfile_in_zip_read_info->total_out_64=0; - pfile_in_zip_read_info->compression_method = s->cur_file_info.compression_method; - pfile_in_zip_read_info->filestream=s->filestream; - pfile_in_zip_read_info->z_filefunc=s->z_filefunc; - pfile_in_zip_read_info->byte_before_the_zipfile=s->byte_before_the_zipfile; - - pfile_in_zip_read_info->stream.total_out = 0; - - if ((s->cur_file_info.compression_method==Z_BZIP2ED) && (!raw)) - { -#ifdef HAVE_BZIP2 - pfile_in_zip_read_info->bstream.bzalloc = (void *(*) (void *, int, int))0; - pfile_in_zip_read_info->bstream.bzfree = (free_func)0; - pfile_in_zip_read_info->bstream.opaque = (voidpf)0; - pfile_in_zip_read_info->bstream.state = (voidpf)0; - - pfile_in_zip_read_info->stream.zalloc = (alloc_func)0; - pfile_in_zip_read_info->stream.zfree = (free_func)0; - pfile_in_zip_read_info->stream.opaque = (voidpf)0; - pfile_in_zip_read_info->stream.next_in = (voidpf)0; - pfile_in_zip_read_info->stream.avail_in = 0; - - err=BZ2_bzDecompressInit(&pfile_in_zip_read_info->bstream, 0, 0); - if (err == Z_OK) - pfile_in_zip_read_info->stream_initialised=Z_BZIP2ED; - else - { - TRYFREE(pfile_in_zip_read_info); - return err; - } -#else - pfile_in_zip_read_info->raw=1; -#endif - } - else if ((s->cur_file_info.compression_method==Z_DEFLATED) && (!raw)) - { - pfile_in_zip_read_info->stream.zalloc = (alloc_func)0; - pfile_in_zip_read_info->stream.zfree = (free_func)0; - pfile_in_zip_read_info->stream.opaque = (voidpf)0; - pfile_in_zip_read_info->stream.next_in = 0; - pfile_in_zip_read_info->stream.avail_in = 0; - - err=inflateInit2(&pfile_in_zip_read_info->stream, -MAX_WBITS); - if (err == Z_OK) - pfile_in_zip_read_info->stream_initialised=Z_DEFLATED; - else - { - TRYFREE(pfile_in_zip_read_info); - return err; - } - /* windowBits is passed < 0 to tell that there is no zlib header. - * Note that in this case inflate *requires* an extra "dummy" byte - * after the compressed stream in order to complete decompression and - * return Z_STREAM_END. - * In unzip, i don't wait absolutely Z_STREAM_END because I known the - * size of both compressed and uncompressed data - */ - } - pfile_in_zip_read_info->rest_read_compressed = - s->cur_file_info.compressed_size ; - pfile_in_zip_read_info->rest_read_uncompressed = - s->cur_file_info.uncompressed_size ; - - - pfile_in_zip_read_info->pos_in_zipfile = - s->cur_file_info_internal.offset_curfile + SIZEZIPLOCALHEADER + - iSizeVar; - - pfile_in_zip_read_info->stream.avail_in = (uInt)0; - - s->pfile_in_zip_read = pfile_in_zip_read_info; - s->encrypted = 0; - -# ifndef NOUNCRYPT - if (password != NULL) - { - int i; - s->pcrc_32_tab = get_crc_table(); - init_keys(password,s->keys,s->pcrc_32_tab); - if (ZSEEK64(s->z_filefunc, s->filestream, - s->pfile_in_zip_read->pos_in_zipfile + - s->pfile_in_zip_read->byte_before_the_zipfile, - SEEK_SET)!=0) - return UNZ_INTERNALERROR; - if(ZREAD64(s->z_filefunc, s->filestream,source, 12)<12) - return UNZ_INTERNALERROR; - - for (i = 0; i<12; i++) - zdecode(s->keys,s->pcrc_32_tab,source[i]); - - s->pfile_in_zip_read->pos_in_zipfile+=12; - s->encrypted=1; - } -# endif - - - return UNZ_OK; -} - -extern int ZEXPORT unzOpenCurrentFile (unzFile file) -{ - return unzOpenCurrentFile3(file, NULL, NULL, 0, NULL); -} - -extern int ZEXPORT unzOpenCurrentFilePassword (unzFile file, const char* password) -{ - return unzOpenCurrentFile3(file, NULL, NULL, 0, password); -} - -extern int ZEXPORT unzOpenCurrentFile2 (unzFile file, int* method, int* level, int raw) -{ - return unzOpenCurrentFile3(file, method, level, raw, NULL); -} - -/** Addition for GDAL : START */ - -extern ZPOS64_T ZEXPORT unzGetCurrentFileZStreamPos64( unzFile file) -{ - unz64_s* s; - file_in_zip64_read_info_s* pfile_in_zip_read_info; - s=(unz64_s*)file; - if (file==NULL) - return 0; //UNZ_PARAMERROR; - pfile_in_zip_read_info=s->pfile_in_zip_read; - if (pfile_in_zip_read_info==NULL) - return 0; //UNZ_PARAMERROR; - return pfile_in_zip_read_info->pos_in_zipfile + - pfile_in_zip_read_info->byte_before_the_zipfile; -} - -/** Addition for GDAL : END */ - -/* - Read bytes from the current file. - buf contain buffer where data must be copied - len the size of buf. - - return the number of byte copied if somes bytes are copied - return 0 if the end of file was reached - return <0 with error code if there is an error - (UNZ_ERRNO for IO error, or zLib error for uncompress error) -*/ -extern int ZEXPORT unzReadCurrentFile (unzFile file, voidp buf, unsigned len) -{ - int err=UNZ_OK; - uInt iRead = 0; - unz64_s* s; - file_in_zip64_read_info_s* pfile_in_zip_read_info; - if (file==NULL) - return UNZ_PARAMERROR; - s=(unz64_s*)file; - pfile_in_zip_read_info=s->pfile_in_zip_read; - - if (pfile_in_zip_read_info==NULL) - return UNZ_PARAMERROR; - - - if (pfile_in_zip_read_info->read_buffer == NULL) - return UNZ_END_OF_LIST_OF_FILE; - if (len==0) - return 0; - - pfile_in_zip_read_info->stream.next_out = (Bytef*)buf; - - pfile_in_zip_read_info->stream.avail_out = (uInt)len; - - if ((len>pfile_in_zip_read_info->rest_read_uncompressed) && - (!(pfile_in_zip_read_info->raw))) - pfile_in_zip_read_info->stream.avail_out = - (uInt)pfile_in_zip_read_info->rest_read_uncompressed; - - if ((len>pfile_in_zip_read_info->rest_read_compressed+ - pfile_in_zip_read_info->stream.avail_in) && - (pfile_in_zip_read_info->raw)) - pfile_in_zip_read_info->stream.avail_out = - (uInt)pfile_in_zip_read_info->rest_read_compressed+ - pfile_in_zip_read_info->stream.avail_in; - - while (pfile_in_zip_read_info->stream.avail_out>0) - { - if ((pfile_in_zip_read_info->stream.avail_in==0) && - (pfile_in_zip_read_info->rest_read_compressed>0)) - { - uInt uReadThis = UNZ_BUFSIZE; - if (pfile_in_zip_read_info->rest_read_compressedrest_read_compressed; - if (uReadThis == 0) - return UNZ_EOF; - if (ZSEEK64(pfile_in_zip_read_info->z_filefunc, - pfile_in_zip_read_info->filestream, - pfile_in_zip_read_info->pos_in_zipfile + - pfile_in_zip_read_info->byte_before_the_zipfile, - ZLIB_FILEFUNC_SEEK_SET)!=0) - return UNZ_ERRNO; - if (ZREAD64(pfile_in_zip_read_info->z_filefunc, - pfile_in_zip_read_info->filestream, - pfile_in_zip_read_info->read_buffer, - uReadThis)!=uReadThis) - return UNZ_ERRNO; - - -# ifndef NOUNCRYPT - if(s->encrypted) - { - uInt i; - for(i=0;iread_buffer[i] = - zdecode(s->keys,s->pcrc_32_tab, - pfile_in_zip_read_info->read_buffer[i]); - } -# endif - - - pfile_in_zip_read_info->pos_in_zipfile += uReadThis; - - pfile_in_zip_read_info->rest_read_compressed-=uReadThis; - - pfile_in_zip_read_info->stream.next_in = - (Bytef*)pfile_in_zip_read_info->read_buffer; - pfile_in_zip_read_info->stream.avail_in = (uInt)uReadThis; - } - - if ((pfile_in_zip_read_info->compression_method==0) || (pfile_in_zip_read_info->raw)) - { - uInt uDoCopy,i ; - - if ((pfile_in_zip_read_info->stream.avail_in == 0) && - (pfile_in_zip_read_info->rest_read_compressed == 0)) - return (iRead==0) ? UNZ_EOF : iRead; - - if (pfile_in_zip_read_info->stream.avail_out < - pfile_in_zip_read_info->stream.avail_in) - uDoCopy = pfile_in_zip_read_info->stream.avail_out ; - else - uDoCopy = pfile_in_zip_read_info->stream.avail_in ; - - for (i=0;istream.next_out+i) = - *(pfile_in_zip_read_info->stream.next_in+i); - - pfile_in_zip_read_info->total_out_64 = pfile_in_zip_read_info->total_out_64 + uDoCopy; - - pfile_in_zip_read_info->crc32 = crc32(pfile_in_zip_read_info->crc32, - pfile_in_zip_read_info->stream.next_out, - uDoCopy); - pfile_in_zip_read_info->rest_read_uncompressed-=uDoCopy; - pfile_in_zip_read_info->stream.avail_in -= uDoCopy; - pfile_in_zip_read_info->stream.avail_out -= uDoCopy; - pfile_in_zip_read_info->stream.next_out += uDoCopy; - pfile_in_zip_read_info->stream.next_in += uDoCopy; - pfile_in_zip_read_info->stream.total_out += uDoCopy; - iRead += uDoCopy; - } - else if (pfile_in_zip_read_info->compression_method==Z_BZIP2ED) - { -#ifdef HAVE_BZIP2 - uLong uTotalOutBefore,uTotalOutAfter; - const Bytef *bufBefore; - uLong uOutThis; - - pfile_in_zip_read_info->bstream.next_in = (char*)pfile_in_zip_read_info->stream.next_in; - pfile_in_zip_read_info->bstream.avail_in = pfile_in_zip_read_info->stream.avail_in; - pfile_in_zip_read_info->bstream.total_in_lo32 = pfile_in_zip_read_info->stream.total_in; - pfile_in_zip_read_info->bstream.total_in_hi32 = 0; - pfile_in_zip_read_info->bstream.next_out = (char*)pfile_in_zip_read_info->stream.next_out; - pfile_in_zip_read_info->bstream.avail_out = pfile_in_zip_read_info->stream.avail_out; - pfile_in_zip_read_info->bstream.total_out_lo32 = pfile_in_zip_read_info->stream.total_out; - pfile_in_zip_read_info->bstream.total_out_hi32 = 0; - - uTotalOutBefore = pfile_in_zip_read_info->bstream.total_out_lo32; - bufBefore = (const Bytef *)pfile_in_zip_read_info->bstream.next_out; - - err=BZ2_bzDecompress(&pfile_in_zip_read_info->bstream); - - uTotalOutAfter = pfile_in_zip_read_info->bstream.total_out_lo32; - uOutThis = uTotalOutAfter-uTotalOutBefore; - - pfile_in_zip_read_info->total_out_64 = pfile_in_zip_read_info->total_out_64 + uOutThis; - - pfile_in_zip_read_info->crc32 = crc32(pfile_in_zip_read_info->crc32,bufBefore, (uInt)(uOutThis)); - pfile_in_zip_read_info->rest_read_uncompressed -= uOutThis; - iRead += (uInt)(uTotalOutAfter - uTotalOutBefore); - - pfile_in_zip_read_info->stream.next_in = (Bytef*)pfile_in_zip_read_info->bstream.next_in; - pfile_in_zip_read_info->stream.avail_in = pfile_in_zip_read_info->bstream.avail_in; - pfile_in_zip_read_info->stream.total_in = pfile_in_zip_read_info->bstream.total_in_lo32; - pfile_in_zip_read_info->stream.next_out = (Bytef*)pfile_in_zip_read_info->bstream.next_out; - pfile_in_zip_read_info->stream.avail_out = pfile_in_zip_read_info->bstream.avail_out; - pfile_in_zip_read_info->stream.total_out = pfile_in_zip_read_info->bstream.total_out_lo32; - - if (err==BZ_STREAM_END) - return (iRead==0) ? UNZ_EOF : iRead; - if (err!=BZ_OK) - break; -#endif - } // end Z_BZIP2ED - else - { - ZPOS64_T uTotalOutBefore,uTotalOutAfter; - const Bytef *bufBefore; - ZPOS64_T uOutThis; - int flush=Z_SYNC_FLUSH; - - uTotalOutBefore = pfile_in_zip_read_info->stream.total_out; - bufBefore = pfile_in_zip_read_info->stream.next_out; - - /* - if ((pfile_in_zip_read_info->rest_read_uncompressed == - pfile_in_zip_read_info->stream.avail_out) && - (pfile_in_zip_read_info->rest_read_compressed == 0)) - flush = Z_FINISH; - */ - err=inflate(&pfile_in_zip_read_info->stream,flush); - - if ((err>=0) && (pfile_in_zip_read_info->stream.msg!=NULL)) - err = Z_DATA_ERROR; - - uTotalOutAfter = pfile_in_zip_read_info->stream.total_out; - uOutThis = uTotalOutAfter-uTotalOutBefore; - - pfile_in_zip_read_info->total_out_64 = pfile_in_zip_read_info->total_out_64 + uOutThis; - - pfile_in_zip_read_info->crc32 = - crc32(pfile_in_zip_read_info->crc32,bufBefore, - (uInt)(uOutThis)); - - pfile_in_zip_read_info->rest_read_uncompressed -= - uOutThis; - - iRead += (uInt)(uTotalOutAfter - uTotalOutBefore); - - if (err==Z_STREAM_END) - return (iRead==0) ? UNZ_EOF : iRead; - if (err!=Z_OK) - break; - } - } - - if (err==Z_OK) - return iRead; - return err; -} - - -/* - Give the current position in uncompressed data -*/ -extern z_off_t ZEXPORT unztell (unzFile file) -{ - unz64_s* s; - file_in_zip64_read_info_s* pfile_in_zip_read_info; - if (file==NULL) - return UNZ_PARAMERROR; - s=(unz64_s*)file; - pfile_in_zip_read_info=s->pfile_in_zip_read; - - if (pfile_in_zip_read_info==NULL) - return UNZ_PARAMERROR; - - return (z_off_t)pfile_in_zip_read_info->stream.total_out; -} - -extern ZPOS64_T ZEXPORT unztell64 (unzFile file) -{ - - unz64_s* s; - file_in_zip64_read_info_s* pfile_in_zip_read_info; - if (file==NULL) - return (ZPOS64_T)-1; - s=(unz64_s*)file; - pfile_in_zip_read_info=s->pfile_in_zip_read; - - if (pfile_in_zip_read_info==NULL) - return (ZPOS64_T)-1; - - return pfile_in_zip_read_info->total_out_64; -} - - -/* - return 1 if the end of file was reached, 0 elsewhere -*/ -extern int ZEXPORT unzeof (unzFile file) -{ - unz64_s* s; - file_in_zip64_read_info_s* pfile_in_zip_read_info; - if (file==NULL) - return UNZ_PARAMERROR; - s=(unz64_s*)file; - pfile_in_zip_read_info=s->pfile_in_zip_read; - - if (pfile_in_zip_read_info==NULL) - return UNZ_PARAMERROR; - - if (pfile_in_zip_read_info->rest_read_uncompressed == 0) - return 1; - else - return 0; -} - - - -/* -Read extra field from the current file (opened by unzOpenCurrentFile) -This is the local-header version of the extra field (sometimes, there is -more info in the local-header version than in the central-header) - - if buf==NULL, it return the size of the local extra field that can be read - - if buf!=NULL, len is the size of the buffer, the extra header is copied in - buf. - the return value is the number of bytes copied in buf, or (if <0) - the error code -*/ -extern int ZEXPORT unzGetLocalExtrafield (unzFile file, voidp buf, unsigned len) -{ - unz64_s* s; - file_in_zip64_read_info_s* pfile_in_zip_read_info; - uInt read_now; - ZPOS64_T size_to_read; - - if (file==NULL) - return UNZ_PARAMERROR; - s=(unz64_s*)file; - pfile_in_zip_read_info=s->pfile_in_zip_read; - - if (pfile_in_zip_read_info==NULL) - return UNZ_PARAMERROR; - - size_to_read = (pfile_in_zip_read_info->size_local_extrafield - - pfile_in_zip_read_info->pos_local_extrafield); - - if (buf==NULL) - return (int)size_to_read; - - if (len>size_to_read) - read_now = (uInt)size_to_read; - else - read_now = (uInt)len ; - - if (read_now==0) - return 0; - - if (ZSEEK64(pfile_in_zip_read_info->z_filefunc, - pfile_in_zip_read_info->filestream, - pfile_in_zip_read_info->offset_local_extrafield + - pfile_in_zip_read_info->pos_local_extrafield, - ZLIB_FILEFUNC_SEEK_SET)!=0) - return UNZ_ERRNO; - - if (ZREAD64(pfile_in_zip_read_info->z_filefunc, - pfile_in_zip_read_info->filestream, - buf,read_now)!=read_now) - return UNZ_ERRNO; - - return (int)read_now; -} - -/* - Close the file in zip opened with unzOpenCurrentFile - Return UNZ_CRCERROR if all the file was read but the CRC is not good -*/ -extern int ZEXPORT unzCloseCurrentFile (unzFile file) -{ - int err=UNZ_OK; - - unz64_s* s; - file_in_zip64_read_info_s* pfile_in_zip_read_info; - if (file==NULL) - return UNZ_PARAMERROR; - s=(unz64_s*)file; - pfile_in_zip_read_info=s->pfile_in_zip_read; - - if (pfile_in_zip_read_info==NULL) - return UNZ_PARAMERROR; - - - if ((pfile_in_zip_read_info->rest_read_uncompressed == 0) && - (!pfile_in_zip_read_info->raw)) - { - if (pfile_in_zip_read_info->crc32 != pfile_in_zip_read_info->crc32_wait) - err=UNZ_CRCERROR; - } - - - TRYFREE(pfile_in_zip_read_info->read_buffer); - pfile_in_zip_read_info->read_buffer = NULL; - if (pfile_in_zip_read_info->stream_initialised == Z_DEFLATED) - inflateEnd(&pfile_in_zip_read_info->stream); -#ifdef HAVE_BZIP2 - else if (pfile_in_zip_read_info->stream_initialised == Z_BZIP2ED) - BZ2_bzDecompressEnd(&pfile_in_zip_read_info->bstream); -#endif - - - pfile_in_zip_read_info->stream_initialised = 0; - TRYFREE(pfile_in_zip_read_info); - - s->pfile_in_zip_read=NULL; - - return err; -} - - -/* - Get the global comment string of the ZipFile, in the szComment buffer. - uSizeBuf is the size of the szComment buffer. - return the number of byte copied or an error code <0 -*/ -extern int ZEXPORT unzGetGlobalComment (unzFile file, char * szComment, uLong uSizeBuf) -{ - unz64_s* s; - uLong uReadThis ; - if (file==NULL) - return (int)UNZ_PARAMERROR; - s=(unz64_s*)file; - - uReadThis = uSizeBuf; - if (uReadThis>s->gi.size_comment) - uReadThis = s->gi.size_comment; - - if (ZSEEK64(s->z_filefunc,s->filestream,s->central_pos+22,ZLIB_FILEFUNC_SEEK_SET)!=0) - return UNZ_ERRNO; - - if (uReadThis>0) - { - *szComment='\0'; - if (ZREAD64(s->z_filefunc,s->filestream,szComment,uReadThis)!=uReadThis) - return UNZ_ERRNO; - } - - if ((szComment != NULL) && (uSizeBuf > s->gi.size_comment)) - *(szComment+s->gi.size_comment)='\0'; - return (int)uReadThis; -} - -/* Additions by RX '2004 */ -extern ZPOS64_T ZEXPORT unzGetOffset64(unzFile file) -{ - unz64_s* s; - - if (file==NULL) - return 0; //UNZ_PARAMERROR; - s=(unz64_s*)file; - if (!s->current_file_ok) - return 0; - if (s->gi.number_entry != 0 && s->gi.number_entry != 0xffff) - if (s->num_file==s->gi.number_entry) - return 0; - return s->pos_in_central_dir; -} - -extern uLong ZEXPORT unzGetOffset (unzFile file) -{ - ZPOS64_T offset64; - - if (file==NULL) - return 0; //UNZ_PARAMERROR; - offset64 = unzGetOffset64(file); - return (uLong)offset64; -} - -extern int ZEXPORT unzSetOffset64(unzFile file, ZPOS64_T pos) -{ - unz64_s* s; - int err; - - if (file==NULL) - return UNZ_PARAMERROR; - s=(unz64_s*)file; - - s->pos_in_central_dir = pos; - s->num_file = s->gi.number_entry; /* hack */ - err = unz64local_GetCurrentFileInfoInternal(file,&s->cur_file_info, - &s->cur_file_info_internal, - NULL,0,NULL,0,NULL,0); - s->current_file_ok = (err == UNZ_OK); - return err; -} - -extern int ZEXPORT unzSetOffset (unzFile file, uLong pos) -{ - return unzSetOffset64(file,pos); -} DELETED compat/zlib/contrib/minizip/unzip.h Index: compat/zlib/contrib/minizip/unzip.h ================================================================== --- compat/zlib/contrib/minizip/unzip.h +++ /dev/null @@ -1,437 +0,0 @@ -/* unzip.h -- IO for uncompress .zip files using zlib - Version 1.1, February 14h, 2010 - part of the MiniZip project - ( http://www.winimage.com/zLibDll/minizip.html ) - - Copyright (C) 1998-2010 Gilles Vollant (minizip) ( http://www.winimage.com/zLibDll/minizip.html ) - - Modifications of Unzip for Zip64 - Copyright (C) 2007-2008 Even Rouault - - Modifications for Zip64 support on both zip and unzip - Copyright (C) 2009-2010 Mathias Svensson ( http://result42.com ) - - For more info read MiniZip_info.txt - - --------------------------------------------------------------------------------- - - Condition of use and distribution are the same than zlib : - - This software is provided 'as-is', without any express or implied - warranty. In no event will the authors be held liable for any damages - arising from the use of this software. - - Permission is granted to anyone to use this software for any purpose, - including commercial applications, and to alter it and redistribute it - freely, subject to the following restrictions: - - 1. The origin of this software must not be misrepresented; you must not - claim that you wrote the original software. If you use this software - in a product, an acknowledgment in the product documentation would be - appreciated but is not required. - 2. Altered source versions must be plainly marked as such, and must not be - misrepresented as being the original software. - 3. This notice may not be removed or altered from any source distribution. - - --------------------------------------------------------------------------------- - - Changes - - See header of unzip64.c - -*/ - -#ifndef _unz64_H -#define _unz64_H - -#ifdef __cplusplus -extern "C" { -#endif - -#ifndef _ZLIB_H -#include "zlib.h" -#endif - -#ifndef _ZLIBIOAPI_H -#include "ioapi.h" -#endif - -#ifdef HAVE_BZIP2 -#include "bzlib.h" -#endif - -#define Z_BZIP2ED 12 - -#if defined(STRICTUNZIP) || defined(STRICTZIPUNZIP) -/* like the STRICT of WIN32, we define a pointer that cannot be converted - from (void*) without cast */ -typedef struct TagunzFile__ { int unused; } unzFile__; -typedef unzFile__ *unzFile; -#else -typedef voidp unzFile; -#endif - - -#define UNZ_OK (0) -#define UNZ_END_OF_LIST_OF_FILE (-100) -#define UNZ_ERRNO (Z_ERRNO) -#define UNZ_EOF (0) -#define UNZ_PARAMERROR (-102) -#define UNZ_BADZIPFILE (-103) -#define UNZ_INTERNALERROR (-104) -#define UNZ_CRCERROR (-105) - -/* tm_unz contain date/time info */ -typedef struct tm_unz_s -{ - uInt tm_sec; /* seconds after the minute - [0,59] */ - uInt tm_min; /* minutes after the hour - [0,59] */ - uInt tm_hour; /* hours since midnight - [0,23] */ - uInt tm_mday; /* day of the month - [1,31] */ - uInt tm_mon; /* months since January - [0,11] */ - uInt tm_year; /* years - [1980..2044] */ -} tm_unz; - -/* unz_global_info structure contain global data about the ZIPfile - These data comes from the end of central dir */ -typedef struct unz_global_info64_s -{ - ZPOS64_T number_entry; /* total number of entries in - the central dir on this disk */ - uLong size_comment; /* size of the global comment of the zipfile */ -} unz_global_info64; - -typedef struct unz_global_info_s -{ - uLong number_entry; /* total number of entries in - the central dir on this disk */ - uLong size_comment; /* size of the global comment of the zipfile */ -} unz_global_info; - -/* unz_file_info contain information about a file in the zipfile */ -typedef struct unz_file_info64_s -{ - uLong version; /* version made by 2 bytes */ - uLong version_needed; /* version needed to extract 2 bytes */ - uLong flag; /* general purpose bit flag 2 bytes */ - uLong compression_method; /* compression method 2 bytes */ - uLong dosDate; /* last mod file date in Dos fmt 4 bytes */ - uLong crc; /* crc-32 4 bytes */ - ZPOS64_T compressed_size; /* compressed size 8 bytes */ - ZPOS64_T uncompressed_size; /* uncompressed size 8 bytes */ - uLong size_filename; /* filename length 2 bytes */ - uLong size_file_extra; /* extra field length 2 bytes */ - uLong size_file_comment; /* file comment length 2 bytes */ - - uLong disk_num_start; /* disk number start 2 bytes */ - uLong internal_fa; /* internal file attributes 2 bytes */ - uLong external_fa; /* external file attributes 4 bytes */ - - tm_unz tmu_date; -} unz_file_info64; - -typedef struct unz_file_info_s -{ - uLong version; /* version made by 2 bytes */ - uLong version_needed; /* version needed to extract 2 bytes */ - uLong flag; /* general purpose bit flag 2 bytes */ - uLong compression_method; /* compression method 2 bytes */ - uLong dosDate; /* last mod file date in Dos fmt 4 bytes */ - uLong crc; /* crc-32 4 bytes */ - uLong compressed_size; /* compressed size 4 bytes */ - uLong uncompressed_size; /* uncompressed size 4 bytes */ - uLong size_filename; /* filename length 2 bytes */ - uLong size_file_extra; /* extra field length 2 bytes */ - uLong size_file_comment; /* file comment length 2 bytes */ - - uLong disk_num_start; /* disk number start 2 bytes */ - uLong internal_fa; /* internal file attributes 2 bytes */ - uLong external_fa; /* external file attributes 4 bytes */ - - tm_unz tmu_date; -} unz_file_info; - -extern int ZEXPORT unzStringFileNameCompare OF ((const char* fileName1, - const char* fileName2, - int iCaseSensitivity)); -/* - Compare two filename (fileName1,fileName2). - If iCaseSenisivity = 1, comparision is case sensitivity (like strcmp) - If iCaseSenisivity = 2, comparision is not case sensitivity (like strcmpi - or strcasecmp) - If iCaseSenisivity = 0, case sensitivity is defaut of your operating system - (like 1 on Unix, 2 on Windows) -*/ - - -extern unzFile ZEXPORT unzOpen OF((const char *path)); -extern unzFile ZEXPORT unzOpen64 OF((const void *path)); -/* - Open a Zip file. path contain the full pathname (by example, - on a Windows XP computer "c:\\zlib\\zlib113.zip" or on an Unix computer - "zlib/zlib113.zip". - If the zipfile cannot be opened (file don't exist or in not valid), the - return value is NULL. - Else, the return value is a unzFile Handle, usable with other function - of this unzip package. - the "64" function take a const void* pointer, because the path is just the - value passed to the open64_file_func callback. - Under Windows, if UNICODE is defined, using fill_fopen64_filefunc, the path - is a pointer to a wide unicode string (LPCTSTR is LPCWSTR), so const char* - does not describe the reality -*/ - - -extern unzFile ZEXPORT unzOpen2 OF((const char *path, - zlib_filefunc_def* pzlib_filefunc_def)); -/* - Open a Zip file, like unzOpen, but provide a set of file low level API - for read/write the zip file (see ioapi.h) -*/ - -extern unzFile ZEXPORT unzOpen2_64 OF((const void *path, - zlib_filefunc64_def* pzlib_filefunc_def)); -/* - Open a Zip file, like unz64Open, but provide a set of file low level API - for read/write the zip file (see ioapi.h) -*/ - -extern int ZEXPORT unzClose OF((unzFile file)); -/* - Close a ZipFile opened with unzOpen. - If there is files inside the .Zip opened with unzOpenCurrentFile (see later), - these files MUST be closed with unzCloseCurrentFile before call unzClose. - return UNZ_OK if there is no problem. */ - -extern int ZEXPORT unzGetGlobalInfo OF((unzFile file, - unz_global_info *pglobal_info)); - -extern int ZEXPORT unzGetGlobalInfo64 OF((unzFile file, - unz_global_info64 *pglobal_info)); -/* - Write info about the ZipFile in the *pglobal_info structure. - No preparation of the structure is needed - return UNZ_OK if there is no problem. */ - - -extern int ZEXPORT unzGetGlobalComment OF((unzFile file, - char *szComment, - uLong uSizeBuf)); -/* - Get the global comment string of the ZipFile, in the szComment buffer. - uSizeBuf is the size of the szComment buffer. - return the number of byte copied or an error code <0 -*/ - - -/***************************************************************************/ -/* Unzip package allow you browse the directory of the zipfile */ - -extern int ZEXPORT unzGoToFirstFile OF((unzFile file)); -/* - Set the current file of the zipfile to the first file. - return UNZ_OK if there is no problem -*/ - -extern int ZEXPORT unzGoToNextFile OF((unzFile file)); -/* - Set the current file of the zipfile to the next file. - return UNZ_OK if there is no problem - return UNZ_END_OF_LIST_OF_FILE if the actual file was the latest. -*/ - -extern int ZEXPORT unzLocateFile OF((unzFile file, - const char *szFileName, - int iCaseSensitivity)); -/* - Try locate the file szFileName in the zipfile. - For the iCaseSensitivity signification, see unzStringFileNameCompare - - return value : - UNZ_OK if the file is found. It becomes the current file. - UNZ_END_OF_LIST_OF_FILE if the file is not found -*/ - - -/* ****************************************** */ -/* Ryan supplied functions */ -/* unz_file_info contain information about a file in the zipfile */ -typedef struct unz_file_pos_s -{ - uLong pos_in_zip_directory; /* offset in zip file directory */ - uLong num_of_file; /* # of file */ -} unz_file_pos; - -extern int ZEXPORT unzGetFilePos( - unzFile file, - unz_file_pos* file_pos); - -extern int ZEXPORT unzGoToFilePos( - unzFile file, - unz_file_pos* file_pos); - -typedef struct unz64_file_pos_s -{ - ZPOS64_T pos_in_zip_directory; /* offset in zip file directory */ - ZPOS64_T num_of_file; /* # of file */ -} unz64_file_pos; - -extern int ZEXPORT unzGetFilePos64( - unzFile file, - unz64_file_pos* file_pos); - -extern int ZEXPORT unzGoToFilePos64( - unzFile file, - const unz64_file_pos* file_pos); - -/* ****************************************** */ - -extern int ZEXPORT unzGetCurrentFileInfo64 OF((unzFile file, - unz_file_info64 *pfile_info, - char *szFileName, - uLong fileNameBufferSize, - void *extraField, - uLong extraFieldBufferSize, - char *szComment, - uLong commentBufferSize)); - -extern int ZEXPORT unzGetCurrentFileInfo OF((unzFile file, - unz_file_info *pfile_info, - char *szFileName, - uLong fileNameBufferSize, - void *extraField, - uLong extraFieldBufferSize, - char *szComment, - uLong commentBufferSize)); -/* - Get Info about the current file - if pfile_info!=NULL, the *pfile_info structure will contain somes info about - the current file - if szFileName!=NULL, the filemane string will be copied in szFileName - (fileNameBufferSize is the size of the buffer) - if extraField!=NULL, the extra field information will be copied in extraField - (extraFieldBufferSize is the size of the buffer). - This is the Central-header version of the extra field - if szComment!=NULL, the comment string of the file will be copied in szComment - (commentBufferSize is the size of the buffer) -*/ - - -/** Addition for GDAL : START */ - -extern ZPOS64_T ZEXPORT unzGetCurrentFileZStreamPos64 OF((unzFile file)); - -/** Addition for GDAL : END */ - - -/***************************************************************************/ -/* for reading the content of the current zipfile, you can open it, read data - from it, and close it (you can close it before reading all the file) - */ - -extern int ZEXPORT unzOpenCurrentFile OF((unzFile file)); -/* - Open for reading data the current file in the zipfile. - If there is no error, the return value is UNZ_OK. -*/ - -extern int ZEXPORT unzOpenCurrentFilePassword OF((unzFile file, - const char* password)); -/* - Open for reading data the current file in the zipfile. - password is a crypting password - If there is no error, the return value is UNZ_OK. -*/ - -extern int ZEXPORT unzOpenCurrentFile2 OF((unzFile file, - int* method, - int* level, - int raw)); -/* - Same than unzOpenCurrentFile, but open for read raw the file (not uncompress) - if raw==1 - *method will receive method of compression, *level will receive level of - compression - note : you can set level parameter as NULL (if you did not want known level, - but you CANNOT set method parameter as NULL -*/ - -extern int ZEXPORT unzOpenCurrentFile3 OF((unzFile file, - int* method, - int* level, - int raw, - const char* password)); -/* - Same than unzOpenCurrentFile, but open for read raw the file (not uncompress) - if raw==1 - *method will receive method of compression, *level will receive level of - compression - note : you can set level parameter as NULL (if you did not want known level, - but you CANNOT set method parameter as NULL -*/ - - -extern int ZEXPORT unzCloseCurrentFile OF((unzFile file)); -/* - Close the file in zip opened with unzOpenCurrentFile - Return UNZ_CRCERROR if all the file was read but the CRC is not good -*/ - -extern int ZEXPORT unzReadCurrentFile OF((unzFile file, - voidp buf, - unsigned len)); -/* - Read bytes from the current file (opened by unzOpenCurrentFile) - buf contain buffer where data must be copied - len the size of buf. - - return the number of byte copied if somes bytes are copied - return 0 if the end of file was reached - return <0 with error code if there is an error - (UNZ_ERRNO for IO error, or zLib error for uncompress error) -*/ - -extern z_off_t ZEXPORT unztell OF((unzFile file)); - -extern ZPOS64_T ZEXPORT unztell64 OF((unzFile file)); -/* - Give the current position in uncompressed data -*/ - -extern int ZEXPORT unzeof OF((unzFile file)); -/* - return 1 if the end of file was reached, 0 elsewhere -*/ - -extern int ZEXPORT unzGetLocalExtrafield OF((unzFile file, - voidp buf, - unsigned len)); -/* - Read extra field from the current file (opened by unzOpenCurrentFile) - This is the local-header version of the extra field (sometimes, there is - more info in the local-header version than in the central-header) - - if buf==NULL, it return the size of the local extra field - - if buf!=NULL, len is the size of the buffer, the extra header is copied in - buf. - the return value is the number of bytes copied in buf, or (if <0) - the error code -*/ - -/***************************************************************************/ - -/* Get the current file offset */ -extern ZPOS64_T ZEXPORT unzGetOffset64 (unzFile file); -extern uLong ZEXPORT unzGetOffset (unzFile file); - -/* Set the current file offset */ -extern int ZEXPORT unzSetOffset64 (unzFile file, ZPOS64_T pos); -extern int ZEXPORT unzSetOffset (unzFile file, uLong pos); - - - -#ifdef __cplusplus -} -#endif - -#endif /* _unz64_H */ DELETED compat/zlib/contrib/minizip/zip.c Index: compat/zlib/contrib/minizip/zip.c ================================================================== --- compat/zlib/contrib/minizip/zip.c +++ /dev/null @@ -1,2007 +0,0 @@ -/* zip.c -- IO on .zip files using zlib - Version 1.1, February 14h, 2010 - part of the MiniZip project - ( http://www.winimage.com/zLibDll/minizip.html ) - - Copyright (C) 1998-2010 Gilles Vollant (minizip) ( http://www.winimage.com/zLibDll/minizip.html ) - - Modifications for Zip64 support - Copyright (C) 2009-2010 Mathias Svensson ( http://result42.com ) - - For more info read MiniZip_info.txt - - Changes - Oct-2009 - Mathias Svensson - Remove old C style function prototypes - Oct-2009 - Mathias Svensson - Added Zip64 Support when creating new file archives - Oct-2009 - Mathias Svensson - Did some code cleanup and refactoring to get better overview of some functions. - Oct-2009 - Mathias Svensson - Added zipRemoveExtraInfoBlock to strip extra field data from its ZIP64 data - It is used when recreting zip archive with RAW when deleting items from a zip. - ZIP64 data is automatically added to items that needs it, and existing ZIP64 data need to be removed. - Oct-2009 - Mathias Svensson - Added support for BZIP2 as compression mode (bzip2 lib is required) - Jan-2010 - back to unzip and minizip 1.0 name scheme, with compatibility layer - -*/ - - -#include -#include -#include -#include -#include "zlib.h" -#include "zip.h" - -#ifdef STDC -# include -# include -# include -#endif -#ifdef NO_ERRNO_H - extern int errno; -#else -# include -#endif - - -#ifndef local -# define local static -#endif -/* compile with -Dlocal if your debugger can't find static symbols */ - -#ifndef VERSIONMADEBY -# define VERSIONMADEBY (0x0) /* platform depedent */ -#endif - -#ifndef Z_BUFSIZE -#define Z_BUFSIZE (64*1024) //(16384) -#endif - -#ifndef Z_MAXFILENAMEINZIP -#define Z_MAXFILENAMEINZIP (256) -#endif - -#ifndef ALLOC -# define ALLOC(size) (malloc(size)) -#endif -#ifndef TRYFREE -# define TRYFREE(p) {if (p) free(p);} -#endif - -/* -#define SIZECENTRALDIRITEM (0x2e) -#define SIZEZIPLOCALHEADER (0x1e) -*/ - -/* I've found an old Unix (a SunOS 4.1.3_U1) without all SEEK_* defined.... */ - - -// NOT sure that this work on ALL platform -#define MAKEULONG64(a, b) ((ZPOS64_T)(((unsigned long)(a)) | ((ZPOS64_T)((unsigned long)(b))) << 32)) - -#ifndef SEEK_CUR -#define SEEK_CUR 1 -#endif - -#ifndef SEEK_END -#define SEEK_END 2 -#endif - -#ifndef SEEK_SET -#define SEEK_SET 0 -#endif - -#ifndef DEF_MEM_LEVEL -#if MAX_MEM_LEVEL >= 8 -# define DEF_MEM_LEVEL 8 -#else -# define DEF_MEM_LEVEL MAX_MEM_LEVEL -#endif -#endif -const char zip_copyright[] =" zip 1.01 Copyright 1998-2004 Gilles Vollant - http://www.winimage.com/zLibDll"; - - -#define SIZEDATA_INDATABLOCK (4096-(4*4)) - -#define LOCALHEADERMAGIC (0x04034b50) -#define CENTRALHEADERMAGIC (0x02014b50) -#define ENDHEADERMAGIC (0x06054b50) -#define ZIP64ENDHEADERMAGIC (0x6064b50) -#define ZIP64ENDLOCHEADERMAGIC (0x7064b50) - -#define FLAG_LOCALHEADER_OFFSET (0x06) -#define CRC_LOCALHEADER_OFFSET (0x0e) - -#define SIZECENTRALHEADER (0x2e) /* 46 */ - -typedef struct linkedlist_datablock_internal_s -{ - struct linkedlist_datablock_internal_s* next_datablock; - uLong avail_in_this_block; - uLong filled_in_this_block; - uLong unused; /* for future use and alignment */ - unsigned char data[SIZEDATA_INDATABLOCK]; -} linkedlist_datablock_internal; - -typedef struct linkedlist_data_s -{ - linkedlist_datablock_internal* first_block; - linkedlist_datablock_internal* last_block; -} linkedlist_data; - - -typedef struct -{ - z_stream stream; /* zLib stream structure for inflate */ -#ifdef HAVE_BZIP2 - bz_stream bstream; /* bzLib stream structure for bziped */ -#endif - - int stream_initialised; /* 1 is stream is initialised */ - uInt pos_in_buffered_data; /* last written byte in buffered_data */ - - ZPOS64_T pos_local_header; /* offset of the local header of the file - currenty writing */ - char* central_header; /* central header data for the current file */ - uLong size_centralExtra; - uLong size_centralheader; /* size of the central header for cur file */ - uLong size_centralExtraFree; /* Extra bytes allocated to the centralheader but that are not used */ - uLong flag; /* flag of the file currently writing */ - - int method; /* compression method of file currenty wr.*/ - int raw; /* 1 for directly writing raw data */ - Byte buffered_data[Z_BUFSIZE];/* buffer contain compressed data to be writ*/ - uLong dosDate; - uLong crc32; - int encrypt; - int zip64; /* Add ZIP64 extened information in the extra field */ - ZPOS64_T pos_zip64extrainfo; - ZPOS64_T totalCompressedData; - ZPOS64_T totalUncompressedData; -#ifndef NOCRYPT - unsigned long keys[3]; /* keys defining the pseudo-random sequence */ - const z_crc_t* pcrc_32_tab; - int crypt_header_size; -#endif -} curfile64_info; - -typedef struct -{ - zlib_filefunc64_32_def z_filefunc; - voidpf filestream; /* io structore of the zipfile */ - linkedlist_data central_dir;/* datablock with central dir in construction*/ - int in_opened_file_inzip; /* 1 if a file in the zip is currently writ.*/ - curfile64_info ci; /* info on the file curretly writing */ - - ZPOS64_T begin_pos; /* position of the beginning of the zipfile */ - ZPOS64_T add_position_when_writing_offset; - ZPOS64_T number_entry; - -#ifndef NO_ADDFILEINEXISTINGZIP - char *globalcomment; -#endif - -} zip64_internal; - - -#ifndef NOCRYPT -#define INCLUDECRYPTINGCODE_IFCRYPTALLOWED -#include "crypt.h" -#endif - -local linkedlist_datablock_internal* allocate_new_datablock() -{ - linkedlist_datablock_internal* ldi; - ldi = (linkedlist_datablock_internal*) - ALLOC(sizeof(linkedlist_datablock_internal)); - if (ldi!=NULL) - { - ldi->next_datablock = NULL ; - ldi->filled_in_this_block = 0 ; - ldi->avail_in_this_block = SIZEDATA_INDATABLOCK ; - } - return ldi; -} - -local void free_datablock(linkedlist_datablock_internal* ldi) -{ - while (ldi!=NULL) - { - linkedlist_datablock_internal* ldinext = ldi->next_datablock; - TRYFREE(ldi); - ldi = ldinext; - } -} - -local void init_linkedlist(linkedlist_data* ll) -{ - ll->first_block = ll->last_block = NULL; -} - -local void free_linkedlist(linkedlist_data* ll) -{ - free_datablock(ll->first_block); - ll->first_block = ll->last_block = NULL; -} - - -local int add_data_in_datablock(linkedlist_data* ll, const void* buf, uLong len) -{ - linkedlist_datablock_internal* ldi; - const unsigned char* from_copy; - - if (ll==NULL) - return ZIP_INTERNALERROR; - - if (ll->last_block == NULL) - { - ll->first_block = ll->last_block = allocate_new_datablock(); - if (ll->first_block == NULL) - return ZIP_INTERNALERROR; - } - - ldi = ll->last_block; - from_copy = (unsigned char*)buf; - - while (len>0) - { - uInt copy_this; - uInt i; - unsigned char* to_copy; - - if (ldi->avail_in_this_block==0) - { - ldi->next_datablock = allocate_new_datablock(); - if (ldi->next_datablock == NULL) - return ZIP_INTERNALERROR; - ldi = ldi->next_datablock ; - ll->last_block = ldi; - } - - if (ldi->avail_in_this_block < len) - copy_this = (uInt)ldi->avail_in_this_block; - else - copy_this = (uInt)len; - - to_copy = &(ldi->data[ldi->filled_in_this_block]); - - for (i=0;ifilled_in_this_block += copy_this; - ldi->avail_in_this_block -= copy_this; - from_copy += copy_this ; - len -= copy_this; - } - return ZIP_OK; -} - - - -/****************************************************************************/ - -#ifndef NO_ADDFILEINEXISTINGZIP -/* =========================================================================== - Inputs a long in LSB order to the given file - nbByte == 1, 2 ,4 or 8 (byte, short or long, ZPOS64_T) -*/ - -local int zip64local_putValue OF((const zlib_filefunc64_32_def* pzlib_filefunc_def, voidpf filestream, ZPOS64_T x, int nbByte)); -local int zip64local_putValue (const zlib_filefunc64_32_def* pzlib_filefunc_def, voidpf filestream, ZPOS64_T x, int nbByte) -{ - unsigned char buf[8]; - int n; - for (n = 0; n < nbByte; n++) - { - buf[n] = (unsigned char)(x & 0xff); - x >>= 8; - } - if (x != 0) - { /* data overflow - hack for ZIP64 (X Roche) */ - for (n = 0; n < nbByte; n++) - { - buf[n] = 0xff; - } - } - - if (ZWRITE64(*pzlib_filefunc_def,filestream,buf,nbByte)!=(uLong)nbByte) - return ZIP_ERRNO; - else - return ZIP_OK; -} - -local void zip64local_putValue_inmemory OF((void* dest, ZPOS64_T x, int nbByte)); -local void zip64local_putValue_inmemory (void* dest, ZPOS64_T x, int nbByte) -{ - unsigned char* buf=(unsigned char*)dest; - int n; - for (n = 0; n < nbByte; n++) { - buf[n] = (unsigned char)(x & 0xff); - x >>= 8; - } - - if (x != 0) - { /* data overflow - hack for ZIP64 */ - for (n = 0; n < nbByte; n++) - { - buf[n] = 0xff; - } - } -} - -/****************************************************************************/ - - -local uLong zip64local_TmzDateToDosDate(const tm_zip* ptm) -{ - uLong year = (uLong)ptm->tm_year; - if (year>=1980) - year-=1980; - else if (year>=80) - year-=80; - return - (uLong) (((ptm->tm_mday) + (32 * (ptm->tm_mon+1)) + (512 * year)) << 16) | - ((ptm->tm_sec/2) + (32* ptm->tm_min) + (2048 * (uLong)ptm->tm_hour)); -} - - -/****************************************************************************/ - -local int zip64local_getByte OF((const zlib_filefunc64_32_def* pzlib_filefunc_def, voidpf filestream, int *pi)); - -local int zip64local_getByte(const zlib_filefunc64_32_def* pzlib_filefunc_def,voidpf filestream,int* pi) -{ - unsigned char c; - int err = (int)ZREAD64(*pzlib_filefunc_def,filestream,&c,1); - if (err==1) - { - *pi = (int)c; - return ZIP_OK; - } - else - { - if (ZERROR64(*pzlib_filefunc_def,filestream)) - return ZIP_ERRNO; - else - return ZIP_EOF; - } -} - - -/* =========================================================================== - Reads a long in LSB order from the given gz_stream. Sets -*/ -local int zip64local_getShort OF((const zlib_filefunc64_32_def* pzlib_filefunc_def, voidpf filestream, uLong *pX)); - -local int zip64local_getShort (const zlib_filefunc64_32_def* pzlib_filefunc_def, voidpf filestream, uLong* pX) -{ - uLong x ; - int i = 0; - int err; - - err = zip64local_getByte(pzlib_filefunc_def,filestream,&i); - x = (uLong)i; - - if (err==ZIP_OK) - err = zip64local_getByte(pzlib_filefunc_def,filestream,&i); - x += ((uLong)i)<<8; - - if (err==ZIP_OK) - *pX = x; - else - *pX = 0; - return err; -} - -local int zip64local_getLong OF((const zlib_filefunc64_32_def* pzlib_filefunc_def, voidpf filestream, uLong *pX)); - -local int zip64local_getLong (const zlib_filefunc64_32_def* pzlib_filefunc_def, voidpf filestream, uLong* pX) -{ - uLong x ; - int i = 0; - int err; - - err = zip64local_getByte(pzlib_filefunc_def,filestream,&i); - x = (uLong)i; - - if (err==ZIP_OK) - err = zip64local_getByte(pzlib_filefunc_def,filestream,&i); - x += ((uLong)i)<<8; - - if (err==ZIP_OK) - err = zip64local_getByte(pzlib_filefunc_def,filestream,&i); - x += ((uLong)i)<<16; - - if (err==ZIP_OK) - err = zip64local_getByte(pzlib_filefunc_def,filestream,&i); - x += ((uLong)i)<<24; - - if (err==ZIP_OK) - *pX = x; - else - *pX = 0; - return err; -} - -local int zip64local_getLong64 OF((const zlib_filefunc64_32_def* pzlib_filefunc_def, voidpf filestream, ZPOS64_T *pX)); - - -local int zip64local_getLong64 (const zlib_filefunc64_32_def* pzlib_filefunc_def, voidpf filestream, ZPOS64_T *pX) -{ - ZPOS64_T x; - int i = 0; - int err; - - err = zip64local_getByte(pzlib_filefunc_def,filestream,&i); - x = (ZPOS64_T)i; - - if (err==ZIP_OK) - err = zip64local_getByte(pzlib_filefunc_def,filestream,&i); - x += ((ZPOS64_T)i)<<8; - - if (err==ZIP_OK) - err = zip64local_getByte(pzlib_filefunc_def,filestream,&i); - x += ((ZPOS64_T)i)<<16; - - if (err==ZIP_OK) - err = zip64local_getByte(pzlib_filefunc_def,filestream,&i); - x += ((ZPOS64_T)i)<<24; - - if (err==ZIP_OK) - err = zip64local_getByte(pzlib_filefunc_def,filestream,&i); - x += ((ZPOS64_T)i)<<32; - - if (err==ZIP_OK) - err = zip64local_getByte(pzlib_filefunc_def,filestream,&i); - x += ((ZPOS64_T)i)<<40; - - if (err==ZIP_OK) - err = zip64local_getByte(pzlib_filefunc_def,filestream,&i); - x += ((ZPOS64_T)i)<<48; - - if (err==ZIP_OK) - err = zip64local_getByte(pzlib_filefunc_def,filestream,&i); - x += ((ZPOS64_T)i)<<56; - - if (err==ZIP_OK) - *pX = x; - else - *pX = 0; - - return err; -} - -#ifndef BUFREADCOMMENT -#define BUFREADCOMMENT (0x400) -#endif -/* - Locate the Central directory of a zipfile (at the end, just before - the global comment) -*/ -local ZPOS64_T zip64local_SearchCentralDir OF((const zlib_filefunc64_32_def* pzlib_filefunc_def, voidpf filestream)); - -local ZPOS64_T zip64local_SearchCentralDir(const zlib_filefunc64_32_def* pzlib_filefunc_def, voidpf filestream) -{ - unsigned char* buf; - ZPOS64_T uSizeFile; - ZPOS64_T uBackRead; - ZPOS64_T uMaxBack=0xffff; /* maximum size of global comment */ - ZPOS64_T uPosFound=0; - - if (ZSEEK64(*pzlib_filefunc_def,filestream,0,ZLIB_FILEFUNC_SEEK_END) != 0) - return 0; - - - uSizeFile = ZTELL64(*pzlib_filefunc_def,filestream); - - if (uMaxBack>uSizeFile) - uMaxBack = uSizeFile; - - buf = (unsigned char*)ALLOC(BUFREADCOMMENT+4); - if (buf==NULL) - return 0; - - uBackRead = 4; - while (uBackReaduMaxBack) - uBackRead = uMaxBack; - else - uBackRead+=BUFREADCOMMENT; - uReadPos = uSizeFile-uBackRead ; - - uReadSize = ((BUFREADCOMMENT+4) < (uSizeFile-uReadPos)) ? - (BUFREADCOMMENT+4) : (uLong)(uSizeFile-uReadPos); - if (ZSEEK64(*pzlib_filefunc_def,filestream,uReadPos,ZLIB_FILEFUNC_SEEK_SET)!=0) - break; - - if (ZREAD64(*pzlib_filefunc_def,filestream,buf,uReadSize)!=uReadSize) - break; - - for (i=(int)uReadSize-3; (i--)>0;) - if (((*(buf+i))==0x50) && ((*(buf+i+1))==0x4b) && - ((*(buf+i+2))==0x05) && ((*(buf+i+3))==0x06)) - { - uPosFound = uReadPos+i; - break; - } - - if (uPosFound!=0) - break; - } - TRYFREE(buf); - return uPosFound; -} - -/* -Locate the End of Zip64 Central directory locator and from there find the CD of a zipfile (at the end, just before -the global comment) -*/ -local ZPOS64_T zip64local_SearchCentralDir64 OF((const zlib_filefunc64_32_def* pzlib_filefunc_def, voidpf filestream)); - -local ZPOS64_T zip64local_SearchCentralDir64(const zlib_filefunc64_32_def* pzlib_filefunc_def, voidpf filestream) -{ - unsigned char* buf; - ZPOS64_T uSizeFile; - ZPOS64_T uBackRead; - ZPOS64_T uMaxBack=0xffff; /* maximum size of global comment */ - ZPOS64_T uPosFound=0; - uLong uL; - ZPOS64_T relativeOffset; - - if (ZSEEK64(*pzlib_filefunc_def,filestream,0,ZLIB_FILEFUNC_SEEK_END) != 0) - return 0; - - uSizeFile = ZTELL64(*pzlib_filefunc_def,filestream); - - if (uMaxBack>uSizeFile) - uMaxBack = uSizeFile; - - buf = (unsigned char*)ALLOC(BUFREADCOMMENT+4); - if (buf==NULL) - return 0; - - uBackRead = 4; - while (uBackReaduMaxBack) - uBackRead = uMaxBack; - else - uBackRead+=BUFREADCOMMENT; - uReadPos = uSizeFile-uBackRead ; - - uReadSize = ((BUFREADCOMMENT+4) < (uSizeFile-uReadPos)) ? - (BUFREADCOMMENT+4) : (uLong)(uSizeFile-uReadPos); - if (ZSEEK64(*pzlib_filefunc_def,filestream,uReadPos,ZLIB_FILEFUNC_SEEK_SET)!=0) - break; - - if (ZREAD64(*pzlib_filefunc_def,filestream,buf,uReadSize)!=uReadSize) - break; - - for (i=(int)uReadSize-3; (i--)>0;) - { - // Signature "0x07064b50" Zip64 end of central directory locater - if (((*(buf+i))==0x50) && ((*(buf+i+1))==0x4b) && ((*(buf+i+2))==0x06) && ((*(buf+i+3))==0x07)) - { - uPosFound = uReadPos+i; - break; - } - } - - if (uPosFound!=0) - break; - } - - TRYFREE(buf); - if (uPosFound == 0) - return 0; - - /* Zip64 end of central directory locator */ - if (ZSEEK64(*pzlib_filefunc_def,filestream, uPosFound,ZLIB_FILEFUNC_SEEK_SET)!=0) - return 0; - - /* the signature, already checked */ - if (zip64local_getLong(pzlib_filefunc_def,filestream,&uL)!=ZIP_OK) - return 0; - - /* number of the disk with the start of the zip64 end of central directory */ - if (zip64local_getLong(pzlib_filefunc_def,filestream,&uL)!=ZIP_OK) - return 0; - if (uL != 0) - return 0; - - /* relative offset of the zip64 end of central directory record */ - if (zip64local_getLong64(pzlib_filefunc_def,filestream,&relativeOffset)!=ZIP_OK) - return 0; - - /* total number of disks */ - if (zip64local_getLong(pzlib_filefunc_def,filestream,&uL)!=ZIP_OK) - return 0; - if (uL != 1) - return 0; - - /* Goto Zip64 end of central directory record */ - if (ZSEEK64(*pzlib_filefunc_def,filestream, relativeOffset,ZLIB_FILEFUNC_SEEK_SET)!=0) - return 0; - - /* the signature */ - if (zip64local_getLong(pzlib_filefunc_def,filestream,&uL)!=ZIP_OK) - return 0; - - if (uL != 0x06064b50) // signature of 'Zip64 end of central directory' - return 0; - - return relativeOffset; -} - -int LoadCentralDirectoryRecord(zip64_internal* pziinit) -{ - int err=ZIP_OK; - ZPOS64_T byte_before_the_zipfile;/* byte before the zipfile, (>0 for sfx)*/ - - ZPOS64_T size_central_dir; /* size of the central directory */ - ZPOS64_T offset_central_dir; /* offset of start of central directory */ - ZPOS64_T central_pos; - uLong uL; - - uLong number_disk; /* number of the current dist, used for - spaning ZIP, unsupported, always 0*/ - uLong number_disk_with_CD; /* number the the disk with central dir, used - for spaning ZIP, unsupported, always 0*/ - ZPOS64_T number_entry; - ZPOS64_T number_entry_CD; /* total number of entries in - the central dir - (same than number_entry on nospan) */ - uLong VersionMadeBy; - uLong VersionNeeded; - uLong size_comment; - - int hasZIP64Record = 0; - - // check first if we find a ZIP64 record - central_pos = zip64local_SearchCentralDir64(&pziinit->z_filefunc,pziinit->filestream); - if(central_pos > 0) - { - hasZIP64Record = 1; - } - else if(central_pos == 0) - { - central_pos = zip64local_SearchCentralDir(&pziinit->z_filefunc,pziinit->filestream); - } - -/* disable to allow appending to empty ZIP archive - if (central_pos==0) - err=ZIP_ERRNO; -*/ - - if(hasZIP64Record) - { - ZPOS64_T sizeEndOfCentralDirectory; - if (ZSEEK64(pziinit->z_filefunc, pziinit->filestream, central_pos, ZLIB_FILEFUNC_SEEK_SET) != 0) - err=ZIP_ERRNO; - - /* the signature, already checked */ - if (zip64local_getLong(&pziinit->z_filefunc, pziinit->filestream,&uL)!=ZIP_OK) - err=ZIP_ERRNO; - - /* size of zip64 end of central directory record */ - if (zip64local_getLong64(&pziinit->z_filefunc, pziinit->filestream, &sizeEndOfCentralDirectory)!=ZIP_OK) - err=ZIP_ERRNO; - - /* version made by */ - if (zip64local_getShort(&pziinit->z_filefunc, pziinit->filestream, &VersionMadeBy)!=ZIP_OK) - err=ZIP_ERRNO; - - /* version needed to extract */ - if (zip64local_getShort(&pziinit->z_filefunc, pziinit->filestream, &VersionNeeded)!=ZIP_OK) - err=ZIP_ERRNO; - - /* number of this disk */ - if (zip64local_getLong(&pziinit->z_filefunc, pziinit->filestream,&number_disk)!=ZIP_OK) - err=ZIP_ERRNO; - - /* number of the disk with the start of the central directory */ - if (zip64local_getLong(&pziinit->z_filefunc, pziinit->filestream,&number_disk_with_CD)!=ZIP_OK) - err=ZIP_ERRNO; - - /* total number of entries in the central directory on this disk */ - if (zip64local_getLong64(&pziinit->z_filefunc, pziinit->filestream, &number_entry)!=ZIP_OK) - err=ZIP_ERRNO; - - /* total number of entries in the central directory */ - if (zip64local_getLong64(&pziinit->z_filefunc, pziinit->filestream,&number_entry_CD)!=ZIP_OK) - err=ZIP_ERRNO; - - if ((number_entry_CD!=number_entry) || (number_disk_with_CD!=0) || (number_disk!=0)) - err=ZIP_BADZIPFILE; - - /* size of the central directory */ - if (zip64local_getLong64(&pziinit->z_filefunc, pziinit->filestream,&size_central_dir)!=ZIP_OK) - err=ZIP_ERRNO; - - /* offset of start of central directory with respect to the - starting disk number */ - if (zip64local_getLong64(&pziinit->z_filefunc, pziinit->filestream,&offset_central_dir)!=ZIP_OK) - err=ZIP_ERRNO; - - // TODO.. - // read the comment from the standard central header. - size_comment = 0; - } - else - { - // Read End of central Directory info - if (ZSEEK64(pziinit->z_filefunc, pziinit->filestream, central_pos,ZLIB_FILEFUNC_SEEK_SET)!=0) - err=ZIP_ERRNO; - - /* the signature, already checked */ - if (zip64local_getLong(&pziinit->z_filefunc, pziinit->filestream,&uL)!=ZIP_OK) - err=ZIP_ERRNO; - - /* number of this disk */ - if (zip64local_getShort(&pziinit->z_filefunc, pziinit->filestream,&number_disk)!=ZIP_OK) - err=ZIP_ERRNO; - - /* number of the disk with the start of the central directory */ - if (zip64local_getShort(&pziinit->z_filefunc, pziinit->filestream,&number_disk_with_CD)!=ZIP_OK) - err=ZIP_ERRNO; - - /* total number of entries in the central dir on this disk */ - number_entry = 0; - if (zip64local_getShort(&pziinit->z_filefunc, pziinit->filestream, &uL)!=ZIP_OK) - err=ZIP_ERRNO; - else - number_entry = uL; - - /* total number of entries in the central dir */ - number_entry_CD = 0; - if (zip64local_getShort(&pziinit->z_filefunc, pziinit->filestream, &uL)!=ZIP_OK) - err=ZIP_ERRNO; - else - number_entry_CD = uL; - - if ((number_entry_CD!=number_entry) || (number_disk_with_CD!=0) || (number_disk!=0)) - err=ZIP_BADZIPFILE; - - /* size of the central directory */ - size_central_dir = 0; - if (zip64local_getLong(&pziinit->z_filefunc, pziinit->filestream, &uL)!=ZIP_OK) - err=ZIP_ERRNO; - else - size_central_dir = uL; - - /* offset of start of central directory with respect to the starting disk number */ - offset_central_dir = 0; - if (zip64local_getLong(&pziinit->z_filefunc, pziinit->filestream, &uL)!=ZIP_OK) - err=ZIP_ERRNO; - else - offset_central_dir = uL; - - - /* zipfile global comment length */ - if (zip64local_getShort(&pziinit->z_filefunc, pziinit->filestream, &size_comment)!=ZIP_OK) - err=ZIP_ERRNO; - } - - if ((central_posz_filefunc, pziinit->filestream); - return ZIP_ERRNO; - } - - if (size_comment>0) - { - pziinit->globalcomment = (char*)ALLOC(size_comment+1); - if (pziinit->globalcomment) - { - size_comment = ZREAD64(pziinit->z_filefunc, pziinit->filestream, pziinit->globalcomment,size_comment); - pziinit->globalcomment[size_comment]=0; - } - } - - byte_before_the_zipfile = central_pos - (offset_central_dir+size_central_dir); - pziinit->add_position_when_writing_offset = byte_before_the_zipfile; - - { - ZPOS64_T size_central_dir_to_read = size_central_dir; - size_t buf_size = SIZEDATA_INDATABLOCK; - void* buf_read = (void*)ALLOC(buf_size); - if (ZSEEK64(pziinit->z_filefunc, pziinit->filestream, offset_central_dir + byte_before_the_zipfile, ZLIB_FILEFUNC_SEEK_SET) != 0) - err=ZIP_ERRNO; - - while ((size_central_dir_to_read>0) && (err==ZIP_OK)) - { - ZPOS64_T read_this = SIZEDATA_INDATABLOCK; - if (read_this > size_central_dir_to_read) - read_this = size_central_dir_to_read; - - if (ZREAD64(pziinit->z_filefunc, pziinit->filestream,buf_read,(uLong)read_this) != read_this) - err=ZIP_ERRNO; - - if (err==ZIP_OK) - err = add_data_in_datablock(&pziinit->central_dir,buf_read, (uLong)read_this); - - size_central_dir_to_read-=read_this; - } - TRYFREE(buf_read); - } - pziinit->begin_pos = byte_before_the_zipfile; - pziinit->number_entry = number_entry_CD; - - if (ZSEEK64(pziinit->z_filefunc, pziinit->filestream, offset_central_dir+byte_before_the_zipfile,ZLIB_FILEFUNC_SEEK_SET) != 0) - err=ZIP_ERRNO; - - return err; -} - - -#endif /* !NO_ADDFILEINEXISTINGZIP*/ - - -/************************************************************/ -extern zipFile ZEXPORT zipOpen3 (const void *pathname, int append, zipcharpc* globalcomment, zlib_filefunc64_32_def* pzlib_filefunc64_32_def) -{ - zip64_internal ziinit; - zip64_internal* zi; - int err=ZIP_OK; - - ziinit.z_filefunc.zseek32_file = NULL; - ziinit.z_filefunc.ztell32_file = NULL; - if (pzlib_filefunc64_32_def==NULL) - fill_fopen64_filefunc(&ziinit.z_filefunc.zfile_func64); - else - ziinit.z_filefunc = *pzlib_filefunc64_32_def; - - ziinit.filestream = ZOPEN64(ziinit.z_filefunc, - pathname, - (append == APPEND_STATUS_CREATE) ? - (ZLIB_FILEFUNC_MODE_READ | ZLIB_FILEFUNC_MODE_WRITE | ZLIB_FILEFUNC_MODE_CREATE) : - (ZLIB_FILEFUNC_MODE_READ | ZLIB_FILEFUNC_MODE_WRITE | ZLIB_FILEFUNC_MODE_EXISTING)); - - if (ziinit.filestream == NULL) - return NULL; - - if (append == APPEND_STATUS_CREATEAFTER) - ZSEEK64(ziinit.z_filefunc,ziinit.filestream,0,SEEK_END); - - ziinit.begin_pos = ZTELL64(ziinit.z_filefunc,ziinit.filestream); - ziinit.in_opened_file_inzip = 0; - ziinit.ci.stream_initialised = 0; - ziinit.number_entry = 0; - ziinit.add_position_when_writing_offset = 0; - init_linkedlist(&(ziinit.central_dir)); - - - - zi = (zip64_internal*)ALLOC(sizeof(zip64_internal)); - if (zi==NULL) - { - ZCLOSE64(ziinit.z_filefunc,ziinit.filestream); - return NULL; - } - - /* now we add file in a zipfile */ -# ifndef NO_ADDFILEINEXISTINGZIP - ziinit.globalcomment = NULL; - if (append == APPEND_STATUS_ADDINZIP) - { - // Read and Cache Central Directory Records - err = LoadCentralDirectoryRecord(&ziinit); - } - - if (globalcomment) - { - *globalcomment = ziinit.globalcomment; - } -# endif /* !NO_ADDFILEINEXISTINGZIP*/ - - if (err != ZIP_OK) - { -# ifndef NO_ADDFILEINEXISTINGZIP - TRYFREE(ziinit.globalcomment); -# endif /* !NO_ADDFILEINEXISTINGZIP*/ - TRYFREE(zi); - return NULL; - } - else - { - *zi = ziinit; - return (zipFile)zi; - } -} - -extern zipFile ZEXPORT zipOpen2 (const char *pathname, int append, zipcharpc* globalcomment, zlib_filefunc_def* pzlib_filefunc32_def) -{ - if (pzlib_filefunc32_def != NULL) - { - zlib_filefunc64_32_def zlib_filefunc64_32_def_fill; - fill_zlib_filefunc64_32_def_from_filefunc32(&zlib_filefunc64_32_def_fill,pzlib_filefunc32_def); - return zipOpen3(pathname, append, globalcomment, &zlib_filefunc64_32_def_fill); - } - else - return zipOpen3(pathname, append, globalcomment, NULL); -} - -extern zipFile ZEXPORT zipOpen2_64 (const void *pathname, int append, zipcharpc* globalcomment, zlib_filefunc64_def* pzlib_filefunc_def) -{ - if (pzlib_filefunc_def != NULL) - { - zlib_filefunc64_32_def zlib_filefunc64_32_def_fill; - zlib_filefunc64_32_def_fill.zfile_func64 = *pzlib_filefunc_def; - zlib_filefunc64_32_def_fill.ztell32_file = NULL; - zlib_filefunc64_32_def_fill.zseek32_file = NULL; - return zipOpen3(pathname, append, globalcomment, &zlib_filefunc64_32_def_fill); - } - else - return zipOpen3(pathname, append, globalcomment, NULL); -} - - - -extern zipFile ZEXPORT zipOpen (const char* pathname, int append) -{ - return zipOpen3((const void*)pathname,append,NULL,NULL); -} - -extern zipFile ZEXPORT zipOpen64 (const void* pathname, int append) -{ - return zipOpen3(pathname,append,NULL,NULL); -} - -int Write_LocalFileHeader(zip64_internal* zi, const char* filename, uInt size_extrafield_local, const void* extrafield_local) -{ - /* write the local header */ - int err; - uInt size_filename = (uInt)strlen(filename); - uInt size_extrafield = size_extrafield_local; - - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)LOCALHEADERMAGIC, 4); - - if (err==ZIP_OK) - { - if(zi->ci.zip64) - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)45,2);/* version needed to extract */ - else - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)20,2);/* version needed to extract */ - } - - if (err==ZIP_OK) - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)zi->ci.flag,2); - - if (err==ZIP_OK) - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)zi->ci.method,2); - - if (err==ZIP_OK) - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)zi->ci.dosDate,4); - - // CRC / Compressed size / Uncompressed size will be filled in later and rewritten later - if (err==ZIP_OK) - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)0,4); /* crc 32, unknown */ - if (err==ZIP_OK) - { - if(zi->ci.zip64) - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)0xFFFFFFFF,4); /* compressed size, unknown */ - else - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)0,4); /* compressed size, unknown */ - } - if (err==ZIP_OK) - { - if(zi->ci.zip64) - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)0xFFFFFFFF,4); /* uncompressed size, unknown */ - else - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)0,4); /* uncompressed size, unknown */ - } - - if (err==ZIP_OK) - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)size_filename,2); - - if(zi->ci.zip64) - { - size_extrafield += 20; - } - - if (err==ZIP_OK) - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)size_extrafield,2); - - if ((err==ZIP_OK) && (size_filename > 0)) - { - if (ZWRITE64(zi->z_filefunc,zi->filestream,filename,size_filename)!=size_filename) - err = ZIP_ERRNO; - } - - if ((err==ZIP_OK) && (size_extrafield_local > 0)) - { - if (ZWRITE64(zi->z_filefunc, zi->filestream, extrafield_local, size_extrafield_local) != size_extrafield_local) - err = ZIP_ERRNO; - } - - - if ((err==ZIP_OK) && (zi->ci.zip64)) - { - // write the Zip64 extended info - short HeaderID = 1; - short DataSize = 16; - ZPOS64_T CompressedSize = 0; - ZPOS64_T UncompressedSize = 0; - - // Remember position of Zip64 extended info for the local file header. (needed when we update size after done with file) - zi->ci.pos_zip64extrainfo = ZTELL64(zi->z_filefunc,zi->filestream); - - err = zip64local_putValue(&zi->z_filefunc, zi->filestream, (short)HeaderID,2); - err = zip64local_putValue(&zi->z_filefunc, zi->filestream, (short)DataSize,2); - - err = zip64local_putValue(&zi->z_filefunc, zi->filestream, (ZPOS64_T)UncompressedSize,8); - err = zip64local_putValue(&zi->z_filefunc, zi->filestream, (ZPOS64_T)CompressedSize,8); - } - - return err; -} - -/* - NOTE. - When writing RAW the ZIP64 extended information in extrafield_local and extrafield_global needs to be stripped - before calling this function it can be done with zipRemoveExtraInfoBlock - - It is not done here because then we need to realloc a new buffer since parameters are 'const' and I want to minimize - unnecessary allocations. - */ -extern int ZEXPORT zipOpenNewFileInZip4_64 (zipFile file, const char* filename, const zip_fileinfo* zipfi, - const void* extrafield_local, uInt size_extrafield_local, - const void* extrafield_global, uInt size_extrafield_global, - const char* comment, int method, int level, int raw, - int windowBits,int memLevel, int strategy, - const char* password, uLong crcForCrypting, - uLong versionMadeBy, uLong flagBase, int zip64) -{ - zip64_internal* zi; - uInt size_filename; - uInt size_comment; - uInt i; - int err = ZIP_OK; - -# ifdef NOCRYPT - (crcForCrypting); - if (password != NULL) - return ZIP_PARAMERROR; -# endif - - if (file == NULL) - return ZIP_PARAMERROR; - -#ifdef HAVE_BZIP2 - if ((method!=0) && (method!=Z_DEFLATED) && (method!=Z_BZIP2ED)) - return ZIP_PARAMERROR; -#else - if ((method!=0) && (method!=Z_DEFLATED)) - return ZIP_PARAMERROR; -#endif - - zi = (zip64_internal*)file; - - if (zi->in_opened_file_inzip == 1) - { - err = zipCloseFileInZip (file); - if (err != ZIP_OK) - return err; - } - - if (filename==NULL) - filename="-"; - - if (comment==NULL) - size_comment = 0; - else - size_comment = (uInt)strlen(comment); - - size_filename = (uInt)strlen(filename); - - if (zipfi == NULL) - zi->ci.dosDate = 0; - else - { - if (zipfi->dosDate != 0) - zi->ci.dosDate = zipfi->dosDate; - else - zi->ci.dosDate = zip64local_TmzDateToDosDate(&zipfi->tmz_date); - } - - zi->ci.flag = flagBase; - if ((level==8) || (level==9)) - zi->ci.flag |= 2; - if (level==2) - zi->ci.flag |= 4; - if (level==1) - zi->ci.flag |= 6; - if (password != NULL) - zi->ci.flag |= 1; - - zi->ci.crc32 = 0; - zi->ci.method = method; - zi->ci.encrypt = 0; - zi->ci.stream_initialised = 0; - zi->ci.pos_in_buffered_data = 0; - zi->ci.raw = raw; - zi->ci.pos_local_header = ZTELL64(zi->z_filefunc,zi->filestream); - - zi->ci.size_centralheader = SIZECENTRALHEADER + size_filename + size_extrafield_global + size_comment; - zi->ci.size_centralExtraFree = 32; // Extra space we have reserved in case we need to add ZIP64 extra info data - - zi->ci.central_header = (char*)ALLOC((uInt)zi->ci.size_centralheader + zi->ci.size_centralExtraFree); - - zi->ci.size_centralExtra = size_extrafield_global; - zip64local_putValue_inmemory(zi->ci.central_header,(uLong)CENTRALHEADERMAGIC,4); - /* version info */ - zip64local_putValue_inmemory(zi->ci.central_header+4,(uLong)versionMadeBy,2); - zip64local_putValue_inmemory(zi->ci.central_header+6,(uLong)20,2); - zip64local_putValue_inmemory(zi->ci.central_header+8,(uLong)zi->ci.flag,2); - zip64local_putValue_inmemory(zi->ci.central_header+10,(uLong)zi->ci.method,2); - zip64local_putValue_inmemory(zi->ci.central_header+12,(uLong)zi->ci.dosDate,4); - zip64local_putValue_inmemory(zi->ci.central_header+16,(uLong)0,4); /*crc*/ - zip64local_putValue_inmemory(zi->ci.central_header+20,(uLong)0,4); /*compr size*/ - zip64local_putValue_inmemory(zi->ci.central_header+24,(uLong)0,4); /*uncompr size*/ - zip64local_putValue_inmemory(zi->ci.central_header+28,(uLong)size_filename,2); - zip64local_putValue_inmemory(zi->ci.central_header+30,(uLong)size_extrafield_global,2); - zip64local_putValue_inmemory(zi->ci.central_header+32,(uLong)size_comment,2); - zip64local_putValue_inmemory(zi->ci.central_header+34,(uLong)0,2); /*disk nm start*/ - - if (zipfi==NULL) - zip64local_putValue_inmemory(zi->ci.central_header+36,(uLong)0,2); - else - zip64local_putValue_inmemory(zi->ci.central_header+36,(uLong)zipfi->internal_fa,2); - - if (zipfi==NULL) - zip64local_putValue_inmemory(zi->ci.central_header+38,(uLong)0,4); - else - zip64local_putValue_inmemory(zi->ci.central_header+38,(uLong)zipfi->external_fa,4); - - if(zi->ci.pos_local_header >= 0xffffffff) - zip64local_putValue_inmemory(zi->ci.central_header+42,(uLong)0xffffffff,4); - else - zip64local_putValue_inmemory(zi->ci.central_header+42,(uLong)zi->ci.pos_local_header - zi->add_position_when_writing_offset,4); - - for (i=0;ici.central_header+SIZECENTRALHEADER+i) = *(filename+i); - - for (i=0;ici.central_header+SIZECENTRALHEADER+size_filename+i) = - *(((const char*)extrafield_global)+i); - - for (i=0;ici.central_header+SIZECENTRALHEADER+size_filename+ - size_extrafield_global+i) = *(comment+i); - if (zi->ci.central_header == NULL) - return ZIP_INTERNALERROR; - - zi->ci.zip64 = zip64; - zi->ci.totalCompressedData = 0; - zi->ci.totalUncompressedData = 0; - zi->ci.pos_zip64extrainfo = 0; - - err = Write_LocalFileHeader(zi, filename, size_extrafield_local, extrafield_local); - -#ifdef HAVE_BZIP2 - zi->ci.bstream.avail_in = (uInt)0; - zi->ci.bstream.avail_out = (uInt)Z_BUFSIZE; - zi->ci.bstream.next_out = (char*)zi->ci.buffered_data; - zi->ci.bstream.total_in_hi32 = 0; - zi->ci.bstream.total_in_lo32 = 0; - zi->ci.bstream.total_out_hi32 = 0; - zi->ci.bstream.total_out_lo32 = 0; -#endif - - zi->ci.stream.avail_in = (uInt)0; - zi->ci.stream.avail_out = (uInt)Z_BUFSIZE; - zi->ci.stream.next_out = zi->ci.buffered_data; - zi->ci.stream.total_in = 0; - zi->ci.stream.total_out = 0; - zi->ci.stream.data_type = Z_BINARY; - -#ifdef HAVE_BZIP2 - if ((err==ZIP_OK) && (zi->ci.method == Z_DEFLATED || zi->ci.method == Z_BZIP2ED) && (!zi->ci.raw)) -#else - if ((err==ZIP_OK) && (zi->ci.method == Z_DEFLATED) && (!zi->ci.raw)) -#endif - { - if(zi->ci.method == Z_DEFLATED) - { - zi->ci.stream.zalloc = (alloc_func)0; - zi->ci.stream.zfree = (free_func)0; - zi->ci.stream.opaque = (voidpf)0; - - if (windowBits>0) - windowBits = -windowBits; - - err = deflateInit2(&zi->ci.stream, level, Z_DEFLATED, windowBits, memLevel, strategy); - - if (err==Z_OK) - zi->ci.stream_initialised = Z_DEFLATED; - } - else if(zi->ci.method == Z_BZIP2ED) - { -#ifdef HAVE_BZIP2 - // Init BZip stuff here - zi->ci.bstream.bzalloc = 0; - zi->ci.bstream.bzfree = 0; - zi->ci.bstream.opaque = (voidpf)0; - - err = BZ2_bzCompressInit(&zi->ci.bstream, level, 0,35); - if(err == BZ_OK) - zi->ci.stream_initialised = Z_BZIP2ED; -#endif - } - - } - -# ifndef NOCRYPT - zi->ci.crypt_header_size = 0; - if ((err==Z_OK) && (password != NULL)) - { - unsigned char bufHead[RAND_HEAD_LEN]; - unsigned int sizeHead; - zi->ci.encrypt = 1; - zi->ci.pcrc_32_tab = get_crc_table(); - /*init_keys(password,zi->ci.keys,zi->ci.pcrc_32_tab);*/ - - sizeHead=crypthead(password,bufHead,RAND_HEAD_LEN,zi->ci.keys,zi->ci.pcrc_32_tab,crcForCrypting); - zi->ci.crypt_header_size = sizeHead; - - if (ZWRITE64(zi->z_filefunc,zi->filestream,bufHead,sizeHead) != sizeHead) - err = ZIP_ERRNO; - } -# endif - - if (err==Z_OK) - zi->in_opened_file_inzip = 1; - return err; -} - -extern int ZEXPORT zipOpenNewFileInZip4 (zipFile file, const char* filename, const zip_fileinfo* zipfi, - const void* extrafield_local, uInt size_extrafield_local, - const void* extrafield_global, uInt size_extrafield_global, - const char* comment, int method, int level, int raw, - int windowBits,int memLevel, int strategy, - const char* password, uLong crcForCrypting, - uLong versionMadeBy, uLong flagBase) -{ - return zipOpenNewFileInZip4_64 (file, filename, zipfi, - extrafield_local, size_extrafield_local, - extrafield_global, size_extrafield_global, - comment, method, level, raw, - windowBits, memLevel, strategy, - password, crcForCrypting, versionMadeBy, flagBase, 0); -} - -extern int ZEXPORT zipOpenNewFileInZip3 (zipFile file, const char* filename, const zip_fileinfo* zipfi, - const void* extrafield_local, uInt size_extrafield_local, - const void* extrafield_global, uInt size_extrafield_global, - const char* comment, int method, int level, int raw, - int windowBits,int memLevel, int strategy, - const char* password, uLong crcForCrypting) -{ - return zipOpenNewFileInZip4_64 (file, filename, zipfi, - extrafield_local, size_extrafield_local, - extrafield_global, size_extrafield_global, - comment, method, level, raw, - windowBits, memLevel, strategy, - password, crcForCrypting, VERSIONMADEBY, 0, 0); -} - -extern int ZEXPORT zipOpenNewFileInZip3_64(zipFile file, const char* filename, const zip_fileinfo* zipfi, - const void* extrafield_local, uInt size_extrafield_local, - const void* extrafield_global, uInt size_extrafield_global, - const char* comment, int method, int level, int raw, - int windowBits,int memLevel, int strategy, - const char* password, uLong crcForCrypting, int zip64) -{ - return zipOpenNewFileInZip4_64 (file, filename, zipfi, - extrafield_local, size_extrafield_local, - extrafield_global, size_extrafield_global, - comment, method, level, raw, - windowBits, memLevel, strategy, - password, crcForCrypting, VERSIONMADEBY, 0, zip64); -} - -extern int ZEXPORT zipOpenNewFileInZip2(zipFile file, const char* filename, const zip_fileinfo* zipfi, - const void* extrafield_local, uInt size_extrafield_local, - const void* extrafield_global, uInt size_extrafield_global, - const char* comment, int method, int level, int raw) -{ - return zipOpenNewFileInZip4_64 (file, filename, zipfi, - extrafield_local, size_extrafield_local, - extrafield_global, size_extrafield_global, - comment, method, level, raw, - -MAX_WBITS, DEF_MEM_LEVEL, Z_DEFAULT_STRATEGY, - NULL, 0, VERSIONMADEBY, 0, 0); -} - -extern int ZEXPORT zipOpenNewFileInZip2_64(zipFile file, const char* filename, const zip_fileinfo* zipfi, - const void* extrafield_local, uInt size_extrafield_local, - const void* extrafield_global, uInt size_extrafield_global, - const char* comment, int method, int level, int raw, int zip64) -{ - return zipOpenNewFileInZip4_64 (file, filename, zipfi, - extrafield_local, size_extrafield_local, - extrafield_global, size_extrafield_global, - comment, method, level, raw, - -MAX_WBITS, DEF_MEM_LEVEL, Z_DEFAULT_STRATEGY, - NULL, 0, VERSIONMADEBY, 0, zip64); -} - -extern int ZEXPORT zipOpenNewFileInZip64 (zipFile file, const char* filename, const zip_fileinfo* zipfi, - const void* extrafield_local, uInt size_extrafield_local, - const void*extrafield_global, uInt size_extrafield_global, - const char* comment, int method, int level, int zip64) -{ - return zipOpenNewFileInZip4_64 (file, filename, zipfi, - extrafield_local, size_extrafield_local, - extrafield_global, size_extrafield_global, - comment, method, level, 0, - -MAX_WBITS, DEF_MEM_LEVEL, Z_DEFAULT_STRATEGY, - NULL, 0, VERSIONMADEBY, 0, zip64); -} - -extern int ZEXPORT zipOpenNewFileInZip (zipFile file, const char* filename, const zip_fileinfo* zipfi, - const void* extrafield_local, uInt size_extrafield_local, - const void*extrafield_global, uInt size_extrafield_global, - const char* comment, int method, int level) -{ - return zipOpenNewFileInZip4_64 (file, filename, zipfi, - extrafield_local, size_extrafield_local, - extrafield_global, size_extrafield_global, - comment, method, level, 0, - -MAX_WBITS, DEF_MEM_LEVEL, Z_DEFAULT_STRATEGY, - NULL, 0, VERSIONMADEBY, 0, 0); -} - -local int zip64FlushWriteBuffer(zip64_internal* zi) -{ - int err=ZIP_OK; - - if (zi->ci.encrypt != 0) - { -#ifndef NOCRYPT - uInt i; - int t; - for (i=0;ici.pos_in_buffered_data;i++) - zi->ci.buffered_data[i] = zencode(zi->ci.keys, zi->ci.pcrc_32_tab, zi->ci.buffered_data[i],t); -#endif - } - - if (ZWRITE64(zi->z_filefunc,zi->filestream,zi->ci.buffered_data,zi->ci.pos_in_buffered_data) != zi->ci.pos_in_buffered_data) - err = ZIP_ERRNO; - - zi->ci.totalCompressedData += zi->ci.pos_in_buffered_data; - -#ifdef HAVE_BZIP2 - if(zi->ci.method == Z_BZIP2ED) - { - zi->ci.totalUncompressedData += zi->ci.bstream.total_in_lo32; - zi->ci.bstream.total_in_lo32 = 0; - zi->ci.bstream.total_in_hi32 = 0; - } - else -#endif - { - zi->ci.totalUncompressedData += zi->ci.stream.total_in; - zi->ci.stream.total_in = 0; - } - - - zi->ci.pos_in_buffered_data = 0; - - return err; -} - -extern int ZEXPORT zipWriteInFileInZip (zipFile file,const void* buf,unsigned int len) -{ - zip64_internal* zi; - int err=ZIP_OK; - - if (file == NULL) - return ZIP_PARAMERROR; - zi = (zip64_internal*)file; - - if (zi->in_opened_file_inzip == 0) - return ZIP_PARAMERROR; - - zi->ci.crc32 = crc32(zi->ci.crc32,buf,(uInt)len); - -#ifdef HAVE_BZIP2 - if(zi->ci.method == Z_BZIP2ED && (!zi->ci.raw)) - { - zi->ci.bstream.next_in = (void*)buf; - zi->ci.bstream.avail_in = len; - err = BZ_RUN_OK; - - while ((err==BZ_RUN_OK) && (zi->ci.bstream.avail_in>0)) - { - if (zi->ci.bstream.avail_out == 0) - { - if (zip64FlushWriteBuffer(zi) == ZIP_ERRNO) - err = ZIP_ERRNO; - zi->ci.bstream.avail_out = (uInt)Z_BUFSIZE; - zi->ci.bstream.next_out = (char*)zi->ci.buffered_data; - } - - - if(err != BZ_RUN_OK) - break; - - if ((zi->ci.method == Z_BZIP2ED) && (!zi->ci.raw)) - { - uLong uTotalOutBefore_lo = zi->ci.bstream.total_out_lo32; -// uLong uTotalOutBefore_hi = zi->ci.bstream.total_out_hi32; - err=BZ2_bzCompress(&zi->ci.bstream, BZ_RUN); - - zi->ci.pos_in_buffered_data += (uInt)(zi->ci.bstream.total_out_lo32 - uTotalOutBefore_lo) ; - } - } - - if(err == BZ_RUN_OK) - err = ZIP_OK; - } - else -#endif - { - zi->ci.stream.next_in = (Bytef*)buf; - zi->ci.stream.avail_in = len; - - while ((err==ZIP_OK) && (zi->ci.stream.avail_in>0)) - { - if (zi->ci.stream.avail_out == 0) - { - if (zip64FlushWriteBuffer(zi) == ZIP_ERRNO) - err = ZIP_ERRNO; - zi->ci.stream.avail_out = (uInt)Z_BUFSIZE; - zi->ci.stream.next_out = zi->ci.buffered_data; - } - - - if(err != ZIP_OK) - break; - - if ((zi->ci.method == Z_DEFLATED) && (!zi->ci.raw)) - { - uLong uTotalOutBefore = zi->ci.stream.total_out; - err=deflate(&zi->ci.stream, Z_NO_FLUSH); - if(uTotalOutBefore > zi->ci.stream.total_out) - { - int bBreak = 0; - bBreak++; - } - - zi->ci.pos_in_buffered_data += (uInt)(zi->ci.stream.total_out - uTotalOutBefore) ; - } - else - { - uInt copy_this,i; - if (zi->ci.stream.avail_in < zi->ci.stream.avail_out) - copy_this = zi->ci.stream.avail_in; - else - copy_this = zi->ci.stream.avail_out; - - for (i = 0; i < copy_this; i++) - *(((char*)zi->ci.stream.next_out)+i) = - *(((const char*)zi->ci.stream.next_in)+i); - { - zi->ci.stream.avail_in -= copy_this; - zi->ci.stream.avail_out-= copy_this; - zi->ci.stream.next_in+= copy_this; - zi->ci.stream.next_out+= copy_this; - zi->ci.stream.total_in+= copy_this; - zi->ci.stream.total_out+= copy_this; - zi->ci.pos_in_buffered_data += copy_this; - } - } - }// while(...) - } - - return err; -} - -extern int ZEXPORT zipCloseFileInZipRaw (zipFile file, uLong uncompressed_size, uLong crc32) -{ - return zipCloseFileInZipRaw64 (file, uncompressed_size, crc32); -} - -extern int ZEXPORT zipCloseFileInZipRaw64 (zipFile file, ZPOS64_T uncompressed_size, uLong crc32) -{ - zip64_internal* zi; - ZPOS64_T compressed_size; - uLong invalidValue = 0xffffffff; - short datasize = 0; - int err=ZIP_OK; - - if (file == NULL) - return ZIP_PARAMERROR; - zi = (zip64_internal*)file; - - if (zi->in_opened_file_inzip == 0) - return ZIP_PARAMERROR; - zi->ci.stream.avail_in = 0; - - if ((zi->ci.method == Z_DEFLATED) && (!zi->ci.raw)) - { - while (err==ZIP_OK) - { - uLong uTotalOutBefore; - if (zi->ci.stream.avail_out == 0) - { - if (zip64FlushWriteBuffer(zi) == ZIP_ERRNO) - err = ZIP_ERRNO; - zi->ci.stream.avail_out = (uInt)Z_BUFSIZE; - zi->ci.stream.next_out = zi->ci.buffered_data; - } - uTotalOutBefore = zi->ci.stream.total_out; - err=deflate(&zi->ci.stream, Z_FINISH); - zi->ci.pos_in_buffered_data += (uInt)(zi->ci.stream.total_out - uTotalOutBefore) ; - } - } - else if ((zi->ci.method == Z_BZIP2ED) && (!zi->ci.raw)) - { -#ifdef HAVE_BZIP2 - err = BZ_FINISH_OK; - while (err==BZ_FINISH_OK) - { - uLong uTotalOutBefore; - if (zi->ci.bstream.avail_out == 0) - { - if (zip64FlushWriteBuffer(zi) == ZIP_ERRNO) - err = ZIP_ERRNO; - zi->ci.bstream.avail_out = (uInt)Z_BUFSIZE; - zi->ci.bstream.next_out = (char*)zi->ci.buffered_data; - } - uTotalOutBefore = zi->ci.bstream.total_out_lo32; - err=BZ2_bzCompress(&zi->ci.bstream, BZ_FINISH); - if(err == BZ_STREAM_END) - err = Z_STREAM_END; - - zi->ci.pos_in_buffered_data += (uInt)(zi->ci.bstream.total_out_lo32 - uTotalOutBefore); - } - - if(err == BZ_FINISH_OK) - err = ZIP_OK; -#endif - } - - if (err==Z_STREAM_END) - err=ZIP_OK; /* this is normal */ - - if ((zi->ci.pos_in_buffered_data>0) && (err==ZIP_OK)) - { - if (zip64FlushWriteBuffer(zi)==ZIP_ERRNO) - err = ZIP_ERRNO; - } - - if ((zi->ci.method == Z_DEFLATED) && (!zi->ci.raw)) - { - int tmp_err = deflateEnd(&zi->ci.stream); - if (err == ZIP_OK) - err = tmp_err; - zi->ci.stream_initialised = 0; - } -#ifdef HAVE_BZIP2 - else if((zi->ci.method == Z_BZIP2ED) && (!zi->ci.raw)) - { - int tmperr = BZ2_bzCompressEnd(&zi->ci.bstream); - if (err==ZIP_OK) - err = tmperr; - zi->ci.stream_initialised = 0; - } -#endif - - if (!zi->ci.raw) - { - crc32 = (uLong)zi->ci.crc32; - uncompressed_size = zi->ci.totalUncompressedData; - } - compressed_size = zi->ci.totalCompressedData; - -# ifndef NOCRYPT - compressed_size += zi->ci.crypt_header_size; -# endif - - // update Current Item crc and sizes, - if(compressed_size >= 0xffffffff || uncompressed_size >= 0xffffffff || zi->ci.pos_local_header >= 0xffffffff) - { - /*version Made by*/ - zip64local_putValue_inmemory(zi->ci.central_header+4,(uLong)45,2); - /*version needed*/ - zip64local_putValue_inmemory(zi->ci.central_header+6,(uLong)45,2); - - } - - zip64local_putValue_inmemory(zi->ci.central_header+16,crc32,4); /*crc*/ - - - if(compressed_size >= 0xffffffff) - zip64local_putValue_inmemory(zi->ci.central_header+20, invalidValue,4); /*compr size*/ - else - zip64local_putValue_inmemory(zi->ci.central_header+20, compressed_size,4); /*compr size*/ - - /// set internal file attributes field - if (zi->ci.stream.data_type == Z_ASCII) - zip64local_putValue_inmemory(zi->ci.central_header+36,(uLong)Z_ASCII,2); - - if(uncompressed_size >= 0xffffffff) - zip64local_putValue_inmemory(zi->ci.central_header+24, invalidValue,4); /*uncompr size*/ - else - zip64local_putValue_inmemory(zi->ci.central_header+24, uncompressed_size,4); /*uncompr size*/ - - // Add ZIP64 extra info field for uncompressed size - if(uncompressed_size >= 0xffffffff) - datasize += 8; - - // Add ZIP64 extra info field for compressed size - if(compressed_size >= 0xffffffff) - datasize += 8; - - // Add ZIP64 extra info field for relative offset to local file header of current file - if(zi->ci.pos_local_header >= 0xffffffff) - datasize += 8; - - if(datasize > 0) - { - char* p = NULL; - - if((uLong)(datasize + 4) > zi->ci.size_centralExtraFree) - { - // we can not write more data to the buffer that we have room for. - return ZIP_BADZIPFILE; - } - - p = zi->ci.central_header + zi->ci.size_centralheader; - - // Add Extra Information Header for 'ZIP64 information' - zip64local_putValue_inmemory(p, 0x0001, 2); // HeaderID - p += 2; - zip64local_putValue_inmemory(p, datasize, 2); // DataSize - p += 2; - - if(uncompressed_size >= 0xffffffff) - { - zip64local_putValue_inmemory(p, uncompressed_size, 8); - p += 8; - } - - if(compressed_size >= 0xffffffff) - { - zip64local_putValue_inmemory(p, compressed_size, 8); - p += 8; - } - - if(zi->ci.pos_local_header >= 0xffffffff) - { - zip64local_putValue_inmemory(p, zi->ci.pos_local_header, 8); - p += 8; - } - - // Update how much extra free space we got in the memory buffer - // and increase the centralheader size so the new ZIP64 fields are included - // ( 4 below is the size of HeaderID and DataSize field ) - zi->ci.size_centralExtraFree -= datasize + 4; - zi->ci.size_centralheader += datasize + 4; - - // Update the extra info size field - zi->ci.size_centralExtra += datasize + 4; - zip64local_putValue_inmemory(zi->ci.central_header+30,(uLong)zi->ci.size_centralExtra,2); - } - - if (err==ZIP_OK) - err = add_data_in_datablock(&zi->central_dir, zi->ci.central_header, (uLong)zi->ci.size_centralheader); - - free(zi->ci.central_header); - - if (err==ZIP_OK) - { - // Update the LocalFileHeader with the new values. - - ZPOS64_T cur_pos_inzip = ZTELL64(zi->z_filefunc,zi->filestream); - - if (ZSEEK64(zi->z_filefunc,zi->filestream, zi->ci.pos_local_header + 14,ZLIB_FILEFUNC_SEEK_SET)!=0) - err = ZIP_ERRNO; - - if (err==ZIP_OK) - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,crc32,4); /* crc 32, unknown */ - - if(uncompressed_size >= 0xffffffff || compressed_size >= 0xffffffff ) - { - if(zi->ci.pos_zip64extrainfo > 0) - { - // Update the size in the ZIP64 extended field. - if (ZSEEK64(zi->z_filefunc,zi->filestream, zi->ci.pos_zip64extrainfo + 4,ZLIB_FILEFUNC_SEEK_SET)!=0) - err = ZIP_ERRNO; - - if (err==ZIP_OK) /* compressed size, unknown */ - err = zip64local_putValue(&zi->z_filefunc, zi->filestream, uncompressed_size, 8); - - if (err==ZIP_OK) /* uncompressed size, unknown */ - err = zip64local_putValue(&zi->z_filefunc, zi->filestream, compressed_size, 8); - } - else - err = ZIP_BADZIPFILE; // Caller passed zip64 = 0, so no room for zip64 info -> fatal - } - else - { - if (err==ZIP_OK) /* compressed size, unknown */ - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,compressed_size,4); - - if (err==ZIP_OK) /* uncompressed size, unknown */ - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,uncompressed_size,4); - } - - if (ZSEEK64(zi->z_filefunc,zi->filestream, cur_pos_inzip,ZLIB_FILEFUNC_SEEK_SET)!=0) - err = ZIP_ERRNO; - } - - zi->number_entry ++; - zi->in_opened_file_inzip = 0; - - return err; -} - -extern int ZEXPORT zipCloseFileInZip (zipFile file) -{ - return zipCloseFileInZipRaw (file,0,0); -} - -int Write_Zip64EndOfCentralDirectoryLocator(zip64_internal* zi, ZPOS64_T zip64eocd_pos_inzip) -{ - int err = ZIP_OK; - ZPOS64_T pos = zip64eocd_pos_inzip - zi->add_position_when_writing_offset; - - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)ZIP64ENDLOCHEADERMAGIC,4); - - /*num disks*/ - if (err==ZIP_OK) /* number of the disk with the start of the central directory */ - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)0,4); - - /*relative offset*/ - if (err==ZIP_OK) /* Relative offset to the Zip64EndOfCentralDirectory */ - err = zip64local_putValue(&zi->z_filefunc,zi->filestream, pos,8); - - /*total disks*/ /* Do not support spawning of disk so always say 1 here*/ - if (err==ZIP_OK) /* number of the disk with the start of the central directory */ - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)1,4); - - return err; -} - -int Write_Zip64EndOfCentralDirectoryRecord(zip64_internal* zi, uLong size_centraldir, ZPOS64_T centraldir_pos_inzip) -{ - int err = ZIP_OK; - - uLong Zip64DataSize = 44; - - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)ZIP64ENDHEADERMAGIC,4); - - if (err==ZIP_OK) /* size of this 'zip64 end of central directory' */ - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(ZPOS64_T)Zip64DataSize,8); // why ZPOS64_T of this ? - - if (err==ZIP_OK) /* version made by */ - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)45,2); - - if (err==ZIP_OK) /* version needed */ - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)45,2); - - if (err==ZIP_OK) /* number of this disk */ - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)0,4); - - if (err==ZIP_OK) /* number of the disk with the start of the central directory */ - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)0,4); - - if (err==ZIP_OK) /* total number of entries in the central dir on this disk */ - err = zip64local_putValue(&zi->z_filefunc, zi->filestream, zi->number_entry, 8); - - if (err==ZIP_OK) /* total number of entries in the central dir */ - err = zip64local_putValue(&zi->z_filefunc, zi->filestream, zi->number_entry, 8); - - if (err==ZIP_OK) /* size of the central directory */ - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(ZPOS64_T)size_centraldir,8); - - if (err==ZIP_OK) /* offset of start of central directory with respect to the starting disk number */ - { - ZPOS64_T pos = centraldir_pos_inzip - zi->add_position_when_writing_offset; - err = zip64local_putValue(&zi->z_filefunc,zi->filestream, (ZPOS64_T)pos,8); - } - return err; -} -int Write_EndOfCentralDirectoryRecord(zip64_internal* zi, uLong size_centraldir, ZPOS64_T centraldir_pos_inzip) -{ - int err = ZIP_OK; - - /*signature*/ - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)ENDHEADERMAGIC,4); - - if (err==ZIP_OK) /* number of this disk */ - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)0,2); - - if (err==ZIP_OK) /* number of the disk with the start of the central directory */ - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)0,2); - - if (err==ZIP_OK) /* total number of entries in the central dir on this disk */ - { - { - if(zi->number_entry >= 0xFFFF) - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)0xffff,2); // use value in ZIP64 record - else - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)zi->number_entry,2); - } - } - - if (err==ZIP_OK) /* total number of entries in the central dir */ - { - if(zi->number_entry >= 0xFFFF) - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)0xffff,2); // use value in ZIP64 record - else - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)zi->number_entry,2); - } - - if (err==ZIP_OK) /* size of the central directory */ - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)size_centraldir,4); - - if (err==ZIP_OK) /* offset of start of central directory with respect to the starting disk number */ - { - ZPOS64_T pos = centraldir_pos_inzip - zi->add_position_when_writing_offset; - if(pos >= 0xffffffff) - { - err = zip64local_putValue(&zi->z_filefunc,zi->filestream, (uLong)0xffffffff,4); - } - else - err = zip64local_putValue(&zi->z_filefunc,zi->filestream, (uLong)(centraldir_pos_inzip - zi->add_position_when_writing_offset),4); - } - - return err; -} - -int Write_GlobalComment(zip64_internal* zi, const char* global_comment) -{ - int err = ZIP_OK; - uInt size_global_comment = 0; - - if(global_comment != NULL) - size_global_comment = (uInt)strlen(global_comment); - - err = zip64local_putValue(&zi->z_filefunc,zi->filestream,(uLong)size_global_comment,2); - - if (err == ZIP_OK && size_global_comment > 0) - { - if (ZWRITE64(zi->z_filefunc,zi->filestream, global_comment, size_global_comment) != size_global_comment) - err = ZIP_ERRNO; - } - return err; -} - -extern int ZEXPORT zipClose (zipFile file, const char* global_comment) -{ - zip64_internal* zi; - int err = 0; - uLong size_centraldir = 0; - ZPOS64_T centraldir_pos_inzip; - ZPOS64_T pos; - - if (file == NULL) - return ZIP_PARAMERROR; - - zi = (zip64_internal*)file; - - if (zi->in_opened_file_inzip == 1) - { - err = zipCloseFileInZip (file); - } - -#ifndef NO_ADDFILEINEXISTINGZIP - if (global_comment==NULL) - global_comment = zi->globalcomment; -#endif - - centraldir_pos_inzip = ZTELL64(zi->z_filefunc,zi->filestream); - - if (err==ZIP_OK) - { - linkedlist_datablock_internal* ldi = zi->central_dir.first_block; - while (ldi!=NULL) - { - if ((err==ZIP_OK) && (ldi->filled_in_this_block>0)) - { - if (ZWRITE64(zi->z_filefunc,zi->filestream, ldi->data, ldi->filled_in_this_block) != ldi->filled_in_this_block) - err = ZIP_ERRNO; - } - - size_centraldir += ldi->filled_in_this_block; - ldi = ldi->next_datablock; - } - } - free_linkedlist(&(zi->central_dir)); - - pos = centraldir_pos_inzip - zi->add_position_when_writing_offset; - if(pos >= 0xffffffff || zi->number_entry > 0xFFFF) - { - ZPOS64_T Zip64EOCDpos = ZTELL64(zi->z_filefunc,zi->filestream); - Write_Zip64EndOfCentralDirectoryRecord(zi, size_centraldir, centraldir_pos_inzip); - - Write_Zip64EndOfCentralDirectoryLocator(zi, Zip64EOCDpos); - } - - if (err==ZIP_OK) - err = Write_EndOfCentralDirectoryRecord(zi, size_centraldir, centraldir_pos_inzip); - - if(err == ZIP_OK) - err = Write_GlobalComment(zi, global_comment); - - if (ZCLOSE64(zi->z_filefunc,zi->filestream) != 0) - if (err == ZIP_OK) - err = ZIP_ERRNO; - -#ifndef NO_ADDFILEINEXISTINGZIP - TRYFREE(zi->globalcomment); -#endif - TRYFREE(zi); - - return err; -} - -extern int ZEXPORT zipRemoveExtraInfoBlock (char* pData, int* dataLen, short sHeader) -{ - char* p = pData; - int size = 0; - char* pNewHeader; - char* pTmp; - short header; - short dataSize; - - int retVal = ZIP_OK; - - if(pData == NULL || *dataLen < 4) - return ZIP_PARAMERROR; - - pNewHeader = (char*)ALLOC(*dataLen); - pTmp = pNewHeader; - - while(p < (pData + *dataLen)) - { - header = *(short*)p; - dataSize = *(((short*)p)+1); - - if( header == sHeader ) // Header found. - { - p += dataSize + 4; // skip it. do not copy to temp buffer - } - else - { - // Extra Info block should not be removed, So copy it to the temp buffer. - memcpy(pTmp, p, dataSize + 4); - p += dataSize + 4; - size += dataSize + 4; - } - - } - - if(size < *dataLen) - { - // clean old extra info block. - memset(pData,0, *dataLen); - - // copy the new extra info block over the old - if(size > 0) - memcpy(pData, pNewHeader, size); - - // set the new extra info size - *dataLen = size; - - retVal = ZIP_OK; - } - else - retVal = ZIP_ERRNO; - - TRYFREE(pNewHeader); - - return retVal; -} DELETED compat/zlib/contrib/minizip/zip.h Index: compat/zlib/contrib/minizip/zip.h ================================================================== --- compat/zlib/contrib/minizip/zip.h +++ /dev/null @@ -1,362 +0,0 @@ -/* zip.h -- IO on .zip files using zlib - Version 1.1, February 14h, 2010 - part of the MiniZip project - ( http://www.winimage.com/zLibDll/minizip.html ) - - Copyright (C) 1998-2010 Gilles Vollant (minizip) ( http://www.winimage.com/zLibDll/minizip.html ) - - Modifications for Zip64 support - Copyright (C) 2009-2010 Mathias Svensson ( http://result42.com ) - - For more info read MiniZip_info.txt - - --------------------------------------------------------------------------- - - Condition of use and distribution are the same than zlib : - - This software is provided 'as-is', without any express or implied - warranty. In no event will the authors be held liable for any damages - arising from the use of this software. - - Permission is granted to anyone to use this software for any purpose, - including commercial applications, and to alter it and redistribute it - freely, subject to the following restrictions: - - 1. The origin of this software must not be misrepresented; you must not - claim that you wrote the original software. If you use this software - in a product, an acknowledgment in the product documentation would be - appreciated but is not required. - 2. Altered source versions must be plainly marked as such, and must not be - misrepresented as being the original software. - 3. This notice may not be removed or altered from any source distribution. - - --------------------------------------------------------------------------- - - Changes - - See header of zip.h - -*/ - -#ifndef _zip12_H -#define _zip12_H - -#ifdef __cplusplus -extern "C" { -#endif - -//#define HAVE_BZIP2 - -#ifndef _ZLIB_H -#include "zlib.h" -#endif - -#ifndef _ZLIBIOAPI_H -#include "ioapi.h" -#endif - -#ifdef HAVE_BZIP2 -#include "bzlib.h" -#endif - -#define Z_BZIP2ED 12 - -#if defined(STRICTZIP) || defined(STRICTZIPUNZIP) -/* like the STRICT of WIN32, we define a pointer that cannot be converted - from (void*) without cast */ -typedef struct TagzipFile__ { int unused; } zipFile__; -typedef zipFile__ *zipFile; -#else -typedef voidp zipFile; -#endif - -#define ZIP_OK (0) -#define ZIP_EOF (0) -#define ZIP_ERRNO (Z_ERRNO) -#define ZIP_PARAMERROR (-102) -#define ZIP_BADZIPFILE (-103) -#define ZIP_INTERNALERROR (-104) - -#ifndef DEF_MEM_LEVEL -# if MAX_MEM_LEVEL >= 8 -# define DEF_MEM_LEVEL 8 -# else -# define DEF_MEM_LEVEL MAX_MEM_LEVEL -# endif -#endif -/* default memLevel */ - -/* tm_zip contain date/time info */ -typedef struct tm_zip_s -{ - uInt tm_sec; /* seconds after the minute - [0,59] */ - uInt tm_min; /* minutes after the hour - [0,59] */ - uInt tm_hour; /* hours since midnight - [0,23] */ - uInt tm_mday; /* day of the month - [1,31] */ - uInt tm_mon; /* months since January - [0,11] */ - uInt tm_year; /* years - [1980..2044] */ -} tm_zip; - -typedef struct -{ - tm_zip tmz_date; /* date in understandable format */ - uLong dosDate; /* if dos_date == 0, tmu_date is used */ -/* uLong flag; */ /* general purpose bit flag 2 bytes */ - - uLong internal_fa; /* internal file attributes 2 bytes */ - uLong external_fa; /* external file attributes 4 bytes */ -} zip_fileinfo; - -typedef const char* zipcharpc; - - -#define APPEND_STATUS_CREATE (0) -#define APPEND_STATUS_CREATEAFTER (1) -#define APPEND_STATUS_ADDINZIP (2) - -extern zipFile ZEXPORT zipOpen OF((const char *pathname, int append)); -extern zipFile ZEXPORT zipOpen64 OF((const void *pathname, int append)); -/* - Create a zipfile. - pathname contain on Windows XP a filename like "c:\\zlib\\zlib113.zip" or on - an Unix computer "zlib/zlib113.zip". - if the file pathname exist and append==APPEND_STATUS_CREATEAFTER, the zip - will be created at the end of the file. - (useful if the file contain a self extractor code) - if the file pathname exist and append==APPEND_STATUS_ADDINZIP, we will - add files in existing zip (be sure you don't add file that doesn't exist) - If the zipfile cannot be opened, the return value is NULL. - Else, the return value is a zipFile Handle, usable with other function - of this zip package. -*/ - -/* Note : there is no delete function into a zipfile. - If you want delete file into a zipfile, you must open a zipfile, and create another - Of couse, you can use RAW reading and writing to copy the file you did not want delte -*/ - -extern zipFile ZEXPORT zipOpen2 OF((const char *pathname, - int append, - zipcharpc* globalcomment, - zlib_filefunc_def* pzlib_filefunc_def)); - -extern zipFile ZEXPORT zipOpen2_64 OF((const void *pathname, - int append, - zipcharpc* globalcomment, - zlib_filefunc64_def* pzlib_filefunc_def)); - -extern int ZEXPORT zipOpenNewFileInZip OF((zipFile file, - const char* filename, - const zip_fileinfo* zipfi, - const void* extrafield_local, - uInt size_extrafield_local, - const void* extrafield_global, - uInt size_extrafield_global, - const char* comment, - int method, - int level)); - -extern int ZEXPORT zipOpenNewFileInZip64 OF((zipFile file, - const char* filename, - const zip_fileinfo* zipfi, - const void* extrafield_local, - uInt size_extrafield_local, - const void* extrafield_global, - uInt size_extrafield_global, - const char* comment, - int method, - int level, - int zip64)); - -/* - Open a file in the ZIP for writing. - filename : the filename in zip (if NULL, '-' without quote will be used - *zipfi contain supplemental information - if extrafield_local!=NULL and size_extrafield_local>0, extrafield_local - contains the extrafield data the the local header - if extrafield_global!=NULL and size_extrafield_global>0, extrafield_global - contains the extrafield data the the local header - if comment != NULL, comment contain the comment string - method contain the compression method (0 for store, Z_DEFLATED for deflate) - level contain the level of compression (can be Z_DEFAULT_COMPRESSION) - zip64 is set to 1 if a zip64 extended information block should be added to the local file header. - this MUST be '1' if the uncompressed size is >= 0xffffffff. - -*/ - - -extern int ZEXPORT zipOpenNewFileInZip2 OF((zipFile file, - const char* filename, - const zip_fileinfo* zipfi, - const void* extrafield_local, - uInt size_extrafield_local, - const void* extrafield_global, - uInt size_extrafield_global, - const char* comment, - int method, - int level, - int raw)); - - -extern int ZEXPORT zipOpenNewFileInZip2_64 OF((zipFile file, - const char* filename, - const zip_fileinfo* zipfi, - const void* extrafield_local, - uInt size_extrafield_local, - const void* extrafield_global, - uInt size_extrafield_global, - const char* comment, - int method, - int level, - int raw, - int zip64)); -/* - Same than zipOpenNewFileInZip, except if raw=1, we write raw file - */ - -extern int ZEXPORT zipOpenNewFileInZip3 OF((zipFile file, - const char* filename, - const zip_fileinfo* zipfi, - const void* extrafield_local, - uInt size_extrafield_local, - const void* extrafield_global, - uInt size_extrafield_global, - const char* comment, - int method, - int level, - int raw, - int windowBits, - int memLevel, - int strategy, - const char* password, - uLong crcForCrypting)); - -extern int ZEXPORT zipOpenNewFileInZip3_64 OF((zipFile file, - const char* filename, - const zip_fileinfo* zipfi, - const void* extrafield_local, - uInt size_extrafield_local, - const void* extrafield_global, - uInt size_extrafield_global, - const char* comment, - int method, - int level, - int raw, - int windowBits, - int memLevel, - int strategy, - const char* password, - uLong crcForCrypting, - int zip64 - )); - -/* - Same than zipOpenNewFileInZip2, except - windowBits,memLevel,,strategy : see parameter strategy in deflateInit2 - password : crypting password (NULL for no crypting) - crcForCrypting : crc of file to compress (needed for crypting) - */ - -extern int ZEXPORT zipOpenNewFileInZip4 OF((zipFile file, - const char* filename, - const zip_fileinfo* zipfi, - const void* extrafield_local, - uInt size_extrafield_local, - const void* extrafield_global, - uInt size_extrafield_global, - const char* comment, - int method, - int level, - int raw, - int windowBits, - int memLevel, - int strategy, - const char* password, - uLong crcForCrypting, - uLong versionMadeBy, - uLong flagBase - )); - - -extern int ZEXPORT zipOpenNewFileInZip4_64 OF((zipFile file, - const char* filename, - const zip_fileinfo* zipfi, - const void* extrafield_local, - uInt size_extrafield_local, - const void* extrafield_global, - uInt size_extrafield_global, - const char* comment, - int method, - int level, - int raw, - int windowBits, - int memLevel, - int strategy, - const char* password, - uLong crcForCrypting, - uLong versionMadeBy, - uLong flagBase, - int zip64 - )); -/* - Same than zipOpenNewFileInZip4, except - versionMadeBy : value for Version made by field - flag : value for flag field (compression level info will be added) - */ - - -extern int ZEXPORT zipWriteInFileInZip OF((zipFile file, - const void* buf, - unsigned len)); -/* - Write data in the zipfile -*/ - -extern int ZEXPORT zipCloseFileInZip OF((zipFile file)); -/* - Close the current file in the zipfile -*/ - -extern int ZEXPORT zipCloseFileInZipRaw OF((zipFile file, - uLong uncompressed_size, - uLong crc32)); - -extern int ZEXPORT zipCloseFileInZipRaw64 OF((zipFile file, - ZPOS64_T uncompressed_size, - uLong crc32)); - -/* - Close the current file in the zipfile, for file opened with - parameter raw=1 in zipOpenNewFileInZip2 - uncompressed_size and crc32 are value for the uncompressed size -*/ - -extern int ZEXPORT zipClose OF((zipFile file, - const char* global_comment)); -/* - Close the zipfile -*/ - - -extern int ZEXPORT zipRemoveExtraInfoBlock OF((char* pData, int* dataLen, short sHeader)); -/* - zipRemoveExtraInfoBlock - Added by Mathias Svensson - - Remove extra information block from a extra information data for the local file header or central directory header - - It is needed to remove ZIP64 extra information blocks when before data is written if using RAW mode. - - 0x0001 is the signature header for the ZIP64 extra information blocks - - usage. - Remove ZIP64 Extra information from a central director extra field data - zipRemoveExtraInfoBlock(pCenDirExtraFieldData, &nCenDirExtraFieldDataLen, 0x0001); - - Remove ZIP64 Extra information from a Local File Header extra field data - zipRemoveExtraInfoBlock(pLocalHeaderExtraFieldData, &nLocalHeaderExtraFieldDataLen, 0x0001); -*/ - -#ifdef __cplusplus -} -#endif - -#endif /* _zip64_H */ DELETED compat/zlib/contrib/pascal/example.pas Index: compat/zlib/contrib/pascal/example.pas ================================================================== --- compat/zlib/contrib/pascal/example.pas +++ /dev/null @@ -1,599 +0,0 @@ -(* example.c -- usage example of the zlib compression library - * Copyright (C) 1995-2003 Jean-loup Gailly. - * For conditions of distribution and use, see copyright notice in zlib.h - * - * Pascal translation - * Copyright (C) 1998 by Jacques Nomssi Nzali. - * For conditions of distribution and use, see copyright notice in readme.txt - * - * Adaptation to the zlibpas interface - * Copyright (C) 2003 by Cosmin Truta. - * For conditions of distribution and use, see copyright notice in readme.txt - *) - -program example; - -{$DEFINE TEST_COMPRESS} -{DO NOT $DEFINE TEST_GZIO} -{$DEFINE TEST_DEFLATE} -{$DEFINE TEST_INFLATE} -{$DEFINE TEST_FLUSH} -{$DEFINE TEST_SYNC} -{$DEFINE TEST_DICT} - -uses SysUtils, zlibpas; - -const TESTFILE = 'foo.gz'; - -(* "hello world" would be more standard, but the repeated "hello" - * stresses the compression code better, sorry... - *) -const hello: PChar = 'hello, hello!'; - -const dictionary: PChar = 'hello'; - -var dictId: LongInt; (* Adler32 value of the dictionary *) - -procedure CHECK_ERR(err: Integer; msg: String); -begin - if err <> Z_OK then - begin - WriteLn(msg, ' error: ', err); - Halt(1); - end; -end; - -procedure EXIT_ERR(const msg: String); -begin - WriteLn('Error: ', msg); - Halt(1); -end; - -(* =========================================================================== - * Test compress and uncompress - *) -{$IFDEF TEST_COMPRESS} -procedure test_compress(compr: Pointer; comprLen: LongInt; - uncompr: Pointer; uncomprLen: LongInt); -var err: Integer; - len: LongInt; -begin - len := StrLen(hello)+1; - - err := compress(compr, comprLen, hello, len); - CHECK_ERR(err, 'compress'); - - StrCopy(PChar(uncompr), 'garbage'); - - err := uncompress(uncompr, uncomprLen, compr, comprLen); - CHECK_ERR(err, 'uncompress'); - - if StrComp(PChar(uncompr), hello) <> 0 then - EXIT_ERR('bad uncompress') - else - WriteLn('uncompress(): ', PChar(uncompr)); -end; -{$ENDIF} - -(* =========================================================================== - * Test read/write of .gz files - *) -{$IFDEF TEST_GZIO} -procedure test_gzio(const fname: PChar; (* compressed file name *) - uncompr: Pointer; - uncomprLen: LongInt); -var err: Integer; - len: Integer; - zfile: gzFile; - pos: LongInt; -begin - len := StrLen(hello)+1; - - zfile := gzopen(fname, 'wb'); - if zfile = NIL then - begin - WriteLn('gzopen error'); - Halt(1); - end; - gzputc(zfile, 'h'); - if gzputs(zfile, 'ello') <> 4 then - begin - WriteLn('gzputs err: ', gzerror(zfile, err)); - Halt(1); - end; - {$IFDEF GZ_FORMAT_STRING} - if gzprintf(zfile, ', %s!', 'hello') <> 8 then - begin - WriteLn('gzprintf err: ', gzerror(zfile, err)); - Halt(1); - end; - {$ELSE} - if gzputs(zfile, ', hello!') <> 8 then - begin - WriteLn('gzputs err: ', gzerror(zfile, err)); - Halt(1); - end; - {$ENDIF} - gzseek(zfile, 1, SEEK_CUR); (* add one zero byte *) - gzclose(zfile); - - zfile := gzopen(fname, 'rb'); - if zfile = NIL then - begin - WriteLn('gzopen error'); - Halt(1); - end; - - StrCopy(PChar(uncompr), 'garbage'); - - if gzread(zfile, uncompr, uncomprLen) <> len then - begin - WriteLn('gzread err: ', gzerror(zfile, err)); - Halt(1); - end; - if StrComp(PChar(uncompr), hello) <> 0 then - begin - WriteLn('bad gzread: ', PChar(uncompr)); - Halt(1); - end - else - WriteLn('gzread(): ', PChar(uncompr)); - - pos := gzseek(zfile, -8, SEEK_CUR); - if (pos <> 6) or (gztell(zfile) <> pos) then - begin - WriteLn('gzseek error, pos=', pos, ', gztell=', gztell(zfile)); - Halt(1); - end; - - if gzgetc(zfile) <> ' ' then - begin - WriteLn('gzgetc error'); - Halt(1); - end; - - if gzungetc(' ', zfile) <> ' ' then - begin - WriteLn('gzungetc error'); - Halt(1); - end; - - gzgets(zfile, PChar(uncompr), uncomprLen); - uncomprLen := StrLen(PChar(uncompr)); - if uncomprLen <> 7 then (* " hello!" *) - begin - WriteLn('gzgets err after gzseek: ', gzerror(zfile, err)); - Halt(1); - end; - if StrComp(PChar(uncompr), hello + 6) <> 0 then - begin - WriteLn('bad gzgets after gzseek'); - Halt(1); - end - else - WriteLn('gzgets() after gzseek: ', PChar(uncompr)); - - gzclose(zfile); -end; -{$ENDIF} - -(* =========================================================================== - * Test deflate with small buffers - *) -{$IFDEF TEST_DEFLATE} -procedure test_deflate(compr: Pointer; comprLen: LongInt); -var c_stream: z_stream; (* compression stream *) - err: Integer; - len: LongInt; -begin - len := StrLen(hello)+1; - - c_stream.zalloc := NIL; - c_stream.zfree := NIL; - c_stream.opaque := NIL; - - err := deflateInit(c_stream, Z_DEFAULT_COMPRESSION); - CHECK_ERR(err, 'deflateInit'); - - c_stream.next_in := hello; - c_stream.next_out := compr; - - while (c_stream.total_in <> len) and - (c_stream.total_out < comprLen) do - begin - c_stream.avail_out := 1; { force small buffers } - c_stream.avail_in := 1; - err := deflate(c_stream, Z_NO_FLUSH); - CHECK_ERR(err, 'deflate'); - end; - - (* Finish the stream, still forcing small buffers: *) - while TRUE do - begin - c_stream.avail_out := 1; - err := deflate(c_stream, Z_FINISH); - if err = Z_STREAM_END then - break; - CHECK_ERR(err, 'deflate'); - end; - - err := deflateEnd(c_stream); - CHECK_ERR(err, 'deflateEnd'); -end; -{$ENDIF} - -(* =========================================================================== - * Test inflate with small buffers - *) -{$IFDEF TEST_INFLATE} -procedure test_inflate(compr: Pointer; comprLen : LongInt; - uncompr: Pointer; uncomprLen : LongInt); -var err: Integer; - d_stream: z_stream; (* decompression stream *) -begin - StrCopy(PChar(uncompr), 'garbage'); - - d_stream.zalloc := NIL; - d_stream.zfree := NIL; - d_stream.opaque := NIL; - - d_stream.next_in := compr; - d_stream.avail_in := 0; - d_stream.next_out := uncompr; - - err := inflateInit(d_stream); - CHECK_ERR(err, 'inflateInit'); - - while (d_stream.total_out < uncomprLen) and - (d_stream.total_in < comprLen) do - begin - d_stream.avail_out := 1; (* force small buffers *) - d_stream.avail_in := 1; - err := inflate(d_stream, Z_NO_FLUSH); - if err = Z_STREAM_END then - break; - CHECK_ERR(err, 'inflate'); - end; - - err := inflateEnd(d_stream); - CHECK_ERR(err, 'inflateEnd'); - - if StrComp(PChar(uncompr), hello) <> 0 then - EXIT_ERR('bad inflate') - else - WriteLn('inflate(): ', PChar(uncompr)); -end; -{$ENDIF} - -(* =========================================================================== - * Test deflate with large buffers and dynamic change of compression level - *) -{$IFDEF TEST_DEFLATE} -procedure test_large_deflate(compr: Pointer; comprLen: LongInt; - uncompr: Pointer; uncomprLen: LongInt); -var c_stream: z_stream; (* compression stream *) - err: Integer; -begin - c_stream.zalloc := NIL; - c_stream.zfree := NIL; - c_stream.opaque := NIL; - - err := deflateInit(c_stream, Z_BEST_SPEED); - CHECK_ERR(err, 'deflateInit'); - - c_stream.next_out := compr; - c_stream.avail_out := Integer(comprLen); - - (* At this point, uncompr is still mostly zeroes, so it should compress - * very well: - *) - c_stream.next_in := uncompr; - c_stream.avail_in := Integer(uncomprLen); - err := deflate(c_stream, Z_NO_FLUSH); - CHECK_ERR(err, 'deflate'); - if c_stream.avail_in <> 0 then - EXIT_ERR('deflate not greedy'); - - (* Feed in already compressed data and switch to no compression: *) - deflateParams(c_stream, Z_NO_COMPRESSION, Z_DEFAULT_STRATEGY); - c_stream.next_in := compr; - c_stream.avail_in := Integer(comprLen div 2); - err := deflate(c_stream, Z_NO_FLUSH); - CHECK_ERR(err, 'deflate'); - - (* Switch back to compressing mode: *) - deflateParams(c_stream, Z_BEST_COMPRESSION, Z_FILTERED); - c_stream.next_in := uncompr; - c_stream.avail_in := Integer(uncomprLen); - err := deflate(c_stream, Z_NO_FLUSH); - CHECK_ERR(err, 'deflate'); - - err := deflate(c_stream, Z_FINISH); - if err <> Z_STREAM_END then - EXIT_ERR('deflate should report Z_STREAM_END'); - - err := deflateEnd(c_stream); - CHECK_ERR(err, 'deflateEnd'); -end; -{$ENDIF} - -(* =========================================================================== - * Test inflate with large buffers - *) -{$IFDEF TEST_INFLATE} -procedure test_large_inflate(compr: Pointer; comprLen: LongInt; - uncompr: Pointer; uncomprLen: LongInt); -var err: Integer; - d_stream: z_stream; (* decompression stream *) -begin - StrCopy(PChar(uncompr), 'garbage'); - - d_stream.zalloc := NIL; - d_stream.zfree := NIL; - d_stream.opaque := NIL; - - d_stream.next_in := compr; - d_stream.avail_in := Integer(comprLen); - - err := inflateInit(d_stream); - CHECK_ERR(err, 'inflateInit'); - - while TRUE do - begin - d_stream.next_out := uncompr; (* discard the output *) - d_stream.avail_out := Integer(uncomprLen); - err := inflate(d_stream, Z_NO_FLUSH); - if err = Z_STREAM_END then - break; - CHECK_ERR(err, 'large inflate'); - end; - - err := inflateEnd(d_stream); - CHECK_ERR(err, 'inflateEnd'); - - if d_stream.total_out <> 2 * uncomprLen + comprLen div 2 then - begin - WriteLn('bad large inflate: ', d_stream.total_out); - Halt(1); - end - else - WriteLn('large_inflate(): OK'); -end; -{$ENDIF} - -(* =========================================================================== - * Test deflate with full flush - *) -{$IFDEF TEST_FLUSH} -procedure test_flush(compr: Pointer; var comprLen : LongInt); -var c_stream: z_stream; (* compression stream *) - err: Integer; - len: Integer; -begin - len := StrLen(hello)+1; - - c_stream.zalloc := NIL; - c_stream.zfree := NIL; - c_stream.opaque := NIL; - - err := deflateInit(c_stream, Z_DEFAULT_COMPRESSION); - CHECK_ERR(err, 'deflateInit'); - - c_stream.next_in := hello; - c_stream.next_out := compr; - c_stream.avail_in := 3; - c_stream.avail_out := Integer(comprLen); - err := deflate(c_stream, Z_FULL_FLUSH); - CHECK_ERR(err, 'deflate'); - - Inc(PByteArray(compr)^[3]); (* force an error in first compressed block *) - c_stream.avail_in := len - 3; - - err := deflate(c_stream, Z_FINISH); - if err <> Z_STREAM_END then - CHECK_ERR(err, 'deflate'); - - err := deflateEnd(c_stream); - CHECK_ERR(err, 'deflateEnd'); - - comprLen := c_stream.total_out; -end; -{$ENDIF} - -(* =========================================================================== - * Test inflateSync() - *) -{$IFDEF TEST_SYNC} -procedure test_sync(compr: Pointer; comprLen: LongInt; - uncompr: Pointer; uncomprLen : LongInt); -var err: Integer; - d_stream: z_stream; (* decompression stream *) -begin - StrCopy(PChar(uncompr), 'garbage'); - - d_stream.zalloc := NIL; - d_stream.zfree := NIL; - d_stream.opaque := NIL; - - d_stream.next_in := compr; - d_stream.avail_in := 2; (* just read the zlib header *) - - err := inflateInit(d_stream); - CHECK_ERR(err, 'inflateInit'); - - d_stream.next_out := uncompr; - d_stream.avail_out := Integer(uncomprLen); - - inflate(d_stream, Z_NO_FLUSH); - CHECK_ERR(err, 'inflate'); - - d_stream.avail_in := Integer(comprLen-2); (* read all compressed data *) - err := inflateSync(d_stream); (* but skip the damaged part *) - CHECK_ERR(err, 'inflateSync'); - - err := inflate(d_stream, Z_FINISH); - if err <> Z_DATA_ERROR then - EXIT_ERR('inflate should report DATA_ERROR'); - (* Because of incorrect adler32 *) - - err := inflateEnd(d_stream); - CHECK_ERR(err, 'inflateEnd'); - - WriteLn('after inflateSync(): hel', PChar(uncompr)); -end; -{$ENDIF} - -(* =========================================================================== - * Test deflate with preset dictionary - *) -{$IFDEF TEST_DICT} -procedure test_dict_deflate(compr: Pointer; comprLen: LongInt); -var c_stream: z_stream; (* compression stream *) - err: Integer; -begin - c_stream.zalloc := NIL; - c_stream.zfree := NIL; - c_stream.opaque := NIL; - - err := deflateInit(c_stream, Z_BEST_COMPRESSION); - CHECK_ERR(err, 'deflateInit'); - - err := deflateSetDictionary(c_stream, dictionary, StrLen(dictionary)); - CHECK_ERR(err, 'deflateSetDictionary'); - - dictId := c_stream.adler; - c_stream.next_out := compr; - c_stream.avail_out := Integer(comprLen); - - c_stream.next_in := hello; - c_stream.avail_in := StrLen(hello)+1; - - err := deflate(c_stream, Z_FINISH); - if err <> Z_STREAM_END then - EXIT_ERR('deflate should report Z_STREAM_END'); - - err := deflateEnd(c_stream); - CHECK_ERR(err, 'deflateEnd'); -end; -{$ENDIF} - -(* =========================================================================== - * Test inflate with a preset dictionary - *) -{$IFDEF TEST_DICT} -procedure test_dict_inflate(compr: Pointer; comprLen: LongInt; - uncompr: Pointer; uncomprLen: LongInt); -var err: Integer; - d_stream: z_stream; (* decompression stream *) -begin - StrCopy(PChar(uncompr), 'garbage'); - - d_stream.zalloc := NIL; - d_stream.zfree := NIL; - d_stream.opaque := NIL; - - d_stream.next_in := compr; - d_stream.avail_in := Integer(comprLen); - - err := inflateInit(d_stream); - CHECK_ERR(err, 'inflateInit'); - - d_stream.next_out := uncompr; - d_stream.avail_out := Integer(uncomprLen); - - while TRUE do - begin - err := inflate(d_stream, Z_NO_FLUSH); - if err = Z_STREAM_END then - break; - if err = Z_NEED_DICT then - begin - if d_stream.adler <> dictId then - EXIT_ERR('unexpected dictionary'); - err := inflateSetDictionary(d_stream, dictionary, StrLen(dictionary)); - end; - CHECK_ERR(err, 'inflate with dict'); - end; - - err := inflateEnd(d_stream); - CHECK_ERR(err, 'inflateEnd'); - - if StrComp(PChar(uncompr), hello) <> 0 then - EXIT_ERR('bad inflate with dict') - else - WriteLn('inflate with dictionary: ', PChar(uncompr)); -end; -{$ENDIF} - -var compr, uncompr: Pointer; - comprLen, uncomprLen: LongInt; - -begin - if zlibVersion^ <> ZLIB_VERSION[1] then - EXIT_ERR('Incompatible zlib version'); - - WriteLn('zlib version: ', zlibVersion); - WriteLn('zlib compile flags: ', Format('0x%x', [zlibCompileFlags])); - - comprLen := 10000 * SizeOf(Integer); (* don't overflow on MSDOS *) - uncomprLen := comprLen; - GetMem(compr, comprLen); - GetMem(uncompr, uncomprLen); - if (compr = NIL) or (uncompr = NIL) then - EXIT_ERR('Out of memory'); - (* compr and uncompr are cleared to avoid reading uninitialized - * data and to ensure that uncompr compresses well. - *) - FillChar(compr^, comprLen, 0); - FillChar(uncompr^, uncomprLen, 0); - - {$IFDEF TEST_COMPRESS} - WriteLn('** Testing compress'); - test_compress(compr, comprLen, uncompr, uncomprLen); - {$ENDIF} - - {$IFDEF TEST_GZIO} - WriteLn('** Testing gzio'); - if ParamCount >= 1 then - test_gzio(ParamStr(1), uncompr, uncomprLen) - else - test_gzio(TESTFILE, uncompr, uncomprLen); - {$ENDIF} - - {$IFDEF TEST_DEFLATE} - WriteLn('** Testing deflate with small buffers'); - test_deflate(compr, comprLen); - {$ENDIF} - {$IFDEF TEST_INFLATE} - WriteLn('** Testing inflate with small buffers'); - test_inflate(compr, comprLen, uncompr, uncomprLen); - {$ENDIF} - - {$IFDEF TEST_DEFLATE} - WriteLn('** Testing deflate with large buffers'); - test_large_deflate(compr, comprLen, uncompr, uncomprLen); - {$ENDIF} - {$IFDEF TEST_INFLATE} - WriteLn('** Testing inflate with large buffers'); - test_large_inflate(compr, comprLen, uncompr, uncomprLen); - {$ENDIF} - - {$IFDEF TEST_FLUSH} - WriteLn('** Testing deflate with full flush'); - test_flush(compr, comprLen); - {$ENDIF} - {$IFDEF TEST_SYNC} - WriteLn('** Testing inflateSync'); - test_sync(compr, comprLen, uncompr, uncomprLen); - {$ENDIF} - comprLen := uncomprLen; - - {$IFDEF TEST_DICT} - WriteLn('** Testing deflate and inflate with preset dictionary'); - test_dict_deflate(compr, comprLen); - test_dict_inflate(compr, comprLen, uncompr, uncomprLen); - {$ENDIF} - - FreeMem(compr, comprLen); - FreeMem(uncompr, uncomprLen); -end. DELETED compat/zlib/contrib/pascal/readme.txt Index: compat/zlib/contrib/pascal/readme.txt ================================================================== --- compat/zlib/contrib/pascal/readme.txt +++ /dev/null @@ -1,76 +0,0 @@ - -This directory contains a Pascal (Delphi, Kylix) interface to the -zlib data compression library. - - -Directory listing -================= - -zlibd32.mak makefile for Borland C++ -example.pas usage example of zlib -zlibpas.pas the Pascal interface to zlib -readme.txt this file - - -Compatibility notes -=================== - -- Although the name "zlib" would have been more normal for the - zlibpas unit, this name is already taken by Borland's ZLib unit. - This is somehow unfortunate, because that unit is not a genuine - interface to the full-fledged zlib functionality, but a suite of - class wrappers around zlib streams. Other essential features, - such as checksums, are missing. - It would have been more appropriate for that unit to have a name - like "ZStreams", or something similar. - -- The C and zlib-supplied types int, uInt, long, uLong, etc. are - translated directly into Pascal types of similar sizes (Integer, - LongInt, etc.), to avoid namespace pollution. In particular, - there is no conversion of unsigned int into a Pascal unsigned - integer. The Word type is non-portable and has the same size - (16 bits) both in a 16-bit and in a 32-bit environment, unlike - Integer. Even if there is a 32-bit Cardinal type, there is no - real need for unsigned int in zlib under a 32-bit environment. - -- Except for the callbacks, the zlib function interfaces are - assuming the calling convention normally used in Pascal - (__pascal for DOS and Windows16, __fastcall for Windows32). - Since the cdecl keyword is used, the old Turbo Pascal does - not work with this interface. - -- The gz* function interfaces are not translated, to avoid - interfacing problems with the C runtime library. Besides, - gzprintf(gzFile file, const char *format, ...) - cannot be translated into Pascal. - - -Legal issues -============ - -The zlibpas interface is: - Copyright (C) 1995-2003 Jean-loup Gailly and Mark Adler. - Copyright (C) 1998 by Bob Dellaca. - Copyright (C) 2003 by Cosmin Truta. - -The example program is: - Copyright (C) 1995-2003 by Jean-loup Gailly. - Copyright (C) 1998,1999,2000 by Jacques Nomssi Nzali. - Copyright (C) 2003 by Cosmin Truta. - - This software is provided 'as-is', without any express or implied - warranty. In no event will the author be held liable for any damages - arising from the use of this software. - - Permission is granted to anyone to use this software for any purpose, - including commercial applications, and to alter it and redistribute it - freely, subject to the following restrictions: - - 1. The origin of this software must not be misrepresented; you must not - claim that you wrote the original software. If you use this software - in a product, an acknowledgment in the product documentation would be - appreciated but is not required. - 2. Altered source versions must be plainly marked as such, and must not be - misrepresented as being the original software. - 3. This notice may not be removed or altered from any source distribution. - DELETED compat/zlib/contrib/pascal/zlibd32.mak Index: compat/zlib/contrib/pascal/zlibd32.mak ================================================================== --- compat/zlib/contrib/pascal/zlibd32.mak +++ /dev/null @@ -1,99 +0,0 @@ -# Makefile for zlib -# For use with Delphi and C++ Builder under Win32 -# Updated for zlib 1.2.x by Cosmin Truta - -# ------------ Borland C++ ------------ - -# This project uses the Delphi (fastcall/register) calling convention: -LOC = -DZEXPORT=__fastcall -DZEXPORTVA=__cdecl - -CC = bcc32 -LD = bcc32 -AR = tlib -# do not use "-pr" in CFLAGS -CFLAGS = -a -d -k- -O2 $(LOC) -LDFLAGS = - - -# variables -ZLIB_LIB = zlib.lib - -OBJ1 = adler32.obj compress.obj crc32.obj deflate.obj gzclose.obj gzlib.obj gzread.obj -OBJ2 = gzwrite.obj infback.obj inffast.obj inflate.obj inftrees.obj trees.obj uncompr.obj zutil.obj -OBJP1 = +adler32.obj+compress.obj+crc32.obj+deflate.obj+gzclose.obj+gzlib.obj+gzread.obj -OBJP2 = +gzwrite.obj+infback.obj+inffast.obj+inflate.obj+inftrees.obj+trees.obj+uncompr.obj+zutil.obj - - -# targets -all: $(ZLIB_LIB) example.exe minigzip.exe - -.c.obj: - $(CC) -c $(CFLAGS) $*.c - -adler32.obj: adler32.c zlib.h zconf.h - -compress.obj: compress.c zlib.h zconf.h - -crc32.obj: crc32.c zlib.h zconf.h crc32.h - -deflate.obj: deflate.c deflate.h zutil.h zlib.h zconf.h - -gzclose.obj: gzclose.c zlib.h zconf.h gzguts.h - -gzlib.obj: gzlib.c zlib.h zconf.h gzguts.h - -gzread.obj: gzread.c zlib.h zconf.h gzguts.h - -gzwrite.obj: gzwrite.c zlib.h zconf.h gzguts.h - -infback.obj: infback.c zutil.h zlib.h zconf.h inftrees.h inflate.h \ - inffast.h inffixed.h - -inffast.obj: inffast.c zutil.h zlib.h zconf.h inftrees.h inflate.h \ - inffast.h - -inflate.obj: inflate.c zutil.h zlib.h zconf.h inftrees.h inflate.h \ - inffast.h inffixed.h - -inftrees.obj: inftrees.c zutil.h zlib.h zconf.h inftrees.h - -trees.obj: trees.c zutil.h zlib.h zconf.h deflate.h trees.h - -uncompr.obj: uncompr.c zlib.h zconf.h - -zutil.obj: zutil.c zutil.h zlib.h zconf.h - -example.obj: test/example.c zlib.h zconf.h - -minigzip.obj: test/minigzip.c zlib.h zconf.h - - -# For the sake of the old Borland make, -# the command line is cut to fit in the MS-DOS 128 byte limit: -$(ZLIB_LIB): $(OBJ1) $(OBJ2) - -del $(ZLIB_LIB) - $(AR) $(ZLIB_LIB) $(OBJP1) - $(AR) $(ZLIB_LIB) $(OBJP2) - - -# testing -test: example.exe minigzip.exe - example - echo hello world | minigzip | minigzip -d - -example.exe: example.obj $(ZLIB_LIB) - $(LD) $(LDFLAGS) example.obj $(ZLIB_LIB) - -minigzip.exe: minigzip.obj $(ZLIB_LIB) - $(LD) $(LDFLAGS) minigzip.obj $(ZLIB_LIB) - - -# cleanup -clean: - -del *.obj - -del *.exe - -del *.lib - -del *.tds - -del zlib.bak - -del foo.gz - DELETED compat/zlib/contrib/pascal/zlibpas.pas Index: compat/zlib/contrib/pascal/zlibpas.pas ================================================================== --- compat/zlib/contrib/pascal/zlibpas.pas +++ /dev/null @@ -1,276 +0,0 @@ -(* zlibpas -- Pascal interface to the zlib data compression library - * - * Copyright (C) 2003 Cosmin Truta. - * Derived from original sources by Bob Dellaca. - * For conditions of distribution and use, see copyright notice in readme.txt - *) - -unit zlibpas; - -interface - -const - ZLIB_VERSION = '1.2.11'; - ZLIB_VERNUM = $12a0; - -type - alloc_func = function(opaque: Pointer; items, size: Integer): Pointer; - cdecl; - free_func = procedure(opaque, address: Pointer); - cdecl; - - in_func = function(opaque: Pointer; var buf: PByte): Integer; - cdecl; - out_func = function(opaque: Pointer; buf: PByte; size: Integer): Integer; - cdecl; - - z_streamp = ^z_stream; - z_stream = packed record - next_in: PChar; (* next input byte *) - avail_in: Integer; (* number of bytes available at next_in *) - total_in: LongInt; (* total nb of input bytes read so far *) - - next_out: PChar; (* next output byte should be put there *) - avail_out: Integer; (* remaining free space at next_out *) - total_out: LongInt; (* total nb of bytes output so far *) - - msg: PChar; (* last error message, NULL if no error *) - state: Pointer; (* not visible by applications *) - - zalloc: alloc_func; (* used to allocate the internal state *) - zfree: free_func; (* used to free the internal state *) - opaque: Pointer; (* private data object passed to zalloc and zfree *) - - data_type: Integer; (* best guess about the data type: ascii or binary *) - adler: LongInt; (* adler32 value of the uncompressed data *) - reserved: LongInt; (* reserved for future use *) - end; - - gz_headerp = ^gz_header; - gz_header = packed record - text: Integer; (* true if compressed data believed to be text *) - time: LongInt; (* modification time *) - xflags: Integer; (* extra flags (not used when writing a gzip file) *) - os: Integer; (* operating system *) - extra: PChar; (* pointer to extra field or Z_NULL if none *) - extra_len: Integer; (* extra field length (valid if extra != Z_NULL) *) - extra_max: Integer; (* space at extra (only when reading header) *) - name: PChar; (* pointer to zero-terminated file name or Z_NULL *) - name_max: Integer; (* space at name (only when reading header) *) - comment: PChar; (* pointer to zero-terminated comment or Z_NULL *) - comm_max: Integer; (* space at comment (only when reading header) *) - hcrc: Integer; (* true if there was or will be a header crc *) - done: Integer; (* true when done reading gzip header *) - end; - -(* constants *) -const - Z_NO_FLUSH = 0; - Z_PARTIAL_FLUSH = 1; - Z_SYNC_FLUSH = 2; - Z_FULL_FLUSH = 3; - Z_FINISH = 4; - Z_BLOCK = 5; - Z_TREES = 6; - - Z_OK = 0; - Z_STREAM_END = 1; - Z_NEED_DICT = 2; - Z_ERRNO = -1; - Z_STREAM_ERROR = -2; - Z_DATA_ERROR = -3; - Z_MEM_ERROR = -4; - Z_BUF_ERROR = -5; - Z_VERSION_ERROR = -6; - - Z_NO_COMPRESSION = 0; - Z_BEST_SPEED = 1; - Z_BEST_COMPRESSION = 9; - Z_DEFAULT_COMPRESSION = -1; - - Z_FILTERED = 1; - Z_HUFFMAN_ONLY = 2; - Z_RLE = 3; - Z_FIXED = 4; - Z_DEFAULT_STRATEGY = 0; - - Z_BINARY = 0; - Z_TEXT = 1; - Z_ASCII = 1; - Z_UNKNOWN = 2; - - Z_DEFLATED = 8; - -(* basic functions *) -function zlibVersion: PChar; -function deflateInit(var strm: z_stream; level: Integer): Integer; -function deflate(var strm: z_stream; flush: Integer): Integer; -function deflateEnd(var strm: z_stream): Integer; -function inflateInit(var strm: z_stream): Integer; -function inflate(var strm: z_stream; flush: Integer): Integer; -function inflateEnd(var strm: z_stream): Integer; - -(* advanced functions *) -function deflateInit2(var strm: z_stream; level, method, windowBits, - memLevel, strategy: Integer): Integer; -function deflateSetDictionary(var strm: z_stream; const dictionary: PChar; - dictLength: Integer): Integer; -function deflateCopy(var dest, source: z_stream): Integer; -function deflateReset(var strm: z_stream): Integer; -function deflateParams(var strm: z_stream; level, strategy: Integer): Integer; -function deflateTune(var strm: z_stream; good_length, max_lazy, nice_length, max_chain: Integer): Integer; -function deflateBound(var strm: z_stream; sourceLen: LongInt): LongInt; -function deflatePending(var strm: z_stream; var pending: Integer; var bits: Integer): Integer; -function deflatePrime(var strm: z_stream; bits, value: Integer): Integer; -function deflateSetHeader(var strm: z_stream; head: gz_header): Integer; -function inflateInit2(var strm: z_stream; windowBits: Integer): Integer; -function inflateSetDictionary(var strm: z_stream; const dictionary: PChar; - dictLength: Integer): Integer; -function inflateSync(var strm: z_stream): Integer; -function inflateCopy(var dest, source: z_stream): Integer; -function inflateReset(var strm: z_stream): Integer; -function inflateReset2(var strm: z_stream; windowBits: Integer): Integer; -function inflatePrime(var strm: z_stream; bits, value: Integer): Integer; -function inflateMark(var strm: z_stream): LongInt; -function inflateGetHeader(var strm: z_stream; var head: gz_header): Integer; -function inflateBackInit(var strm: z_stream; - windowBits: Integer; window: PChar): Integer; -function inflateBack(var strm: z_stream; in_fn: in_func; in_desc: Pointer; - out_fn: out_func; out_desc: Pointer): Integer; -function inflateBackEnd(var strm: z_stream): Integer; -function zlibCompileFlags: LongInt; - -(* utility functions *) -function compress(dest: PChar; var destLen: LongInt; - const source: PChar; sourceLen: LongInt): Integer; -function compress2(dest: PChar; var destLen: LongInt; - const source: PChar; sourceLen: LongInt; - level: Integer): Integer; -function compressBound(sourceLen: LongInt): LongInt; -function uncompress(dest: PChar; var destLen: LongInt; - const source: PChar; sourceLen: LongInt): Integer; - -(* checksum functions *) -function adler32(adler: LongInt; const buf: PChar; len: Integer): LongInt; -function adler32_combine(adler1, adler2, len2: LongInt): LongInt; -function crc32(crc: LongInt; const buf: PChar; len: Integer): LongInt; -function crc32_combine(crc1, crc2, len2: LongInt): LongInt; - -(* various hacks, don't look :) *) -function deflateInit_(var strm: z_stream; level: Integer; - const version: PChar; stream_size: Integer): Integer; -function inflateInit_(var strm: z_stream; const version: PChar; - stream_size: Integer): Integer; -function deflateInit2_(var strm: z_stream; - level, method, windowBits, memLevel, strategy: Integer; - const version: PChar; stream_size: Integer): Integer; -function inflateInit2_(var strm: z_stream; windowBits: Integer; - const version: PChar; stream_size: Integer): Integer; -function inflateBackInit_(var strm: z_stream; - windowBits: Integer; window: PChar; - const version: PChar; stream_size: Integer): Integer; - - -implementation - -{$L adler32.obj} -{$L compress.obj} -{$L crc32.obj} -{$L deflate.obj} -{$L infback.obj} -{$L inffast.obj} -{$L inflate.obj} -{$L inftrees.obj} -{$L trees.obj} -{$L uncompr.obj} -{$L zutil.obj} - -function adler32; external; -function adler32_combine; external; -function compress; external; -function compress2; external; -function compressBound; external; -function crc32; external; -function crc32_combine; external; -function deflate; external; -function deflateBound; external; -function deflateCopy; external; -function deflateEnd; external; -function deflateInit_; external; -function deflateInit2_; external; -function deflateParams; external; -function deflatePending; external; -function deflatePrime; external; -function deflateReset; external; -function deflateSetDictionary; external; -function deflateSetHeader; external; -function deflateTune; external; -function inflate; external; -function inflateBack; external; -function inflateBackEnd; external; -function inflateBackInit_; external; -function inflateCopy; external; -function inflateEnd; external; -function inflateGetHeader; external; -function inflateInit_; external; -function inflateInit2_; external; -function inflateMark; external; -function inflatePrime; external; -function inflateReset; external; -function inflateReset2; external; -function inflateSetDictionary; external; -function inflateSync; external; -function uncompress; external; -function zlibCompileFlags; external; -function zlibVersion; external; - -function deflateInit(var strm: z_stream; level: Integer): Integer; -begin - Result := deflateInit_(strm, level, ZLIB_VERSION, sizeof(z_stream)); -end; - -function deflateInit2(var strm: z_stream; level, method, windowBits, memLevel, - strategy: Integer): Integer; -begin - Result := deflateInit2_(strm, level, method, windowBits, memLevel, strategy, - ZLIB_VERSION, sizeof(z_stream)); -end; - -function inflateInit(var strm: z_stream): Integer; -begin - Result := inflateInit_(strm, ZLIB_VERSION, sizeof(z_stream)); -end; - -function inflateInit2(var strm: z_stream; windowBits: Integer): Integer; -begin - Result := inflateInit2_(strm, windowBits, ZLIB_VERSION, sizeof(z_stream)); -end; - -function inflateBackInit(var strm: z_stream; - windowBits: Integer; window: PChar): Integer; -begin - Result := inflateBackInit_(strm, windowBits, window, - ZLIB_VERSION, sizeof(z_stream)); -end; - -function _malloc(Size: Integer): Pointer; cdecl; -begin - GetMem(Result, Size); -end; - -procedure _free(Block: Pointer); cdecl; -begin - FreeMem(Block); -end; - -procedure _memset(P: Pointer; B: Byte; count: Integer); cdecl; -begin - FillChar(P^, count, B); -end; - -procedure _memcpy(dest, source: Pointer; count: Integer); cdecl; -begin - Move(source^, dest^, count); -end; - -end. DELETED compat/zlib/contrib/puff/Makefile Index: compat/zlib/contrib/puff/Makefile ================================================================== --- compat/zlib/contrib/puff/Makefile +++ /dev/null @@ -1,42 +0,0 @@ -CFLAGS=-O - -puff: puff.o pufftest.o - -puff.o: puff.h - -pufftest.o: puff.h - -test: puff - puff zeros.raw - -puft: puff.c puff.h pufftest.o - cc -fprofile-arcs -ftest-coverage -o puft puff.c pufftest.o - -# puff full coverage test (should say 100%) -cov: puft - @rm -f *.gcov *.gcda - @puft -w zeros.raw 2>&1 | cat > /dev/null - @echo '04' | xxd -r -p | puft 2> /dev/null || test $$? -eq 2 - @echo '00' | xxd -r -p | puft 2> /dev/null || test $$? -eq 2 - @echo '00 00 00 00 00' | xxd -r -p | puft 2> /dev/null || test $$? -eq 254 - @echo '00 01 00 fe ff' | xxd -r -p | puft 2> /dev/null || test $$? -eq 2 - @echo '01 01 00 fe ff 0a' | xxd -r -p | puft -f 2>&1 | cat > /dev/null - @echo '02 7e ff ff' | xxd -r -p | puft 2> /dev/null || test $$? -eq 246 - @echo '02' | xxd -r -p | puft 2> /dev/null || test $$? -eq 2 - @echo '04 80 49 92 24 49 92 24 0f b4 ff ff c3 04' | xxd -r -p | puft 2> /dev/null || test $$? -eq 2 - @echo '04 80 49 92 24 49 92 24 71 ff ff 93 11 00' | xxd -r -p | puft 2> /dev/null || test $$? -eq 249 - @echo '04 c0 81 08 00 00 00 00 20 7f eb 0b 00 00' | xxd -r -p | puft 2> /dev/null || test $$? -eq 246 - @echo '0b 00 00' | xxd -r -p | puft -f 2>&1 | cat > /dev/null - @echo '1a 07' | xxd -r -p | puft 2> /dev/null || test $$? -eq 246 - @echo '0c c0 81 00 00 00 00 00 90 ff 6b 04' | xxd -r -p | puft 2> /dev/null || test $$? -eq 245 - @puft -f zeros.raw 2>&1 | cat > /dev/null - @echo 'fc 00 00' | xxd -r -p | puft 2> /dev/null || test $$? -eq 253 - @echo '04 00 fe ff' | xxd -r -p | puft 2> /dev/null || test $$? -eq 252 - @echo '04 00 24 49' | xxd -r -p | puft 2> /dev/null || test $$? -eq 251 - @echo '04 80 49 92 24 49 92 24 0f b4 ff ff c3 84' | xxd -r -p | puft 2> /dev/null || test $$? -eq 248 - @echo '04 00 24 e9 ff ff' | xxd -r -p | puft 2> /dev/null || test $$? -eq 250 - @echo '04 00 24 e9 ff 6d' | xxd -r -p | puft 2> /dev/null || test $$? -eq 247 - @gcov -n puff.c - -clean: - rm -f puff puft *.o *.gc* DELETED compat/zlib/contrib/puff/README Index: compat/zlib/contrib/puff/README ================================================================== --- compat/zlib/contrib/puff/README +++ /dev/null @@ -1,63 +0,0 @@ -Puff -- A Simple Inflate -3 Mar 2003 -Mark Adler -madler@alumni.caltech.edu - -What this is -- - -puff.c provides the routine puff() to decompress the deflate data format. It -does so more slowly than zlib, but the code is about one-fifth the size of the -inflate code in zlib, and written to be very easy to read. - -Why I wrote this -- - -puff.c was written to document the deflate format unambiguously, by virtue of -being working C code. It is meant to supplement RFC 1951, which formally -describes the deflate format. I have received many questions on details of the -deflate format, and I hope that reading this code will answer those questions. -puff.c is heavily commented with details of the deflate format, especially -those little nooks and cranies of the format that might not be obvious from a -specification. - -puff.c may also be useful in applications where code size or memory usage is a -very limited resource, and speed is not as important. - -How to use it -- - -Well, most likely you should just be reading puff.c and using zlib for actual -applications, but if you must ... - -Include puff.h in your code, which provides this prototype: - -int puff(unsigned char *dest, /* pointer to destination pointer */ - unsigned long *destlen, /* amount of output space */ - unsigned char *source, /* pointer to source data pointer */ - unsigned long *sourcelen); /* amount of input available */ - -Then you can call puff() to decompress a deflate stream that is in memory in -its entirety at source, to a sufficiently sized block of memory for the -decompressed data at dest. puff() is the only external symbol in puff.c The -only C library functions that puff.c needs are setjmp() and longjmp(), which -are used to simplify error checking in the code to improve readabilty. puff.c -does no memory allocation, and uses less than 2K bytes off of the stack. - -If destlen is not enough space for the uncompressed data, then inflate will -return an error without writing more than destlen bytes. Note that this means -that in order to decompress the deflate data successfully, you need to know -the size of the uncompressed data ahead of time. - -If needed, puff() can determine the size of the uncompressed data with no -output space. This is done by passing dest equal to (unsigned char *)0. Then -the initial value of *destlen is ignored and *destlen is set to the length of -the uncompressed data. So if the size of the uncompressed data is not known, -then two passes of puff() can be used--first to determine the size, and second -to do the actual inflation after allocating the appropriate memory. Not -pretty, but it works. (This is one of the reasons you should be using zlib.) - -The deflate format is self-terminating. If the deflate stream does not end -in *sourcelen bytes, puff() will return an error without reading at or past -endsource. - -On return, *sourcelen is updated to the amount of input data consumed, and -*destlen is updated to the size of the uncompressed data. See the comments -in puff.c for the possible return codes for puff(). DELETED compat/zlib/contrib/puff/puff.c Index: compat/zlib/contrib/puff/puff.c ================================================================== --- compat/zlib/contrib/puff/puff.c +++ /dev/null @@ -1,840 +0,0 @@ -/* - * puff.c - * Copyright (C) 2002-2013 Mark Adler - * For conditions of distribution and use, see copyright notice in puff.h - * version 2.3, 21 Jan 2013 - * - * puff.c is a simple inflate written to be an unambiguous way to specify the - * deflate format. It is not written for speed but rather simplicity. As a - * side benefit, this code might actually be useful when small code is more - * important than speed, such as bootstrap applications. For typical deflate - * data, zlib's inflate() is about four times as fast as puff(). zlib's - * inflate compiles to around 20K on my machine, whereas puff.c compiles to - * around 4K on my machine (a PowerPC using GNU cc). If the faster decode() - * function here is used, then puff() is only twice as slow as zlib's - * inflate(). - * - * All dynamically allocated memory comes from the stack. The stack required - * is less than 2K bytes. This code is compatible with 16-bit int's and - * assumes that long's are at least 32 bits. puff.c uses the short data type, - * assumed to be 16 bits, for arrays in order to conserve memory. The code - * works whether integers are stored big endian or little endian. - * - * In the comments below are "Format notes" that describe the inflate process - * and document some of the less obvious aspects of the format. This source - * code is meant to supplement RFC 1951, which formally describes the deflate - * format: - * - * http://www.zlib.org/rfc-deflate.html - */ - -/* - * Change history: - * - * 1.0 10 Feb 2002 - First version - * 1.1 17 Feb 2002 - Clarifications of some comments and notes - * - Update puff() dest and source pointers on negative - * errors to facilitate debugging deflators - * - Remove longest from struct huffman -- not needed - * - Simplify offs[] index in construct() - * - Add input size and checking, using longjmp() to - * maintain easy readability - * - Use short data type for large arrays - * - Use pointers instead of long to specify source and - * destination sizes to avoid arbitrary 4 GB limits - * 1.2 17 Mar 2002 - Add faster version of decode(), doubles speed (!), - * but leave simple version for readabilty - * - Make sure invalid distances detected if pointers - * are 16 bits - * - Fix fixed codes table error - * - Provide a scanning mode for determining size of - * uncompressed data - * 1.3 20 Mar 2002 - Go back to lengths for puff() parameters [Gailly] - * - Add a puff.h file for the interface - * - Add braces in puff() for else do [Gailly] - * - Use indexes instead of pointers for readability - * 1.4 31 Mar 2002 - Simplify construct() code set check - * - Fix some comments - * - Add FIXLCODES #define - * 1.5 6 Apr 2002 - Minor comment fixes - * 1.6 7 Aug 2002 - Minor format changes - * 1.7 3 Mar 2003 - Added test code for distribution - * - Added zlib-like license - * 1.8 9 Jan 2004 - Added some comments on no distance codes case - * 1.9 21 Feb 2008 - Fix bug on 16-bit integer architectures [Pohland] - * - Catch missing end-of-block symbol error - * 2.0 25 Jul 2008 - Add #define to permit distance too far back - * - Add option in TEST code for puff to write the data - * - Add option in TEST code to skip input bytes - * - Allow TEST code to read from piped stdin - * 2.1 4 Apr 2010 - Avoid variable initialization for happier compilers - * - Avoid unsigned comparisons for even happier compilers - * 2.2 25 Apr 2010 - Fix bug in variable initializations [Oberhumer] - * - Add const where appropriate [Oberhumer] - * - Split if's and ?'s for coverage testing - * - Break out test code to separate file - * - Move NIL to puff.h - * - Allow incomplete code only if single code length is 1 - * - Add full code coverage test to Makefile - * 2.3 21 Jan 2013 - Check for invalid code length codes in dynamic blocks - */ - -#include /* for setjmp(), longjmp(), and jmp_buf */ -#include "puff.h" /* prototype for puff() */ - -#define local static /* for local function definitions */ - -/* - * Maximums for allocations and loops. It is not useful to change these -- - * they are fixed by the deflate format. - */ -#define MAXBITS 15 /* maximum bits in a code */ -#define MAXLCODES 286 /* maximum number of literal/length codes */ -#define MAXDCODES 30 /* maximum number of distance codes */ -#define MAXCODES (MAXLCODES+MAXDCODES) /* maximum codes lengths to read */ -#define FIXLCODES 288 /* number of fixed literal/length codes */ - -/* input and output state */ -struct state { - /* output state */ - unsigned char *out; /* output buffer */ - unsigned long outlen; /* available space at out */ - unsigned long outcnt; /* bytes written to out so far */ - - /* input state */ - const unsigned char *in; /* input buffer */ - unsigned long inlen; /* available input at in */ - unsigned long incnt; /* bytes read so far */ - int bitbuf; /* bit buffer */ - int bitcnt; /* number of bits in bit buffer */ - - /* input limit error return state for bits() and decode() */ - jmp_buf env; -}; - -/* - * Return need bits from the input stream. This always leaves less than - * eight bits in the buffer. bits() works properly for need == 0. - * - * Format notes: - * - * - Bits are stored in bytes from the least significant bit to the most - * significant bit. Therefore bits are dropped from the bottom of the bit - * buffer, using shift right, and new bytes are appended to the top of the - * bit buffer, using shift left. - */ -local int bits(struct state *s, int need) -{ - long val; /* bit accumulator (can use up to 20 bits) */ - - /* load at least need bits into val */ - val = s->bitbuf; - while (s->bitcnt < need) { - if (s->incnt == s->inlen) - longjmp(s->env, 1); /* out of input */ - val |= (long)(s->in[s->incnt++]) << s->bitcnt; /* load eight bits */ - s->bitcnt += 8; - } - - /* drop need bits and update buffer, always zero to seven bits left */ - s->bitbuf = (int)(val >> need); - s->bitcnt -= need; - - /* return need bits, zeroing the bits above that */ - return (int)(val & ((1L << need) - 1)); -} - -/* - * Process a stored block. - * - * Format notes: - * - * - After the two-bit stored block type (00), the stored block length and - * stored bytes are byte-aligned for fast copying. Therefore any leftover - * bits in the byte that has the last bit of the type, as many as seven, are - * discarded. The value of the discarded bits are not defined and should not - * be checked against any expectation. - * - * - The second inverted copy of the stored block length does not have to be - * checked, but it's probably a good idea to do so anyway. - * - * - A stored block can have zero length. This is sometimes used to byte-align - * subsets of the compressed data for random access or partial recovery. - */ -local int stored(struct state *s) -{ - unsigned len; /* length of stored block */ - - /* discard leftover bits from current byte (assumes s->bitcnt < 8) */ - s->bitbuf = 0; - s->bitcnt = 0; - - /* get length and check against its one's complement */ - if (s->incnt + 4 > s->inlen) - return 2; /* not enough input */ - len = s->in[s->incnt++]; - len |= s->in[s->incnt++] << 8; - if (s->in[s->incnt++] != (~len & 0xff) || - s->in[s->incnt++] != ((~len >> 8) & 0xff)) - return -2; /* didn't match complement! */ - - /* copy len bytes from in to out */ - if (s->incnt + len > s->inlen) - return 2; /* not enough input */ - if (s->out != NIL) { - if (s->outcnt + len > s->outlen) - return 1; /* not enough output space */ - while (len--) - s->out[s->outcnt++] = s->in[s->incnt++]; - } - else { /* just scanning */ - s->outcnt += len; - s->incnt += len; - } - - /* done with a valid stored block */ - return 0; -} - -/* - * Huffman code decoding tables. count[1..MAXBITS] is the number of symbols of - * each length, which for a canonical code are stepped through in order. - * symbol[] are the symbol values in canonical order, where the number of - * entries is the sum of the counts in count[]. The decoding process can be - * seen in the function decode() below. - */ -struct huffman { - short *count; /* number of symbols of each length */ - short *symbol; /* canonically ordered symbols */ -}; - -/* - * Decode a code from the stream s using huffman table h. Return the symbol or - * a negative value if there is an error. If all of the lengths are zero, i.e. - * an empty code, or if the code is incomplete and an invalid code is received, - * then -10 is returned after reading MAXBITS bits. - * - * Format notes: - * - * - The codes as stored in the compressed data are bit-reversed relative to - * a simple integer ordering of codes of the same lengths. Hence below the - * bits are pulled from the compressed data one at a time and used to - * build the code value reversed from what is in the stream in order to - * permit simple integer comparisons for decoding. A table-based decoding - * scheme (as used in zlib) does not need to do this reversal. - * - * - The first code for the shortest length is all zeros. Subsequent codes of - * the same length are simply integer increments of the previous code. When - * moving up a length, a zero bit is appended to the code. For a complete - * code, the last code of the longest length will be all ones. - * - * - Incomplete codes are handled by this decoder, since they are permitted - * in the deflate format. See the format notes for fixed() and dynamic(). - */ -#ifdef SLOW -local int decode(struct state *s, const struct huffman *h) -{ - int len; /* current number of bits in code */ - int code; /* len bits being decoded */ - int first; /* first code of length len */ - int count; /* number of codes of length len */ - int index; /* index of first code of length len in symbol table */ - - code = first = index = 0; - for (len = 1; len <= MAXBITS; len++) { - code |= bits(s, 1); /* get next bit */ - count = h->count[len]; - if (code - count < first) /* if length len, return symbol */ - return h->symbol[index + (code - first)]; - index += count; /* else update for next length */ - first += count; - first <<= 1; - code <<= 1; - } - return -10; /* ran out of codes */ -} - -/* - * A faster version of decode() for real applications of this code. It's not - * as readable, but it makes puff() twice as fast. And it only makes the code - * a few percent larger. - */ -#else /* !SLOW */ -local int decode(struct state *s, const struct huffman *h) -{ - int len; /* current number of bits in code */ - int code; /* len bits being decoded */ - int first; /* first code of length len */ - int count; /* number of codes of length len */ - int index; /* index of first code of length len in symbol table */ - int bitbuf; /* bits from stream */ - int left; /* bits left in next or left to process */ - short *next; /* next number of codes */ - - bitbuf = s->bitbuf; - left = s->bitcnt; - code = first = index = 0; - len = 1; - next = h->count + 1; - while (1) { - while (left--) { - code |= bitbuf & 1; - bitbuf >>= 1; - count = *next++; - if (code - count < first) { /* if length len, return symbol */ - s->bitbuf = bitbuf; - s->bitcnt = (s->bitcnt - len) & 7; - return h->symbol[index + (code - first)]; - } - index += count; /* else update for next length */ - first += count; - first <<= 1; - code <<= 1; - len++; - } - left = (MAXBITS+1) - len; - if (left == 0) - break; - if (s->incnt == s->inlen) - longjmp(s->env, 1); /* out of input */ - bitbuf = s->in[s->incnt++]; - if (left > 8) - left = 8; - } - return -10; /* ran out of codes */ -} -#endif /* SLOW */ - -/* - * Given the list of code lengths length[0..n-1] representing a canonical - * Huffman code for n symbols, construct the tables required to decode those - * codes. Those tables are the number of codes of each length, and the symbols - * sorted by length, retaining their original order within each length. The - * return value is zero for a complete code set, negative for an over- - * subscribed code set, and positive for an incomplete code set. The tables - * can be used if the return value is zero or positive, but they cannot be used - * if the return value is negative. If the return value is zero, it is not - * possible for decode() using that table to return an error--any stream of - * enough bits will resolve to a symbol. If the return value is positive, then - * it is possible for decode() using that table to return an error for received - * codes past the end of the incomplete lengths. - * - * Not used by decode(), but used for error checking, h->count[0] is the number - * of the n symbols not in the code. So n - h->count[0] is the number of - * codes. This is useful for checking for incomplete codes that have more than - * one symbol, which is an error in a dynamic block. - * - * Assumption: for all i in 0..n-1, 0 <= length[i] <= MAXBITS - * This is assured by the construction of the length arrays in dynamic() and - * fixed() and is not verified by construct(). - * - * Format notes: - * - * - Permitted and expected examples of incomplete codes are one of the fixed - * codes and any code with a single symbol which in deflate is coded as one - * bit instead of zero bits. See the format notes for fixed() and dynamic(). - * - * - Within a given code length, the symbols are kept in ascending order for - * the code bits definition. - */ -local int construct(struct huffman *h, const short *length, int n) -{ - int symbol; /* current symbol when stepping through length[] */ - int len; /* current length when stepping through h->count[] */ - int left; /* number of possible codes left of current length */ - short offs[MAXBITS+1]; /* offsets in symbol table for each length */ - - /* count number of codes of each length */ - for (len = 0; len <= MAXBITS; len++) - h->count[len] = 0; - for (symbol = 0; symbol < n; symbol++) - (h->count[length[symbol]])++; /* assumes lengths are within bounds */ - if (h->count[0] == n) /* no codes! */ - return 0; /* complete, but decode() will fail */ - - /* check for an over-subscribed or incomplete set of lengths */ - left = 1; /* one possible code of zero length */ - for (len = 1; len <= MAXBITS; len++) { - left <<= 1; /* one more bit, double codes left */ - left -= h->count[len]; /* deduct count from possible codes */ - if (left < 0) - return left; /* over-subscribed--return negative */ - } /* left > 0 means incomplete */ - - /* generate offsets into symbol table for each length for sorting */ - offs[1] = 0; - for (len = 1; len < MAXBITS; len++) - offs[len + 1] = offs[len] + h->count[len]; - - /* - * put symbols in table sorted by length, by symbol order within each - * length - */ - for (symbol = 0; symbol < n; symbol++) - if (length[symbol] != 0) - h->symbol[offs[length[symbol]]++] = symbol; - - /* return zero for complete set, positive for incomplete set */ - return left; -} - -/* - * Decode literal/length and distance codes until an end-of-block code. - * - * Format notes: - * - * - Compressed data that is after the block type if fixed or after the code - * description if dynamic is a combination of literals and length/distance - * pairs terminated by and end-of-block code. Literals are simply Huffman - * coded bytes. A length/distance pair is a coded length followed by a - * coded distance to represent a string that occurs earlier in the - * uncompressed data that occurs again at the current location. - * - * - Literals, lengths, and the end-of-block code are combined into a single - * code of up to 286 symbols. They are 256 literals (0..255), 29 length - * symbols (257..285), and the end-of-block symbol (256). - * - * - There are 256 possible lengths (3..258), and so 29 symbols are not enough - * to represent all of those. Lengths 3..10 and 258 are in fact represented - * by just a length symbol. Lengths 11..257 are represented as a symbol and - * some number of extra bits that are added as an integer to the base length - * of the length symbol. The number of extra bits is determined by the base - * length symbol. These are in the static arrays below, lens[] for the base - * lengths and lext[] for the corresponding number of extra bits. - * - * - The reason that 258 gets its own symbol is that the longest length is used - * often in highly redundant files. Note that 258 can also be coded as the - * base value 227 plus the maximum extra value of 31. While a good deflate - * should never do this, it is not an error, and should be decoded properly. - * - * - If a length is decoded, including its extra bits if any, then it is - * followed a distance code. There are up to 30 distance symbols. Again - * there are many more possible distances (1..32768), so extra bits are added - * to a base value represented by the symbol. The distances 1..4 get their - * own symbol, but the rest require extra bits. The base distances and - * corresponding number of extra bits are below in the static arrays dist[] - * and dext[]. - * - * - Literal bytes are simply written to the output. A length/distance pair is - * an instruction to copy previously uncompressed bytes to the output. The - * copy is from distance bytes back in the output stream, copying for length - * bytes. - * - * - Distances pointing before the beginning of the output data are not - * permitted. - * - * - Overlapped copies, where the length is greater than the distance, are - * allowed and common. For example, a distance of one and a length of 258 - * simply copies the last byte 258 times. A distance of four and a length of - * twelve copies the last four bytes three times. A simple forward copy - * ignoring whether the length is greater than the distance or not implements - * this correctly. You should not use memcpy() since its behavior is not - * defined for overlapped arrays. You should not use memmove() or bcopy() - * since though their behavior -is- defined for overlapping arrays, it is - * defined to do the wrong thing in this case. - */ -local int codes(struct state *s, - const struct huffman *lencode, - const struct huffman *distcode) -{ - int symbol; /* decoded symbol */ - int len; /* length for copy */ - unsigned dist; /* distance for copy */ - static const short lens[29] = { /* Size base for length codes 257..285 */ - 3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 15, 17, 19, 23, 27, 31, - 35, 43, 51, 59, 67, 83, 99, 115, 131, 163, 195, 227, 258}; - static const short lext[29] = { /* Extra bits for length codes 257..285 */ - 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 2, - 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 5, 5, 0}; - static const short dists[30] = { /* Offset base for distance codes 0..29 */ - 1, 2, 3, 4, 5, 7, 9, 13, 17, 25, 33, 49, 65, 97, 129, 193, - 257, 385, 513, 769, 1025, 1537, 2049, 3073, 4097, 6145, - 8193, 12289, 16385, 24577}; - static const short dext[30] = { /* Extra bits for distance codes 0..29 */ - 0, 0, 0, 0, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6, - 7, 7, 8, 8, 9, 9, 10, 10, 11, 11, - 12, 12, 13, 13}; - - /* decode literals and length/distance pairs */ - do { - symbol = decode(s, lencode); - if (symbol < 0) - return symbol; /* invalid symbol */ - if (symbol < 256) { /* literal: symbol is the byte */ - /* write out the literal */ - if (s->out != NIL) { - if (s->outcnt == s->outlen) - return 1; - s->out[s->outcnt] = symbol; - } - s->outcnt++; - } - else if (symbol > 256) { /* length */ - /* get and compute length */ - symbol -= 257; - if (symbol >= 29) - return -10; /* invalid fixed code */ - len = lens[symbol] + bits(s, lext[symbol]); - - /* get and check distance */ - symbol = decode(s, distcode); - if (symbol < 0) - return symbol; /* invalid symbol */ - dist = dists[symbol] + bits(s, dext[symbol]); -#ifndef INFLATE_ALLOW_INVALID_DISTANCE_TOOFAR_ARRR - if (dist > s->outcnt) - return -11; /* distance too far back */ -#endif - - /* copy length bytes from distance bytes back */ - if (s->out != NIL) { - if (s->outcnt + len > s->outlen) - return 1; - while (len--) { - s->out[s->outcnt] = -#ifdef INFLATE_ALLOW_INVALID_DISTANCE_TOOFAR_ARRR - dist > s->outcnt ? - 0 : -#endif - s->out[s->outcnt - dist]; - s->outcnt++; - } - } - else - s->outcnt += len; - } - } while (symbol != 256); /* end of block symbol */ - - /* done with a valid fixed or dynamic block */ - return 0; -} - -/* - * Process a fixed codes block. - * - * Format notes: - * - * - This block type can be useful for compressing small amounts of data for - * which the size of the code descriptions in a dynamic block exceeds the - * benefit of custom codes for that block. For fixed codes, no bits are - * spent on code descriptions. Instead the code lengths for literal/length - * codes and distance codes are fixed. The specific lengths for each symbol - * can be seen in the "for" loops below. - * - * - The literal/length code is complete, but has two symbols that are invalid - * and should result in an error if received. This cannot be implemented - * simply as an incomplete code since those two symbols are in the "middle" - * of the code. They are eight bits long and the longest literal/length\ - * code is nine bits. Therefore the code must be constructed with those - * symbols, and the invalid symbols must be detected after decoding. - * - * - The fixed distance codes also have two invalid symbols that should result - * in an error if received. Since all of the distance codes are the same - * length, this can be implemented as an incomplete code. Then the invalid - * codes are detected while decoding. - */ -local int fixed(struct state *s) -{ - static int virgin = 1; - static short lencnt[MAXBITS+1], lensym[FIXLCODES]; - static short distcnt[MAXBITS+1], distsym[MAXDCODES]; - static struct huffman lencode, distcode; - - /* build fixed huffman tables if first call (may not be thread safe) */ - if (virgin) { - int symbol; - short lengths[FIXLCODES]; - - /* construct lencode and distcode */ - lencode.count = lencnt; - lencode.symbol = lensym; - distcode.count = distcnt; - distcode.symbol = distsym; - - /* literal/length table */ - for (symbol = 0; symbol < 144; symbol++) - lengths[symbol] = 8; - for (; symbol < 256; symbol++) - lengths[symbol] = 9; - for (; symbol < 280; symbol++) - lengths[symbol] = 7; - for (; symbol < FIXLCODES; symbol++) - lengths[symbol] = 8; - construct(&lencode, lengths, FIXLCODES); - - /* distance table */ - for (symbol = 0; symbol < MAXDCODES; symbol++) - lengths[symbol] = 5; - construct(&distcode, lengths, MAXDCODES); - - /* do this just once */ - virgin = 0; - } - - /* decode data until end-of-block code */ - return codes(s, &lencode, &distcode); -} - -/* - * Process a dynamic codes block. - * - * Format notes: - * - * - A dynamic block starts with a description of the literal/length and - * distance codes for that block. New dynamic blocks allow the compressor to - * rapidly adapt to changing data with new codes optimized for that data. - * - * - The codes used by the deflate format are "canonical", which means that - * the actual bits of the codes are generated in an unambiguous way simply - * from the number of bits in each code. Therefore the code descriptions - * are simply a list of code lengths for each symbol. - * - * - The code lengths are stored in order for the symbols, so lengths are - * provided for each of the literal/length symbols, and for each of the - * distance symbols. - * - * - If a symbol is not used in the block, this is represented by a zero as - * as the code length. This does not mean a zero-length code, but rather - * that no code should be created for this symbol. There is no way in the - * deflate format to represent a zero-length code. - * - * - The maximum number of bits in a code is 15, so the possible lengths for - * any code are 1..15. - * - * - The fact that a length of zero is not permitted for a code has an - * interesting consequence. Normally if only one symbol is used for a given - * code, then in fact that code could be represented with zero bits. However - * in deflate, that code has to be at least one bit. So for example, if - * only a single distance base symbol appears in a block, then it will be - * represented by a single code of length one, in particular one 0 bit. This - * is an incomplete code, since if a 1 bit is received, it has no meaning, - * and should result in an error. So incomplete distance codes of one symbol - * should be permitted, and the receipt of invalid codes should be handled. - * - * - It is also possible to have a single literal/length code, but that code - * must be the end-of-block code, since every dynamic block has one. This - * is not the most efficient way to create an empty block (an empty fixed - * block is fewer bits), but it is allowed by the format. So incomplete - * literal/length codes of one symbol should also be permitted. - * - * - If there are only literal codes and no lengths, then there are no distance - * codes. This is represented by one distance code with zero bits. - * - * - The list of up to 286 length/literal lengths and up to 30 distance lengths - * are themselves compressed using Huffman codes and run-length encoding. In - * the list of code lengths, a 0 symbol means no code, a 1..15 symbol means - * that length, and the symbols 16, 17, and 18 are run-length instructions. - * Each of 16, 17, and 18 are follwed by extra bits to define the length of - * the run. 16 copies the last length 3 to 6 times. 17 represents 3 to 10 - * zero lengths, and 18 represents 11 to 138 zero lengths. Unused symbols - * are common, hence the special coding for zero lengths. - * - * - The symbols for 0..18 are Huffman coded, and so that code must be - * described first. This is simply a sequence of up to 19 three-bit values - * representing no code (0) or the code length for that symbol (1..7). - * - * - A dynamic block starts with three fixed-size counts from which is computed - * the number of literal/length code lengths, the number of distance code - * lengths, and the number of code length code lengths (ok, you come up with - * a better name!) in the code descriptions. For the literal/length and - * distance codes, lengths after those provided are considered zero, i.e. no - * code. The code length code lengths are received in a permuted order (see - * the order[] array below) to make a short code length code length list more - * likely. As it turns out, very short and very long codes are less likely - * to be seen in a dynamic code description, hence what may appear initially - * to be a peculiar ordering. - * - * - Given the number of literal/length code lengths (nlen) and distance code - * lengths (ndist), then they are treated as one long list of nlen + ndist - * code lengths. Therefore run-length coding can and often does cross the - * boundary between the two sets of lengths. - * - * - So to summarize, the code description at the start of a dynamic block is - * three counts for the number of code lengths for the literal/length codes, - * the distance codes, and the code length codes. This is followed by the - * code length code lengths, three bits each. This is used to construct the - * code length code which is used to read the remainder of the lengths. Then - * the literal/length code lengths and distance lengths are read as a single - * set of lengths using the code length codes. Codes are constructed from - * the resulting two sets of lengths, and then finally you can start - * decoding actual compressed data in the block. - * - * - For reference, a "typical" size for the code description in a dynamic - * block is around 80 bytes. - */ -local int dynamic(struct state *s) -{ - int nlen, ndist, ncode; /* number of lengths in descriptor */ - int index; /* index of lengths[] */ - int err; /* construct() return value */ - short lengths[MAXCODES]; /* descriptor code lengths */ - short lencnt[MAXBITS+1], lensym[MAXLCODES]; /* lencode memory */ - short distcnt[MAXBITS+1], distsym[MAXDCODES]; /* distcode memory */ - struct huffman lencode, distcode; /* length and distance codes */ - static const short order[19] = /* permutation of code length codes */ - {16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15}; - - /* construct lencode and distcode */ - lencode.count = lencnt; - lencode.symbol = lensym; - distcode.count = distcnt; - distcode.symbol = distsym; - - /* get number of lengths in each table, check lengths */ - nlen = bits(s, 5) + 257; - ndist = bits(s, 5) + 1; - ncode = bits(s, 4) + 4; - if (nlen > MAXLCODES || ndist > MAXDCODES) - return -3; /* bad counts */ - - /* read code length code lengths (really), missing lengths are zero */ - for (index = 0; index < ncode; index++) - lengths[order[index]] = bits(s, 3); - for (; index < 19; index++) - lengths[order[index]] = 0; - - /* build huffman table for code lengths codes (use lencode temporarily) */ - err = construct(&lencode, lengths, 19); - if (err != 0) /* require complete code set here */ - return -4; - - /* read length/literal and distance code length tables */ - index = 0; - while (index < nlen + ndist) { - int symbol; /* decoded value */ - int len; /* last length to repeat */ - - symbol = decode(s, &lencode); - if (symbol < 0) - return symbol; /* invalid symbol */ - if (symbol < 16) /* length in 0..15 */ - lengths[index++] = symbol; - else { /* repeat instruction */ - len = 0; /* assume repeating zeros */ - if (symbol == 16) { /* repeat last length 3..6 times */ - if (index == 0) - return -5; /* no last length! */ - len = lengths[index - 1]; /* last length */ - symbol = 3 + bits(s, 2); - } - else if (symbol == 17) /* repeat zero 3..10 times */ - symbol = 3 + bits(s, 3); - else /* == 18, repeat zero 11..138 times */ - symbol = 11 + bits(s, 7); - if (index + symbol > nlen + ndist) - return -6; /* too many lengths! */ - while (symbol--) /* repeat last or zero symbol times */ - lengths[index++] = len; - } - } - - /* check for end-of-block code -- there better be one! */ - if (lengths[256] == 0) - return -9; - - /* build huffman table for literal/length codes */ - err = construct(&lencode, lengths, nlen); - if (err && (err < 0 || nlen != lencode.count[0] + lencode.count[1])) - return -7; /* incomplete code ok only for single length 1 code */ - - /* build huffman table for distance codes */ - err = construct(&distcode, lengths + nlen, ndist); - if (err && (err < 0 || ndist != distcode.count[0] + distcode.count[1])) - return -8; /* incomplete code ok only for single length 1 code */ - - /* decode data until end-of-block code */ - return codes(s, &lencode, &distcode); -} - -/* - * Inflate source to dest. On return, destlen and sourcelen are updated to the - * size of the uncompressed data and the size of the deflate data respectively. - * On success, the return value of puff() is zero. If there is an error in the - * source data, i.e. it is not in the deflate format, then a negative value is - * returned. If there is not enough input available or there is not enough - * output space, then a positive error is returned. In that case, destlen and - * sourcelen are not updated to facilitate retrying from the beginning with the - * provision of more input data or more output space. In the case of invalid - * inflate data (a negative error), the dest and source pointers are updated to - * facilitate the debugging of deflators. - * - * puff() also has a mode to determine the size of the uncompressed output with - * no output written. For this dest must be (unsigned char *)0. In this case, - * the input value of *destlen is ignored, and on return *destlen is set to the - * size of the uncompressed output. - * - * The return codes are: - * - * 2: available inflate data did not terminate - * 1: output space exhausted before completing inflate - * 0: successful inflate - * -1: invalid block type (type == 3) - * -2: stored block length did not match one's complement - * -3: dynamic block code description: too many length or distance codes - * -4: dynamic block code description: code lengths codes incomplete - * -5: dynamic block code description: repeat lengths with no first length - * -6: dynamic block code description: repeat more than specified lengths - * -7: dynamic block code description: invalid literal/length code lengths - * -8: dynamic block code description: invalid distance code lengths - * -9: dynamic block code description: missing end-of-block code - * -10: invalid literal/length or distance code in fixed or dynamic block - * -11: distance is too far back in fixed or dynamic block - * - * Format notes: - * - * - Three bits are read for each block to determine the kind of block and - * whether or not it is the last block. Then the block is decoded and the - * process repeated if it was not the last block. - * - * - The leftover bits in the last byte of the deflate data after the last - * block (if it was a fixed or dynamic block) are undefined and have no - * expected values to check. - */ -int puff(unsigned char *dest, /* pointer to destination pointer */ - unsigned long *destlen, /* amount of output space */ - const unsigned char *source, /* pointer to source data pointer */ - unsigned long *sourcelen) /* amount of input available */ -{ - struct state s; /* input/output state */ - int last, type; /* block information */ - int err; /* return value */ - - /* initialize output state */ - s.out = dest; - s.outlen = *destlen; /* ignored if dest is NIL */ - s.outcnt = 0; - - /* initialize input state */ - s.in = source; - s.inlen = *sourcelen; - s.incnt = 0; - s.bitbuf = 0; - s.bitcnt = 0; - - /* return if bits() or decode() tries to read past available input */ - if (setjmp(s.env) != 0) /* if came back here via longjmp() */ - err = 2; /* then skip do-loop, return error */ - else { - /* process blocks until last block or error */ - do { - last = bits(&s, 1); /* one if last block */ - type = bits(&s, 2); /* block type 0..3 */ - err = type == 0 ? - stored(&s) : - (type == 1 ? - fixed(&s) : - (type == 2 ? - dynamic(&s) : - -1)); /* type == 3, invalid */ - if (err != 0) - break; /* return with error */ - } while (!last); - } - - /* update the lengths and return */ - if (err <= 0) { - *destlen = s.outcnt; - *sourcelen = s.incnt; - } - return err; -} DELETED compat/zlib/contrib/puff/puff.h Index: compat/zlib/contrib/puff/puff.h ================================================================== --- compat/zlib/contrib/puff/puff.h +++ /dev/null @@ -1,35 +0,0 @@ -/* puff.h - Copyright (C) 2002-2013 Mark Adler, all rights reserved - version 2.3, 21 Jan 2013 - - This software is provided 'as-is', without any express or implied - warranty. In no event will the author be held liable for any damages - arising from the use of this software. - - Permission is granted to anyone to use this software for any purpose, - including commercial applications, and to alter it and redistribute it - freely, subject to the following restrictions: - - 1. The origin of this software must not be misrepresented; you must not - claim that you wrote the original software. If you use this software - in a product, an acknowledgment in the product documentation would be - appreciated but is not required. - 2. Altered source versions must be plainly marked as such, and must not be - misrepresented as being the original software. - 3. This notice may not be removed or altered from any source distribution. - - Mark Adler madler@alumni.caltech.edu - */ - - -/* - * See puff.c for purpose and usage. - */ -#ifndef NIL -# define NIL ((unsigned char *)0) /* for no output option */ -#endif - -int puff(unsigned char *dest, /* pointer to destination pointer */ - unsigned long *destlen, /* amount of output space */ - const unsigned char *source, /* pointer to source data pointer */ - unsigned long *sourcelen); /* amount of input available */ DELETED compat/zlib/contrib/puff/pufftest.c Index: compat/zlib/contrib/puff/pufftest.c ================================================================== --- compat/zlib/contrib/puff/pufftest.c +++ /dev/null @@ -1,165 +0,0 @@ -/* - * pufftest.c - * Copyright (C) 2002-2013 Mark Adler - * For conditions of distribution and use, see copyright notice in puff.h - * version 2.3, 21 Jan 2013 - */ - -/* Example of how to use puff(). - - Usage: puff [-w] [-f] [-nnn] file - ... | puff [-w] [-f] [-nnn] - - where file is the input file with deflate data, nnn is the number of bytes - of input to skip before inflating (e.g. to skip a zlib or gzip header), and - -w is used to write the decompressed data to stdout. -f is for coverage - testing, and causes pufftest to fail with not enough output space (-f does - a write like -w, so -w is not required). */ - -#include -#include -#include "puff.h" - -#if defined(MSDOS) || defined(OS2) || defined(WIN32) || defined(__CYGWIN__) -# include -# include -# define SET_BINARY_MODE(file) setmode(fileno(file), O_BINARY) -#else -# define SET_BINARY_MODE(file) -#endif - -#define local static - -/* Return size times approximately the cube root of 2, keeping the result as 1, - 3, or 5 times a power of 2 -- the result is always > size, until the result - is the maximum value of an unsigned long, where it remains. This is useful - to keep reallocations less than ~33% over the actual data. */ -local size_t bythirds(size_t size) -{ - int n; - size_t m; - - m = size; - for (n = 0; m; n++) - m >>= 1; - if (n < 3) - return size + 1; - n -= 3; - m = size >> n; - m += m == 6 ? 2 : 1; - m <<= n; - return m > size ? m : (size_t)(-1); -} - -/* Read the input file *name, or stdin if name is NULL, into allocated memory. - Reallocate to larger buffers until the entire file is read in. Return a - pointer to the allocated data, or NULL if there was a memory allocation - failure. *len is the number of bytes of data read from the input file (even - if load() returns NULL). If the input file was empty or could not be opened - or read, *len is zero. */ -local void *load(const char *name, size_t *len) -{ - size_t size; - void *buf, *swap; - FILE *in; - - *len = 0; - buf = malloc(size = 4096); - if (buf == NULL) - return NULL; - in = name == NULL ? stdin : fopen(name, "rb"); - if (in != NULL) { - for (;;) { - *len += fread((char *)buf + *len, 1, size - *len, in); - if (*len < size) break; - size = bythirds(size); - if (size == *len || (swap = realloc(buf, size)) == NULL) { - free(buf); - buf = NULL; - break; - } - buf = swap; - } - fclose(in); - } - return buf; -} - -int main(int argc, char **argv) -{ - int ret, put = 0, fail = 0; - unsigned skip = 0; - char *arg, *name = NULL; - unsigned char *source = NULL, *dest; - size_t len = 0; - unsigned long sourcelen, destlen; - - /* process arguments */ - while (arg = *++argv, --argc) - if (arg[0] == '-') { - if (arg[1] == 'w' && arg[2] == 0) - put = 1; - else if (arg[1] == 'f' && arg[2] == 0) - fail = 1, put = 1; - else if (arg[1] >= '0' && arg[1] <= '9') - skip = (unsigned)atoi(arg + 1); - else { - fprintf(stderr, "invalid option %s\n", arg); - return 3; - } - } - else if (name != NULL) { - fprintf(stderr, "only one file name allowed\n"); - return 3; - } - else - name = arg; - source = load(name, &len); - if (source == NULL) { - fprintf(stderr, "memory allocation failure\n"); - return 4; - } - if (len == 0) { - fprintf(stderr, "could not read %s, or it was empty\n", - name == NULL ? "" : name); - free(source); - return 3; - } - if (skip >= len) { - fprintf(stderr, "skip request of %d leaves no input\n", skip); - free(source); - return 3; - } - - /* test inflate data with offset skip */ - len -= skip; - sourcelen = (unsigned long)len; - ret = puff(NIL, &destlen, source + skip, &sourcelen); - if (ret) - fprintf(stderr, "puff() failed with return code %d\n", ret); - else { - fprintf(stderr, "puff() succeeded uncompressing %lu bytes\n", destlen); - if (sourcelen < len) fprintf(stderr, "%lu compressed bytes unused\n", - len - sourcelen); - } - - /* if requested, inflate again and write decompressd data to stdout */ - if (put && ret == 0) { - if (fail) - destlen >>= 1; - dest = malloc(destlen); - if (dest == NULL) { - fprintf(stderr, "memory allocation failure\n"); - free(source); - return 4; - } - puff(dest, &destlen, source + skip, &sourcelen); - SET_BINARY_MODE(stdout); - fwrite(dest, 1, destlen, stdout); - free(dest); - } - - /* clean up */ - free(source); - return ret; -} DELETED compat/zlib/contrib/puff/zeros.raw Index: compat/zlib/contrib/puff/zeros.raw ================================================================== --- compat/zlib/contrib/puff/zeros.raw +++ /dev/null cannot compute difference between binary files DELETED compat/zlib/contrib/testzlib/testzlib.c Index: compat/zlib/contrib/testzlib/testzlib.c ================================================================== --- compat/zlib/contrib/testzlib/testzlib.c +++ /dev/null @@ -1,275 +0,0 @@ -#include -#include -#include - -#include "zlib.h" - - -void MyDoMinus64(LARGE_INTEGER *R,LARGE_INTEGER A,LARGE_INTEGER B) -{ - R->HighPart = A.HighPart - B.HighPart; - if (A.LowPart >= B.LowPart) - R->LowPart = A.LowPart - B.LowPart; - else - { - R->LowPart = A.LowPart - B.LowPart; - R->HighPart --; - } -} - -#ifdef _M_X64 -// see http://msdn2.microsoft.com/library/twchhe95(en-us,vs.80).aspx for __rdtsc -unsigned __int64 __rdtsc(void); -void BeginCountRdtsc(LARGE_INTEGER * pbeginTime64) -{ - // printf("rdtsc = %I64x\n",__rdtsc()); - pbeginTime64->QuadPart=__rdtsc(); -} - -LARGE_INTEGER GetResRdtsc(LARGE_INTEGER beginTime64,BOOL fComputeTimeQueryPerf) -{ - LARGE_INTEGER LIres; - unsigned _int64 res=__rdtsc()-((unsigned _int64)(beginTime64.QuadPart)); - LIres.QuadPart=res; - // printf("rdtsc = %I64x\n",__rdtsc()); - return LIres; -} -#else -#ifdef _M_IX86 -void myGetRDTSC32(LARGE_INTEGER * pbeginTime64) -{ - DWORD dwEdx,dwEax; - _asm - { - rdtsc - mov dwEax,eax - mov dwEdx,edx - } - pbeginTime64->LowPart=dwEax; - pbeginTime64->HighPart=dwEdx; -} - -void BeginCountRdtsc(LARGE_INTEGER * pbeginTime64) -{ - myGetRDTSC32(pbeginTime64); -} - -LARGE_INTEGER GetResRdtsc(LARGE_INTEGER beginTime64,BOOL fComputeTimeQueryPerf) -{ - LARGE_INTEGER LIres,endTime64; - myGetRDTSC32(&endTime64); - - LIres.LowPart=LIres.HighPart=0; - MyDoMinus64(&LIres,endTime64,beginTime64); - return LIres; -} -#else -void myGetRDTSC32(LARGE_INTEGER * pbeginTime64) -{ -} - -void BeginCountRdtsc(LARGE_INTEGER * pbeginTime64) -{ -} - -LARGE_INTEGER GetResRdtsc(LARGE_INTEGER beginTime64,BOOL fComputeTimeQueryPerf) -{ - LARGE_INTEGER lr; - lr.QuadPart=0; - return lr; -} -#endif -#endif - -void BeginCountPerfCounter(LARGE_INTEGER * pbeginTime64,BOOL fComputeTimeQueryPerf) -{ - if ((!fComputeTimeQueryPerf) || (!QueryPerformanceCounter(pbeginTime64))) - { - pbeginTime64->LowPart = GetTickCount(); - pbeginTime64->HighPart = 0; - } -} - -DWORD GetMsecSincePerfCounter(LARGE_INTEGER beginTime64,BOOL fComputeTimeQueryPerf) -{ - LARGE_INTEGER endTime64,ticksPerSecond,ticks; - DWORDLONG ticksShifted,tickSecShifted; - DWORD dwLog=16+0; - DWORD dwRet; - if ((!fComputeTimeQueryPerf) || (!QueryPerformanceCounter(&endTime64))) - dwRet = (GetTickCount() - beginTime64.LowPart)*1; - else - { - MyDoMinus64(&ticks,endTime64,beginTime64); - QueryPerformanceFrequency(&ticksPerSecond); - - - { - ticksShifted = Int64ShrlMod32(*(DWORDLONG*)&ticks,dwLog); - tickSecShifted = Int64ShrlMod32(*(DWORDLONG*)&ticksPerSecond,dwLog); - - } - - dwRet = (DWORD)((((DWORD)ticksShifted)*1000)/(DWORD)(tickSecShifted)); - dwRet *=1; - } - return dwRet; -} - -int ReadFileMemory(const char* filename,long* plFileSize,unsigned char** pFilePtr) -{ - FILE* stream; - unsigned char* ptr; - int retVal=1; - stream=fopen(filename, "rb"); - if (stream==NULL) - return 0; - - fseek(stream,0,SEEK_END); - - *plFileSize=ftell(stream); - fseek(stream,0,SEEK_SET); - ptr=malloc((*plFileSize)+1); - if (ptr==NULL) - retVal=0; - else - { - if (fread(ptr, 1, *plFileSize,stream) != (*plFileSize)) - retVal=0; - } - fclose(stream); - *pFilePtr=ptr; - return retVal; -} - -int main(int argc, char *argv[]) -{ - int BlockSizeCompress=0x8000; - int BlockSizeUncompress=0x8000; - int cprLevel=Z_DEFAULT_COMPRESSION ; - long lFileSize; - unsigned char* FilePtr; - long lBufferSizeCpr; - long lBufferSizeUncpr; - long lCompressedSize=0; - unsigned char* CprPtr; - unsigned char* UncprPtr; - long lSizeCpr,lSizeUncpr; - DWORD dwGetTick,dwMsecQP; - LARGE_INTEGER li_qp,li_rdtsc,dwResRdtsc; - - if (argc<=1) - { - printf("run TestZlib [BlockSizeCompress] [BlockSizeUncompress] [compres. level]\n"); - return 0; - } - - if (ReadFileMemory(argv[1],&lFileSize,&FilePtr)==0) - { - printf("error reading %s\n",argv[1]); - return 1; - } - else printf("file %s read, %u bytes\n",argv[1],lFileSize); - - if (argc>=3) - BlockSizeCompress=atol(argv[2]); - - if (argc>=4) - BlockSizeUncompress=atol(argv[3]); - - if (argc>=5) - cprLevel=(int)atol(argv[4]); - - lBufferSizeCpr = lFileSize + (lFileSize/0x10) + 0x200; - lBufferSizeUncpr = lBufferSizeCpr; - - CprPtr=(unsigned char*)malloc(lBufferSizeCpr + BlockSizeCompress); - - BeginCountPerfCounter(&li_qp,TRUE); - dwGetTick=GetTickCount(); - BeginCountRdtsc(&li_rdtsc); - { - z_stream zcpr; - int ret=Z_OK; - long lOrigToDo = lFileSize; - long lOrigDone = 0; - int step=0; - memset(&zcpr,0,sizeof(z_stream)); - deflateInit(&zcpr,cprLevel); - - zcpr.next_in = FilePtr; - zcpr.next_out = CprPtr; - - - do - { - long all_read_before = zcpr.total_in; - zcpr.avail_in = min(lOrigToDo,BlockSizeCompress); - zcpr.avail_out = BlockSizeCompress; - ret=deflate(&zcpr,(zcpr.avail_in==lOrigToDo) ? Z_FINISH : Z_SYNC_FLUSH); - lOrigDone += (zcpr.total_in-all_read_before); - lOrigToDo -= (zcpr.total_in-all_read_before); - step++; - } while (ret==Z_OK); - - lSizeCpr=zcpr.total_out; - deflateEnd(&zcpr); - dwGetTick=GetTickCount()-dwGetTick; - dwMsecQP=GetMsecSincePerfCounter(li_qp,TRUE); - dwResRdtsc=GetResRdtsc(li_rdtsc,TRUE); - printf("total compress size = %u, in %u step\n",lSizeCpr,step); - printf("time = %u msec = %f sec\n",dwGetTick,dwGetTick/(double)1000.); - printf("defcpr time QP = %u msec = %f sec\n",dwMsecQP,dwMsecQP/(double)1000.); - printf("defcpr result rdtsc = %I64x\n\n",dwResRdtsc.QuadPart); - } - - CprPtr=(unsigned char*)realloc(CprPtr,lSizeCpr); - UncprPtr=(unsigned char*)malloc(lBufferSizeUncpr + BlockSizeUncompress); - - BeginCountPerfCounter(&li_qp,TRUE); - dwGetTick=GetTickCount(); - BeginCountRdtsc(&li_rdtsc); - { - z_stream zcpr; - int ret=Z_OK; - long lOrigToDo = lSizeCpr; - long lOrigDone = 0; - int step=0; - memset(&zcpr,0,sizeof(z_stream)); - inflateInit(&zcpr); - - zcpr.next_in = CprPtr; - zcpr.next_out = UncprPtr; - - - do - { - long all_read_before = zcpr.total_in; - zcpr.avail_in = min(lOrigToDo,BlockSizeUncompress); - zcpr.avail_out = BlockSizeUncompress; - ret=inflate(&zcpr,Z_SYNC_FLUSH); - lOrigDone += (zcpr.total_in-all_read_before); - lOrigToDo -= (zcpr.total_in-all_read_before); - step++; - } while (ret==Z_OK); - - lSizeUncpr=zcpr.total_out; - inflateEnd(&zcpr); - dwGetTick=GetTickCount()-dwGetTick; - dwMsecQP=GetMsecSincePerfCounter(li_qp,TRUE); - dwResRdtsc=GetResRdtsc(li_rdtsc,TRUE); - printf("total uncompress size = %u, in %u step\n",lSizeUncpr,step); - printf("time = %u msec = %f sec\n",dwGetTick,dwGetTick/(double)1000.); - printf("uncpr time QP = %u msec = %f sec\n",dwMsecQP,dwMsecQP/(double)1000.); - printf("uncpr result rdtsc = %I64x\n\n",dwResRdtsc.QuadPart); - } - - if (lSizeUncpr==lFileSize) - { - if (memcmp(FilePtr,UncprPtr,lFileSize)==0) - printf("compare ok\n"); - - } - - return 0; -} DELETED compat/zlib/contrib/testzlib/testzlib.txt Index: compat/zlib/contrib/testzlib/testzlib.txt ================================================================== --- compat/zlib/contrib/testzlib/testzlib.txt +++ /dev/null @@ -1,10 +0,0 @@ -To build testzLib with Visual Studio 2005: - -copy to a directory file from : -- root of zLib tree -- contrib/testzlib -- contrib/masmx86 -- contrib/masmx64 -- contrib/vstudio/vc7 - -and open testzlib8.sln DELETED compat/zlib/contrib/untgz/Makefile Index: compat/zlib/contrib/untgz/Makefile ================================================================== --- compat/zlib/contrib/untgz/Makefile +++ /dev/null @@ -1,14 +0,0 @@ -CC=cc -CFLAGS=-g - -untgz: untgz.o ../../libz.a - $(CC) $(CFLAGS) -o untgz untgz.o -L../.. -lz - -untgz.o: untgz.c ../../zlib.h - $(CC) $(CFLAGS) -c -I../.. untgz.c - -../../libz.a: - cd ../..; ./configure; make - -clean: - rm -f untgz untgz.o *~ DELETED compat/zlib/contrib/untgz/Makefile.msc Index: compat/zlib/contrib/untgz/Makefile.msc ================================================================== --- compat/zlib/contrib/untgz/Makefile.msc +++ /dev/null @@ -1,17 +0,0 @@ -CC=cl -CFLAGS=-MD - -untgz.exe: untgz.obj ..\..\zlib.lib - $(CC) $(CFLAGS) untgz.obj ..\..\zlib.lib - -untgz.obj: untgz.c ..\..\zlib.h - $(CC) $(CFLAGS) -c -I..\.. untgz.c - -..\..\zlib.lib: - cd ..\.. - $(MAKE) -f win32\makefile.msc - cd contrib\untgz - -clean: - -del untgz.obj - -del untgz.exe DELETED compat/zlib/contrib/untgz/untgz.c Index: compat/zlib/contrib/untgz/untgz.c ================================================================== --- compat/zlib/contrib/untgz/untgz.c +++ /dev/null @@ -1,674 +0,0 @@ -/* - * untgz.c -- Display contents and extract files from a gzip'd TAR file - * - * written by Pedro A. Aranda Gutierrez - * adaptation to Unix by Jean-loup Gailly - * various fixes by Cosmin Truta - */ - -#include -#include -#include -#include -#include - -#include "zlib.h" - -#ifdef unix -# include -#else -# include -# include -#endif - -#ifdef WIN32 -#include -# ifndef F_OK -# define F_OK 0 -# endif -# define mkdir(dirname,mode) _mkdir(dirname) -# ifdef _MSC_VER -# define access(path,mode) _access(path,mode) -# define chmod(path,mode) _chmod(path,mode) -# define strdup(str) _strdup(str) -# endif -#else -# include -#endif - - -/* values used in typeflag field */ - -#define REGTYPE '0' /* regular file */ -#define AREGTYPE '\0' /* regular file */ -#define LNKTYPE '1' /* link */ -#define SYMTYPE '2' /* reserved */ -#define CHRTYPE '3' /* character special */ -#define BLKTYPE '4' /* block special */ -#define DIRTYPE '5' /* directory */ -#define FIFOTYPE '6' /* FIFO special */ -#define CONTTYPE '7' /* reserved */ - -/* GNU tar extensions */ - -#define GNUTYPE_DUMPDIR 'D' /* file names from dumped directory */ -#define GNUTYPE_LONGLINK 'K' /* long link name */ -#define GNUTYPE_LONGNAME 'L' /* long file name */ -#define GNUTYPE_MULTIVOL 'M' /* continuation of file from another volume */ -#define GNUTYPE_NAMES 'N' /* file name that does not fit into main hdr */ -#define GNUTYPE_SPARSE 'S' /* sparse file */ -#define GNUTYPE_VOLHDR 'V' /* tape/volume header */ - - -/* tar header */ - -#define BLOCKSIZE 512 -#define SHORTNAMESIZE 100 - -struct tar_header -{ /* byte offset */ - char name[100]; /* 0 */ - char mode[8]; /* 100 */ - char uid[8]; /* 108 */ - char gid[8]; /* 116 */ - char size[12]; /* 124 */ - char mtime[12]; /* 136 */ - char chksum[8]; /* 148 */ - char typeflag; /* 156 */ - char linkname[100]; /* 157 */ - char magic[6]; /* 257 */ - char version[2]; /* 263 */ - char uname[32]; /* 265 */ - char gname[32]; /* 297 */ - char devmajor[8]; /* 329 */ - char devminor[8]; /* 337 */ - char prefix[155]; /* 345 */ - /* 500 */ -}; - -union tar_buffer -{ - char buffer[BLOCKSIZE]; - struct tar_header header; -}; - -struct attr_item -{ - struct attr_item *next; - char *fname; - int mode; - time_t time; -}; - -enum { TGZ_EXTRACT, TGZ_LIST, TGZ_INVALID }; - -char *TGZfname OF((const char *)); -void TGZnotfound OF((const char *)); - -int getoct OF((char *, int)); -char *strtime OF((time_t *)); -int setfiletime OF((char *, time_t)); -void push_attr OF((struct attr_item **, char *, int, time_t)); -void restore_attr OF((struct attr_item **)); - -int ExprMatch OF((char *, char *)); - -int makedir OF((char *)); -int matchname OF((int, int, char **, char *)); - -void error OF((const char *)); -int tar OF((gzFile, int, int, int, char **)); - -void help OF((int)); -int main OF((int, char **)); - -char *prog; - -const char *TGZsuffix[] = { "\0", ".tar", ".tar.gz", ".taz", ".tgz", NULL }; - -/* return the file name of the TGZ archive */ -/* or NULL if it does not exist */ - -char *TGZfname (const char *arcname) -{ - static char buffer[1024]; - int origlen,i; - - strcpy(buffer,arcname); - origlen = strlen(buffer); - - for (i=0; TGZsuffix[i]; i++) - { - strcpy(buffer+origlen,TGZsuffix[i]); - if (access(buffer,F_OK) == 0) - return buffer; - } - return NULL; -} - - -/* error message for the filename */ - -void TGZnotfound (const char *arcname) -{ - int i; - - fprintf(stderr,"%s: Couldn't find ",prog); - for (i=0;TGZsuffix[i];i++) - fprintf(stderr,(TGZsuffix[i+1]) ? "%s%s, " : "or %s%s\n", - arcname, - TGZsuffix[i]); - exit(1); -} - - -/* convert octal digits to int */ -/* on error return -1 */ - -int getoct (char *p,int width) -{ - int result = 0; - char c; - - while (width--) - { - c = *p++; - if (c == 0) - break; - if (c == ' ') - continue; - if (c < '0' || c > '7') - return -1; - result = result * 8 + (c - '0'); - } - return result; -} - - -/* convert time_t to string */ -/* use the "YYYY/MM/DD hh:mm:ss" format */ - -char *strtime (time_t *t) -{ - struct tm *local; - static char result[32]; - - local = localtime(t); - sprintf(result,"%4d/%02d/%02d %02d:%02d:%02d", - local->tm_year+1900, local->tm_mon+1, local->tm_mday, - local->tm_hour, local->tm_min, local->tm_sec); - return result; -} - - -/* set file time */ - -int setfiletime (char *fname,time_t ftime) -{ -#ifdef WIN32 - static int isWinNT = -1; - SYSTEMTIME st; - FILETIME locft, modft; - struct tm *loctm; - HANDLE hFile; - int result; - - loctm = localtime(&ftime); - if (loctm == NULL) - return -1; - - st.wYear = (WORD)loctm->tm_year + 1900; - st.wMonth = (WORD)loctm->tm_mon + 1; - st.wDayOfWeek = (WORD)loctm->tm_wday; - st.wDay = (WORD)loctm->tm_mday; - st.wHour = (WORD)loctm->tm_hour; - st.wMinute = (WORD)loctm->tm_min; - st.wSecond = (WORD)loctm->tm_sec; - st.wMilliseconds = 0; - if (!SystemTimeToFileTime(&st, &locft) || - !LocalFileTimeToFileTime(&locft, &modft)) - return -1; - - if (isWinNT < 0) - isWinNT = (GetVersion() < 0x80000000) ? 1 : 0; - hFile = CreateFile(fname, GENERIC_WRITE, 0, NULL, OPEN_EXISTING, - (isWinNT ? FILE_FLAG_BACKUP_SEMANTICS : 0), - NULL); - if (hFile == INVALID_HANDLE_VALUE) - return -1; - result = SetFileTime(hFile, NULL, NULL, &modft) ? 0 : -1; - CloseHandle(hFile); - return result; -#else - struct utimbuf settime; - - settime.actime = settime.modtime = ftime; - return utime(fname,&settime); -#endif -} - - -/* push file attributes */ - -void push_attr(struct attr_item **list,char *fname,int mode,time_t time) -{ - struct attr_item *item; - - item = (struct attr_item *)malloc(sizeof(struct attr_item)); - if (item == NULL) - error("Out of memory"); - item->fname = strdup(fname); - item->mode = mode; - item->time = time; - item->next = *list; - *list = item; -} - - -/* restore file attributes */ - -void restore_attr(struct attr_item **list) -{ - struct attr_item *item, *prev; - - for (item = *list; item != NULL; ) - { - setfiletime(item->fname,item->time); - chmod(item->fname,item->mode); - prev = item; - item = item->next; - free(prev); - } - *list = NULL; -} - - -/* match regular expression */ - -#define ISSPECIAL(c) (((c) == '*') || ((c) == '/')) - -int ExprMatch (char *string,char *expr) -{ - while (1) - { - if (ISSPECIAL(*expr)) - { - if (*expr == '/') - { - if (*string != '\\' && *string != '/') - return 0; - string ++; expr++; - } - else if (*expr == '*') - { - if (*expr ++ == 0) - return 1; - while (*++string != *expr) - if (*string == 0) - return 0; - } - } - else - { - if (*string != *expr) - return 0; - if (*expr++ == 0) - return 1; - string++; - } - } -} - - -/* recursive mkdir */ -/* abort on ENOENT; ignore other errors like "directory already exists" */ -/* return 1 if OK */ -/* 0 on error */ - -int makedir (char *newdir) -{ - char *buffer = strdup(newdir); - char *p; - int len = strlen(buffer); - - if (len <= 0) { - free(buffer); - return 0; - } - if (buffer[len-1] == '/') { - buffer[len-1] = '\0'; - } - if (mkdir(buffer, 0755) == 0) - { - free(buffer); - return 1; - } - - p = buffer+1; - while (1) - { - char hold; - - while(*p && *p != '\\' && *p != '/') - p++; - hold = *p; - *p = 0; - if ((mkdir(buffer, 0755) == -1) && (errno == ENOENT)) - { - fprintf(stderr,"%s: Couldn't create directory %s\n",prog,buffer); - free(buffer); - return 0; - } - if (hold == 0) - break; - *p++ = hold; - } - free(buffer); - return 1; -} - - -int matchname (int arg,int argc,char **argv,char *fname) -{ - if (arg == argc) /* no arguments given (untgz tgzarchive) */ - return 1; - - while (arg < argc) - if (ExprMatch(fname,argv[arg++])) - return 1; - - return 0; /* ignore this for the moment being */ -} - - -/* tar file list or extract */ - -int tar (gzFile in,int action,int arg,int argc,char **argv) -{ - union tar_buffer buffer; - int len; - int err; - int getheader = 1; - int remaining = 0; - FILE *outfile = NULL; - char fname[BLOCKSIZE]; - int tarmode; - time_t tartime; - struct attr_item *attributes = NULL; - - if (action == TGZ_LIST) - printf(" date time size file\n" - " ---------- -------- --------- -------------------------------------\n"); - while (1) - { - len = gzread(in, &buffer, BLOCKSIZE); - if (len < 0) - error(gzerror(in, &err)); - /* - * Always expect complete blocks to process - * the tar information. - */ - if (len != BLOCKSIZE) - { - action = TGZ_INVALID; /* force error exit */ - remaining = 0; /* force I/O cleanup */ - } - - /* - * If we have to get a tar header - */ - if (getheader >= 1) - { - /* - * if we met the end of the tar - * or the end-of-tar block, - * we are done - */ - if (len == 0 || buffer.header.name[0] == 0) - break; - - tarmode = getoct(buffer.header.mode,8); - tartime = (time_t)getoct(buffer.header.mtime,12); - if (tarmode == -1 || tartime == (time_t)-1) - { - buffer.header.name[0] = 0; - action = TGZ_INVALID; - } - - if (getheader == 1) - { - strncpy(fname,buffer.header.name,SHORTNAMESIZE); - if (fname[SHORTNAMESIZE-1] != 0) - fname[SHORTNAMESIZE] = 0; - } - else - { - /* - * The file name is longer than SHORTNAMESIZE - */ - if (strncmp(fname,buffer.header.name,SHORTNAMESIZE-1) != 0) - error("bad long name"); - getheader = 1; - } - - /* - * Act according to the type flag - */ - switch (buffer.header.typeflag) - { - case DIRTYPE: - if (action == TGZ_LIST) - printf(" %s %s\n",strtime(&tartime),fname); - if (action == TGZ_EXTRACT) - { - makedir(fname); - push_attr(&attributes,fname,tarmode,tartime); - } - break; - case REGTYPE: - case AREGTYPE: - remaining = getoct(buffer.header.size,12); - if (remaining == -1) - { - action = TGZ_INVALID; - break; - } - if (action == TGZ_LIST) - printf(" %s %9d %s\n",strtime(&tartime),remaining,fname); - else if (action == TGZ_EXTRACT) - { - if (matchname(arg,argc,argv,fname)) - { - outfile = fopen(fname,"wb"); - if (outfile == NULL) { - /* try creating directory */ - char *p = strrchr(fname, '/'); - if (p != NULL) { - *p = '\0'; - makedir(fname); - *p = '/'; - outfile = fopen(fname,"wb"); - } - } - if (outfile != NULL) - printf("Extracting %s\n",fname); - else - fprintf(stderr, "%s: Couldn't create %s",prog,fname); - } - else - outfile = NULL; - } - getheader = 0; - break; - case GNUTYPE_LONGLINK: - case GNUTYPE_LONGNAME: - remaining = getoct(buffer.header.size,12); - if (remaining < 0 || remaining >= BLOCKSIZE) - { - action = TGZ_INVALID; - break; - } - len = gzread(in, fname, BLOCKSIZE); - if (len < 0) - error(gzerror(in, &err)); - if (fname[BLOCKSIZE-1] != 0 || (int)strlen(fname) > remaining) - { - action = TGZ_INVALID; - break; - } - getheader = 2; - break; - default: - if (action == TGZ_LIST) - printf(" %s <---> %s\n",strtime(&tartime),fname); - break; - } - } - else - { - unsigned int bytes = (remaining > BLOCKSIZE) ? BLOCKSIZE : remaining; - - if (outfile != NULL) - { - if (fwrite(&buffer,sizeof(char),bytes,outfile) != bytes) - { - fprintf(stderr, - "%s: Error writing %s -- skipping\n",prog,fname); - fclose(outfile); - outfile = NULL; - remove(fname); - } - } - remaining -= bytes; - } - - if (remaining == 0) - { - getheader = 1; - if (outfile != NULL) - { - fclose(outfile); - outfile = NULL; - if (action != TGZ_INVALID) - push_attr(&attributes,fname,tarmode,tartime); - } - } - - /* - * Abandon if errors are found - */ - if (action == TGZ_INVALID) - { - error("broken archive"); - break; - } - } - - /* - * Restore file modes and time stamps - */ - restore_attr(&attributes); - - if (gzclose(in) != Z_OK) - error("failed gzclose"); - - return 0; -} - - -/* ============================================================ */ - -void help(int exitval) -{ - printf("untgz version 0.2.1\n" - " using zlib version %s\n\n", - zlibVersion()); - printf("Usage: untgz file.tgz extract all files\n" - " untgz file.tgz fname ... extract selected files\n" - " untgz -l file.tgz list archive contents\n" - " untgz -h display this help\n"); - exit(exitval); -} - -void error(const char *msg) -{ - fprintf(stderr, "%s: %s\n", prog, msg); - exit(1); -} - - -/* ============================================================ */ - -#if defined(WIN32) && defined(__GNUC__) -int _CRT_glob = 0; /* disable argument globbing in MinGW */ -#endif - -int main(int argc,char **argv) -{ - int action = TGZ_EXTRACT; - int arg = 1; - char *TGZfile; - gzFile *f; - - prog = strrchr(argv[0],'\\'); - if (prog == NULL) - { - prog = strrchr(argv[0],'/'); - if (prog == NULL) - { - prog = strrchr(argv[0],':'); - if (prog == NULL) - prog = argv[0]; - else - prog++; - } - else - prog++; - } - else - prog++; - - if (argc == 1) - help(0); - - if (strcmp(argv[arg],"-l") == 0) - { - action = TGZ_LIST; - if (argc == ++arg) - help(0); - } - else if (strcmp(argv[arg],"-h") == 0) - { - help(0); - } - - if ((TGZfile = TGZfname(argv[arg])) == NULL) - TGZnotfound(argv[arg]); - - ++arg; - if ((action == TGZ_LIST) && (arg != argc)) - help(1); - -/* - * Process the TGZ file - */ - switch(action) - { - case TGZ_LIST: - case TGZ_EXTRACT: - f = gzopen(TGZfile,"rb"); - if (f == NULL) - { - fprintf(stderr,"%s: Couldn't gzopen %s\n",prog,TGZfile); - return 1; - } - exit(tar(f, action, arg, argc, argv)); - break; - - default: - error("Unknown option"); - exit(1); - } - - return 0; -} DELETED compat/zlib/contrib/vstudio/readme.txt Index: compat/zlib/contrib/vstudio/readme.txt ================================================================== --- compat/zlib/contrib/vstudio/readme.txt +++ /dev/null @@ -1,78 +0,0 @@ -Building instructions for the DLL versions of Zlib 1.2.11 -======================================================== - -This directory contains projects that build zlib and minizip using -Microsoft Visual C++ 9.0/10.0. - -You don't need to build these projects yourself. You can download the -binaries from: - http://www.winimage.com/zLibDll - -More information can be found at this site. - - - - - -Build instructions for Visual Studio 2008 (32 bits or 64 bits) --------------------------------------------------------------- -- Decompress current zlib, including all contrib/* files -- Compile assembly code (with Visual Studio Command Prompt) by running: - bld_ml64.bat (in contrib\masmx64) - bld_ml32.bat (in contrib\masmx86) -- Open contrib\vstudio\vc9\zlibvc.sln with Microsoft Visual C++ 2008 -- Or run: vcbuild /rebuild contrib\vstudio\vc9\zlibvc.sln "Release|Win32" - -Build instructions for Visual Studio 2010 (32 bits or 64 bits) --------------------------------------------------------------- -- Decompress current zlib, including all contrib/* files -- Open contrib\vstudio\vc10\zlibvc.sln with Microsoft Visual C++ 2010 - -Build instructions for Visual Studio 2012 (32 bits or 64 bits) --------------------------------------------------------------- -- Decompress current zlib, including all contrib/* files -- Open contrib\vstudio\vc11\zlibvc.sln with Microsoft Visual C++ 2012 - -Build instructions for Visual Studio 2013 (32 bits or 64 bits) --------------------------------------------------------------- -- Decompress current zlib, including all contrib/* files -- Open contrib\vstudio\vc12\zlibvc.sln with Microsoft Visual C++ 2013 - -Build instructions for Visual Studio 2015 (32 bits or 64 bits) --------------------------------------------------------------- -- Decompress current zlib, including all contrib/* files -- Open contrib\vstudio\vc14\zlibvc.sln with Microsoft Visual C++ 2015 - - -Important ---------- -- To use zlibwapi.dll in your application, you must define the - macro ZLIB_WINAPI when compiling your application's source files. - - -Additional notes ----------------- -- This DLL, named zlibwapi.dll, is compatible to the old zlib.dll built - by Gilles Vollant from the zlib 1.1.x sources, and distributed at - http://www.winimage.com/zLibDll - It uses the WINAPI calling convention for the exported functions, and - includes the minizip functionality. If your application needs that - particular build of zlib.dll, you can rename zlibwapi.dll to zlib.dll. - -- The new DLL was renamed because there exist several incompatible - versions of zlib.dll on the Internet. - -- There is also an official DLL build of zlib, named zlib1.dll. This one - is exporting the functions using the CDECL convention. See the file - win32\DLL_FAQ.txt found in this zlib distribution. - -- There used to be a ZLIB_DLL macro in zlib 1.1.x, but now this symbol - has a slightly different effect. To avoid compatibility problems, do - not define it here. - - -Gilles Vollant -info@winimage.com - -Visual Studio 2013 and 2015 Projects from Sean Hunt -seandhunt_7@yahoo.com DELETED compat/zlib/contrib/vstudio/vc10/miniunz.vcxproj Index: compat/zlib/contrib/vstudio/vc10/miniunz.vcxproj ================================================================== --- compat/zlib/contrib/vstudio/vc10/miniunz.vcxproj +++ /dev/null @@ -1,310 +0,0 @@ - - - - - Debug - Itanium - - - Debug - Win32 - - - Debug - x64 - - - Release - Itanium - - - Release - Win32 - - - Release - x64 - - - - {C52F9E7B-498A-42BE-8DB4-85A15694382A} - Win32Proj - - - - Application - MultiByte - - - Application - MultiByte - - - Application - MultiByte - - - Application - MultiByte - - - Application - MultiByte - - - Application - MultiByte - - - - - - - - - - - - - - - - - - - - - - - - - <_ProjectFileVersion>10.0.30128.1 - x86\MiniUnzip$(Configuration)\ - x86\MiniUnzip$(Configuration)\Tmp\ - true - false - x86\MiniUnzip$(Configuration)\ - x86\MiniUnzip$(Configuration)\Tmp\ - false - false - x64\MiniUnzip$(Configuration)\ - x64\MiniUnzip$(Configuration)\Tmp\ - true - false - ia64\MiniUnzip$(Configuration)\ - ia64\MiniUnzip$(Configuration)\Tmp\ - true - false - x64\MiniUnzip$(Configuration)\ - x64\MiniUnzip$(Configuration)\Tmp\ - false - false - ia64\MiniUnzip$(Configuration)\ - ia64\MiniUnzip$(Configuration)\Tmp\ - false - false - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebug - false - - - $(IntDir) - Level3 - EditAndContinue - - - x86\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)miniunz.exe - true - $(OutDir)miniunz.pdb - Console - false - - - MachineX86 - - - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) - true - Default - MultiThreaded - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - x86\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)miniunz.exe - true - Console - true - true - false - - - MachineX86 - - - - - X64 - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - x64\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)miniunz.exe - true - $(OutDir)miniunz.pdb - Console - MachineX64 - - - - - Itanium - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - ia64\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)miniunz.exe - true - $(OutDir)miniunz.pdb - Console - MachineIA64 - - - - - X64 - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - x64\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)miniunz.exe - true - Console - true - true - MachineX64 - - - - - Itanium - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - ia64\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)miniunz.exe - true - Console - true - true - MachineIA64 - - - - - - - - {8fd826f8-3739-44e6-8cc8-997122e53b8d} - - - - - - DELETED compat/zlib/contrib/vstudio/vc10/miniunz.vcxproj.filters Index: compat/zlib/contrib/vstudio/vc10/miniunz.vcxproj.filters ================================================================== --- compat/zlib/contrib/vstudio/vc10/miniunz.vcxproj.filters +++ /dev/null @@ -1,22 +0,0 @@ - - - - - {048af943-022b-4db6-beeb-a54c34774ee2} - cpp;c;cxx;def;odl;idl;hpj;bat;asm - - - {c1d600d2-888f-4aea-b73e-8b0dd9befa0c} - h;hpp;hxx;hm;inl;inc - - - {0844199a-966b-4f19-81db-1e0125e141b9} - rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe - - - - - Source Files - - - DELETED compat/zlib/contrib/vstudio/vc10/minizip.vcxproj Index: compat/zlib/contrib/vstudio/vc10/minizip.vcxproj ================================================================== --- compat/zlib/contrib/vstudio/vc10/minizip.vcxproj +++ /dev/null @@ -1,307 +0,0 @@ - - - - - Debug - Itanium - - - Debug - Win32 - - - Debug - x64 - - - Release - Itanium - - - Release - Win32 - - - Release - x64 - - - - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B} - Win32Proj - - - - Application - MultiByte - - - Application - MultiByte - - - Application - MultiByte - - - Application - MultiByte - - - Application - MultiByte - - - Application - MultiByte - - - - - - - - - - - - - - - - - - - - - - - - - <_ProjectFileVersion>10.0.30128.1 - x86\MiniZip$(Configuration)\ - x86\MiniZip$(Configuration)\Tmp\ - true - false - x86\MiniZip$(Configuration)\ - x86\MiniZip$(Configuration)\Tmp\ - false - x64\$(Configuration)\ - x64\$(Configuration)\ - true - false - ia64\$(Configuration)\ - ia64\$(Configuration)\ - true - false - x64\$(Configuration)\ - x64\$(Configuration)\ - false - ia64\$(Configuration)\ - ia64\$(Configuration)\ - false - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebug - false - - - $(IntDir) - Level3 - EditAndContinue - - - x86\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)minizip.exe - true - $(OutDir)minizip.pdb - Console - false - - - MachineX86 - - - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) - true - Default - MultiThreaded - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - x86\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)minizip.exe - true - Console - true - true - false - - - MachineX86 - - - - - X64 - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - x64\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)minizip.exe - true - $(OutDir)minizip.pdb - Console - MachineX64 - - - - - Itanium - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - ia64\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)minizip.exe - true - $(OutDir)minizip.pdb - Console - MachineIA64 - - - - - X64 - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - x64\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)minizip.exe - true - Console - true - true - MachineX64 - - - - - Itanium - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - ia64\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)minizip.exe - true - Console - true - true - MachineIA64 - - - - - - - - {8fd826f8-3739-44e6-8cc8-997122e53b8d} - - - - - - DELETED compat/zlib/contrib/vstudio/vc10/minizip.vcxproj.filters Index: compat/zlib/contrib/vstudio/vc10/minizip.vcxproj.filters ================================================================== --- compat/zlib/contrib/vstudio/vc10/minizip.vcxproj.filters +++ /dev/null @@ -1,22 +0,0 @@ - - - - - {c0419b40-bf50-40da-b153-ff74215b79de} - cpp;c;cxx;def;odl;idl;hpj;bat;asm - - - {bb87b070-735b-478e-92ce-7383abb2f36c} - h;hpp;hxx;hm;inl;inc - - - {f46ab6a6-548f-43cb-ae96-681abb5bd5db} - rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe - - - - - Source Files - - - DELETED compat/zlib/contrib/vstudio/vc10/testzlib.vcxproj Index: compat/zlib/contrib/vstudio/vc10/testzlib.vcxproj ================================================================== --- compat/zlib/contrib/vstudio/vc10/testzlib.vcxproj +++ /dev/null @@ -1,420 +0,0 @@ - - - - - Debug - Itanium - - - Debug - Win32 - - - Debug - x64 - - - ReleaseWithoutAsm - Itanium - - - ReleaseWithoutAsm - Win32 - - - ReleaseWithoutAsm - x64 - - - Release - Itanium - - - Release - Win32 - - - Release - x64 - - - - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B} - testzlib - Win32Proj - - - - Application - MultiByte - true - - - Application - MultiByte - true - - - Application - MultiByte - - - Application - MultiByte - true - - - Application - MultiByte - true - - - Application - MultiByte - - - Application - true - - - Application - true - - - Application - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <_ProjectFileVersion>10.0.30128.1 - x86\TestZlib$(Configuration)\ - x86\TestZlib$(Configuration)\Tmp\ - true - false - x86\TestZlib$(Configuration)\ - x86\TestZlib$(Configuration)\Tmp\ - false - false - x86\TestZlib$(Configuration)\ - x86\TestZlib$(Configuration)\Tmp\ - false - false - x64\TestZlib$(Configuration)\ - x64\TestZlib$(Configuration)\Tmp\ - false - ia64\TestZlib$(Configuration)\ - ia64\TestZlib$(Configuration)\Tmp\ - true - false - x64\TestZlib$(Configuration)\ - x64\TestZlib$(Configuration)\Tmp\ - false - ia64\TestZlib$(Configuration)\ - ia64\TestZlib$(Configuration)\Tmp\ - false - false - x64\TestZlib$(Configuration)\ - x64\TestZlib$(Configuration)\Tmp\ - false - ia64\TestZlib$(Configuration)\ - ia64\TestZlib$(Configuration)\Tmp\ - false - false - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - - - - Disabled - ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;_DEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebug - false - - - AssemblyAndSourceCode - $(IntDir) - Level3 - EditAndContinue - - - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) - $(OutDir)testzlib.exe - true - $(OutDir)testzlib.pdb - Console - false - - - MachineX86 - - - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;%(AdditionalIncludeDirectories) - WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - true - Default - MultiThreaded - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - $(OutDir)testzlib.exe - true - Console - true - true - false - - - MachineX86 - - - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - true - Default - MultiThreaded - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) - $(OutDir)testzlib.exe - true - Console - true - true - false - - - MachineX86 - - - - - ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;_DEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - Default - MultiThreadedDebugDLL - false - $(IntDir) - - - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) - - - - - Itanium - - - Disabled - ..\..\..;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_DEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - AssemblyAndSourceCode - $(IntDir) - Level3 - ProgramDatabase - - - $(OutDir)testzlib.exe - true - $(OutDir)testzlib.pdb - Console - MachineIA64 - - - - - ..\..\..;%(AdditionalIncludeDirectories) - WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - Default - MultiThreadedDLL - false - $(IntDir) - - - %(AdditionalDependencies) - - - - - Itanium - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - $(OutDir)testzlib.exe - true - Console - true - true - MachineIA64 - - - - - ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - Default - MultiThreadedDLL - false - $(IntDir) - - - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) - - - - - Itanium - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - $(OutDir)testzlib.exe - true - Console - true - true - MachineIA64 - - - - - - - - - - true - true - true - true - true - true - - - - - - - - - - - - - DELETED compat/zlib/contrib/vstudio/vc10/testzlib.vcxproj.filters Index: compat/zlib/contrib/vstudio/vc10/testzlib.vcxproj.filters ================================================================== --- compat/zlib/contrib/vstudio/vc10/testzlib.vcxproj.filters +++ /dev/null @@ -1,58 +0,0 @@ - - - - - {c1f6a2e3-5da5-4955-8653-310d3efe05a9} - cpp;c;cxx;def;odl;idl;hpj;bat;asm - - - {c2aaffdc-2c95-4d6f-8466-4bec5890af2c} - h;hpp;hxx;hm;inl;inc - - - {c274fe07-05f2-461c-964b-f6341e4e7eb5} - rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe - - - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - DELETED compat/zlib/contrib/vstudio/vc10/testzlibdll.vcxproj Index: compat/zlib/contrib/vstudio/vc10/testzlibdll.vcxproj ================================================================== --- compat/zlib/contrib/vstudio/vc10/testzlibdll.vcxproj +++ /dev/null @@ -1,310 +0,0 @@ - - - - - Debug - Itanium - - - Debug - Win32 - - - Debug - x64 - - - Release - Itanium - - - Release - Win32 - - - Release - x64 - - - - {C52F9E7B-498A-42BE-8DB4-85A15694366A} - Win32Proj - - - - Application - MultiByte - - - Application - MultiByte - - - Application - MultiByte - - - Application - MultiByte - - - Application - MultiByte - - - Application - MultiByte - - - - - - - - - - - - - - - - - - - - - - - - - <_ProjectFileVersion>10.0.30128.1 - x86\TestZlibDll$(Configuration)\ - x86\TestZlibDll$(Configuration)\Tmp\ - true - false - x86\TestZlibDll$(Configuration)\ - x86\TestZlibDll$(Configuration)\Tmp\ - false - false - x64\TestZlibDll$(Configuration)\ - x64\TestZlibDll$(Configuration)\Tmp\ - true - false - ia64\TestZlibDll$(Configuration)\ - ia64\TestZlibDll$(Configuration)\Tmp\ - true - false - x64\TestZlibDll$(Configuration)\ - x64\TestZlibDll$(Configuration)\Tmp\ - false - false - ia64\TestZlibDll$(Configuration)\ - ia64\TestZlibDll$(Configuration)\Tmp\ - false - false - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebug - false - - - $(IntDir) - Level3 - EditAndContinue - - - x86\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)testzlibdll.exe - true - $(OutDir)testzlib.pdb - Console - false - - - MachineX86 - - - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) - true - Default - MultiThreaded - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - x86\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)testzlibdll.exe - true - Console - true - true - false - - - MachineX86 - - - - - X64 - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - x64\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)testzlibdll.exe - true - $(OutDir)testzlib.pdb - Console - MachineX64 - - - - - Itanium - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - ia64\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)testzlibdll.exe - true - $(OutDir)testzlib.pdb - Console - MachineIA64 - - - - - X64 - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - x64\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)testzlibdll.exe - true - Console - true - true - MachineX64 - - - - - Itanium - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - ia64\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)testzlibdll.exe - true - Console - true - true - MachineIA64 - - - - - - - - {8fd826f8-3739-44e6-8cc8-997122e53b8d} - - - - - - DELETED compat/zlib/contrib/vstudio/vc10/testzlibdll.vcxproj.filters Index: compat/zlib/contrib/vstudio/vc10/testzlibdll.vcxproj.filters ================================================================== --- compat/zlib/contrib/vstudio/vc10/testzlibdll.vcxproj.filters +++ /dev/null @@ -1,22 +0,0 @@ - - - - - {fa61a89f-93fc-4c89-b29e-36224b7592f4} - cpp;c;cxx;def;odl;idl;hpj;bat;asm - - - {d4b85da0-2ba2-4934-b57f-e2584e3848ee} - h;hpp;hxx;hm;inl;inc - - - {e573e075-00bd-4a7d-bd67-a8cc9bfc5aca} - rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe - - - - - Source Files - - - DELETED compat/zlib/contrib/vstudio/vc10/zlib.rc Index: compat/zlib/contrib/vstudio/vc10/zlib.rc ================================================================== --- compat/zlib/contrib/vstudio/vc10/zlib.rc +++ /dev/null @@ -1,32 +0,0 @@ -#include - -#define IDR_VERSION1 1 -IDR_VERSION1 VERSIONINFO MOVEABLE IMPURE LOADONCALL DISCARDABLE - FILEVERSION 1, 2, 11, 0 - PRODUCTVERSION 1, 2, 11, 0 - FILEFLAGSMASK VS_FFI_FILEFLAGSMASK - FILEFLAGS 0 - FILEOS VOS_DOS_WINDOWS32 - FILETYPE VFT_DLL - FILESUBTYPE 0 // not used -BEGIN - BLOCK "StringFileInfo" - BEGIN - BLOCK "040904E4" - //language ID = U.S. English, char set = Windows, Multilingual - - BEGIN - VALUE "FileDescription", "zlib data compression and ZIP file I/O library\0" - VALUE "FileVersion", "1.2.11\0" - VALUE "InternalName", "zlib\0" - VALUE "OriginalFilename", "zlibwapi.dll\0" - VALUE "ProductName", "ZLib.DLL\0" - VALUE "Comments","DLL support by Alessandro Iacopetti & Gilles Vollant\0" - VALUE "LegalCopyright", "(C) 1995-2017 Jean-loup Gailly & Mark Adler\0" - END - END - BLOCK "VarFileInfo" - BEGIN - VALUE "Translation", 0x0409, 1252 - END -END DELETED compat/zlib/contrib/vstudio/vc10/zlibstat.vcxproj Index: compat/zlib/contrib/vstudio/vc10/zlibstat.vcxproj ================================================================== --- compat/zlib/contrib/vstudio/vc10/zlibstat.vcxproj +++ /dev/null @@ -1,473 +0,0 @@ - - - - - Debug - Itanium - - - Debug - Win32 - - - Debug - x64 - - - ReleaseWithoutAsm - Itanium - - - ReleaseWithoutAsm - Win32 - - - ReleaseWithoutAsm - x64 - - - Release - Itanium - - - Release - Win32 - - - Release - x64 - - - - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8} - - - - StaticLibrary - false - - - StaticLibrary - false - - - StaticLibrary - false - - - StaticLibrary - false - - - StaticLibrary - false - - - StaticLibrary - false - - - StaticLibrary - false - - - StaticLibrary - false - - - StaticLibrary - false - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <_ProjectFileVersion>10.0.30128.1 - x86\ZlibStat$(Configuration)\ - x86\ZlibStat$(Configuration)\Tmp\ - x86\ZlibStat$(Configuration)\ - x86\ZlibStat$(Configuration)\Tmp\ - x86\ZlibStat$(Configuration)\ - x86\ZlibStat$(Configuration)\Tmp\ - x64\ZlibStat$(Configuration)\ - x64\ZlibStat$(Configuration)\Tmp\ - ia64\ZlibStat$(Configuration)\ - ia64\ZlibStat$(Configuration)\Tmp\ - x64\ZlibStat$(Configuration)\ - x64\ZlibStat$(Configuration)\Tmp\ - ia64\ZlibStat$(Configuration)\ - ia64\ZlibStat$(Configuration)\Tmp\ - x64\ZlibStat$(Configuration)\ - x64\ZlibStat$(Configuration)\Tmp\ - ia64\ZlibStat$(Configuration)\ - ia64\ZlibStat$(Configuration)\Tmp\ - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - - - - Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - - - MultiThreadedDebug - false - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - OldStyle - - - 0x040c - - - /MACHINE:X86 /NODEFAULTLIB %(AdditionalOptions) - $(OutDir)zlibstat.lib - true - - - cd ..\..\masmx86 -bld_ml32.bat - - - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ASMV;ASMINF;%(PreprocessorDefinitions) - true - - - MultiThreaded - false - true - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - - - 0x040c - - - /MACHINE:X86 /NODEFAULTLIB %(AdditionalOptions) - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) - $(OutDir)zlibstat.lib - true - - - cd ..\..\masmx86 -bld_ml32.bat - - - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - true - - - MultiThreaded - false - true - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - - - 0x040c - - - /MACHINE:X86 /NODEFAULTLIB %(AdditionalOptions) - $(OutDir)zlibstat.lib - true - - - - - X64 - - - Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - - - MultiThreadedDebugDLL - false - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - OldStyle - - - 0x040c - - - /MACHINE:AMD64 /NODEFAULTLIB %(AdditionalOptions) - $(OutDir)zlibstat.lib - true - - - cd ..\..\masmx64 -bld_ml64.bat - - - - - Itanium - - - Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - - - MultiThreadedDebugDLL - false - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - OldStyle - - - 0x040c - - - /MACHINE:IA64 /NODEFAULTLIB %(AdditionalOptions) - $(OutDir)zlibstat.lib - true - - - - - X64 - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ASMV;ASMINF;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - - - 0x040c - - - /MACHINE:AMD64 /NODEFAULTLIB %(AdditionalOptions) - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) - $(OutDir)zlibstat.lib - true - - - cd ..\..\masmx64 -bld_ml64.bat - - - - - Itanium - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - - - 0x040c - - - /MACHINE:IA64 /NODEFAULTLIB %(AdditionalOptions) - $(OutDir)zlibstat.lib - true - - - - - X64 - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - - - 0x040c - - - /MACHINE:AMD64 /NODEFAULTLIB %(AdditionalOptions) - $(OutDir)zlibstat.lib - true - - - - - Itanium - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - - - 0x040c - - - /MACHINE:IA64 /NODEFAULTLIB %(AdditionalOptions) - $(OutDir)zlibstat.lib - true - - - - - - - - - - - - - - true - true - true - true - true - true - - - - - - - - - - - - - - - - - - - - - DELETED compat/zlib/contrib/vstudio/vc10/zlibstat.vcxproj.filters Index: compat/zlib/contrib/vstudio/vc10/zlibstat.vcxproj.filters ================================================================== --- compat/zlib/contrib/vstudio/vc10/zlibstat.vcxproj.filters +++ /dev/null @@ -1,77 +0,0 @@ - - - - - {174213f6-7f66-4ae8-a3a8-a1e0a1e6ffdd} - - - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - - - Source Files - - - - - Source Files - - - DELETED compat/zlib/contrib/vstudio/vc10/zlibvc.def Index: compat/zlib/contrib/vstudio/vc10/zlibvc.def ================================================================== --- compat/zlib/contrib/vstudio/vc10/zlibvc.def +++ /dev/null @@ -1,153 +0,0 @@ -LIBRARY -; zlib data compression and ZIP file I/O library - -VERSION 1.2 - -EXPORTS - adler32 @1 - compress @2 - crc32 @3 - deflate @4 - deflateCopy @5 - deflateEnd @6 - deflateInit2_ @7 - deflateInit_ @8 - deflateParams @9 - deflateReset @10 - deflateSetDictionary @11 - gzclose @12 - gzdopen @13 - gzerror @14 - gzflush @15 - gzopen @16 - gzread @17 - gzwrite @18 - inflate @19 - inflateEnd @20 - inflateInit2_ @21 - inflateInit_ @22 - inflateReset @23 - inflateSetDictionary @24 - inflateSync @25 - uncompress @26 - zlibVersion @27 - gzprintf @28 - gzputc @29 - gzgetc @30 - gzseek @31 - gzrewind @32 - gztell @33 - gzeof @34 - gzsetparams @35 - zError @36 - inflateSyncPoint @37 - get_crc_table @38 - compress2 @39 - gzputs @40 - gzgets @41 - inflateCopy @42 - inflateBackInit_ @43 - inflateBack @44 - inflateBackEnd @45 - compressBound @46 - deflateBound @47 - gzclearerr @48 - gzungetc @49 - zlibCompileFlags @50 - deflatePrime @51 - deflatePending @52 - - unzOpen @61 - unzClose @62 - unzGetGlobalInfo @63 - unzGetCurrentFileInfo @64 - unzGoToFirstFile @65 - unzGoToNextFile @66 - unzOpenCurrentFile @67 - unzReadCurrentFile @68 - unzOpenCurrentFile3 @69 - unztell @70 - unzeof @71 - unzCloseCurrentFile @72 - unzGetGlobalComment @73 - unzStringFileNameCompare @74 - unzLocateFile @75 - unzGetLocalExtrafield @76 - unzOpen2 @77 - unzOpenCurrentFile2 @78 - unzOpenCurrentFilePassword @79 - - zipOpen @80 - zipOpenNewFileInZip @81 - zipWriteInFileInZip @82 - zipCloseFileInZip @83 - zipClose @84 - zipOpenNewFileInZip2 @86 - zipCloseFileInZipRaw @87 - zipOpen2 @88 - zipOpenNewFileInZip3 @89 - - unzGetFilePos @100 - unzGoToFilePos @101 - - fill_win32_filefunc @110 - -; zlibwapi v1.2.4 added: - fill_win32_filefunc64 @111 - fill_win32_filefunc64A @112 - fill_win32_filefunc64W @113 - - unzOpen64 @120 - unzOpen2_64 @121 - unzGetGlobalInfo64 @122 - unzGetCurrentFileInfo64 @124 - unzGetCurrentFileZStreamPos64 @125 - unztell64 @126 - unzGetFilePos64 @127 - unzGoToFilePos64 @128 - - zipOpen64 @130 - zipOpen2_64 @131 - zipOpenNewFileInZip64 @132 - zipOpenNewFileInZip2_64 @133 - zipOpenNewFileInZip3_64 @134 - zipOpenNewFileInZip4_64 @135 - zipCloseFileInZipRaw64 @136 - -; zlib1 v1.2.4 added: - adler32_combine @140 - crc32_combine @142 - deflateSetHeader @144 - deflateTune @145 - gzbuffer @146 - gzclose_r @147 - gzclose_w @148 - gzdirect @149 - gzoffset @150 - inflateGetHeader @156 - inflateMark @157 - inflatePrime @158 - inflateReset2 @159 - inflateUndermine @160 - -; zlib1 v1.2.6 added: - gzgetc_ @161 - inflateResetKeep @163 - deflateResetKeep @164 - -; zlib1 v1.2.7 added: - gzopen_w @165 - -; zlib1 v1.2.8 added: - inflateGetDictionary @166 - gzvprintf @167 - -; zlib1 v1.2.9 added: - inflateCodesUsed @168 - inflateValidate @169 - uncompress2 @170 - gzfread @171 - gzfwrite @172 - deflateGetDictionary @173 - adler32_z @174 - crc32_z @175 DELETED compat/zlib/contrib/vstudio/vc10/zlibvc.sln Index: compat/zlib/contrib/vstudio/vc10/zlibvc.sln ================================================================== --- compat/zlib/contrib/vstudio/vc10/zlibvc.sln +++ /dev/null @@ -1,135 +0,0 @@ - -Microsoft Visual Studio Solution File, Format Version 11.00 -# Visual Studio 2010 -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "zlibvc", "zlibvc.vcxproj", "{8FD826F8-3739-44E6-8CC8-997122E53B8D}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "zlibstat", "zlibstat.vcxproj", "{745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "testzlib", "testzlib.vcxproj", "{AA6666AA-E09F-4135-9C0C-4FE50C3C654B}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "testzlibdll", "testzlibdll.vcxproj", "{C52F9E7B-498A-42BE-8DB4-85A15694366A}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "minizip", "minizip.vcxproj", "{48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "miniunz", "miniunz.vcxproj", "{C52F9E7B-498A-42BE-8DB4-85A15694382A}" -EndProject -Global - GlobalSection(SolutionConfigurationPlatforms) = preSolution - Debug|Itanium = Debug|Itanium - Debug|Win32 = Debug|Win32 - Debug|x64 = Debug|x64 - Release|Itanium = Release|Itanium - Release|Win32 = Release|Win32 - Release|x64 = Release|x64 - ReleaseWithoutAsm|Itanium = ReleaseWithoutAsm|Itanium - ReleaseWithoutAsm|Win32 = ReleaseWithoutAsm|Win32 - ReleaseWithoutAsm|x64 = ReleaseWithoutAsm|x64 - EndGlobalSection - GlobalSection(ProjectConfigurationPlatforms) = postSolution - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Itanium.ActiveCfg = Debug|Itanium - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Itanium.Build.0 = Debug|Itanium - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Win32.ActiveCfg = Debug|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Win32.Build.0 = Debug|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|x64.ActiveCfg = Debug|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|x64.Build.0 = Debug|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Itanium.ActiveCfg = Release|Itanium - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Itanium.Build.0 = Release|Itanium - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Win32.ActiveCfg = Release|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Win32.Build.0 = Release|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|x64.ActiveCfg = Release|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|x64.Build.0 = Release|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Itanium - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Itanium.Build.0 = ReleaseWithoutAsm|Itanium - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Itanium.ActiveCfg = Debug|Itanium - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Itanium.Build.0 = Debug|Itanium - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Win32.ActiveCfg = Debug|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Win32.Build.0 = Debug|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|x64.ActiveCfg = Debug|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|x64.Build.0 = Debug|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Itanium.ActiveCfg = Release|Itanium - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Itanium.Build.0 = Release|Itanium - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Win32.ActiveCfg = Release|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Win32.Build.0 = Release|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|x64.ActiveCfg = Release|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|x64.Build.0 = Release|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Itanium - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Itanium.Build.0 = ReleaseWithoutAsm|Itanium - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.ActiveCfg = Debug|Itanium - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.Build.0 = Debug|Itanium - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.ActiveCfg = Debug|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.Build.0 = Debug|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.ActiveCfg = Debug|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.Build.0 = Debug|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.ActiveCfg = Release|Itanium - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.Build.0 = Release|Itanium - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.ActiveCfg = Release|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.Build.0 = Release|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.ActiveCfg = Release|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.Build.0 = Release|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Itanium - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.Build.0 = ReleaseWithoutAsm|Itanium - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Itanium.ActiveCfg = Debug|Itanium - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Itanium.Build.0 = Debug|Itanium - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Win32.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Win32.Build.0 = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|x64.ActiveCfg = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|x64.Build.0 = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Itanium.ActiveCfg = Release|Itanium - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Itanium.Build.0 = Release|Itanium - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Win32.Build.0 = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|x64.ActiveCfg = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|x64.Build.0 = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Itanium - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|Itanium.Build.0 = Release|Itanium - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.ActiveCfg = Debug|Itanium - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.Build.0 = Debug|Itanium - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.ActiveCfg = Debug|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.Build.0 = Debug|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.ActiveCfg = Debug|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.Build.0 = Debug|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.ActiveCfg = Release|Itanium - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.Build.0 = Release|Itanium - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.Build.0 = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.ActiveCfg = Release|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.Build.0 = Release|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Itanium - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.Build.0 = Release|Itanium - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Itanium.ActiveCfg = Debug|Itanium - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Itanium.Build.0 = Debug|Itanium - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Win32.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Win32.Build.0 = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|x64.ActiveCfg = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|x64.Build.0 = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Itanium.ActiveCfg = Release|Itanium - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Itanium.Build.0 = Release|Itanium - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Win32.Build.0 = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|x64.ActiveCfg = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|x64.Build.0 = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Itanium - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|Itanium.Build.0 = Release|Itanium - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 - EndGlobalSection - GlobalSection(SolutionProperties) = preSolution - HideSolutionNode = FALSE - EndGlobalSection -EndGlobal DELETED compat/zlib/contrib/vstudio/vc10/zlibvc.vcxproj Index: compat/zlib/contrib/vstudio/vc10/zlibvc.vcxproj ================================================================== --- compat/zlib/contrib/vstudio/vc10/zlibvc.vcxproj +++ /dev/null @@ -1,657 +0,0 @@ - - - - - Debug - Itanium - - - Debug - Win32 - - - Debug - x64 - - - ReleaseWithoutAsm - Itanium - - - ReleaseWithoutAsm - Win32 - - - ReleaseWithoutAsm - x64 - - - Release - Itanium - - - Release - Win32 - - - Release - x64 - - - - {8FD826F8-3739-44E6-8CC8-997122E53B8D} - - - - DynamicLibrary - false - true - - - DynamicLibrary - false - true - - - DynamicLibrary - false - - - DynamicLibrary - false - true - - - DynamicLibrary - false - true - - - DynamicLibrary - false - - - DynamicLibrary - false - true - - - DynamicLibrary - false - true - - - DynamicLibrary - false - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <_ProjectFileVersion>10.0.30128.1 - x86\ZlibDll$(Configuration)\ - x86\ZlibDll$(Configuration)\Tmp\ - true - false - x86\ZlibDll$(Configuration)\ - x86\ZlibDll$(Configuration)\Tmp\ - false - false - x86\ZlibDll$(Configuration)\ - x86\ZlibDll$(Configuration)\Tmp\ - false - false - x64\ZlibDll$(Configuration)\ - x64\ZlibDll$(Configuration)\Tmp\ - true - false - ia64\ZlibDll$(Configuration)\ - ia64\ZlibDll$(Configuration)\Tmp\ - true - false - x64\ZlibDll$(Configuration)\ - x64\ZlibDll$(Configuration)\Tmp\ - false - false - ia64\ZlibDll$(Configuration)\ - ia64\ZlibDll$(Configuration)\Tmp\ - false - false - x64\ZlibDll$(Configuration)\ - x64\ZlibDll$(Configuration)\Tmp\ - false - false - ia64\ZlibDll$(Configuration)\ - ia64\ZlibDll$(Configuration)\Tmp\ - false - false - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - zlibwapid - zlibwapi - zlibwapi - zlibwapid - zlibwapi - zlibwapi - - - - _DEBUG;%(PreprocessorDefinitions) - true - true - Win32 - $(OutDir)zlibvc.tlb - - - Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;%(PreprocessorDefinitions) - - - MultiThreadedDebug - false - $(IntDir)zlibvc.pch - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - EditAndContinue - - - _DEBUG;%(PreprocessorDefinitions) - 0x040c - - - /MACHINE:I386 %(AdditionalOptions) - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) - true - .\zlibvc.def - true - true - Windows - false - - - - - cd ..\..\masmx86 -bld_ml32.bat - - - - - NDEBUG;%(PreprocessorDefinitions) - true - true - Win32 - $(OutDir)zlibvc.tlb - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibvc.pch - All - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - - - NDEBUG;%(PreprocessorDefinitions) - 0x040c - - - /MACHINE:I386 %(AdditionalOptions) - true - false - .\zlibvc.def - true - Windows - false - - - - - - - NDEBUG;%(PreprocessorDefinitions) - true - true - Win32 - $(OutDir)zlibvc.tlb - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;%(PreprocessorDefinitions) - true - - - MultiThreaded - false - true - $(IntDir)zlibvc.pch - All - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - - - NDEBUG;%(PreprocessorDefinitions) - 0x040c - - - /MACHINE:I386 %(AdditionalOptions) - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) - true - false - .\zlibvc.def - true - Windows - false - - - - - cd ..\..\masmx86 -bld_ml32.bat - - - - - _DEBUG;%(PreprocessorDefinitions) - true - true - X64 - $(OutDir)zlibvc.tlb - - - Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;WIN64;%(PreprocessorDefinitions) - - - MultiThreadedDebugDLL - false - $(IntDir)zlibvc.pch - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - ProgramDatabase - - - _DEBUG;%(PreprocessorDefinitions) - 0x040c - - - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) - true - .\zlibvc.def - true - true - Windows - MachineX64 - - - cd ..\..\masmx64 -bld_ml64.bat - - - - - _DEBUG;%(PreprocessorDefinitions) - true - true - Itanium - $(OutDir)zlibvc.tlb - - - Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) - - - MultiThreadedDebugDLL - false - $(IntDir)zlibvc.pch - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - ProgramDatabase - - - _DEBUG;%(PreprocessorDefinitions) - 0x040c - - - $(OutDir)zlibwapi.dll - true - .\zlibvc.def - true - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - $(OutDir)zlibwapi.lib - MachineIA64 - - - - - NDEBUG;%(PreprocessorDefinitions) - true - true - X64 - $(OutDir)zlibvc.tlb - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibvc.pch - All - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - - - NDEBUG;%(PreprocessorDefinitions) - 0x040c - - - true - false - .\zlibvc.def - true - Windows - MachineX64 - - - - - NDEBUG;%(PreprocessorDefinitions) - true - true - Itanium - $(OutDir)zlibvc.tlb - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibvc.pch - All - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - - - NDEBUG;%(PreprocessorDefinitions) - 0x040c - - - $(OutDir)zlibwapi.dll - true - false - .\zlibvc.def - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - $(OutDir)zlibwapi.lib - MachineIA64 - - - - - NDEBUG;%(PreprocessorDefinitions) - true - true - X64 - $(OutDir)zlibvc.tlb - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibvc.pch - All - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - - - NDEBUG;%(PreprocessorDefinitions) - 0x040c - - - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) - true - false - .\zlibvc.def - true - Windows - MachineX64 - - - cd ..\..\masmx64 -bld_ml64.bat - - - - - NDEBUG;%(PreprocessorDefinitions) - true - true - Itanium - $(OutDir)zlibvc.tlb - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibvc.pch - All - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - - - NDEBUG;%(PreprocessorDefinitions) - 0x040c - - - $(OutDir)zlibwapi.dll - true - false - .\zlibvc.def - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - $(OutDir)zlibwapi.lib - MachineIA64 - - - - - - - - - - - - - - true - true - true - true - true - true - - - - - - - - - - %(AdditionalIncludeDirectories) - ZLIB_INTERNAL;%(PreprocessorDefinitions) - %(AdditionalIncludeDirectories) - ZLIB_INTERNAL;%(PreprocessorDefinitions) - %(AdditionalIncludeDirectories) - ZLIB_INTERNAL;%(PreprocessorDefinitions) - - - %(AdditionalIncludeDirectories) - ZLIB_INTERNAL;%(PreprocessorDefinitions) - %(AdditionalIncludeDirectories) - ZLIB_INTERNAL;%(PreprocessorDefinitions) - %(AdditionalIncludeDirectories) - ZLIB_INTERNAL;%(PreprocessorDefinitions) - - - - - - - - - - - - - - - - - - - - - - - - DELETED compat/zlib/contrib/vstudio/vc10/zlibvc.vcxproj.filters Index: compat/zlib/contrib/vstudio/vc10/zlibvc.vcxproj.filters ================================================================== --- compat/zlib/contrib/vstudio/vc10/zlibvc.vcxproj.filters +++ /dev/null @@ -1,118 +0,0 @@ - - - - - {07934a85-8b61-443d-a0ee-b2eedb74f3cd} - cpp;c;cxx;rc;def;r;odl;hpj;bat;for;f90 - - - {1d99675b-433d-4a21-9e50-ed4ab8b19762} - h;hpp;hxx;hm;inl;fi;fd - - - {431c0958-fa71-44d0-9084-2d19d100c0cc} - ico;cur;bmp;dlg;rc2;rct;bin;cnt;rtf;gif;jpg;jpeg;jpe - - - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - Source Files - - - - - Source Files - - - - - Source Files - - - - - Header Files - - - Header Files - - - Header Files - - - Header Files - - - Header Files - - - Header Files - - - Header Files - - - Header Files - - - Header Files - - - DELETED compat/zlib/contrib/vstudio/vc11/miniunz.vcxproj Index: compat/zlib/contrib/vstudio/vc11/miniunz.vcxproj ================================================================== --- compat/zlib/contrib/vstudio/vc11/miniunz.vcxproj +++ /dev/null @@ -1,314 +0,0 @@ - - - - - Debug - Itanium - - - Debug - Win32 - - - Debug - x64 - - - Release - Itanium - - - Release - Win32 - - - Release - x64 - - - - {C52F9E7B-498A-42BE-8DB4-85A15694382A} - Win32Proj - - - - Application - MultiByte - v110 - - - Application - Unicode - v110 - - - Application - MultiByte - - - Application - MultiByte - - - Application - MultiByte - v110 - - - Application - MultiByte - v110 - - - - - - - - - - - - - - - - - - - - - - - - - <_ProjectFileVersion>10.0.30128.1 - x86\MiniUnzip$(Configuration)\ - x86\MiniUnzip$(Configuration)\Tmp\ - true - false - x86\MiniUnzip$(Configuration)\ - x86\MiniUnzip$(Configuration)\Tmp\ - false - false - x64\MiniUnzip$(Configuration)\ - x64\MiniUnzip$(Configuration)\Tmp\ - true - false - ia64\MiniUnzip$(Configuration)\ - ia64\MiniUnzip$(Configuration)\Tmp\ - true - false - x64\MiniUnzip$(Configuration)\ - x64\MiniUnzip$(Configuration)\Tmp\ - false - false - ia64\MiniUnzip$(Configuration)\ - ia64\MiniUnzip$(Configuration)\Tmp\ - false - false - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - x86\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)miniunz.exe - true - $(OutDir)miniunz.pdb - Console - false - - - MachineX86 - - - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) - true - Default - MultiThreaded - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - x86\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)miniunz.exe - true - Console - true - true - false - - - MachineX86 - - - - - X64 - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - x64\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)miniunz.exe - true - $(OutDir)miniunz.pdb - Console - MachineX64 - - - - - Itanium - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - ia64\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)miniunz.exe - true - $(OutDir)miniunz.pdb - Console - MachineIA64 - - - - - X64 - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - x64\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)miniunz.exe - true - Console - true - true - MachineX64 - - - - - Itanium - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - ia64\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)miniunz.exe - true - Console - true - true - MachineIA64 - - - - - - - - {8fd826f8-3739-44e6-8cc8-997122e53b8d} - - - - - - DELETED compat/zlib/contrib/vstudio/vc11/minizip.vcxproj Index: compat/zlib/contrib/vstudio/vc11/minizip.vcxproj ================================================================== --- compat/zlib/contrib/vstudio/vc11/minizip.vcxproj +++ /dev/null @@ -1,311 +0,0 @@ - - - - - Debug - Itanium - - - Debug - Win32 - - - Debug - x64 - - - Release - Itanium - - - Release - Win32 - - - Release - x64 - - - - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B} - Win32Proj - - - - Application - MultiByte - v110 - - - Application - Unicode - v110 - - - Application - MultiByte - - - Application - MultiByte - - - Application - MultiByte - v110 - - - Application - MultiByte - v110 - - - - - - - - - - - - - - - - - - - - - - - - - <_ProjectFileVersion>10.0.30128.1 - x86\MiniZip$(Configuration)\ - x86\MiniZip$(Configuration)\Tmp\ - true - false - x86\MiniZip$(Configuration)\ - x86\MiniZip$(Configuration)\Tmp\ - false - x64\$(Configuration)\ - x64\$(Configuration)\ - true - false - ia64\$(Configuration)\ - ia64\$(Configuration)\ - true - false - x64\$(Configuration)\ - x64\$(Configuration)\ - false - ia64\$(Configuration)\ - ia64\$(Configuration)\ - false - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - x86\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)minizip.exe - true - $(OutDir)minizip.pdb - Console - false - - - MachineX86 - - - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) - true - Default - MultiThreaded - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - x86\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)minizip.exe - true - Console - true - true - false - - - MachineX86 - - - - - X64 - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - x64\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)minizip.exe - true - $(OutDir)minizip.pdb - Console - MachineX64 - - - - - Itanium - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - ia64\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)minizip.exe - true - $(OutDir)minizip.pdb - Console - MachineIA64 - - - - - X64 - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - x64\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)minizip.exe - true - Console - true - true - MachineX64 - - - - - Itanium - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - ia64\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)minizip.exe - true - Console - true - true - MachineIA64 - - - - - - - - {8fd826f8-3739-44e6-8cc8-997122e53b8d} - - - - - - DELETED compat/zlib/contrib/vstudio/vc11/testzlib.vcxproj Index: compat/zlib/contrib/vstudio/vc11/testzlib.vcxproj ================================================================== --- compat/zlib/contrib/vstudio/vc11/testzlib.vcxproj +++ /dev/null @@ -1,426 +0,0 @@ - - - - - Debug - Itanium - - - Debug - Win32 - - - Debug - x64 - - - ReleaseWithoutAsm - Itanium - - - ReleaseWithoutAsm - Win32 - - - ReleaseWithoutAsm - x64 - - - Release - Itanium - - - Release - Win32 - - - Release - x64 - - - - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B} - testzlib - Win32Proj - - - - Application - MultiByte - true - v110 - - - Application - MultiByte - true - v110 - - - Application - Unicode - v110 - - - Application - MultiByte - true - - - Application - MultiByte - true - - - Application - MultiByte - - - Application - true - v110 - - - Application - true - v110 - - - Application - v110 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <_ProjectFileVersion>10.0.30128.1 - x86\TestZlib$(Configuration)\ - x86\TestZlib$(Configuration)\Tmp\ - true - false - x86\TestZlib$(Configuration)\ - x86\TestZlib$(Configuration)\Tmp\ - false - false - x86\TestZlib$(Configuration)\ - x86\TestZlib$(Configuration)\Tmp\ - false - false - x64\TestZlib$(Configuration)\ - x64\TestZlib$(Configuration)\Tmp\ - false - ia64\TestZlib$(Configuration)\ - ia64\TestZlib$(Configuration)\Tmp\ - true - false - x64\TestZlib$(Configuration)\ - x64\TestZlib$(Configuration)\Tmp\ - false - ia64\TestZlib$(Configuration)\ - ia64\TestZlib$(Configuration)\Tmp\ - false - false - x64\TestZlib$(Configuration)\ - x64\TestZlib$(Configuration)\Tmp\ - false - ia64\TestZlib$(Configuration)\ - ia64\TestZlib$(Configuration)\Tmp\ - false - false - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - - - - Disabled - ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;_DEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - AssemblyAndSourceCode - $(IntDir) - Level3 - ProgramDatabase - - - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) - $(OutDir)testzlib.exe - true - $(OutDir)testzlib.pdb - Console - false - - - MachineX86 - - - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;%(AdditionalIncludeDirectories) - WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - true - Default - MultiThreaded - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - $(OutDir)testzlib.exe - true - Console - true - true - false - - - MachineX86 - - - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - true - Default - MultiThreaded - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) - $(OutDir)testzlib.exe - true - Console - true - true - false - - - MachineX86 - - - - - ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;_DEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - Default - MultiThreadedDebugDLL - false - $(IntDir) - - - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) - - - - - Itanium - - - Disabled - ..\..\..;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_DEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - AssemblyAndSourceCode - $(IntDir) - Level3 - ProgramDatabase - - - $(OutDir)testzlib.exe - true - $(OutDir)testzlib.pdb - Console - MachineIA64 - - - - - ..\..\..;%(AdditionalIncludeDirectories) - WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - Default - MultiThreadedDLL - false - $(IntDir) - - - %(AdditionalDependencies) - - - - - Itanium - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - $(OutDir)testzlib.exe - true - Console - true - true - MachineIA64 - - - - - ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - Default - MultiThreadedDLL - false - $(IntDir) - - - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) - - - - - Itanium - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - $(OutDir)testzlib.exe - true - Console - true - true - MachineIA64 - - - - - - - - - - true - true - true - true - true - true - - - - - - - - - - - - - DELETED compat/zlib/contrib/vstudio/vc11/testzlibdll.vcxproj Index: compat/zlib/contrib/vstudio/vc11/testzlibdll.vcxproj ================================================================== --- compat/zlib/contrib/vstudio/vc11/testzlibdll.vcxproj +++ /dev/null @@ -1,314 +0,0 @@ - - - - - Debug - Itanium - - - Debug - Win32 - - - Debug - x64 - - - Release - Itanium - - - Release - Win32 - - - Release - x64 - - - - {C52F9E7B-498A-42BE-8DB4-85A15694366A} - Win32Proj - - - - Application - MultiByte - v110 - - - Application - Unicode - v110 - - - Application - MultiByte - - - Application - MultiByte - - - Application - MultiByte - v110 - - - Application - MultiByte - v110 - - - - - - - - - - - - - - - - - - - - - - - - - <_ProjectFileVersion>10.0.30128.1 - x86\TestZlibDll$(Configuration)\ - x86\TestZlibDll$(Configuration)\Tmp\ - true - false - x86\TestZlibDll$(Configuration)\ - x86\TestZlibDll$(Configuration)\Tmp\ - false - false - x64\TestZlibDll$(Configuration)\ - x64\TestZlibDll$(Configuration)\Tmp\ - true - false - ia64\TestZlibDll$(Configuration)\ - ia64\TestZlibDll$(Configuration)\Tmp\ - true - false - x64\TestZlibDll$(Configuration)\ - x64\TestZlibDll$(Configuration)\Tmp\ - false - false - ia64\TestZlibDll$(Configuration)\ - ia64\TestZlibDll$(Configuration)\Tmp\ - false - false - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - x86\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)testzlibdll.exe - true - $(OutDir)testzlib.pdb - Console - false - - - MachineX86 - - - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) - true - Default - MultiThreaded - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - x86\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)testzlibdll.exe - true - Console - true - true - false - - - MachineX86 - - - - - X64 - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - x64\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)testzlibdll.exe - true - $(OutDir)testzlib.pdb - Console - MachineX64 - - - - - Itanium - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - ia64\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)testzlibdll.exe - true - $(OutDir)testzlib.pdb - Console - MachineIA64 - - - - - X64 - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - x64\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)testzlibdll.exe - true - Console - true - true - MachineX64 - - - - - Itanium - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - ia64\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)testzlibdll.exe - true - Console - true - true - MachineIA64 - - - - - - - - {8fd826f8-3739-44e6-8cc8-997122e53b8d} - - - - - - DELETED compat/zlib/contrib/vstudio/vc11/zlib.rc Index: compat/zlib/contrib/vstudio/vc11/zlib.rc ================================================================== --- compat/zlib/contrib/vstudio/vc11/zlib.rc +++ /dev/null @@ -1,32 +0,0 @@ -#include - -#define IDR_VERSION1 1 -IDR_VERSION1 VERSIONINFO MOVEABLE IMPURE LOADONCALL DISCARDABLE - FILEVERSION 1, 2, 11, 0 - PRODUCTVERSION 1, 2, 11, 0 - FILEFLAGSMASK VS_FFI_FILEFLAGSMASK - FILEFLAGS 0 - FILEOS VOS_DOS_WINDOWS32 - FILETYPE VFT_DLL - FILESUBTYPE 0 // not used -BEGIN - BLOCK "StringFileInfo" - BEGIN - BLOCK "040904E4" - //language ID = U.S. English, char set = Windows, Multilingual - - BEGIN - VALUE "FileDescription", "zlib data compression and ZIP file I/O library\0" - VALUE "FileVersion", "1.2.11\0" - VALUE "InternalName", "zlib\0" - VALUE "OriginalFilename", "zlibwapi.dll\0" - VALUE "ProductName", "ZLib.DLL\0" - VALUE "Comments","DLL support by Alessandro Iacopetti & Gilles Vollant\0" - VALUE "LegalCopyright", "(C) 1995-2017 Jean-loup Gailly & Mark Adler\0" - END - END - BLOCK "VarFileInfo" - BEGIN - VALUE "Translation", 0x0409, 1252 - END -END DELETED compat/zlib/contrib/vstudio/vc11/zlibstat.vcxproj Index: compat/zlib/contrib/vstudio/vc11/zlibstat.vcxproj ================================================================== --- compat/zlib/contrib/vstudio/vc11/zlibstat.vcxproj +++ /dev/null @@ -1,464 +0,0 @@ - - - - - Debug - Itanium - - - Debug - Win32 - - - Debug - x64 - - - ReleaseWithoutAsm - Itanium - - - ReleaseWithoutAsm - Win32 - - - ReleaseWithoutAsm - x64 - - - Release - Itanium - - - Release - Win32 - - - Release - x64 - - - - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8} - - - - StaticLibrary - false - v110 - - - StaticLibrary - false - v110 - - - StaticLibrary - false - v110 - Unicode - - - StaticLibrary - false - - - StaticLibrary - false - - - StaticLibrary - false - - - StaticLibrary - false - v110 - - - StaticLibrary - false - v110 - - - StaticLibrary - false - v110 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <_ProjectFileVersion>10.0.30128.1 - x86\ZlibStat$(Configuration)\ - x86\ZlibStat$(Configuration)\Tmp\ - x86\ZlibStat$(Configuration)\ - x86\ZlibStat$(Configuration)\Tmp\ - x86\ZlibStat$(Configuration)\ - x86\ZlibStat$(Configuration)\Tmp\ - x64\ZlibStat$(Configuration)\ - x64\ZlibStat$(Configuration)\Tmp\ - ia64\ZlibStat$(Configuration)\ - ia64\ZlibStat$(Configuration)\Tmp\ - x64\ZlibStat$(Configuration)\ - x64\ZlibStat$(Configuration)\Tmp\ - ia64\ZlibStat$(Configuration)\ - ia64\ZlibStat$(Configuration)\Tmp\ - x64\ZlibStat$(Configuration)\ - x64\ZlibStat$(Configuration)\Tmp\ - ia64\ZlibStat$(Configuration)\ - ia64\ZlibStat$(Configuration)\Tmp\ - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - - - - Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - - - MultiThreadedDebugDLL - false - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - OldStyle - - - 0x040c - - - /MACHINE:X86 /NODEFAULTLIB %(AdditionalOptions) - $(OutDir)zlibstat.lib - true - - - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ASMV;ASMINF;%(PreprocessorDefinitions) - true - - - MultiThreaded - false - true - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - - - 0x040c - - - /MACHINE:X86 /NODEFAULTLIB %(AdditionalOptions) - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) - $(OutDir)zlibstat.lib - true - - - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - true - - - MultiThreaded - false - true - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - - - 0x040c - - - /MACHINE:X86 /NODEFAULTLIB %(AdditionalOptions) - $(OutDir)zlibstat.lib - true - - - - - X64 - - - Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - - - MultiThreadedDebugDLL - false - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - OldStyle - - - 0x040c - - - /MACHINE:AMD64 /NODEFAULTLIB %(AdditionalOptions) - $(OutDir)zlibstat.lib - true - - - - - Itanium - - - Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - - - MultiThreadedDebugDLL - false - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - OldStyle - - - 0x040c - - - /MACHINE:IA64 /NODEFAULTLIB %(AdditionalOptions) - $(OutDir)zlibstat.lib - true - - - - - X64 - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ASMV;ASMINF;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - - - 0x040c - - - /MACHINE:AMD64 /NODEFAULTLIB %(AdditionalOptions) - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) - $(OutDir)zlibstat.lib - true - - - - - Itanium - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - - - 0x040c - - - /MACHINE:IA64 /NODEFAULTLIB %(AdditionalOptions) - $(OutDir)zlibstat.lib - true - - - - - X64 - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - - - 0x040c - - - /MACHINE:AMD64 /NODEFAULTLIB %(AdditionalOptions) - $(OutDir)zlibstat.lib - true - - - - - Itanium - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - - - 0x040c - - - /MACHINE:IA64 /NODEFAULTLIB %(AdditionalOptions) - $(OutDir)zlibstat.lib - true - - - - - - - - - - - - - - true - true - true - true - true - true - - - - - - - - - - - - - - - - - - - - - DELETED compat/zlib/contrib/vstudio/vc11/zlibvc.def Index: compat/zlib/contrib/vstudio/vc11/zlibvc.def ================================================================== --- compat/zlib/contrib/vstudio/vc11/zlibvc.def +++ /dev/null @@ -1,153 +0,0 @@ -LIBRARY -; zlib data compression and ZIP file I/O library - -VERSION 1.2 - -EXPORTS - adler32 @1 - compress @2 - crc32 @3 - deflate @4 - deflateCopy @5 - deflateEnd @6 - deflateInit2_ @7 - deflateInit_ @8 - deflateParams @9 - deflateReset @10 - deflateSetDictionary @11 - gzclose @12 - gzdopen @13 - gzerror @14 - gzflush @15 - gzopen @16 - gzread @17 - gzwrite @18 - inflate @19 - inflateEnd @20 - inflateInit2_ @21 - inflateInit_ @22 - inflateReset @23 - inflateSetDictionary @24 - inflateSync @25 - uncompress @26 - zlibVersion @27 - gzprintf @28 - gzputc @29 - gzgetc @30 - gzseek @31 - gzrewind @32 - gztell @33 - gzeof @34 - gzsetparams @35 - zError @36 - inflateSyncPoint @37 - get_crc_table @38 - compress2 @39 - gzputs @40 - gzgets @41 - inflateCopy @42 - inflateBackInit_ @43 - inflateBack @44 - inflateBackEnd @45 - compressBound @46 - deflateBound @47 - gzclearerr @48 - gzungetc @49 - zlibCompileFlags @50 - deflatePrime @51 - deflatePending @52 - - unzOpen @61 - unzClose @62 - unzGetGlobalInfo @63 - unzGetCurrentFileInfo @64 - unzGoToFirstFile @65 - unzGoToNextFile @66 - unzOpenCurrentFile @67 - unzReadCurrentFile @68 - unzOpenCurrentFile3 @69 - unztell @70 - unzeof @71 - unzCloseCurrentFile @72 - unzGetGlobalComment @73 - unzStringFileNameCompare @74 - unzLocateFile @75 - unzGetLocalExtrafield @76 - unzOpen2 @77 - unzOpenCurrentFile2 @78 - unzOpenCurrentFilePassword @79 - - zipOpen @80 - zipOpenNewFileInZip @81 - zipWriteInFileInZip @82 - zipCloseFileInZip @83 - zipClose @84 - zipOpenNewFileInZip2 @86 - zipCloseFileInZipRaw @87 - zipOpen2 @88 - zipOpenNewFileInZip3 @89 - - unzGetFilePos @100 - unzGoToFilePos @101 - - fill_win32_filefunc @110 - -; zlibwapi v1.2.4 added: - fill_win32_filefunc64 @111 - fill_win32_filefunc64A @112 - fill_win32_filefunc64W @113 - - unzOpen64 @120 - unzOpen2_64 @121 - unzGetGlobalInfo64 @122 - unzGetCurrentFileInfo64 @124 - unzGetCurrentFileZStreamPos64 @125 - unztell64 @126 - unzGetFilePos64 @127 - unzGoToFilePos64 @128 - - zipOpen64 @130 - zipOpen2_64 @131 - zipOpenNewFileInZip64 @132 - zipOpenNewFileInZip2_64 @133 - zipOpenNewFileInZip3_64 @134 - zipOpenNewFileInZip4_64 @135 - zipCloseFileInZipRaw64 @136 - -; zlib1 v1.2.4 added: - adler32_combine @140 - crc32_combine @142 - deflateSetHeader @144 - deflateTune @145 - gzbuffer @146 - gzclose_r @147 - gzclose_w @148 - gzdirect @149 - gzoffset @150 - inflateGetHeader @156 - inflateMark @157 - inflatePrime @158 - inflateReset2 @159 - inflateUndermine @160 - -; zlib1 v1.2.6 added: - gzgetc_ @161 - inflateResetKeep @163 - deflateResetKeep @164 - -; zlib1 v1.2.7 added: - gzopen_w @165 - -; zlib1 v1.2.8 added: - inflateGetDictionary @166 - gzvprintf @167 - -; zlib1 v1.2.9 added: - inflateCodesUsed @168 - inflateValidate @169 - uncompress2 @170 - gzfread @171 - gzfwrite @172 - deflateGetDictionary @173 - adler32_z @174 - crc32_z @175 DELETED compat/zlib/contrib/vstudio/vc11/zlibvc.sln Index: compat/zlib/contrib/vstudio/vc11/zlibvc.sln ================================================================== --- compat/zlib/contrib/vstudio/vc11/zlibvc.sln +++ /dev/null @@ -1,117 +0,0 @@ - -Microsoft Visual Studio Solution File, Format Version 12.00 -# Visual Studio 2012 -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "zlibvc", "zlibvc.vcxproj", "{8FD826F8-3739-44E6-8CC8-997122E53B8D}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "zlibstat", "zlibstat.vcxproj", "{745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "testzlib", "testzlib.vcxproj", "{AA6666AA-E09F-4135-9C0C-4FE50C3C654B}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "testzlibdll", "testzlibdll.vcxproj", "{C52F9E7B-498A-42BE-8DB4-85A15694366A}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "minizip", "minizip.vcxproj", "{48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "miniunz", "miniunz.vcxproj", "{C52F9E7B-498A-42BE-8DB4-85A15694382A}" -EndProject -Global - GlobalSection(SolutionConfigurationPlatforms) = preSolution - Debug|Itanium = Debug|Itanium - Debug|Win32 = Debug|Win32 - Debug|x64 = Debug|x64 - Release|Itanium = Release|Itanium - Release|Win32 = Release|Win32 - Release|x64 = Release|x64 - ReleaseWithoutAsm|Itanium = ReleaseWithoutAsm|Itanium - ReleaseWithoutAsm|Win32 = ReleaseWithoutAsm|Win32 - ReleaseWithoutAsm|x64 = ReleaseWithoutAsm|x64 - EndGlobalSection - GlobalSection(ProjectConfigurationPlatforms) = postSolution - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Itanium.ActiveCfg = Debug|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Win32.ActiveCfg = Debug|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Win32.Build.0 = Debug|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|x64.ActiveCfg = Debug|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|x64.Build.0 = Debug|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Itanium.ActiveCfg = Release|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Win32.ActiveCfg = Release|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Win32.Build.0 = Release|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|x64.ActiveCfg = Release|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|x64.Build.0 = Release|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Itanium.ActiveCfg = Debug|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Win32.ActiveCfg = Debug|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Win32.Build.0 = Debug|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|x64.ActiveCfg = Debug|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|x64.Build.0 = Debug|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Itanium.ActiveCfg = Release|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Win32.ActiveCfg = Release|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Win32.Build.0 = Release|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|x64.ActiveCfg = Release|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|x64.Build.0 = Release|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.ActiveCfg = Debug|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.ActiveCfg = Debug|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.Build.0 = Debug|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.ActiveCfg = Debug|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.Build.0 = Debug|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.ActiveCfg = Release|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.ActiveCfg = Release|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.Build.0 = Release|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.ActiveCfg = Release|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.Build.0 = Release|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Itanium.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Win32.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Win32.Build.0 = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|x64.ActiveCfg = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|x64.Build.0 = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Itanium.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Win32.Build.0 = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|x64.ActiveCfg = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|x64.Build.0 = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.ActiveCfg = Debug|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.ActiveCfg = Debug|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.Build.0 = Debug|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.ActiveCfg = Debug|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.Build.0 = Debug|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.Build.0 = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.ActiveCfg = Release|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.Build.0 = Release|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Itanium.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Win32.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Win32.Build.0 = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|x64.ActiveCfg = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|x64.Build.0 = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Itanium.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Win32.Build.0 = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|x64.ActiveCfg = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|x64.Build.0 = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 - EndGlobalSection - GlobalSection(SolutionProperties) = preSolution - HideSolutionNode = FALSE - EndGlobalSection -EndGlobal DELETED compat/zlib/contrib/vstudio/vc11/zlibvc.vcxproj Index: compat/zlib/contrib/vstudio/vc11/zlibvc.vcxproj ================================================================== --- compat/zlib/contrib/vstudio/vc11/zlibvc.vcxproj +++ /dev/null @@ -1,688 +0,0 @@ - - - - - Debug - Itanium - - - Debug - Win32 - - - Debug - x64 - - - ReleaseWithoutAsm - Itanium - - - ReleaseWithoutAsm - Win32 - - - ReleaseWithoutAsm - x64 - - - Release - Itanium - - - Release - Win32 - - - Release - x64 - - - - {8FD826F8-3739-44E6-8CC8-997122E53B8D} - - - - DynamicLibrary - false - true - v110 - - - DynamicLibrary - false - true - v110 - - - DynamicLibrary - false - v110 - Unicode - - - DynamicLibrary - false - true - - - DynamicLibrary - false - true - - - DynamicLibrary - false - - - DynamicLibrary - false - true - v110 - - - DynamicLibrary - false - true - v110 - - - DynamicLibrary - false - v110 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <_ProjectFileVersion>10.0.30128.1 - x86\ZlibDll$(Configuration)\ - x86\ZlibDll$(Configuration)\Tmp\ - true - false - x86\ZlibDll$(Configuration)\ - x86\ZlibDll$(Configuration)\Tmp\ - false - false - x86\ZlibDll$(Configuration)\ - x86\ZlibDll$(Configuration)\Tmp\ - false - false - x64\ZlibDll$(Configuration)\ - x64\ZlibDll$(Configuration)\Tmp\ - true - false - ia64\ZlibDll$(Configuration)\ - ia64\ZlibDll$(Configuration)\Tmp\ - true - false - x64\ZlibDll$(Configuration)\ - x64\ZlibDll$(Configuration)\Tmp\ - false - false - ia64\ZlibDll$(Configuration)\ - ia64\ZlibDll$(Configuration)\Tmp\ - false - false - x64\ZlibDll$(Configuration)\ - x64\ZlibDll$(Configuration)\Tmp\ - false - false - ia64\ZlibDll$(Configuration)\ - ia64\ZlibDll$(Configuration)\Tmp\ - false - false - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - zlibwapi - zlibwapi - zlibwapi - zlibwapi - zlibwapi - zlibwapi - - - - _DEBUG;%(PreprocessorDefinitions) - true - true - Win32 - $(OutDir)zlibvc.tlb - - - Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;%(PreprocessorDefinitions) - - - MultiThreadedDebugDLL - false - $(IntDir)zlibvc.pch - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - ProgramDatabase - - - _DEBUG;%(PreprocessorDefinitions) - 0x040c - - - /MACHINE:I386 %(AdditionalOptions) - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) - $(OutDir)zlibwapi.dll - true - .\zlibvc.def - true - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - false - - - $(OutDir)zlibwapi.lib - - - cd ..\..\masmx86 -bld_ml32.bat - - - - - NDEBUG;%(PreprocessorDefinitions) - true - true - Win32 - $(OutDir)zlibvc.tlb - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibvc.pch - All - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - - - NDEBUG;%(PreprocessorDefinitions) - 0x040c - - - /MACHINE:I386 %(AdditionalOptions) - $(OutDir)zlibwapi.dll - true - false - .\zlibvc.def - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - false - - - $(OutDir)zlibwapi.lib - - - - - NDEBUG;%(PreprocessorDefinitions) - true - true - Win32 - $(OutDir)zlibvc.tlb - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;%(PreprocessorDefinitions) - true - - - MultiThreaded - false - true - $(IntDir)zlibvc.pch - All - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - - - NDEBUG;%(PreprocessorDefinitions) - 0x040c - - - /MACHINE:I386 %(AdditionalOptions) - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) - $(OutDir)zlibwapi.dll - true - false - .\zlibvc.def - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - false - - - $(OutDir)zlibwapi.lib - - - cd ..\..\masmx86 -bld_ml32.bat - - - - - _DEBUG;%(PreprocessorDefinitions) - true - true - X64 - $(OutDir)zlibvc.tlb - - - Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;WIN64;%(PreprocessorDefinitions) - - - MultiThreadedDebugDLL - false - $(IntDir)zlibvc.pch - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - ProgramDatabase - - - _DEBUG;%(PreprocessorDefinitions) - 0x040c - - - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) - $(OutDir)zlibwapi.dll - true - .\zlibvc.def - true - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - $(OutDir)zlibwapi.lib - MachineX64 - - - cd ..\..\contrib\masmx64 -bld_ml64.bat - - - - - _DEBUG;%(PreprocessorDefinitions) - true - true - Itanium - $(OutDir)zlibvc.tlb - - - Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) - - - MultiThreadedDebugDLL - false - $(IntDir)zlibvc.pch - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - ProgramDatabase - - - _DEBUG;%(PreprocessorDefinitions) - 0x040c - - - $(OutDir)zlibwapi.dll - true - .\zlibvc.def - true - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - $(OutDir)zlibwapi.lib - MachineIA64 - - - - - NDEBUG;%(PreprocessorDefinitions) - true - true - X64 - $(OutDir)zlibvc.tlb - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibvc.pch - All - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - - - NDEBUG;%(PreprocessorDefinitions) - 0x040c - - - $(OutDir)zlibwapi.dll - true - false - .\zlibvc.def - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - $(OutDir)zlibwapi.lib - MachineX64 - - - - - NDEBUG;%(PreprocessorDefinitions) - true - true - Itanium - $(OutDir)zlibvc.tlb - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibvc.pch - All - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - - - NDEBUG;%(PreprocessorDefinitions) - 0x040c - - - $(OutDir)zlibwapi.dll - true - false - .\zlibvc.def - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - $(OutDir)zlibwapi.lib - MachineIA64 - - - - - NDEBUG;%(PreprocessorDefinitions) - true - true - X64 - $(OutDir)zlibvc.tlb - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibvc.pch - All - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - - - NDEBUG;%(PreprocessorDefinitions) - 0x040c - - - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) - $(OutDir)zlibwapi.dll - true - false - .\zlibvc.def - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - $(OutDir)zlibwapi.lib - MachineX64 - - - cd ..\..\masmx64 -bld_ml64.bat - - - - - NDEBUG;%(PreprocessorDefinitions) - true - true - Itanium - $(OutDir)zlibvc.tlb - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibvc.pch - All - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - - - NDEBUG;%(PreprocessorDefinitions) - 0x040c - - - $(OutDir)zlibwapi.dll - true - false - .\zlibvc.def - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - $(OutDir)zlibwapi.lib - MachineIA64 - - - - - - - - - - - - - - true - true - true - true - true - true - - - - - - - - - - %(AdditionalIncludeDirectories) - ZLIB_INTERNAL;%(PreprocessorDefinitions) - %(AdditionalIncludeDirectories) - ZLIB_INTERNAL;%(PreprocessorDefinitions) - %(AdditionalIncludeDirectories) - ZLIB_INTERNAL;%(PreprocessorDefinitions) - - - %(AdditionalIncludeDirectories) - ZLIB_INTERNAL;%(PreprocessorDefinitions) - %(AdditionalIncludeDirectories) - ZLIB_INTERNAL;%(PreprocessorDefinitions) - %(AdditionalIncludeDirectories) - ZLIB_INTERNAL;%(PreprocessorDefinitions) - - - - - - - - - - - - - - - - - - - - - - - - DELETED compat/zlib/contrib/vstudio/vc12/miniunz.vcxproj Index: compat/zlib/contrib/vstudio/vc12/miniunz.vcxproj ================================================================== --- compat/zlib/contrib/vstudio/vc12/miniunz.vcxproj +++ /dev/null @@ -1,316 +0,0 @@ - - - - - Debug - Itanium - - - Debug - Win32 - - - Debug - x64 - - - Release - Itanium - - - Release - Win32 - - - Release - x64 - - - - {C52F9E7B-498A-42BE-8DB4-85A15694382A} - Win32Proj - - - - Application - MultiByte - v120 - - - Application - Unicode - v120 - - - Application - MultiByte - v120 - - - Application - MultiByte - v120 - - - Application - MultiByte - v120 - - - Application - MultiByte - v120 - - - - - - - - - - - - - - - - - - - - - - - - - <_ProjectFileVersion>10.0.30128.1 - x86\MiniUnzip$(Configuration)\ - x86\MiniUnzip$(Configuration)\Tmp\ - true - false - x86\MiniUnzip$(Configuration)\ - x86\MiniUnzip$(Configuration)\Tmp\ - false - false - x64\MiniUnzip$(Configuration)\ - x64\MiniUnzip$(Configuration)\Tmp\ - true - false - ia64\MiniUnzip$(Configuration)\ - ia64\MiniUnzip$(Configuration)\Tmp\ - true - false - x64\MiniUnzip$(Configuration)\ - x64\MiniUnzip$(Configuration)\Tmp\ - false - false - ia64\MiniUnzip$(Configuration)\ - ia64\MiniUnzip$(Configuration)\Tmp\ - false - false - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - x86\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)miniunz.exe - true - $(OutDir)miniunz.pdb - Console - false - - - MachineX86 - - - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) - true - Default - MultiThreaded - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - x86\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)miniunz.exe - true - Console - true - true - false - - - MachineX86 - - - - - X64 - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - x64\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)miniunz.exe - true - $(OutDir)miniunz.pdb - Console - MachineX64 - - - - - Itanium - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - ia64\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)miniunz.exe - true - $(OutDir)miniunz.pdb - Console - MachineIA64 - - - - - X64 - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - x64\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)miniunz.exe - true - Console - true - true - MachineX64 - - - - - Itanium - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - ia64\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)miniunz.exe - true - Console - true - true - MachineIA64 - - - - - - - - {8fd826f8-3739-44e6-8cc8-997122e53b8d} - - - - - - DELETED compat/zlib/contrib/vstudio/vc12/minizip.vcxproj Index: compat/zlib/contrib/vstudio/vc12/minizip.vcxproj ================================================================== --- compat/zlib/contrib/vstudio/vc12/minizip.vcxproj +++ /dev/null @@ -1,313 +0,0 @@ - - - - - Debug - Itanium - - - Debug - Win32 - - - Debug - x64 - - - Release - Itanium - - - Release - Win32 - - - Release - x64 - - - - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B} - Win32Proj - - - - Application - MultiByte - v120 - - - Application - Unicode - v120 - - - Application - MultiByte - v120 - - - Application - MultiByte - v120 - - - Application - MultiByte - v120 - - - Application - MultiByte - v120 - - - - - - - - - - - - - - - - - - - - - - - - - <_ProjectFileVersion>10.0.30128.1 - x86\MiniZip$(Configuration)\ - x86\MiniZip$(Configuration)\Tmp\ - true - false - x86\MiniZip$(Configuration)\ - x86\MiniZip$(Configuration)\Tmp\ - false - x64\$(Configuration)\ - x64\$(Configuration)\ - true - false - ia64\$(Configuration)\ - ia64\$(Configuration)\ - true - false - x64\$(Configuration)\ - x64\$(Configuration)\ - false - ia64\$(Configuration)\ - ia64\$(Configuration)\ - false - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - x86\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)minizip.exe - true - $(OutDir)minizip.pdb - Console - false - - - MachineX86 - - - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) - true - Default - MultiThreaded - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - x86\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)minizip.exe - true - Console - true - true - false - - - MachineX86 - - - - - X64 - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - x64\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)minizip.exe - true - $(OutDir)minizip.pdb - Console - MachineX64 - - - - - Itanium - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - ia64\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)minizip.exe - true - $(OutDir)minizip.pdb - Console - MachineIA64 - - - - - X64 - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - x64\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)minizip.exe - true - Console - true - true - MachineX64 - - - - - Itanium - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - ia64\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)minizip.exe - true - Console - true - true - MachineIA64 - - - - - - - - {8fd826f8-3739-44e6-8cc8-997122e53b8d} - - - - - - DELETED compat/zlib/contrib/vstudio/vc12/testzlib.vcxproj Index: compat/zlib/contrib/vstudio/vc12/testzlib.vcxproj ================================================================== --- compat/zlib/contrib/vstudio/vc12/testzlib.vcxproj +++ /dev/null @@ -1,430 +0,0 @@ - - - - - Debug - Itanium - - - Debug - Win32 - - - Debug - x64 - - - ReleaseWithoutAsm - Itanium - - - ReleaseWithoutAsm - Win32 - - - ReleaseWithoutAsm - x64 - - - Release - Itanium - - - Release - Win32 - - - Release - x64 - - - - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B} - testzlib - Win32Proj - - - - Application - MultiByte - true - v120 - - - Application - MultiByte - true - v120 - - - Application - Unicode - v120 - - - Application - MultiByte - true - v120 - - - Application - MultiByte - true - v120 - - - Application - MultiByte - v120 - - - Application - true - v120 - - - Application - true - v120 - - - Application - v120 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <_ProjectFileVersion>10.0.30128.1 - x86\TestZlib$(Configuration)\ - x86\TestZlib$(Configuration)\Tmp\ - true - false - x86\TestZlib$(Configuration)\ - x86\TestZlib$(Configuration)\Tmp\ - false - false - x86\TestZlib$(Configuration)\ - x86\TestZlib$(Configuration)\Tmp\ - false - false - x64\TestZlib$(Configuration)\ - x64\TestZlib$(Configuration)\Tmp\ - false - ia64\TestZlib$(Configuration)\ - ia64\TestZlib$(Configuration)\Tmp\ - true - false - x64\TestZlib$(Configuration)\ - x64\TestZlib$(Configuration)\Tmp\ - false - ia64\TestZlib$(Configuration)\ - ia64\TestZlib$(Configuration)\Tmp\ - false - false - x64\TestZlib$(Configuration)\ - x64\TestZlib$(Configuration)\Tmp\ - false - ia64\TestZlib$(Configuration)\ - ia64\TestZlib$(Configuration)\Tmp\ - false - false - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - - - - Disabled - ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;_DEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - AssemblyAndSourceCode - $(IntDir) - Level3 - ProgramDatabase - - - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) - $(OutDir)testzlib.exe - true - $(OutDir)testzlib.pdb - Console - false - - - MachineX86 - - - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;%(AdditionalIncludeDirectories) - WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - true - Default - MultiThreaded - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - $(OutDir)testzlib.exe - true - Console - true - true - false - - - MachineX86 - - - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - true - Default - MultiThreaded - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) - $(OutDir)testzlib.exe - true - Console - true - true - false - - - MachineX86 - false - - - - - ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;_DEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - Default - MultiThreadedDebugDLL - false - $(IntDir) - - - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) - - - - - Itanium - - - Disabled - ..\..\..;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_DEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - AssemblyAndSourceCode - $(IntDir) - Level3 - ProgramDatabase - - - $(OutDir)testzlib.exe - true - $(OutDir)testzlib.pdb - Console - MachineIA64 - - - - - ..\..\..;%(AdditionalIncludeDirectories) - WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - Default - MultiThreadedDLL - false - $(IntDir) - - - %(AdditionalDependencies) - - - - - Itanium - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - $(OutDir)testzlib.exe - true - Console - true - true - MachineIA64 - - - - - ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - Default - MultiThreadedDLL - false - $(IntDir) - - - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) - - - - - Itanium - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - $(OutDir)testzlib.exe - true - Console - true - true - MachineIA64 - - - - - - - - - - true - true - true - true - true - true - - - - - - - - - - - - - DELETED compat/zlib/contrib/vstudio/vc12/testzlibdll.vcxproj Index: compat/zlib/contrib/vstudio/vc12/testzlibdll.vcxproj ================================================================== --- compat/zlib/contrib/vstudio/vc12/testzlibdll.vcxproj +++ /dev/null @@ -1,316 +0,0 @@ - - - - - Debug - Itanium - - - Debug - Win32 - - - Debug - x64 - - - Release - Itanium - - - Release - Win32 - - - Release - x64 - - - - {C52F9E7B-498A-42BE-8DB4-85A15694366A} - Win32Proj - - - - Application - MultiByte - v120 - - - Application - Unicode - v120 - - - Application - MultiByte - v120 - - - Application - MultiByte - v120 - - - Application - MultiByte - v120 - - - Application - MultiByte - v120 - - - - - - - - - - - - - - - - - - - - - - - - - <_ProjectFileVersion>10.0.30128.1 - x86\TestZlibDll$(Configuration)\ - x86\TestZlibDll$(Configuration)\Tmp\ - true - false - x86\TestZlibDll$(Configuration)\ - x86\TestZlibDll$(Configuration)\Tmp\ - false - false - x64\TestZlibDll$(Configuration)\ - x64\TestZlibDll$(Configuration)\Tmp\ - true - false - ia64\TestZlibDll$(Configuration)\ - ia64\TestZlibDll$(Configuration)\Tmp\ - true - false - x64\TestZlibDll$(Configuration)\ - x64\TestZlibDll$(Configuration)\Tmp\ - false - false - ia64\TestZlibDll$(Configuration)\ - ia64\TestZlibDll$(Configuration)\Tmp\ - false - false - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - x86\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)testzlibdll.exe - true - $(OutDir)testzlib.pdb - Console - false - - - MachineX86 - - - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) - true - Default - MultiThreaded - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - x86\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)testzlibdll.exe - true - Console - true - true - false - - - MachineX86 - - - - - X64 - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - x64\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)testzlibdll.exe - true - $(OutDir)testzlib.pdb - Console - MachineX64 - - - - - Itanium - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - ia64\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)testzlibdll.exe - true - $(OutDir)testzlib.pdb - Console - MachineIA64 - - - - - X64 - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - x64\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)testzlibdll.exe - true - Console - true - true - MachineX64 - - - - - Itanium - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - ia64\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)testzlibdll.exe - true - Console - true - true - MachineIA64 - - - - - - - - {8fd826f8-3739-44e6-8cc8-997122e53b8d} - - - - - - DELETED compat/zlib/contrib/vstudio/vc12/zlib.rc Index: compat/zlib/contrib/vstudio/vc12/zlib.rc ================================================================== --- compat/zlib/contrib/vstudio/vc12/zlib.rc +++ /dev/null @@ -1,32 +0,0 @@ -#include - -#define IDR_VERSION1 1 -IDR_VERSION1 VERSIONINFO MOVEABLE IMPURE LOADONCALL DISCARDABLE - FILEVERSION 1, 2, 11, 0 - PRODUCTVERSION 1, 2, 11, 0 - FILEFLAGSMASK VS_FFI_FILEFLAGSMASK - FILEFLAGS 0 - FILEOS VOS_DOS_WINDOWS32 - FILETYPE VFT_DLL - FILESUBTYPE 0 // not used -BEGIN - BLOCK "StringFileInfo" - BEGIN - BLOCK "040904E4" - //language ID = U.S. English, char set = Windows, Multilingual - - BEGIN - VALUE "FileDescription", "zlib data compression and ZIP file I/O library\0" - VALUE "FileVersion", "1.2.11\0" - VALUE "InternalName", "zlib\0" - VALUE "OriginalFilename", "zlibwapi.dll\0" - VALUE "ProductName", "ZLib.DLL\0" - VALUE "Comments","DLL support by Alessandro Iacopetti & Gilles Vollant\0" - VALUE "LegalCopyright", "(C) 1995-2017 Jean-loup Gailly & Mark Adler\0" - END - END - BLOCK "VarFileInfo" - BEGIN - VALUE "Translation", 0x0409, 1252 - END -END DELETED compat/zlib/contrib/vstudio/vc12/zlibstat.vcxproj Index: compat/zlib/contrib/vstudio/vc12/zlibstat.vcxproj ================================================================== --- compat/zlib/contrib/vstudio/vc12/zlibstat.vcxproj +++ /dev/null @@ -1,467 +0,0 @@ - - - - - Debug - Itanium - - - Debug - Win32 - - - Debug - x64 - - - ReleaseWithoutAsm - Itanium - - - ReleaseWithoutAsm - Win32 - - - ReleaseWithoutAsm - x64 - - - Release - Itanium - - - Release - Win32 - - - Release - x64 - - - - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8} - - - - StaticLibrary - false - v120 - - - StaticLibrary - false - v120 - - - StaticLibrary - false - v120 - Unicode - - - StaticLibrary - false - v120 - - - StaticLibrary - false - v120 - - - StaticLibrary - false - v120 - - - StaticLibrary - false - v120 - - - StaticLibrary - false - v120 - - - StaticLibrary - false - v120 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <_ProjectFileVersion>10.0.30128.1 - x86\ZlibStat$(Configuration)\ - x86\ZlibStat$(Configuration)\Tmp\ - x86\ZlibStat$(Configuration)\ - x86\ZlibStat$(Configuration)\Tmp\ - x86\ZlibStat$(Configuration)\ - x86\ZlibStat$(Configuration)\Tmp\ - x64\ZlibStat$(Configuration)\ - x64\ZlibStat$(Configuration)\Tmp\ - ia64\ZlibStat$(Configuration)\ - ia64\ZlibStat$(Configuration)\Tmp\ - x64\ZlibStat$(Configuration)\ - x64\ZlibStat$(Configuration)\Tmp\ - ia64\ZlibStat$(Configuration)\ - ia64\ZlibStat$(Configuration)\Tmp\ - x64\ZlibStat$(Configuration)\ - x64\ZlibStat$(Configuration)\Tmp\ - ia64\ZlibStat$(Configuration)\ - ia64\ZlibStat$(Configuration)\Tmp\ - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - - - - Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - - - MultiThreadedDebugDLL - false - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - OldStyle - - - 0x040c - - - /MACHINE:X86 /NODEFAULTLIB %(AdditionalOptions) - $(OutDir)zlibstat.lib - true - - - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ASMV;ASMINF;%(PreprocessorDefinitions) - true - - - MultiThreaded - false - true - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - - - 0x040c - - - /MACHINE:X86 /NODEFAULTLIB %(AdditionalOptions) - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) - $(OutDir)zlibstat.lib - true - - - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - true - - - MultiThreaded - false - true - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - - - 0x040c - - - /MACHINE:X86 /NODEFAULTLIB %(AdditionalOptions) - $(OutDir)zlibstat.lib - true - - - - - X64 - - - Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - - - MultiThreadedDebugDLL - false - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - OldStyle - - - 0x040c - - - /MACHINE:AMD64 /NODEFAULTLIB %(AdditionalOptions) - $(OutDir)zlibstat.lib - true - - - - - Itanium - - - Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - - - MultiThreadedDebugDLL - false - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - OldStyle - - - 0x040c - - - /MACHINE:IA64 /NODEFAULTLIB %(AdditionalOptions) - $(OutDir)zlibstat.lib - true - - - - - X64 - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ASMV;ASMINF;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - - - 0x040c - - - /MACHINE:AMD64 /NODEFAULTLIB %(AdditionalOptions) - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) - $(OutDir)zlibstat.lib - true - - - - - Itanium - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - - - 0x040c - - - /MACHINE:IA64 /NODEFAULTLIB %(AdditionalOptions) - $(OutDir)zlibstat.lib - true - - - - - X64 - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - - - 0x040c - - - /MACHINE:AMD64 /NODEFAULTLIB %(AdditionalOptions) - $(OutDir)zlibstat.lib - true - - - - - Itanium - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - - - 0x040c - - - /MACHINE:IA64 /NODEFAULTLIB %(AdditionalOptions) - $(OutDir)zlibstat.lib - true - - - - - - - - - - - - - - true - true - true - true - true - true - - - - - - - - - - - - - - - - - - - - - DELETED compat/zlib/contrib/vstudio/vc12/zlibvc.def Index: compat/zlib/contrib/vstudio/vc12/zlibvc.def ================================================================== --- compat/zlib/contrib/vstudio/vc12/zlibvc.def +++ /dev/null @@ -1,153 +0,0 @@ -LIBRARY -; zlib data compression and ZIP file I/O library - -VERSION 1.2 - -EXPORTS - adler32 @1 - compress @2 - crc32 @3 - deflate @4 - deflateCopy @5 - deflateEnd @6 - deflateInit2_ @7 - deflateInit_ @8 - deflateParams @9 - deflateReset @10 - deflateSetDictionary @11 - gzclose @12 - gzdopen @13 - gzerror @14 - gzflush @15 - gzopen @16 - gzread @17 - gzwrite @18 - inflate @19 - inflateEnd @20 - inflateInit2_ @21 - inflateInit_ @22 - inflateReset @23 - inflateSetDictionary @24 - inflateSync @25 - uncompress @26 - zlibVersion @27 - gzprintf @28 - gzputc @29 - gzgetc @30 - gzseek @31 - gzrewind @32 - gztell @33 - gzeof @34 - gzsetparams @35 - zError @36 - inflateSyncPoint @37 - get_crc_table @38 - compress2 @39 - gzputs @40 - gzgets @41 - inflateCopy @42 - inflateBackInit_ @43 - inflateBack @44 - inflateBackEnd @45 - compressBound @46 - deflateBound @47 - gzclearerr @48 - gzungetc @49 - zlibCompileFlags @50 - deflatePrime @51 - deflatePending @52 - - unzOpen @61 - unzClose @62 - unzGetGlobalInfo @63 - unzGetCurrentFileInfo @64 - unzGoToFirstFile @65 - unzGoToNextFile @66 - unzOpenCurrentFile @67 - unzReadCurrentFile @68 - unzOpenCurrentFile3 @69 - unztell @70 - unzeof @71 - unzCloseCurrentFile @72 - unzGetGlobalComment @73 - unzStringFileNameCompare @74 - unzLocateFile @75 - unzGetLocalExtrafield @76 - unzOpen2 @77 - unzOpenCurrentFile2 @78 - unzOpenCurrentFilePassword @79 - - zipOpen @80 - zipOpenNewFileInZip @81 - zipWriteInFileInZip @82 - zipCloseFileInZip @83 - zipClose @84 - zipOpenNewFileInZip2 @86 - zipCloseFileInZipRaw @87 - zipOpen2 @88 - zipOpenNewFileInZip3 @89 - - unzGetFilePos @100 - unzGoToFilePos @101 - - fill_win32_filefunc @110 - -; zlibwapi v1.2.4 added: - fill_win32_filefunc64 @111 - fill_win32_filefunc64A @112 - fill_win32_filefunc64W @113 - - unzOpen64 @120 - unzOpen2_64 @121 - unzGetGlobalInfo64 @122 - unzGetCurrentFileInfo64 @124 - unzGetCurrentFileZStreamPos64 @125 - unztell64 @126 - unzGetFilePos64 @127 - unzGoToFilePos64 @128 - - zipOpen64 @130 - zipOpen2_64 @131 - zipOpenNewFileInZip64 @132 - zipOpenNewFileInZip2_64 @133 - zipOpenNewFileInZip3_64 @134 - zipOpenNewFileInZip4_64 @135 - zipCloseFileInZipRaw64 @136 - -; zlib1 v1.2.4 added: - adler32_combine @140 - crc32_combine @142 - deflateSetHeader @144 - deflateTune @145 - gzbuffer @146 - gzclose_r @147 - gzclose_w @148 - gzdirect @149 - gzoffset @150 - inflateGetHeader @156 - inflateMark @157 - inflatePrime @158 - inflateReset2 @159 - inflateUndermine @160 - -; zlib1 v1.2.6 added: - gzgetc_ @161 - inflateResetKeep @163 - deflateResetKeep @164 - -; zlib1 v1.2.7 added: - gzopen_w @165 - -; zlib1 v1.2.8 added: - inflateGetDictionary @166 - gzvprintf @167 - -; zlib1 v1.2.9 added: - inflateCodesUsed @168 - inflateValidate @169 - uncompress2 @170 - gzfread @171 - gzfwrite @172 - deflateGetDictionary @173 - adler32_z @174 - crc32_z @175 DELETED compat/zlib/contrib/vstudio/vc12/zlibvc.sln Index: compat/zlib/contrib/vstudio/vc12/zlibvc.sln ================================================================== --- compat/zlib/contrib/vstudio/vc12/zlibvc.sln +++ /dev/null @@ -1,119 +0,0 @@ - -Microsoft Visual Studio Solution File, Format Version 12.00 -# Visual Studio 2013 -VisualStudioVersion = 12.0.40629.0 -MinimumVisualStudioVersion = 10.0.40219.1 -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "zlibvc", "zlibvc.vcxproj", "{8FD826F8-3739-44E6-8CC8-997122E53B8D}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "zlibstat", "zlibstat.vcxproj", "{745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "testzlib", "testzlib.vcxproj", "{AA6666AA-E09F-4135-9C0C-4FE50C3C654B}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "testzlibdll", "testzlibdll.vcxproj", "{C52F9E7B-498A-42BE-8DB4-85A15694366A}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "minizip", "minizip.vcxproj", "{48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "miniunz", "miniunz.vcxproj", "{C52F9E7B-498A-42BE-8DB4-85A15694382A}" -EndProject -Global - GlobalSection(SolutionConfigurationPlatforms) = preSolution - Debug|Itanium = Debug|Itanium - Debug|Win32 = Debug|Win32 - Debug|x64 = Debug|x64 - Release|Itanium = Release|Itanium - Release|Win32 = Release|Win32 - Release|x64 = Release|x64 - ReleaseWithoutAsm|Itanium = ReleaseWithoutAsm|Itanium - ReleaseWithoutAsm|Win32 = ReleaseWithoutAsm|Win32 - ReleaseWithoutAsm|x64 = ReleaseWithoutAsm|x64 - EndGlobalSection - GlobalSection(ProjectConfigurationPlatforms) = postSolution - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Itanium.ActiveCfg = Debug|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Win32.ActiveCfg = Debug|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Win32.Build.0 = Debug|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|x64.ActiveCfg = Debug|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|x64.Build.0 = Debug|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Itanium.ActiveCfg = Release|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Win32.ActiveCfg = Release|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Win32.Build.0 = Release|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|x64.ActiveCfg = Release|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|x64.Build.0 = Release|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Itanium.ActiveCfg = Debug|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Win32.ActiveCfg = Debug|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Win32.Build.0 = Debug|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|x64.ActiveCfg = Debug|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|x64.Build.0 = Debug|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Itanium.ActiveCfg = Release|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Win32.ActiveCfg = Release|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Win32.Build.0 = Release|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|x64.ActiveCfg = Release|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|x64.Build.0 = Release|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.ActiveCfg = Debug|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.ActiveCfg = Debug|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.Build.0 = Debug|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.ActiveCfg = Debug|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.Build.0 = Debug|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.ActiveCfg = Release|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.ActiveCfg = Release|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.Build.0 = Release|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.ActiveCfg = Release|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.Build.0 = Release|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Itanium.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Win32.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Win32.Build.0 = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|x64.ActiveCfg = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|x64.Build.0 = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Itanium.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Win32.Build.0 = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|x64.ActiveCfg = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|x64.Build.0 = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.ActiveCfg = Debug|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.ActiveCfg = Debug|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.Build.0 = Debug|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.ActiveCfg = Debug|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.Build.0 = Debug|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.Build.0 = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.ActiveCfg = Release|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.Build.0 = Release|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Itanium.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Win32.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Win32.Build.0 = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|x64.ActiveCfg = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|x64.Build.0 = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Itanium.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Win32.Build.0 = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|x64.ActiveCfg = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|x64.Build.0 = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 - EndGlobalSection - GlobalSection(SolutionProperties) = preSolution - HideSolutionNode = FALSE - EndGlobalSection -EndGlobal DELETED compat/zlib/contrib/vstudio/vc12/zlibvc.vcxproj Index: compat/zlib/contrib/vstudio/vc12/zlibvc.vcxproj ================================================================== --- compat/zlib/contrib/vstudio/vc12/zlibvc.vcxproj +++ /dev/null @@ -1,692 +0,0 @@ - - - - - Debug - Itanium - - - Debug - Win32 - - - Debug - x64 - - - ReleaseWithoutAsm - Itanium - - - ReleaseWithoutAsm - Win32 - - - ReleaseWithoutAsm - x64 - - - Release - Itanium - - - Release - Win32 - - - Release - x64 - - - - {8FD826F8-3739-44E6-8CC8-997122E53B8D} - - - - DynamicLibrary - false - true - v120 - - - DynamicLibrary - false - true - v120 - - - DynamicLibrary - false - v120 - Unicode - - - DynamicLibrary - false - true - v120 - - - DynamicLibrary - false - true - v120 - - - DynamicLibrary - false - v120 - - - DynamicLibrary - false - true - v120 - - - DynamicLibrary - false - true - v120 - - - DynamicLibrary - false - v120 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <_ProjectFileVersion>10.0.30128.1 - x86\ZlibDll$(Configuration)\ - x86\ZlibDll$(Configuration)\Tmp\ - true - false - x86\ZlibDll$(Configuration)\ - x86\ZlibDll$(Configuration)\Tmp\ - false - false - x86\ZlibDll$(Configuration)\ - x86\ZlibDll$(Configuration)\Tmp\ - false - false - x64\ZlibDll$(Configuration)\ - x64\ZlibDll$(Configuration)\Tmp\ - true - false - ia64\ZlibDll$(Configuration)\ - ia64\ZlibDll$(Configuration)\Tmp\ - true - false - x64\ZlibDll$(Configuration)\ - x64\ZlibDll$(Configuration)\Tmp\ - false - false - ia64\ZlibDll$(Configuration)\ - ia64\ZlibDll$(Configuration)\Tmp\ - false - false - x64\ZlibDll$(Configuration)\ - x64\ZlibDll$(Configuration)\Tmp\ - false - false - ia64\ZlibDll$(Configuration)\ - ia64\ZlibDll$(Configuration)\Tmp\ - false - false - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - zlibwapi - zlibwapi - zlibwapi - zlibwapi - zlibwapi - zlibwapi - - - - _DEBUG;%(PreprocessorDefinitions) - true - true - Win32 - $(OutDir)zlibvc.tlb - - - Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;%(PreprocessorDefinitions) - - - MultiThreadedDebugDLL - false - $(IntDir)zlibvc.pch - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - ProgramDatabase - - - _DEBUG;%(PreprocessorDefinitions) - 0x040c - - - /MACHINE:I386 %(AdditionalOptions) - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) - $(OutDir)zlibwapi.dll - true - .\zlibvc.def - true - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - false - - - $(OutDir)zlibwapi.lib - - - cd ..\..\masmx86 -bld_ml32.bat - - - - - NDEBUG;%(PreprocessorDefinitions) - true - true - Win32 - $(OutDir)zlibvc.tlb - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibvc.pch - All - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - - - NDEBUG;%(PreprocessorDefinitions) - 0x040c - - - /MACHINE:I386 %(AdditionalOptions) - $(OutDir)zlibwapi.dll - true - false - .\zlibvc.def - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - false - - - $(OutDir)zlibwapi.lib - - - - - NDEBUG;%(PreprocessorDefinitions) - true - true - Win32 - $(OutDir)zlibvc.tlb - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;%(PreprocessorDefinitions) - true - - - MultiThreaded - false - true - $(IntDir)zlibvc.pch - All - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - - - NDEBUG;%(PreprocessorDefinitions) - 0x040c - - - /MACHINE:I386 %(AdditionalOptions) - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) - $(OutDir)zlibwapi.dll - true - false - .\zlibvc.def - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - false - - - $(OutDir)zlibwapi.lib - false - - - cd ..\..\masmx86 -bld_ml32.bat - - - - - _DEBUG;%(PreprocessorDefinitions) - true - true - X64 - $(OutDir)zlibvc.tlb - - - Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;WIN64;%(PreprocessorDefinitions) - - - MultiThreadedDebugDLL - false - $(IntDir)zlibvc.pch - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - ProgramDatabase - - - _DEBUG;%(PreprocessorDefinitions) - 0x040c - - - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) - $(OutDir)zlibwapi.dll - true - .\zlibvc.def - true - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - $(OutDir)zlibwapi.lib - MachineX64 - - - cd ..\..\contrib\masmx64 -bld_ml64.bat - - - - - _DEBUG;%(PreprocessorDefinitions) - true - true - Itanium - $(OutDir)zlibvc.tlb - - - Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) - - - MultiThreadedDebugDLL - false - $(IntDir)zlibvc.pch - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - ProgramDatabase - - - _DEBUG;%(PreprocessorDefinitions) - 0x040c - - - $(OutDir)zlibwapi.dll - true - .\zlibvc.def - true - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - $(OutDir)zlibwapi.lib - MachineIA64 - - - - - NDEBUG;%(PreprocessorDefinitions) - true - true - X64 - $(OutDir)zlibvc.tlb - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibvc.pch - All - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - - - NDEBUG;%(PreprocessorDefinitions) - 0x040c - - - $(OutDir)zlibwapi.dll - true - false - .\zlibvc.def - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - $(OutDir)zlibwapi.lib - MachineX64 - - - - - NDEBUG;%(PreprocessorDefinitions) - true - true - Itanium - $(OutDir)zlibvc.tlb - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibvc.pch - All - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - - - NDEBUG;%(PreprocessorDefinitions) - 0x040c - - - $(OutDir)zlibwapi.dll - true - false - .\zlibvc.def - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - $(OutDir)zlibwapi.lib - MachineIA64 - - - - - NDEBUG;%(PreprocessorDefinitions) - true - true - X64 - $(OutDir)zlibvc.tlb - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibvc.pch - All - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - - - NDEBUG;%(PreprocessorDefinitions) - 0x040c - - - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) - $(OutDir)zlibwapi.dll - true - false - .\zlibvc.def - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - $(OutDir)zlibwapi.lib - MachineX64 - - - cd ..\..\masmx64 -bld_ml64.bat - - - - - NDEBUG;%(PreprocessorDefinitions) - true - true - Itanium - $(OutDir)zlibvc.tlb - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibvc.pch - All - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - - - NDEBUG;%(PreprocessorDefinitions) - 0x040c - - - $(OutDir)zlibwapi.dll - true - false - .\zlibvc.def - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - $(OutDir)zlibwapi.lib - MachineIA64 - - - - - - - - - - - - - - true - true - true - true - true - true - - - - - - - - - - %(AdditionalIncludeDirectories) - ZLIB_INTERNAL;%(PreprocessorDefinitions) - %(AdditionalIncludeDirectories) - ZLIB_INTERNAL;%(PreprocessorDefinitions) - %(AdditionalIncludeDirectories) - ZLIB_INTERNAL;%(PreprocessorDefinitions) - - - %(AdditionalIncludeDirectories) - ZLIB_INTERNAL;%(PreprocessorDefinitions) - %(AdditionalIncludeDirectories) - ZLIB_INTERNAL;%(PreprocessorDefinitions) - %(AdditionalIncludeDirectories) - ZLIB_INTERNAL;%(PreprocessorDefinitions) - - - - - - - - - - - - - - - - - - - - - - - - DELETED compat/zlib/contrib/vstudio/vc14/miniunz.vcxproj Index: compat/zlib/contrib/vstudio/vc14/miniunz.vcxproj ================================================================== --- compat/zlib/contrib/vstudio/vc14/miniunz.vcxproj +++ /dev/null @@ -1,316 +0,0 @@ - - - - - Debug - Itanium - - - Debug - Win32 - - - Debug - x64 - - - Release - Itanium - - - Release - Win32 - - - Release - x64 - - - - {C52F9E7B-498A-42BE-8DB4-85A15694382A} - Win32Proj - - - - Application - MultiByte - v140 - - - Application - Unicode - v140 - - - Application - MultiByte - v140 - - - Application - MultiByte - v140 - - - Application - MultiByte - v140 - - - Application - MultiByte - v140 - - - - - - - - - - - - - - - - - - - - - - - - - <_ProjectFileVersion>10.0.30128.1 - x86\MiniUnzip$(Configuration)\ - x86\MiniUnzip$(Configuration)\Tmp\ - true - false - x86\MiniUnzip$(Configuration)\ - x86\MiniUnzip$(Configuration)\Tmp\ - false - false - x64\MiniUnzip$(Configuration)\ - x64\MiniUnzip$(Configuration)\Tmp\ - true - false - ia64\MiniUnzip$(Configuration)\ - ia64\MiniUnzip$(Configuration)\Tmp\ - true - false - x64\MiniUnzip$(Configuration)\ - x64\MiniUnzip$(Configuration)\Tmp\ - false - false - ia64\MiniUnzip$(Configuration)\ - ia64\MiniUnzip$(Configuration)\Tmp\ - false - false - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - x86\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)miniunz.exe - true - $(OutDir)miniunz.pdb - Console - false - - - MachineX86 - - - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) - true - Default - MultiThreaded - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - x86\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)miniunz.exe - true - Console - true - true - false - - - MachineX86 - - - - - X64 - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - x64\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)miniunz.exe - true - $(OutDir)miniunz.pdb - Console - MachineX64 - - - - - Itanium - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - ia64\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)miniunz.exe - true - $(OutDir)miniunz.pdb - Console - MachineIA64 - - - - - X64 - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - x64\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)miniunz.exe - true - Console - true - true - MachineX64 - - - - - Itanium - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - ia64\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)miniunz.exe - true - Console - true - true - MachineIA64 - - - - - - - - {8fd826f8-3739-44e6-8cc8-997122e53b8d} - - - - - - DELETED compat/zlib/contrib/vstudio/vc14/minizip.vcxproj Index: compat/zlib/contrib/vstudio/vc14/minizip.vcxproj ================================================================== --- compat/zlib/contrib/vstudio/vc14/minizip.vcxproj +++ /dev/null @@ -1,313 +0,0 @@ - - - - - Debug - Itanium - - - Debug - Win32 - - - Debug - x64 - - - Release - Itanium - - - Release - Win32 - - - Release - x64 - - - - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B} - Win32Proj - - - - Application - MultiByte - v140 - - - Application - Unicode - v140 - - - Application - MultiByte - v140 - - - Application - MultiByte - v140 - - - Application - MultiByte - v140 - - - Application - MultiByte - v140 - - - - - - - - - - - - - - - - - - - - - - - - - <_ProjectFileVersion>10.0.30128.1 - x86\MiniZip$(Configuration)\ - x86\MiniZip$(Configuration)\Tmp\ - true - false - x86\MiniZip$(Configuration)\ - x86\MiniZip$(Configuration)\Tmp\ - false - x64\$(Configuration)\ - x64\$(Configuration)\ - true - false - ia64\$(Configuration)\ - ia64\$(Configuration)\ - true - false - x64\$(Configuration)\ - x64\$(Configuration)\ - false - ia64\$(Configuration)\ - ia64\$(Configuration)\ - false - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - x86\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)minizip.exe - true - $(OutDir)minizip.pdb - Console - false - - - MachineX86 - - - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) - true - Default - MultiThreaded - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - x86\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)minizip.exe - true - Console - true - true - false - - - MachineX86 - - - - - X64 - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - x64\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)minizip.exe - true - $(OutDir)minizip.pdb - Console - MachineX64 - - - - - Itanium - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - ia64\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)minizip.exe - true - $(OutDir)minizip.pdb - Console - MachineIA64 - - - - - X64 - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - x64\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)minizip.exe - true - Console - true - true - MachineX64 - - - - - Itanium - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - ia64\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)minizip.exe - true - Console - true - true - MachineIA64 - - - - - - - - {8fd826f8-3739-44e6-8cc8-997122e53b8d} - - - - - - DELETED compat/zlib/contrib/vstudio/vc14/testzlib.vcxproj Index: compat/zlib/contrib/vstudio/vc14/testzlib.vcxproj ================================================================== --- compat/zlib/contrib/vstudio/vc14/testzlib.vcxproj +++ /dev/null @@ -1,430 +0,0 @@ - - - - - Debug - Itanium - - - Debug - Win32 - - - Debug - x64 - - - ReleaseWithoutAsm - Itanium - - - ReleaseWithoutAsm - Win32 - - - ReleaseWithoutAsm - x64 - - - Release - Itanium - - - Release - Win32 - - - Release - x64 - - - - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B} - testzlib - Win32Proj - - - - Application - MultiByte - true - v140 - - - Application - MultiByte - true - v140 - - - Application - Unicode - v140 - - - Application - MultiByte - true - v140 - - - Application - MultiByte - true - v140 - - - Application - MultiByte - v140 - - - Application - true - v140 - - - Application - true - v140 - - - Application - v140 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <_ProjectFileVersion>10.0.30128.1 - x86\TestZlib$(Configuration)\ - x86\TestZlib$(Configuration)\Tmp\ - true - false - x86\TestZlib$(Configuration)\ - x86\TestZlib$(Configuration)\Tmp\ - false - false - x86\TestZlib$(Configuration)\ - x86\TestZlib$(Configuration)\Tmp\ - false - false - x64\TestZlib$(Configuration)\ - x64\TestZlib$(Configuration)\Tmp\ - false - ia64\TestZlib$(Configuration)\ - ia64\TestZlib$(Configuration)\Tmp\ - true - false - x64\TestZlib$(Configuration)\ - x64\TestZlib$(Configuration)\Tmp\ - false - ia64\TestZlib$(Configuration)\ - ia64\TestZlib$(Configuration)\Tmp\ - false - false - x64\TestZlib$(Configuration)\ - x64\TestZlib$(Configuration)\Tmp\ - false - ia64\TestZlib$(Configuration)\ - ia64\TestZlib$(Configuration)\Tmp\ - false - false - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - - - - Disabled - ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;_DEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - AssemblyAndSourceCode - $(IntDir) - Level3 - ProgramDatabase - - - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) - $(OutDir)testzlib.exe - true - $(OutDir)testzlib.pdb - Console - false - - - MachineX86 - - - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;%(AdditionalIncludeDirectories) - WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - true - Default - MultiThreaded - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - $(OutDir)testzlib.exe - true - Console - true - true - false - - - MachineX86 - - - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - true - Default - MultiThreaded - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) - $(OutDir)testzlib.exe - true - Console - true - true - false - - - MachineX86 - false - - - - - ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;_DEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - Default - MultiThreadedDebugDLL - false - $(IntDir) - - - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) - - - - - Itanium - - - Disabled - ..\..\..;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_DEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - AssemblyAndSourceCode - $(IntDir) - Level3 - ProgramDatabase - - - $(OutDir)testzlib.exe - true - $(OutDir)testzlib.pdb - Console - MachineIA64 - - - - - ..\..\..;%(AdditionalIncludeDirectories) - WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - Default - MultiThreadedDLL - false - $(IntDir) - - - %(AdditionalDependencies) - - - - - Itanium - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - $(OutDir)testzlib.exe - true - Console - true - true - MachineIA64 - - - - - ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - Default - MultiThreadedDLL - false - $(IntDir) - - - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) - - - - - Itanium - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - $(OutDir)testzlib.exe - true - Console - true - true - MachineIA64 - - - - - - - - - - true - true - true - true - true - true - - - - - - - - - - - - - DELETED compat/zlib/contrib/vstudio/vc14/testzlibdll.vcxproj Index: compat/zlib/contrib/vstudio/vc14/testzlibdll.vcxproj ================================================================== --- compat/zlib/contrib/vstudio/vc14/testzlibdll.vcxproj +++ /dev/null @@ -1,316 +0,0 @@ - - - - - Debug - Itanium - - - Debug - Win32 - - - Debug - x64 - - - Release - Itanium - - - Release - Win32 - - - Release - x64 - - - - {C52F9E7B-498A-42BE-8DB4-85A15694366A} - Win32Proj - - - - Application - MultiByte - v140 - - - Application - Unicode - v140 - - - Application - MultiByte - v140 - - - Application - MultiByte - v140 - - - Application - MultiByte - v140 - - - Application - MultiByte - v140 - - - - - - - - - - - - - - - - - - - - - - - - - <_ProjectFileVersion>10.0.30128.1 - x86\TestZlibDll$(Configuration)\ - x86\TestZlibDll$(Configuration)\Tmp\ - true - false - x86\TestZlibDll$(Configuration)\ - x86\TestZlibDll$(Configuration)\Tmp\ - false - false - x64\TestZlibDll$(Configuration)\ - x64\TestZlibDll$(Configuration)\Tmp\ - true - false - ia64\TestZlibDll$(Configuration)\ - ia64\TestZlibDll$(Configuration)\Tmp\ - true - false - x64\TestZlibDll$(Configuration)\ - x64\TestZlibDll$(Configuration)\Tmp\ - false - false - ia64\TestZlibDll$(Configuration)\ - ia64\TestZlibDll$(Configuration)\Tmp\ - false - false - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - x86\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)testzlibdll.exe - true - $(OutDir)testzlib.pdb - Console - false - - - MachineX86 - - - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;%(PreprocessorDefinitions) - true - Default - MultiThreaded - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - x86\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)testzlibdll.exe - true - Console - true - true - false - - - MachineX86 - - - - - X64 - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - x64\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)testzlibdll.exe - true - $(OutDir)testzlib.pdb - Console - MachineX64 - - - - - Itanium - - - Disabled - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;_DEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDebugDLL - false - - - $(IntDir) - Level3 - ProgramDatabase - - - ia64\ZlibDllDebug\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)testzlibdll.exe - true - $(OutDir)testzlib.pdb - Console - MachineIA64 - - - - - X64 - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - x64\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)testzlibdll.exe - true - Console - true - true - MachineX64 - - - - - Itanium - - - MaxSpeed - OnlyExplicitInline - true - ..\..\..;..\..\minizip;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;ZLIB_WINAPI;NDEBUG;_CONSOLE;WIN64;%(PreprocessorDefinitions) - true - Default - MultiThreadedDLL - false - true - - - $(IntDir) - Level3 - ProgramDatabase - - - ia64\ZlibDllRelease\zlibwapi.lib;%(AdditionalDependencies) - $(OutDir)testzlibdll.exe - true - Console - true - true - MachineIA64 - - - - - - - - {8fd826f8-3739-44e6-8cc8-997122e53b8d} - - - - - - DELETED compat/zlib/contrib/vstudio/vc14/zlib.rc Index: compat/zlib/contrib/vstudio/vc14/zlib.rc ================================================================== --- compat/zlib/contrib/vstudio/vc14/zlib.rc +++ /dev/null @@ -1,32 +0,0 @@ -#include - -#define IDR_VERSION1 1 -IDR_VERSION1 VERSIONINFO MOVEABLE IMPURE LOADONCALL DISCARDABLE - FILEVERSION 1, 2, 11, 0 - PRODUCTVERSION 1, 2, 11, 0 - FILEFLAGSMASK VS_FFI_FILEFLAGSMASK - FILEFLAGS 0 - FILEOS VOS_DOS_WINDOWS32 - FILETYPE VFT_DLL - FILESUBTYPE 0 // not used -BEGIN - BLOCK "StringFileInfo" - BEGIN - BLOCK "040904E4" - //language ID = U.S. English, char set = Windows, Multilingual - - BEGIN - VALUE "FileDescription", "zlib data compression and ZIP file I/O library\0" - VALUE "FileVersion", "1.2.11\0" - VALUE "InternalName", "zlib\0" - VALUE "OriginalFilename", "zlibwapi.dll\0" - VALUE "ProductName", "ZLib.DLL\0" - VALUE "Comments","DLL support by Alessandro Iacopetti & Gilles Vollant\0" - VALUE "LegalCopyright", "(C) 1995-2017 Jean-loup Gailly & Mark Adler\0" - END - END - BLOCK "VarFileInfo" - BEGIN - VALUE "Translation", 0x0409, 1252 - END -END DELETED compat/zlib/contrib/vstudio/vc14/zlibstat.vcxproj Index: compat/zlib/contrib/vstudio/vc14/zlibstat.vcxproj ================================================================== --- compat/zlib/contrib/vstudio/vc14/zlibstat.vcxproj +++ /dev/null @@ -1,467 +0,0 @@ - - - - - Debug - Itanium - - - Debug - Win32 - - - Debug - x64 - - - ReleaseWithoutAsm - Itanium - - - ReleaseWithoutAsm - Win32 - - - ReleaseWithoutAsm - x64 - - - Release - Itanium - - - Release - Win32 - - - Release - x64 - - - - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8} - - - - StaticLibrary - false - v140 - - - StaticLibrary - false - v140 - - - StaticLibrary - false - v140 - Unicode - - - StaticLibrary - false - v140 - - - StaticLibrary - false - v140 - - - StaticLibrary - false - v140 - - - StaticLibrary - false - v140 - - - StaticLibrary - false - v140 - - - StaticLibrary - false - v140 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <_ProjectFileVersion>10.0.30128.1 - x86\ZlibStat$(Configuration)\ - x86\ZlibStat$(Configuration)\Tmp\ - x86\ZlibStat$(Configuration)\ - x86\ZlibStat$(Configuration)\Tmp\ - x86\ZlibStat$(Configuration)\ - x86\ZlibStat$(Configuration)\Tmp\ - x64\ZlibStat$(Configuration)\ - x64\ZlibStat$(Configuration)\Tmp\ - ia64\ZlibStat$(Configuration)\ - ia64\ZlibStat$(Configuration)\Tmp\ - x64\ZlibStat$(Configuration)\ - x64\ZlibStat$(Configuration)\Tmp\ - ia64\ZlibStat$(Configuration)\ - ia64\ZlibStat$(Configuration)\Tmp\ - x64\ZlibStat$(Configuration)\ - x64\ZlibStat$(Configuration)\Tmp\ - ia64\ZlibStat$(Configuration)\ - ia64\ZlibStat$(Configuration)\Tmp\ - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - - - - Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - - - MultiThreadedDebugDLL - false - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - OldStyle - - - 0x040c - - - /MACHINE:X86 /NODEFAULTLIB %(AdditionalOptions) - $(OutDir)zlibstat.lib - true - - - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ASMV;ASMINF;%(PreprocessorDefinitions) - true - - - MultiThreaded - false - true - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - - - 0x040c - - - /MACHINE:X86 /NODEFAULTLIB %(AdditionalOptions) - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) - $(OutDir)zlibstat.lib - true - - - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) - true - - - MultiThreaded - false - true - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - - - 0x040c - - - /MACHINE:X86 /NODEFAULTLIB %(AdditionalOptions) - $(OutDir)zlibstat.lib - true - - - - - X64 - - - Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - - - MultiThreadedDebugDLL - false - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - OldStyle - - - 0x040c - - - /MACHINE:AMD64 /NODEFAULTLIB %(AdditionalOptions) - $(OutDir)zlibstat.lib - true - - - - - Itanium - - - Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - - - MultiThreadedDebugDLL - false - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - OldStyle - - - 0x040c - - - /MACHINE:IA64 /NODEFAULTLIB %(AdditionalOptions) - $(OutDir)zlibstat.lib - true - - - - - X64 - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ASMV;ASMINF;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - - - 0x040c - - - /MACHINE:AMD64 /NODEFAULTLIB %(AdditionalOptions) - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) - $(OutDir)zlibstat.lib - true - - - - - Itanium - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - - - 0x040c - - - /MACHINE:IA64 /NODEFAULTLIB %(AdditionalOptions) - $(OutDir)zlibstat.lib - true - - - - - X64 - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - - - 0x040c - - - /MACHINE:AMD64 /NODEFAULTLIB %(AdditionalOptions) - $(OutDir)zlibstat.lib - true - - - - - Itanium - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibstat.pch - $(IntDir) - $(IntDir) - $(OutDir) - Level3 - true - - - 0x040c - - - /MACHINE:IA64 /NODEFAULTLIB %(AdditionalOptions) - $(OutDir)zlibstat.lib - true - - - - - - - - - - - - - - true - true - true - true - true - true - - - - - - - - - - - - - - - - - - - - - DELETED compat/zlib/contrib/vstudio/vc14/zlibvc.def Index: compat/zlib/contrib/vstudio/vc14/zlibvc.def ================================================================== --- compat/zlib/contrib/vstudio/vc14/zlibvc.def +++ /dev/null @@ -1,153 +0,0 @@ -LIBRARY -; zlib data compression and ZIP file I/O library - -VERSION 1.2 - -EXPORTS - adler32 @1 - compress @2 - crc32 @3 - deflate @4 - deflateCopy @5 - deflateEnd @6 - deflateInit2_ @7 - deflateInit_ @8 - deflateParams @9 - deflateReset @10 - deflateSetDictionary @11 - gzclose @12 - gzdopen @13 - gzerror @14 - gzflush @15 - gzopen @16 - gzread @17 - gzwrite @18 - inflate @19 - inflateEnd @20 - inflateInit2_ @21 - inflateInit_ @22 - inflateReset @23 - inflateSetDictionary @24 - inflateSync @25 - uncompress @26 - zlibVersion @27 - gzprintf @28 - gzputc @29 - gzgetc @30 - gzseek @31 - gzrewind @32 - gztell @33 - gzeof @34 - gzsetparams @35 - zError @36 - inflateSyncPoint @37 - get_crc_table @38 - compress2 @39 - gzputs @40 - gzgets @41 - inflateCopy @42 - inflateBackInit_ @43 - inflateBack @44 - inflateBackEnd @45 - compressBound @46 - deflateBound @47 - gzclearerr @48 - gzungetc @49 - zlibCompileFlags @50 - deflatePrime @51 - deflatePending @52 - - unzOpen @61 - unzClose @62 - unzGetGlobalInfo @63 - unzGetCurrentFileInfo @64 - unzGoToFirstFile @65 - unzGoToNextFile @66 - unzOpenCurrentFile @67 - unzReadCurrentFile @68 - unzOpenCurrentFile3 @69 - unztell @70 - unzeof @71 - unzCloseCurrentFile @72 - unzGetGlobalComment @73 - unzStringFileNameCompare @74 - unzLocateFile @75 - unzGetLocalExtrafield @76 - unzOpen2 @77 - unzOpenCurrentFile2 @78 - unzOpenCurrentFilePassword @79 - - zipOpen @80 - zipOpenNewFileInZip @81 - zipWriteInFileInZip @82 - zipCloseFileInZip @83 - zipClose @84 - zipOpenNewFileInZip2 @86 - zipCloseFileInZipRaw @87 - zipOpen2 @88 - zipOpenNewFileInZip3 @89 - - unzGetFilePos @100 - unzGoToFilePos @101 - - fill_win32_filefunc @110 - -; zlibwapi v1.2.4 added: - fill_win32_filefunc64 @111 - fill_win32_filefunc64A @112 - fill_win32_filefunc64W @113 - - unzOpen64 @120 - unzOpen2_64 @121 - unzGetGlobalInfo64 @122 - unzGetCurrentFileInfo64 @124 - unzGetCurrentFileZStreamPos64 @125 - unztell64 @126 - unzGetFilePos64 @127 - unzGoToFilePos64 @128 - - zipOpen64 @130 - zipOpen2_64 @131 - zipOpenNewFileInZip64 @132 - zipOpenNewFileInZip2_64 @133 - zipOpenNewFileInZip3_64 @134 - zipOpenNewFileInZip4_64 @135 - zipCloseFileInZipRaw64 @136 - -; zlib1 v1.2.4 added: - adler32_combine @140 - crc32_combine @142 - deflateSetHeader @144 - deflateTune @145 - gzbuffer @146 - gzclose_r @147 - gzclose_w @148 - gzdirect @149 - gzoffset @150 - inflateGetHeader @156 - inflateMark @157 - inflatePrime @158 - inflateReset2 @159 - inflateUndermine @160 - -; zlib1 v1.2.6 added: - gzgetc_ @161 - inflateResetKeep @163 - deflateResetKeep @164 - -; zlib1 v1.2.7 added: - gzopen_w @165 - -; zlib1 v1.2.8 added: - inflateGetDictionary @166 - gzvprintf @167 - -; zlib1 v1.2.9 added: - inflateCodesUsed @168 - inflateValidate @169 - uncompress2 @170 - gzfread @171 - gzfwrite @172 - deflateGetDictionary @173 - adler32_z @174 - crc32_z @175 DELETED compat/zlib/contrib/vstudio/vc14/zlibvc.sln Index: compat/zlib/contrib/vstudio/vc14/zlibvc.sln ================================================================== --- compat/zlib/contrib/vstudio/vc14/zlibvc.sln +++ /dev/null @@ -1,119 +0,0 @@ - -Microsoft Visual Studio Solution File, Format Version 12.00 -# Visual Studio 14 -VisualStudioVersion = 14.0.25420.1 -MinimumVisualStudioVersion = 10.0.40219.1 -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "zlibvc", "zlibvc.vcxproj", "{8FD826F8-3739-44E6-8CC8-997122E53B8D}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "zlibstat", "zlibstat.vcxproj", "{745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "testzlib", "testzlib.vcxproj", "{AA6666AA-E09F-4135-9C0C-4FE50C3C654B}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "testzlibdll", "testzlibdll.vcxproj", "{C52F9E7B-498A-42BE-8DB4-85A15694366A}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "minizip", "minizip.vcxproj", "{48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "miniunz", "miniunz.vcxproj", "{C52F9E7B-498A-42BE-8DB4-85A15694382A}" -EndProject -Global - GlobalSection(SolutionConfigurationPlatforms) = preSolution - Debug|Itanium = Debug|Itanium - Debug|Win32 = Debug|Win32 - Debug|x64 = Debug|x64 - Release|Itanium = Release|Itanium - Release|Win32 = Release|Win32 - Release|x64 = Release|x64 - ReleaseWithoutAsm|Itanium = ReleaseWithoutAsm|Itanium - ReleaseWithoutAsm|Win32 = ReleaseWithoutAsm|Win32 - ReleaseWithoutAsm|x64 = ReleaseWithoutAsm|x64 - EndGlobalSection - GlobalSection(ProjectConfigurationPlatforms) = postSolution - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Itanium.ActiveCfg = Debug|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Win32.ActiveCfg = Debug|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Win32.Build.0 = Debug|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|x64.ActiveCfg = Debug|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|x64.Build.0 = Debug|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Itanium.ActiveCfg = Release|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Win32.ActiveCfg = Release|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Win32.Build.0 = Release|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|x64.ActiveCfg = Release|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|x64.Build.0 = Release|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Itanium.ActiveCfg = Debug|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Win32.ActiveCfg = Debug|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Win32.Build.0 = Debug|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|x64.ActiveCfg = Debug|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|x64.Build.0 = Debug|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Itanium.ActiveCfg = Release|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Win32.ActiveCfg = Release|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Win32.Build.0 = Release|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|x64.ActiveCfg = Release|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|x64.Build.0 = Release|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.ActiveCfg = Debug|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.ActiveCfg = Debug|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.Build.0 = Debug|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.ActiveCfg = Debug|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.Build.0 = Debug|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.ActiveCfg = Release|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.ActiveCfg = Release|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.Build.0 = Release|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.ActiveCfg = Release|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.Build.0 = Release|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Itanium.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Win32.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Win32.Build.0 = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|x64.ActiveCfg = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|x64.Build.0 = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Itanium.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Win32.Build.0 = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|x64.ActiveCfg = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|x64.Build.0 = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.ActiveCfg = Debug|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.ActiveCfg = Debug|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.Build.0 = Debug|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.ActiveCfg = Debug|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.Build.0 = Debug|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.Build.0 = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.ActiveCfg = Release|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.Build.0 = Release|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Itanium.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Win32.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Win32.Build.0 = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|x64.ActiveCfg = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|x64.Build.0 = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Itanium.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Win32.Build.0 = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|x64.ActiveCfg = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|x64.Build.0 = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 - EndGlobalSection - GlobalSection(SolutionProperties) = preSolution - HideSolutionNode = FALSE - EndGlobalSection -EndGlobal DELETED compat/zlib/contrib/vstudio/vc14/zlibvc.vcxproj Index: compat/zlib/contrib/vstudio/vc14/zlibvc.vcxproj ================================================================== --- compat/zlib/contrib/vstudio/vc14/zlibvc.vcxproj +++ /dev/null @@ -1,692 +0,0 @@ - - - - - Debug - Itanium - - - Debug - Win32 - - - Debug - x64 - - - ReleaseWithoutAsm - Itanium - - - ReleaseWithoutAsm - Win32 - - - ReleaseWithoutAsm - x64 - - - Release - Itanium - - - Release - Win32 - - - Release - x64 - - - - {8FD826F8-3739-44E6-8CC8-997122E53B8D} - - - - DynamicLibrary - false - true - v140 - - - DynamicLibrary - false - true - v140 - - - DynamicLibrary - false - v140 - Unicode - - - DynamicLibrary - false - true - v140 - - - DynamicLibrary - false - true - v140 - - - DynamicLibrary - false - v140 - - - DynamicLibrary - false - true - v140 - - - DynamicLibrary - false - true - v140 - - - DynamicLibrary - false - v140 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - <_ProjectFileVersion>10.0.30128.1 - x86\ZlibDll$(Configuration)\ - x86\ZlibDll$(Configuration)\Tmp\ - true - false - x86\ZlibDll$(Configuration)\ - x86\ZlibDll$(Configuration)\Tmp\ - false - false - x86\ZlibDll$(Configuration)\ - x86\ZlibDll$(Configuration)\Tmp\ - false - false - x64\ZlibDll$(Configuration)\ - x64\ZlibDll$(Configuration)\Tmp\ - true - false - ia64\ZlibDll$(Configuration)\ - ia64\ZlibDll$(Configuration)\Tmp\ - true - false - x64\ZlibDll$(Configuration)\ - x64\ZlibDll$(Configuration)\Tmp\ - false - false - ia64\ZlibDll$(Configuration)\ - ia64\ZlibDll$(Configuration)\Tmp\ - false - false - x64\ZlibDll$(Configuration)\ - x64\ZlibDll$(Configuration)\Tmp\ - false - false - ia64\ZlibDll$(Configuration)\ - ia64\ZlibDll$(Configuration)\Tmp\ - false - false - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - AllRules.ruleset - - - zlibwapi - zlibwapi - zlibwapi - zlibwapi - zlibwapi - zlibwapi - - - - _DEBUG;%(PreprocessorDefinitions) - true - true - Win32 - $(OutDir)zlibvc.tlb - - - Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;%(PreprocessorDefinitions) - - - MultiThreadedDebugDLL - false - $(IntDir)zlibvc.pch - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - ProgramDatabase - - - _DEBUG;%(PreprocessorDefinitions) - 0x040c - - - /MACHINE:I386 %(AdditionalOptions) - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) - $(OutDir)zlibwapi.dll - true - .\zlibvc.def - true - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - false - - - $(OutDir)zlibwapi.lib - - - cd ..\..\masmx86 -bld_ml32.bat - - - - - NDEBUG;%(PreprocessorDefinitions) - true - true - Win32 - $(OutDir)zlibvc.tlb - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibvc.pch - All - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - - - NDEBUG;%(PreprocessorDefinitions) - 0x040c - - - /MACHINE:I386 %(AdditionalOptions) - $(OutDir)zlibwapi.dll - true - false - .\zlibvc.def - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - false - - - $(OutDir)zlibwapi.lib - - - - - NDEBUG;%(PreprocessorDefinitions) - true - true - Win32 - $(OutDir)zlibvc.tlb - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;%(PreprocessorDefinitions) - true - - - MultiThreaded - false - true - $(IntDir)zlibvc.pch - All - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - - - NDEBUG;%(PreprocessorDefinitions) - 0x040c - - - /MACHINE:I386 %(AdditionalOptions) - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) - $(OutDir)zlibwapi.dll - true - false - .\zlibvc.def - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - false - - - $(OutDir)zlibwapi.lib - false - - - cd ..\..\masmx86 -bld_ml32.bat - - - - - _DEBUG;%(PreprocessorDefinitions) - true - true - X64 - $(OutDir)zlibvc.tlb - - - Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;WIN64;%(PreprocessorDefinitions) - - - MultiThreadedDebugDLL - false - $(IntDir)zlibvc.pch - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - ProgramDatabase - - - _DEBUG;%(PreprocessorDefinitions) - 0x040c - - - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) - $(OutDir)zlibwapi.dll - true - .\zlibvc.def - true - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - $(OutDir)zlibwapi.lib - MachineX64 - - - cd ..\..\contrib\masmx64 -bld_ml64.bat - - - - - _DEBUG;%(PreprocessorDefinitions) - true - true - Itanium - $(OutDir)zlibvc.tlb - - - Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) - - - MultiThreadedDebugDLL - false - $(IntDir)zlibvc.pch - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - ProgramDatabase - - - _DEBUG;%(PreprocessorDefinitions) - 0x040c - - - $(OutDir)zlibwapi.dll - true - .\zlibvc.def - true - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - $(OutDir)zlibwapi.lib - MachineIA64 - - - - - NDEBUG;%(PreprocessorDefinitions) - true - true - X64 - $(OutDir)zlibvc.tlb - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibvc.pch - All - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - - - NDEBUG;%(PreprocessorDefinitions) - 0x040c - - - $(OutDir)zlibwapi.dll - true - false - .\zlibvc.def - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - $(OutDir)zlibwapi.lib - MachineX64 - - - - - NDEBUG;%(PreprocessorDefinitions) - true - true - Itanium - $(OutDir)zlibvc.tlb - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibvc.pch - All - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - - - NDEBUG;%(PreprocessorDefinitions) - 0x040c - - - $(OutDir)zlibwapi.dll - true - false - .\zlibvc.def - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - $(OutDir)zlibwapi.lib - MachineIA64 - - - - - NDEBUG;%(PreprocessorDefinitions) - true - true - X64 - $(OutDir)zlibvc.tlb - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibvc.pch - All - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - - - NDEBUG;%(PreprocessorDefinitions) - 0x040c - - - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) - $(OutDir)zlibwapi.dll - true - false - .\zlibvc.def - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - $(OutDir)zlibwapi.lib - MachineX64 - - - cd ..\..\masmx64 -bld_ml64.bat - - - - - NDEBUG;%(PreprocessorDefinitions) - true - true - Itanium - $(OutDir)zlibvc.tlb - - - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) - true - - - MultiThreadedDLL - false - true - $(IntDir)zlibvc.pch - All - $(IntDir) - $(IntDir) - $(OutDir) - - - Level3 - true - - - NDEBUG;%(PreprocessorDefinitions) - 0x040c - - - $(OutDir)zlibwapi.dll - true - false - .\zlibvc.def - $(OutDir)zlibwapi.pdb - true - $(OutDir)zlibwapi.map - Windows - $(OutDir)zlibwapi.lib - MachineIA64 - - - - - - - - - - - - - - true - true - true - true - true - true - - - - - - - - - - %(AdditionalIncludeDirectories) - ZLIB_INTERNAL;%(PreprocessorDefinitions) - %(AdditionalIncludeDirectories) - ZLIB_INTERNAL;%(PreprocessorDefinitions) - %(AdditionalIncludeDirectories) - ZLIB_INTERNAL;%(PreprocessorDefinitions) - - - %(AdditionalIncludeDirectories) - ZLIB_INTERNAL;%(PreprocessorDefinitions) - %(AdditionalIncludeDirectories) - ZLIB_INTERNAL;%(PreprocessorDefinitions) - %(AdditionalIncludeDirectories) - ZLIB_INTERNAL;%(PreprocessorDefinitions) - - - - - - - - - - - - - - - - - - - - - - - - DELETED compat/zlib/contrib/vstudio/vc9/miniunz.vcproj Index: compat/zlib/contrib/vstudio/vc9/miniunz.vcproj ================================================================== --- compat/zlib/contrib/vstudio/vc9/miniunz.vcproj +++ /dev/null @@ -1,565 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DELETED compat/zlib/contrib/vstudio/vc9/minizip.vcproj Index: compat/zlib/contrib/vstudio/vc9/minizip.vcproj ================================================================== --- compat/zlib/contrib/vstudio/vc9/minizip.vcproj +++ /dev/null @@ -1,562 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DELETED compat/zlib/contrib/vstudio/vc9/testzlib.vcproj Index: compat/zlib/contrib/vstudio/vc9/testzlib.vcproj ================================================================== --- compat/zlib/contrib/vstudio/vc9/testzlib.vcproj +++ /dev/null @@ -1,852 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DELETED compat/zlib/contrib/vstudio/vc9/testzlibdll.vcproj Index: compat/zlib/contrib/vstudio/vc9/testzlibdll.vcproj ================================================================== --- compat/zlib/contrib/vstudio/vc9/testzlibdll.vcproj +++ /dev/null @@ -1,565 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DELETED compat/zlib/contrib/vstudio/vc9/zlib.rc Index: compat/zlib/contrib/vstudio/vc9/zlib.rc ================================================================== --- compat/zlib/contrib/vstudio/vc9/zlib.rc +++ /dev/null @@ -1,32 +0,0 @@ -#include - -#define IDR_VERSION1 1 -IDR_VERSION1 VERSIONINFO MOVEABLE IMPURE LOADONCALL DISCARDABLE - FILEVERSION 1, 2, 11, 0 - PRODUCTVERSION 1, 2, 11, 0 - FILEFLAGSMASK VS_FFI_FILEFLAGSMASK - FILEFLAGS 0 - FILEOS VOS_DOS_WINDOWS32 - FILETYPE VFT_DLL - FILESUBTYPE 0 // not used -BEGIN - BLOCK "StringFileInfo" - BEGIN - BLOCK "040904E4" - //language ID = U.S. English, char set = Windows, Multilingual - - BEGIN - VALUE "FileDescription", "zlib data compression and ZIP file I/O library\0" - VALUE "FileVersion", "1.2.11\0" - VALUE "InternalName", "zlib\0" - VALUE "OriginalFilename", "zlibwapi.dll\0" - VALUE "ProductName", "ZLib.DLL\0" - VALUE "Comments","DLL support by Alessandro Iacopetti & Gilles Vollant\0" - VALUE "LegalCopyright", "(C) 1995-2017 Jean-loup Gailly & Mark Adler\0" - END - END - BLOCK "VarFileInfo" - BEGIN - VALUE "Translation", 0x0409, 1252 - END -END DELETED compat/zlib/contrib/vstudio/vc9/zlibstat.vcproj Index: compat/zlib/contrib/vstudio/vc9/zlibstat.vcproj ================================================================== --- compat/zlib/contrib/vstudio/vc9/zlibstat.vcproj +++ /dev/null @@ -1,835 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DELETED compat/zlib/contrib/vstudio/vc9/zlibvc.def Index: compat/zlib/contrib/vstudio/vc9/zlibvc.def ================================================================== --- compat/zlib/contrib/vstudio/vc9/zlibvc.def +++ /dev/null @@ -1,153 +0,0 @@ -LIBRARY -; zlib data compression and ZIP file I/O library - -VERSION 1.2 - -EXPORTS - adler32 @1 - compress @2 - crc32 @3 - deflate @4 - deflateCopy @5 - deflateEnd @6 - deflateInit2_ @7 - deflateInit_ @8 - deflateParams @9 - deflateReset @10 - deflateSetDictionary @11 - gzclose @12 - gzdopen @13 - gzerror @14 - gzflush @15 - gzopen @16 - gzread @17 - gzwrite @18 - inflate @19 - inflateEnd @20 - inflateInit2_ @21 - inflateInit_ @22 - inflateReset @23 - inflateSetDictionary @24 - inflateSync @25 - uncompress @26 - zlibVersion @27 - gzprintf @28 - gzputc @29 - gzgetc @30 - gzseek @31 - gzrewind @32 - gztell @33 - gzeof @34 - gzsetparams @35 - zError @36 - inflateSyncPoint @37 - get_crc_table @38 - compress2 @39 - gzputs @40 - gzgets @41 - inflateCopy @42 - inflateBackInit_ @43 - inflateBack @44 - inflateBackEnd @45 - compressBound @46 - deflateBound @47 - gzclearerr @48 - gzungetc @49 - zlibCompileFlags @50 - deflatePrime @51 - deflatePending @52 - - unzOpen @61 - unzClose @62 - unzGetGlobalInfo @63 - unzGetCurrentFileInfo @64 - unzGoToFirstFile @65 - unzGoToNextFile @66 - unzOpenCurrentFile @67 - unzReadCurrentFile @68 - unzOpenCurrentFile3 @69 - unztell @70 - unzeof @71 - unzCloseCurrentFile @72 - unzGetGlobalComment @73 - unzStringFileNameCompare @74 - unzLocateFile @75 - unzGetLocalExtrafield @76 - unzOpen2 @77 - unzOpenCurrentFile2 @78 - unzOpenCurrentFilePassword @79 - - zipOpen @80 - zipOpenNewFileInZip @81 - zipWriteInFileInZip @82 - zipCloseFileInZip @83 - zipClose @84 - zipOpenNewFileInZip2 @86 - zipCloseFileInZipRaw @87 - zipOpen2 @88 - zipOpenNewFileInZip3 @89 - - unzGetFilePos @100 - unzGoToFilePos @101 - - fill_win32_filefunc @110 - -; zlibwapi v1.2.4 added: - fill_win32_filefunc64 @111 - fill_win32_filefunc64A @112 - fill_win32_filefunc64W @113 - - unzOpen64 @120 - unzOpen2_64 @121 - unzGetGlobalInfo64 @122 - unzGetCurrentFileInfo64 @124 - unzGetCurrentFileZStreamPos64 @125 - unztell64 @126 - unzGetFilePos64 @127 - unzGoToFilePos64 @128 - - zipOpen64 @130 - zipOpen2_64 @131 - zipOpenNewFileInZip64 @132 - zipOpenNewFileInZip2_64 @133 - zipOpenNewFileInZip3_64 @134 - zipOpenNewFileInZip4_64 @135 - zipCloseFileInZipRaw64 @136 - -; zlib1 v1.2.4 added: - adler32_combine @140 - crc32_combine @142 - deflateSetHeader @144 - deflateTune @145 - gzbuffer @146 - gzclose_r @147 - gzclose_w @148 - gzdirect @149 - gzoffset @150 - inflateGetHeader @156 - inflateMark @157 - inflatePrime @158 - inflateReset2 @159 - inflateUndermine @160 - -; zlib1 v1.2.6 added: - gzgetc_ @161 - inflateResetKeep @163 - deflateResetKeep @164 - -; zlib1 v1.2.7 added: - gzopen_w @165 - -; zlib1 v1.2.8 added: - inflateGetDictionary @166 - gzvprintf @167 - -; zlib1 v1.2.9 added: - inflateCodesUsed @168 - inflateValidate @169 - uncompress2 @170 - gzfread @171 - gzfwrite @172 - deflateGetDictionary @173 - adler32_z @174 - crc32_z @175 DELETED compat/zlib/contrib/vstudio/vc9/zlibvc.sln Index: compat/zlib/contrib/vstudio/vc9/zlibvc.sln ================================================================== --- compat/zlib/contrib/vstudio/vc9/zlibvc.sln +++ /dev/null @@ -1,144 +0,0 @@ - -Microsoft Visual Studio Solution File, Format Version 10.00 -# Visual Studio 2008 -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "zlibvc", "zlibvc.vcproj", "{8FD826F8-3739-44E6-8CC8-997122E53B8D}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "zlibstat", "zlibstat.vcproj", "{745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "testzlib", "testzlib.vcproj", "{AA6666AA-E09F-4135-9C0C-4FE50C3C654B}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "TestZlibDll", "testzlibdll.vcproj", "{C52F9E7B-498A-42BE-8DB4-85A15694366A}" - ProjectSection(ProjectDependencies) = postProject - {8FD826F8-3739-44E6-8CC8-997122E53B8D} = {8FD826F8-3739-44E6-8CC8-997122E53B8D} - EndProjectSection -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "minizip", "minizip.vcproj", "{48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}" - ProjectSection(ProjectDependencies) = postProject - {8FD826F8-3739-44E6-8CC8-997122E53B8D} = {8FD826F8-3739-44E6-8CC8-997122E53B8D} - EndProjectSection -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "miniunz", "miniunz.vcproj", "{C52F9E7B-498A-42BE-8DB4-85A15694382A}" - ProjectSection(ProjectDependencies) = postProject - {8FD826F8-3739-44E6-8CC8-997122E53B8D} = {8FD826F8-3739-44E6-8CC8-997122E53B8D} - EndProjectSection -EndProject -Global - GlobalSection(SolutionConfigurationPlatforms) = preSolution - Debug|Itanium = Debug|Itanium - Debug|Win32 = Debug|Win32 - Debug|x64 = Debug|x64 - Release|Itanium = Release|Itanium - Release|Win32 = Release|Win32 - Release|x64 = Release|x64 - ReleaseWithoutAsm|Itanium = ReleaseWithoutAsm|Itanium - ReleaseWithoutAsm|Win32 = ReleaseWithoutAsm|Win32 - ReleaseWithoutAsm|x64 = ReleaseWithoutAsm|x64 - EndGlobalSection - GlobalSection(ProjectConfigurationPlatforms) = postSolution - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Itanium.ActiveCfg = Debug|Itanium - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Itanium.Build.0 = Debug|Itanium - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Win32.ActiveCfg = Debug|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Win32.Build.0 = Debug|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|x64.ActiveCfg = Debug|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|x64.Build.0 = Debug|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Itanium.ActiveCfg = Release|Itanium - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Itanium.Build.0 = Release|Itanium - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Win32.ActiveCfg = Release|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Win32.Build.0 = Release|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|x64.ActiveCfg = Release|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|x64.Build.0 = Release|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Itanium - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Itanium.Build.0 = ReleaseWithoutAsm|Itanium - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Itanium.ActiveCfg = Debug|Itanium - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Itanium.Build.0 = Debug|Itanium - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Win32.ActiveCfg = Debug|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Win32.Build.0 = Debug|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|x64.ActiveCfg = Debug|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|x64.Build.0 = Debug|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Itanium.ActiveCfg = Release|Itanium - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Itanium.Build.0 = Release|Itanium - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Win32.ActiveCfg = Release|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Win32.Build.0 = Release|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|x64.ActiveCfg = Release|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|x64.Build.0 = Release|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Itanium - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Itanium.Build.0 = ReleaseWithoutAsm|Itanium - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.ActiveCfg = Debug|Itanium - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.Build.0 = Debug|Itanium - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.ActiveCfg = Debug|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.Build.0 = Debug|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.ActiveCfg = Debug|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.Build.0 = Debug|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.ActiveCfg = Release|Itanium - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.Build.0 = Release|Itanium - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.ActiveCfg = Release|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.Build.0 = Release|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.ActiveCfg = Release|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.Build.0 = Release|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Itanium - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.Build.0 = ReleaseWithoutAsm|Itanium - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Itanium.ActiveCfg = Debug|Itanium - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Itanium.Build.0 = Debug|Itanium - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Win32.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Win32.Build.0 = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|x64.ActiveCfg = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|x64.Build.0 = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Itanium.ActiveCfg = Release|Itanium - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Itanium.Build.0 = Release|Itanium - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Win32.Build.0 = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|x64.ActiveCfg = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|x64.Build.0 = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Itanium - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|Itanium.Build.0 = Release|Itanium - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.ActiveCfg = Debug|Itanium - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.Build.0 = Debug|Itanium - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.ActiveCfg = Debug|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.Build.0 = Debug|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.ActiveCfg = Debug|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.Build.0 = Debug|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.ActiveCfg = Release|Itanium - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.Build.0 = Release|Itanium - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.Build.0 = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.ActiveCfg = Release|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.Build.0 = Release|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Itanium - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.Build.0 = Release|Itanium - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Itanium.ActiveCfg = Debug|Itanium - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Itanium.Build.0 = Debug|Itanium - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Win32.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Win32.Build.0 = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|x64.ActiveCfg = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|x64.Build.0 = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Itanium.ActiveCfg = Release|Itanium - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Itanium.Build.0 = Release|Itanium - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Win32.Build.0 = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|x64.ActiveCfg = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|x64.Build.0 = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Itanium - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|Itanium.Build.0 = Release|Itanium - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 - EndGlobalSection - GlobalSection(SolutionProperties) = preSolution - HideSolutionNode = FALSE - EndGlobalSection -EndGlobal DELETED compat/zlib/contrib/vstudio/vc9/zlibvc.vcproj Index: compat/zlib/contrib/vstudio/vc9/zlibvc.vcproj ================================================================== --- compat/zlib/contrib/vstudio/vc9/zlibvc.vcproj +++ /dev/null @@ -1,1156 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DELETED compat/zlib/crc32.c Index: compat/zlib/crc32.c ================================================================== --- compat/zlib/crc32.c +++ /dev/null @@ -1,442 +0,0 @@ -/* crc32.c -- compute the CRC-32 of a data stream - * Copyright (C) 1995-2006, 2010, 2011, 2012, 2016 Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - * - * Thanks to Rodney Brown for his contribution of faster - * CRC methods: exclusive-oring 32 bits of data at a time, and pre-computing - * tables for updating the shift register in one step with three exclusive-ors - * instead of four steps with four exclusive-ors. This results in about a - * factor of two increase in speed on a Power PC G4 (PPC7455) using gcc -O3. - */ - -/* @(#) $Id$ */ - -/* - Note on the use of DYNAMIC_CRC_TABLE: there is no mutex or semaphore - protection on the static variables used to control the first-use generation - of the crc tables. Therefore, if you #define DYNAMIC_CRC_TABLE, you should - first call get_crc_table() to initialize the tables before allowing more than - one thread to use crc32(). - - DYNAMIC_CRC_TABLE and MAKECRCH can be #defined to write out crc32.h. - */ - -#ifdef MAKECRCH -# include -# ifndef DYNAMIC_CRC_TABLE -# define DYNAMIC_CRC_TABLE -# endif /* !DYNAMIC_CRC_TABLE */ -#endif /* MAKECRCH */ - -#include "zutil.h" /* for STDC and FAR definitions */ - -/* Definitions for doing the crc four data bytes at a time. */ -#if !defined(NOBYFOUR) && defined(Z_U4) -# define BYFOUR -#endif -#ifdef BYFOUR - local unsigned long crc32_little OF((unsigned long, - const unsigned char FAR *, z_size_t)); - local unsigned long crc32_big OF((unsigned long, - const unsigned char FAR *, z_size_t)); -# define TBLS 8 -#else -# define TBLS 1 -#endif /* BYFOUR */ - -/* Local functions for crc concatenation */ -local unsigned long gf2_matrix_times OF((unsigned long *mat, - unsigned long vec)); -local void gf2_matrix_square OF((unsigned long *square, unsigned long *mat)); -local uLong crc32_combine_ OF((uLong crc1, uLong crc2, z_off64_t len2)); - - -#ifdef DYNAMIC_CRC_TABLE - -local volatile int crc_table_empty = 1; -local z_crc_t FAR crc_table[TBLS][256]; -local void make_crc_table OF((void)); -#ifdef MAKECRCH - local void write_table OF((FILE *, const z_crc_t FAR *)); -#endif /* MAKECRCH */ -/* - Generate tables for a byte-wise 32-bit CRC calculation on the polynomial: - x^32+x^26+x^23+x^22+x^16+x^12+x^11+x^10+x^8+x^7+x^5+x^4+x^2+x+1. - - Polynomials over GF(2) are represented in binary, one bit per coefficient, - with the lowest powers in the most significant bit. Then adding polynomials - is just exclusive-or, and multiplying a polynomial by x is a right shift by - one. If we call the above polynomial p, and represent a byte as the - polynomial q, also with the lowest power in the most significant bit (so the - byte 0xb1 is the polynomial x^7+x^3+x+1), then the CRC is (q*x^32) mod p, - where a mod b means the remainder after dividing a by b. - - This calculation is done using the shift-register method of multiplying and - taking the remainder. The register is initialized to zero, and for each - incoming bit, x^32 is added mod p to the register if the bit is a one (where - x^32 mod p is p+x^32 = x^26+...+1), and the register is multiplied mod p by - x (which is shifting right by one and adding x^32 mod p if the bit shifted - out is a one). We start with the highest power (least significant bit) of - q and repeat for all eight bits of q. - - The first table is simply the CRC of all possible eight bit values. This is - all the information needed to generate CRCs on data a byte at a time for all - combinations of CRC register values and incoming bytes. The remaining tables - allow for word-at-a-time CRC calculation for both big-endian and little- - endian machines, where a word is four bytes. -*/ -local void make_crc_table() -{ - z_crc_t c; - int n, k; - z_crc_t poly; /* polynomial exclusive-or pattern */ - /* terms of polynomial defining this crc (except x^32): */ - static volatile int first = 1; /* flag to limit concurrent making */ - static const unsigned char p[] = {0,1,2,4,5,7,8,10,11,12,16,22,23,26}; - - /* See if another task is already doing this (not thread-safe, but better - than nothing -- significantly reduces duration of vulnerability in - case the advice about DYNAMIC_CRC_TABLE is ignored) */ - if (first) { - first = 0; - - /* make exclusive-or pattern from polynomial (0xedb88320UL) */ - poly = 0; - for (n = 0; n < (int)(sizeof(p)/sizeof(unsigned char)); n++) - poly |= (z_crc_t)1 << (31 - p[n]); - - /* generate a crc for every 8-bit value */ - for (n = 0; n < 256; n++) { - c = (z_crc_t)n; - for (k = 0; k < 8; k++) - c = c & 1 ? poly ^ (c >> 1) : c >> 1; - crc_table[0][n] = c; - } - -#ifdef BYFOUR - /* generate crc for each value followed by one, two, and three zeros, - and then the byte reversal of those as well as the first table */ - for (n = 0; n < 256; n++) { - c = crc_table[0][n]; - crc_table[4][n] = ZSWAP32(c); - for (k = 1; k < 4; k++) { - c = crc_table[0][c & 0xff] ^ (c >> 8); - crc_table[k][n] = c; - crc_table[k + 4][n] = ZSWAP32(c); - } - } -#endif /* BYFOUR */ - - crc_table_empty = 0; - } - else { /* not first */ - /* wait for the other guy to finish (not efficient, but rare) */ - while (crc_table_empty) - ; - } - -#ifdef MAKECRCH - /* write out CRC tables to crc32.h */ - { - FILE *out; - - out = fopen("crc32.h", "w"); - if (out == NULL) return; - fprintf(out, "/* crc32.h -- tables for rapid CRC calculation\n"); - fprintf(out, " * Generated automatically by crc32.c\n */\n\n"); - fprintf(out, "local const z_crc_t FAR "); - fprintf(out, "crc_table[TBLS][256] =\n{\n {\n"); - write_table(out, crc_table[0]); -# ifdef BYFOUR - fprintf(out, "#ifdef BYFOUR\n"); - for (k = 1; k < 8; k++) { - fprintf(out, " },\n {\n"); - write_table(out, crc_table[k]); - } - fprintf(out, "#endif\n"); -# endif /* BYFOUR */ - fprintf(out, " }\n};\n"); - fclose(out); - } -#endif /* MAKECRCH */ -} - -#ifdef MAKECRCH -local void write_table(out, table) - FILE *out; - const z_crc_t FAR *table; -{ - int n; - - for (n = 0; n < 256; n++) - fprintf(out, "%s0x%08lxUL%s", n % 5 ? "" : " ", - (unsigned long)(table[n]), - n == 255 ? "\n" : (n % 5 == 4 ? ",\n" : ", ")); -} -#endif /* MAKECRCH */ - -#else /* !DYNAMIC_CRC_TABLE */ -/* ======================================================================== - * Tables of CRC-32s of all single-byte values, made by make_crc_table(). - */ -#include "crc32.h" -#endif /* DYNAMIC_CRC_TABLE */ - -/* ========================================================================= - * This function can be used by asm versions of crc32() - */ -const z_crc_t FAR * ZEXPORT get_crc_table() -{ -#ifdef DYNAMIC_CRC_TABLE - if (crc_table_empty) - make_crc_table(); -#endif /* DYNAMIC_CRC_TABLE */ - return (const z_crc_t FAR *)crc_table; -} - -/* ========================================================================= */ -#define DO1 crc = crc_table[0][((int)crc ^ (*buf++)) & 0xff] ^ (crc >> 8) -#define DO8 DO1; DO1; DO1; DO1; DO1; DO1; DO1; DO1 - -/* ========================================================================= */ -unsigned long ZEXPORT crc32_z(crc, buf, len) - unsigned long crc; - const unsigned char FAR *buf; - z_size_t len; -{ - if (buf == Z_NULL) return 0UL; - -#ifdef DYNAMIC_CRC_TABLE - if (crc_table_empty) - make_crc_table(); -#endif /* DYNAMIC_CRC_TABLE */ - -#ifdef BYFOUR - if (sizeof(void *) == sizeof(ptrdiff_t)) { - z_crc_t endian; - - endian = 1; - if (*((unsigned char *)(&endian))) - return crc32_little(crc, buf, len); - else - return crc32_big(crc, buf, len); - } -#endif /* BYFOUR */ - crc = crc ^ 0xffffffffUL; - while (len >= 8) { - DO8; - len -= 8; - } - if (len) do { - DO1; - } while (--len); - return crc ^ 0xffffffffUL; -} - -/* ========================================================================= */ -unsigned long ZEXPORT crc32(crc, buf, len) - unsigned long crc; - const unsigned char FAR *buf; - uInt len; -{ - return crc32_z(crc, buf, len); -} - -#ifdef BYFOUR - -/* - This BYFOUR code accesses the passed unsigned char * buffer with a 32-bit - integer pointer type. This violates the strict aliasing rule, where a - compiler can assume, for optimization purposes, that two pointers to - fundamentally different types won't ever point to the same memory. This can - manifest as a problem only if one of the pointers is written to. This code - only reads from those pointers. So long as this code remains isolated in - this compilation unit, there won't be a problem. For this reason, this code - should not be copied and pasted into a compilation unit in which other code - writes to the buffer that is passed to these routines. - */ - -/* ========================================================================= */ -#define DOLIT4 c ^= *buf4++; \ - c = crc_table[3][c & 0xff] ^ crc_table[2][(c >> 8) & 0xff] ^ \ - crc_table[1][(c >> 16) & 0xff] ^ crc_table[0][c >> 24] -#define DOLIT32 DOLIT4; DOLIT4; DOLIT4; DOLIT4; DOLIT4; DOLIT4; DOLIT4; DOLIT4 - -/* ========================================================================= */ -local unsigned long crc32_little(crc, buf, len) - unsigned long crc; - const unsigned char FAR *buf; - z_size_t len; -{ - register z_crc_t c; - register const z_crc_t FAR *buf4; - - c = (z_crc_t)crc; - c = ~c; - while (len && ((ptrdiff_t)buf & 3)) { - c = crc_table[0][(c ^ *buf++) & 0xff] ^ (c >> 8); - len--; - } - - buf4 = (const z_crc_t FAR *)(const void FAR *)buf; - while (len >= 32) { - DOLIT32; - len -= 32; - } - while (len >= 4) { - DOLIT4; - len -= 4; - } - buf = (const unsigned char FAR *)buf4; - - if (len) do { - c = crc_table[0][(c ^ *buf++) & 0xff] ^ (c >> 8); - } while (--len); - c = ~c; - return (unsigned long)c; -} - -/* ========================================================================= */ -#define DOBIG4 c ^= *buf4++; \ - c = crc_table[4][c & 0xff] ^ crc_table[5][(c >> 8) & 0xff] ^ \ - crc_table[6][(c >> 16) & 0xff] ^ crc_table[7][c >> 24] -#define DOBIG32 DOBIG4; DOBIG4; DOBIG4; DOBIG4; DOBIG4; DOBIG4; DOBIG4; DOBIG4 - -/* ========================================================================= */ -local unsigned long crc32_big(crc, buf, len) - unsigned long crc; - const unsigned char FAR *buf; - z_size_t len; -{ - register z_crc_t c; - register const z_crc_t FAR *buf4; - - c = ZSWAP32((z_crc_t)crc); - c = ~c; - while (len && ((ptrdiff_t)buf & 3)) { - c = crc_table[4][(c >> 24) ^ *buf++] ^ (c << 8); - len--; - } - - buf4 = (const z_crc_t FAR *)(const void FAR *)buf; - while (len >= 32) { - DOBIG32; - len -= 32; - } - while (len >= 4) { - DOBIG4; - len -= 4; - } - buf = (const unsigned char FAR *)buf4; - - if (len) do { - c = crc_table[4][(c >> 24) ^ *buf++] ^ (c << 8); - } while (--len); - c = ~c; - return (unsigned long)(ZSWAP32(c)); -} - -#endif /* BYFOUR */ - -#define GF2_DIM 32 /* dimension of GF(2) vectors (length of CRC) */ - -/* ========================================================================= */ -local unsigned long gf2_matrix_times(mat, vec) - unsigned long *mat; - unsigned long vec; -{ - unsigned long sum; - - sum = 0; - while (vec) { - if (vec & 1) - sum ^= *mat; - vec >>= 1; - mat++; - } - return sum; -} - -/* ========================================================================= */ -local void gf2_matrix_square(square, mat) - unsigned long *square; - unsigned long *mat; -{ - int n; - - for (n = 0; n < GF2_DIM; n++) - square[n] = gf2_matrix_times(mat, mat[n]); -} - -/* ========================================================================= */ -local uLong crc32_combine_(crc1, crc2, len2) - uLong crc1; - uLong crc2; - z_off64_t len2; -{ - int n; - unsigned long row; - unsigned long even[GF2_DIM]; /* even-power-of-two zeros operator */ - unsigned long odd[GF2_DIM]; /* odd-power-of-two zeros operator */ - - /* degenerate case (also disallow negative lengths) */ - if (len2 <= 0) - return crc1; - - /* put operator for one zero bit in odd */ - odd[0] = 0xedb88320UL; /* CRC-32 polynomial */ - row = 1; - for (n = 1; n < GF2_DIM; n++) { - odd[n] = row; - row <<= 1; - } - - /* put operator for two zero bits in even */ - gf2_matrix_square(even, odd); - - /* put operator for four zero bits in odd */ - gf2_matrix_square(odd, even); - - /* apply len2 zeros to crc1 (first square will put the operator for one - zero byte, eight zero bits, in even) */ - do { - /* apply zeros operator for this bit of len2 */ - gf2_matrix_square(even, odd); - if (len2 & 1) - crc1 = gf2_matrix_times(even, crc1); - len2 >>= 1; - - /* if no more bits set, then done */ - if (len2 == 0) - break; - - /* another iteration of the loop with odd and even swapped */ - gf2_matrix_square(odd, even); - if (len2 & 1) - crc1 = gf2_matrix_times(odd, crc1); - len2 >>= 1; - - /* if no more bits set, then done */ - } while (len2 != 0); - - /* return combined crc */ - crc1 ^= crc2; - return crc1; -} - -/* ========================================================================= */ -uLong ZEXPORT crc32_combine(crc1, crc2, len2) - uLong crc1; - uLong crc2; - z_off_t len2; -{ - return crc32_combine_(crc1, crc2, len2); -} - -uLong ZEXPORT crc32_combine64(crc1, crc2, len2) - uLong crc1; - uLong crc2; - z_off64_t len2; -{ - return crc32_combine_(crc1, crc2, len2); -} DELETED compat/zlib/crc32.h Index: compat/zlib/crc32.h ================================================================== --- compat/zlib/crc32.h +++ /dev/null @@ -1,441 +0,0 @@ -/* crc32.h -- tables for rapid CRC calculation - * Generated automatically by crc32.c - */ - -local const z_crc_t FAR crc_table[TBLS][256] = -{ - { - 0x00000000UL, 0x77073096UL, 0xee0e612cUL, 0x990951baUL, 0x076dc419UL, - 0x706af48fUL, 0xe963a535UL, 0x9e6495a3UL, 0x0edb8832UL, 0x79dcb8a4UL, - 0xe0d5e91eUL, 0x97d2d988UL, 0x09b64c2bUL, 0x7eb17cbdUL, 0xe7b82d07UL, - 0x90bf1d91UL, 0x1db71064UL, 0x6ab020f2UL, 0xf3b97148UL, 0x84be41deUL, - 0x1adad47dUL, 0x6ddde4ebUL, 0xf4d4b551UL, 0x83d385c7UL, 0x136c9856UL, - 0x646ba8c0UL, 0xfd62f97aUL, 0x8a65c9ecUL, 0x14015c4fUL, 0x63066cd9UL, - 0xfa0f3d63UL, 0x8d080df5UL, 0x3b6e20c8UL, 0x4c69105eUL, 0xd56041e4UL, - 0xa2677172UL, 0x3c03e4d1UL, 0x4b04d447UL, 0xd20d85fdUL, 0xa50ab56bUL, - 0x35b5a8faUL, 0x42b2986cUL, 0xdbbbc9d6UL, 0xacbcf940UL, 0x32d86ce3UL, - 0x45df5c75UL, 0xdcd60dcfUL, 0xabd13d59UL, 0x26d930acUL, 0x51de003aUL, - 0xc8d75180UL, 0xbfd06116UL, 0x21b4f4b5UL, 0x56b3c423UL, 0xcfba9599UL, - 0xb8bda50fUL, 0x2802b89eUL, 0x5f058808UL, 0xc60cd9b2UL, 0xb10be924UL, - 0x2f6f7c87UL, 0x58684c11UL, 0xc1611dabUL, 0xb6662d3dUL, 0x76dc4190UL, - 0x01db7106UL, 0x98d220bcUL, 0xefd5102aUL, 0x71b18589UL, 0x06b6b51fUL, - 0x9fbfe4a5UL, 0xe8b8d433UL, 0x7807c9a2UL, 0x0f00f934UL, 0x9609a88eUL, - 0xe10e9818UL, 0x7f6a0dbbUL, 0x086d3d2dUL, 0x91646c97UL, 0xe6635c01UL, - 0x6b6b51f4UL, 0x1c6c6162UL, 0x856530d8UL, 0xf262004eUL, 0x6c0695edUL, - 0x1b01a57bUL, 0x8208f4c1UL, 0xf50fc457UL, 0x65b0d9c6UL, 0x12b7e950UL, - 0x8bbeb8eaUL, 0xfcb9887cUL, 0x62dd1ddfUL, 0x15da2d49UL, 0x8cd37cf3UL, - 0xfbd44c65UL, 0x4db26158UL, 0x3ab551ceUL, 0xa3bc0074UL, 0xd4bb30e2UL, - 0x4adfa541UL, 0x3dd895d7UL, 0xa4d1c46dUL, 0xd3d6f4fbUL, 0x4369e96aUL, - 0x346ed9fcUL, 0xad678846UL, 0xda60b8d0UL, 0x44042d73UL, 0x33031de5UL, - 0xaa0a4c5fUL, 0xdd0d7cc9UL, 0x5005713cUL, 0x270241aaUL, 0xbe0b1010UL, - 0xc90c2086UL, 0x5768b525UL, 0x206f85b3UL, 0xb966d409UL, 0xce61e49fUL, - 0x5edef90eUL, 0x29d9c998UL, 0xb0d09822UL, 0xc7d7a8b4UL, 0x59b33d17UL, - 0x2eb40d81UL, 0xb7bd5c3bUL, 0xc0ba6cadUL, 0xedb88320UL, 0x9abfb3b6UL, - 0x03b6e20cUL, 0x74b1d29aUL, 0xead54739UL, 0x9dd277afUL, 0x04db2615UL, - 0x73dc1683UL, 0xe3630b12UL, 0x94643b84UL, 0x0d6d6a3eUL, 0x7a6a5aa8UL, - 0xe40ecf0bUL, 0x9309ff9dUL, 0x0a00ae27UL, 0x7d079eb1UL, 0xf00f9344UL, - 0x8708a3d2UL, 0x1e01f268UL, 0x6906c2feUL, 0xf762575dUL, 0x806567cbUL, - 0x196c3671UL, 0x6e6b06e7UL, 0xfed41b76UL, 0x89d32be0UL, 0x10da7a5aUL, - 0x67dd4accUL, 0xf9b9df6fUL, 0x8ebeeff9UL, 0x17b7be43UL, 0x60b08ed5UL, - 0xd6d6a3e8UL, 0xa1d1937eUL, 0x38d8c2c4UL, 0x4fdff252UL, 0xd1bb67f1UL, - 0xa6bc5767UL, 0x3fb506ddUL, 0x48b2364bUL, 0xd80d2bdaUL, 0xaf0a1b4cUL, - 0x36034af6UL, 0x41047a60UL, 0xdf60efc3UL, 0xa867df55UL, 0x316e8eefUL, - 0x4669be79UL, 0xcb61b38cUL, 0xbc66831aUL, 0x256fd2a0UL, 0x5268e236UL, - 0xcc0c7795UL, 0xbb0b4703UL, 0x220216b9UL, 0x5505262fUL, 0xc5ba3bbeUL, - 0xb2bd0b28UL, 0x2bb45a92UL, 0x5cb36a04UL, 0xc2d7ffa7UL, 0xb5d0cf31UL, - 0x2cd99e8bUL, 0x5bdeae1dUL, 0x9b64c2b0UL, 0xec63f226UL, 0x756aa39cUL, - 0x026d930aUL, 0x9c0906a9UL, 0xeb0e363fUL, 0x72076785UL, 0x05005713UL, - 0x95bf4a82UL, 0xe2b87a14UL, 0x7bb12baeUL, 0x0cb61b38UL, 0x92d28e9bUL, - 0xe5d5be0dUL, 0x7cdcefb7UL, 0x0bdbdf21UL, 0x86d3d2d4UL, 0xf1d4e242UL, - 0x68ddb3f8UL, 0x1fda836eUL, 0x81be16cdUL, 0xf6b9265bUL, 0x6fb077e1UL, - 0x18b74777UL, 0x88085ae6UL, 0xff0f6a70UL, 0x66063bcaUL, 0x11010b5cUL, - 0x8f659effUL, 0xf862ae69UL, 0x616bffd3UL, 0x166ccf45UL, 0xa00ae278UL, - 0xd70dd2eeUL, 0x4e048354UL, 0x3903b3c2UL, 0xa7672661UL, 0xd06016f7UL, - 0x4969474dUL, 0x3e6e77dbUL, 0xaed16a4aUL, 0xd9d65adcUL, 0x40df0b66UL, - 0x37d83bf0UL, 0xa9bcae53UL, 0xdebb9ec5UL, 0x47b2cf7fUL, 0x30b5ffe9UL, - 0xbdbdf21cUL, 0xcabac28aUL, 0x53b39330UL, 0x24b4a3a6UL, 0xbad03605UL, - 0xcdd70693UL, 0x54de5729UL, 0x23d967bfUL, 0xb3667a2eUL, 0xc4614ab8UL, - 0x5d681b02UL, 0x2a6f2b94UL, 0xb40bbe37UL, 0xc30c8ea1UL, 0x5a05df1bUL, - 0x2d02ef8dUL -#ifdef BYFOUR - }, - { - 0x00000000UL, 0x191b3141UL, 0x32366282UL, 0x2b2d53c3UL, 0x646cc504UL, - 0x7d77f445UL, 0x565aa786UL, 0x4f4196c7UL, 0xc8d98a08UL, 0xd1c2bb49UL, - 0xfaefe88aUL, 0xe3f4d9cbUL, 0xacb54f0cUL, 0xb5ae7e4dUL, 0x9e832d8eUL, - 0x87981ccfUL, 0x4ac21251UL, 0x53d92310UL, 0x78f470d3UL, 0x61ef4192UL, - 0x2eaed755UL, 0x37b5e614UL, 0x1c98b5d7UL, 0x05838496UL, 0x821b9859UL, - 0x9b00a918UL, 0xb02dfadbUL, 0xa936cb9aUL, 0xe6775d5dUL, 0xff6c6c1cUL, - 0xd4413fdfUL, 0xcd5a0e9eUL, 0x958424a2UL, 0x8c9f15e3UL, 0xa7b24620UL, - 0xbea97761UL, 0xf1e8e1a6UL, 0xe8f3d0e7UL, 0xc3de8324UL, 0xdac5b265UL, - 0x5d5daeaaUL, 0x44469febUL, 0x6f6bcc28UL, 0x7670fd69UL, 0x39316baeUL, - 0x202a5aefUL, 0x0b07092cUL, 0x121c386dUL, 0xdf4636f3UL, 0xc65d07b2UL, - 0xed705471UL, 0xf46b6530UL, 0xbb2af3f7UL, 0xa231c2b6UL, 0x891c9175UL, - 0x9007a034UL, 0x179fbcfbUL, 0x0e848dbaUL, 0x25a9de79UL, 0x3cb2ef38UL, - 0x73f379ffUL, 0x6ae848beUL, 0x41c51b7dUL, 0x58de2a3cUL, 0xf0794f05UL, - 0xe9627e44UL, 0xc24f2d87UL, 0xdb541cc6UL, 0x94158a01UL, 0x8d0ebb40UL, - 0xa623e883UL, 0xbf38d9c2UL, 0x38a0c50dUL, 0x21bbf44cUL, 0x0a96a78fUL, - 0x138d96ceUL, 0x5ccc0009UL, 0x45d73148UL, 0x6efa628bUL, 0x77e153caUL, - 0xbabb5d54UL, 0xa3a06c15UL, 0x888d3fd6UL, 0x91960e97UL, 0xded79850UL, - 0xc7cca911UL, 0xece1fad2UL, 0xf5facb93UL, 0x7262d75cUL, 0x6b79e61dUL, - 0x4054b5deUL, 0x594f849fUL, 0x160e1258UL, 0x0f152319UL, 0x243870daUL, - 0x3d23419bUL, 0x65fd6ba7UL, 0x7ce65ae6UL, 0x57cb0925UL, 0x4ed03864UL, - 0x0191aea3UL, 0x188a9fe2UL, 0x33a7cc21UL, 0x2abcfd60UL, 0xad24e1afUL, - 0xb43fd0eeUL, 0x9f12832dUL, 0x8609b26cUL, 0xc94824abUL, 0xd05315eaUL, - 0xfb7e4629UL, 0xe2657768UL, 0x2f3f79f6UL, 0x362448b7UL, 0x1d091b74UL, - 0x04122a35UL, 0x4b53bcf2UL, 0x52488db3UL, 0x7965de70UL, 0x607eef31UL, - 0xe7e6f3feUL, 0xfefdc2bfUL, 0xd5d0917cUL, 0xcccba03dUL, 0x838a36faUL, - 0x9a9107bbUL, 0xb1bc5478UL, 0xa8a76539UL, 0x3b83984bUL, 0x2298a90aUL, - 0x09b5fac9UL, 0x10aecb88UL, 0x5fef5d4fUL, 0x46f46c0eUL, 0x6dd93fcdUL, - 0x74c20e8cUL, 0xf35a1243UL, 0xea412302UL, 0xc16c70c1UL, 0xd8774180UL, - 0x9736d747UL, 0x8e2de606UL, 0xa500b5c5UL, 0xbc1b8484UL, 0x71418a1aUL, - 0x685abb5bUL, 0x4377e898UL, 0x5a6cd9d9UL, 0x152d4f1eUL, 0x0c367e5fUL, - 0x271b2d9cUL, 0x3e001cddUL, 0xb9980012UL, 0xa0833153UL, 0x8bae6290UL, - 0x92b553d1UL, 0xddf4c516UL, 0xc4eff457UL, 0xefc2a794UL, 0xf6d996d5UL, - 0xae07bce9UL, 0xb71c8da8UL, 0x9c31de6bUL, 0x852aef2aUL, 0xca6b79edUL, - 0xd37048acUL, 0xf85d1b6fUL, 0xe1462a2eUL, 0x66de36e1UL, 0x7fc507a0UL, - 0x54e85463UL, 0x4df36522UL, 0x02b2f3e5UL, 0x1ba9c2a4UL, 0x30849167UL, - 0x299fa026UL, 0xe4c5aeb8UL, 0xfdde9ff9UL, 0xd6f3cc3aUL, 0xcfe8fd7bUL, - 0x80a96bbcUL, 0x99b25afdUL, 0xb29f093eUL, 0xab84387fUL, 0x2c1c24b0UL, - 0x350715f1UL, 0x1e2a4632UL, 0x07317773UL, 0x4870e1b4UL, 0x516bd0f5UL, - 0x7a468336UL, 0x635db277UL, 0xcbfad74eUL, 0xd2e1e60fUL, 0xf9ccb5ccUL, - 0xe0d7848dUL, 0xaf96124aUL, 0xb68d230bUL, 0x9da070c8UL, 0x84bb4189UL, - 0x03235d46UL, 0x1a386c07UL, 0x31153fc4UL, 0x280e0e85UL, 0x674f9842UL, - 0x7e54a903UL, 0x5579fac0UL, 0x4c62cb81UL, 0x8138c51fUL, 0x9823f45eUL, - 0xb30ea79dUL, 0xaa1596dcUL, 0xe554001bUL, 0xfc4f315aUL, 0xd7626299UL, - 0xce7953d8UL, 0x49e14f17UL, 0x50fa7e56UL, 0x7bd72d95UL, 0x62cc1cd4UL, - 0x2d8d8a13UL, 0x3496bb52UL, 0x1fbbe891UL, 0x06a0d9d0UL, 0x5e7ef3ecUL, - 0x4765c2adUL, 0x6c48916eUL, 0x7553a02fUL, 0x3a1236e8UL, 0x230907a9UL, - 0x0824546aUL, 0x113f652bUL, 0x96a779e4UL, 0x8fbc48a5UL, 0xa4911b66UL, - 0xbd8a2a27UL, 0xf2cbbce0UL, 0xebd08da1UL, 0xc0fdde62UL, 0xd9e6ef23UL, - 0x14bce1bdUL, 0x0da7d0fcUL, 0x268a833fUL, 0x3f91b27eUL, 0x70d024b9UL, - 0x69cb15f8UL, 0x42e6463bUL, 0x5bfd777aUL, 0xdc656bb5UL, 0xc57e5af4UL, - 0xee530937UL, 0xf7483876UL, 0xb809aeb1UL, 0xa1129ff0UL, 0x8a3fcc33UL, - 0x9324fd72UL - }, - { - 0x00000000UL, 0x01c26a37UL, 0x0384d46eUL, 0x0246be59UL, 0x0709a8dcUL, - 0x06cbc2ebUL, 0x048d7cb2UL, 0x054f1685UL, 0x0e1351b8UL, 0x0fd13b8fUL, - 0x0d9785d6UL, 0x0c55efe1UL, 0x091af964UL, 0x08d89353UL, 0x0a9e2d0aUL, - 0x0b5c473dUL, 0x1c26a370UL, 0x1de4c947UL, 0x1fa2771eUL, 0x1e601d29UL, - 0x1b2f0bacUL, 0x1aed619bUL, 0x18abdfc2UL, 0x1969b5f5UL, 0x1235f2c8UL, - 0x13f798ffUL, 0x11b126a6UL, 0x10734c91UL, 0x153c5a14UL, 0x14fe3023UL, - 0x16b88e7aUL, 0x177ae44dUL, 0x384d46e0UL, 0x398f2cd7UL, 0x3bc9928eUL, - 0x3a0bf8b9UL, 0x3f44ee3cUL, 0x3e86840bUL, 0x3cc03a52UL, 0x3d025065UL, - 0x365e1758UL, 0x379c7d6fUL, 0x35dac336UL, 0x3418a901UL, 0x3157bf84UL, - 0x3095d5b3UL, 0x32d36beaUL, 0x331101ddUL, 0x246be590UL, 0x25a98fa7UL, - 0x27ef31feUL, 0x262d5bc9UL, 0x23624d4cUL, 0x22a0277bUL, 0x20e69922UL, - 0x2124f315UL, 0x2a78b428UL, 0x2bbade1fUL, 0x29fc6046UL, 0x283e0a71UL, - 0x2d711cf4UL, 0x2cb376c3UL, 0x2ef5c89aUL, 0x2f37a2adUL, 0x709a8dc0UL, - 0x7158e7f7UL, 0x731e59aeUL, 0x72dc3399UL, 0x7793251cUL, 0x76514f2bUL, - 0x7417f172UL, 0x75d59b45UL, 0x7e89dc78UL, 0x7f4bb64fUL, 0x7d0d0816UL, - 0x7ccf6221UL, 0x798074a4UL, 0x78421e93UL, 0x7a04a0caUL, 0x7bc6cafdUL, - 0x6cbc2eb0UL, 0x6d7e4487UL, 0x6f38fadeUL, 0x6efa90e9UL, 0x6bb5866cUL, - 0x6a77ec5bUL, 0x68315202UL, 0x69f33835UL, 0x62af7f08UL, 0x636d153fUL, - 0x612bab66UL, 0x60e9c151UL, 0x65a6d7d4UL, 0x6464bde3UL, 0x662203baUL, - 0x67e0698dUL, 0x48d7cb20UL, 0x4915a117UL, 0x4b531f4eUL, 0x4a917579UL, - 0x4fde63fcUL, 0x4e1c09cbUL, 0x4c5ab792UL, 0x4d98dda5UL, 0x46c49a98UL, - 0x4706f0afUL, 0x45404ef6UL, 0x448224c1UL, 0x41cd3244UL, 0x400f5873UL, - 0x4249e62aUL, 0x438b8c1dUL, 0x54f16850UL, 0x55330267UL, 0x5775bc3eUL, - 0x56b7d609UL, 0x53f8c08cUL, 0x523aaabbUL, 0x507c14e2UL, 0x51be7ed5UL, - 0x5ae239e8UL, 0x5b2053dfUL, 0x5966ed86UL, 0x58a487b1UL, 0x5deb9134UL, - 0x5c29fb03UL, 0x5e6f455aUL, 0x5fad2f6dUL, 0xe1351b80UL, 0xe0f771b7UL, - 0xe2b1cfeeUL, 0xe373a5d9UL, 0xe63cb35cUL, 0xe7fed96bUL, 0xe5b86732UL, - 0xe47a0d05UL, 0xef264a38UL, 0xeee4200fUL, 0xeca29e56UL, 0xed60f461UL, - 0xe82fe2e4UL, 0xe9ed88d3UL, 0xebab368aUL, 0xea695cbdUL, 0xfd13b8f0UL, - 0xfcd1d2c7UL, 0xfe976c9eUL, 0xff5506a9UL, 0xfa1a102cUL, 0xfbd87a1bUL, - 0xf99ec442UL, 0xf85cae75UL, 0xf300e948UL, 0xf2c2837fUL, 0xf0843d26UL, - 0xf1465711UL, 0xf4094194UL, 0xf5cb2ba3UL, 0xf78d95faUL, 0xf64fffcdUL, - 0xd9785d60UL, 0xd8ba3757UL, 0xdafc890eUL, 0xdb3ee339UL, 0xde71f5bcUL, - 0xdfb39f8bUL, 0xddf521d2UL, 0xdc374be5UL, 0xd76b0cd8UL, 0xd6a966efUL, - 0xd4efd8b6UL, 0xd52db281UL, 0xd062a404UL, 0xd1a0ce33UL, 0xd3e6706aUL, - 0xd2241a5dUL, 0xc55efe10UL, 0xc49c9427UL, 0xc6da2a7eUL, 0xc7184049UL, - 0xc25756ccUL, 0xc3953cfbUL, 0xc1d382a2UL, 0xc011e895UL, 0xcb4dafa8UL, - 0xca8fc59fUL, 0xc8c97bc6UL, 0xc90b11f1UL, 0xcc440774UL, 0xcd866d43UL, - 0xcfc0d31aUL, 0xce02b92dUL, 0x91af9640UL, 0x906dfc77UL, 0x922b422eUL, - 0x93e92819UL, 0x96a63e9cUL, 0x976454abUL, 0x9522eaf2UL, 0x94e080c5UL, - 0x9fbcc7f8UL, 0x9e7eadcfUL, 0x9c381396UL, 0x9dfa79a1UL, 0x98b56f24UL, - 0x99770513UL, 0x9b31bb4aUL, 0x9af3d17dUL, 0x8d893530UL, 0x8c4b5f07UL, - 0x8e0de15eUL, 0x8fcf8b69UL, 0x8a809decUL, 0x8b42f7dbUL, 0x89044982UL, - 0x88c623b5UL, 0x839a6488UL, 0x82580ebfUL, 0x801eb0e6UL, 0x81dcdad1UL, - 0x8493cc54UL, 0x8551a663UL, 0x8717183aUL, 0x86d5720dUL, 0xa9e2d0a0UL, - 0xa820ba97UL, 0xaa6604ceUL, 0xaba46ef9UL, 0xaeeb787cUL, 0xaf29124bUL, - 0xad6fac12UL, 0xacadc625UL, 0xa7f18118UL, 0xa633eb2fUL, 0xa4755576UL, - 0xa5b73f41UL, 0xa0f829c4UL, 0xa13a43f3UL, 0xa37cfdaaUL, 0xa2be979dUL, - 0xb5c473d0UL, 0xb40619e7UL, 0xb640a7beUL, 0xb782cd89UL, 0xb2cddb0cUL, - 0xb30fb13bUL, 0xb1490f62UL, 0xb08b6555UL, 0xbbd72268UL, 0xba15485fUL, - 0xb853f606UL, 0xb9919c31UL, 0xbcde8ab4UL, 0xbd1ce083UL, 0xbf5a5edaUL, - 0xbe9834edUL - }, - { - 0x00000000UL, 0xb8bc6765UL, 0xaa09c88bUL, 0x12b5afeeUL, 0x8f629757UL, - 0x37def032UL, 0x256b5fdcUL, 0x9dd738b9UL, 0xc5b428efUL, 0x7d084f8aUL, - 0x6fbde064UL, 0xd7018701UL, 0x4ad6bfb8UL, 0xf26ad8ddUL, 0xe0df7733UL, - 0x58631056UL, 0x5019579fUL, 0xe8a530faUL, 0xfa109f14UL, 0x42acf871UL, - 0xdf7bc0c8UL, 0x67c7a7adUL, 0x75720843UL, 0xcdce6f26UL, 0x95ad7f70UL, - 0x2d111815UL, 0x3fa4b7fbUL, 0x8718d09eUL, 0x1acfe827UL, 0xa2738f42UL, - 0xb0c620acUL, 0x087a47c9UL, 0xa032af3eUL, 0x188ec85bUL, 0x0a3b67b5UL, - 0xb28700d0UL, 0x2f503869UL, 0x97ec5f0cUL, 0x8559f0e2UL, 0x3de59787UL, - 0x658687d1UL, 0xdd3ae0b4UL, 0xcf8f4f5aUL, 0x7733283fUL, 0xeae41086UL, - 0x525877e3UL, 0x40edd80dUL, 0xf851bf68UL, 0xf02bf8a1UL, 0x48979fc4UL, - 0x5a22302aUL, 0xe29e574fUL, 0x7f496ff6UL, 0xc7f50893UL, 0xd540a77dUL, - 0x6dfcc018UL, 0x359fd04eUL, 0x8d23b72bUL, 0x9f9618c5UL, 0x272a7fa0UL, - 0xbafd4719UL, 0x0241207cUL, 0x10f48f92UL, 0xa848e8f7UL, 0x9b14583dUL, - 0x23a83f58UL, 0x311d90b6UL, 0x89a1f7d3UL, 0x1476cf6aUL, 0xaccaa80fUL, - 0xbe7f07e1UL, 0x06c36084UL, 0x5ea070d2UL, 0xe61c17b7UL, 0xf4a9b859UL, - 0x4c15df3cUL, 0xd1c2e785UL, 0x697e80e0UL, 0x7bcb2f0eUL, 0xc377486bUL, - 0xcb0d0fa2UL, 0x73b168c7UL, 0x6104c729UL, 0xd9b8a04cUL, 0x446f98f5UL, - 0xfcd3ff90UL, 0xee66507eUL, 0x56da371bUL, 0x0eb9274dUL, 0xb6054028UL, - 0xa4b0efc6UL, 0x1c0c88a3UL, 0x81dbb01aUL, 0x3967d77fUL, 0x2bd27891UL, - 0x936e1ff4UL, 0x3b26f703UL, 0x839a9066UL, 0x912f3f88UL, 0x299358edUL, - 0xb4446054UL, 0x0cf80731UL, 0x1e4da8dfUL, 0xa6f1cfbaUL, 0xfe92dfecUL, - 0x462eb889UL, 0x549b1767UL, 0xec277002UL, 0x71f048bbUL, 0xc94c2fdeUL, - 0xdbf98030UL, 0x6345e755UL, 0x6b3fa09cUL, 0xd383c7f9UL, 0xc1366817UL, - 0x798a0f72UL, 0xe45d37cbUL, 0x5ce150aeUL, 0x4e54ff40UL, 0xf6e89825UL, - 0xae8b8873UL, 0x1637ef16UL, 0x048240f8UL, 0xbc3e279dUL, 0x21e91f24UL, - 0x99557841UL, 0x8be0d7afUL, 0x335cb0caUL, 0xed59b63bUL, 0x55e5d15eUL, - 0x47507eb0UL, 0xffec19d5UL, 0x623b216cUL, 0xda874609UL, 0xc832e9e7UL, - 0x708e8e82UL, 0x28ed9ed4UL, 0x9051f9b1UL, 0x82e4565fUL, 0x3a58313aUL, - 0xa78f0983UL, 0x1f336ee6UL, 0x0d86c108UL, 0xb53aa66dUL, 0xbd40e1a4UL, - 0x05fc86c1UL, 0x1749292fUL, 0xaff54e4aUL, 0x322276f3UL, 0x8a9e1196UL, - 0x982bbe78UL, 0x2097d91dUL, 0x78f4c94bUL, 0xc048ae2eUL, 0xd2fd01c0UL, - 0x6a4166a5UL, 0xf7965e1cUL, 0x4f2a3979UL, 0x5d9f9697UL, 0xe523f1f2UL, - 0x4d6b1905UL, 0xf5d77e60UL, 0xe762d18eUL, 0x5fdeb6ebUL, 0xc2098e52UL, - 0x7ab5e937UL, 0x680046d9UL, 0xd0bc21bcUL, 0x88df31eaUL, 0x3063568fUL, - 0x22d6f961UL, 0x9a6a9e04UL, 0x07bda6bdUL, 0xbf01c1d8UL, 0xadb46e36UL, - 0x15080953UL, 0x1d724e9aUL, 0xa5ce29ffUL, 0xb77b8611UL, 0x0fc7e174UL, - 0x9210d9cdUL, 0x2aacbea8UL, 0x38191146UL, 0x80a57623UL, 0xd8c66675UL, - 0x607a0110UL, 0x72cfaefeUL, 0xca73c99bUL, 0x57a4f122UL, 0xef189647UL, - 0xfdad39a9UL, 0x45115eccUL, 0x764dee06UL, 0xcef18963UL, 0xdc44268dUL, - 0x64f841e8UL, 0xf92f7951UL, 0x41931e34UL, 0x5326b1daUL, 0xeb9ad6bfUL, - 0xb3f9c6e9UL, 0x0b45a18cUL, 0x19f00e62UL, 0xa14c6907UL, 0x3c9b51beUL, - 0x842736dbUL, 0x96929935UL, 0x2e2efe50UL, 0x2654b999UL, 0x9ee8defcUL, - 0x8c5d7112UL, 0x34e11677UL, 0xa9362eceUL, 0x118a49abUL, 0x033fe645UL, - 0xbb838120UL, 0xe3e09176UL, 0x5b5cf613UL, 0x49e959fdUL, 0xf1553e98UL, - 0x6c820621UL, 0xd43e6144UL, 0xc68bceaaUL, 0x7e37a9cfUL, 0xd67f4138UL, - 0x6ec3265dUL, 0x7c7689b3UL, 0xc4caeed6UL, 0x591dd66fUL, 0xe1a1b10aUL, - 0xf3141ee4UL, 0x4ba87981UL, 0x13cb69d7UL, 0xab770eb2UL, 0xb9c2a15cUL, - 0x017ec639UL, 0x9ca9fe80UL, 0x241599e5UL, 0x36a0360bUL, 0x8e1c516eUL, - 0x866616a7UL, 0x3eda71c2UL, 0x2c6fde2cUL, 0x94d3b949UL, 0x090481f0UL, - 0xb1b8e695UL, 0xa30d497bUL, 0x1bb12e1eUL, 0x43d23e48UL, 0xfb6e592dUL, - 0xe9dbf6c3UL, 0x516791a6UL, 0xccb0a91fUL, 0x740cce7aUL, 0x66b96194UL, - 0xde0506f1UL - }, - { - 0x00000000UL, 0x96300777UL, 0x2c610eeeUL, 0xba510999UL, 0x19c46d07UL, - 0x8ff46a70UL, 0x35a563e9UL, 0xa395649eUL, 0x3288db0eUL, 0xa4b8dc79UL, - 0x1ee9d5e0UL, 0x88d9d297UL, 0x2b4cb609UL, 0xbd7cb17eUL, 0x072db8e7UL, - 0x911dbf90UL, 0x6410b71dUL, 0xf220b06aUL, 0x4871b9f3UL, 0xde41be84UL, - 0x7dd4da1aUL, 0xebe4dd6dUL, 0x51b5d4f4UL, 0xc785d383UL, 0x56986c13UL, - 0xc0a86b64UL, 0x7af962fdUL, 0xecc9658aUL, 0x4f5c0114UL, 0xd96c0663UL, - 0x633d0ffaUL, 0xf50d088dUL, 0xc8206e3bUL, 0x5e10694cUL, 0xe44160d5UL, - 0x727167a2UL, 0xd1e4033cUL, 0x47d4044bUL, 0xfd850dd2UL, 0x6bb50aa5UL, - 0xfaa8b535UL, 0x6c98b242UL, 0xd6c9bbdbUL, 0x40f9bcacUL, 0xe36cd832UL, - 0x755cdf45UL, 0xcf0dd6dcUL, 0x593dd1abUL, 0xac30d926UL, 0x3a00de51UL, - 0x8051d7c8UL, 0x1661d0bfUL, 0xb5f4b421UL, 0x23c4b356UL, 0x9995bacfUL, - 0x0fa5bdb8UL, 0x9eb80228UL, 0x0888055fUL, 0xb2d90cc6UL, 0x24e90bb1UL, - 0x877c6f2fUL, 0x114c6858UL, 0xab1d61c1UL, 0x3d2d66b6UL, 0x9041dc76UL, - 0x0671db01UL, 0xbc20d298UL, 0x2a10d5efUL, 0x8985b171UL, 0x1fb5b606UL, - 0xa5e4bf9fUL, 0x33d4b8e8UL, 0xa2c90778UL, 0x34f9000fUL, 0x8ea80996UL, - 0x18980ee1UL, 0xbb0d6a7fUL, 0x2d3d6d08UL, 0x976c6491UL, 0x015c63e6UL, - 0xf4516b6bUL, 0x62616c1cUL, 0xd8306585UL, 0x4e0062f2UL, 0xed95066cUL, - 0x7ba5011bUL, 0xc1f40882UL, 0x57c40ff5UL, 0xc6d9b065UL, 0x50e9b712UL, - 0xeab8be8bUL, 0x7c88b9fcUL, 0xdf1ddd62UL, 0x492dda15UL, 0xf37cd38cUL, - 0x654cd4fbUL, 0x5861b24dUL, 0xce51b53aUL, 0x7400bca3UL, 0xe230bbd4UL, - 0x41a5df4aUL, 0xd795d83dUL, 0x6dc4d1a4UL, 0xfbf4d6d3UL, 0x6ae96943UL, - 0xfcd96e34UL, 0x468867adUL, 0xd0b860daUL, 0x732d0444UL, 0xe51d0333UL, - 0x5f4c0aaaUL, 0xc97c0dddUL, 0x3c710550UL, 0xaa410227UL, 0x10100bbeUL, - 0x86200cc9UL, 0x25b56857UL, 0xb3856f20UL, 0x09d466b9UL, 0x9fe461ceUL, - 0x0ef9de5eUL, 0x98c9d929UL, 0x2298d0b0UL, 0xb4a8d7c7UL, 0x173db359UL, - 0x810db42eUL, 0x3b5cbdb7UL, 0xad6cbac0UL, 0x2083b8edUL, 0xb6b3bf9aUL, - 0x0ce2b603UL, 0x9ad2b174UL, 0x3947d5eaUL, 0xaf77d29dUL, 0x1526db04UL, - 0x8316dc73UL, 0x120b63e3UL, 0x843b6494UL, 0x3e6a6d0dUL, 0xa85a6a7aUL, - 0x0bcf0ee4UL, 0x9dff0993UL, 0x27ae000aUL, 0xb19e077dUL, 0x44930ff0UL, - 0xd2a30887UL, 0x68f2011eUL, 0xfec20669UL, 0x5d5762f7UL, 0xcb676580UL, - 0x71366c19UL, 0xe7066b6eUL, 0x761bd4feUL, 0xe02bd389UL, 0x5a7ada10UL, - 0xcc4add67UL, 0x6fdfb9f9UL, 0xf9efbe8eUL, 0x43beb717UL, 0xd58eb060UL, - 0xe8a3d6d6UL, 0x7e93d1a1UL, 0xc4c2d838UL, 0x52f2df4fUL, 0xf167bbd1UL, - 0x6757bca6UL, 0xdd06b53fUL, 0x4b36b248UL, 0xda2b0dd8UL, 0x4c1b0aafUL, - 0xf64a0336UL, 0x607a0441UL, 0xc3ef60dfUL, 0x55df67a8UL, 0xef8e6e31UL, - 0x79be6946UL, 0x8cb361cbUL, 0x1a8366bcUL, 0xa0d26f25UL, 0x36e26852UL, - 0x95770cccUL, 0x03470bbbUL, 0xb9160222UL, 0x2f260555UL, 0xbe3bbac5UL, - 0x280bbdb2UL, 0x925ab42bUL, 0x046ab35cUL, 0xa7ffd7c2UL, 0x31cfd0b5UL, - 0x8b9ed92cUL, 0x1daede5bUL, 0xb0c2649bUL, 0x26f263ecUL, 0x9ca36a75UL, - 0x0a936d02UL, 0xa906099cUL, 0x3f360eebUL, 0x85670772UL, 0x13570005UL, - 0x824abf95UL, 0x147ab8e2UL, 0xae2bb17bUL, 0x381bb60cUL, 0x9b8ed292UL, - 0x0dbed5e5UL, 0xb7efdc7cUL, 0x21dfdb0bUL, 0xd4d2d386UL, 0x42e2d4f1UL, - 0xf8b3dd68UL, 0x6e83da1fUL, 0xcd16be81UL, 0x5b26b9f6UL, 0xe177b06fUL, - 0x7747b718UL, 0xe65a0888UL, 0x706a0fffUL, 0xca3b0666UL, 0x5c0b0111UL, - 0xff9e658fUL, 0x69ae62f8UL, 0xd3ff6b61UL, 0x45cf6c16UL, 0x78e20aa0UL, - 0xeed20dd7UL, 0x5483044eUL, 0xc2b30339UL, 0x612667a7UL, 0xf71660d0UL, - 0x4d476949UL, 0xdb776e3eUL, 0x4a6ad1aeUL, 0xdc5ad6d9UL, 0x660bdf40UL, - 0xf03bd837UL, 0x53aebca9UL, 0xc59ebbdeUL, 0x7fcfb247UL, 0xe9ffb530UL, - 0x1cf2bdbdUL, 0x8ac2bacaUL, 0x3093b353UL, 0xa6a3b424UL, 0x0536d0baUL, - 0x9306d7cdUL, 0x2957de54UL, 0xbf67d923UL, 0x2e7a66b3UL, 0xb84a61c4UL, - 0x021b685dUL, 0x942b6f2aUL, 0x37be0bb4UL, 0xa18e0cc3UL, 0x1bdf055aUL, - 0x8def022dUL - }, - { - 0x00000000UL, 0x41311b19UL, 0x82623632UL, 0xc3532d2bUL, 0x04c56c64UL, - 0x45f4777dUL, 0x86a75a56UL, 0xc796414fUL, 0x088ad9c8UL, 0x49bbc2d1UL, - 0x8ae8effaUL, 0xcbd9f4e3UL, 0x0c4fb5acUL, 0x4d7eaeb5UL, 0x8e2d839eUL, - 0xcf1c9887UL, 0x5112c24aUL, 0x1023d953UL, 0xd370f478UL, 0x9241ef61UL, - 0x55d7ae2eUL, 0x14e6b537UL, 0xd7b5981cUL, 0x96848305UL, 0x59981b82UL, - 0x18a9009bUL, 0xdbfa2db0UL, 0x9acb36a9UL, 0x5d5d77e6UL, 0x1c6c6cffUL, - 0xdf3f41d4UL, 0x9e0e5acdUL, 0xa2248495UL, 0xe3159f8cUL, 0x2046b2a7UL, - 0x6177a9beUL, 0xa6e1e8f1UL, 0xe7d0f3e8UL, 0x2483dec3UL, 0x65b2c5daUL, - 0xaaae5d5dUL, 0xeb9f4644UL, 0x28cc6b6fUL, 0x69fd7076UL, 0xae6b3139UL, - 0xef5a2a20UL, 0x2c09070bUL, 0x6d381c12UL, 0xf33646dfUL, 0xb2075dc6UL, - 0x715470edUL, 0x30656bf4UL, 0xf7f32abbUL, 0xb6c231a2UL, 0x75911c89UL, - 0x34a00790UL, 0xfbbc9f17UL, 0xba8d840eUL, 0x79dea925UL, 0x38efb23cUL, - 0xff79f373UL, 0xbe48e86aUL, 0x7d1bc541UL, 0x3c2ade58UL, 0x054f79f0UL, - 0x447e62e9UL, 0x872d4fc2UL, 0xc61c54dbUL, 0x018a1594UL, 0x40bb0e8dUL, - 0x83e823a6UL, 0xc2d938bfUL, 0x0dc5a038UL, 0x4cf4bb21UL, 0x8fa7960aUL, - 0xce968d13UL, 0x0900cc5cUL, 0x4831d745UL, 0x8b62fa6eUL, 0xca53e177UL, - 0x545dbbbaUL, 0x156ca0a3UL, 0xd63f8d88UL, 0x970e9691UL, 0x5098d7deUL, - 0x11a9ccc7UL, 0xd2fae1ecUL, 0x93cbfaf5UL, 0x5cd76272UL, 0x1de6796bUL, - 0xdeb55440UL, 0x9f844f59UL, 0x58120e16UL, 0x1923150fUL, 0xda703824UL, - 0x9b41233dUL, 0xa76bfd65UL, 0xe65ae67cUL, 0x2509cb57UL, 0x6438d04eUL, - 0xa3ae9101UL, 0xe29f8a18UL, 0x21cca733UL, 0x60fdbc2aUL, 0xafe124adUL, - 0xeed03fb4UL, 0x2d83129fUL, 0x6cb20986UL, 0xab2448c9UL, 0xea1553d0UL, - 0x29467efbUL, 0x687765e2UL, 0xf6793f2fUL, 0xb7482436UL, 0x741b091dUL, - 0x352a1204UL, 0xf2bc534bUL, 0xb38d4852UL, 0x70de6579UL, 0x31ef7e60UL, - 0xfef3e6e7UL, 0xbfc2fdfeUL, 0x7c91d0d5UL, 0x3da0cbccUL, 0xfa368a83UL, - 0xbb07919aUL, 0x7854bcb1UL, 0x3965a7a8UL, 0x4b98833bUL, 0x0aa99822UL, - 0xc9fab509UL, 0x88cbae10UL, 0x4f5def5fUL, 0x0e6cf446UL, 0xcd3fd96dUL, - 0x8c0ec274UL, 0x43125af3UL, 0x022341eaUL, 0xc1706cc1UL, 0x804177d8UL, - 0x47d73697UL, 0x06e62d8eUL, 0xc5b500a5UL, 0x84841bbcUL, 0x1a8a4171UL, - 0x5bbb5a68UL, 0x98e87743UL, 0xd9d96c5aUL, 0x1e4f2d15UL, 0x5f7e360cUL, - 0x9c2d1b27UL, 0xdd1c003eUL, 0x120098b9UL, 0x533183a0UL, 0x9062ae8bUL, - 0xd153b592UL, 0x16c5f4ddUL, 0x57f4efc4UL, 0x94a7c2efUL, 0xd596d9f6UL, - 0xe9bc07aeUL, 0xa88d1cb7UL, 0x6bde319cUL, 0x2aef2a85UL, 0xed796bcaUL, - 0xac4870d3UL, 0x6f1b5df8UL, 0x2e2a46e1UL, 0xe136de66UL, 0xa007c57fUL, - 0x6354e854UL, 0x2265f34dUL, 0xe5f3b202UL, 0xa4c2a91bUL, 0x67918430UL, - 0x26a09f29UL, 0xb8aec5e4UL, 0xf99fdefdUL, 0x3accf3d6UL, 0x7bfde8cfUL, - 0xbc6ba980UL, 0xfd5ab299UL, 0x3e099fb2UL, 0x7f3884abUL, 0xb0241c2cUL, - 0xf1150735UL, 0x32462a1eUL, 0x73773107UL, 0xb4e17048UL, 0xf5d06b51UL, - 0x3683467aUL, 0x77b25d63UL, 0x4ed7facbUL, 0x0fe6e1d2UL, 0xccb5ccf9UL, - 0x8d84d7e0UL, 0x4a1296afUL, 0x0b238db6UL, 0xc870a09dUL, 0x8941bb84UL, - 0x465d2303UL, 0x076c381aUL, 0xc43f1531UL, 0x850e0e28UL, 0x42984f67UL, - 0x03a9547eUL, 0xc0fa7955UL, 0x81cb624cUL, 0x1fc53881UL, 0x5ef42398UL, - 0x9da70eb3UL, 0xdc9615aaUL, 0x1b0054e5UL, 0x5a314ffcUL, 0x996262d7UL, - 0xd85379ceUL, 0x174fe149UL, 0x567efa50UL, 0x952dd77bUL, 0xd41ccc62UL, - 0x138a8d2dUL, 0x52bb9634UL, 0x91e8bb1fUL, 0xd0d9a006UL, 0xecf37e5eUL, - 0xadc26547UL, 0x6e91486cUL, 0x2fa05375UL, 0xe836123aUL, 0xa9070923UL, - 0x6a542408UL, 0x2b653f11UL, 0xe479a796UL, 0xa548bc8fUL, 0x661b91a4UL, - 0x272a8abdUL, 0xe0bccbf2UL, 0xa18dd0ebUL, 0x62defdc0UL, 0x23efe6d9UL, - 0xbde1bc14UL, 0xfcd0a70dUL, 0x3f838a26UL, 0x7eb2913fUL, 0xb924d070UL, - 0xf815cb69UL, 0x3b46e642UL, 0x7a77fd5bUL, 0xb56b65dcUL, 0xf45a7ec5UL, - 0x370953eeUL, 0x763848f7UL, 0xb1ae09b8UL, 0xf09f12a1UL, 0x33cc3f8aUL, - 0x72fd2493UL - }, - { - 0x00000000UL, 0x376ac201UL, 0x6ed48403UL, 0x59be4602UL, 0xdca80907UL, - 0xebc2cb06UL, 0xb27c8d04UL, 0x85164f05UL, 0xb851130eUL, 0x8f3bd10fUL, - 0xd685970dUL, 0xe1ef550cUL, 0x64f91a09UL, 0x5393d808UL, 0x0a2d9e0aUL, - 0x3d475c0bUL, 0x70a3261cUL, 0x47c9e41dUL, 0x1e77a21fUL, 0x291d601eUL, - 0xac0b2f1bUL, 0x9b61ed1aUL, 0xc2dfab18UL, 0xf5b56919UL, 0xc8f23512UL, - 0xff98f713UL, 0xa626b111UL, 0x914c7310UL, 0x145a3c15UL, 0x2330fe14UL, - 0x7a8eb816UL, 0x4de47a17UL, 0xe0464d38UL, 0xd72c8f39UL, 0x8e92c93bUL, - 0xb9f80b3aUL, 0x3cee443fUL, 0x0b84863eUL, 0x523ac03cUL, 0x6550023dUL, - 0x58175e36UL, 0x6f7d9c37UL, 0x36c3da35UL, 0x01a91834UL, 0x84bf5731UL, - 0xb3d59530UL, 0xea6bd332UL, 0xdd011133UL, 0x90e56b24UL, 0xa78fa925UL, - 0xfe31ef27UL, 0xc95b2d26UL, 0x4c4d6223UL, 0x7b27a022UL, 0x2299e620UL, - 0x15f32421UL, 0x28b4782aUL, 0x1fdeba2bUL, 0x4660fc29UL, 0x710a3e28UL, - 0xf41c712dUL, 0xc376b32cUL, 0x9ac8f52eUL, 0xada2372fUL, 0xc08d9a70UL, - 0xf7e75871UL, 0xae591e73UL, 0x9933dc72UL, 0x1c259377UL, 0x2b4f5176UL, - 0x72f11774UL, 0x459bd575UL, 0x78dc897eUL, 0x4fb64b7fUL, 0x16080d7dUL, - 0x2162cf7cUL, 0xa4748079UL, 0x931e4278UL, 0xcaa0047aUL, 0xfdcac67bUL, - 0xb02ebc6cUL, 0x87447e6dUL, 0xdefa386fUL, 0xe990fa6eUL, 0x6c86b56bUL, - 0x5bec776aUL, 0x02523168UL, 0x3538f369UL, 0x087faf62UL, 0x3f156d63UL, - 0x66ab2b61UL, 0x51c1e960UL, 0xd4d7a665UL, 0xe3bd6464UL, 0xba032266UL, - 0x8d69e067UL, 0x20cbd748UL, 0x17a11549UL, 0x4e1f534bUL, 0x7975914aUL, - 0xfc63de4fUL, 0xcb091c4eUL, 0x92b75a4cUL, 0xa5dd984dUL, 0x989ac446UL, - 0xaff00647UL, 0xf64e4045UL, 0xc1248244UL, 0x4432cd41UL, 0x73580f40UL, - 0x2ae64942UL, 0x1d8c8b43UL, 0x5068f154UL, 0x67023355UL, 0x3ebc7557UL, - 0x09d6b756UL, 0x8cc0f853UL, 0xbbaa3a52UL, 0xe2147c50UL, 0xd57ebe51UL, - 0xe839e25aUL, 0xdf53205bUL, 0x86ed6659UL, 0xb187a458UL, 0x3491eb5dUL, - 0x03fb295cUL, 0x5a456f5eUL, 0x6d2fad5fUL, 0x801b35e1UL, 0xb771f7e0UL, - 0xeecfb1e2UL, 0xd9a573e3UL, 0x5cb33ce6UL, 0x6bd9fee7UL, 0x3267b8e5UL, - 0x050d7ae4UL, 0x384a26efUL, 0x0f20e4eeUL, 0x569ea2ecUL, 0x61f460edUL, - 0xe4e22fe8UL, 0xd388ede9UL, 0x8a36abebUL, 0xbd5c69eaUL, 0xf0b813fdUL, - 0xc7d2d1fcUL, 0x9e6c97feUL, 0xa90655ffUL, 0x2c101afaUL, 0x1b7ad8fbUL, - 0x42c49ef9UL, 0x75ae5cf8UL, 0x48e900f3UL, 0x7f83c2f2UL, 0x263d84f0UL, - 0x115746f1UL, 0x944109f4UL, 0xa32bcbf5UL, 0xfa958df7UL, 0xcdff4ff6UL, - 0x605d78d9UL, 0x5737bad8UL, 0x0e89fcdaUL, 0x39e33edbUL, 0xbcf571deUL, - 0x8b9fb3dfUL, 0xd221f5ddUL, 0xe54b37dcUL, 0xd80c6bd7UL, 0xef66a9d6UL, - 0xb6d8efd4UL, 0x81b22dd5UL, 0x04a462d0UL, 0x33cea0d1UL, 0x6a70e6d3UL, - 0x5d1a24d2UL, 0x10fe5ec5UL, 0x27949cc4UL, 0x7e2adac6UL, 0x494018c7UL, - 0xcc5657c2UL, 0xfb3c95c3UL, 0xa282d3c1UL, 0x95e811c0UL, 0xa8af4dcbUL, - 0x9fc58fcaUL, 0xc67bc9c8UL, 0xf1110bc9UL, 0x740744ccUL, 0x436d86cdUL, - 0x1ad3c0cfUL, 0x2db902ceUL, 0x4096af91UL, 0x77fc6d90UL, 0x2e422b92UL, - 0x1928e993UL, 0x9c3ea696UL, 0xab546497UL, 0xf2ea2295UL, 0xc580e094UL, - 0xf8c7bc9fUL, 0xcfad7e9eUL, 0x9613389cUL, 0xa179fa9dUL, 0x246fb598UL, - 0x13057799UL, 0x4abb319bUL, 0x7dd1f39aUL, 0x3035898dUL, 0x075f4b8cUL, - 0x5ee10d8eUL, 0x698bcf8fUL, 0xec9d808aUL, 0xdbf7428bUL, 0x82490489UL, - 0xb523c688UL, 0x88649a83UL, 0xbf0e5882UL, 0xe6b01e80UL, 0xd1dadc81UL, - 0x54cc9384UL, 0x63a65185UL, 0x3a181787UL, 0x0d72d586UL, 0xa0d0e2a9UL, - 0x97ba20a8UL, 0xce0466aaUL, 0xf96ea4abUL, 0x7c78ebaeUL, 0x4b1229afUL, - 0x12ac6fadUL, 0x25c6adacUL, 0x1881f1a7UL, 0x2feb33a6UL, 0x765575a4UL, - 0x413fb7a5UL, 0xc429f8a0UL, 0xf3433aa1UL, 0xaafd7ca3UL, 0x9d97bea2UL, - 0xd073c4b5UL, 0xe71906b4UL, 0xbea740b6UL, 0x89cd82b7UL, 0x0cdbcdb2UL, - 0x3bb10fb3UL, 0x620f49b1UL, 0x55658bb0UL, 0x6822d7bbUL, 0x5f4815baUL, - 0x06f653b8UL, 0x319c91b9UL, 0xb48adebcUL, 0x83e01cbdUL, 0xda5e5abfUL, - 0xed3498beUL - }, - { - 0x00000000UL, 0x6567bcb8UL, 0x8bc809aaUL, 0xeeafb512UL, 0x5797628fUL, - 0x32f0de37UL, 0xdc5f6b25UL, 0xb938d79dUL, 0xef28b4c5UL, 0x8a4f087dUL, - 0x64e0bd6fUL, 0x018701d7UL, 0xb8bfd64aUL, 0xddd86af2UL, 0x3377dfe0UL, - 0x56106358UL, 0x9f571950UL, 0xfa30a5e8UL, 0x149f10faUL, 0x71f8ac42UL, - 0xc8c07bdfUL, 0xada7c767UL, 0x43087275UL, 0x266fcecdUL, 0x707fad95UL, - 0x1518112dUL, 0xfbb7a43fUL, 0x9ed01887UL, 0x27e8cf1aUL, 0x428f73a2UL, - 0xac20c6b0UL, 0xc9477a08UL, 0x3eaf32a0UL, 0x5bc88e18UL, 0xb5673b0aUL, - 0xd00087b2UL, 0x6938502fUL, 0x0c5fec97UL, 0xe2f05985UL, 0x8797e53dUL, - 0xd1878665UL, 0xb4e03addUL, 0x5a4f8fcfUL, 0x3f283377UL, 0x8610e4eaUL, - 0xe3775852UL, 0x0dd8ed40UL, 0x68bf51f8UL, 0xa1f82bf0UL, 0xc49f9748UL, - 0x2a30225aUL, 0x4f579ee2UL, 0xf66f497fUL, 0x9308f5c7UL, 0x7da740d5UL, - 0x18c0fc6dUL, 0x4ed09f35UL, 0x2bb7238dUL, 0xc518969fUL, 0xa07f2a27UL, - 0x1947fdbaUL, 0x7c204102UL, 0x928ff410UL, 0xf7e848a8UL, 0x3d58149bUL, - 0x583fa823UL, 0xb6901d31UL, 0xd3f7a189UL, 0x6acf7614UL, 0x0fa8caacUL, - 0xe1077fbeUL, 0x8460c306UL, 0xd270a05eUL, 0xb7171ce6UL, 0x59b8a9f4UL, - 0x3cdf154cUL, 0x85e7c2d1UL, 0xe0807e69UL, 0x0e2fcb7bUL, 0x6b4877c3UL, - 0xa20f0dcbUL, 0xc768b173UL, 0x29c70461UL, 0x4ca0b8d9UL, 0xf5986f44UL, - 0x90ffd3fcUL, 0x7e5066eeUL, 0x1b37da56UL, 0x4d27b90eUL, 0x284005b6UL, - 0xc6efb0a4UL, 0xa3880c1cUL, 0x1ab0db81UL, 0x7fd76739UL, 0x9178d22bUL, - 0xf41f6e93UL, 0x03f7263bUL, 0x66909a83UL, 0x883f2f91UL, 0xed589329UL, - 0x546044b4UL, 0x3107f80cUL, 0xdfa84d1eUL, 0xbacff1a6UL, 0xecdf92feUL, - 0x89b82e46UL, 0x67179b54UL, 0x027027ecUL, 0xbb48f071UL, 0xde2f4cc9UL, - 0x3080f9dbUL, 0x55e74563UL, 0x9ca03f6bUL, 0xf9c783d3UL, 0x176836c1UL, - 0x720f8a79UL, 0xcb375de4UL, 0xae50e15cUL, 0x40ff544eUL, 0x2598e8f6UL, - 0x73888baeUL, 0x16ef3716UL, 0xf8408204UL, 0x9d273ebcUL, 0x241fe921UL, - 0x41785599UL, 0xafd7e08bUL, 0xcab05c33UL, 0x3bb659edUL, 0x5ed1e555UL, - 0xb07e5047UL, 0xd519ecffUL, 0x6c213b62UL, 0x094687daUL, 0xe7e932c8UL, - 0x828e8e70UL, 0xd49eed28UL, 0xb1f95190UL, 0x5f56e482UL, 0x3a31583aUL, - 0x83098fa7UL, 0xe66e331fUL, 0x08c1860dUL, 0x6da63ab5UL, 0xa4e140bdUL, - 0xc186fc05UL, 0x2f294917UL, 0x4a4ef5afUL, 0xf3762232UL, 0x96119e8aUL, - 0x78be2b98UL, 0x1dd99720UL, 0x4bc9f478UL, 0x2eae48c0UL, 0xc001fdd2UL, - 0xa566416aUL, 0x1c5e96f7UL, 0x79392a4fUL, 0x97969f5dUL, 0xf2f123e5UL, - 0x05196b4dUL, 0x607ed7f5UL, 0x8ed162e7UL, 0xebb6de5fUL, 0x528e09c2UL, - 0x37e9b57aUL, 0xd9460068UL, 0xbc21bcd0UL, 0xea31df88UL, 0x8f566330UL, - 0x61f9d622UL, 0x049e6a9aUL, 0xbda6bd07UL, 0xd8c101bfUL, 0x366eb4adUL, - 0x53090815UL, 0x9a4e721dUL, 0xff29cea5UL, 0x11867bb7UL, 0x74e1c70fUL, - 0xcdd91092UL, 0xa8beac2aUL, 0x46111938UL, 0x2376a580UL, 0x7566c6d8UL, - 0x10017a60UL, 0xfeaecf72UL, 0x9bc973caUL, 0x22f1a457UL, 0x479618efUL, - 0xa939adfdUL, 0xcc5e1145UL, 0x06ee4d76UL, 0x6389f1ceUL, 0x8d2644dcUL, - 0xe841f864UL, 0x51792ff9UL, 0x341e9341UL, 0xdab12653UL, 0xbfd69aebUL, - 0xe9c6f9b3UL, 0x8ca1450bUL, 0x620ef019UL, 0x07694ca1UL, 0xbe519b3cUL, - 0xdb362784UL, 0x35999296UL, 0x50fe2e2eUL, 0x99b95426UL, 0xfcdee89eUL, - 0x12715d8cUL, 0x7716e134UL, 0xce2e36a9UL, 0xab498a11UL, 0x45e63f03UL, - 0x208183bbUL, 0x7691e0e3UL, 0x13f65c5bUL, 0xfd59e949UL, 0x983e55f1UL, - 0x2106826cUL, 0x44613ed4UL, 0xaace8bc6UL, 0xcfa9377eUL, 0x38417fd6UL, - 0x5d26c36eUL, 0xb389767cUL, 0xd6eecac4UL, 0x6fd61d59UL, 0x0ab1a1e1UL, - 0xe41e14f3UL, 0x8179a84bUL, 0xd769cb13UL, 0xb20e77abUL, 0x5ca1c2b9UL, - 0x39c67e01UL, 0x80fea99cUL, 0xe5991524UL, 0x0b36a036UL, 0x6e511c8eUL, - 0xa7166686UL, 0xc271da3eUL, 0x2cde6f2cUL, 0x49b9d394UL, 0xf0810409UL, - 0x95e6b8b1UL, 0x7b490da3UL, 0x1e2eb11bUL, 0x483ed243UL, 0x2d596efbUL, - 0xc3f6dbe9UL, 0xa6916751UL, 0x1fa9b0ccUL, 0x7ace0c74UL, 0x9461b966UL, - 0xf10605deUL -#endif - } -}; DELETED compat/zlib/deflate.c Index: compat/zlib/deflate.c ================================================================== --- compat/zlib/deflate.c +++ /dev/null @@ -1,2163 +0,0 @@ -/* deflate.c -- compress data using the deflation algorithm - * Copyright (C) 1995-2017 Jean-loup Gailly and Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -/* - * ALGORITHM - * - * The "deflation" process depends on being able to identify portions - * of the input text which are identical to earlier input (within a - * sliding window trailing behind the input currently being processed). - * - * The most straightforward technique turns out to be the fastest for - * most input files: try all possible matches and select the longest. - * The key feature of this algorithm is that insertions into the string - * dictionary are very simple and thus fast, and deletions are avoided - * completely. Insertions are performed at each input character, whereas - * string matches are performed only when the previous match ends. So it - * is preferable to spend more time in matches to allow very fast string - * insertions and avoid deletions. The matching algorithm for small - * strings is inspired from that of Rabin & Karp. A brute force approach - * is used to find longer strings when a small match has been found. - * A similar algorithm is used in comic (by Jan-Mark Wams) and freeze - * (by Leonid Broukhis). - * A previous version of this file used a more sophisticated algorithm - * (by Fiala and Greene) which is guaranteed to run in linear amortized - * time, but has a larger average cost, uses more memory and is patented. - * However the F&G algorithm may be faster for some highly redundant - * files if the parameter max_chain_length (described below) is too large. - * - * ACKNOWLEDGEMENTS - * - * The idea of lazy evaluation of matches is due to Jan-Mark Wams, and - * I found it in 'freeze' written by Leonid Broukhis. - * Thanks to many people for bug reports and testing. - * - * REFERENCES - * - * Deutsch, L.P.,"DEFLATE Compressed Data Format Specification". - * Available in http://tools.ietf.org/html/rfc1951 - * - * A description of the Rabin and Karp algorithm is given in the book - * "Algorithms" by R. Sedgewick, Addison-Wesley, p252. - * - * Fiala,E.R., and Greene,D.H. - * Data Compression with Finite Windows, Comm.ACM, 32,4 (1989) 490-595 - * - */ - -/* @(#) $Id$ */ - -#include "deflate.h" - -const char deflate_copyright[] = - " deflate 1.2.11 Copyright 1995-2017 Jean-loup Gailly and Mark Adler "; -/* - If you use the zlib library in a product, an acknowledgment is welcome - in the documentation of your product. If for some reason you cannot - include such an acknowledgment, I would appreciate that you keep this - copyright string in the executable of your product. - */ - -/* =========================================================================== - * Function prototypes. - */ -typedef enum { - need_more, /* block not completed, need more input or more output */ - block_done, /* block flush performed */ - finish_started, /* finish started, need only more output at next deflate */ - finish_done /* finish done, accept no more input or output */ -} block_state; - -typedef block_state (*compress_func) OF((deflate_state *s, int flush)); -/* Compression function. Returns the block state after the call. */ - -local int deflateStateCheck OF((z_streamp strm)); -local void slide_hash OF((deflate_state *s)); -local void fill_window OF((deflate_state *s)); -local block_state deflate_stored OF((deflate_state *s, int flush)); -local block_state deflate_fast OF((deflate_state *s, int flush)); -#ifndef FASTEST -local block_state deflate_slow OF((deflate_state *s, int flush)); -#endif -local block_state deflate_rle OF((deflate_state *s, int flush)); -local block_state deflate_huff OF((deflate_state *s, int flush)); -local void lm_init OF((deflate_state *s)); -local void putShortMSB OF((deflate_state *s, uInt b)); -local void flush_pending OF((z_streamp strm)); -local unsigned read_buf OF((z_streamp strm, Bytef *buf, unsigned size)); -#ifdef ASMV -# pragma message("Assembler code may have bugs -- use at your own risk") - void match_init OF((void)); /* asm code initialization */ - uInt longest_match OF((deflate_state *s, IPos cur_match)); -#else -local uInt longest_match OF((deflate_state *s, IPos cur_match)); -#endif - -#ifdef ZLIB_DEBUG -local void check_match OF((deflate_state *s, IPos start, IPos match, - int length)); -#endif - -/* =========================================================================== - * Local data - */ - -#define NIL 0 -/* Tail of hash chains */ - -#ifndef TOO_FAR -# define TOO_FAR 4096 -#endif -/* Matches of length 3 are discarded if their distance exceeds TOO_FAR */ - -/* Values for max_lazy_match, good_match and max_chain_length, depending on - * the desired pack level (0..9). The values given below have been tuned to - * exclude worst case performance for pathological files. Better values may be - * found for specific files. - */ -typedef struct config_s { - ush good_length; /* reduce lazy search above this match length */ - ush max_lazy; /* do not perform lazy search above this match length */ - ush nice_length; /* quit search above this match length */ - ush max_chain; - compress_func func; -} config; - -#ifdef FASTEST -local const config configuration_table[2] = { -/* good lazy nice chain */ -/* 0 */ {0, 0, 0, 0, deflate_stored}, /* store only */ -/* 1 */ {4, 4, 8, 4, deflate_fast}}; /* max speed, no lazy matches */ -#else -local const config configuration_table[10] = { -/* good lazy nice chain */ -/* 0 */ {0, 0, 0, 0, deflate_stored}, /* store only */ -/* 1 */ {4, 4, 8, 4, deflate_fast}, /* max speed, no lazy matches */ -/* 2 */ {4, 5, 16, 8, deflate_fast}, -/* 3 */ {4, 6, 32, 32, deflate_fast}, - -/* 4 */ {4, 4, 16, 16, deflate_slow}, /* lazy matches */ -/* 5 */ {8, 16, 32, 32, deflate_slow}, -/* 6 */ {8, 16, 128, 128, deflate_slow}, -/* 7 */ {8, 32, 128, 256, deflate_slow}, -/* 8 */ {32, 128, 258, 1024, deflate_slow}, -/* 9 */ {32, 258, 258, 4096, deflate_slow}}; /* max compression */ -#endif - -/* Note: the deflate() code requires max_lazy >= MIN_MATCH and max_chain >= 4 - * For deflate_fast() (levels <= 3) good is ignored and lazy has a different - * meaning. - */ - -/* rank Z_BLOCK between Z_NO_FLUSH and Z_PARTIAL_FLUSH */ -#define RANK(f) (((f) * 2) - ((f) > 4 ? 9 : 0)) - -/* =========================================================================== - * Update a hash value with the given input byte - * IN assertion: all calls to UPDATE_HASH are made with consecutive input - * characters, so that a running hash key can be computed from the previous - * key instead of complete recalculation each time. - */ -#define UPDATE_HASH(s,h,c) (h = (((h)<hash_shift) ^ (c)) & s->hash_mask) - - -/* =========================================================================== - * Insert string str in the dictionary and set match_head to the previous head - * of the hash chain (the most recent string with same hash key). Return - * the previous length of the hash chain. - * If this file is compiled with -DFASTEST, the compression level is forced - * to 1, and no hash chains are maintained. - * IN assertion: all calls to INSERT_STRING are made with consecutive input - * characters and the first MIN_MATCH bytes of str are valid (except for - * the last MIN_MATCH-1 bytes of the input file). - */ -#ifdef FASTEST -#define INSERT_STRING(s, str, match_head) \ - (UPDATE_HASH(s, s->ins_h, s->window[(str) + (MIN_MATCH-1)]), \ - match_head = s->head[s->ins_h], \ - s->head[s->ins_h] = (Pos)(str)) -#else -#define INSERT_STRING(s, str, match_head) \ - (UPDATE_HASH(s, s->ins_h, s->window[(str) + (MIN_MATCH-1)]), \ - match_head = s->prev[(str) & s->w_mask] = s->head[s->ins_h], \ - s->head[s->ins_h] = (Pos)(str)) -#endif - -/* =========================================================================== - * Initialize the hash table (avoiding 64K overflow for 16 bit systems). - * prev[] will be initialized on the fly. - */ -#define CLEAR_HASH(s) \ - s->head[s->hash_size-1] = NIL; \ - zmemzero((Bytef *)s->head, (unsigned)(s->hash_size-1)*sizeof(*s->head)); - -/* =========================================================================== - * Slide the hash table when sliding the window down (could be avoided with 32 - * bit values at the expense of memory usage). We slide even when level == 0 to - * keep the hash table consistent if we switch back to level > 0 later. - */ -local void slide_hash(s) - deflate_state *s; -{ - unsigned n, m; - Posf *p; - uInt wsize = s->w_size; - - n = s->hash_size; - p = &s->head[n]; - do { - m = *--p; - *p = (Pos)(m >= wsize ? m - wsize : NIL); - } while (--n); - n = wsize; -#ifndef FASTEST - p = &s->prev[n]; - do { - m = *--p; - *p = (Pos)(m >= wsize ? m - wsize : NIL); - /* If n is not on any hash chain, prev[n] is garbage but - * its value will never be used. - */ - } while (--n); -#endif -} - -/* ========================================================================= */ -int ZEXPORT deflateInit_(strm, level, version, stream_size) - z_streamp strm; - int level; - const char *version; - int stream_size; -{ - return deflateInit2_(strm, level, Z_DEFLATED, MAX_WBITS, DEF_MEM_LEVEL, - Z_DEFAULT_STRATEGY, version, stream_size); - /* To do: ignore strm->next_in if we use it as window */ -} - -/* ========================================================================= */ -int ZEXPORT deflateInit2_(strm, level, method, windowBits, memLevel, strategy, - version, stream_size) - z_streamp strm; - int level; - int method; - int windowBits; - int memLevel; - int strategy; - const char *version; - int stream_size; -{ - deflate_state *s; - int wrap = 1; - static const char my_version[] = ZLIB_VERSION; - - ushf *overlay; - /* We overlay pending_buf and d_buf+l_buf. This works since the average - * output size for (length,distance) codes is <= 24 bits. - */ - - if (version == Z_NULL || version[0] != my_version[0] || - stream_size != sizeof(z_stream)) { - return Z_VERSION_ERROR; - } - if (strm == Z_NULL) return Z_STREAM_ERROR; - - strm->msg = Z_NULL; - if (strm->zalloc == (alloc_func)0) { -#ifdef Z_SOLO - return Z_STREAM_ERROR; -#else - strm->zalloc = zcalloc; - strm->opaque = (voidpf)0; -#endif - } - if (strm->zfree == (free_func)0) -#ifdef Z_SOLO - return Z_STREAM_ERROR; -#else - strm->zfree = zcfree; -#endif - -#ifdef FASTEST - if (level != 0) level = 1; -#else - if (level == Z_DEFAULT_COMPRESSION) level = 6; -#endif - - if (windowBits < 0) { /* suppress zlib wrapper */ - wrap = 0; - windowBits = -windowBits; - } -#ifdef GZIP - else if (windowBits > 15) { - wrap = 2; /* write gzip wrapper instead */ - windowBits -= 16; - } -#endif - if (memLevel < 1 || memLevel > MAX_MEM_LEVEL || method != Z_DEFLATED || - windowBits < 8 || windowBits > 15 || level < 0 || level > 9 || - strategy < 0 || strategy > Z_FIXED || (windowBits == 8 && wrap != 1)) { - return Z_STREAM_ERROR; - } - if (windowBits == 8) windowBits = 9; /* until 256-byte window bug fixed */ - s = (deflate_state *) ZALLOC(strm, 1, sizeof(deflate_state)); - if (s == Z_NULL) return Z_MEM_ERROR; - strm->state = (struct internal_state FAR *)s; - s->strm = strm; - s->status = INIT_STATE; /* to pass state test in deflateReset() */ - - s->wrap = wrap; - s->gzhead = Z_NULL; - s->w_bits = (uInt)windowBits; - s->w_size = 1 << s->w_bits; - s->w_mask = s->w_size - 1; - - s->hash_bits = (uInt)memLevel + 7; - s->hash_size = 1 << s->hash_bits; - s->hash_mask = s->hash_size - 1; - s->hash_shift = ((s->hash_bits+MIN_MATCH-1)/MIN_MATCH); - - s->window = (Bytef *) ZALLOC(strm, s->w_size, 2*sizeof(Byte)); - s->prev = (Posf *) ZALLOC(strm, s->w_size, sizeof(Pos)); - s->head = (Posf *) ZALLOC(strm, s->hash_size, sizeof(Pos)); - - s->high_water = 0; /* nothing written to s->window yet */ - - s->lit_bufsize = 1 << (memLevel + 6); /* 16K elements by default */ - - overlay = (ushf *) ZALLOC(strm, s->lit_bufsize, sizeof(ush)+2); - s->pending_buf = (uchf *) overlay; - s->pending_buf_size = (ulg)s->lit_bufsize * (sizeof(ush)+2L); - - if (s->window == Z_NULL || s->prev == Z_NULL || s->head == Z_NULL || - s->pending_buf == Z_NULL) { - s->status = FINISH_STATE; - strm->msg = ERR_MSG(Z_MEM_ERROR); - deflateEnd (strm); - return Z_MEM_ERROR; - } - s->d_buf = overlay + s->lit_bufsize/sizeof(ush); - s->l_buf = s->pending_buf + (1+sizeof(ush))*s->lit_bufsize; - - s->level = level; - s->strategy = strategy; - s->method = (Byte)method; - - return deflateReset(strm); -} - -/* ========================================================================= - * Check for a valid deflate stream state. Return 0 if ok, 1 if not. - */ -local int deflateStateCheck (strm) - z_streamp strm; -{ - deflate_state *s; - if (strm == Z_NULL || - strm->zalloc == (alloc_func)0 || strm->zfree == (free_func)0) - return 1; - s = strm->state; - if (s == Z_NULL || s->strm != strm || (s->status != INIT_STATE && -#ifdef GZIP - s->status != GZIP_STATE && -#endif - s->status != EXTRA_STATE && - s->status != NAME_STATE && - s->status != COMMENT_STATE && - s->status != HCRC_STATE && - s->status != BUSY_STATE && - s->status != FINISH_STATE)) - return 1; - return 0; -} - -/* ========================================================================= */ -int ZEXPORT deflateSetDictionary (strm, dictionary, dictLength) - z_streamp strm; - const Bytef *dictionary; - uInt dictLength; -{ - deflate_state *s; - uInt str, n; - int wrap; - unsigned avail; - z_const unsigned char *next; - - if (deflateStateCheck(strm) || dictionary == Z_NULL) - return Z_STREAM_ERROR; - s = strm->state; - wrap = s->wrap; - if (wrap == 2 || (wrap == 1 && s->status != INIT_STATE) || s->lookahead) - return Z_STREAM_ERROR; - - /* when using zlib wrappers, compute Adler-32 for provided dictionary */ - if (wrap == 1) - strm->adler = adler32(strm->adler, dictionary, dictLength); - s->wrap = 0; /* avoid computing Adler-32 in read_buf */ - - /* if dictionary would fill window, just replace the history */ - if (dictLength >= s->w_size) { - if (wrap == 0) { /* already empty otherwise */ - CLEAR_HASH(s); - s->strstart = 0; - s->block_start = 0L; - s->insert = 0; - } - dictionary += dictLength - s->w_size; /* use the tail */ - dictLength = s->w_size; - } - - /* insert dictionary into window and hash */ - avail = strm->avail_in; - next = strm->next_in; - strm->avail_in = dictLength; - strm->next_in = (z_const Bytef *)dictionary; - fill_window(s); - while (s->lookahead >= MIN_MATCH) { - str = s->strstart; - n = s->lookahead - (MIN_MATCH-1); - do { - UPDATE_HASH(s, s->ins_h, s->window[str + MIN_MATCH-1]); -#ifndef FASTEST - s->prev[str & s->w_mask] = s->head[s->ins_h]; -#endif - s->head[s->ins_h] = (Pos)str; - str++; - } while (--n); - s->strstart = str; - s->lookahead = MIN_MATCH-1; - fill_window(s); - } - s->strstart += s->lookahead; - s->block_start = (long)s->strstart; - s->insert = s->lookahead; - s->lookahead = 0; - s->match_length = s->prev_length = MIN_MATCH-1; - s->match_available = 0; - strm->next_in = next; - strm->avail_in = avail; - s->wrap = wrap; - return Z_OK; -} - -/* ========================================================================= */ -int ZEXPORT deflateGetDictionary (strm, dictionary, dictLength) - z_streamp strm; - Bytef *dictionary; - uInt *dictLength; -{ - deflate_state *s; - uInt len; - - if (deflateStateCheck(strm)) - return Z_STREAM_ERROR; - s = strm->state; - len = s->strstart + s->lookahead; - if (len > s->w_size) - len = s->w_size; - if (dictionary != Z_NULL && len) - zmemcpy(dictionary, s->window + s->strstart + s->lookahead - len, len); - if (dictLength != Z_NULL) - *dictLength = len; - return Z_OK; -} - -/* ========================================================================= */ -int ZEXPORT deflateResetKeep (strm) - z_streamp strm; -{ - deflate_state *s; - - if (deflateStateCheck(strm)) { - return Z_STREAM_ERROR; - } - - strm->total_in = strm->total_out = 0; - strm->msg = Z_NULL; /* use zfree if we ever allocate msg dynamically */ - strm->data_type = Z_UNKNOWN; - - s = (deflate_state *)strm->state; - s->pending = 0; - s->pending_out = s->pending_buf; - - if (s->wrap < 0) { - s->wrap = -s->wrap; /* was made negative by deflate(..., Z_FINISH); */ - } - s->status = -#ifdef GZIP - s->wrap == 2 ? GZIP_STATE : -#endif - s->wrap ? INIT_STATE : BUSY_STATE; - strm->adler = -#ifdef GZIP - s->wrap == 2 ? crc32(0L, Z_NULL, 0) : -#endif - adler32(0L, Z_NULL, 0); - s->last_flush = Z_NO_FLUSH; - - _tr_init(s); - - return Z_OK; -} - -/* ========================================================================= */ -int ZEXPORT deflateReset (strm) - z_streamp strm; -{ - int ret; - - ret = deflateResetKeep(strm); - if (ret == Z_OK) - lm_init(strm->state); - return ret; -} - -/* ========================================================================= */ -int ZEXPORT deflateSetHeader (strm, head) - z_streamp strm; - gz_headerp head; -{ - if (deflateStateCheck(strm) || strm->state->wrap != 2) - return Z_STREAM_ERROR; - strm->state->gzhead = head; - return Z_OK; -} - -/* ========================================================================= */ -int ZEXPORT deflatePending (strm, pending, bits) - unsigned *pending; - int *bits; - z_streamp strm; -{ - if (deflateStateCheck(strm)) return Z_STREAM_ERROR; - if (pending != Z_NULL) - *pending = strm->state->pending; - if (bits != Z_NULL) - *bits = strm->state->bi_valid; - return Z_OK; -} - -/* ========================================================================= */ -int ZEXPORT deflatePrime (strm, bits, value) - z_streamp strm; - int bits; - int value; -{ - deflate_state *s; - int put; - - if (deflateStateCheck(strm)) return Z_STREAM_ERROR; - s = strm->state; - if ((Bytef *)(s->d_buf) < s->pending_out + ((Buf_size + 7) >> 3)) - return Z_BUF_ERROR; - do { - put = Buf_size - s->bi_valid; - if (put > bits) - put = bits; - s->bi_buf |= (ush)((value & ((1 << put) - 1)) << s->bi_valid); - s->bi_valid += put; - _tr_flush_bits(s); - value >>= put; - bits -= put; - } while (bits); - return Z_OK; -} - -/* ========================================================================= */ -int ZEXPORT deflateParams(strm, level, strategy) - z_streamp strm; - int level; - int strategy; -{ - deflate_state *s; - compress_func func; - - if (deflateStateCheck(strm)) return Z_STREAM_ERROR; - s = strm->state; - -#ifdef FASTEST - if (level != 0) level = 1; -#else - if (level == Z_DEFAULT_COMPRESSION) level = 6; -#endif - if (level < 0 || level > 9 || strategy < 0 || strategy > Z_FIXED) { - return Z_STREAM_ERROR; - } - func = configuration_table[s->level].func; - - if ((strategy != s->strategy || func != configuration_table[level].func) && - s->high_water) { - /* Flush the last buffer: */ - int err = deflate(strm, Z_BLOCK); - if (err == Z_STREAM_ERROR) - return err; - if (strm->avail_out == 0) - return Z_BUF_ERROR; - } - if (s->level != level) { - if (s->level == 0 && s->matches != 0) { - if (s->matches == 1) - slide_hash(s); - else - CLEAR_HASH(s); - s->matches = 0; - } - s->level = level; - s->max_lazy_match = configuration_table[level].max_lazy; - s->good_match = configuration_table[level].good_length; - s->nice_match = configuration_table[level].nice_length; - s->max_chain_length = configuration_table[level].max_chain; - } - s->strategy = strategy; - return Z_OK; -} - -/* ========================================================================= */ -int ZEXPORT deflateTune(strm, good_length, max_lazy, nice_length, max_chain) - z_streamp strm; - int good_length; - int max_lazy; - int nice_length; - int max_chain; -{ - deflate_state *s; - - if (deflateStateCheck(strm)) return Z_STREAM_ERROR; - s = strm->state; - s->good_match = (uInt)good_length; - s->max_lazy_match = (uInt)max_lazy; - s->nice_match = nice_length; - s->max_chain_length = (uInt)max_chain; - return Z_OK; -} - -/* ========================================================================= - * For the default windowBits of 15 and memLevel of 8, this function returns - * a close to exact, as well as small, upper bound on the compressed size. - * They are coded as constants here for a reason--if the #define's are - * changed, then this function needs to be changed as well. The return - * value for 15 and 8 only works for those exact settings. - * - * For any setting other than those defaults for windowBits and memLevel, - * the value returned is a conservative worst case for the maximum expansion - * resulting from using fixed blocks instead of stored blocks, which deflate - * can emit on compressed data for some combinations of the parameters. - * - * This function could be more sophisticated to provide closer upper bounds for - * every combination of windowBits and memLevel. But even the conservative - * upper bound of about 14% expansion does not seem onerous for output buffer - * allocation. - */ -uLong ZEXPORT deflateBound(strm, sourceLen) - z_streamp strm; - uLong sourceLen; -{ - deflate_state *s; - uLong complen, wraplen; - - /* conservative upper bound for compressed data */ - complen = sourceLen + - ((sourceLen + 7) >> 3) + ((sourceLen + 63) >> 6) + 5; - - /* if can't get parameters, return conservative bound plus zlib wrapper */ - if (deflateStateCheck(strm)) - return complen + 6; - - /* compute wrapper length */ - s = strm->state; - switch (s->wrap) { - case 0: /* raw deflate */ - wraplen = 0; - break; - case 1: /* zlib wrapper */ - wraplen = 6 + (s->strstart ? 4 : 0); - break; -#ifdef GZIP - case 2: /* gzip wrapper */ - wraplen = 18; - if (s->gzhead != Z_NULL) { /* user-supplied gzip header */ - Bytef *str; - if (s->gzhead->extra != Z_NULL) - wraplen += 2 + s->gzhead->extra_len; - str = s->gzhead->name; - if (str != Z_NULL) - do { - wraplen++; - } while (*str++); - str = s->gzhead->comment; - if (str != Z_NULL) - do { - wraplen++; - } while (*str++); - if (s->gzhead->hcrc) - wraplen += 2; - } - break; -#endif - default: /* for compiler happiness */ - wraplen = 6; - } - - /* if not default parameters, return conservative bound */ - if (s->w_bits != 15 || s->hash_bits != 8 + 7) - return complen + wraplen; - - /* default settings: return tight bound for that case */ - return sourceLen + (sourceLen >> 12) + (sourceLen >> 14) + - (sourceLen >> 25) + 13 - 6 + wraplen; -} - -/* ========================================================================= - * Put a short in the pending buffer. The 16-bit value is put in MSB order. - * IN assertion: the stream state is correct and there is enough room in - * pending_buf. - */ -local void putShortMSB (s, b) - deflate_state *s; - uInt b; -{ - put_byte(s, (Byte)(b >> 8)); - put_byte(s, (Byte)(b & 0xff)); -} - -/* ========================================================================= - * Flush as much pending output as possible. All deflate() output, except for - * some deflate_stored() output, goes through this function so some - * applications may wish to modify it to avoid allocating a large - * strm->next_out buffer and copying into it. (See also read_buf()). - */ -local void flush_pending(strm) - z_streamp strm; -{ - unsigned len; - deflate_state *s = strm->state; - - _tr_flush_bits(s); - len = s->pending; - if (len > strm->avail_out) len = strm->avail_out; - if (len == 0) return; - - zmemcpy(strm->next_out, s->pending_out, len); - strm->next_out += len; - s->pending_out += len; - strm->total_out += len; - strm->avail_out -= len; - s->pending -= len; - if (s->pending == 0) { - s->pending_out = s->pending_buf; - } -} - -/* =========================================================================== - * Update the header CRC with the bytes s->pending_buf[beg..s->pending - 1]. - */ -#define HCRC_UPDATE(beg) \ - do { \ - if (s->gzhead->hcrc && s->pending > (beg)) \ - strm->adler = crc32(strm->adler, s->pending_buf + (beg), \ - s->pending - (beg)); \ - } while (0) - -/* ========================================================================= */ -int ZEXPORT deflate (strm, flush) - z_streamp strm; - int flush; -{ - int old_flush; /* value of flush param for previous deflate call */ - deflate_state *s; - - if (deflateStateCheck(strm) || flush > Z_BLOCK || flush < 0) { - return Z_STREAM_ERROR; - } - s = strm->state; - - if (strm->next_out == Z_NULL || - (strm->avail_in != 0 && strm->next_in == Z_NULL) || - (s->status == FINISH_STATE && flush != Z_FINISH)) { - ERR_RETURN(strm, Z_STREAM_ERROR); - } - if (strm->avail_out == 0) ERR_RETURN(strm, Z_BUF_ERROR); - - old_flush = s->last_flush; - s->last_flush = flush; - - /* Flush as much pending output as possible */ - if (s->pending != 0) { - flush_pending(strm); - if (strm->avail_out == 0) { - /* Since avail_out is 0, deflate will be called again with - * more output space, but possibly with both pending and - * avail_in equal to zero. There won't be anything to do, - * but this is not an error situation so make sure we - * return OK instead of BUF_ERROR at next call of deflate: - */ - s->last_flush = -1; - return Z_OK; - } - - /* Make sure there is something to do and avoid duplicate consecutive - * flushes. For repeated and useless calls with Z_FINISH, we keep - * returning Z_STREAM_END instead of Z_BUF_ERROR. - */ - } else if (strm->avail_in == 0 && RANK(flush) <= RANK(old_flush) && - flush != Z_FINISH) { - ERR_RETURN(strm, Z_BUF_ERROR); - } - - /* User must not provide more input after the first FINISH: */ - if (s->status == FINISH_STATE && strm->avail_in != 0) { - ERR_RETURN(strm, Z_BUF_ERROR); - } - - /* Write the header */ - if (s->status == INIT_STATE) { - /* zlib header */ - uInt header = (Z_DEFLATED + ((s->w_bits-8)<<4)) << 8; - uInt level_flags; - - if (s->strategy >= Z_HUFFMAN_ONLY || s->level < 2) - level_flags = 0; - else if (s->level < 6) - level_flags = 1; - else if (s->level == 6) - level_flags = 2; - else - level_flags = 3; - header |= (level_flags << 6); - if (s->strstart != 0) header |= PRESET_DICT; - header += 31 - (header % 31); - - putShortMSB(s, header); - - /* Save the adler32 of the preset dictionary: */ - if (s->strstart != 0) { - putShortMSB(s, (uInt)(strm->adler >> 16)); - putShortMSB(s, (uInt)(strm->adler & 0xffff)); - } - strm->adler = adler32(0L, Z_NULL, 0); - s->status = BUSY_STATE; - - /* Compression must start with an empty pending buffer */ - flush_pending(strm); - if (s->pending != 0) { - s->last_flush = -1; - return Z_OK; - } - } -#ifdef GZIP - if (s->status == GZIP_STATE) { - /* gzip header */ - strm->adler = crc32(0L, Z_NULL, 0); - put_byte(s, 31); - put_byte(s, 139); - put_byte(s, 8); - if (s->gzhead == Z_NULL) { - put_byte(s, 0); - put_byte(s, 0); - put_byte(s, 0); - put_byte(s, 0); - put_byte(s, 0); - put_byte(s, s->level == 9 ? 2 : - (s->strategy >= Z_HUFFMAN_ONLY || s->level < 2 ? - 4 : 0)); - put_byte(s, OS_CODE); - s->status = BUSY_STATE; - - /* Compression must start with an empty pending buffer */ - flush_pending(strm); - if (s->pending != 0) { - s->last_flush = -1; - return Z_OK; - } - } - else { - put_byte(s, (s->gzhead->text ? 1 : 0) + - (s->gzhead->hcrc ? 2 : 0) + - (s->gzhead->extra == Z_NULL ? 0 : 4) + - (s->gzhead->name == Z_NULL ? 0 : 8) + - (s->gzhead->comment == Z_NULL ? 0 : 16) - ); - put_byte(s, (Byte)(s->gzhead->time & 0xff)); - put_byte(s, (Byte)((s->gzhead->time >> 8) & 0xff)); - put_byte(s, (Byte)((s->gzhead->time >> 16) & 0xff)); - put_byte(s, (Byte)((s->gzhead->time >> 24) & 0xff)); - put_byte(s, s->level == 9 ? 2 : - (s->strategy >= Z_HUFFMAN_ONLY || s->level < 2 ? - 4 : 0)); - put_byte(s, s->gzhead->os & 0xff); - if (s->gzhead->extra != Z_NULL) { - put_byte(s, s->gzhead->extra_len & 0xff); - put_byte(s, (s->gzhead->extra_len >> 8) & 0xff); - } - if (s->gzhead->hcrc) - strm->adler = crc32(strm->adler, s->pending_buf, - s->pending); - s->gzindex = 0; - s->status = EXTRA_STATE; - } - } - if (s->status == EXTRA_STATE) { - if (s->gzhead->extra != Z_NULL) { - ulg beg = s->pending; /* start of bytes to update crc */ - uInt left = (s->gzhead->extra_len & 0xffff) - s->gzindex; - while (s->pending + left > s->pending_buf_size) { - uInt copy = s->pending_buf_size - s->pending; - zmemcpy(s->pending_buf + s->pending, - s->gzhead->extra + s->gzindex, copy); - s->pending = s->pending_buf_size; - HCRC_UPDATE(beg); - s->gzindex += copy; - flush_pending(strm); - if (s->pending != 0) { - s->last_flush = -1; - return Z_OK; - } - beg = 0; - left -= copy; - } - zmemcpy(s->pending_buf + s->pending, - s->gzhead->extra + s->gzindex, left); - s->pending += left; - HCRC_UPDATE(beg); - s->gzindex = 0; - } - s->status = NAME_STATE; - } - if (s->status == NAME_STATE) { - if (s->gzhead->name != Z_NULL) { - ulg beg = s->pending; /* start of bytes to update crc */ - int val; - do { - if (s->pending == s->pending_buf_size) { - HCRC_UPDATE(beg); - flush_pending(strm); - if (s->pending != 0) { - s->last_flush = -1; - return Z_OK; - } - beg = 0; - } - val = s->gzhead->name[s->gzindex++]; - put_byte(s, val); - } while (val != 0); - HCRC_UPDATE(beg); - s->gzindex = 0; - } - s->status = COMMENT_STATE; - } - if (s->status == COMMENT_STATE) { - if (s->gzhead->comment != Z_NULL) { - ulg beg = s->pending; /* start of bytes to update crc */ - int val; - do { - if (s->pending == s->pending_buf_size) { - HCRC_UPDATE(beg); - flush_pending(strm); - if (s->pending != 0) { - s->last_flush = -1; - return Z_OK; - } - beg = 0; - } - val = s->gzhead->comment[s->gzindex++]; - put_byte(s, val); - } while (val != 0); - HCRC_UPDATE(beg); - } - s->status = HCRC_STATE; - } - if (s->status == HCRC_STATE) { - if (s->gzhead->hcrc) { - if (s->pending + 2 > s->pending_buf_size) { - flush_pending(strm); - if (s->pending != 0) { - s->last_flush = -1; - return Z_OK; - } - } - put_byte(s, (Byte)(strm->adler & 0xff)); - put_byte(s, (Byte)((strm->adler >> 8) & 0xff)); - strm->adler = crc32(0L, Z_NULL, 0); - } - s->status = BUSY_STATE; - - /* Compression must start with an empty pending buffer */ - flush_pending(strm); - if (s->pending != 0) { - s->last_flush = -1; - return Z_OK; - } - } -#endif - - /* Start a new block or continue the current one. - */ - if (strm->avail_in != 0 || s->lookahead != 0 || - (flush != Z_NO_FLUSH && s->status != FINISH_STATE)) { - block_state bstate; - - bstate = s->level == 0 ? deflate_stored(s, flush) : - s->strategy == Z_HUFFMAN_ONLY ? deflate_huff(s, flush) : - s->strategy == Z_RLE ? deflate_rle(s, flush) : - (*(configuration_table[s->level].func))(s, flush); - - if (bstate == finish_started || bstate == finish_done) { - s->status = FINISH_STATE; - } - if (bstate == need_more || bstate == finish_started) { - if (strm->avail_out == 0) { - s->last_flush = -1; /* avoid BUF_ERROR next call, see above */ - } - return Z_OK; - /* If flush != Z_NO_FLUSH && avail_out == 0, the next call - * of deflate should use the same flush parameter to make sure - * that the flush is complete. So we don't have to output an - * empty block here, this will be done at next call. This also - * ensures that for a very small output buffer, we emit at most - * one empty block. - */ - } - if (bstate == block_done) { - if (flush == Z_PARTIAL_FLUSH) { - _tr_align(s); - } else if (flush != Z_BLOCK) { /* FULL_FLUSH or SYNC_FLUSH */ - _tr_stored_block(s, (char*)0, 0L, 0); - /* For a full flush, this empty block will be recognized - * as a special marker by inflate_sync(). - */ - if (flush == Z_FULL_FLUSH) { - CLEAR_HASH(s); /* forget history */ - if (s->lookahead == 0) { - s->strstart = 0; - s->block_start = 0L; - s->insert = 0; - } - } - } - flush_pending(strm); - if (strm->avail_out == 0) { - s->last_flush = -1; /* avoid BUF_ERROR at next call, see above */ - return Z_OK; - } - } - } - - if (flush != Z_FINISH) return Z_OK; - if (s->wrap <= 0) return Z_STREAM_END; - - /* Write the trailer */ -#ifdef GZIP - if (s->wrap == 2) { - put_byte(s, (Byte)(strm->adler & 0xff)); - put_byte(s, (Byte)((strm->adler >> 8) & 0xff)); - put_byte(s, (Byte)((strm->adler >> 16) & 0xff)); - put_byte(s, (Byte)((strm->adler >> 24) & 0xff)); - put_byte(s, (Byte)(strm->total_in & 0xff)); - put_byte(s, (Byte)((strm->total_in >> 8) & 0xff)); - put_byte(s, (Byte)((strm->total_in >> 16) & 0xff)); - put_byte(s, (Byte)((strm->total_in >> 24) & 0xff)); - } - else -#endif - { - putShortMSB(s, (uInt)(strm->adler >> 16)); - putShortMSB(s, (uInt)(strm->adler & 0xffff)); - } - flush_pending(strm); - /* If avail_out is zero, the application will call deflate again - * to flush the rest. - */ - if (s->wrap > 0) s->wrap = -s->wrap; /* write the trailer only once! */ - return s->pending != 0 ? Z_OK : Z_STREAM_END; -} - -/* ========================================================================= */ -int ZEXPORT deflateEnd (strm) - z_streamp strm; -{ - int status; - - if (deflateStateCheck(strm)) return Z_STREAM_ERROR; - - status = strm->state->status; - - /* Deallocate in reverse order of allocations: */ - TRY_FREE(strm, strm->state->pending_buf); - TRY_FREE(strm, strm->state->head); - TRY_FREE(strm, strm->state->prev); - TRY_FREE(strm, strm->state->window); - - ZFREE(strm, strm->state); - strm->state = Z_NULL; - - return status == BUSY_STATE ? Z_DATA_ERROR : Z_OK; -} - -/* ========================================================================= - * Copy the source state to the destination state. - * To simplify the source, this is not supported for 16-bit MSDOS (which - * doesn't have enough memory anyway to duplicate compression states). - */ -int ZEXPORT deflateCopy (dest, source) - z_streamp dest; - z_streamp source; -{ -#ifdef MAXSEG_64K - return Z_STREAM_ERROR; -#else - deflate_state *ds; - deflate_state *ss; - ushf *overlay; - - - if (deflateStateCheck(source) || dest == Z_NULL) { - return Z_STREAM_ERROR; - } - - ss = source->state; - - zmemcpy((voidpf)dest, (voidpf)source, sizeof(z_stream)); - - ds = (deflate_state *) ZALLOC(dest, 1, sizeof(deflate_state)); - if (ds == Z_NULL) return Z_MEM_ERROR; - dest->state = (struct internal_state FAR *) ds; - zmemcpy((voidpf)ds, (voidpf)ss, sizeof(deflate_state)); - ds->strm = dest; - - ds->window = (Bytef *) ZALLOC(dest, ds->w_size, 2*sizeof(Byte)); - ds->prev = (Posf *) ZALLOC(dest, ds->w_size, sizeof(Pos)); - ds->head = (Posf *) ZALLOC(dest, ds->hash_size, sizeof(Pos)); - overlay = (ushf *) ZALLOC(dest, ds->lit_bufsize, sizeof(ush)+2); - ds->pending_buf = (uchf *) overlay; - - if (ds->window == Z_NULL || ds->prev == Z_NULL || ds->head == Z_NULL || - ds->pending_buf == Z_NULL) { - deflateEnd (dest); - return Z_MEM_ERROR; - } - /* following zmemcpy do not work for 16-bit MSDOS */ - zmemcpy(ds->window, ss->window, ds->w_size * 2 * sizeof(Byte)); - zmemcpy((voidpf)ds->prev, (voidpf)ss->prev, ds->w_size * sizeof(Pos)); - zmemcpy((voidpf)ds->head, (voidpf)ss->head, ds->hash_size * sizeof(Pos)); - zmemcpy(ds->pending_buf, ss->pending_buf, (uInt)ds->pending_buf_size); - - ds->pending_out = ds->pending_buf + (ss->pending_out - ss->pending_buf); - ds->d_buf = overlay + ds->lit_bufsize/sizeof(ush); - ds->l_buf = ds->pending_buf + (1+sizeof(ush))*ds->lit_bufsize; - - ds->l_desc.dyn_tree = ds->dyn_ltree; - ds->d_desc.dyn_tree = ds->dyn_dtree; - ds->bl_desc.dyn_tree = ds->bl_tree; - - return Z_OK; -#endif /* MAXSEG_64K */ -} - -/* =========================================================================== - * Read a new buffer from the current input stream, update the adler32 - * and total number of bytes read. All deflate() input goes through - * this function so some applications may wish to modify it to avoid - * allocating a large strm->next_in buffer and copying from it. - * (See also flush_pending()). - */ -local unsigned read_buf(strm, buf, size) - z_streamp strm; - Bytef *buf; - unsigned size; -{ - unsigned len = strm->avail_in; - - if (len > size) len = size; - if (len == 0) return 0; - - strm->avail_in -= len; - - zmemcpy(buf, strm->next_in, len); - if (strm->state->wrap == 1) { - strm->adler = adler32(strm->adler, buf, len); - } -#ifdef GZIP - else if (strm->state->wrap == 2) { - strm->adler = crc32(strm->adler, buf, len); - } -#endif - strm->next_in += len; - strm->total_in += len; - - return len; -} - -/* =========================================================================== - * Initialize the "longest match" routines for a new zlib stream - */ -local void lm_init (s) - deflate_state *s; -{ - s->window_size = (ulg)2L*s->w_size; - - CLEAR_HASH(s); - - /* Set the default configuration parameters: - */ - s->max_lazy_match = configuration_table[s->level].max_lazy; - s->good_match = configuration_table[s->level].good_length; - s->nice_match = configuration_table[s->level].nice_length; - s->max_chain_length = configuration_table[s->level].max_chain; - - s->strstart = 0; - s->block_start = 0L; - s->lookahead = 0; - s->insert = 0; - s->match_length = s->prev_length = MIN_MATCH-1; - s->match_available = 0; - s->ins_h = 0; -#ifndef FASTEST -#ifdef ASMV - match_init(); /* initialize the asm code */ -#endif -#endif -} - -#ifndef FASTEST -/* =========================================================================== - * Set match_start to the longest match starting at the given string and - * return its length. Matches shorter or equal to prev_length are discarded, - * in which case the result is equal to prev_length and match_start is - * garbage. - * IN assertions: cur_match is the head of the hash chain for the current - * string (strstart) and its distance is <= MAX_DIST, and prev_length >= 1 - * OUT assertion: the match length is not greater than s->lookahead. - */ -#ifndef ASMV -/* For 80x86 and 680x0, an optimized version will be provided in match.asm or - * match.S. The code will be functionally equivalent. - */ -local uInt longest_match(s, cur_match) - deflate_state *s; - IPos cur_match; /* current match */ -{ - unsigned chain_length = s->max_chain_length;/* max hash chain length */ - register Bytef *scan = s->window + s->strstart; /* current string */ - register Bytef *match; /* matched string */ - register int len; /* length of current match */ - int best_len = (int)s->prev_length; /* best match length so far */ - int nice_match = s->nice_match; /* stop if match long enough */ - IPos limit = s->strstart > (IPos)MAX_DIST(s) ? - s->strstart - (IPos)MAX_DIST(s) : NIL; - /* Stop when cur_match becomes <= limit. To simplify the code, - * we prevent matches with the string of window index 0. - */ - Posf *prev = s->prev; - uInt wmask = s->w_mask; - -#ifdef UNALIGNED_OK - /* Compare two bytes at a time. Note: this is not always beneficial. - * Try with and without -DUNALIGNED_OK to check. - */ - register Bytef *strend = s->window + s->strstart + MAX_MATCH - 1; - register ush scan_start = *(ushf*)scan; - register ush scan_end = *(ushf*)(scan+best_len-1); -#else - register Bytef *strend = s->window + s->strstart + MAX_MATCH; - register Byte scan_end1 = scan[best_len-1]; - register Byte scan_end = scan[best_len]; -#endif - - /* The code is optimized for HASH_BITS >= 8 and MAX_MATCH-2 multiple of 16. - * It is easy to get rid of this optimization if necessary. - */ - Assert(s->hash_bits >= 8 && MAX_MATCH == 258, "Code too clever"); - - /* Do not waste too much time if we already have a good match: */ - if (s->prev_length >= s->good_match) { - chain_length >>= 2; - } - /* Do not look for matches beyond the end of the input. This is necessary - * to make deflate deterministic. - */ - if ((uInt)nice_match > s->lookahead) nice_match = (int)s->lookahead; - - Assert((ulg)s->strstart <= s->window_size-MIN_LOOKAHEAD, "need lookahead"); - - do { - Assert(cur_match < s->strstart, "no future"); - match = s->window + cur_match; - - /* Skip to next match if the match length cannot increase - * or if the match length is less than 2. Note that the checks below - * for insufficient lookahead only occur occasionally for performance - * reasons. Therefore uninitialized memory will be accessed, and - * conditional jumps will be made that depend on those values. - * However the length of the match is limited to the lookahead, so - * the output of deflate is not affected by the uninitialized values. - */ -#if (defined(UNALIGNED_OK) && MAX_MATCH == 258) - /* This code assumes sizeof(unsigned short) == 2. Do not use - * UNALIGNED_OK if your compiler uses a different size. - */ - if (*(ushf*)(match+best_len-1) != scan_end || - *(ushf*)match != scan_start) continue; - - /* It is not necessary to compare scan[2] and match[2] since they are - * always equal when the other bytes match, given that the hash keys - * are equal and that HASH_BITS >= 8. Compare 2 bytes at a time at - * strstart+3, +5, ... up to strstart+257. We check for insufficient - * lookahead only every 4th comparison; the 128th check will be made - * at strstart+257. If MAX_MATCH-2 is not a multiple of 8, it is - * necessary to put more guard bytes at the end of the window, or - * to check more often for insufficient lookahead. - */ - Assert(scan[2] == match[2], "scan[2]?"); - scan++, match++; - do { - } while (*(ushf*)(scan+=2) == *(ushf*)(match+=2) && - *(ushf*)(scan+=2) == *(ushf*)(match+=2) && - *(ushf*)(scan+=2) == *(ushf*)(match+=2) && - *(ushf*)(scan+=2) == *(ushf*)(match+=2) && - scan < strend); - /* The funny "do {}" generates better code on most compilers */ - - /* Here, scan <= window+strstart+257 */ - Assert(scan <= s->window+(unsigned)(s->window_size-1), "wild scan"); - if (*scan == *match) scan++; - - len = (MAX_MATCH - 1) - (int)(strend-scan); - scan = strend - (MAX_MATCH-1); - -#else /* UNALIGNED_OK */ - - if (match[best_len] != scan_end || - match[best_len-1] != scan_end1 || - *match != *scan || - *++match != scan[1]) continue; - - /* The check at best_len-1 can be removed because it will be made - * again later. (This heuristic is not always a win.) - * It is not necessary to compare scan[2] and match[2] since they - * are always equal when the other bytes match, given that - * the hash keys are equal and that HASH_BITS >= 8. - */ - scan += 2, match++; - Assert(*scan == *match, "match[2]?"); - - /* We check for insufficient lookahead only every 8th comparison; - * the 256th check will be made at strstart+258. - */ - do { - } while (*++scan == *++match && *++scan == *++match && - *++scan == *++match && *++scan == *++match && - *++scan == *++match && *++scan == *++match && - *++scan == *++match && *++scan == *++match && - scan < strend); - - Assert(scan <= s->window+(unsigned)(s->window_size-1), "wild scan"); - - len = MAX_MATCH - (int)(strend - scan); - scan = strend - MAX_MATCH; - -#endif /* UNALIGNED_OK */ - - if (len > best_len) { - s->match_start = cur_match; - best_len = len; - if (len >= nice_match) break; -#ifdef UNALIGNED_OK - scan_end = *(ushf*)(scan+best_len-1); -#else - scan_end1 = scan[best_len-1]; - scan_end = scan[best_len]; -#endif - } - } while ((cur_match = prev[cur_match & wmask]) > limit - && --chain_length != 0); - - if ((uInt)best_len <= s->lookahead) return (uInt)best_len; - return s->lookahead; -} -#endif /* ASMV */ - -#else /* FASTEST */ - -/* --------------------------------------------------------------------------- - * Optimized version for FASTEST only - */ -local uInt longest_match(s, cur_match) - deflate_state *s; - IPos cur_match; /* current match */ -{ - register Bytef *scan = s->window + s->strstart; /* current string */ - register Bytef *match; /* matched string */ - register int len; /* length of current match */ - register Bytef *strend = s->window + s->strstart + MAX_MATCH; - - /* The code is optimized for HASH_BITS >= 8 and MAX_MATCH-2 multiple of 16. - * It is easy to get rid of this optimization if necessary. - */ - Assert(s->hash_bits >= 8 && MAX_MATCH == 258, "Code too clever"); - - Assert((ulg)s->strstart <= s->window_size-MIN_LOOKAHEAD, "need lookahead"); - - Assert(cur_match < s->strstart, "no future"); - - match = s->window + cur_match; - - /* Return failure if the match length is less than 2: - */ - if (match[0] != scan[0] || match[1] != scan[1]) return MIN_MATCH-1; - - /* The check at best_len-1 can be removed because it will be made - * again later. (This heuristic is not always a win.) - * It is not necessary to compare scan[2] and match[2] since they - * are always equal when the other bytes match, given that - * the hash keys are equal and that HASH_BITS >= 8. - */ - scan += 2, match += 2; - Assert(*scan == *match, "match[2]?"); - - /* We check for insufficient lookahead only every 8th comparison; - * the 256th check will be made at strstart+258. - */ - do { - } while (*++scan == *++match && *++scan == *++match && - *++scan == *++match && *++scan == *++match && - *++scan == *++match && *++scan == *++match && - *++scan == *++match && *++scan == *++match && - scan < strend); - - Assert(scan <= s->window+(unsigned)(s->window_size-1), "wild scan"); - - len = MAX_MATCH - (int)(strend - scan); - - if (len < MIN_MATCH) return MIN_MATCH - 1; - - s->match_start = cur_match; - return (uInt)len <= s->lookahead ? (uInt)len : s->lookahead; -} - -#endif /* FASTEST */ - -#ifdef ZLIB_DEBUG - -#define EQUAL 0 -/* result of memcmp for equal strings */ - -/* =========================================================================== - * Check that the match at match_start is indeed a match. - */ -local void check_match(s, start, match, length) - deflate_state *s; - IPos start, match; - int length; -{ - /* check that the match is indeed a match */ - if (zmemcmp(s->window + match, - s->window + start, length) != EQUAL) { - fprintf(stderr, " start %u, match %u, length %d\n", - start, match, length); - do { - fprintf(stderr, "%c%c", s->window[match++], s->window[start++]); - } while (--length != 0); - z_error("invalid match"); - } - if (z_verbose > 1) { - fprintf(stderr,"\\[%d,%d]", start-match, length); - do { putc(s->window[start++], stderr); } while (--length != 0); - } -} -#else -# define check_match(s, start, match, length) -#endif /* ZLIB_DEBUG */ - -/* =========================================================================== - * Fill the window when the lookahead becomes insufficient. - * Updates strstart and lookahead. - * - * IN assertion: lookahead < MIN_LOOKAHEAD - * OUT assertions: strstart <= window_size-MIN_LOOKAHEAD - * At least one byte has been read, or avail_in == 0; reads are - * performed for at least two bytes (required for the zip translate_eol - * option -- not supported here). - */ -local void fill_window(s) - deflate_state *s; -{ - unsigned n; - unsigned more; /* Amount of free space at the end of the window. */ - uInt wsize = s->w_size; - - Assert(s->lookahead < MIN_LOOKAHEAD, "already enough lookahead"); - - do { - more = (unsigned)(s->window_size -(ulg)s->lookahead -(ulg)s->strstart); - - /* Deal with !@#$% 64K limit: */ - if (sizeof(int) <= 2) { - if (more == 0 && s->strstart == 0 && s->lookahead == 0) { - more = wsize; - - } else if (more == (unsigned)(-1)) { - /* Very unlikely, but possible on 16 bit machine if - * strstart == 0 && lookahead == 1 (input done a byte at time) - */ - more--; - } - } - - /* If the window is almost full and there is insufficient lookahead, - * move the upper half to the lower one to make room in the upper half. - */ - if (s->strstart >= wsize+MAX_DIST(s)) { - - zmemcpy(s->window, s->window+wsize, (unsigned)wsize - more); - s->match_start -= wsize; - s->strstart -= wsize; /* we now have strstart >= MAX_DIST */ - s->block_start -= (long) wsize; - slide_hash(s); - more += wsize; - } - if (s->strm->avail_in == 0) break; - - /* If there was no sliding: - * strstart <= WSIZE+MAX_DIST-1 && lookahead <= MIN_LOOKAHEAD - 1 && - * more == window_size - lookahead - strstart - * => more >= window_size - (MIN_LOOKAHEAD-1 + WSIZE + MAX_DIST-1) - * => more >= window_size - 2*WSIZE + 2 - * In the BIG_MEM or MMAP case (not yet supported), - * window_size == input_size + MIN_LOOKAHEAD && - * strstart + s->lookahead <= input_size => more >= MIN_LOOKAHEAD. - * Otherwise, window_size == 2*WSIZE so more >= 2. - * If there was sliding, more >= WSIZE. So in all cases, more >= 2. - */ - Assert(more >= 2, "more < 2"); - - n = read_buf(s->strm, s->window + s->strstart + s->lookahead, more); - s->lookahead += n; - - /* Initialize the hash value now that we have some input: */ - if (s->lookahead + s->insert >= MIN_MATCH) { - uInt str = s->strstart - s->insert; - s->ins_h = s->window[str]; - UPDATE_HASH(s, s->ins_h, s->window[str + 1]); -#if MIN_MATCH != 3 - Call UPDATE_HASH() MIN_MATCH-3 more times -#endif - while (s->insert) { - UPDATE_HASH(s, s->ins_h, s->window[str + MIN_MATCH-1]); -#ifndef FASTEST - s->prev[str & s->w_mask] = s->head[s->ins_h]; -#endif - s->head[s->ins_h] = (Pos)str; - str++; - s->insert--; - if (s->lookahead + s->insert < MIN_MATCH) - break; - } - } - /* If the whole input has less than MIN_MATCH bytes, ins_h is garbage, - * but this is not important since only literal bytes will be emitted. - */ - - } while (s->lookahead < MIN_LOOKAHEAD && s->strm->avail_in != 0); - - /* If the WIN_INIT bytes after the end of the current data have never been - * written, then zero those bytes in order to avoid memory check reports of - * the use of uninitialized (or uninitialised as Julian writes) bytes by - * the longest match routines. Update the high water mark for the next - * time through here. WIN_INIT is set to MAX_MATCH since the longest match - * routines allow scanning to strstart + MAX_MATCH, ignoring lookahead. - */ - if (s->high_water < s->window_size) { - ulg curr = s->strstart + (ulg)(s->lookahead); - ulg init; - - if (s->high_water < curr) { - /* Previous high water mark below current data -- zero WIN_INIT - * bytes or up to end of window, whichever is less. - */ - init = s->window_size - curr; - if (init > WIN_INIT) - init = WIN_INIT; - zmemzero(s->window + curr, (unsigned)init); - s->high_water = curr + init; - } - else if (s->high_water < (ulg)curr + WIN_INIT) { - /* High water mark at or above current data, but below current data - * plus WIN_INIT -- zero out to current data plus WIN_INIT, or up - * to end of window, whichever is less. - */ - init = (ulg)curr + WIN_INIT - s->high_water; - if (init > s->window_size - s->high_water) - init = s->window_size - s->high_water; - zmemzero(s->window + s->high_water, (unsigned)init); - s->high_water += init; - } - } - - Assert((ulg)s->strstart <= s->window_size - MIN_LOOKAHEAD, - "not enough room for search"); -} - -/* =========================================================================== - * Flush the current block, with given end-of-file flag. - * IN assertion: strstart is set to the end of the current match. - */ -#define FLUSH_BLOCK_ONLY(s, last) { \ - _tr_flush_block(s, (s->block_start >= 0L ? \ - (charf *)&s->window[(unsigned)s->block_start] : \ - (charf *)Z_NULL), \ - (ulg)((long)s->strstart - s->block_start), \ - (last)); \ - s->block_start = s->strstart; \ - flush_pending(s->strm); \ - Tracev((stderr,"[FLUSH]")); \ -} - -/* Same but force premature exit if necessary. */ -#define FLUSH_BLOCK(s, last) { \ - FLUSH_BLOCK_ONLY(s, last); \ - if (s->strm->avail_out == 0) return (last) ? finish_started : need_more; \ -} - -/* Maximum stored block length in deflate format (not including header). */ -#define MAX_STORED 65535 - -/* Minimum of a and b. */ -#define MIN(a, b) ((a) > (b) ? (b) : (a)) - -/* =========================================================================== - * Copy without compression as much as possible from the input stream, return - * the current block state. - * - * In case deflateParams() is used to later switch to a non-zero compression - * level, s->matches (otherwise unused when storing) keeps track of the number - * of hash table slides to perform. If s->matches is 1, then one hash table - * slide will be done when switching. If s->matches is 2, the maximum value - * allowed here, then the hash table will be cleared, since two or more slides - * is the same as a clear. - * - * deflate_stored() is written to minimize the number of times an input byte is - * copied. It is most efficient with large input and output buffers, which - * maximizes the opportunites to have a single copy from next_in to next_out. - */ -local block_state deflate_stored(s, flush) - deflate_state *s; - int flush; -{ - /* Smallest worthy block size when not flushing or finishing. By default - * this is 32K. This can be as small as 507 bytes for memLevel == 1. For - * large input and output buffers, the stored block size will be larger. - */ - unsigned min_block = MIN(s->pending_buf_size - 5, s->w_size); - - /* Copy as many min_block or larger stored blocks directly to next_out as - * possible. If flushing, copy the remaining available input to next_out as - * stored blocks, if there is enough space. - */ - unsigned len, left, have, last = 0; - unsigned used = s->strm->avail_in; - do { - /* Set len to the maximum size block that we can copy directly with the - * available input data and output space. Set left to how much of that - * would be copied from what's left in the window. - */ - len = MAX_STORED; /* maximum deflate stored block length */ - have = (s->bi_valid + 42) >> 3; /* number of header bytes */ - if (s->strm->avail_out < have) /* need room for header */ - break; - /* maximum stored block length that will fit in avail_out: */ - have = s->strm->avail_out - have; - left = s->strstart - s->block_start; /* bytes left in window */ - if (len > (ulg)left + s->strm->avail_in) - len = left + s->strm->avail_in; /* limit len to the input */ - if (len > have) - len = have; /* limit len to the output */ - - /* If the stored block would be less than min_block in length, or if - * unable to copy all of the available input when flushing, then try - * copying to the window and the pending buffer instead. Also don't - * write an empty block when flushing -- deflate() does that. - */ - if (len < min_block && ((len == 0 && flush != Z_FINISH) || - flush == Z_NO_FLUSH || - len != left + s->strm->avail_in)) - break; - - /* Make a dummy stored block in pending to get the header bytes, - * including any pending bits. This also updates the debugging counts. - */ - last = flush == Z_FINISH && len == left + s->strm->avail_in ? 1 : 0; - _tr_stored_block(s, (char *)0, 0L, last); - - /* Replace the lengths in the dummy stored block with len. */ - s->pending_buf[s->pending - 4] = len; - s->pending_buf[s->pending - 3] = len >> 8; - s->pending_buf[s->pending - 2] = ~len; - s->pending_buf[s->pending - 1] = ~len >> 8; - - /* Write the stored block header bytes. */ - flush_pending(s->strm); - -#ifdef ZLIB_DEBUG - /* Update debugging counts for the data about to be copied. */ - s->compressed_len += len << 3; - s->bits_sent += len << 3; -#endif - - /* Copy uncompressed bytes from the window to next_out. */ - if (left) { - if (left > len) - left = len; - zmemcpy(s->strm->next_out, s->window + s->block_start, left); - s->strm->next_out += left; - s->strm->avail_out -= left; - s->strm->total_out += left; - s->block_start += left; - len -= left; - } - - /* Copy uncompressed bytes directly from next_in to next_out, updating - * the check value. - */ - if (len) { - read_buf(s->strm, s->strm->next_out, len); - s->strm->next_out += len; - s->strm->avail_out -= len; - s->strm->total_out += len; - } - } while (last == 0); - - /* Update the sliding window with the last s->w_size bytes of the copied - * data, or append all of the copied data to the existing window if less - * than s->w_size bytes were copied. Also update the number of bytes to - * insert in the hash tables, in the event that deflateParams() switches to - * a non-zero compression level. - */ - used -= s->strm->avail_in; /* number of input bytes directly copied */ - if (used) { - /* If any input was used, then no unused input remains in the window, - * therefore s->block_start == s->strstart. - */ - if (used >= s->w_size) { /* supplant the previous history */ - s->matches = 2; /* clear hash */ - zmemcpy(s->window, s->strm->next_in - s->w_size, s->w_size); - s->strstart = s->w_size; - } - else { - if (s->window_size - s->strstart <= used) { - /* Slide the window down. */ - s->strstart -= s->w_size; - zmemcpy(s->window, s->window + s->w_size, s->strstart); - if (s->matches < 2) - s->matches++; /* add a pending slide_hash() */ - } - zmemcpy(s->window + s->strstart, s->strm->next_in - used, used); - s->strstart += used; - } - s->block_start = s->strstart; - s->insert += MIN(used, s->w_size - s->insert); - } - if (s->high_water < s->strstart) - s->high_water = s->strstart; - - /* If the last block was written to next_out, then done. */ - if (last) - return finish_done; - - /* If flushing and all input has been consumed, then done. */ - if (flush != Z_NO_FLUSH && flush != Z_FINISH && - s->strm->avail_in == 0 && (long)s->strstart == s->block_start) - return block_done; - - /* Fill the window with any remaining input. */ - have = s->window_size - s->strstart - 1; - if (s->strm->avail_in > have && s->block_start >= (long)s->w_size) { - /* Slide the window down. */ - s->block_start -= s->w_size; - s->strstart -= s->w_size; - zmemcpy(s->window, s->window + s->w_size, s->strstart); - if (s->matches < 2) - s->matches++; /* add a pending slide_hash() */ - have += s->w_size; /* more space now */ - } - if (have > s->strm->avail_in) - have = s->strm->avail_in; - if (have) { - read_buf(s->strm, s->window + s->strstart, have); - s->strstart += have; - } - if (s->high_water < s->strstart) - s->high_water = s->strstart; - - /* There was not enough avail_out to write a complete worthy or flushed - * stored block to next_out. Write a stored block to pending instead, if we - * have enough input for a worthy block, or if flushing and there is enough - * room for the remaining input as a stored block in the pending buffer. - */ - have = (s->bi_valid + 42) >> 3; /* number of header bytes */ - /* maximum stored block length that will fit in pending: */ - have = MIN(s->pending_buf_size - have, MAX_STORED); - min_block = MIN(have, s->w_size); - left = s->strstart - s->block_start; - if (left >= min_block || - ((left || flush == Z_FINISH) && flush != Z_NO_FLUSH && - s->strm->avail_in == 0 && left <= have)) { - len = MIN(left, have); - last = flush == Z_FINISH && s->strm->avail_in == 0 && - len == left ? 1 : 0; - _tr_stored_block(s, (charf *)s->window + s->block_start, len, last); - s->block_start += len; - flush_pending(s->strm); - } - - /* We've done all we can with the available input and output. */ - return last ? finish_started : need_more; -} - -/* =========================================================================== - * Compress as much as possible from the input stream, return the current - * block state. - * This function does not perform lazy evaluation of matches and inserts - * new strings in the dictionary only for unmatched strings or for short - * matches. It is used only for the fast compression options. - */ -local block_state deflate_fast(s, flush) - deflate_state *s; - int flush; -{ - IPos hash_head; /* head of the hash chain */ - int bflush; /* set if current block must be flushed */ - - for (;;) { - /* Make sure that we always have enough lookahead, except - * at the end of the input file. We need MAX_MATCH bytes - * for the next match, plus MIN_MATCH bytes to insert the - * string following the next match. - */ - if (s->lookahead < MIN_LOOKAHEAD) { - fill_window(s); - if (s->lookahead < MIN_LOOKAHEAD && flush == Z_NO_FLUSH) { - return need_more; - } - if (s->lookahead == 0) break; /* flush the current block */ - } - - /* Insert the string window[strstart .. strstart+2] in the - * dictionary, and set hash_head to the head of the hash chain: - */ - hash_head = NIL; - if (s->lookahead >= MIN_MATCH) { - INSERT_STRING(s, s->strstart, hash_head); - } - - /* Find the longest match, discarding those <= prev_length. - * At this point we have always match_length < MIN_MATCH - */ - if (hash_head != NIL && s->strstart - hash_head <= MAX_DIST(s)) { - /* To simplify the code, we prevent matches with the string - * of window index 0 (in particular we have to avoid a match - * of the string with itself at the start of the input file). - */ - s->match_length = longest_match (s, hash_head); - /* longest_match() sets match_start */ - } - if (s->match_length >= MIN_MATCH) { - check_match(s, s->strstart, s->match_start, s->match_length); - - _tr_tally_dist(s, s->strstart - s->match_start, - s->match_length - MIN_MATCH, bflush); - - s->lookahead -= s->match_length; - - /* Insert new strings in the hash table only if the match length - * is not too large. This saves time but degrades compression. - */ -#ifndef FASTEST - if (s->match_length <= s->max_insert_length && - s->lookahead >= MIN_MATCH) { - s->match_length--; /* string at strstart already in table */ - do { - s->strstart++; - INSERT_STRING(s, s->strstart, hash_head); - /* strstart never exceeds WSIZE-MAX_MATCH, so there are - * always MIN_MATCH bytes ahead. - */ - } while (--s->match_length != 0); - s->strstart++; - } else -#endif - { - s->strstart += s->match_length; - s->match_length = 0; - s->ins_h = s->window[s->strstart]; - UPDATE_HASH(s, s->ins_h, s->window[s->strstart+1]); -#if MIN_MATCH != 3 - Call UPDATE_HASH() MIN_MATCH-3 more times -#endif - /* If lookahead < MIN_MATCH, ins_h is garbage, but it does not - * matter since it will be recomputed at next deflate call. - */ - } - } else { - /* No match, output a literal byte */ - Tracevv((stderr,"%c", s->window[s->strstart])); - _tr_tally_lit (s, s->window[s->strstart], bflush); - s->lookahead--; - s->strstart++; - } - if (bflush) FLUSH_BLOCK(s, 0); - } - s->insert = s->strstart < MIN_MATCH-1 ? s->strstart : MIN_MATCH-1; - if (flush == Z_FINISH) { - FLUSH_BLOCK(s, 1); - return finish_done; - } - if (s->last_lit) - FLUSH_BLOCK(s, 0); - return block_done; -} - -#ifndef FASTEST -/* =========================================================================== - * Same as above, but achieves better compression. We use a lazy - * evaluation for matches: a match is finally adopted only if there is - * no better match at the next window position. - */ -local block_state deflate_slow(s, flush) - deflate_state *s; - int flush; -{ - IPos hash_head; /* head of hash chain */ - int bflush; /* set if current block must be flushed */ - - /* Process the input block. */ - for (;;) { - /* Make sure that we always have enough lookahead, except - * at the end of the input file. We need MAX_MATCH bytes - * for the next match, plus MIN_MATCH bytes to insert the - * string following the next match. - */ - if (s->lookahead < MIN_LOOKAHEAD) { - fill_window(s); - if (s->lookahead < MIN_LOOKAHEAD && flush == Z_NO_FLUSH) { - return need_more; - } - if (s->lookahead == 0) break; /* flush the current block */ - } - - /* Insert the string window[strstart .. strstart+2] in the - * dictionary, and set hash_head to the head of the hash chain: - */ - hash_head = NIL; - if (s->lookahead >= MIN_MATCH) { - INSERT_STRING(s, s->strstart, hash_head); - } - - /* Find the longest match, discarding those <= prev_length. - */ - s->prev_length = s->match_length, s->prev_match = s->match_start; - s->match_length = MIN_MATCH-1; - - if (hash_head != NIL && s->prev_length < s->max_lazy_match && - s->strstart - hash_head <= MAX_DIST(s)) { - /* To simplify the code, we prevent matches with the string - * of window index 0 (in particular we have to avoid a match - * of the string with itself at the start of the input file). - */ - s->match_length = longest_match (s, hash_head); - /* longest_match() sets match_start */ - - if (s->match_length <= 5 && (s->strategy == Z_FILTERED -#if TOO_FAR <= 32767 - || (s->match_length == MIN_MATCH && - s->strstart - s->match_start > TOO_FAR) -#endif - )) { - - /* If prev_match is also MIN_MATCH, match_start is garbage - * but we will ignore the current match anyway. - */ - s->match_length = MIN_MATCH-1; - } - } - /* If there was a match at the previous step and the current - * match is not better, output the previous match: - */ - if (s->prev_length >= MIN_MATCH && s->match_length <= s->prev_length) { - uInt max_insert = s->strstart + s->lookahead - MIN_MATCH; - /* Do not insert strings in hash table beyond this. */ - - check_match(s, s->strstart-1, s->prev_match, s->prev_length); - - _tr_tally_dist(s, s->strstart -1 - s->prev_match, - s->prev_length - MIN_MATCH, bflush); - - /* Insert in hash table all strings up to the end of the match. - * strstart-1 and strstart are already inserted. If there is not - * enough lookahead, the last two strings are not inserted in - * the hash table. - */ - s->lookahead -= s->prev_length-1; - s->prev_length -= 2; - do { - if (++s->strstart <= max_insert) { - INSERT_STRING(s, s->strstart, hash_head); - } - } while (--s->prev_length != 0); - s->match_available = 0; - s->match_length = MIN_MATCH-1; - s->strstart++; - - if (bflush) FLUSH_BLOCK(s, 0); - - } else if (s->match_available) { - /* If there was no match at the previous position, output a - * single literal. If there was a match but the current match - * is longer, truncate the previous match to a single literal. - */ - Tracevv((stderr,"%c", s->window[s->strstart-1])); - _tr_tally_lit(s, s->window[s->strstart-1], bflush); - if (bflush) { - FLUSH_BLOCK_ONLY(s, 0); - } - s->strstart++; - s->lookahead--; - if (s->strm->avail_out == 0) return need_more; - } else { - /* There is no previous match to compare with, wait for - * the next step to decide. - */ - s->match_available = 1; - s->strstart++; - s->lookahead--; - } - } - Assert (flush != Z_NO_FLUSH, "no flush?"); - if (s->match_available) { - Tracevv((stderr,"%c", s->window[s->strstart-1])); - _tr_tally_lit(s, s->window[s->strstart-1], bflush); - s->match_available = 0; - } - s->insert = s->strstart < MIN_MATCH-1 ? s->strstart : MIN_MATCH-1; - if (flush == Z_FINISH) { - FLUSH_BLOCK(s, 1); - return finish_done; - } - if (s->last_lit) - FLUSH_BLOCK(s, 0); - return block_done; -} -#endif /* FASTEST */ - -/* =========================================================================== - * For Z_RLE, simply look for runs of bytes, generate matches only of distance - * one. Do not maintain a hash table. (It will be regenerated if this run of - * deflate switches away from Z_RLE.) - */ -local block_state deflate_rle(s, flush) - deflate_state *s; - int flush; -{ - int bflush; /* set if current block must be flushed */ - uInt prev; /* byte at distance one to match */ - Bytef *scan, *strend; /* scan goes up to strend for length of run */ - - for (;;) { - /* Make sure that we always have enough lookahead, except - * at the end of the input file. We need MAX_MATCH bytes - * for the longest run, plus one for the unrolled loop. - */ - if (s->lookahead <= MAX_MATCH) { - fill_window(s); - if (s->lookahead <= MAX_MATCH && flush == Z_NO_FLUSH) { - return need_more; - } - if (s->lookahead == 0) break; /* flush the current block */ - } - - /* See how many times the previous byte repeats */ - s->match_length = 0; - if (s->lookahead >= MIN_MATCH && s->strstart > 0) { - scan = s->window + s->strstart - 1; - prev = *scan; - if (prev == *++scan && prev == *++scan && prev == *++scan) { - strend = s->window + s->strstart + MAX_MATCH; - do { - } while (prev == *++scan && prev == *++scan && - prev == *++scan && prev == *++scan && - prev == *++scan && prev == *++scan && - prev == *++scan && prev == *++scan && - scan < strend); - s->match_length = MAX_MATCH - (uInt)(strend - scan); - if (s->match_length > s->lookahead) - s->match_length = s->lookahead; - } - Assert(scan <= s->window+(uInt)(s->window_size-1), "wild scan"); - } - - /* Emit match if have run of MIN_MATCH or longer, else emit literal */ - if (s->match_length >= MIN_MATCH) { - check_match(s, s->strstart, s->strstart - 1, s->match_length); - - _tr_tally_dist(s, 1, s->match_length - MIN_MATCH, bflush); - - s->lookahead -= s->match_length; - s->strstart += s->match_length; - s->match_length = 0; - } else { - /* No match, output a literal byte */ - Tracevv((stderr,"%c", s->window[s->strstart])); - _tr_tally_lit (s, s->window[s->strstart], bflush); - s->lookahead--; - s->strstart++; - } - if (bflush) FLUSH_BLOCK(s, 0); - } - s->insert = 0; - if (flush == Z_FINISH) { - FLUSH_BLOCK(s, 1); - return finish_done; - } - if (s->last_lit) - FLUSH_BLOCK(s, 0); - return block_done; -} - -/* =========================================================================== - * For Z_HUFFMAN_ONLY, do not look for matches. Do not maintain a hash table. - * (It will be regenerated if this run of deflate switches away from Huffman.) - */ -local block_state deflate_huff(s, flush) - deflate_state *s; - int flush; -{ - int bflush; /* set if current block must be flushed */ - - for (;;) { - /* Make sure that we have a literal to write. */ - if (s->lookahead == 0) { - fill_window(s); - if (s->lookahead == 0) { - if (flush == Z_NO_FLUSH) - return need_more; - break; /* flush the current block */ - } - } - - /* Output a literal byte */ - s->match_length = 0; - Tracevv((stderr,"%c", s->window[s->strstart])); - _tr_tally_lit (s, s->window[s->strstart], bflush); - s->lookahead--; - s->strstart++; - if (bflush) FLUSH_BLOCK(s, 0); - } - s->insert = 0; - if (flush == Z_FINISH) { - FLUSH_BLOCK(s, 1); - return finish_done; - } - if (s->last_lit) - FLUSH_BLOCK(s, 0); - return block_done; -} DELETED compat/zlib/deflate.h Index: compat/zlib/deflate.h ================================================================== --- compat/zlib/deflate.h +++ /dev/null @@ -1,349 +0,0 @@ -/* deflate.h -- internal compression state - * Copyright (C) 1995-2016 Jean-loup Gailly - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -/* WARNING: this file should *not* be used by applications. It is - part of the implementation of the compression library and is - subject to change. Applications should only use zlib.h. - */ - -/* @(#) $Id$ */ - -#ifndef DEFLATE_H -#define DEFLATE_H - -#include "zutil.h" - -/* define NO_GZIP when compiling if you want to disable gzip header and - trailer creation by deflate(). NO_GZIP would be used to avoid linking in - the crc code when it is not needed. For shared libraries, gzip encoding - should be left enabled. */ -#ifndef NO_GZIP -# define GZIP -#endif - -/* =========================================================================== - * Internal compression state. - */ - -#define LENGTH_CODES 29 -/* number of length codes, not counting the special END_BLOCK code */ - -#define LITERALS 256 -/* number of literal bytes 0..255 */ - -#define L_CODES (LITERALS+1+LENGTH_CODES) -/* number of Literal or Length codes, including the END_BLOCK code */ - -#define D_CODES 30 -/* number of distance codes */ - -#define BL_CODES 19 -/* number of codes used to transfer the bit lengths */ - -#define HEAP_SIZE (2*L_CODES+1) -/* maximum heap size */ - -#define MAX_BITS 15 -/* All codes must not exceed MAX_BITS bits */ - -#define Buf_size 16 -/* size of bit buffer in bi_buf */ - -#define INIT_STATE 42 /* zlib header -> BUSY_STATE */ -#ifdef GZIP -# define GZIP_STATE 57 /* gzip header -> BUSY_STATE | EXTRA_STATE */ -#endif -#define EXTRA_STATE 69 /* gzip extra block -> NAME_STATE */ -#define NAME_STATE 73 /* gzip file name -> COMMENT_STATE */ -#define COMMENT_STATE 91 /* gzip comment -> HCRC_STATE */ -#define HCRC_STATE 103 /* gzip header CRC -> BUSY_STATE */ -#define BUSY_STATE 113 /* deflate -> FINISH_STATE */ -#define FINISH_STATE 666 /* stream complete */ -/* Stream status */ - - -/* Data structure describing a single value and its code string. */ -typedef struct ct_data_s { - union { - ush freq; /* frequency count */ - ush code; /* bit string */ - } fc; - union { - ush dad; /* father node in Huffman tree */ - ush len; /* length of bit string */ - } dl; -} FAR ct_data; - -#define Freq fc.freq -#define Code fc.code -#define Dad dl.dad -#define Len dl.len - -typedef struct static_tree_desc_s static_tree_desc; - -typedef struct tree_desc_s { - ct_data *dyn_tree; /* the dynamic tree */ - int max_code; /* largest code with non zero frequency */ - const static_tree_desc *stat_desc; /* the corresponding static tree */ -} FAR tree_desc; - -typedef ush Pos; -typedef Pos FAR Posf; -typedef unsigned IPos; - -/* A Pos is an index in the character window. We use short instead of int to - * save space in the various tables. IPos is used only for parameter passing. - */ - -typedef struct internal_state { - z_streamp strm; /* pointer back to this zlib stream */ - int status; /* as the name implies */ - Bytef *pending_buf; /* output still pending */ - ulg pending_buf_size; /* size of pending_buf */ - Bytef *pending_out; /* next pending byte to output to the stream */ - ulg pending; /* nb of bytes in the pending buffer */ - int wrap; /* bit 0 true for zlib, bit 1 true for gzip */ - gz_headerp gzhead; /* gzip header information to write */ - ulg gzindex; /* where in extra, name, or comment */ - Byte method; /* can only be DEFLATED */ - int last_flush; /* value of flush param for previous deflate call */ - - /* used by deflate.c: */ - - uInt w_size; /* LZ77 window size (32K by default) */ - uInt w_bits; /* log2(w_size) (8..16) */ - uInt w_mask; /* w_size - 1 */ - - Bytef *window; - /* Sliding window. Input bytes are read into the second half of the window, - * and move to the first half later to keep a dictionary of at least wSize - * bytes. With this organization, matches are limited to a distance of - * wSize-MAX_MATCH bytes, but this ensures that IO is always - * performed with a length multiple of the block size. Also, it limits - * the window size to 64K, which is quite useful on MSDOS. - * To do: use the user input buffer as sliding window. - */ - - ulg window_size; - /* Actual size of window: 2*wSize, except when the user input buffer - * is directly used as sliding window. - */ - - Posf *prev; - /* Link to older string with same hash index. To limit the size of this - * array to 64K, this link is maintained only for the last 32K strings. - * An index in this array is thus a window index modulo 32K. - */ - - Posf *head; /* Heads of the hash chains or NIL. */ - - uInt ins_h; /* hash index of string to be inserted */ - uInt hash_size; /* number of elements in hash table */ - uInt hash_bits; /* log2(hash_size) */ - uInt hash_mask; /* hash_size-1 */ - - uInt hash_shift; - /* Number of bits by which ins_h must be shifted at each input - * step. It must be such that after MIN_MATCH steps, the oldest - * byte no longer takes part in the hash key, that is: - * hash_shift * MIN_MATCH >= hash_bits - */ - - long block_start; - /* Window position at the beginning of the current output block. Gets - * negative when the window is moved backwards. - */ - - uInt match_length; /* length of best match */ - IPos prev_match; /* previous match */ - int match_available; /* set if previous match exists */ - uInt strstart; /* start of string to insert */ - uInt match_start; /* start of matching string */ - uInt lookahead; /* number of valid bytes ahead in window */ - - uInt prev_length; - /* Length of the best match at previous step. Matches not greater than this - * are discarded. This is used in the lazy match evaluation. - */ - - uInt max_chain_length; - /* To speed up deflation, hash chains are never searched beyond this - * length. A higher limit improves compression ratio but degrades the - * speed. - */ - - uInt max_lazy_match; - /* Attempt to find a better match only when the current match is strictly - * smaller than this value. This mechanism is used only for compression - * levels >= 4. - */ -# define max_insert_length max_lazy_match - /* Insert new strings in the hash table only if the match length is not - * greater than this length. This saves time but degrades compression. - * max_insert_length is used only for compression levels <= 3. - */ - - int level; /* compression level (1..9) */ - int strategy; /* favor or force Huffman coding*/ - - uInt good_match; - /* Use a faster search when the previous match is longer than this */ - - int nice_match; /* Stop searching when current match exceeds this */ - - /* used by trees.c: */ - /* Didn't use ct_data typedef below to suppress compiler warning */ - struct ct_data_s dyn_ltree[HEAP_SIZE]; /* literal and length tree */ - struct ct_data_s dyn_dtree[2*D_CODES+1]; /* distance tree */ - struct ct_data_s bl_tree[2*BL_CODES+1]; /* Huffman tree for bit lengths */ - - struct tree_desc_s l_desc; /* desc. for literal tree */ - struct tree_desc_s d_desc; /* desc. for distance tree */ - struct tree_desc_s bl_desc; /* desc. for bit length tree */ - - ush bl_count[MAX_BITS+1]; - /* number of codes at each bit length for an optimal tree */ - - int heap[2*L_CODES+1]; /* heap used to build the Huffman trees */ - int heap_len; /* number of elements in the heap */ - int heap_max; /* element of largest frequency */ - /* The sons of heap[n] are heap[2*n] and heap[2*n+1]. heap[0] is not used. - * The same heap array is used to build all trees. - */ - - uch depth[2*L_CODES+1]; - /* Depth of each subtree used as tie breaker for trees of equal frequency - */ - - uchf *l_buf; /* buffer for literals or lengths */ - - uInt lit_bufsize; - /* Size of match buffer for literals/lengths. There are 4 reasons for - * limiting lit_bufsize to 64K: - * - frequencies can be kept in 16 bit counters - * - if compression is not successful for the first block, all input - * data is still in the window so we can still emit a stored block even - * when input comes from standard input. (This can also be done for - * all blocks if lit_bufsize is not greater than 32K.) - * - if compression is not successful for a file smaller than 64K, we can - * even emit a stored file instead of a stored block (saving 5 bytes). - * This is applicable only for zip (not gzip or zlib). - * - creating new Huffman trees less frequently may not provide fast - * adaptation to changes in the input data statistics. (Take for - * example a binary file with poorly compressible code followed by - * a highly compressible string table.) Smaller buffer sizes give - * fast adaptation but have of course the overhead of transmitting - * trees more frequently. - * - I can't count above 4 - */ - - uInt last_lit; /* running index in l_buf */ - - ushf *d_buf; - /* Buffer for distances. To simplify the code, d_buf and l_buf have - * the same number of elements. To use different lengths, an extra flag - * array would be necessary. - */ - - ulg opt_len; /* bit length of current block with optimal trees */ - ulg static_len; /* bit length of current block with static trees */ - uInt matches; /* number of string matches in current block */ - uInt insert; /* bytes at end of window left to insert */ - -#ifdef ZLIB_DEBUG - ulg compressed_len; /* total bit length of compressed file mod 2^32 */ - ulg bits_sent; /* bit length of compressed data sent mod 2^32 */ -#endif - - ush bi_buf; - /* Output buffer. bits are inserted starting at the bottom (least - * significant bits). - */ - int bi_valid; - /* Number of valid bits in bi_buf. All bits above the last valid bit - * are always zero. - */ - - ulg high_water; - /* High water mark offset in window for initialized bytes -- bytes above - * this are set to zero in order to avoid memory check warnings when - * longest match routines access bytes past the input. This is then - * updated to the new high water mark. - */ - -} FAR deflate_state; - -/* Output a byte on the stream. - * IN assertion: there is enough room in pending_buf. - */ -#define put_byte(s, c) {s->pending_buf[s->pending++] = (Bytef)(c);} - - -#define MIN_LOOKAHEAD (MAX_MATCH+MIN_MATCH+1) -/* Minimum amount of lookahead, except at the end of the input file. - * See deflate.c for comments about the MIN_MATCH+1. - */ - -#define MAX_DIST(s) ((s)->w_size-MIN_LOOKAHEAD) -/* In order to simplify the code, particularly on 16 bit machines, match - * distances are limited to MAX_DIST instead of WSIZE. - */ - -#define WIN_INIT MAX_MATCH -/* Number of bytes after end of data in window to initialize in order to avoid - memory checker errors from longest match routines */ - - /* in trees.c */ -void ZLIB_INTERNAL _tr_init OF((deflate_state *s)); -int ZLIB_INTERNAL _tr_tally OF((deflate_state *s, unsigned dist, unsigned lc)); -void ZLIB_INTERNAL _tr_flush_block OF((deflate_state *s, charf *buf, - ulg stored_len, int last)); -void ZLIB_INTERNAL _tr_flush_bits OF((deflate_state *s)); -void ZLIB_INTERNAL _tr_align OF((deflate_state *s)); -void ZLIB_INTERNAL _tr_stored_block OF((deflate_state *s, charf *buf, - ulg stored_len, int last)); - -#define d_code(dist) \ - ((dist) < 256 ? _dist_code[dist] : _dist_code[256+((dist)>>7)]) -/* Mapping from a distance to a distance code. dist is the distance - 1 and - * must not have side effects. _dist_code[256] and _dist_code[257] are never - * used. - */ - -#ifndef ZLIB_DEBUG -/* Inline versions of _tr_tally for speed: */ - -#if defined(GEN_TREES_H) || !defined(STDC) - extern uch ZLIB_INTERNAL _length_code[]; - extern uch ZLIB_INTERNAL _dist_code[]; -#else - extern const uch ZLIB_INTERNAL _length_code[]; - extern const uch ZLIB_INTERNAL _dist_code[]; -#endif - -# define _tr_tally_lit(s, c, flush) \ - { uch cc = (c); \ - s->d_buf[s->last_lit] = 0; \ - s->l_buf[s->last_lit++] = cc; \ - s->dyn_ltree[cc].Freq++; \ - flush = (s->last_lit == s->lit_bufsize-1); \ - } -# define _tr_tally_dist(s, distance, length, flush) \ - { uch len = (uch)(length); \ - ush dist = (ush)(distance); \ - s->d_buf[s->last_lit] = dist; \ - s->l_buf[s->last_lit++] = len; \ - dist--; \ - s->dyn_ltree[_length_code[len]+LITERALS+1].Freq++; \ - s->dyn_dtree[d_code(dist)].Freq++; \ - flush = (s->last_lit == s->lit_bufsize-1); \ - } -#else -# define _tr_tally_lit(s, c, flush) flush = _tr_tally(s, 0, c) -# define _tr_tally_dist(s, distance, length, flush) \ - flush = _tr_tally(s, distance, length) -#endif - -#endif /* DEFLATE_H */ DELETED compat/zlib/examples/README.examples Index: compat/zlib/examples/README.examples ================================================================== --- compat/zlib/examples/README.examples +++ /dev/null @@ -1,49 +0,0 @@ -This directory contains examples of the use of zlib and other relevant -programs and documentation. - -enough.c - calculation and justification of ENOUGH parameter in inftrees.h - - calculates the maximum table space used in inflate tree - construction over all possible Huffman codes - -fitblk.c - compress just enough input to nearly fill a requested output size - - zlib isn't designed to do this, but fitblk does it anyway - -gun.c - uncompress a gzip file - - illustrates the use of inflateBack() for high speed file-to-file - decompression using call-back functions - - is approximately twice as fast as gzip -d - - also provides Unix uncompress functionality, again twice as fast - -gzappend.c - append to a gzip file - - illustrates the use of the Z_BLOCK flush parameter for inflate() - - illustrates the use of deflatePrime() to start at any bit - -gzjoin.c - join gzip files without recalculating the crc or recompressing - - illustrates the use of the Z_BLOCK flush parameter for inflate() - - illustrates the use of crc32_combine() - -gzlog.c -gzlog.h - efficiently and robustly maintain a message log file in gzip format - - illustrates use of raw deflate, Z_PARTIAL_FLUSH, deflatePrime(), - and deflateSetDictionary() - - illustrates use of a gzip header extra field - -zlib_how.html - painfully comprehensive description of zpipe.c (see below) - - describes in excruciating detail the use of deflate() and inflate() - -zpipe.c - reads and writes zlib streams from stdin to stdout - - illustrates the proper use of deflate() and inflate() - - deeply commented in zlib_how.html (see above) - -zran.c - index a zlib or gzip stream and randomly access it - - illustrates the use of Z_BLOCK, inflatePrime(), and - inflateSetDictionary() to provide random access DELETED compat/zlib/examples/enough.c Index: compat/zlib/examples/enough.c ================================================================== --- compat/zlib/examples/enough.c +++ /dev/null @@ -1,572 +0,0 @@ -/* enough.c -- determine the maximum size of inflate's Huffman code tables over - * all possible valid and complete Huffman codes, subject to a length limit. - * Copyright (C) 2007, 2008, 2012 Mark Adler - * Version 1.4 18 August 2012 Mark Adler - */ - -/* Version history: - 1.0 3 Jan 2007 First version (derived from codecount.c version 1.4) - 1.1 4 Jan 2007 Use faster incremental table usage computation - Prune examine() search on previously visited states - 1.2 5 Jan 2007 Comments clean up - As inflate does, decrease root for short codes - Refuse cases where inflate would increase root - 1.3 17 Feb 2008 Add argument for initial root table size - Fix bug for initial root table size == max - 1 - Use a macro to compute the history index - 1.4 18 Aug 2012 Avoid shifts more than bits in type (caused endless loop!) - Clean up comparisons of different types - Clean up code indentation - */ - -/* - Examine all possible Huffman codes for a given number of symbols and a - maximum code length in bits to determine the maximum table size for zilb's - inflate. Only complete Huffman codes are counted. - - Two codes are considered distinct if the vectors of the number of codes per - length are not identical. So permutations of the symbol assignments result - in the same code for the counting, as do permutations of the assignments of - the bit values to the codes (i.e. only canonical codes are counted). - - We build a code from shorter to longer lengths, determining how many symbols - are coded at each length. At each step, we have how many symbols remain to - be coded, what the last code length used was, and how many bit patterns of - that length remain unused. Then we add one to the code length and double the - number of unused patterns to graduate to the next code length. We then - assign all portions of the remaining symbols to that code length that - preserve the properties of a correct and eventually complete code. Those - properties are: we cannot use more bit patterns than are available; and when - all the symbols are used, there are exactly zero possible bit patterns - remaining. - - The inflate Huffman decoding algorithm uses two-level lookup tables for - speed. There is a single first-level table to decode codes up to root bits - in length (root == 9 in the current inflate implementation). The table - has 1 << root entries and is indexed by the next root bits of input. Codes - shorter than root bits have replicated table entries, so that the correct - entry is pointed to regardless of the bits that follow the short code. If - the code is longer than root bits, then the table entry points to a second- - level table. The size of that table is determined by the longest code with - that root-bit prefix. If that longest code has length len, then the table - has size 1 << (len - root), to index the remaining bits in that set of - codes. Each subsequent root-bit prefix then has its own sub-table. The - total number of table entries required by the code is calculated - incrementally as the number of codes at each bit length is populated. When - all of the codes are shorter than root bits, then root is reduced to the - longest code length, resulting in a single, smaller, one-level table. - - The inflate algorithm also provides for small values of root (relative to - the log2 of the number of symbols), where the shortest code has more bits - than root. In that case, root is increased to the length of the shortest - code. This program, by design, does not handle that case, so it is verified - that the number of symbols is less than 2^(root + 1). - - In order to speed up the examination (by about ten orders of magnitude for - the default arguments), the intermediate states in the build-up of a code - are remembered and previously visited branches are pruned. The memory - required for this will increase rapidly with the total number of symbols and - the maximum code length in bits. However this is a very small price to pay - for the vast speedup. - - First, all of the possible Huffman codes are counted, and reachable - intermediate states are noted by a non-zero count in a saved-results array. - Second, the intermediate states that lead to (root + 1) bit or longer codes - are used to look at all sub-codes from those junctures for their inflate - memory usage. (The amount of memory used is not affected by the number of - codes of root bits or less in length.) Third, the visited states in the - construction of those sub-codes and the associated calculation of the table - size is recalled in order to avoid recalculating from the same juncture. - Beginning the code examination at (root + 1) bit codes, which is enabled by - identifying the reachable nodes, accounts for about six of the orders of - magnitude of improvement for the default arguments. About another four - orders of magnitude come from not revisiting previous states. Out of - approximately 2x10^16 possible Huffman codes, only about 2x10^6 sub-codes - need to be examined to cover all of the possible table memory usage cases - for the default arguments of 286 symbols limited to 15-bit codes. - - Note that an unsigned long long type is used for counting. It is quite easy - to exceed the capacity of an eight-byte integer with a large number of - symbols and a large maximum code length, so multiple-precision arithmetic - would need to replace the unsigned long long arithmetic in that case. This - program will abort if an overflow occurs. The big_t type identifies where - the counting takes place. - - An unsigned long long type is also used for calculating the number of - possible codes remaining at the maximum length. This limits the maximum - code length to the number of bits in a long long minus the number of bits - needed to represent the symbols in a flat code. The code_t type identifies - where the bit pattern counting takes place. - */ - -#include -#include -#include -#include - -#define local static - -/* special data types */ -typedef unsigned long long big_t; /* type for code counting */ -typedef unsigned long long code_t; /* type for bit pattern counting */ -struct tab { /* type for been here check */ - size_t len; /* length of bit vector in char's */ - char *vec; /* allocated bit vector */ -}; - -/* The array for saving results, num[], is indexed with this triplet: - - syms: number of symbols remaining to code - left: number of available bit patterns at length len - len: number of bits in the codes currently being assigned - - Those indices are constrained thusly when saving results: - - syms: 3..totsym (totsym == total symbols to code) - left: 2..syms - 1, but only the evens (so syms == 8 -> 2, 4, 6) - len: 1..max - 1 (max == maximum code length in bits) - - syms == 2 is not saved since that immediately leads to a single code. left - must be even, since it represents the number of available bit patterns at - the current length, which is double the number at the previous length. - left ends at syms-1 since left == syms immediately results in a single code. - (left > sym is not allowed since that would result in an incomplete code.) - len is less than max, since the code completes immediately when len == max. - - The offset into the array is calculated for the three indices with the - first one (syms) being outermost, and the last one (len) being innermost. - We build the array with length max-1 lists for the len index, with syms-3 - of those for each symbol. There are totsym-2 of those, with each one - varying in length as a function of sym. See the calculation of index in - count() for the index, and the calculation of size in main() for the size - of the array. - - For the deflate example of 286 symbols limited to 15-bit codes, the array - has 284,284 entries, taking up 2.17 MB for an 8-byte big_t. More than - half of the space allocated for saved results is actually used -- not all - possible triplets are reached in the generation of valid Huffman codes. - */ - -/* The array for tracking visited states, done[], is itself indexed identically - to the num[] array as described above for the (syms, left, len) triplet. - Each element in the array is further indexed by the (mem, rem) doublet, - where mem is the amount of inflate table space used so far, and rem is the - remaining unused entries in the current inflate sub-table. Each indexed - element is simply one bit indicating whether the state has been visited or - not. Since the ranges for mem and rem are not known a priori, each bit - vector is of a variable size, and grows as needed to accommodate the visited - states. mem and rem are used to calculate a single index in a triangular - array. Since the range of mem is expected in the default case to be about - ten times larger than the range of rem, the array is skewed to reduce the - memory usage, with eight times the range for mem than for rem. See the - calculations for offset and bit in beenhere() for the details. - - For the deflate example of 286 symbols limited to 15-bit codes, the bit - vectors grow to total approximately 21 MB, in addition to the 4.3 MB done[] - array itself. - */ - -/* Globals to avoid propagating constants or constant pointers recursively */ -local int max; /* maximum allowed bit length for the codes */ -local int root; /* size of base code table in bits */ -local int large; /* largest code table so far */ -local size_t size; /* number of elements in num and done */ -local int *code; /* number of symbols assigned to each bit length */ -local big_t *num; /* saved results array for code counting */ -local struct tab *done; /* states already evaluated array */ - -/* Index function for num[] and done[] */ -#define INDEX(i,j,k) (((size_t)((i-1)>>1)*((i-2)>>1)+(j>>1)-1)*(max-1)+k-1) - -/* Free allocated space. Uses globals code, num, and done. */ -local void cleanup(void) -{ - size_t n; - - if (done != NULL) { - for (n = 0; n < size; n++) - if (done[n].len) - free(done[n].vec); - free(done); - } - if (num != NULL) - free(num); - if (code != NULL) - free(code); -} - -/* Return the number of possible Huffman codes using bit patterns of lengths - len through max inclusive, coding syms symbols, with left bit patterns of - length len unused -- return -1 if there is an overflow in the counting. - Keep a record of previous results in num to prevent repeating the same - calculation. Uses the globals max and num. */ -local big_t count(int syms, int len, int left) -{ - big_t sum; /* number of possible codes from this juncture */ - big_t got; /* value returned from count() */ - int least; /* least number of syms to use at this juncture */ - int most; /* most number of syms to use at this juncture */ - int use; /* number of bit patterns to use in next call */ - size_t index; /* index of this case in *num */ - - /* see if only one possible code */ - if (syms == left) - return 1; - - /* note and verify the expected state */ - assert(syms > left && left > 0 && len < max); - - /* see if we've done this one already */ - index = INDEX(syms, left, len); - got = num[index]; - if (got) - return got; /* we have -- return the saved result */ - - /* we need to use at least this many bit patterns so that the code won't be - incomplete at the next length (more bit patterns than symbols) */ - least = (left << 1) - syms; - if (least < 0) - least = 0; - - /* we can use at most this many bit patterns, lest there not be enough - available for the remaining symbols at the maximum length (if there were - no limit to the code length, this would become: most = left - 1) */ - most = (((code_t)left << (max - len)) - syms) / - (((code_t)1 << (max - len)) - 1); - - /* count all possible codes from this juncture and add them up */ - sum = 0; - for (use = least; use <= most; use++) { - got = count(syms - use, len + 1, (left - use) << 1); - sum += got; - if (got == (big_t)0 - 1 || sum < got) /* overflow */ - return (big_t)0 - 1; - } - - /* verify that all recursive calls are productive */ - assert(sum != 0); - - /* save the result and return it */ - num[index] = sum; - return sum; -} - -/* Return true if we've been here before, set to true if not. Set a bit in a - bit vector to indicate visiting this state. Each (syms,len,left) state - has a variable size bit vector indexed by (mem,rem). The bit vector is - lengthened if needed to allow setting the (mem,rem) bit. */ -local int beenhere(int syms, int len, int left, int mem, int rem) -{ - size_t index; /* index for this state's bit vector */ - size_t offset; /* offset in this state's bit vector */ - int bit; /* mask for this state's bit */ - size_t length; /* length of the bit vector in bytes */ - char *vector; /* new or enlarged bit vector */ - - /* point to vector for (syms,left,len), bit in vector for (mem,rem) */ - index = INDEX(syms, left, len); - mem -= 1 << root; - offset = (mem >> 3) + rem; - offset = ((offset * (offset + 1)) >> 1) + rem; - bit = 1 << (mem & 7); - - /* see if we've been here */ - length = done[index].len; - if (offset < length && (done[index].vec[offset] & bit) != 0) - return 1; /* done this! */ - - /* we haven't been here before -- set the bit to show we have now */ - - /* see if we need to lengthen the vector in order to set the bit */ - if (length <= offset) { - /* if we have one already, enlarge it, zero out the appended space */ - if (length) { - do { - length <<= 1; - } while (length <= offset); - vector = realloc(done[index].vec, length); - if (vector != NULL) - memset(vector + done[index].len, 0, length - done[index].len); - } - - /* otherwise we need to make a new vector and zero it out */ - else { - length = 1 << (len - root); - while (length <= offset) - length <<= 1; - vector = calloc(length, sizeof(char)); - } - - /* in either case, bail if we can't get the memory */ - if (vector == NULL) { - fputs("abort: unable to allocate enough memory\n", stderr); - cleanup(); - exit(1); - } - - /* install the new vector */ - done[index].len = length; - done[index].vec = vector; - } - - /* set the bit */ - done[index].vec[offset] |= bit; - return 0; -} - -/* Examine all possible codes from the given node (syms, len, left). Compute - the amount of memory required to build inflate's decoding tables, where the - number of code structures used so far is mem, and the number remaining in - the current sub-table is rem. Uses the globals max, code, root, large, and - done. */ -local void examine(int syms, int len, int left, int mem, int rem) -{ - int least; /* least number of syms to use at this juncture */ - int most; /* most number of syms to use at this juncture */ - int use; /* number of bit patterns to use in next call */ - - /* see if we have a complete code */ - if (syms == left) { - /* set the last code entry */ - code[len] = left; - - /* complete computation of memory used by this code */ - while (rem < left) { - left -= rem; - rem = 1 << (len - root); - mem += rem; - } - assert(rem == left); - - /* if this is a new maximum, show the entries used and the sub-code */ - if (mem > large) { - large = mem; - printf("max %d: ", mem); - for (use = root + 1; use <= max; use++) - if (code[use]) - printf("%d[%d] ", code[use], use); - putchar('\n'); - fflush(stdout); - } - - /* remove entries as we drop back down in the recursion */ - code[len] = 0; - return; - } - - /* prune the tree if we can */ - if (beenhere(syms, len, left, mem, rem)) - return; - - /* we need to use at least this many bit patterns so that the code won't be - incomplete at the next length (more bit patterns than symbols) */ - least = (left << 1) - syms; - if (least < 0) - least = 0; - - /* we can use at most this many bit patterns, lest there not be enough - available for the remaining symbols at the maximum length (if there were - no limit to the code length, this would become: most = left - 1) */ - most = (((code_t)left << (max - len)) - syms) / - (((code_t)1 << (max - len)) - 1); - - /* occupy least table spaces, creating new sub-tables as needed */ - use = least; - while (rem < use) { - use -= rem; - rem = 1 << (len - root); - mem += rem; - } - rem -= use; - - /* examine codes from here, updating table space as we go */ - for (use = least; use <= most; use++) { - code[len] = use; - examine(syms - use, len + 1, (left - use) << 1, - mem + (rem ? 1 << (len - root) : 0), rem << 1); - if (rem == 0) { - rem = 1 << (len - root); - mem += rem; - } - rem--; - } - - /* remove entries as we drop back down in the recursion */ - code[len] = 0; -} - -/* Look at all sub-codes starting with root + 1 bits. Look at only the valid - intermediate code states (syms, left, len). For each completed code, - calculate the amount of memory required by inflate to build the decoding - tables. Find the maximum amount of memory required and show the code that - requires that maximum. Uses the globals max, root, and num. */ -local void enough(int syms) -{ - int n; /* number of remaing symbols for this node */ - int left; /* number of unused bit patterns at this length */ - size_t index; /* index of this case in *num */ - - /* clear code */ - for (n = 0; n <= max; n++) - code[n] = 0; - - /* look at all (root + 1) bit and longer codes */ - large = 1 << root; /* base table */ - if (root < max) /* otherwise, there's only a base table */ - for (n = 3; n <= syms; n++) - for (left = 2; left < n; left += 2) - { - /* look at all reachable (root + 1) bit nodes, and the - resulting codes (complete at root + 2 or more) */ - index = INDEX(n, left, root + 1); - if (root + 1 < max && num[index]) /* reachable node */ - examine(n, root + 1, left, 1 << root, 0); - - /* also look at root bit codes with completions at root + 1 - bits (not saved in num, since complete), just in case */ - if (num[index - 1] && n <= left << 1) - examine((n - left) << 1, root + 1, (n - left) << 1, - 1 << root, 0); - } - - /* done */ - printf("done: maximum of %d table entries\n", large); -} - -/* - Examine and show the total number of possible Huffman codes for a given - maximum number of symbols, initial root table size, and maximum code length - in bits -- those are the command arguments in that order. The default - values are 286, 9, and 15 respectively, for the deflate literal/length code. - The possible codes are counted for each number of coded symbols from two to - the maximum. The counts for each of those and the total number of codes are - shown. The maximum number of inflate table entires is then calculated - across all possible codes. Each new maximum number of table entries and the - associated sub-code (starting at root + 1 == 10 bits) is shown. - - To count and examine Huffman codes that are not length-limited, provide a - maximum length equal to the number of symbols minus one. - - For the deflate literal/length code, use "enough". For the deflate distance - code, use "enough 30 6". - - This uses the %llu printf format to print big_t numbers, which assumes that - big_t is an unsigned long long. If the big_t type is changed (for example - to a multiple precision type), the method of printing will also need to be - updated. - */ -int main(int argc, char **argv) -{ - int syms; /* total number of symbols to code */ - int n; /* number of symbols to code for this run */ - big_t got; /* return value of count() */ - big_t sum; /* accumulated number of codes over n */ - code_t word; /* for counting bits in code_t */ - - /* set up globals for cleanup() */ - code = NULL; - num = NULL; - done = NULL; - - /* get arguments -- default to the deflate literal/length code */ - syms = 286; - root = 9; - max = 15; - if (argc > 1) { - syms = atoi(argv[1]); - if (argc > 2) { - root = atoi(argv[2]); - if (argc > 3) - max = atoi(argv[3]); - } - } - if (argc > 4 || syms < 2 || root < 1 || max < 1) { - fputs("invalid arguments, need: [sym >= 2 [root >= 1 [max >= 1]]]\n", - stderr); - return 1; - } - - /* if not restricting the code length, the longest is syms - 1 */ - if (max > syms - 1) - max = syms - 1; - - /* determine the number of bits in a code_t */ - for (n = 0, word = 1; word; n++, word <<= 1) - ; - - /* make sure that the calculation of most will not overflow */ - if (max > n || (code_t)(syms - 2) >= (((code_t)0 - 1) >> (max - 1))) { - fputs("abort: code length too long for internal types\n", stderr); - return 1; - } - - /* reject impossible code requests */ - if ((code_t)(syms - 1) > ((code_t)1 << max) - 1) { - fprintf(stderr, "%d symbols cannot be coded in %d bits\n", - syms, max); - return 1; - } - - /* allocate code vector */ - code = calloc(max + 1, sizeof(int)); - if (code == NULL) { - fputs("abort: unable to allocate enough memory\n", stderr); - return 1; - } - - /* determine size of saved results array, checking for overflows, - allocate and clear the array (set all to zero with calloc()) */ - if (syms == 2) /* iff max == 1 */ - num = NULL; /* won't be saving any results */ - else { - size = syms >> 1; - if (size > ((size_t)0 - 1) / (n = (syms - 1) >> 1) || - (size *= n, size > ((size_t)0 - 1) / (n = max - 1)) || - (size *= n, size > ((size_t)0 - 1) / sizeof(big_t)) || - (num = calloc(size, sizeof(big_t))) == NULL) { - fputs("abort: unable to allocate enough memory\n", stderr); - cleanup(); - return 1; - } - } - - /* count possible codes for all numbers of symbols, add up counts */ - sum = 0; - for (n = 2; n <= syms; n++) { - got = count(n, 1, 2); - sum += got; - if (got == (big_t)0 - 1 || sum < got) { /* overflow */ - fputs("abort: can't count that high!\n", stderr); - cleanup(); - return 1; - } - printf("%llu %d-codes\n", got, n); - } - printf("%llu total codes for 2 to %d symbols", sum, syms); - if (max < syms - 1) - printf(" (%d-bit length limit)\n", max); - else - puts(" (no length limit)"); - - /* allocate and clear done array for beenhere() */ - if (syms == 2) - done = NULL; - else if (size > ((size_t)0 - 1) / sizeof(struct tab) || - (done = calloc(size, sizeof(struct tab))) == NULL) { - fputs("abort: unable to allocate enough memory\n", stderr); - cleanup(); - return 1; - } - - /* find and show maximum inflate table usage */ - if (root > max) /* reduce root to max length */ - root = max; - if ((code_t)syms < ((code_t)1 << (root + 1))) - enough(syms); - else - puts("cannot handle minimum code lengths > root"); - - /* done */ - cleanup(); - return 0; -} DELETED compat/zlib/examples/fitblk.c Index: compat/zlib/examples/fitblk.c ================================================================== --- compat/zlib/examples/fitblk.c +++ /dev/null @@ -1,233 +0,0 @@ -/* fitblk.c: example of fitting compressed output to a specified size - Not copyrighted -- provided to the public domain - Version 1.1 25 November 2004 Mark Adler */ - -/* Version history: - 1.0 24 Nov 2004 First version - 1.1 25 Nov 2004 Change deflateInit2() to deflateInit() - Use fixed-size, stack-allocated raw buffers - Simplify code moving compression to subroutines - Use assert() for internal errors - Add detailed description of approach - */ - -/* Approach to just fitting a requested compressed size: - - fitblk performs three compression passes on a portion of the input - data in order to determine how much of that input will compress to - nearly the requested output block size. The first pass generates - enough deflate blocks to produce output to fill the requested - output size plus a specfied excess amount (see the EXCESS define - below). The last deflate block may go quite a bit past that, but - is discarded. The second pass decompresses and recompresses just - the compressed data that fit in the requested plus excess sized - buffer. The deflate process is terminated after that amount of - input, which is less than the amount consumed on the first pass. - The last deflate block of the result will be of a comparable size - to the final product, so that the header for that deflate block and - the compression ratio for that block will be about the same as in - the final product. The third compression pass decompresses the - result of the second step, but only the compressed data up to the - requested size minus an amount to allow the compressed stream to - complete (see the MARGIN define below). That will result in a - final compressed stream whose length is less than or equal to the - requested size. Assuming sufficient input and a requested size - greater than a few hundred bytes, the shortfall will typically be - less than ten bytes. - - If the input is short enough that the first compression completes - before filling the requested output size, then that compressed - stream is return with no recompression. - - EXCESS is chosen to be just greater than the shortfall seen in a - two pass approach similar to the above. That shortfall is due to - the last deflate block compressing more efficiently with a smaller - header on the second pass. EXCESS is set to be large enough so - that there is enough uncompressed data for the second pass to fill - out the requested size, and small enough so that the final deflate - block of the second pass will be close in size to the final deflate - block of the third and final pass. MARGIN is chosen to be just - large enough to assure that the final compression has enough room - to complete in all cases. - */ - -#include -#include -#include -#include "zlib.h" - -#define local static - -/* print nastygram and leave */ -local void quit(char *why) -{ - fprintf(stderr, "fitblk abort: %s\n", why); - exit(1); -} - -#define RAWLEN 4096 /* intermediate uncompressed buffer size */ - -/* compress from file to def until provided buffer is full or end of - input reached; return last deflate() return value, or Z_ERRNO if - there was read error on the file */ -local int partcompress(FILE *in, z_streamp def) -{ - int ret, flush; - unsigned char raw[RAWLEN]; - - flush = Z_NO_FLUSH; - do { - def->avail_in = fread(raw, 1, RAWLEN, in); - if (ferror(in)) - return Z_ERRNO; - def->next_in = raw; - if (feof(in)) - flush = Z_FINISH; - ret = deflate(def, flush); - assert(ret != Z_STREAM_ERROR); - } while (def->avail_out != 0 && flush == Z_NO_FLUSH); - return ret; -} - -/* recompress from inf's input to def's output; the input for inf and - the output for def are set in those structures before calling; - return last deflate() return value, or Z_MEM_ERROR if inflate() - was not able to allocate enough memory when it needed to */ -local int recompress(z_streamp inf, z_streamp def) -{ - int ret, flush; - unsigned char raw[RAWLEN]; - - flush = Z_NO_FLUSH; - do { - /* decompress */ - inf->avail_out = RAWLEN; - inf->next_out = raw; - ret = inflate(inf, Z_NO_FLUSH); - assert(ret != Z_STREAM_ERROR && ret != Z_DATA_ERROR && - ret != Z_NEED_DICT); - if (ret == Z_MEM_ERROR) - return ret; - - /* compress what was decompresed until done or no room */ - def->avail_in = RAWLEN - inf->avail_out; - def->next_in = raw; - if (inf->avail_out != 0) - flush = Z_FINISH; - ret = deflate(def, flush); - assert(ret != Z_STREAM_ERROR); - } while (ret != Z_STREAM_END && def->avail_out != 0); - return ret; -} - -#define EXCESS 256 /* empirically determined stream overage */ -#define MARGIN 8 /* amount to back off for completion */ - -/* compress from stdin to fixed-size block on stdout */ -int main(int argc, char **argv) -{ - int ret; /* return code */ - unsigned size; /* requested fixed output block size */ - unsigned have; /* bytes written by deflate() call */ - unsigned char *blk; /* intermediate and final stream */ - unsigned char *tmp; /* close to desired size stream */ - z_stream def, inf; /* zlib deflate and inflate states */ - - /* get requested output size */ - if (argc != 2) - quit("need one argument: size of output block"); - ret = strtol(argv[1], argv + 1, 10); - if (argv[1][0] != 0) - quit("argument must be a number"); - if (ret < 8) /* 8 is minimum zlib stream size */ - quit("need positive size of 8 or greater"); - size = (unsigned)ret; - - /* allocate memory for buffers and compression engine */ - blk = malloc(size + EXCESS); - def.zalloc = Z_NULL; - def.zfree = Z_NULL; - def.opaque = Z_NULL; - ret = deflateInit(&def, Z_DEFAULT_COMPRESSION); - if (ret != Z_OK || blk == NULL) - quit("out of memory"); - - /* compress from stdin until output full, or no more input */ - def.avail_out = size + EXCESS; - def.next_out = blk; - ret = partcompress(stdin, &def); - if (ret == Z_ERRNO) - quit("error reading input"); - - /* if it all fit, then size was undersubscribed -- done! */ - if (ret == Z_STREAM_END && def.avail_out >= EXCESS) { - /* write block to stdout */ - have = size + EXCESS - def.avail_out; - if (fwrite(blk, 1, have, stdout) != have || ferror(stdout)) - quit("error writing output"); - - /* clean up and print results to stderr */ - ret = deflateEnd(&def); - assert(ret != Z_STREAM_ERROR); - free(blk); - fprintf(stderr, - "%u bytes unused out of %u requested (all input)\n", - size - have, size); - return 0; - } - - /* it didn't all fit -- set up for recompression */ - inf.zalloc = Z_NULL; - inf.zfree = Z_NULL; - inf.opaque = Z_NULL; - inf.avail_in = 0; - inf.next_in = Z_NULL; - ret = inflateInit(&inf); - tmp = malloc(size + EXCESS); - if (ret != Z_OK || tmp == NULL) - quit("out of memory"); - ret = deflateReset(&def); - assert(ret != Z_STREAM_ERROR); - - /* do first recompression close to the right amount */ - inf.avail_in = size + EXCESS; - inf.next_in = blk; - def.avail_out = size + EXCESS; - def.next_out = tmp; - ret = recompress(&inf, &def); - if (ret == Z_MEM_ERROR) - quit("out of memory"); - - /* set up for next reocmpression */ - ret = inflateReset(&inf); - assert(ret != Z_STREAM_ERROR); - ret = deflateReset(&def); - assert(ret != Z_STREAM_ERROR); - - /* do second and final recompression (third compression) */ - inf.avail_in = size - MARGIN; /* assure stream will complete */ - inf.next_in = tmp; - def.avail_out = size; - def.next_out = blk; - ret = recompress(&inf, &def); - if (ret == Z_MEM_ERROR) - quit("out of memory"); - assert(ret == Z_STREAM_END); /* otherwise MARGIN too small */ - - /* done -- write block to stdout */ - have = size - def.avail_out; - if (fwrite(blk, 1, have, stdout) != have || ferror(stdout)) - quit("error writing output"); - - /* clean up and print results to stderr */ - free(tmp); - ret = inflateEnd(&inf); - assert(ret != Z_STREAM_ERROR); - ret = deflateEnd(&def); - assert(ret != Z_STREAM_ERROR); - free(blk); - fprintf(stderr, - "%u bytes unused out of %u requested (%lu input)\n", - size - have, size, def.total_in); - return 0; -} DELETED compat/zlib/examples/gun.c Index: compat/zlib/examples/gun.c ================================================================== --- compat/zlib/examples/gun.c +++ /dev/null @@ -1,702 +0,0 @@ -/* gun.c -- simple gunzip to give an example of the use of inflateBack() - * Copyright (C) 2003, 2005, 2008, 2010, 2012 Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - Version 1.7 12 August 2012 Mark Adler */ - -/* Version history: - 1.0 16 Feb 2003 First version for testing of inflateBack() - 1.1 21 Feb 2005 Decompress concatenated gzip streams - Remove use of "this" variable (C++ keyword) - Fix return value for in() - Improve allocation failure checking - Add typecasting for void * structures - Add -h option for command version and usage - Add a bunch of comments - 1.2 20 Mar 2005 Add Unix compress (LZW) decompression - Copy file attributes from input file to output file - 1.3 12 Jun 2005 Add casts for error messages [Oberhumer] - 1.4 8 Dec 2006 LZW decompression speed improvements - 1.5 9 Feb 2008 Avoid warning in latest version of gcc - 1.6 17 Jan 2010 Avoid signed/unsigned comparison warnings - 1.7 12 Aug 2012 Update for z_const usage in zlib 1.2.8 - */ - -/* - gun [ -t ] [ name ... ] - - decompresses the data in the named gzip files. If no arguments are given, - gun will decompress from stdin to stdout. The names must end in .gz, -gz, - .z, -z, _z, or .Z. The uncompressed data will be written to a file name - with the suffix stripped. On success, the original file is deleted. On - failure, the output file is deleted. For most failures, the command will - continue to process the remaining names on the command line. A memory - allocation failure will abort the command. If -t is specified, then the - listed files or stdin will be tested as gzip files for integrity (without - checking for a proper suffix), no output will be written, and no files - will be deleted. - - Like gzip, gun allows concatenated gzip streams and will decompress them, - writing all of the uncompressed data to the output. Unlike gzip, gun allows - an empty file on input, and will produce no error writing an empty output - file. - - gun will also decompress files made by Unix compress, which uses LZW - compression. These files are automatically detected by virtue of their - magic header bytes. Since the end of Unix compress stream is marked by the - end-of-file, they cannot be concantenated. If a Unix compress stream is - encountered in an input file, it is the last stream in that file. - - Like gunzip and uncompress, the file attributes of the original compressed - file are maintained in the final uncompressed file, to the extent that the - user permissions allow it. - - On my Mac OS X PowerPC G4, gun is almost twice as fast as gunzip (version - 1.2.4) is on the same file, when gun is linked with zlib 1.2.2. Also the - LZW decompression provided by gun is about twice as fast as the standard - Unix uncompress command. - */ - -/* external functions and related types and constants */ -#include /* fprintf() */ -#include /* malloc(), free() */ -#include /* strerror(), strcmp(), strlen(), memcpy() */ -#include /* errno */ -#include /* open() */ -#include /* read(), write(), close(), chown(), unlink() */ -#include -#include /* stat(), chmod() */ -#include /* utime() */ -#include "zlib.h" /* inflateBackInit(), inflateBack(), */ - /* inflateBackEnd(), crc32() */ - -/* function declaration */ -#define local static - -/* buffer constants */ -#define SIZE 32768U /* input and output buffer sizes */ -#define PIECE 16384 /* limits i/o chunks for 16-bit int case */ - -/* structure for infback() to pass to input function in() -- it maintains the - input file and a buffer of size SIZE */ -struct ind { - int infile; - unsigned char *inbuf; -}; - -/* Load input buffer, assumed to be empty, and return bytes loaded and a - pointer to them. read() is called until the buffer is full, or until it - returns end-of-file or error. Return 0 on error. */ -local unsigned in(void *in_desc, z_const unsigned char **buf) -{ - int ret; - unsigned len; - unsigned char *next; - struct ind *me = (struct ind *)in_desc; - - next = me->inbuf; - *buf = next; - len = 0; - do { - ret = PIECE; - if ((unsigned)ret > SIZE - len) - ret = (int)(SIZE - len); - ret = (int)read(me->infile, next, ret); - if (ret == -1) { - len = 0; - break; - } - next += ret; - len += ret; - } while (ret != 0 && len < SIZE); - return len; -} - -/* structure for infback() to pass to output function out() -- it maintains the - output file, a running CRC-32 check on the output and the total number of - bytes output, both for checking against the gzip trailer. (The length in - the gzip trailer is stored modulo 2^32, so it's ok if a long is 32 bits and - the output is greater than 4 GB.) */ -struct outd { - int outfile; - int check; /* true if checking crc and total */ - unsigned long crc; - unsigned long total; -}; - -/* Write output buffer and update the CRC-32 and total bytes written. write() - is called until all of the output is written or an error is encountered. - On success out() returns 0. For a write failure, out() returns 1. If the - output file descriptor is -1, then nothing is written. - */ -local int out(void *out_desc, unsigned char *buf, unsigned len) -{ - int ret; - struct outd *me = (struct outd *)out_desc; - - if (me->check) { - me->crc = crc32(me->crc, buf, len); - me->total += len; - } - if (me->outfile != -1) - do { - ret = PIECE; - if ((unsigned)ret > len) - ret = (int)len; - ret = (int)write(me->outfile, buf, ret); - if (ret == -1) - return 1; - buf += ret; - len -= ret; - } while (len != 0); - return 0; -} - -/* next input byte macro for use inside lunpipe() and gunpipe() */ -#define NEXT() (have ? 0 : (have = in(indp, &next)), \ - last = have ? (have--, (int)(*next++)) : -1) - -/* memory for gunpipe() and lunpipe() -- - the first 256 entries of prefix[] and suffix[] are never used, could - have offset the index, but it's faster to waste the memory */ -unsigned char inbuf[SIZE]; /* input buffer */ -unsigned char outbuf[SIZE]; /* output buffer */ -unsigned short prefix[65536]; /* index to LZW prefix string */ -unsigned char suffix[65536]; /* one-character LZW suffix */ -unsigned char match[65280 + 2]; /* buffer for reversed match or gzip - 32K sliding window */ - -/* throw out what's left in the current bits byte buffer (this is a vestigial - aspect of the compressed data format derived from an implementation that - made use of a special VAX machine instruction!) */ -#define FLUSHCODE() \ - do { \ - left = 0; \ - rem = 0; \ - if (chunk > have) { \ - chunk -= have; \ - have = 0; \ - if (NEXT() == -1) \ - break; \ - chunk--; \ - if (chunk > have) { \ - chunk = have = 0; \ - break; \ - } \ - } \ - have -= chunk; \ - next += chunk; \ - chunk = 0; \ - } while (0) - -/* Decompress a compress (LZW) file from indp to outfile. The compress magic - header (two bytes) has already been read and verified. There are have bytes - of buffered input at next. strm is used for passing error information back - to gunpipe(). - - lunpipe() will return Z_OK on success, Z_BUF_ERROR for an unexpected end of - file, read error, or write error (a write error indicated by strm->next_in - not equal to Z_NULL), or Z_DATA_ERROR for invalid input. - */ -local int lunpipe(unsigned have, z_const unsigned char *next, struct ind *indp, - int outfile, z_stream *strm) -{ - int last; /* last byte read by NEXT(), or -1 if EOF */ - unsigned chunk; /* bytes left in current chunk */ - int left; /* bits left in rem */ - unsigned rem; /* unused bits from input */ - int bits; /* current bits per code */ - unsigned code; /* code, table traversal index */ - unsigned mask; /* mask for current bits codes */ - int max; /* maximum bits per code for this stream */ - unsigned flags; /* compress flags, then block compress flag */ - unsigned end; /* last valid entry in prefix/suffix tables */ - unsigned temp; /* current code */ - unsigned prev; /* previous code */ - unsigned final; /* last character written for previous code */ - unsigned stack; /* next position for reversed string */ - unsigned outcnt; /* bytes in output buffer */ - struct outd outd; /* output structure */ - unsigned char *p; - - /* set up output */ - outd.outfile = outfile; - outd.check = 0; - - /* process remainder of compress header -- a flags byte */ - flags = NEXT(); - if (last == -1) - return Z_BUF_ERROR; - if (flags & 0x60) { - strm->msg = (char *)"unknown lzw flags set"; - return Z_DATA_ERROR; - } - max = flags & 0x1f; - if (max < 9 || max > 16) { - strm->msg = (char *)"lzw bits out of range"; - return Z_DATA_ERROR; - } - if (max == 9) /* 9 doesn't really mean 9 */ - max = 10; - flags &= 0x80; /* true if block compress */ - - /* clear table */ - bits = 9; - mask = 0x1ff; - end = flags ? 256 : 255; - - /* set up: get first 9-bit code, which is the first decompressed byte, but - don't create a table entry until the next code */ - if (NEXT() == -1) /* no compressed data is ok */ - return Z_OK; - final = prev = (unsigned)last; /* low 8 bits of code */ - if (NEXT() == -1) /* missing a bit */ - return Z_BUF_ERROR; - if (last & 1) { /* code must be < 256 */ - strm->msg = (char *)"invalid lzw code"; - return Z_DATA_ERROR; - } - rem = (unsigned)last >> 1; /* remaining 7 bits */ - left = 7; - chunk = bits - 2; /* 7 bytes left in this chunk */ - outbuf[0] = (unsigned char)final; /* write first decompressed byte */ - outcnt = 1; - - /* decode codes */ - stack = 0; - for (;;) { - /* if the table will be full after this, increment the code size */ - if (end >= mask && bits < max) { - FLUSHCODE(); - bits++; - mask <<= 1; - mask++; - } - - /* get a code of length bits */ - if (chunk == 0) /* decrement chunk modulo bits */ - chunk = bits; - code = rem; /* low bits of code */ - if (NEXT() == -1) { /* EOF is end of compressed data */ - /* write remaining buffered output */ - if (outcnt && out(&outd, outbuf, outcnt)) { - strm->next_in = outbuf; /* signal write error */ - return Z_BUF_ERROR; - } - return Z_OK; - } - code += (unsigned)last << left; /* middle (or high) bits of code */ - left += 8; - chunk--; - if (bits > left) { /* need more bits */ - if (NEXT() == -1) /* can't end in middle of code */ - return Z_BUF_ERROR; - code += (unsigned)last << left; /* high bits of code */ - left += 8; - chunk--; - } - code &= mask; /* mask to current code length */ - left -= bits; /* number of unused bits */ - rem = (unsigned)last >> (8 - left); /* unused bits from last byte */ - - /* process clear code (256) */ - if (code == 256 && flags) { - FLUSHCODE(); - bits = 9; /* initialize bits and mask */ - mask = 0x1ff; - end = 255; /* empty table */ - continue; /* get next code */ - } - - /* special code to reuse last match */ - temp = code; /* save the current code */ - if (code > end) { - /* Be picky on the allowed code here, and make sure that the code - we drop through (prev) will be a valid index so that random - input does not cause an exception. The code != end + 1 check is - empirically derived, and not checked in the original uncompress - code. If this ever causes a problem, that check could be safely - removed. Leaving this check in greatly improves gun's ability - to detect random or corrupted input after a compress header. - In any case, the prev > end check must be retained. */ - if (code != end + 1 || prev > end) { - strm->msg = (char *)"invalid lzw code"; - return Z_DATA_ERROR; - } - match[stack++] = (unsigned char)final; - code = prev; - } - - /* walk through linked list to generate output in reverse order */ - p = match + stack; - while (code >= 256) { - *p++ = suffix[code]; - code = prefix[code]; - } - stack = p - match; - match[stack++] = (unsigned char)code; - final = code; - - /* link new table entry */ - if (end < mask) { - end++; - prefix[end] = (unsigned short)prev; - suffix[end] = (unsigned char)final; - } - - /* set previous code for next iteration */ - prev = temp; - - /* write output in forward order */ - while (stack > SIZE - outcnt) { - while (outcnt < SIZE) - outbuf[outcnt++] = match[--stack]; - if (out(&outd, outbuf, outcnt)) { - strm->next_in = outbuf; /* signal write error */ - return Z_BUF_ERROR; - } - outcnt = 0; - } - p = match + stack; - do { - outbuf[outcnt++] = *--p; - } while (p > match); - stack = 0; - - /* loop for next code with final and prev as the last match, rem and - left provide the first 0..7 bits of the next code, end is the last - valid table entry */ - } -} - -/* Decompress a gzip file from infile to outfile. strm is assumed to have been - successfully initialized with inflateBackInit(). The input file may consist - of a series of gzip streams, in which case all of them will be decompressed - to the output file. If outfile is -1, then the gzip stream(s) integrity is - checked and nothing is written. - - The return value is a zlib error code: Z_MEM_ERROR if out of memory, - Z_DATA_ERROR if the header or the compressed data is invalid, or if the - trailer CRC-32 check or length doesn't match, Z_BUF_ERROR if the input ends - prematurely or a write error occurs, or Z_ERRNO if junk (not a another gzip - stream) follows a valid gzip stream. - */ -local int gunpipe(z_stream *strm, int infile, int outfile) -{ - int ret, first, last; - unsigned have, flags, len; - z_const unsigned char *next = NULL; - struct ind ind, *indp; - struct outd outd; - - /* setup input buffer */ - ind.infile = infile; - ind.inbuf = inbuf; - indp = &ind; - - /* decompress concatenated gzip streams */ - have = 0; /* no input data read in yet */ - first = 1; /* looking for first gzip header */ - strm->next_in = Z_NULL; /* so Z_BUF_ERROR means EOF */ - for (;;) { - /* look for the two magic header bytes for a gzip stream */ - if (NEXT() == -1) { - ret = Z_OK; - break; /* empty gzip stream is ok */ - } - if (last != 31 || (NEXT() != 139 && last != 157)) { - strm->msg = (char *)"incorrect header check"; - ret = first ? Z_DATA_ERROR : Z_ERRNO; - break; /* not a gzip or compress header */ - } - first = 0; /* next non-header is junk */ - - /* process a compress (LZW) file -- can't be concatenated after this */ - if (last == 157) { - ret = lunpipe(have, next, indp, outfile, strm); - break; - } - - /* process remainder of gzip header */ - ret = Z_BUF_ERROR; - if (NEXT() != 8) { /* only deflate method allowed */ - if (last == -1) break; - strm->msg = (char *)"unknown compression method"; - ret = Z_DATA_ERROR; - break; - } - flags = NEXT(); /* header flags */ - NEXT(); /* discard mod time, xflgs, os */ - NEXT(); - NEXT(); - NEXT(); - NEXT(); - NEXT(); - if (last == -1) break; - if (flags & 0xe0) { - strm->msg = (char *)"unknown header flags set"; - ret = Z_DATA_ERROR; - break; - } - if (flags & 4) { /* extra field */ - len = NEXT(); - len += (unsigned)(NEXT()) << 8; - if (last == -1) break; - while (len > have) { - len -= have; - have = 0; - if (NEXT() == -1) break; - len--; - } - if (last == -1) break; - have -= len; - next += len; - } - if (flags & 8) /* file name */ - while (NEXT() != 0 && last != -1) - ; - if (flags & 16) /* comment */ - while (NEXT() != 0 && last != -1) - ; - if (flags & 2) { /* header crc */ - NEXT(); - NEXT(); - } - if (last == -1) break; - - /* set up output */ - outd.outfile = outfile; - outd.check = 1; - outd.crc = crc32(0L, Z_NULL, 0); - outd.total = 0; - - /* decompress data to output */ - strm->next_in = next; - strm->avail_in = have; - ret = inflateBack(strm, in, indp, out, &outd); - if (ret != Z_STREAM_END) break; - next = strm->next_in; - have = strm->avail_in; - strm->next_in = Z_NULL; /* so Z_BUF_ERROR means EOF */ - - /* check trailer */ - ret = Z_BUF_ERROR; - if (NEXT() != (int)(outd.crc & 0xff) || - NEXT() != (int)((outd.crc >> 8) & 0xff) || - NEXT() != (int)((outd.crc >> 16) & 0xff) || - NEXT() != (int)((outd.crc >> 24) & 0xff)) { - /* crc error */ - if (last != -1) { - strm->msg = (char *)"incorrect data check"; - ret = Z_DATA_ERROR; - } - break; - } - if (NEXT() != (int)(outd.total & 0xff) || - NEXT() != (int)((outd.total >> 8) & 0xff) || - NEXT() != (int)((outd.total >> 16) & 0xff) || - NEXT() != (int)((outd.total >> 24) & 0xff)) { - /* length error */ - if (last != -1) { - strm->msg = (char *)"incorrect length check"; - ret = Z_DATA_ERROR; - } - break; - } - - /* go back and look for another gzip stream */ - } - - /* clean up and return */ - return ret; -} - -/* Copy file attributes, from -> to, as best we can. This is best effort, so - no errors are reported. The mode bits, including suid, sgid, and the sticky - bit are copied (if allowed), the owner's user id and group id are copied - (again if allowed), and the access and modify times are copied. */ -local void copymeta(char *from, char *to) -{ - struct stat was; - struct utimbuf when; - - /* get all of from's Unix meta data, return if not a regular file */ - if (stat(from, &was) != 0 || (was.st_mode & S_IFMT) != S_IFREG) - return; - - /* set to's mode bits, ignore errors */ - (void)chmod(to, was.st_mode & 07777); - - /* copy owner's user and group, ignore errors */ - (void)chown(to, was.st_uid, was.st_gid); - - /* copy access and modify times, ignore errors */ - when.actime = was.st_atime; - when.modtime = was.st_mtime; - (void)utime(to, &when); -} - -/* Decompress the file inname to the file outnname, of if test is true, just - decompress without writing and check the gzip trailer for integrity. If - inname is NULL or an empty string, read from stdin. If outname is NULL or - an empty string, write to stdout. strm is a pre-initialized inflateBack - structure. When appropriate, copy the file attributes from inname to - outname. - - gunzip() returns 1 if there is an out-of-memory error or an unexpected - return code from gunpipe(). Otherwise it returns 0. - */ -local int gunzip(z_stream *strm, char *inname, char *outname, int test) -{ - int ret; - int infile, outfile; - - /* open files */ - if (inname == NULL || *inname == 0) { - inname = "-"; - infile = 0; /* stdin */ - } - else { - infile = open(inname, O_RDONLY, 0); - if (infile == -1) { - fprintf(stderr, "gun cannot open %s\n", inname); - return 0; - } - } - if (test) - outfile = -1; - else if (outname == NULL || *outname == 0) { - outname = "-"; - outfile = 1; /* stdout */ - } - else { - outfile = open(outname, O_CREAT | O_TRUNC | O_WRONLY, 0666); - if (outfile == -1) { - close(infile); - fprintf(stderr, "gun cannot create %s\n", outname); - return 0; - } - } - errno = 0; - - /* decompress */ - ret = gunpipe(strm, infile, outfile); - if (outfile > 2) close(outfile); - if (infile > 2) close(infile); - - /* interpret result */ - switch (ret) { - case Z_OK: - case Z_ERRNO: - if (infile > 2 && outfile > 2) { - copymeta(inname, outname); /* copy attributes */ - unlink(inname); - } - if (ret == Z_ERRNO) - fprintf(stderr, "gun warning: trailing garbage ignored in %s\n", - inname); - break; - case Z_DATA_ERROR: - if (outfile > 2) unlink(outname); - fprintf(stderr, "gun data error on %s: %s\n", inname, strm->msg); - break; - case Z_MEM_ERROR: - if (outfile > 2) unlink(outname); - fprintf(stderr, "gun out of memory error--aborting\n"); - return 1; - case Z_BUF_ERROR: - if (outfile > 2) unlink(outname); - if (strm->next_in != Z_NULL) { - fprintf(stderr, "gun write error on %s: %s\n", - outname, strerror(errno)); - } - else if (errno) { - fprintf(stderr, "gun read error on %s: %s\n", - inname, strerror(errno)); - } - else { - fprintf(stderr, "gun unexpected end of file on %s\n", - inname); - } - break; - default: - if (outfile > 2) unlink(outname); - fprintf(stderr, "gun internal error--aborting\n"); - return 1; - } - return 0; -} - -/* Process the gun command line arguments. See the command syntax near the - beginning of this source file. */ -int main(int argc, char **argv) -{ - int ret, len, test; - char *outname; - unsigned char *window; - z_stream strm; - - /* initialize inflateBack state for repeated use */ - window = match; /* reuse LZW match buffer */ - strm.zalloc = Z_NULL; - strm.zfree = Z_NULL; - strm.opaque = Z_NULL; - ret = inflateBackInit(&strm, 15, window); - if (ret != Z_OK) { - fprintf(stderr, "gun out of memory error--aborting\n"); - return 1; - } - - /* decompress each file to the same name with the suffix removed */ - argc--; - argv++; - test = 0; - if (argc && strcmp(*argv, "-h") == 0) { - fprintf(stderr, "gun 1.6 (17 Jan 2010)\n"); - fprintf(stderr, "Copyright (C) 2003-2010 Mark Adler\n"); - fprintf(stderr, "usage: gun [-t] [file1.gz [file2.Z ...]]\n"); - return 0; - } - if (argc && strcmp(*argv, "-t") == 0) { - test = 1; - argc--; - argv++; - } - if (argc) - do { - if (test) - outname = NULL; - else { - len = (int)strlen(*argv); - if (strcmp(*argv + len - 3, ".gz") == 0 || - strcmp(*argv + len - 3, "-gz") == 0) - len -= 3; - else if (strcmp(*argv + len - 2, ".z") == 0 || - strcmp(*argv + len - 2, "-z") == 0 || - strcmp(*argv + len - 2, "_z") == 0 || - strcmp(*argv + len - 2, ".Z") == 0) - len -= 2; - else { - fprintf(stderr, "gun error: no gz type on %s--skipping\n", - *argv); - continue; - } - outname = malloc(len + 1); - if (outname == NULL) { - fprintf(stderr, "gun out of memory error--aborting\n"); - ret = 1; - break; - } - memcpy(outname, *argv, len); - outname[len] = 0; - } - ret = gunzip(&strm, *argv, outname, test); - if (outname != NULL) free(outname); - if (ret) break; - } while (argv++, --argc); - else - ret = gunzip(&strm, NULL, NULL, test); - - /* clean up */ - inflateBackEnd(&strm); - return ret; -} DELETED compat/zlib/examples/gzappend.c Index: compat/zlib/examples/gzappend.c ================================================================== --- compat/zlib/examples/gzappend.c +++ /dev/null @@ -1,504 +0,0 @@ -/* gzappend -- command to append to a gzip file - - Copyright (C) 2003, 2012 Mark Adler, all rights reserved - version 1.2, 11 Oct 2012 - - This software is provided 'as-is', without any express or implied - warranty. In no event will the author be held liable for any damages - arising from the use of this software. - - Permission is granted to anyone to use this software for any purpose, - including commercial applications, and to alter it and redistribute it - freely, subject to the following restrictions: - - 1. The origin of this software must not be misrepresented; you must not - claim that you wrote the original software. If you use this software - in a product, an acknowledgment in the product documentation would be - appreciated but is not required. - 2. Altered source versions must be plainly marked as such, and must not be - misrepresented as being the original software. - 3. This notice may not be removed or altered from any source distribution. - - Mark Adler madler@alumni.caltech.edu - */ - -/* - * Change history: - * - * 1.0 19 Oct 2003 - First version - * 1.1 4 Nov 2003 - Expand and clarify some comments and notes - * - Add version and copyright to help - * - Send help to stdout instead of stderr - * - Add some preemptive typecasts - * - Add L to constants in lseek() calls - * - Remove some debugging information in error messages - * - Use new data_type definition for zlib 1.2.1 - * - Simplfy and unify file operations - * - Finish off gzip file in gztack() - * - Use deflatePrime() instead of adding empty blocks - * - Keep gzip file clean on appended file read errors - * - Use in-place rotate instead of auxiliary buffer - * (Why you ask? Because it was fun to write!) - * 1.2 11 Oct 2012 - Fix for proper z_const usage - * - Check for input buffer malloc failure - */ - -/* - gzappend takes a gzip file and appends to it, compressing files from the - command line or data from stdin. The gzip file is written to directly, to - avoid copying that file, in case it's large. Note that this results in the - unfriendly behavior that if gzappend fails, the gzip file is corrupted. - - This program was written to illustrate the use of the new Z_BLOCK option of - zlib 1.2.x's inflate() function. This option returns from inflate() at each - block boundary to facilitate locating and modifying the last block bit at - the start of the final deflate block. Also whether using Z_BLOCK or not, - another required feature of zlib 1.2.x is that inflate() now provides the - number of unusued bits in the last input byte used. gzappend will not work - with versions of zlib earlier than 1.2.1. - - gzappend first decompresses the gzip file internally, discarding all but - the last 32K of uncompressed data, and noting the location of the last block - bit and the number of unused bits in the last byte of the compressed data. - The gzip trailer containing the CRC-32 and length of the uncompressed data - is verified. This trailer will be later overwritten. - - Then the last block bit is cleared by seeking back in the file and rewriting - the byte that contains it. Seeking forward, the last byte of the compressed - data is saved along with the number of unused bits to initialize deflate. - - A deflate process is initialized, using the last 32K of the uncompressed - data from the gzip file to initialize the dictionary. If the total - uncompressed data was less than 32K, then all of it is used to initialize - the dictionary. The deflate output bit buffer is also initialized with the - last bits from the original deflate stream. From here on, the data to - append is simply compressed using deflate, and written to the gzip file. - When that is complete, the new CRC-32 and uncompressed length are written - as the trailer of the gzip file. - */ - -#include -#include -#include -#include -#include -#include "zlib.h" - -#define local static -#define LGCHUNK 14 -#define CHUNK (1U << LGCHUNK) -#define DSIZE 32768U - -/* print an error message and terminate with extreme prejudice */ -local void bye(char *msg1, char *msg2) -{ - fprintf(stderr, "gzappend error: %s%s\n", msg1, msg2); - exit(1); -} - -/* return the greatest common divisor of a and b using Euclid's algorithm, - modified to be fast when one argument much greater than the other, and - coded to avoid unnecessary swapping */ -local unsigned gcd(unsigned a, unsigned b) -{ - unsigned c; - - while (a && b) - if (a > b) { - c = b; - while (a - c >= c) - c <<= 1; - a -= c; - } - else { - c = a; - while (b - c >= c) - c <<= 1; - b -= c; - } - return a + b; -} - -/* rotate list[0..len-1] left by rot positions, in place */ -local void rotate(unsigned char *list, unsigned len, unsigned rot) -{ - unsigned char tmp; - unsigned cycles; - unsigned char *start, *last, *to, *from; - - /* normalize rot and handle degenerate cases */ - if (len < 2) return; - if (rot >= len) rot %= len; - if (rot == 0) return; - - /* pointer to last entry in list */ - last = list + (len - 1); - - /* do simple left shift by one */ - if (rot == 1) { - tmp = *list; - memcpy(list, list + 1, len - 1); - *last = tmp; - return; - } - - /* do simple right shift by one */ - if (rot == len - 1) { - tmp = *last; - memmove(list + 1, list, len - 1); - *list = tmp; - return; - } - - /* otherwise do rotate as a set of cycles in place */ - cycles = gcd(len, rot); /* number of cycles */ - do { - start = from = list + cycles; /* start index is arbitrary */ - tmp = *from; /* save entry to be overwritten */ - for (;;) { - to = from; /* next step in cycle */ - from += rot; /* go right rot positions */ - if (from > last) from -= len; /* (pointer better not wrap) */ - if (from == start) break; /* all but one shifted */ - *to = *from; /* shift left */ - } - *to = tmp; /* complete the circle */ - } while (--cycles); -} - -/* structure for gzip file read operations */ -typedef struct { - int fd; /* file descriptor */ - int size; /* 1 << size is bytes in buf */ - unsigned left; /* bytes available at next */ - unsigned char *buf; /* buffer */ - z_const unsigned char *next; /* next byte in buffer */ - char *name; /* file name for error messages */ -} file; - -/* reload buffer */ -local int readin(file *in) -{ - int len; - - len = read(in->fd, in->buf, 1 << in->size); - if (len == -1) bye("error reading ", in->name); - in->left = (unsigned)len; - in->next = in->buf; - return len; -} - -/* read from file in, exit if end-of-file */ -local int readmore(file *in) -{ - if (readin(in) == 0) bye("unexpected end of ", in->name); - return 0; -} - -#define read1(in) (in->left == 0 ? readmore(in) : 0, \ - in->left--, *(in->next)++) - -/* skip over n bytes of in */ -local void skip(file *in, unsigned n) -{ - unsigned bypass; - - if (n > in->left) { - n -= in->left; - bypass = n & ~((1U << in->size) - 1); - if (bypass) { - if (lseek(in->fd, (off_t)bypass, SEEK_CUR) == -1) - bye("seeking ", in->name); - n -= bypass; - } - readmore(in); - if (n > in->left) - bye("unexpected end of ", in->name); - } - in->left -= n; - in->next += n; -} - -/* read a four-byte unsigned integer, little-endian, from in */ -unsigned long read4(file *in) -{ - unsigned long val; - - val = read1(in); - val += (unsigned)read1(in) << 8; - val += (unsigned long)read1(in) << 16; - val += (unsigned long)read1(in) << 24; - return val; -} - -/* skip over gzip header */ -local void gzheader(file *in) -{ - int flags; - unsigned n; - - if (read1(in) != 31 || read1(in) != 139) bye(in->name, " not a gzip file"); - if (read1(in) != 8) bye("unknown compression method in", in->name); - flags = read1(in); - if (flags & 0xe0) bye("unknown header flags set in", in->name); - skip(in, 6); - if (flags & 4) { - n = read1(in); - n += (unsigned)(read1(in)) << 8; - skip(in, n); - } - if (flags & 8) while (read1(in) != 0) ; - if (flags & 16) while (read1(in) != 0) ; - if (flags & 2) skip(in, 2); -} - -/* decompress gzip file "name", return strm with a deflate stream ready to - continue compression of the data in the gzip file, and return a file - descriptor pointing to where to write the compressed data -- the deflate - stream is initialized to compress using level "level" */ -local int gzscan(char *name, z_stream *strm, int level) -{ - int ret, lastbit, left, full; - unsigned have; - unsigned long crc, tot; - unsigned char *window; - off_t lastoff, end; - file gz; - - /* open gzip file */ - gz.name = name; - gz.fd = open(name, O_RDWR, 0); - if (gz.fd == -1) bye("cannot open ", name); - gz.buf = malloc(CHUNK); - if (gz.buf == NULL) bye("out of memory", ""); - gz.size = LGCHUNK; - gz.left = 0; - - /* skip gzip header */ - gzheader(&gz); - - /* prepare to decompress */ - window = malloc(DSIZE); - if (window == NULL) bye("out of memory", ""); - strm->zalloc = Z_NULL; - strm->zfree = Z_NULL; - strm->opaque = Z_NULL; - ret = inflateInit2(strm, -15); - if (ret != Z_OK) bye("out of memory", " or library mismatch"); - - /* decompress the deflate stream, saving append information */ - lastbit = 0; - lastoff = lseek(gz.fd, 0L, SEEK_CUR) - gz.left; - left = 0; - strm->avail_in = gz.left; - strm->next_in = gz.next; - crc = crc32(0L, Z_NULL, 0); - have = full = 0; - do { - /* if needed, get more input */ - if (strm->avail_in == 0) { - readmore(&gz); - strm->avail_in = gz.left; - strm->next_in = gz.next; - } - - /* set up output to next available section of sliding window */ - strm->avail_out = DSIZE - have; - strm->next_out = window + have; - - /* inflate and check for errors */ - ret = inflate(strm, Z_BLOCK); - if (ret == Z_STREAM_ERROR) bye("internal stream error!", ""); - if (ret == Z_MEM_ERROR) bye("out of memory", ""); - if (ret == Z_DATA_ERROR) - bye("invalid compressed data--format violated in", name); - - /* update crc and sliding window pointer */ - crc = crc32(crc, window + have, DSIZE - have - strm->avail_out); - if (strm->avail_out) - have = DSIZE - strm->avail_out; - else { - have = 0; - full = 1; - } - - /* process end of block */ - if (strm->data_type & 128) { - if (strm->data_type & 64) - left = strm->data_type & 0x1f; - else { - lastbit = strm->data_type & 0x1f; - lastoff = lseek(gz.fd, 0L, SEEK_CUR) - strm->avail_in; - } - } - } while (ret != Z_STREAM_END); - inflateEnd(strm); - gz.left = strm->avail_in; - gz.next = strm->next_in; - - /* save the location of the end of the compressed data */ - end = lseek(gz.fd, 0L, SEEK_CUR) - gz.left; - - /* check gzip trailer and save total for deflate */ - if (crc != read4(&gz)) - bye("invalid compressed data--crc mismatch in ", name); - tot = strm->total_out; - if ((tot & 0xffffffffUL) != read4(&gz)) - bye("invalid compressed data--length mismatch in", name); - - /* if not at end of file, warn */ - if (gz.left || readin(&gz)) - fprintf(stderr, - "gzappend warning: junk at end of gzip file overwritten\n"); - - /* clear last block bit */ - lseek(gz.fd, lastoff - (lastbit != 0), SEEK_SET); - if (read(gz.fd, gz.buf, 1) != 1) bye("reading after seek on ", name); - *gz.buf = (unsigned char)(*gz.buf ^ (1 << ((8 - lastbit) & 7))); - lseek(gz.fd, -1L, SEEK_CUR); - if (write(gz.fd, gz.buf, 1) != 1) bye("writing after seek to ", name); - - /* if window wrapped, build dictionary from window by rotating */ - if (full) { - rotate(window, DSIZE, have); - have = DSIZE; - } - - /* set up deflate stream with window, crc, total_in, and leftover bits */ - ret = deflateInit2(strm, level, Z_DEFLATED, -15, 8, Z_DEFAULT_STRATEGY); - if (ret != Z_OK) bye("out of memory", ""); - deflateSetDictionary(strm, window, have); - strm->adler = crc; - strm->total_in = tot; - if (left) { - lseek(gz.fd, --end, SEEK_SET); - if (read(gz.fd, gz.buf, 1) != 1) bye("reading after seek on ", name); - deflatePrime(strm, 8 - left, *gz.buf); - } - lseek(gz.fd, end, SEEK_SET); - - /* clean up and return */ - free(window); - free(gz.buf); - return gz.fd; -} - -/* append file "name" to gzip file gd using deflate stream strm -- if last - is true, then finish off the deflate stream at the end */ -local void gztack(char *name, int gd, z_stream *strm, int last) -{ - int fd, len, ret; - unsigned left; - unsigned char *in, *out; - - /* open file to compress and append */ - fd = 0; - if (name != NULL) { - fd = open(name, O_RDONLY, 0); - if (fd == -1) - fprintf(stderr, "gzappend warning: %s not found, skipping ...\n", - name); - } - - /* allocate buffers */ - in = malloc(CHUNK); - out = malloc(CHUNK); - if (in == NULL || out == NULL) bye("out of memory", ""); - - /* compress input file and append to gzip file */ - do { - /* get more input */ - len = read(fd, in, CHUNK); - if (len == -1) { - fprintf(stderr, - "gzappend warning: error reading %s, skipping rest ...\n", - name); - len = 0; - } - strm->avail_in = (unsigned)len; - strm->next_in = in; - if (len) strm->adler = crc32(strm->adler, in, (unsigned)len); - - /* compress and write all available output */ - do { - strm->avail_out = CHUNK; - strm->next_out = out; - ret = deflate(strm, last && len == 0 ? Z_FINISH : Z_NO_FLUSH); - left = CHUNK - strm->avail_out; - while (left) { - len = write(gd, out + CHUNK - strm->avail_out - left, left); - if (len == -1) bye("writing gzip file", ""); - left -= (unsigned)len; - } - } while (strm->avail_out == 0 && ret != Z_STREAM_END); - } while (len != 0); - - /* write trailer after last entry */ - if (last) { - deflateEnd(strm); - out[0] = (unsigned char)(strm->adler); - out[1] = (unsigned char)(strm->adler >> 8); - out[2] = (unsigned char)(strm->adler >> 16); - out[3] = (unsigned char)(strm->adler >> 24); - out[4] = (unsigned char)(strm->total_in); - out[5] = (unsigned char)(strm->total_in >> 8); - out[6] = (unsigned char)(strm->total_in >> 16); - out[7] = (unsigned char)(strm->total_in >> 24); - len = 8; - do { - ret = write(gd, out + 8 - len, len); - if (ret == -1) bye("writing gzip file", ""); - len -= ret; - } while (len); - close(gd); - } - - /* clean up and return */ - free(out); - free(in); - if (fd > 0) close(fd); -} - -/* process the compression level option if present, scan the gzip file, and - append the specified files, or append the data from stdin if no other file - names are provided on the command line -- the gzip file must be writable - and seekable */ -int main(int argc, char **argv) -{ - int gd, level; - z_stream strm; - - /* ignore command name */ - argc--; argv++; - - /* provide usage if no arguments */ - if (*argv == NULL) { - printf( - "gzappend 1.2 (11 Oct 2012) Copyright (C) 2003, 2012 Mark Adler\n" - ); - printf( - "usage: gzappend [-level] file.gz [ addthis [ andthis ... ]]\n"); - return 0; - } - - /* set compression level */ - level = Z_DEFAULT_COMPRESSION; - if (argv[0][0] == '-') { - if (argv[0][1] < '0' || argv[0][1] > '9' || argv[0][2] != 0) - bye("invalid compression level", ""); - level = argv[0][1] - '0'; - if (*++argv == NULL) bye("no gzip file name after options", ""); - } - - /* prepare to append to gzip file */ - gd = gzscan(*argv++, &strm, level); - - /* append files on command line, or from stdin if none */ - if (*argv == NULL) - gztack(NULL, gd, &strm, 1); - else - do { - gztack(*argv, gd, &strm, argv[1] == NULL); - } while (*++argv != NULL); - return 0; -} DELETED compat/zlib/examples/gzjoin.c Index: compat/zlib/examples/gzjoin.c ================================================================== --- compat/zlib/examples/gzjoin.c +++ /dev/null @@ -1,449 +0,0 @@ -/* gzjoin -- command to join gzip files into one gzip file - - Copyright (C) 2004, 2005, 2012 Mark Adler, all rights reserved - version 1.2, 14 Aug 2012 - - This software is provided 'as-is', without any express or implied - warranty. In no event will the author be held liable for any damages - arising from the use of this software. - - Permission is granted to anyone to use this software for any purpose, - including commercial applications, and to alter it and redistribute it - freely, subject to the following restrictions: - - 1. The origin of this software must not be misrepresented; you must not - claim that you wrote the original software. If you use this software - in a product, an acknowledgment in the product documentation would be - appreciated but is not required. - 2. Altered source versions must be plainly marked as such, and must not be - misrepresented as being the original software. - 3. This notice may not be removed or altered from any source distribution. - - Mark Adler madler@alumni.caltech.edu - */ - -/* - * Change history: - * - * 1.0 11 Dec 2004 - First version - * 1.1 12 Jun 2005 - Changed ssize_t to long for portability - * 1.2 14 Aug 2012 - Clean up for z_const usage - */ - -/* - gzjoin takes one or more gzip files on the command line and writes out a - single gzip file that will uncompress to the concatenation of the - uncompressed data from the individual gzip files. gzjoin does this without - having to recompress any of the data and without having to calculate a new - crc32 for the concatenated uncompressed data. gzjoin does however have to - decompress all of the input data in order to find the bits in the compressed - data that need to be modified to concatenate the streams. - - gzjoin does not do an integrity check on the input gzip files other than - checking the gzip header and decompressing the compressed data. They are - otherwise assumed to be complete and correct. - - Each joint between gzip files removes at least 18 bytes of previous trailer - and subsequent header, and inserts an average of about three bytes to the - compressed data in order to connect the streams. The output gzip file - has a minimal ten-byte gzip header with no file name or modification time. - - This program was written to illustrate the use of the Z_BLOCK option of - inflate() and the crc32_combine() function. gzjoin will not compile with - versions of zlib earlier than 1.2.3. - */ - -#include /* fputs(), fprintf(), fwrite(), putc() */ -#include /* exit(), malloc(), free() */ -#include /* open() */ -#include /* close(), read(), lseek() */ -#include "zlib.h" - /* crc32(), crc32_combine(), inflateInit2(), inflate(), inflateEnd() */ - -#define local static - -/* exit with an error (return a value to allow use in an expression) */ -local int bail(char *why1, char *why2) -{ - fprintf(stderr, "gzjoin error: %s%s, output incomplete\n", why1, why2); - exit(1); - return 0; -} - -/* -- simple buffered file input with access to the buffer -- */ - -#define CHUNK 32768 /* must be a power of two and fit in unsigned */ - -/* bin buffered input file type */ -typedef struct { - char *name; /* name of file for error messages */ - int fd; /* file descriptor */ - unsigned left; /* bytes remaining at next */ - unsigned char *next; /* next byte to read */ - unsigned char *buf; /* allocated buffer of length CHUNK */ -} bin; - -/* close a buffered file and free allocated memory */ -local void bclose(bin *in) -{ - if (in != NULL) { - if (in->fd != -1) - close(in->fd); - if (in->buf != NULL) - free(in->buf); - free(in); - } -} - -/* open a buffered file for input, return a pointer to type bin, or NULL on - failure */ -local bin *bopen(char *name) -{ - bin *in; - - in = malloc(sizeof(bin)); - if (in == NULL) - return NULL; - in->buf = malloc(CHUNK); - in->fd = open(name, O_RDONLY, 0); - if (in->buf == NULL || in->fd == -1) { - bclose(in); - return NULL; - } - in->left = 0; - in->next = in->buf; - in->name = name; - return in; -} - -/* load buffer from file, return -1 on read error, 0 or 1 on success, with - 1 indicating that end-of-file was reached */ -local int bload(bin *in) -{ - long len; - - if (in == NULL) - return -1; - if (in->left != 0) - return 0; - in->next = in->buf; - do { - len = (long)read(in->fd, in->buf + in->left, CHUNK - in->left); - if (len < 0) - return -1; - in->left += (unsigned)len; - } while (len != 0 && in->left < CHUNK); - return len == 0 ? 1 : 0; -} - -/* get a byte from the file, bail if end of file */ -#define bget(in) (in->left ? 0 : bload(in), \ - in->left ? (in->left--, *(in->next)++) : \ - bail("unexpected end of file on ", in->name)) - -/* get a four-byte little-endian unsigned integer from file */ -local unsigned long bget4(bin *in) -{ - unsigned long val; - - val = bget(in); - val += (unsigned long)(bget(in)) << 8; - val += (unsigned long)(bget(in)) << 16; - val += (unsigned long)(bget(in)) << 24; - return val; -} - -/* skip bytes in file */ -local void bskip(bin *in, unsigned skip) -{ - /* check pointer */ - if (in == NULL) - return; - - /* easy case -- skip bytes in buffer */ - if (skip <= in->left) { - in->left -= skip; - in->next += skip; - return; - } - - /* skip what's in buffer, discard buffer contents */ - skip -= in->left; - in->left = 0; - - /* seek past multiples of CHUNK bytes */ - if (skip > CHUNK) { - unsigned left; - - left = skip & (CHUNK - 1); - if (left == 0) { - /* exact number of chunks: seek all the way minus one byte to check - for end-of-file with a read */ - lseek(in->fd, skip - 1, SEEK_CUR); - if (read(in->fd, in->buf, 1) != 1) - bail("unexpected end of file on ", in->name); - return; - } - - /* skip the integral chunks, update skip with remainder */ - lseek(in->fd, skip - left, SEEK_CUR); - skip = left; - } - - /* read more input and skip remainder */ - bload(in); - if (skip > in->left) - bail("unexpected end of file on ", in->name); - in->left -= skip; - in->next += skip; -} - -/* -- end of buffered input functions -- */ - -/* skip the gzip header from file in */ -local void gzhead(bin *in) -{ - int flags; - - /* verify gzip magic header and compression method */ - if (bget(in) != 0x1f || bget(in) != 0x8b || bget(in) != 8) - bail(in->name, " is not a valid gzip file"); - - /* get and verify flags */ - flags = bget(in); - if ((flags & 0xe0) != 0) - bail("unknown reserved bits set in ", in->name); - - /* skip modification time, extra flags, and os */ - bskip(in, 6); - - /* skip extra field if present */ - if (flags & 4) { - unsigned len; - - len = bget(in); - len += (unsigned)(bget(in)) << 8; - bskip(in, len); - } - - /* skip file name if present */ - if (flags & 8) - while (bget(in) != 0) - ; - - /* skip comment if present */ - if (flags & 16) - while (bget(in) != 0) - ; - - /* skip header crc if present */ - if (flags & 2) - bskip(in, 2); -} - -/* write a four-byte little-endian unsigned integer to out */ -local void put4(unsigned long val, FILE *out) -{ - putc(val & 0xff, out); - putc((val >> 8) & 0xff, out); - putc((val >> 16) & 0xff, out); - putc((val >> 24) & 0xff, out); -} - -/* Load up zlib stream from buffered input, bail if end of file */ -local void zpull(z_streamp strm, bin *in) -{ - if (in->left == 0) - bload(in); - if (in->left == 0) - bail("unexpected end of file on ", in->name); - strm->avail_in = in->left; - strm->next_in = in->next; -} - -/* Write header for gzip file to out and initialize trailer. */ -local void gzinit(unsigned long *crc, unsigned long *tot, FILE *out) -{ - fwrite("\x1f\x8b\x08\0\0\0\0\0\0\xff", 1, 10, out); - *crc = crc32(0L, Z_NULL, 0); - *tot = 0; -} - -/* Copy the compressed data from name, zeroing the last block bit of the last - block if clr is true, and adding empty blocks as needed to get to a byte - boundary. If clr is false, then the last block becomes the last block of - the output, and the gzip trailer is written. crc and tot maintains the - crc and length (modulo 2^32) of the output for the trailer. The resulting - gzip file is written to out. gzinit() must be called before the first call - of gzcopy() to write the gzip header and to initialize crc and tot. */ -local void gzcopy(char *name, int clr, unsigned long *crc, unsigned long *tot, - FILE *out) -{ - int ret; /* return value from zlib functions */ - int pos; /* where the "last block" bit is in byte */ - int last; /* true if processing the last block */ - bin *in; /* buffered input file */ - unsigned char *start; /* start of compressed data in buffer */ - unsigned char *junk; /* buffer for uncompressed data -- discarded */ - z_off_t len; /* length of uncompressed data (support > 4 GB) */ - z_stream strm; /* zlib inflate stream */ - - /* open gzip file and skip header */ - in = bopen(name); - if (in == NULL) - bail("could not open ", name); - gzhead(in); - - /* allocate buffer for uncompressed data and initialize raw inflate - stream */ - junk = malloc(CHUNK); - strm.zalloc = Z_NULL; - strm.zfree = Z_NULL; - strm.opaque = Z_NULL; - strm.avail_in = 0; - strm.next_in = Z_NULL; - ret = inflateInit2(&strm, -15); - if (junk == NULL || ret != Z_OK) - bail("out of memory", ""); - - /* inflate and copy compressed data, clear last-block bit if requested */ - len = 0; - zpull(&strm, in); - start = in->next; - last = start[0] & 1; - if (last && clr) - start[0] &= ~1; - strm.avail_out = 0; - for (;;) { - /* if input used and output done, write used input and get more */ - if (strm.avail_in == 0 && strm.avail_out != 0) { - fwrite(start, 1, strm.next_in - start, out); - start = in->buf; - in->left = 0; - zpull(&strm, in); - } - - /* decompress -- return early when end-of-block reached */ - strm.avail_out = CHUNK; - strm.next_out = junk; - ret = inflate(&strm, Z_BLOCK); - switch (ret) { - case Z_MEM_ERROR: - bail("out of memory", ""); - case Z_DATA_ERROR: - bail("invalid compressed data in ", in->name); - } - - /* update length of uncompressed data */ - len += CHUNK - strm.avail_out; - - /* check for block boundary (only get this when block copied out) */ - if (strm.data_type & 128) { - /* if that was the last block, then done */ - if (last) - break; - - /* number of unused bits in last byte */ - pos = strm.data_type & 7; - - /* find the next last-block bit */ - if (pos != 0) { - /* next last-block bit is in last used byte */ - pos = 0x100 >> pos; - last = strm.next_in[-1] & pos; - if (last && clr) - in->buf[strm.next_in - in->buf - 1] &= ~pos; - } - else { - /* next last-block bit is in next unused byte */ - if (strm.avail_in == 0) { - /* don't have that byte yet -- get it */ - fwrite(start, 1, strm.next_in - start, out); - start = in->buf; - in->left = 0; - zpull(&strm, in); - } - last = strm.next_in[0] & 1; - if (last && clr) - in->buf[strm.next_in - in->buf] &= ~1; - } - } - } - - /* update buffer with unused input */ - in->left = strm.avail_in; - in->next = in->buf + (strm.next_in - in->buf); - - /* copy used input, write empty blocks to get to byte boundary */ - pos = strm.data_type & 7; - fwrite(start, 1, in->next - start - 1, out); - last = in->next[-1]; - if (pos == 0 || !clr) - /* already at byte boundary, or last file: write last byte */ - putc(last, out); - else { - /* append empty blocks to last byte */ - last &= ((0x100 >> pos) - 1); /* assure unused bits are zero */ - if (pos & 1) { - /* odd -- append an empty stored block */ - putc(last, out); - if (pos == 1) - putc(0, out); /* two more bits in block header */ - fwrite("\0\0\xff\xff", 1, 4, out); - } - else { - /* even -- append 1, 2, or 3 empty fixed blocks */ - switch (pos) { - case 6: - putc(last | 8, out); - last = 0; - case 4: - putc(last | 0x20, out); - last = 0; - case 2: - putc(last | 0x80, out); - putc(0, out); - } - } - } - - /* update crc and tot */ - *crc = crc32_combine(*crc, bget4(in), len); - *tot += (unsigned long)len; - - /* clean up */ - inflateEnd(&strm); - free(junk); - bclose(in); - - /* write trailer if this is the last gzip file */ - if (!clr) { - put4(*crc, out); - put4(*tot, out); - } -} - -/* join the gzip files on the command line, write result to stdout */ -int main(int argc, char **argv) -{ - unsigned long crc, tot; /* running crc and total uncompressed length */ - - /* skip command name */ - argc--; - argv++; - - /* show usage if no arguments */ - if (argc == 0) { - fputs("gzjoin usage: gzjoin f1.gz [f2.gz [f3.gz ...]] > fjoin.gz\n", - stderr); - return 0; - } - - /* join gzip files on command line and write to stdout */ - gzinit(&crc, &tot, stdout); - while (argc--) - gzcopy(*argv++, argc, &crc, &tot, stdout); - - /* done */ - return 0; -} DELETED compat/zlib/examples/gzlog.c Index: compat/zlib/examples/gzlog.c ================================================================== --- compat/zlib/examples/gzlog.c +++ /dev/null @@ -1,1059 +0,0 @@ -/* - * gzlog.c - * Copyright (C) 2004, 2008, 2012, 2016 Mark Adler, all rights reserved - * For conditions of distribution and use, see copyright notice in gzlog.h - * version 2.2, 14 Aug 2012 - */ - -/* - gzlog provides a mechanism for frequently appending short strings to a gzip - file that is efficient both in execution time and compression ratio. The - strategy is to write the short strings in an uncompressed form to the end of - the gzip file, only compressing when the amount of uncompressed data has - reached a given threshold. - - gzlog also provides protection against interruptions in the process due to - system crashes. The status of the operation is recorded in an extra field - in the gzip file, and is only updated once the gzip file is brought to a - valid state. The last data to be appended or compressed is saved in an - auxiliary file, so that if the operation is interrupted, it can be completed - the next time an append operation is attempted. - - gzlog maintains another auxiliary file with the last 32K of data from the - compressed portion, which is preloaded for the compression of the subsequent - data. This minimizes the impact to the compression ratio of appending. - */ - -/* - Operations Concept: - - Files (log name "foo"): - foo.gz -- gzip file with the complete log - foo.add -- last message to append or last data to compress - foo.dict -- dictionary of the last 32K of data for next compression - foo.temp -- temporary dictionary file for compression after this one - foo.lock -- lock file for reading and writing the other files - foo.repairs -- log file for log file recovery operations (not compressed) - - gzip file structure: - - fixed-length (no file name) header with extra field (see below) - - compressed data ending initially with empty stored block - - uncompressed data filling out originally empty stored block and - subsequent stored blocks as needed (16K max each) - - gzip trailer - - no junk at end (no other gzip streams) - - When appending data, the information in the first three items above plus the - foo.add file are sufficient to recover an interrupted append operation. The - extra field has the necessary information to restore the start of the last - stored block and determine where to append the data in the foo.add file, as - well as the crc and length of the gzip data before the append operation. - - The foo.add file is created before the gzip file is marked for append, and - deleted after the gzip file is marked as complete. So if the append - operation is interrupted, the data to add will still be there. If due to - some external force, the foo.add file gets deleted between when the append - operation was interrupted and when recovery is attempted, the gzip file will - still be restored, but without the appended data. - - When compressing data, the information in the first two items above plus the - foo.add file are sufficient to recover an interrupted compress operation. - The extra field has the necessary information to find the end of the - compressed data, and contains both the crc and length of just the compressed - data and of the complete set of data including the contents of the foo.add - file. - - Again, the foo.add file is maintained during the compress operation in case - of an interruption. If in the unlikely event the foo.add file with the data - to be compressed is missing due to some external force, a gzip file with - just the previous compressed data will be reconstructed. In this case, all - of the data that was to be compressed is lost (approximately one megabyte). - This will not occur if all that happened was an interruption of the compress - operation. - - The third state that is marked is the replacement of the old dictionary with - the new dictionary after a compress operation. Once compression is - complete, the gzip file is marked as being in the replace state. This - completes the gzip file, so an interrupt after being so marked does not - result in recompression. Then the dictionary file is replaced, and the gzip - file is marked as completed. This state prevents the possibility of - restarting compression with the wrong dictionary file. - - All three operations are wrapped by a lock/unlock procedure. In order to - gain exclusive access to the log files, first a foo.lock file must be - exclusively created. When all operations are complete, the lock is - released by deleting the foo.lock file. If when attempting to create the - lock file, it already exists and the modify time of the lock file is more - than five minutes old (set by the PATIENCE define below), then the old - lock file is considered stale and deleted, and the exclusive creation of - the lock file is retried. To assure that there are no false assessments - of the staleness of the lock file, the operations periodically touch the - lock file to update the modified date. - - Following is the definition of the extra field with all of the information - required to enable the above append and compress operations and their - recovery if interrupted. Multi-byte values are stored little endian - (consistent with the gzip format). File pointers are eight bytes long. - The crc's and lengths for the gzip trailer are four bytes long. (Note that - the length at the end of a gzip file is used for error checking only, and - for large files is actually the length modulo 2^32.) The stored block - length is two bytes long. The gzip extra field two-byte identification is - "ap" for append. It is assumed that writing the extra field to the file is - an "atomic" operation. That is, either all of the extra field is written - to the file, or none of it is, if the operation is interrupted right at the - point of updating the extra field. This is a reasonable assumption, since - the extra field is within the first 52 bytes of the file, which is smaller - than any expected block size for a mass storage device (usually 512 bytes or - larger). - - Extra field (35 bytes): - - Pointer to first stored block length -- this points to the two-byte length - of the first stored block, which is followed by the two-byte, one's - complement of that length. The stored block length is preceded by the - three-bit header of the stored block, which is the actual start of the - stored block in the deflate format. See the bit offset field below. - - Pointer to the last stored block length. This is the same as above, but - for the last stored block of the uncompressed data in the gzip file. - Initially this is the same as the first stored block length pointer. - When the stored block gets to 16K (see the MAX_STORE define), then a new - stored block as added, at which point the last stored block length pointer - is different from the first stored block length pointer. When they are - different, the first bit of the last stored block header is eight bits, or - one byte back from the block length. - - Compressed data crc and length. This is the crc and length of the data - that is in the compressed portion of the deflate stream. These are used - only in the event that the foo.add file containing the data to compress is - lost after a compress operation is interrupted. - - Total data crc and length. This is the crc and length of all of the data - stored in the gzip file, compressed and uncompressed. It is used to - reconstruct the gzip trailer when compressing, as well as when recovering - interrupted operations. - - Final stored block length. This is used to quickly find where to append, - and allows the restoration of the original final stored block state when - an append operation is interrupted. - - First stored block start as the number of bits back from the final stored - block first length byte. This value is in the range of 3..10, and is - stored as the low three bits of the final byte of the extra field after - subtracting three (0..7). This allows the last-block bit of the stored - block header to be updated when a new stored block is added, for the case - when the first stored block and the last stored block are the same. (When - they are different, the numbers of bits back is known to be eight.) This - also allows for new compressed data to be appended to the old compressed - data in the compress operation, overwriting the previous first stored - block, or for the compressed data to be terminated and a valid gzip file - reconstructed on the off chance that a compression operation was - interrupted and the data to compress in the foo.add file was deleted. - - The operation in process. This is the next two bits in the last byte (the - bits under the mask 0x18). The are interpreted as 0: nothing in process, - 1: append in process, 2: compress in process, 3: replace in process. - - The top three bits of the last byte in the extra field are reserved and - are currently set to zero. - - Main procedure: - - Exclusively create the foo.lock file using the O_CREAT and O_EXCL modes of - the system open() call. If the modify time of an existing lock file is - more than PATIENCE seconds old, then the lock file is deleted and the - exclusive create is retried. - - Load the extra field from the foo.gz file, and see if an operation was in - progress but not completed. If so, apply the recovery procedure below. - - Perform the append procedure with the provided data. - - If the uncompressed data in the foo.gz file is 1MB or more, apply the - compress procedure. - - Delete the foo.lock file. - - Append procedure: - - Put what to append in the foo.add file so that the operation can be - restarted if this procedure is interrupted. - - Mark the foo.gz extra field with the append operation in progress. - + Restore the original last-block bit and stored block length of the last - stored block from the information in the extra field, in case a previous - append operation was interrupted. - - Append the provided data to the last stored block, creating new stored - blocks as needed and updating the stored blocks last-block bits and - lengths. - - Update the crc and length with the new data, and write the gzip trailer. - - Write over the extra field (with a single write operation) with the new - pointers, lengths, and crc's, and mark the gzip file as not in process. - Though there is still a foo.add file, it will be ignored since nothing - is in process. If a foo.add file is leftover from a previously - completed operation, it is truncated when writing new data to it. - - Delete the foo.add file. - - Compress and replace procedures: - - Read all of the uncompressed data in the stored blocks in foo.gz and write - it to foo.add. Also write foo.temp with the last 32K of that data to - provide a dictionary for the next invocation of this procedure. - - Rewrite the extra field marking foo.gz with a compression in process. - * If there is no data provided to compress (due to a missing foo.add file - when recovering), reconstruct and truncate the foo.gz file to contain - only the previous compressed data and proceed to the step after the next - one. Otherwise ... - - Compress the data with the dictionary in foo.dict, and write to the - foo.gz file starting at the bit immediately following the last previously - compressed block. If there is no foo.dict, proceed anyway with the - compression at slightly reduced efficiency. (For the foo.dict file to be - missing requires some external failure beyond simply the interruption of - a compress operation.) During this process, the foo.lock file is - periodically touched to assure that that file is not considered stale by - another process before we're done. The deflation is terminated with a - non-last empty static block (10 bits long), that is then located and - written over by a last-bit-set empty stored block. - - Append the crc and length of the data in the gzip file (previously - calculated during the append operations). - - Write over the extra field with the updated stored block offsets, bits - back, crc's, and lengths, and mark foo.gz as in process for a replacement - of the dictionary. - @ Delete the foo.add file. - - Replace foo.dict with foo.temp. - - Write over the extra field, marking foo.gz as complete. - - Recovery procedure: - - If not a replace recovery, read in the foo.add file, and provide that data - to the appropriate recovery below. If there is no foo.add file, provide - a zero data length to the recovery. In that case, the append recovery - restores the foo.gz to the previous compressed + uncompressed data state. - For the the compress recovery, a missing foo.add file results in foo.gz - being restored to the previous compressed-only data state. - - Append recovery: - - Pick up append at + step above - - Compress recovery: - - Pick up compress at * step above - - Replace recovery: - - Pick up compress at @ step above - - Log the repair with a date stamp in foo.repairs - */ - -#include -#include /* rename, fopen, fprintf, fclose */ -#include /* malloc, free */ -#include /* strlen, strrchr, strcpy, strncpy, strcmp */ -#include /* open */ -#include /* lseek, read, write, close, unlink, sleep, */ - /* ftruncate, fsync */ -#include /* errno */ -#include /* time, ctime */ -#include /* stat */ -#include /* utimes */ -#include "zlib.h" /* crc32 */ - -#include "gzlog.h" /* header for external access */ - -#define local static -typedef unsigned int uint; -typedef unsigned long ulong; - -/* Macro for debugging to deterministically force recovery operations */ -#ifdef GZLOG_DEBUG - #include /* longjmp */ - jmp_buf gzlog_jump; /* where to go back to */ - int gzlog_bail = 0; /* which point to bail at (1..8) */ - int gzlog_count = -1; /* number of times through to wait */ -# define BAIL(n) do { if (n == gzlog_bail && gzlog_count-- == 0) \ - longjmp(gzlog_jump, gzlog_bail); } while (0) -#else -# define BAIL(n) -#endif - -/* how old the lock file can be in seconds before considering it stale */ -#define PATIENCE 300 - -/* maximum stored block size in Kbytes -- must be in 1..63 */ -#define MAX_STORE 16 - -/* number of stored Kbytes to trigger compression (must be >= 32 to allow - dictionary construction, and <= 204 * MAX_STORE, in order for >> 10 to - discard the stored block headers contribution of five bytes each) */ -#define TRIGGER 1024 - -/* size of a deflate dictionary (this cannot be changed) */ -#define DICT 32768U - -/* values for the operation (2 bits) */ -#define NO_OP 0 -#define APPEND_OP 1 -#define COMPRESS_OP 2 -#define REPLACE_OP 3 - -/* macros to extract little-endian integers from an unsigned byte buffer */ -#define PULL2(p) ((p)[0]+((uint)((p)[1])<<8)) -#define PULL4(p) (PULL2(p)+((ulong)PULL2(p+2)<<16)) -#define PULL8(p) (PULL4(p)+((off_t)PULL4(p+4)<<32)) - -/* macros to store integers into a byte buffer in little-endian order */ -#define PUT2(p,a) do {(p)[0]=a;(p)[1]=(a)>>8;} while(0) -#define PUT4(p,a) do {PUT2(p,a);PUT2(p+2,a>>16);} while(0) -#define PUT8(p,a) do {PUT4(p,a);PUT4(p+4,a>>32);} while(0) - -/* internal structure for log information */ -#define LOGID "\106\035\172" /* should be three non-zero characters */ -struct log { - char id[4]; /* contains LOGID to detect inadvertent overwrites */ - int fd; /* file descriptor for .gz file, opened read/write */ - char *path; /* allocated path, e.g. "/var/log/foo" or "foo" */ - char *end; /* end of path, for appending suffices such as ".gz" */ - off_t first; /* offset of first stored block first length byte */ - int back; /* location of first block id in bits back from first */ - uint stored; /* bytes currently in last stored block */ - off_t last; /* offset of last stored block first length byte */ - ulong ccrc; /* crc of compressed data */ - ulong clen; /* length (modulo 2^32) of compressed data */ - ulong tcrc; /* crc of total data */ - ulong tlen; /* length (modulo 2^32) of total data */ - time_t lock; /* last modify time of our lock file */ -}; - -/* gzip header for gzlog */ -local unsigned char log_gzhead[] = { - 0x1f, 0x8b, /* magic gzip id */ - 8, /* compression method is deflate */ - 4, /* there is an extra field (no file name) */ - 0, 0, 0, 0, /* no modification time provided */ - 0, 0xff, /* no extra flags, no OS specified */ - 39, 0, 'a', 'p', 35, 0 /* extra field with "ap" subfield */ - /* 35 is EXTRA, 39 is EXTRA + 4 */ -}; - -#define HEAD sizeof(log_gzhead) /* should be 16 */ - -/* initial gzip extra field content (52 == HEAD + EXTRA + 1) */ -local unsigned char log_gzext[] = { - 52, 0, 0, 0, 0, 0, 0, 0, /* offset of first stored block length */ - 52, 0, 0, 0, 0, 0, 0, 0, /* offset of last stored block length */ - 0, 0, 0, 0, 0, 0, 0, 0, /* compressed data crc and length */ - 0, 0, 0, 0, 0, 0, 0, 0, /* total data crc and length */ - 0, 0, /* final stored block data length */ - 5 /* op is NO_OP, last bit 8 bits back */ -}; - -#define EXTRA sizeof(log_gzext) /* should be 35 */ - -/* initial gzip data and trailer */ -local unsigned char log_gzbody[] = { - 1, 0, 0, 0xff, 0xff, /* empty stored block (last) */ - 0, 0, 0, 0, /* crc */ - 0, 0, 0, 0 /* uncompressed length */ -}; - -#define BODY sizeof(log_gzbody) - -/* Exclusively create foo.lock in order to negotiate exclusive access to the - foo.* files. If the modify time of an existing lock file is greater than - PATIENCE seconds in the past, then consider the lock file to have been - abandoned, delete it, and try the exclusive create again. Save the lock - file modify time for verification of ownership. Return 0 on success, or -1 - on failure, usually due to an access restriction or invalid path. Note that - if stat() or unlink() fails, it may be due to another process noticing the - abandoned lock file a smidge sooner and deleting it, so those are not - flagged as an error. */ -local int log_lock(struct log *log) -{ - int fd; - struct stat st; - - strcpy(log->end, ".lock"); - while ((fd = open(log->path, O_CREAT | O_EXCL, 0644)) < 0) { - if (errno != EEXIST) - return -1; - if (stat(log->path, &st) == 0 && time(NULL) - st.st_mtime > PATIENCE) { - unlink(log->path); - continue; - } - sleep(2); /* relinquish the CPU for two seconds while waiting */ - } - close(fd); - if (stat(log->path, &st) == 0) - log->lock = st.st_mtime; - return 0; -} - -/* Update the modify time of the lock file to now, in order to prevent another - task from thinking that the lock is stale. Save the lock file modify time - for verification of ownership. */ -local void log_touch(struct log *log) -{ - struct stat st; - - strcpy(log->end, ".lock"); - utimes(log->path, NULL); - if (stat(log->path, &st) == 0) - log->lock = st.st_mtime; -} - -/* Check the log file modify time against what is expected. Return true if - this is not our lock. If it is our lock, touch it to keep it. */ -local int log_check(struct log *log) -{ - struct stat st; - - strcpy(log->end, ".lock"); - if (stat(log->path, &st) || st.st_mtime != log->lock) - return 1; - log_touch(log); - return 0; -} - -/* Unlock a previously acquired lock, but only if it's ours. */ -local void log_unlock(struct log *log) -{ - if (log_check(log)) - return; - strcpy(log->end, ".lock"); - unlink(log->path); - log->lock = 0; -} - -/* Check the gzip header and read in the extra field, filling in the values in - the log structure. Return op on success or -1 if the gzip header was not as - expected. op is the current operation in progress last written to the extra - field. This assumes that the gzip file has already been opened, with the - file descriptor log->fd. */ -local int log_head(struct log *log) -{ - int op; - unsigned char buf[HEAD + EXTRA]; - - if (lseek(log->fd, 0, SEEK_SET) < 0 || - read(log->fd, buf, HEAD + EXTRA) != HEAD + EXTRA || - memcmp(buf, log_gzhead, HEAD)) { - return -1; - } - log->first = PULL8(buf + HEAD); - log->last = PULL8(buf + HEAD + 8); - log->ccrc = PULL4(buf + HEAD + 16); - log->clen = PULL4(buf + HEAD + 20); - log->tcrc = PULL4(buf + HEAD + 24); - log->tlen = PULL4(buf + HEAD + 28); - log->stored = PULL2(buf + HEAD + 32); - log->back = 3 + (buf[HEAD + 34] & 7); - op = (buf[HEAD + 34] >> 3) & 3; - return op; -} - -/* Write over the extra field contents, marking the operation as op. Use fsync - to assure that the device is written to, and in the requested order. This - operation, and only this operation, is assumed to be atomic in order to - assure that the log is recoverable in the event of an interruption at any - point in the process. Return -1 if the write to foo.gz failed. */ -local int log_mark(struct log *log, int op) -{ - int ret; - unsigned char ext[EXTRA]; - - PUT8(ext, log->first); - PUT8(ext + 8, log->last); - PUT4(ext + 16, log->ccrc); - PUT4(ext + 20, log->clen); - PUT4(ext + 24, log->tcrc); - PUT4(ext + 28, log->tlen); - PUT2(ext + 32, log->stored); - ext[34] = log->back - 3 + (op << 3); - fsync(log->fd); - ret = lseek(log->fd, HEAD, SEEK_SET) < 0 || - write(log->fd, ext, EXTRA) != EXTRA ? -1 : 0; - fsync(log->fd); - return ret; -} - -/* Rewrite the last block header bits and subsequent zero bits to get to a byte - boundary, setting the last block bit if last is true, and then write the - remainder of the stored block header (length and one's complement). Leave - the file pointer after the end of the last stored block data. Return -1 if - there is a read or write failure on the foo.gz file */ -local int log_last(struct log *log, int last) -{ - int back, len, mask; - unsigned char buf[6]; - - /* determine the locations of the bytes and bits to modify */ - back = log->last == log->first ? log->back : 8; - len = back > 8 ? 2 : 1; /* bytes back from log->last */ - mask = 0x80 >> ((back - 1) & 7); /* mask for block last-bit */ - - /* get the byte to modify (one or two back) into buf[0] -- don't need to - read the byte if the last-bit is eight bits back, since in that case - the entire byte will be modified */ - buf[0] = 0; - if (back != 8 && (lseek(log->fd, log->last - len, SEEK_SET) < 0 || - read(log->fd, buf, 1) != 1)) - return -1; - - /* change the last-bit of the last stored block as requested -- note - that all bits above the last-bit are set to zero, per the type bits - of a stored block being 00 and per the convention that the bits to - bring the stream to a byte boundary are also zeros */ - buf[1] = 0; - buf[2 - len] = (*buf & (mask - 1)) + (last ? mask : 0); - - /* write the modified stored block header and lengths, move the file - pointer to after the last stored block data */ - PUT2(buf + 2, log->stored); - PUT2(buf + 4, log->stored ^ 0xffff); - return lseek(log->fd, log->last - len, SEEK_SET) < 0 || - write(log->fd, buf + 2 - len, len + 4) != len + 4 || - lseek(log->fd, log->stored, SEEK_CUR) < 0 ? -1 : 0; -} - -/* Append len bytes from data to the locked and open log file. len may be zero - if recovering and no .add file was found. In that case, the previous state - of the foo.gz file is restored. The data is appended uncompressed in - deflate stored blocks. Return -1 if there was an error reading or writing - the foo.gz file. */ -local int log_append(struct log *log, unsigned char *data, size_t len) -{ - uint put; - off_t end; - unsigned char buf[8]; - - /* set the last block last-bit and length, in case recovering an - interrupted append, then position the file pointer to append to the - block */ - if (log_last(log, 1)) - return -1; - - /* append, adding stored blocks and updating the offset of the last stored - block as needed, and update the total crc and length */ - while (len) { - /* append as much as we can to the last block */ - put = (MAX_STORE << 10) - log->stored; - if (put > len) - put = (uint)len; - if (put) { - if (write(log->fd, data, put) != put) - return -1; - BAIL(1); - log->tcrc = crc32(log->tcrc, data, put); - log->tlen += put; - log->stored += put; - data += put; - len -= put; - } - - /* if we need to, add a new empty stored block */ - if (len) { - /* mark current block as not last */ - if (log_last(log, 0)) - return -1; - - /* point to new, empty stored block */ - log->last += 4 + log->stored + 1; - log->stored = 0; - } - - /* mark last block as last, update its length */ - if (log_last(log, 1)) - return -1; - BAIL(2); - } - - /* write the new crc and length trailer, and truncate just in case (could - be recovering from partial append with a missing foo.add file) */ - PUT4(buf, log->tcrc); - PUT4(buf + 4, log->tlen); - if (write(log->fd, buf, 8) != 8 || - (end = lseek(log->fd, 0, SEEK_CUR)) < 0 || ftruncate(log->fd, end)) - return -1; - - /* write the extra field, marking the log file as done, delete .add file */ - if (log_mark(log, NO_OP)) - return -1; - strcpy(log->end, ".add"); - unlink(log->path); /* ignore error, since may not exist */ - return 0; -} - -/* Replace the foo.dict file with the foo.temp file. Also delete the foo.add - file, since the compress operation may have been interrupted before that was - done. Returns 1 if memory could not be allocated, or -1 if reading or - writing foo.gz fails, or if the rename fails for some reason other than - foo.temp not existing. foo.temp not existing is a permitted error, since - the replace operation may have been interrupted after the rename is done, - but before foo.gz is marked as complete. */ -local int log_replace(struct log *log) -{ - int ret; - char *dest; - - /* delete foo.add file */ - strcpy(log->end, ".add"); - unlink(log->path); /* ignore error, since may not exist */ - BAIL(3); - - /* rename foo.name to foo.dict, replacing foo.dict if it exists */ - strcpy(log->end, ".dict"); - dest = malloc(strlen(log->path) + 1); - if (dest == NULL) - return -2; - strcpy(dest, log->path); - strcpy(log->end, ".temp"); - ret = rename(log->path, dest); - free(dest); - if (ret && errno != ENOENT) - return -1; - BAIL(4); - - /* mark the foo.gz file as done */ - return log_mark(log, NO_OP); -} - -/* Compress the len bytes at data and append the compressed data to the - foo.gz deflate data immediately after the previous compressed data. This - overwrites the previous uncompressed data, which was stored in foo.add - and is the data provided in data[0..len-1]. If this operation is - interrupted, it picks up at the start of this routine, with the foo.add - file read in again. If there is no data to compress (len == 0), then we - simply terminate the foo.gz file after the previously compressed data, - appending a final empty stored block and the gzip trailer. Return -1 if - reading or writing the log.gz file failed, or -2 if there was a memory - allocation failure. */ -local int log_compress(struct log *log, unsigned char *data, size_t len) -{ - int fd; - uint got, max; - ssize_t dict; - off_t end; - z_stream strm; - unsigned char buf[DICT]; - - /* compress and append compressed data */ - if (len) { - /* set up for deflate, allocating memory */ - strm.zalloc = Z_NULL; - strm.zfree = Z_NULL; - strm.opaque = Z_NULL; - if (deflateInit2(&strm, Z_DEFAULT_COMPRESSION, Z_DEFLATED, -15, 8, - Z_DEFAULT_STRATEGY) != Z_OK) - return -2; - - /* read in dictionary (last 32K of data that was compressed) */ - strcpy(log->end, ".dict"); - fd = open(log->path, O_RDONLY, 0); - if (fd >= 0) { - dict = read(fd, buf, DICT); - close(fd); - if (dict < 0) { - deflateEnd(&strm); - return -1; - } - if (dict) - deflateSetDictionary(&strm, buf, (uint)dict); - } - log_touch(log); - - /* prime deflate with last bits of previous block, position write - pointer to write those bits and overwrite what follows */ - if (lseek(log->fd, log->first - (log->back > 8 ? 2 : 1), - SEEK_SET) < 0 || - read(log->fd, buf, 1) != 1 || lseek(log->fd, -1, SEEK_CUR) < 0) { - deflateEnd(&strm); - return -1; - } - deflatePrime(&strm, (8 - log->back) & 7, *buf); - - /* compress, finishing with a partial non-last empty static block */ - strm.next_in = data; - max = (((uint)0 - 1) >> 1) + 1; /* in case int smaller than size_t */ - do { - strm.avail_in = len > max ? max : (uint)len; - len -= strm.avail_in; - do { - strm.avail_out = DICT; - strm.next_out = buf; - deflate(&strm, len ? Z_NO_FLUSH : Z_PARTIAL_FLUSH); - got = DICT - strm.avail_out; - if (got && write(log->fd, buf, got) != got) { - deflateEnd(&strm); - return -1; - } - log_touch(log); - } while (strm.avail_out == 0); - } while (len); - deflateEnd(&strm); - BAIL(5); - - /* find start of empty static block -- scanning backwards the first one - bit is the second bit of the block, if the last byte is zero, then - we know the byte before that has a one in the top bit, since an - empty static block is ten bits long */ - if ((log->first = lseek(log->fd, -1, SEEK_CUR)) < 0 || - read(log->fd, buf, 1) != 1) - return -1; - log->first++; - if (*buf) { - log->back = 1; - while ((*buf & ((uint)1 << (8 - log->back++))) == 0) - ; /* guaranteed to terminate, since *buf != 0 */ - } - else - log->back = 10; - - /* update compressed crc and length */ - log->ccrc = log->tcrc; - log->clen = log->tlen; - } - else { - /* no data to compress -- fix up existing gzip stream */ - log->tcrc = log->ccrc; - log->tlen = log->clen; - } - - /* complete and truncate gzip stream */ - log->last = log->first; - log->stored = 0; - PUT4(buf, log->tcrc); - PUT4(buf + 4, log->tlen); - if (log_last(log, 1) || write(log->fd, buf, 8) != 8 || - (end = lseek(log->fd, 0, SEEK_CUR)) < 0 || ftruncate(log->fd, end)) - return -1; - BAIL(6); - - /* mark as being in the replace operation */ - if (log_mark(log, REPLACE_OP)) - return -1; - - /* execute the replace operation and mark the file as done */ - return log_replace(log); -} - -/* log a repair record to the .repairs file */ -local void log_log(struct log *log, int op, char *record) -{ - time_t now; - FILE *rec; - - now = time(NULL); - strcpy(log->end, ".repairs"); - rec = fopen(log->path, "a"); - if (rec == NULL) - return; - fprintf(rec, "%.24s %s recovery: %s\n", ctime(&now), op == APPEND_OP ? - "append" : (op == COMPRESS_OP ? "compress" : "replace"), record); - fclose(rec); - return; -} - -/* Recover the interrupted operation op. First read foo.add for recovering an - append or compress operation. Return -1 if there was an error reading or - writing foo.gz or reading an existing foo.add, or -2 if there was a memory - allocation failure. */ -local int log_recover(struct log *log, int op) -{ - int fd, ret = 0; - unsigned char *data = NULL; - size_t len = 0; - struct stat st; - - /* log recovery */ - log_log(log, op, "start"); - - /* load foo.add file if expected and present */ - if (op == APPEND_OP || op == COMPRESS_OP) { - strcpy(log->end, ".add"); - if (stat(log->path, &st) == 0 && st.st_size) { - len = (size_t)(st.st_size); - if ((off_t)len != st.st_size || - (data = malloc(st.st_size)) == NULL) { - log_log(log, op, "allocation failure"); - return -2; - } - if ((fd = open(log->path, O_RDONLY, 0)) < 0) { - log_log(log, op, ".add file read failure"); - return -1; - } - ret = (size_t)read(fd, data, len) != len; - close(fd); - if (ret) { - log_log(log, op, ".add file read failure"); - return -1; - } - log_log(log, op, "loaded .add file"); - } - else - log_log(log, op, "missing .add file!"); - } - - /* recover the interrupted operation */ - switch (op) { - case APPEND_OP: - ret = log_append(log, data, len); - break; - case COMPRESS_OP: - ret = log_compress(log, data, len); - break; - case REPLACE_OP: - ret = log_replace(log); - } - - /* log status */ - log_log(log, op, ret ? "failure" : "complete"); - - /* clean up */ - if (data != NULL) - free(data); - return ret; -} - -/* Close the foo.gz file (if open) and release the lock. */ -local void log_close(struct log *log) -{ - if (log->fd >= 0) - close(log->fd); - log->fd = -1; - log_unlock(log); -} - -/* Open foo.gz, verify the header, and load the extra field contents, after - first creating the foo.lock file to gain exclusive access to the foo.* - files. If foo.gz does not exist or is empty, then write the initial header, - extra, and body content of an empty foo.gz log file. If there is an error - creating the lock file due to access restrictions, or an error reading or - writing the foo.gz file, or if the foo.gz file is not a proper log file for - this object (e.g. not a gzip file or does not contain the expected extra - field), then return true. If there is an error, the lock is released. - Otherwise, the lock is left in place. */ -local int log_open(struct log *log) -{ - int op; - - /* release open file resource if left over -- can occur if lock lost - between gzlog_open() and gzlog_write() */ - if (log->fd >= 0) - close(log->fd); - log->fd = -1; - - /* negotiate exclusive access */ - if (log_lock(log) < 0) - return -1; - - /* open the log file, foo.gz */ - strcpy(log->end, ".gz"); - log->fd = open(log->path, O_RDWR | O_CREAT, 0644); - if (log->fd < 0) { - log_close(log); - return -1; - } - - /* if new, initialize foo.gz with an empty log, delete old dictionary */ - if (lseek(log->fd, 0, SEEK_END) == 0) { - if (write(log->fd, log_gzhead, HEAD) != HEAD || - write(log->fd, log_gzext, EXTRA) != EXTRA || - write(log->fd, log_gzbody, BODY) != BODY) { - log_close(log); - return -1; - } - strcpy(log->end, ".dict"); - unlink(log->path); - } - - /* verify log file and load extra field information */ - if ((op = log_head(log)) < 0) { - log_close(log); - return -1; - } - - /* check for interrupted process and if so, recover */ - if (op != NO_OP && log_recover(log, op)) { - log_close(log); - return -1; - } - - /* touch the lock file to prevent another process from grabbing it */ - log_touch(log); - return 0; -} - -/* See gzlog.h for the description of the external methods below */ -gzlog *gzlog_open(char *path) -{ - size_t n; - struct log *log; - - /* check arguments */ - if (path == NULL || *path == 0) - return NULL; - - /* allocate and initialize log structure */ - log = malloc(sizeof(struct log)); - if (log == NULL) - return NULL; - strcpy(log->id, LOGID); - log->fd = -1; - - /* save path and end of path for name construction */ - n = strlen(path); - log->path = malloc(n + 9); /* allow for ".repairs" */ - if (log->path == NULL) { - free(log); - return NULL; - } - strcpy(log->path, path); - log->end = log->path + n; - - /* gain exclusive access and verify log file -- may perform a - recovery operation if needed */ - if (log_open(log)) { - free(log->path); - free(log); - return NULL; - } - - /* return pointer to log structure */ - return log; -} - -/* gzlog_compress() return values: - 0: all good - -1: file i/o error (usually access issue) - -2: memory allocation failure - -3: invalid log pointer argument */ -int gzlog_compress(gzlog *logd) -{ - int fd, ret; - uint block; - size_t len, next; - unsigned char *data, buf[5]; - struct log *log = logd; - - /* check arguments */ - if (log == NULL || strcmp(log->id, LOGID)) - return -3; - - /* see if we lost the lock -- if so get it again and reload the extra - field information (it probably changed), recover last operation if - necessary */ - if (log_check(log) && log_open(log)) - return -1; - - /* create space for uncompressed data */ - len = ((size_t)(log->last - log->first) & ~(((size_t)1 << 10) - 1)) + - log->stored; - if ((data = malloc(len)) == NULL) - return -2; - - /* do statement here is just a cheap trick for error handling */ - do { - /* read in the uncompressed data */ - if (lseek(log->fd, log->first - 1, SEEK_SET) < 0) - break; - next = 0; - while (next < len) { - if (read(log->fd, buf, 5) != 5) - break; - block = PULL2(buf + 1); - if (next + block > len || - read(log->fd, (char *)data + next, block) != block) - break; - next += block; - } - if (lseek(log->fd, 0, SEEK_CUR) != log->last + 4 + log->stored) - break; - log_touch(log); - - /* write the uncompressed data to the .add file */ - strcpy(log->end, ".add"); - fd = open(log->path, O_WRONLY | O_CREAT | O_TRUNC, 0644); - if (fd < 0) - break; - ret = (size_t)write(fd, data, len) != len; - if (ret | close(fd)) - break; - log_touch(log); - - /* write the dictionary for the next compress to the .temp file */ - strcpy(log->end, ".temp"); - fd = open(log->path, O_WRONLY | O_CREAT | O_TRUNC, 0644); - if (fd < 0) - break; - next = DICT > len ? len : DICT; - ret = (size_t)write(fd, (char *)data + len - next, next) != next; - if (ret | close(fd)) - break; - log_touch(log); - - /* roll back to compressed data, mark the compress in progress */ - log->last = log->first; - log->stored = 0; - if (log_mark(log, COMPRESS_OP)) - break; - BAIL(7); - - /* compress and append the data (clears mark) */ - ret = log_compress(log, data, len); - free(data); - return ret; - } while (0); - - /* broke out of do above on i/o error */ - free(data); - return -1; -} - -/* gzlog_write() return values: - 0: all good - -1: file i/o error (usually access issue) - -2: memory allocation failure - -3: invalid log pointer argument */ -int gzlog_write(gzlog *logd, void *data, size_t len) -{ - int fd, ret; - struct log *log = logd; - - /* check arguments */ - if (log == NULL || strcmp(log->id, LOGID)) - return -3; - if (data == NULL || len <= 0) - return 0; - - /* see if we lost the lock -- if so get it again and reload the extra - field information (it probably changed), recover last operation if - necessary */ - if (log_check(log) && log_open(log)) - return -1; - - /* create and write .add file */ - strcpy(log->end, ".add"); - fd = open(log->path, O_WRONLY | O_CREAT | O_TRUNC, 0644); - if (fd < 0) - return -1; - ret = (size_t)write(fd, data, len) != len; - if (ret | close(fd)) - return -1; - log_touch(log); - - /* mark log file with append in progress */ - if (log_mark(log, APPEND_OP)) - return -1; - BAIL(8); - - /* append data (clears mark) */ - if (log_append(log, data, len)) - return -1; - - /* check to see if it's time to compress -- if not, then done */ - if (((log->last - log->first) >> 10) + (log->stored >> 10) < TRIGGER) - return 0; - - /* time to compress */ - return gzlog_compress(log); -} - -/* gzlog_close() return values: - 0: ok - -3: invalid log pointer argument */ -int gzlog_close(gzlog *logd) -{ - struct log *log = logd; - - /* check arguments */ - if (log == NULL || strcmp(log->id, LOGID)) - return -3; - - /* close the log file and release the lock */ - log_close(log); - - /* free structure and return */ - if (log->path != NULL) - free(log->path); - strcpy(log->id, "bad"); - free(log); - return 0; -} DELETED compat/zlib/examples/gzlog.h Index: compat/zlib/examples/gzlog.h ================================================================== --- compat/zlib/examples/gzlog.h +++ /dev/null @@ -1,91 +0,0 @@ -/* gzlog.h - Copyright (C) 2004, 2008, 2012 Mark Adler, all rights reserved - version 2.2, 14 Aug 2012 - - This software is provided 'as-is', without any express or implied - warranty. In no event will the author be held liable for any damages - arising from the use of this software. - - Permission is granted to anyone to use this software for any purpose, - including commercial applications, and to alter it and redistribute it - freely, subject to the following restrictions: - - 1. The origin of this software must not be misrepresented; you must not - claim that you wrote the original software. If you use this software - in a product, an acknowledgment in the product documentation would be - appreciated but is not required. - 2. Altered source versions must be plainly marked as such, and must not be - misrepresented as being the original software. - 3. This notice may not be removed or altered from any source distribution. - - Mark Adler madler@alumni.caltech.edu - */ - -/* Version History: - 1.0 26 Nov 2004 First version - 2.0 25 Apr 2008 Complete redesign for recovery of interrupted operations - Interface changed slightly in that now path is a prefix - Compression now occurs as needed during gzlog_write() - gzlog_write() now always leaves the log file as valid gzip - 2.1 8 Jul 2012 Fix argument checks in gzlog_compress() and gzlog_write() - 2.2 14 Aug 2012 Clean up signed comparisons - */ - -/* - The gzlog object allows writing short messages to a gzipped log file, - opening the log file locked for small bursts, and then closing it. The log - object works by appending stored (uncompressed) data to the gzip file until - 1 MB has been accumulated. At that time, the stored data is compressed, and - replaces the uncompressed data in the file. The log file is truncated to - its new size at that time. After each write operation, the log file is a - valid gzip file that can decompressed to recover what was written. - - The gzlog operations can be interupted at any point due to an application or - system crash, and the log file will be recovered the next time the log is - opened with gzlog_open(). - */ - -#ifndef GZLOG_H -#define GZLOG_H - -/* gzlog object type */ -typedef void gzlog; - -/* Open a gzlog object, creating the log file if it does not exist. Return - NULL on error. Note that gzlog_open() could take a while to complete if it - has to wait to verify that a lock is stale (possibly for five minutes), or - if there is significant contention with other instantiations of this object - when locking the resource. path is the prefix of the file names created by - this object. If path is "foo", then the log file will be "foo.gz", and - other auxiliary files will be created and destroyed during the process: - "foo.dict" for a compression dictionary, "foo.temp" for a temporary (next) - dictionary, "foo.add" for data being added or compressed, "foo.lock" for the - lock file, and "foo.repairs" to log recovery operations performed due to - interrupted gzlog operations. A gzlog_open() followed by a gzlog_close() - will recover a previously interrupted operation, if any. */ -gzlog *gzlog_open(char *path); - -/* Write to a gzlog object. Return zero on success, -1 if there is a file i/o - error on any of the gzlog files (this should not happen if gzlog_open() - succeeded, unless the device has run out of space or leftover auxiliary - files have permissions or ownership that prevent their use), -2 if there is - a memory allocation failure, or -3 if the log argument is invalid (e.g. if - it was not created by gzlog_open()). This function will write data to the - file uncompressed, until 1 MB has been accumulated, at which time that data - will be compressed. The log file will be a valid gzip file upon successful - return. */ -int gzlog_write(gzlog *log, void *data, size_t len); - -/* Force compression of any uncompressed data in the log. This should be used - sparingly, if at all. The main application would be when a log file will - not be appended to again. If this is used to compress frequently while - appending, it will both significantly increase the execution time and - reduce the compression ratio. The return codes are the same as for - gzlog_write(). */ -int gzlog_compress(gzlog *log); - -/* Close a gzlog object. Return zero on success, -3 if the log argument is - invalid. The log object is freed, and so cannot be referenced again. */ -int gzlog_close(gzlog *log); - -#endif DELETED compat/zlib/examples/zlib_how.html Index: compat/zlib/examples/zlib_how.html ================================================================== --- compat/zlib/examples/zlib_how.html +++ /dev/null @@ -1,545 +0,0 @@ - - - - -zlib Usage Example - - - -

zlib Usage Example

-We often get questions about how the deflate() and inflate() functions should be used. -Users wonder when they should provide more input, when they should use more output, -what to do with a Z_BUF_ERROR, how to make sure the process terminates properly, and -so on. So for those who have read zlib.h (a few times), and -would like further edification, below is an annotated example in C of simple routines to compress and decompress -from an input file to an output file using deflate() and inflate() respectively. The -annotations are interspersed between lines of the code. So please read between the lines. -We hope this helps explain some of the intricacies of zlib. -

-Without further adieu, here is the program zpipe.c: -


-/* zpipe.c: example of proper use of zlib's inflate() and deflate()
-   Not copyrighted -- provided to the public domain
-   Version 1.4  11 December 2005  Mark Adler */
-
-/* Version history:
-   1.0  30 Oct 2004  First version
-   1.1   8 Nov 2004  Add void casting for unused return values
-                     Use switch statement for inflate() return values
-   1.2   9 Nov 2004  Add assertions to document zlib guarantees
-   1.3   6 Apr 2005  Remove incorrect assertion in inf()
-   1.4  11 Dec 2005  Add hack to avoid MSDOS end-of-line conversions
-                     Avoid some compiler warnings for input and output buffers
- */
-
-We now include the header files for the required definitions. From -stdio.h we use fopen(), fread(), fwrite(), -feof(), ferror(), and fclose() for file i/o, and -fputs() for error messages. From string.h we use -strcmp() for command line argument processing. -From assert.h we use the assert() macro. -From zlib.h -we use the basic compression functions deflateInit(), -deflate(), and deflateEnd(), and the basic decompression -functions inflateInit(), inflate(), and -inflateEnd(). -

-#include <stdio.h>
-#include <string.h>
-#include <assert.h>
-#include "zlib.h"
-
-This is an ugly hack required to avoid corruption of the input and output data on -Windows/MS-DOS systems. Without this, those systems would assume that the input and output -files are text, and try to convert the end-of-line characters from one standard to -another. That would corrupt binary data, and in particular would render the compressed data unusable. -This sets the input and output to binary which suppresses the end-of-line conversions. -SET_BINARY_MODE() will be used later on stdin and stdout, at the beginning of main(). -

-#if defined(MSDOS) || defined(OS2) || defined(WIN32) || defined(__CYGWIN__)
-#  include <fcntl.h>
-#  include <io.h>
-#  define SET_BINARY_MODE(file) setmode(fileno(file), O_BINARY)
-#else
-#  define SET_BINARY_MODE(file)
-#endif
-
-CHUNK is simply the buffer size for feeding data to and pulling data -from the zlib routines. Larger buffer sizes would be more efficient, -especially for inflate(). If the memory is available, buffers sizes -on the order of 128K or 256K bytes should be used. -

-#define CHUNK 16384
-
-The def() routine compresses data from an input file to an output file. The output data -will be in the zlib format, which is different from the gzip or zip -formats. The zlib format has a very small header of only two bytes to identify it as -a zlib stream and to provide decoding information, and a four-byte trailer with a fast -check value to verify the integrity of the uncompressed data after decoding. -

-/* Compress from file source to file dest until EOF on source.
-   def() returns Z_OK on success, Z_MEM_ERROR if memory could not be
-   allocated for processing, Z_STREAM_ERROR if an invalid compression
-   level is supplied, Z_VERSION_ERROR if the version of zlib.h and the
-   version of the library linked do not match, or Z_ERRNO if there is
-   an error reading or writing the files. */
-int def(FILE *source, FILE *dest, int level)
-{
-
-Here are the local variables for def(). ret will be used for zlib -return codes. flush will keep track of the current flushing state for deflate(), -which is either no flushing, or flush to completion after the end of the input file is reached. -have is the amount of data returned from deflate(). The strm structure -is used to pass information to and from the zlib routines, and to maintain the -deflate() state. in and out are the input and output buffers for -deflate(). -

-    int ret, flush;
-    unsigned have;
-    z_stream strm;
-    unsigned char in[CHUNK];
-    unsigned char out[CHUNK];
-
-The first thing we do is to initialize the zlib state for compression using -deflateInit(). This must be done before the first use of deflate(). -The zalloc, zfree, and opaque fields in the strm -structure must be initialized before calling deflateInit(). Here they are -set to the zlib constant Z_NULL to request that zlib use -the default memory allocation routines. An application may also choose to provide -custom memory allocation routines here. deflateInit() will allocate on the -order of 256K bytes for the internal state. -(See zlib Technical Details.) -

-deflateInit() is called with a pointer to the structure to be initialized and -the compression level, which is an integer in the range of -1 to 9. Lower compression -levels result in faster execution, but less compression. Higher levels result in -greater compression, but slower execution. The zlib constant Z_DEFAULT_COMPRESSION, -equal to -1, -provides a good compromise between compression and speed and is equivalent to level 6. -Level 0 actually does no compression at all, and in fact expands the data slightly to produce -the zlib format (it is not a byte-for-byte copy of the input). -More advanced applications of zlib -may use deflateInit2() here instead. Such an application may want to reduce how -much memory will be used, at some price in compression. Or it may need to request a -gzip header and trailer instead of a zlib header and trailer, or raw -encoding with no header or trailer at all. -

-We must check the return value of deflateInit() against the zlib constant -Z_OK to make sure that it was able to -allocate memory for the internal state, and that the provided arguments were valid. -deflateInit() will also check that the version of zlib that the zlib.h -file came from matches the version of zlib actually linked with the program. This -is especially important for environments in which zlib is a shared library. -

-Note that an application can initialize multiple, independent zlib streams, which can -operate in parallel. The state information maintained in the structure allows the zlib -routines to be reentrant. -


-    /* allocate deflate state */
-    strm.zalloc = Z_NULL;
-    strm.zfree = Z_NULL;
-    strm.opaque = Z_NULL;
-    ret = deflateInit(&strm, level);
-    if (ret != Z_OK)
-        return ret;
-
-With the pleasantries out of the way, now we can get down to business. The outer do-loop -reads all of the input file and exits at the bottom of the loop once end-of-file is reached. -This loop contains the only call of deflate(). So we must make sure that all of the -input data has been processed and that all of the output data has been generated and consumed -before we fall out of the loop at the bottom. -

-    /* compress until end of file */
-    do {
-
-We start off by reading data from the input file. The number of bytes read is put directly -into avail_in, and a pointer to those bytes is put into next_in. We also -check to see if end-of-file on the input has been reached. If we are at the end of file, then flush is set to the -zlib constant Z_FINISH, which is later passed to deflate() to -indicate that this is the last chunk of input data to compress. We need to use feof() -to check for end-of-file as opposed to seeing if fewer than CHUNK bytes have been read. The -reason is that if the input file length is an exact multiple of CHUNK, we will miss -the fact that we got to the end-of-file, and not know to tell deflate() to finish -up the compressed stream. If we are not yet at the end of the input, then the zlib -constant Z_NO_FLUSH will be passed to deflate to indicate that we are still -in the middle of the uncompressed data. -

-If there is an error in reading from the input file, the process is aborted with -deflateEnd() being called to free the allocated zlib state before returning -the error. We wouldn't want a memory leak, now would we? deflateEnd() can be called -at any time after the state has been initialized. Once that's done, deflateInit() (or -deflateInit2()) would have to be called to start a new compression process. There is -no point here in checking the deflateEnd() return code. The deallocation can't fail. -


-        strm.avail_in = fread(in, 1, CHUNK, source);
-        if (ferror(source)) {
-            (void)deflateEnd(&strm);
-            return Z_ERRNO;
-        }
-        flush = feof(source) ? Z_FINISH : Z_NO_FLUSH;
-        strm.next_in = in;
-
-The inner do-loop passes our chunk of input data to deflate(), and then -keeps calling deflate() until it is done producing output. Once there is no more -new output, deflate() is guaranteed to have consumed all of the input, i.e., -avail_in will be zero. -

-        /* run deflate() on input until output buffer not full, finish
-           compression if all of source has been read in */
-        do {
-
-Output space is provided to deflate() by setting avail_out to the number -of available output bytes and next_out to a pointer to that space. -

-            strm.avail_out = CHUNK;
-            strm.next_out = out;
-
-Now we call the compression engine itself, deflate(). It takes as many of the -avail_in bytes at next_in as it can process, and writes as many as -avail_out bytes to next_out. Those counters and pointers are then -updated past the input data consumed and the output data written. It is the amount of -output space available that may limit how much input is consumed. -Hence the inner loop to make sure that -all of the input is consumed by providing more output space each time. Since avail_in -and next_in are updated by deflate(), we don't have to mess with those -between deflate() calls until it's all used up. -

-The parameters to deflate() are a pointer to the strm structure containing -the input and output information and the internal compression engine state, and a parameter -indicating whether and how to flush data to the output. Normally deflate will consume -several K bytes of input data before producing any output (except for the header), in order -to accumulate statistics on the data for optimum compression. It will then put out a burst of -compressed data, and proceed to consume more input before the next burst. Eventually, -deflate() -must be told to terminate the stream, complete the compression with provided input data, and -write out the trailer check value. deflate() will continue to compress normally as long -as the flush parameter is Z_NO_FLUSH. Once the Z_FINISH parameter is provided, -deflate() will begin to complete the compressed output stream. However depending on how -much output space is provided, deflate() may have to be called several times until it -has provided the complete compressed stream, even after it has consumed all of the input. The flush -parameter must continue to be Z_FINISH for those subsequent calls. -

-There are other values of the flush parameter that are used in more advanced applications. You can -force deflate() to produce a burst of output that encodes all of the input data provided -so far, even if it wouldn't have otherwise, for example to control data latency on a link with -compressed data. You can also ask that deflate() do that as well as erase any history up to -that point so that what follows can be decompressed independently, for example for random access -applications. Both requests will degrade compression by an amount depending on how often such -requests are made. -

-deflate() has a return value that can indicate errors, yet we do not check it here. Why -not? Well, it turns out that deflate() can do no wrong here. Let's go through -deflate()'s return values and dispense with them one by one. The possible values are -Z_OK, Z_STREAM_END, Z_STREAM_ERROR, or Z_BUF_ERROR. Z_OK -is, well, ok. Z_STREAM_END is also ok and will be returned for the last call of -deflate(). This is already guaranteed by calling deflate() with Z_FINISH -until it has no more output. Z_STREAM_ERROR is only possible if the stream is not -initialized properly, but we did initialize it properly. There is no harm in checking for -Z_STREAM_ERROR here, for example to check for the possibility that some -other part of the application inadvertently clobbered the memory containing the zlib state. -Z_BUF_ERROR will be explained further below, but -suffice it to say that this is simply an indication that deflate() could not consume -more input or produce more output. deflate() can be called again with more output space -or more available input, which it will be in this code. -


-            ret = deflate(&strm, flush);    /* no bad return value */
-            assert(ret != Z_STREAM_ERROR);  /* state not clobbered */
-
-Now we compute how much output deflate() provided on the last call, which is the -difference between how much space was provided before the call, and how much output space -is still available after the call. Then that data, if any, is written to the output file. -We can then reuse the output buffer for the next call of deflate(). Again if there -is a file i/o error, we call deflateEnd() before returning to avoid a memory leak. -

-            have = CHUNK - strm.avail_out;
-            if (fwrite(out, 1, have, dest) != have || ferror(dest)) {
-                (void)deflateEnd(&strm);
-                return Z_ERRNO;
-            }
-
-The inner do-loop is repeated until the last deflate() call fails to fill the -provided output buffer. Then we know that deflate() has done as much as it can with -the provided input, and that all of that input has been consumed. We can then fall out of this -loop and reuse the input buffer. -

-The way we tell that deflate() has no more output is by seeing that it did not fill -the output buffer, leaving avail_out greater than zero. However suppose that -deflate() has no more output, but just so happened to exactly fill the output buffer! -avail_out is zero, and we can't tell that deflate() has done all it can. -As far as we know, deflate() -has more output for us. So we call it again. But now deflate() produces no output -at all, and avail_out remains unchanged as CHUNK. That deflate() call -wasn't able to do anything, either consume input or produce output, and so it returns -Z_BUF_ERROR. (See, I told you I'd cover this later.) However this is not a problem at -all. Now we finally have the desired indication that deflate() is really done, -and so we drop out of the inner loop to provide more input to deflate(). -

-With flush set to Z_FINISH, this final set of deflate() calls will -complete the output stream. Once that is done, subsequent calls of deflate() would return -Z_STREAM_ERROR if the flush parameter is not Z_FINISH, and do no more processing -until the state is reinitialized. -

-Some applications of zlib have two loops that call deflate() -instead of the single inner loop we have here. The first loop would call -without flushing and feed all of the data to deflate(). The second loop would call -deflate() with no more -data and the Z_FINISH parameter to complete the process. As you can see from this -example, that can be avoided by simply keeping track of the current flush state. -


-        } while (strm.avail_out == 0);
-        assert(strm.avail_in == 0);     /* all input will be used */
-
-Now we check to see if we have already processed all of the input file. That information was -saved in the flush variable, so we see if that was set to Z_FINISH. If so, -then we're done and we fall out of the outer loop. We're guaranteed to get Z_STREAM_END -from the last deflate() call, since we ran it until the last chunk of input was -consumed and all of the output was generated. -

-        /* done when last data in file processed */
-    } while (flush != Z_FINISH);
-    assert(ret == Z_STREAM_END);        /* stream will be complete */
-
-The process is complete, but we still need to deallocate the state to avoid a memory leak -(or rather more like a memory hemorrhage if you didn't do this). Then -finally we can return with a happy return value. -

-    /* clean up and return */
-    (void)deflateEnd(&strm);
-    return Z_OK;
-}
-
-Now we do the same thing for decompression in the inf() routine. inf() -decompresses what is hopefully a valid zlib stream from the input file and writes the -uncompressed data to the output file. Much of the discussion above for def() -applies to inf() as well, so the discussion here will focus on the differences between -the two. -

-/* Decompress from file source to file dest until stream ends or EOF.
-   inf() returns Z_OK on success, Z_MEM_ERROR if memory could not be
-   allocated for processing, Z_DATA_ERROR if the deflate data is
-   invalid or incomplete, Z_VERSION_ERROR if the version of zlib.h and
-   the version of the library linked do not match, or Z_ERRNO if there
-   is an error reading or writing the files. */
-int inf(FILE *source, FILE *dest)
-{
-
-The local variables have the same functionality as they do for def(). The -only difference is that there is no flush variable, since inflate() -can tell from the zlib stream itself when the stream is complete. -

-    int ret;
-    unsigned have;
-    z_stream strm;
-    unsigned char in[CHUNK];
-    unsigned char out[CHUNK];
-
-The initialization of the state is the same, except that there is no compression level, -of course, and two more elements of the structure are initialized. avail_in -and next_in must be initialized before calling inflateInit(). This -is because the application has the option to provide the start of the zlib stream in -order for inflateInit() to have access to information about the compression -method to aid in memory allocation. In the current implementation of zlib -(up through versions 1.2.x), the method-dependent memory allocations are deferred to the first call of -inflate() anyway. However those fields must be initialized since later versions -of zlib that provide more compression methods may take advantage of this interface. -In any case, no decompression is performed by inflateInit(), so the -avail_out and next_out fields do not need to be initialized before calling. -

-Here avail_in is set to zero and next_in is set to Z_NULL to -indicate that no input data is being provided. -


-    /* allocate inflate state */
-    strm.zalloc = Z_NULL;
-    strm.zfree = Z_NULL;
-    strm.opaque = Z_NULL;
-    strm.avail_in = 0;
-    strm.next_in = Z_NULL;
-    ret = inflateInit(&strm);
-    if (ret != Z_OK)
-        return ret;
-
-The outer do-loop decompresses input until inflate() indicates -that it has reached the end of the compressed data and has produced all of the uncompressed -output. This is in contrast to def() which processes all of the input file. -If end-of-file is reached before the compressed data self-terminates, then the compressed -data is incomplete and an error is returned. -

-    /* decompress until deflate stream ends or end of file */
-    do {
-
-We read input data and set the strm structure accordingly. If we've reached the -end of the input file, then we leave the outer loop and report an error, since the -compressed data is incomplete. Note that we may read more data than is eventually consumed -by inflate(), if the input file continues past the zlib stream. -For applications where zlib streams are embedded in other data, this routine would -need to be modified to return the unused data, or at least indicate how much of the input -data was not used, so the application would know where to pick up after the zlib stream. -

-        strm.avail_in = fread(in, 1, CHUNK, source);
-        if (ferror(source)) {
-            (void)inflateEnd(&strm);
-            return Z_ERRNO;
-        }
-        if (strm.avail_in == 0)
-            break;
-        strm.next_in = in;
-
-The inner do-loop has the same function it did in def(), which is to -keep calling inflate() until has generated all of the output it can with the -provided input. -

-        /* run inflate() on input until output buffer not full */
-        do {
-
-Just like in def(), the same output space is provided for each call of inflate(). -

-            strm.avail_out = CHUNK;
-            strm.next_out = out;
-
-Now we run the decompression engine itself. There is no need to adjust the flush parameter, since -the zlib format is self-terminating. The main difference here is that there are -return values that we need to pay attention to. Z_DATA_ERROR -indicates that inflate() detected an error in the zlib compressed data format, -which means that either the data is not a zlib stream to begin with, or that the data was -corrupted somewhere along the way since it was compressed. The other error to be processed is -Z_MEM_ERROR, which can occur since memory allocation is deferred until inflate() -needs it, unlike deflate(), whose memory is allocated at the start by deflateInit(). -

-Advanced applications may use -deflateSetDictionary() to prime deflate() with a set of likely data to improve the -first 32K or so of compression. This is noted in the zlib header, so inflate() -requests that that dictionary be provided before it can start to decompress. Without the dictionary, -correct decompression is not possible. For this routine, we have no idea what the dictionary is, -so the Z_NEED_DICT indication is converted to a Z_DATA_ERROR. -

-inflate() can also return Z_STREAM_ERROR, which should not be possible here, -but could be checked for as noted above for def(). Z_BUF_ERROR does not need to be -checked for here, for the same reasons noted for def(). Z_STREAM_END will be -checked for later. -


-            ret = inflate(&strm, Z_NO_FLUSH);
-            assert(ret != Z_STREAM_ERROR);  /* state not clobbered */
-            switch (ret) {
-            case Z_NEED_DICT:
-                ret = Z_DATA_ERROR;     /* and fall through */
-            case Z_DATA_ERROR:
-            case Z_MEM_ERROR:
-                (void)inflateEnd(&strm);
-                return ret;
-            }
-
-The output of inflate() is handled identically to that of deflate(). -

-            have = CHUNK - strm.avail_out;
-            if (fwrite(out, 1, have, dest) != have || ferror(dest)) {
-                (void)inflateEnd(&strm);
-                return Z_ERRNO;
-            }
-
-The inner do-loop ends when inflate() has no more output as indicated -by not filling the output buffer, just as for deflate(). In this case, we cannot -assert that strm.avail_in will be zero, since the deflate stream may end before the file -does. -

-        } while (strm.avail_out == 0);
-
-The outer do-loop ends when inflate() reports that it has reached the -end of the input zlib stream, has completed the decompression and integrity -check, and has provided all of the output. This is indicated by the inflate() -return value Z_STREAM_END. The inner loop is guaranteed to leave ret -equal to Z_STREAM_END if the last chunk of the input file read contained the end -of the zlib stream. So if the return value is not Z_STREAM_END, the -loop continues to read more input. -

-        /* done when inflate() says it's done */
-    } while (ret != Z_STREAM_END);
-
-At this point, decompression successfully completed, or we broke out of the loop due to no -more data being available from the input file. If the last inflate() return value -is not Z_STREAM_END, then the zlib stream was incomplete and a data error -is returned. Otherwise, we return with a happy return value. Of course, inflateEnd() -is called first to avoid a memory leak. -

-    /* clean up and return */
-    (void)inflateEnd(&strm);
-    return ret == Z_STREAM_END ? Z_OK : Z_DATA_ERROR;
-}
-
-That ends the routines that directly use zlib. The following routines make this -a command-line program by running data through the above routines from stdin to -stdout, and handling any errors reported by def() or inf(). -

-zerr() is used to interpret the possible error codes from def() -and inf(), as detailed in their comments above, and print out an error message. -Note that these are only a subset of the possible return values from deflate() -and inflate(). -


-/* report a zlib or i/o error */
-void zerr(int ret)
-{
-    fputs("zpipe: ", stderr);
-    switch (ret) {
-    case Z_ERRNO:
-        if (ferror(stdin))
-            fputs("error reading stdin\n", stderr);
-        if (ferror(stdout))
-            fputs("error writing stdout\n", stderr);
-        break;
-    case Z_STREAM_ERROR:
-        fputs("invalid compression level\n", stderr);
-        break;
-    case Z_DATA_ERROR:
-        fputs("invalid or incomplete deflate data\n", stderr);
-        break;
-    case Z_MEM_ERROR:
-        fputs("out of memory\n", stderr);
-        break;
-    case Z_VERSION_ERROR:
-        fputs("zlib version mismatch!\n", stderr);
-    }
-}
-
-Here is the main() routine used to test def() and inf(). The -zpipe command is simply a compression pipe from stdin to stdout, if -no arguments are given, or it is a decompression pipe if zpipe -d is used. If any other -arguments are provided, no compression or decompression is performed. Instead a usage -message is displayed. Examples are zpipe < foo.txt > foo.txt.z to compress, and -zpipe -d < foo.txt.z > foo.txt to decompress. -

-/* compress or decompress from stdin to stdout */
-int main(int argc, char **argv)
-{
-    int ret;
-
-    /* avoid end-of-line conversions */
-    SET_BINARY_MODE(stdin);
-    SET_BINARY_MODE(stdout);
-
-    /* do compression if no arguments */
-    if (argc == 1) {
-        ret = def(stdin, stdout, Z_DEFAULT_COMPRESSION);
-        if (ret != Z_OK)
-            zerr(ret);
-        return ret;
-    }
-
-    /* do decompression if -d specified */
-    else if (argc == 2 && strcmp(argv[1], "-d") == 0) {
-        ret = inf(stdin, stdout);
-        if (ret != Z_OK)
-            zerr(ret);
-        return ret;
-    }
-
-    /* otherwise, report usage */
-    else {
-        fputs("zpipe usage: zpipe [-d] < source > dest\n", stderr);
-        return 1;
-    }
-}
-
-
-Copyright (c) 2004, 2005 by Mark Adler
Last modified 11 December 2005 - - DELETED compat/zlib/examples/zpipe.c Index: compat/zlib/examples/zpipe.c ================================================================== --- compat/zlib/examples/zpipe.c +++ /dev/null @@ -1,205 +0,0 @@ -/* zpipe.c: example of proper use of zlib's inflate() and deflate() - Not copyrighted -- provided to the public domain - Version 1.4 11 December 2005 Mark Adler */ - -/* Version history: - 1.0 30 Oct 2004 First version - 1.1 8 Nov 2004 Add void casting for unused return values - Use switch statement for inflate() return values - 1.2 9 Nov 2004 Add assertions to document zlib guarantees - 1.3 6 Apr 2005 Remove incorrect assertion in inf() - 1.4 11 Dec 2005 Add hack to avoid MSDOS end-of-line conversions - Avoid some compiler warnings for input and output buffers - */ - -#include -#include -#include -#include "zlib.h" - -#if defined(MSDOS) || defined(OS2) || defined(WIN32) || defined(__CYGWIN__) -# include -# include -# define SET_BINARY_MODE(file) setmode(fileno(file), O_BINARY) -#else -# define SET_BINARY_MODE(file) -#endif - -#define CHUNK 16384 - -/* Compress from file source to file dest until EOF on source. - def() returns Z_OK on success, Z_MEM_ERROR if memory could not be - allocated for processing, Z_STREAM_ERROR if an invalid compression - level is supplied, Z_VERSION_ERROR if the version of zlib.h and the - version of the library linked do not match, or Z_ERRNO if there is - an error reading or writing the files. */ -int def(FILE *source, FILE *dest, int level) -{ - int ret, flush; - unsigned have; - z_stream strm; - unsigned char in[CHUNK]; - unsigned char out[CHUNK]; - - /* allocate deflate state */ - strm.zalloc = Z_NULL; - strm.zfree = Z_NULL; - strm.opaque = Z_NULL; - ret = deflateInit(&strm, level); - if (ret != Z_OK) - return ret; - - /* compress until end of file */ - do { - strm.avail_in = fread(in, 1, CHUNK, source); - if (ferror(source)) { - (void)deflateEnd(&strm); - return Z_ERRNO; - } - flush = feof(source) ? Z_FINISH : Z_NO_FLUSH; - strm.next_in = in; - - /* run deflate() on input until output buffer not full, finish - compression if all of source has been read in */ - do { - strm.avail_out = CHUNK; - strm.next_out = out; - ret = deflate(&strm, flush); /* no bad return value */ - assert(ret != Z_STREAM_ERROR); /* state not clobbered */ - have = CHUNK - strm.avail_out; - if (fwrite(out, 1, have, dest) != have || ferror(dest)) { - (void)deflateEnd(&strm); - return Z_ERRNO; - } - } while (strm.avail_out == 0); - assert(strm.avail_in == 0); /* all input will be used */ - - /* done when last data in file processed */ - } while (flush != Z_FINISH); - assert(ret == Z_STREAM_END); /* stream will be complete */ - - /* clean up and return */ - (void)deflateEnd(&strm); - return Z_OK; -} - -/* Decompress from file source to file dest until stream ends or EOF. - inf() returns Z_OK on success, Z_MEM_ERROR if memory could not be - allocated for processing, Z_DATA_ERROR if the deflate data is - invalid or incomplete, Z_VERSION_ERROR if the version of zlib.h and - the version of the library linked do not match, or Z_ERRNO if there - is an error reading or writing the files. */ -int inf(FILE *source, FILE *dest) -{ - int ret; - unsigned have; - z_stream strm; - unsigned char in[CHUNK]; - unsigned char out[CHUNK]; - - /* allocate inflate state */ - strm.zalloc = Z_NULL; - strm.zfree = Z_NULL; - strm.opaque = Z_NULL; - strm.avail_in = 0; - strm.next_in = Z_NULL; - ret = inflateInit(&strm); - if (ret != Z_OK) - return ret; - - /* decompress until deflate stream ends or end of file */ - do { - strm.avail_in = fread(in, 1, CHUNK, source); - if (ferror(source)) { - (void)inflateEnd(&strm); - return Z_ERRNO; - } - if (strm.avail_in == 0) - break; - strm.next_in = in; - - /* run inflate() on input until output buffer not full */ - do { - strm.avail_out = CHUNK; - strm.next_out = out; - ret = inflate(&strm, Z_NO_FLUSH); - assert(ret != Z_STREAM_ERROR); /* state not clobbered */ - switch (ret) { - case Z_NEED_DICT: - ret = Z_DATA_ERROR; /* and fall through */ - case Z_DATA_ERROR: - case Z_MEM_ERROR: - (void)inflateEnd(&strm); - return ret; - } - have = CHUNK - strm.avail_out; - if (fwrite(out, 1, have, dest) != have || ferror(dest)) { - (void)inflateEnd(&strm); - return Z_ERRNO; - } - } while (strm.avail_out == 0); - - /* done when inflate() says it's done */ - } while (ret != Z_STREAM_END); - - /* clean up and return */ - (void)inflateEnd(&strm); - return ret == Z_STREAM_END ? Z_OK : Z_DATA_ERROR; -} - -/* report a zlib or i/o error */ -void zerr(int ret) -{ - fputs("zpipe: ", stderr); - switch (ret) { - case Z_ERRNO: - if (ferror(stdin)) - fputs("error reading stdin\n", stderr); - if (ferror(stdout)) - fputs("error writing stdout\n", stderr); - break; - case Z_STREAM_ERROR: - fputs("invalid compression level\n", stderr); - break; - case Z_DATA_ERROR: - fputs("invalid or incomplete deflate data\n", stderr); - break; - case Z_MEM_ERROR: - fputs("out of memory\n", stderr); - break; - case Z_VERSION_ERROR: - fputs("zlib version mismatch!\n", stderr); - } -} - -/* compress or decompress from stdin to stdout */ -int main(int argc, char **argv) -{ - int ret; - - /* avoid end-of-line conversions */ - SET_BINARY_MODE(stdin); - SET_BINARY_MODE(stdout); - - /* do compression if no arguments */ - if (argc == 1) { - ret = def(stdin, stdout, Z_DEFAULT_COMPRESSION); - if (ret != Z_OK) - zerr(ret); - return ret; - } - - /* do decompression if -d specified */ - else if (argc == 2 && strcmp(argv[1], "-d") == 0) { - ret = inf(stdin, stdout); - if (ret != Z_OK) - zerr(ret); - return ret; - } - - /* otherwise, report usage */ - else { - fputs("zpipe usage: zpipe [-d] < source > dest\n", stderr); - return 1; - } -} DELETED compat/zlib/examples/zran.c Index: compat/zlib/examples/zran.c ================================================================== --- compat/zlib/examples/zran.c +++ /dev/null @@ -1,409 +0,0 @@ -/* zran.c -- example of zlib/gzip stream indexing and random access - * Copyright (C) 2005, 2012 Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - Version 1.1 29 Sep 2012 Mark Adler */ - -/* Version History: - 1.0 29 May 2005 First version - 1.1 29 Sep 2012 Fix memory reallocation error - */ - -/* Illustrate the use of Z_BLOCK, inflatePrime(), and inflateSetDictionary() - for random access of a compressed file. A file containing a zlib or gzip - stream is provided on the command line. The compressed stream is decoded in - its entirety, and an index built with access points about every SPAN bytes - in the uncompressed output. The compressed file is left open, and can then - be read randomly, having to decompress on the average SPAN/2 uncompressed - bytes before getting to the desired block of data. - - An access point can be created at the start of any deflate block, by saving - the starting file offset and bit of that block, and the 32K bytes of - uncompressed data that precede that block. Also the uncompressed offset of - that block is saved to provide a referece for locating a desired starting - point in the uncompressed stream. build_index() works by decompressing the - input zlib or gzip stream a block at a time, and at the end of each block - deciding if enough uncompressed data has gone by to justify the creation of - a new access point. If so, that point is saved in a data structure that - grows as needed to accommodate the points. - - To use the index, an offset in the uncompressed data is provided, for which - the latest access point at or preceding that offset is located in the index. - The input file is positioned to the specified location in the index, and if - necessary the first few bits of the compressed data is read from the file. - inflate is initialized with those bits and the 32K of uncompressed data, and - the decompression then proceeds until the desired offset in the file is - reached. Then the decompression continues to read the desired uncompressed - data from the file. - - Another approach would be to generate the index on demand. In that case, - requests for random access reads from the compressed data would try to use - the index, but if a read far enough past the end of the index is required, - then further index entries would be generated and added. - - There is some fair bit of overhead to starting inflation for the random - access, mainly copying the 32K byte dictionary. So if small pieces of the - file are being accessed, it would make sense to implement a cache to hold - some lookahead and avoid many calls to extract() for small lengths. - - Another way to build an index would be to use inflateCopy(). That would - not be constrained to have access points at block boundaries, but requires - more memory per access point, and also cannot be saved to file due to the - use of pointers in the state. The approach here allows for storage of the - index in a file. - */ - -#include -#include -#include -#include "zlib.h" - -#define local static - -#define SPAN 1048576L /* desired distance between access points */ -#define WINSIZE 32768U /* sliding window size */ -#define CHUNK 16384 /* file input buffer size */ - -/* access point entry */ -struct point { - off_t out; /* corresponding offset in uncompressed data */ - off_t in; /* offset in input file of first full byte */ - int bits; /* number of bits (1-7) from byte at in - 1, or 0 */ - unsigned char window[WINSIZE]; /* preceding 32K of uncompressed data */ -}; - -/* access point list */ -struct access { - int have; /* number of list entries filled in */ - int size; /* number of list entries allocated */ - struct point *list; /* allocated list */ -}; - -/* Deallocate an index built by build_index() */ -local void free_index(struct access *index) -{ - if (index != NULL) { - free(index->list); - free(index); - } -} - -/* Add an entry to the access point list. If out of memory, deallocate the - existing list and return NULL. */ -local struct access *addpoint(struct access *index, int bits, - off_t in, off_t out, unsigned left, unsigned char *window) -{ - struct point *next; - - /* if list is empty, create it (start with eight points) */ - if (index == NULL) { - index = malloc(sizeof(struct access)); - if (index == NULL) return NULL; - index->list = malloc(sizeof(struct point) << 3); - if (index->list == NULL) { - free(index); - return NULL; - } - index->size = 8; - index->have = 0; - } - - /* if list is full, make it bigger */ - else if (index->have == index->size) { - index->size <<= 1; - next = realloc(index->list, sizeof(struct point) * index->size); - if (next == NULL) { - free_index(index); - return NULL; - } - index->list = next; - } - - /* fill in entry and increment how many we have */ - next = index->list + index->have; - next->bits = bits; - next->in = in; - next->out = out; - if (left) - memcpy(next->window, window + WINSIZE - left, left); - if (left < WINSIZE) - memcpy(next->window + left, window, WINSIZE - left); - index->have++; - - /* return list, possibly reallocated */ - return index; -} - -/* Make one entire pass through the compressed stream and build an index, with - access points about every span bytes of uncompressed output -- span is - chosen to balance the speed of random access against the memory requirements - of the list, about 32K bytes per access point. Note that data after the end - of the first zlib or gzip stream in the file is ignored. build_index() - returns the number of access points on success (>= 1), Z_MEM_ERROR for out - of memory, Z_DATA_ERROR for an error in the input file, or Z_ERRNO for a - file read error. On success, *built points to the resulting index. */ -local int build_index(FILE *in, off_t span, struct access **built) -{ - int ret; - off_t totin, totout; /* our own total counters to avoid 4GB limit */ - off_t last; /* totout value of last access point */ - struct access *index; /* access points being generated */ - z_stream strm; - unsigned char input[CHUNK]; - unsigned char window[WINSIZE]; - - /* initialize inflate */ - strm.zalloc = Z_NULL; - strm.zfree = Z_NULL; - strm.opaque = Z_NULL; - strm.avail_in = 0; - strm.next_in = Z_NULL; - ret = inflateInit2(&strm, 47); /* automatic zlib or gzip decoding */ - if (ret != Z_OK) - return ret; - - /* inflate the input, maintain a sliding window, and build an index -- this - also validates the integrity of the compressed data using the check - information at the end of the gzip or zlib stream */ - totin = totout = last = 0; - index = NULL; /* will be allocated by first addpoint() */ - strm.avail_out = 0; - do { - /* get some compressed data from input file */ - strm.avail_in = fread(input, 1, CHUNK, in); - if (ferror(in)) { - ret = Z_ERRNO; - goto build_index_error; - } - if (strm.avail_in == 0) { - ret = Z_DATA_ERROR; - goto build_index_error; - } - strm.next_in = input; - - /* process all of that, or until end of stream */ - do { - /* reset sliding window if necessary */ - if (strm.avail_out == 0) { - strm.avail_out = WINSIZE; - strm.next_out = window; - } - - /* inflate until out of input, output, or at end of block -- - update the total input and output counters */ - totin += strm.avail_in; - totout += strm.avail_out; - ret = inflate(&strm, Z_BLOCK); /* return at end of block */ - totin -= strm.avail_in; - totout -= strm.avail_out; - if (ret == Z_NEED_DICT) - ret = Z_DATA_ERROR; - if (ret == Z_MEM_ERROR || ret == Z_DATA_ERROR) - goto build_index_error; - if (ret == Z_STREAM_END) - break; - - /* if at end of block, consider adding an index entry (note that if - data_type indicates an end-of-block, then all of the - uncompressed data from that block has been delivered, and none - of the compressed data after that block has been consumed, - except for up to seven bits) -- the totout == 0 provides an - entry point after the zlib or gzip header, and assures that the - index always has at least one access point; we avoid creating an - access point after the last block by checking bit 6 of data_type - */ - if ((strm.data_type & 128) && !(strm.data_type & 64) && - (totout == 0 || totout - last > span)) { - index = addpoint(index, strm.data_type & 7, totin, - totout, strm.avail_out, window); - if (index == NULL) { - ret = Z_MEM_ERROR; - goto build_index_error; - } - last = totout; - } - } while (strm.avail_in != 0); - } while (ret != Z_STREAM_END); - - /* clean up and return index (release unused entries in list) */ - (void)inflateEnd(&strm); - index->list = realloc(index->list, sizeof(struct point) * index->have); - index->size = index->have; - *built = index; - return index->size; - - /* return error */ - build_index_error: - (void)inflateEnd(&strm); - if (index != NULL) - free_index(index); - return ret; -} - -/* Use the index to read len bytes from offset into buf, return bytes read or - negative for error (Z_DATA_ERROR or Z_MEM_ERROR). If data is requested past - the end of the uncompressed data, then extract() will return a value less - than len, indicating how much as actually read into buf. This function - should not return a data error unless the file was modified since the index - was generated. extract() may also return Z_ERRNO if there is an error on - reading or seeking the input file. */ -local int extract(FILE *in, struct access *index, off_t offset, - unsigned char *buf, int len) -{ - int ret, skip; - z_stream strm; - struct point *here; - unsigned char input[CHUNK]; - unsigned char discard[WINSIZE]; - - /* proceed only if something reasonable to do */ - if (len < 0) - return 0; - - /* find where in stream to start */ - here = index->list; - ret = index->have; - while (--ret && here[1].out <= offset) - here++; - - /* initialize file and inflate state to start there */ - strm.zalloc = Z_NULL; - strm.zfree = Z_NULL; - strm.opaque = Z_NULL; - strm.avail_in = 0; - strm.next_in = Z_NULL; - ret = inflateInit2(&strm, -15); /* raw inflate */ - if (ret != Z_OK) - return ret; - ret = fseeko(in, here->in - (here->bits ? 1 : 0), SEEK_SET); - if (ret == -1) - goto extract_ret; - if (here->bits) { - ret = getc(in); - if (ret == -1) { - ret = ferror(in) ? Z_ERRNO : Z_DATA_ERROR; - goto extract_ret; - } - (void)inflatePrime(&strm, here->bits, ret >> (8 - here->bits)); - } - (void)inflateSetDictionary(&strm, here->window, WINSIZE); - - /* skip uncompressed bytes until offset reached, then satisfy request */ - offset -= here->out; - strm.avail_in = 0; - skip = 1; /* while skipping to offset */ - do { - /* define where to put uncompressed data, and how much */ - if (offset == 0 && skip) { /* at offset now */ - strm.avail_out = len; - strm.next_out = buf; - skip = 0; /* only do this once */ - } - if (offset > WINSIZE) { /* skip WINSIZE bytes */ - strm.avail_out = WINSIZE; - strm.next_out = discard; - offset -= WINSIZE; - } - else if (offset != 0) { /* last skip */ - strm.avail_out = (unsigned)offset; - strm.next_out = discard; - offset = 0; - } - - /* uncompress until avail_out filled, or end of stream */ - do { - if (strm.avail_in == 0) { - strm.avail_in = fread(input, 1, CHUNK, in); - if (ferror(in)) { - ret = Z_ERRNO; - goto extract_ret; - } - if (strm.avail_in == 0) { - ret = Z_DATA_ERROR; - goto extract_ret; - } - strm.next_in = input; - } - ret = inflate(&strm, Z_NO_FLUSH); /* normal inflate */ - if (ret == Z_NEED_DICT) - ret = Z_DATA_ERROR; - if (ret == Z_MEM_ERROR || ret == Z_DATA_ERROR) - goto extract_ret; - if (ret == Z_STREAM_END) - break; - } while (strm.avail_out != 0); - - /* if reach end of stream, then don't keep trying to get more */ - if (ret == Z_STREAM_END) - break; - - /* do until offset reached and requested data read, or stream ends */ - } while (skip); - - /* compute number of uncompressed bytes read after offset */ - ret = skip ? 0 : len - strm.avail_out; - - /* clean up and return bytes read or error */ - extract_ret: - (void)inflateEnd(&strm); - return ret; -} - -/* Demonstrate the use of build_index() and extract() by processing the file - provided on the command line, and the extracting 16K from about 2/3rds of - the way through the uncompressed output, and writing that to stdout. */ -int main(int argc, char **argv) -{ - int len; - off_t offset; - FILE *in; - struct access *index = NULL; - unsigned char buf[CHUNK]; - - /* open input file */ - if (argc != 2) { - fprintf(stderr, "usage: zran file.gz\n"); - return 1; - } - in = fopen(argv[1], "rb"); - if (in == NULL) { - fprintf(stderr, "zran: could not open %s for reading\n", argv[1]); - return 1; - } - - /* build index */ - len = build_index(in, SPAN, &index); - if (len < 0) { - fclose(in); - switch (len) { - case Z_MEM_ERROR: - fprintf(stderr, "zran: out of memory\n"); - break; - case Z_DATA_ERROR: - fprintf(stderr, "zran: compressed data error in %s\n", argv[1]); - break; - case Z_ERRNO: - fprintf(stderr, "zran: read error on %s\n", argv[1]); - break; - default: - fprintf(stderr, "zran: error %d while building index\n", len); - } - return 1; - } - fprintf(stderr, "zran: built index with %d access points\n", len); - - /* use index by reading some bytes from an arbitrary offset */ - offset = (index->list[index->have - 1].out << 1) / 3; - len = extract(in, index, offset, buf, CHUNK); - if (len < 0) - fprintf(stderr, "zran: extraction failed: %s error\n", - len == Z_MEM_ERROR ? "out of memory" : "input corrupted"); - else { - fwrite(buf, 1, len, stdout); - fprintf(stderr, "zran: extracted %d bytes at %llu\n", len, offset); - } - - /* clean up and exit */ - free_index(index); - fclose(in); - return 0; -} DELETED compat/zlib/gzclose.c Index: compat/zlib/gzclose.c ================================================================== --- compat/zlib/gzclose.c +++ /dev/null @@ -1,25 +0,0 @@ -/* gzclose.c -- zlib gzclose() function - * Copyright (C) 2004, 2010 Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -#include "gzguts.h" - -/* gzclose() is in a separate file so that it is linked in only if it is used. - That way the other gzclose functions can be used instead to avoid linking in - unneeded compression or decompression routines. */ -int ZEXPORT gzclose(file) - gzFile file; -{ -#ifndef NO_GZCOMPRESS - gz_statep state; - - if (file == NULL) - return Z_STREAM_ERROR; - state = (gz_statep)file; - - return state->mode == GZ_READ ? gzclose_r(file) : gzclose_w(file); -#else - return gzclose_r(file); -#endif -} DELETED compat/zlib/gzguts.h Index: compat/zlib/gzguts.h ================================================================== --- compat/zlib/gzguts.h +++ /dev/null @@ -1,218 +0,0 @@ -/* gzguts.h -- zlib internal header definitions for gz* operations - * Copyright (C) 2004, 2005, 2010, 2011, 2012, 2013, 2016 Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -#ifdef _LARGEFILE64_SOURCE -# ifndef _LARGEFILE_SOURCE -# define _LARGEFILE_SOURCE 1 -# endif -# ifdef _FILE_OFFSET_BITS -# undef _FILE_OFFSET_BITS -# endif -#endif - -#ifdef HAVE_HIDDEN -# define ZLIB_INTERNAL __attribute__((visibility ("hidden"))) -#else -# define ZLIB_INTERNAL -#endif - -#include -#include "zlib.h" -#ifdef STDC -# include -# include -# include -#endif - -#ifndef _POSIX_SOURCE -# define _POSIX_SOURCE -#endif -#include - -#ifdef _WIN32 -# include -#endif - -#if defined(__TURBOC__) || defined(_MSC_VER) || defined(_WIN32) -# include -#endif - -#if defined(_WIN32) || defined(__CYGWIN__) -# define WIDECHAR -#endif - -#ifdef WINAPI_FAMILY -# define open _open -# define read _read -# define write _write -# define close _close -#endif - -#ifdef NO_DEFLATE /* for compatibility with old definition */ -# define NO_GZCOMPRESS -#endif - -#if defined(STDC99) || (defined(__TURBOC__) && __TURBOC__ >= 0x550) -# ifndef HAVE_VSNPRINTF -# define HAVE_VSNPRINTF -# endif -#endif - -#if defined(__CYGWIN__) -# ifndef HAVE_VSNPRINTF -# define HAVE_VSNPRINTF -# endif -#endif - -#if defined(MSDOS) && defined(__BORLANDC__) && (BORLANDC > 0x410) -# ifndef HAVE_VSNPRINTF -# define HAVE_VSNPRINTF -# endif -#endif - -#ifndef HAVE_VSNPRINTF -# ifdef MSDOS -/* vsnprintf may exist on some MS-DOS compilers (DJGPP?), - but for now we just assume it doesn't. */ -# define NO_vsnprintf -# endif -# ifdef __TURBOC__ -# define NO_vsnprintf -# endif -# ifdef WIN32 -/* In Win32, vsnprintf is available as the "non-ANSI" _vsnprintf. */ -# if !defined(vsnprintf) && !defined(NO_vsnprintf) -# if !defined(_MSC_VER) || ( defined(_MSC_VER) && _MSC_VER < 1500 ) -# define vsnprintf _vsnprintf -# endif -# endif -# endif -# ifdef __SASC -# define NO_vsnprintf -# endif -# ifdef VMS -# define NO_vsnprintf -# endif -# ifdef __OS400__ -# define NO_vsnprintf -# endif -# ifdef __MVS__ -# define NO_vsnprintf -# endif -#endif - -/* unlike snprintf (which is required in C99), _snprintf does not guarantee - null termination of the result -- however this is only used in gzlib.c where - the result is assured to fit in the space provided */ -#if defined(_MSC_VER) && _MSC_VER < 1900 -# define snprintf _snprintf -#endif - -#ifndef local -# define local static -#endif -/* since "static" is used to mean two completely different things in C, we - define "local" for the non-static meaning of "static", for readability - (compile with -Dlocal if your debugger can't find static symbols) */ - -/* gz* functions always use library allocation functions */ -#ifndef STDC - extern voidp malloc OF((uInt size)); - extern void free OF((voidpf ptr)); -#endif - -/* get errno and strerror definition */ -#if defined UNDER_CE -# include -# define zstrerror() gz_strwinerror((DWORD)GetLastError()) -#else -# ifndef NO_STRERROR -# include -# define zstrerror() strerror(errno) -# else -# define zstrerror() "stdio error (consult errno)" -# endif -#endif - -/* provide prototypes for these when building zlib without LFS */ -#if !defined(_LARGEFILE64_SOURCE) || _LFS64_LARGEFILE-0 == 0 - ZEXTERN gzFile ZEXPORT gzopen64 OF((const char *, const char *)); - ZEXTERN z_off64_t ZEXPORT gzseek64 OF((gzFile, z_off64_t, int)); - ZEXTERN z_off64_t ZEXPORT gztell64 OF((gzFile)); - ZEXTERN z_off64_t ZEXPORT gzoffset64 OF((gzFile)); -#endif - -/* default memLevel */ -#if MAX_MEM_LEVEL >= 8 -# define DEF_MEM_LEVEL 8 -#else -# define DEF_MEM_LEVEL MAX_MEM_LEVEL -#endif - -/* default i/o buffer size -- double this for output when reading (this and - twice this must be able to fit in an unsigned type) */ -#define GZBUFSIZE 8192 - -/* gzip modes, also provide a little integrity check on the passed structure */ -#define GZ_NONE 0 -#define GZ_READ 7247 -#define GZ_WRITE 31153 -#define GZ_APPEND 1 /* mode set to GZ_WRITE after the file is opened */ - -/* values for gz_state how */ -#define LOOK 0 /* look for a gzip header */ -#define COPY 1 /* copy input directly */ -#define GZIP 2 /* decompress a gzip stream */ - -/* internal gzip file state data structure */ -typedef struct { - /* exposed contents for gzgetc() macro */ - struct gzFile_s x; /* "x" for exposed */ - /* x.have: number of bytes available at x.next */ - /* x.next: next output data to deliver or write */ - /* x.pos: current position in uncompressed data */ - /* used for both reading and writing */ - int mode; /* see gzip modes above */ - int fd; /* file descriptor */ - char *path; /* path or fd for error messages */ - unsigned size; /* buffer size, zero if not allocated yet */ - unsigned want; /* requested buffer size, default is GZBUFSIZE */ - unsigned char *in; /* input buffer (double-sized when writing) */ - unsigned char *out; /* output buffer (double-sized when reading) */ - int direct; /* 0 if processing gzip, 1 if transparent */ - /* just for reading */ - int how; /* 0: get header, 1: copy, 2: decompress */ - z_off64_t start; /* where the gzip data started, for rewinding */ - int eof; /* true if end of input file reached */ - int past; /* true if read requested past end */ - /* just for writing */ - int level; /* compression level */ - int strategy; /* compression strategy */ - /* seek request */ - z_off64_t skip; /* amount to skip (already rewound if backwards) */ - int seek; /* true if seek request pending */ - /* error information */ - int err; /* error code */ - char *msg; /* error message */ - /* zlib inflate or deflate stream */ - z_stream strm; /* stream structure in-place (not a pointer) */ -} gz_state; -typedef gz_state FAR *gz_statep; - -/* shared functions */ -void ZLIB_INTERNAL gz_error OF((gz_statep, int, const char *)); -#if defined UNDER_CE -char ZLIB_INTERNAL *gz_strwinerror OF((DWORD error)); -#endif - -/* GT_OFF(x), where x is an unsigned value, is true if x > maximum z_off64_t - value -- needed when comparing unsigned to z_off64_t, which is signed - (possible z_off64_t types off_t, off64_t, and long are all signed) */ -#ifdef INT_MAX -# define GT_OFF(x) (sizeof(int) == sizeof(z_off64_t) && (x) > INT_MAX) -#else -unsigned ZLIB_INTERNAL gz_intmax OF((void)); -# define GT_OFF(x) (sizeof(int) == sizeof(z_off64_t) && (x) > gz_intmax()) -#endif DELETED compat/zlib/gzlib.c Index: compat/zlib/gzlib.c ================================================================== --- compat/zlib/gzlib.c +++ /dev/null @@ -1,637 +0,0 @@ -/* gzlib.c -- zlib functions common to reading and writing gzip files - * Copyright (C) 2004-2017 Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -#include "gzguts.h" - -#if defined(_WIN32) && !defined(__BORLANDC__) && !defined(__MINGW32__) -# define LSEEK _lseeki64 -#else -#if defined(_LARGEFILE64_SOURCE) && _LFS64_LARGEFILE-0 -# define LSEEK lseek64 -#else -# define LSEEK lseek -#endif -#endif - -/* Local functions */ -local void gz_reset OF((gz_statep)); -local gzFile gz_open OF((const void *, int, const char *)); - -#if defined UNDER_CE - -/* Map the Windows error number in ERROR to a locale-dependent error message - string and return a pointer to it. Typically, the values for ERROR come - from GetLastError. - - The string pointed to shall not be modified by the application, but may be - overwritten by a subsequent call to gz_strwinerror - - The gz_strwinerror function does not change the current setting of - GetLastError. */ -char ZLIB_INTERNAL *gz_strwinerror (error) - DWORD error; -{ - static char buf[1024]; - - wchar_t *msgbuf; - DWORD lasterr = GetLastError(); - DWORD chars = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM - | FORMAT_MESSAGE_ALLOCATE_BUFFER, - NULL, - error, - 0, /* Default language */ - (LPVOID)&msgbuf, - 0, - NULL); - if (chars != 0) { - /* If there is an \r\n appended, zap it. */ - if (chars >= 2 - && msgbuf[chars - 2] == '\r' && msgbuf[chars - 1] == '\n') { - chars -= 2; - msgbuf[chars] = 0; - } - - if (chars > sizeof (buf) - 1) { - chars = sizeof (buf) - 1; - msgbuf[chars] = 0; - } - - wcstombs(buf, msgbuf, chars + 1); - LocalFree(msgbuf); - } - else { - sprintf(buf, "unknown win32 error (%ld)", error); - } - - SetLastError(lasterr); - return buf; -} - -#endif /* UNDER_CE */ - -/* Reset gzip file state */ -local void gz_reset(state) - gz_statep state; -{ - state->x.have = 0; /* no output data available */ - if (state->mode == GZ_READ) { /* for reading ... */ - state->eof = 0; /* not at end of file */ - state->past = 0; /* have not read past end yet */ - state->how = LOOK; /* look for gzip header */ - } - state->seek = 0; /* no seek request pending */ - gz_error(state, Z_OK, NULL); /* clear error */ - state->x.pos = 0; /* no uncompressed data yet */ - state->strm.avail_in = 0; /* no input data yet */ -} - -/* Open a gzip file either by name or file descriptor. */ -local gzFile gz_open(path, fd, mode) - const void *path; - int fd; - const char *mode; -{ - gz_statep state; - z_size_t len; - int oflag; -#ifdef O_CLOEXEC - int cloexec = 0; -#endif -#ifdef O_EXCL - int exclusive = 0; -#endif - - /* check input */ - if (path == NULL) - return NULL; - - /* allocate gzFile structure to return */ - state = (gz_statep)malloc(sizeof(gz_state)); - if (state == NULL) - return NULL; - state->size = 0; /* no buffers allocated yet */ - state->want = GZBUFSIZE; /* requested buffer size */ - state->msg = NULL; /* no error message yet */ - - /* interpret mode */ - state->mode = GZ_NONE; - state->level = Z_DEFAULT_COMPRESSION; - state->strategy = Z_DEFAULT_STRATEGY; - state->direct = 0; - while (*mode) { - if (*mode >= '0' && *mode <= '9') - state->level = *mode - '0'; - else - switch (*mode) { - case 'r': - state->mode = GZ_READ; - break; -#ifndef NO_GZCOMPRESS - case 'w': - state->mode = GZ_WRITE; - break; - case 'a': - state->mode = GZ_APPEND; - break; -#endif - case '+': /* can't read and write at the same time */ - free(state); - return NULL; - case 'b': /* ignore -- will request binary anyway */ - break; -#ifdef O_CLOEXEC - case 'e': - cloexec = 1; - break; -#endif -#ifdef O_EXCL - case 'x': - exclusive = 1; - break; -#endif - case 'f': - state->strategy = Z_FILTERED; - break; - case 'h': - state->strategy = Z_HUFFMAN_ONLY; - break; - case 'R': - state->strategy = Z_RLE; - break; - case 'F': - state->strategy = Z_FIXED; - break; - case 'T': - state->direct = 1; - break; - default: /* could consider as an error, but just ignore */ - ; - } - mode++; - } - - /* must provide an "r", "w", or "a" */ - if (state->mode == GZ_NONE) { - free(state); - return NULL; - } - - /* can't force transparent read */ - if (state->mode == GZ_READ) { - if (state->direct) { - free(state); - return NULL; - } - state->direct = 1; /* for empty file */ - } - - /* save the path name for error messages */ -#ifdef WIDECHAR - if (fd == -2) { - len = wcstombs(NULL, path, 0); - if (len == (z_size_t)-1) - len = 0; - } - else -#endif - len = strlen((const char *)path); - state->path = (char *)malloc(len + 1); - if (state->path == NULL) { - free(state); - return NULL; - } -#ifdef WIDECHAR - if (fd == -2) - if (len) - wcstombs(state->path, path, len + 1); - else - *(state->path) = 0; - else -#endif -#if !defined(NO_snprintf) && !defined(NO_vsnprintf) - (void)snprintf(state->path, len + 1, "%s", (const char *)path); -#else - strcpy(state->path, path); -#endif - - /* compute the flags for open() */ - oflag = -#ifdef O_LARGEFILE - O_LARGEFILE | -#endif -#ifdef O_BINARY - O_BINARY | -#endif -#ifdef O_CLOEXEC - (cloexec ? O_CLOEXEC : 0) | -#endif - (state->mode == GZ_READ ? - O_RDONLY : - (O_WRONLY | O_CREAT | -#ifdef O_EXCL - (exclusive ? O_EXCL : 0) | -#endif - (state->mode == GZ_WRITE ? - O_TRUNC : - O_APPEND))); - - /* open the file with the appropriate flags (or just use fd) */ - state->fd = fd > -1 ? fd : ( -#ifdef WIDECHAR - fd == -2 ? _wopen(path, oflag, 0666) : -#endif - open((const char *)path, oflag, 0666)); - if (state->fd == -1) { - free(state->path); - free(state); - return NULL; - } - if (state->mode == GZ_APPEND) { - LSEEK(state->fd, 0, SEEK_END); /* so gzoffset() is correct */ - state->mode = GZ_WRITE; /* simplify later checks */ - } - - /* save the current position for rewinding (only if reading) */ - if (state->mode == GZ_READ) { - state->start = LSEEK(state->fd, 0, SEEK_CUR); - if (state->start == -1) state->start = 0; - } - - /* initialize stream */ - gz_reset(state); - - /* return stream */ - return (gzFile)state; -} - -/* -- see zlib.h -- */ -gzFile ZEXPORT gzopen(path, mode) - const char *path; - const char *mode; -{ - return gz_open(path, -1, mode); -} - -/* -- see zlib.h -- */ -gzFile ZEXPORT gzopen64(path, mode) - const char *path; - const char *mode; -{ - return gz_open(path, -1, mode); -} - -/* -- see zlib.h -- */ -gzFile ZEXPORT gzdopen(fd, mode) - int fd; - const char *mode; -{ - char *path; /* identifier for error messages */ - gzFile gz; - - if (fd == -1 || (path = (char *)malloc(7 + 3 * sizeof(int))) == NULL) - return NULL; -#if !defined(NO_snprintf) && !defined(NO_vsnprintf) - (void)snprintf(path, 7 + 3 * sizeof(int), "", fd); -#else - sprintf(path, "", fd); /* for debugging */ -#endif - gz = gz_open(path, fd, mode); - free(path); - return gz; -} - -/* -- see zlib.h -- */ -#ifdef WIDECHAR -gzFile ZEXPORT gzopen_w(path, mode) - const wchar_t *path; - const char *mode; -{ - return gz_open(path, -2, mode); -} -#endif - -/* -- see zlib.h -- */ -int ZEXPORT gzbuffer(file, size) - gzFile file; - unsigned size; -{ - gz_statep state; - - /* get internal structure and check integrity */ - if (file == NULL) - return -1; - state = (gz_statep)file; - if (state->mode != GZ_READ && state->mode != GZ_WRITE) - return -1; - - /* make sure we haven't already allocated memory */ - if (state->size != 0) - return -1; - - /* check and set requested size */ - if ((size << 1) < size) - return -1; /* need to be able to double it */ - if (size < 2) - size = 2; /* need two bytes to check magic header */ - state->want = size; - return 0; -} - -/* -- see zlib.h -- */ -int ZEXPORT gzrewind(file) - gzFile file; -{ - gz_statep state; - - /* get internal structure */ - if (file == NULL) - return -1; - state = (gz_statep)file; - - /* check that we're reading and that there's no error */ - if (state->mode != GZ_READ || - (state->err != Z_OK && state->err != Z_BUF_ERROR)) - return -1; - - /* back up and start over */ - if (LSEEK(state->fd, state->start, SEEK_SET) == -1) - return -1; - gz_reset(state); - return 0; -} - -/* -- see zlib.h -- */ -z_off64_t ZEXPORT gzseek64(file, offset, whence) - gzFile file; - z_off64_t offset; - int whence; -{ - unsigned n; - z_off64_t ret; - gz_statep state; - - /* get internal structure and check integrity */ - if (file == NULL) - return -1; - state = (gz_statep)file; - if (state->mode != GZ_READ && state->mode != GZ_WRITE) - return -1; - - /* check that there's no error */ - if (state->err != Z_OK && state->err != Z_BUF_ERROR) - return -1; - - /* can only seek from start or relative to current position */ - if (whence != SEEK_SET && whence != SEEK_CUR) - return -1; - - /* normalize offset to a SEEK_CUR specification */ - if (whence == SEEK_SET) - offset -= state->x.pos; - else if (state->seek) - offset += state->skip; - state->seek = 0; - - /* if within raw area while reading, just go there */ - if (state->mode == GZ_READ && state->how == COPY && - state->x.pos + offset >= 0) { - ret = LSEEK(state->fd, offset - state->x.have, SEEK_CUR); - if (ret == -1) - return -1; - state->x.have = 0; - state->eof = 0; - state->past = 0; - state->seek = 0; - gz_error(state, Z_OK, NULL); - state->strm.avail_in = 0; - state->x.pos += offset; - return state->x.pos; - } - - /* calculate skip amount, rewinding if needed for back seek when reading */ - if (offset < 0) { - if (state->mode != GZ_READ) /* writing -- can't go backwards */ - return -1; - offset += state->x.pos; - if (offset < 0) /* before start of file! */ - return -1; - if (gzrewind(file) == -1) /* rewind, then skip to offset */ - return -1; - } - - /* if reading, skip what's in output buffer (one less gzgetc() check) */ - if (state->mode == GZ_READ) { - n = GT_OFF(state->x.have) || (z_off64_t)state->x.have > offset ? - (unsigned)offset : state->x.have; - state->x.have -= n; - state->x.next += n; - state->x.pos += n; - offset -= n; - } - - /* request skip (if not zero) */ - if (offset) { - state->seek = 1; - state->skip = offset; - } - return state->x.pos + offset; -} - -/* -- see zlib.h -- */ -z_off_t ZEXPORT gzseek(file, offset, whence) - gzFile file; - z_off_t offset; - int whence; -{ - z_off64_t ret; - - ret = gzseek64(file, (z_off64_t)offset, whence); - return ret == (z_off_t)ret ? (z_off_t)ret : -1; -} - -/* -- see zlib.h -- */ -z_off64_t ZEXPORT gztell64(file) - gzFile file; -{ - gz_statep state; - - /* get internal structure and check integrity */ - if (file == NULL) - return -1; - state = (gz_statep)file; - if (state->mode != GZ_READ && state->mode != GZ_WRITE) - return -1; - - /* return position */ - return state->x.pos + (state->seek ? state->skip : 0); -} - -/* -- see zlib.h -- */ -z_off_t ZEXPORT gztell(file) - gzFile file; -{ - z_off64_t ret; - - ret = gztell64(file); - return ret == (z_off_t)ret ? (z_off_t)ret : -1; -} - -/* -- see zlib.h -- */ -z_off64_t ZEXPORT gzoffset64(file) - gzFile file; -{ - z_off64_t offset; - gz_statep state; - - /* get internal structure and check integrity */ - if (file == NULL) - return -1; - state = (gz_statep)file; - if (state->mode != GZ_READ && state->mode != GZ_WRITE) - return -1; - - /* compute and return effective offset in file */ - offset = LSEEK(state->fd, 0, SEEK_CUR); - if (offset == -1) - return -1; - if (state->mode == GZ_READ) /* reading */ - offset -= state->strm.avail_in; /* don't count buffered input */ - return offset; -} - -/* -- see zlib.h -- */ -z_off_t ZEXPORT gzoffset(file) - gzFile file; -{ - z_off64_t ret; - - ret = gzoffset64(file); - return ret == (z_off_t)ret ? (z_off_t)ret : -1; -} - -/* -- see zlib.h -- */ -int ZEXPORT gzeof(file) - gzFile file; -{ - gz_statep state; - - /* get internal structure and check integrity */ - if (file == NULL) - return 0; - state = (gz_statep)file; - if (state->mode != GZ_READ && state->mode != GZ_WRITE) - return 0; - - /* return end-of-file state */ - return state->mode == GZ_READ ? state->past : 0; -} - -/* -- see zlib.h -- */ -const char * ZEXPORT gzerror(file, errnum) - gzFile file; - int *errnum; -{ - gz_statep state; - - /* get internal structure and check integrity */ - if (file == NULL) - return NULL; - state = (gz_statep)file; - if (state->mode != GZ_READ && state->mode != GZ_WRITE) - return NULL; - - /* return error information */ - if (errnum != NULL) - *errnum = state->err; - return state->err == Z_MEM_ERROR ? "out of memory" : - (state->msg == NULL ? "" : state->msg); -} - -/* -- see zlib.h -- */ -void ZEXPORT gzclearerr(file) - gzFile file; -{ - gz_statep state; - - /* get internal structure and check integrity */ - if (file == NULL) - return; - state = (gz_statep)file; - if (state->mode != GZ_READ && state->mode != GZ_WRITE) - return; - - /* clear error and end-of-file */ - if (state->mode == GZ_READ) { - state->eof = 0; - state->past = 0; - } - gz_error(state, Z_OK, NULL); -} - -/* Create an error message in allocated memory and set state->err and - state->msg accordingly. Free any previous error message already there. Do - not try to free or allocate space if the error is Z_MEM_ERROR (out of - memory). Simply save the error message as a static string. If there is an - allocation failure constructing the error message, then convert the error to - out of memory. */ -void ZLIB_INTERNAL gz_error(state, err, msg) - gz_statep state; - int err; - const char *msg; -{ - /* free previously allocated message and clear */ - if (state->msg != NULL) { - if (state->err != Z_MEM_ERROR) - free(state->msg); - state->msg = NULL; - } - - /* if fatal, set state->x.have to 0 so that the gzgetc() macro fails */ - if (err != Z_OK && err != Z_BUF_ERROR) - state->x.have = 0; - - /* set error code, and if no message, then done */ - state->err = err; - if (msg == NULL) - return; - - /* for an out of memory error, return literal string when requested */ - if (err == Z_MEM_ERROR) - return; - - /* construct error message with path */ - if ((state->msg = (char *)malloc(strlen(state->path) + strlen(msg) + 3)) == - NULL) { - state->err = Z_MEM_ERROR; - return; - } -#if !defined(NO_snprintf) && !defined(NO_vsnprintf) - (void)snprintf(state->msg, strlen(state->path) + strlen(msg) + 3, - "%s%s%s", state->path, ": ", msg); -#else - strcpy(state->msg, state->path); - strcat(state->msg, ": "); - strcat(state->msg, msg); -#endif -} - -#ifndef INT_MAX -/* portably return maximum value for an int (when limits.h presumed not - available) -- we need to do this to cover cases where 2's complement not - used, since C standard permits 1's complement and sign-bit representations, - otherwise we could just use ((unsigned)-1) >> 1 */ -unsigned ZLIB_INTERNAL gz_intmax() -{ - unsigned p, q; - - p = 1; - do { - q = p; - p <<= 1; - p++; - } while (p > q); - return q >> 1; -} -#endif DELETED compat/zlib/gzread.c Index: compat/zlib/gzread.c ================================================================== --- compat/zlib/gzread.c +++ /dev/null @@ -1,654 +0,0 @@ -/* gzread.c -- zlib functions for reading gzip files - * Copyright (C) 2004, 2005, 2010, 2011, 2012, 2013, 2016 Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -#include "gzguts.h" - -/* Local functions */ -local int gz_load OF((gz_statep, unsigned char *, unsigned, unsigned *)); -local int gz_avail OF((gz_statep)); -local int gz_look OF((gz_statep)); -local int gz_decomp OF((gz_statep)); -local int gz_fetch OF((gz_statep)); -local int gz_skip OF((gz_statep, z_off64_t)); -local z_size_t gz_read OF((gz_statep, voidp, z_size_t)); - -/* Use read() to load a buffer -- return -1 on error, otherwise 0. Read from - state->fd, and update state->eof, state->err, and state->msg as appropriate. - This function needs to loop on read(), since read() is not guaranteed to - read the number of bytes requested, depending on the type of descriptor. */ -local int gz_load(state, buf, len, have) - gz_statep state; - unsigned char *buf; - unsigned len; - unsigned *have; -{ - int ret; - unsigned get, max = ((unsigned)-1 >> 2) + 1; - - *have = 0; - do { - get = len - *have; - if (get > max) - get = max; - ret = read(state->fd, buf + *have, get); - if (ret <= 0) - break; - *have += (unsigned)ret; - } while (*have < len); - if (ret < 0) { - gz_error(state, Z_ERRNO, zstrerror()); - return -1; - } - if (ret == 0) - state->eof = 1; - return 0; -} - -/* Load up input buffer and set eof flag if last data loaded -- return -1 on - error, 0 otherwise. Note that the eof flag is set when the end of the input - file is reached, even though there may be unused data in the buffer. Once - that data has been used, no more attempts will be made to read the file. - If strm->avail_in != 0, then the current data is moved to the beginning of - the input buffer, and then the remainder of the buffer is loaded with the - available data from the input file. */ -local int gz_avail(state) - gz_statep state; -{ - unsigned got; - z_streamp strm = &(state->strm); - - if (state->err != Z_OK && state->err != Z_BUF_ERROR) - return -1; - if (state->eof == 0) { - if (strm->avail_in) { /* copy what's there to the start */ - unsigned char *p = state->in; - unsigned const char *q = strm->next_in; - unsigned n = strm->avail_in; - do { - *p++ = *q++; - } while (--n); - } - if (gz_load(state, state->in + strm->avail_in, - state->size - strm->avail_in, &got) == -1) - return -1; - strm->avail_in += got; - strm->next_in = state->in; - } - return 0; -} - -/* Look for gzip header, set up for inflate or copy. state->x.have must be 0. - If this is the first time in, allocate required memory. state->how will be - left unchanged if there is no more input data available, will be set to COPY - if there is no gzip header and direct copying will be performed, or it will - be set to GZIP for decompression. If direct copying, then leftover input - data from the input buffer will be copied to the output buffer. In that - case, all further file reads will be directly to either the output buffer or - a user buffer. If decompressing, the inflate state will be initialized. - gz_look() will return 0 on success or -1 on failure. */ -local int gz_look(state) - gz_statep state; -{ - z_streamp strm = &(state->strm); - - /* allocate read buffers and inflate memory */ - if (state->size == 0) { - /* allocate buffers */ - state->in = (unsigned char *)malloc(state->want); - state->out = (unsigned char *)malloc(state->want << 1); - if (state->in == NULL || state->out == NULL) { - free(state->out); - free(state->in); - gz_error(state, Z_MEM_ERROR, "out of memory"); - return -1; - } - state->size = state->want; - - /* allocate inflate memory */ - state->strm.zalloc = Z_NULL; - state->strm.zfree = Z_NULL; - state->strm.opaque = Z_NULL; - state->strm.avail_in = 0; - state->strm.next_in = Z_NULL; - if (inflateInit2(&(state->strm), 15 + 16) != Z_OK) { /* gunzip */ - free(state->out); - free(state->in); - state->size = 0; - gz_error(state, Z_MEM_ERROR, "out of memory"); - return -1; - } - } - - /* get at least the magic bytes in the input buffer */ - if (strm->avail_in < 2) { - if (gz_avail(state) == -1) - return -1; - if (strm->avail_in == 0) - return 0; - } - - /* look for gzip magic bytes -- if there, do gzip decoding (note: there is - a logical dilemma here when considering the case of a partially written - gzip file, to wit, if a single 31 byte is written, then we cannot tell - whether this is a single-byte file, or just a partially written gzip - file -- for here we assume that if a gzip file is being written, then - the header will be written in a single operation, so that reading a - single byte is sufficient indication that it is not a gzip file) */ - if (strm->avail_in > 1 && - strm->next_in[0] == 31 && strm->next_in[1] == 139) { - inflateReset(strm); - state->how = GZIP; - state->direct = 0; - return 0; - } - - /* no gzip header -- if we were decoding gzip before, then this is trailing - garbage. Ignore the trailing garbage and finish. */ - if (state->direct == 0) { - strm->avail_in = 0; - state->eof = 1; - state->x.have = 0; - return 0; - } - - /* doing raw i/o, copy any leftover input to output -- this assumes that - the output buffer is larger than the input buffer, which also assures - space for gzungetc() */ - state->x.next = state->out; - if (strm->avail_in) { - memcpy(state->x.next, strm->next_in, strm->avail_in); - state->x.have = strm->avail_in; - strm->avail_in = 0; - } - state->how = COPY; - state->direct = 1; - return 0; -} - -/* Decompress from input to the provided next_out and avail_out in the state. - On return, state->x.have and state->x.next point to the just decompressed - data. If the gzip stream completes, state->how is reset to LOOK to look for - the next gzip stream or raw data, once state->x.have is depleted. Returns 0 - on success, -1 on failure. */ -local int gz_decomp(state) - gz_statep state; -{ - int ret = Z_OK; - unsigned had; - z_streamp strm = &(state->strm); - - /* fill output buffer up to end of deflate stream */ - had = strm->avail_out; - do { - /* get more input for inflate() */ - if (strm->avail_in == 0 && gz_avail(state) == -1) - return -1; - if (strm->avail_in == 0) { - gz_error(state, Z_BUF_ERROR, "unexpected end of file"); - break; - } - - /* decompress and handle errors */ - ret = inflate(strm, Z_NO_FLUSH); - if (ret == Z_STREAM_ERROR || ret == Z_NEED_DICT) { - gz_error(state, Z_STREAM_ERROR, - "internal error: inflate stream corrupt"); - return -1; - } - if (ret == Z_MEM_ERROR) { - gz_error(state, Z_MEM_ERROR, "out of memory"); - return -1; - } - if (ret == Z_DATA_ERROR) { /* deflate stream invalid */ - gz_error(state, Z_DATA_ERROR, - strm->msg == NULL ? "compressed data error" : strm->msg); - return -1; - } - } while (strm->avail_out && ret != Z_STREAM_END); - - /* update available output */ - state->x.have = had - strm->avail_out; - state->x.next = strm->next_out - state->x.have; - - /* if the gzip stream completed successfully, look for another */ - if (ret == Z_STREAM_END) - state->how = LOOK; - - /* good decompression */ - return 0; -} - -/* Fetch data and put it in the output buffer. Assumes state->x.have is 0. - Data is either copied from the input file or decompressed from the input - file depending on state->how. If state->how is LOOK, then a gzip header is - looked for to determine whether to copy or decompress. Returns -1 on error, - otherwise 0. gz_fetch() will leave state->how as COPY or GZIP unless the - end of the input file has been reached and all data has been processed. */ -local int gz_fetch(state) - gz_statep state; -{ - z_streamp strm = &(state->strm); - - do { - switch(state->how) { - case LOOK: /* -> LOOK, COPY (only if never GZIP), or GZIP */ - if (gz_look(state) == -1) - return -1; - if (state->how == LOOK) - return 0; - break; - case COPY: /* -> COPY */ - if (gz_load(state, state->out, state->size << 1, &(state->x.have)) - == -1) - return -1; - state->x.next = state->out; - return 0; - case GZIP: /* -> GZIP or LOOK (if end of gzip stream) */ - strm->avail_out = state->size << 1; - strm->next_out = state->out; - if (gz_decomp(state) == -1) - return -1; - } - } while (state->x.have == 0 && (!state->eof || strm->avail_in)); - return 0; -} - -/* Skip len uncompressed bytes of output. Return -1 on error, 0 on success. */ -local int gz_skip(state, len) - gz_statep state; - z_off64_t len; -{ - unsigned n; - - /* skip over len bytes or reach end-of-file, whichever comes first */ - while (len) - /* skip over whatever is in output buffer */ - if (state->x.have) { - n = GT_OFF(state->x.have) || (z_off64_t)state->x.have > len ? - (unsigned)len : state->x.have; - state->x.have -= n; - state->x.next += n; - state->x.pos += n; - len -= n; - } - - /* output buffer empty -- return if we're at the end of the input */ - else if (state->eof && state->strm.avail_in == 0) - break; - - /* need more data to skip -- load up output buffer */ - else { - /* get more output, looking for header if required */ - if (gz_fetch(state) == -1) - return -1; - } - return 0; -} - -/* Read len bytes into buf from file, or less than len up to the end of the - input. Return the number of bytes read. If zero is returned, either the - end of file was reached, or there was an error. state->err must be - consulted in that case to determine which. */ -local z_size_t gz_read(state, buf, len) - gz_statep state; - voidp buf; - z_size_t len; -{ - z_size_t got; - unsigned n; - - /* if len is zero, avoid unnecessary operations */ - if (len == 0) - return 0; - - /* process a skip request */ - if (state->seek) { - state->seek = 0; - if (gz_skip(state, state->skip) == -1) - return 0; - } - - /* get len bytes to buf, or less than len if at the end */ - got = 0; - do { - /* set n to the maximum amount of len that fits in an unsigned int */ - n = -1; - if (n > len) - n = len; - - /* first just try copying data from the output buffer */ - if (state->x.have) { - if (state->x.have < n) - n = state->x.have; - memcpy(buf, state->x.next, n); - state->x.next += n; - state->x.have -= n; - } - - /* output buffer empty -- return if we're at the end of the input */ - else if (state->eof && state->strm.avail_in == 0) { - state->past = 1; /* tried to read past end */ - break; - } - - /* need output data -- for small len or new stream load up our output - buffer */ - else if (state->how == LOOK || n < (state->size << 1)) { - /* get more output, looking for header if required */ - if (gz_fetch(state) == -1) - return 0; - continue; /* no progress yet -- go back to copy above */ - /* the copy above assures that we will leave with space in the - output buffer, allowing at least one gzungetc() to succeed */ - } - - /* large len -- read directly into user buffer */ - else if (state->how == COPY) { /* read directly */ - if (gz_load(state, (unsigned char *)buf, n, &n) == -1) - return 0; - } - - /* large len -- decompress directly into user buffer */ - else { /* state->how == GZIP */ - state->strm.avail_out = n; - state->strm.next_out = (unsigned char *)buf; - if (gz_decomp(state) == -1) - return 0; - n = state->x.have; - state->x.have = 0; - } - - /* update progress */ - len -= n; - buf = (char *)buf + n; - got += n; - state->x.pos += n; - } while (len); - - /* return number of bytes read into user buffer */ - return got; -} - -/* -- see zlib.h -- */ -int ZEXPORT gzread(file, buf, len) - gzFile file; - voidp buf; - unsigned len; -{ - gz_statep state; - - /* get internal structure */ - if (file == NULL) - return -1; - state = (gz_statep)file; - - /* check that we're reading and that there's no (serious) error */ - if (state->mode != GZ_READ || - (state->err != Z_OK && state->err != Z_BUF_ERROR)) - return -1; - - /* since an int is returned, make sure len fits in one, otherwise return - with an error (this avoids a flaw in the interface) */ - if ((int)len < 0) { - gz_error(state, Z_STREAM_ERROR, "request does not fit in an int"); - return -1; - } - - /* read len or fewer bytes to buf */ - len = gz_read(state, buf, len); - - /* check for an error */ - if (len == 0 && state->err != Z_OK && state->err != Z_BUF_ERROR) - return -1; - - /* return the number of bytes read (this is assured to fit in an int) */ - return (int)len; -} - -/* -- see zlib.h -- */ -z_size_t ZEXPORT gzfread(buf, size, nitems, file) - voidp buf; - z_size_t size; - z_size_t nitems; - gzFile file; -{ - z_size_t len; - gz_statep state; - - /* get internal structure */ - if (file == NULL) - return 0; - state = (gz_statep)file; - - /* check that we're reading and that there's no (serious) error */ - if (state->mode != GZ_READ || - (state->err != Z_OK && state->err != Z_BUF_ERROR)) - return 0; - - /* compute bytes to read -- error on overflow */ - len = nitems * size; - if (size && len / size != nitems) { - gz_error(state, Z_STREAM_ERROR, "request does not fit in a size_t"); - return 0; - } - - /* read len or fewer bytes to buf, return the number of full items read */ - return len ? gz_read(state, buf, len) / size : 0; -} - -/* -- see zlib.h -- */ -#ifdef Z_PREFIX_SET -# undef z_gzgetc -#else -# undef gzgetc -#endif -int ZEXPORT gzgetc(file) - gzFile file; -{ - int ret; - unsigned char buf[1]; - gz_statep state; - - /* get internal structure */ - if (file == NULL) - return -1; - state = (gz_statep)file; - - /* check that we're reading and that there's no (serious) error */ - if (state->mode != GZ_READ || - (state->err != Z_OK && state->err != Z_BUF_ERROR)) - return -1; - - /* try output buffer (no need to check for skip request) */ - if (state->x.have) { - state->x.have--; - state->x.pos++; - return *(state->x.next)++; - } - - /* nothing there -- try gz_read() */ - ret = gz_read(state, buf, 1); - return ret < 1 ? -1 : buf[0]; -} - -int ZEXPORT gzgetc_(file) -gzFile file; -{ - return gzgetc(file); -} - -/* -- see zlib.h -- */ -int ZEXPORT gzungetc(c, file) - int c; - gzFile file; -{ - gz_statep state; - - /* get internal structure */ - if (file == NULL) - return -1; - state = (gz_statep)file; - - /* check that we're reading and that there's no (serious) error */ - if (state->mode != GZ_READ || - (state->err != Z_OK && state->err != Z_BUF_ERROR)) - return -1; - - /* process a skip request */ - if (state->seek) { - state->seek = 0; - if (gz_skip(state, state->skip) == -1) - return -1; - } - - /* can't push EOF */ - if (c < 0) - return -1; - - /* if output buffer empty, put byte at end (allows more pushing) */ - if (state->x.have == 0) { - state->x.have = 1; - state->x.next = state->out + (state->size << 1) - 1; - state->x.next[0] = (unsigned char)c; - state->x.pos--; - state->past = 0; - return c; - } - - /* if no room, give up (must have already done a gzungetc()) */ - if (state->x.have == (state->size << 1)) { - gz_error(state, Z_DATA_ERROR, "out of room to push characters"); - return -1; - } - - /* slide output data if needed and insert byte before existing data */ - if (state->x.next == state->out) { - unsigned char *src = state->out + state->x.have; - unsigned char *dest = state->out + (state->size << 1); - while (src > state->out) - *--dest = *--src; - state->x.next = dest; - } - state->x.have++; - state->x.next--; - state->x.next[0] = (unsigned char)c; - state->x.pos--; - state->past = 0; - return c; -} - -/* -- see zlib.h -- */ -char * ZEXPORT gzgets(file, buf, len) - gzFile file; - char *buf; - int len; -{ - unsigned left, n; - char *str; - unsigned char *eol; - gz_statep state; - - /* check parameters and get internal structure */ - if (file == NULL || buf == NULL || len < 1) - return NULL; - state = (gz_statep)file; - - /* check that we're reading and that there's no (serious) error */ - if (state->mode != GZ_READ || - (state->err != Z_OK && state->err != Z_BUF_ERROR)) - return NULL; - - /* process a skip request */ - if (state->seek) { - state->seek = 0; - if (gz_skip(state, state->skip) == -1) - return NULL; - } - - /* copy output bytes up to new line or len - 1, whichever comes first -- - append a terminating zero to the string (we don't check for a zero in - the contents, let the user worry about that) */ - str = buf; - left = (unsigned)len - 1; - if (left) do { - /* assure that something is in the output buffer */ - if (state->x.have == 0 && gz_fetch(state) == -1) - return NULL; /* error */ - if (state->x.have == 0) { /* end of file */ - state->past = 1; /* read past end */ - break; /* return what we have */ - } - - /* look for end-of-line in current output buffer */ - n = state->x.have > left ? left : state->x.have; - eol = (unsigned char *)memchr(state->x.next, '\n', n); - if (eol != NULL) - n = (unsigned)(eol - state->x.next) + 1; - - /* copy through end-of-line, or remainder if not found */ - memcpy(buf, state->x.next, n); - state->x.have -= n; - state->x.next += n; - state->x.pos += n; - left -= n; - buf += n; - } while (left && eol == NULL); - - /* return terminated string, or if nothing, end of file */ - if (buf == str) - return NULL; - buf[0] = 0; - return str; -} - -/* -- see zlib.h -- */ -int ZEXPORT gzdirect(file) - gzFile file; -{ - gz_statep state; - - /* get internal structure */ - if (file == NULL) - return 0; - state = (gz_statep)file; - - /* if the state is not known, but we can find out, then do so (this is - mainly for right after a gzopen() or gzdopen()) */ - if (state->mode == GZ_READ && state->how == LOOK && state->x.have == 0) - (void)gz_look(state); - - /* return 1 if transparent, 0 if processing a gzip stream */ - return state->direct; -} - -/* -- see zlib.h -- */ -int ZEXPORT gzclose_r(file) - gzFile file; -{ - int ret, err; - gz_statep state; - - /* get internal structure */ - if (file == NULL) - return Z_STREAM_ERROR; - state = (gz_statep)file; - - /* check that we're reading */ - if (state->mode != GZ_READ) - return Z_STREAM_ERROR; - - /* free memory and close file */ - if (state->size) { - inflateEnd(&(state->strm)); - free(state->out); - free(state->in); - } - err = state->err == Z_BUF_ERROR ? Z_BUF_ERROR : Z_OK; - gz_error(state, Z_OK, NULL); - free(state->path); - ret = close(state->fd); - free(state); - return ret ? Z_ERRNO : err; -} DELETED compat/zlib/gzwrite.c Index: compat/zlib/gzwrite.c ================================================================== --- compat/zlib/gzwrite.c +++ /dev/null @@ -1,665 +0,0 @@ -/* gzwrite.c -- zlib functions for writing gzip files - * Copyright (C) 2004-2017 Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -#include "gzguts.h" - -/* Local functions */ -local int gz_init OF((gz_statep)); -local int gz_comp OF((gz_statep, int)); -local int gz_zero OF((gz_statep, z_off64_t)); -local z_size_t gz_write OF((gz_statep, voidpc, z_size_t)); - -/* Initialize state for writing a gzip file. Mark initialization by setting - state->size to non-zero. Return -1 on a memory allocation failure, or 0 on - success. */ -local int gz_init(state) - gz_statep state; -{ - int ret; - z_streamp strm = &(state->strm); - - /* allocate input buffer (double size for gzprintf) */ - state->in = (unsigned char *)malloc(state->want << 1); - if (state->in == NULL) { - gz_error(state, Z_MEM_ERROR, "out of memory"); - return -1; - } - - /* only need output buffer and deflate state if compressing */ - if (!state->direct) { - /* allocate output buffer */ - state->out = (unsigned char *)malloc(state->want); - if (state->out == NULL) { - free(state->in); - gz_error(state, Z_MEM_ERROR, "out of memory"); - return -1; - } - - /* allocate deflate memory, set up for gzip compression */ - strm->zalloc = Z_NULL; - strm->zfree = Z_NULL; - strm->opaque = Z_NULL; - ret = deflateInit2(strm, state->level, Z_DEFLATED, - MAX_WBITS + 16, DEF_MEM_LEVEL, state->strategy); - if (ret != Z_OK) { - free(state->out); - free(state->in); - gz_error(state, Z_MEM_ERROR, "out of memory"); - return -1; - } - strm->next_in = NULL; - } - - /* mark state as initialized */ - state->size = state->want; - - /* initialize write buffer if compressing */ - if (!state->direct) { - strm->avail_out = state->size; - strm->next_out = state->out; - state->x.next = strm->next_out; - } - return 0; -} - -/* Compress whatever is at avail_in and next_in and write to the output file. - Return -1 if there is an error writing to the output file or if gz_init() - fails to allocate memory, otherwise 0. flush is assumed to be a valid - deflate() flush value. If flush is Z_FINISH, then the deflate() state is - reset to start a new gzip stream. If gz->direct is true, then simply write - to the output file without compressing, and ignore flush. */ -local int gz_comp(state, flush) - gz_statep state; - int flush; -{ - int ret, writ; - unsigned have, put, max = ((unsigned)-1 >> 2) + 1; - z_streamp strm = &(state->strm); - - /* allocate memory if this is the first time through */ - if (state->size == 0 && gz_init(state) == -1) - return -1; - - /* write directly if requested */ - if (state->direct) { - while (strm->avail_in) { - put = strm->avail_in > max ? max : strm->avail_in; - writ = write(state->fd, strm->next_in, put); - if (writ < 0) { - gz_error(state, Z_ERRNO, zstrerror()); - return -1; - } - strm->avail_in -= (unsigned)writ; - strm->next_in += writ; - } - return 0; - } - - /* run deflate() on provided input until it produces no more output */ - ret = Z_OK; - do { - /* write out current buffer contents if full, or if flushing, but if - doing Z_FINISH then don't write until we get to Z_STREAM_END */ - if (strm->avail_out == 0 || (flush != Z_NO_FLUSH && - (flush != Z_FINISH || ret == Z_STREAM_END))) { - while (strm->next_out > state->x.next) { - put = strm->next_out - state->x.next > (int)max ? max : - (unsigned)(strm->next_out - state->x.next); - writ = write(state->fd, state->x.next, put); - if (writ < 0) { - gz_error(state, Z_ERRNO, zstrerror()); - return -1; - } - state->x.next += writ; - } - if (strm->avail_out == 0) { - strm->avail_out = state->size; - strm->next_out = state->out; - state->x.next = state->out; - } - } - - /* compress */ - have = strm->avail_out; - ret = deflate(strm, flush); - if (ret == Z_STREAM_ERROR) { - gz_error(state, Z_STREAM_ERROR, - "internal error: deflate stream corrupt"); - return -1; - } - have -= strm->avail_out; - } while (have); - - /* if that completed a deflate stream, allow another to start */ - if (flush == Z_FINISH) - deflateReset(strm); - - /* all done, no errors */ - return 0; -} - -/* Compress len zeros to output. Return -1 on a write error or memory - allocation failure by gz_comp(), or 0 on success. */ -local int gz_zero(state, len) - gz_statep state; - z_off64_t len; -{ - int first; - unsigned n; - z_streamp strm = &(state->strm); - - /* consume whatever's left in the input buffer */ - if (strm->avail_in && gz_comp(state, Z_NO_FLUSH) == -1) - return -1; - - /* compress len zeros (len guaranteed > 0) */ - first = 1; - while (len) { - n = GT_OFF(state->size) || (z_off64_t)state->size > len ? - (unsigned)len : state->size; - if (first) { - memset(state->in, 0, n); - first = 0; - } - strm->avail_in = n; - strm->next_in = state->in; - state->x.pos += n; - if (gz_comp(state, Z_NO_FLUSH) == -1) - return -1; - len -= n; - } - return 0; -} - -/* Write len bytes from buf to file. Return the number of bytes written. If - the returned value is less than len, then there was an error. */ -local z_size_t gz_write(state, buf, len) - gz_statep state; - voidpc buf; - z_size_t len; -{ - z_size_t put = len; - - /* if len is zero, avoid unnecessary operations */ - if (len == 0) - return 0; - - /* allocate memory if this is the first time through */ - if (state->size == 0 && gz_init(state) == -1) - return 0; - - /* check for seek request */ - if (state->seek) { - state->seek = 0; - if (gz_zero(state, state->skip) == -1) - return 0; - } - - /* for small len, copy to input buffer, otherwise compress directly */ - if (len < state->size) { - /* copy to input buffer, compress when full */ - do { - unsigned have, copy; - - if (state->strm.avail_in == 0) - state->strm.next_in = state->in; - have = (unsigned)((state->strm.next_in + state->strm.avail_in) - - state->in); - copy = state->size - have; - if (copy > len) - copy = len; - memcpy(state->in + have, buf, copy); - state->strm.avail_in += copy; - state->x.pos += copy; - buf = (const char *)buf + copy; - len -= copy; - if (len && gz_comp(state, Z_NO_FLUSH) == -1) - return 0; - } while (len); - } - else { - /* consume whatever's left in the input buffer */ - if (state->strm.avail_in && gz_comp(state, Z_NO_FLUSH) == -1) - return 0; - - /* directly compress user buffer to file */ - state->strm.next_in = (z_const Bytef *)buf; - do { - unsigned n = (unsigned)-1; - if (n > len) - n = len; - state->strm.avail_in = n; - state->x.pos += n; - if (gz_comp(state, Z_NO_FLUSH) == -1) - return 0; - len -= n; - } while (len); - } - - /* input was all buffered or compressed */ - return put; -} - -/* -- see zlib.h -- */ -int ZEXPORT gzwrite(file, buf, len) - gzFile file; - voidpc buf; - unsigned len; -{ - gz_statep state; - - /* get internal structure */ - if (file == NULL) - return 0; - state = (gz_statep)file; - - /* check that we're writing and that there's no error */ - if (state->mode != GZ_WRITE || state->err != Z_OK) - return 0; - - /* since an int is returned, make sure len fits in one, otherwise return - with an error (this avoids a flaw in the interface) */ - if ((int)len < 0) { - gz_error(state, Z_DATA_ERROR, "requested length does not fit in int"); - return 0; - } - - /* write len bytes from buf (the return value will fit in an int) */ - return (int)gz_write(state, buf, len); -} - -/* -- see zlib.h -- */ -z_size_t ZEXPORT gzfwrite(buf, size, nitems, file) - voidpc buf; - z_size_t size; - z_size_t nitems; - gzFile file; -{ - z_size_t len; - gz_statep state; - - /* get internal structure */ - if (file == NULL) - return 0; - state = (gz_statep)file; - - /* check that we're writing and that there's no error */ - if (state->mode != GZ_WRITE || state->err != Z_OK) - return 0; - - /* compute bytes to read -- error on overflow */ - len = nitems * size; - if (size && len / size != nitems) { - gz_error(state, Z_STREAM_ERROR, "request does not fit in a size_t"); - return 0; - } - - /* write len bytes to buf, return the number of full items written */ - return len ? gz_write(state, buf, len) / size : 0; -} - -/* -- see zlib.h -- */ -int ZEXPORT gzputc(file, c) - gzFile file; - int c; -{ - unsigned have; - unsigned char buf[1]; - gz_statep state; - z_streamp strm; - - /* get internal structure */ - if (file == NULL) - return -1; - state = (gz_statep)file; - strm = &(state->strm); - - /* check that we're writing and that there's no error */ - if (state->mode != GZ_WRITE || state->err != Z_OK) - return -1; - - /* check for seek request */ - if (state->seek) { - state->seek = 0; - if (gz_zero(state, state->skip) == -1) - return -1; - } - - /* try writing to input buffer for speed (state->size == 0 if buffer not - initialized) */ - if (state->size) { - if (strm->avail_in == 0) - strm->next_in = state->in; - have = (unsigned)((strm->next_in + strm->avail_in) - state->in); - if (have < state->size) { - state->in[have] = (unsigned char)c; - strm->avail_in++; - state->x.pos++; - return c & 0xff; - } - } - - /* no room in buffer or not initialized, use gz_write() */ - buf[0] = (unsigned char)c; - if (gz_write(state, buf, 1) != 1) - return -1; - return c & 0xff; -} - -/* -- see zlib.h -- */ -int ZEXPORT gzputs(file, str) - gzFile file; - const char *str; -{ - int ret; - z_size_t len; - gz_statep state; - - /* get internal structure */ - if (file == NULL) - return -1; - state = (gz_statep)file; - - /* check that we're writing and that there's no error */ - if (state->mode != GZ_WRITE || state->err != Z_OK) - return -1; - - /* write string */ - len = strlen(str); - ret = gz_write(state, str, len); - return ret == 0 && len != 0 ? -1 : ret; -} - -#if defined(STDC) || defined(Z_HAVE_STDARG_H) -#include - -/* -- see zlib.h -- */ -int ZEXPORTVA gzvprintf(gzFile file, const char *format, va_list va) -{ - int len; - unsigned left; - char *next; - gz_statep state; - z_streamp strm; - - /* get internal structure */ - if (file == NULL) - return Z_STREAM_ERROR; - state = (gz_statep)file; - strm = &(state->strm); - - /* check that we're writing and that there's no error */ - if (state->mode != GZ_WRITE || state->err != Z_OK) - return Z_STREAM_ERROR; - - /* make sure we have some buffer space */ - if (state->size == 0 && gz_init(state) == -1) - return state->err; - - /* check for seek request */ - if (state->seek) { - state->seek = 0; - if (gz_zero(state, state->skip) == -1) - return state->err; - } - - /* do the printf() into the input buffer, put length in len -- the input - buffer is double-sized just for this function, so there is guaranteed to - be state->size bytes available after the current contents */ - if (strm->avail_in == 0) - strm->next_in = state->in; - next = (char *)(state->in + (strm->next_in - state->in) + strm->avail_in); - next[state->size - 1] = 0; -#ifdef NO_vsnprintf -# ifdef HAS_vsprintf_void - (void)vsprintf(next, format, va); - for (len = 0; len < state->size; len++) - if (next[len] == 0) break; -# else - len = vsprintf(next, format, va); -# endif -#else -# ifdef HAS_vsnprintf_void - (void)vsnprintf(next, state->size, format, va); - len = strlen(next); -# else - len = vsnprintf(next, state->size, format, va); -# endif -#endif - - /* check that printf() results fit in buffer */ - if (len == 0 || (unsigned)len >= state->size || next[state->size - 1] != 0) - return 0; - - /* update buffer and position, compress first half if past that */ - strm->avail_in += (unsigned)len; - state->x.pos += len; - if (strm->avail_in >= state->size) { - left = strm->avail_in - state->size; - strm->avail_in = state->size; - if (gz_comp(state, Z_NO_FLUSH) == -1) - return state->err; - memcpy(state->in, state->in + state->size, left); - strm->next_in = state->in; - strm->avail_in = left; - } - return len; -} - -int ZEXPORTVA gzprintf(gzFile file, const char *format, ...) -{ - va_list va; - int ret; - - va_start(va, format); - ret = gzvprintf(file, format, va); - va_end(va); - return ret; -} - -#else /* !STDC && !Z_HAVE_STDARG_H */ - -/* -- see zlib.h -- */ -int ZEXPORTVA gzprintf (file, format, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, - a11, a12, a13, a14, a15, a16, a17, a18, a19, a20) - gzFile file; - const char *format; - int a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, - a11, a12, a13, a14, a15, a16, a17, a18, a19, a20; -{ - unsigned len, left; - char *next; - gz_statep state; - z_streamp strm; - - /* get internal structure */ - if (file == NULL) - return Z_STREAM_ERROR; - state = (gz_statep)file; - strm = &(state->strm); - - /* check that can really pass pointer in ints */ - if (sizeof(int) != sizeof(void *)) - return Z_STREAM_ERROR; - - /* check that we're writing and that there's no error */ - if (state->mode != GZ_WRITE || state->err != Z_OK) - return Z_STREAM_ERROR; - - /* make sure we have some buffer space */ - if (state->size == 0 && gz_init(state) == -1) - return state->error; - - /* check for seek request */ - if (state->seek) { - state->seek = 0; - if (gz_zero(state, state->skip) == -1) - return state->error; - } - - /* do the printf() into the input buffer, put length in len -- the input - buffer is double-sized just for this function, so there is guaranteed to - be state->size bytes available after the current contents */ - if (strm->avail_in == 0) - strm->next_in = state->in; - next = (char *)(strm->next_in + strm->avail_in); - next[state->size - 1] = 0; -#ifdef NO_snprintf -# ifdef HAS_sprintf_void - sprintf(next, format, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, - a13, a14, a15, a16, a17, a18, a19, a20); - for (len = 0; len < size; len++) - if (next[len] == 0) - break; -# else - len = sprintf(next, format, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, - a12, a13, a14, a15, a16, a17, a18, a19, a20); -# endif -#else -# ifdef HAS_snprintf_void - snprintf(next, state->size, format, a1, a2, a3, a4, a5, a6, a7, a8, a9, - a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20); - len = strlen(next); -# else - len = snprintf(next, state->size, format, a1, a2, a3, a4, a5, a6, a7, a8, - a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20); -# endif -#endif - - /* check that printf() results fit in buffer */ - if (len == 0 || len >= state->size || next[state->size - 1] != 0) - return 0; - - /* update buffer and position, compress first half if past that */ - strm->avail_in += len; - state->x.pos += len; - if (strm->avail_in >= state->size) { - left = strm->avail_in - state->size; - strm->avail_in = state->size; - if (gz_comp(state, Z_NO_FLUSH) == -1) - return state->err; - memcpy(state->in, state->in + state->size, left); - strm->next_in = state->in; - strm->avail_in = left; - } - return (int)len; -} - -#endif - -/* -- see zlib.h -- */ -int ZEXPORT gzflush(file, flush) - gzFile file; - int flush; -{ - gz_statep state; - - /* get internal structure */ - if (file == NULL) - return Z_STREAM_ERROR; - state = (gz_statep)file; - - /* check that we're writing and that there's no error */ - if (state->mode != GZ_WRITE || state->err != Z_OK) - return Z_STREAM_ERROR; - - /* check flush parameter */ - if (flush < 0 || flush > Z_FINISH) - return Z_STREAM_ERROR; - - /* check for seek request */ - if (state->seek) { - state->seek = 0; - if (gz_zero(state, state->skip) == -1) - return state->err; - } - - /* compress remaining data with requested flush */ - (void)gz_comp(state, flush); - return state->err; -} - -/* -- see zlib.h -- */ -int ZEXPORT gzsetparams(file, level, strategy) - gzFile file; - int level; - int strategy; -{ - gz_statep state; - z_streamp strm; - - /* get internal structure */ - if (file == NULL) - return Z_STREAM_ERROR; - state = (gz_statep)file; - strm = &(state->strm); - - /* check that we're writing and that there's no error */ - if (state->mode != GZ_WRITE || state->err != Z_OK) - return Z_STREAM_ERROR; - - /* if no change is requested, then do nothing */ - if (level == state->level && strategy == state->strategy) - return Z_OK; - - /* check for seek request */ - if (state->seek) { - state->seek = 0; - if (gz_zero(state, state->skip) == -1) - return state->err; - } - - /* change compression parameters for subsequent input */ - if (state->size) { - /* flush previous input with previous parameters before changing */ - if (strm->avail_in && gz_comp(state, Z_BLOCK) == -1) - return state->err; - deflateParams(strm, level, strategy); - } - state->level = level; - state->strategy = strategy; - return Z_OK; -} - -/* -- see zlib.h -- */ -int ZEXPORT gzclose_w(file) - gzFile file; -{ - int ret = Z_OK; - gz_statep state; - - /* get internal structure */ - if (file == NULL) - return Z_STREAM_ERROR; - state = (gz_statep)file; - - /* check that we're writing */ - if (state->mode != GZ_WRITE) - return Z_STREAM_ERROR; - - /* check for seek request */ - if (state->seek) { - state->seek = 0; - if (gz_zero(state, state->skip) == -1) - ret = state->err; - } - - /* flush, free memory, and close file */ - if (gz_comp(state, Z_FINISH) == -1) - ret = state->err; - if (state->size) { - if (!state->direct) { - (void)deflateEnd(&(state->strm)); - free(state->out); - } - free(state->in); - } - gz_error(state, Z_OK, NULL); - free(state->path); - if (close(state->fd) == -1) - ret = Z_ERRNO; - free(state); - return ret; -} DELETED compat/zlib/infback.c Index: compat/zlib/infback.c ================================================================== --- compat/zlib/infback.c +++ /dev/null @@ -1,640 +0,0 @@ -/* infback.c -- inflate using a call-back interface - * Copyright (C) 1995-2016 Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -/* - This code is largely copied from inflate.c. Normally either infback.o or - inflate.o would be linked into an application--not both. The interface - with inffast.c is retained so that optimized assembler-coded versions of - inflate_fast() can be used with either inflate.c or infback.c. - */ - -#include "zutil.h" -#include "inftrees.h" -#include "inflate.h" -#include "inffast.h" - -/* function prototypes */ -local void fixedtables OF((struct inflate_state FAR *state)); - -/* - strm provides memory allocation functions in zalloc and zfree, or - Z_NULL to use the library memory allocation functions. - - windowBits is in the range 8..15, and window is a user-supplied - window and output buffer that is 2**windowBits bytes. - */ -int ZEXPORT inflateBackInit_(strm, windowBits, window, version, stream_size) -z_streamp strm; -int windowBits; -unsigned char FAR *window; -const char *version; -int stream_size; -{ - struct inflate_state FAR *state; - - if (version == Z_NULL || version[0] != ZLIB_VERSION[0] || - stream_size != (int)(sizeof(z_stream))) - return Z_VERSION_ERROR; - if (strm == Z_NULL || window == Z_NULL || - windowBits < 8 || windowBits > 15) - return Z_STREAM_ERROR; - strm->msg = Z_NULL; /* in case we return an error */ - if (strm->zalloc == (alloc_func)0) { -#ifdef Z_SOLO - return Z_STREAM_ERROR; -#else - strm->zalloc = zcalloc; - strm->opaque = (voidpf)0; -#endif - } - if (strm->zfree == (free_func)0) -#ifdef Z_SOLO - return Z_STREAM_ERROR; -#else - strm->zfree = zcfree; -#endif - state = (struct inflate_state FAR *)ZALLOC(strm, 1, - sizeof(struct inflate_state)); - if (state == Z_NULL) return Z_MEM_ERROR; - Tracev((stderr, "inflate: allocated\n")); - strm->state = (struct internal_state FAR *)state; - state->dmax = 32768U; - state->wbits = (uInt)windowBits; - state->wsize = 1U << windowBits; - state->window = window; - state->wnext = 0; - state->whave = 0; - return Z_OK; -} - -/* - Return state with length and distance decoding tables and index sizes set to - fixed code decoding. Normally this returns fixed tables from inffixed.h. - If BUILDFIXED is defined, then instead this routine builds the tables the - first time it's called, and returns those tables the first time and - thereafter. This reduces the size of the code by about 2K bytes, in - exchange for a little execution time. However, BUILDFIXED should not be - used for threaded applications, since the rewriting of the tables and virgin - may not be thread-safe. - */ -local void fixedtables(state) -struct inflate_state FAR *state; -{ -#ifdef BUILDFIXED - static int virgin = 1; - static code *lenfix, *distfix; - static code fixed[544]; - - /* build fixed huffman tables if first call (may not be thread safe) */ - if (virgin) { - unsigned sym, bits; - static code *next; - - /* literal/length table */ - sym = 0; - while (sym < 144) state->lens[sym++] = 8; - while (sym < 256) state->lens[sym++] = 9; - while (sym < 280) state->lens[sym++] = 7; - while (sym < 288) state->lens[sym++] = 8; - next = fixed; - lenfix = next; - bits = 9; - inflate_table(LENS, state->lens, 288, &(next), &(bits), state->work); - - /* distance table */ - sym = 0; - while (sym < 32) state->lens[sym++] = 5; - distfix = next; - bits = 5; - inflate_table(DISTS, state->lens, 32, &(next), &(bits), state->work); - - /* do this just once */ - virgin = 0; - } -#else /* !BUILDFIXED */ -# include "inffixed.h" -#endif /* BUILDFIXED */ - state->lencode = lenfix; - state->lenbits = 9; - state->distcode = distfix; - state->distbits = 5; -} - -/* Macros for inflateBack(): */ - -/* Load returned state from inflate_fast() */ -#define LOAD() \ - do { \ - put = strm->next_out; \ - left = strm->avail_out; \ - next = strm->next_in; \ - have = strm->avail_in; \ - hold = state->hold; \ - bits = state->bits; \ - } while (0) - -/* Set state from registers for inflate_fast() */ -#define RESTORE() \ - do { \ - strm->next_out = put; \ - strm->avail_out = left; \ - strm->next_in = next; \ - strm->avail_in = have; \ - state->hold = hold; \ - state->bits = bits; \ - } while (0) - -/* Clear the input bit accumulator */ -#define INITBITS() \ - do { \ - hold = 0; \ - bits = 0; \ - } while (0) - -/* Assure that some input is available. If input is requested, but denied, - then return a Z_BUF_ERROR from inflateBack(). */ -#define PULL() \ - do { \ - if (have == 0) { \ - have = in(in_desc, &next); \ - if (have == 0) { \ - next = Z_NULL; \ - ret = Z_BUF_ERROR; \ - goto inf_leave; \ - } \ - } \ - } while (0) - -/* Get a byte of input into the bit accumulator, or return from inflateBack() - with an error if there is no input available. */ -#define PULLBYTE() \ - do { \ - PULL(); \ - have--; \ - hold += (unsigned long)(*next++) << bits; \ - bits += 8; \ - } while (0) - -/* Assure that there are at least n bits in the bit accumulator. If there is - not enough available input to do that, then return from inflateBack() with - an error. */ -#define NEEDBITS(n) \ - do { \ - while (bits < (unsigned)(n)) \ - PULLBYTE(); \ - } while (0) - -/* Return the low n bits of the bit accumulator (n < 16) */ -#define BITS(n) \ - ((unsigned)hold & ((1U << (n)) - 1)) - -/* Remove n bits from the bit accumulator */ -#define DROPBITS(n) \ - do { \ - hold >>= (n); \ - bits -= (unsigned)(n); \ - } while (0) - -/* Remove zero to seven bits as needed to go to a byte boundary */ -#define BYTEBITS() \ - do { \ - hold >>= bits & 7; \ - bits -= bits & 7; \ - } while (0) - -/* Assure that some output space is available, by writing out the window - if it's full. If the write fails, return from inflateBack() with a - Z_BUF_ERROR. */ -#define ROOM() \ - do { \ - if (left == 0) { \ - put = state->window; \ - left = state->wsize; \ - state->whave = left; \ - if (out(out_desc, put, left)) { \ - ret = Z_BUF_ERROR; \ - goto inf_leave; \ - } \ - } \ - } while (0) - -/* - strm provides the memory allocation functions and window buffer on input, - and provides information on the unused input on return. For Z_DATA_ERROR - returns, strm will also provide an error message. - - in() and out() are the call-back input and output functions. When - inflateBack() needs more input, it calls in(). When inflateBack() has - filled the window with output, or when it completes with data in the - window, it calls out() to write out the data. The application must not - change the provided input until in() is called again or inflateBack() - returns. The application must not change the window/output buffer until - inflateBack() returns. - - in() and out() are called with a descriptor parameter provided in the - inflateBack() call. This parameter can be a structure that provides the - information required to do the read or write, as well as accumulated - information on the input and output such as totals and check values. - - in() should return zero on failure. out() should return non-zero on - failure. If either in() or out() fails, than inflateBack() returns a - Z_BUF_ERROR. strm->next_in can be checked for Z_NULL to see whether it - was in() or out() that caused in the error. Otherwise, inflateBack() - returns Z_STREAM_END on success, Z_DATA_ERROR for an deflate format - error, or Z_MEM_ERROR if it could not allocate memory for the state. - inflateBack() can also return Z_STREAM_ERROR if the input parameters - are not correct, i.e. strm is Z_NULL or the state was not initialized. - */ -int ZEXPORT inflateBack(strm, in, in_desc, out, out_desc) -z_streamp strm; -in_func in; -void FAR *in_desc; -out_func out; -void FAR *out_desc; -{ - struct inflate_state FAR *state; - z_const unsigned char FAR *next; /* next input */ - unsigned char FAR *put; /* next output */ - unsigned have, left; /* available input and output */ - unsigned long hold; /* bit buffer */ - unsigned bits; /* bits in bit buffer */ - unsigned copy; /* number of stored or match bytes to copy */ - unsigned char FAR *from; /* where to copy match bytes from */ - code here; /* current decoding table entry */ - code last; /* parent table entry */ - unsigned len; /* length to copy for repeats, bits to drop */ - int ret; /* return code */ - static const unsigned short order[19] = /* permutation of code lengths */ - {16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15}; - - /* Check that the strm exists and that the state was initialized */ - if (strm == Z_NULL || strm->state == Z_NULL) - return Z_STREAM_ERROR; - state = (struct inflate_state FAR *)strm->state; - - /* Reset the state */ - strm->msg = Z_NULL; - state->mode = TYPE; - state->last = 0; - state->whave = 0; - next = strm->next_in; - have = next != Z_NULL ? strm->avail_in : 0; - hold = 0; - bits = 0; - put = state->window; - left = state->wsize; - - /* Inflate until end of block marked as last */ - for (;;) - switch (state->mode) { - case TYPE: - /* determine and dispatch block type */ - if (state->last) { - BYTEBITS(); - state->mode = DONE; - break; - } - NEEDBITS(3); - state->last = BITS(1); - DROPBITS(1); - switch (BITS(2)) { - case 0: /* stored block */ - Tracev((stderr, "inflate: stored block%s\n", - state->last ? " (last)" : "")); - state->mode = STORED; - break; - case 1: /* fixed block */ - fixedtables(state); - Tracev((stderr, "inflate: fixed codes block%s\n", - state->last ? " (last)" : "")); - state->mode = LEN; /* decode codes */ - break; - case 2: /* dynamic block */ - Tracev((stderr, "inflate: dynamic codes block%s\n", - state->last ? " (last)" : "")); - state->mode = TABLE; - break; - case 3: - strm->msg = (char *)"invalid block type"; - state->mode = BAD; - } - DROPBITS(2); - break; - - case STORED: - /* get and verify stored block length */ - BYTEBITS(); /* go to byte boundary */ - NEEDBITS(32); - if ((hold & 0xffff) != ((hold >> 16) ^ 0xffff)) { - strm->msg = (char *)"invalid stored block lengths"; - state->mode = BAD; - break; - } - state->length = (unsigned)hold & 0xffff; - Tracev((stderr, "inflate: stored length %u\n", - state->length)); - INITBITS(); - - /* copy stored block from input to output */ - while (state->length != 0) { - copy = state->length; - PULL(); - ROOM(); - if (copy > have) copy = have; - if (copy > left) copy = left; - zmemcpy(put, next, copy); - have -= copy; - next += copy; - left -= copy; - put += copy; - state->length -= copy; - } - Tracev((stderr, "inflate: stored end\n")); - state->mode = TYPE; - break; - - case TABLE: - /* get dynamic table entries descriptor */ - NEEDBITS(14); - state->nlen = BITS(5) + 257; - DROPBITS(5); - state->ndist = BITS(5) + 1; - DROPBITS(5); - state->ncode = BITS(4) + 4; - DROPBITS(4); -#ifndef PKZIP_BUG_WORKAROUND - if (state->nlen > 286 || state->ndist > 30) { - strm->msg = (char *)"too many length or distance symbols"; - state->mode = BAD; - break; - } -#endif - Tracev((stderr, "inflate: table sizes ok\n")); - - /* get code length code lengths (not a typo) */ - state->have = 0; - while (state->have < state->ncode) { - NEEDBITS(3); - state->lens[order[state->have++]] = (unsigned short)BITS(3); - DROPBITS(3); - } - while (state->have < 19) - state->lens[order[state->have++]] = 0; - state->next = state->codes; - state->lencode = (code const FAR *)(state->next); - state->lenbits = 7; - ret = inflate_table(CODES, state->lens, 19, &(state->next), - &(state->lenbits), state->work); - if (ret) { - strm->msg = (char *)"invalid code lengths set"; - state->mode = BAD; - break; - } - Tracev((stderr, "inflate: code lengths ok\n")); - - /* get length and distance code code lengths */ - state->have = 0; - while (state->have < state->nlen + state->ndist) { - for (;;) { - here = state->lencode[BITS(state->lenbits)]; - if ((unsigned)(here.bits) <= bits) break; - PULLBYTE(); - } - if (here.val < 16) { - DROPBITS(here.bits); - state->lens[state->have++] = here.val; - } - else { - if (here.val == 16) { - NEEDBITS(here.bits + 2); - DROPBITS(here.bits); - if (state->have == 0) { - strm->msg = (char *)"invalid bit length repeat"; - state->mode = BAD; - break; - } - len = (unsigned)(state->lens[state->have - 1]); - copy = 3 + BITS(2); - DROPBITS(2); - } - else if (here.val == 17) { - NEEDBITS(here.bits + 3); - DROPBITS(here.bits); - len = 0; - copy = 3 + BITS(3); - DROPBITS(3); - } - else { - NEEDBITS(here.bits + 7); - DROPBITS(here.bits); - len = 0; - copy = 11 + BITS(7); - DROPBITS(7); - } - if (state->have + copy > state->nlen + state->ndist) { - strm->msg = (char *)"invalid bit length repeat"; - state->mode = BAD; - break; - } - while (copy--) - state->lens[state->have++] = (unsigned short)len; - } - } - - /* handle error breaks in while */ - if (state->mode == BAD) break; - - /* check for end-of-block code (better have one) */ - if (state->lens[256] == 0) { - strm->msg = (char *)"invalid code -- missing end-of-block"; - state->mode = BAD; - break; - } - - /* build code tables -- note: do not change the lenbits or distbits - values here (9 and 6) without reading the comments in inftrees.h - concerning the ENOUGH constants, which depend on those values */ - state->next = state->codes; - state->lencode = (code const FAR *)(state->next); - state->lenbits = 9; - ret = inflate_table(LENS, state->lens, state->nlen, &(state->next), - &(state->lenbits), state->work); - if (ret) { - strm->msg = (char *)"invalid literal/lengths set"; - state->mode = BAD; - break; - } - state->distcode = (code const FAR *)(state->next); - state->distbits = 6; - ret = inflate_table(DISTS, state->lens + state->nlen, state->ndist, - &(state->next), &(state->distbits), state->work); - if (ret) { - strm->msg = (char *)"invalid distances set"; - state->mode = BAD; - break; - } - Tracev((stderr, "inflate: codes ok\n")); - state->mode = LEN; - - case LEN: - /* use inflate_fast() if we have enough input and output */ - if (have >= 6 && left >= 258) { - RESTORE(); - if (state->whave < state->wsize) - state->whave = state->wsize - left; - inflate_fast(strm, state->wsize); - LOAD(); - break; - } - - /* get a literal, length, or end-of-block code */ - for (;;) { - here = state->lencode[BITS(state->lenbits)]; - if ((unsigned)(here.bits) <= bits) break; - PULLBYTE(); - } - if (here.op && (here.op & 0xf0) == 0) { - last = here; - for (;;) { - here = state->lencode[last.val + - (BITS(last.bits + last.op) >> last.bits)]; - if ((unsigned)(last.bits + here.bits) <= bits) break; - PULLBYTE(); - } - DROPBITS(last.bits); - } - DROPBITS(here.bits); - state->length = (unsigned)here.val; - - /* process literal */ - if (here.op == 0) { - Tracevv((stderr, here.val >= 0x20 && here.val < 0x7f ? - "inflate: literal '%c'\n" : - "inflate: literal 0x%02x\n", here.val)); - ROOM(); - *put++ = (unsigned char)(state->length); - left--; - state->mode = LEN; - break; - } - - /* process end of block */ - if (here.op & 32) { - Tracevv((stderr, "inflate: end of block\n")); - state->mode = TYPE; - break; - } - - /* invalid code */ - if (here.op & 64) { - strm->msg = (char *)"invalid literal/length code"; - state->mode = BAD; - break; - } - - /* length code -- get extra bits, if any */ - state->extra = (unsigned)(here.op) & 15; - if (state->extra != 0) { - NEEDBITS(state->extra); - state->length += BITS(state->extra); - DROPBITS(state->extra); - } - Tracevv((stderr, "inflate: length %u\n", state->length)); - - /* get distance code */ - for (;;) { - here = state->distcode[BITS(state->distbits)]; - if ((unsigned)(here.bits) <= bits) break; - PULLBYTE(); - } - if ((here.op & 0xf0) == 0) { - last = here; - for (;;) { - here = state->distcode[last.val + - (BITS(last.bits + last.op) >> last.bits)]; - if ((unsigned)(last.bits + here.bits) <= bits) break; - PULLBYTE(); - } - DROPBITS(last.bits); - } - DROPBITS(here.bits); - if (here.op & 64) { - strm->msg = (char *)"invalid distance code"; - state->mode = BAD; - break; - } - state->offset = (unsigned)here.val; - - /* get distance extra bits, if any */ - state->extra = (unsigned)(here.op) & 15; - if (state->extra != 0) { - NEEDBITS(state->extra); - state->offset += BITS(state->extra); - DROPBITS(state->extra); - } - if (state->offset > state->wsize - (state->whave < state->wsize ? - left : 0)) { - strm->msg = (char *)"invalid distance too far back"; - state->mode = BAD; - break; - } - Tracevv((stderr, "inflate: distance %u\n", state->offset)); - - /* copy match from window to output */ - do { - ROOM(); - copy = state->wsize - state->offset; - if (copy < left) { - from = put + copy; - copy = left - copy; - } - else { - from = put - state->offset; - copy = left; - } - if (copy > state->length) copy = state->length; - state->length -= copy; - left -= copy; - do { - *put++ = *from++; - } while (--copy); - } while (state->length != 0); - break; - - case DONE: - /* inflate stream terminated properly -- write leftover output */ - ret = Z_STREAM_END; - if (left < state->wsize) { - if (out(out_desc, state->window, state->wsize - left)) - ret = Z_BUF_ERROR; - } - goto inf_leave; - - case BAD: - ret = Z_DATA_ERROR; - goto inf_leave; - - default: /* can't happen, but makes compilers happy */ - ret = Z_STREAM_ERROR; - goto inf_leave; - } - - /* Return unused input */ - inf_leave: - strm->next_in = next; - strm->avail_in = have; - return ret; -} - -int ZEXPORT inflateBackEnd(strm) -z_streamp strm; -{ - if (strm == Z_NULL || strm->state == Z_NULL || strm->zfree == (free_func)0) - return Z_STREAM_ERROR; - ZFREE(strm, strm->state); - strm->state = Z_NULL; - Tracev((stderr, "inflate: end\n")); - return Z_OK; -} DELETED compat/zlib/inffast.c Index: compat/zlib/inffast.c ================================================================== --- compat/zlib/inffast.c +++ /dev/null @@ -1,323 +0,0 @@ -/* inffast.c -- fast decoding - * Copyright (C) 1995-2017 Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -#include "zutil.h" -#include "inftrees.h" -#include "inflate.h" -#include "inffast.h" - -#ifdef ASMINF -# pragma message("Assembler code may have bugs -- use at your own risk") -#else - -/* - Decode literal, length, and distance codes and write out the resulting - literal and match bytes until either not enough input or output is - available, an end-of-block is encountered, or a data error is encountered. - When large enough input and output buffers are supplied to inflate(), for - example, a 16K input buffer and a 64K output buffer, more than 95% of the - inflate execution time is spent in this routine. - - Entry assumptions: - - state->mode == LEN - strm->avail_in >= 6 - strm->avail_out >= 258 - start >= strm->avail_out - state->bits < 8 - - On return, state->mode is one of: - - LEN -- ran out of enough output space or enough available input - TYPE -- reached end of block code, inflate() to interpret next block - BAD -- error in block data - - Notes: - - - The maximum input bits used by a length/distance pair is 15 bits for the - length code, 5 bits for the length extra, 15 bits for the distance code, - and 13 bits for the distance extra. This totals 48 bits, or six bytes. - Therefore if strm->avail_in >= 6, then there is enough input to avoid - checking for available input while decoding. - - - The maximum bytes that a single length/distance pair can output is 258 - bytes, which is the maximum length that can be coded. inflate_fast() - requires strm->avail_out >= 258 for each loop to avoid checking for - output space. - */ -void ZLIB_INTERNAL inflate_fast(strm, start) -z_streamp strm; -unsigned start; /* inflate()'s starting value for strm->avail_out */ -{ - struct inflate_state FAR *state; - z_const unsigned char FAR *in; /* local strm->next_in */ - z_const unsigned char FAR *last; /* have enough input while in < last */ - unsigned char FAR *out; /* local strm->next_out */ - unsigned char FAR *beg; /* inflate()'s initial strm->next_out */ - unsigned char FAR *end; /* while out < end, enough space available */ -#ifdef INFLATE_STRICT - unsigned dmax; /* maximum distance from zlib header */ -#endif - unsigned wsize; /* window size or zero if not using window */ - unsigned whave; /* valid bytes in the window */ - unsigned wnext; /* window write index */ - unsigned char FAR *window; /* allocated sliding window, if wsize != 0 */ - unsigned long hold; /* local strm->hold */ - unsigned bits; /* local strm->bits */ - code const FAR *lcode; /* local strm->lencode */ - code const FAR *dcode; /* local strm->distcode */ - unsigned lmask; /* mask for first level of length codes */ - unsigned dmask; /* mask for first level of distance codes */ - code here; /* retrieved table entry */ - unsigned op; /* code bits, operation, extra bits, or */ - /* window position, window bytes to copy */ - unsigned len; /* match length, unused bytes */ - unsigned dist; /* match distance */ - unsigned char FAR *from; /* where to copy match from */ - - /* copy state to local variables */ - state = (struct inflate_state FAR *)strm->state; - in = strm->next_in; - last = in + (strm->avail_in - 5); - out = strm->next_out; - beg = out - (start - strm->avail_out); - end = out + (strm->avail_out - 257); -#ifdef INFLATE_STRICT - dmax = state->dmax; -#endif - wsize = state->wsize; - whave = state->whave; - wnext = state->wnext; - window = state->window; - hold = state->hold; - bits = state->bits; - lcode = state->lencode; - dcode = state->distcode; - lmask = (1U << state->lenbits) - 1; - dmask = (1U << state->distbits) - 1; - - /* decode literals and length/distances until end-of-block or not enough - input data or output space */ - do { - if (bits < 15) { - hold += (unsigned long)(*in++) << bits; - bits += 8; - hold += (unsigned long)(*in++) << bits; - bits += 8; - } - here = lcode[hold & lmask]; - dolen: - op = (unsigned)(here.bits); - hold >>= op; - bits -= op; - op = (unsigned)(here.op); - if (op == 0) { /* literal */ - Tracevv((stderr, here.val >= 0x20 && here.val < 0x7f ? - "inflate: literal '%c'\n" : - "inflate: literal 0x%02x\n", here.val)); - *out++ = (unsigned char)(here.val); - } - else if (op & 16) { /* length base */ - len = (unsigned)(here.val); - op &= 15; /* number of extra bits */ - if (op) { - if (bits < op) { - hold += (unsigned long)(*in++) << bits; - bits += 8; - } - len += (unsigned)hold & ((1U << op) - 1); - hold >>= op; - bits -= op; - } - Tracevv((stderr, "inflate: length %u\n", len)); - if (bits < 15) { - hold += (unsigned long)(*in++) << bits; - bits += 8; - hold += (unsigned long)(*in++) << bits; - bits += 8; - } - here = dcode[hold & dmask]; - dodist: - op = (unsigned)(here.bits); - hold >>= op; - bits -= op; - op = (unsigned)(here.op); - if (op & 16) { /* distance base */ - dist = (unsigned)(here.val); - op &= 15; /* number of extra bits */ - if (bits < op) { - hold += (unsigned long)(*in++) << bits; - bits += 8; - if (bits < op) { - hold += (unsigned long)(*in++) << bits; - bits += 8; - } - } - dist += (unsigned)hold & ((1U << op) - 1); -#ifdef INFLATE_STRICT - if (dist > dmax) { - strm->msg = (char *)"invalid distance too far back"; - state->mode = BAD; - break; - } -#endif - hold >>= op; - bits -= op; - Tracevv((stderr, "inflate: distance %u\n", dist)); - op = (unsigned)(out - beg); /* max distance in output */ - if (dist > op) { /* see if copy from window */ - op = dist - op; /* distance back in window */ - if (op > whave) { - if (state->sane) { - strm->msg = - (char *)"invalid distance too far back"; - state->mode = BAD; - break; - } -#ifdef INFLATE_ALLOW_INVALID_DISTANCE_TOOFAR_ARRR - if (len <= op - whave) { - do { - *out++ = 0; - } while (--len); - continue; - } - len -= op - whave; - do { - *out++ = 0; - } while (--op > whave); - if (op == 0) { - from = out - dist; - do { - *out++ = *from++; - } while (--len); - continue; - } -#endif - } - from = window; - if (wnext == 0) { /* very common case */ - from += wsize - op; - if (op < len) { /* some from window */ - len -= op; - do { - *out++ = *from++; - } while (--op); - from = out - dist; /* rest from output */ - } - } - else if (wnext < op) { /* wrap around window */ - from += wsize + wnext - op; - op -= wnext; - if (op < len) { /* some from end of window */ - len -= op; - do { - *out++ = *from++; - } while (--op); - from = window; - if (wnext < len) { /* some from start of window */ - op = wnext; - len -= op; - do { - *out++ = *from++; - } while (--op); - from = out - dist; /* rest from output */ - } - } - } - else { /* contiguous in window */ - from += wnext - op; - if (op < len) { /* some from window */ - len -= op; - do { - *out++ = *from++; - } while (--op); - from = out - dist; /* rest from output */ - } - } - while (len > 2) { - *out++ = *from++; - *out++ = *from++; - *out++ = *from++; - len -= 3; - } - if (len) { - *out++ = *from++; - if (len > 1) - *out++ = *from++; - } - } - else { - from = out - dist; /* copy direct from output */ - do { /* minimum length is three */ - *out++ = *from++; - *out++ = *from++; - *out++ = *from++; - len -= 3; - } while (len > 2); - if (len) { - *out++ = *from++; - if (len > 1) - *out++ = *from++; - } - } - } - else if ((op & 64) == 0) { /* 2nd level distance code */ - here = dcode[here.val + (hold & ((1U << op) - 1))]; - goto dodist; - } - else { - strm->msg = (char *)"invalid distance code"; - state->mode = BAD; - break; - } - } - else if ((op & 64) == 0) { /* 2nd level length code */ - here = lcode[here.val + (hold & ((1U << op) - 1))]; - goto dolen; - } - else if (op & 32) { /* end-of-block */ - Tracevv((stderr, "inflate: end of block\n")); - state->mode = TYPE; - break; - } - else { - strm->msg = (char *)"invalid literal/length code"; - state->mode = BAD; - break; - } - } while (in < last && out < end); - - /* return unused bytes (on entry, bits < 8, so in won't go too far back) */ - len = bits >> 3; - in -= len; - bits -= len << 3; - hold &= (1U << bits) - 1; - - /* update state and return */ - strm->next_in = in; - strm->next_out = out; - strm->avail_in = (unsigned)(in < last ? 5 + (last - in) : 5 - (in - last)); - strm->avail_out = (unsigned)(out < end ? - 257 + (end - out) : 257 - (out - end)); - state->hold = hold; - state->bits = bits; - return; -} - -/* - inflate_fast() speedups that turned out slower (on a PowerPC G3 750CXe): - - Using bit fields for code structure - - Different op definition to avoid & for extra bits (do & for table bits) - - Three separate decoding do-loops for direct, window, and wnext == 0 - - Special case for distance > 1 copies to do overlapped load and store copy - - Explicit branch predictions (based on measured branch probabilities) - - Deferring match copy and interspersed it with decoding subsequent codes - - Swapping literal/length else - - Swapping window/direct else - - Larger unrolled copy loops (three is about right) - - Moving len -= 3 statement into middle of loop - */ - -#endif /* !ASMINF */ DELETED compat/zlib/inffast.h Index: compat/zlib/inffast.h ================================================================== --- compat/zlib/inffast.h +++ /dev/null @@ -1,11 +0,0 @@ -/* inffast.h -- header to use inffast.c - * Copyright (C) 1995-2003, 2010 Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -/* WARNING: this file should *not* be used by applications. It is - part of the implementation of the compression library and is - subject to change. Applications should only use zlib.h. - */ - -void ZLIB_INTERNAL inflate_fast OF((z_streamp strm, unsigned start)); DELETED compat/zlib/inffixed.h Index: compat/zlib/inffixed.h ================================================================== --- compat/zlib/inffixed.h +++ /dev/null @@ -1,94 +0,0 @@ - /* inffixed.h -- table for decoding fixed codes - * Generated automatically by makefixed(). - */ - - /* WARNING: this file should *not* be used by applications. - It is part of the implementation of this library and is - subject to change. Applications should only use zlib.h. - */ - - static const code lenfix[512] = { - {96,7,0},{0,8,80},{0,8,16},{20,8,115},{18,7,31},{0,8,112},{0,8,48}, - {0,9,192},{16,7,10},{0,8,96},{0,8,32},{0,9,160},{0,8,0},{0,8,128}, - {0,8,64},{0,9,224},{16,7,6},{0,8,88},{0,8,24},{0,9,144},{19,7,59}, - {0,8,120},{0,8,56},{0,9,208},{17,7,17},{0,8,104},{0,8,40},{0,9,176}, - {0,8,8},{0,8,136},{0,8,72},{0,9,240},{16,7,4},{0,8,84},{0,8,20}, - {21,8,227},{19,7,43},{0,8,116},{0,8,52},{0,9,200},{17,7,13},{0,8,100}, - {0,8,36},{0,9,168},{0,8,4},{0,8,132},{0,8,68},{0,9,232},{16,7,8}, - {0,8,92},{0,8,28},{0,9,152},{20,7,83},{0,8,124},{0,8,60},{0,9,216}, - {18,7,23},{0,8,108},{0,8,44},{0,9,184},{0,8,12},{0,8,140},{0,8,76}, - {0,9,248},{16,7,3},{0,8,82},{0,8,18},{21,8,163},{19,7,35},{0,8,114}, - {0,8,50},{0,9,196},{17,7,11},{0,8,98},{0,8,34},{0,9,164},{0,8,2}, - {0,8,130},{0,8,66},{0,9,228},{16,7,7},{0,8,90},{0,8,26},{0,9,148}, - {20,7,67},{0,8,122},{0,8,58},{0,9,212},{18,7,19},{0,8,106},{0,8,42}, - {0,9,180},{0,8,10},{0,8,138},{0,8,74},{0,9,244},{16,7,5},{0,8,86}, - {0,8,22},{64,8,0},{19,7,51},{0,8,118},{0,8,54},{0,9,204},{17,7,15}, - {0,8,102},{0,8,38},{0,9,172},{0,8,6},{0,8,134},{0,8,70},{0,9,236}, - {16,7,9},{0,8,94},{0,8,30},{0,9,156},{20,7,99},{0,8,126},{0,8,62}, - {0,9,220},{18,7,27},{0,8,110},{0,8,46},{0,9,188},{0,8,14},{0,8,142}, - {0,8,78},{0,9,252},{96,7,0},{0,8,81},{0,8,17},{21,8,131},{18,7,31}, - {0,8,113},{0,8,49},{0,9,194},{16,7,10},{0,8,97},{0,8,33},{0,9,162}, - {0,8,1},{0,8,129},{0,8,65},{0,9,226},{16,7,6},{0,8,89},{0,8,25}, - {0,9,146},{19,7,59},{0,8,121},{0,8,57},{0,9,210},{17,7,17},{0,8,105}, - {0,8,41},{0,9,178},{0,8,9},{0,8,137},{0,8,73},{0,9,242},{16,7,4}, - {0,8,85},{0,8,21},{16,8,258},{19,7,43},{0,8,117},{0,8,53},{0,9,202}, - {17,7,13},{0,8,101},{0,8,37},{0,9,170},{0,8,5},{0,8,133},{0,8,69}, - {0,9,234},{16,7,8},{0,8,93},{0,8,29},{0,9,154},{20,7,83},{0,8,125}, - {0,8,61},{0,9,218},{18,7,23},{0,8,109},{0,8,45},{0,9,186},{0,8,13}, - {0,8,141},{0,8,77},{0,9,250},{16,7,3},{0,8,83},{0,8,19},{21,8,195}, - {19,7,35},{0,8,115},{0,8,51},{0,9,198},{17,7,11},{0,8,99},{0,8,35}, - {0,9,166},{0,8,3},{0,8,131},{0,8,67},{0,9,230},{16,7,7},{0,8,91}, - {0,8,27},{0,9,150},{20,7,67},{0,8,123},{0,8,59},{0,9,214},{18,7,19}, - {0,8,107},{0,8,43},{0,9,182},{0,8,11},{0,8,139},{0,8,75},{0,9,246}, - {16,7,5},{0,8,87},{0,8,23},{64,8,0},{19,7,51},{0,8,119},{0,8,55}, - {0,9,206},{17,7,15},{0,8,103},{0,8,39},{0,9,174},{0,8,7},{0,8,135}, - {0,8,71},{0,9,238},{16,7,9},{0,8,95},{0,8,31},{0,9,158},{20,7,99}, - {0,8,127},{0,8,63},{0,9,222},{18,7,27},{0,8,111},{0,8,47},{0,9,190}, - {0,8,15},{0,8,143},{0,8,79},{0,9,254},{96,7,0},{0,8,80},{0,8,16}, - {20,8,115},{18,7,31},{0,8,112},{0,8,48},{0,9,193},{16,7,10},{0,8,96}, - {0,8,32},{0,9,161},{0,8,0},{0,8,128},{0,8,64},{0,9,225},{16,7,6}, - {0,8,88},{0,8,24},{0,9,145},{19,7,59},{0,8,120},{0,8,56},{0,9,209}, - {17,7,17},{0,8,104},{0,8,40},{0,9,177},{0,8,8},{0,8,136},{0,8,72}, - {0,9,241},{16,7,4},{0,8,84},{0,8,20},{21,8,227},{19,7,43},{0,8,116}, - {0,8,52},{0,9,201},{17,7,13},{0,8,100},{0,8,36},{0,9,169},{0,8,4}, - {0,8,132},{0,8,68},{0,9,233},{16,7,8},{0,8,92},{0,8,28},{0,9,153}, - {20,7,83},{0,8,124},{0,8,60},{0,9,217},{18,7,23},{0,8,108},{0,8,44}, - {0,9,185},{0,8,12},{0,8,140},{0,8,76},{0,9,249},{16,7,3},{0,8,82}, - {0,8,18},{21,8,163},{19,7,35},{0,8,114},{0,8,50},{0,9,197},{17,7,11}, - {0,8,98},{0,8,34},{0,9,165},{0,8,2},{0,8,130},{0,8,66},{0,9,229}, - {16,7,7},{0,8,90},{0,8,26},{0,9,149},{20,7,67},{0,8,122},{0,8,58}, - {0,9,213},{18,7,19},{0,8,106},{0,8,42},{0,9,181},{0,8,10},{0,8,138}, - {0,8,74},{0,9,245},{16,7,5},{0,8,86},{0,8,22},{64,8,0},{19,7,51}, - {0,8,118},{0,8,54},{0,9,205},{17,7,15},{0,8,102},{0,8,38},{0,9,173}, - {0,8,6},{0,8,134},{0,8,70},{0,9,237},{16,7,9},{0,8,94},{0,8,30}, - {0,9,157},{20,7,99},{0,8,126},{0,8,62},{0,9,221},{18,7,27},{0,8,110}, - {0,8,46},{0,9,189},{0,8,14},{0,8,142},{0,8,78},{0,9,253},{96,7,0}, - {0,8,81},{0,8,17},{21,8,131},{18,7,31},{0,8,113},{0,8,49},{0,9,195}, - {16,7,10},{0,8,97},{0,8,33},{0,9,163},{0,8,1},{0,8,129},{0,8,65}, - {0,9,227},{16,7,6},{0,8,89},{0,8,25},{0,9,147},{19,7,59},{0,8,121}, - {0,8,57},{0,9,211},{17,7,17},{0,8,105},{0,8,41},{0,9,179},{0,8,9}, - {0,8,137},{0,8,73},{0,9,243},{16,7,4},{0,8,85},{0,8,21},{16,8,258}, - {19,7,43},{0,8,117},{0,8,53},{0,9,203},{17,7,13},{0,8,101},{0,8,37}, - {0,9,171},{0,8,5},{0,8,133},{0,8,69},{0,9,235},{16,7,8},{0,8,93}, - {0,8,29},{0,9,155},{20,7,83},{0,8,125},{0,8,61},{0,9,219},{18,7,23}, - {0,8,109},{0,8,45},{0,9,187},{0,8,13},{0,8,141},{0,8,77},{0,9,251}, - {16,7,3},{0,8,83},{0,8,19},{21,8,195},{19,7,35},{0,8,115},{0,8,51}, - {0,9,199},{17,7,11},{0,8,99},{0,8,35},{0,9,167},{0,8,3},{0,8,131}, - {0,8,67},{0,9,231},{16,7,7},{0,8,91},{0,8,27},{0,9,151},{20,7,67}, - {0,8,123},{0,8,59},{0,9,215},{18,7,19},{0,8,107},{0,8,43},{0,9,183}, - {0,8,11},{0,8,139},{0,8,75},{0,9,247},{16,7,5},{0,8,87},{0,8,23}, - {64,8,0},{19,7,51},{0,8,119},{0,8,55},{0,9,207},{17,7,15},{0,8,103}, - {0,8,39},{0,9,175},{0,8,7},{0,8,135},{0,8,71},{0,9,239},{16,7,9}, - {0,8,95},{0,8,31},{0,9,159},{20,7,99},{0,8,127},{0,8,63},{0,9,223}, - {18,7,27},{0,8,111},{0,8,47},{0,9,191},{0,8,15},{0,8,143},{0,8,79}, - {0,9,255} - }; - - static const code distfix[32] = { - {16,5,1},{23,5,257},{19,5,17},{27,5,4097},{17,5,5},{25,5,1025}, - {21,5,65},{29,5,16385},{16,5,3},{24,5,513},{20,5,33},{28,5,8193}, - {18,5,9},{26,5,2049},{22,5,129},{64,5,0},{16,5,2},{23,5,385}, - {19,5,25},{27,5,6145},{17,5,7},{25,5,1537},{21,5,97},{29,5,24577}, - {16,5,4},{24,5,769},{20,5,49},{28,5,12289},{18,5,13},{26,5,3073}, - {22,5,193},{64,5,0} - }; DELETED compat/zlib/inflate.c Index: compat/zlib/inflate.c ================================================================== --- compat/zlib/inflate.c +++ /dev/null @@ -1,1561 +0,0 @@ -/* inflate.c -- zlib decompression - * Copyright (C) 1995-2016 Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -/* - * Change history: - * - * 1.2.beta0 24 Nov 2002 - * - First version -- complete rewrite of inflate to simplify code, avoid - * creation of window when not needed, minimize use of window when it is - * needed, make inffast.c even faster, implement gzip decoding, and to - * improve code readability and style over the previous zlib inflate code - * - * 1.2.beta1 25 Nov 2002 - * - Use pointers for available input and output checking in inffast.c - * - Remove input and output counters in inffast.c - * - Change inffast.c entry and loop from avail_in >= 7 to >= 6 - * - Remove unnecessary second byte pull from length extra in inffast.c - * - Unroll direct copy to three copies per loop in inffast.c - * - * 1.2.beta2 4 Dec 2002 - * - Change external routine names to reduce potential conflicts - * - Correct filename to inffixed.h for fixed tables in inflate.c - * - Make hbuf[] unsigned char to match parameter type in inflate.c - * - Change strm->next_out[-state->offset] to *(strm->next_out - state->offset) - * to avoid negation problem on Alphas (64 bit) in inflate.c - * - * 1.2.beta3 22 Dec 2002 - * - Add comments on state->bits assertion in inffast.c - * - Add comments on op field in inftrees.h - * - Fix bug in reuse of allocated window after inflateReset() - * - Remove bit fields--back to byte structure for speed - * - Remove distance extra == 0 check in inflate_fast()--only helps for lengths - * - Change post-increments to pre-increments in inflate_fast(), PPC biased? - * - Add compile time option, POSTINC, to use post-increments instead (Intel?) - * - Make MATCH copy in inflate() much faster for when inflate_fast() not used - * - Use local copies of stream next and avail values, as well as local bit - * buffer and bit count in inflate()--for speed when inflate_fast() not used - * - * 1.2.beta4 1 Jan 2003 - * - Split ptr - 257 statements in inflate_table() to avoid compiler warnings - * - Move a comment on output buffer sizes from inffast.c to inflate.c - * - Add comments in inffast.c to introduce the inflate_fast() routine - * - Rearrange window copies in inflate_fast() for speed and simplification - * - Unroll last copy for window match in inflate_fast() - * - Use local copies of window variables in inflate_fast() for speed - * - Pull out common wnext == 0 case for speed in inflate_fast() - * - Make op and len in inflate_fast() unsigned for consistency - * - Add FAR to lcode and dcode declarations in inflate_fast() - * - Simplified bad distance check in inflate_fast() - * - Added inflateBackInit(), inflateBack(), and inflateBackEnd() in new - * source file infback.c to provide a call-back interface to inflate for - * programs like gzip and unzip -- uses window as output buffer to avoid - * window copying - * - * 1.2.beta5 1 Jan 2003 - * - Improved inflateBack() interface to allow the caller to provide initial - * input in strm. - * - Fixed stored blocks bug in inflateBack() - * - * 1.2.beta6 4 Jan 2003 - * - Added comments in inffast.c on effectiveness of POSTINC - * - Typecasting all around to reduce compiler warnings - * - Changed loops from while (1) or do {} while (1) to for (;;), again to - * make compilers happy - * - Changed type of window in inflateBackInit() to unsigned char * - * - * 1.2.beta7 27 Jan 2003 - * - Changed many types to unsigned or unsigned short to avoid warnings - * - Added inflateCopy() function - * - * 1.2.0 9 Mar 2003 - * - Changed inflateBack() interface to provide separate opaque descriptors - * for the in() and out() functions - * - Changed inflateBack() argument and in_func typedef to swap the length - * and buffer address return values for the input function - * - Check next_in and next_out for Z_NULL on entry to inflate() - * - * The history for versions after 1.2.0 are in ChangeLog in zlib distribution. - */ - -#include "zutil.h" -#include "inftrees.h" -#include "inflate.h" -#include "inffast.h" - -#ifdef MAKEFIXED -# ifndef BUILDFIXED -# define BUILDFIXED -# endif -#endif - -/* function prototypes */ -local int inflateStateCheck OF((z_streamp strm)); -local void fixedtables OF((struct inflate_state FAR *state)); -local int updatewindow OF((z_streamp strm, const unsigned char FAR *end, - unsigned copy)); -#ifdef BUILDFIXED - void makefixed OF((void)); -#endif -local unsigned syncsearch OF((unsigned FAR *have, const unsigned char FAR *buf, - unsigned len)); - -local int inflateStateCheck(strm) -z_streamp strm; -{ - struct inflate_state FAR *state; - if (strm == Z_NULL || - strm->zalloc == (alloc_func)0 || strm->zfree == (free_func)0) - return 1; - state = (struct inflate_state FAR *)strm->state; - if (state == Z_NULL || state->strm != strm || - state->mode < HEAD || state->mode > SYNC) - return 1; - return 0; -} - -int ZEXPORT inflateResetKeep(strm) -z_streamp strm; -{ - struct inflate_state FAR *state; - - if (inflateStateCheck(strm)) return Z_STREAM_ERROR; - state = (struct inflate_state FAR *)strm->state; - strm->total_in = strm->total_out = state->total = 0; - strm->msg = Z_NULL; - if (state->wrap) /* to support ill-conceived Java test suite */ - strm->adler = state->wrap & 1; - state->mode = HEAD; - state->last = 0; - state->havedict = 0; - state->dmax = 32768U; - state->head = Z_NULL; - state->hold = 0; - state->bits = 0; - state->lencode = state->distcode = state->next = state->codes; - state->sane = 1; - state->back = -1; - Tracev((stderr, "inflate: reset\n")); - return Z_OK; -} - -int ZEXPORT inflateReset(strm) -z_streamp strm; -{ - struct inflate_state FAR *state; - - if (inflateStateCheck(strm)) return Z_STREAM_ERROR; - state = (struct inflate_state FAR *)strm->state; - state->wsize = 0; - state->whave = 0; - state->wnext = 0; - return inflateResetKeep(strm); -} - -int ZEXPORT inflateReset2(strm, windowBits) -z_streamp strm; -int windowBits; -{ - int wrap; - struct inflate_state FAR *state; - - /* get the state */ - if (inflateStateCheck(strm)) return Z_STREAM_ERROR; - state = (struct inflate_state FAR *)strm->state; - - /* extract wrap request from windowBits parameter */ - if (windowBits < 0) { - wrap = 0; - windowBits = -windowBits; - } - else { - wrap = (windowBits >> 4) + 5; -#ifdef GUNZIP - if (windowBits < 48) - windowBits &= 15; -#endif - } - - /* set number of window bits, free window if different */ - if (windowBits && (windowBits < 8 || windowBits > 15)) - return Z_STREAM_ERROR; - if (state->window != Z_NULL && state->wbits != (unsigned)windowBits) { - ZFREE(strm, state->window); - state->window = Z_NULL; - } - - /* update state and reset the rest of it */ - state->wrap = wrap; - state->wbits = (unsigned)windowBits; - return inflateReset(strm); -} - -int ZEXPORT inflateInit2_(strm, windowBits, version, stream_size) -z_streamp strm; -int windowBits; -const char *version; -int stream_size; -{ - int ret; - struct inflate_state FAR *state; - - if (version == Z_NULL || version[0] != ZLIB_VERSION[0] || - stream_size != (int)(sizeof(z_stream))) - return Z_VERSION_ERROR; - if (strm == Z_NULL) return Z_STREAM_ERROR; - strm->msg = Z_NULL; /* in case we return an error */ - if (strm->zalloc == (alloc_func)0) { -#ifdef Z_SOLO - return Z_STREAM_ERROR; -#else - strm->zalloc = zcalloc; - strm->opaque = (voidpf)0; -#endif - } - if (strm->zfree == (free_func)0) -#ifdef Z_SOLO - return Z_STREAM_ERROR; -#else - strm->zfree = zcfree; -#endif - state = (struct inflate_state FAR *) - ZALLOC(strm, 1, sizeof(struct inflate_state)); - if (state == Z_NULL) return Z_MEM_ERROR; - Tracev((stderr, "inflate: allocated\n")); - strm->state = (struct internal_state FAR *)state; - state->strm = strm; - state->window = Z_NULL; - state->mode = HEAD; /* to pass state test in inflateReset2() */ - ret = inflateReset2(strm, windowBits); - if (ret != Z_OK) { - ZFREE(strm, state); - strm->state = Z_NULL; - } - return ret; -} - -int ZEXPORT inflateInit_(strm, version, stream_size) -z_streamp strm; -const char *version; -int stream_size; -{ - return inflateInit2_(strm, DEF_WBITS, version, stream_size); -} - -int ZEXPORT inflatePrime(strm, bits, value) -z_streamp strm; -int bits; -int value; -{ - struct inflate_state FAR *state; - - if (inflateStateCheck(strm)) return Z_STREAM_ERROR; - state = (struct inflate_state FAR *)strm->state; - if (bits < 0) { - state->hold = 0; - state->bits = 0; - return Z_OK; - } - if (bits > 16 || state->bits + (uInt)bits > 32) return Z_STREAM_ERROR; - value &= (1L << bits) - 1; - state->hold += (unsigned)value << state->bits; - state->bits += (uInt)bits; - return Z_OK; -} - -/* - Return state with length and distance decoding tables and index sizes set to - fixed code decoding. Normally this returns fixed tables from inffixed.h. - If BUILDFIXED is defined, then instead this routine builds the tables the - first time it's called, and returns those tables the first time and - thereafter. This reduces the size of the code by about 2K bytes, in - exchange for a little execution time. However, BUILDFIXED should not be - used for threaded applications, since the rewriting of the tables and virgin - may not be thread-safe. - */ -local void fixedtables(state) -struct inflate_state FAR *state; -{ -#ifdef BUILDFIXED - static int virgin = 1; - static code *lenfix, *distfix; - static code fixed[544]; - - /* build fixed huffman tables if first call (may not be thread safe) */ - if (virgin) { - unsigned sym, bits; - static code *next; - - /* literal/length table */ - sym = 0; - while (sym < 144) state->lens[sym++] = 8; - while (sym < 256) state->lens[sym++] = 9; - while (sym < 280) state->lens[sym++] = 7; - while (sym < 288) state->lens[sym++] = 8; - next = fixed; - lenfix = next; - bits = 9; - inflate_table(LENS, state->lens, 288, &(next), &(bits), state->work); - - /* distance table */ - sym = 0; - while (sym < 32) state->lens[sym++] = 5; - distfix = next; - bits = 5; - inflate_table(DISTS, state->lens, 32, &(next), &(bits), state->work); - - /* do this just once */ - virgin = 0; - } -#else /* !BUILDFIXED */ -# include "inffixed.h" -#endif /* BUILDFIXED */ - state->lencode = lenfix; - state->lenbits = 9; - state->distcode = distfix; - state->distbits = 5; -} - -#ifdef MAKEFIXED -#include - -/* - Write out the inffixed.h that is #include'd above. Defining MAKEFIXED also - defines BUILDFIXED, so the tables are built on the fly. makefixed() writes - those tables to stdout, which would be piped to inffixed.h. A small program - can simply call makefixed to do this: - - void makefixed(void); - - int main(void) - { - makefixed(); - return 0; - } - - Then that can be linked with zlib built with MAKEFIXED defined and run: - - a.out > inffixed.h - */ -void makefixed() -{ - unsigned low, size; - struct inflate_state state; - - fixedtables(&state); - puts(" /* inffixed.h -- table for decoding fixed codes"); - puts(" * Generated automatically by makefixed()."); - puts(" */"); - puts(""); - puts(" /* WARNING: this file should *not* be used by applications."); - puts(" It is part of the implementation of this library and is"); - puts(" subject to change. Applications should only use zlib.h."); - puts(" */"); - puts(""); - size = 1U << 9; - printf(" static const code lenfix[%u] = {", size); - low = 0; - for (;;) { - if ((low % 7) == 0) printf("\n "); - printf("{%u,%u,%d}", (low & 127) == 99 ? 64 : state.lencode[low].op, - state.lencode[low].bits, state.lencode[low].val); - if (++low == size) break; - putchar(','); - } - puts("\n };"); - size = 1U << 5; - printf("\n static const code distfix[%u] = {", size); - low = 0; - for (;;) { - if ((low % 6) == 0) printf("\n "); - printf("{%u,%u,%d}", state.distcode[low].op, state.distcode[low].bits, - state.distcode[low].val); - if (++low == size) break; - putchar(','); - } - puts("\n };"); -} -#endif /* MAKEFIXED */ - -/* - Update the window with the last wsize (normally 32K) bytes written before - returning. If window does not exist yet, create it. This is only called - when a window is already in use, or when output has been written during this - inflate call, but the end of the deflate stream has not been reached yet. - It is also called to create a window for dictionary data when a dictionary - is loaded. - - Providing output buffers larger than 32K to inflate() should provide a speed - advantage, since only the last 32K of output is copied to the sliding window - upon return from inflate(), and since all distances after the first 32K of - output will fall in the output data, making match copies simpler and faster. - The advantage may be dependent on the size of the processor's data caches. - */ -local int updatewindow(strm, end, copy) -z_streamp strm; -const Bytef *end; -unsigned copy; -{ - struct inflate_state FAR *state; - unsigned dist; - - state = (struct inflate_state FAR *)strm->state; - - /* if it hasn't been done already, allocate space for the window */ - if (state->window == Z_NULL) { - state->window = (unsigned char FAR *) - ZALLOC(strm, 1U << state->wbits, - sizeof(unsigned char)); - if (state->window == Z_NULL) return 1; - } - - /* if window not in use yet, initialize */ - if (state->wsize == 0) { - state->wsize = 1U << state->wbits; - state->wnext = 0; - state->whave = 0; - } - - /* copy state->wsize or less output bytes into the circular window */ - if (copy >= state->wsize) { - zmemcpy(state->window, end - state->wsize, state->wsize); - state->wnext = 0; - state->whave = state->wsize; - } - else { - dist = state->wsize - state->wnext; - if (dist > copy) dist = copy; - zmemcpy(state->window + state->wnext, end - copy, dist); - copy -= dist; - if (copy) { - zmemcpy(state->window, end - copy, copy); - state->wnext = copy; - state->whave = state->wsize; - } - else { - state->wnext += dist; - if (state->wnext == state->wsize) state->wnext = 0; - if (state->whave < state->wsize) state->whave += dist; - } - } - return 0; -} - -/* Macros for inflate(): */ - -/* check function to use adler32() for zlib or crc32() for gzip */ -#ifdef GUNZIP -# define UPDATE(check, buf, len) \ - (state->flags ? crc32(check, buf, len) : adler32(check, buf, len)) -#else -# define UPDATE(check, buf, len) adler32(check, buf, len) -#endif - -/* check macros for header crc */ -#ifdef GUNZIP -# define CRC2(check, word) \ - do { \ - hbuf[0] = (unsigned char)(word); \ - hbuf[1] = (unsigned char)((word) >> 8); \ - check = crc32(check, hbuf, 2); \ - } while (0) - -# define CRC4(check, word) \ - do { \ - hbuf[0] = (unsigned char)(word); \ - hbuf[1] = (unsigned char)((word) >> 8); \ - hbuf[2] = (unsigned char)((word) >> 16); \ - hbuf[3] = (unsigned char)((word) >> 24); \ - check = crc32(check, hbuf, 4); \ - } while (0) -#endif - -/* Load registers with state in inflate() for speed */ -#define LOAD() \ - do { \ - put = strm->next_out; \ - left = strm->avail_out; \ - next = strm->next_in; \ - have = strm->avail_in; \ - hold = state->hold; \ - bits = state->bits; \ - } while (0) - -/* Restore state from registers in inflate() */ -#define RESTORE() \ - do { \ - strm->next_out = put; \ - strm->avail_out = left; \ - strm->next_in = next; \ - strm->avail_in = have; \ - state->hold = hold; \ - state->bits = bits; \ - } while (0) - -/* Clear the input bit accumulator */ -#define INITBITS() \ - do { \ - hold = 0; \ - bits = 0; \ - } while (0) - -/* Get a byte of input into the bit accumulator, or return from inflate() - if there is no input available. */ -#define PULLBYTE() \ - do { \ - if (have == 0) goto inf_leave; \ - have--; \ - hold += (unsigned long)(*next++) << bits; \ - bits += 8; \ - } while (0) - -/* Assure that there are at least n bits in the bit accumulator. If there is - not enough available input to do that, then return from inflate(). */ -#define NEEDBITS(n) \ - do { \ - while (bits < (unsigned)(n)) \ - PULLBYTE(); \ - } while (0) - -/* Return the low n bits of the bit accumulator (n < 16) */ -#define BITS(n) \ - ((unsigned)hold & ((1U << (n)) - 1)) - -/* Remove n bits from the bit accumulator */ -#define DROPBITS(n) \ - do { \ - hold >>= (n); \ - bits -= (unsigned)(n); \ - } while (0) - -/* Remove zero to seven bits as needed to go to a byte boundary */ -#define BYTEBITS() \ - do { \ - hold >>= bits & 7; \ - bits -= bits & 7; \ - } while (0) - -/* - inflate() uses a state machine to process as much input data and generate as - much output data as possible before returning. The state machine is - structured roughly as follows: - - for (;;) switch (state) { - ... - case STATEn: - if (not enough input data or output space to make progress) - return; - ... make progress ... - state = STATEm; - break; - ... - } - - so when inflate() is called again, the same case is attempted again, and - if the appropriate resources are provided, the machine proceeds to the - next state. The NEEDBITS() macro is usually the way the state evaluates - whether it can proceed or should return. NEEDBITS() does the return if - the requested bits are not available. The typical use of the BITS macros - is: - - NEEDBITS(n); - ... do something with BITS(n) ... - DROPBITS(n); - - where NEEDBITS(n) either returns from inflate() if there isn't enough - input left to load n bits into the accumulator, or it continues. BITS(n) - gives the low n bits in the accumulator. When done, DROPBITS(n) drops - the low n bits off the accumulator. INITBITS() clears the accumulator - and sets the number of available bits to zero. BYTEBITS() discards just - enough bits to put the accumulator on a byte boundary. After BYTEBITS() - and a NEEDBITS(8), then BITS(8) would return the next byte in the stream. - - NEEDBITS(n) uses PULLBYTE() to get an available byte of input, or to return - if there is no input available. The decoding of variable length codes uses - PULLBYTE() directly in order to pull just enough bytes to decode the next - code, and no more. - - Some states loop until they get enough input, making sure that enough - state information is maintained to continue the loop where it left off - if NEEDBITS() returns in the loop. For example, want, need, and keep - would all have to actually be part of the saved state in case NEEDBITS() - returns: - - case STATEw: - while (want < need) { - NEEDBITS(n); - keep[want++] = BITS(n); - DROPBITS(n); - } - state = STATEx; - case STATEx: - - As shown above, if the next state is also the next case, then the break - is omitted. - - A state may also return if there is not enough output space available to - complete that state. Those states are copying stored data, writing a - literal byte, and copying a matching string. - - When returning, a "goto inf_leave" is used to update the total counters, - update the check value, and determine whether any progress has been made - during that inflate() call in order to return the proper return code. - Progress is defined as a change in either strm->avail_in or strm->avail_out. - When there is a window, goto inf_leave will update the window with the last - output written. If a goto inf_leave occurs in the middle of decompression - and there is no window currently, goto inf_leave will create one and copy - output to the window for the next call of inflate(). - - In this implementation, the flush parameter of inflate() only affects the - return code (per zlib.h). inflate() always writes as much as possible to - strm->next_out, given the space available and the provided input--the effect - documented in zlib.h of Z_SYNC_FLUSH. Furthermore, inflate() always defers - the allocation of and copying into a sliding window until necessary, which - provides the effect documented in zlib.h for Z_FINISH when the entire input - stream available. So the only thing the flush parameter actually does is: - when flush is set to Z_FINISH, inflate() cannot return Z_OK. Instead it - will return Z_BUF_ERROR if it has not reached the end of the stream. - */ - -int ZEXPORT inflate(strm, flush) -z_streamp strm; -int flush; -{ - struct inflate_state FAR *state; - z_const unsigned char FAR *next; /* next input */ - unsigned char FAR *put; /* next output */ - unsigned have, left; /* available input and output */ - unsigned long hold; /* bit buffer */ - unsigned bits; /* bits in bit buffer */ - unsigned in, out; /* save starting available input and output */ - unsigned copy; /* number of stored or match bytes to copy */ - unsigned char FAR *from; /* where to copy match bytes from */ - code here; /* current decoding table entry */ - code last; /* parent table entry */ - unsigned len; /* length to copy for repeats, bits to drop */ - int ret; /* return code */ -#ifdef GUNZIP - unsigned char hbuf[4]; /* buffer for gzip header crc calculation */ -#endif - static const unsigned short order[19] = /* permutation of code lengths */ - {16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15}; - - if (inflateStateCheck(strm) || strm->next_out == Z_NULL || - (strm->next_in == Z_NULL && strm->avail_in != 0)) - return Z_STREAM_ERROR; - - state = (struct inflate_state FAR *)strm->state; - if (state->mode == TYPE) state->mode = TYPEDO; /* skip check */ - LOAD(); - in = have; - out = left; - ret = Z_OK; - for (;;) - switch (state->mode) { - case HEAD: - if (state->wrap == 0) { - state->mode = TYPEDO; - break; - } - NEEDBITS(16); -#ifdef GUNZIP - if ((state->wrap & 2) && hold == 0x8b1f) { /* gzip header */ - if (state->wbits == 0) - state->wbits = 15; - state->check = crc32(0L, Z_NULL, 0); - CRC2(state->check, hold); - INITBITS(); - state->mode = FLAGS; - break; - } - state->flags = 0; /* expect zlib header */ - if (state->head != Z_NULL) - state->head->done = -1; - if (!(state->wrap & 1) || /* check if zlib header allowed */ -#else - if ( -#endif - ((BITS(8) << 8) + (hold >> 8)) % 31) { - strm->msg = (char *)"incorrect header check"; - state->mode = BAD; - break; - } - if (BITS(4) != Z_DEFLATED) { - strm->msg = (char *)"unknown compression method"; - state->mode = BAD; - break; - } - DROPBITS(4); - len = BITS(4) + 8; - if (state->wbits == 0) - state->wbits = len; - if (len > 15 || len > state->wbits) { - strm->msg = (char *)"invalid window size"; - state->mode = BAD; - break; - } - state->dmax = 1U << len; - Tracev((stderr, "inflate: zlib header ok\n")); - strm->adler = state->check = adler32(0L, Z_NULL, 0); - state->mode = hold & 0x200 ? DICTID : TYPE; - INITBITS(); - break; -#ifdef GUNZIP - case FLAGS: - NEEDBITS(16); - state->flags = (int)(hold); - if ((state->flags & 0xff) != Z_DEFLATED) { - strm->msg = (char *)"unknown compression method"; - state->mode = BAD; - break; - } - if (state->flags & 0xe000) { - strm->msg = (char *)"unknown header flags set"; - state->mode = BAD; - break; - } - if (state->head != Z_NULL) - state->head->text = (int)((hold >> 8) & 1); - if ((state->flags & 0x0200) && (state->wrap & 4)) - CRC2(state->check, hold); - INITBITS(); - state->mode = TIME; - case TIME: - NEEDBITS(32); - if (state->head != Z_NULL) - state->head->time = hold; - if ((state->flags & 0x0200) && (state->wrap & 4)) - CRC4(state->check, hold); - INITBITS(); - state->mode = OS; - case OS: - NEEDBITS(16); - if (state->head != Z_NULL) { - state->head->xflags = (int)(hold & 0xff); - state->head->os = (int)(hold >> 8); - } - if ((state->flags & 0x0200) && (state->wrap & 4)) - CRC2(state->check, hold); - INITBITS(); - state->mode = EXLEN; - case EXLEN: - if (state->flags & 0x0400) { - NEEDBITS(16); - state->length = (unsigned)(hold); - if (state->head != Z_NULL) - state->head->extra_len = (unsigned)hold; - if ((state->flags & 0x0200) && (state->wrap & 4)) - CRC2(state->check, hold); - INITBITS(); - } - else if (state->head != Z_NULL) - state->head->extra = Z_NULL; - state->mode = EXTRA; - case EXTRA: - if (state->flags & 0x0400) { - copy = state->length; - if (copy > have) copy = have; - if (copy) { - if (state->head != Z_NULL && - state->head->extra != Z_NULL) { - len = state->head->extra_len - state->length; - zmemcpy(state->head->extra + len, next, - len + copy > state->head->extra_max ? - state->head->extra_max - len : copy); - } - if ((state->flags & 0x0200) && (state->wrap & 4)) - state->check = crc32(state->check, next, copy); - have -= copy; - next += copy; - state->length -= copy; - } - if (state->length) goto inf_leave; - } - state->length = 0; - state->mode = NAME; - case NAME: - if (state->flags & 0x0800) { - if (have == 0) goto inf_leave; - copy = 0; - do { - len = (unsigned)(next[copy++]); - if (state->head != Z_NULL && - state->head->name != Z_NULL && - state->length < state->head->name_max) - state->head->name[state->length++] = (Bytef)len; - } while (len && copy < have); - if ((state->flags & 0x0200) && (state->wrap & 4)) - state->check = crc32(state->check, next, copy); - have -= copy; - next += copy; - if (len) goto inf_leave; - } - else if (state->head != Z_NULL) - state->head->name = Z_NULL; - state->length = 0; - state->mode = COMMENT; - case COMMENT: - if (state->flags & 0x1000) { - if (have == 0) goto inf_leave; - copy = 0; - do { - len = (unsigned)(next[copy++]); - if (state->head != Z_NULL && - state->head->comment != Z_NULL && - state->length < state->head->comm_max) - state->head->comment[state->length++] = (Bytef)len; - } while (len && copy < have); - if ((state->flags & 0x0200) && (state->wrap & 4)) - state->check = crc32(state->check, next, copy); - have -= copy; - next += copy; - if (len) goto inf_leave; - } - else if (state->head != Z_NULL) - state->head->comment = Z_NULL; - state->mode = HCRC; - case HCRC: - if (state->flags & 0x0200) { - NEEDBITS(16); - if ((state->wrap & 4) && hold != (state->check & 0xffff)) { - strm->msg = (char *)"header crc mismatch"; - state->mode = BAD; - break; - } - INITBITS(); - } - if (state->head != Z_NULL) { - state->head->hcrc = (int)((state->flags >> 9) & 1); - state->head->done = 1; - } - strm->adler = state->check = crc32(0L, Z_NULL, 0); - state->mode = TYPE; - break; -#endif - case DICTID: - NEEDBITS(32); - strm->adler = state->check = ZSWAP32(hold); - INITBITS(); - state->mode = DICT; - case DICT: - if (state->havedict == 0) { - RESTORE(); - return Z_NEED_DICT; - } - strm->adler = state->check = adler32(0L, Z_NULL, 0); - state->mode = TYPE; - case TYPE: - if (flush == Z_BLOCK || flush == Z_TREES) goto inf_leave; - case TYPEDO: - if (state->last) { - BYTEBITS(); - state->mode = CHECK; - break; - } - NEEDBITS(3); - state->last = BITS(1); - DROPBITS(1); - switch (BITS(2)) { - case 0: /* stored block */ - Tracev((stderr, "inflate: stored block%s\n", - state->last ? " (last)" : "")); - state->mode = STORED; - break; - case 1: /* fixed block */ - fixedtables(state); - Tracev((stderr, "inflate: fixed codes block%s\n", - state->last ? " (last)" : "")); - state->mode = LEN_; /* decode codes */ - if (flush == Z_TREES) { - DROPBITS(2); - goto inf_leave; - } - break; - case 2: /* dynamic block */ - Tracev((stderr, "inflate: dynamic codes block%s\n", - state->last ? " (last)" : "")); - state->mode = TABLE; - break; - case 3: - strm->msg = (char *)"invalid block type"; - state->mode = BAD; - } - DROPBITS(2); - break; - case STORED: - BYTEBITS(); /* go to byte boundary */ - NEEDBITS(32); - if ((hold & 0xffff) != ((hold >> 16) ^ 0xffff)) { - strm->msg = (char *)"invalid stored block lengths"; - state->mode = BAD; - break; - } - state->length = (unsigned)hold & 0xffff; - Tracev((stderr, "inflate: stored length %u\n", - state->length)); - INITBITS(); - state->mode = COPY_; - if (flush == Z_TREES) goto inf_leave; - case COPY_: - state->mode = COPY; - case COPY: - copy = state->length; - if (copy) { - if (copy > have) copy = have; - if (copy > left) copy = left; - if (copy == 0) goto inf_leave; - zmemcpy(put, next, copy); - have -= copy; - next += copy; - left -= copy; - put += copy; - state->length -= copy; - break; - } - Tracev((stderr, "inflate: stored end\n")); - state->mode = TYPE; - break; - case TABLE: - NEEDBITS(14); - state->nlen = BITS(5) + 257; - DROPBITS(5); - state->ndist = BITS(5) + 1; - DROPBITS(5); - state->ncode = BITS(4) + 4; - DROPBITS(4); -#ifndef PKZIP_BUG_WORKAROUND - if (state->nlen > 286 || state->ndist > 30) { - strm->msg = (char *)"too many length or distance symbols"; - state->mode = BAD; - break; - } -#endif - Tracev((stderr, "inflate: table sizes ok\n")); - state->have = 0; - state->mode = LENLENS; - case LENLENS: - while (state->have < state->ncode) { - NEEDBITS(3); - state->lens[order[state->have++]] = (unsigned short)BITS(3); - DROPBITS(3); - } - while (state->have < 19) - state->lens[order[state->have++]] = 0; - state->next = state->codes; - state->lencode = (const code FAR *)(state->next); - state->lenbits = 7; - ret = inflate_table(CODES, state->lens, 19, &(state->next), - &(state->lenbits), state->work); - if (ret) { - strm->msg = (char *)"invalid code lengths set"; - state->mode = BAD; - break; - } - Tracev((stderr, "inflate: code lengths ok\n")); - state->have = 0; - state->mode = CODELENS; - case CODELENS: - while (state->have < state->nlen + state->ndist) { - for (;;) { - here = state->lencode[BITS(state->lenbits)]; - if ((unsigned)(here.bits) <= bits) break; - PULLBYTE(); - } - if (here.val < 16) { - DROPBITS(here.bits); - state->lens[state->have++] = here.val; - } - else { - if (here.val == 16) { - NEEDBITS(here.bits + 2); - DROPBITS(here.bits); - if (state->have == 0) { - strm->msg = (char *)"invalid bit length repeat"; - state->mode = BAD; - break; - } - len = state->lens[state->have - 1]; - copy = 3 + BITS(2); - DROPBITS(2); - } - else if (here.val == 17) { - NEEDBITS(here.bits + 3); - DROPBITS(here.bits); - len = 0; - copy = 3 + BITS(3); - DROPBITS(3); - } - else { - NEEDBITS(here.bits + 7); - DROPBITS(here.bits); - len = 0; - copy = 11 + BITS(7); - DROPBITS(7); - } - if (state->have + copy > state->nlen + state->ndist) { - strm->msg = (char *)"invalid bit length repeat"; - state->mode = BAD; - break; - } - while (copy--) - state->lens[state->have++] = (unsigned short)len; - } - } - - /* handle error breaks in while */ - if (state->mode == BAD) break; - - /* check for end-of-block code (better have one) */ - if (state->lens[256] == 0) { - strm->msg = (char *)"invalid code -- missing end-of-block"; - state->mode = BAD; - break; - } - - /* build code tables -- note: do not change the lenbits or distbits - values here (9 and 6) without reading the comments in inftrees.h - concerning the ENOUGH constants, which depend on those values */ - state->next = state->codes; - state->lencode = (const code FAR *)(state->next); - state->lenbits = 9; - ret = inflate_table(LENS, state->lens, state->nlen, &(state->next), - &(state->lenbits), state->work); - if (ret) { - strm->msg = (char *)"invalid literal/lengths set"; - state->mode = BAD; - break; - } - state->distcode = (const code FAR *)(state->next); - state->distbits = 6; - ret = inflate_table(DISTS, state->lens + state->nlen, state->ndist, - &(state->next), &(state->distbits), state->work); - if (ret) { - strm->msg = (char *)"invalid distances set"; - state->mode = BAD; - break; - } - Tracev((stderr, "inflate: codes ok\n")); - state->mode = LEN_; - if (flush == Z_TREES) goto inf_leave; - case LEN_: - state->mode = LEN; - case LEN: - if (have >= 6 && left >= 258) { - RESTORE(); - inflate_fast(strm, out); - LOAD(); - if (state->mode == TYPE) - state->back = -1; - break; - } - state->back = 0; - for (;;) { - here = state->lencode[BITS(state->lenbits)]; - if ((unsigned)(here.bits) <= bits) break; - PULLBYTE(); - } - if (here.op && (here.op & 0xf0) == 0) { - last = here; - for (;;) { - here = state->lencode[last.val + - (BITS(last.bits + last.op) >> last.bits)]; - if ((unsigned)(last.bits + here.bits) <= bits) break; - PULLBYTE(); - } - DROPBITS(last.bits); - state->back += last.bits; - } - DROPBITS(here.bits); - state->back += here.bits; - state->length = (unsigned)here.val; - if ((int)(here.op) == 0) { - Tracevv((stderr, here.val >= 0x20 && here.val < 0x7f ? - "inflate: literal '%c'\n" : - "inflate: literal 0x%02x\n", here.val)); - state->mode = LIT; - break; - } - if (here.op & 32) { - Tracevv((stderr, "inflate: end of block\n")); - state->back = -1; - state->mode = TYPE; - break; - } - if (here.op & 64) { - strm->msg = (char *)"invalid literal/length code"; - state->mode = BAD; - break; - } - state->extra = (unsigned)(here.op) & 15; - state->mode = LENEXT; - case LENEXT: - if (state->extra) { - NEEDBITS(state->extra); - state->length += BITS(state->extra); - DROPBITS(state->extra); - state->back += state->extra; - } - Tracevv((stderr, "inflate: length %u\n", state->length)); - state->was = state->length; - state->mode = DIST; - case DIST: - for (;;) { - here = state->distcode[BITS(state->distbits)]; - if ((unsigned)(here.bits) <= bits) break; - PULLBYTE(); - } - if ((here.op & 0xf0) == 0) { - last = here; - for (;;) { - here = state->distcode[last.val + - (BITS(last.bits + last.op) >> last.bits)]; - if ((unsigned)(last.bits + here.bits) <= bits) break; - PULLBYTE(); - } - DROPBITS(last.bits); - state->back += last.bits; - } - DROPBITS(here.bits); - state->back += here.bits; - if (here.op & 64) { - strm->msg = (char *)"invalid distance code"; - state->mode = BAD; - break; - } - state->offset = (unsigned)here.val; - state->extra = (unsigned)(here.op) & 15; - state->mode = DISTEXT; - case DISTEXT: - if (state->extra) { - NEEDBITS(state->extra); - state->offset += BITS(state->extra); - DROPBITS(state->extra); - state->back += state->extra; - } -#ifdef INFLATE_STRICT - if (state->offset > state->dmax) { - strm->msg = (char *)"invalid distance too far back"; - state->mode = BAD; - break; - } -#endif - Tracevv((stderr, "inflate: distance %u\n", state->offset)); - state->mode = MATCH; - case MATCH: - if (left == 0) goto inf_leave; - copy = out - left; - if (state->offset > copy) { /* copy from window */ - copy = state->offset - copy; - if (copy > state->whave) { - if (state->sane) { - strm->msg = (char *)"invalid distance too far back"; - state->mode = BAD; - break; - } -#ifdef INFLATE_ALLOW_INVALID_DISTANCE_TOOFAR_ARRR - Trace((stderr, "inflate.c too far\n")); - copy -= state->whave; - if (copy > state->length) copy = state->length; - if (copy > left) copy = left; - left -= copy; - state->length -= copy; - do { - *put++ = 0; - } while (--copy); - if (state->length == 0) state->mode = LEN; - break; -#endif - } - if (copy > state->wnext) { - copy -= state->wnext; - from = state->window + (state->wsize - copy); - } - else - from = state->window + (state->wnext - copy); - if (copy > state->length) copy = state->length; - } - else { /* copy from output */ - from = put - state->offset; - copy = state->length; - } - if (copy > left) copy = left; - left -= copy; - state->length -= copy; - do { - *put++ = *from++; - } while (--copy); - if (state->length == 0) state->mode = LEN; - break; - case LIT: - if (left == 0) goto inf_leave; - *put++ = (unsigned char)(state->length); - left--; - state->mode = LEN; - break; - case CHECK: - if (state->wrap) { - NEEDBITS(32); - out -= left; - strm->total_out += out; - state->total += out; - if ((state->wrap & 4) && out) - strm->adler = state->check = - UPDATE(state->check, put - out, out); - out = left; - if ((state->wrap & 4) && ( -#ifdef GUNZIP - state->flags ? hold : -#endif - ZSWAP32(hold)) != state->check) { - strm->msg = (char *)"incorrect data check"; - state->mode = BAD; - break; - } - INITBITS(); - Tracev((stderr, "inflate: check matches trailer\n")); - } -#ifdef GUNZIP - state->mode = LENGTH; - case LENGTH: - if (state->wrap && state->flags) { - NEEDBITS(32); - if (hold != (state->total & 0xffffffffUL)) { - strm->msg = (char *)"incorrect length check"; - state->mode = BAD; - break; - } - INITBITS(); - Tracev((stderr, "inflate: length matches trailer\n")); - } -#endif - state->mode = DONE; - case DONE: - ret = Z_STREAM_END; - goto inf_leave; - case BAD: - ret = Z_DATA_ERROR; - goto inf_leave; - case MEM: - return Z_MEM_ERROR; - case SYNC: - default: - return Z_STREAM_ERROR; - } - - /* - Return from inflate(), updating the total counts and the check value. - If there was no progress during the inflate() call, return a buffer - error. Call updatewindow() to create and/or update the window state. - Note: a memory error from inflate() is non-recoverable. - */ - inf_leave: - RESTORE(); - if (state->wsize || (out != strm->avail_out && state->mode < BAD && - (state->mode < CHECK || flush != Z_FINISH))) - if (updatewindow(strm, strm->next_out, out - strm->avail_out)) { - state->mode = MEM; - return Z_MEM_ERROR; - } - in -= strm->avail_in; - out -= strm->avail_out; - strm->total_in += in; - strm->total_out += out; - state->total += out; - if ((state->wrap & 4) && out) - strm->adler = state->check = - UPDATE(state->check, strm->next_out - out, out); - strm->data_type = (int)state->bits + (state->last ? 64 : 0) + - (state->mode == TYPE ? 128 : 0) + - (state->mode == LEN_ || state->mode == COPY_ ? 256 : 0); - if (((in == 0 && out == 0) || flush == Z_FINISH) && ret == Z_OK) - ret = Z_BUF_ERROR; - return ret; -} - -int ZEXPORT inflateEnd(strm) -z_streamp strm; -{ - struct inflate_state FAR *state; - if (inflateStateCheck(strm)) - return Z_STREAM_ERROR; - state = (struct inflate_state FAR *)strm->state; - if (state->window != Z_NULL) ZFREE(strm, state->window); - ZFREE(strm, strm->state); - strm->state = Z_NULL; - Tracev((stderr, "inflate: end\n")); - return Z_OK; -} - -int ZEXPORT inflateGetDictionary(strm, dictionary, dictLength) -z_streamp strm; -Bytef *dictionary; -uInt *dictLength; -{ - struct inflate_state FAR *state; - - /* check state */ - if (inflateStateCheck(strm)) return Z_STREAM_ERROR; - state = (struct inflate_state FAR *)strm->state; - - /* copy dictionary */ - if (state->whave && dictionary != Z_NULL) { - zmemcpy(dictionary, state->window + state->wnext, - state->whave - state->wnext); - zmemcpy(dictionary + state->whave - state->wnext, - state->window, state->wnext); - } - if (dictLength != Z_NULL) - *dictLength = state->whave; - return Z_OK; -} - -int ZEXPORT inflateSetDictionary(strm, dictionary, dictLength) -z_streamp strm; -const Bytef *dictionary; -uInt dictLength; -{ - struct inflate_state FAR *state; - unsigned long dictid; - int ret; - - /* check state */ - if (inflateStateCheck(strm)) return Z_STREAM_ERROR; - state = (struct inflate_state FAR *)strm->state; - if (state->wrap != 0 && state->mode != DICT) - return Z_STREAM_ERROR; - - /* check for correct dictionary identifier */ - if (state->mode == DICT) { - dictid = adler32(0L, Z_NULL, 0); - dictid = adler32(dictid, dictionary, dictLength); - if (dictid != state->check) - return Z_DATA_ERROR; - } - - /* copy dictionary to window using updatewindow(), which will amend the - existing dictionary if appropriate */ - ret = updatewindow(strm, dictionary + dictLength, dictLength); - if (ret) { - state->mode = MEM; - return Z_MEM_ERROR; - } - state->havedict = 1; - Tracev((stderr, "inflate: dictionary set\n")); - return Z_OK; -} - -int ZEXPORT inflateGetHeader(strm, head) -z_streamp strm; -gz_headerp head; -{ - struct inflate_state FAR *state; - - /* check state */ - if (inflateStateCheck(strm)) return Z_STREAM_ERROR; - state = (struct inflate_state FAR *)strm->state; - if ((state->wrap & 2) == 0) return Z_STREAM_ERROR; - - /* save header structure */ - state->head = head; - head->done = 0; - return Z_OK; -} - -/* - Search buf[0..len-1] for the pattern: 0, 0, 0xff, 0xff. Return when found - or when out of input. When called, *have is the number of pattern bytes - found in order so far, in 0..3. On return *have is updated to the new - state. If on return *have equals four, then the pattern was found and the - return value is how many bytes were read including the last byte of the - pattern. If *have is less than four, then the pattern has not been found - yet and the return value is len. In the latter case, syncsearch() can be - called again with more data and the *have state. *have is initialized to - zero for the first call. - */ -local unsigned syncsearch(have, buf, len) -unsigned FAR *have; -const unsigned char FAR *buf; -unsigned len; -{ - unsigned got; - unsigned next; - - got = *have; - next = 0; - while (next < len && got < 4) { - if ((int)(buf[next]) == (got < 2 ? 0 : 0xff)) - got++; - else if (buf[next]) - got = 0; - else - got = 4 - got; - next++; - } - *have = got; - return next; -} - -int ZEXPORT inflateSync(strm) -z_streamp strm; -{ - unsigned len; /* number of bytes to look at or looked at */ - unsigned long in, out; /* temporary to save total_in and total_out */ - unsigned char buf[4]; /* to restore bit buffer to byte string */ - struct inflate_state FAR *state; - - /* check parameters */ - if (inflateStateCheck(strm)) return Z_STREAM_ERROR; - state = (struct inflate_state FAR *)strm->state; - if (strm->avail_in == 0 && state->bits < 8) return Z_BUF_ERROR; - - /* if first time, start search in bit buffer */ - if (state->mode != SYNC) { - state->mode = SYNC; - state->hold <<= state->bits & 7; - state->bits -= state->bits & 7; - len = 0; - while (state->bits >= 8) { - buf[len++] = (unsigned char)(state->hold); - state->hold >>= 8; - state->bits -= 8; - } - state->have = 0; - syncsearch(&(state->have), buf, len); - } - - /* search available input */ - len = syncsearch(&(state->have), strm->next_in, strm->avail_in); - strm->avail_in -= len; - strm->next_in += len; - strm->total_in += len; - - /* return no joy or set up to restart inflate() on a new block */ - if (state->have != 4) return Z_DATA_ERROR; - in = strm->total_in; out = strm->total_out; - inflateReset(strm); - strm->total_in = in; strm->total_out = out; - state->mode = TYPE; - return Z_OK; -} - -/* - Returns true if inflate is currently at the end of a block generated by - Z_SYNC_FLUSH or Z_FULL_FLUSH. This function is used by one PPP - implementation to provide an additional safety check. PPP uses - Z_SYNC_FLUSH but removes the length bytes of the resulting empty stored - block. When decompressing, PPP checks that at the end of input packet, - inflate is waiting for these length bytes. - */ -int ZEXPORT inflateSyncPoint(strm) -z_streamp strm; -{ - struct inflate_state FAR *state; - - if (inflateStateCheck(strm)) return Z_STREAM_ERROR; - state = (struct inflate_state FAR *)strm->state; - return state->mode == STORED && state->bits == 0; -} - -int ZEXPORT inflateCopy(dest, source) -z_streamp dest; -z_streamp source; -{ - struct inflate_state FAR *state; - struct inflate_state FAR *copy; - unsigned char FAR *window; - unsigned wsize; - - /* check input */ - if (inflateStateCheck(source) || dest == Z_NULL) - return Z_STREAM_ERROR; - state = (struct inflate_state FAR *)source->state; - - /* allocate space */ - copy = (struct inflate_state FAR *) - ZALLOC(source, 1, sizeof(struct inflate_state)); - if (copy == Z_NULL) return Z_MEM_ERROR; - window = Z_NULL; - if (state->window != Z_NULL) { - window = (unsigned char FAR *) - ZALLOC(source, 1U << state->wbits, sizeof(unsigned char)); - if (window == Z_NULL) { - ZFREE(source, copy); - return Z_MEM_ERROR; - } - } - - /* copy state */ - zmemcpy((voidpf)dest, (voidpf)source, sizeof(z_stream)); - zmemcpy((voidpf)copy, (voidpf)state, sizeof(struct inflate_state)); - copy->strm = dest; - if (state->lencode >= state->codes && - state->lencode <= state->codes + ENOUGH - 1) { - copy->lencode = copy->codes + (state->lencode - state->codes); - copy->distcode = copy->codes + (state->distcode - state->codes); - } - copy->next = copy->codes + (state->next - state->codes); - if (window != Z_NULL) { - wsize = 1U << state->wbits; - zmemcpy(window, state->window, wsize); - } - copy->window = window; - dest->state = (struct internal_state FAR *)copy; - return Z_OK; -} - -int ZEXPORT inflateUndermine(strm, subvert) -z_streamp strm; -int subvert; -{ - struct inflate_state FAR *state; - - if (inflateStateCheck(strm)) return Z_STREAM_ERROR; - state = (struct inflate_state FAR *)strm->state; -#ifdef INFLATE_ALLOW_INVALID_DISTANCE_TOOFAR_ARRR - state->sane = !subvert; - return Z_OK; -#else - (void)subvert; - state->sane = 1; - return Z_DATA_ERROR; -#endif -} - -int ZEXPORT inflateValidate(strm, check) -z_streamp strm; -int check; -{ - struct inflate_state FAR *state; - - if (inflateStateCheck(strm)) return Z_STREAM_ERROR; - state = (struct inflate_state FAR *)strm->state; - if (check) - state->wrap |= 4; - else - state->wrap &= ~4; - return Z_OK; -} - -long ZEXPORT inflateMark(strm) -z_streamp strm; -{ - struct inflate_state FAR *state; - - if (inflateStateCheck(strm)) - return -(1L << 16); - state = (struct inflate_state FAR *)strm->state; - return (long)(((unsigned long)((long)state->back)) << 16) + - (state->mode == COPY ? state->length : - (state->mode == MATCH ? state->was - state->length : 0)); -} - -unsigned long ZEXPORT inflateCodesUsed(strm) -z_streamp strm; -{ - struct inflate_state FAR *state; - if (inflateStateCheck(strm)) return (unsigned long)-1; - state = (struct inflate_state FAR *)strm->state; - return (unsigned long)(state->next - state->codes); -} DELETED compat/zlib/inflate.h Index: compat/zlib/inflate.h ================================================================== --- compat/zlib/inflate.h +++ /dev/null @@ -1,125 +0,0 @@ -/* inflate.h -- internal inflate state definition - * Copyright (C) 1995-2016 Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -/* WARNING: this file should *not* be used by applications. It is - part of the implementation of the compression library and is - subject to change. Applications should only use zlib.h. - */ - -/* define NO_GZIP when compiling if you want to disable gzip header and - trailer decoding by inflate(). NO_GZIP would be used to avoid linking in - the crc code when it is not needed. For shared libraries, gzip decoding - should be left enabled. */ -#ifndef NO_GZIP -# define GUNZIP -#endif - -/* Possible inflate modes between inflate() calls */ -typedef enum { - HEAD = 16180, /* i: waiting for magic header */ - FLAGS, /* i: waiting for method and flags (gzip) */ - TIME, /* i: waiting for modification time (gzip) */ - OS, /* i: waiting for extra flags and operating system (gzip) */ - EXLEN, /* i: waiting for extra length (gzip) */ - EXTRA, /* i: waiting for extra bytes (gzip) */ - NAME, /* i: waiting for end of file name (gzip) */ - COMMENT, /* i: waiting for end of comment (gzip) */ - HCRC, /* i: waiting for header crc (gzip) */ - DICTID, /* i: waiting for dictionary check value */ - DICT, /* waiting for inflateSetDictionary() call */ - TYPE, /* i: waiting for type bits, including last-flag bit */ - TYPEDO, /* i: same, but skip check to exit inflate on new block */ - STORED, /* i: waiting for stored size (length and complement) */ - COPY_, /* i/o: same as COPY below, but only first time in */ - COPY, /* i/o: waiting for input or output to copy stored block */ - TABLE, /* i: waiting for dynamic block table lengths */ - LENLENS, /* i: waiting for code length code lengths */ - CODELENS, /* i: waiting for length/lit and distance code lengths */ - LEN_, /* i: same as LEN below, but only first time in */ - LEN, /* i: waiting for length/lit/eob code */ - LENEXT, /* i: waiting for length extra bits */ - DIST, /* i: waiting for distance code */ - DISTEXT, /* i: waiting for distance extra bits */ - MATCH, /* o: waiting for output space to copy string */ - LIT, /* o: waiting for output space to write literal */ - CHECK, /* i: waiting for 32-bit check value */ - LENGTH, /* i: waiting for 32-bit length (gzip) */ - DONE, /* finished check, done -- remain here until reset */ - BAD, /* got a data error -- remain here until reset */ - MEM, /* got an inflate() memory error -- remain here until reset */ - SYNC /* looking for synchronization bytes to restart inflate() */ -} inflate_mode; - -/* - State transitions between above modes - - - (most modes can go to BAD or MEM on error -- not shown for clarity) - - Process header: - HEAD -> (gzip) or (zlib) or (raw) - (gzip) -> FLAGS -> TIME -> OS -> EXLEN -> EXTRA -> NAME -> COMMENT -> - HCRC -> TYPE - (zlib) -> DICTID or TYPE - DICTID -> DICT -> TYPE - (raw) -> TYPEDO - Read deflate blocks: - TYPE -> TYPEDO -> STORED or TABLE or LEN_ or CHECK - STORED -> COPY_ -> COPY -> TYPE - TABLE -> LENLENS -> CODELENS -> LEN_ - LEN_ -> LEN - Read deflate codes in fixed or dynamic block: - LEN -> LENEXT or LIT or TYPE - LENEXT -> DIST -> DISTEXT -> MATCH -> LEN - LIT -> LEN - Process trailer: - CHECK -> LENGTH -> DONE - */ - -/* State maintained between inflate() calls -- approximately 7K bytes, not - including the allocated sliding window, which is up to 32K bytes. */ -struct inflate_state { - z_streamp strm; /* pointer back to this zlib stream */ - inflate_mode mode; /* current inflate mode */ - int last; /* true if processing last block */ - int wrap; /* bit 0 true for zlib, bit 1 true for gzip, - bit 2 true to validate check value */ - int havedict; /* true if dictionary provided */ - int flags; /* gzip header method and flags (0 if zlib) */ - unsigned dmax; /* zlib header max distance (INFLATE_STRICT) */ - unsigned long check; /* protected copy of check value */ - unsigned long total; /* protected copy of output count */ - gz_headerp head; /* where to save gzip header information */ - /* sliding window */ - unsigned wbits; /* log base 2 of requested window size */ - unsigned wsize; /* window size or zero if not using window */ - unsigned whave; /* valid bytes in the window */ - unsigned wnext; /* window write index */ - unsigned char FAR *window; /* allocated sliding window, if needed */ - /* bit accumulator */ - unsigned long hold; /* input bit accumulator */ - unsigned bits; /* number of bits in "in" */ - /* for string and stored block copying */ - unsigned length; /* literal or length of data to copy */ - unsigned offset; /* distance back to copy string from */ - /* for table and code decoding */ - unsigned extra; /* extra bits needed */ - /* fixed and dynamic code tables */ - code const FAR *lencode; /* starting table for length/literal codes */ - code const FAR *distcode; /* starting table for distance codes */ - unsigned lenbits; /* index bits for lencode */ - unsigned distbits; /* index bits for distcode */ - /* dynamic table building */ - unsigned ncode; /* number of code length code lengths */ - unsigned nlen; /* number of length code lengths */ - unsigned ndist; /* number of distance code lengths */ - unsigned have; /* number of code lengths in lens[] */ - code FAR *next; /* next available space in codes[] */ - unsigned short lens[320]; /* temporary storage for code lengths */ - unsigned short work[288]; /* work area for code table building */ - code codes[ENOUGH]; /* space for code tables */ - int sane; /* if false, allow invalid distance too far */ - int back; /* bits back of last unprocessed length/lit */ - unsigned was; /* initial length of match */ -}; DELETED compat/zlib/inftrees.c Index: compat/zlib/inftrees.c ================================================================== --- compat/zlib/inftrees.c +++ /dev/null @@ -1,304 +0,0 @@ -/* inftrees.c -- generate Huffman trees for efficient decoding - * Copyright (C) 1995-2017 Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -#include "zutil.h" -#include "inftrees.h" - -#define MAXBITS 15 - -const char inflate_copyright[] = - " inflate 1.2.11 Copyright 1995-2017 Mark Adler "; -/* - If you use the zlib library in a product, an acknowledgment is welcome - in the documentation of your product. If for some reason you cannot - include such an acknowledgment, I would appreciate that you keep this - copyright string in the executable of your product. - */ - -/* - Build a set of tables to decode the provided canonical Huffman code. - The code lengths are lens[0..codes-1]. The result starts at *table, - whose indices are 0..2^bits-1. work is a writable array of at least - lens shorts, which is used as a work area. type is the type of code - to be generated, CODES, LENS, or DISTS. On return, zero is success, - -1 is an invalid code, and +1 means that ENOUGH isn't enough. table - on return points to the next available entry's address. bits is the - requested root table index bits, and on return it is the actual root - table index bits. It will differ if the request is greater than the - longest code or if it is less than the shortest code. - */ -int ZLIB_INTERNAL inflate_table(type, lens, codes, table, bits, work) -codetype type; -unsigned short FAR *lens; -unsigned codes; -code FAR * FAR *table; -unsigned FAR *bits; -unsigned short FAR *work; -{ - unsigned len; /* a code's length in bits */ - unsigned sym; /* index of code symbols */ - unsigned min, max; /* minimum and maximum code lengths */ - unsigned root; /* number of index bits for root table */ - unsigned curr; /* number of index bits for current table */ - unsigned drop; /* code bits to drop for sub-table */ - int left; /* number of prefix codes available */ - unsigned used; /* code entries in table used */ - unsigned huff; /* Huffman code */ - unsigned incr; /* for incrementing code, index */ - unsigned fill; /* index for replicating entries */ - unsigned low; /* low bits for current root entry */ - unsigned mask; /* mask for low root bits */ - code here; /* table entry for duplication */ - code FAR *next; /* next available space in table */ - const unsigned short FAR *base; /* base value table to use */ - const unsigned short FAR *extra; /* extra bits table to use */ - unsigned match; /* use base and extra for symbol >= match */ - unsigned short count[MAXBITS+1]; /* number of codes of each length */ - unsigned short offs[MAXBITS+1]; /* offsets in table for each length */ - static const unsigned short lbase[31] = { /* Length codes 257..285 base */ - 3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 15, 17, 19, 23, 27, 31, - 35, 43, 51, 59, 67, 83, 99, 115, 131, 163, 195, 227, 258, 0, 0}; - static const unsigned short lext[31] = { /* Length codes 257..285 extra */ - 16, 16, 16, 16, 16, 16, 16, 16, 17, 17, 17, 17, 18, 18, 18, 18, - 19, 19, 19, 19, 20, 20, 20, 20, 21, 21, 21, 21, 16, 77, 202}; - static const unsigned short dbase[32] = { /* Distance codes 0..29 base */ - 1, 2, 3, 4, 5, 7, 9, 13, 17, 25, 33, 49, 65, 97, 129, 193, - 257, 385, 513, 769, 1025, 1537, 2049, 3073, 4097, 6145, - 8193, 12289, 16385, 24577, 0, 0}; - static const unsigned short dext[32] = { /* Distance codes 0..29 extra */ - 16, 16, 16, 16, 17, 17, 18, 18, 19, 19, 20, 20, 21, 21, 22, 22, - 23, 23, 24, 24, 25, 25, 26, 26, 27, 27, - 28, 28, 29, 29, 64, 64}; - - /* - Process a set of code lengths to create a canonical Huffman code. The - code lengths are lens[0..codes-1]. Each length corresponds to the - symbols 0..codes-1. The Huffman code is generated by first sorting the - symbols by length from short to long, and retaining the symbol order - for codes with equal lengths. Then the code starts with all zero bits - for the first code of the shortest length, and the codes are integer - increments for the same length, and zeros are appended as the length - increases. For the deflate format, these bits are stored backwards - from their more natural integer increment ordering, and so when the - decoding tables are built in the large loop below, the integer codes - are incremented backwards. - - This routine assumes, but does not check, that all of the entries in - lens[] are in the range 0..MAXBITS. The caller must assure this. - 1..MAXBITS is interpreted as that code length. zero means that that - symbol does not occur in this code. - - The codes are sorted by computing a count of codes for each length, - creating from that a table of starting indices for each length in the - sorted table, and then entering the symbols in order in the sorted - table. The sorted table is work[], with that space being provided by - the caller. - - The length counts are used for other purposes as well, i.e. finding - the minimum and maximum length codes, determining if there are any - codes at all, checking for a valid set of lengths, and looking ahead - at length counts to determine sub-table sizes when building the - decoding tables. - */ - - /* accumulate lengths for codes (assumes lens[] all in 0..MAXBITS) */ - for (len = 0; len <= MAXBITS; len++) - count[len] = 0; - for (sym = 0; sym < codes; sym++) - count[lens[sym]]++; - - /* bound code lengths, force root to be within code lengths */ - root = *bits; - for (max = MAXBITS; max >= 1; max--) - if (count[max] != 0) break; - if (root > max) root = max; - if (max == 0) { /* no symbols to code at all */ - here.op = (unsigned char)64; /* invalid code marker */ - here.bits = (unsigned char)1; - here.val = (unsigned short)0; - *(*table)++ = here; /* make a table to force an error */ - *(*table)++ = here; - *bits = 1; - return 0; /* no symbols, but wait for decoding to report error */ - } - for (min = 1; min < max; min++) - if (count[min] != 0) break; - if (root < min) root = min; - - /* check for an over-subscribed or incomplete set of lengths */ - left = 1; - for (len = 1; len <= MAXBITS; len++) { - left <<= 1; - left -= count[len]; - if (left < 0) return -1; /* over-subscribed */ - } - if (left > 0 && (type == CODES || max != 1)) - return -1; /* incomplete set */ - - /* generate offsets into symbol table for each length for sorting */ - offs[1] = 0; - for (len = 1; len < MAXBITS; len++) - offs[len + 1] = offs[len] + count[len]; - - /* sort symbols by length, by symbol order within each length */ - for (sym = 0; sym < codes; sym++) - if (lens[sym] != 0) work[offs[lens[sym]]++] = (unsigned short)sym; - - /* - Create and fill in decoding tables. In this loop, the table being - filled is at next and has curr index bits. The code being used is huff - with length len. That code is converted to an index by dropping drop - bits off of the bottom. For codes where len is less than drop + curr, - those top drop + curr - len bits are incremented through all values to - fill the table with replicated entries. - - root is the number of index bits for the root table. When len exceeds - root, sub-tables are created pointed to by the root entry with an index - of the low root bits of huff. This is saved in low to check for when a - new sub-table should be started. drop is zero when the root table is - being filled, and drop is root when sub-tables are being filled. - - When a new sub-table is needed, it is necessary to look ahead in the - code lengths to determine what size sub-table is needed. The length - counts are used for this, and so count[] is decremented as codes are - entered in the tables. - - used keeps track of how many table entries have been allocated from the - provided *table space. It is checked for LENS and DIST tables against - the constants ENOUGH_LENS and ENOUGH_DISTS to guard against changes in - the initial root table size constants. See the comments in inftrees.h - for more information. - - sym increments through all symbols, and the loop terminates when - all codes of length max, i.e. all codes, have been processed. This - routine permits incomplete codes, so another loop after this one fills - in the rest of the decoding tables with invalid code markers. - */ - - /* set up for code type */ - switch (type) { - case CODES: - base = extra = work; /* dummy value--not used */ - match = 20; - break; - case LENS: - base = lbase; - extra = lext; - match = 257; - break; - default: /* DISTS */ - base = dbase; - extra = dext; - match = 0; - } - - /* initialize state for loop */ - huff = 0; /* starting code */ - sym = 0; /* starting code symbol */ - len = min; /* starting code length */ - next = *table; /* current table to fill in */ - curr = root; /* current table index bits */ - drop = 0; /* current bits to drop from code for index */ - low = (unsigned)(-1); /* trigger new sub-table when len > root */ - used = 1U << root; /* use root table entries */ - mask = used - 1; /* mask for comparing low */ - - /* check available table space */ - if ((type == LENS && used > ENOUGH_LENS) || - (type == DISTS && used > ENOUGH_DISTS)) - return 1; - - /* process all codes and make table entries */ - for (;;) { - /* create table entry */ - here.bits = (unsigned char)(len - drop); - if (work[sym] + 1U < match) { - here.op = (unsigned char)0; - here.val = work[sym]; - } - else if (work[sym] >= match) { - here.op = (unsigned char)(extra[work[sym] - match]); - here.val = base[work[sym] - match]; - } - else { - here.op = (unsigned char)(32 + 64); /* end of block */ - here.val = 0; - } - - /* replicate for those indices with low len bits equal to huff */ - incr = 1U << (len - drop); - fill = 1U << curr; - min = fill; /* save offset to next table */ - do { - fill -= incr; - next[(huff >> drop) + fill] = here; - } while (fill != 0); - - /* backwards increment the len-bit code huff */ - incr = 1U << (len - 1); - while (huff & incr) - incr >>= 1; - if (incr != 0) { - huff &= incr - 1; - huff += incr; - } - else - huff = 0; - - /* go to next symbol, update count, len */ - sym++; - if (--(count[len]) == 0) { - if (len == max) break; - len = lens[work[sym]]; - } - - /* create new sub-table if needed */ - if (len > root && (huff & mask) != low) { - /* if first time, transition to sub-tables */ - if (drop == 0) - drop = root; - - /* increment past last table */ - next += min; /* here min is 1 << curr */ - - /* determine length of next table */ - curr = len - drop; - left = (int)(1 << curr); - while (curr + drop < max) { - left -= count[curr + drop]; - if (left <= 0) break; - curr++; - left <<= 1; - } - - /* check for enough space */ - used += 1U << curr; - if ((type == LENS && used > ENOUGH_LENS) || - (type == DISTS && used > ENOUGH_DISTS)) - return 1; - - /* point entry in root table to sub-table */ - low = huff & mask; - (*table)[low].op = (unsigned char)curr; - (*table)[low].bits = (unsigned char)root; - (*table)[low].val = (unsigned short)(next - *table); - } - } - - /* fill in remaining table entry if code is incomplete (guaranteed to have - at most one remaining entry, since if the code is incomplete, the - maximum code length that was allowed to get this far is one bit) */ - if (huff != 0) { - here.op = (unsigned char)64; /* invalid code marker */ - here.bits = (unsigned char)(len - drop); - here.val = (unsigned short)0; - next[huff] = here; - } - - /* set return parameters */ - *table += used; - *bits = root; - return 0; -} DELETED compat/zlib/inftrees.h Index: compat/zlib/inftrees.h ================================================================== --- compat/zlib/inftrees.h +++ /dev/null @@ -1,62 +0,0 @@ -/* inftrees.h -- header to use inftrees.c - * Copyright (C) 1995-2005, 2010 Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -/* WARNING: this file should *not* be used by applications. It is - part of the implementation of the compression library and is - subject to change. Applications should only use zlib.h. - */ - -/* Structure for decoding tables. Each entry provides either the - information needed to do the operation requested by the code that - indexed that table entry, or it provides a pointer to another - table that indexes more bits of the code. op indicates whether - the entry is a pointer to another table, a literal, a length or - distance, an end-of-block, or an invalid code. For a table - pointer, the low four bits of op is the number of index bits of - that table. For a length or distance, the low four bits of op - is the number of extra bits to get after the code. bits is - the number of bits in this code or part of the code to drop off - of the bit buffer. val is the actual byte to output in the case - of a literal, the base length or distance, or the offset from - the current table to the next table. Each entry is four bytes. */ -typedef struct { - unsigned char op; /* operation, extra bits, table bits */ - unsigned char bits; /* bits in this part of the code */ - unsigned short val; /* offset in table or code value */ -} code; - -/* op values as set by inflate_table(): - 00000000 - literal - 0000tttt - table link, tttt != 0 is the number of table index bits - 0001eeee - length or distance, eeee is the number of extra bits - 01100000 - end of block - 01000000 - invalid code - */ - -/* Maximum size of the dynamic table. The maximum number of code structures is - 1444, which is the sum of 852 for literal/length codes and 592 for distance - codes. These values were found by exhaustive searches using the program - examples/enough.c found in the zlib distribtution. The arguments to that - program are the number of symbols, the initial root table size, and the - maximum bit length of a code. "enough 286 9 15" for literal/length codes - returns returns 852, and "enough 30 6 15" for distance codes returns 592. - The initial root table size (9 or 6) is found in the fifth argument of the - inflate_table() calls in inflate.c and infback.c. If the root table size is - changed, then these maximum sizes would be need to be recalculated and - updated. */ -#define ENOUGH_LENS 852 -#define ENOUGH_DISTS 592 -#define ENOUGH (ENOUGH_LENS+ENOUGH_DISTS) - -/* Type of code to build for inflate_table() */ -typedef enum { - CODES, - LENS, - DISTS -} codetype; - -int ZLIB_INTERNAL inflate_table OF((codetype type, unsigned short FAR *lens, - unsigned codes, code FAR * FAR *table, - unsigned FAR *bits, unsigned short FAR *work)); DELETED compat/zlib/make_vms.com Index: compat/zlib/make_vms.com ================================================================== --- compat/zlib/make_vms.com +++ /dev/null @@ -1,867 +0,0 @@ -$! make libz under VMS written by -$! Martin P.J. Zinser -$! -$! In case of problems with the install you might contact me at -$! zinser@zinser.no-ip.info(preferred) or -$! martin.zinser@eurexchange.com (work) -$! -$! Make procedure history for Zlib -$! -$!------------------------------------------------------------------------------ -$! Version history -$! 0.01 20060120 First version to receive a number -$! 0.02 20061008 Adapt to new Makefile.in -$! 0.03 20091224 Add support for large file check -$! 0.04 20100110 Add new gzclose, gzlib, gzread, gzwrite -$! 0.05 20100221 Exchange zlibdefs.h by zconf.h.in -$! 0.06 20120111 Fix missing amiss_err, update zconf_h.in, fix new exmples -$! subdir path, update module search in makefile.in -$! 0.07 20120115 Triggered by work done by Alexey Chupahin completly redesigned -$! shared image creation -$! 0.08 20120219 Make it work on VAX again, pre-load missing symbols to shared -$! image -$! 0.09 20120305 SMS. P1 sets builder ("MMK", "MMS", " " (built-in)). -$! "" -> automatic, preference: MMK, MMS, built-in. -$! -$ on error then goto err_exit -$! -$ true = 1 -$ false = 0 -$ tmpnam = "temp_" + f$getjpi("","pid") -$ tt = tmpnam + ".txt" -$ tc = tmpnam + ".c" -$ th = tmpnam + ".h" -$ define/nolog tconfig 'th' -$ its_decc = false -$ its_vaxc = false -$ its_gnuc = false -$ s_case = False -$! -$! Setup variables holding "config" information -$! -$ Make = "''p1'" -$ name = "Zlib" -$ version = "?.?.?" -$ v_string = "ZLIB_VERSION" -$ v_file = "zlib.h" -$ ccopt = "/include = []" -$ lopts = "" -$ dnsrl = "" -$ aconf_in_file = "zconf.h.in#zconf.h_in#zconf_h.in" -$ conf_check_string = "" -$ linkonly = false -$ optfile = name + ".opt" -$ mapfile = name + ".map" -$ libdefs = "" -$ vax = f$getsyi("HW_MODEL").lt.1024 -$ axp = f$getsyi("HW_MODEL").ge.1024 .and. f$getsyi("HW_MODEL").lt.4096 -$ ia64 = f$getsyi("HW_MODEL").ge.4096 -$! -$! 2012-03-05 SMS. -$! Why is this needed? And if it is needed, why not simply ".not. vax"? -$! -$!!! if axp .or. ia64 then set proc/parse=extended -$! -$ whoami = f$parse(f$environment("Procedure"),,,,"NO_CONCEAL") -$ mydef = F$parse(whoami,,,"DEVICE") -$ mydir = f$parse(whoami,,,"DIRECTORY") - "][" -$ myproc = f$parse(whoami,,,"Name") + f$parse(whoami,,,"type") -$! -$! Check for MMK/MMS -$! -$ if (Make .eqs. "") -$ then -$ If F$Search ("Sys$System:MMS.EXE") .nes. "" Then Make = "MMS" -$ If F$Type (MMK) .eqs. "STRING" Then Make = "MMK" -$ else -$ Make = f$edit( Make, "trim") -$ endif -$! -$ gosub find_version -$! -$ open/write topt tmp.opt -$ open/write optf 'optfile' -$! -$ gosub check_opts -$! -$! Look for the compiler used -$! -$ gosub check_compiler -$ close topt -$ close optf -$! -$ if its_decc -$ then -$ ccopt = "/prefix=all" + ccopt -$ if f$trnlnm("SYS") .eqs. "" -$ then -$ if axp -$ then -$ define sys sys$library: -$ else -$ ccopt = "/decc" + ccopt -$ define sys decc$library_include: -$ endif -$ endif -$! -$! 2012-03-05 SMS. -$! Why /NAMES = AS_IS? Why not simply ".not. vax"? And why not on VAX? -$! -$ if axp .or. ia64 -$ then -$ ccopt = ccopt + "/name=as_is/opt=(inline=speed)" -$ s_case = true -$ endif -$ endif -$ if its_vaxc .or. its_gnuc -$ then -$ if f$trnlnm("SYS").eqs."" then define sys sys$library: -$ endif -$! -$! Build a fake configure input header -$! -$ open/write conf_hin config.hin -$ write conf_hin "#undef _LARGEFILE64_SOURCE" -$ close conf_hin -$! -$! -$ i = 0 -$FIND_ACONF: -$ fname = f$element(i,"#",aconf_in_file) -$ if fname .eqs. "#" then goto AMISS_ERR -$ if f$search(fname) .eqs. "" -$ then -$ i = i + 1 -$ goto find_aconf -$ endif -$ open/read/err=aconf_err aconf_in 'fname' -$ open/write aconf zconf.h -$ACONF_LOOP: -$ read/end_of_file=aconf_exit aconf_in line -$ work = f$edit(line, "compress,trim") -$ if f$extract(0,6,work) .nes. "#undef" -$ then -$ if f$extract(0,12,work) .nes. "#cmakedefine" -$ then -$ write aconf line -$ endif -$ else -$ cdef = f$element(1," ",work) -$ gosub check_config -$ endif -$ goto aconf_loop -$ACONF_EXIT: -$ write aconf "" -$ write aconf "/* VMS specifics added by make_vms.com: */" -$ write aconf "#define VMS 1" -$ write aconf "#include " -$ write aconf "#include " -$ write aconf "#ifdef _LARGEFILE" -$ write aconf "# define off64_t __off64_t" -$ write aconf "# define fopen64 fopen" -$ write aconf "# define fseeko64 fseeko" -$ write aconf "# define lseek64 lseek" -$ write aconf "# define ftello64 ftell" -$ write aconf "#endif" -$ write aconf "#if !defined( __VAX) && (__CRTL_VER >= 70312000)" -$ write aconf "# define HAVE_VSNPRINTF" -$ write aconf "#endif" -$ close aconf_in -$ close aconf -$ if f$search("''th'") .nes. "" then delete 'th';* -$! Build the thing plain or with mms -$! -$ write sys$output "Compiling Zlib sources ..." -$ if make.eqs."" -$ then -$ if (f$search( "example.obj;*") .nes. "") then delete example.obj;* -$ if (f$search( "minigzip.obj;*") .nes. "") then delete minigzip.obj;* -$ CALL MAKE adler32.OBJ "CC ''CCOPT' adler32" - - adler32.c zlib.h zconf.h -$ CALL MAKE compress.OBJ "CC ''CCOPT' compress" - - compress.c zlib.h zconf.h -$ CALL MAKE crc32.OBJ "CC ''CCOPT' crc32" - - crc32.c zlib.h zconf.h -$ CALL MAKE deflate.OBJ "CC ''CCOPT' deflate" - - deflate.c deflate.h zutil.h zlib.h zconf.h -$ CALL MAKE gzclose.OBJ "CC ''CCOPT' gzclose" - - gzclose.c zutil.h zlib.h zconf.h -$ CALL MAKE gzlib.OBJ "CC ''CCOPT' gzlib" - - gzlib.c zutil.h zlib.h zconf.h -$ CALL MAKE gzread.OBJ "CC ''CCOPT' gzread" - - gzread.c zutil.h zlib.h zconf.h -$ CALL MAKE gzwrite.OBJ "CC ''CCOPT' gzwrite" - - gzwrite.c zutil.h zlib.h zconf.h -$ CALL MAKE infback.OBJ "CC ''CCOPT' infback" - - infback.c zutil.h inftrees.h inflate.h inffast.h inffixed.h -$ CALL MAKE inffast.OBJ "CC ''CCOPT' inffast" - - inffast.c zutil.h zlib.h zconf.h inffast.h -$ CALL MAKE inflate.OBJ "CC ''CCOPT' inflate" - - inflate.c zutil.h zlib.h zconf.h infblock.h -$ CALL MAKE inftrees.OBJ "CC ''CCOPT' inftrees" - - inftrees.c zutil.h zlib.h zconf.h inftrees.h -$ CALL MAKE trees.OBJ "CC ''CCOPT' trees" - - trees.c deflate.h zutil.h zlib.h zconf.h -$ CALL MAKE uncompr.OBJ "CC ''CCOPT' uncompr" - - uncompr.c zlib.h zconf.h -$ CALL MAKE zutil.OBJ "CC ''CCOPT' zutil" - - zutil.c zutil.h zlib.h zconf.h -$ write sys$output "Building Zlib ..." -$ CALL MAKE libz.OLB "lib/crea libz.olb *.obj" *.OBJ -$ write sys$output "Building example..." -$ CALL MAKE example.OBJ "CC ''CCOPT' [.test]example" - - [.test]example.c zlib.h zconf.h -$ call make example.exe "LINK example,libz.olb/lib" example.obj libz.olb -$ write sys$output "Building minigzip..." -$ CALL MAKE minigzip.OBJ "CC ''CCOPT' [.test]minigzip" - - [.test]minigzip.c zlib.h zconf.h -$ call make minigzip.exe - - "LINK minigzip,libz.olb/lib" - - minigzip.obj libz.olb -$ else -$ gosub crea_mms -$ write sys$output "Make ''name' ''version' with ''Make' " -$ 'make' -$ endif -$! -$! Create shareable image -$! -$ gosub crea_olist -$ write sys$output "Creating libzshr.exe" -$ call map_2_shopt 'mapfile' 'optfile' -$ LINK_'lopts'/SHARE=libzshr.exe modules.opt/opt,'optfile'/opt -$ write sys$output "Zlib build completed" -$ delete/nolog tmp.opt;* -$ exit -$AMISS_ERR: -$ write sys$output "No source for config.hin found." -$ write sys$output "Tried any of ''aconf_in_file'" -$ goto err_exit -$CC_ERR: -$ write sys$output "C compiler required to build ''name'" -$ goto err_exit -$ERR_EXIT: -$ set message/facil/ident/sever/text -$ close/nolog optf -$ close/nolog topt -$ close/nolog aconf_in -$ close/nolog aconf -$ close/nolog out -$ close/nolog min -$ close/nolog mod -$ close/nolog h_in -$ write sys$output "Exiting..." -$ exit 2 -$! -$! -$MAKE: SUBROUTINE !SUBROUTINE TO CHECK DEPENDENCIES -$ V = 'F$Verify(0) -$! P1 = What we are trying to make -$! P2 = Command to make it -$! P3 - P8 What it depends on -$ -$ If F$Search(P1) .Eqs. "" Then Goto Makeit -$ Time = F$CvTime(F$File(P1,"RDT")) -$arg=3 -$Loop: -$ Argument = P'arg -$ If Argument .Eqs. "" Then Goto Exit -$ El=0 -$Loop2: -$ File = F$Element(El," ",Argument) -$ If File .Eqs. " " Then Goto Endl -$ AFile = "" -$Loop3: -$ OFile = AFile -$ AFile = F$Search(File) -$ If AFile .Eqs. "" .Or. AFile .Eqs. OFile Then Goto NextEl -$ If F$CvTime(F$File(AFile,"RDT")) .Ges. Time Then Goto Makeit -$ Goto Loop3 -$NextEL: -$ El = El + 1 -$ Goto Loop2 -$EndL: -$ arg=arg+1 -$ If arg .Le. 8 Then Goto Loop -$ Goto Exit -$ -$Makeit: -$ VV=F$VERIFY(0) -$ write sys$output P2 -$ 'P2 -$ VV='F$Verify(VV) -$Exit: -$ If V Then Set Verify -$ENDSUBROUTINE -$!------------------------------------------------------------------------------ -$! -$! Check command line options and set symbols accordingly -$! -$!------------------------------------------------------------------------------ -$! Version history -$! 0.01 20041206 First version to receive a number -$! 0.02 20060126 Add new "HELP" target -$ CHECK_OPTS: -$ i = 1 -$ OPT_LOOP: -$ if i .lt. 9 -$ then -$ cparm = f$edit(p'i',"upcase") -$! -$! Check if parameter actually contains something -$! -$ if f$edit(cparm,"trim") .nes. "" -$ then -$ if cparm .eqs. "DEBUG" -$ then -$ ccopt = ccopt + "/noopt/deb" -$ lopts = lopts + "/deb" -$ endif -$ if f$locate("CCOPT=",cparm) .lt. f$length(cparm) -$ then -$ start = f$locate("=",cparm) + 1 -$ len = f$length(cparm) - start -$ ccopt = ccopt + f$extract(start,len,cparm) -$ if f$locate("AS_IS",f$edit(ccopt,"UPCASE")) .lt. f$length(ccopt) - - then s_case = true -$ endif -$ if cparm .eqs. "LINK" then linkonly = true -$ if f$locate("LOPTS=",cparm) .lt. f$length(cparm) -$ then -$ start = f$locate("=",cparm) + 1 -$ len = f$length(cparm) - start -$ lopts = lopts + f$extract(start,len,cparm) -$ endif -$ if f$locate("CC=",cparm) .lt. f$length(cparm) -$ then -$ start = f$locate("=",cparm) + 1 -$ len = f$length(cparm) - start -$ cc_com = f$extract(start,len,cparm) - if (cc_com .nes. "DECC") .and. - - (cc_com .nes. "VAXC") .and. - - (cc_com .nes. "GNUC") -$ then -$ write sys$output "Unsupported compiler choice ''cc_com' ignored" -$ write sys$output "Use DECC, VAXC, or GNUC instead" -$ else -$ if cc_com .eqs. "DECC" then its_decc = true -$ if cc_com .eqs. "VAXC" then its_vaxc = true -$ if cc_com .eqs. "GNUC" then its_gnuc = true -$ endif -$ endif -$ if f$locate("MAKE=",cparm) .lt. f$length(cparm) -$ then -$ start = f$locate("=",cparm) + 1 -$ len = f$length(cparm) - start -$ mmks = f$extract(start,len,cparm) -$ if (mmks .eqs. "MMK") .or. (mmks .eqs. "MMS") -$ then -$ make = mmks -$ else -$ write sys$output "Unsupported make choice ''mmks' ignored" -$ write sys$output "Use MMK or MMS instead" -$ endif -$ endif -$ if cparm .eqs. "HELP" then gosub bhelp -$ endif -$ i = i + 1 -$ goto opt_loop -$ endif -$ return -$!------------------------------------------------------------------------------ -$! -$! Look for the compiler used -$! -$! Version history -$! 0.01 20040223 First version to receive a number -$! 0.02 20040229 Save/set value of decc$no_rooted_search_lists -$! 0.03 20060202 Extend handling of GNU C -$! 0.04 20090402 Compaq -> hp -$CHECK_COMPILER: -$ if (.not. (its_decc .or. its_vaxc .or. its_gnuc)) -$ then -$ its_decc = (f$search("SYS$SYSTEM:DECC$COMPILER.EXE") .nes. "") -$ its_vaxc = .not. its_decc .and. (F$Search("SYS$System:VAXC.Exe") .nes. "") -$ its_gnuc = .not. (its_decc .or. its_vaxc) .and. (f$trnlnm("gnu_cc") .nes. "") -$ endif -$! -$! Exit if no compiler available -$! -$ if (.not. (its_decc .or. its_vaxc .or. its_gnuc)) -$ then goto CC_ERR -$ else -$ if its_decc -$ then -$ write sys$output "CC compiler check ... hp C" -$ if f$trnlnm("decc$no_rooted_search_lists") .nes. "" -$ then -$ dnrsl = f$trnlnm("decc$no_rooted_search_lists") -$ endif -$ define/nolog decc$no_rooted_search_lists 1 -$ else -$ if its_vaxc then write sys$output "CC compiler check ... VAX C" -$ if its_gnuc -$ then -$ write sys$output "CC compiler check ... GNU C" -$ if f$trnlnm(topt) then write topt "gnu_cc:[000000]gcclib.olb/lib" -$ if f$trnlnm(optf) then write optf "gnu_cc:[000000]gcclib.olb/lib" -$ cc = "gcc" -$ endif -$ if f$trnlnm(topt) then write topt "sys$share:vaxcrtl.exe/share" -$ if f$trnlnm(optf) then write optf "sys$share:vaxcrtl.exe/share" -$ endif -$ endif -$ return -$!------------------------------------------------------------------------------ -$! -$! If MMS/MMK are available dump out the descrip.mms if required -$! -$CREA_MMS: -$ write sys$output "Creating descrip.mms..." -$ create descrip.mms -$ open/append out descrip.mms -$ copy sys$input: out -$ deck -# descrip.mms: MMS description file for building zlib on VMS -# written by Martin P.J. Zinser -# - -OBJS = adler32.obj, compress.obj, crc32.obj, gzclose.obj, gzlib.obj\ - gzread.obj, gzwrite.obj, uncompr.obj, infback.obj\ - deflate.obj, trees.obj, zutil.obj, inflate.obj, \ - inftrees.obj, inffast.obj - -$ eod -$ write out "CFLAGS=", ccopt -$ write out "LOPTS=", lopts -$ write out "all : example.exe minigzip.exe libz.olb" -$ copy sys$input: out -$ deck - @ write sys$output " Example applications available" - -libz.olb : libz.olb($(OBJS)) - @ write sys$output " libz available" - -example.exe : example.obj libz.olb - link $(LOPTS) example,libz.olb/lib - -minigzip.exe : minigzip.obj libz.olb - link $(LOPTS) minigzip,libz.olb/lib - -clean : - delete *.obj;*,libz.olb;*,*.opt;*,*.exe;* - - -# Other dependencies. -adler32.obj : adler32.c zutil.h zlib.h zconf.h -compress.obj : compress.c zlib.h zconf.h -crc32.obj : crc32.c zutil.h zlib.h zconf.h -deflate.obj : deflate.c deflate.h zutil.h zlib.h zconf.h -example.obj : [.test]example.c zlib.h zconf.h -gzclose.obj : gzclose.c zutil.h zlib.h zconf.h -gzlib.obj : gzlib.c zutil.h zlib.h zconf.h -gzread.obj : gzread.c zutil.h zlib.h zconf.h -gzwrite.obj : gzwrite.c zutil.h zlib.h zconf.h -inffast.obj : inffast.c zutil.h zlib.h zconf.h inftrees.h inffast.h -inflate.obj : inflate.c zutil.h zlib.h zconf.h -inftrees.obj : inftrees.c zutil.h zlib.h zconf.h inftrees.h -minigzip.obj : [.test]minigzip.c zlib.h zconf.h -trees.obj : trees.c deflate.h zutil.h zlib.h zconf.h -uncompr.obj : uncompr.c zlib.h zconf.h -zutil.obj : zutil.c zutil.h zlib.h zconf.h -infback.obj : infback.c zutil.h inftrees.h inflate.h inffast.h inffixed.h -$ eod -$ close out -$ return -$!------------------------------------------------------------------------------ -$! -$! Read list of core library sources from makefile.in and create options -$! needed to build shareable image -$! -$CREA_OLIST: -$ open/read min makefile.in -$ open/write mod modules.opt -$ src_check_list = "OBJZ =#OBJG =" -$MRLOOP: -$ read/end=mrdone min rec -$ i = 0 -$SRC_CHECK_LOOP: -$ src_check = f$element(i, "#", src_check_list) -$ i = i+1 -$ if src_check .eqs. "#" then goto mrloop -$ if (f$extract(0,6,rec) .nes. src_check) then goto src_check_loop -$ rec = rec - src_check -$ gosub extra_filnam -$ if (f$element(1,"\",rec) .eqs. "\") then goto mrloop -$MRSLOOP: -$ read/end=mrdone min rec -$ gosub extra_filnam -$ if (f$element(1,"\",rec) .nes. "\") then goto mrsloop -$MRDONE: -$ close min -$ close mod -$ return -$!------------------------------------------------------------------------------ -$! -$! Take record extracted in crea_olist and split it into single filenames -$! -$EXTRA_FILNAM: -$ myrec = f$edit(rec - "\", "trim,compress") -$ i = 0 -$FELOOP: -$ srcfil = f$element(i," ", myrec) -$ if (srcfil .nes. " ") -$ then -$ write mod f$parse(srcfil,,,"NAME"), ".obj" -$ i = i + 1 -$ goto feloop -$ endif -$ return -$!------------------------------------------------------------------------------ -$! -$! Find current Zlib version number -$! -$FIND_VERSION: -$ open/read h_in 'v_file' -$hloop: -$ read/end=hdone h_in rec -$ rec = f$edit(rec,"TRIM") -$ if (f$extract(0,1,rec) .nes. "#") then goto hloop -$ rec = f$edit(rec - "#", "TRIM") -$ if f$element(0," ",rec) .nes. "define" then goto hloop -$ if f$element(1," ",rec) .eqs. v_string -$ then -$ version = 'f$element(2," ",rec)' -$ goto hdone -$ endif -$ goto hloop -$hdone: -$ close h_in -$ return -$!------------------------------------------------------------------------------ -$! -$CHECK_CONFIG: -$! -$ in_ldef = f$locate(cdef,libdefs) -$ if (in_ldef .lt. f$length(libdefs)) -$ then -$ write aconf "#define ''cdef' 1" -$ libdefs = f$extract(0,in_ldef,libdefs) + - - f$extract(in_ldef + f$length(cdef) + 1, - - f$length(libdefs) - in_ldef - f$length(cdef) - 1, - - libdefs) -$ else -$ if (f$type('cdef') .eqs. "INTEGER") -$ then -$ write aconf "#define ''cdef' ", 'cdef' -$ else -$ if (f$type('cdef') .eqs. "STRING") -$ then -$ write aconf "#define ''cdef' ", """", '''cdef'', """" -$ else -$ gosub check_cc_def -$ endif -$ endif -$ endif -$ return -$!------------------------------------------------------------------------------ -$! -$! Check if this is a define relating to the properties of the C/C++ -$! compiler -$! -$ CHECK_CC_DEF: -$ if (cdef .eqs. "_LARGEFILE64_SOURCE") -$ then -$ copy sys$input: 'tc' -$ deck -#include "tconfig" -#define _LARGEFILE -#include - -int main(){ -FILE *fp; - fp = fopen("temp.txt","r"); - fseeko(fp,1,SEEK_SET); - fclose(fp); -} - -$ eod -$ test_inv = false -$ comm_h = false -$ gosub cc_prop_check -$ return -$ endif -$ write aconf "/* ", line, " */" -$ return -$!------------------------------------------------------------------------------ -$! -$! Check for properties of C/C++ compiler -$! -$! Version history -$! 0.01 20031020 First version to receive a number -$! 0.02 20031022 Added logic for defines with value -$! 0.03 20040309 Make sure local config file gets not deleted -$! 0.04 20041230 Also write include for configure run -$! 0.05 20050103 Add processing of "comment defines" -$CC_PROP_CHECK: -$ cc_prop = true -$ is_need = false -$ is_need = (f$extract(0,4,cdef) .eqs. "NEED") .or. (test_inv .eq. true) -$ if f$search(th) .eqs. "" then create 'th' -$ set message/nofac/noident/nosever/notext -$ on error then continue -$ cc 'tmpnam' -$ if .not. ($status) then cc_prop = false -$ on error then continue -$! The headers might lie about the capabilities of the RTL -$ link 'tmpnam',tmp.opt/opt -$ if .not. ($status) then cc_prop = false -$ set message/fac/ident/sever/text -$ on error then goto err_exit -$ delete/nolog 'tmpnam'.*;*/exclude='th' -$ if (cc_prop .and. .not. is_need) .or. - - (.not. cc_prop .and. is_need) -$ then -$ write sys$output "Checking for ''cdef'... yes" -$ if f$type('cdef_val'_yes) .nes. "" -$ then -$ if f$type('cdef_val'_yes) .eqs. "INTEGER" - - then call write_config f$fao("#define !AS !UL",cdef,'cdef_val'_yes) -$ if f$type('cdef_val'_yes) .eqs. "STRING" - - then call write_config f$fao("#define !AS !AS",cdef,'cdef_val'_yes) -$ else -$ call write_config f$fao("#define !AS 1",cdef) -$ endif -$ if (cdef .eqs. "HAVE_FSEEKO") .or. (cdef .eqs. "_LARGE_FILES") .or. - - (cdef .eqs. "_LARGEFILE64_SOURCE") then - - call write_config f$string("#define _LARGEFILE 1") -$ else -$ write sys$output "Checking for ''cdef'... no" -$ if (comm_h) -$ then - call write_config f$fao("/* !AS */",line) -$ else -$ if f$type('cdef_val'_no) .nes. "" -$ then -$ if f$type('cdef_val'_no) .eqs. "INTEGER" - - then call write_config f$fao("#define !AS !UL",cdef,'cdef_val'_no) -$ if f$type('cdef_val'_no) .eqs. "STRING" - - then call write_config f$fao("#define !AS !AS",cdef,'cdef_val'_no) -$ else -$ call write_config f$fao("#undef !AS",cdef) -$ endif -$ endif -$ endif -$ return -$!------------------------------------------------------------------------------ -$! -$! Check for properties of C/C++ compiler with multiple result values -$! -$! Version history -$! 0.01 20040127 First version -$! 0.02 20050103 Reconcile changes from cc_prop up to version 0.05 -$CC_MPROP_CHECK: -$ cc_prop = true -$ i = 1 -$ idel = 1 -$ MT_LOOP: -$ if f$type(result_'i') .eqs. "STRING" -$ then -$ set message/nofac/noident/nosever/notext -$ on error then continue -$ cc 'tmpnam'_'i' -$ if .not. ($status) then cc_prop = false -$ on error then continue -$! The headers might lie about the capabilities of the RTL -$ link 'tmpnam'_'i',tmp.opt/opt -$ if .not. ($status) then cc_prop = false -$ set message/fac/ident/sever/text -$ on error then goto err_exit -$ delete/nolog 'tmpnam'_'i'.*;* -$ if (cc_prop) -$ then -$ write sys$output "Checking for ''cdef'... ", mdef_'i' -$ if f$type(mdef_'i') .eqs. "INTEGER" - - then call write_config f$fao("#define !AS !UL",cdef,mdef_'i') -$ if f$type('cdef_val'_yes) .eqs. "STRING" - - then call write_config f$fao("#define !AS !AS",cdef,mdef_'i') -$ goto msym_clean -$ else -$ i = i + 1 -$ goto mt_loop -$ endif -$ endif -$ write sys$output "Checking for ''cdef'... no" -$ call write_config f$fao("#undef !AS",cdef) -$ MSYM_CLEAN: -$ if (idel .le. msym_max) -$ then -$ delete/sym mdef_'idel' -$ idel = idel + 1 -$ goto msym_clean -$ endif -$ return -$!------------------------------------------------------------------------------ -$! -$! Write configuration to both permanent and temporary config file -$! -$! Version history -$! 0.01 20031029 First version to receive a number -$! -$WRITE_CONFIG: SUBROUTINE -$ write aconf 'p1' -$ open/append confh 'th' -$ write confh 'p1' -$ close confh -$ENDSUBROUTINE -$!------------------------------------------------------------------------------ -$! -$! Analyze the project map file and create the symbol vector for a shareable -$! image from it -$! -$! Version history -$! 0.01 20120128 First version -$! 0.02 20120226 Add pre-load logic -$! -$ MAP_2_SHOPT: Subroutine -$! -$ SAY := "WRITE_ SYS$OUTPUT" -$! -$ IF F$SEARCH("''P1'") .EQS. "" -$ THEN -$ SAY "MAP_2_SHOPT-E-NOSUCHFILE: Error, inputfile ''p1' not available" -$ goto exit_m2s -$ ENDIF -$ IF "''P2'" .EQS. "" -$ THEN -$ SAY "MAP_2_SHOPT: Error, no output file provided" -$ goto exit_m2s -$ ENDIF -$! -$ module1 = "deflate#deflateEnd#deflateInit_#deflateParams#deflateSetDictionary" -$ module2 = "gzclose#gzerror#gzgetc#gzgets#gzopen#gzprintf#gzputc#gzputs#gzread" -$ module3 = "gzseek#gztell#inflate#inflateEnd#inflateInit_#inflateSetDictionary" -$ module4 = "inflateSync#uncompress#zlibVersion#compress" -$ open/read map 'p1 -$ if axp .or. ia64 -$ then -$ open/write aopt a.opt -$ open/write bopt b.opt -$ write aopt " CASE_SENSITIVE=YES" -$ write bopt "SYMBOL_VECTOR= (-" -$ mod_sym_num = 1 -$ MOD_SYM_LOOP: -$ if f$type(module'mod_sym_num') .nes. "" -$ then -$ mod_in = 0 -$ MOD_SYM_IN: -$ shared_proc = f$element(mod_in, "#", module'mod_sym_num') -$ if shared_proc .nes. "#" -$ then -$ write aopt f$fao(" symbol_vector=(!AS/!AS=PROCEDURE)",- - f$edit(shared_proc,"upcase"),shared_proc) -$ write bopt f$fao("!AS=PROCEDURE,-",shared_proc) -$ mod_in = mod_in + 1 -$ goto mod_sym_in -$ endif -$ mod_sym_num = mod_sym_num + 1 -$ goto mod_sym_loop -$ endif -$MAP_LOOP: -$ read/end=map_end map line -$ if (f$locate("{",line).lt. f$length(line)) .or. - - (f$locate("global:", line) .lt. f$length(line)) -$ then -$ proc = true -$ goto map_loop -$ endif -$ if f$locate("}",line).lt. f$length(line) then proc = false -$ if f$locate("local:", line) .lt. f$length(line) then proc = false -$ if proc -$ then -$ shared_proc = f$edit(line,"collapse") -$ chop_semi = f$locate(";", shared_proc) -$ if chop_semi .lt. f$length(shared_proc) then - - shared_proc = f$extract(0, chop_semi, shared_proc) -$ write aopt f$fao(" symbol_vector=(!AS/!AS=PROCEDURE)",- - f$edit(shared_proc,"upcase"),shared_proc) -$ write bopt f$fao("!AS=PROCEDURE,-",shared_proc) -$ endif -$ goto map_loop -$MAP_END: -$ close/nolog aopt -$ close/nolog bopt -$ open/append libopt 'p2' -$ open/read aopt a.opt -$ open/read bopt b.opt -$ALOOP: -$ read/end=aloop_end aopt line -$ write libopt line -$ goto aloop -$ALOOP_END: -$ close/nolog aopt -$ sv = "" -$BLOOP: -$ read/end=bloop_end bopt svn -$ if (svn.nes."") -$ then -$ if (sv.nes."") then write libopt sv -$ sv = svn -$ endif -$ goto bloop -$BLOOP_END: -$ write libopt f$extract(0,f$length(sv)-2,sv), "-" -$ write libopt ")" -$ close/nolog bopt -$ delete/nolog/noconf a.opt;*,b.opt;* -$ else -$ if vax -$ then -$ open/append libopt 'p2' -$ mod_sym_num = 1 -$ VMOD_SYM_LOOP: -$ if f$type(module'mod_sym_num') .nes. "" -$ then -$ mod_in = 0 -$ VMOD_SYM_IN: -$ shared_proc = f$element(mod_in, "#", module'mod_sym_num') -$ if shared_proc .nes. "#" -$ then -$ write libopt f$fao("UNIVERSAL=!AS",- - f$edit(shared_proc,"upcase")) -$ mod_in = mod_in + 1 -$ goto vmod_sym_in -$ endif -$ mod_sym_num = mod_sym_num + 1 -$ goto vmod_sym_loop -$ endif -$VMAP_LOOP: -$ read/end=vmap_end map line -$ if (f$locate("{",line).lt. f$length(line)) .or. - - (f$locate("global:", line) .lt. f$length(line)) -$ then -$ proc = true -$ goto vmap_loop -$ endif -$ if f$locate("}",line).lt. f$length(line) then proc = false -$ if f$locate("local:", line) .lt. f$length(line) then proc = false -$ if proc -$ then -$ shared_proc = f$edit(line,"collapse") -$ chop_semi = f$locate(";", shared_proc) -$ if chop_semi .lt. f$length(shared_proc) then - - shared_proc = f$extract(0, chop_semi, shared_proc) -$ write libopt f$fao("UNIVERSAL=!AS",- - f$edit(shared_proc,"upcase")) -$ endif -$ goto vmap_loop -$VMAP_END: -$ else -$ write sys$output "Unknown Architecture (Not VAX, AXP, or IA64)" -$ write sys$output "No options file created" -$ endif -$ endif -$ EXIT_M2S: -$ close/nolog map -$ close/nolog libopt -$ endsubroutine DELETED compat/zlib/msdos/Makefile.bor Index: compat/zlib/msdos/Makefile.bor ================================================================== --- compat/zlib/msdos/Makefile.bor +++ /dev/null @@ -1,115 +0,0 @@ -# Makefile for zlib -# Borland C++ -# Last updated: 15-Mar-2003 - -# To use, do "make -fmakefile.bor" -# To compile in small model, set below: MODEL=s - -# WARNING: the small model is supported but only for small values of -# MAX_WBITS and MAX_MEM_LEVEL. For example: -# -DMAX_WBITS=11 -DDEF_WBITS=11 -DMAX_MEM_LEVEL=3 -# If you wish to reduce the memory requirements (default 256K for big -# objects plus a few K), you can add to the LOC macro below: -# -DMAX_MEM_LEVEL=7 -DMAX_WBITS=14 -# See zconf.h for details about the memory requirements. - -# ------------ Turbo C++, Borland C++ ------------ - -# Optional nonstandard preprocessor flags (e.g. -DMAX_MEM_LEVEL=7) -# should be added to the environment via "set LOCAL_ZLIB=-DFOO" or added -# to the declaration of LOC here: -LOC = $(LOCAL_ZLIB) - -# type for CPU required: 0: 8086, 1: 80186, 2: 80286, 3: 80386, etc. -CPU_TYP = 0 - -# memory model: one of s, m, c, l (small, medium, compact, large) -MODEL=l - -# replace bcc with tcc for Turbo C++ 1.0, with bcc32 for the 32 bit version -CC=bcc -LD=bcc -AR=tlib - -# compiler flags -# replace "-O2" by "-O -G -a -d" for Turbo C++ 1.0 -CFLAGS=-O2 -Z -m$(MODEL) $(LOC) - -LDFLAGS=-m$(MODEL) -f- - - -# variables -ZLIB_LIB = zlib_$(MODEL).lib - -OBJ1 = adler32.obj compress.obj crc32.obj deflate.obj gzclose.obj gzlib.obj gzread.obj -OBJ2 = gzwrite.obj infback.obj inffast.obj inflate.obj inftrees.obj trees.obj uncompr.obj zutil.obj -OBJP1 = +adler32.obj+compress.obj+crc32.obj+deflate.obj+gzclose.obj+gzlib.obj+gzread.obj -OBJP2 = +gzwrite.obj+infback.obj+inffast.obj+inflate.obj+inftrees.obj+trees.obj+uncompr.obj+zutil.obj - - -# targets -all: $(ZLIB_LIB) example.exe minigzip.exe - -.c.obj: - $(CC) -c $(CFLAGS) $*.c - -adler32.obj: adler32.c zlib.h zconf.h - -compress.obj: compress.c zlib.h zconf.h - -crc32.obj: crc32.c zlib.h zconf.h crc32.h - -deflate.obj: deflate.c deflate.h zutil.h zlib.h zconf.h - -gzclose.obj: gzclose.c zlib.h zconf.h gzguts.h - -gzlib.obj: gzlib.c zlib.h zconf.h gzguts.h - -gzread.obj: gzread.c zlib.h zconf.h gzguts.h - -gzwrite.obj: gzwrite.c zlib.h zconf.h gzguts.h - -infback.obj: infback.c zutil.h zlib.h zconf.h inftrees.h inflate.h \ - inffast.h inffixed.h - -inffast.obj: inffast.c zutil.h zlib.h zconf.h inftrees.h inflate.h \ - inffast.h - -inflate.obj: inflate.c zutil.h zlib.h zconf.h inftrees.h inflate.h \ - inffast.h inffixed.h - -inftrees.obj: inftrees.c zutil.h zlib.h zconf.h inftrees.h - -trees.obj: trees.c zutil.h zlib.h zconf.h deflate.h trees.h - -uncompr.obj: uncompr.c zlib.h zconf.h - -zutil.obj: zutil.c zutil.h zlib.h zconf.h - -example.obj: test/example.c zlib.h zconf.h - -minigzip.obj: test/minigzip.c zlib.h zconf.h - - -# the command line is cut to fit in the MS-DOS 128 byte limit: -$(ZLIB_LIB): $(OBJ1) $(OBJ2) - -del $(ZLIB_LIB) - $(AR) $(ZLIB_LIB) $(OBJP1) - $(AR) $(ZLIB_LIB) $(OBJP2) - -example.exe: example.obj $(ZLIB_LIB) - $(LD) $(LDFLAGS) example.obj $(ZLIB_LIB) - -minigzip.exe: minigzip.obj $(ZLIB_LIB) - $(LD) $(LDFLAGS) minigzip.obj $(ZLIB_LIB) - -test: example.exe minigzip.exe - example - echo hello world | minigzip | minigzip -d - -clean: - -del *.obj - -del *.lib - -del *.exe - -del zlib_*.bak - -del foo.gz DELETED compat/zlib/msdos/Makefile.dj2 Index: compat/zlib/msdos/Makefile.dj2 ================================================================== --- compat/zlib/msdos/Makefile.dj2 +++ /dev/null @@ -1,104 +0,0 @@ -# Makefile for zlib. Modified for djgpp v2.0 by F. J. Donahoe, 3/15/96. -# Copyright (C) 1995-1998 Jean-loup Gailly. -# For conditions of distribution and use, see copyright notice in zlib.h - -# To compile, or to compile and test, type: -# -# make -fmakefile.dj2; make test -fmakefile.dj2 -# -# To install libz.a, zconf.h and zlib.h in the djgpp directories, type: -# -# make install -fmakefile.dj2 -# -# after first defining LIBRARY_PATH and INCLUDE_PATH in djgpp.env as -# in the sample below if the pattern of the DJGPP distribution is to -# be followed. Remember that, while 'es around <=> are ignored in -# makefiles, they are *not* in batch files or in djgpp.env. -# - - - - - -# [make] -# INCLUDE_PATH=%\>;INCLUDE_PATH%%\DJDIR%\include -# LIBRARY_PATH=%\>;LIBRARY_PATH%%\DJDIR%\lib -# BUTT=-m486 -# - - - - - -# Alternately, these variables may be defined below, overriding the values -# in djgpp.env, as -# INCLUDE_PATH=c:\usr\include -# LIBRARY_PATH=c:\usr\lib - -CC=gcc - -#CFLAGS=-MMD -O -#CFLAGS=-O -DMAX_WBITS=14 -DMAX_MEM_LEVEL=7 -#CFLAGS=-MMD -g -DZLIB_DEBUG -CFLAGS=-MMD -O3 $(BUTT) -Wall -Wwrite-strings -Wpointer-arith -Wconversion \ - -Wstrict-prototypes -Wmissing-prototypes - -# If cp.exe is available, replace "copy /Y" with "cp -fp" . -CP=copy /Y -# If gnu install.exe is available, replace $(CP) with ginstall. -INSTALL=$(CP) -# The default value of RM is "rm -f." If "rm.exe" is found, comment out: -RM=del -LDLIBS=-L. -lz -LD=$(CC) -s -o -LDSHARED=$(CC) - -INCL=zlib.h zconf.h -LIBS=libz.a - -AR=ar rcs - -prefix=/usr/local -exec_prefix = $(prefix) - -OBJS = adler32.o compress.o crc32.o gzclose.o gzlib.o gzread.o gzwrite.o \ - uncompr.o deflate.o trees.o zutil.o inflate.o infback.o inftrees.o inffast.o - -OBJA = -# to use the asm code: make OBJA=match.o - -TEST_OBJS = example.o minigzip.o - -all: example.exe minigzip.exe - -check: test -test: all - ./example - echo hello world | .\minigzip | .\minigzip -d - -%.o : %.c - $(CC) $(CFLAGS) -c $< -o $@ - -libz.a: $(OBJS) $(OBJA) - $(AR) $@ $(OBJS) $(OBJA) - -%.exe : %.o $(LIBS) - $(LD) $@ $< $(LDLIBS) - -# INCLUDE_PATH and LIBRARY_PATH were set for [make] in djgpp.env . - -.PHONY : uninstall clean - -install: $(INCL) $(LIBS) - -@if not exist $(INCLUDE_PATH)\nul mkdir $(INCLUDE_PATH) - -@if not exist $(LIBRARY_PATH)\nul mkdir $(LIBRARY_PATH) - $(INSTALL) zlib.h $(INCLUDE_PATH) - $(INSTALL) zconf.h $(INCLUDE_PATH) - $(INSTALL) libz.a $(LIBRARY_PATH) - -uninstall: - $(RM) $(INCLUDE_PATH)\zlib.h - $(RM) $(INCLUDE_PATH)\zconf.h - $(RM) $(LIBRARY_PATH)\libz.a - -clean: - $(RM) *.d - $(RM) *.o - $(RM) *.exe - $(RM) libz.a - $(RM) foo.gz - -DEPS := $(wildcard *.d) -ifneq ($(DEPS),) -include $(DEPS) -endif DELETED compat/zlib/msdos/Makefile.emx Index: compat/zlib/msdos/Makefile.emx ================================================================== --- compat/zlib/msdos/Makefile.emx +++ /dev/null @@ -1,69 +0,0 @@ -# Makefile for zlib. Modified for emx 0.9c by Chr. Spieler, 6/17/98. -# Copyright (C) 1995-1998 Jean-loup Gailly. -# For conditions of distribution and use, see copyright notice in zlib.h - -# To compile, or to compile and test, type: -# -# make -fmakefile.emx; make test -fmakefile.emx -# - -CC=gcc - -#CFLAGS=-MMD -O -#CFLAGS=-O -DMAX_WBITS=14 -DMAX_MEM_LEVEL=7 -#CFLAGS=-MMD -g -DZLIB_DEBUG -CFLAGS=-MMD -O3 $(BUTT) -Wall -Wwrite-strings -Wpointer-arith -Wconversion \ - -Wstrict-prototypes -Wmissing-prototypes - -# If cp.exe is available, replace "copy /Y" with "cp -fp" . -CP=copy /Y -# If gnu install.exe is available, replace $(CP) with ginstall. -INSTALL=$(CP) -# The default value of RM is "rm -f." If "rm.exe" is found, comment out: -RM=del -LDLIBS=-L. -lzlib -LD=$(CC) -s -o -LDSHARED=$(CC) - -INCL=zlib.h zconf.h -LIBS=zlib.a - -AR=ar rcs - -prefix=/usr/local -exec_prefix = $(prefix) - -OBJS = adler32.o compress.o crc32.o gzclose.o gzlib.o gzread.o gzwrite.o \ - uncompr.o deflate.o trees.o zutil.o inflate.o infback.o inftrees.o inffast.o - -TEST_OBJS = example.o minigzip.o - -all: example.exe minigzip.exe - -test: all - ./example - echo hello world | .\minigzip | .\minigzip -d - -%.o : %.c - $(CC) $(CFLAGS) -c $< -o $@ - -zlib.a: $(OBJS) - $(AR) $@ $(OBJS) - -%.exe : %.o $(LIBS) - $(LD) $@ $< $(LDLIBS) - - -.PHONY : clean - -clean: - $(RM) *.d - $(RM) *.o - $(RM) *.exe - $(RM) zlib.a - $(RM) foo.gz - -DEPS := $(wildcard *.d) -ifneq ($(DEPS),) -include $(DEPS) -endif DELETED compat/zlib/msdos/Makefile.msc Index: compat/zlib/msdos/Makefile.msc ================================================================== --- compat/zlib/msdos/Makefile.msc +++ /dev/null @@ -1,112 +0,0 @@ -# Makefile for zlib -# Microsoft C 5.1 or later -# Last updated: 19-Mar-2003 - -# To use, do "make makefile.msc" -# To compile in small model, set below: MODEL=S - -# If you wish to reduce the memory requirements (default 256K for big -# objects plus a few K), you can add to the LOC macro below: -# -DMAX_MEM_LEVEL=7 -DMAX_WBITS=14 -# See zconf.h for details about the memory requirements. - -# ------------- Microsoft C 5.1 and later ------------- - -# Optional nonstandard preprocessor flags (e.g. -DMAX_MEM_LEVEL=7) -# should be added to the environment via "set LOCAL_ZLIB=-DFOO" or added -# to the declaration of LOC here: -LOC = $(LOCAL_ZLIB) - -# Type for CPU required: 0: 8086, 1: 80186, 2: 80286, 3: 80386, etc. -CPU_TYP = 0 - -# Memory model: one of S, M, C, L (small, medium, compact, large) -MODEL=L - -CC=cl -CFLAGS=-nologo -A$(MODEL) -G$(CPU_TYP) -W3 -Oait -Gs $(LOC) -#-Ox generates bad code with MSC 5.1 -LIB_CFLAGS=-Zl $(CFLAGS) - -LD=link -LDFLAGS=/noi/e/st:0x1500/noe/farcall/packcode -# "/farcall/packcode" are only useful for `large code' memory models -# but should be a "no-op" for small code models. - - -# variables -ZLIB_LIB = zlib_$(MODEL).lib - -OBJ1 = adler32.obj compress.obj crc32.obj deflate.obj gzclose.obj gzlib.obj gzread.obj -OBJ2 = gzwrite.obj infback.obj inffast.obj inflate.obj inftrees.obj trees.obj uncompr.obj zutil.obj - - -# targets -all: $(ZLIB_LIB) example.exe minigzip.exe - -.c.obj: - $(CC) -c $(LIB_CFLAGS) $*.c - -adler32.obj: adler32.c zlib.h zconf.h - -compress.obj: compress.c zlib.h zconf.h - -crc32.obj: crc32.c zlib.h zconf.h crc32.h - -deflate.obj: deflate.c deflate.h zutil.h zlib.h zconf.h - -gzclose.obj: gzclose.c zlib.h zconf.h gzguts.h - -gzlib.obj: gzlib.c zlib.h zconf.h gzguts.h - -gzread.obj: gzread.c zlib.h zconf.h gzguts.h - -gzwrite.obj: gzwrite.c zlib.h zconf.h gzguts.h - -infback.obj: infback.c zutil.h zlib.h zconf.h inftrees.h inflate.h \ - inffast.h inffixed.h - -inffast.obj: inffast.c zutil.h zlib.h zconf.h inftrees.h inflate.h \ - inffast.h - -inflate.obj: inflate.c zutil.h zlib.h zconf.h inftrees.h inflate.h \ - inffast.h inffixed.h - -inftrees.obj: inftrees.c zutil.h zlib.h zconf.h inftrees.h - -trees.obj: trees.c zutil.h zlib.h zconf.h deflate.h trees.h - -uncompr.obj: uncompr.c zlib.h zconf.h - -zutil.obj: zutil.c zutil.h zlib.h zconf.h - -example.obj: test/example.c zlib.h zconf.h - $(CC) -c $(CFLAGS) $*.c - -minigzip.obj: test/minigzip.c zlib.h zconf.h - $(CC) -c $(CFLAGS) $*.c - - -# the command line is cut to fit in the MS-DOS 128 byte limit: -$(ZLIB_LIB): $(OBJ1) $(OBJ2) - if exist $(ZLIB_LIB) del $(ZLIB_LIB) - lib $(ZLIB_LIB) $(OBJ1); - lib $(ZLIB_LIB) $(OBJ2); - -example.exe: example.obj $(ZLIB_LIB) - $(LD) $(LDFLAGS) example.obj,,,$(ZLIB_LIB); - -minigzip.exe: minigzip.obj $(ZLIB_LIB) - $(LD) $(LDFLAGS) minigzip.obj,,,$(ZLIB_LIB); - -test: example.exe minigzip.exe - example - echo hello world | minigzip | minigzip -d - -clean: - -del *.obj - -del *.lib - -del *.exe - -del *.map - -del zlib_*.bak - -del foo.gz DELETED compat/zlib/msdos/Makefile.tc Index: compat/zlib/msdos/Makefile.tc ================================================================== --- compat/zlib/msdos/Makefile.tc +++ /dev/null @@ -1,100 +0,0 @@ -# Makefile for zlib -# Turbo C 2.01, Turbo C++ 1.01 -# Last updated: 15-Mar-2003 - -# To use, do "make -fmakefile.tc" -# To compile in small model, set below: MODEL=s - -# WARNING: the small model is supported but only for small values of -# MAX_WBITS and MAX_MEM_LEVEL. For example: -# -DMAX_WBITS=11 -DMAX_MEM_LEVEL=3 -# If you wish to reduce the memory requirements (default 256K for big -# objects plus a few K), you can add to CFLAGS below: -# -DMAX_MEM_LEVEL=7 -DMAX_WBITS=14 -# See zconf.h for details about the memory requirements. - -# ------------ Turbo C 2.01, Turbo C++ 1.01 ------------ -MODEL=l -CC=tcc -LD=tcc -AR=tlib -# CFLAGS=-O2 -G -Z -m$(MODEL) -DMAX_WBITS=11 -DMAX_MEM_LEVEL=3 -CFLAGS=-O2 -G -Z -m$(MODEL) -LDFLAGS=-m$(MODEL) -f- - - -# variables -ZLIB_LIB = zlib_$(MODEL).lib - -OBJ1 = adler32.obj compress.obj crc32.obj deflate.obj gzclose.obj gzlib.obj gzread.obj -OBJ2 = gzwrite.obj infback.obj inffast.obj inflate.obj inftrees.obj trees.obj uncompr.obj zutil.obj -OBJP1 = +adler32.obj+compress.obj+crc32.obj+deflate.obj+gzclose.obj+gzlib.obj+gzread.obj -OBJP2 = +gzwrite.obj+infback.obj+inffast.obj+inflate.obj+inftrees.obj+trees.obj+uncompr.obj+zutil.obj - - -# targets -all: $(ZLIB_LIB) example.exe minigzip.exe - -.c.obj: - $(CC) -c $(CFLAGS) $*.c - -adler32.obj: adler32.c zlib.h zconf.h - -compress.obj: compress.c zlib.h zconf.h - -crc32.obj: crc32.c zlib.h zconf.h crc32.h - -deflate.obj: deflate.c deflate.h zutil.h zlib.h zconf.h - -gzclose.obj: gzclose.c zlib.h zconf.h gzguts.h - -gzlib.obj: gzlib.c zlib.h zconf.h gzguts.h - -gzread.obj: gzread.c zlib.h zconf.h gzguts.h - -gzwrite.obj: gzwrite.c zlib.h zconf.h gzguts.h - -infback.obj: infback.c zutil.h zlib.h zconf.h inftrees.h inflate.h \ - inffast.h inffixed.h - -inffast.obj: inffast.c zutil.h zlib.h zconf.h inftrees.h inflate.h \ - inffast.h - -inflate.obj: inflate.c zutil.h zlib.h zconf.h inftrees.h inflate.h \ - inffast.h inffixed.h - -inftrees.obj: inftrees.c zutil.h zlib.h zconf.h inftrees.h - -trees.obj: trees.c zutil.h zlib.h zconf.h deflate.h trees.h - -uncompr.obj: uncompr.c zlib.h zconf.h - -zutil.obj: zutil.c zutil.h zlib.h zconf.h - -example.obj: test/example.c zlib.h zconf.h - -minigzip.obj: test/minigzip.c zlib.h zconf.h - - -# the command line is cut to fit in the MS-DOS 128 byte limit: -$(ZLIB_LIB): $(OBJ1) $(OBJ2) - -del $(ZLIB_LIB) - $(AR) $(ZLIB_LIB) $(OBJP1) - $(AR) $(ZLIB_LIB) $(OBJP2) - -example.exe: example.obj $(ZLIB_LIB) - $(LD) $(LDFLAGS) example.obj $(ZLIB_LIB) - -minigzip.exe: minigzip.obj $(ZLIB_LIB) - $(LD) $(LDFLAGS) minigzip.obj $(ZLIB_LIB) - -test: example.exe minigzip.exe - example - echo hello world | minigzip | minigzip -d - -clean: - -del *.obj - -del *.lib - -del *.exe - -del zlib_*.bak - -del foo.gz DELETED compat/zlib/nintendods/Makefile Index: compat/zlib/nintendods/Makefile ================================================================== --- compat/zlib/nintendods/Makefile +++ /dev/null @@ -1,126 +0,0 @@ -#--------------------------------------------------------------------------------- -.SUFFIXES: -#--------------------------------------------------------------------------------- - -ifeq ($(strip $(DEVKITARM)),) -$(error "Please set DEVKITARM in your environment. export DEVKITARM=devkitARM") -endif - -include $(DEVKITARM)/ds_rules - -#--------------------------------------------------------------------------------- -# TARGET is the name of the output -# BUILD is the directory where object files & intermediate files will be placed -# SOURCES is a list of directories containing source code -# DATA is a list of directories containing data files -# INCLUDES is a list of directories containing header files -#--------------------------------------------------------------------------------- -TARGET := $(shell basename $(CURDIR)) -BUILD := build -SOURCES := ../../ -DATA := data -INCLUDES := include - -#--------------------------------------------------------------------------------- -# options for code generation -#--------------------------------------------------------------------------------- -ARCH := -mthumb -mthumb-interwork - -CFLAGS := -Wall -O2\ - -march=armv5te -mtune=arm946e-s \ - -fomit-frame-pointer -ffast-math \ - $(ARCH) - -CFLAGS += $(INCLUDE) -DARM9 -CXXFLAGS := $(CFLAGS) -fno-rtti -fno-exceptions - -ASFLAGS := $(ARCH) -march=armv5te -mtune=arm946e-s -LDFLAGS = -specs=ds_arm9.specs -g $(ARCH) -Wl,-Map,$(notdir $*.map) - -#--------------------------------------------------------------------------------- -# list of directories containing libraries, this must be the top level containing -# include and lib -#--------------------------------------------------------------------------------- -LIBDIRS := $(LIBNDS) - -#--------------------------------------------------------------------------------- -# no real need to edit anything past this point unless you need to add additional -# rules for different file extensions -#--------------------------------------------------------------------------------- -ifneq ($(BUILD),$(notdir $(CURDIR))) -#--------------------------------------------------------------------------------- - -export OUTPUT := $(CURDIR)/lib/libz.a - -export VPATH := $(foreach dir,$(SOURCES),$(CURDIR)/$(dir)) \ - $(foreach dir,$(DATA),$(CURDIR)/$(dir)) - -export DEPSDIR := $(CURDIR)/$(BUILD) - -CFILES := $(foreach dir,$(SOURCES),$(notdir $(wildcard $(dir)/*.c))) -CPPFILES := $(foreach dir,$(SOURCES),$(notdir $(wildcard $(dir)/*.cpp))) -SFILES := $(foreach dir,$(SOURCES),$(notdir $(wildcard $(dir)/*.s))) -BINFILES := $(foreach dir,$(DATA),$(notdir $(wildcard $(dir)/*.*))) - -#--------------------------------------------------------------------------------- -# use CXX for linking C++ projects, CC for standard C -#--------------------------------------------------------------------------------- -ifeq ($(strip $(CPPFILES)),) -#--------------------------------------------------------------------------------- - export LD := $(CC) -#--------------------------------------------------------------------------------- -else -#--------------------------------------------------------------------------------- - export LD := $(CXX) -#--------------------------------------------------------------------------------- -endif -#--------------------------------------------------------------------------------- - -export OFILES := $(addsuffix .o,$(BINFILES)) \ - $(CPPFILES:.cpp=.o) $(CFILES:.c=.o) $(SFILES:.s=.o) - -export INCLUDE := $(foreach dir,$(INCLUDES),-I$(CURDIR)/$(dir)) \ - $(foreach dir,$(LIBDIRS),-I$(dir)/include) \ - -I$(CURDIR)/$(BUILD) - -.PHONY: $(BUILD) clean all - -#--------------------------------------------------------------------------------- -all: $(BUILD) - @[ -d $@ ] || mkdir -p include - @cp ../../*.h include - -lib: - @[ -d $@ ] || mkdir -p $@ - -$(BUILD): lib - @[ -d $@ ] || mkdir -p $@ - @$(MAKE) --no-print-directory -C $(BUILD) -f $(CURDIR)/Makefile - -#--------------------------------------------------------------------------------- -clean: - @echo clean ... - @rm -fr $(BUILD) lib - -#--------------------------------------------------------------------------------- -else - -DEPENDS := $(OFILES:.o=.d) - -#--------------------------------------------------------------------------------- -# main targets -#--------------------------------------------------------------------------------- -$(OUTPUT) : $(OFILES) - -#--------------------------------------------------------------------------------- -%.bin.o : %.bin -#--------------------------------------------------------------------------------- - @echo $(notdir $<) - @$(bin2o) - - --include $(DEPENDS) - -#--------------------------------------------------------------------------------------- -endif -#--------------------------------------------------------------------------------------- DELETED compat/zlib/nintendods/README Index: compat/zlib/nintendods/README ================================================================== --- compat/zlib/nintendods/README +++ /dev/null @@ -1,5 +0,0 @@ -This Makefile requires devkitARM (http://www.devkitpro.org/category/devkitarm/) and works inside "contrib/nds". It is based on a devkitARM template. - -Eduardo Costa -January 3, 2009 - DELETED compat/zlib/old/Makefile.emx Index: compat/zlib/old/Makefile.emx ================================================================== --- compat/zlib/old/Makefile.emx +++ /dev/null @@ -1,69 +0,0 @@ -# Makefile for zlib. Modified for emx/rsxnt by Chr. Spieler, 6/16/98. -# Copyright (C) 1995-1998 Jean-loup Gailly. -# For conditions of distribution and use, see copyright notice in zlib.h - -# To compile, or to compile and test, type: -# -# make -fmakefile.emx; make test -fmakefile.emx -# - -CC=gcc -Zwin32 - -#CFLAGS=-MMD -O -#CFLAGS=-O -DMAX_WBITS=14 -DMAX_MEM_LEVEL=7 -#CFLAGS=-MMD -g -DZLIB_DEBUG -CFLAGS=-MMD -O3 $(BUTT) -Wall -Wwrite-strings -Wpointer-arith -Wconversion \ - -Wstrict-prototypes -Wmissing-prototypes - -# If cp.exe is available, replace "copy /Y" with "cp -fp" . -CP=copy /Y -# If gnu install.exe is available, replace $(CP) with ginstall. -INSTALL=$(CP) -# The default value of RM is "rm -f." If "rm.exe" is found, comment out: -RM=del -LDLIBS=-L. -lzlib -LD=$(CC) -s -o -LDSHARED=$(CC) - -INCL=zlib.h zconf.h -LIBS=zlib.a - -AR=ar rcs - -prefix=/usr/local -exec_prefix = $(prefix) - -OBJS = adler32.o compress.o crc32.o deflate.o gzclose.o gzlib.o gzread.o \ - gzwrite.o infback.o inffast.o inflate.o inftrees.o trees.o uncompr.o zutil.o - -TEST_OBJS = example.o minigzip.o - -all: example.exe minigzip.exe - -test: all - ./example - echo hello world | .\minigzip | .\minigzip -d - -%.o : %.c - $(CC) $(CFLAGS) -c $< -o $@ - -zlib.a: $(OBJS) - $(AR) $@ $(OBJS) - -%.exe : %.o $(LIBS) - $(LD) $@ $< $(LDLIBS) - - -.PHONY : clean - -clean: - $(RM) *.d - $(RM) *.o - $(RM) *.exe - $(RM) zlib.a - $(RM) foo.gz - -DEPS := $(wildcard *.d) -ifneq ($(DEPS),) -include $(DEPS) -endif DELETED compat/zlib/old/Makefile.riscos Index: compat/zlib/old/Makefile.riscos ================================================================== --- compat/zlib/old/Makefile.riscos +++ /dev/null @@ -1,151 +0,0 @@ -# Project: zlib_1_03 -# Patched for zlib 1.1.2 rw@shadow.org.uk 19980430 -# test works out-of-the-box, installs `somewhere' on demand - -# Toolflags: -CCflags = -c -depend !Depend -IC: -g -throwback -DRISCOS -fah -C++flags = -c -depend !Depend -IC: -throwback -Linkflags = -aif -c++ -o $@ -ObjAsmflags = -throwback -NoCache -depend !Depend -CMHGflags = -LibFileflags = -c -l -o $@ -Squeezeflags = -o $@ - -# change the line below to where _you_ want the library installed. -libdest = lib:zlib - -# Final targets: -@.lib: @.o.adler32 @.o.compress @.o.crc32 @.o.deflate @.o.gzio \ - @.o.infblock @.o.infcodes @.o.inffast @.o.inflate @.o.inftrees @.o.infutil @.o.trees \ - @.o.uncompr @.o.zutil - LibFile $(LibFileflags) @.o.adler32 @.o.compress @.o.crc32 @.o.deflate \ - @.o.gzio @.o.infblock @.o.infcodes @.o.inffast @.o.inflate @.o.inftrees @.o.infutil \ - @.o.trees @.o.uncompr @.o.zutil -test: @.minigzip @.example @.lib - @copy @.lib @.libc A~C~DF~L~N~P~Q~RS~TV - @echo running tests: hang on. - @/@.minigzip -f -9 libc - @/@.minigzip -d libc-gz - @/@.minigzip -f -1 libc - @/@.minigzip -d libc-gz - @/@.minigzip -h -9 libc - @/@.minigzip -d libc-gz - @/@.minigzip -h -1 libc - @/@.minigzip -d libc-gz - @/@.minigzip -9 libc - @/@.minigzip -d libc-gz - @/@.minigzip -1 libc - @/@.minigzip -d libc-gz - @diff @.lib @.libc - @echo that should have reported '@.lib and @.libc identical' if you have diff. - @/@.example @.fred @.fred - @echo that will have given lots of hello!'s. - -@.minigzip: @.o.minigzip @.lib C:o.Stubs - Link $(Linkflags) @.o.minigzip @.lib C:o.Stubs -@.example: @.o.example @.lib C:o.Stubs - Link $(Linkflags) @.o.example @.lib C:o.Stubs - -install: @.lib - cdir $(libdest) - cdir $(libdest).h - @copy @.h.zlib $(libdest).h.zlib A~C~DF~L~N~P~Q~RS~TV - @copy @.h.zconf $(libdest).h.zconf A~C~DF~L~N~P~Q~RS~TV - @copy @.lib $(libdest).lib A~C~DF~L~N~P~Q~RS~TV - @echo okay, installed zlib in $(libdest) - -clean:; remove @.minigzip - remove @.example - remove @.libc - -wipe @.o.* F~r~cV - remove @.fred - -# User-editable dependencies: -.c.o: - cc $(ccflags) -o $@ $< - -# Static dependencies: - -# Dynamic dependencies: -o.example: c.example -o.example: h.zlib -o.example: h.zconf -o.minigzip: c.minigzip -o.minigzip: h.zlib -o.minigzip: h.zconf -o.adler32: c.adler32 -o.adler32: h.zlib -o.adler32: h.zconf -o.compress: c.compress -o.compress: h.zlib -o.compress: h.zconf -o.crc32: c.crc32 -o.crc32: h.zlib -o.crc32: h.zconf -o.deflate: c.deflate -o.deflate: h.deflate -o.deflate: h.zutil -o.deflate: h.zlib -o.deflate: h.zconf -o.gzio: c.gzio -o.gzio: h.zutil -o.gzio: h.zlib -o.gzio: h.zconf -o.infblock: c.infblock -o.infblock: h.zutil -o.infblock: h.zlib -o.infblock: h.zconf -o.infblock: h.infblock -o.infblock: h.inftrees -o.infblock: h.infcodes -o.infblock: h.infutil -o.infcodes: c.infcodes -o.infcodes: h.zutil -o.infcodes: h.zlib -o.infcodes: h.zconf -o.infcodes: h.inftrees -o.infcodes: h.infblock -o.infcodes: h.infcodes -o.infcodes: h.infutil -o.infcodes: h.inffast -o.inffast: c.inffast -o.inffast: h.zutil -o.inffast: h.zlib -o.inffast: h.zconf -o.inffast: h.inftrees -o.inffast: h.infblock -o.inffast: h.infcodes -o.inffast: h.infutil -o.inffast: h.inffast -o.inflate: c.inflate -o.inflate: h.zutil -o.inflate: h.zlib -o.inflate: h.zconf -o.inflate: h.infblock -o.inftrees: c.inftrees -o.inftrees: h.zutil -o.inftrees: h.zlib -o.inftrees: h.zconf -o.inftrees: h.inftrees -o.inftrees: h.inffixed -o.infutil: c.infutil -o.infutil: h.zutil -o.infutil: h.zlib -o.infutil: h.zconf -o.infutil: h.infblock -o.infutil: h.inftrees -o.infutil: h.infcodes -o.infutil: h.infutil -o.trees: c.trees -o.trees: h.deflate -o.trees: h.zutil -o.trees: h.zlib -o.trees: h.zconf -o.trees: h.trees -o.uncompr: c.uncompr -o.uncompr: h.zlib -o.uncompr: h.zconf -o.zutil: c.zutil -o.zutil: h.zutil -o.zutil: h.zlib -o.zutil: h.zconf DELETED compat/zlib/old/README Index: compat/zlib/old/README ================================================================== --- compat/zlib/old/README +++ /dev/null @@ -1,3 +0,0 @@ -This directory contains files that have not been updated for zlib 1.2.x - -(Volunteers are encouraged to help clean this up. Thanks.) DELETED compat/zlib/old/descrip.mms Index: compat/zlib/old/descrip.mms ================================================================== --- compat/zlib/old/descrip.mms +++ /dev/null @@ -1,48 +0,0 @@ -# descrip.mms: MMS description file for building zlib on VMS -# written by Martin P.J. Zinser - -cc_defs = -c_deb = - -.ifdef __DECC__ -pref = /prefix=all -.endif - -OBJS = adler32.obj, compress.obj, crc32.obj, gzio.obj, uncompr.obj,\ - deflate.obj, trees.obj, zutil.obj, inflate.obj, infblock.obj,\ - inftrees.obj, infcodes.obj, infutil.obj, inffast.obj - -CFLAGS= $(C_DEB) $(CC_DEFS) $(PREF) - -all : example.exe minigzip.exe - @ write sys$output " Example applications available" -libz.olb : libz.olb($(OBJS)) - @ write sys$output " libz available" - -example.exe : example.obj libz.olb - link example,libz.olb/lib - -minigzip.exe : minigzip.obj libz.olb - link minigzip,libz.olb/lib,x11vms:xvmsutils.olb/lib - -clean : - delete *.obj;*,libz.olb;* - - -# Other dependencies. -adler32.obj : zutil.h zlib.h zconf.h -compress.obj : zlib.h zconf.h -crc32.obj : zutil.h zlib.h zconf.h -deflate.obj : deflate.h zutil.h zlib.h zconf.h -example.obj : zlib.h zconf.h -gzio.obj : zutil.h zlib.h zconf.h -infblock.obj : zutil.h zlib.h zconf.h infblock.h inftrees.h infcodes.h infutil.h -infcodes.obj : zutil.h zlib.h zconf.h inftrees.h infutil.h infcodes.h inffast.h -inffast.obj : zutil.h zlib.h zconf.h inftrees.h infutil.h inffast.h -inflate.obj : zutil.h zlib.h zconf.h infblock.h -inftrees.obj : zutil.h zlib.h zconf.h inftrees.h -infutil.obj : zutil.h zlib.h zconf.h inftrees.h infutil.h -minigzip.obj : zlib.h zconf.h -trees.obj : deflate.h zutil.h zlib.h zconf.h -uncompr.obj : zlib.h zconf.h -zutil.obj : zutil.h zlib.h zconf.h DELETED compat/zlib/old/os2/Makefile.os2 Index: compat/zlib/old/os2/Makefile.os2 ================================================================== --- compat/zlib/old/os2/Makefile.os2 +++ /dev/null @@ -1,136 +0,0 @@ -# Makefile for zlib under OS/2 using GCC (PGCC) -# For conditions of distribution and use, see copyright notice in zlib.h - -# To compile and test, type: -# cp Makefile.os2 .. -# cd .. -# make -f Makefile.os2 test - -# This makefile will build a static library z.lib, a shared library -# z.dll and a import library zdll.lib. You can use either z.lib or -# zdll.lib by specifying either -lz or -lzdll on gcc's command line - -CC=gcc -Zomf -s - -CFLAGS=-O6 -Wall -#CFLAGS=-O -DMAX_WBITS=14 -DMAX_MEM_LEVEL=7 -#CFLAGS=-g -DZLIB_DEBUG -#CFLAGS=-O3 -Wall -Wwrite-strings -Wpointer-arith -Wconversion \ -# -Wstrict-prototypes -Wmissing-prototypes - -#################### BUG WARNING: ##################### -## infcodes.c hits a bug in pgcc-1.0, so you have to use either -## -O# where # <= 4 or one of (-fno-ommit-frame-pointer or -fno-force-mem) -## This bug is reportedly fixed in pgcc >1.0, but this was not tested -CFLAGS+=-fno-force-mem - -LDFLAGS=-s -L. -lzdll -Zcrtdll -LDSHARED=$(CC) -s -Zomf -Zdll -Zcrtdll - -VER=1.1.0 -ZLIB=z.lib -SHAREDLIB=z.dll -SHAREDLIBIMP=zdll.lib -LIBS=$(ZLIB) $(SHAREDLIB) $(SHAREDLIBIMP) - -AR=emxomfar cr -IMPLIB=emximp -RANLIB=echo -TAR=tar -SHELL=bash - -prefix=/usr/local -exec_prefix = $(prefix) - -OBJS = adler32.o compress.o crc32.o gzio.o uncompr.o deflate.o trees.o \ - zutil.o inflate.o infblock.o inftrees.o infcodes.o infutil.o inffast.o - -TEST_OBJS = example.o minigzip.o - -DISTFILES = README INDEX ChangeLog configure Make*[a-z0-9] *.[ch] descrip.mms \ - algorithm.txt zlib.3 msdos/Make*[a-z0-9] msdos/zlib.def msdos/zlib.rc \ - nt/Makefile.nt nt/zlib.dnt contrib/README.contrib contrib/*.txt \ - contrib/asm386/*.asm contrib/asm386/*.c \ - contrib/asm386/*.bat contrib/asm386/zlibvc.d?? contrib/iostream/*.cpp \ - contrib/iostream/*.h contrib/iostream2/*.h contrib/iostream2/*.cpp \ - contrib/untgz/Makefile contrib/untgz/*.c contrib/untgz/*.w32 - -all: example.exe minigzip.exe - -test: all - @LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ; export LD_LIBRARY_PATH; \ - echo hello world | ./minigzip | ./minigzip -d || \ - echo ' *** minigzip test FAILED ***' ; \ - if ./example; then \ - echo ' *** zlib test OK ***'; \ - else \ - echo ' *** zlib test FAILED ***'; \ - fi - -$(ZLIB): $(OBJS) - $(AR) $@ $(OBJS) - -@ ($(RANLIB) $@ || true) >/dev/null 2>&1 - -$(SHAREDLIB): $(OBJS) os2/z.def - $(LDSHARED) -o $@ $^ - -$(SHAREDLIBIMP): os2/z.def - $(IMPLIB) -o $@ $^ - -example.exe: example.o $(LIBS) - $(CC) $(CFLAGS) -o $@ example.o $(LDFLAGS) - -minigzip.exe: minigzip.o $(LIBS) - $(CC) $(CFLAGS) -o $@ minigzip.o $(LDFLAGS) - -clean: - rm -f *.o *~ example minigzip libz.a libz.so* foo.gz - -distclean: clean - -zip: - mv Makefile Makefile~; cp -p Makefile.in Makefile - rm -f test.c ztest*.c - v=`sed -n -e 's/\.//g' -e '/VERSION "/s/.*"\(.*\)".*/\1/p' < zlib.h`;\ - zip -ul9 zlib$$v $(DISTFILES) - mv Makefile~ Makefile - -dist: - mv Makefile Makefile~; cp -p Makefile.in Makefile - rm -f test.c ztest*.c - d=zlib-`sed -n '/VERSION "/s/.*"\(.*\)".*/\1/p' < zlib.h`;\ - rm -f $$d.tar.gz; \ - if test ! -d ../$$d; then rm -f ../$$d; ln -s `pwd` ../$$d; fi; \ - files=""; \ - for f in $(DISTFILES); do files="$$files $$d/$$f"; done; \ - cd ..; \ - GZIP=-9 $(TAR) chofz $$d/$$d.tar.gz $$files; \ - if test ! -d $$d; then rm -f $$d; fi - mv Makefile~ Makefile - -tags: - etags *.[ch] - -depend: - makedepend -- $(CFLAGS) -- *.[ch] - -# DO NOT DELETE THIS LINE -- make depend depends on it. - -adler32.o: zlib.h zconf.h -compress.o: zlib.h zconf.h -crc32.o: zlib.h zconf.h -deflate.o: deflate.h zutil.h zlib.h zconf.h -example.o: zlib.h zconf.h -gzio.o: zutil.h zlib.h zconf.h -infblock.o: infblock.h inftrees.h infcodes.h infutil.h zutil.h zlib.h zconf.h -infcodes.o: zutil.h zlib.h zconf.h -infcodes.o: inftrees.h infblock.h infcodes.h infutil.h inffast.h -inffast.o: zutil.h zlib.h zconf.h inftrees.h -inffast.o: infblock.h infcodes.h infutil.h inffast.h -inflate.o: zutil.h zlib.h zconf.h infblock.h -inftrees.o: zutil.h zlib.h zconf.h inftrees.h -infutil.o: zutil.h zlib.h zconf.h infblock.h inftrees.h infcodes.h infutil.h -minigzip.o: zlib.h zconf.h -trees.o: deflate.h zutil.h zlib.h zconf.h trees.h -uncompr.o: zlib.h zconf.h -zutil.o: zutil.h zlib.h zconf.h DELETED compat/zlib/old/os2/zlib.def Index: compat/zlib/old/os2/zlib.def ================================================================== --- compat/zlib/old/os2/zlib.def +++ /dev/null @@ -1,51 +0,0 @@ -; -; Slightly modified version of ../nt/zlib.dnt :-) -; - -LIBRARY Z -DESCRIPTION "Zlib compression library for OS/2" -CODE PRELOAD MOVEABLE DISCARDABLE -DATA PRELOAD MOVEABLE MULTIPLE - -EXPORTS - adler32 - compress - crc32 - deflate - deflateCopy - deflateEnd - deflateInit2_ - deflateInit_ - deflateParams - deflateReset - deflateSetDictionary - gzclose - gzdopen - gzerror - gzflush - gzopen - gzread - gzwrite - inflate - inflateEnd - inflateInit2_ - inflateInit_ - inflateReset - inflateSetDictionary - inflateSync - uncompress - zlibVersion - gzprintf - gzputc - gzgetc - gzseek - gzrewind - gztell - gzeof - gzsetparams - zError - inflateSyncPoint - get_crc_table - compress2 - gzputs - gzgets DELETED compat/zlib/old/visual-basic.txt Index: compat/zlib/old/visual-basic.txt ================================================================== --- compat/zlib/old/visual-basic.txt +++ /dev/null @@ -1,160 +0,0 @@ -See below some functions declarations for Visual Basic. - -Frequently Asked Question: - -Q: Each time I use the compress function I get the -5 error (not enough - room in the output buffer). - -A: Make sure that the length of the compressed buffer is passed by - reference ("as any"), not by value ("as long"). Also check that - before the call of compress this length is equal to the total size of - the compressed buffer and not zero. - - -From: "Jon Caruana" -Subject: Re: How to port zlib declares to vb? -Date: Mon, 28 Oct 1996 18:33:03 -0600 - -Got the answer! (I haven't had time to check this but it's what I got, and -looks correct): - -He has the following routines working: - compress - uncompress - gzopen - gzwrite - gzread - gzclose - -Declares follow: (Quoted from Carlos Rios , in Vb4 form) - -#If Win16 Then 'Use Win16 calls. -Declare Function compress Lib "ZLIB.DLL" (ByVal compr As - String, comprLen As Any, ByVal buf As String, ByVal buflen - As Long) As Integer -Declare Function uncompress Lib "ZLIB.DLL" (ByVal uncompr - As String, uncomprLen As Any, ByVal compr As String, ByVal - lcompr As Long) As Integer -Declare Function gzopen Lib "ZLIB.DLL" (ByVal filePath As - String, ByVal mode As String) As Long -Declare Function gzread Lib "ZLIB.DLL" (ByVal file As - Long, ByVal uncompr As String, ByVal uncomprLen As Integer) - As Integer -Declare Function gzwrite Lib "ZLIB.DLL" (ByVal file As - Long, ByVal uncompr As String, ByVal uncomprLen As Integer) - As Integer -Declare Function gzclose Lib "ZLIB.DLL" (ByVal file As - Long) As Integer -#Else -Declare Function compress Lib "ZLIB32.DLL" - (ByVal compr As String, comprLen As Any, ByVal buf As - String, ByVal buflen As Long) As Integer -Declare Function uncompress Lib "ZLIB32.DLL" - (ByVal uncompr As String, uncomprLen As Any, ByVal compr As - String, ByVal lcompr As Long) As Long -Declare Function gzopen Lib "ZLIB32.DLL" - (ByVal file As String, ByVal mode As String) As Long -Declare Function gzread Lib "ZLIB32.DLL" - (ByVal file As Long, ByVal uncompr As String, ByVal - uncomprLen As Long) As Long -Declare Function gzwrite Lib "ZLIB32.DLL" - (ByVal file As Long, ByVal uncompr As String, ByVal - uncomprLen As Long) As Long -Declare Function gzclose Lib "ZLIB32.DLL" - (ByVal file As Long) As Long -#End If - --Jon Caruana -jon-net@usa.net -Microsoft Sitebuilder Network Level 1 Member - HTML Writer's Guild Member - - -Here is another example from Michael that he -says conforms to the VB guidelines, and that solves the problem of not -knowing the uncompressed size by storing it at the end of the file: - -'Calling the functions: -'bracket meaning: [optional] {Range of possible values} -'Call subCompressFile( [, , [level of compression {1..9}]]) -'Call subUncompressFile() - -Option Explicit -Private lngpvtPcnSml As Long 'Stores value for 'lngPercentSmaller' -Private Const SUCCESS As Long = 0 -Private Const strFilExt As String = ".cpr" -Private Declare Function lngfncCpr Lib "zlib.dll" Alias "compress2" (ByRef -dest As Any, ByRef destLen As Any, ByRef src As Any, ByVal srcLen As Long, -ByVal level As Integer) As Long -Private Declare Function lngfncUcp Lib "zlib.dll" Alias "uncompress" (ByRef -dest As Any, ByRef destLen As Any, ByRef src As Any, ByVal srcLen As Long) -As Long - -Public Sub subCompressFile(ByVal strargOriFilPth As String, Optional ByVal -strargCprFilPth As String, Optional ByVal intLvl As Integer = 9) - Dim strCprPth As String - Dim lngOriSiz As Long - Dim lngCprSiz As Long - Dim bytaryOri() As Byte - Dim bytaryCpr() As Byte - lngOriSiz = FileLen(strargOriFilPth) - ReDim bytaryOri(lngOriSiz - 1) - Open strargOriFilPth For Binary Access Read As #1 - Get #1, , bytaryOri() - Close #1 - strCprPth = IIf(strargCprFilPth = "", strargOriFilPth, strargCprFilPth) -'Select file path and name - strCprPth = strCprPth & IIf(Right(strCprPth, Len(strFilExt)) = -strFilExt, "", strFilExt) 'Add file extension if not exists - lngCprSiz = (lngOriSiz * 1.01) + 12 'Compression needs temporary a bit -more space then original file size - ReDim bytaryCpr(lngCprSiz - 1) - If lngfncCpr(bytaryCpr(0), lngCprSiz, bytaryOri(0), lngOriSiz, intLvl) = -SUCCESS Then - lngpvtPcnSml = (1# - (lngCprSiz / lngOriSiz)) * 100 - ReDim Preserve bytaryCpr(lngCprSiz - 1) - Open strCprPth For Binary Access Write As #1 - Put #1, , bytaryCpr() - Put #1, , lngOriSiz 'Add the the original size value to the end -(last 4 bytes) - Close #1 - Else - MsgBox "Compression error" - End If - Erase bytaryCpr - Erase bytaryOri -End Sub - -Public Sub subUncompressFile(ByVal strargFilPth As String) - Dim bytaryCpr() As Byte - Dim bytaryOri() As Byte - Dim lngOriSiz As Long - Dim lngCprSiz As Long - Dim strOriPth As String - lngCprSiz = FileLen(strargFilPth) - ReDim bytaryCpr(lngCprSiz - 1) - Open strargFilPth For Binary Access Read As #1 - Get #1, , bytaryCpr() - Close #1 - 'Read the original file size value: - lngOriSiz = bytaryCpr(lngCprSiz - 1) * (2 ^ 24) _ - + bytaryCpr(lngCprSiz - 2) * (2 ^ 16) _ - + bytaryCpr(lngCprSiz - 3) * (2 ^ 8) _ - + bytaryCpr(lngCprSiz - 4) - ReDim Preserve bytaryCpr(lngCprSiz - 5) 'Cut of the original size value - ReDim bytaryOri(lngOriSiz - 1) - If lngfncUcp(bytaryOri(0), lngOriSiz, bytaryCpr(0), lngCprSiz) = SUCCESS -Then - strOriPth = Left(strargFilPth, Len(strargFilPth) - Len(strFilExt)) - Open strOriPth For Binary Access Write As #1 - Put #1, , bytaryOri() - Close #1 - Else - MsgBox "Uncompression error" - End If - Erase bytaryCpr - Erase bytaryOri -End Sub -Public Property Get lngPercentSmaller() As Long - lngPercentSmaller = lngpvtPcnSml -End Property DELETED compat/zlib/os400/README400 Index: compat/zlib/os400/README400 ================================================================== --- compat/zlib/os400/README400 +++ /dev/null @@ -1,48 +0,0 @@ - ZLIB version 1.2.11 for OS/400 installation instructions - -1) Download and unpack the zlib tarball to some IFS directory. - (i.e.: /path/to/the/zlib/ifs/source/directory) - - If the installed IFS command suppors gzip format, this is straightforward, -else you have to unpack first to some directory on a system supporting it, -then move the whole directory to the IFS via the network (via SMB or FTP). - -2) Edit the configuration parameters in the compilation script. - - EDTF STMF('/path/to/the/zlib/ifs/source/directory/os400/make.sh') - -Tune the parameters according to your needs if not matching the defaults. -Save the file and exit after edition. - -3) Enter qshell, then work in the zlib OS/400 specific directory. - - QSH - cd /path/to/the/zlib/ifs/source/directory/os400 - -4) Compile and install - - sh make.sh - -The script will: -- create the libraries, objects and IFS directories for the zlib environment, -- compile all modules, -- create a service program, -- create a static and a dynamic binding directory, -- install header files for C/C++ and for ILE/RPG, both for compilation in - DB2 and IFS environments. - -That's all. - - -Notes: For OS/400 ILE RPG programmers, a /copy member defining the ZLIB - API prototypes for ILE RPG can be found in ZLIB/H(ZLIB.INC). - In the ILE environment, the same definitions are available from - file zlib.inc located in the same IFS include directory as the - C/C++ header files. - Please read comments in this member for more information. - - Remember that most foreign textual data are ASCII coded: this - implementation does not handle conversion from/to ASCII, so - text data code conversions must be done explicitely. - - Mainly for the reason above, always open zipped files in binary mode. DELETED compat/zlib/os400/bndsrc Index: compat/zlib/os400/bndsrc ================================================================== --- compat/zlib/os400/bndsrc +++ /dev/null @@ -1,119 +0,0 @@ -STRPGMEXP PGMLVL(*CURRENT) SIGNATURE('ZLIB') - -/*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*/ -/* Version 1.1.3 entry points. */ -/*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*/ - - EXPORT SYMBOL("adler32") - EXPORT SYMBOL("compress") - EXPORT SYMBOL("compress2") - EXPORT SYMBOL("crc32") - EXPORT SYMBOL("get_crc_table") - EXPORT SYMBOL("deflate") - EXPORT SYMBOL("deflateEnd") - EXPORT SYMBOL("deflateSetDictionary") - EXPORT SYMBOL("deflateCopy") - EXPORT SYMBOL("deflateReset") - EXPORT SYMBOL("deflateParams") - EXPORT SYMBOL("deflatePrime") - EXPORT SYMBOL("deflateInit_") - EXPORT SYMBOL("deflateInit2_") - EXPORT SYMBOL("gzopen") - EXPORT SYMBOL("gzdopen") - EXPORT SYMBOL("gzsetparams") - EXPORT SYMBOL("gzread") - EXPORT SYMBOL("gzwrite") - EXPORT SYMBOL("gzprintf") - EXPORT SYMBOL("gzputs") - EXPORT SYMBOL("gzgets") - EXPORT SYMBOL("gzputc") - EXPORT SYMBOL("gzgetc") - EXPORT SYMBOL("gzflush") - EXPORT SYMBOL("gzseek") - EXPORT SYMBOL("gzrewind") - EXPORT SYMBOL("gztell") - EXPORT SYMBOL("gzeof") - EXPORT SYMBOL("gzclose") - EXPORT SYMBOL("gzerror") - EXPORT SYMBOL("inflate") - EXPORT SYMBOL("inflateEnd") - EXPORT SYMBOL("inflateSetDictionary") - EXPORT SYMBOL("inflateSync") - EXPORT SYMBOL("inflateReset") - EXPORT SYMBOL("inflateInit_") - EXPORT SYMBOL("inflateInit2_") - EXPORT SYMBOL("inflateSyncPoint") - EXPORT SYMBOL("uncompress") - EXPORT SYMBOL("zlibVersion") - EXPORT SYMBOL("zError") - EXPORT SYMBOL("z_errmsg") - -/*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*/ -/* Version 1.2.1 additional entry points. */ -/*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*/ - - EXPORT SYMBOL("compressBound") - EXPORT SYMBOL("deflateBound") - EXPORT SYMBOL("deflatePending") - EXPORT SYMBOL("gzungetc") - EXPORT SYMBOL("gzclearerr") - EXPORT SYMBOL("inflateBack") - EXPORT SYMBOL("inflateBackEnd") - EXPORT SYMBOL("inflateBackInit_") - EXPORT SYMBOL("inflateCopy") - EXPORT SYMBOL("zlibCompileFlags") - -/*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*/ -/* Version 1.2.4 additional entry points. */ -/*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*/ - - EXPORT SYMBOL("adler32_combine") - EXPORT SYMBOL("adler32_combine64") - EXPORT SYMBOL("crc32_combine") - EXPORT SYMBOL("crc32_combine64") - EXPORT SYMBOL("deflateSetHeader") - EXPORT SYMBOL("deflateTune") - EXPORT SYMBOL("gzbuffer") - EXPORT SYMBOL("gzclose_r") - EXPORT SYMBOL("gzclose_w") - EXPORT SYMBOL("gzdirect") - EXPORT SYMBOL("gzoffset") - EXPORT SYMBOL("gzoffset64") - EXPORT SYMBOL("gzopen64") - EXPORT SYMBOL("gzseek64") - EXPORT SYMBOL("gztell64") - EXPORT SYMBOL("inflateGetHeader") - EXPORT SYMBOL("inflateMark") - EXPORT SYMBOL("inflatePrime") - EXPORT SYMBOL("inflateReset2") - EXPORT SYMBOL("inflateUndermine") - -/*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*/ -/* Version 1.2.6 additional entry points. */ -/*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*/ - - EXPORT SYMBOL("deflateResetKeep") - EXPORT SYMBOL("gzgetc_") - EXPORT SYMBOL("inflateResetKeep") - -/*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*/ -/* Version 1.2.8 additional entry points. */ -/*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*/ - - EXPORT SYMBOL("gzvprintf") - EXPORT SYMBOL("inflateGetDictionary") - -/*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*/ -/* Version 1.2.9 additional entry points. */ -/*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*/ - - EXPORT SYMBOL("adler32_z") - EXPORT SYMBOL("crc32_z") - EXPORT SYMBOL("deflateGetDictionary") - EXPORT SYMBOL("gzfread") - EXPORT SYMBOL("gzfwrite") - EXPORT SYMBOL("inflateCodesUsed") - EXPORT SYMBOL("inflateValidate") - EXPORT SYMBOL("uncompress2") - -ENDPGMEXP DELETED compat/zlib/os400/make.sh Index: compat/zlib/os400/make.sh ================================================================== --- compat/zlib/os400/make.sh +++ /dev/null @@ -1,366 +0,0 @@ -#!/bin/sh -# -# ZLIB compilation script for the OS/400. -# -# -# This is a shell script since make is not a standard component of OS/400. - - -################################################################################ -# -# Tunable configuration parameters. -# -################################################################################ - -TARGETLIB='ZLIB' # Target OS/400 program library -STATBNDDIR='ZLIB_A' # Static binding directory. -DYNBNDDIR='ZLIB' # Dynamic binding directory. -SRVPGM="ZLIB" # Service program. -IFSDIR='/zlib' # IFS support base directory. -TGTCCSID='500' # Target CCSID of objects -DEBUG='*NONE' # Debug level -OPTIMIZE='40' # Optimisation level -OUTPUT='*NONE' # Compilation output option. -TGTRLS='V6R1M0' # Target OS release - -export TARGETLIB STATBNDDIR DYNBNDDIR SRVPGM IFSDIR -export TGTCCSID DEBUG OPTIMIZE OUTPUT TGTRLS - - -################################################################################ -# -# OS/400 specific definitions. -# -################################################################################ - -LIBIFSNAME="/QSYS.LIB/${TARGETLIB}.LIB" - - -################################################################################ -# -# Procedures. -# -################################################################################ - -# action_needed dest [src] -# -# dest is an object to build -# if specified, src is an object on which dest depends. -# -# exit 0 (succeeds) if some action has to be taken, else 1. - -action_needed() - -{ - [ ! -e "${1}" ] && return 0 - [ "${2}" ] || return 1 - [ "${1}" -ot "${2}" ] && return 0 - return 1 -} - - -# make_module module_name source_name [additional_definitions] -# -# Compile source name into module if needed. -# As side effect, append the module name to variable MODULES. -# Set LINK to "YES" if the module has been compiled. - -make_module() - -{ - MODULES="${MODULES} ${1}" - MODIFSNAME="${LIBIFSNAME}/${1}.MODULE" - CSRC="`basename \"${2}\"`" - - if action_needed "${MODIFSNAME}" "${2}" - then : - elif [ ! "`sed -e \"//,/<\\\\/source>/!d\" \ - -e '/ tmphdrfile - - # Need to translate to target CCSID. - - CMD="CPY OBJ('`pwd`/tmphdrfile') TOOBJ('${DEST}')" - CMD="${CMD} TOCCSID(${TGTCCSID}) DTAFMT(*TEXT) REPLACE(*YES)" - system "${CMD}" - # touch -r "${HFILE}" "${DEST}" - rm -f tmphdrfile - fi - - IFSFILE="${IFSDIR}/include/`basename \"${HFILE}\"`" - - if action_needed "${IFSFILE}" "${DEST}" - then rm -f "${IFSFILE}" - ln -s "${DEST}" "${IFSFILE}" - fi -done - - -# Install the ILE/RPG header file. - - -HFILE="${SCRIPTDIR}/zlib.inc" -DEST="${SRCPF}/ZLIB.INC.MBR" - -if action_needed "${DEST}" "${HFILE}" -then CMD="CPY OBJ('${HFILE}') TOOBJ('${DEST}')" - CMD="${CMD} TOCCSID(${TGTCCSID}) DTAFMT(*TEXT) REPLACE(*YES)" - system "${CMD}" - # touch -r "${HFILE}" "${DEST}" -fi - -IFSFILE="${IFSDIR}/include/`basename \"${HFILE}\"`" - -if action_needed "${IFSFILE}" "${DEST}" -then rm -f "${IFSFILE}" - ln -s "${DEST}" "${IFSFILE}" -fi - - -# Create and compile the identification source file. - -echo '#pragma comment(user, "ZLIB version '"${VERSION}"'")' > os400.c -echo '#pragma comment(user, __DATE__)' >> os400.c -echo '#pragma comment(user, __TIME__)' >> os400.c -echo '#pragma comment(copyright, "Copyright (C) 1995-2017 Jean-Loup Gailly, Mark Adler. OS/400 version by P. Monnerat.")' >> os400.c -make_module OS400 os400.c -LINK= # No need to rebuild service program yet. -MODULES= - - -# Get source list. - -CSOURCES=`sed -e '/ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Library - - Medium - - 2.0 - - - - zlib - zlib - alain.bonnefoy@icbt.com - Public - public - www.gzip.org/zlib - - - Jean-Loup Gailly,Mark Adler - www.gzip.org/zlib - - zlib@gzip.org - - - A massively spiffy yet delicately unobtrusive compression library. - zlib is designed to be a free, general-purpose, legally unencumbered, lossless data compression library for use on virtually any computer hardware and operating system. - http://www.gzip.org/zlib - - - - - 1.2.11 - Medium - Stable - - - - - - - No License - - - - Software Development/Libraries and Extensions/C Libraries - zlib,compression - qnx6 - qnx6 - None - Developer - - - - - - - - - - - - - - Install - Post - No - Ignore - - No - Optional - - - - - - - - - - - - - InstallOver - zlib - - - - - - - - - - - - - InstallOver - zlib-dev - - - - - - - - - DELETED compat/zlib/test/example.c Index: compat/zlib/test/example.c ================================================================== --- compat/zlib/test/example.c +++ /dev/null @@ -1,602 +0,0 @@ -/* example.c -- usage example of the zlib compression library - * Copyright (C) 1995-2006, 2011, 2016 Jean-loup Gailly - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -/* @(#) $Id$ */ - -#include "zlib.h" -#include - -#ifdef STDC -# include -# include -#endif - -#if defined(VMS) || defined(RISCOS) -# define TESTFILE "foo-gz" -#else -# define TESTFILE "foo.gz" -#endif - -#define CHECK_ERR(err, msg) { \ - if (err != Z_OK) { \ - fprintf(stderr, "%s error: %d\n", msg, err); \ - exit(1); \ - } \ -} - -static z_const char hello[] = "hello, hello!"; -/* "hello world" would be more standard, but the repeated "hello" - * stresses the compression code better, sorry... - */ - -static const char dictionary[] = "hello"; -static uLong dictId; /* Adler32 value of the dictionary */ - -void test_deflate OF((Byte *compr, uLong comprLen)); -void test_inflate OF((Byte *compr, uLong comprLen, - Byte *uncompr, uLong uncomprLen)); -void test_large_deflate OF((Byte *compr, uLong comprLen, - Byte *uncompr, uLong uncomprLen)); -void test_large_inflate OF((Byte *compr, uLong comprLen, - Byte *uncompr, uLong uncomprLen)); -void test_flush OF((Byte *compr, uLong *comprLen)); -void test_sync OF((Byte *compr, uLong comprLen, - Byte *uncompr, uLong uncomprLen)); -void test_dict_deflate OF((Byte *compr, uLong comprLen)); -void test_dict_inflate OF((Byte *compr, uLong comprLen, - Byte *uncompr, uLong uncomprLen)); -int main OF((int argc, char *argv[])); - - -#ifdef Z_SOLO - -void *myalloc OF((void *, unsigned, unsigned)); -void myfree OF((void *, void *)); - -void *myalloc(q, n, m) - void *q; - unsigned n, m; -{ - (void)q; - return calloc(n, m); -} - -void myfree(void *q, void *p) -{ - (void)q; - free(p); -} - -static alloc_func zalloc = myalloc; -static free_func zfree = myfree; - -#else /* !Z_SOLO */ - -static alloc_func zalloc = (alloc_func)0; -static free_func zfree = (free_func)0; - -void test_compress OF((Byte *compr, uLong comprLen, - Byte *uncompr, uLong uncomprLen)); -void test_gzio OF((const char *fname, - Byte *uncompr, uLong uncomprLen)); - -/* =========================================================================== - * Test compress() and uncompress() - */ -void test_compress(compr, comprLen, uncompr, uncomprLen) - Byte *compr, *uncompr; - uLong comprLen, uncomprLen; -{ - int err; - uLong len = (uLong)strlen(hello)+1; - - err = compress(compr, &comprLen, (const Bytef*)hello, len); - CHECK_ERR(err, "compress"); - - strcpy((char*)uncompr, "garbage"); - - err = uncompress(uncompr, &uncomprLen, compr, comprLen); - CHECK_ERR(err, "uncompress"); - - if (strcmp((char*)uncompr, hello)) { - fprintf(stderr, "bad uncompress\n"); - exit(1); - } else { - printf("uncompress(): %s\n", (char *)uncompr); - } -} - -/* =========================================================================== - * Test read/write of .gz files - */ -void test_gzio(fname, uncompr, uncomprLen) - const char *fname; /* compressed file name */ - Byte *uncompr; - uLong uncomprLen; -{ -#ifdef NO_GZCOMPRESS - fprintf(stderr, "NO_GZCOMPRESS -- gz* functions cannot compress\n"); -#else - int err; - int len = (int)strlen(hello)+1; - gzFile file; - z_off_t pos; - - file = gzopen(fname, "wb"); - if (file == NULL) { - fprintf(stderr, "gzopen error\n"); - exit(1); - } - gzputc(file, 'h'); - if (gzputs(file, "ello") != 4) { - fprintf(stderr, "gzputs err: %s\n", gzerror(file, &err)); - exit(1); - } - if (gzprintf(file, ", %s!", "hello") != 8) { - fprintf(stderr, "gzprintf err: %s\n", gzerror(file, &err)); - exit(1); - } - gzseek(file, 1L, SEEK_CUR); /* add one zero byte */ - gzclose(file); - - file = gzopen(fname, "rb"); - if (file == NULL) { - fprintf(stderr, "gzopen error\n"); - exit(1); - } - strcpy((char*)uncompr, "garbage"); - - if (gzread(file, uncompr, (unsigned)uncomprLen) != len) { - fprintf(stderr, "gzread err: %s\n", gzerror(file, &err)); - exit(1); - } - if (strcmp((char*)uncompr, hello)) { - fprintf(stderr, "bad gzread: %s\n", (char*)uncompr); - exit(1); - } else { - printf("gzread(): %s\n", (char*)uncompr); - } - - pos = gzseek(file, -8L, SEEK_CUR); - if (pos != 6 || gztell(file) != pos) { - fprintf(stderr, "gzseek error, pos=%ld, gztell=%ld\n", - (long)pos, (long)gztell(file)); - exit(1); - } - - if (gzgetc(file) != ' ') { - fprintf(stderr, "gzgetc error\n"); - exit(1); - } - - if (gzungetc(' ', file) != ' ') { - fprintf(stderr, "gzungetc error\n"); - exit(1); - } - - gzgets(file, (char*)uncompr, (int)uncomprLen); - if (strlen((char*)uncompr) != 7) { /* " hello!" */ - fprintf(stderr, "gzgets err after gzseek: %s\n", gzerror(file, &err)); - exit(1); - } - if (strcmp((char*)uncompr, hello + 6)) { - fprintf(stderr, "bad gzgets after gzseek\n"); - exit(1); - } else { - printf("gzgets() after gzseek: %s\n", (char*)uncompr); - } - - gzclose(file); -#endif -} - -#endif /* Z_SOLO */ - -/* =========================================================================== - * Test deflate() with small buffers - */ -void test_deflate(compr, comprLen) - Byte *compr; - uLong comprLen; -{ - z_stream c_stream; /* compression stream */ - int err; - uLong len = (uLong)strlen(hello)+1; - - c_stream.zalloc = zalloc; - c_stream.zfree = zfree; - c_stream.opaque = (voidpf)0; - - err = deflateInit(&c_stream, Z_DEFAULT_COMPRESSION); - CHECK_ERR(err, "deflateInit"); - - c_stream.next_in = (z_const unsigned char *)hello; - c_stream.next_out = compr; - - while (c_stream.total_in != len && c_stream.total_out < comprLen) { - c_stream.avail_in = c_stream.avail_out = 1; /* force small buffers */ - err = deflate(&c_stream, Z_NO_FLUSH); - CHECK_ERR(err, "deflate"); - } - /* Finish the stream, still forcing small buffers: */ - for (;;) { - c_stream.avail_out = 1; - err = deflate(&c_stream, Z_FINISH); - if (err == Z_STREAM_END) break; - CHECK_ERR(err, "deflate"); - } - - err = deflateEnd(&c_stream); - CHECK_ERR(err, "deflateEnd"); -} - -/* =========================================================================== - * Test inflate() with small buffers - */ -void test_inflate(compr, comprLen, uncompr, uncomprLen) - Byte *compr, *uncompr; - uLong comprLen, uncomprLen; -{ - int err; - z_stream d_stream; /* decompression stream */ - - strcpy((char*)uncompr, "garbage"); - - d_stream.zalloc = zalloc; - d_stream.zfree = zfree; - d_stream.opaque = (voidpf)0; - - d_stream.next_in = compr; - d_stream.avail_in = 0; - d_stream.next_out = uncompr; - - err = inflateInit(&d_stream); - CHECK_ERR(err, "inflateInit"); - - while (d_stream.total_out < uncomprLen && d_stream.total_in < comprLen) { - d_stream.avail_in = d_stream.avail_out = 1; /* force small buffers */ - err = inflate(&d_stream, Z_NO_FLUSH); - if (err == Z_STREAM_END) break; - CHECK_ERR(err, "inflate"); - } - - err = inflateEnd(&d_stream); - CHECK_ERR(err, "inflateEnd"); - - if (strcmp((char*)uncompr, hello)) { - fprintf(stderr, "bad inflate\n"); - exit(1); - } else { - printf("inflate(): %s\n", (char *)uncompr); - } -} - -/* =========================================================================== - * Test deflate() with large buffers and dynamic change of compression level - */ -void test_large_deflate(compr, comprLen, uncompr, uncomprLen) - Byte *compr, *uncompr; - uLong comprLen, uncomprLen; -{ - z_stream c_stream; /* compression stream */ - int err; - - c_stream.zalloc = zalloc; - c_stream.zfree = zfree; - c_stream.opaque = (voidpf)0; - - err = deflateInit(&c_stream, Z_BEST_SPEED); - CHECK_ERR(err, "deflateInit"); - - c_stream.next_out = compr; - c_stream.avail_out = (uInt)comprLen; - - /* At this point, uncompr is still mostly zeroes, so it should compress - * very well: - */ - c_stream.next_in = uncompr; - c_stream.avail_in = (uInt)uncomprLen; - err = deflate(&c_stream, Z_NO_FLUSH); - CHECK_ERR(err, "deflate"); - if (c_stream.avail_in != 0) { - fprintf(stderr, "deflate not greedy\n"); - exit(1); - } - - /* Feed in already compressed data and switch to no compression: */ - deflateParams(&c_stream, Z_NO_COMPRESSION, Z_DEFAULT_STRATEGY); - c_stream.next_in = compr; - c_stream.avail_in = (uInt)comprLen/2; - err = deflate(&c_stream, Z_NO_FLUSH); - CHECK_ERR(err, "deflate"); - - /* Switch back to compressing mode: */ - deflateParams(&c_stream, Z_BEST_COMPRESSION, Z_FILTERED); - c_stream.next_in = uncompr; - c_stream.avail_in = (uInt)uncomprLen; - err = deflate(&c_stream, Z_NO_FLUSH); - CHECK_ERR(err, "deflate"); - - err = deflate(&c_stream, Z_FINISH); - if (err != Z_STREAM_END) { - fprintf(stderr, "deflate should report Z_STREAM_END\n"); - exit(1); - } - err = deflateEnd(&c_stream); - CHECK_ERR(err, "deflateEnd"); -} - -/* =========================================================================== - * Test inflate() with large buffers - */ -void test_large_inflate(compr, comprLen, uncompr, uncomprLen) - Byte *compr, *uncompr; - uLong comprLen, uncomprLen; -{ - int err; - z_stream d_stream; /* decompression stream */ - - strcpy((char*)uncompr, "garbage"); - - d_stream.zalloc = zalloc; - d_stream.zfree = zfree; - d_stream.opaque = (voidpf)0; - - d_stream.next_in = compr; - d_stream.avail_in = (uInt)comprLen; - - err = inflateInit(&d_stream); - CHECK_ERR(err, "inflateInit"); - - for (;;) { - d_stream.next_out = uncompr; /* discard the output */ - d_stream.avail_out = (uInt)uncomprLen; - err = inflate(&d_stream, Z_NO_FLUSH); - if (err == Z_STREAM_END) break; - CHECK_ERR(err, "large inflate"); - } - - err = inflateEnd(&d_stream); - CHECK_ERR(err, "inflateEnd"); - - if (d_stream.total_out != 2*uncomprLen + comprLen/2) { - fprintf(stderr, "bad large inflate: %ld\n", d_stream.total_out); - exit(1); - } else { - printf("large_inflate(): OK\n"); - } -} - -/* =========================================================================== - * Test deflate() with full flush - */ -void test_flush(compr, comprLen) - Byte *compr; - uLong *comprLen; -{ - z_stream c_stream; /* compression stream */ - int err; - uInt len = (uInt)strlen(hello)+1; - - c_stream.zalloc = zalloc; - c_stream.zfree = zfree; - c_stream.opaque = (voidpf)0; - - err = deflateInit(&c_stream, Z_DEFAULT_COMPRESSION); - CHECK_ERR(err, "deflateInit"); - - c_stream.next_in = (z_const unsigned char *)hello; - c_stream.next_out = compr; - c_stream.avail_in = 3; - c_stream.avail_out = (uInt)*comprLen; - err = deflate(&c_stream, Z_FULL_FLUSH); - CHECK_ERR(err, "deflate"); - - compr[3]++; /* force an error in first compressed block */ - c_stream.avail_in = len - 3; - - err = deflate(&c_stream, Z_FINISH); - if (err != Z_STREAM_END) { - CHECK_ERR(err, "deflate"); - } - err = deflateEnd(&c_stream); - CHECK_ERR(err, "deflateEnd"); - - *comprLen = c_stream.total_out; -} - -/* =========================================================================== - * Test inflateSync() - */ -void test_sync(compr, comprLen, uncompr, uncomprLen) - Byte *compr, *uncompr; - uLong comprLen, uncomprLen; -{ - int err; - z_stream d_stream; /* decompression stream */ - - strcpy((char*)uncompr, "garbage"); - - d_stream.zalloc = zalloc; - d_stream.zfree = zfree; - d_stream.opaque = (voidpf)0; - - d_stream.next_in = compr; - d_stream.avail_in = 2; /* just read the zlib header */ - - err = inflateInit(&d_stream); - CHECK_ERR(err, "inflateInit"); - - d_stream.next_out = uncompr; - d_stream.avail_out = (uInt)uncomprLen; - - err = inflate(&d_stream, Z_NO_FLUSH); - CHECK_ERR(err, "inflate"); - - d_stream.avail_in = (uInt)comprLen-2; /* read all compressed data */ - err = inflateSync(&d_stream); /* but skip the damaged part */ - CHECK_ERR(err, "inflateSync"); - - err = inflate(&d_stream, Z_FINISH); - if (err != Z_DATA_ERROR) { - fprintf(stderr, "inflate should report DATA_ERROR\n"); - /* Because of incorrect adler32 */ - exit(1); - } - err = inflateEnd(&d_stream); - CHECK_ERR(err, "inflateEnd"); - - printf("after inflateSync(): hel%s\n", (char *)uncompr); -} - -/* =========================================================================== - * Test deflate() with preset dictionary - */ -void test_dict_deflate(compr, comprLen) - Byte *compr; - uLong comprLen; -{ - z_stream c_stream; /* compression stream */ - int err; - - c_stream.zalloc = zalloc; - c_stream.zfree = zfree; - c_stream.opaque = (voidpf)0; - - err = deflateInit(&c_stream, Z_BEST_COMPRESSION); - CHECK_ERR(err, "deflateInit"); - - err = deflateSetDictionary(&c_stream, - (const Bytef*)dictionary, (int)sizeof(dictionary)); - CHECK_ERR(err, "deflateSetDictionary"); - - dictId = c_stream.adler; - c_stream.next_out = compr; - c_stream.avail_out = (uInt)comprLen; - - c_stream.next_in = (z_const unsigned char *)hello; - c_stream.avail_in = (uInt)strlen(hello)+1; - - err = deflate(&c_stream, Z_FINISH); - if (err != Z_STREAM_END) { - fprintf(stderr, "deflate should report Z_STREAM_END\n"); - exit(1); - } - err = deflateEnd(&c_stream); - CHECK_ERR(err, "deflateEnd"); -} - -/* =========================================================================== - * Test inflate() with a preset dictionary - */ -void test_dict_inflate(compr, comprLen, uncompr, uncomprLen) - Byte *compr, *uncompr; - uLong comprLen, uncomprLen; -{ - int err; - z_stream d_stream; /* decompression stream */ - - strcpy((char*)uncompr, "garbage"); - - d_stream.zalloc = zalloc; - d_stream.zfree = zfree; - d_stream.opaque = (voidpf)0; - - d_stream.next_in = compr; - d_stream.avail_in = (uInt)comprLen; - - err = inflateInit(&d_stream); - CHECK_ERR(err, "inflateInit"); - - d_stream.next_out = uncompr; - d_stream.avail_out = (uInt)uncomprLen; - - for (;;) { - err = inflate(&d_stream, Z_NO_FLUSH); - if (err == Z_STREAM_END) break; - if (err == Z_NEED_DICT) { - if (d_stream.adler != dictId) { - fprintf(stderr, "unexpected dictionary"); - exit(1); - } - err = inflateSetDictionary(&d_stream, (const Bytef*)dictionary, - (int)sizeof(dictionary)); - } - CHECK_ERR(err, "inflate with dict"); - } - - err = inflateEnd(&d_stream); - CHECK_ERR(err, "inflateEnd"); - - if (strcmp((char*)uncompr, hello)) { - fprintf(stderr, "bad inflate with dict\n"); - exit(1); - } else { - printf("inflate with dictionary: %s\n", (char *)uncompr); - } -} - -/* =========================================================================== - * Usage: example [output.gz [input.gz]] - */ - -int main(argc, argv) - int argc; - char *argv[]; -{ - Byte *compr, *uncompr; - uLong comprLen = 10000*sizeof(int); /* don't overflow on MSDOS */ - uLong uncomprLen = comprLen; - static const char* myVersion = ZLIB_VERSION; - - if (zlibVersion()[0] != myVersion[0]) { - fprintf(stderr, "incompatible zlib version\n"); - exit(1); - - } else if (strcmp(zlibVersion(), ZLIB_VERSION) != 0) { - fprintf(stderr, "warning: different zlib version\n"); - } - - printf("zlib version %s = 0x%04x, compile flags = 0x%lx\n", - ZLIB_VERSION, ZLIB_VERNUM, zlibCompileFlags()); - - compr = (Byte*)calloc((uInt)comprLen, 1); - uncompr = (Byte*)calloc((uInt)uncomprLen, 1); - /* compr and uncompr are cleared to avoid reading uninitialized - * data and to ensure that uncompr compresses well. - */ - if (compr == Z_NULL || uncompr == Z_NULL) { - printf("out of memory\n"); - exit(1); - } - -#ifdef Z_SOLO - (void)argc; - (void)argv; -#else - test_compress(compr, comprLen, uncompr, uncomprLen); - - test_gzio((argc > 1 ? argv[1] : TESTFILE), - uncompr, uncomprLen); -#endif - - test_deflate(compr, comprLen); - test_inflate(compr, comprLen, uncompr, uncomprLen); - - test_large_deflate(compr, comprLen, uncompr, uncomprLen); - test_large_inflate(compr, comprLen, uncompr, uncomprLen); - - test_flush(compr, &comprLen); - test_sync(compr, comprLen, uncompr, uncomprLen); - comprLen = uncomprLen; - - test_dict_deflate(compr, comprLen); - test_dict_inflate(compr, comprLen, uncompr, uncomprLen); - - free(compr); - free(uncompr); - - return 0; -} DELETED compat/zlib/test/infcover.c Index: compat/zlib/test/infcover.c ================================================================== --- compat/zlib/test/infcover.c +++ /dev/null @@ -1,671 +0,0 @@ -/* infcover.c -- test zlib's inflate routines with full code coverage - * Copyright (C) 2011, 2016 Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -/* to use, do: ./configure --cover && make cover */ - -#include -#include -#include -#include -#include "zlib.h" - -/* get definition of internal structure so we can mess with it (see pull()), - and so we can call inflate_trees() (see cover5()) */ -#define ZLIB_INTERNAL -#include "inftrees.h" -#include "inflate.h" - -#define local static - -/* -- memory tracking routines -- */ - -/* - These memory tracking routines are provided to zlib and track all of zlib's - allocations and deallocations, check for LIFO operations, keep a current - and high water mark of total bytes requested, optionally set a limit on the - total memory that can be allocated, and when done check for memory leaks. - - They are used as follows: - - z_stream strm; - mem_setup(&strm) initializes the memory tracking and sets the - zalloc, zfree, and opaque members of strm to use - memory tracking for all zlib operations on strm - mem_limit(&strm, limit) sets a limit on the total bytes requested -- a - request that exceeds this limit will result in an - allocation failure (returns NULL) -- setting the - limit to zero means no limit, which is the default - after mem_setup() - mem_used(&strm, "msg") prints to stderr "msg" and the total bytes used - mem_high(&strm, "msg") prints to stderr "msg" and the high water mark - mem_done(&strm, "msg") ends memory tracking, releases all allocations - for the tracking as well as leaked zlib blocks, if - any. If there was anything unusual, such as leaked - blocks, non-FIFO frees, or frees of addresses not - allocated, then "msg" and information about the - problem is printed to stderr. If everything is - normal, nothing is printed. mem_done resets the - strm members to Z_NULL to use the default memory - allocation routines on the next zlib initialization - using strm. - */ - -/* these items are strung together in a linked list, one for each allocation */ -struct mem_item { - void *ptr; /* pointer to allocated memory */ - size_t size; /* requested size of allocation */ - struct mem_item *next; /* pointer to next item in list, or NULL */ -}; - -/* this structure is at the root of the linked list, and tracks statistics */ -struct mem_zone { - struct mem_item *first; /* pointer to first item in list, or NULL */ - size_t total, highwater; /* total allocations, and largest total */ - size_t limit; /* memory allocation limit, or 0 if no limit */ - int notlifo, rogue; /* counts of non-LIFO frees and rogue frees */ -}; - -/* memory allocation routine to pass to zlib */ -local void *mem_alloc(void *mem, unsigned count, unsigned size) -{ - void *ptr; - struct mem_item *item; - struct mem_zone *zone = mem; - size_t len = count * (size_t)size; - - /* induced allocation failure */ - if (zone == NULL || (zone->limit && zone->total + len > zone->limit)) - return NULL; - - /* perform allocation using the standard library, fill memory with a - non-zero value to make sure that the code isn't depending on zeros */ - ptr = malloc(len); - if (ptr == NULL) - return NULL; - memset(ptr, 0xa5, len); - - /* create a new item for the list */ - item = malloc(sizeof(struct mem_item)); - if (item == NULL) { - free(ptr); - return NULL; - } - item->ptr = ptr; - item->size = len; - - /* insert item at the beginning of the list */ - item->next = zone->first; - zone->first = item; - - /* update the statistics */ - zone->total += item->size; - if (zone->total > zone->highwater) - zone->highwater = zone->total; - - /* return the allocated memory */ - return ptr; -} - -/* memory free routine to pass to zlib */ -local void mem_free(void *mem, void *ptr) -{ - struct mem_item *item, *next; - struct mem_zone *zone = mem; - - /* if no zone, just do a free */ - if (zone == NULL) { - free(ptr); - return; - } - - /* point next to the item that matches ptr, or NULL if not found -- remove - the item from the linked list if found */ - next = zone->first; - if (next) { - if (next->ptr == ptr) - zone->first = next->next; /* first one is it, remove from list */ - else { - do { /* search the linked list */ - item = next; - next = item->next; - } while (next != NULL && next->ptr != ptr); - if (next) { /* if found, remove from linked list */ - item->next = next->next; - zone->notlifo++; /* not a LIFO free */ - } - - } - } - - /* if found, update the statistics and free the item */ - if (next) { - zone->total -= next->size; - free(next); - } - - /* if not found, update the rogue count */ - else - zone->rogue++; - - /* in any case, do the requested free with the standard library function */ - free(ptr); -} - -/* set up a controlled memory allocation space for monitoring, set the stream - parameters to the controlled routines, with opaque pointing to the space */ -local void mem_setup(z_stream *strm) -{ - struct mem_zone *zone; - - zone = malloc(sizeof(struct mem_zone)); - assert(zone != NULL); - zone->first = NULL; - zone->total = 0; - zone->highwater = 0; - zone->limit = 0; - zone->notlifo = 0; - zone->rogue = 0; - strm->opaque = zone; - strm->zalloc = mem_alloc; - strm->zfree = mem_free; -} - -/* set a limit on the total memory allocation, or 0 to remove the limit */ -local void mem_limit(z_stream *strm, size_t limit) -{ - struct mem_zone *zone = strm->opaque; - - zone->limit = limit; -} - -/* show the current total requested allocations in bytes */ -local void mem_used(z_stream *strm, char *prefix) -{ - struct mem_zone *zone = strm->opaque; - - fprintf(stderr, "%s: %lu allocated\n", prefix, zone->total); -} - -/* show the high water allocation in bytes */ -local void mem_high(z_stream *strm, char *prefix) -{ - struct mem_zone *zone = strm->opaque; - - fprintf(stderr, "%s: %lu high water mark\n", prefix, zone->highwater); -} - -/* release the memory allocation zone -- if there are any surprises, notify */ -local void mem_done(z_stream *strm, char *prefix) -{ - int count = 0; - struct mem_item *item, *next; - struct mem_zone *zone = strm->opaque; - - /* show high water mark */ - mem_high(strm, prefix); - - /* free leftover allocations and item structures, if any */ - item = zone->first; - while (item != NULL) { - free(item->ptr); - next = item->next; - free(item); - item = next; - count++; - } - - /* issue alerts about anything unexpected */ - if (count || zone->total) - fprintf(stderr, "** %s: %lu bytes in %d blocks not freed\n", - prefix, zone->total, count); - if (zone->notlifo) - fprintf(stderr, "** %s: %d frees not LIFO\n", prefix, zone->notlifo); - if (zone->rogue) - fprintf(stderr, "** %s: %d frees not recognized\n", - prefix, zone->rogue); - - /* free the zone and delete from the stream */ - free(zone); - strm->opaque = Z_NULL; - strm->zalloc = Z_NULL; - strm->zfree = Z_NULL; -} - -/* -- inflate test routines -- */ - -/* Decode a hexadecimal string, set *len to length, in[] to the bytes. This - decodes liberally, in that hex digits can be adjacent, in which case two in - a row writes a byte. Or they can be delimited by any non-hex character, - where the delimiters are ignored except when a single hex digit is followed - by a delimiter, where that single digit writes a byte. The returned data is - allocated and must eventually be freed. NULL is returned if out of memory. - If the length is not needed, then len can be NULL. */ -local unsigned char *h2b(const char *hex, unsigned *len) -{ - unsigned char *in, *re; - unsigned next, val; - - in = malloc((strlen(hex) + 1) >> 1); - if (in == NULL) - return NULL; - next = 0; - val = 1; - do { - if (*hex >= '0' && *hex <= '9') - val = (val << 4) + *hex - '0'; - else if (*hex >= 'A' && *hex <= 'F') - val = (val << 4) + *hex - 'A' + 10; - else if (*hex >= 'a' && *hex <= 'f') - val = (val << 4) + *hex - 'a' + 10; - else if (val != 1 && val < 32) /* one digit followed by delimiter */ - val += 240; /* make it look like two digits */ - if (val > 255) { /* have two digits */ - in[next++] = val & 0xff; /* save the decoded byte */ - val = 1; /* start over */ - } - } while (*hex++); /* go through the loop with the terminating null */ - if (len != NULL) - *len = next; - re = realloc(in, next); - return re == NULL ? in : re; -} - -/* generic inflate() run, where hex is the hexadecimal input data, what is the - text to include in an error message, step is how much input data to feed - inflate() on each call, or zero to feed it all, win is the window bits - parameter to inflateInit2(), len is the size of the output buffer, and err - is the error code expected from the first inflate() call (the second - inflate() call is expected to return Z_STREAM_END). If win is 47, then - header information is collected with inflateGetHeader(). If a zlib stream - is looking for a dictionary, then an empty dictionary is provided. - inflate() is run until all of the input data is consumed. */ -local void inf(char *hex, char *what, unsigned step, int win, unsigned len, - int err) -{ - int ret; - unsigned have; - unsigned char *in, *out; - z_stream strm, copy; - gz_header head; - - mem_setup(&strm); - strm.avail_in = 0; - strm.next_in = Z_NULL; - ret = inflateInit2(&strm, win); - if (ret != Z_OK) { - mem_done(&strm, what); - return; - } - out = malloc(len); assert(out != NULL); - if (win == 47) { - head.extra = out; - head.extra_max = len; - head.name = out; - head.name_max = len; - head.comment = out; - head.comm_max = len; - ret = inflateGetHeader(&strm, &head); assert(ret == Z_OK); - } - in = h2b(hex, &have); assert(in != NULL); - if (step == 0 || step > have) - step = have; - strm.avail_in = step; - have -= step; - strm.next_in = in; - do { - strm.avail_out = len; - strm.next_out = out; - ret = inflate(&strm, Z_NO_FLUSH); assert(err == 9 || ret == err); - if (ret != Z_OK && ret != Z_BUF_ERROR && ret != Z_NEED_DICT) - break; - if (ret == Z_NEED_DICT) { - ret = inflateSetDictionary(&strm, in, 1); - assert(ret == Z_DATA_ERROR); - mem_limit(&strm, 1); - ret = inflateSetDictionary(&strm, out, 0); - assert(ret == Z_MEM_ERROR); - mem_limit(&strm, 0); - ((struct inflate_state *)strm.state)->mode = DICT; - ret = inflateSetDictionary(&strm, out, 0); - assert(ret == Z_OK); - ret = inflate(&strm, Z_NO_FLUSH); assert(ret == Z_BUF_ERROR); - } - ret = inflateCopy(©, &strm); assert(ret == Z_OK); - ret = inflateEnd(©); assert(ret == Z_OK); - err = 9; /* don't care next time around */ - have += strm.avail_in; - strm.avail_in = step > have ? have : step; - have -= strm.avail_in; - } while (strm.avail_in); - free(in); - free(out); - ret = inflateReset2(&strm, -8); assert(ret == Z_OK); - ret = inflateEnd(&strm); assert(ret == Z_OK); - mem_done(&strm, what); -} - -/* cover all of the lines in inflate.c up to inflate() */ -local void cover_support(void) -{ - int ret; - z_stream strm; - - mem_setup(&strm); - strm.avail_in = 0; - strm.next_in = Z_NULL; - ret = inflateInit(&strm); assert(ret == Z_OK); - mem_used(&strm, "inflate init"); - ret = inflatePrime(&strm, 5, 31); assert(ret == Z_OK); - ret = inflatePrime(&strm, -1, 0); assert(ret == Z_OK); - ret = inflateSetDictionary(&strm, Z_NULL, 0); - assert(ret == Z_STREAM_ERROR); - ret = inflateEnd(&strm); assert(ret == Z_OK); - mem_done(&strm, "prime"); - - inf("63 0", "force window allocation", 0, -15, 1, Z_OK); - inf("63 18 5", "force window replacement", 0, -8, 259, Z_OK); - inf("63 18 68 30 d0 0 0", "force split window update", 4, -8, 259, Z_OK); - inf("3 0", "use fixed blocks", 0, -15, 1, Z_STREAM_END); - inf("", "bad window size", 0, 1, 0, Z_STREAM_ERROR); - - mem_setup(&strm); - strm.avail_in = 0; - strm.next_in = Z_NULL; - ret = inflateInit_(&strm, ZLIB_VERSION - 1, (int)sizeof(z_stream)); - assert(ret == Z_VERSION_ERROR); - mem_done(&strm, "wrong version"); - - strm.avail_in = 0; - strm.next_in = Z_NULL; - ret = inflateInit(&strm); assert(ret == Z_OK); - ret = inflateEnd(&strm); assert(ret == Z_OK); - fputs("inflate built-in memory routines\n", stderr); -} - -/* cover all inflate() header and trailer cases and code after inflate() */ -local void cover_wrap(void) -{ - int ret; - z_stream strm, copy; - unsigned char dict[257]; - - ret = inflate(Z_NULL, 0); assert(ret == Z_STREAM_ERROR); - ret = inflateEnd(Z_NULL); assert(ret == Z_STREAM_ERROR); - ret = inflateCopy(Z_NULL, Z_NULL); assert(ret == Z_STREAM_ERROR); - fputs("inflate bad parameters\n", stderr); - - inf("1f 8b 0 0", "bad gzip method", 0, 31, 0, Z_DATA_ERROR); - inf("1f 8b 8 80", "bad gzip flags", 0, 31, 0, Z_DATA_ERROR); - inf("77 85", "bad zlib method", 0, 15, 0, Z_DATA_ERROR); - inf("8 99", "set window size from header", 0, 0, 0, Z_OK); - inf("78 9c", "bad zlib window size", 0, 8, 0, Z_DATA_ERROR); - inf("78 9c 63 0 0 0 1 0 1", "check adler32", 0, 15, 1, Z_STREAM_END); - inf("1f 8b 8 1e 0 0 0 0 0 0 1 0 0 0 0 0 0", "bad header crc", 0, 47, 1, - Z_DATA_ERROR); - inf("1f 8b 8 2 0 0 0 0 0 0 1d 26 3 0 0 0 0 0 0 0 0 0", "check gzip length", - 0, 47, 0, Z_STREAM_END); - inf("78 90", "bad zlib header check", 0, 47, 0, Z_DATA_ERROR); - inf("8 b8 0 0 0 1", "need dictionary", 0, 8, 0, Z_NEED_DICT); - inf("78 9c 63 0", "compute adler32", 0, 15, 1, Z_OK); - - mem_setup(&strm); - strm.avail_in = 0; - strm.next_in = Z_NULL; - ret = inflateInit2(&strm, -8); - strm.avail_in = 2; - strm.next_in = (void *)"\x63"; - strm.avail_out = 1; - strm.next_out = (void *)&ret; - mem_limit(&strm, 1); - ret = inflate(&strm, Z_NO_FLUSH); assert(ret == Z_MEM_ERROR); - ret = inflate(&strm, Z_NO_FLUSH); assert(ret == Z_MEM_ERROR); - mem_limit(&strm, 0); - memset(dict, 0, 257); - ret = inflateSetDictionary(&strm, dict, 257); - assert(ret == Z_OK); - mem_limit(&strm, (sizeof(struct inflate_state) << 1) + 256); - ret = inflatePrime(&strm, 16, 0); assert(ret == Z_OK); - strm.avail_in = 2; - strm.next_in = (void *)"\x80"; - ret = inflateSync(&strm); assert(ret == Z_DATA_ERROR); - ret = inflate(&strm, Z_NO_FLUSH); assert(ret == Z_STREAM_ERROR); - strm.avail_in = 4; - strm.next_in = (void *)"\0\0\xff\xff"; - ret = inflateSync(&strm); assert(ret == Z_OK); - (void)inflateSyncPoint(&strm); - ret = inflateCopy(©, &strm); assert(ret == Z_MEM_ERROR); - mem_limit(&strm, 0); - ret = inflateUndermine(&strm, 1); assert(ret == Z_DATA_ERROR); - (void)inflateMark(&strm); - ret = inflateEnd(&strm); assert(ret == Z_OK); - mem_done(&strm, "miscellaneous, force memory errors"); -} - -/* input and output functions for inflateBack() */ -local unsigned pull(void *desc, unsigned char **buf) -{ - static unsigned int next = 0; - static unsigned char dat[] = {0x63, 0, 2, 0}; - struct inflate_state *state; - - if (desc == Z_NULL) { - next = 0; - return 0; /* no input (already provided at next_in) */ - } - state = (void *)((z_stream *)desc)->state; - if (state != Z_NULL) - state->mode = SYNC; /* force an otherwise impossible situation */ - return next < sizeof(dat) ? (*buf = dat + next++, 1) : 0; -} - -local int push(void *desc, unsigned char *buf, unsigned len) -{ - buf += len; - return desc != Z_NULL; /* force error if desc not null */ -} - -/* cover inflateBack() up to common deflate data cases and after those */ -local void cover_back(void) -{ - int ret; - z_stream strm; - unsigned char win[32768]; - - ret = inflateBackInit_(Z_NULL, 0, win, 0, 0); - assert(ret == Z_VERSION_ERROR); - ret = inflateBackInit(Z_NULL, 0, win); assert(ret == Z_STREAM_ERROR); - ret = inflateBack(Z_NULL, Z_NULL, Z_NULL, Z_NULL, Z_NULL); - assert(ret == Z_STREAM_ERROR); - ret = inflateBackEnd(Z_NULL); assert(ret == Z_STREAM_ERROR); - fputs("inflateBack bad parameters\n", stderr); - - mem_setup(&strm); - ret = inflateBackInit(&strm, 15, win); assert(ret == Z_OK); - strm.avail_in = 2; - strm.next_in = (void *)"\x03"; - ret = inflateBack(&strm, pull, Z_NULL, push, Z_NULL); - assert(ret == Z_STREAM_END); - /* force output error */ - strm.avail_in = 3; - strm.next_in = (void *)"\x63\x00"; - ret = inflateBack(&strm, pull, Z_NULL, push, &strm); - assert(ret == Z_BUF_ERROR); - /* force mode error by mucking with state */ - ret = inflateBack(&strm, pull, &strm, push, Z_NULL); - assert(ret == Z_STREAM_ERROR); - ret = inflateBackEnd(&strm); assert(ret == Z_OK); - mem_done(&strm, "inflateBack bad state"); - - ret = inflateBackInit(&strm, 15, win); assert(ret == Z_OK); - ret = inflateBackEnd(&strm); assert(ret == Z_OK); - fputs("inflateBack built-in memory routines\n", stderr); -} - -/* do a raw inflate of data in hexadecimal with both inflate and inflateBack */ -local int try(char *hex, char *id, int err) -{ - int ret; - unsigned len, size; - unsigned char *in, *out, *win; - char *prefix; - z_stream strm; - - /* convert to hex */ - in = h2b(hex, &len); - assert(in != NULL); - - /* allocate work areas */ - size = len << 3; - out = malloc(size); - assert(out != NULL); - win = malloc(32768); - assert(win != NULL); - prefix = malloc(strlen(id) + 6); - assert(prefix != NULL); - - /* first with inflate */ - strcpy(prefix, id); - strcat(prefix, "-late"); - mem_setup(&strm); - strm.avail_in = 0; - strm.next_in = Z_NULL; - ret = inflateInit2(&strm, err < 0 ? 47 : -15); - assert(ret == Z_OK); - strm.avail_in = len; - strm.next_in = in; - do { - strm.avail_out = size; - strm.next_out = out; - ret = inflate(&strm, Z_TREES); - assert(ret != Z_STREAM_ERROR && ret != Z_MEM_ERROR); - if (ret == Z_DATA_ERROR || ret == Z_NEED_DICT) - break; - } while (strm.avail_in || strm.avail_out == 0); - if (err) { - assert(ret == Z_DATA_ERROR); - assert(strcmp(id, strm.msg) == 0); - } - inflateEnd(&strm); - mem_done(&strm, prefix); - - /* then with inflateBack */ - if (err >= 0) { - strcpy(prefix, id); - strcat(prefix, "-back"); - mem_setup(&strm); - ret = inflateBackInit(&strm, 15, win); - assert(ret == Z_OK); - strm.avail_in = len; - strm.next_in = in; - ret = inflateBack(&strm, pull, Z_NULL, push, Z_NULL); - assert(ret != Z_STREAM_ERROR); - if (err) { - assert(ret == Z_DATA_ERROR); - assert(strcmp(id, strm.msg) == 0); - } - inflateBackEnd(&strm); - mem_done(&strm, prefix); - } - - /* clean up */ - free(prefix); - free(win); - free(out); - free(in); - return ret; -} - -/* cover deflate data cases in both inflate() and inflateBack() */ -local void cover_inflate(void) -{ - try("0 0 0 0 0", "invalid stored block lengths", 1); - try("3 0", "fixed", 0); - try("6", "invalid block type", 1); - try("1 1 0 fe ff 0", "stored", 0); - try("fc 0 0", "too many length or distance symbols", 1); - try("4 0 fe ff", "invalid code lengths set", 1); - try("4 0 24 49 0", "invalid bit length repeat", 1); - try("4 0 24 e9 ff ff", "invalid bit length repeat", 1); - try("4 0 24 e9 ff 6d", "invalid code -- missing end-of-block", 1); - try("4 80 49 92 24 49 92 24 71 ff ff 93 11 0", - "invalid literal/lengths set", 1); - try("4 80 49 92 24 49 92 24 f b4 ff ff c3 84", "invalid distances set", 1); - try("4 c0 81 8 0 0 0 0 20 7f eb b 0 0", "invalid literal/length code", 1); - try("2 7e ff ff", "invalid distance code", 1); - try("c c0 81 0 0 0 0 0 90 ff 6b 4 0", "invalid distance too far back", 1); - - /* also trailer mismatch just in inflate() */ - try("1f 8b 8 0 0 0 0 0 0 0 3 0 0 0 0 1", "incorrect data check", -1); - try("1f 8b 8 0 0 0 0 0 0 0 3 0 0 0 0 0 0 0 0 1", - "incorrect length check", -1); - try("5 c0 21 d 0 0 0 80 b0 fe 6d 2f 91 6c", "pull 17", 0); - try("5 e0 81 91 24 cb b2 2c 49 e2 f 2e 8b 9a 47 56 9f fb fe ec d2 ff 1f", - "long code", 0); - try("ed c0 1 1 0 0 0 40 20 ff 57 1b 42 2c 4f", "length extra", 0); - try("ed cf c1 b1 2c 47 10 c4 30 fa 6f 35 1d 1 82 59 3d fb be 2e 2a fc f c", - "long distance and extra", 0); - try("ed c0 81 0 0 0 0 80 a0 fd a9 17 a9 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 " - "0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6", "window end", 0); - inf("2 8 20 80 0 3 0", "inflate_fast TYPE return", 0, -15, 258, - Z_STREAM_END); - inf("63 18 5 40 c 0", "window wrap", 3, -8, 300, Z_OK); -} - -/* cover remaining lines in inftrees.c */ -local void cover_trees(void) -{ - int ret; - unsigned bits; - unsigned short lens[16], work[16]; - code *next, table[ENOUGH_DISTS]; - - /* we need to call inflate_table() directly in order to manifest not- - enough errors, since zlib insures that enough is always enough */ - for (bits = 0; bits < 15; bits++) - lens[bits] = (unsigned short)(bits + 1); - lens[15] = 15; - next = table; - bits = 15; - ret = inflate_table(DISTS, lens, 16, &next, &bits, work); - assert(ret == 1); - next = table; - bits = 1; - ret = inflate_table(DISTS, lens, 16, &next, &bits, work); - assert(ret == 1); - fputs("inflate_table not enough errors\n", stderr); -} - -/* cover remaining inffast.c decoding and window copying */ -local void cover_fast(void) -{ - inf("e5 e0 81 ad 6d cb b2 2c c9 01 1e 59 63 ae 7d ee fb 4d fd b5 35 41 68" - " ff 7f 0f 0 0 0", "fast length extra bits", 0, -8, 258, Z_DATA_ERROR); - inf("25 fd 81 b5 6d 59 b6 6a 49 ea af 35 6 34 eb 8c b9 f6 b9 1e ef 67 49" - " 50 fe ff ff 3f 0 0", "fast distance extra bits", 0, -8, 258, - Z_DATA_ERROR); - inf("3 7e 0 0 0 0 0", "fast invalid distance code", 0, -8, 258, - Z_DATA_ERROR); - inf("1b 7 0 0 0 0 0", "fast invalid literal/length code", 0, -8, 258, - Z_DATA_ERROR); - inf("d c7 1 ae eb 38 c 4 41 a0 87 72 de df fb 1f b8 36 b1 38 5d ff ff 0", - "fast 2nd level codes and too far back", 0, -8, 258, Z_DATA_ERROR); - inf("63 18 5 8c 10 8 0 0 0 0", "very common case", 0, -8, 259, Z_OK); - inf("63 60 60 18 c9 0 8 18 18 18 26 c0 28 0 29 0 0 0", - "contiguous and wrap around window", 6, -8, 259, Z_OK); - inf("63 0 3 0 0 0 0 0", "copy direct from output", 0, -8, 259, - Z_STREAM_END); -} - -int main(void) -{ - fprintf(stderr, "%s\n", zlibVersion()); - cover_support(); - cover_wrap(); - cover_back(); - cover_inflate(); - cover_trees(); - cover_fast(); - return 0; -} DELETED compat/zlib/test/minigzip.c Index: compat/zlib/test/minigzip.c ================================================================== --- compat/zlib/test/minigzip.c +++ /dev/null @@ -1,651 +0,0 @@ -/* minigzip.c -- simulate gzip using the zlib compression library - * Copyright (C) 1995-2006, 2010, 2011, 2016 Jean-loup Gailly - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -/* - * minigzip is a minimal implementation of the gzip utility. This is - * only an example of using zlib and isn't meant to replace the - * full-featured gzip. No attempt is made to deal with file systems - * limiting names to 14 or 8+3 characters, etc... Error checking is - * very limited. So use minigzip only for testing; use gzip for the - * real thing. On MSDOS, use only on file names without extension - * or in pipe mode. - */ - -/* @(#) $Id$ */ - -#include "zlib.h" -#include - -#ifdef STDC -# include -# include -#endif - -#ifdef USE_MMAP -# include -# include -# include -#endif - -#if defined(MSDOS) || defined(OS2) || defined(WIN32) || defined(__CYGWIN__) -# include -# include -# ifdef UNDER_CE -# include -# endif -# define SET_BINARY_MODE(file) setmode(fileno(file), O_BINARY) -#else -# define SET_BINARY_MODE(file) -#endif - -#if defined(_MSC_VER) && _MSC_VER < 1900 -# define snprintf _snprintf -#endif - -#ifdef VMS -# define unlink delete -# define GZ_SUFFIX "-gz" -#endif -#ifdef RISCOS -# define unlink remove -# define GZ_SUFFIX "-gz" -# define fileno(file) file->__file -#endif -#if defined(__MWERKS__) && __dest_os != __be_os && __dest_os != __win32_os -# include /* for fileno */ -#endif - -#if !defined(Z_HAVE_UNISTD_H) && !defined(_LARGEFILE64_SOURCE) -#ifndef WIN32 /* unlink already in stdio.h for WIN32 */ - extern int unlink OF((const char *)); -#endif -#endif - -#if defined(UNDER_CE) -# include -# define perror(s) pwinerror(s) - -/* Map the Windows error number in ERROR to a locale-dependent error - message string and return a pointer to it. Typically, the values - for ERROR come from GetLastError. - - The string pointed to shall not be modified by the application, - but may be overwritten by a subsequent call to strwinerror - - The strwinerror function does not change the current setting - of GetLastError. */ - -static char *strwinerror (error) - DWORD error; -{ - static char buf[1024]; - - wchar_t *msgbuf; - DWORD lasterr = GetLastError(); - DWORD chars = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM - | FORMAT_MESSAGE_ALLOCATE_BUFFER, - NULL, - error, - 0, /* Default language */ - (LPVOID)&msgbuf, - 0, - NULL); - if (chars != 0) { - /* If there is an \r\n appended, zap it. */ - if (chars >= 2 - && msgbuf[chars - 2] == '\r' && msgbuf[chars - 1] == '\n') { - chars -= 2; - msgbuf[chars] = 0; - } - - if (chars > sizeof (buf) - 1) { - chars = sizeof (buf) - 1; - msgbuf[chars] = 0; - } - - wcstombs(buf, msgbuf, chars + 1); - LocalFree(msgbuf); - } - else { - sprintf(buf, "unknown win32 error (%ld)", error); - } - - SetLastError(lasterr); - return buf; -} - -static void pwinerror (s) - const char *s; -{ - if (s && *s) - fprintf(stderr, "%s: %s\n", s, strwinerror(GetLastError ())); - else - fprintf(stderr, "%s\n", strwinerror(GetLastError ())); -} - -#endif /* UNDER_CE */ - -#ifndef GZ_SUFFIX -# define GZ_SUFFIX ".gz" -#endif -#define SUFFIX_LEN (sizeof(GZ_SUFFIX)-1) - -#define BUFLEN 16384 -#define MAX_NAME_LEN 1024 - -#ifdef MAXSEG_64K -# define local static - /* Needed for systems with limitation on stack size. */ -#else -# define local -#endif - -#ifdef Z_SOLO -/* for Z_SOLO, create simplified gz* functions using deflate and inflate */ - -#if defined(Z_HAVE_UNISTD_H) || defined(Z_LARGE) -# include /* for unlink() */ -#endif - -void *myalloc OF((void *, unsigned, unsigned)); -void myfree OF((void *, void *)); - -void *myalloc(q, n, m) - void *q; - unsigned n, m; -{ - (void)q; - return calloc(n, m); -} - -void myfree(q, p) - void *q, *p; -{ - (void)q; - free(p); -} - -typedef struct gzFile_s { - FILE *file; - int write; - int err; - char *msg; - z_stream strm; -} *gzFile; - -gzFile gzopen OF((const char *, const char *)); -gzFile gzdopen OF((int, const char *)); -gzFile gz_open OF((const char *, int, const char *)); - -gzFile gzopen(path, mode) -const char *path; -const char *mode; -{ - return gz_open(path, -1, mode); -} - -gzFile gzdopen(fd, mode) -int fd; -const char *mode; -{ - return gz_open(NULL, fd, mode); -} - -gzFile gz_open(path, fd, mode) - const char *path; - int fd; - const char *mode; -{ - gzFile gz; - int ret; - - gz = malloc(sizeof(struct gzFile_s)); - if (gz == NULL) - return NULL; - gz->write = strchr(mode, 'w') != NULL; - gz->strm.zalloc = myalloc; - gz->strm.zfree = myfree; - gz->strm.opaque = Z_NULL; - if (gz->write) - ret = deflateInit2(&(gz->strm), -1, 8, 15 + 16, 8, 0); - else { - gz->strm.next_in = 0; - gz->strm.avail_in = Z_NULL; - ret = inflateInit2(&(gz->strm), 15 + 16); - } - if (ret != Z_OK) { - free(gz); - return NULL; - } - gz->file = path == NULL ? fdopen(fd, gz->write ? "wb" : "rb") : - fopen(path, gz->write ? "wb" : "rb"); - if (gz->file == NULL) { - gz->write ? deflateEnd(&(gz->strm)) : inflateEnd(&(gz->strm)); - free(gz); - return NULL; - } - gz->err = 0; - gz->msg = ""; - return gz; -} - -int gzwrite OF((gzFile, const void *, unsigned)); - -int gzwrite(gz, buf, len) - gzFile gz; - const void *buf; - unsigned len; -{ - z_stream *strm; - unsigned char out[BUFLEN]; - - if (gz == NULL || !gz->write) - return 0; - strm = &(gz->strm); - strm->next_in = (void *)buf; - strm->avail_in = len; - do { - strm->next_out = out; - strm->avail_out = BUFLEN; - (void)deflate(strm, Z_NO_FLUSH); - fwrite(out, 1, BUFLEN - strm->avail_out, gz->file); - } while (strm->avail_out == 0); - return len; -} - -int gzread OF((gzFile, void *, unsigned)); - -int gzread(gz, buf, len) - gzFile gz; - void *buf; - unsigned len; -{ - int ret; - unsigned got; - unsigned char in[1]; - z_stream *strm; - - if (gz == NULL || gz->write) - return 0; - if (gz->err) - return 0; - strm = &(gz->strm); - strm->next_out = (void *)buf; - strm->avail_out = len; - do { - got = fread(in, 1, 1, gz->file); - if (got == 0) - break; - strm->next_in = in; - strm->avail_in = 1; - ret = inflate(strm, Z_NO_FLUSH); - if (ret == Z_DATA_ERROR) { - gz->err = Z_DATA_ERROR; - gz->msg = strm->msg; - return 0; - } - if (ret == Z_STREAM_END) - inflateReset(strm); - } while (strm->avail_out); - return len - strm->avail_out; -} - -int gzclose OF((gzFile)); - -int gzclose(gz) - gzFile gz; -{ - z_stream *strm; - unsigned char out[BUFLEN]; - - if (gz == NULL) - return Z_STREAM_ERROR; - strm = &(gz->strm); - if (gz->write) { - strm->next_in = Z_NULL; - strm->avail_in = 0; - do { - strm->next_out = out; - strm->avail_out = BUFLEN; - (void)deflate(strm, Z_FINISH); - fwrite(out, 1, BUFLEN - strm->avail_out, gz->file); - } while (strm->avail_out == 0); - deflateEnd(strm); - } - else - inflateEnd(strm); - fclose(gz->file); - free(gz); - return Z_OK; -} - -const char *gzerror OF((gzFile, int *)); - -const char *gzerror(gz, err) - gzFile gz; - int *err; -{ - *err = gz->err; - return gz->msg; -} - -#endif - -static char *prog; - -void error OF((const char *msg)); -void gz_compress OF((FILE *in, gzFile out)); -#ifdef USE_MMAP -int gz_compress_mmap OF((FILE *in, gzFile out)); -#endif -void gz_uncompress OF((gzFile in, FILE *out)); -void file_compress OF((char *file, char *mode)); -void file_uncompress OF((char *file)); -int main OF((int argc, char *argv[])); - -/* =========================================================================== - * Display error message and exit - */ -void error(msg) - const char *msg; -{ - fprintf(stderr, "%s: %s\n", prog, msg); - exit(1); -} - -/* =========================================================================== - * Compress input to output then close both files. - */ - -void gz_compress(in, out) - FILE *in; - gzFile out; -{ - local char buf[BUFLEN]; - int len; - int err; - -#ifdef USE_MMAP - /* Try first compressing with mmap. If mmap fails (minigzip used in a - * pipe), use the normal fread loop. - */ - if (gz_compress_mmap(in, out) == Z_OK) return; -#endif - for (;;) { - len = (int)fread(buf, 1, sizeof(buf), in); - if (ferror(in)) { - perror("fread"); - exit(1); - } - if (len == 0) break; - - if (gzwrite(out, buf, (unsigned)len) != len) error(gzerror(out, &err)); - } - fclose(in); - if (gzclose(out) != Z_OK) error("failed gzclose"); -} - -#ifdef USE_MMAP /* MMAP version, Miguel Albrecht */ - -/* Try compressing the input file at once using mmap. Return Z_OK if - * if success, Z_ERRNO otherwise. - */ -int gz_compress_mmap(in, out) - FILE *in; - gzFile out; -{ - int len; - int err; - int ifd = fileno(in); - caddr_t buf; /* mmap'ed buffer for the entire input file */ - off_t buf_len; /* length of the input file */ - struct stat sb; - - /* Determine the size of the file, needed for mmap: */ - if (fstat(ifd, &sb) < 0) return Z_ERRNO; - buf_len = sb.st_size; - if (buf_len <= 0) return Z_ERRNO; - - /* Now do the actual mmap: */ - buf = mmap((caddr_t) 0, buf_len, PROT_READ, MAP_SHARED, ifd, (off_t)0); - if (buf == (caddr_t)(-1)) return Z_ERRNO; - - /* Compress the whole file at once: */ - len = gzwrite(out, (char *)buf, (unsigned)buf_len); - - if (len != (int)buf_len) error(gzerror(out, &err)); - - munmap(buf, buf_len); - fclose(in); - if (gzclose(out) != Z_OK) error("failed gzclose"); - return Z_OK; -} -#endif /* USE_MMAP */ - -/* =========================================================================== - * Uncompress input to output then close both files. - */ -void gz_uncompress(in, out) - gzFile in; - FILE *out; -{ - local char buf[BUFLEN]; - int len; - int err; - - for (;;) { - len = gzread(in, buf, sizeof(buf)); - if (len < 0) error (gzerror(in, &err)); - if (len == 0) break; - - if ((int)fwrite(buf, 1, (unsigned)len, out) != len) { - error("failed fwrite"); - } - } - if (fclose(out)) error("failed fclose"); - - if (gzclose(in) != Z_OK) error("failed gzclose"); -} - - -/* =========================================================================== - * Compress the given file: create a corresponding .gz file and remove the - * original. - */ -void file_compress(file, mode) - char *file; - char *mode; -{ - local char outfile[MAX_NAME_LEN]; - FILE *in; - gzFile out; - - if (strlen(file) + strlen(GZ_SUFFIX) >= sizeof(outfile)) { - fprintf(stderr, "%s: filename too long\n", prog); - exit(1); - } - -#if !defined(NO_snprintf) && !defined(NO_vsnprintf) - snprintf(outfile, sizeof(outfile), "%s%s", file, GZ_SUFFIX); -#else - strcpy(outfile, file); - strcat(outfile, GZ_SUFFIX); -#endif - - in = fopen(file, "rb"); - if (in == NULL) { - perror(file); - exit(1); - } - out = gzopen(outfile, mode); - if (out == NULL) { - fprintf(stderr, "%s: can't gzopen %s\n", prog, outfile); - exit(1); - } - gz_compress(in, out); - - unlink(file); -} - - -/* =========================================================================== - * Uncompress the given file and remove the original. - */ -void file_uncompress(file) - char *file; -{ - local char buf[MAX_NAME_LEN]; - char *infile, *outfile; - FILE *out; - gzFile in; - unsigned len = strlen(file); - - if (len + strlen(GZ_SUFFIX) >= sizeof(buf)) { - fprintf(stderr, "%s: filename too long\n", prog); - exit(1); - } - -#if !defined(NO_snprintf) && !defined(NO_vsnprintf) - snprintf(buf, sizeof(buf), "%s", file); -#else - strcpy(buf, file); -#endif - - if (len > SUFFIX_LEN && strcmp(file+len-SUFFIX_LEN, GZ_SUFFIX) == 0) { - infile = file; - outfile = buf; - outfile[len-3] = '\0'; - } else { - outfile = file; - infile = buf; -#if !defined(NO_snprintf) && !defined(NO_vsnprintf) - snprintf(buf + len, sizeof(buf) - len, "%s", GZ_SUFFIX); -#else - strcat(infile, GZ_SUFFIX); -#endif - } - in = gzopen(infile, "rb"); - if (in == NULL) { - fprintf(stderr, "%s: can't gzopen %s\n", prog, infile); - exit(1); - } - out = fopen(outfile, "wb"); - if (out == NULL) { - perror(file); - exit(1); - } - - gz_uncompress(in, out); - - unlink(infile); -} - - -/* =========================================================================== - * Usage: minigzip [-c] [-d] [-f] [-h] [-r] [-1 to -9] [files...] - * -c : write to standard output - * -d : decompress - * -f : compress with Z_FILTERED - * -h : compress with Z_HUFFMAN_ONLY - * -r : compress with Z_RLE - * -1 to -9 : compression level - */ - -int main(argc, argv) - int argc; - char *argv[]; -{ - int copyout = 0; - int uncompr = 0; - gzFile file; - char *bname, outmode[20]; - -#if !defined(NO_snprintf) && !defined(NO_vsnprintf) - snprintf(outmode, sizeof(outmode), "%s", "wb6 "); -#else - strcpy(outmode, "wb6 "); -#endif - - prog = argv[0]; - bname = strrchr(argv[0], '/'); - if (bname) - bname++; - else - bname = argv[0]; - argc--, argv++; - - if (!strcmp(bname, "gunzip")) - uncompr = 1; - else if (!strcmp(bname, "zcat")) - copyout = uncompr = 1; - - while (argc > 0) { - if (strcmp(*argv, "-c") == 0) - copyout = 1; - else if (strcmp(*argv, "-d") == 0) - uncompr = 1; - else if (strcmp(*argv, "-f") == 0) - outmode[3] = 'f'; - else if (strcmp(*argv, "-h") == 0) - outmode[3] = 'h'; - else if (strcmp(*argv, "-r") == 0) - outmode[3] = 'R'; - else if ((*argv)[0] == '-' && (*argv)[1] >= '1' && (*argv)[1] <= '9' && - (*argv)[2] == 0) - outmode[2] = (*argv)[1]; - else - break; - argc--, argv++; - } - if (outmode[3] == ' ') - outmode[3] = 0; - if (argc == 0) { - SET_BINARY_MODE(stdin); - SET_BINARY_MODE(stdout); - if (uncompr) { - file = gzdopen(fileno(stdin), "rb"); - if (file == NULL) error("can't gzdopen stdin"); - gz_uncompress(file, stdout); - } else { - file = gzdopen(fileno(stdout), outmode); - if (file == NULL) error("can't gzdopen stdout"); - gz_compress(stdin, file); - } - } else { - if (copyout) { - SET_BINARY_MODE(stdout); - } - do { - if (uncompr) { - if (copyout) { - file = gzopen(*argv, "rb"); - if (file == NULL) - fprintf(stderr, "%s: can't gzopen %s\n", prog, *argv); - else - gz_uncompress(file, stdout); - } else { - file_uncompress(*argv); - } - } else { - if (copyout) { - FILE * in = fopen(*argv, "rb"); - - if (in == NULL) { - perror(*argv); - } else { - file = gzdopen(fileno(stdout), outmode); - if (file == NULL) error("can't gzdopen stdout"); - - gz_compress(in, file); - } - - } else { - file_compress(*argv, outmode); - } - } - } while (argv++, --argc); - } - return 0; -} DELETED compat/zlib/treebuild.xml Index: compat/zlib/treebuild.xml ================================================================== --- compat/zlib/treebuild.xml +++ /dev/null @@ -1,116 +0,0 @@ - - - - zip compression library - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DELETED compat/zlib/trees.c Index: compat/zlib/trees.c ================================================================== --- compat/zlib/trees.c +++ /dev/null @@ -1,1203 +0,0 @@ -/* trees.c -- output deflated data using Huffman coding - * Copyright (C) 1995-2017 Jean-loup Gailly - * detect_data_type() function provided freely by Cosmin Truta, 2006 - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -/* - * ALGORITHM - * - * The "deflation" process uses several Huffman trees. The more - * common source values are represented by shorter bit sequences. - * - * Each code tree is stored in a compressed form which is itself - * a Huffman encoding of the lengths of all the code strings (in - * ascending order by source values). The actual code strings are - * reconstructed from the lengths in the inflate process, as described - * in the deflate specification. - * - * REFERENCES - * - * Deutsch, L.P.,"'Deflate' Compressed Data Format Specification". - * Available in ftp.uu.net:/pub/archiving/zip/doc/deflate-1.1.doc - * - * Storer, James A. - * Data Compression: Methods and Theory, pp. 49-50. - * Computer Science Press, 1988. ISBN 0-7167-8156-5. - * - * Sedgewick, R. - * Algorithms, p290. - * Addison-Wesley, 1983. ISBN 0-201-06672-6. - */ - -/* @(#) $Id$ */ - -/* #define GEN_TREES_H */ - -#include "deflate.h" - -#ifdef ZLIB_DEBUG -# include -#endif - -/* =========================================================================== - * Constants - */ - -#define MAX_BL_BITS 7 -/* Bit length codes must not exceed MAX_BL_BITS bits */ - -#define END_BLOCK 256 -/* end of block literal code */ - -#define REP_3_6 16 -/* repeat previous bit length 3-6 times (2 bits of repeat count) */ - -#define REPZ_3_10 17 -/* repeat a zero length 3-10 times (3 bits of repeat count) */ - -#define REPZ_11_138 18 -/* repeat a zero length 11-138 times (7 bits of repeat count) */ - -local const int extra_lbits[LENGTH_CODES] /* extra bits for each length code */ - = {0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,3,3,3,3,4,4,4,4,5,5,5,5,0}; - -local const int extra_dbits[D_CODES] /* extra bits for each distance code */ - = {0,0,0,0,1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8,9,9,10,10,11,11,12,12,13,13}; - -local const int extra_blbits[BL_CODES]/* extra bits for each bit length code */ - = {0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,2,3,7}; - -local const uch bl_order[BL_CODES] - = {16,17,18,0,8,7,9,6,10,5,11,4,12,3,13,2,14,1,15}; -/* The lengths of the bit length codes are sent in order of decreasing - * probability, to avoid transmitting the lengths for unused bit length codes. - */ - -/* =========================================================================== - * Local data. These are initialized only once. - */ - -#define DIST_CODE_LEN 512 /* see definition of array dist_code below */ - -#if defined(GEN_TREES_H) || !defined(STDC) -/* non ANSI compilers may not accept trees.h */ - -local ct_data static_ltree[L_CODES+2]; -/* The static literal tree. Since the bit lengths are imposed, there is no - * need for the L_CODES extra codes used during heap construction. However - * The codes 286 and 287 are needed to build a canonical tree (see _tr_init - * below). - */ - -local ct_data static_dtree[D_CODES]; -/* The static distance tree. (Actually a trivial tree since all codes use - * 5 bits.) - */ - -uch _dist_code[DIST_CODE_LEN]; -/* Distance codes. The first 256 values correspond to the distances - * 3 .. 258, the last 256 values correspond to the top 8 bits of - * the 15 bit distances. - */ - -uch _length_code[MAX_MATCH-MIN_MATCH+1]; -/* length code for each normalized match length (0 == MIN_MATCH) */ - -local int base_length[LENGTH_CODES]; -/* First normalized length for each code (0 = MIN_MATCH) */ - -local int base_dist[D_CODES]; -/* First normalized distance for each code (0 = distance of 1) */ - -#else -# include "trees.h" -#endif /* GEN_TREES_H */ - -struct static_tree_desc_s { - const ct_data *static_tree; /* static tree or NULL */ - const intf *extra_bits; /* extra bits for each code or NULL */ - int extra_base; /* base index for extra_bits */ - int elems; /* max number of elements in the tree */ - int max_length; /* max bit length for the codes */ -}; - -local const static_tree_desc static_l_desc = -{static_ltree, extra_lbits, LITERALS+1, L_CODES, MAX_BITS}; - -local const static_tree_desc static_d_desc = -{static_dtree, extra_dbits, 0, D_CODES, MAX_BITS}; - -local const static_tree_desc static_bl_desc = -{(const ct_data *)0, extra_blbits, 0, BL_CODES, MAX_BL_BITS}; - -/* =========================================================================== - * Local (static) routines in this file. - */ - -local void tr_static_init OF((void)); -local void init_block OF((deflate_state *s)); -local void pqdownheap OF((deflate_state *s, ct_data *tree, int k)); -local void gen_bitlen OF((deflate_state *s, tree_desc *desc)); -local void gen_codes OF((ct_data *tree, int max_code, ushf *bl_count)); -local void build_tree OF((deflate_state *s, tree_desc *desc)); -local void scan_tree OF((deflate_state *s, ct_data *tree, int max_code)); -local void send_tree OF((deflate_state *s, ct_data *tree, int max_code)); -local int build_bl_tree OF((deflate_state *s)); -local void send_all_trees OF((deflate_state *s, int lcodes, int dcodes, - int blcodes)); -local void compress_block OF((deflate_state *s, const ct_data *ltree, - const ct_data *dtree)); -local int detect_data_type OF((deflate_state *s)); -local unsigned bi_reverse OF((unsigned value, int length)); -local void bi_windup OF((deflate_state *s)); -local void bi_flush OF((deflate_state *s)); - -#ifdef GEN_TREES_H -local void gen_trees_header OF((void)); -#endif - -#ifndef ZLIB_DEBUG -# define send_code(s, c, tree) send_bits(s, tree[c].Code, tree[c].Len) - /* Send a code of the given tree. c and tree must not have side effects */ - -#else /* !ZLIB_DEBUG */ -# define send_code(s, c, tree) \ - { if (z_verbose>2) fprintf(stderr,"\ncd %3d ",(c)); \ - send_bits(s, tree[c].Code, tree[c].Len); } -#endif - -/* =========================================================================== - * Output a short LSB first on the stream. - * IN assertion: there is enough room in pendingBuf. - */ -#define put_short(s, w) { \ - put_byte(s, (uch)((w) & 0xff)); \ - put_byte(s, (uch)((ush)(w) >> 8)); \ -} - -/* =========================================================================== - * Send a value on a given number of bits. - * IN assertion: length <= 16 and value fits in length bits. - */ -#ifdef ZLIB_DEBUG -local void send_bits OF((deflate_state *s, int value, int length)); - -local void send_bits(s, value, length) - deflate_state *s; - int value; /* value to send */ - int length; /* number of bits */ -{ - Tracevv((stderr," l %2d v %4x ", length, value)); - Assert(length > 0 && length <= 15, "invalid length"); - s->bits_sent += (ulg)length; - - /* If not enough room in bi_buf, use (valid) bits from bi_buf and - * (16 - bi_valid) bits from value, leaving (width - (16-bi_valid)) - * unused bits in value. - */ - if (s->bi_valid > (int)Buf_size - length) { - s->bi_buf |= (ush)value << s->bi_valid; - put_short(s, s->bi_buf); - s->bi_buf = (ush)value >> (Buf_size - s->bi_valid); - s->bi_valid += length - Buf_size; - } else { - s->bi_buf |= (ush)value << s->bi_valid; - s->bi_valid += length; - } -} -#else /* !ZLIB_DEBUG */ - -#define send_bits(s, value, length) \ -{ int len = length;\ - if (s->bi_valid > (int)Buf_size - len) {\ - int val = (int)value;\ - s->bi_buf |= (ush)val << s->bi_valid;\ - put_short(s, s->bi_buf);\ - s->bi_buf = (ush)val >> (Buf_size - s->bi_valid);\ - s->bi_valid += len - Buf_size;\ - } else {\ - s->bi_buf |= (ush)(value) << s->bi_valid;\ - s->bi_valid += len;\ - }\ -} -#endif /* ZLIB_DEBUG */ - - -/* the arguments must not have side effects */ - -/* =========================================================================== - * Initialize the various 'constant' tables. - */ -local void tr_static_init() -{ -#if defined(GEN_TREES_H) || !defined(STDC) - static int static_init_done = 0; - int n; /* iterates over tree elements */ - int bits; /* bit counter */ - int length; /* length value */ - int code; /* code value */ - int dist; /* distance index */ - ush bl_count[MAX_BITS+1]; - /* number of codes at each bit length for an optimal tree */ - - if (static_init_done) return; - - /* For some embedded targets, global variables are not initialized: */ -#ifdef NO_INIT_GLOBAL_POINTERS - static_l_desc.static_tree = static_ltree; - static_l_desc.extra_bits = extra_lbits; - static_d_desc.static_tree = static_dtree; - static_d_desc.extra_bits = extra_dbits; - static_bl_desc.extra_bits = extra_blbits; -#endif - - /* Initialize the mapping length (0..255) -> length code (0..28) */ - length = 0; - for (code = 0; code < LENGTH_CODES-1; code++) { - base_length[code] = length; - for (n = 0; n < (1< dist code (0..29) */ - dist = 0; - for (code = 0 ; code < 16; code++) { - base_dist[code] = dist; - for (n = 0; n < (1<>= 7; /* from now on, all distances are divided by 128 */ - for ( ; code < D_CODES; code++) { - base_dist[code] = dist << 7; - for (n = 0; n < (1<<(extra_dbits[code]-7)); n++) { - _dist_code[256 + dist++] = (uch)code; - } - } - Assert (dist == 256, "tr_static_init: 256+dist != 512"); - - /* Construct the codes of the static literal tree */ - for (bits = 0; bits <= MAX_BITS; bits++) bl_count[bits] = 0; - n = 0; - while (n <= 143) static_ltree[n++].Len = 8, bl_count[8]++; - while (n <= 255) static_ltree[n++].Len = 9, bl_count[9]++; - while (n <= 279) static_ltree[n++].Len = 7, bl_count[7]++; - while (n <= 287) static_ltree[n++].Len = 8, bl_count[8]++; - /* Codes 286 and 287 do not exist, but we must include them in the - * tree construction to get a canonical Huffman tree (longest code - * all ones) - */ - gen_codes((ct_data *)static_ltree, L_CODES+1, bl_count); - - /* The static distance tree is trivial: */ - for (n = 0; n < D_CODES; n++) { - static_dtree[n].Len = 5; - static_dtree[n].Code = bi_reverse((unsigned)n, 5); - } - static_init_done = 1; - -# ifdef GEN_TREES_H - gen_trees_header(); -# endif -#endif /* defined(GEN_TREES_H) || !defined(STDC) */ -} - -/* =========================================================================== - * Genererate the file trees.h describing the static trees. - */ -#ifdef GEN_TREES_H -# ifndef ZLIB_DEBUG -# include -# endif - -# define SEPARATOR(i, last, width) \ - ((i) == (last)? "\n};\n\n" : \ - ((i) % (width) == (width)-1 ? ",\n" : ", ")) - -void gen_trees_header() -{ - FILE *header = fopen("trees.h", "w"); - int i; - - Assert (header != NULL, "Can't open trees.h"); - fprintf(header, - "/* header created automatically with -DGEN_TREES_H */\n\n"); - - fprintf(header, "local const ct_data static_ltree[L_CODES+2] = {\n"); - for (i = 0; i < L_CODES+2; i++) { - fprintf(header, "{{%3u},{%3u}}%s", static_ltree[i].Code, - static_ltree[i].Len, SEPARATOR(i, L_CODES+1, 5)); - } - - fprintf(header, "local const ct_data static_dtree[D_CODES] = {\n"); - for (i = 0; i < D_CODES; i++) { - fprintf(header, "{{%2u},{%2u}}%s", static_dtree[i].Code, - static_dtree[i].Len, SEPARATOR(i, D_CODES-1, 5)); - } - - fprintf(header, "const uch ZLIB_INTERNAL _dist_code[DIST_CODE_LEN] = {\n"); - for (i = 0; i < DIST_CODE_LEN; i++) { - fprintf(header, "%2u%s", _dist_code[i], - SEPARATOR(i, DIST_CODE_LEN-1, 20)); - } - - fprintf(header, - "const uch ZLIB_INTERNAL _length_code[MAX_MATCH-MIN_MATCH+1]= {\n"); - for (i = 0; i < MAX_MATCH-MIN_MATCH+1; i++) { - fprintf(header, "%2u%s", _length_code[i], - SEPARATOR(i, MAX_MATCH-MIN_MATCH, 20)); - } - - fprintf(header, "local const int base_length[LENGTH_CODES] = {\n"); - for (i = 0; i < LENGTH_CODES; i++) { - fprintf(header, "%1u%s", base_length[i], - SEPARATOR(i, LENGTH_CODES-1, 20)); - } - - fprintf(header, "local const int base_dist[D_CODES] = {\n"); - for (i = 0; i < D_CODES; i++) { - fprintf(header, "%5u%s", base_dist[i], - SEPARATOR(i, D_CODES-1, 10)); - } - - fclose(header); -} -#endif /* GEN_TREES_H */ - -/* =========================================================================== - * Initialize the tree data structures for a new zlib stream. - */ -void ZLIB_INTERNAL _tr_init(s) - deflate_state *s; -{ - tr_static_init(); - - s->l_desc.dyn_tree = s->dyn_ltree; - s->l_desc.stat_desc = &static_l_desc; - - s->d_desc.dyn_tree = s->dyn_dtree; - s->d_desc.stat_desc = &static_d_desc; - - s->bl_desc.dyn_tree = s->bl_tree; - s->bl_desc.stat_desc = &static_bl_desc; - - s->bi_buf = 0; - s->bi_valid = 0; -#ifdef ZLIB_DEBUG - s->compressed_len = 0L; - s->bits_sent = 0L; -#endif - - /* Initialize the first block of the first file: */ - init_block(s); -} - -/* =========================================================================== - * Initialize a new block. - */ -local void init_block(s) - deflate_state *s; -{ - int n; /* iterates over tree elements */ - - /* Initialize the trees. */ - for (n = 0; n < L_CODES; n++) s->dyn_ltree[n].Freq = 0; - for (n = 0; n < D_CODES; n++) s->dyn_dtree[n].Freq = 0; - for (n = 0; n < BL_CODES; n++) s->bl_tree[n].Freq = 0; - - s->dyn_ltree[END_BLOCK].Freq = 1; - s->opt_len = s->static_len = 0L; - s->last_lit = s->matches = 0; -} - -#define SMALLEST 1 -/* Index within the heap array of least frequent node in the Huffman tree */ - - -/* =========================================================================== - * Remove the smallest element from the heap and recreate the heap with - * one less element. Updates heap and heap_len. - */ -#define pqremove(s, tree, top) \ -{\ - top = s->heap[SMALLEST]; \ - s->heap[SMALLEST] = s->heap[s->heap_len--]; \ - pqdownheap(s, tree, SMALLEST); \ -} - -/* =========================================================================== - * Compares to subtrees, using the tree depth as tie breaker when - * the subtrees have equal frequency. This minimizes the worst case length. - */ -#define smaller(tree, n, m, depth) \ - (tree[n].Freq < tree[m].Freq || \ - (tree[n].Freq == tree[m].Freq && depth[n] <= depth[m])) - -/* =========================================================================== - * Restore the heap property by moving down the tree starting at node k, - * exchanging a node with the smallest of its two sons if necessary, stopping - * when the heap property is re-established (each father smaller than its - * two sons). - */ -local void pqdownheap(s, tree, k) - deflate_state *s; - ct_data *tree; /* the tree to restore */ - int k; /* node to move down */ -{ - int v = s->heap[k]; - int j = k << 1; /* left son of k */ - while (j <= s->heap_len) { - /* Set j to the smallest of the two sons: */ - if (j < s->heap_len && - smaller(tree, s->heap[j+1], s->heap[j], s->depth)) { - j++; - } - /* Exit if v is smaller than both sons */ - if (smaller(tree, v, s->heap[j], s->depth)) break; - - /* Exchange v with the smallest son */ - s->heap[k] = s->heap[j]; k = j; - - /* And continue down the tree, setting j to the left son of k */ - j <<= 1; - } - s->heap[k] = v; -} - -/* =========================================================================== - * Compute the optimal bit lengths for a tree and update the total bit length - * for the current block. - * IN assertion: the fields freq and dad are set, heap[heap_max] and - * above are the tree nodes sorted by increasing frequency. - * OUT assertions: the field len is set to the optimal bit length, the - * array bl_count contains the frequencies for each bit length. - * The length opt_len is updated; static_len is also updated if stree is - * not null. - */ -local void gen_bitlen(s, desc) - deflate_state *s; - tree_desc *desc; /* the tree descriptor */ -{ - ct_data *tree = desc->dyn_tree; - int max_code = desc->max_code; - const ct_data *stree = desc->stat_desc->static_tree; - const intf *extra = desc->stat_desc->extra_bits; - int base = desc->stat_desc->extra_base; - int max_length = desc->stat_desc->max_length; - int h; /* heap index */ - int n, m; /* iterate over the tree elements */ - int bits; /* bit length */ - int xbits; /* extra bits */ - ush f; /* frequency */ - int overflow = 0; /* number of elements with bit length too large */ - - for (bits = 0; bits <= MAX_BITS; bits++) s->bl_count[bits] = 0; - - /* In a first pass, compute the optimal bit lengths (which may - * overflow in the case of the bit length tree). - */ - tree[s->heap[s->heap_max]].Len = 0; /* root of the heap */ - - for (h = s->heap_max+1; h < HEAP_SIZE; h++) { - n = s->heap[h]; - bits = tree[tree[n].Dad].Len + 1; - if (bits > max_length) bits = max_length, overflow++; - tree[n].Len = (ush)bits; - /* We overwrite tree[n].Dad which is no longer needed */ - - if (n > max_code) continue; /* not a leaf node */ - - s->bl_count[bits]++; - xbits = 0; - if (n >= base) xbits = extra[n-base]; - f = tree[n].Freq; - s->opt_len += (ulg)f * (unsigned)(bits + xbits); - if (stree) s->static_len += (ulg)f * (unsigned)(stree[n].Len + xbits); - } - if (overflow == 0) return; - - Tracev((stderr,"\nbit length overflow\n")); - /* This happens for example on obj2 and pic of the Calgary corpus */ - - /* Find the first bit length which could increase: */ - do { - bits = max_length-1; - while (s->bl_count[bits] == 0) bits--; - s->bl_count[bits]--; /* move one leaf down the tree */ - s->bl_count[bits+1] += 2; /* move one overflow item as its brother */ - s->bl_count[max_length]--; - /* The brother of the overflow item also moves one step up, - * but this does not affect bl_count[max_length] - */ - overflow -= 2; - } while (overflow > 0); - - /* Now recompute all bit lengths, scanning in increasing frequency. - * h is still equal to HEAP_SIZE. (It is simpler to reconstruct all - * lengths instead of fixing only the wrong ones. This idea is taken - * from 'ar' written by Haruhiko Okumura.) - */ - for (bits = max_length; bits != 0; bits--) { - n = s->bl_count[bits]; - while (n != 0) { - m = s->heap[--h]; - if (m > max_code) continue; - if ((unsigned) tree[m].Len != (unsigned) bits) { - Tracev((stderr,"code %d bits %d->%d\n", m, tree[m].Len, bits)); - s->opt_len += ((ulg)bits - tree[m].Len) * tree[m].Freq; - tree[m].Len = (ush)bits; - } - n--; - } - } -} - -/* =========================================================================== - * Generate the codes for a given tree and bit counts (which need not be - * optimal). - * IN assertion: the array bl_count contains the bit length statistics for - * the given tree and the field len is set for all tree elements. - * OUT assertion: the field code is set for all tree elements of non - * zero code length. - */ -local void gen_codes (tree, max_code, bl_count) - ct_data *tree; /* the tree to decorate */ - int max_code; /* largest code with non zero frequency */ - ushf *bl_count; /* number of codes at each bit length */ -{ - ush next_code[MAX_BITS+1]; /* next code value for each bit length */ - unsigned code = 0; /* running code value */ - int bits; /* bit index */ - int n; /* code index */ - - /* The distribution counts are first used to generate the code values - * without bit reversal. - */ - for (bits = 1; bits <= MAX_BITS; bits++) { - code = (code + bl_count[bits-1]) << 1; - next_code[bits] = (ush)code; - } - /* Check that the bit counts in bl_count are consistent. The last code - * must be all ones. - */ - Assert (code + bl_count[MAX_BITS]-1 == (1<dyn_tree; - const ct_data *stree = desc->stat_desc->static_tree; - int elems = desc->stat_desc->elems; - int n, m; /* iterate over heap elements */ - int max_code = -1; /* largest code with non zero frequency */ - int node; /* new node being created */ - - /* Construct the initial heap, with least frequent element in - * heap[SMALLEST]. The sons of heap[n] are heap[2*n] and heap[2*n+1]. - * heap[0] is not used. - */ - s->heap_len = 0, s->heap_max = HEAP_SIZE; - - for (n = 0; n < elems; n++) { - if (tree[n].Freq != 0) { - s->heap[++(s->heap_len)] = max_code = n; - s->depth[n] = 0; - } else { - tree[n].Len = 0; - } - } - - /* The pkzip format requires that at least one distance code exists, - * and that at least one bit should be sent even if there is only one - * possible code. So to avoid special checks later on we force at least - * two codes of non zero frequency. - */ - while (s->heap_len < 2) { - node = s->heap[++(s->heap_len)] = (max_code < 2 ? ++max_code : 0); - tree[node].Freq = 1; - s->depth[node] = 0; - s->opt_len--; if (stree) s->static_len -= stree[node].Len; - /* node is 0 or 1 so it does not have extra bits */ - } - desc->max_code = max_code; - - /* The elements heap[heap_len/2+1 .. heap_len] are leaves of the tree, - * establish sub-heaps of increasing lengths: - */ - for (n = s->heap_len/2; n >= 1; n--) pqdownheap(s, tree, n); - - /* Construct the Huffman tree by repeatedly combining the least two - * frequent nodes. - */ - node = elems; /* next internal node of the tree */ - do { - pqremove(s, tree, n); /* n = node of least frequency */ - m = s->heap[SMALLEST]; /* m = node of next least frequency */ - - s->heap[--(s->heap_max)] = n; /* keep the nodes sorted by frequency */ - s->heap[--(s->heap_max)] = m; - - /* Create a new node father of n and m */ - tree[node].Freq = tree[n].Freq + tree[m].Freq; - s->depth[node] = (uch)((s->depth[n] >= s->depth[m] ? - s->depth[n] : s->depth[m]) + 1); - tree[n].Dad = tree[m].Dad = (ush)node; -#ifdef DUMP_BL_TREE - if (tree == s->bl_tree) { - fprintf(stderr,"\nnode %d(%d), sons %d(%d) %d(%d)", - node, tree[node].Freq, n, tree[n].Freq, m, tree[m].Freq); - } -#endif - /* and insert the new node in the heap */ - s->heap[SMALLEST] = node++; - pqdownheap(s, tree, SMALLEST); - - } while (s->heap_len >= 2); - - s->heap[--(s->heap_max)] = s->heap[SMALLEST]; - - /* At this point, the fields freq and dad are set. We can now - * generate the bit lengths. - */ - gen_bitlen(s, (tree_desc *)desc); - - /* The field len is now set, we can generate the bit codes */ - gen_codes ((ct_data *)tree, max_code, s->bl_count); -} - -/* =========================================================================== - * Scan a literal or distance tree to determine the frequencies of the codes - * in the bit length tree. - */ -local void scan_tree (s, tree, max_code) - deflate_state *s; - ct_data *tree; /* the tree to be scanned */ - int max_code; /* and its largest code of non zero frequency */ -{ - int n; /* iterates over all tree elements */ - int prevlen = -1; /* last emitted length */ - int curlen; /* length of current code */ - int nextlen = tree[0].Len; /* length of next code */ - int count = 0; /* repeat count of the current code */ - int max_count = 7; /* max repeat count */ - int min_count = 4; /* min repeat count */ - - if (nextlen == 0) max_count = 138, min_count = 3; - tree[max_code+1].Len = (ush)0xffff; /* guard */ - - for (n = 0; n <= max_code; n++) { - curlen = nextlen; nextlen = tree[n+1].Len; - if (++count < max_count && curlen == nextlen) { - continue; - } else if (count < min_count) { - s->bl_tree[curlen].Freq += count; - } else if (curlen != 0) { - if (curlen != prevlen) s->bl_tree[curlen].Freq++; - s->bl_tree[REP_3_6].Freq++; - } else if (count <= 10) { - s->bl_tree[REPZ_3_10].Freq++; - } else { - s->bl_tree[REPZ_11_138].Freq++; - } - count = 0; prevlen = curlen; - if (nextlen == 0) { - max_count = 138, min_count = 3; - } else if (curlen == nextlen) { - max_count = 6, min_count = 3; - } else { - max_count = 7, min_count = 4; - } - } -} - -/* =========================================================================== - * Send a literal or distance tree in compressed form, using the codes in - * bl_tree. - */ -local void send_tree (s, tree, max_code) - deflate_state *s; - ct_data *tree; /* the tree to be scanned */ - int max_code; /* and its largest code of non zero frequency */ -{ - int n; /* iterates over all tree elements */ - int prevlen = -1; /* last emitted length */ - int curlen; /* length of current code */ - int nextlen = tree[0].Len; /* length of next code */ - int count = 0; /* repeat count of the current code */ - int max_count = 7; /* max repeat count */ - int min_count = 4; /* min repeat count */ - - /* tree[max_code+1].Len = -1; */ /* guard already set */ - if (nextlen == 0) max_count = 138, min_count = 3; - - for (n = 0; n <= max_code; n++) { - curlen = nextlen; nextlen = tree[n+1].Len; - if (++count < max_count && curlen == nextlen) { - continue; - } else if (count < min_count) { - do { send_code(s, curlen, s->bl_tree); } while (--count != 0); - - } else if (curlen != 0) { - if (curlen != prevlen) { - send_code(s, curlen, s->bl_tree); count--; - } - Assert(count >= 3 && count <= 6, " 3_6?"); - send_code(s, REP_3_6, s->bl_tree); send_bits(s, count-3, 2); - - } else if (count <= 10) { - send_code(s, REPZ_3_10, s->bl_tree); send_bits(s, count-3, 3); - - } else { - send_code(s, REPZ_11_138, s->bl_tree); send_bits(s, count-11, 7); - } - count = 0; prevlen = curlen; - if (nextlen == 0) { - max_count = 138, min_count = 3; - } else if (curlen == nextlen) { - max_count = 6, min_count = 3; - } else { - max_count = 7, min_count = 4; - } - } -} - -/* =========================================================================== - * Construct the Huffman tree for the bit lengths and return the index in - * bl_order of the last bit length code to send. - */ -local int build_bl_tree(s) - deflate_state *s; -{ - int max_blindex; /* index of last bit length code of non zero freq */ - - /* Determine the bit length frequencies for literal and distance trees */ - scan_tree(s, (ct_data *)s->dyn_ltree, s->l_desc.max_code); - scan_tree(s, (ct_data *)s->dyn_dtree, s->d_desc.max_code); - - /* Build the bit length tree: */ - build_tree(s, (tree_desc *)(&(s->bl_desc))); - /* opt_len now includes the length of the tree representations, except - * the lengths of the bit lengths codes and the 5+5+4 bits for the counts. - */ - - /* Determine the number of bit length codes to send. The pkzip format - * requires that at least 4 bit length codes be sent. (appnote.txt says - * 3 but the actual value used is 4.) - */ - for (max_blindex = BL_CODES-1; max_blindex >= 3; max_blindex--) { - if (s->bl_tree[bl_order[max_blindex]].Len != 0) break; - } - /* Update opt_len to include the bit length tree and counts */ - s->opt_len += 3*((ulg)max_blindex+1) + 5+5+4; - Tracev((stderr, "\ndyn trees: dyn %ld, stat %ld", - s->opt_len, s->static_len)); - - return max_blindex; -} - -/* =========================================================================== - * Send the header for a block using dynamic Huffman trees: the counts, the - * lengths of the bit length codes, the literal tree and the distance tree. - * IN assertion: lcodes >= 257, dcodes >= 1, blcodes >= 4. - */ -local void send_all_trees(s, lcodes, dcodes, blcodes) - deflate_state *s; - int lcodes, dcodes, blcodes; /* number of codes for each tree */ -{ - int rank; /* index in bl_order */ - - Assert (lcodes >= 257 && dcodes >= 1 && blcodes >= 4, "not enough codes"); - Assert (lcodes <= L_CODES && dcodes <= D_CODES && blcodes <= BL_CODES, - "too many codes"); - Tracev((stderr, "\nbl counts: ")); - send_bits(s, lcodes-257, 5); /* not +255 as stated in appnote.txt */ - send_bits(s, dcodes-1, 5); - send_bits(s, blcodes-4, 4); /* not -3 as stated in appnote.txt */ - for (rank = 0; rank < blcodes; rank++) { - Tracev((stderr, "\nbl code %2d ", bl_order[rank])); - send_bits(s, s->bl_tree[bl_order[rank]].Len, 3); - } - Tracev((stderr, "\nbl tree: sent %ld", s->bits_sent)); - - send_tree(s, (ct_data *)s->dyn_ltree, lcodes-1); /* literal tree */ - Tracev((stderr, "\nlit tree: sent %ld", s->bits_sent)); - - send_tree(s, (ct_data *)s->dyn_dtree, dcodes-1); /* distance tree */ - Tracev((stderr, "\ndist tree: sent %ld", s->bits_sent)); -} - -/* =========================================================================== - * Send a stored block - */ -void ZLIB_INTERNAL _tr_stored_block(s, buf, stored_len, last) - deflate_state *s; - charf *buf; /* input block */ - ulg stored_len; /* length of input block */ - int last; /* one if this is the last block for a file */ -{ - send_bits(s, (STORED_BLOCK<<1)+last, 3); /* send block type */ - bi_windup(s); /* align on byte boundary */ - put_short(s, (ush)stored_len); - put_short(s, (ush)~stored_len); - zmemcpy(s->pending_buf + s->pending, (Bytef *)buf, stored_len); - s->pending += stored_len; -#ifdef ZLIB_DEBUG - s->compressed_len = (s->compressed_len + 3 + 7) & (ulg)~7L; - s->compressed_len += (stored_len + 4) << 3; - s->bits_sent += 2*16; - s->bits_sent += stored_len<<3; -#endif -} - -/* =========================================================================== - * Flush the bits in the bit buffer to pending output (leaves at most 7 bits) - */ -void ZLIB_INTERNAL _tr_flush_bits(s) - deflate_state *s; -{ - bi_flush(s); -} - -/* =========================================================================== - * Send one empty static block to give enough lookahead for inflate. - * This takes 10 bits, of which 7 may remain in the bit buffer. - */ -void ZLIB_INTERNAL _tr_align(s) - deflate_state *s; -{ - send_bits(s, STATIC_TREES<<1, 3); - send_code(s, END_BLOCK, static_ltree); -#ifdef ZLIB_DEBUG - s->compressed_len += 10L; /* 3 for block type, 7 for EOB */ -#endif - bi_flush(s); -} - -/* =========================================================================== - * Determine the best encoding for the current block: dynamic trees, static - * trees or store, and write out the encoded block. - */ -void ZLIB_INTERNAL _tr_flush_block(s, buf, stored_len, last) - deflate_state *s; - charf *buf; /* input block, or NULL if too old */ - ulg stored_len; /* length of input block */ - int last; /* one if this is the last block for a file */ -{ - ulg opt_lenb, static_lenb; /* opt_len and static_len in bytes */ - int max_blindex = 0; /* index of last bit length code of non zero freq */ - - /* Build the Huffman trees unless a stored block is forced */ - if (s->level > 0) { - - /* Check if the file is binary or text */ - if (s->strm->data_type == Z_UNKNOWN) - s->strm->data_type = detect_data_type(s); - - /* Construct the literal and distance trees */ - build_tree(s, (tree_desc *)(&(s->l_desc))); - Tracev((stderr, "\nlit data: dyn %ld, stat %ld", s->opt_len, - s->static_len)); - - build_tree(s, (tree_desc *)(&(s->d_desc))); - Tracev((stderr, "\ndist data: dyn %ld, stat %ld", s->opt_len, - s->static_len)); - /* At this point, opt_len and static_len are the total bit lengths of - * the compressed block data, excluding the tree representations. - */ - - /* Build the bit length tree for the above two trees, and get the index - * in bl_order of the last bit length code to send. - */ - max_blindex = build_bl_tree(s); - - /* Determine the best encoding. Compute the block lengths in bytes. */ - opt_lenb = (s->opt_len+3+7)>>3; - static_lenb = (s->static_len+3+7)>>3; - - Tracev((stderr, "\nopt %lu(%lu) stat %lu(%lu) stored %lu lit %u ", - opt_lenb, s->opt_len, static_lenb, s->static_len, stored_len, - s->last_lit)); - - if (static_lenb <= opt_lenb) opt_lenb = static_lenb; - - } else { - Assert(buf != (char*)0, "lost buf"); - opt_lenb = static_lenb = stored_len + 5; /* force a stored block */ - } - -#ifdef FORCE_STORED - if (buf != (char*)0) { /* force stored block */ -#else - if (stored_len+4 <= opt_lenb && buf != (char*)0) { - /* 4: two words for the lengths */ -#endif - /* The test buf != NULL is only necessary if LIT_BUFSIZE > WSIZE. - * Otherwise we can't have processed more than WSIZE input bytes since - * the last block flush, because compression would have been - * successful. If LIT_BUFSIZE <= WSIZE, it is never too late to - * transform a block into a stored block. - */ - _tr_stored_block(s, buf, stored_len, last); - -#ifdef FORCE_STATIC - } else if (static_lenb >= 0) { /* force static trees */ -#else - } else if (s->strategy == Z_FIXED || static_lenb == opt_lenb) { -#endif - send_bits(s, (STATIC_TREES<<1)+last, 3); - compress_block(s, (const ct_data *)static_ltree, - (const ct_data *)static_dtree); -#ifdef ZLIB_DEBUG - s->compressed_len += 3 + s->static_len; -#endif - } else { - send_bits(s, (DYN_TREES<<1)+last, 3); - send_all_trees(s, s->l_desc.max_code+1, s->d_desc.max_code+1, - max_blindex+1); - compress_block(s, (const ct_data *)s->dyn_ltree, - (const ct_data *)s->dyn_dtree); -#ifdef ZLIB_DEBUG - s->compressed_len += 3 + s->opt_len; -#endif - } - Assert (s->compressed_len == s->bits_sent, "bad compressed size"); - /* The above check is made mod 2^32, for files larger than 512 MB - * and uLong implemented on 32 bits. - */ - init_block(s); - - if (last) { - bi_windup(s); -#ifdef ZLIB_DEBUG - s->compressed_len += 7; /* align on byte boundary */ -#endif - } - Tracev((stderr,"\ncomprlen %lu(%lu) ", s->compressed_len>>3, - s->compressed_len-7*last)); -} - -/* =========================================================================== - * Save the match info and tally the frequency counts. Return true if - * the current block must be flushed. - */ -int ZLIB_INTERNAL _tr_tally (s, dist, lc) - deflate_state *s; - unsigned dist; /* distance of matched string */ - unsigned lc; /* match length-MIN_MATCH or unmatched char (if dist==0) */ -{ - s->d_buf[s->last_lit] = (ush)dist; - s->l_buf[s->last_lit++] = (uch)lc; - if (dist == 0) { - /* lc is the unmatched char */ - s->dyn_ltree[lc].Freq++; - } else { - s->matches++; - /* Here, lc is the match length - MIN_MATCH */ - dist--; /* dist = match distance - 1 */ - Assert((ush)dist < (ush)MAX_DIST(s) && - (ush)lc <= (ush)(MAX_MATCH-MIN_MATCH) && - (ush)d_code(dist) < (ush)D_CODES, "_tr_tally: bad match"); - - s->dyn_ltree[_length_code[lc]+LITERALS+1].Freq++; - s->dyn_dtree[d_code(dist)].Freq++; - } - -#ifdef TRUNCATE_BLOCK - /* Try to guess if it is profitable to stop the current block here */ - if ((s->last_lit & 0x1fff) == 0 && s->level > 2) { - /* Compute an upper bound for the compressed length */ - ulg out_length = (ulg)s->last_lit*8L; - ulg in_length = (ulg)((long)s->strstart - s->block_start); - int dcode; - for (dcode = 0; dcode < D_CODES; dcode++) { - out_length += (ulg)s->dyn_dtree[dcode].Freq * - (5L+extra_dbits[dcode]); - } - out_length >>= 3; - Tracev((stderr,"\nlast_lit %u, in %ld, out ~%ld(%ld%%) ", - s->last_lit, in_length, out_length, - 100L - out_length*100L/in_length)); - if (s->matches < s->last_lit/2 && out_length < in_length/2) return 1; - } -#endif - return (s->last_lit == s->lit_bufsize-1); - /* We avoid equality with lit_bufsize because of wraparound at 64K - * on 16 bit machines and because stored blocks are restricted to - * 64K-1 bytes. - */ -} - -/* =========================================================================== - * Send the block data compressed using the given Huffman trees - */ -local void compress_block(s, ltree, dtree) - deflate_state *s; - const ct_data *ltree; /* literal tree */ - const ct_data *dtree; /* distance tree */ -{ - unsigned dist; /* distance of matched string */ - int lc; /* match length or unmatched char (if dist == 0) */ - unsigned lx = 0; /* running index in l_buf */ - unsigned code; /* the code to send */ - int extra; /* number of extra bits to send */ - - if (s->last_lit != 0) do { - dist = s->d_buf[lx]; - lc = s->l_buf[lx++]; - if (dist == 0) { - send_code(s, lc, ltree); /* send a literal byte */ - Tracecv(isgraph(lc), (stderr," '%c' ", lc)); - } else { - /* Here, lc is the match length - MIN_MATCH */ - code = _length_code[lc]; - send_code(s, code+LITERALS+1, ltree); /* send the length code */ - extra = extra_lbits[code]; - if (extra != 0) { - lc -= base_length[code]; - send_bits(s, lc, extra); /* send the extra length bits */ - } - dist--; /* dist is now the match distance - 1 */ - code = d_code(dist); - Assert (code < D_CODES, "bad d_code"); - - send_code(s, code, dtree); /* send the distance code */ - extra = extra_dbits[code]; - if (extra != 0) { - dist -= (unsigned)base_dist[code]; - send_bits(s, dist, extra); /* send the extra distance bits */ - } - } /* literal or match pair ? */ - - /* Check that the overlay between pending_buf and d_buf+l_buf is ok: */ - Assert((uInt)(s->pending) < s->lit_bufsize + 2*lx, - "pendingBuf overflow"); - - } while (lx < s->last_lit); - - send_code(s, END_BLOCK, ltree); -} - -/* =========================================================================== - * Check if the data type is TEXT or BINARY, using the following algorithm: - * - TEXT if the two conditions below are satisfied: - * a) There are no non-portable control characters belonging to the - * "black list" (0..6, 14..25, 28..31). - * b) There is at least one printable character belonging to the - * "white list" (9 {TAB}, 10 {LF}, 13 {CR}, 32..255). - * - BINARY otherwise. - * - The following partially-portable control characters form a - * "gray list" that is ignored in this detection algorithm: - * (7 {BEL}, 8 {BS}, 11 {VT}, 12 {FF}, 26 {SUB}, 27 {ESC}). - * IN assertion: the fields Freq of dyn_ltree are set. - */ -local int detect_data_type(s) - deflate_state *s; -{ - /* black_mask is the bit mask of black-listed bytes - * set bits 0..6, 14..25, and 28..31 - * 0xf3ffc07f = binary 11110011111111111100000001111111 - */ - unsigned long black_mask = 0xf3ffc07fUL; - int n; - - /* Check for non-textual ("black-listed") bytes. */ - for (n = 0; n <= 31; n++, black_mask >>= 1) - if ((black_mask & 1) && (s->dyn_ltree[n].Freq != 0)) - return Z_BINARY; - - /* Check for textual ("white-listed") bytes. */ - if (s->dyn_ltree[9].Freq != 0 || s->dyn_ltree[10].Freq != 0 - || s->dyn_ltree[13].Freq != 0) - return Z_TEXT; - for (n = 32; n < LITERALS; n++) - if (s->dyn_ltree[n].Freq != 0) - return Z_TEXT; - - /* There are no "black-listed" or "white-listed" bytes: - * this stream either is empty or has tolerated ("gray-listed") bytes only. - */ - return Z_BINARY; -} - -/* =========================================================================== - * Reverse the first len bits of a code, using straightforward code (a faster - * method would use a table) - * IN assertion: 1 <= len <= 15 - */ -local unsigned bi_reverse(code, len) - unsigned code; /* the value to invert */ - int len; /* its bit length */ -{ - register unsigned res = 0; - do { - res |= code & 1; - code >>= 1, res <<= 1; - } while (--len > 0); - return res >> 1; -} - -/* =========================================================================== - * Flush the bit buffer, keeping at most 7 bits in it. - */ -local void bi_flush(s) - deflate_state *s; -{ - if (s->bi_valid == 16) { - put_short(s, s->bi_buf); - s->bi_buf = 0; - s->bi_valid = 0; - } else if (s->bi_valid >= 8) { - put_byte(s, (Byte)s->bi_buf); - s->bi_buf >>= 8; - s->bi_valid -= 8; - } -} - -/* =========================================================================== - * Flush the bit buffer and align the output on a byte boundary - */ -local void bi_windup(s) - deflate_state *s; -{ - if (s->bi_valid > 8) { - put_short(s, s->bi_buf); - } else if (s->bi_valid > 0) { - put_byte(s, (Byte)s->bi_buf); - } - s->bi_buf = 0; - s->bi_valid = 0; -#ifdef ZLIB_DEBUG - s->bits_sent = (s->bits_sent+7) & ~7; -#endif -} DELETED compat/zlib/trees.h Index: compat/zlib/trees.h ================================================================== --- compat/zlib/trees.h +++ /dev/null @@ -1,128 +0,0 @@ -/* header created automatically with -DGEN_TREES_H */ - -local const ct_data static_ltree[L_CODES+2] = { -{{ 12},{ 8}}, {{140},{ 8}}, {{ 76},{ 8}}, {{204},{ 8}}, {{ 44},{ 8}}, -{{172},{ 8}}, {{108},{ 8}}, {{236},{ 8}}, {{ 28},{ 8}}, {{156},{ 8}}, -{{ 92},{ 8}}, {{220},{ 8}}, {{ 60},{ 8}}, {{188},{ 8}}, {{124},{ 8}}, -{{252},{ 8}}, {{ 2},{ 8}}, {{130},{ 8}}, {{ 66},{ 8}}, {{194},{ 8}}, -{{ 34},{ 8}}, {{162},{ 8}}, {{ 98},{ 8}}, {{226},{ 8}}, {{ 18},{ 8}}, -{{146},{ 8}}, {{ 82},{ 8}}, {{210},{ 8}}, {{ 50},{ 8}}, {{178},{ 8}}, -{{114},{ 8}}, {{242},{ 8}}, {{ 10},{ 8}}, {{138},{ 8}}, {{ 74},{ 8}}, -{{202},{ 8}}, {{ 42},{ 8}}, {{170},{ 8}}, {{106},{ 8}}, {{234},{ 8}}, -{{ 26},{ 8}}, {{154},{ 8}}, {{ 90},{ 8}}, {{218},{ 8}}, {{ 58},{ 8}}, -{{186},{ 8}}, {{122},{ 8}}, {{250},{ 8}}, {{ 6},{ 8}}, {{134},{ 8}}, -{{ 70},{ 8}}, {{198},{ 8}}, {{ 38},{ 8}}, {{166},{ 8}}, {{102},{ 8}}, -{{230},{ 8}}, {{ 22},{ 8}}, {{150},{ 8}}, {{ 86},{ 8}}, {{214},{ 8}}, -{{ 54},{ 8}}, {{182},{ 8}}, {{118},{ 8}}, {{246},{ 8}}, {{ 14},{ 8}}, -{{142},{ 8}}, {{ 78},{ 8}}, {{206},{ 8}}, {{ 46},{ 8}}, {{174},{ 8}}, -{{110},{ 8}}, {{238},{ 8}}, {{ 30},{ 8}}, {{158},{ 8}}, {{ 94},{ 8}}, -{{222},{ 8}}, {{ 62},{ 8}}, {{190},{ 8}}, {{126},{ 8}}, {{254},{ 8}}, -{{ 1},{ 8}}, {{129},{ 8}}, {{ 65},{ 8}}, {{193},{ 8}}, {{ 33},{ 8}}, -{{161},{ 8}}, {{ 97},{ 8}}, {{225},{ 8}}, {{ 17},{ 8}}, {{145},{ 8}}, -{{ 81},{ 8}}, {{209},{ 8}}, {{ 49},{ 8}}, {{177},{ 8}}, {{113},{ 8}}, -{{241},{ 8}}, {{ 9},{ 8}}, {{137},{ 8}}, {{ 73},{ 8}}, {{201},{ 8}}, -{{ 41},{ 8}}, {{169},{ 8}}, {{105},{ 8}}, {{233},{ 8}}, {{ 25},{ 8}}, -{{153},{ 8}}, {{ 89},{ 8}}, {{217},{ 8}}, {{ 57},{ 8}}, {{185},{ 8}}, -{{121},{ 8}}, {{249},{ 8}}, {{ 5},{ 8}}, {{133},{ 8}}, {{ 69},{ 8}}, -{{197},{ 8}}, {{ 37},{ 8}}, {{165},{ 8}}, {{101},{ 8}}, {{229},{ 8}}, -{{ 21},{ 8}}, {{149},{ 8}}, {{ 85},{ 8}}, {{213},{ 8}}, {{ 53},{ 8}}, -{{181},{ 8}}, {{117},{ 8}}, {{245},{ 8}}, {{ 13},{ 8}}, {{141},{ 8}}, -{{ 77},{ 8}}, {{205},{ 8}}, {{ 45},{ 8}}, {{173},{ 8}}, {{109},{ 8}}, -{{237},{ 8}}, {{ 29},{ 8}}, {{157},{ 8}}, {{ 93},{ 8}}, {{221},{ 8}}, -{{ 61},{ 8}}, {{189},{ 8}}, {{125},{ 8}}, {{253},{ 8}}, {{ 19},{ 9}}, -{{275},{ 9}}, {{147},{ 9}}, {{403},{ 9}}, {{ 83},{ 9}}, {{339},{ 9}}, -{{211},{ 9}}, {{467},{ 9}}, {{ 51},{ 9}}, {{307},{ 9}}, {{179},{ 9}}, -{{435},{ 9}}, {{115},{ 9}}, {{371},{ 9}}, {{243},{ 9}}, {{499},{ 9}}, -{{ 11},{ 9}}, {{267},{ 9}}, {{139},{ 9}}, {{395},{ 9}}, {{ 75},{ 9}}, -{{331},{ 9}}, {{203},{ 9}}, {{459},{ 9}}, {{ 43},{ 9}}, {{299},{ 9}}, -{{171},{ 9}}, {{427},{ 9}}, {{107},{ 9}}, {{363},{ 9}}, {{235},{ 9}}, -{{491},{ 9}}, {{ 27},{ 9}}, {{283},{ 9}}, {{155},{ 9}}, {{411},{ 9}}, -{{ 91},{ 9}}, {{347},{ 9}}, {{219},{ 9}}, {{475},{ 9}}, {{ 59},{ 9}}, -{{315},{ 9}}, {{187},{ 9}}, {{443},{ 9}}, {{123},{ 9}}, {{379},{ 9}}, -{{251},{ 9}}, {{507},{ 9}}, {{ 7},{ 9}}, {{263},{ 9}}, {{135},{ 9}}, -{{391},{ 9}}, {{ 71},{ 9}}, {{327},{ 9}}, {{199},{ 9}}, {{455},{ 9}}, -{{ 39},{ 9}}, {{295},{ 9}}, {{167},{ 9}}, {{423},{ 9}}, {{103},{ 9}}, -{{359},{ 9}}, {{231},{ 9}}, {{487},{ 9}}, {{ 23},{ 9}}, {{279},{ 9}}, -{{151},{ 9}}, {{407},{ 9}}, {{ 87},{ 9}}, {{343},{ 9}}, {{215},{ 9}}, -{{471},{ 9}}, {{ 55},{ 9}}, {{311},{ 9}}, {{183},{ 9}}, {{439},{ 9}}, -{{119},{ 9}}, {{375},{ 9}}, {{247},{ 9}}, {{503},{ 9}}, {{ 15},{ 9}}, -{{271},{ 9}}, {{143},{ 9}}, {{399},{ 9}}, {{ 79},{ 9}}, {{335},{ 9}}, -{{207},{ 9}}, {{463},{ 9}}, {{ 47},{ 9}}, {{303},{ 9}}, {{175},{ 9}}, -{{431},{ 9}}, {{111},{ 9}}, {{367},{ 9}}, {{239},{ 9}}, {{495},{ 9}}, -{{ 31},{ 9}}, {{287},{ 9}}, {{159},{ 9}}, {{415},{ 9}}, {{ 95},{ 9}}, -{{351},{ 9}}, {{223},{ 9}}, {{479},{ 9}}, {{ 63},{ 9}}, {{319},{ 9}}, -{{191},{ 9}}, {{447},{ 9}}, {{127},{ 9}}, {{383},{ 9}}, {{255},{ 9}}, -{{511},{ 9}}, {{ 0},{ 7}}, {{ 64},{ 7}}, {{ 32},{ 7}}, {{ 96},{ 7}}, -{{ 16},{ 7}}, {{ 80},{ 7}}, {{ 48},{ 7}}, {{112},{ 7}}, {{ 8},{ 7}}, -{{ 72},{ 7}}, {{ 40},{ 7}}, {{104},{ 7}}, {{ 24},{ 7}}, {{ 88},{ 7}}, -{{ 56},{ 7}}, {{120},{ 7}}, {{ 4},{ 7}}, {{ 68},{ 7}}, {{ 36},{ 7}}, -{{100},{ 7}}, {{ 20},{ 7}}, {{ 84},{ 7}}, {{ 52},{ 7}}, {{116},{ 7}}, -{{ 3},{ 8}}, {{131},{ 8}}, {{ 67},{ 8}}, {{195},{ 8}}, {{ 35},{ 8}}, -{{163},{ 8}}, {{ 99},{ 8}}, {{227},{ 8}} -}; - -local const ct_data static_dtree[D_CODES] = { -{{ 0},{ 5}}, {{16},{ 5}}, {{ 8},{ 5}}, {{24},{ 5}}, {{ 4},{ 5}}, -{{20},{ 5}}, {{12},{ 5}}, {{28},{ 5}}, {{ 2},{ 5}}, {{18},{ 5}}, -{{10},{ 5}}, {{26},{ 5}}, {{ 6},{ 5}}, {{22},{ 5}}, {{14},{ 5}}, -{{30},{ 5}}, {{ 1},{ 5}}, {{17},{ 5}}, {{ 9},{ 5}}, {{25},{ 5}}, -{{ 5},{ 5}}, {{21},{ 5}}, {{13},{ 5}}, {{29},{ 5}}, {{ 3},{ 5}}, -{{19},{ 5}}, {{11},{ 5}}, {{27},{ 5}}, {{ 7},{ 5}}, {{23},{ 5}} -}; - -const uch ZLIB_INTERNAL _dist_code[DIST_CODE_LEN] = { - 0, 1, 2, 3, 4, 4, 5, 5, 6, 6, 6, 6, 7, 7, 7, 7, 8, 8, 8, 8, - 8, 8, 8, 8, 9, 9, 9, 9, 9, 9, 9, 9, 10, 10, 10, 10, 10, 10, 10, 10, -10, 10, 10, 10, 10, 10, 10, 10, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, -11, 11, 11, 11, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, -12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 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, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, -14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, -14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, -14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15, -15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, -15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 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, 16, 17, -18, 18, 19, 19, 20, 20, 20, 20, 21, 21, 21, 21, 22, 22, 22, 22, 22, 22, 22, 22, -23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, -24, 24, 24, 24, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, -26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, -26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27, -27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, -27, 27, 27, 27, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, -28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, -28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, -28, 28, 28, 28, 28, 28, 28, 28, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, -29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, -29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, -29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29 -}; - -const uch ZLIB_INTERNAL _length_code[MAX_MATCH-MIN_MATCH+1]= { - 0, 1, 2, 3, 4, 5, 6, 7, 8, 8, 9, 9, 10, 10, 11, 11, 12, 12, 12, 12, -13, 13, 13, 13, 14, 14, 14, 14, 15, 15, 15, 15, 16, 16, 16, 16, 16, 16, 16, 16, -17, 17, 17, 17, 17, 17, 17, 17, 18, 18, 18, 18, 18, 18, 18, 18, 19, 19, 19, 19, -19, 19, 19, 19, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, -21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 22, 22, 22, 22, -22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 23, 23, 23, 23, 23, 23, 23, 23, -23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, -24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, -25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, -25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 26, 26, 26, 26, 26, 26, 26, 26, -26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, -26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, -27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 28 -}; - -local const int base_length[LENGTH_CODES] = { -0, 1, 2, 3, 4, 5, 6, 7, 8, 10, 12, 14, 16, 20, 24, 28, 32, 40, 48, 56, -64, 80, 96, 112, 128, 160, 192, 224, 0 -}; - -local const int base_dist[D_CODES] = { - 0, 1, 2, 3, 4, 6, 8, 12, 16, 24, - 32, 48, 64, 96, 128, 192, 256, 384, 512, 768, - 1024, 1536, 2048, 3072, 4096, 6144, 8192, 12288, 16384, 24576 -}; - DELETED compat/zlib/uncompr.c Index: compat/zlib/uncompr.c ================================================================== --- compat/zlib/uncompr.c +++ /dev/null @@ -1,93 +0,0 @@ -/* uncompr.c -- decompress a memory buffer - * Copyright (C) 1995-2003, 2010, 2014, 2016 Jean-loup Gailly, Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -/* @(#) $Id$ */ - -#define ZLIB_INTERNAL -#include "zlib.h" - -/* =========================================================================== - Decompresses the source buffer into the destination buffer. *sourceLen is - the byte length of the source buffer. Upon entry, *destLen is the total size - of the destination buffer, which must be large enough to hold the entire - uncompressed data. (The size of the uncompressed data must have been saved - previously by the compressor and transmitted to the decompressor by some - mechanism outside the scope of this compression library.) Upon exit, - *destLen is the size of the decompressed data and *sourceLen is the number - of source bytes consumed. Upon return, source + *sourceLen points to the - first unused input byte. - - uncompress returns Z_OK if success, Z_MEM_ERROR if there was not enough - memory, Z_BUF_ERROR if there was not enough room in the output buffer, or - Z_DATA_ERROR if the input data was corrupted, including if the input data is - an incomplete zlib stream. -*/ -int ZEXPORT uncompress2 (dest, destLen, source, sourceLen) - Bytef *dest; - uLongf *destLen; - const Bytef *source; - uLong *sourceLen; -{ - z_stream stream; - int err; - const uInt max = (uInt)-1; - uLong len, left; - Byte buf[1]; /* for detection of incomplete stream when *destLen == 0 */ - - len = *sourceLen; - if (*destLen) { - left = *destLen; - *destLen = 0; - } - else { - left = 1; - dest = buf; - } - - stream.next_in = (z_const Bytef *)source; - stream.avail_in = 0; - stream.zalloc = (alloc_func)0; - stream.zfree = (free_func)0; - stream.opaque = (voidpf)0; - - err = inflateInit(&stream); - if (err != Z_OK) return err; - - stream.next_out = dest; - stream.avail_out = 0; - - do { - if (stream.avail_out == 0) { - stream.avail_out = left > (uLong)max ? max : (uInt)left; - left -= stream.avail_out; - } - if (stream.avail_in == 0) { - stream.avail_in = len > (uLong)max ? max : (uInt)len; - len -= stream.avail_in; - } - err = inflate(&stream, Z_NO_FLUSH); - } while (err == Z_OK); - - *sourceLen -= len + stream.avail_in; - if (dest != buf) - *destLen = stream.total_out; - else if (stream.total_out && err == Z_BUF_ERROR) - left = 1; - - inflateEnd(&stream); - return err == Z_STREAM_END ? Z_OK : - err == Z_NEED_DICT ? Z_DATA_ERROR : - err == Z_BUF_ERROR && left + stream.avail_out ? Z_DATA_ERROR : - err; -} - -int ZEXPORT uncompress (dest, destLen, source, sourceLen) - Bytef *dest; - uLongf *destLen; - const Bytef *source; - uLong sourceLen; -{ - return uncompress2(dest, destLen, source, &sourceLen); -} DELETED compat/zlib/watcom/watcom_f.mak Index: compat/zlib/watcom/watcom_f.mak ================================================================== --- compat/zlib/watcom/watcom_f.mak +++ /dev/null @@ -1,43 +0,0 @@ -# Makefile for zlib -# OpenWatcom flat model -# Last updated: 28-Dec-2005 - -# To use, do "wmake -f watcom_f.mak" - -C_SOURCE = adler32.c compress.c crc32.c deflate.c & - gzclose.c gzlib.c gzread.c gzwrite.c & - infback.c inffast.c inflate.c inftrees.c & - trees.c uncompr.c zutil.c - -OBJS = adler32.obj compress.obj crc32.obj deflate.obj & - gzclose.obj gzlib.obj gzread.obj gzwrite.obj & - infback.obj inffast.obj inflate.obj inftrees.obj & - trees.obj uncompr.obj zutil.obj - -CC = wcc386 -LINKER = wcl386 -CFLAGS = -zq -mf -3r -fp3 -s -bt=dos -oilrtfm -fr=nul -wx -ZLIB_LIB = zlib_f.lib - -.C.OBJ: - $(CC) $(CFLAGS) $[@ - -all: $(ZLIB_LIB) example.exe minigzip.exe - -$(ZLIB_LIB): $(OBJS) - wlib -b -c $(ZLIB_LIB) -+adler32.obj -+compress.obj -+crc32.obj - wlib -b -c $(ZLIB_LIB) -+gzclose.obj -+gzlib.obj -+gzread.obj -+gzwrite.obj - wlib -b -c $(ZLIB_LIB) -+deflate.obj -+infback.obj - wlib -b -c $(ZLIB_LIB) -+inffast.obj -+inflate.obj -+inftrees.obj - wlib -b -c $(ZLIB_LIB) -+trees.obj -+uncompr.obj -+zutil.obj - -example.exe: $(ZLIB_LIB) example.obj - $(LINKER) -ldos32a -fe=example.exe example.obj $(ZLIB_LIB) - -minigzip.exe: $(ZLIB_LIB) minigzip.obj - $(LINKER) -ldos32a -fe=minigzip.exe minigzip.obj $(ZLIB_LIB) - -clean: .SYMBOLIC - del *.obj - del $(ZLIB_LIB) - @echo Cleaning done DELETED compat/zlib/watcom/watcom_l.mak Index: compat/zlib/watcom/watcom_l.mak ================================================================== --- compat/zlib/watcom/watcom_l.mak +++ /dev/null @@ -1,43 +0,0 @@ -# Makefile for zlib -# OpenWatcom large model -# Last updated: 28-Dec-2005 - -# To use, do "wmake -f watcom_l.mak" - -C_SOURCE = adler32.c compress.c crc32.c deflate.c & - gzclose.c gzlib.c gzread.c gzwrite.c & - infback.c inffast.c inflate.c inftrees.c & - trees.c uncompr.c zutil.c - -OBJS = adler32.obj compress.obj crc32.obj deflate.obj & - gzclose.obj gzlib.obj gzread.obj gzwrite.obj & - infback.obj inffast.obj inflate.obj inftrees.obj & - trees.obj uncompr.obj zutil.obj - -CC = wcc -LINKER = wcl -CFLAGS = -zq -ml -s -bt=dos -oilrtfm -fr=nul -wx -ZLIB_LIB = zlib_l.lib - -.C.OBJ: - $(CC) $(CFLAGS) $[@ - -all: $(ZLIB_LIB) example.exe minigzip.exe - -$(ZLIB_LIB): $(OBJS) - wlib -b -c $(ZLIB_LIB) -+adler32.obj -+compress.obj -+crc32.obj - wlib -b -c $(ZLIB_LIB) -+gzclose.obj -+gzlib.obj -+gzread.obj -+gzwrite.obj - wlib -b -c $(ZLIB_LIB) -+deflate.obj -+infback.obj - wlib -b -c $(ZLIB_LIB) -+inffast.obj -+inflate.obj -+inftrees.obj - wlib -b -c $(ZLIB_LIB) -+trees.obj -+uncompr.obj -+zutil.obj - -example.exe: $(ZLIB_LIB) example.obj - $(LINKER) -fe=example.exe example.obj $(ZLIB_LIB) - -minigzip.exe: $(ZLIB_LIB) minigzip.obj - $(LINKER) -fe=minigzip.exe minigzip.obj $(ZLIB_LIB) - -clean: .SYMBOLIC - del *.obj - del $(ZLIB_LIB) - @echo Cleaning done DELETED compat/zlib/win32/DLL_FAQ.txt Index: compat/zlib/win32/DLL_FAQ.txt ================================================================== --- compat/zlib/win32/DLL_FAQ.txt +++ /dev/null @@ -1,397 +0,0 @@ - - Frequently Asked Questions about ZLIB1.DLL - - -This document describes the design, the rationale, and the usage -of the official DLL build of zlib, named ZLIB1.DLL. If you have -general questions about zlib, you should see the file "FAQ" found -in the zlib distribution, or at the following location: - http://www.gzip.org/zlib/zlib_faq.html - - - 1. What is ZLIB1.DLL, and how can I get it? - - - ZLIB1.DLL is the official build of zlib as a DLL. - (Please remark the character '1' in the name.) - - Pointers to a precompiled ZLIB1.DLL can be found in the zlib - web site at: - http://www.zlib.net/ - - Applications that link to ZLIB1.DLL can rely on the following - specification: - - * The exported symbols are exclusively defined in the source - files "zlib.h" and "zlib.def", found in an official zlib - source distribution. - * The symbols are exported by name, not by ordinal. - * The exported names are undecorated. - * The calling convention of functions is "C" (CDECL). - * The ZLIB1.DLL binary is linked to MSVCRT.DLL. - - The archive in which ZLIB1.DLL is bundled contains compiled - test programs that must run with a valid build of ZLIB1.DLL. - It is recommended to download the prebuilt DLL from the zlib - web site, instead of building it yourself, to avoid potential - incompatibilities that could be introduced by your compiler - and build settings. If you do build the DLL yourself, please - make sure that it complies with all the above requirements, - and it runs with the precompiled test programs, bundled with - the original ZLIB1.DLL distribution. - - If, for any reason, you need to build an incompatible DLL, - please use a different file name. - - - 2. Why did you change the name of the DLL to ZLIB1.DLL? - What happened to the old ZLIB.DLL? - - - The old ZLIB.DLL, built from zlib-1.1.4 or earlier, required - compilation settings that were incompatible to those used by - a static build. The DLL settings were supposed to be enabled - by defining the macro ZLIB_DLL, before including "zlib.h". - Incorrect handling of this macro was silently accepted at - build time, resulting in two major problems: - - * ZLIB_DLL was missing from the old makefile. When building - the DLL, not all people added it to the build options. In - consequence, incompatible incarnations of ZLIB.DLL started - to circulate around the net. - - * When switching from using the static library to using the - DLL, applications had to define the ZLIB_DLL macro and - to recompile all the sources that contained calls to zlib - functions. Failure to do so resulted in creating binaries - that were unable to run with the official ZLIB.DLL build. - - The only possible solution that we could foresee was to make - a binary-incompatible change in the DLL interface, in order to - remove the dependency on the ZLIB_DLL macro, and to release - the new DLL under a different name. - - We chose the name ZLIB1.DLL, where '1' indicates the major - zlib version number. We hope that we will not have to break - the binary compatibility again, at least not as long as the - zlib-1.x series will last. - - There is still a ZLIB_DLL macro, that can trigger a more - efficient build and use of the DLL, but compatibility no - longer dependents on it. - - - 3. Can I build ZLIB.DLL from the new zlib sources, and replace - an old ZLIB.DLL, that was built from zlib-1.1.4 or earlier? - - - In principle, you can do it by assigning calling convention - keywords to the macros ZEXPORT and ZEXPORTVA. In practice, - it depends on what you mean by "an old ZLIB.DLL", because the - old DLL exists in several mutually-incompatible versions. - You have to find out first what kind of calling convention is - being used in your particular ZLIB.DLL build, and to use the - same one in the new build. If you don't know what this is all - about, you might be better off if you would just leave the old - DLL intact. - - - 4. Can I compile my application using the new zlib interface, and - link it to an old ZLIB.DLL, that was built from zlib-1.1.4 or - earlier? - - - The official answer is "no"; the real answer depends again on - what kind of ZLIB.DLL you have. Even if you are lucky, this - course of action is unreliable. - - If you rebuild your application and you intend to use a newer - version of zlib (post- 1.1.4), it is strongly recommended to - link it to the new ZLIB1.DLL. - - - 5. Why are the zlib symbols exported by name, and not by ordinal? - - - Although exporting symbols by ordinal is a little faster, it - is risky. Any single glitch in the maintenance or use of the - DEF file that contains the ordinals can result in incompatible - builds and frustrating crashes. Simply put, the benefits of - exporting symbols by ordinal do not justify the risks. - - Technically, it should be possible to maintain ordinals in - the DEF file, and still export the symbols by name. Ordinals - exist in every DLL, and even if the dynamic linking performed - at the DLL startup is searching for names, ordinals serve as - hints, for a faster name lookup. However, if the DEF file - contains ordinals, the Microsoft linker automatically builds - an implib that will cause the executables linked to it to use - those ordinals, and not the names. It is interesting to - notice that the GNU linker for Win32 does not suffer from this - problem. - - It is possible to avoid the DEF file if the exported symbols - are accompanied by a "__declspec(dllexport)" attribute in the - source files. You can do this in zlib by predefining the - ZLIB_DLL macro. - - - 6. I see that the ZLIB1.DLL functions use the "C" (CDECL) calling - convention. Why not use the STDCALL convention? - STDCALL is the standard convention in Win32, and I need it in - my Visual Basic project! - - (For readability, we use CDECL to refer to the convention - triggered by the "__cdecl" keyword, STDCALL to refer to - the convention triggered by "__stdcall", and FASTCALL to - refer to the convention triggered by "__fastcall".) - - - Most of the native Windows API functions (without varargs) use - indeed the WINAPI convention (which translates to STDCALL in - Win32), but the standard C functions use CDECL. If a user - application is intrinsically tied to the Windows API (e.g. - it calls native Windows API functions such as CreateFile()), - sometimes it makes sense to decorate its own functions with - WINAPI. But if ANSI C or POSIX portability is a goal (e.g. - it calls standard C functions such as fopen()), it is not a - sound decision to request the inclusion of , or to - use non-ANSI constructs, for the sole purpose to make the user - functions STDCALL-able. - - The functionality offered by zlib is not in the category of - "Windows functionality", but is more like "C functionality". - - Technically, STDCALL is not bad; in fact, it is slightly - faster than CDECL, and it works with variable-argument - functions, just like CDECL. It is unfortunate that, in spite - of using STDCALL in the Windows API, it is not the default - convention used by the C compilers that run under Windows. - The roots of the problem reside deep inside the unsafety of - the K&R-style function prototypes, where the argument types - are not specified; but that is another story for another day. - - The remaining fact is that CDECL is the default convention. - Even if an explicit convention is hard-coded into the function - prototypes inside C headers, problems may appear. The - necessity to expose the convention in users' callbacks is one - of these problems. - - The calling convention issues are also important when using - zlib in other programming languages. Some of them, like Ada - (GNAT) and Fortran (GNU G77), have C bindings implemented - initially on Unix, and relying on the C calling convention. - On the other hand, the pre- .NET versions of Microsoft Visual - Basic require STDCALL, while Borland Delphi prefers, although - it does not require, FASTCALL. - - In fairness to all possible uses of zlib outside the C - programming language, we choose the default "C" convention. - Anyone interested in different bindings or conventions is - encouraged to maintain specialized projects. The "contrib/" - directory from the zlib distribution already holds a couple - of foreign bindings, such as Ada, C++, and Delphi. - - - 7. I need a DLL for my Visual Basic project. What can I do? - - - Define the ZLIB_WINAPI macro before including "zlib.h", when - building both the DLL and the user application (except that - you don't need to define anything when using the DLL in Visual - Basic). The ZLIB_WINAPI macro will switch on the WINAPI - (STDCALL) convention. The name of this DLL must be different - than the official ZLIB1.DLL. - - Gilles Vollant has contributed a build named ZLIBWAPI.DLL, - with the ZLIB_WINAPI macro turned on, and with the minizip - functionality built in. For more information, please read - the notes inside "contrib/vstudio/readme.txt", found in the - zlib distribution. - - - 8. I need to use zlib in my Microsoft .NET project. What can I - do? - - - Henrik Ravn has contributed a .NET wrapper around zlib. Look - into contrib/dotzlib/, inside the zlib distribution. - - - 9. If my application uses ZLIB1.DLL, should I link it to - MSVCRT.DLL? Why? - - - It is not required, but it is recommended to link your - application to MSVCRT.DLL, if it uses ZLIB1.DLL. - - The executables (.EXE, .DLL, etc.) that are involved in the - same process and are using the C run-time library (i.e. they - are calling standard C functions), must link to the same - library. There are several libraries in the Win32 system: - CRTDLL.DLL, MSVCRT.DLL, the static C libraries, etc. - Since ZLIB1.DLL is linked to MSVCRT.DLL, the executables that - depend on it should also be linked to MSVCRT.DLL. - - -10. Why are you saying that ZLIB1.DLL and my application should - be linked to the same C run-time (CRT) library? I linked my - application and my DLLs to different C libraries (e.g. my - application to a static library, and my DLLs to MSVCRT.DLL), - and everything works fine. - - - If a user library invokes only pure Win32 API (accessible via - and the related headers), its DLL build will work - in any context. But if this library invokes standard C API, - things get more complicated. - - There is a single Win32 library in a Win32 system. Every - function in this library resides in a single DLL module, that - is safe to call from anywhere. On the other hand, there are - multiple versions of the C library, and each of them has its - own separate internal state. Standalone executables and user - DLLs that call standard C functions must link to a C run-time - (CRT) library, be it static or shared (DLL). Intermixing - occurs when an executable (not necessarily standalone) and a - DLL are linked to different CRTs, and both are running in the - same process. - - Intermixing multiple CRTs is possible, as long as their - internal states are kept intact. The Microsoft Knowledge Base - articles KB94248 "HOWTO: Use the C Run-Time" and KB140584 - "HOWTO: Link with the Correct C Run-Time (CRT) Library" - mention the potential problems raised by intermixing. - - If intermixing works for you, it's because your application - and DLLs are avoiding the corruption of each of the CRTs' - internal states, maybe by careful design, or maybe by fortune. - - Also note that linking ZLIB1.DLL to non-Microsoft CRTs, such - as those provided by Borland, raises similar problems. - - -11. Why are you linking ZLIB1.DLL to MSVCRT.DLL? - - - MSVCRT.DLL exists on every Windows 95 with a new service pack - installed, or with Microsoft Internet Explorer 4 or later, and - on all other Windows 4.x or later (Windows 98, Windows NT 4, - or later). It is freely distributable; if not present in the - system, it can be downloaded from Microsoft or from other - software provider for free. - - The fact that MSVCRT.DLL does not exist on a virgin Windows 95 - is not so problematic. Windows 95 is scarcely found nowadays, - Microsoft ended its support a long time ago, and many recent - applications from various vendors, including Microsoft, do not - even run on it. Furthermore, no serious user should run - Windows 95 without a proper update installed. - - -12. Why are you not linking ZLIB1.DLL to - <> ? - - - We considered and abandoned the following alternatives: - - * Linking ZLIB1.DLL to a static C library (LIBC.LIB, or - LIBCMT.LIB) is not a good option. People are using the DLL - mainly to save disk space. If you are linking your program - to a static C library, you may as well consider linking zlib - in statically, too. - - * Linking ZLIB1.DLL to CRTDLL.DLL looks appealing, because - CRTDLL.DLL is present on every Win32 installation. - Unfortunately, it has a series of problems: it does not - work properly with Microsoft's C++ libraries, it does not - provide support for 64-bit file offsets, (and so on...), - and Microsoft discontinued its support a long time ago. - - * Linking ZLIB1.DLL to MSVCR70.DLL or MSVCR71.DLL, supplied - with the Microsoft .NET platform, and Visual C++ 7.0/7.1, - raises problems related to the status of ZLIB1.DLL as a - system component. According to the Microsoft Knowledge Base - article KB326922 "INFO: Redistribution of the Shared C - Runtime Component in Visual C++ .NET", MSVCR70.DLL and - MSVCR71.DLL are not supposed to function as system DLLs, - because they may clash with MSVCRT.DLL. Instead, the - application's installer is supposed to put these DLLs - (if needed) in the application's private directory. - If ZLIB1.DLL depends on a non-system runtime, it cannot - function as a redistributable system component. - - * Linking ZLIB1.DLL to non-Microsoft runtimes, such as - Borland's, or Cygwin's, raises problems related to the - reliable presence of these runtimes on Win32 systems. - It's easier to let the DLL build of zlib up to the people - who distribute these runtimes, and who may proceed as - explained in the answer to Question 14. - - -13. If ZLIB1.DLL cannot be linked to MSVCR70.DLL or MSVCR71.DLL, - how can I build/use ZLIB1.DLL in Microsoft Visual C++ 7.0 - (Visual Studio .NET) or newer? - - - Due to the problems explained in the Microsoft Knowledge Base - article KB326922 (see the previous answer), the C runtime that - comes with the VC7 environment is no longer considered a - system component. That is, it should not be assumed that this - runtime exists, or may be installed in a system directory. - Since ZLIB1.DLL is supposed to be a system component, it may - not depend on a non-system component. - - In order to link ZLIB1.DLL and your application to MSVCRT.DLL - in VC7, you need the library of Visual C++ 6.0 or older. If - you don't have this library at hand, it's probably best not to - use ZLIB1.DLL. - - We are hoping that, in the future, Microsoft will provide a - way to build applications linked to a proper system runtime, - from the Visual C++ environment. Until then, you have a - couple of alternatives, such as linking zlib in statically. - If your application requires dynamic linking, you may proceed - as explained in the answer to Question 14. - - -14. I need to link my own DLL build to a CRT different than - MSVCRT.DLL. What can I do? - - - Feel free to rebuild the DLL from the zlib sources, and link - it the way you want. You should, however, clearly state that - your build is unofficial. You should give it a different file - name, and/or install it in a private directory that can be - accessed by your application only, and is not visible to the - others (i.e. it's neither in the PATH, nor in the SYSTEM or - SYSTEM32 directories). Otherwise, your build may clash with - applications that link to the official build. - - For example, in Cygwin, zlib is linked to the Cygwin runtime - CYGWIN1.DLL, and it is distributed under the name CYGZ.DLL. - - -15. May I include additional pieces of code that I find useful, - link them in ZLIB1.DLL, and export them? - - - No. A legitimate build of ZLIB1.DLL must not include code - that does not originate from the official zlib source code. - But you can make your own private DLL build, under a different - file name, as suggested in the previous answer. - - For example, zlib is a part of the VCL library, distributed - with Borland Delphi and C++ Builder. The DLL build of VCL - is a redistributable file, named VCLxx.DLL. - - -16. May I remove some functionality out of ZLIB1.DLL, by enabling - macros like NO_GZCOMPRESS or NO_GZIP at compile time? - - - No. A legitimate build of ZLIB1.DLL must provide the complete - zlib functionality, as implemented in the official zlib source - code. But you can make your own private DLL build, under a - different file name, as suggested in the previous answer. - - -17. I made my own ZLIB1.DLL build. Can I test it for compliance? - - - We prefer that you download the official DLL from the zlib - web site. If you need something peculiar from this DLL, you - can send your suggestion to the zlib mailing list. - - However, in case you do rebuild the DLL yourself, you can run - it with the test programs found in the DLL distribution. - Running these test programs is not a guarantee of compliance, - but a failure can imply a detected problem. - -** - -This document is written and maintained by -Cosmin Truta DELETED compat/zlib/win32/Makefile.bor Index: compat/zlib/win32/Makefile.bor ================================================================== --- compat/zlib/win32/Makefile.bor +++ /dev/null @@ -1,110 +0,0 @@ -# Makefile for zlib -# Borland C++ for Win32 -# -# Usage: -# make -f win32/Makefile.bor -# make -f win32/Makefile.bor LOCAL_ZLIB=-DASMV OBJA=match.obj OBJPA=+match.obj - -# ------------ Borland C++ ------------ - -# Optional nonstandard preprocessor flags (e.g. -DMAX_MEM_LEVEL=7) -# should be added to the environment via "set LOCAL_ZLIB=-DFOO" or -# added to the declaration of LOC here: -LOC = $(LOCAL_ZLIB) - -CC = bcc32 -AS = bcc32 -LD = bcc32 -AR = tlib -CFLAGS = -a -d -k- -O2 $(LOC) -ASFLAGS = $(LOC) -LDFLAGS = $(LOC) - - -# variables -ZLIB_LIB = zlib.lib - -OBJ1 = adler32.obj compress.obj crc32.obj deflate.obj gzclose.obj gzlib.obj gzread.obj -OBJ2 = gzwrite.obj infback.obj inffast.obj inflate.obj inftrees.obj trees.obj uncompr.obj zutil.obj -#OBJA = -OBJP1 = +adler32.obj+compress.obj+crc32.obj+deflate.obj+gzclose.obj+gzlib.obj+gzread.obj -OBJP2 = +gzwrite.obj+infback.obj+inffast.obj+inflate.obj+inftrees.obj+trees.obj+uncompr.obj+zutil.obj -#OBJPA= - - -# targets -all: $(ZLIB_LIB) example.exe minigzip.exe - -.c.obj: - $(CC) -c $(CFLAGS) $< - -.asm.obj: - $(AS) -c $(ASFLAGS) $< - -adler32.obj: adler32.c zlib.h zconf.h - -compress.obj: compress.c zlib.h zconf.h - -crc32.obj: crc32.c zlib.h zconf.h crc32.h - -deflate.obj: deflate.c deflate.h zutil.h zlib.h zconf.h - -gzclose.obj: gzclose.c zlib.h zconf.h gzguts.h - -gzlib.obj: gzlib.c zlib.h zconf.h gzguts.h - -gzread.obj: gzread.c zlib.h zconf.h gzguts.h - -gzwrite.obj: gzwrite.c zlib.h zconf.h gzguts.h - -infback.obj: infback.c zutil.h zlib.h zconf.h inftrees.h inflate.h \ - inffast.h inffixed.h - -inffast.obj: inffast.c zutil.h zlib.h zconf.h inftrees.h inflate.h \ - inffast.h - -inflate.obj: inflate.c zutil.h zlib.h zconf.h inftrees.h inflate.h \ - inffast.h inffixed.h - -inftrees.obj: inftrees.c zutil.h zlib.h zconf.h inftrees.h - -trees.obj: trees.c zutil.h zlib.h zconf.h deflate.h trees.h - -uncompr.obj: uncompr.c zlib.h zconf.h - -zutil.obj: zutil.c zutil.h zlib.h zconf.h - -example.obj: test/example.c zlib.h zconf.h - -minigzip.obj: test/minigzip.c zlib.h zconf.h - - -# For the sake of the old Borland make, -# the command line is cut to fit in the MS-DOS 128 byte limit: -$(ZLIB_LIB): $(OBJ1) $(OBJ2) $(OBJA) - -del $(ZLIB_LIB) - $(AR) $(ZLIB_LIB) $(OBJP1) - $(AR) $(ZLIB_LIB) $(OBJP2) - $(AR) $(ZLIB_LIB) $(OBJPA) - - -# testing -test: example.exe minigzip.exe - example - echo hello world | minigzip | minigzip -d - -example.exe: example.obj $(ZLIB_LIB) - $(LD) $(LDFLAGS) example.obj $(ZLIB_LIB) - -minigzip.exe: minigzip.obj $(ZLIB_LIB) - $(LD) $(LDFLAGS) minigzip.obj $(ZLIB_LIB) - - -# cleanup -clean: - -del $(ZLIB_LIB) - -del *.obj - -del *.exe - -del *.tds - -del zlib.bak - -del foo.gz DELETED compat/zlib/win32/Makefile.gcc Index: compat/zlib/win32/Makefile.gcc ================================================================== --- compat/zlib/win32/Makefile.gcc +++ /dev/null @@ -1,182 +0,0 @@ -# Makefile for zlib, derived from Makefile.dj2. -# Modified for mingw32 by C. Spieler, 6/16/98. -# Updated for zlib 1.2.x by Christian Spieler and Cosmin Truta, Mar-2003. -# Last updated: Mar 2012. -# Tested under Cygwin and MinGW. - -# Copyright (C) 1995-2003 Jean-loup Gailly. -# For conditions of distribution and use, see copyright notice in zlib.h - -# To compile, or to compile and test, type from the top level zlib directory: -# -# make -fwin32/Makefile.gcc; make test testdll -fwin32/Makefile.gcc -# -# To use the asm code, type: -# cp contrib/asm?86/match.S ./match.S -# make LOC=-DASMV OBJA=match.o -fwin32/Makefile.gcc -# -# To install libz.a, zconf.h and zlib.h in the system directories, type: -# -# make install -fwin32/Makefile.gcc -# -# BINARY_PATH, INCLUDE_PATH and LIBRARY_PATH must be set. -# -# To install the shared lib, append SHARED_MODE=1 to the make command : -# -# make install -fwin32/Makefile.gcc SHARED_MODE=1 - -# Note: -# If the platform is *not* MinGW (e.g. it is Cygwin or UWIN), -# the DLL name should be changed from "zlib1.dll". - -STATICLIB = libz.a -SHAREDLIB = zlib1.dll -IMPLIB = libz.dll.a - -# -# Set to 1 if shared object needs to be installed -# -SHARED_MODE=0 - -#LOC = -DASMV -#LOC = -DZLIB_DEBUG -g - -PREFIX = -CC = $(PREFIX)gcc -CFLAGS = $(LOC) -O3 -Wall - -AS = $(CC) -ASFLAGS = $(LOC) -Wall - -LD = $(CC) -LDFLAGS = $(LOC) - -AR = $(PREFIX)ar -ARFLAGS = rcs - -RC = $(PREFIX)windres -RCFLAGS = --define GCC_WINDRES - -STRIP = $(PREFIX)strip - -CP = cp -fp -# If GNU install is available, replace $(CP) with install. -INSTALL = $(CP) -RM = rm -f - -prefix ?= /usr/local -exec_prefix = $(prefix) - -OBJS = adler32.o compress.o crc32.o deflate.o gzclose.o gzlib.o gzread.o \ - gzwrite.o infback.o inffast.o inflate.o inftrees.o trees.o uncompr.o zutil.o -OBJA = - -all: $(STATICLIB) $(SHAREDLIB) $(IMPLIB) example.exe minigzip.exe example_d.exe minigzip_d.exe - -test: example.exe minigzip.exe - ./example - echo hello world | ./minigzip | ./minigzip -d - -testdll: example_d.exe minigzip_d.exe - ./example_d - echo hello world | ./minigzip_d | ./minigzip_d -d - -.c.o: - $(CC) $(CFLAGS) -c -o $@ $< - -.S.o: - $(AS) $(ASFLAGS) -c -o $@ $< - -$(STATICLIB): $(OBJS) $(OBJA) - $(AR) $(ARFLAGS) $@ $(OBJS) $(OBJA) - -$(IMPLIB): $(SHAREDLIB) - -$(SHAREDLIB): win32/zlib.def $(OBJS) $(OBJA) zlibrc.o - $(CC) -shared -Wl,--out-implib,$(IMPLIB) $(LDFLAGS) \ - -o $@ win32/zlib.def $(OBJS) $(OBJA) zlibrc.o - $(STRIP) $@ - -example.exe: example.o $(STATICLIB) - $(LD) $(LDFLAGS) -o $@ example.o $(STATICLIB) - $(STRIP) $@ - -minigzip.exe: minigzip.o $(STATICLIB) - $(LD) $(LDFLAGS) -o $@ minigzip.o $(STATICLIB) - $(STRIP) $@ - -example_d.exe: example.o $(IMPLIB) - $(LD) $(LDFLAGS) -o $@ example.o $(IMPLIB) - $(STRIP) $@ - -minigzip_d.exe: minigzip.o $(IMPLIB) - $(LD) $(LDFLAGS) -o $@ minigzip.o $(IMPLIB) - $(STRIP) $@ - -example.o: test/example.c zlib.h zconf.h - $(CC) $(CFLAGS) -I. -c -o $@ test/example.c - -minigzip.o: test/minigzip.c zlib.h zconf.h - $(CC) $(CFLAGS) -I. -c -o $@ test/minigzip.c - -zlibrc.o: win32/zlib1.rc - $(RC) $(RCFLAGS) -o $@ win32/zlib1.rc - -.PHONY: install uninstall clean - -install: zlib.h zconf.h $(STATICLIB) $(IMPLIB) - @if test -z "$(DESTDIR)$(INCLUDE_PATH)" -o -z "$(DESTDIR)$(LIBRARY_PATH)" -o -z "$(DESTDIR)$(BINARY_PATH)"; then \ - echo INCLUDE_PATH, LIBRARY_PATH, and BINARY_PATH must be specified; \ - exit 1; \ - fi - -@mkdir -p '$(DESTDIR)$(INCLUDE_PATH)' - -@mkdir -p '$(DESTDIR)$(LIBRARY_PATH)' '$(DESTDIR)$(LIBRARY_PATH)'/pkgconfig - -if [ "$(SHARED_MODE)" = "1" ]; then \ - mkdir -p '$(DESTDIR)$(BINARY_PATH)'; \ - $(INSTALL) $(SHAREDLIB) '$(DESTDIR)$(BINARY_PATH)'; \ - $(INSTALL) $(IMPLIB) '$(DESTDIR)$(LIBRARY_PATH)'; \ - fi - -$(INSTALL) zlib.h '$(DESTDIR)$(INCLUDE_PATH)' - -$(INSTALL) zconf.h '$(DESTDIR)$(INCLUDE_PATH)' - -$(INSTALL) $(STATICLIB) '$(DESTDIR)$(LIBRARY_PATH)' - sed \ - -e 's|@prefix@|${prefix}|g' \ - -e 's|@exec_prefix@|${exec_prefix}|g' \ - -e 's|@libdir@|$(LIBRARY_PATH)|g' \ - -e 's|@sharedlibdir@|$(LIBRARY_PATH)|g' \ - -e 's|@includedir@|$(INCLUDE_PATH)|g' \ - -e 's|@VERSION@|'`sed -n -e '/VERSION "/s/.*"\(.*\)".*/\1/p' zlib.h`'|g' \ - zlib.pc.in > '$(DESTDIR)$(LIBRARY_PATH)'/pkgconfig/zlib.pc - -uninstall: - -if [ "$(SHARED_MODE)" = "1" ]; then \ - $(RM) '$(DESTDIR)$(BINARY_PATH)'/$(SHAREDLIB); \ - $(RM) '$(DESTDIR)$(LIBRARY_PATH)'/$(IMPLIB); \ - fi - -$(RM) '$(DESTDIR)$(INCLUDE_PATH)'/zlib.h - -$(RM) '$(DESTDIR)$(INCLUDE_PATH)'/zconf.h - -$(RM) '$(DESTDIR)$(LIBRARY_PATH)'/$(STATICLIB) - -clean: - -$(RM) $(STATICLIB) - -$(RM) $(SHAREDLIB) - -$(RM) $(IMPLIB) - -$(RM) *.o - -$(RM) *.exe - -$(RM) foo.gz - -adler32.o: zlib.h zconf.h -compress.o: zlib.h zconf.h -crc32.o: crc32.h zlib.h zconf.h -deflate.o: deflate.h zutil.h zlib.h zconf.h -gzclose.o: zlib.h zconf.h gzguts.h -gzlib.o: zlib.h zconf.h gzguts.h -gzread.o: zlib.h zconf.h gzguts.h -gzwrite.o: zlib.h zconf.h gzguts.h -inffast.o: zutil.h zlib.h zconf.h inftrees.h inflate.h inffast.h -inflate.o: zutil.h zlib.h zconf.h inftrees.h inflate.h inffast.h -infback.o: zutil.h zlib.h zconf.h inftrees.h inflate.h inffast.h -inftrees.o: zutil.h zlib.h zconf.h inftrees.h -trees.o: deflate.h zutil.h zlib.h zconf.h trees.h -uncompr.o: zlib.h zconf.h -zutil.o: zutil.h zlib.h zconf.h DELETED compat/zlib/win32/Makefile.msc Index: compat/zlib/win32/Makefile.msc ================================================================== --- compat/zlib/win32/Makefile.msc +++ /dev/null @@ -1,163 +0,0 @@ -# Makefile for zlib using Microsoft (Visual) C -# zlib is copyright (C) 1995-2017 Jean-loup Gailly and Mark Adler -# -# Usage: -# nmake -f win32/Makefile.msc (standard build) -# nmake -f win32/Makefile.msc LOC=-DFOO (nonstandard build) -# nmake -f win32/Makefile.msc LOC="-DASMV -DASMINF" \ -# OBJA="inffas32.obj match686.obj" (use ASM code, x86) -# nmake -f win32/Makefile.msc AS=ml64 LOC="-DASMV -DASMINF -I." \ -# OBJA="inffasx64.obj gvmat64.obj inffas8664.obj" (use ASM code, x64) - -# The toplevel directory of the source tree. -# -TOP = . - -# optional build flags -LOC = - -# variables -STATICLIB = zlib.lib -SHAREDLIB = zlib1.dll -IMPLIB = zdll.lib - -CC = cl -AS = ml -LD = link -AR = lib -RC = rc -CFLAGS = -nologo -MD -W3 -O2 -Oy- -Zi -Fd"zlib" $(LOC) -WFLAGS = -D_CRT_SECURE_NO_DEPRECATE -D_CRT_NONSTDC_NO_DEPRECATE -ASFLAGS = -coff -Zi $(LOC) -LDFLAGS = -nologo -debug -incremental:no -opt:ref -ARFLAGS = -nologo -RCFLAGS = /dWIN32 /r - -OBJS = adler32.obj compress.obj crc32.obj deflate.obj gzclose.obj gzlib.obj gzread.obj \ - gzwrite.obj infback.obj inflate.obj inftrees.obj inffast.obj trees.obj uncompr.obj zutil.obj -OBJA = - - -# targets -all: $(STATICLIB) $(SHAREDLIB) $(IMPLIB) \ - example.exe minigzip.exe example_d.exe minigzip_d.exe - -$(STATICLIB): $(OBJS) $(OBJA) - $(AR) $(ARFLAGS) -out:$@ $(OBJS) $(OBJA) - -$(IMPLIB): $(SHAREDLIB) - -$(SHAREDLIB): $(TOP)/win32/zlib.def $(OBJS) $(OBJA) zlib1.res - $(LD) $(LDFLAGS) -def:$(TOP)/win32/zlib.def -dll -implib:$(IMPLIB) \ - -out:$@ -base:0x5A4C0000 $(OBJS) $(OBJA) zlib1.res - if exist $@.manifest \ - mt -nologo -manifest $@.manifest -outputresource:$@;2 - -example.exe: example.obj $(STATICLIB) - $(LD) $(LDFLAGS) example.obj $(STATICLIB) - if exist $@.manifest \ - mt -nologo -manifest $@.manifest -outputresource:$@;1 - -minigzip.exe: minigzip.obj $(STATICLIB) - $(LD) $(LDFLAGS) minigzip.obj $(STATICLIB) - if exist $@.manifest \ - mt -nologo -manifest $@.manifest -outputresource:$@;1 - -example_d.exe: example.obj $(IMPLIB) - $(LD) $(LDFLAGS) -out:$@ example.obj $(IMPLIB) - if exist $@.manifest \ - mt -nologo -manifest $@.manifest -outputresource:$@;1 - -minigzip_d.exe: minigzip.obj $(IMPLIB) - $(LD) $(LDFLAGS) -out:$@ minigzip.obj $(IMPLIB) - if exist $@.manifest \ - mt -nologo -manifest $@.manifest -outputresource:$@;1 - -{$(TOP)}.c.obj: - $(CC) -c $(WFLAGS) $(CFLAGS) $< - -{$(TOP)/test}.c.obj: - $(CC) -c -I$(TOP) $(WFLAGS) $(CFLAGS) $< - -{$(TOP)/contrib/masmx64}.c.obj: - $(CC) -c $(WFLAGS) $(CFLAGS) $< - -{$(TOP)/contrib/masmx64}.asm.obj: - $(AS) -c $(ASFLAGS) $< - -{$(TOP)/contrib/masmx86}.asm.obj: - $(AS) -c $(ASFLAGS) $< - -adler32.obj: $(TOP)/adler32.c $(TOP)/zlib.h $(TOP)/zconf.h - -compress.obj: $(TOP)/compress.c $(TOP)/zlib.h $(TOP)/zconf.h - -crc32.obj: $(TOP)/crc32.c $(TOP)/zlib.h $(TOP)/zconf.h $(TOP)/crc32.h - -deflate.obj: $(TOP)/deflate.c $(TOP)/deflate.h $(TOP)/zutil.h $(TOP)/zlib.h $(TOP)/zconf.h - -gzclose.obj: $(TOP)/gzclose.c $(TOP)/zlib.h $(TOP)/zconf.h $(TOP)/gzguts.h - -gzlib.obj: $(TOP)/gzlib.c $(TOP)/zlib.h $(TOP)/zconf.h $(TOP)/gzguts.h - -gzread.obj: $(TOP)/gzread.c $(TOP)/zlib.h $(TOP)/zconf.h $(TOP)/gzguts.h - -gzwrite.obj: $(TOP)/gzwrite.c $(TOP)/zlib.h $(TOP)/zconf.h $(TOP)/gzguts.h - -infback.obj: $(TOP)/infback.c $(TOP)/zutil.h $(TOP)/zlib.h $(TOP)/zconf.h $(TOP)/inftrees.h $(TOP)/inflate.h \ - $(TOP)/inffast.h $(TOP)/inffixed.h - -inffast.obj: $(TOP)/inffast.c $(TOP)/zutil.h $(TOP)/zlib.h $(TOP)/zconf.h $(TOP)/inftrees.h $(TOP)/inflate.h \ - $(TOP)/inffast.h - -inflate.obj: $(TOP)/inflate.c $(TOP)/zutil.h $(TOP)/zlib.h $(TOP)/zconf.h $(TOP)/inftrees.h $(TOP)/inflate.h \ - $(TOP)/inffast.h $(TOP)/inffixed.h - -inftrees.obj: $(TOP)/inftrees.c $(TOP)/zutil.h $(TOP)/zlib.h $(TOP)/zconf.h $(TOP)/inftrees.h - -trees.obj: $(TOP)/trees.c $(TOP)/zutil.h $(TOP)/zlib.h $(TOP)/zconf.h $(TOP)/deflate.h $(TOP)/trees.h - -uncompr.obj: $(TOP)/uncompr.c $(TOP)/zlib.h $(TOP)/zconf.h - -zutil.obj: $(TOP)/zutil.c $(TOP)/zutil.h $(TOP)/zlib.h $(TOP)/zconf.h - -gvmat64.obj: $(TOP)/contrib\masmx64\gvmat64.asm - -inffasx64.obj: $(TOP)/contrib\masmx64\inffasx64.asm - -inffas8664.obj: $(TOP)/contrib\masmx64\inffas8664.c $(TOP)/zutil.h $(TOP)/zlib.h $(TOP)/zconf.h \ - $(TOP)/inftrees.h $(TOP)/inflate.h $(TOP)/inffast.h - -inffas32.obj: $(TOP)/contrib\masmx86\inffas32.asm - -match686.obj: $(TOP)/contrib\masmx86\match686.asm - -example.obj: $(TOP)/test/example.c $(TOP)/zlib.h $(TOP)/zconf.h - -minigzip.obj: $(TOP)/test/minigzip.c $(TOP)/zlib.h $(TOP)/zconf.h - -zlib1.res: $(TOP)/win32/zlib1.rc - $(RC) $(RCFLAGS) /fo$@ $(TOP)/win32/zlib1.rc - -# testing -test: example.exe minigzip.exe - example - echo hello world | minigzip | minigzip -d - -testdll: example_d.exe minigzip_d.exe - example_d - echo hello world | minigzip_d | minigzip_d -d - - -# cleanup -clean: - -del $(STATICLIB) - -del $(SHAREDLIB) - -del $(IMPLIB) - -del *.obj - -del *.res - -del *.exp - -del *.exe - -del *.pdb - -del *.manifest - -del foo.gz DELETED compat/zlib/win32/README-WIN32.txt Index: compat/zlib/win32/README-WIN32.txt ================================================================== --- compat/zlib/win32/README-WIN32.txt +++ /dev/null @@ -1,103 +0,0 @@ -ZLIB DATA COMPRESSION LIBRARY - -zlib 1.2.11 is a general purpose data compression library. All the code is -thread safe. The data format used by the zlib library is described by RFCs -(Request for Comments) 1950 to 1952 in the files -http://www.ietf.org/rfc/rfc1950.txt (zlib format), rfc1951.txt (deflate format) -and rfc1952.txt (gzip format). - -All functions of the compression library are documented in the file zlib.h -(volunteer to write man pages welcome, contact zlib@gzip.org). Two compiled -examples are distributed in this package, example and minigzip. The example_d -and minigzip_d flavors validate that the zlib1.dll file is working correctly. - -Questions about zlib should be sent to . The zlib home page -is http://zlib.net/ . Before reporting a problem, please check this site to -verify that you have the latest version of zlib; otherwise get the latest -version and check whether the problem still exists or not. - -PLEASE read DLL_FAQ.txt, and the the zlib FAQ http://zlib.net/zlib_faq.html -before asking for help. - - -Manifest: - -The package zlib-1.2.11-win32-x86.zip will contain the following files: - - README-WIN32.txt This document - ChangeLog Changes since previous zlib packages - DLL_FAQ.txt Frequently asked questions about zlib1.dll - zlib.3.pdf Documentation of this library in Adobe Acrobat format - - example.exe A statically-bound example (using zlib.lib, not the dll) - example.pdb Symbolic information for debugging example.exe - - example_d.exe A zlib1.dll bound example (using zdll.lib) - example_d.pdb Symbolic information for debugging example_d.exe - - minigzip.exe A statically-bound test program (using zlib.lib, not the dll) - minigzip.pdb Symbolic information for debugging minigzip.exe - - minigzip_d.exe A zlib1.dll bound test program (using zdll.lib) - minigzip_d.pdb Symbolic information for debugging minigzip_d.exe - - zlib.h Install these files into the compilers' INCLUDE path to - zconf.h compile programs which use zlib.lib or zdll.lib - - zdll.lib Install these files into the compilers' LIB path if linking - zdll.exp a compiled program to the zlib1.dll binary - - zlib.lib Install these files into the compilers' LIB path to link zlib - zlib.pdb into compiled programs, without zlib1.dll runtime dependency - (zlib.pdb provides debugging info to the compile time linker) - - zlib1.dll Install this binary shared library into the system PATH, or - the program's runtime directory (where the .exe resides) - zlib1.pdb Install in the same directory as zlib1.dll, in order to debug - an application crash using WinDbg or similar tools. - -All .pdb files above are entirely optional, but are very useful to a developer -attempting to diagnose program misbehavior or a crash. Many additional -important files for developers can be found in the zlib127.zip source package -available from http://zlib.net/ - review that package's README file for details. - - -Acknowledgments: - -The deflate format used by zlib was defined by Phil Katz. The deflate and -zlib specifications were written by L. Peter Deutsch. Thanks to all the -people who reported problems and suggested various improvements in zlib; they -are too numerous to cite here. - - -Copyright notice: - - (C) 1995-2017 Jean-loup Gailly and Mark Adler - - This software is provided 'as-is', without any express or implied - warranty. In no event will the authors be held liable for any damages - arising from the use of this software. - - Permission is granted to anyone to use this software for any purpose, - including commercial applications, and to alter it and redistribute it - freely, subject to the following restrictions: - - 1. The origin of this software must not be misrepresented; you must not - claim that you wrote the original software. If you use this software - in a product, an acknowledgment in the product documentation would be - appreciated but is not required. - 2. Altered source versions must be plainly marked as such, and must not be - misrepresented as being the original software. - 3. This notice may not be removed or altered from any source distribution. - - Jean-loup Gailly Mark Adler - jloup@gzip.org madler@alumni.caltech.edu - -If you use the zlib library in a product, we would appreciate *not* receiving -lengthy legal documents to sign. The sources are provided for free but without -warranty of any kind. The library has been entirely written by Jean-loup -Gailly and Mark Adler; it does not include third-party code. - -If you redistribute modified sources, we would appreciate that you include in -the file ChangeLog history information documenting your changes. Please read -the FAQ for more information on the distribution of modified source versions. DELETED compat/zlib/win32/README.txt Index: compat/zlib/win32/README.txt ================================================================== --- compat/zlib/win32/README.txt +++ /dev/null @@ -1,60 +0,0 @@ - -What's here -=========== - The official ZLIB1.DLL - - -Source -====== - zlib version 1.2.11 - available at http://www.gzip.org/zlib/ - - -Specification and rationale -=========================== - See the accompanying DLL_FAQ.txt - - -Usage -===== - See the accompanying USAGE.txt - - -Build info -========== - Contributed by Jan Nijtmans. - - Compiler: - i686-w64-mingw32-gcc (GCC) 5.4.0 - Library: - mingw64-i686-runtime/headers: 5.0.0 - Build commands: - i686-w64-mingw32-gcc -c -DASMV contrib/asm686/match.S - i686-w64-mingw32-gcc -c -DASMINF -I. -O3 contrib/inflate86/inffas86.c - make -f win32/Makefile.gcc PREFIX=i686-w64-mingw32- LOC="-mms-bitfields -DASMV -DASMINF" OBJA="inffas86.o match.o" - Finally, from VS commandline (VS2005 or higher): - lib -machine:X86 -name:zlib1.dll -def:zlib.def -out:zdll.lib - -Copyright notice -================ - Copyright (C) 1995-2017 Jean-loup Gailly and Mark Adler - - This software is provided 'as-is', without any express or implied - warranty. In no event will the authors be held liable for any damages - arising from the use of this software. - - Permission is granted to anyone to use this software for any purpose, - including commercial applications, and to alter it and redistribute it - freely, subject to the following restrictions: - - 1. The origin of this software must not be misrepresented; you must not - claim that you wrote the original software. If you use this software - in a product, an acknowledgment in the product documentation would be - appreciated but is not required. - 2. Altered source versions must be plainly marked as such, and must not be - misrepresented as being the original software. - 3. This notice may not be removed or altered from any source distribution. - - Jean-loup Gailly Mark Adler - jloup@gzip.org madler@alumni.caltech.edu - DELETED compat/zlib/win32/USAGE.txt Index: compat/zlib/win32/USAGE.txt ================================================================== --- compat/zlib/win32/USAGE.txt +++ /dev/null @@ -1,97 +0,0 @@ - -Installing ZLIB1.DLL -==================== - Copy ZLIB1.DLL to the SYSTEM or the SYSTEM32 directory. - - If you want to install the 32-bit dll on a 64-bit - machine, use the SysWOW64 directory instead. - - -Using ZLIB1.DLL with Microsoft Visual C++ -========================================= - 1. Install the supplied header files "zlib.h" and "zconf.h" - into a directory found in the INCLUDE path list. - - 2. Install the supplied library file "zdll.lib" into a - directory found in the LIB path list. - - 3. Add "zdll.lib" to your project. - - -Using ZLIB1.DLL with gcc/MinGW -============================== - 1. Install the supplied header files "zlib.h" and "zconf.h" - into the INCLUDE directory. - - 2. (32-bit): Copy the supplied library file "zdll.lib" to "libzdll.a": - cp lib/zdll.lib lib/libzdll.a - - OR - - 2'. (64-bit): Copy the supplied library file "libz.dll.a" to "libzdll.a": - cp lib/libz.dll.a lib/libzdll.a - - OR - - 2'' Build the import library from the supplied "zlib.def": - dlltool -D zlib1.dll -d lib/zlib.def -l lib/libzdll.a - - 3. Install "libzdll.a" into the LIB directory. - - 4. Add "libzdll.a" to your project, or use the -lzdll option. - - -Using ZLIB1.DLL with gcc/Cygwin -=============================== - ZLIB1.DLL is not designed to work with Cygwin. The Cygwin - system has its own DLL build of zlib, named CYGZ.DLL. - - -Using ZLIB1.DLL with Borland C++ -================================ - 1. Install the supplied header files "zlib.h" and "zconf.h" - into a directory found in the INCLUDE path list. - - 2. Build the import library using the IMPLIB tool: - implib -a -c -f lib\zdllbor.lib zlib1.dll - - OR - - 2' Convert the supplied library file "zdll.lib" to OMF format, - using the COFF2OMF tool: - coff2omf lib\zdll.lib lib\zdllbor.lib - - 3. Install "zdllbor.lib" into a directory found in the LIB path - list. - - 4. Add "zdllbor.lib" to your project. - - Notes: - - The modules that are linked with "zdllbor.lib" must be compiled - using a 4-byte alignment (option -a): - bcc32 -a -c myprog.c - bcc32 myprog.obj zdllbor.lib - - If you wish, you may use "zlib1.lib" instead of "zdllbor.lib". - - -Rebuilding ZLIB1.DLL -==================== - Depending on your build environment, use the appropriate - makefile from the win32/ directory, found in the zlib source - distribution. - - Your custom build has to comply with the requirements stated - in DLL_FAQ.txt, including (but not limited to) the following: - - It must be built from an unaltered zlib source distribution. - - It must be linked to MSVCRT.DLL. - - The macros that compile out certain portions of the zlib - code (such as NO_GZCOMPRESS, NO_GZIP) must not be enabled. - - The ZLIB_WINAPI macro must not be enabled. - - Furthermore, it has to run successfully with the test suite - found in this package. - - It is recommended, however, to use the supplied ZLIB1.DLL, - instead of rebuilding it yourself. You should rebuild it - only if you have a special reason. - DELETED compat/zlib/win32/VisualC.txt Index: compat/zlib/win32/VisualC.txt ================================================================== --- compat/zlib/win32/VisualC.txt +++ /dev/null @@ -1,3 +0,0 @@ - -To build zlib using the Microsoft Visual C++ environment, -use the appropriate project from the contrib/vstudio/ directory. DELETED compat/zlib/win32/zdll.lib Index: compat/zlib/win32/zdll.lib ================================================================== --- compat/zlib/win32/zdll.lib +++ /dev/null cannot compute difference between binary files DELETED compat/zlib/win32/zlib.def Index: compat/zlib/win32/zlib.def ================================================================== --- compat/zlib/win32/zlib.def +++ /dev/null @@ -1,94 +0,0 @@ -; zlib data compression library -EXPORTS -; basic functions - zlibVersion - deflate - deflateEnd - inflate - inflateEnd -; advanced functions - deflateSetDictionary - deflateGetDictionary - deflateCopy - deflateReset - deflateParams - deflateTune - deflateBound - deflatePending - deflatePrime - deflateSetHeader - inflateSetDictionary - inflateGetDictionary - inflateSync - inflateCopy - inflateReset - inflateReset2 - inflatePrime - inflateMark - inflateGetHeader - inflateBack - inflateBackEnd - zlibCompileFlags -; utility functions - compress - compress2 - compressBound - uncompress - uncompress2 - gzopen - gzdopen - gzbuffer - gzsetparams - gzread - gzfread - gzwrite - gzfwrite - gzprintf - gzvprintf - gzputs - gzgets - gzputc - gzgetc - gzungetc - gzflush - gzseek - gzrewind - gztell - gzoffset - gzeof - gzdirect - gzclose - gzclose_r - gzclose_w - gzerror - gzclearerr -; large file functions - gzopen64 - gzseek64 - gztell64 - gzoffset64 - adler32_combine64 - crc32_combine64 -; checksum functions - adler32 - adler32_z - crc32 - crc32_z - adler32_combine - crc32_combine -; various hacks, don't look :) - deflateInit_ - deflateInit2_ - inflateInit_ - inflateInit2_ - inflateBackInit_ - gzgetc_ - zError - inflateSyncPoint - get_crc_table - inflateUndermine - inflateValidate - inflateCodesUsed - inflateResetKeep - deflateResetKeep - gzopen_w DELETED compat/zlib/win32/zlib1.dll Index: compat/zlib/win32/zlib1.dll ================================================================== --- compat/zlib/win32/zlib1.dll +++ /dev/null cannot compute difference between binary files DELETED compat/zlib/win32/zlib1.rc Index: compat/zlib/win32/zlib1.rc ================================================================== --- compat/zlib/win32/zlib1.rc +++ /dev/null @@ -1,40 +0,0 @@ -#include -#include "../zlib.h" - -#ifdef GCC_WINDRES -VS_VERSION_INFO VERSIONINFO -#else -VS_VERSION_INFO VERSIONINFO MOVEABLE IMPURE LOADONCALL DISCARDABLE -#endif - FILEVERSION ZLIB_VER_MAJOR,ZLIB_VER_MINOR,ZLIB_VER_REVISION,0 - PRODUCTVERSION ZLIB_VER_MAJOR,ZLIB_VER_MINOR,ZLIB_VER_REVISION,0 - FILEFLAGSMASK VS_FFI_FILEFLAGSMASK -#ifdef _DEBUG - FILEFLAGS 1 -#else - FILEFLAGS 0 -#endif - FILEOS VOS__WINDOWS32 - FILETYPE VFT_DLL - FILESUBTYPE 0 // not used -BEGIN - BLOCK "StringFileInfo" - BEGIN - BLOCK "040904E4" - //language ID = U.S. English, char set = Windows, Multilingual - BEGIN - VALUE "FileDescription", "zlib data compression library\0" - VALUE "FileVersion", ZLIB_VERSION "\0" - VALUE "InternalName", "zlib1.dll\0" - VALUE "LegalCopyright", "(C) 1995-2017 Jean-loup Gailly & Mark Adler\0" - VALUE "OriginalFilename", "zlib1.dll\0" - VALUE "ProductName", "zlib\0" - VALUE "ProductVersion", ZLIB_VERSION "\0" - VALUE "Comments", "For more information visit http://www.zlib.net/\0" - END - END - BLOCK "VarFileInfo" - BEGIN - VALUE "Translation", 0x0409, 1252 - END -END DELETED compat/zlib/win64/libz.dll.a Index: compat/zlib/win64/libz.dll.a ================================================================== --- compat/zlib/win64/libz.dll.a +++ /dev/null cannot compute difference between binary files DELETED compat/zlib/win64/zdll.lib Index: compat/zlib/win64/zdll.lib ================================================================== --- compat/zlib/win64/zdll.lib +++ /dev/null cannot compute difference between binary files DELETED compat/zlib/win64/zlib1.dll Index: compat/zlib/win64/zlib1.dll ================================================================== --- compat/zlib/win64/zlib1.dll +++ /dev/null cannot compute difference between binary files DELETED compat/zlib/zconf.h Index: compat/zlib/zconf.h ================================================================== --- compat/zlib/zconf.h +++ /dev/null @@ -1,534 +0,0 @@ -/* zconf.h -- configuration of the zlib compression library - * Copyright (C) 1995-2016 Jean-loup Gailly, Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -/* @(#) $Id$ */ - -#ifndef ZCONF_H -#define ZCONF_H - -/* - * If you *really* need a unique prefix for all types and library functions, - * compile with -DZ_PREFIX. The "standard" zlib should be compiled without it. - * Even better than compiling with -DZ_PREFIX would be to use configure to set - * this permanently in zconf.h using "./configure --zprefix". - */ -#ifdef Z_PREFIX /* may be set to #if 1 by ./configure */ -# define Z_PREFIX_SET - -/* all linked symbols and init macros */ -# define _dist_code z__dist_code -# define _length_code z__length_code -# define _tr_align z__tr_align -# define _tr_flush_bits z__tr_flush_bits -# define _tr_flush_block z__tr_flush_block -# define _tr_init z__tr_init -# define _tr_stored_block z__tr_stored_block -# define _tr_tally z__tr_tally -# define adler32 z_adler32 -# define adler32_combine z_adler32_combine -# define adler32_combine64 z_adler32_combine64 -# define adler32_z z_adler32_z -# ifndef Z_SOLO -# define compress z_compress -# define compress2 z_compress2 -# define compressBound z_compressBound -# endif -# define crc32 z_crc32 -# define crc32_combine z_crc32_combine -# define crc32_combine64 z_crc32_combine64 -# define crc32_z z_crc32_z -# define deflate z_deflate -# define deflateBound z_deflateBound -# define deflateCopy z_deflateCopy -# define deflateEnd z_deflateEnd -# define deflateGetDictionary z_deflateGetDictionary -# define deflateInit z_deflateInit -# define deflateInit2 z_deflateInit2 -# define deflateInit2_ z_deflateInit2_ -# define deflateInit_ z_deflateInit_ -# define deflateParams z_deflateParams -# define deflatePending z_deflatePending -# define deflatePrime z_deflatePrime -# define deflateReset z_deflateReset -# define deflateResetKeep z_deflateResetKeep -# define deflateSetDictionary z_deflateSetDictionary -# define deflateSetHeader z_deflateSetHeader -# define deflateTune z_deflateTune -# define deflate_copyright z_deflate_copyright -# define get_crc_table z_get_crc_table -# ifndef Z_SOLO -# define gz_error z_gz_error -# define gz_intmax z_gz_intmax -# define gz_strwinerror z_gz_strwinerror -# define gzbuffer z_gzbuffer -# define gzclearerr z_gzclearerr -# define gzclose z_gzclose -# define gzclose_r z_gzclose_r -# define gzclose_w z_gzclose_w -# define gzdirect z_gzdirect -# define gzdopen z_gzdopen -# define gzeof z_gzeof -# define gzerror z_gzerror -# define gzflush z_gzflush -# define gzfread z_gzfread -# define gzfwrite z_gzfwrite -# define gzgetc z_gzgetc -# define gzgetc_ z_gzgetc_ -# define gzgets z_gzgets -# define gzoffset z_gzoffset -# define gzoffset64 z_gzoffset64 -# define gzopen z_gzopen -# define gzopen64 z_gzopen64 -# ifdef _WIN32 -# define gzopen_w z_gzopen_w -# endif -# define gzprintf z_gzprintf -# define gzputc z_gzputc -# define gzputs z_gzputs -# define gzread z_gzread -# define gzrewind z_gzrewind -# define gzseek z_gzseek -# define gzseek64 z_gzseek64 -# define gzsetparams z_gzsetparams -# define gztell z_gztell -# define gztell64 z_gztell64 -# define gzungetc z_gzungetc -# define gzvprintf z_gzvprintf -# define gzwrite z_gzwrite -# endif -# define inflate z_inflate -# define inflateBack z_inflateBack -# define inflateBackEnd z_inflateBackEnd -# define inflateBackInit z_inflateBackInit -# define inflateBackInit_ z_inflateBackInit_ -# define inflateCodesUsed z_inflateCodesUsed -# define inflateCopy z_inflateCopy -# define inflateEnd z_inflateEnd -# define inflateGetDictionary z_inflateGetDictionary -# define inflateGetHeader z_inflateGetHeader -# define inflateInit z_inflateInit -# define inflateInit2 z_inflateInit2 -# define inflateInit2_ z_inflateInit2_ -# define inflateInit_ z_inflateInit_ -# define inflateMark z_inflateMark -# define inflatePrime z_inflatePrime -# define inflateReset z_inflateReset -# define inflateReset2 z_inflateReset2 -# define inflateResetKeep z_inflateResetKeep -# define inflateSetDictionary z_inflateSetDictionary -# define inflateSync z_inflateSync -# define inflateSyncPoint z_inflateSyncPoint -# define inflateUndermine z_inflateUndermine -# define inflateValidate z_inflateValidate -# define inflate_copyright z_inflate_copyright -# define inflate_fast z_inflate_fast -# define inflate_table z_inflate_table -# ifndef Z_SOLO -# define uncompress z_uncompress -# define uncompress2 z_uncompress2 -# endif -# define zError z_zError -# ifndef Z_SOLO -# define zcalloc z_zcalloc -# define zcfree z_zcfree -# endif -# define zlibCompileFlags z_zlibCompileFlags -# define zlibVersion z_zlibVersion - -/* all zlib typedefs in zlib.h and zconf.h */ -# define Byte z_Byte -# define Bytef z_Bytef -# define alloc_func z_alloc_func -# define charf z_charf -# define free_func z_free_func -# ifndef Z_SOLO -# define gzFile z_gzFile -# endif -# define gz_header z_gz_header -# define gz_headerp z_gz_headerp -# define in_func z_in_func -# define intf z_intf -# define out_func z_out_func -# define uInt z_uInt -# define uIntf z_uIntf -# define uLong z_uLong -# define uLongf z_uLongf -# define voidp z_voidp -# define voidpc z_voidpc -# define voidpf z_voidpf - -/* all zlib structs in zlib.h and zconf.h */ -# define gz_header_s z_gz_header_s -# define internal_state z_internal_state - -#endif - -#if defined(__MSDOS__) && !defined(MSDOS) -# define MSDOS -#endif -#if (defined(OS_2) || defined(__OS2__)) && !defined(OS2) -# define OS2 -#endif -#if defined(_WINDOWS) && !defined(WINDOWS) -# define WINDOWS -#endif -#if defined(_WIN32) || defined(_WIN32_WCE) || defined(__WIN32__) -# ifndef WIN32 -# define WIN32 -# endif -#endif -#if (defined(MSDOS) || defined(OS2) || defined(WINDOWS)) && !defined(WIN32) -# if !defined(__GNUC__) && !defined(__FLAT__) && !defined(__386__) -# ifndef SYS16BIT -# define SYS16BIT -# endif -# endif -#endif - -/* - * Compile with -DMAXSEG_64K if the alloc function cannot allocate more - * than 64k bytes at a time (needed on systems with 16-bit int). - */ -#ifdef SYS16BIT -# define MAXSEG_64K -#endif -#ifdef MSDOS -# define UNALIGNED_OK -#endif - -#ifdef __STDC_VERSION__ -# ifndef STDC -# define STDC -# endif -# if __STDC_VERSION__ >= 199901L -# ifndef STDC99 -# define STDC99 -# endif -# endif -#endif -#if !defined(STDC) && (defined(__STDC__) || defined(__cplusplus)) -# define STDC -#endif -#if !defined(STDC) && (defined(__GNUC__) || defined(__BORLANDC__)) -# define STDC -#endif -#if !defined(STDC) && (defined(MSDOS) || defined(WINDOWS) || defined(WIN32)) -# define STDC -#endif -#if !defined(STDC) && (defined(OS2) || defined(__HOS_AIX__)) -# define STDC -#endif - -#if defined(__OS400__) && !defined(STDC) /* iSeries (formerly AS/400). */ -# define STDC -#endif - -#ifndef STDC -# ifndef const /* cannot use !defined(STDC) && !defined(const) on Mac */ -# define const /* note: need a more gentle solution here */ -# endif -#endif - -#if defined(ZLIB_CONST) && !defined(z_const) -# define z_const const -#else -# define z_const -#endif - -#ifdef Z_SOLO - typedef unsigned long z_size_t; -#else -# define z_longlong long long -# if defined(NO_SIZE_T) - typedef unsigned NO_SIZE_T z_size_t; -# elif defined(STDC) -# include - typedef size_t z_size_t; -# else - typedef unsigned long z_size_t; -# endif -# undef z_longlong -#endif - -/* Maximum value for memLevel in deflateInit2 */ -#ifndef MAX_MEM_LEVEL -# ifdef MAXSEG_64K -# define MAX_MEM_LEVEL 8 -# else -# define MAX_MEM_LEVEL 9 -# endif -#endif - -/* Maximum value for windowBits in deflateInit2 and inflateInit2. - * WARNING: reducing MAX_WBITS makes minigzip unable to extract .gz files - * created by gzip. (Files created by minigzip can still be extracted by - * gzip.) - */ -#ifndef MAX_WBITS -# define MAX_WBITS 15 /* 32K LZ77 window */ -#endif - -/* The memory requirements for deflate are (in bytes): - (1 << (windowBits+2)) + (1 << (memLevel+9)) - that is: 128K for windowBits=15 + 128K for memLevel = 8 (default values) - plus a few kilobytes for small objects. For example, if you want to reduce - the default memory requirements from 256K to 128K, compile with - make CFLAGS="-O -DMAX_WBITS=14 -DMAX_MEM_LEVEL=7" - Of course this will generally degrade compression (there's no free lunch). - - The memory requirements for inflate are (in bytes) 1 << windowBits - that is, 32K for windowBits=15 (default value) plus about 7 kilobytes - for small objects. -*/ - - /* Type declarations */ - -#ifndef OF /* function prototypes */ -# ifdef STDC -# define OF(args) args -# else -# define OF(args) () -# endif -#endif - -#ifndef Z_ARG /* function prototypes for stdarg */ -# if defined(STDC) || defined(Z_HAVE_STDARG_H) -# define Z_ARG(args) args -# else -# define Z_ARG(args) () -# endif -#endif - -/* The following definitions for FAR are needed only for MSDOS mixed - * model programming (small or medium model with some far allocations). - * This was tested only with MSC; for other MSDOS compilers you may have - * to define NO_MEMCPY in zutil.h. If you don't need the mixed model, - * just define FAR to be empty. - */ -#ifdef SYS16BIT -# if defined(M_I86SM) || defined(M_I86MM) - /* MSC small or medium model */ -# define SMALL_MEDIUM -# ifdef _MSC_VER -# define FAR _far -# else -# define FAR far -# endif -# endif -# if (defined(__SMALL__) || defined(__MEDIUM__)) - /* Turbo C small or medium model */ -# define SMALL_MEDIUM -# ifdef __BORLANDC__ -# define FAR _far -# else -# define FAR far -# endif -# endif -#endif - -#if defined(WINDOWS) || defined(WIN32) - /* If building or using zlib as a DLL, define ZLIB_DLL. - * This is not mandatory, but it offers a little performance increase. - */ -# ifdef ZLIB_DLL -# if defined(WIN32) && (!defined(__BORLANDC__) || (__BORLANDC__ >= 0x500)) -# ifdef ZLIB_INTERNAL -# define ZEXTERN extern __declspec(dllexport) -# else -# define ZEXTERN extern __declspec(dllimport) -# endif -# endif -# endif /* ZLIB_DLL */ - /* If building or using zlib with the WINAPI/WINAPIV calling convention, - * define ZLIB_WINAPI. - * Caution: the standard ZLIB1.DLL is NOT compiled using ZLIB_WINAPI. - */ -# ifdef ZLIB_WINAPI -# ifdef FAR -# undef FAR -# endif -# include - /* No need for _export, use ZLIB.DEF instead. */ - /* For complete Windows compatibility, use WINAPI, not __stdcall. */ -# define ZEXPORT WINAPI -# ifdef WIN32 -# define ZEXPORTVA WINAPIV -# else -# define ZEXPORTVA FAR CDECL -# endif -# endif -#endif - -#if defined (__BEOS__) -# ifdef ZLIB_DLL -# ifdef ZLIB_INTERNAL -# define ZEXPORT __declspec(dllexport) -# define ZEXPORTVA __declspec(dllexport) -# else -# define ZEXPORT __declspec(dllimport) -# define ZEXPORTVA __declspec(dllimport) -# endif -# endif -#endif - -#ifndef ZEXTERN -# define ZEXTERN extern -#endif -#ifndef ZEXPORT -# define ZEXPORT -#endif -#ifndef ZEXPORTVA -# define ZEXPORTVA -#endif - -#ifndef FAR -# define FAR -#endif - -#if !defined(__MACTYPES__) -typedef unsigned char Byte; /* 8 bits */ -#endif -typedef unsigned int uInt; /* 16 bits or more */ -typedef unsigned long uLong; /* 32 bits or more */ - -#ifdef SMALL_MEDIUM - /* Borland C/C++ and some old MSC versions ignore FAR inside typedef */ -# define Bytef Byte FAR -#else - typedef Byte FAR Bytef; -#endif -typedef char FAR charf; -typedef int FAR intf; -typedef uInt FAR uIntf; -typedef uLong FAR uLongf; - -#ifdef STDC - typedef void const *voidpc; - typedef void FAR *voidpf; - typedef void *voidp; -#else - typedef Byte const *voidpc; - typedef Byte FAR *voidpf; - typedef Byte *voidp; -#endif - -#if !defined(Z_U4) && !defined(Z_SOLO) && defined(STDC) -# include -# if (UINT_MAX == 0xffffffffUL) -# define Z_U4 unsigned -# elif (ULONG_MAX == 0xffffffffUL) -# define Z_U4 unsigned long -# elif (USHRT_MAX == 0xffffffffUL) -# define Z_U4 unsigned short -# endif -#endif - -#ifdef Z_U4 - typedef Z_U4 z_crc_t; -#else - typedef unsigned long z_crc_t; -#endif - -#ifdef HAVE_UNISTD_H /* may be set to #if 1 by ./configure */ -# define Z_HAVE_UNISTD_H -#endif - -#ifdef HAVE_STDARG_H /* may be set to #if 1 by ./configure */ -# define Z_HAVE_STDARG_H -#endif - -#ifdef STDC -# ifndef Z_SOLO -# include /* for off_t */ -# endif -#endif - -#if defined(STDC) || defined(Z_HAVE_STDARG_H) -# ifndef Z_SOLO -# include /* for va_list */ -# endif -#endif - -#ifdef _WIN32 -# ifndef Z_SOLO -# include /* for wchar_t */ -# endif -#endif - -/* a little trick to accommodate both "#define _LARGEFILE64_SOURCE" and - * "#define _LARGEFILE64_SOURCE 1" as requesting 64-bit operations, (even - * though the former does not conform to the LFS document), but considering - * both "#undef _LARGEFILE64_SOURCE" and "#define _LARGEFILE64_SOURCE 0" as - * equivalently requesting no 64-bit operations - */ -#if defined(_LARGEFILE64_SOURCE) && -_LARGEFILE64_SOURCE - -1 == 1 -# undef _LARGEFILE64_SOURCE -#endif - -#if defined(__WATCOMC__) && !defined(Z_HAVE_UNISTD_H) -# define Z_HAVE_UNISTD_H -#endif -#ifndef Z_SOLO -# if defined(Z_HAVE_UNISTD_H) || defined(_LARGEFILE64_SOURCE) -# include /* for SEEK_*, off_t, and _LFS64_LARGEFILE */ -# ifdef VMS -# include /* for off_t */ -# endif -# ifndef z_off_t -# define z_off_t off_t -# endif -# endif -#endif - -#if defined(_LFS64_LARGEFILE) && _LFS64_LARGEFILE-0 -# define Z_LFS64 -#endif - -#if defined(_LARGEFILE64_SOURCE) && defined(Z_LFS64) -# define Z_LARGE64 -#endif - -#if defined(_FILE_OFFSET_BITS) && _FILE_OFFSET_BITS-0 == 64 && defined(Z_LFS64) -# define Z_WANT64 -#endif - -#if !defined(SEEK_SET) && !defined(Z_SOLO) -# define SEEK_SET 0 /* Seek from beginning of file. */ -# define SEEK_CUR 1 /* Seek from current position. */ -# define SEEK_END 2 /* Set file pointer to EOF plus "offset" */ -#endif - -#ifndef z_off_t -# define z_off_t long -#endif - -#if !defined(_WIN32) && defined(Z_LARGE64) -# define z_off64_t off64_t -#else -# if defined(_WIN32) && !defined(__GNUC__) && !defined(Z_SOLO) -# define z_off64_t __int64 -# else -# define z_off64_t z_off_t -# endif -#endif - -/* MVS linker does not support external names larger than 8 bytes */ -#if defined(__MVS__) - #pragma map(deflateInit_,"DEIN") - #pragma map(deflateInit2_,"DEIN2") - #pragma map(deflateEnd,"DEEND") - #pragma map(deflateBound,"DEBND") - #pragma map(inflateInit_,"ININ") - #pragma map(inflateInit2_,"ININ2") - #pragma map(inflateEnd,"INEND") - #pragma map(inflateSync,"INSY") - #pragma map(inflateSetDictionary,"INSEDI") - #pragma map(compressBound,"CMBND") - #pragma map(inflate_table,"INTABL") - #pragma map(inflate_fast,"INFA") - #pragma map(inflate_copyright,"INCOPY") -#endif - -#endif /* ZCONF_H */ DELETED compat/zlib/zconf.h.cmakein Index: compat/zlib/zconf.h.cmakein ================================================================== --- compat/zlib/zconf.h.cmakein +++ /dev/null @@ -1,536 +0,0 @@ -/* zconf.h -- configuration of the zlib compression library - * Copyright (C) 1995-2016 Jean-loup Gailly, Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -/* @(#) $Id$ */ - -#ifndef ZCONF_H -#define ZCONF_H -#cmakedefine Z_PREFIX -#cmakedefine Z_HAVE_UNISTD_H - -/* - * If you *really* need a unique prefix for all types and library functions, - * compile with -DZ_PREFIX. The "standard" zlib should be compiled without it. - * Even better than compiling with -DZ_PREFIX would be to use configure to set - * this permanently in zconf.h using "./configure --zprefix". - */ -#ifdef Z_PREFIX /* may be set to #if 1 by ./configure */ -# define Z_PREFIX_SET - -/* all linked symbols and init macros */ -# define _dist_code z__dist_code -# define _length_code z__length_code -# define _tr_align z__tr_align -# define _tr_flush_bits z__tr_flush_bits -# define _tr_flush_block z__tr_flush_block -# define _tr_init z__tr_init -# define _tr_stored_block z__tr_stored_block -# define _tr_tally z__tr_tally -# define adler32 z_adler32 -# define adler32_combine z_adler32_combine -# define adler32_combine64 z_adler32_combine64 -# define adler32_z z_adler32_z -# ifndef Z_SOLO -# define compress z_compress -# define compress2 z_compress2 -# define compressBound z_compressBound -# endif -# define crc32 z_crc32 -# define crc32_combine z_crc32_combine -# define crc32_combine64 z_crc32_combine64 -# define crc32_z z_crc32_z -# define deflate z_deflate -# define deflateBound z_deflateBound -# define deflateCopy z_deflateCopy -# define deflateEnd z_deflateEnd -# define deflateGetDictionary z_deflateGetDictionary -# define deflateInit z_deflateInit -# define deflateInit2 z_deflateInit2 -# define deflateInit2_ z_deflateInit2_ -# define deflateInit_ z_deflateInit_ -# define deflateParams z_deflateParams -# define deflatePending z_deflatePending -# define deflatePrime z_deflatePrime -# define deflateReset z_deflateReset -# define deflateResetKeep z_deflateResetKeep -# define deflateSetDictionary z_deflateSetDictionary -# define deflateSetHeader z_deflateSetHeader -# define deflateTune z_deflateTune -# define deflate_copyright z_deflate_copyright -# define get_crc_table z_get_crc_table -# ifndef Z_SOLO -# define gz_error z_gz_error -# define gz_intmax z_gz_intmax -# define gz_strwinerror z_gz_strwinerror -# define gzbuffer z_gzbuffer -# define gzclearerr z_gzclearerr -# define gzclose z_gzclose -# define gzclose_r z_gzclose_r -# define gzclose_w z_gzclose_w -# define gzdirect z_gzdirect -# define gzdopen z_gzdopen -# define gzeof z_gzeof -# define gzerror z_gzerror -# define gzflush z_gzflush -# define gzfread z_gzfread -# define gzfwrite z_gzfwrite -# define gzgetc z_gzgetc -# define gzgetc_ z_gzgetc_ -# define gzgets z_gzgets -# define gzoffset z_gzoffset -# define gzoffset64 z_gzoffset64 -# define gzopen z_gzopen -# define gzopen64 z_gzopen64 -# ifdef _WIN32 -# define gzopen_w z_gzopen_w -# endif -# define gzprintf z_gzprintf -# define gzputc z_gzputc -# define gzputs z_gzputs -# define gzread z_gzread -# define gzrewind z_gzrewind -# define gzseek z_gzseek -# define gzseek64 z_gzseek64 -# define gzsetparams z_gzsetparams -# define gztell z_gztell -# define gztell64 z_gztell64 -# define gzungetc z_gzungetc -# define gzvprintf z_gzvprintf -# define gzwrite z_gzwrite -# endif -# define inflate z_inflate -# define inflateBack z_inflateBack -# define inflateBackEnd z_inflateBackEnd -# define inflateBackInit z_inflateBackInit -# define inflateBackInit_ z_inflateBackInit_ -# define inflateCodesUsed z_inflateCodesUsed -# define inflateCopy z_inflateCopy -# define inflateEnd z_inflateEnd -# define inflateGetDictionary z_inflateGetDictionary -# define inflateGetHeader z_inflateGetHeader -# define inflateInit z_inflateInit -# define inflateInit2 z_inflateInit2 -# define inflateInit2_ z_inflateInit2_ -# define inflateInit_ z_inflateInit_ -# define inflateMark z_inflateMark -# define inflatePrime z_inflatePrime -# define inflateReset z_inflateReset -# define inflateReset2 z_inflateReset2 -# define inflateResetKeep z_inflateResetKeep -# define inflateSetDictionary z_inflateSetDictionary -# define inflateSync z_inflateSync -# define inflateSyncPoint z_inflateSyncPoint -# define inflateUndermine z_inflateUndermine -# define inflateValidate z_inflateValidate -# define inflate_copyright z_inflate_copyright -# define inflate_fast z_inflate_fast -# define inflate_table z_inflate_table -# ifndef Z_SOLO -# define uncompress z_uncompress -# define uncompress2 z_uncompress2 -# endif -# define zError z_zError -# ifndef Z_SOLO -# define zcalloc z_zcalloc -# define zcfree z_zcfree -# endif -# define zlibCompileFlags z_zlibCompileFlags -# define zlibVersion z_zlibVersion - -/* all zlib typedefs in zlib.h and zconf.h */ -# define Byte z_Byte -# define Bytef z_Bytef -# define alloc_func z_alloc_func -# define charf z_charf -# define free_func z_free_func -# ifndef Z_SOLO -# define gzFile z_gzFile -# endif -# define gz_header z_gz_header -# define gz_headerp z_gz_headerp -# define in_func z_in_func -# define intf z_intf -# define out_func z_out_func -# define uInt z_uInt -# define uIntf z_uIntf -# define uLong z_uLong -# define uLongf z_uLongf -# define voidp z_voidp -# define voidpc z_voidpc -# define voidpf z_voidpf - -/* all zlib structs in zlib.h and zconf.h */ -# define gz_header_s z_gz_header_s -# define internal_state z_internal_state - -#endif - -#if defined(__MSDOS__) && !defined(MSDOS) -# define MSDOS -#endif -#if (defined(OS_2) || defined(__OS2__)) && !defined(OS2) -# define OS2 -#endif -#if defined(_WINDOWS) && !defined(WINDOWS) -# define WINDOWS -#endif -#if defined(_WIN32) || defined(_WIN32_WCE) || defined(__WIN32__) -# ifndef WIN32 -# define WIN32 -# endif -#endif -#if (defined(MSDOS) || defined(OS2) || defined(WINDOWS)) && !defined(WIN32) -# if !defined(__GNUC__) && !defined(__FLAT__) && !defined(__386__) -# ifndef SYS16BIT -# define SYS16BIT -# endif -# endif -#endif - -/* - * Compile with -DMAXSEG_64K if the alloc function cannot allocate more - * than 64k bytes at a time (needed on systems with 16-bit int). - */ -#ifdef SYS16BIT -# define MAXSEG_64K -#endif -#ifdef MSDOS -# define UNALIGNED_OK -#endif - -#ifdef __STDC_VERSION__ -# ifndef STDC -# define STDC -# endif -# if __STDC_VERSION__ >= 199901L -# ifndef STDC99 -# define STDC99 -# endif -# endif -#endif -#if !defined(STDC) && (defined(__STDC__) || defined(__cplusplus)) -# define STDC -#endif -#if !defined(STDC) && (defined(__GNUC__) || defined(__BORLANDC__)) -# define STDC -#endif -#if !defined(STDC) && (defined(MSDOS) || defined(WINDOWS) || defined(WIN32)) -# define STDC -#endif -#if !defined(STDC) && (defined(OS2) || defined(__HOS_AIX__)) -# define STDC -#endif - -#if defined(__OS400__) && !defined(STDC) /* iSeries (formerly AS/400). */ -# define STDC -#endif - -#ifndef STDC -# ifndef const /* cannot use !defined(STDC) && !defined(const) on Mac */ -# define const /* note: need a more gentle solution here */ -# endif -#endif - -#if defined(ZLIB_CONST) && !defined(z_const) -# define z_const const -#else -# define z_const -#endif - -#ifdef Z_SOLO - typedef unsigned long z_size_t; -#else -# define z_longlong long long -# if defined(NO_SIZE_T) - typedef unsigned NO_SIZE_T z_size_t; -# elif defined(STDC) -# include - typedef size_t z_size_t; -# else - typedef unsigned long z_size_t; -# endif -# undef z_longlong -#endif - -/* Maximum value for memLevel in deflateInit2 */ -#ifndef MAX_MEM_LEVEL -# ifdef MAXSEG_64K -# define MAX_MEM_LEVEL 8 -# else -# define MAX_MEM_LEVEL 9 -# endif -#endif - -/* Maximum value for windowBits in deflateInit2 and inflateInit2. - * WARNING: reducing MAX_WBITS makes minigzip unable to extract .gz files - * created by gzip. (Files created by minigzip can still be extracted by - * gzip.) - */ -#ifndef MAX_WBITS -# define MAX_WBITS 15 /* 32K LZ77 window */ -#endif - -/* The memory requirements for deflate are (in bytes): - (1 << (windowBits+2)) + (1 << (memLevel+9)) - that is: 128K for windowBits=15 + 128K for memLevel = 8 (default values) - plus a few kilobytes for small objects. For example, if you want to reduce - the default memory requirements from 256K to 128K, compile with - make CFLAGS="-O -DMAX_WBITS=14 -DMAX_MEM_LEVEL=7" - Of course this will generally degrade compression (there's no free lunch). - - The memory requirements for inflate are (in bytes) 1 << windowBits - that is, 32K for windowBits=15 (default value) plus about 7 kilobytes - for small objects. -*/ - - /* Type declarations */ - -#ifndef OF /* function prototypes */ -# ifdef STDC -# define OF(args) args -# else -# define OF(args) () -# endif -#endif - -#ifndef Z_ARG /* function prototypes for stdarg */ -# if defined(STDC) || defined(Z_HAVE_STDARG_H) -# define Z_ARG(args) args -# else -# define Z_ARG(args) () -# endif -#endif - -/* The following definitions for FAR are needed only for MSDOS mixed - * model programming (small or medium model with some far allocations). - * This was tested only with MSC; for other MSDOS compilers you may have - * to define NO_MEMCPY in zutil.h. If you don't need the mixed model, - * just define FAR to be empty. - */ -#ifdef SYS16BIT -# if defined(M_I86SM) || defined(M_I86MM) - /* MSC small or medium model */ -# define SMALL_MEDIUM -# ifdef _MSC_VER -# define FAR _far -# else -# define FAR far -# endif -# endif -# if (defined(__SMALL__) || defined(__MEDIUM__)) - /* Turbo C small or medium model */ -# define SMALL_MEDIUM -# ifdef __BORLANDC__ -# define FAR _far -# else -# define FAR far -# endif -# endif -#endif - -#if defined(WINDOWS) || defined(WIN32) - /* If building or using zlib as a DLL, define ZLIB_DLL. - * This is not mandatory, but it offers a little performance increase. - */ -# ifdef ZLIB_DLL -# if defined(WIN32) && (!defined(__BORLANDC__) || (__BORLANDC__ >= 0x500)) -# ifdef ZLIB_INTERNAL -# define ZEXTERN extern __declspec(dllexport) -# else -# define ZEXTERN extern __declspec(dllimport) -# endif -# endif -# endif /* ZLIB_DLL */ - /* If building or using zlib with the WINAPI/WINAPIV calling convention, - * define ZLIB_WINAPI. - * Caution: the standard ZLIB1.DLL is NOT compiled using ZLIB_WINAPI. - */ -# ifdef ZLIB_WINAPI -# ifdef FAR -# undef FAR -# endif -# include - /* No need for _export, use ZLIB.DEF instead. */ - /* For complete Windows compatibility, use WINAPI, not __stdcall. */ -# define ZEXPORT WINAPI -# ifdef WIN32 -# define ZEXPORTVA WINAPIV -# else -# define ZEXPORTVA FAR CDECL -# endif -# endif -#endif - -#if defined (__BEOS__) -# ifdef ZLIB_DLL -# ifdef ZLIB_INTERNAL -# define ZEXPORT __declspec(dllexport) -# define ZEXPORTVA __declspec(dllexport) -# else -# define ZEXPORT __declspec(dllimport) -# define ZEXPORTVA __declspec(dllimport) -# endif -# endif -#endif - -#ifndef ZEXTERN -# define ZEXTERN extern -#endif -#ifndef ZEXPORT -# define ZEXPORT -#endif -#ifndef ZEXPORTVA -# define ZEXPORTVA -#endif - -#ifndef FAR -# define FAR -#endif - -#if !defined(__MACTYPES__) -typedef unsigned char Byte; /* 8 bits */ -#endif -typedef unsigned int uInt; /* 16 bits or more */ -typedef unsigned long uLong; /* 32 bits or more */ - -#ifdef SMALL_MEDIUM - /* Borland C/C++ and some old MSC versions ignore FAR inside typedef */ -# define Bytef Byte FAR -#else - typedef Byte FAR Bytef; -#endif -typedef char FAR charf; -typedef int FAR intf; -typedef uInt FAR uIntf; -typedef uLong FAR uLongf; - -#ifdef STDC - typedef void const *voidpc; - typedef void FAR *voidpf; - typedef void *voidp; -#else - typedef Byte const *voidpc; - typedef Byte FAR *voidpf; - typedef Byte *voidp; -#endif - -#if !defined(Z_U4) && !defined(Z_SOLO) && defined(STDC) -# include -# if (UINT_MAX == 0xffffffffUL) -# define Z_U4 unsigned -# elif (ULONG_MAX == 0xffffffffUL) -# define Z_U4 unsigned long -# elif (USHRT_MAX == 0xffffffffUL) -# define Z_U4 unsigned short -# endif -#endif - -#ifdef Z_U4 - typedef Z_U4 z_crc_t; -#else - typedef unsigned long z_crc_t; -#endif - -#ifdef HAVE_UNISTD_H /* may be set to #if 1 by ./configure */ -# define Z_HAVE_UNISTD_H -#endif - -#ifdef HAVE_STDARG_H /* may be set to #if 1 by ./configure */ -# define Z_HAVE_STDARG_H -#endif - -#ifdef STDC -# ifndef Z_SOLO -# include /* for off_t */ -# endif -#endif - -#if defined(STDC) || defined(Z_HAVE_STDARG_H) -# ifndef Z_SOLO -# include /* for va_list */ -# endif -#endif - -#ifdef _WIN32 -# ifndef Z_SOLO -# include /* for wchar_t */ -# endif -#endif - -/* a little trick to accommodate both "#define _LARGEFILE64_SOURCE" and - * "#define _LARGEFILE64_SOURCE 1" as requesting 64-bit operations, (even - * though the former does not conform to the LFS document), but considering - * both "#undef _LARGEFILE64_SOURCE" and "#define _LARGEFILE64_SOURCE 0" as - * equivalently requesting no 64-bit operations - */ -#if defined(_LARGEFILE64_SOURCE) && -_LARGEFILE64_SOURCE - -1 == 1 -# undef _LARGEFILE64_SOURCE -#endif - -#if defined(__WATCOMC__) && !defined(Z_HAVE_UNISTD_H) -# define Z_HAVE_UNISTD_H -#endif -#ifndef Z_SOLO -# if defined(Z_HAVE_UNISTD_H) || defined(_LARGEFILE64_SOURCE) -# include /* for SEEK_*, off_t, and _LFS64_LARGEFILE */ -# ifdef VMS -# include /* for off_t */ -# endif -# ifndef z_off_t -# define z_off_t off_t -# endif -# endif -#endif - -#if defined(_LFS64_LARGEFILE) && _LFS64_LARGEFILE-0 -# define Z_LFS64 -#endif - -#if defined(_LARGEFILE64_SOURCE) && defined(Z_LFS64) -# define Z_LARGE64 -#endif - -#if defined(_FILE_OFFSET_BITS) && _FILE_OFFSET_BITS-0 == 64 && defined(Z_LFS64) -# define Z_WANT64 -#endif - -#if !defined(SEEK_SET) && !defined(Z_SOLO) -# define SEEK_SET 0 /* Seek from beginning of file. */ -# define SEEK_CUR 1 /* Seek from current position. */ -# define SEEK_END 2 /* Set file pointer to EOF plus "offset" */ -#endif - -#ifndef z_off_t -# define z_off_t long -#endif - -#if !defined(_WIN32) && defined(Z_LARGE64) -# define z_off64_t off64_t -#else -# if defined(_WIN32) && !defined(__GNUC__) && !defined(Z_SOLO) -# define z_off64_t __int64 -# else -# define z_off64_t z_off_t -# endif -#endif - -/* MVS linker does not support external names larger than 8 bytes */ -#if defined(__MVS__) - #pragma map(deflateInit_,"DEIN") - #pragma map(deflateInit2_,"DEIN2") - #pragma map(deflateEnd,"DEEND") - #pragma map(deflateBound,"DEBND") - #pragma map(inflateInit_,"ININ") - #pragma map(inflateInit2_,"ININ2") - #pragma map(inflateEnd,"INEND") - #pragma map(inflateSync,"INSY") - #pragma map(inflateSetDictionary,"INSEDI") - #pragma map(compressBound,"CMBND") - #pragma map(inflate_table,"INTABL") - #pragma map(inflate_fast,"INFA") - #pragma map(inflate_copyright,"INCOPY") -#endif - -#endif /* ZCONF_H */ DELETED compat/zlib/zconf.h.in Index: compat/zlib/zconf.h.in ================================================================== --- compat/zlib/zconf.h.in +++ /dev/null @@ -1,534 +0,0 @@ -/* zconf.h -- configuration of the zlib compression library - * Copyright (C) 1995-2016 Jean-loup Gailly, Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -/* @(#) $Id$ */ - -#ifndef ZCONF_H -#define ZCONF_H - -/* - * If you *really* need a unique prefix for all types and library functions, - * compile with -DZ_PREFIX. The "standard" zlib should be compiled without it. - * Even better than compiling with -DZ_PREFIX would be to use configure to set - * this permanently in zconf.h using "./configure --zprefix". - */ -#ifdef Z_PREFIX /* may be set to #if 1 by ./configure */ -# define Z_PREFIX_SET - -/* all linked symbols and init macros */ -# define _dist_code z__dist_code -# define _length_code z__length_code -# define _tr_align z__tr_align -# define _tr_flush_bits z__tr_flush_bits -# define _tr_flush_block z__tr_flush_block -# define _tr_init z__tr_init -# define _tr_stored_block z__tr_stored_block -# define _tr_tally z__tr_tally -# define adler32 z_adler32 -# define adler32_combine z_adler32_combine -# define adler32_combine64 z_adler32_combine64 -# define adler32_z z_adler32_z -# ifndef Z_SOLO -# define compress z_compress -# define compress2 z_compress2 -# define compressBound z_compressBound -# endif -# define crc32 z_crc32 -# define crc32_combine z_crc32_combine -# define crc32_combine64 z_crc32_combine64 -# define crc32_z z_crc32_z -# define deflate z_deflate -# define deflateBound z_deflateBound -# define deflateCopy z_deflateCopy -# define deflateEnd z_deflateEnd -# define deflateGetDictionary z_deflateGetDictionary -# define deflateInit z_deflateInit -# define deflateInit2 z_deflateInit2 -# define deflateInit2_ z_deflateInit2_ -# define deflateInit_ z_deflateInit_ -# define deflateParams z_deflateParams -# define deflatePending z_deflatePending -# define deflatePrime z_deflatePrime -# define deflateReset z_deflateReset -# define deflateResetKeep z_deflateResetKeep -# define deflateSetDictionary z_deflateSetDictionary -# define deflateSetHeader z_deflateSetHeader -# define deflateTune z_deflateTune -# define deflate_copyright z_deflate_copyright -# define get_crc_table z_get_crc_table -# ifndef Z_SOLO -# define gz_error z_gz_error -# define gz_intmax z_gz_intmax -# define gz_strwinerror z_gz_strwinerror -# define gzbuffer z_gzbuffer -# define gzclearerr z_gzclearerr -# define gzclose z_gzclose -# define gzclose_r z_gzclose_r -# define gzclose_w z_gzclose_w -# define gzdirect z_gzdirect -# define gzdopen z_gzdopen -# define gzeof z_gzeof -# define gzerror z_gzerror -# define gzflush z_gzflush -# define gzfread z_gzfread -# define gzfwrite z_gzfwrite -# define gzgetc z_gzgetc -# define gzgetc_ z_gzgetc_ -# define gzgets z_gzgets -# define gzoffset z_gzoffset -# define gzoffset64 z_gzoffset64 -# define gzopen z_gzopen -# define gzopen64 z_gzopen64 -# ifdef _WIN32 -# define gzopen_w z_gzopen_w -# endif -# define gzprintf z_gzprintf -# define gzputc z_gzputc -# define gzputs z_gzputs -# define gzread z_gzread -# define gzrewind z_gzrewind -# define gzseek z_gzseek -# define gzseek64 z_gzseek64 -# define gzsetparams z_gzsetparams -# define gztell z_gztell -# define gztell64 z_gztell64 -# define gzungetc z_gzungetc -# define gzvprintf z_gzvprintf -# define gzwrite z_gzwrite -# endif -# define inflate z_inflate -# define inflateBack z_inflateBack -# define inflateBackEnd z_inflateBackEnd -# define inflateBackInit z_inflateBackInit -# define inflateBackInit_ z_inflateBackInit_ -# define inflateCodesUsed z_inflateCodesUsed -# define inflateCopy z_inflateCopy -# define inflateEnd z_inflateEnd -# define inflateGetDictionary z_inflateGetDictionary -# define inflateGetHeader z_inflateGetHeader -# define inflateInit z_inflateInit -# define inflateInit2 z_inflateInit2 -# define inflateInit2_ z_inflateInit2_ -# define inflateInit_ z_inflateInit_ -# define inflateMark z_inflateMark -# define inflatePrime z_inflatePrime -# define inflateReset z_inflateReset -# define inflateReset2 z_inflateReset2 -# define inflateResetKeep z_inflateResetKeep -# define inflateSetDictionary z_inflateSetDictionary -# define inflateSync z_inflateSync -# define inflateSyncPoint z_inflateSyncPoint -# define inflateUndermine z_inflateUndermine -# define inflateValidate z_inflateValidate -# define inflate_copyright z_inflate_copyright -# define inflate_fast z_inflate_fast -# define inflate_table z_inflate_table -# ifndef Z_SOLO -# define uncompress z_uncompress -# define uncompress2 z_uncompress2 -# endif -# define zError z_zError -# ifndef Z_SOLO -# define zcalloc z_zcalloc -# define zcfree z_zcfree -# endif -# define zlibCompileFlags z_zlibCompileFlags -# define zlibVersion z_zlibVersion - -/* all zlib typedefs in zlib.h and zconf.h */ -# define Byte z_Byte -# define Bytef z_Bytef -# define alloc_func z_alloc_func -# define charf z_charf -# define free_func z_free_func -# ifndef Z_SOLO -# define gzFile z_gzFile -# endif -# define gz_header z_gz_header -# define gz_headerp z_gz_headerp -# define in_func z_in_func -# define intf z_intf -# define out_func z_out_func -# define uInt z_uInt -# define uIntf z_uIntf -# define uLong z_uLong -# define uLongf z_uLongf -# define voidp z_voidp -# define voidpc z_voidpc -# define voidpf z_voidpf - -/* all zlib structs in zlib.h and zconf.h */ -# define gz_header_s z_gz_header_s -# define internal_state z_internal_state - -#endif - -#if defined(__MSDOS__) && !defined(MSDOS) -# define MSDOS -#endif -#if (defined(OS_2) || defined(__OS2__)) && !defined(OS2) -# define OS2 -#endif -#if defined(_WINDOWS) && !defined(WINDOWS) -# define WINDOWS -#endif -#if defined(_WIN32) || defined(_WIN32_WCE) || defined(__WIN32__) -# ifndef WIN32 -# define WIN32 -# endif -#endif -#if (defined(MSDOS) || defined(OS2) || defined(WINDOWS)) && !defined(WIN32) -# if !defined(__GNUC__) && !defined(__FLAT__) && !defined(__386__) -# ifndef SYS16BIT -# define SYS16BIT -# endif -# endif -#endif - -/* - * Compile with -DMAXSEG_64K if the alloc function cannot allocate more - * than 64k bytes at a time (needed on systems with 16-bit int). - */ -#ifdef SYS16BIT -# define MAXSEG_64K -#endif -#ifdef MSDOS -# define UNALIGNED_OK -#endif - -#ifdef __STDC_VERSION__ -# ifndef STDC -# define STDC -# endif -# if __STDC_VERSION__ >= 199901L -# ifndef STDC99 -# define STDC99 -# endif -# endif -#endif -#if !defined(STDC) && (defined(__STDC__) || defined(__cplusplus)) -# define STDC -#endif -#if !defined(STDC) && (defined(__GNUC__) || defined(__BORLANDC__)) -# define STDC -#endif -#if !defined(STDC) && (defined(MSDOS) || defined(WINDOWS) || defined(WIN32)) -# define STDC -#endif -#if !defined(STDC) && (defined(OS2) || defined(__HOS_AIX__)) -# define STDC -#endif - -#if defined(__OS400__) && !defined(STDC) /* iSeries (formerly AS/400). */ -# define STDC -#endif - -#ifndef STDC -# ifndef const /* cannot use !defined(STDC) && !defined(const) on Mac */ -# define const /* note: need a more gentle solution here */ -# endif -#endif - -#if defined(ZLIB_CONST) && !defined(z_const) -# define z_const const -#else -# define z_const -#endif - -#ifdef Z_SOLO - typedef unsigned long z_size_t; -#else -# define z_longlong long long -# if defined(NO_SIZE_T) - typedef unsigned NO_SIZE_T z_size_t; -# elif defined(STDC) -# include - typedef size_t z_size_t; -# else - typedef unsigned long z_size_t; -# endif -# undef z_longlong -#endif - -/* Maximum value for memLevel in deflateInit2 */ -#ifndef MAX_MEM_LEVEL -# ifdef MAXSEG_64K -# define MAX_MEM_LEVEL 8 -# else -# define MAX_MEM_LEVEL 9 -# endif -#endif - -/* Maximum value for windowBits in deflateInit2 and inflateInit2. - * WARNING: reducing MAX_WBITS makes minigzip unable to extract .gz files - * created by gzip. (Files created by minigzip can still be extracted by - * gzip.) - */ -#ifndef MAX_WBITS -# define MAX_WBITS 15 /* 32K LZ77 window */ -#endif - -/* The memory requirements for deflate are (in bytes): - (1 << (windowBits+2)) + (1 << (memLevel+9)) - that is: 128K for windowBits=15 + 128K for memLevel = 8 (default values) - plus a few kilobytes for small objects. For example, if you want to reduce - the default memory requirements from 256K to 128K, compile with - make CFLAGS="-O -DMAX_WBITS=14 -DMAX_MEM_LEVEL=7" - Of course this will generally degrade compression (there's no free lunch). - - The memory requirements for inflate are (in bytes) 1 << windowBits - that is, 32K for windowBits=15 (default value) plus about 7 kilobytes - for small objects. -*/ - - /* Type declarations */ - -#ifndef OF /* function prototypes */ -# ifdef STDC -# define OF(args) args -# else -# define OF(args) () -# endif -#endif - -#ifndef Z_ARG /* function prototypes for stdarg */ -# if defined(STDC) || defined(Z_HAVE_STDARG_H) -# define Z_ARG(args) args -# else -# define Z_ARG(args) () -# endif -#endif - -/* The following definitions for FAR are needed only for MSDOS mixed - * model programming (small or medium model with some far allocations). - * This was tested only with MSC; for other MSDOS compilers you may have - * to define NO_MEMCPY in zutil.h. If you don't need the mixed model, - * just define FAR to be empty. - */ -#ifdef SYS16BIT -# if defined(M_I86SM) || defined(M_I86MM) - /* MSC small or medium model */ -# define SMALL_MEDIUM -# ifdef _MSC_VER -# define FAR _far -# else -# define FAR far -# endif -# endif -# if (defined(__SMALL__) || defined(__MEDIUM__)) - /* Turbo C small or medium model */ -# define SMALL_MEDIUM -# ifdef __BORLANDC__ -# define FAR _far -# else -# define FAR far -# endif -# endif -#endif - -#if defined(WINDOWS) || defined(WIN32) - /* If building or using zlib as a DLL, define ZLIB_DLL. - * This is not mandatory, but it offers a little performance increase. - */ -# ifdef ZLIB_DLL -# if defined(WIN32) && (!defined(__BORLANDC__) || (__BORLANDC__ >= 0x500)) -# ifdef ZLIB_INTERNAL -# define ZEXTERN extern __declspec(dllexport) -# else -# define ZEXTERN extern __declspec(dllimport) -# endif -# endif -# endif /* ZLIB_DLL */ - /* If building or using zlib with the WINAPI/WINAPIV calling convention, - * define ZLIB_WINAPI. - * Caution: the standard ZLIB1.DLL is NOT compiled using ZLIB_WINAPI. - */ -# ifdef ZLIB_WINAPI -# ifdef FAR -# undef FAR -# endif -# include - /* No need for _export, use ZLIB.DEF instead. */ - /* For complete Windows compatibility, use WINAPI, not __stdcall. */ -# define ZEXPORT WINAPI -# ifdef WIN32 -# define ZEXPORTVA WINAPIV -# else -# define ZEXPORTVA FAR CDECL -# endif -# endif -#endif - -#if defined (__BEOS__) -# ifdef ZLIB_DLL -# ifdef ZLIB_INTERNAL -# define ZEXPORT __declspec(dllexport) -# define ZEXPORTVA __declspec(dllexport) -# else -# define ZEXPORT __declspec(dllimport) -# define ZEXPORTVA __declspec(dllimport) -# endif -# endif -#endif - -#ifndef ZEXTERN -# define ZEXTERN extern -#endif -#ifndef ZEXPORT -# define ZEXPORT -#endif -#ifndef ZEXPORTVA -# define ZEXPORTVA -#endif - -#ifndef FAR -# define FAR -#endif - -#if !defined(__MACTYPES__) -typedef unsigned char Byte; /* 8 bits */ -#endif -typedef unsigned int uInt; /* 16 bits or more */ -typedef unsigned long uLong; /* 32 bits or more */ - -#ifdef SMALL_MEDIUM - /* Borland C/C++ and some old MSC versions ignore FAR inside typedef */ -# define Bytef Byte FAR -#else - typedef Byte FAR Bytef; -#endif -typedef char FAR charf; -typedef int FAR intf; -typedef uInt FAR uIntf; -typedef uLong FAR uLongf; - -#ifdef STDC - typedef void const *voidpc; - typedef void FAR *voidpf; - typedef void *voidp; -#else - typedef Byte const *voidpc; - typedef Byte FAR *voidpf; - typedef Byte *voidp; -#endif - -#if !defined(Z_U4) && !defined(Z_SOLO) && defined(STDC) -# include -# if (UINT_MAX == 0xffffffffUL) -# define Z_U4 unsigned -# elif (ULONG_MAX == 0xffffffffUL) -# define Z_U4 unsigned long -# elif (USHRT_MAX == 0xffffffffUL) -# define Z_U4 unsigned short -# endif -#endif - -#ifdef Z_U4 - typedef Z_U4 z_crc_t; -#else - typedef unsigned long z_crc_t; -#endif - -#ifdef HAVE_UNISTD_H /* may be set to #if 1 by ./configure */ -# define Z_HAVE_UNISTD_H -#endif - -#ifdef HAVE_STDARG_H /* may be set to #if 1 by ./configure */ -# define Z_HAVE_STDARG_H -#endif - -#ifdef STDC -# ifndef Z_SOLO -# include /* for off_t */ -# endif -#endif - -#if defined(STDC) || defined(Z_HAVE_STDARG_H) -# ifndef Z_SOLO -# include /* for va_list */ -# endif -#endif - -#ifdef _WIN32 -# ifndef Z_SOLO -# include /* for wchar_t */ -# endif -#endif - -/* a little trick to accommodate both "#define _LARGEFILE64_SOURCE" and - * "#define _LARGEFILE64_SOURCE 1" as requesting 64-bit operations, (even - * though the former does not conform to the LFS document), but considering - * both "#undef _LARGEFILE64_SOURCE" and "#define _LARGEFILE64_SOURCE 0" as - * equivalently requesting no 64-bit operations - */ -#if defined(_LARGEFILE64_SOURCE) && -_LARGEFILE64_SOURCE - -1 == 1 -# undef _LARGEFILE64_SOURCE -#endif - -#if defined(__WATCOMC__) && !defined(Z_HAVE_UNISTD_H) -# define Z_HAVE_UNISTD_H -#endif -#ifndef Z_SOLO -# if defined(Z_HAVE_UNISTD_H) || defined(_LARGEFILE64_SOURCE) -# include /* for SEEK_*, off_t, and _LFS64_LARGEFILE */ -# ifdef VMS -# include /* for off_t */ -# endif -# ifndef z_off_t -# define z_off_t off_t -# endif -# endif -#endif - -#if defined(_LFS64_LARGEFILE) && _LFS64_LARGEFILE-0 -# define Z_LFS64 -#endif - -#if defined(_LARGEFILE64_SOURCE) && defined(Z_LFS64) -# define Z_LARGE64 -#endif - -#if defined(_FILE_OFFSET_BITS) && _FILE_OFFSET_BITS-0 == 64 && defined(Z_LFS64) -# define Z_WANT64 -#endif - -#if !defined(SEEK_SET) && !defined(Z_SOLO) -# define SEEK_SET 0 /* Seek from beginning of file. */ -# define SEEK_CUR 1 /* Seek from current position. */ -# define SEEK_END 2 /* Set file pointer to EOF plus "offset" */ -#endif - -#ifndef z_off_t -# define z_off_t long -#endif - -#if !defined(_WIN32) && defined(Z_LARGE64) -# define z_off64_t off64_t -#else -# if defined(_WIN32) && !defined(__GNUC__) && !defined(Z_SOLO) -# define z_off64_t __int64 -# else -# define z_off64_t z_off_t -# endif -#endif - -/* MVS linker does not support external names larger than 8 bytes */ -#if defined(__MVS__) - #pragma map(deflateInit_,"DEIN") - #pragma map(deflateInit2_,"DEIN2") - #pragma map(deflateEnd,"DEEND") - #pragma map(deflateBound,"DEBND") - #pragma map(inflateInit_,"ININ") - #pragma map(inflateInit2_,"ININ2") - #pragma map(inflateEnd,"INEND") - #pragma map(inflateSync,"INSY") - #pragma map(inflateSetDictionary,"INSEDI") - #pragma map(compressBound,"CMBND") - #pragma map(inflate_table,"INTABL") - #pragma map(inflate_fast,"INFA") - #pragma map(inflate_copyright,"INCOPY") -#endif - -#endif /* ZCONF_H */ DELETED compat/zlib/zlib.3 Index: compat/zlib/zlib.3 ================================================================== --- compat/zlib/zlib.3 +++ /dev/null @@ -1,149 +0,0 @@ -.TH ZLIB 3 "15 Jan 2017" -.SH NAME -zlib \- compression/decompression library -.SH SYNOPSIS -[see -.I zlib.h -for full description] -.SH DESCRIPTION -The -.I zlib -library is a general purpose data compression library. -The code is thread safe, assuming that the standard library functions -used are thread safe, such as memory allocation routines. -It provides in-memory compression and decompression functions, -including integrity checks of the uncompressed data. -This version of the library supports only one compression method (deflation) -but other algorithms may be added later -with the same stream interface. -.LP -Compression can be done in a single step if the buffers are large enough -or can be done by repeated calls of the compression function. -In the latter case, -the application must provide more input and/or consume the output -(providing more output space) before each call. -.LP -The library also supports reading and writing files in -.IR gzip (1) -(.gz) format -with an interface similar to that of stdio. -.LP -The library does not install any signal handler. -The decoder checks the consistency of the compressed data, -so the library should never crash even in the case of corrupted input. -.LP -All functions of the compression library are documented in the file -.IR zlib.h . -The distribution source includes examples of use of the library -in the files -.I test/example.c -and -.IR test/minigzip.c, -as well as other examples in the -.IR examples/ -directory. -.LP -Changes to this version are documented in the file -.I ChangeLog -that accompanies the source. -.LP -.I zlib -is built in to many languages and operating systems, including but not limited to -Java, Python, .NET, PHP, Perl, Ruby, Swift, and Go. -.LP -An experimental package to read and write files in the .zip format, -written on top of -.I zlib -by Gilles Vollant (info@winimage.com), -is available at: -.IP -http://www.winimage.com/zLibDll/minizip.html -and also in the -.I contrib/minizip -directory of the main -.I zlib -source distribution. -.SH "SEE ALSO" -The -.I zlib -web site can be found at: -.IP -http://zlib.net/ -.LP -The data format used by the -.I zlib -library is described by RFC -(Request for Comments) 1950 to 1952 in the files: -.IP -http://tools.ietf.org/html/rfc1950 (for the zlib header and trailer format) -.br -http://tools.ietf.org/html/rfc1951 (for the deflate compressed data format) -.br -http://tools.ietf.org/html/rfc1952 (for the gzip header and trailer format) -.LP -Mark Nelson wrote an article about -.I zlib -for the Jan. 1997 issue of Dr. Dobb's Journal; -a copy of the article is available at: -.IP -http://marknelson.us/1997/01/01/zlib-engine/ -.SH "REPORTING PROBLEMS" -Before reporting a problem, -please check the -.I zlib -web site to verify that you have the latest version of -.IR zlib ; -otherwise, -obtain the latest version and see if the problem still exists. -Please read the -.I zlib -FAQ at: -.IP -http://zlib.net/zlib_faq.html -.LP -before asking for help. -Send questions and/or comments to zlib@gzip.org, -or (for the Windows DLL version) to Gilles Vollant (info@winimage.com). -.SH AUTHORS AND LICENSE -Version 1.2.11 -.LP -Copyright (C) 1995-2017 Jean-loup Gailly and Mark Adler -.LP -This software is provided 'as-is', without any express or implied -warranty. In no event will the authors be held liable for any damages -arising from the use of this software. -.LP -Permission is granted to anyone to use this software for any purpose, -including commercial applications, and to alter it and redistribute it -freely, subject to the following restrictions: -.LP -.nr step 1 1 -.IP \n[step]. 3 -The origin of this software must not be misrepresented; you must not -claim that you wrote the original software. If you use this software -in a product, an acknowledgment in the product documentation would be -appreciated but is not required. -.IP \n+[step]. -Altered source versions must be plainly marked as such, and must not be -misrepresented as being the original software. -.IP \n+[step]. -This notice may not be removed or altered from any source distribution. -.LP -Jean-loup Gailly Mark Adler -.br -jloup@gzip.org madler@alumni.caltech.edu -.LP -The deflate format used by -.I zlib -was defined by Phil Katz. -The deflate and -.I zlib -specifications were written by L. Peter Deutsch. -Thanks to all the people who reported problems and suggested various -improvements in -.IR zlib ; -who are too numerous to cite here. -.LP -UNIX manual page by R. P. C. Rodgers, -U.S. National Library of Medicine (rodgers@nlm.nih.gov). -.\" end of man page DELETED compat/zlib/zlib.3.pdf Index: compat/zlib/zlib.3.pdf ================================================================== --- compat/zlib/zlib.3.pdf +++ /dev/null cannot compute difference between binary files DELETED compat/zlib/zlib.h Index: compat/zlib/zlib.h ================================================================== --- compat/zlib/zlib.h +++ /dev/null @@ -1,1912 +0,0 @@ -/* zlib.h -- interface of the 'zlib' general purpose compression library - version 1.2.11, January 15th, 2017 - - Copyright (C) 1995-2017 Jean-loup Gailly and Mark Adler - - This software is provided 'as-is', without any express or implied - warranty. In no event will the authors be held liable for any damages - arising from the use of this software. - - Permission is granted to anyone to use this software for any purpose, - including commercial applications, and to alter it and redistribute it - freely, subject to the following restrictions: - - 1. The origin of this software must not be misrepresented; you must not - claim that you wrote the original software. If you use this software - in a product, an acknowledgment in the product documentation would be - appreciated but is not required. - 2. Altered source versions must be plainly marked as such, and must not be - misrepresented as being the original software. - 3. This notice may not be removed or altered from any source distribution. - - Jean-loup Gailly Mark Adler - jloup@gzip.org madler@alumni.caltech.edu - - - The data format used by the zlib library is described by RFCs (Request for - Comments) 1950 to 1952 in the files http://tools.ietf.org/html/rfc1950 - (zlib format), rfc1951 (deflate format) and rfc1952 (gzip format). -*/ - -#ifndef ZLIB_H -#define ZLIB_H - -#include "zconf.h" - -#ifdef __cplusplus -extern "C" { -#endif - -#define ZLIB_VERSION "1.2.11" -#define ZLIB_VERNUM 0x12b0 -#define ZLIB_VER_MAJOR 1 -#define ZLIB_VER_MINOR 2 -#define ZLIB_VER_REVISION 11 -#define ZLIB_VER_SUBREVISION 0 - -/* - The 'zlib' compression library provides in-memory compression and - decompression functions, including integrity checks of the uncompressed data. - This version of the library supports only one compression method (deflation) - but other algorithms will be added later and will have the same stream - interface. - - Compression can be done in a single step if the buffers are large enough, - or can be done by repeated calls of the compression function. In the latter - case, the application must provide more input and/or consume the output - (providing more output space) before each call. - - The compressed data format used by default by the in-memory functions is - the zlib format, which is a zlib wrapper documented in RFC 1950, wrapped - around a deflate stream, which is itself documented in RFC 1951. - - The library also supports reading and writing files in gzip (.gz) format - with an interface similar to that of stdio using the functions that start - with "gz". The gzip format is different from the zlib format. gzip is a - gzip wrapper, documented in RFC 1952, wrapped around a deflate stream. - - This library can optionally read and write gzip and raw deflate streams in - memory as well. - - The zlib format was designed to be compact and fast for use in memory - and on communications channels. The gzip format was designed for single- - file compression on file systems, has a larger header than zlib to maintain - directory information, and uses a different, slower check method than zlib. - - The library does not install any signal handler. The decoder checks - the consistency of the compressed data, so the library should never crash - even in the case of corrupted input. -*/ - -typedef voidpf (*alloc_func) OF((voidpf opaque, uInt items, uInt size)); -typedef void (*free_func) OF((voidpf opaque, voidpf address)); - -struct internal_state; - -typedef struct z_stream_s { - z_const Bytef *next_in; /* next input byte */ - uInt avail_in; /* number of bytes available at next_in */ - uLong total_in; /* total number of input bytes read so far */ - - Bytef *next_out; /* next output byte will go here */ - uInt avail_out; /* remaining free space at next_out */ - uLong total_out; /* total number of bytes output so far */ - - z_const char *msg; /* last error message, NULL if no error */ - struct internal_state FAR *state; /* not visible by applications */ - - alloc_func zalloc; /* used to allocate the internal state */ - free_func zfree; /* used to free the internal state */ - voidpf opaque; /* private data object passed to zalloc and zfree */ - - int data_type; /* best guess about the data type: binary or text - for deflate, or the decoding state for inflate */ - uLong adler; /* Adler-32 or CRC-32 value of the uncompressed data */ - uLong reserved; /* reserved for future use */ -} z_stream; - -typedef z_stream FAR *z_streamp; - -/* - gzip header information passed to and from zlib routines. See RFC 1952 - for more details on the meanings of these fields. -*/ -typedef struct gz_header_s { - int text; /* true if compressed data believed to be text */ - uLong time; /* modification time */ - int xflags; /* extra flags (not used when writing a gzip file) */ - int os; /* operating system */ - Bytef *extra; /* pointer to extra field or Z_NULL if none */ - uInt extra_len; /* extra field length (valid if extra != Z_NULL) */ - uInt extra_max; /* space at extra (only when reading header) */ - Bytef *name; /* pointer to zero-terminated file name or Z_NULL */ - uInt name_max; /* space at name (only when reading header) */ - Bytef *comment; /* pointer to zero-terminated comment or Z_NULL */ - uInt comm_max; /* space at comment (only when reading header) */ - int hcrc; /* true if there was or will be a header crc */ - int done; /* true when done reading gzip header (not used - when writing a gzip file) */ -} gz_header; - -typedef gz_header FAR *gz_headerp; - -/* - The application must update next_in and avail_in when avail_in has dropped - to zero. It must update next_out and avail_out when avail_out has dropped - to zero. The application must initialize zalloc, zfree and opaque before - calling the init function. All other fields are set by the compression - library and must not be updated by the application. - - The opaque value provided by the application will be passed as the first - parameter for calls of zalloc and zfree. This can be useful for custom - memory management. The compression library attaches no meaning to the - opaque value. - - zalloc must return Z_NULL if there is not enough memory for the object. - If zlib is used in a multi-threaded application, zalloc and zfree must be - thread safe. In that case, zlib is thread-safe. When zalloc and zfree are - Z_NULL on entry to the initialization function, they are set to internal - routines that use the standard library functions malloc() and free(). - - On 16-bit systems, the functions zalloc and zfree must be able to allocate - exactly 65536 bytes, but will not be required to allocate more than this if - the symbol MAXSEG_64K is defined (see zconf.h). WARNING: On MSDOS, pointers - returned by zalloc for objects of exactly 65536 bytes *must* have their - offset normalized to zero. The default allocation function provided by this - library ensures this (see zutil.c). To reduce memory requirements and avoid - any allocation of 64K objects, at the expense of compression ratio, compile - the library with -DMAX_WBITS=14 (see zconf.h). - - The fields total_in and total_out can be used for statistics or progress - reports. After compression, total_in holds the total size of the - uncompressed data and may be saved for use by the decompressor (particularly - if the decompressor wants to decompress everything in a single step). -*/ - - /* constants */ - -#define Z_NO_FLUSH 0 -#define Z_PARTIAL_FLUSH 1 -#define Z_SYNC_FLUSH 2 -#define Z_FULL_FLUSH 3 -#define Z_FINISH 4 -#define Z_BLOCK 5 -#define Z_TREES 6 -/* Allowed flush values; see deflate() and inflate() below for details */ - -#define Z_OK 0 -#define Z_STREAM_END 1 -#define Z_NEED_DICT 2 -#define Z_ERRNO (-1) -#define Z_STREAM_ERROR (-2) -#define Z_DATA_ERROR (-3) -#define Z_MEM_ERROR (-4) -#define Z_BUF_ERROR (-5) -#define Z_VERSION_ERROR (-6) -/* Return codes for the compression/decompression functions. Negative values - * are errors, positive values are used for special but normal events. - */ - -#define Z_NO_COMPRESSION 0 -#define Z_BEST_SPEED 1 -#define Z_BEST_COMPRESSION 9 -#define Z_DEFAULT_COMPRESSION (-1) -/* compression levels */ - -#define Z_FILTERED 1 -#define Z_HUFFMAN_ONLY 2 -#define Z_RLE 3 -#define Z_FIXED 4 -#define Z_DEFAULT_STRATEGY 0 -/* compression strategy; see deflateInit2() below for details */ - -#define Z_BINARY 0 -#define Z_TEXT 1 -#define Z_ASCII Z_TEXT /* for compatibility with 1.2.2 and earlier */ -#define Z_UNKNOWN 2 -/* Possible values of the data_type field for deflate() */ - -#define Z_DEFLATED 8 -/* The deflate compression method (the only one supported in this version) */ - -#define Z_NULL 0 /* for initializing zalloc, zfree, opaque */ - -#define zlib_version zlibVersion() -/* for compatibility with versions < 1.0.2 */ - - - /* basic functions */ - -ZEXTERN const char * ZEXPORT zlibVersion OF((void)); -/* The application can compare zlibVersion and ZLIB_VERSION for consistency. - If the first character differs, the library code actually used is not - compatible with the zlib.h header file used by the application. This check - is automatically made by deflateInit and inflateInit. - */ - -/* -ZEXTERN int ZEXPORT deflateInit OF((z_streamp strm, int level)); - - Initializes the internal stream state for compression. The fields - zalloc, zfree and opaque must be initialized before by the caller. If - zalloc and zfree are set to Z_NULL, deflateInit updates them to use default - allocation functions. - - The compression level must be Z_DEFAULT_COMPRESSION, or between 0 and 9: - 1 gives best speed, 9 gives best compression, 0 gives no compression at all - (the input data is simply copied a block at a time). Z_DEFAULT_COMPRESSION - requests a default compromise between speed and compression (currently - equivalent to level 6). - - deflateInit returns Z_OK if success, Z_MEM_ERROR if there was not enough - memory, Z_STREAM_ERROR if level is not a valid compression level, or - Z_VERSION_ERROR if the zlib library version (zlib_version) is incompatible - with the version assumed by the caller (ZLIB_VERSION). msg is set to null - if there is no error message. deflateInit does not perform any compression: - this will be done by deflate(). -*/ - - -ZEXTERN int ZEXPORT deflate OF((z_streamp strm, int flush)); -/* - deflate compresses as much data as possible, and stops when the input - buffer becomes empty or the output buffer becomes full. It may introduce - some output latency (reading input without producing any output) except when - forced to flush. - - The detailed semantics are as follows. deflate performs one or both of the - following actions: - - - Compress more input starting at next_in and update next_in and avail_in - accordingly. If not all input can be processed (because there is not - enough room in the output buffer), next_in and avail_in are updated and - processing will resume at this point for the next call of deflate(). - - - Generate more output starting at next_out and update next_out and avail_out - accordingly. This action is forced if the parameter flush is non zero. - Forcing flush frequently degrades the compression ratio, so this parameter - should be set only when necessary. Some output may be provided even if - flush is zero. - - Before the call of deflate(), the application should ensure that at least - one of the actions is possible, by providing more input and/or consuming more - output, and updating avail_in or avail_out accordingly; avail_out should - never be zero before the call. The application can consume the compressed - output when it wants, for example when the output buffer is full (avail_out - == 0), or after each call of deflate(). If deflate returns Z_OK and with - zero avail_out, it must be called again after making room in the output - buffer because there might be more output pending. See deflatePending(), - which can be used if desired to determine whether or not there is more ouput - in that case. - - Normally the parameter flush is set to Z_NO_FLUSH, which allows deflate to - decide how much data to accumulate before producing output, in order to - maximize compression. - - If the parameter flush is set to Z_SYNC_FLUSH, all pending output is - flushed to the output buffer and the output is aligned on a byte boundary, so - that the decompressor can get all input data available so far. (In - particular avail_in is zero after the call if enough output space has been - provided before the call.) Flushing may degrade compression for some - compression algorithms and so it should be used only when necessary. This - completes the current deflate block and follows it with an empty stored block - that is three bits plus filler bits to the next byte, followed by four bytes - (00 00 ff ff). - - If flush is set to Z_PARTIAL_FLUSH, all pending output is flushed to the - output buffer, but the output is not aligned to a byte boundary. All of the - input data so far will be available to the decompressor, as for Z_SYNC_FLUSH. - This completes the current deflate block and follows it with an empty fixed - codes block that is 10 bits long. This assures that enough bytes are output - in order for the decompressor to finish the block before the empty fixed - codes block. - - If flush is set to Z_BLOCK, a deflate block is completed and emitted, as - for Z_SYNC_FLUSH, but the output is not aligned on a byte boundary, and up to - seven bits of the current block are held to be written as the next byte after - the next deflate block is completed. In this case, the decompressor may not - be provided enough bits at this point in order to complete decompression of - the data provided so far to the compressor. It may need to wait for the next - block to be emitted. This is for advanced applications that need to control - the emission of deflate blocks. - - If flush is set to Z_FULL_FLUSH, all output is flushed as with - Z_SYNC_FLUSH, and the compression state is reset so that decompression can - restart from this point if previous compressed data has been damaged or if - random access is desired. Using Z_FULL_FLUSH too often can seriously degrade - compression. - - If deflate returns with avail_out == 0, this function must be called again - with the same value of the flush parameter and more output space (updated - avail_out), until the flush is complete (deflate returns with non-zero - avail_out). In the case of a Z_FULL_FLUSH or Z_SYNC_FLUSH, make sure that - avail_out is greater than six to avoid repeated flush markers due to - avail_out == 0 on return. - - If the parameter flush is set to Z_FINISH, pending input is processed, - pending output is flushed and deflate returns with Z_STREAM_END if there was - enough output space. If deflate returns with Z_OK or Z_BUF_ERROR, this - function must be called again with Z_FINISH and more output space (updated - avail_out) but no more input data, until it returns with Z_STREAM_END or an - error. After deflate has returned Z_STREAM_END, the only possible operations - on the stream are deflateReset or deflateEnd. - - Z_FINISH can be used in the first deflate call after deflateInit if all the - compression is to be done in a single step. In order to complete in one - call, avail_out must be at least the value returned by deflateBound (see - below). Then deflate is guaranteed to return Z_STREAM_END. If not enough - output space is provided, deflate will not return Z_STREAM_END, and it must - be called again as described above. - - deflate() sets strm->adler to the Adler-32 checksum of all input read - so far (that is, total_in bytes). If a gzip stream is being generated, then - strm->adler will be the CRC-32 checksum of the input read so far. (See - deflateInit2 below.) - - deflate() may update strm->data_type if it can make a good guess about - the input data type (Z_BINARY or Z_TEXT). If in doubt, the data is - considered binary. This field is only for information purposes and does not - affect the compression algorithm in any manner. - - deflate() returns Z_OK if some progress has been made (more input - processed or more output produced), Z_STREAM_END if all input has been - consumed and all output has been produced (only when flush is set to - Z_FINISH), Z_STREAM_ERROR if the stream state was inconsistent (for example - if next_in or next_out was Z_NULL or the state was inadvertently written over - by the application), or Z_BUF_ERROR if no progress is possible (for example - avail_in or avail_out was zero). Note that Z_BUF_ERROR is not fatal, and - deflate() can be called again with more input and more output space to - continue compressing. -*/ - - -ZEXTERN int ZEXPORT deflateEnd OF((z_streamp strm)); -/* - All dynamically allocated data structures for this stream are freed. - This function discards any unprocessed input and does not flush any pending - output. - - deflateEnd returns Z_OK if success, Z_STREAM_ERROR if the - stream state was inconsistent, Z_DATA_ERROR if the stream was freed - prematurely (some input or output was discarded). In the error case, msg - may be set but then points to a static string (which must not be - deallocated). -*/ - - -/* -ZEXTERN int ZEXPORT inflateInit OF((z_streamp strm)); - - Initializes the internal stream state for decompression. The fields - next_in, avail_in, zalloc, zfree and opaque must be initialized before by - the caller. In the current version of inflate, the provided input is not - read or consumed. The allocation of a sliding window will be deferred to - the first call of inflate (if the decompression does not complete on the - first call). If zalloc and zfree are set to Z_NULL, inflateInit updates - them to use default allocation functions. - - inflateInit returns Z_OK if success, Z_MEM_ERROR if there was not enough - memory, Z_VERSION_ERROR if the zlib library version is incompatible with the - version assumed by the caller, or Z_STREAM_ERROR if the parameters are - invalid, such as a null pointer to the structure. msg is set to null if - there is no error message. inflateInit does not perform any decompression. - Actual decompression will be done by inflate(). So next_in, and avail_in, - next_out, and avail_out are unused and unchanged. The current - implementation of inflateInit() does not process any header information -- - that is deferred until inflate() is called. -*/ - - -ZEXTERN int ZEXPORT inflate OF((z_streamp strm, int flush)); -/* - inflate decompresses as much data as possible, and stops when the input - buffer becomes empty or the output buffer becomes full. It may introduce - some output latency (reading input without producing any output) except when - forced to flush. - - The detailed semantics are as follows. inflate performs one or both of the - following actions: - - - Decompress more input starting at next_in and update next_in and avail_in - accordingly. If not all input can be processed (because there is not - enough room in the output buffer), then next_in and avail_in are updated - accordingly, and processing will resume at this point for the next call of - inflate(). - - - Generate more output starting at next_out and update next_out and avail_out - accordingly. inflate() provides as much output as possible, until there is - no more input data or no more space in the output buffer (see below about - the flush parameter). - - Before the call of inflate(), the application should ensure that at least - one of the actions is possible, by providing more input and/or consuming more - output, and updating the next_* and avail_* values accordingly. If the - caller of inflate() does not provide both available input and available - output space, it is possible that there will be no progress made. The - application can consume the uncompressed output when it wants, for example - when the output buffer is full (avail_out == 0), or after each call of - inflate(). If inflate returns Z_OK and with zero avail_out, it must be - called again after making room in the output buffer because there might be - more output pending. - - The flush parameter of inflate() can be Z_NO_FLUSH, Z_SYNC_FLUSH, Z_FINISH, - Z_BLOCK, or Z_TREES. Z_SYNC_FLUSH requests that inflate() flush as much - output as possible to the output buffer. Z_BLOCK requests that inflate() - stop if and when it gets to the next deflate block boundary. When decoding - the zlib or gzip format, this will cause inflate() to return immediately - after the header and before the first block. When doing a raw inflate, - inflate() will go ahead and process the first block, and will return when it - gets to the end of that block, or when it runs out of data. - - The Z_BLOCK option assists in appending to or combining deflate streams. - To assist in this, on return inflate() always sets strm->data_type to the - number of unused bits in the last byte taken from strm->next_in, plus 64 if - inflate() is currently decoding the last block in the deflate stream, plus - 128 if inflate() returned immediately after decoding an end-of-block code or - decoding the complete header up to just before the first byte of the deflate - stream. The end-of-block will not be indicated until all of the uncompressed - data from that block has been written to strm->next_out. The number of - unused bits may in general be greater than seven, except when bit 7 of - data_type is set, in which case the number of unused bits will be less than - eight. data_type is set as noted here every time inflate() returns for all - flush options, and so can be used to determine the amount of currently - consumed input in bits. - - The Z_TREES option behaves as Z_BLOCK does, but it also returns when the - end of each deflate block header is reached, before any actual data in that - block is decoded. This allows the caller to determine the length of the - deflate block header for later use in random access within a deflate block. - 256 is added to the value of strm->data_type when inflate() returns - immediately after reaching the end of the deflate block header. - - inflate() should normally be called until it returns Z_STREAM_END or an - error. However if all decompression is to be performed in a single step (a - single call of inflate), the parameter flush should be set to Z_FINISH. In - this case all pending input is processed and all pending output is flushed; - avail_out must be large enough to hold all of the uncompressed data for the - operation to complete. (The size of the uncompressed data may have been - saved by the compressor for this purpose.) The use of Z_FINISH is not - required to perform an inflation in one step. However it may be used to - inform inflate that a faster approach can be used for the single inflate() - call. Z_FINISH also informs inflate to not maintain a sliding window if the - stream completes, which reduces inflate's memory footprint. If the stream - does not complete, either because not all of the stream is provided or not - enough output space is provided, then a sliding window will be allocated and - inflate() can be called again to continue the operation as if Z_NO_FLUSH had - been used. - - In this implementation, inflate() always flushes as much output as - possible to the output buffer, and always uses the faster approach on the - first call. So the effects of the flush parameter in this implementation are - on the return value of inflate() as noted below, when inflate() returns early - when Z_BLOCK or Z_TREES is used, and when inflate() avoids the allocation of - memory for a sliding window when Z_FINISH is used. - - If a preset dictionary is needed after this call (see inflateSetDictionary - below), inflate sets strm->adler to the Adler-32 checksum of the dictionary - chosen by the compressor and returns Z_NEED_DICT; otherwise it sets - strm->adler to the Adler-32 checksum of all output produced so far (that is, - total_out bytes) and returns Z_OK, Z_STREAM_END or an error code as described - below. At the end of the stream, inflate() checks that its computed Adler-32 - checksum is equal to that saved by the compressor and returns Z_STREAM_END - only if the checksum is correct. - - inflate() can decompress and check either zlib-wrapped or gzip-wrapped - deflate data. The header type is detected automatically, if requested when - initializing with inflateInit2(). Any information contained in the gzip - header is not retained unless inflateGetHeader() is used. When processing - gzip-wrapped deflate data, strm->adler32 is set to the CRC-32 of the output - produced so far. The CRC-32 is checked against the gzip trailer, as is the - uncompressed length, modulo 2^32. - - inflate() returns Z_OK if some progress has been made (more input processed - or more output produced), Z_STREAM_END if the end of the compressed data has - been reached and all uncompressed output has been produced, Z_NEED_DICT if a - preset dictionary is needed at this point, Z_DATA_ERROR if the input data was - corrupted (input stream not conforming to the zlib format or incorrect check - value, in which case strm->msg points to a string with a more specific - error), Z_STREAM_ERROR if the stream structure was inconsistent (for example - next_in or next_out was Z_NULL, or the state was inadvertently written over - by the application), Z_MEM_ERROR if there was not enough memory, Z_BUF_ERROR - if no progress was possible or if there was not enough room in the output - buffer when Z_FINISH is used. Note that Z_BUF_ERROR is not fatal, and - inflate() can be called again with more input and more output space to - continue decompressing. If Z_DATA_ERROR is returned, the application may - then call inflateSync() to look for a good compression block if a partial - recovery of the data is to be attempted. -*/ - - -ZEXTERN int ZEXPORT inflateEnd OF((z_streamp strm)); -/* - All dynamically allocated data structures for this stream are freed. - This function discards any unprocessed input and does not flush any pending - output. - - inflateEnd returns Z_OK if success, or Z_STREAM_ERROR if the stream state - was inconsistent. -*/ - - - /* Advanced functions */ - -/* - The following functions are needed only in some special applications. -*/ - -/* -ZEXTERN int ZEXPORT deflateInit2 OF((z_streamp strm, - int level, - int method, - int windowBits, - int memLevel, - int strategy)); - - This is another version of deflateInit with more compression options. The - fields next_in, zalloc, zfree and opaque must be initialized before by the - caller. - - The method parameter is the compression method. It must be Z_DEFLATED in - this version of the library. - - The windowBits parameter is the base two logarithm of the window size - (the size of the history buffer). It should be in the range 8..15 for this - version of the library. Larger values of this parameter result in better - compression at the expense of memory usage. The default value is 15 if - deflateInit is used instead. - - For the current implementation of deflate(), a windowBits value of 8 (a - window size of 256 bytes) is not supported. As a result, a request for 8 - will result in 9 (a 512-byte window). In that case, providing 8 to - inflateInit2() will result in an error when the zlib header with 9 is - checked against the initialization of inflate(). The remedy is to not use 8 - with deflateInit2() with this initialization, or at least in that case use 9 - with inflateInit2(). - - windowBits can also be -8..-15 for raw deflate. In this case, -windowBits - determines the window size. deflate() will then generate raw deflate data - with no zlib header or trailer, and will not compute a check value. - - windowBits can also be greater than 15 for optional gzip encoding. Add - 16 to windowBits to write a simple gzip header and trailer around the - compressed data instead of a zlib wrapper. The gzip header will have no - file name, no extra data, no comment, no modification time (set to zero), no - header crc, and the operating system will be set to the appropriate value, - if the operating system was determined at compile time. If a gzip stream is - being written, strm->adler is a CRC-32 instead of an Adler-32. - - For raw deflate or gzip encoding, a request for a 256-byte window is - rejected as invalid, since only the zlib header provides a means of - transmitting the window size to the decompressor. - - The memLevel parameter specifies how much memory should be allocated - for the internal compression state. memLevel=1 uses minimum memory but is - slow and reduces compression ratio; memLevel=9 uses maximum memory for - optimal speed. The default value is 8. See zconf.h for total memory usage - as a function of windowBits and memLevel. - - The strategy parameter is used to tune the compression algorithm. Use the - value Z_DEFAULT_STRATEGY for normal data, Z_FILTERED for data produced by a - filter (or predictor), Z_HUFFMAN_ONLY to force Huffman encoding only (no - string match), or Z_RLE to limit match distances to one (run-length - encoding). Filtered data consists mostly of small values with a somewhat - random distribution. In this case, the compression algorithm is tuned to - compress them better. The effect of Z_FILTERED is to force more Huffman - coding and less string matching; it is somewhat intermediate between - Z_DEFAULT_STRATEGY and Z_HUFFMAN_ONLY. Z_RLE is designed to be almost as - fast as Z_HUFFMAN_ONLY, but give better compression for PNG image data. The - strategy parameter only affects the compression ratio but not the - correctness of the compressed output even if it is not set appropriately. - Z_FIXED prevents the use of dynamic Huffman codes, allowing for a simpler - decoder for special applications. - - deflateInit2 returns Z_OK if success, Z_MEM_ERROR if there was not enough - memory, Z_STREAM_ERROR if any parameter is invalid (such as an invalid - method), or Z_VERSION_ERROR if the zlib library version (zlib_version) is - incompatible with the version assumed by the caller (ZLIB_VERSION). msg is - set to null if there is no error message. deflateInit2 does not perform any - compression: this will be done by deflate(). -*/ - -ZEXTERN int ZEXPORT deflateSetDictionary OF((z_streamp strm, - const Bytef *dictionary, - uInt dictLength)); -/* - Initializes the compression dictionary from the given byte sequence - without producing any compressed output. When using the zlib format, this - function must be called immediately after deflateInit, deflateInit2 or - deflateReset, and before any call of deflate. When doing raw deflate, this - function must be called either before any call of deflate, or immediately - after the completion of a deflate block, i.e. after all input has been - consumed and all output has been delivered when using any of the flush - options Z_BLOCK, Z_PARTIAL_FLUSH, Z_SYNC_FLUSH, or Z_FULL_FLUSH. The - compressor and decompressor must use exactly the same dictionary (see - inflateSetDictionary). - - The dictionary should consist of strings (byte sequences) that are likely - to be encountered later in the data to be compressed, with the most commonly - used strings preferably put towards the end of the dictionary. Using a - dictionary is most useful when the data to be compressed is short and can be - predicted with good accuracy; the data can then be compressed better than - with the default empty dictionary. - - Depending on the size of the compression data structures selected by - deflateInit or deflateInit2, a part of the dictionary may in effect be - discarded, for example if the dictionary is larger than the window size - provided in deflateInit or deflateInit2. Thus the strings most likely to be - useful should be put at the end of the dictionary, not at the front. In - addition, the current implementation of deflate will use at most the window - size minus 262 bytes of the provided dictionary. - - Upon return of this function, strm->adler is set to the Adler-32 value - of the dictionary; the decompressor may later use this value to determine - which dictionary has been used by the compressor. (The Adler-32 value - applies to the whole dictionary even if only a subset of the dictionary is - actually used by the compressor.) If a raw deflate was requested, then the - Adler-32 value is not computed and strm->adler is not set. - - deflateSetDictionary returns Z_OK if success, or Z_STREAM_ERROR if a - parameter is invalid (e.g. dictionary being Z_NULL) or the stream state is - inconsistent (for example if deflate has already been called for this stream - or if not at a block boundary for raw deflate). deflateSetDictionary does - not perform any compression: this will be done by deflate(). -*/ - -ZEXTERN int ZEXPORT deflateGetDictionary OF((z_streamp strm, - Bytef *dictionary, - uInt *dictLength)); -/* - Returns the sliding dictionary being maintained by deflate. dictLength is - set to the number of bytes in the dictionary, and that many bytes are copied - to dictionary. dictionary must have enough space, where 32768 bytes is - always enough. If deflateGetDictionary() is called with dictionary equal to - Z_NULL, then only the dictionary length is returned, and nothing is copied. - Similary, if dictLength is Z_NULL, then it is not set. - - deflateGetDictionary() may return a length less than the window size, even - when more than the window size in input has been provided. It may return up - to 258 bytes less in that case, due to how zlib's implementation of deflate - manages the sliding window and lookahead for matches, where matches can be - up to 258 bytes long. If the application needs the last window-size bytes of - input, then that would need to be saved by the application outside of zlib. - - deflateGetDictionary returns Z_OK on success, or Z_STREAM_ERROR if the - stream state is inconsistent. -*/ - -ZEXTERN int ZEXPORT deflateCopy OF((z_streamp dest, - z_streamp source)); -/* - Sets the destination stream as a complete copy of the source stream. - - This function can be useful when several compression strategies will be - tried, for example when there are several ways of pre-processing the input - data with a filter. The streams that will be discarded should then be freed - by calling deflateEnd. Note that deflateCopy duplicates the internal - compression state which can be quite large, so this strategy is slow and can - consume lots of memory. - - deflateCopy returns Z_OK if success, Z_MEM_ERROR if there was not - enough memory, Z_STREAM_ERROR if the source stream state was inconsistent - (such as zalloc being Z_NULL). msg is left unchanged in both source and - destination. -*/ - -ZEXTERN int ZEXPORT deflateReset OF((z_streamp strm)); -/* - This function is equivalent to deflateEnd followed by deflateInit, but - does not free and reallocate the internal compression state. The stream - will leave the compression level and any other attributes that may have been - set unchanged. - - deflateReset returns Z_OK if success, or Z_STREAM_ERROR if the source - stream state was inconsistent (such as zalloc or state being Z_NULL). -*/ - -ZEXTERN int ZEXPORT deflateParams OF((z_streamp strm, - int level, - int strategy)); -/* - Dynamically update the compression level and compression strategy. The - interpretation of level and strategy is as in deflateInit2(). This can be - used to switch between compression and straight copy of the input data, or - to switch to a different kind of input data requiring a different strategy. - If the compression approach (which is a function of the level) or the - strategy is changed, and if any input has been consumed in a previous - deflate() call, then the input available so far is compressed with the old - level and strategy using deflate(strm, Z_BLOCK). There are three approaches - for the compression levels 0, 1..3, and 4..9 respectively. The new level - and strategy will take effect at the next call of deflate(). - - If a deflate(strm, Z_BLOCK) is performed by deflateParams(), and it does - not have enough output space to complete, then the parameter change will not - take effect. In this case, deflateParams() can be called again with the - same parameters and more output space to try again. - - In order to assure a change in the parameters on the first try, the - deflate stream should be flushed using deflate() with Z_BLOCK or other flush - request until strm.avail_out is not zero, before calling deflateParams(). - Then no more input data should be provided before the deflateParams() call. - If this is done, the old level and strategy will be applied to the data - compressed before deflateParams(), and the new level and strategy will be - applied to the the data compressed after deflateParams(). - - deflateParams returns Z_OK on success, Z_STREAM_ERROR if the source stream - state was inconsistent or if a parameter was invalid, or Z_BUF_ERROR if - there was not enough output space to complete the compression of the - available input data before a change in the strategy or approach. Note that - in the case of a Z_BUF_ERROR, the parameters are not changed. A return - value of Z_BUF_ERROR is not fatal, in which case deflateParams() can be - retried with more output space. -*/ - -ZEXTERN int ZEXPORT deflateTune OF((z_streamp strm, - int good_length, - int max_lazy, - int nice_length, - int max_chain)); -/* - Fine tune deflate's internal compression parameters. This should only be - used by someone who understands the algorithm used by zlib's deflate for - searching for the best matching string, and even then only by the most - fanatic optimizer trying to squeeze out the last compressed bit for their - specific input data. Read the deflate.c source code for the meaning of the - max_lazy, good_length, nice_length, and max_chain parameters. - - deflateTune() can be called after deflateInit() or deflateInit2(), and - returns Z_OK on success, or Z_STREAM_ERROR for an invalid deflate stream. - */ - -ZEXTERN uLong ZEXPORT deflateBound OF((z_streamp strm, - uLong sourceLen)); -/* - deflateBound() returns an upper bound on the compressed size after - deflation of sourceLen bytes. It must be called after deflateInit() or - deflateInit2(), and after deflateSetHeader(), if used. This would be used - to allocate an output buffer for deflation in a single pass, and so would be - called before deflate(). If that first deflate() call is provided the - sourceLen input bytes, an output buffer allocated to the size returned by - deflateBound(), and the flush value Z_FINISH, then deflate() is guaranteed - to return Z_STREAM_END. Note that it is possible for the compressed size to - be larger than the value returned by deflateBound() if flush options other - than Z_FINISH or Z_NO_FLUSH are used. -*/ - -ZEXTERN int ZEXPORT deflatePending OF((z_streamp strm, - unsigned *pending, - int *bits)); -/* - deflatePending() returns the number of bytes and bits of output that have - been generated, but not yet provided in the available output. The bytes not - provided would be due to the available output space having being consumed. - The number of bits of output not provided are between 0 and 7, where they - await more bits to join them in order to fill out a full byte. If pending - or bits are Z_NULL, then those values are not set. - - deflatePending returns Z_OK if success, or Z_STREAM_ERROR if the source - stream state was inconsistent. - */ - -ZEXTERN int ZEXPORT deflatePrime OF((z_streamp strm, - int bits, - int value)); -/* - deflatePrime() inserts bits in the deflate output stream. The intent - is that this function is used to start off the deflate output with the bits - leftover from a previous deflate stream when appending to it. As such, this - function can only be used for raw deflate, and must be used before the first - deflate() call after a deflateInit2() or deflateReset(). bits must be less - than or equal to 16, and that many of the least significant bits of value - will be inserted in the output. - - deflatePrime returns Z_OK if success, Z_BUF_ERROR if there was not enough - room in the internal buffer to insert the bits, or Z_STREAM_ERROR if the - source stream state was inconsistent. -*/ - -ZEXTERN int ZEXPORT deflateSetHeader OF((z_streamp strm, - gz_headerp head)); -/* - deflateSetHeader() provides gzip header information for when a gzip - stream is requested by deflateInit2(). deflateSetHeader() may be called - after deflateInit2() or deflateReset() and before the first call of - deflate(). The text, time, os, extra field, name, and comment information - in the provided gz_header structure are written to the gzip header (xflag is - ignored -- the extra flags are set according to the compression level). The - caller must assure that, if not Z_NULL, name and comment are terminated with - a zero byte, and that if extra is not Z_NULL, that extra_len bytes are - available there. If hcrc is true, a gzip header crc is included. Note that - the current versions of the command-line version of gzip (up through version - 1.3.x) do not support header crc's, and will report that it is a "multi-part - gzip file" and give up. - - If deflateSetHeader is not used, the default gzip header has text false, - the time set to zero, and os set to 255, with no extra, name, or comment - fields. The gzip header is returned to the default state by deflateReset(). - - deflateSetHeader returns Z_OK if success, or Z_STREAM_ERROR if the source - stream state was inconsistent. -*/ - -/* -ZEXTERN int ZEXPORT inflateInit2 OF((z_streamp strm, - int windowBits)); - - This is another version of inflateInit with an extra parameter. The - fields next_in, avail_in, zalloc, zfree and opaque must be initialized - before by the caller. - - The windowBits parameter is the base two logarithm of the maximum window - size (the size of the history buffer). It should be in the range 8..15 for - this version of the library. The default value is 15 if inflateInit is used - instead. windowBits must be greater than or equal to the windowBits value - provided to deflateInit2() while compressing, or it must be equal to 15 if - deflateInit2() was not used. If a compressed stream with a larger window - size is given as input, inflate() will return with the error code - Z_DATA_ERROR instead of trying to allocate a larger window. - - windowBits can also be zero to request that inflate use the window size in - the zlib header of the compressed stream. - - windowBits can also be -8..-15 for raw inflate. In this case, -windowBits - determines the window size. inflate() will then process raw deflate data, - not looking for a zlib or gzip header, not generating a check value, and not - looking for any check values for comparison at the end of the stream. This - is for use with other formats that use the deflate compressed data format - such as zip. Those formats provide their own check values. If a custom - format is developed using the raw deflate format for compressed data, it is - recommended that a check value such as an Adler-32 or a CRC-32 be applied to - the uncompressed data as is done in the zlib, gzip, and zip formats. For - most applications, the zlib format should be used as is. Note that comments - above on the use in deflateInit2() applies to the magnitude of windowBits. - - windowBits can also be greater than 15 for optional gzip decoding. Add - 32 to windowBits to enable zlib and gzip decoding with automatic header - detection, or add 16 to decode only the gzip format (the zlib format will - return a Z_DATA_ERROR). If a gzip stream is being decoded, strm->adler is a - CRC-32 instead of an Adler-32. Unlike the gunzip utility and gzread() (see - below), inflate() will not automatically decode concatenated gzip streams. - inflate() will return Z_STREAM_END at the end of the gzip stream. The state - would need to be reset to continue decoding a subsequent gzip stream. - - inflateInit2 returns Z_OK if success, Z_MEM_ERROR if there was not enough - memory, Z_VERSION_ERROR if the zlib library version is incompatible with the - version assumed by the caller, or Z_STREAM_ERROR if the parameters are - invalid, such as a null pointer to the structure. msg is set to null if - there is no error message. inflateInit2 does not perform any decompression - apart from possibly reading the zlib header if present: actual decompression - will be done by inflate(). (So next_in and avail_in may be modified, but - next_out and avail_out are unused and unchanged.) The current implementation - of inflateInit2() does not process any header information -- that is - deferred until inflate() is called. -*/ - -ZEXTERN int ZEXPORT inflateSetDictionary OF((z_streamp strm, - const Bytef *dictionary, - uInt dictLength)); -/* - Initializes the decompression dictionary from the given uncompressed byte - sequence. This function must be called immediately after a call of inflate, - if that call returned Z_NEED_DICT. The dictionary chosen by the compressor - can be determined from the Adler-32 value returned by that call of inflate. - The compressor and decompressor must use exactly the same dictionary (see - deflateSetDictionary). For raw inflate, this function can be called at any - time to set the dictionary. If the provided dictionary is smaller than the - window and there is already data in the window, then the provided dictionary - will amend what's there. The application must insure that the dictionary - that was used for compression is provided. - - inflateSetDictionary returns Z_OK if success, Z_STREAM_ERROR if a - parameter is invalid (e.g. dictionary being Z_NULL) or the stream state is - inconsistent, Z_DATA_ERROR if the given dictionary doesn't match the - expected one (incorrect Adler-32 value). inflateSetDictionary does not - perform any decompression: this will be done by subsequent calls of - inflate(). -*/ - -ZEXTERN int ZEXPORT inflateGetDictionary OF((z_streamp strm, - Bytef *dictionary, - uInt *dictLength)); -/* - Returns the sliding dictionary being maintained by inflate. dictLength is - set to the number of bytes in the dictionary, and that many bytes are copied - to dictionary. dictionary must have enough space, where 32768 bytes is - always enough. If inflateGetDictionary() is called with dictionary equal to - Z_NULL, then only the dictionary length is returned, and nothing is copied. - Similary, if dictLength is Z_NULL, then it is not set. - - inflateGetDictionary returns Z_OK on success, or Z_STREAM_ERROR if the - stream state is inconsistent. -*/ - -ZEXTERN int ZEXPORT inflateSync OF((z_streamp strm)); -/* - Skips invalid compressed data until a possible full flush point (see above - for the description of deflate with Z_FULL_FLUSH) can be found, or until all - available input is skipped. No output is provided. - - inflateSync searches for a 00 00 FF FF pattern in the compressed data. - All full flush points have this pattern, but not all occurrences of this - pattern are full flush points. - - inflateSync returns Z_OK if a possible full flush point has been found, - Z_BUF_ERROR if no more input was provided, Z_DATA_ERROR if no flush point - has been found, or Z_STREAM_ERROR if the stream structure was inconsistent. - In the success case, the application may save the current current value of - total_in which indicates where valid compressed data was found. In the - error case, the application may repeatedly call inflateSync, providing more - input each time, until success or end of the input data. -*/ - -ZEXTERN int ZEXPORT inflateCopy OF((z_streamp dest, - z_streamp source)); -/* - Sets the destination stream as a complete copy of the source stream. - - This function can be useful when randomly accessing a large stream. The - first pass through the stream can periodically record the inflate state, - allowing restarting inflate at those points when randomly accessing the - stream. - - inflateCopy returns Z_OK if success, Z_MEM_ERROR if there was not - enough memory, Z_STREAM_ERROR if the source stream state was inconsistent - (such as zalloc being Z_NULL). msg is left unchanged in both source and - destination. -*/ - -ZEXTERN int ZEXPORT inflateReset OF((z_streamp strm)); -/* - This function is equivalent to inflateEnd followed by inflateInit, - but does not free and reallocate the internal decompression state. The - stream will keep attributes that may have been set by inflateInit2. - - inflateReset returns Z_OK if success, or Z_STREAM_ERROR if the source - stream state was inconsistent (such as zalloc or state being Z_NULL). -*/ - -ZEXTERN int ZEXPORT inflateReset2 OF((z_streamp strm, - int windowBits)); -/* - This function is the same as inflateReset, but it also permits changing - the wrap and window size requests. The windowBits parameter is interpreted - the same as it is for inflateInit2. If the window size is changed, then the - memory allocated for the window is freed, and the window will be reallocated - by inflate() if needed. - - inflateReset2 returns Z_OK if success, or Z_STREAM_ERROR if the source - stream state was inconsistent (such as zalloc or state being Z_NULL), or if - the windowBits parameter is invalid. -*/ - -ZEXTERN int ZEXPORT inflatePrime OF((z_streamp strm, - int bits, - int value)); -/* - This function inserts bits in the inflate input stream. The intent is - that this function is used to start inflating at a bit position in the - middle of a byte. The provided bits will be used before any bytes are used - from next_in. This function should only be used with raw inflate, and - should be used before the first inflate() call after inflateInit2() or - inflateReset(). bits must be less than or equal to 16, and that many of the - least significant bits of value will be inserted in the input. - - If bits is negative, then the input stream bit buffer is emptied. Then - inflatePrime() can be called again to put bits in the buffer. This is used - to clear out bits leftover after feeding inflate a block description prior - to feeding inflate codes. - - inflatePrime returns Z_OK if success, or Z_STREAM_ERROR if the source - stream state was inconsistent. -*/ - -ZEXTERN long ZEXPORT inflateMark OF((z_streamp strm)); -/* - This function returns two values, one in the lower 16 bits of the return - value, and the other in the remaining upper bits, obtained by shifting the - return value down 16 bits. If the upper value is -1 and the lower value is - zero, then inflate() is currently decoding information outside of a block. - If the upper value is -1 and the lower value is non-zero, then inflate is in - the middle of a stored block, with the lower value equaling the number of - bytes from the input remaining to copy. If the upper value is not -1, then - it is the number of bits back from the current bit position in the input of - the code (literal or length/distance pair) currently being processed. In - that case the lower value is the number of bytes already emitted for that - code. - - A code is being processed if inflate is waiting for more input to complete - decoding of the code, or if it has completed decoding but is waiting for - more output space to write the literal or match data. - - inflateMark() is used to mark locations in the input data for random - access, which may be at bit positions, and to note those cases where the - output of a code may span boundaries of random access blocks. The current - location in the input stream can be determined from avail_in and data_type - as noted in the description for the Z_BLOCK flush parameter for inflate. - - inflateMark returns the value noted above, or -65536 if the provided - source stream state was inconsistent. -*/ - -ZEXTERN int ZEXPORT inflateGetHeader OF((z_streamp strm, - gz_headerp head)); -/* - inflateGetHeader() requests that gzip header information be stored in the - provided gz_header structure. inflateGetHeader() may be called after - inflateInit2() or inflateReset(), and before the first call of inflate(). - As inflate() processes the gzip stream, head->done is zero until the header - is completed, at which time head->done is set to one. If a zlib stream is - being decoded, then head->done is set to -1 to indicate that there will be - no gzip header information forthcoming. Note that Z_BLOCK or Z_TREES can be - used to force inflate() to return immediately after header processing is - complete and before any actual data is decompressed. - - The text, time, xflags, and os fields are filled in with the gzip header - contents. hcrc is set to true if there is a header CRC. (The header CRC - was valid if done is set to one.) If extra is not Z_NULL, then extra_max - contains the maximum number of bytes to write to extra. Once done is true, - extra_len contains the actual extra field length, and extra contains the - extra field, or that field truncated if extra_max is less than extra_len. - If name is not Z_NULL, then up to name_max characters are written there, - terminated with a zero unless the length is greater than name_max. If - comment is not Z_NULL, then up to comm_max characters are written there, - terminated with a zero unless the length is greater than comm_max. When any - of extra, name, or comment are not Z_NULL and the respective field is not - present in the header, then that field is set to Z_NULL to signal its - absence. This allows the use of deflateSetHeader() with the returned - structure to duplicate the header. However if those fields are set to - allocated memory, then the application will need to save those pointers - elsewhere so that they can be eventually freed. - - If inflateGetHeader is not used, then the header information is simply - discarded. The header is always checked for validity, including the header - CRC if present. inflateReset() will reset the process to discard the header - information. The application would need to call inflateGetHeader() again to - retrieve the header from the next gzip stream. - - inflateGetHeader returns Z_OK if success, or Z_STREAM_ERROR if the source - stream state was inconsistent. -*/ - -/* -ZEXTERN int ZEXPORT inflateBackInit OF((z_streamp strm, int windowBits, - unsigned char FAR *window)); - - Initialize the internal stream state for decompression using inflateBack() - calls. The fields zalloc, zfree and opaque in strm must be initialized - before the call. If zalloc and zfree are Z_NULL, then the default library- - derived memory allocation routines are used. windowBits is the base two - logarithm of the window size, in the range 8..15. window is a caller - supplied buffer of that size. Except for special applications where it is - assured that deflate was used with small window sizes, windowBits must be 15 - and a 32K byte window must be supplied to be able to decompress general - deflate streams. - - See inflateBack() for the usage of these routines. - - inflateBackInit will return Z_OK on success, Z_STREAM_ERROR if any of - the parameters are invalid, Z_MEM_ERROR if the internal state could not be - allocated, or Z_VERSION_ERROR if the version of the library does not match - the version of the header file. -*/ - -typedef unsigned (*in_func) OF((void FAR *, - z_const unsigned char FAR * FAR *)); -typedef int (*out_func) OF((void FAR *, unsigned char FAR *, unsigned)); - -ZEXTERN int ZEXPORT inflateBack OF((z_streamp strm, - in_func in, void FAR *in_desc, - out_func out, void FAR *out_desc)); -/* - inflateBack() does a raw inflate with a single call using a call-back - interface for input and output. This is potentially more efficient than - inflate() for file i/o applications, in that it avoids copying between the - output and the sliding window by simply making the window itself the output - buffer. inflate() can be faster on modern CPUs when used with large - buffers. inflateBack() trusts the application to not change the output - buffer passed by the output function, at least until inflateBack() returns. - - inflateBackInit() must be called first to allocate the internal state - and to initialize the state with the user-provided window buffer. - inflateBack() may then be used multiple times to inflate a complete, raw - deflate stream with each call. inflateBackEnd() is then called to free the - allocated state. - - A raw deflate stream is one with no zlib or gzip header or trailer. - This routine would normally be used in a utility that reads zip or gzip - files and writes out uncompressed files. The utility would decode the - header and process the trailer on its own, hence this routine expects only - the raw deflate stream to decompress. This is different from the default - behavior of inflate(), which expects a zlib header and trailer around the - deflate stream. - - inflateBack() uses two subroutines supplied by the caller that are then - called by inflateBack() for input and output. inflateBack() calls those - routines until it reads a complete deflate stream and writes out all of the - uncompressed data, or until it encounters an error. The function's - parameters and return types are defined above in the in_func and out_func - typedefs. inflateBack() will call in(in_desc, &buf) which should return the - number of bytes of provided input, and a pointer to that input in buf. If - there is no input available, in() must return zero -- buf is ignored in that - case -- and inflateBack() will return a buffer error. inflateBack() will - call out(out_desc, buf, len) to write the uncompressed data buf[0..len-1]. - out() should return zero on success, or non-zero on failure. If out() - returns non-zero, inflateBack() will return with an error. Neither in() nor - out() are permitted to change the contents of the window provided to - inflateBackInit(), which is also the buffer that out() uses to write from. - The length written by out() will be at most the window size. Any non-zero - amount of input may be provided by in(). - - For convenience, inflateBack() can be provided input on the first call by - setting strm->next_in and strm->avail_in. If that input is exhausted, then - in() will be called. Therefore strm->next_in must be initialized before - calling inflateBack(). If strm->next_in is Z_NULL, then in() will be called - immediately for input. If strm->next_in is not Z_NULL, then strm->avail_in - must also be initialized, and then if strm->avail_in is not zero, input will - initially be taken from strm->next_in[0 .. strm->avail_in - 1]. - - The in_desc and out_desc parameters of inflateBack() is passed as the - first parameter of in() and out() respectively when they are called. These - descriptors can be optionally used to pass any information that the caller- - supplied in() and out() functions need to do their job. - - On return, inflateBack() will set strm->next_in and strm->avail_in to - pass back any unused input that was provided by the last in() call. The - return values of inflateBack() can be Z_STREAM_END on success, Z_BUF_ERROR - if in() or out() returned an error, Z_DATA_ERROR if there was a format error - in the deflate stream (in which case strm->msg is set to indicate the nature - of the error), or Z_STREAM_ERROR if the stream was not properly initialized. - In the case of Z_BUF_ERROR, an input or output error can be distinguished - using strm->next_in which will be Z_NULL only if in() returned an error. If - strm->next_in is not Z_NULL, then the Z_BUF_ERROR was due to out() returning - non-zero. (in() will always be called before out(), so strm->next_in is - assured to be defined if out() returns non-zero.) Note that inflateBack() - cannot return Z_OK. -*/ - -ZEXTERN int ZEXPORT inflateBackEnd OF((z_streamp strm)); -/* - All memory allocated by inflateBackInit() is freed. - - inflateBackEnd() returns Z_OK on success, or Z_STREAM_ERROR if the stream - state was inconsistent. -*/ - -ZEXTERN uLong ZEXPORT zlibCompileFlags OF((void)); -/* Return flags indicating compile-time options. - - Type sizes, two bits each, 00 = 16 bits, 01 = 32, 10 = 64, 11 = other: - 1.0: size of uInt - 3.2: size of uLong - 5.4: size of voidpf (pointer) - 7.6: size of z_off_t - - Compiler, assembler, and debug options: - 8: ZLIB_DEBUG - 9: ASMV or ASMINF -- use ASM code - 10: ZLIB_WINAPI -- exported functions use the WINAPI calling convention - 11: 0 (reserved) - - One-time table building (smaller code, but not thread-safe if true): - 12: BUILDFIXED -- build static block decoding tables when needed - 13: DYNAMIC_CRC_TABLE -- build CRC calculation tables when needed - 14,15: 0 (reserved) - - Library content (indicates missing functionality): - 16: NO_GZCOMPRESS -- gz* functions cannot compress (to avoid linking - deflate code when not needed) - 17: NO_GZIP -- deflate can't write gzip streams, and inflate can't detect - and decode gzip streams (to avoid linking crc code) - 18-19: 0 (reserved) - - Operation variations (changes in library functionality): - 20: PKZIP_BUG_WORKAROUND -- slightly more permissive inflate - 21: FASTEST -- deflate algorithm with only one, lowest compression level - 22,23: 0 (reserved) - - The sprintf variant used by gzprintf (zero is best): - 24: 0 = vs*, 1 = s* -- 1 means limited to 20 arguments after the format - 25: 0 = *nprintf, 1 = *printf -- 1 means gzprintf() not secure! - 26: 0 = returns value, 1 = void -- 1 means inferred string length returned - - Remainder: - 27-31: 0 (reserved) - */ - -#ifndef Z_SOLO - - /* utility functions */ - -/* - The following utility functions are implemented on top of the basic - stream-oriented functions. To simplify the interface, some default options - are assumed (compression level and memory usage, standard memory allocation - functions). The source code of these utility functions can be modified if - you need special options. -*/ - -ZEXTERN int ZEXPORT compress OF((Bytef *dest, uLongf *destLen, - const Bytef *source, uLong sourceLen)); -/* - Compresses the source buffer into the destination buffer. sourceLen is - the byte length of the source buffer. Upon entry, destLen is the total size - of the destination buffer, which must be at least the value returned by - compressBound(sourceLen). Upon exit, destLen is the actual size of the - compressed data. compress() is equivalent to compress2() with a level - parameter of Z_DEFAULT_COMPRESSION. - - compress returns Z_OK if success, Z_MEM_ERROR if there was not - enough memory, Z_BUF_ERROR if there was not enough room in the output - buffer. -*/ - -ZEXTERN int ZEXPORT compress2 OF((Bytef *dest, uLongf *destLen, - const Bytef *source, uLong sourceLen, - int level)); -/* - Compresses the source buffer into the destination buffer. The level - parameter has the same meaning as in deflateInit. sourceLen is the byte - length of the source buffer. Upon entry, destLen is the total size of the - destination buffer, which must be at least the value returned by - compressBound(sourceLen). Upon exit, destLen is the actual size of the - compressed data. - - compress2 returns Z_OK if success, Z_MEM_ERROR if there was not enough - memory, Z_BUF_ERROR if there was not enough room in the output buffer, - Z_STREAM_ERROR if the level parameter is invalid. -*/ - -ZEXTERN uLong ZEXPORT compressBound OF((uLong sourceLen)); -/* - compressBound() returns an upper bound on the compressed size after - compress() or compress2() on sourceLen bytes. It would be used before a - compress() or compress2() call to allocate the destination buffer. -*/ - -ZEXTERN int ZEXPORT uncompress OF((Bytef *dest, uLongf *destLen, - const Bytef *source, uLong sourceLen)); -/* - Decompresses the source buffer into the destination buffer. sourceLen is - the byte length of the source buffer. Upon entry, destLen is the total size - of the destination buffer, which must be large enough to hold the entire - uncompressed data. (The size of the uncompressed data must have been saved - previously by the compressor and transmitted to the decompressor by some - mechanism outside the scope of this compression library.) Upon exit, destLen - is the actual size of the uncompressed data. - - uncompress returns Z_OK if success, Z_MEM_ERROR if there was not - enough memory, Z_BUF_ERROR if there was not enough room in the output - buffer, or Z_DATA_ERROR if the input data was corrupted or incomplete. In - the case where there is not enough room, uncompress() will fill the output - buffer with the uncompressed data up to that point. -*/ - -ZEXTERN int ZEXPORT uncompress2 OF((Bytef *dest, uLongf *destLen, - const Bytef *source, uLong *sourceLen)); -/* - Same as uncompress, except that sourceLen is a pointer, where the - length of the source is *sourceLen. On return, *sourceLen is the number of - source bytes consumed. -*/ - - /* gzip file access functions */ - -/* - This library supports reading and writing files in gzip (.gz) format with - an interface similar to that of stdio, using the functions that start with - "gz". The gzip format is different from the zlib format. gzip is a gzip - wrapper, documented in RFC 1952, wrapped around a deflate stream. -*/ - -typedef struct gzFile_s *gzFile; /* semi-opaque gzip file descriptor */ - -/* -ZEXTERN gzFile ZEXPORT gzopen OF((const char *path, const char *mode)); - - Opens a gzip (.gz) file for reading or writing. The mode parameter is as - in fopen ("rb" or "wb") but can also include a compression level ("wb9") or - a strategy: 'f' for filtered data as in "wb6f", 'h' for Huffman-only - compression as in "wb1h", 'R' for run-length encoding as in "wb1R", or 'F' - for fixed code compression as in "wb9F". (See the description of - deflateInit2 for more information about the strategy parameter.) 'T' will - request transparent writing or appending with no compression and not using - the gzip format. - - "a" can be used instead of "w" to request that the gzip stream that will - be written be appended to the file. "+" will result in an error, since - reading and writing to the same gzip file is not supported. The addition of - "x" when writing will create the file exclusively, which fails if the file - already exists. On systems that support it, the addition of "e" when - reading or writing will set the flag to close the file on an execve() call. - - These functions, as well as gzip, will read and decode a sequence of gzip - streams in a file. The append function of gzopen() can be used to create - such a file. (Also see gzflush() for another way to do this.) When - appending, gzopen does not test whether the file begins with a gzip stream, - nor does it look for the end of the gzip streams to begin appending. gzopen - will simply append a gzip stream to the existing file. - - gzopen can be used to read a file which is not in gzip format; in this - case gzread will directly read from the file without decompression. When - reading, this will be detected automatically by looking for the magic two- - byte gzip header. - - gzopen returns NULL if the file could not be opened, if there was - insufficient memory to allocate the gzFile state, or if an invalid mode was - specified (an 'r', 'w', or 'a' was not provided, or '+' was provided). - errno can be checked to determine if the reason gzopen failed was that the - file could not be opened. -*/ - -ZEXTERN gzFile ZEXPORT gzdopen OF((int fd, const char *mode)); -/* - gzdopen associates a gzFile with the file descriptor fd. File descriptors - are obtained from calls like open, dup, creat, pipe or fileno (if the file - has been previously opened with fopen). The mode parameter is as in gzopen. - - The next call of gzclose on the returned gzFile will also close the file - descriptor fd, just like fclose(fdopen(fd, mode)) closes the file descriptor - fd. If you want to keep fd open, use fd = dup(fd_keep); gz = gzdopen(fd, - mode);. The duplicated descriptor should be saved to avoid a leak, since - gzdopen does not close fd if it fails. If you are using fileno() to get the - file descriptor from a FILE *, then you will have to use dup() to avoid - double-close()ing the file descriptor. Both gzclose() and fclose() will - close the associated file descriptor, so they need to have different file - descriptors. - - gzdopen returns NULL if there was insufficient memory to allocate the - gzFile state, if an invalid mode was specified (an 'r', 'w', or 'a' was not - provided, or '+' was provided), or if fd is -1. The file descriptor is not - used until the next gz* read, write, seek, or close operation, so gzdopen - will not detect if fd is invalid (unless fd is -1). -*/ - -ZEXTERN int ZEXPORT gzbuffer OF((gzFile file, unsigned size)); -/* - Set the internal buffer size used by this library's functions. The - default buffer size is 8192 bytes. This function must be called after - gzopen() or gzdopen(), and before any other calls that read or write the - file. The buffer memory allocation is always deferred to the first read or - write. Three times that size in buffer space is allocated. A larger buffer - size of, for example, 64K or 128K bytes will noticeably increase the speed - of decompression (reading). - - The new buffer size also affects the maximum length for gzprintf(). - - gzbuffer() returns 0 on success, or -1 on failure, such as being called - too late. -*/ - -ZEXTERN int ZEXPORT gzsetparams OF((gzFile file, int level, int strategy)); -/* - Dynamically update the compression level or strategy. See the description - of deflateInit2 for the meaning of these parameters. Previously provided - data is flushed before the parameter change. - - gzsetparams returns Z_OK if success, Z_STREAM_ERROR if the file was not - opened for writing, Z_ERRNO if there is an error writing the flushed data, - or Z_MEM_ERROR if there is a memory allocation error. -*/ - -ZEXTERN int ZEXPORT gzread OF((gzFile file, voidp buf, unsigned len)); -/* - Reads the given number of uncompressed bytes from the compressed file. If - the input file is not in gzip format, gzread copies the given number of - bytes into the buffer directly from the file. - - After reaching the end of a gzip stream in the input, gzread will continue - to read, looking for another gzip stream. Any number of gzip streams may be - concatenated in the input file, and will all be decompressed by gzread(). - If something other than a gzip stream is encountered after a gzip stream, - that remaining trailing garbage is ignored (and no error is returned). - - gzread can be used to read a gzip file that is being concurrently written. - Upon reaching the end of the input, gzread will return with the available - data. If the error code returned by gzerror is Z_OK or Z_BUF_ERROR, then - gzclearerr can be used to clear the end of file indicator in order to permit - gzread to be tried again. Z_OK indicates that a gzip stream was completed - on the last gzread. Z_BUF_ERROR indicates that the input file ended in the - middle of a gzip stream. Note that gzread does not return -1 in the event - of an incomplete gzip stream. This error is deferred until gzclose(), which - will return Z_BUF_ERROR if the last gzread ended in the middle of a gzip - stream. Alternatively, gzerror can be used before gzclose to detect this - case. - - gzread returns the number of uncompressed bytes actually read, less than - len for end of file, or -1 for error. If len is too large to fit in an int, - then nothing is read, -1 is returned, and the error state is set to - Z_STREAM_ERROR. -*/ - -ZEXTERN z_size_t ZEXPORT gzfread OF((voidp buf, z_size_t size, z_size_t nitems, - gzFile file)); -/* - Read up to nitems items of size size from file to buf, otherwise operating - as gzread() does. This duplicates the interface of stdio's fread(), with - size_t request and return types. If the library defines size_t, then - z_size_t is identical to size_t. If not, then z_size_t is an unsigned - integer type that can contain a pointer. - - gzfread() returns the number of full items read of size size, or zero if - the end of the file was reached and a full item could not be read, or if - there was an error. gzerror() must be consulted if zero is returned in - order to determine if there was an error. If the multiplication of size and - nitems overflows, i.e. the product does not fit in a z_size_t, then nothing - is read, zero is returned, and the error state is set to Z_STREAM_ERROR. - - In the event that the end of file is reached and only a partial item is - available at the end, i.e. the remaining uncompressed data length is not a - multiple of size, then the final partial item is nevetheless read into buf - and the end-of-file flag is set. The length of the partial item read is not - provided, but could be inferred from the result of gztell(). This behavior - is the same as the behavior of fread() implementations in common libraries, - but it prevents the direct use of gzfread() to read a concurrently written - file, reseting and retrying on end-of-file, when size is not 1. -*/ - -ZEXTERN int ZEXPORT gzwrite OF((gzFile file, - voidpc buf, unsigned len)); -/* - Writes the given number of uncompressed bytes into the compressed file. - gzwrite returns the number of uncompressed bytes written or 0 in case of - error. -*/ - -ZEXTERN z_size_t ZEXPORT gzfwrite OF((voidpc buf, z_size_t size, - z_size_t nitems, gzFile file)); -/* - gzfwrite() writes nitems items of size size from buf to file, duplicating - the interface of stdio's fwrite(), with size_t request and return types. If - the library defines size_t, then z_size_t is identical to size_t. If not, - then z_size_t is an unsigned integer type that can contain a pointer. - - gzfwrite() returns the number of full items written of size size, or zero - if there was an error. If the multiplication of size and nitems overflows, - i.e. the product does not fit in a z_size_t, then nothing is written, zero - is returned, and the error state is set to Z_STREAM_ERROR. -*/ - -ZEXTERN int ZEXPORTVA gzprintf Z_ARG((gzFile file, const char *format, ...)); -/* - Converts, formats, and writes the arguments to the compressed file under - control of the format string, as in fprintf. gzprintf returns the number of - uncompressed bytes actually written, or a negative zlib error code in case - of error. The number of uncompressed bytes written is limited to 8191, or - one less than the buffer size given to gzbuffer(). The caller should assure - that this limit is not exceeded. If it is exceeded, then gzprintf() will - return an error (0) with nothing written. In this case, there may also be a - buffer overflow with unpredictable consequences, which is possible only if - zlib was compiled with the insecure functions sprintf() or vsprintf() - because the secure snprintf() or vsnprintf() functions were not available. - This can be determined using zlibCompileFlags(). -*/ - -ZEXTERN int ZEXPORT gzputs OF((gzFile file, const char *s)); -/* - Writes the given null-terminated string to the compressed file, excluding - the terminating null character. - - gzputs returns the number of characters written, or -1 in case of error. -*/ - -ZEXTERN char * ZEXPORT gzgets OF((gzFile file, char *buf, int len)); -/* - Reads bytes from the compressed file until len-1 characters are read, or a - newline character is read and transferred to buf, or an end-of-file - condition is encountered. If any characters are read or if len == 1, the - string is terminated with a null character. If no characters are read due - to an end-of-file or len < 1, then the buffer is left untouched. - - gzgets returns buf which is a null-terminated string, or it returns NULL - for end-of-file or in case of error. If there was an error, the contents at - buf are indeterminate. -*/ - -ZEXTERN int ZEXPORT gzputc OF((gzFile file, int c)); -/* - Writes c, converted to an unsigned char, into the compressed file. gzputc - returns the value that was written, or -1 in case of error. -*/ - -ZEXTERN int ZEXPORT gzgetc OF((gzFile file)); -/* - Reads one byte from the compressed file. gzgetc returns this byte or -1 - in case of end of file or error. This is implemented as a macro for speed. - As such, it does not do all of the checking the other functions do. I.e. - it does not check to see if file is NULL, nor whether the structure file - points to has been clobbered or not. -*/ - -ZEXTERN int ZEXPORT gzungetc OF((int c, gzFile file)); -/* - Push one character back onto the stream to be read as the first character - on the next read. At least one character of push-back is allowed. - gzungetc() returns the character pushed, or -1 on failure. gzungetc() will - fail if c is -1, and may fail if a character has been pushed but not read - yet. If gzungetc is used immediately after gzopen or gzdopen, at least the - output buffer size of pushed characters is allowed. (See gzbuffer above.) - The pushed character will be discarded if the stream is repositioned with - gzseek() or gzrewind(). -*/ - -ZEXTERN int ZEXPORT gzflush OF((gzFile file, int flush)); -/* - Flushes all pending output into the compressed file. The parameter flush - is as in the deflate() function. The return value is the zlib error number - (see function gzerror below). gzflush is only permitted when writing. - - If the flush parameter is Z_FINISH, the remaining data is written and the - gzip stream is completed in the output. If gzwrite() is called again, a new - gzip stream will be started in the output. gzread() is able to read such - concatenated gzip streams. - - gzflush should be called only when strictly necessary because it will - degrade compression if called too often. -*/ - -/* -ZEXTERN z_off_t ZEXPORT gzseek OF((gzFile file, - z_off_t offset, int whence)); - - Sets the starting position for the next gzread or gzwrite on the given - compressed file. The offset represents a number of bytes in the - uncompressed data stream. The whence parameter is defined as in lseek(2); - the value SEEK_END is not supported. - - If the file is opened for reading, this function is emulated but can be - extremely slow. If the file is opened for writing, only forward seeks are - supported; gzseek then compresses a sequence of zeroes up to the new - starting position. - - gzseek returns the resulting offset location as measured in bytes from - the beginning of the uncompressed stream, or -1 in case of error, in - particular if the file is opened for writing and the new starting position - would be before the current position. -*/ - -ZEXTERN int ZEXPORT gzrewind OF((gzFile file)); -/* - Rewinds the given file. This function is supported only for reading. - - gzrewind(file) is equivalent to (int)gzseek(file, 0L, SEEK_SET) -*/ - -/* -ZEXTERN z_off_t ZEXPORT gztell OF((gzFile file)); - - Returns the starting position for the next gzread or gzwrite on the given - compressed file. This position represents a number of bytes in the - uncompressed data stream, and is zero when starting, even if appending or - reading a gzip stream from the middle of a file using gzdopen(). - - gztell(file) is equivalent to gzseek(file, 0L, SEEK_CUR) -*/ - -/* -ZEXTERN z_off_t ZEXPORT gzoffset OF((gzFile file)); - - Returns the current offset in the file being read or written. This offset - includes the count of bytes that precede the gzip stream, for example when - appending or when using gzdopen() for reading. When reading, the offset - does not include as yet unused buffered input. This information can be used - for a progress indicator. On error, gzoffset() returns -1. -*/ - -ZEXTERN int ZEXPORT gzeof OF((gzFile file)); -/* - Returns true (1) if the end-of-file indicator has been set while reading, - false (0) otherwise. Note that the end-of-file indicator is set only if the - read tried to go past the end of the input, but came up short. Therefore, - just like feof(), gzeof() may return false even if there is no more data to - read, in the event that the last read request was for the exact number of - bytes remaining in the input file. This will happen if the input file size - is an exact multiple of the buffer size. - - If gzeof() returns true, then the read functions will return no more data, - unless the end-of-file indicator is reset by gzclearerr() and the input file - has grown since the previous end of file was detected. -*/ - -ZEXTERN int ZEXPORT gzdirect OF((gzFile file)); -/* - Returns true (1) if file is being copied directly while reading, or false - (0) if file is a gzip stream being decompressed. - - If the input file is empty, gzdirect() will return true, since the input - does not contain a gzip stream. - - If gzdirect() is used immediately after gzopen() or gzdopen() it will - cause buffers to be allocated to allow reading the file to determine if it - is a gzip file. Therefore if gzbuffer() is used, it should be called before - gzdirect(). - - When writing, gzdirect() returns true (1) if transparent writing was - requested ("wT" for the gzopen() mode), or false (0) otherwise. (Note: - gzdirect() is not needed when writing. Transparent writing must be - explicitly requested, so the application already knows the answer. When - linking statically, using gzdirect() will include all of the zlib code for - gzip file reading and decompression, which may not be desired.) -*/ - -ZEXTERN int ZEXPORT gzclose OF((gzFile file)); -/* - Flushes all pending output if necessary, closes the compressed file and - deallocates the (de)compression state. Note that once file is closed, you - cannot call gzerror with file, since its structures have been deallocated. - gzclose must not be called more than once on the same file, just as free - must not be called more than once on the same allocation. - - gzclose will return Z_STREAM_ERROR if file is not valid, Z_ERRNO on a - file operation error, Z_MEM_ERROR if out of memory, Z_BUF_ERROR if the - last read ended in the middle of a gzip stream, or Z_OK on success. -*/ - -ZEXTERN int ZEXPORT gzclose_r OF((gzFile file)); -ZEXTERN int ZEXPORT gzclose_w OF((gzFile file)); -/* - Same as gzclose(), but gzclose_r() is only for use when reading, and - gzclose_w() is only for use when writing or appending. The advantage to - using these instead of gzclose() is that they avoid linking in zlib - compression or decompression code that is not used when only reading or only - writing respectively. If gzclose() is used, then both compression and - decompression code will be included the application when linking to a static - zlib library. -*/ - -ZEXTERN const char * ZEXPORT gzerror OF((gzFile file, int *errnum)); -/* - Returns the error message for the last error which occurred on the given - compressed file. errnum is set to zlib error number. If an error occurred - in the file system and not in the compression library, errnum is set to - Z_ERRNO and the application may consult errno to get the exact error code. - - The application must not modify the returned string. Future calls to - this function may invalidate the previously returned string. If file is - closed, then the string previously returned by gzerror will no longer be - available. - - gzerror() should be used to distinguish errors from end-of-file for those - functions above that do not distinguish those cases in their return values. -*/ - -ZEXTERN void ZEXPORT gzclearerr OF((gzFile file)); -/* - Clears the error and end-of-file flags for file. This is analogous to the - clearerr() function in stdio. This is useful for continuing to read a gzip - file that is being written concurrently. -*/ - -#endif /* !Z_SOLO */ - - /* checksum functions */ - -/* - These functions are not related to compression but are exported - anyway because they might be useful in applications using the compression - library. -*/ - -ZEXTERN uLong ZEXPORT adler32 OF((uLong adler, const Bytef *buf, uInt len)); -/* - Update a running Adler-32 checksum with the bytes buf[0..len-1] and - return the updated checksum. If buf is Z_NULL, this function returns the - required initial value for the checksum. - - An Adler-32 checksum is almost as reliable as a CRC-32 but can be computed - much faster. - - Usage example: - - uLong adler = adler32(0L, Z_NULL, 0); - - while (read_buffer(buffer, length) != EOF) { - adler = adler32(adler, buffer, length); - } - if (adler != original_adler) error(); -*/ - -ZEXTERN uLong ZEXPORT adler32_z OF((uLong adler, const Bytef *buf, - z_size_t len)); -/* - Same as adler32(), but with a size_t length. -*/ - -/* -ZEXTERN uLong ZEXPORT adler32_combine OF((uLong adler1, uLong adler2, - z_off_t len2)); - - Combine two Adler-32 checksums into one. For two sequences of bytes, seq1 - and seq2 with lengths len1 and len2, Adler-32 checksums were calculated for - each, adler1 and adler2. adler32_combine() returns the Adler-32 checksum of - seq1 and seq2 concatenated, requiring only adler1, adler2, and len2. Note - that the z_off_t type (like off_t) is a signed integer. If len2 is - negative, the result has no meaning or utility. -*/ - -ZEXTERN uLong ZEXPORT crc32 OF((uLong crc, const Bytef *buf, uInt len)); -/* - Update a running CRC-32 with the bytes buf[0..len-1] and return the - updated CRC-32. If buf is Z_NULL, this function returns the required - initial value for the crc. Pre- and post-conditioning (one's complement) is - performed within this function so it shouldn't be done by the application. - - Usage example: - - uLong crc = crc32(0L, Z_NULL, 0); - - while (read_buffer(buffer, length) != EOF) { - crc = crc32(crc, buffer, length); - } - if (crc != original_crc) error(); -*/ - -ZEXTERN uLong ZEXPORT crc32_z OF((uLong adler, const Bytef *buf, - z_size_t len)); -/* - Same as crc32(), but with a size_t length. -*/ - -/* -ZEXTERN uLong ZEXPORT crc32_combine OF((uLong crc1, uLong crc2, z_off_t len2)); - - Combine two CRC-32 check values into one. For two sequences of bytes, - seq1 and seq2 with lengths len1 and len2, CRC-32 check values were - calculated for each, crc1 and crc2. crc32_combine() returns the CRC-32 - check value of seq1 and seq2 concatenated, requiring only crc1, crc2, and - len2. -*/ - - - /* various hacks, don't look :) */ - -/* deflateInit and inflateInit are macros to allow checking the zlib version - * and the compiler's view of z_stream: - */ -ZEXTERN int ZEXPORT deflateInit_ OF((z_streamp strm, int level, - const char *version, int stream_size)); -ZEXTERN int ZEXPORT inflateInit_ OF((z_streamp strm, - const char *version, int stream_size)); -ZEXTERN int ZEXPORT deflateInit2_ OF((z_streamp strm, int level, int method, - int windowBits, int memLevel, - int strategy, const char *version, - int stream_size)); -ZEXTERN int ZEXPORT inflateInit2_ OF((z_streamp strm, int windowBits, - const char *version, int stream_size)); -ZEXTERN int ZEXPORT inflateBackInit_ OF((z_streamp strm, int windowBits, - unsigned char FAR *window, - const char *version, - int stream_size)); -#ifdef Z_PREFIX_SET -# define z_deflateInit(strm, level) \ - deflateInit_((strm), (level), ZLIB_VERSION, (int)sizeof(z_stream)) -# define z_inflateInit(strm) \ - inflateInit_((strm), ZLIB_VERSION, (int)sizeof(z_stream)) -# define z_deflateInit2(strm, level, method, windowBits, memLevel, strategy) \ - deflateInit2_((strm),(level),(method),(windowBits),(memLevel),\ - (strategy), ZLIB_VERSION, (int)sizeof(z_stream)) -# define z_inflateInit2(strm, windowBits) \ - inflateInit2_((strm), (windowBits), ZLIB_VERSION, \ - (int)sizeof(z_stream)) -# define z_inflateBackInit(strm, windowBits, window) \ - inflateBackInit_((strm), (windowBits), (window), \ - ZLIB_VERSION, (int)sizeof(z_stream)) -#else -# define deflateInit(strm, level) \ - deflateInit_((strm), (level), ZLIB_VERSION, (int)sizeof(z_stream)) -# define inflateInit(strm) \ - inflateInit_((strm), ZLIB_VERSION, (int)sizeof(z_stream)) -# define deflateInit2(strm, level, method, windowBits, memLevel, strategy) \ - deflateInit2_((strm),(level),(method),(windowBits),(memLevel),\ - (strategy), ZLIB_VERSION, (int)sizeof(z_stream)) -# define inflateInit2(strm, windowBits) \ - inflateInit2_((strm), (windowBits), ZLIB_VERSION, \ - (int)sizeof(z_stream)) -# define inflateBackInit(strm, windowBits, window) \ - inflateBackInit_((strm), (windowBits), (window), \ - ZLIB_VERSION, (int)sizeof(z_stream)) -#endif - -#ifndef Z_SOLO - -/* gzgetc() macro and its supporting function and exposed data structure. Note - * that the real internal state is much larger than the exposed structure. - * This abbreviated structure exposes just enough for the gzgetc() macro. The - * user should not mess with these exposed elements, since their names or - * behavior could change in the future, perhaps even capriciously. They can - * only be used by the gzgetc() macro. You have been warned. - */ -struct gzFile_s { - unsigned have; - unsigned char *next; - z_off64_t pos; -}; -ZEXTERN int ZEXPORT gzgetc_ OF((gzFile file)); /* backward compatibility */ -#ifdef Z_PREFIX_SET -# undef z_gzgetc -# define z_gzgetc(g) \ - ((g)->have ? ((g)->have--, (g)->pos++, *((g)->next)++) : (gzgetc)(g)) -#else -# define gzgetc(g) \ - ((g)->have ? ((g)->have--, (g)->pos++, *((g)->next)++) : (gzgetc)(g)) -#endif - -/* provide 64-bit offset functions if _LARGEFILE64_SOURCE defined, and/or - * change the regular functions to 64 bits if _FILE_OFFSET_BITS is 64 (if - * both are true, the application gets the *64 functions, and the regular - * functions are changed to 64 bits) -- in case these are set on systems - * without large file support, _LFS64_LARGEFILE must also be true - */ -#ifdef Z_LARGE64 - ZEXTERN gzFile ZEXPORT gzopen64 OF((const char *, const char *)); - ZEXTERN z_off64_t ZEXPORT gzseek64 OF((gzFile, z_off64_t, int)); - ZEXTERN z_off64_t ZEXPORT gztell64 OF((gzFile)); - ZEXTERN z_off64_t ZEXPORT gzoffset64 OF((gzFile)); - ZEXTERN uLong ZEXPORT adler32_combine64 OF((uLong, uLong, z_off64_t)); - ZEXTERN uLong ZEXPORT crc32_combine64 OF((uLong, uLong, z_off64_t)); -#endif - -#if !defined(ZLIB_INTERNAL) && defined(Z_WANT64) -# ifdef Z_PREFIX_SET -# define z_gzopen z_gzopen64 -# define z_gzseek z_gzseek64 -# define z_gztell z_gztell64 -# define z_gzoffset z_gzoffset64 -# define z_adler32_combine z_adler32_combine64 -# define z_crc32_combine z_crc32_combine64 -# else -# define gzopen gzopen64 -# define gzseek gzseek64 -# define gztell gztell64 -# define gzoffset gzoffset64 -# define adler32_combine adler32_combine64 -# define crc32_combine crc32_combine64 -# endif -# ifndef Z_LARGE64 - ZEXTERN gzFile ZEXPORT gzopen64 OF((const char *, const char *)); - ZEXTERN z_off_t ZEXPORT gzseek64 OF((gzFile, z_off_t, int)); - ZEXTERN z_off_t ZEXPORT gztell64 OF((gzFile)); - ZEXTERN z_off_t ZEXPORT gzoffset64 OF((gzFile)); - ZEXTERN uLong ZEXPORT adler32_combine64 OF((uLong, uLong, z_off_t)); - ZEXTERN uLong ZEXPORT crc32_combine64 OF((uLong, uLong, z_off_t)); -# endif -#else - ZEXTERN gzFile ZEXPORT gzopen OF((const char *, const char *)); - ZEXTERN z_off_t ZEXPORT gzseek OF((gzFile, z_off_t, int)); - ZEXTERN z_off_t ZEXPORT gztell OF((gzFile)); - ZEXTERN z_off_t ZEXPORT gzoffset OF((gzFile)); - ZEXTERN uLong ZEXPORT adler32_combine OF((uLong, uLong, z_off_t)); - ZEXTERN uLong ZEXPORT crc32_combine OF((uLong, uLong, z_off_t)); -#endif - -#else /* Z_SOLO */ - - ZEXTERN uLong ZEXPORT adler32_combine OF((uLong, uLong, z_off_t)); - ZEXTERN uLong ZEXPORT crc32_combine OF((uLong, uLong, z_off_t)); - -#endif /* !Z_SOLO */ - -/* undocumented functions */ -ZEXTERN const char * ZEXPORT zError OF((int)); -ZEXTERN int ZEXPORT inflateSyncPoint OF((z_streamp)); -ZEXTERN const z_crc_t FAR * ZEXPORT get_crc_table OF((void)); -ZEXTERN int ZEXPORT inflateUndermine OF((z_streamp, int)); -ZEXTERN int ZEXPORT inflateValidate OF((z_streamp, int)); -ZEXTERN unsigned long ZEXPORT inflateCodesUsed OF ((z_streamp)); -ZEXTERN int ZEXPORT inflateResetKeep OF((z_streamp)); -ZEXTERN int ZEXPORT deflateResetKeep OF((z_streamp)); -#if (defined(_WIN32) || defined(__CYGWIN__)) && !defined(Z_SOLO) -ZEXTERN gzFile ZEXPORT gzopen_w OF((const wchar_t *path, - const char *mode)); -#endif -#if defined(STDC) || defined(Z_HAVE_STDARG_H) -# ifndef Z_SOLO -ZEXTERN int ZEXPORTVA gzvprintf Z_ARG((gzFile file, - const char *format, - va_list va)); -# endif -#endif - -#ifdef __cplusplus -} -#endif - -#endif /* ZLIB_H */ DELETED compat/zlib/zlib.map Index: compat/zlib/zlib.map ================================================================== --- compat/zlib/zlib.map +++ /dev/null @@ -1,94 +0,0 @@ -ZLIB_1.2.0 { - global: - compressBound; - deflateBound; - inflateBack; - inflateBackEnd; - inflateBackInit_; - inflateCopy; - local: - deflate_copyright; - inflate_copyright; - inflate_fast; - inflate_table; - zcalloc; - zcfree; - z_errmsg; - gz_error; - gz_intmax; - _*; -}; - -ZLIB_1.2.0.2 { - gzclearerr; - gzungetc; - zlibCompileFlags; -} ZLIB_1.2.0; - -ZLIB_1.2.0.8 { - deflatePrime; -} ZLIB_1.2.0.2; - -ZLIB_1.2.2 { - adler32_combine; - crc32_combine; - deflateSetHeader; - inflateGetHeader; -} ZLIB_1.2.0.8; - -ZLIB_1.2.2.3 { - deflateTune; - gzdirect; -} ZLIB_1.2.2; - -ZLIB_1.2.2.4 { - inflatePrime; -} ZLIB_1.2.2.3; - -ZLIB_1.2.3.3 { - adler32_combine64; - crc32_combine64; - gzopen64; - gzseek64; - gztell64; - inflateUndermine; -} ZLIB_1.2.2.4; - -ZLIB_1.2.3.4 { - inflateReset2; - inflateMark; -} ZLIB_1.2.3.3; - -ZLIB_1.2.3.5 { - gzbuffer; - gzoffset; - gzoffset64; - gzclose_r; - gzclose_w; -} ZLIB_1.2.3.4; - -ZLIB_1.2.5.1 { - deflatePending; -} ZLIB_1.2.3.5; - -ZLIB_1.2.5.2 { - deflateResetKeep; - gzgetc_; - inflateResetKeep; -} ZLIB_1.2.5.1; - -ZLIB_1.2.7.1 { - inflateGetDictionary; - gzvprintf; -} ZLIB_1.2.5.2; - -ZLIB_1.2.9 { - inflateCodesUsed; - inflateValidate; - uncompress2; - gzfread; - gzfwrite; - deflateGetDictionary; - adler32_z; - crc32_z; -} ZLIB_1.2.7.1; DELETED compat/zlib/zlib.pc.cmakein Index: compat/zlib/zlib.pc.cmakein ================================================================== --- compat/zlib/zlib.pc.cmakein +++ /dev/null @@ -1,13 +0,0 @@ -prefix=@CMAKE_INSTALL_PREFIX@ -exec_prefix=@CMAKE_INSTALL_PREFIX@ -libdir=@INSTALL_LIB_DIR@ -sharedlibdir=@INSTALL_LIB_DIR@ -includedir=@INSTALL_INC_DIR@ - -Name: zlib -Description: zlib compression library -Version: @VERSION@ - -Requires: -Libs: -L${libdir} -L${sharedlibdir} -lz -Cflags: -I${includedir} DELETED compat/zlib/zlib.pc.in Index: compat/zlib/zlib.pc.in ================================================================== --- compat/zlib/zlib.pc.in +++ /dev/null @@ -1,13 +0,0 @@ -prefix=@prefix@ -exec_prefix=@exec_prefix@ -libdir=@libdir@ -sharedlibdir=@sharedlibdir@ -includedir=@includedir@ - -Name: zlib -Description: zlib compression library -Version: @VERSION@ - -Requires: -Libs: -L${libdir} -L${sharedlibdir} -lz -Cflags: -I${includedir} DELETED compat/zlib/zlib2ansi Index: compat/zlib/zlib2ansi ================================================================== --- compat/zlib/zlib2ansi +++ /dev/null @@ -1,152 +0,0 @@ -#!/usr/bin/perl - -# Transform K&R C function definitions into ANSI equivalent. -# -# Author: Paul Marquess -# Version: 1.0 -# Date: 3 October 2006 - -# TODO -# -# Asumes no function pointer parameters. unless they are typedefed. -# Assumes no literal strings that look like function definitions -# Assumes functions start at the beginning of a line - -use strict; -use warnings; - -local $/; -$_ = <>; - -my $sp = qr{ \s* (?: /\* .*? \*/ )? \s* }x; # assume no nested comments - -my $d1 = qr{ $sp (?: [\w\*\s]+ $sp)* $sp \w+ $sp [\[\]\s]* $sp }x ; -my $decl = qr{ $sp (?: \w+ $sp )+ $d1 }xo ; -my $dList = qr{ $sp $decl (?: $sp , $d1 )* $sp ; $sp }xo ; - - -while (s/^ - ( # Start $1 - ( # Start $2 - .*? # Minimal eat content - ( ^ \w [\w\s\*]+ ) # $3 -- function name - \s* # optional whitespace - ) # $2 - Matched up to before parameter list - - \( \s* # Literal "(" + optional whitespace - ( [^\)]+ ) # $4 - one or more anythings except ")" - \s* \) # optional whitespace surrounding a Literal ")" - - ( (?: $dList )+ ) # $5 - - $sp ^ { # literal "{" at start of line - ) # Remember to $1 - //xsom - ) -{ - my $all = $1 ; - my $prefix = $2; - my $param_list = $4 ; - my $params = $5; - - StripComments($params); - StripComments($param_list); - $param_list =~ s/^\s+//; - $param_list =~ s/\s+$//; - - my $i = 0 ; - my %pList = map { $_ => $i++ } - split /\s*,\s*/, $param_list; - my $pMatch = '(\b' . join('|', keys %pList) . '\b)\W*$' ; - - my @params = split /\s*;\s*/, $params; - my @outParams = (); - foreach my $p (@params) - { - if ($p =~ /,/) - { - my @bits = split /\s*,\s*/, $p; - my $first = shift @bits; - $first =~ s/^\s*//; - push @outParams, $first; - $first =~ /^(\w+\s*)/; - my $type = $1 ; - push @outParams, map { $type . $_ } @bits; - } - else - { - $p =~ s/^\s+//; - push @outParams, $p; - } - } - - - my %tmp = map { /$pMatch/; $_ => $pList{$1} } - @outParams ; - - @outParams = map { " $_" } - sort { $tmp{$a} <=> $tmp{$b} } - @outParams ; - - print $prefix ; - print "(\n" . join(",\n", @outParams) . ")\n"; - print "{" ; - -} - -# Output any trailing code. -print ; -exit 0; - - -sub StripComments -{ - - no warnings; - - # Strip C & C++ coments - # From the perlfaq - $_[0] =~ - - s{ - /\* ## Start of /* ... */ comment - [^*]*\*+ ## Non-* followed by 1-or-more *'s - ( - [^/*][^*]*\*+ - )* ## 0-or-more things which don't start with / - ## but do end with '*' - / ## End of /* ... */ comment - - | ## OR C++ Comment - // ## Start of C++ comment // - [^\n]* ## followed by 0-or-more non end of line characters - - | ## OR various things which aren't comments: - - ( - " ## Start of " ... " string - ( - \\. ## Escaped char - | ## OR - [^"\\] ## Non "\ - )* - " ## End of " ... " string - - | ## OR - - ' ## Start of ' ... ' string - ( - \\. ## Escaped char - | ## OR - [^'\\] ## Non '\ - )* - ' ## End of ' ... ' string - - | ## OR - - . ## Anything other char - [^/"'\\]* ## Chars which doesn't start a comment, string or escape - ) - }{$2}gxs; - -} DELETED compat/zlib/zutil.c Index: compat/zlib/zutil.c ================================================================== --- compat/zlib/zutil.c +++ /dev/null @@ -1,325 +0,0 @@ -/* zutil.c -- target dependent utility functions for the compression library - * Copyright (C) 1995-2017 Jean-loup Gailly - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -/* @(#) $Id$ */ - -#include "zutil.h" -#ifndef Z_SOLO -# include "gzguts.h" -#endif - -z_const char * const z_errmsg[10] = { - (z_const char *)"need dictionary", /* Z_NEED_DICT 2 */ - (z_const char *)"stream end", /* Z_STREAM_END 1 */ - (z_const char *)"", /* Z_OK 0 */ - (z_const char *)"file error", /* Z_ERRNO (-1) */ - (z_const char *)"stream error", /* Z_STREAM_ERROR (-2) */ - (z_const char *)"data error", /* Z_DATA_ERROR (-3) */ - (z_const char *)"insufficient memory", /* Z_MEM_ERROR (-4) */ - (z_const char *)"buffer error", /* Z_BUF_ERROR (-5) */ - (z_const char *)"incompatible version",/* Z_VERSION_ERROR (-6) */ - (z_const char *)"" -}; - - -const char * ZEXPORT zlibVersion() -{ - return ZLIB_VERSION; -} - -uLong ZEXPORT zlibCompileFlags() -{ - uLong flags; - - flags = 0; - switch ((int)(sizeof(uInt))) { - case 2: break; - case 4: flags += 1; break; - case 8: flags += 2; break; - default: flags += 3; - } - switch ((int)(sizeof(uLong))) { - case 2: break; - case 4: flags += 1 << 2; break; - case 8: flags += 2 << 2; break; - default: flags += 3 << 2; - } - switch ((int)(sizeof(voidpf))) { - case 2: break; - case 4: flags += 1 << 4; break; - case 8: flags += 2 << 4; break; - default: flags += 3 << 4; - } - switch ((int)(sizeof(z_off_t))) { - case 2: break; - case 4: flags += 1 << 6; break; - case 8: flags += 2 << 6; break; - default: flags += 3 << 6; - } -#ifdef ZLIB_DEBUG - flags += 1 << 8; -#endif -#if defined(ASMV) || defined(ASMINF) - flags += 1 << 9; -#endif -#ifdef ZLIB_WINAPI - flags += 1 << 10; -#endif -#ifdef BUILDFIXED - flags += 1 << 12; -#endif -#ifdef DYNAMIC_CRC_TABLE - flags += 1 << 13; -#endif -#ifdef NO_GZCOMPRESS - flags += 1L << 16; -#endif -#ifdef NO_GZIP - flags += 1L << 17; -#endif -#ifdef PKZIP_BUG_WORKAROUND - flags += 1L << 20; -#endif -#ifdef FASTEST - flags += 1L << 21; -#endif -#if defined(STDC) || defined(Z_HAVE_STDARG_H) -# ifdef NO_vsnprintf - flags += 1L << 25; -# ifdef HAS_vsprintf_void - flags += 1L << 26; -# endif -# else -# ifdef HAS_vsnprintf_void - flags += 1L << 26; -# endif -# endif -#else - flags += 1L << 24; -# ifdef NO_snprintf - flags += 1L << 25; -# ifdef HAS_sprintf_void - flags += 1L << 26; -# endif -# else -# ifdef HAS_snprintf_void - flags += 1L << 26; -# endif -# endif -#endif - return flags; -} - -#ifdef ZLIB_DEBUG -#include -# ifndef verbose -# define verbose 0 -# endif -int ZLIB_INTERNAL z_verbose = verbose; - -void ZLIB_INTERNAL z_error (m) - char *m; -{ - fprintf(stderr, "%s\n", m); - exit(1); -} -#endif - -/* exported to allow conversion of error code to string for compress() and - * uncompress() - */ -const char * ZEXPORT zError(err) - int err; -{ - return ERR_MSG(err); -} - -#if defined(_WIN32_WCE) - /* The Microsoft C Run-Time Library for Windows CE doesn't have - * errno. We define it as a global variable to simplify porting. - * Its value is always 0 and should not be used. - */ - int errno = 0; -#endif - -#ifndef HAVE_MEMCPY - -void ZLIB_INTERNAL zmemcpy(dest, source, len) - Bytef* dest; - const Bytef* source; - uInt len; -{ - if (len == 0) return; - do { - *dest++ = *source++; /* ??? to be unrolled */ - } while (--len != 0); -} - -int ZLIB_INTERNAL zmemcmp(s1, s2, len) - const Bytef* s1; - const Bytef* s2; - uInt len; -{ - uInt j; - - for (j = 0; j < len; j++) { - if (s1[j] != s2[j]) return 2*(s1[j] > s2[j])-1; - } - return 0; -} - -void ZLIB_INTERNAL zmemzero(dest, len) - Bytef* dest; - uInt len; -{ - if (len == 0) return; - do { - *dest++ = 0; /* ??? to be unrolled */ - } while (--len != 0); -} -#endif - -#ifndef Z_SOLO - -#ifdef SYS16BIT - -#ifdef __TURBOC__ -/* Turbo C in 16-bit mode */ - -# define MY_ZCALLOC - -/* Turbo C malloc() does not allow dynamic allocation of 64K bytes - * and farmalloc(64K) returns a pointer with an offset of 8, so we - * must fix the pointer. Warning: the pointer must be put back to its - * original form in order to free it, use zcfree(). - */ - -#define MAX_PTR 10 -/* 10*64K = 640K */ - -local int next_ptr = 0; - -typedef struct ptr_table_s { - voidpf org_ptr; - voidpf new_ptr; -} ptr_table; - -local ptr_table table[MAX_PTR]; -/* This table is used to remember the original form of pointers - * to large buffers (64K). Such pointers are normalized with a zero offset. - * Since MSDOS is not a preemptive multitasking OS, this table is not - * protected from concurrent access. This hack doesn't work anyway on - * a protected system like OS/2. Use Microsoft C instead. - */ - -voidpf ZLIB_INTERNAL zcalloc (voidpf opaque, unsigned items, unsigned size) -{ - voidpf buf; - ulg bsize = (ulg)items*size; - - (void)opaque; - - /* If we allocate less than 65520 bytes, we assume that farmalloc - * will return a usable pointer which doesn't have to be normalized. - */ - if (bsize < 65520L) { - buf = farmalloc(bsize); - if (*(ush*)&buf != 0) return buf; - } else { - buf = farmalloc(bsize + 16L); - } - if (buf == NULL || next_ptr >= MAX_PTR) return NULL; - table[next_ptr].org_ptr = buf; - - /* Normalize the pointer to seg:0 */ - *((ush*)&buf+1) += ((ush)((uch*)buf-0) + 15) >> 4; - *(ush*)&buf = 0; - table[next_ptr++].new_ptr = buf; - return buf; -} - -void ZLIB_INTERNAL zcfree (voidpf opaque, voidpf ptr) -{ - int n; - - (void)opaque; - - if (*(ush*)&ptr != 0) { /* object < 64K */ - farfree(ptr); - return; - } - /* Find the original pointer */ - for (n = 0; n < next_ptr; n++) { - if (ptr != table[n].new_ptr) continue; - - farfree(table[n].org_ptr); - while (++n < next_ptr) { - table[n-1] = table[n]; - } - next_ptr--; - return; - } - Assert(0, "zcfree: ptr not found"); -} - -#endif /* __TURBOC__ */ - - -#ifdef M_I86 -/* Microsoft C in 16-bit mode */ - -# define MY_ZCALLOC - -#if (!defined(_MSC_VER) || (_MSC_VER <= 600)) -# define _halloc halloc -# define _hfree hfree -#endif - -voidpf ZLIB_INTERNAL zcalloc (voidpf opaque, uInt items, uInt size) -{ - (void)opaque; - return _halloc((long)items, size); -} - -void ZLIB_INTERNAL zcfree (voidpf opaque, voidpf ptr) -{ - (void)opaque; - _hfree(ptr); -} - -#endif /* M_I86 */ - -#endif /* SYS16BIT */ - - -#ifndef MY_ZCALLOC /* Any system without a special alloc function */ - -#ifndef STDC -extern voidp malloc OF((uInt size)); -extern voidp calloc OF((uInt items, uInt size)); -extern void free OF((voidpf ptr)); -#endif - -voidpf ZLIB_INTERNAL zcalloc (opaque, items, size) - voidpf opaque; - unsigned items; - unsigned size; -{ - (void)opaque; - return sizeof(uInt) > 2 ? (voidpf)malloc(items * size) : - (voidpf)calloc(items, size); -} - -void ZLIB_INTERNAL zcfree (opaque, ptr) - voidpf opaque; - voidpf ptr; -{ - (void)opaque; - free(ptr); -} - -#endif /* MY_ZCALLOC */ - -#endif /* !Z_SOLO */ DELETED compat/zlib/zutil.h Index: compat/zlib/zutil.h ================================================================== --- compat/zlib/zutil.h +++ /dev/null @@ -1,271 +0,0 @@ -/* zutil.h -- internal interface and configuration of the compression library - * Copyright (C) 1995-2016 Jean-loup Gailly, Mark Adler - * For conditions of distribution and use, see copyright notice in zlib.h - */ - -/* WARNING: this file should *not* be used by applications. It is - part of the implementation of the compression library and is - subject to change. Applications should only use zlib.h. - */ - -/* @(#) $Id$ */ - -#ifndef ZUTIL_H -#define ZUTIL_H - -#ifdef HAVE_HIDDEN -# define ZLIB_INTERNAL __attribute__((visibility ("hidden"))) -#else -# define ZLIB_INTERNAL -#endif - -#include "zlib.h" - -#if defined(STDC) && !defined(Z_SOLO) -# if !(defined(_WIN32_WCE) && defined(_MSC_VER)) -# include -# endif -# include -# include -#endif - -#ifdef Z_SOLO - typedef long ptrdiff_t; /* guess -- will be caught if guess is wrong */ -#endif - -#ifndef local -# define local static -#endif -/* since "static" is used to mean two completely different things in C, we - define "local" for the non-static meaning of "static", for readability - (compile with -Dlocal if your debugger can't find static symbols) */ - -typedef unsigned char uch; -typedef uch FAR uchf; -typedef unsigned short ush; -typedef ush FAR ushf; -typedef unsigned long ulg; - -extern z_const char * const z_errmsg[10]; /* indexed by 2-zlib_error */ -/* (size given to avoid silly warnings with Visual C++) */ - -#define ERR_MSG(err) z_errmsg[Z_NEED_DICT-(err)] - -#define ERR_RETURN(strm,err) \ - return (strm->msg = ERR_MSG(err), (err)) -/* To be used only when the state is known to be valid */ - - /* common constants */ - -#ifndef DEF_WBITS -# define DEF_WBITS MAX_WBITS -#endif -/* default windowBits for decompression. MAX_WBITS is for compression only */ - -#if MAX_MEM_LEVEL >= 8 -# define DEF_MEM_LEVEL 8 -#else -# define DEF_MEM_LEVEL MAX_MEM_LEVEL -#endif -/* default memLevel */ - -#define STORED_BLOCK 0 -#define STATIC_TREES 1 -#define DYN_TREES 2 -/* The three kinds of block type */ - -#define MIN_MATCH 3 -#define MAX_MATCH 258 -/* The minimum and maximum match lengths */ - -#define PRESET_DICT 0x20 /* preset dictionary flag in zlib header */ - - /* target dependencies */ - -#if defined(MSDOS) || (defined(WINDOWS) && !defined(WIN32)) -# define OS_CODE 0x00 -# ifndef Z_SOLO -# if defined(__TURBOC__) || defined(__BORLANDC__) -# if (__STDC__ == 1) && (defined(__LARGE__) || defined(__COMPACT__)) - /* Allow compilation with ANSI keywords only enabled */ - void _Cdecl farfree( void *block ); - void *_Cdecl farmalloc( unsigned long nbytes ); -# else -# include -# endif -# else /* MSC or DJGPP */ -# include -# endif -# endif -#endif - -#ifdef AMIGA -# define OS_CODE 1 -#endif - -#if defined(VAXC) || defined(VMS) -# define OS_CODE 2 -# define F_OPEN(name, mode) \ - fopen((name), (mode), "mbc=60", "ctx=stm", "rfm=fix", "mrs=512") -#endif - -#ifdef __370__ -# if __TARGET_LIB__ < 0x20000000 -# define OS_CODE 4 -# elif __TARGET_LIB__ < 0x40000000 -# define OS_CODE 11 -# else -# define OS_CODE 8 -# endif -#endif - -#if defined(ATARI) || defined(atarist) -# define OS_CODE 5 -#endif - -#ifdef OS2 -# define OS_CODE 6 -# if defined(M_I86) && !defined(Z_SOLO) -# include -# endif -#endif - -#if defined(MACOS) || defined(TARGET_OS_MAC) -# define OS_CODE 7 -# ifndef Z_SOLO -# if defined(__MWERKS__) && __dest_os != __be_os && __dest_os != __win32_os -# include /* for fdopen */ -# else -# ifndef fdopen -# define fdopen(fd,mode) NULL /* No fdopen() */ -# endif -# endif -# endif -#endif - -#ifdef __acorn -# define OS_CODE 13 -#endif - -#if defined(WIN32) && !defined(__CYGWIN__) -# define OS_CODE 10 -#endif - -#ifdef _BEOS_ -# define OS_CODE 16 -#endif - -#ifdef __TOS_OS400__ -# define OS_CODE 18 -#endif - -#ifdef __APPLE__ -# define OS_CODE 19 -#endif - -#if defined(_BEOS_) || defined(RISCOS) -# define fdopen(fd,mode) NULL /* No fdopen() */ -#endif - -#if (defined(_MSC_VER) && (_MSC_VER > 600)) && !defined __INTERIX -# if defined(_WIN32_WCE) -# define fdopen(fd,mode) NULL /* No fdopen() */ -# ifndef _PTRDIFF_T_DEFINED - typedef int ptrdiff_t; -# define _PTRDIFF_T_DEFINED -# endif -# else -# define fdopen(fd,type) _fdopen(fd,type) -# endif -#endif - -#if defined(__BORLANDC__) && !defined(MSDOS) - #pragma warn -8004 - #pragma warn -8008 - #pragma warn -8066 -#endif - -/* provide prototypes for these when building zlib without LFS */ -#if !defined(_WIN32) && \ - (!defined(_LARGEFILE64_SOURCE) || _LFS64_LARGEFILE-0 == 0) - ZEXTERN uLong ZEXPORT adler32_combine64 OF((uLong, uLong, z_off_t)); - ZEXTERN uLong ZEXPORT crc32_combine64 OF((uLong, uLong, z_off_t)); -#endif - - /* common defaults */ - -#ifndef OS_CODE -# define OS_CODE 3 /* assume Unix */ -#endif - -#ifndef F_OPEN -# define F_OPEN(name, mode) fopen((name), (mode)) -#endif - - /* functions */ - -#if defined(pyr) || defined(Z_SOLO) -# define NO_MEMCPY -#endif -#if defined(SMALL_MEDIUM) && !defined(_MSC_VER) && !defined(__SC__) - /* Use our own functions for small and medium model with MSC <= 5.0. - * You may have to use the same strategy for Borland C (untested). - * The __SC__ check is for Symantec. - */ -# define NO_MEMCPY -#endif -#if defined(STDC) && !defined(HAVE_MEMCPY) && !defined(NO_MEMCPY) -# define HAVE_MEMCPY -#endif -#ifdef HAVE_MEMCPY -# ifdef SMALL_MEDIUM /* MSDOS small or medium model */ -# define zmemcpy _fmemcpy -# define zmemcmp _fmemcmp -# define zmemzero(dest, len) _fmemset(dest, 0, len) -# else -# define zmemcpy memcpy -# define zmemcmp memcmp -# define zmemzero(dest, len) memset(dest, 0, len) -# endif -#else - void ZLIB_INTERNAL zmemcpy OF((Bytef* dest, const Bytef* source, uInt len)); - int ZLIB_INTERNAL zmemcmp OF((const Bytef* s1, const Bytef* s2, uInt len)); - void ZLIB_INTERNAL zmemzero OF((Bytef* dest, uInt len)); -#endif - -/* Diagnostic functions */ -#ifdef ZLIB_DEBUG -# include - extern int ZLIB_INTERNAL z_verbose; - extern void ZLIB_INTERNAL z_error OF((char *m)); -# define Assert(cond,msg) {if(!(cond)) z_error(msg);} -# define Trace(x) {if (z_verbose>=0) fprintf x ;} -# define Tracev(x) {if (z_verbose>0) fprintf x ;} -# define Tracevv(x) {if (z_verbose>1) fprintf x ;} -# define Tracec(c,x) {if (z_verbose>0 && (c)) fprintf x ;} -# define Tracecv(c,x) {if (z_verbose>1 && (c)) fprintf x ;} -#else -# define Assert(cond,msg) -# define Trace(x) -# define Tracev(x) -# define Tracevv(x) -# define Tracec(c,x) -# define Tracecv(c,x) -#endif - -#ifndef Z_SOLO - voidpf ZLIB_INTERNAL zcalloc OF((voidpf opaque, unsigned items, - unsigned size)); - void ZLIB_INTERNAL zcfree OF((voidpf opaque, voidpf ptr)); -#endif - -#define ZALLOC(strm, items, size) \ - (*((strm)->zalloc))((strm)->opaque, (items), (size)) -#define ZFREE(strm, addr) (*((strm)->zfree))((strm)->opaque, (voidpf)(addr)) -#define TRY_FREE(s, p) {if (p) ZFREE(s, p);} - -/* Reverse the bytes in a 32-bit value */ -#define ZSWAP32(q) ((((q) >> 24) & 0xff) + (((q) >> 8) & 0xff00) + \ - (((q) & 0xff00) << 8) + (((q) & 0xff) << 24)) - -#endif /* ZUTIL_H */ Index: doc/Access.3 ================================================================== --- doc/Access.3 +++ doc/Access.3 @@ -1,11 +1,11 @@ '\" '\" Copyright (c) 1998-1999 Scriptics Corporation '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Tcl_Access 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_Access, Tcl_Stat \- check file permissions and other attributes @@ -21,51 +21,54 @@ .SH ARGUMENTS .AS "struct stat" *statPtr out .AP char *path in Native name of the file to check the attributes of. .AP int mode in -Mask consisting of one or more of \fBR_OK\fR, \fBW_OK\fR, \fBX_OK\fR and -\fBF_OK\fR. \fBR_OK\fR, \fBW_OK\fR and \fBX_OK\fR request checking whether the -file exists and has read, write and execute permissions, respectively. -\fBF_OK\fR just requests a check for the existence of the file. +Mask consisting of one or more of R_OK, W_OK, X_OK and F_OK. R_OK, +W_OK and X_OK request checking whether the file exists and has read, +write and execute permissions, respectively. F_OK just requests +checking for the existence of the file. .AP "struct stat" *statPtr out The structure that contains the result. .BE + .SH DESCRIPTION .PP -As of Tcl 8.4, the object-based APIs \fBTcl_FSAccess\fR and \fBTcl_FSStat\fR -should be used in preference to \fBTcl_Access\fR and \fBTcl_Stat\fR, wherever -possible. Those functions also support Tcl's virtual filesystem layer, which -these do not. -.SS "OBSOLETE FUNCTIONS" -.PP -There are two reasons for calling \fBTcl_Access\fR and \fBTcl_Stat\fR rather -than calling system level functions \fBaccess\fR and \fBstat\fR directly. -First, the Windows implementation of both functions fixes some bugs in the -system level calls. Second, both \fBTcl_Access\fR and \fBTcl_Stat\fR (as well -as \fBTcl_OpenFileChannelProc\fR) hook into a linked list of functions. This -allows the possibility to reroute file access to alternative media or access -methods. -.PP -\fBTcl_Access\fR checks whether the process would be allowed to read, write or -test for existence of the file (or other file system object) whose name is -\fIpath\fR. If \fIpath\fR is a symbolic link on Unix, then permissions of the -file referred by this symbolic link are tested. -.PP -On success (all requested permissions granted), zero is returned. On error (at -least one bit in mode asked for a permission that is denied, or some other -error occurred), -1 is returned. -.PP -\fBTcl_Stat\fR fills the stat structure \fIstatPtr\fR with information about -the specified file. You do not need any access rights to the file to get this -information but you need search rights to all directories named in the path -leading to the file. The stat structure includes info regarding device, inode -(always 0 on Windows), privilege mode, nlink (always 1 on Windows), user id -(always 0 on Windows), group id (always 0 on Windows), rdev (same as device on -Windows), size, last access time, last modification time, and creation time. -.PP -If \fIpath\fR exists, \fBTcl_Stat\fR returns 0 and the stat structure is -filled with data. Otherwise, -1 is returned, and no stat info is given. +As of Tcl 8.4, the object-based APIs \fBTcl_FSAccess\fR and +\fBTcl_FSStat\fR should be used in preference to \fBTcl_Access\fR and +\fBTcl_Stat\fR, wherever possible. +.PP +There are two reasons for calling \fBTcl_Access\fR and \fBTcl_Stat\fR +rather than calling system level functions \fBaccess\fR and \fBstat\fR +directly. First, the Windows implementation of both functions fixes +some bugs in the system level calls. Second, both \fBTcl_Access\fR +and \fBTcl_Stat\fR (as well as \fBTcl_OpenFileChannelProc\fR) hook +into a linked list of functions. This allows the possibility to reroute +file access to alternative media or access methods. +.PP +\fBTcl_Access\fR checks whether the process would be allowed to read, +write or test for existence of the file (or other file system object) +whose name is pathname. If pathname is a symbolic link on Unix, +then permissions of the file referred by this symbolic link are +tested. +.PP +On success (all requested permissions granted), zero is returned. On +error (at least one bit in mode asked for a permission that is denied, +or some other error occurred), -1 is returned. +.PP +\fBTcl_Stat\fR fills the stat structure \fIstatPtr\fR with information +about the specified file. You do not need any access rights to the +file to get this information but you need search rights to all +directories named in the path leading to the file. The stat structure +includes info regarding device, inode (always 0 on Windows), +privilege mode, nlink (always 1 on Windows), user id (always 0 on +Windows), group id (always 0 on Windows), rdev (same as device on +Windows), size, last access time, last modification time, and creation +time. +.PP +If \fIpath\fR exists, \fBTcl_Stat\fR returns 0 and the stat structure +is filled with data. Otherwise, -1 is returned, and no stat info is +given. + .SH KEYWORDS stat, access -.SH "SEE ALSO" -Tcl_FSAccess(3), Tcl_FSStat(3) + Index: doc/AddErrInfo.3 ================================================================== --- doc/AddErrInfo.3 +++ doc/AddErrInfo.3 @@ -2,39 +2,41 @@ '\" 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_SetErrorLine, Tcl_GetErrorLine, Tcl_PosixError, Tcl_LogCommandInfo \- retrieve or record information about errors and other return options +Tcl_GetReturnOptions, Tcl_SetReturnOptions, Tcl_AddErrorInfo, Tcl_AppendObjToErrorInfo, Tcl_AddObjErrorInfo, Tcl_SetObjErrorCode, Tcl_SetErrorCode, Tcl_SetErrorCodeVA, Tcl_PosixError, Tcl_LogCommandInfo \- retrieve or record information about errors and other return options .SH SYNOPSIS .nf \fB#include \fR +.VS 8.5 .sp Tcl_Obj * \fBTcl_GetReturnOptions\fR(\fIinterp, code\fR) .sp -int +int \fBTcl_SetReturnOptions\fR(\fIinterp, options\fR) +.VE 8.5 .sp \fBTcl_AddErrorInfo\fR(\fIinterp, message\fR) +.VS 8.5 .sp \fBTcl_AppendObjToErrorInfo\fR(\fIinterp, objPtr\fR) +.VE 8.5 .sp \fBTcl_AddObjErrorInfo\fR(\fIinterp, message, length\fR) .sp \fBTcl_SetObjErrorCode\fR(\fIinterp, errorObjPtr\fR) .sp \fBTcl_SetErrorCode\fR(\fIinterp, element, element, ... \fB(char *) NULL\fR) .sp -\fBTcl_GetErrorLine\fR(\fIinterp\fR) -.sp -\fBTcl_SetErrorLine\fR(\fIinterp, lineNum\fR) +\fBTcl_SetErrorCodeVA\fR(\fIinterp, argList\fR) .sp const char * \fBTcl_PosixError\fR(\fIinterp\fR) .sp void @@ -41,11 +43,11 @@ \fBTcl_LogCommandInfo\fR(\fIinterp, script, command, commandLength\fR) .SH ARGUMENTS .AS Tcl_Interp commandLength .AP Tcl_Interp *interp in Interpreter in which to record information. -.AP int code +.AP int code The code returned from script evaluation. .AP Tcl_Obj *options A dictionary of return options. .AP char *message in For \fBTcl_AddErrorInfo\fR, @@ -53,36 +55,38 @@ For \fBTcl_AddObjErrorInfo\fR, 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. +.VS 8.5 .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 size_t length in +.VE 8.5 +.AP int length in The number of bytes to copy from \fImessage\fR when appending to the \fB\-errorinfo\fR return option. -If TCL_INDEX_NONE, all bytes up to the first null byte are used. +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 \fBva_start\fR, and cleared using \fBva_end\fR. -.AP int lineNum -The line number of a script where an error occurred. .AP "const char" *script in Pointer to first character in script containing command (must be <= command) .AP "const char" *command in Pointer to first character in command that generated the error .AP int commandLength in Number of bytes in command; -1 means use all bytes up to first null byte .BE + .SH DESCRIPTION .PP +.VS 8.5 The \fBTcl_SetReturnOptions\fR and \fBTcl_GetReturnOptions\fR routines expose the same capabilities as the \fBreturn\fR and \fBcatch\fR commands, respectively, in the form of a C interface. .PP \fBTcl_GetReturnOptions\fR retrieves the dictionary of return options @@ -103,32 +107,25 @@ and \fB\-level\fR will be adjusted if necessary to agree with the value of \fIcode\fR. The \fB(Tcl_Obj *)\fR returned by \fBTcl_GetReturnOptions\fR points to an unshared \fBTcl_Obj\fR with reference count of zero. The dictionary may be written to, either adding, removing, or overwriting -any entries in it, without the need to check for a shared value. -As with any \fBTcl_Obj\fR with reference count of zero, it is up to -the caller to arrange for its disposal with \fBTcl_DecrRefCount\fR or -to a reference to it via \fBTcl_IncrRefCount\fR (or one of the many -functions that call that, notably including \fBTcl_SetObjResult\fR and -\fBTcl_SetVar2Ex\fR). +any entries in it, without the need to check for a shared object. .PP A typical usage for \fBTcl_GetReturnOptions\fR is to retrieve the stack trace when script evaluation returns \fBTCL_ERROR\fR, like so: -.PP .CS -int code = Tcl_EvalEx(interp, script, -1, 0); +int code = Tcl_Eval(interp, script); if (code == TCL_ERROR) { - Tcl_Obj *options = \fBTcl_GetReturnOptions\fR(interp, code); + Tcl_Obj *options = Tcl_GetReturnOptions(interp, code); Tcl_Obj *key = Tcl_NewStringObj("-errorinfo", -1); Tcl_Obj *stackTrace; Tcl_IncrRefCount(key); Tcl_DictObjGet(NULL, options, key, &stackTrace); Tcl_DecrRefCount(key); /* Do something with stackTrace */ - Tcl_DecrRefCount(options); } .CE .PP \fBTcl_SetReturnOptions\fR sets the return options of \fIinterp\fR to be \fIoptions\fR. If \fIoptions\fR @@ -139,19 +136,17 @@ keys in \fIoptions\fR will be returned. .PP As an example, Tcl's \fBreturn\fR command itself could be implemented in terms of \fBTcl_SetReturnOptions\fR like so: -.PP .CS if ((objc % 2) == 0) { /* explicit result argument */ objc--; Tcl_SetObjResult(interp, objv[objc]); } -return \fBTcl_SetReturnOptions\fR(interp, Tcl_NewListObj(objc-1, objv+1)); +return Tcl_SetReturnOptions(interp, Tcl_NewListObj(objc-1, objv+1)); .CE -.PP (It is not really implemented that way. Internal access privileges allow for a more efficient alternative that meshes better with the bytecode compiler.) .PP Note that a newly created \fBTcl_Obj\fR may be passed @@ -159,33 +154,30 @@ to any reference counting. This is analogous to \fBTcl_SetObjResult\fR. .PP While \fBTcl_SetReturnOptions\fR provides a general interface to set any collection of return options, there are a handful -of return options that are very frequently used. Most +of return options that are very frequently used. Most notably the \fB\-errorinfo\fR and \fB\-errorcode\fR return options should be set properly when the command procedure -of a command returns \fBTCL_ERROR\fR. The \fB\-errorline\fR -return option is also read by commands that evaluate scripts -and wish to supply detailed error location information in -the stack trace text they append to the \fB\-errorinfo\fR option. -Tcl provides several simpler interfaces to more directly set -these return options. +of a command returns \fBTCL_ERROR\fR. Tcl provides several +simpler interfaces to more directly set these return options. +.VE 8.5 .PP The \fB\-errorinfo\fR option holds a stack trace of the operations that were in progress when an error occurred, and is intended to be human-readable. -The \fB\-errorcode\fR option holds a Tcl list of items that +The \fB\-errorcode\fR option holds a list of items that are intended to be machine-readable. The first item in the \fB\-errorcode\fR value identifies the class of error that occurred -(e.g., POSIX means an error occurred in a POSIX system call) +(e.g. POSIX means an error occurred in a POSIX system call) and additional elements hold additional pieces of information that depend on the class. -See the manual entry on the \fBerrorCode\fR variable for details on the -various formats for the \fB\-errorcode\fR option used by Tcl's built-in -commands. +See the tclvars manual entry for details on the various +formats for the \fB\-errorcode\fR option used by +Tcl's built-in commands. .PP The \fB\-errorinfo\fR option value is gradually built up as an error unwinds through the nested operations. Each time an error code is returned to \fBTcl_Eval\fR, or any of the routines that performs script evaluation, @@ -213,42 +205,42 @@ a script evaluation routine has returned \fBTCL_ERROR\fR. The value of the \fB\-errorline\fR return option (retrieved via a call to \fBTcl_GetReturnOptions\fR) often makes up a useful part of the \fImessage\fR passed to \fBTcl_AddErrorInfo\fR. .PP +.VS 8.5 \fBTcl_AppendObjToErrorInfo\fR is an alternative interface to the same functionality as \fBTcl_AddErrorInfo\fR. \fBTcl_AppendObjToErrorInfo\fR is called when the string value to be appended to the \fB\-errorinfo\fR option is available as a \fBTcl_Obj\fR instead of as a \fBchar\fR array. +.VE 8.5 .PP \fBTcl_AddObjErrorInfo\fR is nearly identical to \fBTcl_AddErrorInfo\fR, except that it has an additional \fIlength\fR -argument. This allows the \fImessage\fR string to contain +argument. This allows the \fImessage\fR string to contain embedded null bytes. This is essentially never a good idea. If the \fImessage\fR needs to contain the null character \fBU+0000\fR, Tcl's usual internal encoding rules should be used to avoid the need for a null byte. If the \fBTcl_AddObjErrorInfo\fR interface is used at all, it should be with a negative \fIlength\fR value. .PP The procedure \fBTcl_SetObjErrorCode\fR is used to set the -\fB\-errorcode\fR return option to the list value \fIerrorObjPtr\fR -built up by the caller. -\fBTcl_SetObjErrorCode\fR is typically invoked just +\fB\-errorcode\fR return option to the list object \fIerrorObjPtr\fR +built up by the caller. +\fBTcl_SetObjErrorCode\fR is typically invoked just before returning an error. If an error is returned without calling \fBTcl_SetObjErrorCode\fR or \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 +record instead of an object. 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. +\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. .PP \fBTcl_PosixError\fR sets the \fB\-errorcode\fR variable after an error in a POSIX kernel call. It reads the value of the \fBerrno\fR C variable and calls \fBTcl_SetErrorCode\fR to set the \fB\-errorcode\fR return @@ -268,11 +260,11 @@ the interpreter's result. .PP \fBTcl_LogCommandInfo\fR is invoked after an error occurs in an interpreter. It adds information about the command that was being executed when the error occurred to the \fB\-errorinfo\fR value, and -the line number stored internally in the interpreter is set. +the line number stored internally in the interpreter is set. .PP In older releases of Tcl, there was no \fBTcl_GetReturnOptions\fR routine. In its place, the global Tcl variables \fBerrorInfo\fR and \fBerrorCode\fR were the only place to retrieve the error information. Much existing code written for older Tcl releases @@ -281,27 +273,28 @@ It is important to realize that while reading from those global variables remains a supported way to access these return option values, it is important not to assume that writing to those global variables will properly set the corresponding return options. It has long been emphasized -in this manual page that it is important to +in this manual page that it is important to call the procedures described here rather than setting \fBerrorInfo\fR or \fBerrorCode\fR directly with \fBTcl_ObjSetVar2\fR. .PP If the procedure \fBTcl_ResetResult\fR is called, it clears all of the state of the interpreter associated with script evaluation, including the entire return options dictionary. In particular, the \fB\-errorinfo\fR and \fB\-errorcode\fR options -are reset. +are reset. If an error had occurred, the \fBTcl_ResetResult\fR call will clear the error state to make it appear as if no error had occurred after all. The global variables \fBerrorInfo\fR and \fBerrorCode\fR are not modified by \fBTcl_ResetResult\fR so they continue to hold a record of information about the most recent error seen in an interpreter. + .SH "SEE ALSO" -Tcl_DecrRefCount(3), Tcl_IncrRefCount(3), Tcl_Interp(3), Tcl_ResetResult(3), -Tcl_SetErrno(3), errorCode(n), errorInfo(n) +Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_Interp, Tcl_ResetResult, Tcl_SetErrno + .SH KEYWORDS -error, value, value result, stack, trace, variable +error, object, object result, stack, trace, variable Index: doc/Alloc.3 ================================================================== --- doc/Alloc.3 +++ doc/Alloc.3 @@ -6,11 +6,11 @@ '\" .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 \- allocate or free heap memory +Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc, Tcl_GetMemoryInfo, ckalloc, ckfree, ckrealloc, attemptckalloc, attemptckrealloc \- allocate or free heap memory .SH SYNOPSIS .nf \fB#include \fR .sp char * @@ -17,24 +17,44 @@ \fBTcl_Alloc\fR(\fIsize\fR) .sp void \fBTcl_Free\fR(\fIptr\fR) .sp -void * +char * \fBTcl_Realloc\fR(\fIptr, size\fR) .sp -void * +char * \fBTcl_AttemptAlloc\fR(\fIsize\fR) .sp -void * +char * \fBTcl_AttemptRealloc\fR(\fIptr, size\fR) +.sp +void +\fBTcl_GetMemoryInfo\fR(\fIdsPtr\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. +.AP Tcl_DString *dsPtr in +Initialized DString pointer. .BE .SH DESCRIPTION .PP These procedures provide a platform and compiler independent interface @@ -62,12 +82,20 @@ 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 -When a module or Tcl itself is compiled with \fBTCL_MEM_DEBUG\fR defined, -the procedures \fBTcl_Alloc\fR, \fBTcl_Free\fR, \fBTcl_Realloc\fR, -\fBTcl_AttemptAlloc\fR, and \fBTcl_AttempRealloc\fR are implemented -as macros, redefined to be special debugging versions of these procedures. +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. + +\fBTcl_GetMemoryInfo\fR appends a list-of-lists of memory stats to the +provided DString. This function cannot be used in stub-enabled extensions, +and it is only available if Tcl is compiled with the threaded memory allocator. .SH KEYWORDS alloc, allocation, free, malloc, memory, realloc, TCL_MEM_DEBUG Index: doc/AllowExc.3 ================================================================== --- doc/AllowExc.3 +++ doc/AllowExc.3 @@ -2,11 +2,11 @@ '\" 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_AllowExceptions 3 7.4 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_AllowExceptions \- allow all exceptions in next script evaluation @@ -28,11 +28,12 @@ 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 and \fBTcl_VarEval\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. Index: doc/AppInit.3 ================================================================== --- doc/AppInit.3 +++ doc/AppInit.3 @@ -2,11 +2,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_AppInit 3 7.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_AppInit \- perform application-specific initialization @@ -46,27 +46,20 @@ .IP [2] Process command-line arguments, which can be accessed from the Tcl variables \fBargv\fR and \fBargv0\fR in \fIinterp\fR. .IP [3] Invoke a startup script to initialize the application. -.IP [4] -Use the routines \fBTcl_SetStartupScript\fR and -\fBTcl_GetStartupScript\fR to set or query the file and encoding -that the active \fBTcl_Main\fR or \fBTk_Main\fR routine will -use as a startup script. .LP \fBTcl_AppInit\fR returns \fBTCL_OK\fR or \fBTCL_ERROR\fR. If it returns \fBTCL_ERROR\fR then it must leave an error message in for the interpreter's result; otherwise the result is ignored. .PP In addition to \fBTcl_AppInit\fR, your application should also contain a procedure \fBmain\fR that calls \fBTcl_Main\fR as follows: -.PP .CS Tcl_Main(argc, argv, Tcl_AppInit); .CE -.PP The third argument to \fBTcl_Main\fR gives the address of the application-specific initialization procedure to invoke. This means that you do not have to use the name \fBTcl_AppInit\fR for the procedure, but in practice the name is nearly always \fBTcl_AppInit\fR (in versions before Tcl 7.4 the name \fBTcl_AppInit\fR @@ -74,10 +67,7 @@ The best way to get started is to make a copy of the file \fBtclAppInit.c\fR from the Tcl library or source directory. It already contains a \fBmain\fR procedure and a template for \fBTcl_AppInit\fR that you can modify for your application. -.SH "SEE ALSO" -Tcl_Main(3) - .SH KEYWORDS application, argument, command, initialization, interpreter Index: doc/AssocData.3 ================================================================== --- doc/AssocData.3 +++ doc/AssocData.3 @@ -1,21 +1,21 @@ '\" '\" 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_SetAssocData 3 7.5 Tcl "Tcl Library Procedures" .so man.macros .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 \fR .sp -void * +ClientData \fBTcl_GetAssocData\fR(\fIinterp, key, delProcPtr\fR) .sp \fBTcl_SetAssocData\fR(\fIinterp, key, delProc, clientData\fR) .sp \fBTcl_DeleteAssocData\fR(\fIinterp, key\fR) @@ -29,11 +29,11 @@ .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 void *clientData in +.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 @@ -59,17 +59,15 @@ for example, by using package names as the keys. 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( - void *\fIclientData\fR, +typedef void Tcl_InterpDeleteProc( + 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 is deleted before the interpreter is deleted. Index: doc/Async.3 ================================================================== --- doc/Async.3 +++ doc/Async.3 @@ -2,11 +2,11 @@ '\" 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_AsyncCreate 3 7.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_AsyncCreate, Tcl_AsyncMark, Tcl_AsyncInvoke, Tcl_AsyncDelete, Tcl_AsyncReady \- handle asynchronous events @@ -28,11 +28,11 @@ \fBTcl_AsyncReady\fR() .SH ARGUMENTS .AS Tcl_AsyncHandler clientData .AP Tcl_AsyncProc *proc in Procedure to invoke to handle an asynchronous event. -.AP void *clientData in +.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 @@ -79,18 +79,16 @@ Tcl will call the \fIproc\fR associated with the handler later, when 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( - void *\fIclientData\fR, +typedef int Tcl_AsyncProc( + 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. If \fIproc\fR is invoked just after a command has completed execution in an interpreter, then \fIinterp\fR will identify Index: doc/BackgdErr.3 ================================================================== --- doc/BackgdErr.3 +++ doc/BackgdErr.3 @@ -2,77 +2,60 @@ '\" Copyright (c) 1992-1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Tcl_BackgroundError 3 7.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_BackgroundException, Tcl_BackgroundError \- report Tcl exception that occurred in background processing +Tcl_BackgroundError \- report Tcl error that occurred in background processing .SH SYNOPSIS .nf \fB#include \fR .sp -\fBTcl_BackgroundException\fR(\fIinterp, code\fR) -.sp \fBTcl_BackgroundError\fR(\fIinterp\fR) .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in -Interpreter in which the exception occurred. -.AP int code in -The exceptional return code to be reported. +Interpreter in which the error occurred. .BE .SH DESCRIPTION .PP -This procedure is typically invoked when a Tcl exception (any -return code other than TCL_OK) occurs during +This procedure is typically invoked when a Tcl error occurs during .QW "background processing" such as executing an event handler. -When such an exception occurs, the condition is reported to Tcl +When such an error occurs, the error condition is reported to Tcl or to a widget or some other C code, and there is not usually any -obvious way for that code to report the exception to the user. -In these cases the code calls \fBTcl_BackgroundException\fR with an +obvious way for that code to report the error to the user. +In these cases the code calls \fBTcl_BackgroundError\fR with an \fIinterp\fR argument identifying the interpreter in which the -exception occurred, and a \fIcode\fR argument holding the return -code value of the exception. The state of the interpreter, including -any error message in the interpreter result, and the values of -any entries in the return options dictionary, is captured and -saved. \fBTcl_BackgroundException\fR then arranges for the event -loop to invoke at some later time the command registered +error occurred. At the time \fBTcl_BackgroundError\fR is invoked, +the interpreter's result is expected to contain an error message. +\fBTcl_BackgroundError\fR will invoke the command registered in that interpreter to handle background errors by the -\fBinterp bgerror\fR command, passing the captured values as -arguments. -The registered handler command is meant to report the exception +\fBinterp bgerror\fR command. +The registered handler command is meant to report the error in an application-specific fashion. The handler command receives two arguments, the result of the interp, and the return options of the interp at the time the error occurred. If the application registers no handler command, the default handler command will attempt to call \fBbgerror\fR to report the error. If an error condition arises while invoking the -handler command, then \fBTcl_BackgroundException\fR reports the +handler command, then \fBTcl_BackgroundError\fR reports the error itself by printing a message on the standard error file. .PP -\fBTcl_BackgroundException\fR does not invoke the handler command immediately +\fBTcl_BackgroundError\fR does not invoke the handler command immediately because this could potentially interfere with scripts that are in process at the time the error occurred. Instead, it invokes the handler command later as an idle callback. .PP -It is possible for many background exceptions to accumulate before -the handler command is invoked. When this happens, each of the exceptions -is processed in order. However, if the handler command returns a +It is possible for many background errors to accumulate before +the handler command is invoked. When this happens, each of the errors +is processed in order. However, if the handle command returns a break exception, then all remaining error reports for the interpreter are skipped. -.PP -The \fBTcl_BackgroundError\fR routine is an older and simpler interface -useful when the exception code reported is \fBTCL_ERROR\fR. It is -equivalent to: -.PP -.CS -Tcl_BackgroundException(interp, TCL_ERROR); -.CE .SH KEYWORDS background, bgerror, error, interp ADDED doc/Backslash.3 Index: doc/Backslash.3 ================================================================== --- /dev/null +++ doc/Backslash.3 @@ -0,0 +1,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 \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 Index: doc/BoolObj.3 ================================================================== --- doc/BoolObj.3 +++ doc/BoolObj.3 @@ -2,11 +2,11 @@ '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" Contributions from Don Porter, NIST, 2005. (not subject to US copyright) '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Tcl_BooleanObj 3 8.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_NewBooleanObj, Tcl_SetBooleanObj, Tcl_GetBooleanFromObj \- store/retrieve boolean value in a Tcl_Obj @@ -28,11 +28,11 @@ .AP Tcl_Obj *objPtr in/out Points to the Tcl_Obj in which to store, or from which to retrieve a boolean value. .AP Tcl_Interp *interp in/out If a boolean value cannot be retrieved, -an error message is left in the interpreter's result value +an error message is left in the interpreter's result object unless \fIinterp\fR is NULL. .AP int *boolPtr out Points to place where \fBTcl_GetBooleanFromObj\fR stores the boolean value (0 or 1) obtained from \fIobjPtr\fR. .BE @@ -48,11 +48,11 @@ \fBTcl_NewBooleanObj\fR creates a new Tcl_Obj, stores the boolean value \fIboolValue\fR in it, and returns a pointer to the new Tcl_Obj. The new Tcl_Obj has reference count of zero. .PP \fBTcl_SetBooleanObj\fR accepts \fIobjPtr\fR, a pointer to -an existing Tcl_Obj, and stores in the Tcl_Obj \fI*objPtr\fR +an existing Tcl_Obj, and stores in the Tcl_Obj \fI*objPtr\fR the boolean value \fIboolValue\fR. This is a write operation on \fI*objPtr\fR, so \fIobjPtr\fR must be unshared. Attempts to write to a shared Tcl_Obj will panic. A successful write of \fIboolValue\fR into \fI*objPtr\fR implies the freeing of any former value stored in \fI*objPtr\fR. @@ -59,22 +59,22 @@ .PP \fBTcl_GetBooleanFromObj\fR attempts to retrieve a boolean value from the value stored in \fI*objPtr\fR. If \fIobjPtr\fR holds a string value recognized by \fBTcl_GetBoolean\fR, then the recognized boolean value is written at the address given -by \fIboolPtr\fR. +by \fIboolPtr\fR. If \fIobjPtr\fR holds any value recognized as a number by Tcl, then if that value is zero a 0 is written at the address given by \fIboolPtr\fR and if that value is non-zero a 1 is written at the address given by \fIboolPtr\fR. In all cases where a value is written at the address given by \fIboolPtr\fR, \fBTcl_GetBooleanFromObj\fR returns \fBTCL_OK\fR. If the value of \fIobjPtr\fR does not meet any of the conditions -above, then \fBTCL_ERROR\fR is returned and an error message is +above, then \fBTCL_ERROR\fR is returned and an error message is left in the interpreter's result unless \fIinterp\fR is NULL. \fBTcl_GetBooleanFromObj\fR may also make changes to the internal -fields of \fI*objPtr\fR so that future calls to +fields of \fI*objPtr\fR so that future calls to \fBTcl_GetBooleanFromObj\fR on the same \fIobjPtr\fR can be performed more efficiently. .PP Note that the routines \fBTcl_GetBooleanFromObj\fR and \fBTcl_GetBoolean\fR are not functional equivalents. @@ -90,6 +90,6 @@ .SH "SEE ALSO" Tcl_NewObj, Tcl_IsShared, Tcl_GetBoolean .SH KEYWORDS -boolean, value +boolean, object Index: doc/ByteArrObj.3 ================================================================== --- doc/ByteArrObj.3 +++ doc/ByteArrObj.3 @@ -1,24 +1,24 @@ '\" '\" 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_ByteArrayObj 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_NewByteArrayObj, Tcl_SetByteArrayObj, Tcl_GetByteArrayFromObj, Tcl_SetByteArrayLength \- manipulate Tcl values as a arrays of bytes +Tcl_NewByteArrayObj, Tcl_SetByteArrayObj, Tcl_GetByteArrayFromObj, Tcl_SetByteArrayLength \- manipulate Tcl objects as a arrays of bytes .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_Obj * \fBTcl_NewByteArrayObj\fR(\fIbytes, length\fR) .sp -void +void \fBTcl_SetByteArrayObj\fR(\fIobjPtr, bytes, length\fR) .sp unsigned char * \fBTcl_GetByteArrayFromObj\fR(\fIobjPtr, lengthPtr\fR) .sp @@ -25,67 +25,65 @@ 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 size_t length in -The length of the array of bytes. +The array of bytes used to initialize or set a byte-array object. +.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 +For \fBTcl_SetByteArrayObj\fR, this points to the object to be converted to byte-array type. For \fBTcl_GetByteArrayFromObj\fR and -\fBTcl_SetByteArrayLength\fR, this points to the value from which to get +\fBTcl_SetByteArrayLength\fR, this points to the object 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. +object, it will be converted to one. .AP int *lengthPtr out -If non-NULL, filled with the length of the array of bytes in the value. +If non-NULL, filled with the length of the array of bytes in the object. .BE .SH DESCRIPTION .PP -These procedures are used to create, modify, and read Tcl byte-array values -from C code. Byte-array values are typically used to hold the +These procedures are used to create, modify, and read Tcl byte-array objects +from C code. Byte-array objects are typically used to hold the results of binary IO operations or data structures created with the \fBbinary\fR command. In Tcl, an array of bytes is not equivalent to a string. Conceptually, a string is an array of Unicode characters, while a byte-array is an array of 8-bit quantities with no implicit meaning. Accessor functions are provided to get the string representation of a -byte-array or to convert an arbitrary value to a byte-array. Obtaining the -string representation of a byte-array value (by calling +byte-array or to convert an arbitrary object to a byte-array. Obtaining the +string representation of a byte-array object (by calling \fBTcl_GetStringFromObj\fR) produces a properly formed UTF-8 sequence with a one-to-one mapping between the bytes in the internal representation and the -UTF-8 characters in the string representation. +UTF-8 characters in the string representation. .PP \fBTcl_NewByteArrayObj\fR and \fBTcl_SetByteArrayObj\fR will -create a new value of byte-array type or modify an existing value to have a -byte-array type. Both of these procedures set the value's type to be -byte-array and set the value's internal representation to a copy of the +create a new object of byte-array type or modify an existing object to have a +byte-array type. Both of these procedures set the object's type to be +byte-array and set the object's internal representation to a copy of the array of bytes given by \fIbytes\fR. \fBTcl_NewByteArrayObj\fR returns a -pointer to a newly allocated value with a reference count of zero. +pointer to a newly allocated object with a reference count of zero. \fBTcl_SetByteArrayObj\fR invalidates any old string representation and, if -the value is not already a byte-array value, frees any old internal -representation. If \fIbytes\fR is NULL then the new byte array contains -arbitrary values. +the object is not already a byte-array object, frees any old internal +representation. .PP -\fBTcl_GetByteArrayFromObj\fR converts a Tcl value to byte-array type and -returns a pointer to the value's new internal representation as an array of +\fBTcl_GetByteArrayFromObj\fR converts a Tcl object to byte-array type and +returns a pointer to the object's new internal representation as an array of bytes. The length of this array is stored in \fIlengthPtr\fR if \fIlengthPtr\fR is non-NULL. The storage for the array of bytes is owned by -the value and should not be freed. The contents of the array may be -modified by the caller only if the value is not shared and the caller -invalidates the string representation. +the object and should not be freed. The contents of the array may be +modified by the caller only if the object is not shared and the caller +invalidates the string representation. .PP -\fBTcl_SetByteArrayLength\fR converts the Tcl value to byte-array type -and changes the length of the value's internal representation as an +\fBTcl_SetByteArrayLength\fR converts the Tcl object to byte-array type +and changes the length of the object's internal representation as an array of bytes. If \fIlength\fR is greater than the space currently allocated for the array, the array is reallocated to the new length; the newly allocated bytes at the end of the array have arbitrary values. If \fIlength\fR is less than the space currently allocated for the array, the length of array is reduced to the new length. The return value is a -pointer to the value's new array of bytes. +pointer to the object's new array of bytes. .SH "SEE ALSO" Tcl_GetStringFromObj, Tcl_NewObj, Tcl_IncrRefCount, Tcl_DecrRefCount .SH KEYWORDS -value, binary data, byte array, utf, unicode, internationalization +object, byte array, utf, unicode, internationalization Index: doc/CallDel.3 ================================================================== --- doc/CallDel.3 +++ doc/CallDel.3 @@ -2,11 +2,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_CallWhenDeleted 3 7.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_CallWhenDeleted, Tcl_DontCallWhenDeleted \- Arrange for callback when interpreter is deleted @@ -21,29 +21,28 @@ .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 void *clientData in +.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( - void *\fIclientData\fR, +typedef void Tcl_InterpDeleteProc( + 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 data structure that \fIproc\fR uses to perform cleanup when an @@ -55,13 +54,8 @@ \fIproc\fR will not be called after all when \fIinterp\fR is deleted. If there is no deletion callback that matches \fIinterp\fR, \fIproc\fR, and \fIclientData\fR then the call to \fBTcl_DontCallWhenDeleted\fR has no effect. -.PP -Note that if the callback is being used to delete a resource that \fImust\fR -be released on exit, \fBTcl_CreateExitHandler\fR should be used to ensure that -a callback is received even if the application terminates without deleting the interpreter. -.SH "SEE ALSO" -Tcl_CreateExitHandler(3), Tcl_CreateThreadExitHandler(3) + .SH KEYWORDS -callback, cleanup, delete, interpreter +callback, delete, interpreter DELETED doc/Cancel.3 Index: doc/Cancel.3 ================================================================== --- doc/Cancel.3 +++ /dev/null @@ -1,74 +0,0 @@ -'\" -'\" Copyright (c) 2006-2008 Joe Mistachkin. -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH Tcl_Cancel 3 8.6 Tcl "Tcl Library Procedures" -.so man.macros -.BS -.SH NAME -Tcl_CancelEval, Tcl_Canceled \- cancel Tcl scripts -.SH SYNOPSIS -.nf -\fB#include \fR -int -\fBTcl_CancelEval\fR(\fIinterp, resultObjPtr, clientData, flags\fR) -.sp -int -\fBTcl_Canceled\fR(\fIinterp, flags\fR) -.SH ARGUMENTS -.AS Tcl_Interp *interp -.AP Tcl_Interp *interp in -Interpreter in which to cancel the script. -.AP Tcl_Obj *resultObjPtr in -Error message to use in the cancellation, or NULL to use a default message. If -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 void *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 -the return code for that script. This function is thread-safe and may be -called from any thread in the process. -.PP -\fBTcl_Canceled\fR checks if the script in progress has been canceled and -returns \fBTCL_ERROR\fR if it has. Otherwise, \fBTCL_OK\fR is returned. -Extensions can use this function to check to see if they should abort a long -running command. This function is thread sensitive and may only be called -from the thread the interpreter was created in. -.SS "FLAG BITS" -Any ORed combination of the following values may be used for the -\fIflags\fR argument to procedures such as \fBTcl_CancelEval\fR: -.TP 20 -\fBTCL_CANCEL_UNWIND\fR -. -This flag is used by \fBTcl_CancelEval\fR and \fBTcl_Canceled\fR. -For \fBTcl_CancelEval\fR, if this flag is set, the script in progress -is canceled and the evaluation stack for the interpreter is unwound. -For \fBTcl_Canceled\fR, if this flag is set, the script in progress -is considered to be canceled only if the evaluation stack for the -interpreter is being unwound. -.TP 20 -\fBTCL_LEAVE_ERR_MSG\fR -. -This flag is only used by \fBTcl_Canceled\fR; it is ignored by -other procedures. If an error is returned and this bit is set in -\fIflags\fR, then an error message will be left in the interpreter's -result, where it can be retrieved with \fBTcl_GetObjResult\fR or -\fBTcl_GetStringResult\fR. If this flag bit is not set then no error -message is left and the interpreter's result will not be modified. -.SH "SEE ALSO" -interp(n), Tcl_Eval(3), -TIP 285 -.SH KEYWORDS -cancel, unwind Index: doc/ChnlStack.3 ================================================================== --- doc/ChnlStack.3 +++ doc/ChnlStack.3 @@ -28,13 +28,13 @@ .sp .SH ARGUMENTS .AS Tcl_ChannelType clientData .AP Tcl_Interp *interp in Interpreter for error reporting. -.AP "const Tcl_ChannelType" *typePtr in +.AP Tcl_ChannelType *typePtr in The new channel I/O procedures to use for \fIchannel\fR. -.AP void *clientData in +.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. @@ -47,12 +47,15 @@ These functions are for use by extensions that add processing layers to Tcl I/O channels. Examples include compression and encryption modules. These functions transparently stack and unstack a new channel on top of an existing one. Any number of channels can be stacked together. .PP -The \fBTcl_ChannelType\fR version currently supported is -\fBTCL_CHANNEL_VERSION_5\fR. See \fBTcl_CreateChannel\fR for details. +The implementation of the Tcl channel code was rewritten in 8.3.2 to +correct some problems with the previous implementation with regard to +stacked channels. Anyone using stacked channels or creating stacked +channel drivers should update to the new \fBTCL_CHANNEL_VERSION_2\fR +\fBTcl_ChannelType\fR structure. See \fBTcl_CreateChannel\fR for details. .PP \fBTcl_StackChannel\fR stacks a new \fIchannel\fR on an existing channel with the same name that was registered for \fIchannel\fR by \fBTcl_RegisterChannel\fR. .PP DELETED doc/Class.3 Index: doc/Class.3 ================================================================== --- doc/Class.3 +++ /dev/null @@ -1,251 +0,0 @@ -'\" -'\" Copyright (c) 2007 Donal K. Fellows -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH Tcl_Class 3 0.1 TclOO "TclOO Library Functions" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -Tcl_ClassGetMetadata, Tcl_ClassSetMetadata, Tcl_CopyObjectInstance, Tcl_GetClassAsObject, Tcl_GetObjectAsClass, Tcl_GetObjectCommand, Tcl_GetObjectFromObj, Tcl_GetObjectName, Tcl_GetObjectNamespace, Tcl_NewObjectInstance, Tcl_ObjectDeleted, Tcl_ObjectGetMetadata, Tcl_ObjectGetMethodNameMapper, Tcl_ObjectSetMetadata, Tcl_ObjectSetMethodNameMapper \- manipulate objects and classes -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -Tcl_Object -\fBTcl_GetObjectFromObj\fR(\fIinterp, objPtr\fR) -.sp -Tcl_Object -\fBTcl_GetClassAsObject\fR(\fIclass\fR) -.sp -Tcl_Class -\fBTcl_GetObjectAsClass\fR(\fIobject\fR) -.sp -Tcl_Obj * -\fBTcl_GetObjectName\fR(\fIinterp, object\fR) -.sp -Tcl_Command -\fBTcl_GetObjectCommand\fR(\fIobject\fR) -.sp -Tcl_Namespace * -\fBTcl_GetObjectNamespace\fR(\fIobject\fR) -.sp -Tcl_Object -\fBTcl_NewObjectInstance\fR(\fIinterp, class, name, nsName, objc, objv, skip\fR) -.sp -Tcl_Object -\fBTcl_CopyObjectInstance\fR(\fIinterp, object, name, nsName\fR) -.sp -int -\fBTcl_ObjectDeleted\fR(\fIobject\fR) -.sp -void * -\fBTcl_ObjectGetMetadata\fR(\fIobject, metaTypePtr\fR) -.sp -\fBTcl_ObjectSetMetadata\fR(\fIobject, metaTypePtr, metadata\fR) -.sp -void * -\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 void *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. -.AP Tcl_Class class in -Reference to the class to operate upon. -.AP "const char" *name in -The name of the object to create, or NULL if a new unused name is to be -automatically selected. -.AP "const char" *nsName in -The name of the namespace to create for the object's private use, or NULL if a -new unused name is to be automatically selected. The namespace must not -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 void *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 -.PP -Objects are typed entities that have a set of operations ("methods") -associated with them. Classes are objects that can manufacture objects. Each -class can be viewed as an object itself; the object view can be retrieved -using \fBTcl_GetClassAsObject\fR which always returns the object when applied -to a non-destroyed class, and an object can be viewed as a class with the aid -of the \fBTcl_GetObjectAsClass\fR (which either returns the class, or NULL if -the object is not a class). An object may be looked up using the -\fBTcl_GetObjectFromObj\fR function, which either returns an object or NULL -(with an error message in the interpreter result) if the object cannot be -found. The correct way to look up a class by name is to look up the object -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 -argument) that are given to \fBTcl_ObjectSetMetadata\fR and -\fBTcl_ClassSetMetadata\fR, and a particular piece of metadata can be -retrieved given its type using \fBTcl_ObjectGetMetadata\fR and -\fBTcl_ClassGetMetadata\fR. If the \fImetadata\fR parameter to either -\fBTcl_ObjectSetMetadata\fR or \fBTcl_ClassSetMetadata\fR is NULL, the -metadata is removed if it was attached, and the results of -\fBTcl_ObjectGetMetadata\fR and \fBTcl_ClassGetMetadata\fR are NULL if the -given type of metadata was not attached. It is not an error to request or -remove a piece of metadata that was not attached. -.SS "TCL_OBJECTMETADATATYPE STRUCTURE" -.PP -The contents of the Tcl_ObjectMetadataType structure are as follows: -.PP -.CS -typedef const struct { - int \fIversion\fR; - const char *\fIname\fR; - Tcl_ObjectMetadataDeleteProc *\fIdeleteProc\fR; - Tcl_CloneProc *\fIcloneProc\fR; -} \fBTcl_ObjectMetadataType\fR; -.CE -.PP -The \fIversion\fR field allows for future expansion of the structure, and -should always be declared equal to TCL_OO_METADATA_VERSION_CURRENT. The -\fIname\fR field provides a human-readable name for the type, and is reserved -for debugging. -.PP -The \fIdeleteProc\fR field gives a function of type -Tcl_ObjectMetadataDeleteProc that is used to delete a particular piece of -metadata, and is called when the attached metadata is replaced or removed; the -field must not be NULL. -.PP -The \fIcloneProc\fR field gives a function that is used to copy a piece of -metadata (used when a copy of an object is created using -\fBTcl_CopyObjectInstance\fR); if NULL, the metadata will be just directly -copied. -.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( - void *\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, - void *\fIsrcMetadata\fR, - void **\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 -\fIdstMetadataPtr\fR; a NULL should be written if the metadata is to not be -cloned but the overall object copy operation is still to succeed. -.SH "OBJECT METHOD NAME MAPPING" -It is possible to control, on a per-object basis, what methods are invoked -when a particular method is invoked. Normally this is done by looking up the -method name in the object and then in the class hierarchy, but fine control of -exactly what the value used to perform the look up is afforded through the -ability to set a method name mapper callback via -\fBTcl_ObjectSetMethodNameMapper\fR (and its introspection counterpart, -\fBTcl_ObjectGetMethodNameMapper\fR, which returns the current mapper). The -current mapper (if any) is invoked immediately before looking up what chain of -method implementations is to be used. -.SS "TCL_OBJECTMAPMETHODNAMEPROC FUNCTION SIGNATURE" -The \fITcl_ObjectMapMethodNameProc\fR callback is defined as follows: -.PP -.CS -typedef int \fBTcl_ObjectMapMethodNameProc\fR( - Tcl_Interp *\fIinterp\fR, - Tcl_Object \fIobject\fR, - Tcl_Class *\fIstartClsPtr\fR, - Tcl_Obj *\fImethodNameObj\fR); -.CE -.PP -If the result is TCL_OK, the remapping is assumed to have been done. If the -result is TCL_ERROR, an error message will have been left in \fIinterp\fR and -the method call will fail. If the result is TCL_BREAK, the standard method -name lookup rules will be used; the behavior of other result codes is -currently undefined. The \fIobject\fR parameter says which object is being -processed. The \fIstartClsPtr\fR parameter points to a variable that contains -the first class to provide a definition in the method chain to process, or -NULL if the whole chain is to be processed (the argument itself is never -NULL); this variable may be updated by the callback. The \fImethodNameObj\fR -parameter gives an unshared object containing the name of the method being -invoked, as provided by the user; this object may be updated by the callback. -.SH "SEE ALSO" -Method(3), oo::class(n), oo::copy(n), oo::define(n), oo::object(n) -.SH KEYWORDS -class, constructor, object -.\" Local variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: Index: doc/CmdCmplt.3 ================================================================== --- doc/CmdCmplt.3 +++ doc/CmdCmplt.3 @@ -2,11 +2,11 @@ '\" 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_CommandComplete 3 "" Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_CommandComplete \- Check for unmatched braces in a Tcl command Index: doc/Concat.3 ================================================================== --- doc/Concat.3 +++ doc/Concat.3 @@ -2,11 +2,11 @@ '\" 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_Concat 3 7.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_Concat \- concatenate a collection of strings DELETED doc/CrtAlias.3 Index: doc/CrtAlias.3 ================================================================== --- doc/CrtAlias.3 +++ /dev/null @@ -1,236 +0,0 @@ -'\" -'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH Tcl_CreateAlias 3 7.6 Tcl "Tcl Library Procedures" -.so man.macros -.BS -.SH NAME -Tcl_IsSafe, Tcl_MakeSafe, Tcl_CreateChild, Tcl_GetChild, Tcl_GetParent, Tcl_GetInterpPath, Tcl_CreateAlias, Tcl_CreateAliasObj, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_ExposeCommand, Tcl_HideCommand \- manage multiple Tcl interpreters, aliases and hidden commands -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -int -\fBTcl_IsSafe\fR(\fIinterp\fR) -.sp -int -\fBTcl_MakeSafe\fR(\fIinterp\fR) -.sp -Tcl_Interp * -\fBTcl_CreateChild\fR(\fIinterp, name, isSafe\fR) -.sp -Tcl_Interp * -\fBTcl_GetChild\fR(\fIinterp, name\fR) -.sp -Tcl_Interp * -\fBTcl_GetParent\fR(\fIinterp\fR) -.sp -int -\fBTcl_GetInterpPath\fR(\fIinterp, childInterp\fR) -.sp -int -\fBTcl_CreateAlias\fR(\fIchildInterp, childCmd, targetInterp, targetCmd, - argc, argv\fR) -.sp -int -\fBTcl_CreateAliasObj\fR(\fIchildInterp, childCmd, targetInterp, targetCmd, - objc, objv\fR) -.sp -int -\fBTcl_GetAlias\fR(\fIinterp, childCmd, targetInterpPtr, targetCmdPtr, - argcPtr, argvPtr\fR) -.sp -int -\fBTcl_GetAliasObj\fR(\fIinterp, childCmd, targetInterpPtr, targetCmdPtr, - objcPtr, objvPtr\fR) -.sp -int -\fBTcl_ExposeCommand\fR(\fIinterp, hiddenCmdName, cmdName\fR) -.sp -int -\fBTcl_HideCommand\fR(\fIinterp, cmdName, hiddenCmdName\fR) -.SH ARGUMENTS -.AS "const char *const" **targetInterpPtr out -.AP Tcl_Interp *interp in -Interpreter in which to execute the specified command. -.AP "const char" *name in -Name of child interpreter to create or manipulate. -.AP int isSafe in -If non-zero, a -.QW safe -child that is suitable for running untrusted code -is created, otherwise a trusted child is created. -.AP Tcl_Interp *childInterp in -Interpreter to use for creating the source command for an alias (see -below). -.AP "const char" *childCmd in -Name of source command for alias. -.AP Tcl_Interp *targetInterp in -Interpreter that contains the target command for an alias. -.AP "const char" *targetCmd in -Name of target command for alias in \fItargetInterp\fR. -.AP int argc in -Count of additional arguments to pass to the alias command. -.AP "const char *const" *argv in -Vector of strings, the additional arguments to pass to the alias command. -This storage is owned by the caller. -.AP int objc in -Count of additional value arguments to pass to the aliased command. -.AP Tcl_Obj **objv in -Vector of Tcl_Obj structures, the additional value arguments to pass to -the aliased command. -This storage is owned by the caller. -.AP Tcl_Interp **targetInterpPtr in -Pointer to location to store the address of the interpreter where a target -command is defined for an alias. -.AP "const char" **targetCmdPtr out -Pointer to location to store the address of the name of the target command -for an alias. -.AP int *argcPtr out -Pointer to location to store count of additional arguments to be passed to -the alias. The location is in storage owned by the caller. -.AP "const char" ***argvPtr out -Pointer to location to store a vector of strings, the additional arguments -to pass to an alias. The location is in storage owned by the caller, the -vector of strings is owned by the called function. -.AP int *objcPtr out -Pointer to location to store count of additional value arguments to be -passed to the alias. The location is in storage owned by the caller. -.AP Tcl_Obj ***objvPtr out -Pointer to location to store a vector of Tcl_Obj structures, the additional -arguments to pass to an alias command. The location is in storage -owned by the caller, the vector of Tcl_Obj structures is owned by the -called function. -.AP "const char" *cmdName in -Name of an exposed command to hide or create. -.AP "const char" *hiddenCmdName in -Name under which a hidden command is stored and with which it can be -exposed or invoked. -.BE - -.SH DESCRIPTION -.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_CreateChild\fR creates a new interpreter as a child of \fIinterp\fR. -It also creates a child command named \fIname\fR in \fIinterp\fR which -allows \fIinterp\fR to manipulate the new child. -If \fIisSafe\fR is zero, the command creates a trusted child in which Tcl -code has access to all the Tcl commands. -If it is \fB1\fR, the command creates a -.QW safe -child in which Tcl code has access only to set of Tcl commands defined as -.QW "Safe Tcl" ; -see the manual entry for the Tcl \fBinterp\fR command for details. -If the creation of the new child interpreter failed, \fBNULL\fR is returned. -.PP -\fBTcl_IsSafe\fR returns \fB1\fR if \fIinterp\fR is -.QW safe -(was created with the \fBTCL_SAFE_INTERPRETER\fR flag specified), -\fB0\fR otherwise. -.PP -\fBTcl_MakeSafe\fR marks \fIinterp\fR as -.QW safe , -so that future -calls to \fBTcl_IsSafe\fR will return 1. It also removes all known -potentially-unsafe core functionality (both commands and variables) -from \fIinterp\fR. However, it cannot know what parts of an extension -or application are safe and does not make any attempt to remove those -parts, so safety is not guaranteed after calling \fBTcl_MakeSafe\fR. -Callers will want to take care with their use of \fBTcl_MakeSafe\fR -to avoid false claims of safety. For many situations, \fBTcl_CreateChild\fR -may be a better choice, since it creates interpreters in a known-safe state. -.PP -\fBTcl_GetChild\fR returns a pointer to a child interpreter of -\fIinterp\fR. The child interpreter is identified by \fIname\fR. -If no such child interpreter exists, \fBNULL\fR is returned. -.PP -\fBTcl_GetParent\fR returns a pointer to the parent interpreter of -\fIinterp\fR. If \fIinterp\fR has no parent (it is a -top-level interpreter) then \fBNULL\fR is returned. -.PP -\fBTcl_GetInterpPath\fR stores in the result of \fIinterp\fR -the relative path between \fIinterp\fR and \fIchildInterp\fR; -\fIchildInterp\fR must be a child of \fIinterp\fR. If the computation -of the relative path succeeds, \fBTCL_OK\fR is returned, else -\fBTCL_ERROR\fR is returned and an error message is stored as the -result of \fIinterp\fR. -.PP -\fBTcl_CreateAlias\fR creates a command named \fIchildCmd\fR in -\fIchildInterp\fR that when invoked, will cause the command \fItargetCmd\fR -to be invoked in \fItargetInterp\fR. The arguments specified by the strings -contained in \fIargv\fR are always prepended to any arguments supplied in the -invocation of \fIchildCmd\fR and passed to \fItargetCmd\fR. -This operation returns \fBTCL_OK\fR if it succeeds, or \fBTCL_ERROR\fR if -it fails; in that case, an error message is left in the value result -of \fIchildInterp\fR. -Note that there are no restrictions on the ancestry relationship (as -created by \fBTcl_CreateChild\fR) between \fIchildInterp\fR and -\fItargetInterp\fR. Any two interpreters can be used, without any -restrictions on how they are related. -.PP -\fBTcl_CreateAliasObj\fR is similar to \fBTcl_CreateAlias\fR except -that it takes a vector of values to pass as additional arguments instead -of a vector of strings. -.PP -\fBTcl_GetAlias\fR returns information about an alias \fIaliasName\fR -in \fIinterp\fR. Any of the result fields can be \fBNULL\fR, in -which case the corresponding datum is not returned. If a result field is -non\-\fBNULL\fR, the address indicated is set to the corresponding datum. -For example, if \fItargetNamePtr\fR is non\-\fBNULL\fR it is set to a -pointer to the string containing the name of the target command. -.PP -\fBTcl_GetAliasObj\fR is similar to \fBTcl_GetAlias\fR except that it -returns a pointer to a vector of Tcl_Obj structures instead of a vector of -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, -parent, child Index: doc/CrtChannel.3 ================================================================== --- doc/CrtChannel.3 +++ doc/CrtChannel.3 @@ -7,22 +7,22 @@ .TH Tcl_CreateChannel 3 8.4 Tcl "Tcl Library Procedures" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -Tcl_CreateChannel, Tcl_GetChannelInstanceData, Tcl_GetChannelType, Tcl_GetChannelName, Tcl_GetChannelHandle, Tcl_GetChannelMode, Tcl_GetChannelBufferSize, Tcl_SetChannelBufferSize, Tcl_NotifyChannel, Tcl_BadChannelOption, Tcl_ChannelName, Tcl_ChannelVersion, Tcl_ChannelBlockModeProc, Tcl_ChannelClose2Proc, Tcl_ChannelInputProc, Tcl_ChannelOutputProc, Tcl_ChannelWideSeekProc, Tcl_ChannelTruncateProc, Tcl_ChannelSetOptionProc, Tcl_ChannelGetOptionProc, Tcl_ChannelWatchProc, Tcl_ChannelGetHandleProc, Tcl_ChannelFlushProc, Tcl_ChannelHandlerProc, Tcl_ChannelThreadActionProc, Tcl_IsChannelShared, Tcl_IsChannelRegistered, Tcl_CutChannel, Tcl_SpliceChannel, Tcl_IsChannelExisting, Tcl_ClearChannelHandlers, Tcl_GetChannelThread, Tcl_ChannelBuffered \- procedures for creating and manipulating channels +Tcl_CreateChannel, Tcl_GetChannelInstanceData, Tcl_GetChannelType, Tcl_GetChannelName, Tcl_GetChannelHandle, Tcl_GetChannelMode, Tcl_GetChannelBufferSize, Tcl_SetChannelBufferSize, Tcl_NotifyChannel, Tcl_BadChannelOption, Tcl_ChannelName, Tcl_ChannelVersion, Tcl_ChannelBlockModeProc, Tcl_ChannelCloseProc, Tcl_ChannelClose2Proc, Tcl_ChannelInputProc, Tcl_ChannelOutputProc, Tcl_ChannelSeekProc, Tcl_ChannelWideSeekProc, Tcl_ChannelTruncateProc, Tcl_ChannelSetOptionProc, Tcl_ChannelGetOptionProc, Tcl_ChannelWatchProc, Tcl_ChannelGetHandleProc, Tcl_ChannelFlushProc, Tcl_ChannelHandlerProc, Tcl_ChannelThreadActionProc, Tcl_IsChannelShared, Tcl_IsChannelRegistered, Tcl_CutChannel, Tcl_SpliceChannel, Tcl_IsChannelExisting, Tcl_ClearChannelHandlers, Tcl_GetChannelThread, Tcl_ChannelBuffered \- procedures for creating and manipulating channels .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_Channel \fBTcl_CreateChannel\fR(\fItypePtr, channelName, instanceData, mask\fR) .sp -void * +ClientData \fBTcl_GetChannelInstanceData\fR(\fIchannel\fR) .sp -const Tcl_ChannelType * +Tcl_ChannelType * \fBTcl_GetChannelType\fR(\fIchannel\fR) .sp const char * \fBTcl_GetChannelName\fR(\fIchannel\fR) .sp @@ -73,27 +73,35 @@ \fBTcl_ChannelVersion\fR(\fItypePtr\fR) .sp Tcl_DriverBlockModeProc * \fBTcl_ChannelBlockModeProc\fR(\fItypePtr\fR) .sp +Tcl_DriverCloseProc * +\fBTcl_ChannelCloseProc\fR(\fItypePtr\fR) +.sp Tcl_DriverClose2Proc * \fBTcl_ChannelClose2Proc\fR(\fItypePtr\fR) .sp Tcl_DriverInputProc * \fBTcl_ChannelInputProc\fR(\fItypePtr\fR) .sp Tcl_DriverOutputProc * \fBTcl_ChannelOutputProc\fR(\fItypePtr\fR) .sp +Tcl_DriverSeekProc * +\fBTcl_ChannelSeekProc\fR(\fItypePtr\fR) +.sp Tcl_DriverWideSeekProc * \fBTcl_ChannelWideSeekProc\fR(\fItypePtr\fR) .sp Tcl_DriverThreadActionProc * \fBTcl_ChannelThreadActionProc\fR(\fItypePtr\fR) .sp +.VS 8.5 Tcl_DriverTruncateProc * \fBTcl_ChannelTruncateProc\fR(\fItypePtr\fR) +.VE 8.5 .sp Tcl_DriverSetOptionProc * \fBTcl_ChannelSetOptionProc\fR(\fItypePtr\fR) .sp Tcl_DriverGetOptionProc * @@ -117,14 +125,12 @@ Points to a structure containing the addresses of procedures that 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 void *instanceData in +created without a name. +.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. @@ -131,11 +137,11 @@ .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 void **handlePtr out +.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 @@ -149,11 +155,13 @@ .AP "const char" *optionList in Specific options list (space separated words, without .QW \- ) to append to the standard generic options list. Can be NULL for generic options error message only. + .BE + .SH DESCRIPTION .PP Tcl uses a two-layered channel architecture. It provides a generic upper layer to enable C and Tcl programs to perform input and output using the same APIs for a variety of files, devices, sockets etc. The generic C APIs @@ -203,11 +211,11 @@ channels. Once a standard channel was initialized either through a call to \fBTcl_GetStdChannel\fR or a call to \fBTcl_SetStdChannel\fR closing this standard channel will cause the next call to \fBTcl_CreateChannel\fR to make the new channel the new standard channel too. See \fBTcl_StandardChannels\fR for a general treatise -about standard channels and the behavior of the Tcl library with +about standard channels and the behaviour of the Tcl library with regard to them. .PP \fBTcl_GetChannelInstanceData\fR returns the instance data associated with the channel in \fIchannel\fR. This is the same as the \fIinstanceData\fR argument in the call to \fBTcl_CreateChannel\fR that created this channel. @@ -242,12 +250,12 @@ by a previous call to \fBTcl_SetChannelBufferSize\fR, described below, then the default value of 4096 is returned. .PP \fBTcl_SetChannelBufferSize\fR sets the size, in bytes, of buffers that will be allocated in subsequent operations on the channel to store input or -output. The \fIsize\fR argument should be between one and one million, -allowing buffers of one byte to one million bytes. If \fIsize\fR is +output. The \fIsize\fR argument should be between ten and one million, +allowing buffers of ten bytes to one million bytes. If \fIsize\fR is outside this range, \fBTcl_SetChannelBufferSize\fR sets the buffer size to 4096. .PP \fBTcl_NotifyChannel\fR is called by a channel driver to indicate to the generic layer that the events specified by \fImask\fR have @@ -278,17 +286,24 @@ .PP \fBTcl_CutChannel\fR removes the specified \fIchannel\fR from the (thread)global list of all channels (of the current thread). Application to a channel still registered in some interpreter is not allowed. -Also notifies the driver if +.VS 8.5 +Also notifies the driver if the \fBTcl_ChannelType\fR version is +\fBTCL_CHANNEL_VERSION_4\fR (or higher), and \fBTcl_DriverThreadActionProc\fR is defined for it. +.VE 8.5 .PP \fBTcl_SpliceChannel\fR adds the specified \fIchannel\fR to the (thread)global list of all channels (of the current thread). Application to a channel registered in some interpreter is not allowed. -Also notifies the driver if \fBTcl_DriverThreadActionProc\fR is defined for it. +.VS 8.5 +Also notifies the driver if the \fBTcl_ChannelType\fR version is +\fBTCL_CHANNEL_VERSION_4\fR (or higher), and +\fBTcl_DriverThreadActionProc\fR is defined for it. +.VE 8.5 .PP \fBTcl_ClearChannelHandlers\fR removes all channel handlers and event scripts associated with the specified \fIchannel\fR, thus shutting down all event processing for this channel. .SH TCL_CHANNELTYPE @@ -299,19 +314,18 @@ was versioned starting in Tcl 8.3.2/8.4 to correct a problem with stacked channel drivers. See the \fBOLD CHANNEL TYPES\fR section below for details about the old structure. .PP The \fBTcl_ChannelType\fR structure contains the following fields: -.PP .CS typedef struct Tcl_ChannelType { - const char *\fItypeName\fR; + char *\fItypeName\fR; Tcl_ChannelTypeVersion \fIversion\fR; - void *\fIcloseProc\fR; /* Not used any more*/ + Tcl_DriverCloseProc *\fIcloseProc\fR; Tcl_DriverInputProc *\fIinputProc\fR; Tcl_DriverOutputProc *\fIoutputProc\fR; - void *\fIseekProc\fR; /* Not used any more */ + Tcl_DriverSeekProc *\fIseekProc\fR; Tcl_DriverSetOptionProc *\fIsetOptionProc\fR; Tcl_DriverGetOptionProc *\fIgetOptionProc\fR; Tcl_DriverWatchProc *\fIwatchProc\fR; Tcl_DriverGetHandleProc *\fIgetHandleProc\fR; Tcl_DriverClose2Proc *\fIclose2Proc\fR; @@ -318,12 +332,14 @@ Tcl_DriverBlockModeProc *\fIblockModeProc\fR; Tcl_DriverFlushProc *\fIflushProc\fR; Tcl_DriverHandlerProc *\fIhandlerProc\fR; Tcl_DriverWideSeekProc *\fIwideSeekProc\fR; Tcl_DriverThreadActionProc *\fIthreadActionProc\fR; +.VS 8.5 Tcl_DriverTruncateProc *\fItruncateProc\fR; -} \fBTcl_ChannelType\fR; +.VE 8.5 +} Tcl_ChannelType; .CE .PP It is not necessary to provide implementations for all channel operations. Those which are not necessary may be set to NULL in the struct: \fIblockModeProc\fR, \fIseekProc\fR, \fIsetOptionProc\fR, @@ -336,14 +352,17 @@ .PP The user should only use the above structure for \fBTcl_ChannelType\fR instantiation. When referencing fields in a \fBTcl_ChannelType\fR structure, the following functions should be used to obtain the values: \fBTcl_ChannelName\fR, \fBTcl_ChannelVersion\fR, -\fBTcl_ChannelBlockModeProc\fR, \fBTcl_ChannelClose2Proc\fR, -\fBTcl_ChannelInputProc\fR, \fBTcl_ChannelOutputProc\fR, +\fBTcl_ChannelBlockModeProc\fR, \fBTcl_ChannelCloseProc\fR, +\fBTcl_ChannelClose2Proc\fR, \fBTcl_ChannelInputProc\fR, +\fBTcl_ChannelOutputProc\fR, \fBTcl_ChannelSeekProc\fR, \fBTcl_ChannelWideSeekProc\fR, \fBTcl_ChannelThreadActionProc\fR, +.VS 8.5 \fBTcl_ChannelTruncateProc\fR, +.VE 8.5 \fBTcl_ChannelSetOptionProc\fR, \fBTcl_ChannelGetOptionProc\fR, \fBTcl_ChannelWatchProc\fR, \fBTcl_ChannelGetHandleProc\fR, \fBTcl_ChannelFlushProc\fR, or \fBTcl_ChannelHandlerProc\fR. .PP The change to the structures was made in such a way that standard channel @@ -360,22 +379,42 @@ a pointer to the string. .SS VERSION .PP The \fIversion\fR field should be set to the version of the structure -that you require. \fBTCL_CHANNEL_VERSION_5\fR is the minimum supported. +that you require. \fBTCL_CHANNEL_VERSION_2\fR is the minimum recommended. +\fBTCL_CHANNEL_VERSION_3\fR must be set to specify the \fIwideSeekProc\fR member. +\fBTCL_CHANNEL_VERSION_4\fR must be set to specify the \fIthreadActionProc\fR member +(includes \fIwideSeekProc\fR). +.VS 8.5 +\fBTCL_CHANNEL_VERSION_5\fR must be set to specify the +\fItruncateProc\fR members (includes +\fIwideSeekProc\fR and \fIthreadActionProc\fR). +.VE 8.5 +If it is not set to any of these, then this +\fBTcl_ChannelType\fR is assumed to have the original structure. See +\fBOLD CHANNEL TYPES\fR for more details. While Tcl will recognize +and function with either structures, stacked channels must be of at +least \fBTCL_CHANNEL_VERSION_2\fR to function correctly. .PP -This value can be retrieved with \fBTcl_ChannelVersion\fR. +This value can be retrieved with \fBTcl_ChannelVersion\fR, which returns +one of +.VS 8.5 +\fBTCL_CHANNEL_VERSION_5\fR, +.VE 8.5 +\fBTCL_CHANNEL_VERSION_4\fR, +\fBTCL_CHANNEL_VERSION_3\fR, +\fBTCL_CHANNEL_VERSION_2\fR or \fBTCL_CHANNEL_VERSION_1\fR. .SS BLOCKMODEPROC .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( - void *\fIinstanceData\fR, +typedef int Tcl_DriverBlockModeProc( + 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 @@ -398,58 +437,72 @@ very, very careful. It has to tell the generic layer exactly which blocking mode is acceptable to it, and should this also document for the user so that the blocking mode of the channel is not changed to an unacceptable value. Any confusion here may lead the interpreter into a (spurious and difficult to find) deadlock. -.SS "CLOSE2PROC" +.SS "CLOSEPROC AND CLOSE2PROC" .PP -The \fIclose2Proc\fR field contains the address of a function called by the +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. \fIClose2Proc\fR must match the following prototype: +closed. \fICloseProc\fR must match the following prototype: .PP .CS -typedef int \fBTcl_DriverClose2Proc\fR( - void *\fIinstanceData\fR, - Tcl_Interp *\fIinterp\fR, - int \fIflags\fR); +typedef int Tcl_DriverCloseProc( + ClientData \fIinstanceData\fR, + Tcl_Interp *\fIinterp\fR); .CE .PP -If \fIflags\fR is 0, 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 +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 output will have been flushed to the device before this function is called, and no further driver operations will be invoked on this instance after calling the \fIcloseProc\fR. If the close operation is successful, the procedure should return zero; otherwise it should return a nonzero POSIX error code. In addition, if an error occurs and \fIinterp\fR is not NULL, the procedure should store an error message in the interpreter's result. .PP Alternatively, channels that support closing the read and write sides -independently may accept other flag values than 0. -Then \fIclose2Proc\fR will be called with \fIflags\fR set to an OR'ed +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 Tcl_DriverClose2Proc( + 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 the channel. The channel driver may be invoked to perform additional operations on the channel after \fIclose2Proc\fR is -called to close one or both sides of the channel. In all cases, the -\fIclose2Proc\fR function should return zero if the close operation was -successful; otherwise it should return a nonzero POSIX error code. -In addition, if an error occurs and \fIinterp\fR is not NULL, the procedure -should store an error message in the interpreter's result. +called to close one or both sides of the channel. If \fIflags\fR is +\fB0\fR (zero), the driver should close the channel in the manner +described above for \fIcloseProc\fR. No further operations will be +invoked on this instance after \fIclose2Proc\fR is called with all +flags cleared. In all cases, the \fIclose2Proc\fR function should +return zero if the close operation was successful; otherwise it should +return a nonzero POSIX error code. In addition, if an error occurs and +\fIinterp\fR is not NULL, the procedure should store an error message +in the interpreter's result. .PP -The \fIclose2Proc\fR value can be retrieved with \fBTcl_ChannelClose2Proc\fR, -which returns a pointer to the function. +The \fIcloseProc\fR and \fIclose2Proc\fR values can be retrieved with +\fBTcl_ChannelCloseProc\fR or \fBTcl_ChannelClose2Proc\fR, which +return a pointer to the respective function. .SS INPUTPROC .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( - void *\fIinstanceData\fR, +typedef int Tcl_DriverInputProc( + ClientData \fIinstanceData\fR, char *\fIbuf\fR, int \fIbufSize\fR, int *\fIerrorCodePtr\fR); .CE .PP @@ -488,12 +541,12 @@ 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( - void *\fIinstanceData\fR, +typedef int Tcl_DriverOutputProc( + ClientData \fIinstanceData\fR, const char *\fIbuf\fR, int \fItoWrite\fR, int *\fIerrorCodePtr\fR); .CE .PP @@ -519,21 +572,21 @@ data whatsoever, the function should return -1 with an \fBEAGAIN\fR error without writing any data. .PP This value can be retrieved with \fBTcl_ChannelOutputProc\fR, which returns a pointer to the function. -.SS "WIDESEEKPROC" +.SS "SEEKPROC AND WIDESEEKPROC" .PP -The \fIwideSeekProc\fR field contains the address of a function called by the +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. \fIWideSeekProc\fR must match the following +operations will be applied. \fISeekProc\fR must match the following prototype: .PP .CS -typedef Tcl_WideInt \fBTcl_DriverWideSeekProc\fR( - void *\fIinstanceData\fR, - Tcl_WideInt \fIoffset\fR, +typedef int Tcl_DriverSeekProc( + 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 @@ -548,21 +601,43 @@ does not implement seeking. .PP The return value is the new access point or -1 in case of error. If an error occurred, the function should not move the access point. .PP -The \fIwideSseekProc\fR value can be retrieved with -\fBTcl_ChannelWideSeekProc\fR, which returns a pointer to the function. +If there is a non-NULL \fIseekProc\fR field, the \fIwideSeekProc\fR +field may contain the address of an alternative function to use which +handles wide (i.e. larger than 32-bit) offsets, so allowing seeks +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 Tcl_DriverWideSeekProc( + 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 +type are different. +.PP +The \fIseekProc\fR value can be retrieved with +\fBTcl_ChannelSeekProc\fR, which returns a pointer to the function, +and similarly the \fIwideSeekProc\fR can be retrieved with +\fBTcl_ChannelWideSeekProc\fR. .SS SETOPTIONPROC .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( - void *\fIinstanceData\fR, +typedef int Tcl_DriverSetOptionProc( + ClientData \fIinstanceData\fR, Tcl_Interp *\fIinterp\fR, const char *\fIoptionName\fR, const char *\fInewValue\fR); .CE .PP @@ -575,21 +650,21 @@ Some options are handled by the generic code and this function is never called to set them, e.g. \fB\-blockmode\fR. Other options are specific to each channel type and the \fIsetOptionProc\fR procedure of the channel driver will get called to implement them. The \fIsetOptionProc\fR field can be NULL, which indicates that this channel type supports no type specific -options. +options. .PP 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. +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 +the function should leave an error message in the +\fIresult\fR field 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. @@ -598,12 +673,12 @@ 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( - void *\fIinstanceData\fR, +typedef int Tcl_DriverGetOptionProc( + ClientData \fIinstanceData\fR, Tcl_Interp *\fIinterp\fR, const char *\fIoptionName\fR, Tcl_DString *\fIoptionValue\fR); .CE .PP @@ -610,11 +685,11 @@ \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 value, as a string, in the Tcl dynamic string \fIoptionValue\fR. If \fIoptionName\fR is NULL, the function stores in \fIoptionValue\fR an alternating list of all supported options and their current values. -On success, the function returns \fBTCL_OK\fR. +On success, 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 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 @@ -636,12 +711,12 @@ 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( - void *\fIinstanceData\fR, +typedef void Tcl_DriverWatchProc( + 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 @@ -667,14 +742,14 @@ 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( - void *\fIinstanceData\fR, +typedef int Tcl_DriverGetHandleProc( + ClientData \fIinstanceData\fR, int \fIdirection\fR, - void **\fIhandlePtr\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 @@ -696,12 +771,12 @@ 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( - void *\fIinstanceData\fR); +typedef int Tcl_DriverFlushProc( + ClientData \fIinstanceData\fR); .CE .PP This value can be retrieved with \fBTcl_ChannelFlushProc\fR, which returns a pointer to the function. .SS HANDLERPROC @@ -711,12 +786,12 @@ 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( - void *\fIinstanceData\fR, +typedef int Tcl_DriverHandlerProc( + 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 @@ -740,13 +815,13 @@ 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( - void *\fIinstanceData\fR, - int \fIaction\fR); +typedef void Tcl_DriverThreadActionProc( + 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 @@ -757,12 +832,12 @@ 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( - void *\fIinstanceData\fR, +typedef int Tcl_DriverTruncateProc( + 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 @@ -775,22 +850,22 @@ .SH TCL_BADCHANNELOPTION .PP This procedure generates a .QW "bad option" error message in an -(optional) interpreter. It is used by channel drivers when +(optional) interpreter. It is used by channel drivers when an invalid Set/Get option is requested. Its purpose is to concatenate the generic options list to the specific ones and factorize the generic options error message string. .PP It always returns \fBTCL_ERROR\fR .PP -An error message is generated in \fIinterp\fR's result value to +An error message is generated in \fIinterp\fR's result object to indicate that a command was invoked with a bad option. The message has the form .CS - bad option "blah": should be one of + bad option "blah": should be one of <...generic options...>+<...specific options...> .CE so you get for instance: .CS bad option "-blah": should be one of -blocking, @@ -806,9 +881,63 @@ is a space separated list of specific option words. The function takes good care of inserting minus signs before each option, commas after, and an .QW or before the last option. +.SH "OLD CHANNEL TYPES" +The original (8.3.1 and below) \fBTcl_ChannelType\fR structure contains +the following fields: +.PP +.CS +typedef struct Tcl_ChannelType { + char *\fItypeName\fR; + Tcl_DriverBlockModeProc *\fIblockModeProc\fR; + Tcl_DriverCloseProc *\fIcloseProc\fR; + Tcl_DriverInputProc *\fIinputProc\fR; + Tcl_DriverOutputProc *\fIoutputProc\fR; + Tcl_DriverSeekProc *\fIseekProc\fR; + Tcl_DriverSetOptionProc *\fIsetOptionProc\fR; + Tcl_DriverGetOptionProc *\fIgetOptionProc\fR; + Tcl_DriverWatchProc *\fIwatchProc\fR; + Tcl_DriverGetHandleProc *\fIgetHandleProc\fR; + Tcl_DriverClose2Proc *\fIclose2Proc\fR; +} Tcl_ChannelType; +.CE +.PP +It is still possible to create channel with the above structure. The +internal channel code will determine the version. It is imperative to use +the new \fBTcl_ChannelType\fR structure if you are creating a stacked +channel driver, due to problems with the earlier stacked channel +implementation (in 8.2.0 to 8.3.1). +.PP +Prior to 8.4.0 (i.e. during the later releases of 8.3 and early part +of the 8.4 development cycle) the \fBTcl_ChannelType\fR structure +contained the following fields: +.PP +.CS +typedef struct Tcl_ChannelType { + char *\fItypeName\fR; + Tcl_ChannelTypeVersion \fIversion\fR; + Tcl_DriverCloseProc *\fIcloseProc\fR; + Tcl_DriverInputProc *\fIinputProc\fR; + Tcl_DriverOutputProc *\fIoutputProc\fR; + Tcl_DriverSeekProc *\fIseekProc\fR; + Tcl_DriverSetOptionProc *\fIsetOptionProc\fR; + Tcl_DriverGetOptionProc *\fIgetOptionProc\fR; + Tcl_DriverWatchProc *\fIwatchProc\fR; + Tcl_DriverGetHandleProc *\fIgetHandleProc\fR; + Tcl_DriverClose2Proc *\fIclose2Proc\fR; + Tcl_DriverBlockModeProc *\fIblockModeProc\fR; + Tcl_DriverFlushProc *\fIflushProc\fR; + Tcl_DriverHandlerProc *\fIhandlerProc\fR; + Tcl_DriverTruncateProc *\fItruncateProc\fR; +} Tcl_ChannelType; +.CE +.PP +When the above structure is registered as a channel type, the +\fIversion\fR field should always be \fBTCL_CHANNEL_VERSION_2\fR. + .SH "SEE ALSO" Tcl_Close(3), Tcl_OpenFileChannel(3), Tcl_SetErrno(3), Tcl_QueueEvent(3), Tcl_StackChannel(3), Tcl_GetStdChannel(3) + .SH KEYWORDS blocking, channel driver, channel registration, channel type, nonblocking Index: doc/CrtChnlHdlr.3 ================================================================== --- doc/CrtChnlHdlr.3 +++ doc/CrtChnlHdlr.3 @@ -30,13 +30,14 @@ \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 void *clientData in +.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 @@ -43,14 +44,13 @@ \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( - void *\fIclientData\fR, +typedef void Tcl_ChannelProc( + 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, @@ -81,9 +81,11 @@ channel, the first handler could consume all of the available input so that the channel is no longer readable when the second handler is invoked. For this reason it may be useful to use nonblocking I/O on channels for which there are event handlers. + .SH "SEE ALSO" Notifier(3), Tcl_CreateChannel(3), Tcl_OpenFileChannel(3), vwait(n). + .SH KEYWORDS blocking, callback, channel, events, handler, nonblocking. Index: doc/CrtCloseHdlr.3 ================================================================== --- doc/CrtCloseHdlr.3 +++ doc/CrtCloseHdlr.3 @@ -24,23 +24,24 @@ .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 void *clientData in +.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( - void *\fIclientData\fR); +typedef void Tcl_CloseProc( + ClientData \fIclientData\fR); .CE .PP The \fIclientData\fR is the same as the value provided in the call to \fBTcl_CreateCloseHandler\fR. .PP @@ -47,9 +48,11 @@ \fBTcl_DeleteCloseHandler\fR removes a close callback for \fIchannel\fR. The \fIproc\fR and \fIclientData\fR identify which close callback to remove; \fBTcl_DeleteCloseHandler\fR does nothing if its \fIproc\fR and \fIclientData\fR arguments do not match the \fIproc\fR and \fIclientData\fR for a close handler for \fIchannel\fR. + .SH "SEE ALSO" close(n), Tcl_Close(3), Tcl_UnregisterChannel(3) + .SH KEYWORDS callback, channel closing Index: doc/CrtCommand.3 ================================================================== --- doc/CrtCommand.3 +++ doc/CrtCommand.3 @@ -2,11 +2,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_CreateCommand 3 "" Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_CreateCommand \- implement new commands in C @@ -23,38 +23,41 @@ .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 voie *clientData in +.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 .PP \fBTcl_CreateCommand\fR defines a new command in \fIinterp\fR and associates it with procedure \fIproc\fR such that whenever \fIcmdName\fR is invoked as a Tcl command (via a call to \fBTcl_Eval\fR) the Tcl interpreter will call \fIproc\fR to process the command. It differs from \fBTcl_CreateObjCommand\fR in that a new string-based command is defined; that is, a command procedure is defined that takes an array of -argument strings instead of values. -The value-based command procedures registered by \fBTcl_CreateObjCommand\fR +argument strings instead of objects. +The object-based command procedures registered by \fBTcl_CreateObjCommand\fR can execute significantly faster than the string-based command procedures defined by \fBTcl_CreateCommand\fR. -This is because they take Tcl values as arguments -and those values can retain an internal representation that +This is because they take Tcl objects as arguments +and those objects can retain an internal representation that can be manipulated more efficiently. -Also, Tcl's interpreter now uses values internally. +Also, Tcl's interpreter now uses objects internally. In order to invoke a string-based command procedure registered by \fBTcl_CreateCommand\fR, it must generate and fetch a string representation -from each argument value before the call. +from each argument object before the call +and create a new Tcl object to hold the string result returned by the +string-based command procedure. New commands should be defined using \fBTcl_CreateObjCommand\fR. We support \fBTcl_CreateCommand\fR for backwards compatibility. .PP The procedures \fBTcl_DeleteCommand\fR, \fBTcl_GetCommandInfo\fR, and \fBTcl_SetCommandInfo\fR are used in conjunction with @@ -70,19 +73,17 @@ If \fBTcl_CreateCommand\fR is called for an interpreter that is in 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( - void *\fIclientData\fR, +typedef int Tcl_CmdProc( + 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 arguments given to \fBTcl_CreateCommand\fR. Typically, \fIclientData\fR points to an application-specific data structure that describes what to do when the command procedure @@ -89,11 +90,11 @@ is invoked. \fIArgc\fR and \fIargv\fR describe the arguments to the command, \fIargc\fR giving the number of arguments (including the command name) and \fIargv\fR giving the values of the arguments as strings. The \fIargv\fR array will contain \fIargc\fR+1 values; the first \fIargc\fR values point to the argument strings, and the -last value is NULL. +last value is NULL. Note that the argument strings should not be modified as they may point to constant strings or may be shared with other parts of the interpreter. .PP Note that the argument strings are encoded in normalized UTF-8 since @@ -102,11 +103,11 @@ \fIProc\fR must return an integer code that is expected to be one of \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR. See the Tcl overview man page for details on what these codes mean. Most normal commands will only return \fBTCL_OK\fR or \fBTCL_ERROR\fR. In addition, \fIproc\fR must set -the interpreter result; +the interpreter result to point to a string value; in the case of a \fBTCL_OK\fR return code this gives the result of the command, and in the case of \fBTCL_ERROR\fR it gives an error message. The \fBTcl_SetResult\fR procedure provides an easy interface for setting the return value; for complete details on how the interpreter result field is managed, see the \fBTcl_Interp\fR man page. @@ -119,25 +120,24 @@ not modify them, nor should it set the interpreter result to point anywhere within the \fIargv\fR values. Call \fBTcl_SetResult\fR with status \fBTCL_VOLATILE\fR if you want to return something from the \fIargv\fR array. .PP -\fIDeleteProc\fR will be invoked when (if) \fIcmdName\fR is deleted. This can -occur through a call to \fBTcl_DeleteCommand\fR or \fBTcl_DeleteInterp\fR, +\fIDeleteProc\fR will be invoked when (if) \fIcmdName\fR is deleted. +This can occur through a call to \fBTcl_DeleteCommand\fR or \fBTcl_DeleteInterp\fR, or by replacing \fIcmdName\fR in another call to \fBTcl_CreateCommand\fR. \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( - void *\fIclientData\fR); +typedef void Tcl_CmdDeleteProc( + 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 +Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_GetCommandInfo, Tcl_SetCommandInfo, Tcl_GetCommandName, Tcl_SetObjResult + .SH KEYWORDS bind, command, create, delete, interpreter, namespace Index: doc/CrtFileHdlr.3 ================================================================== --- doc/CrtFileHdlr.3 +++ doc/CrtFileHdlr.3 @@ -2,11 +2,11 @@ '\" Copyright (c) 1990-1994 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_CreateFileHandler 3 8.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_CreateFileHandler, Tcl_DeleteFileHandler \- associate procedure callbacks with files or devices (Unix only) @@ -27,13 +27,14 @@ 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 void *clientData in +.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 @@ -46,26 +47,25 @@ events through \fBTcl_DoOneEvent\fR or through Tcl commands such 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( - void *\fIclientData\fR, +typedef void Tcl_FileProc( + 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 structure containing application-specific information about the file. \fIMask\fR is an integer mask indicating which of the requested conditions actually exists for the file; it will contain a subset of the bits in the \fImask\fR argument to \fBTcl_CreateFileHandler\fR. +.PP .PP There may exist only one handler for a given file at a given time. If \fBTcl_CreateFileHandler\fR is called when a handler already exists for \fIfd\fR, then the new callback replaces the information that was previously recorded. @@ -82,10 +82,9 @@ complete the application will not be able to service other events. Use \fBTcl_SetChannelOption\fR with \fB\-blocking\fR to set the channel into blocking or nonblocking mode as required. .PP Note that these interfaces are only supported by the Unix -implementation of the Tcl notifier. -.SH "SEE ALSO" -fileevent(n), Tcl_CreateTimerHandler(3), Tcl_DoWhenIdle(3) +implementation of the Tcl notifier. + .SH KEYWORDS callback, file, handler Index: doc/CrtInterp.3 ================================================================== --- doc/CrtInterp.3 +++ doc/CrtInterp.3 @@ -2,16 +2,16 @@ '\" 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_CreateInterp 3 7.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_CreateInterp, Tcl_DeleteInterp, Tcl_InterpActive, Tcl_InterpDeleted \- create and delete Tcl command interpreters +Tcl_CreateInterp, Tcl_DeleteInterp, Tcl_InterpDeleted \- create and delete Tcl command interpreters .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_Interp * @@ -19,37 +19,34 @@ .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. +Token for interpreter to be destroyed. .BE + .SH DESCRIPTION .PP \fBTcl_CreateInterp\fR creates a new interpreter structure and returns -a token for it. The token is required in calls to most other Tcl +a token for it. The token is required in calls to most other Tcl procedures, such as \fBTcl_CreateCommand\fR, \fBTcl_Eval\fR, and -\fBTcl_DeleteInterp\fR. The token returned by \fBTcl_CreateInterp\fR -may only be passed to Tcl routines called from the same thread as -the original \fBTcl_CreateInterp\fR call. It is not safe for multiple -threads to pass the same token to Tcl's routines. +\fBTcl_DeleteInterp\fR. +Clients are only allowed to access a few of the fields of +Tcl_Interp structures; see the \fBTcl_Interp\fR +and \fBTcl_CreateCommand\fR man pages for details. The new interpreter is initialized with the built-in Tcl commands -and with standard variables like \fBtcl_platform\fR and \fBenv\fR. To -bind in additional commands, call \fBTcl_CreateCommand\fR, and to -create additional variables, call \fBTcl_SetVar\fR. +and with the variables documented in tclvars(n). To bind in +additional commands, call \fBTcl_CreateCommand\fR. .PP \fBTcl_DeleteInterp\fR marks an interpreter as deleted; the interpreter will eventually be deleted when all calls to \fBTcl_Preserve\fR for it have been matched by calls to \fBTcl_Release\fR. At that time, all of the resources associated with it, including variables, procedures, and -application-specific command bindings, will be deleted. After +application-specific command bindings, will be deleted. After \fBTcl_DeleteInterp\fR returns any attempt to use \fBTcl_Eval\fR on the interpreter will fail and return \fBTCL_ERROR\fR. After the call to \fBTcl_DeleteInterp\fR it is safe to examine the interpreter's result, query or set the values of variables, define, undefine or retrieve procedures, and examine the runtime evaluation stack. See below, in the @@ -65,17 +62,11 @@ \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 @@ -91,20 +82,18 @@ \fBTcl_Preserve\fR for a description of these functions. .PP The rules for when the user of an interpreter must call \fBTcl_Preserve\fR and \fBTcl_Release\fR are simple: .TP -\fBInterpreters Passed As Arguments\fR -. +Interpreters Passed As Arguments Functions that are passed an interpreter as an argument can safely use the interpreter without any special protection. Thus, when you write an extension consisting of new Tcl commands, no special code is needed to protect interpreters received as arguments. This covers the majority of all uses. .TP -\fBInterpreter Creation And Deletion\fR -. +Interpreter Creation And Deletion When a new interpreter is created and used in a call to \fBTcl_Eval\fR, \fBTcl_VarEval\fR, \fBTcl_GlobalEval\fR, \fBTcl_SetVar\fR, or \fBTcl_GetVar\fR, a pair of calls to \fBTcl_Preserve\fR and \fBTcl_Release\fR should be wrapped around all uses of the interpreter. Remember that it is unsafe to use the interpreter once \fBTcl_Release\fR @@ -111,20 +100,17 @@ has been called. To ensure that the interpreter is properly deleted when it is no longer needed, call \fBTcl_InterpDeleted\fR to test if some other code already called \fBTcl_DeleteInterp\fR; if not, call \fBTcl_DeleteInterp\fR before calling \fBTcl_Release\fR in your own code. .TP -\fBRetrieving An Interpreter From A Data Structure\fR -. +Retrieving An Interpreter From A Data Structure When an interpreter is retrieved from a data structure (e.g. the client -data of a callback) for use in one of the evaluation functions -(\fBTcl_Eval\fR, \fBTcl_VarEval\fR, \fBTcl_GlobalEval\fR, \fBTcl_EvalObjv\fR, -etc.) or variable access functions (\fBTcl_SetVar\fR, \fBTcl_GetVar\fR, -\fBTcl_SetVar2Ex\fR, etc.), a pair of +data of a callback) for use in \fBTcl_Eval\fR, \fBTcl_VarEval\fR, +\fBTcl_GlobalEval\fR, \fBTcl_SetVar\fR, or \fBTcl_GetVar\fR, a pair of calls to \fBTcl_Preserve\fR and \fBTcl_Release\fR should be wrapped around all uses of the interpreter; it is unsafe to reuse the interpreter once -\fBTcl_Release\fR has been called. If an interpreter is stored inside a +\fBTcl_Release\fR has been called. If an interpreter is stored inside a callback data structure, an appropriate deletion cleanup mechanism should be set up by the code that creates the data structure so that the interpreter is removed from the data structure (e.g. by setting the field to NULL) when the interpreter is deleted. Otherwise, you may be using an interpreter that has been freed and whose memory may already have been @@ -131,14 +117,11 @@ 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 Index: doc/CrtMathFnc.3 ================================================================== --- /dev/null +++ doc/CrtMathFnc.3 @@ -0,0 +1,156 @@ +'\" +'\" 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 SYNOPSIS +.nf +\fB#include \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: +.CS +typedef int Tcl_MathProc( + 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: +.CS +typedef struct Tcl_Value { + Tcl_ValueType \fItype\fR; + long \fIintValue\fR; + double \fIdoubleValue\fR; + Tcl_WideInt \fIwideValue\fR; +} Tcl_Value; +.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 object containing a list of all +the math functions defined in the interpreter whose name matches +\fIpattern\fR. The returned object 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 Index: doc/CrtObjCmd.3 ================================================================== --- doc/CrtObjCmd.3 +++ doc/CrtObjCmd.3 @@ -1,16 +1,16 @@ '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Tcl_CreateObjCommand 3 8.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_DeleteCommandFromToken, Tcl_GetCommandInfo, Tcl_GetCommandInfoFromToken, Tcl_SetCommandInfo, Tcl_SetCommandInfoFromToken, Tcl_GetCommandName, Tcl_GetCommandFullName, Tcl_GetCommandFromObj, Tcl_RegisterCommandTypeName, Tcl_GetCommandTypeName \- implement new commands in C +Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_DeleteCommandFromToken, Tcl_GetCommandInfo, Tcl_GetCommandInfoFromToken, Tcl_SetCommandInfo, Tcl_SetCommandInfoFromToken, Tcl_GetCommandName, Tcl_GetCommandFullName, Tcl_GetCommandFromObj \- implement new commands in C .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_Command @@ -40,28 +40,20 @@ void \fBTcl_GetCommandFullName\fR(\fIinterp, token, objPtr\fR) .sp Tcl_Command \fBTcl_GetCommandFromObj\fR(\fIinterp, objPtr\fR) -.sp -.VS "info cmdtype feature" -void -\fBTcl_RegisterCommandTypeName\fR(\fIproc, typeName\fR) -.sp -const char * -\fBTcl_GetCommandTypeName\fR(\fItoken\fR) -.VE "info cmdtype feature" .SH ARGUMENTS .AS Tcl_CmdDeleteProc *deleteProc in/out .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 void *clientData in +.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. @@ -70,14 +62,11 @@ The command must not have been deleted. .AP Tcl_CmdInfo *infoPtr in/out Pointer to structure containing various information about a Tcl command. .AP Tcl_Obj *objPtr in -Value containing the name of a Tcl command. -.AP "const char" *typeName in -Indicates the name of the type of command implementation associated -with a particular \fIproc\fR, or NULL to break the association. +Object containing the name of a Tcl command. .BE .SH DESCRIPTION .PP \fBTcl_CreateObjCommand\fR defines a new command in \fIinterp\fR and associates it with procedure \fIproc\fR @@ -97,40 +86,38 @@ If \fBTcl_CreateObjCommand\fR is called for an interpreter that is in 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( - void *\fIclientData\fR, +typedef int Tcl_ObjCmdProc( + 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 \fBTcl_CreateObjCommand\fR. Typically, \fIclientData\fR points to an application-specific data structure that describes what to do when the command procedure is invoked. \fIObjc\fR and \fIobjv\fR describe the -arguments to the command, \fIobjc\fR giving the number of argument values +arguments to the command, \fIobjc\fR giving the number of argument objects (including the command name) and \fIobjv\fR giving the values of the arguments. The \fIobjv\fR array will contain \fIobjc\fR values, pointing to -the argument values. Unlike \fIargv\fR[\fIargv\fR] used in a +the argument objects. Unlike \fIargv\fR[\fIargv\fR] used in a string-based command procedure, \fIobjv\fR[\fIobjc\fR] will not contain NULL. .PP Additionally, when \fIproc\fR is invoked, it must not modify the contents of the \fIobjv\fR array by assigning new pointer values to any element of the array (for example, \fIobjv\fR[\fB2\fR] = \fBNULL\fR) because this will cause memory to be lost and the runtime stack to be corrupted. The \fBconst\fR in the declaration of \fIobjv\fR will cause ANSI-compliant compilers to report any such attempted assignment as an error. However, it is acceptable to modify the internal representation of any individual -value argument. For instance, the user may call +object argument. For instance, the user may call \fBTcl_GetIntFromObj\fR on \fIobjv\fR[\fB2\fR] to obtain the integer -representation of that value; that call may change the type of the value +representation of that object; that call may change the type of the object that \fIobjv\fR[\fB2\fR] points at, but will not change where \fIobjv\fR[\fB2\fR] points. .PP \fIproc\fR must return an integer code that is either \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR. @@ -142,11 +129,11 @@ In the case of a \fBTCL_OK\fR return code this gives the result of the command, and in the case of \fBTCL_ERROR\fR this gives an error message. Before invoking a command procedure, \fBTcl_EvalObjEx\fR sets interpreter's result to -point to a value representing an empty string, so simple +point to an object representing an empty string, so simple commands can return an empty result by doing nothing at all. .PP The contents of the \fIobjv\fR array belong to Tcl and are not guaranteed to persist once \fIproc\fR returns: \fIproc\fR should not modify them. @@ -159,11 +146,11 @@ \fBTcl_CreateCommand\fR, \fBTcl_CreateObjCommand\fR does not delete the command but instead arranges for the Tcl interpreter to call the \fBTcl_ObjCmdProc\fR \fIproc\fR in the future. The old string-based \fBTcl_CmdProc\fR associated with the command -is retained and its address can be obtained by subsequent +is retained and its address can be obtained by subsequent \fBTcl_GetCommandInfo\fR calls. This is done for backwards compatibility. .PP \fIDeleteProc\fR will be invoked when (if) \fIname\fR is deleted. This can occur through a call to \fBTcl_DeleteCommand\fR, \fBTcl_DeleteCommandFromToken\fR, or \fBTcl_DeleteInterp\fR, @@ -170,16 +157,14 @@ or by replacing \fIname\fR in another call to \fBTcl_CreateObjCommand\fR. \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( - void *\fIclientData\fR); +typedef void Tcl_CmdDeleteProc( + 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 @@ -210,24 +195,22 @@ If the command is not found, then it returns 0. Otherwise it places information about the command in the \fBTcl_CmdInfo\fR structure 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; - void *\fIobjClientData\fR; + ClientData \fIobjClientData\fR; Tcl_CmdProc *\fIproc\fR; - void *\fIclientData\fR; + ClientData \fIclientData\fR; Tcl_CmdDeleteProc *\fIdeleteProc\fR; - void *\fIdeleteData\fR; + ClientData \fIdeleteData\fR; Tcl_Namespace *\fInamespacePtr\fR; -} \fBTcl_CmdInfo\fR; +} Tcl_CmdInfo; .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. It allows a program to determine whether it is faster to call \fIobjProc\fR or \fIproc\fR: @@ -234,22 +217,22 @@ \fIobjProc\fR is normally faster if \fIisNativeObjectProc\fR has the value 1. The fields \fIobjProc\fR and \fIobjClientData\fR have the same meaning as the \fIproc\fR and \fIclientData\fR arguments to \fBTcl_CreateObjCommand\fR; -they hold information about the value-based command procedure +they hold information about the object-based command procedure that the Tcl interpreter calls to implement the command. The fields \fIproc\fR and \fIclientData\fR hold information about the string-based command procedure 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 +object-based procedure after converting its string arguments to Tcl objects. +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. @@ -259,11 +242,11 @@ 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. +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 @@ -275,13 +258,13 @@ 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 +\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. +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 @@ -297,33 +280,18 @@ owned by Tcl and is only guaranteed to retain its value as long as the command is not deleted or renamed; callers should copy the string if they need to keep it for a long time. .PP \fBTcl_GetCommandFullName\fR produces the fully qualified name -of a command from a command token. +of a command from a command token. The name, including all namespace prefixes, -is appended to the value specified by \fIobjPtr\fR. +is appended to the object specified by \fIobjPtr\fR. .PP \fBTcl_GetCommandFromObj\fR returns a token for the command specified by the name in a \fBTcl_Obj\fR. The command name is resolved relative to the current namespace. Returns NULL if the command is not found. -.PP -.VS "info cmdtype feature" -\fBTcl_RegisterCommandTypeName\fR is used to associate a name (the -\fItypeName\fR argument) with a particular implementation function so that it -can then be looked up with \fBTcl_GetCommandTypeName\fR, which in turn is -called with a command token that information is wanted for and which returns -the name of the type that was registered for the implementation function used -for that command. (The lookup functionality is surfaced virtually directly in Tcl via -\fBinfo cmdtype\fR.) If there is no function registered for a particular -function, the result will be the string literal -.QW \fBnative\fR . -The registration of a name can be undone by registering a mapping to NULL -instead. The result from \fBTcl_GetCommandTypeName\fR will be exactly that -string which was registered, and not a copy; use of a compile-time constant -string is \fIstrongly recommended\fR. -.VE "info cmdtype feature" .SH "SEE ALSO" -Tcl_CreateCommand(3), Tcl_ResetResult(3), Tcl_SetObjResult(3) +Tcl_CreateCommand, Tcl_ResetResult, Tcl_SetObjResult + .SH KEYWORDS -bind, command, create, delete, namespace, value +bind, command, create, delete, namespace, object ADDED doc/CrtSlave.3 Index: doc/CrtSlave.3 ================================================================== --- /dev/null +++ doc/CrtSlave.3 @@ -0,0 +1,236 @@ +'\" +'\" 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_CreateSlave 3 7.6 Tcl "Tcl Library Procedures" +.so man.macros +.BS +.SH NAME +Tcl_IsSafe, Tcl_MakeSafe, Tcl_CreateSlave, Tcl_GetSlave, Tcl_GetMaster, Tcl_GetInterpPath, Tcl_CreateAlias, Tcl_CreateAliasObj, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_ExposeCommand, Tcl_HideCommand \- manage multiple Tcl interpreters, aliases and hidden commands +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +int +\fBTcl_IsSafe\fR(\fIinterp\fR) +.sp +int +\fBTcl_MakeSafe\fR(\fIinterp\fR) +.sp +Tcl_Interp * +\fBTcl_CreateSlave\fR(\fIinterp, slaveName, isSafe\fR) +.sp +Tcl_Interp * +\fBTcl_GetSlave\fR(\fIinterp, slaveName\fR) +.sp +Tcl_Interp * +\fBTcl_GetMaster\fR(\fIinterp\fR) +.sp +int +\fBTcl_GetInterpPath\fR(\fIaskingInterp, slaveInterp\fR) +.sp +int +\fBTcl_CreateAlias\fR(\fIslaveInterp, slaveCmd, targetInterp, targetCmd, + argc, argv\fR) +.sp +int +\fBTcl_CreateAliasObj\fR(\fIslaveInterp, slaveCmd, targetInterp, targetCmd, + objc, objv\fR) +.sp +int +\fBTcl_GetAlias\fR(\fIinterp, slaveCmd, targetInterpPtr, targetCmdPtr, + argcPtr, argvPtr\fR) +.sp +int +\fBTcl_GetAliasObj\fR(\fIinterp, slaveCmd, targetInterpPtr, targetCmdPtr, + objcPtr, objvPtr\fR) +.sp +int +\fBTcl_ExposeCommand\fR(\fIinterp, hiddenCmdName, cmdName\fR) +.sp +int +\fBTcl_HideCommand\fR(\fIinterp, cmdName, hiddenCmdName\fR) +.SH ARGUMENTS +.AS "const char *const" **targetInterpPtr out +.AP Tcl_Interp *interp in +Interpreter in which to execute the specified command. +.AP "const char" *slaveName in +Name of slave interpreter to create or manipulate. +.AP int isSafe in +If non-zero, a +.QW safe +slave that is suitable for running untrusted code +is created, otherwise a trusted slave is created. +.AP Tcl_Interp *slaveInterp in +Interpreter to use for creating the source command for an alias (see +below). +.AP "const char" *slaveCmd in +Name of source command for alias. +.AP Tcl_Interp *targetInterp in +Interpreter that contains the target command for an alias. +.AP "const char" *targetCmd in +Name of target command for alias in \fItargetInterp\fR. +.AP int argc in +Count of additional arguments to pass to the alias command. +.AP "const char *const" *argv in +Vector of strings, the additional arguments to pass to the alias command. +This storage is owned by the caller. +.AP int objc in +Count of additional object arguments to pass to the alias object command. +.AP Tcl_Obj **objv in +Vector of Tcl_Obj structures, the additional object arguments to pass to +the alias object command. +This storage is owned by the caller. +.AP Tcl_Interp **targetInterpPtr in +Pointer to location to store the address of the interpreter where a target +command is defined for an alias. +.AP "const char" **targetCmdPtr out +Pointer to location to store the address of the name of the target command +for an alias. +.AP int *argcPtr out +Pointer to location to store count of additional arguments to be passed to +the alias. The location is in storage owned by the caller. +.AP "const char" ***argvPtr out +Pointer to location to store a vector of strings, the additional arguments +to pass to an alias. The location is in storage owned by the caller, the +vector of strings is owned by the called function. +.AP int *objcPtr out +Pointer to location to store count of additional object arguments to be +passed to the alias. The location is in storage owned by the caller. +.AP Tcl_Obj ***objvPtr out +Pointer to location to store a vector of Tcl_Obj structures, the additional +arguments to pass to an object alias command. The location is in storage +owned by the caller, the vector of Tcl_Obj structures is owned by the +called function. +.AP "const char" *cmdName in +Name of an exposed command to hide or create. +.AP "const char" *hiddenCmdName in +Name under which a hidden command is stored and with which it can be +exposed or invoked. +.BE + +.SH DESCRIPTION +.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 \fBresult\fR field of the interpreter 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 +.QW safe +slave in which Tcl code has access only to set of Tcl commands defined as +.QW "Safe Tcl" ; +see the manual entry for the Tcl \fBinterp\fR command for details. +If the creation of the new slave interpreter failed, \fBNULL\fR is returned. +.PP +\fBTcl_IsSafe\fR returns \fB1\fR if \fIinterp\fR is +.QW safe +(was created with the \fBTCL_SAFE_INTERPRETER\fR flag specified), +\fB0\fR otherwise. +.PP +\fBTcl_MakeSafe\fR marks \fIinterp\fR as +.QW safe , +so that future +calls to \fBTcl_IsSafe\fR will return 1. It also removes all known +potentially-unsafe core functionality (both commands and variables) +from \fIinterp\fR. However, it cannot know what parts of an extension +or application are safe and does not make any attempt to remove those +parts, so safety is not guaranteed after calling \fBTcl_MakeSafe\fR. +Callers will want to take care with their use of \fBTcl_MakeSafe\fR +to avoid false claims of safety. For many situations, \fBTcl_CreateSlave\fR +may be a better choice, since it creates interpreters in a known-safe state. +.PP +\fBTcl_GetSlave\fR returns a pointer to a slave interpreter of +\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 sets the \fIresult\fR field in \fIaskingInterp\fR +to 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 the \fIresult\fR field in +\fIaskingInterp\fR contains the error message. +.PP +\fBTcl_CreateAlias\fR creates an object 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 +it fails; in that case, an error message is left in the object result +of \fIslaveInterp\fR. +Note that there are no restrictions on the ancestry relationship (as +created by \fBTcl_CreateSlave\fR) between \fIslaveInterp\fR and +\fItargetInterp\fR. Any two interpreters can be used, without any +restrictions on how they are related. +.PP +\fBTcl_CreateAliasObj\fR is similar to \fBTcl_CreateAlias\fR except +that it takes a vector of objects to pass as additional arguments instead +of a vector of strings. +.PP +\fBTcl_GetAlias\fR returns information about an alias \fIaliasName\fR +in \fIinterp\fR. Any of the result fields can be \fBNULL\fR, in +which case the corresponding datum is not returned. If a result field is +non\-\fBNULL\fR, the address indicated is set to the corresponding datum. +For example, if \fItargetNamePtr\fR is non\-\fBNULL\fR it is set to a +pointer to the string containing the name of the target command. +.PP +\fBTcl_GetAliasObj\fR is similar to \fBTcl_GetAlias\fR except that it +returns a pointer to a vector of Tcl_Obj structures instead of a vector of +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 in the \fIresult\fR field in \fIinterp\fR. +If an exposed command named \fIcmdName\fR already exists, +the operation returns \fBTCL_ERROR\fR and leaves an error message in the +object result of \fIinterp\fR. +If the operation succeeds, it returns \fBTCL_OK\fR. +After executing this command, attempts to use \fIcmdName\fR in a call to +\fBTcl_Eval\fR or with the Tcl \fBeval\fR command 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 in the object 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 in the object 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 the \fIresult\fR +field in \fIinterp\fR contains an error message. +If the operation succeeds, it returns \fBTCL_OK\fR. +After executing this command, attempts to use \fIcmdName\fR in a call to +\fBTcl_Eval\fR or with the Tcl \fBeval\fR command 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 Index: doc/CrtTimerHdlr.3 ================================================================== --- doc/CrtTimerHdlr.3 +++ doc/CrtTimerHdlr.3 @@ -2,11 +2,11 @@ '\" Copyright (c) 1990 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_CreateTimerHandler 3 7.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_CreateTimerHandler, Tcl_DeleteTimerHandler \- call a procedure at a given time @@ -22,16 +22,17 @@ .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 void *clientData in +.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 \fBTcl_CreateTimerHandler\fR arranges for \fIproc\fR to be invoked at a time \fImilliseconds\fR milliseconds in the future. @@ -46,16 +47,13 @@ are other pending events to process before the call to \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( - void *\fIclientData\fR); +typedef void Tcl_TimerProc(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 @@ -68,9 +66,8 @@ (e.g. because the time period has already elapsed and \fIproc\fR has been invoked then \fBTcl_DeleteTimerHandler\fR does nothing. The tokens returned by \fBTcl_CreateTimerHandler\fR never have a value of NULL, so if NULL is passed to \fBTcl_DeleteTimerHandler\fR then the procedure does nothing. -.SH "SEE ALSO" -after(n), Tcl_CreateFileHandler(3), Tcl_DoWhenIdle(3) + .SH KEYWORDS callback, clock, handler, timer Index: doc/CrtTrace.3 ================================================================== --- doc/CrtTrace.3 +++ doc/CrtTrace.3 @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2002 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. -'\" +'\" .TH Tcl_CreateTrace 3 "" Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_CreateTrace, Tcl_CreateObjTrace, Tcl_DeleteTrace \- arrange for command execution to be traced @@ -39,11 +39,11 @@ 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 void *clientData in +.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. @@ -61,25 +61,23 @@ There may be many traces in effect simultaneously for the same interpreter. .PP \fIobjProc\fR should have arguments and result that match the type, \fBTcl_CmdObjTraceProc\fR: -.PP .CS -typedef int \fBTcl_CmdObjTraceProc\fR( - \fBvoid *\fR \fIclientData\fR, +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[]); + \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 +\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 @@ -139,16 +137,14 @@ .PP 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( - \fBvoid *\fR \fIclientData\fR); +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, @@ -155,23 +151,21 @@ \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( - void *\fIclientData\fR, +typedef void Tcl_CmdTraceProc( + ClientData \fIclientData\fR, Tcl_Interp *\fIinterp\fR, int \fIlevel\fR, char *\fIcommand\fR, Tcl_CmdProc *\fIcmdProc\fR, - void *\fIcmdClientData\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 procedure that will be invoked; and \fIcmdClientData\fR, the client data that will be passed to the procedure. The \fIobjc\fR parameter Index: doc/DString.3 ================================================================== --- doc/DString.3 +++ doc/DString.3 @@ -2,16 +2,16 @@ '\" 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_DStringFree, Tcl_DStringResult, Tcl_DStringGetResult \- manipulate dynamic strings +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 \fR .sp \fBTcl_DStringInit\fR(\fIdsPtr\fR) @@ -24,17 +24,19 @@ .sp \fBTcl_DStringStartSublist\fR(\fIdsPtr\fR) .sp \fBTcl_DStringEndSublist\fR(\fIdsPtr\fR) .sp -size_t +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 @@ -45,14 +47,14 @@ 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 size_t length in -Number of bytes from \fIbytes\fR to add to dynamic string. If TCL_INDEX_NONE, +.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 size_t newLength in +.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. @@ -123,10 +125,14 @@ 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 Index: doc/DetachPids.3 ================================================================== --- doc/DetachPids.3 +++ doc/DetachPids.3 @@ -2,11 +2,11 @@ '\" 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_DetachPids 3 "" Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_DetachPids, Tcl_ReapDetachedProcs, Tcl_WaitPid \- manage child processes in background Index: doc/DictObj.3 ================================================================== --- doc/DictObj.3 +++ doc/DictObj.3 @@ -1,17 +1,17 @@ '\" '\" Copyright (c) 2003 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Tcl_DictObj 3 8.5 Tcl "Tcl Library Procedures" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -Tcl_NewDictObj, Tcl_DictObjPut, Tcl_DictObjGet, Tcl_DictObjRemove, Tcl_DictObjSize, Tcl_DictObjFirst, Tcl_DictObjNext, Tcl_DictObjDone, Tcl_DictObjPutKeyList, Tcl_DictObjRemoveKeyList \- manipulate Tcl values as dictionaries +Tcl_NewDictObj, Tcl_DictObjPut, Tcl_DictObjGet, Tcl_DictObjRemove, Tcl_DictObjSize, Tcl_DictObjFirst, Tcl_DictObjNext, Tcl_DictObjDone, Tcl_DictObjPutKeyList, Tcl_DictObjRemoveKeyList \- manipulate Tcl objects as dictionaries .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_Obj * @@ -45,27 +45,27 @@ int \fBTcl_DictObjRemoveKeyList\fR(\fIinterp, dictPtr, keyc, keyv\fR) .SH ARGUMENTS .AS Tcl_DictSearch "**valuePtrPtr" in/out .AP Tcl_Interp *interp in -If an error occurs while converting a value to be a dictionary value, -an error message is left in the interpreter's result value +If an error occurs while converting an object to be a dictionary object, +an error message is left in the interpreter's result object unless \fIinterp\fR is NULL. .AP Tcl_Obj *dictPtr in/out -Points to the dictionary value to be manipulated. -If \fIdictPtr\fR does not already point to a dictionary value, +Points to the dictionary object to be manipulated. +If \fIdictPtr\fR does not already point to a dictionary object, an attempt will be made to convert it to one. .AP Tcl_Obj *keyPtr in Points to the key for the key/value pair being manipulated within the -dictionary value. +dictionary object. .AP Tcl_Obj **keyPtrPtr out Points to a variable that will have the key from a key/value pair placed within it. May be NULL to indicate that the caller is not interested in the key. .AP Tcl_Obj *valuePtr in -Points to the value for the key/value pair being manipulated within the -dictionary value (or sub-value, in the case of +Points to the value for the key/value pair being manipulate within the +dictionary object (or sub-object, in the case of \fBTcl_DictObjPutKeyList\fR.) .AP Tcl_Obj **valuePtrPtr out Points to a variable that will have the value from a key/value pair placed within it. For \fBTcl_DictObjFirst\fR and \fBTcl_DictObjNext\fR, this may be NULL to indicate that the caller is @@ -86,33 +86,33 @@ completed, and a zero otherwise. .AP int keyc in Indicates the number of keys that will be supplied in the \fIkeyv\fR array. .AP "Tcl_Obj *const" *keyv in -Array of \fIkeyc\fR pointers to values that +Array of \fIkeyc\fR pointers to objects that \fBTcl_DictObjPutKeyList\fR and \fBTcl_DictObjRemoveKeyList\fR will use to locate the key/value pair to manipulate within the -sub-dictionaries of the main dictionary value passed to them. +sub-dictionaries of the main dictionary object passed to them. .BE .SH DESCRIPTION .PP -Tcl dictionary values have an internal representation that supports +Tcl dictionary objects have an internal representation that supports efficient mapping from keys to values and which guarantees that the particular ordering of keys within the dictionary remains the same modulo any keys being deleted (which removes them from the order) or added (which adds them to the end of the order). If reinterpreted as a list, the values at the even-valued indices in the list will be the keys of the dictionary, and each will be followed (in the odd-valued index) by the value associated with that key. .PP The procedures described in this man page are used to -create, modify, index, and iterate over dictionary values from C code. +create, modify, index, and iterate over dictionary objects from C code. .PP -\fBTcl_NewDictObj\fR creates a new, empty dictionary value. The -string representation of the value will be invalid, and the reference -count of the value will be zero. +\fBTcl_NewDictObj\fR creates a new, empty dictionary object. The +string representation of the object will be invalid, and the reference +count of the object will be zero. .PP \fBTcl_DictObjGet\fR looks up the given key within the given dictionary and writes a pointer to the value associated with that key into the variable pointed to by \fIvaluePtrPtr\fR, or a NULL if the key has no mapping within the dictionary. The result of this @@ -215,11 +215,11 @@ return TCL_ERROR; } for (; !done ; \fBTcl_DictObjNext\fR(&search, &key, &value, &done)) { /* * Note that strcmp() is not a good way of comparing - * values and is just used here for demonstration + * objects and is just used here for demonstration * purposes. */ if (!strcmp(Tcl_GetString(key), Tcl_GetString(value))) { break; } @@ -229,6 +229,6 @@ return TCL_OK; .CE .SH "SEE ALSO" Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_InitObjHashTable .SH KEYWORDS -dict, dict value, dictionary, dictionary value, hash table, iteration, value +dict, dict object, dictionary, dictionary object, hash table, iteration, object Index: doc/DoOneEvent.3 ================================================================== --- doc/DoOneEvent.3 +++ doc/DoOneEvent.3 @@ -2,11 +2,11 @@ '\" Copyright (c) 1990-1992 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_DoOneEvent 3 7.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_DoOneEvent \- wait for events and invoke event handlers @@ -18,11 +18,11 @@ \fBTcl_DoOneEvent\fR(\fIflags\fR) .SH ARGUMENTS .AS int flags .AP int flags in This parameter is normally zero. It may be an OR-ed combination -of any of the following flag bits: +of any of the following flag bits: \fBTCL_WINDOW_EVENTS\fR, \fBTCL_FILE_EVENTS\fR, \fBTCL_TIMER_EVENTS\fR, \fBTCL_IDLE_EVENTS\fR, \fBTCL_ALL_EVENTS\fR, or \fBTCL_DONT_WAIT\fR. .BE @@ -41,11 +41,11 @@ If any are found, it puts all of them on Tcl's event queue, calls handlers for the first event on the queue, and returns. If no events are found, \fBTcl_DoOneEvent\fR checks for \fBTcl_DoWhenIdle\fR callbacks; if any are found, it invokes all of them and returns. Finally, if no events or idle callbacks have been found, then -\fBTcl_DoOneEvent\fR sleeps until an event occurs; then it adds any +\fBTcl_DoOneEvent\fR sleeps until an event occurs; then it adds any new events to the Tcl event queue, calls handlers for the first event, and returns. The normal return value is 1 to signify that some event was processed (see below for other alternatives). .PP Index: doc/DoWhenIdle.3 ================================================================== --- doc/DoWhenIdle.3 +++ doc/DoWhenIdle.3 @@ -2,11 +2,11 @@ '\" Copyright (c) 1990 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_DoWhenIdle 3 7.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_DoWhenIdle, Tcl_CancelIdleCall \- invoke a procedure when there are no pending events @@ -19,13 +19,14 @@ \fBTcl_CancelIdleCall\fR(\fIproc, clientData\fR) .SH ARGUMENTS .AS Tcl_IdleProc clientData .AP Tcl_IdleProc *proc in Procedure to invoke. -.AP coid *clientData in +.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 @@ -38,16 +39,13 @@ \fBTcl_DoWhenIdle\fR is only usable in programs that 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( - void *\fIclientData\fR); +typedef void Tcl_IdleProc(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 @@ -79,9 +77,8 @@ At present it is not safe for an idle callback to reschedule itself continuously. This will interact badly with certain features of Tk that attempt to wait for all idle callbacks to complete. If you would like for an idle callback to reschedule itself continuously, it is better to use a timer handler with a zero timeout period. -.SH "SEE ALSO" -after(n), Tcl_CreateFileHandler(3), Tcl_CreateTimerHandler(3) + .SH KEYWORDS callback, defer, idle callback Index: doc/DoubleObj.3 ================================================================== --- doc/DoubleObj.3 +++ doc/DoubleObj.3 @@ -1,16 +1,16 @@ '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Tcl_DoubleObj 3 8.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_NewDoubleObj, Tcl_SetDoubleObj, Tcl_GetDoubleFromObj \- manipulate Tcl values as floating-point values +Tcl_NewDoubleObj, Tcl_SetDoubleObj, Tcl_GetDoubleFromObj \- manipulate Tcl objects as floating-point values .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_Obj * @@ -21,44 +21,44 @@ int \fBTcl_GetDoubleFromObj\fR(\fIinterp, objPtr, doublePtr\fR) .SH ARGUMENTS .AS Tcl_Interp doubleValue in/out .AP double doubleValue in -A double-precision floating-point value used to initialize or set a Tcl value. +A double-precision floating-point value used to initialize or set a Tcl object. .AP Tcl_Obj *objPtr in/out -For \fBTcl_SetDoubleObj\fR, this points to the value in which to store a +For \fBTcl_SetDoubleObj\fR, this points to the object in which to store a double value. -For \fBTcl_GetDoubleFromObj\fR, this refers to the value -from which to retrieve a double value. +For \fBTcl_GetDoubleFromObj\fR, this refers to the object +from which to retrieve a double value. .AP Tcl_Interp *interp in/out When non-NULL, an error message is left here when double value retrieval fails. .AP double *doublePtr out Points to place to store the double value obtained from \fIobjPtr\fR. .BE .SH DESCRIPTION .PP -These procedures are used to create, modify, and read Tcl values that +These procedures are used to create, modify, and read Tcl objects that hold double-precision floating-point values. .PP -\fBTcl_NewDoubleObj\fR creates and returns a new Tcl value initialized to -the double value \fIdoubleValue\fR. The returned Tcl value is unshared. +\fBTcl_NewDoubleObj\fR creates and returns a new Tcl object initialized to +the double value \fIdoubleValue\fR. The returned Tcl object is unshared. .PP -\fBTcl_SetDoubleObj\fR sets the value of an existing Tcl value pointed to +\fBTcl_SetDoubleObj\fR sets the value of an existing Tcl object pointed to by \fIobjPtr\fR to the double value \fIdoubleValue\fR. The \fIobjPtr\fR -argument must point to an unshared Tcl value. Any attempt to set the value -of a shared Tcl value violates Tcl's copy-on-write policy. Any existing -string representation or internal representation in the unshared Tcl value +argument must point to an unshared Tcl object. Any attempt to set the value +of a shared Tcl object violates Tcl's copy-on-write policy. Any existing +string representation or internal representation in the unshared Tcl object will be freed as a consequence of setting the new value. .PP \fBTcl_GetDoubleFromObj\fR attempts to retrieve a double value from the -Tcl value \fIobjPtr\fR. If the attempt succeeds, then \fBTCL_OK\fR is +Tcl object \fIobjPtr\fR. If the attempt succeeds, then \fBTCL_OK\fR is returned, and the double value is written to the storage pointed to by \fIdoublePtr\fR. If the attempt fails, then \fBTCL_ERROR\fR is returned, and if \fIinterp\fR is non-NULL, an error message is left in \fIinterp\fR. The \fBTcl_ObjType\fR of \fIobjPtr\fR may be changed to make subsequent -calls to \fBTcl_GetDoubleFromObj\fR more efficient. +calls to \fBTcl_GetDoubleFromObj\fR more efficient. '\" TODO: add discussion of treatment of NaN value .SH "SEE ALSO" Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult .SH KEYWORDS -double, double value, double type, internal representation, value, value type, string representation +double, double object, double type, internal representation, object, object type, string representation Index: doc/DumpActiveMemory.3 ================================================================== --- doc/DumpActiveMemory.3 +++ doc/DumpActiveMemory.3 @@ -1,10 +1,10 @@ '\" '\" Copyright (c) 1992-1999 Karl Lehenbauer and Mark Diekhans. '\" Copyright (c) 2000 by Scriptics Corporation. '\" All rights reserved. -'\" +'\" .TH "Tcl_DumpActiveMemory" 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_DumpActiveMemory, Tcl_InitMemory, Tcl_ValidateAllMemory \- Validated memory allocation interface @@ -37,15 +37,15 @@ .SH DESCRIPTION These functions provide access to Tcl memory debugging information. 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 +.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 \fBTcl_Alloc\fR was +(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 @@ -53,16 +53,16 @@ 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 \fBTcl_Alloc\fR and -\fBTcl_Free\fR are called. This function forces the validation to occur +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 Index: doc/Encoding.3 ================================================================== --- doc/Encoding.3 +++ doc/Encoding.3 @@ -1,16 +1,16 @@ '\" '\" 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 \- procedures for creating and using encodings +Tcl_GetEncoding, Tcl_FreeEncoding, Tcl_GetEncodingFromObj, Tcl_ExternalToUtfDString, Tcl_ExternalToUtf, Tcl_UtfToExternalDString, Tcl_UtfToExternal, Tcl_WinTCharToUtf, Tcl_WinUtfToTChar, 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 \fR .sp Tcl_Encoding @@ -17,12 +17,14 @@ \fBTcl_GetEncoding\fR(\fIinterp, name\fR) .sp void \fBTcl_FreeEncoding\fR(\fIencoding\fR) .sp +.VS 8.5 int \fBTcl_GetEncodingFromObj\fR(\fIinterp, objPtr, encodingPtr\fR) +.VE 8.5 .sp char * \fBTcl_ExternalToUtfDString\fR(\fIencoding, src, srcLen, dstPtr\fR) .sp char * @@ -34,59 +36,79 @@ .sp int \fBTcl_UtfToExternal\fR(\fIinterp, encoding, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr\fR) .sp +char * +\fBTcl_WinTCharToUtf\fR(\fItsrc, srcLen, dstPtr\fR) +.sp +TCHAR * +\fBTcl_WinUtfToTChar\fR(\fIsrc, srcLen, dstPtr\fR) +.sp const char * \fBTcl_GetEncodingName\fR(\fIencoding\fR) .sp int \fBTcl_SetSystemEncoding\fR(\fIinterp, name\fR) .sp +.VS 8.5 const char * \fBTcl_GetEncodingNameFromEnvironment\fR(\fIbufPtr\fR) +.VE 8.5 .sp void \fBTcl_GetEncodingNames\fR(\fIinterp\fR) .sp Tcl_Encoding \fBTcl_CreateEncoding\fR(\fItypePtr\fR) .sp +.VS 8.5 Tcl_Obj * \fBTcl_GetEncodingSearchPath\fR() .sp int \fBTcl_SetEncodingSearchPath\fR(\fIsearchPath\fR) +.VE 8.5 +.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. .AP Tcl_Encoding encoding in -The encoding to query, free, or use for converting text. If \fIencoding\fR is +The encoding to query, free, or use for converting text. If \fIencoding\fR is NULL, the current system encoding is used. .AP Tcl_Obj *objPtr in +.VS 8.5 Name of encoding to get token for. +.VE 8.5 .AP Tcl_Encoding *encodingPtr out +.VS 8.5 Points to storage where encoding token is to be written. +.VE 8.5 .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 function, an array of -UTF-8 characters to be converted to the specified encoding. +\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 size_t srcLen in -Length of \fIsrc\fR or \fItsrc\fR in bytes. If the length is negative, the +.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. +Various flag bits OR-ed together. \fBTCL_ENCODING_START\fR signifies that the source buffer is the first block in a (potentially multi-block) input stream, telling the conversion routine to reset to an initial state and perform any initialization that needs to occur before the first byte is converted. \fBTCL_ENCODING_END\fR signifies that the source buffer is the last @@ -94,19 +116,19 @@ routine to perform any finalization that needs to occur after the last byte is converted and then to reset to an initial state. \fBTCL_ENCODING_STOPONERROR\fR signifies that the conversion routine should return immediately upon reading a source character that does not exist in the target encoding; otherwise a default fallback character will -automatically be substituted. +automatically be substituted. .AP Tcl_EncodingState *statePtr in/out Used when converting a (generally long or indefinite length) byte stream in a piece-by-piece fashion. The conversion routine stores its current state in \fI*statePtr\fR after \fIsrc\fR (the buffer containing the current piece) has been converted; that state information must be passed back when converting the next piece of the stream so the conversion routine knows what state it was in when it left off at the end of the -last piece. May be NULL, in which case the value specified for \fIflags\fR +last piece. May be NULL, in which case the value specified for \fIflags\fR is ignored and the source buffer is assumed to contain the complete string to convert. .AP char *dst out Buffer in which the converted result will be stored. No more than \fIdstLen\fR bytes will be stored in \fIdst\fR. @@ -121,17 +143,21 @@ buffer as a result of the conversion. May be NULL. .AP int *dstCharsPtr out Filled with the number of characters that correspond to the number of bytes stored in the output buffer. May be NULL. .AP Tcl_DString *bufPtr out +.VS 8.5 Storage for the prescribed system encoding name. +.VE 8.5 .AP "const Tcl_EncodingType" *typePtr in -Structure that defines a new type of encoding. +Structure that defines a new type of encoding. .AP Tcl_Obj *searchPath in +.VS 8.5 List of filesystem directories in which to search for encoding data files. +.VE 8.5 .AP "const char" *path in -A path to the location of the encoding file. +A path to the location of the encoding file. .BE .SH INTRODUCTION .PP These routines convert between Tcl's internal character representation, UTF-8, and character representations used by various operating systems or @@ -166,18 +192,19 @@ The encoding package maintains a database of all encodings currently in use. The first time \fIname\fR is seen, \fBTcl_GetEncoding\fR returns an encoding with a reference count of 1. If the same \fIname\fR is requested further times, then the reference count for that encoding is incremented without the overhead of allocating a new encoding and all its associated -data structures. +data structures. .PP When an \fIencoding\fR is no longer needed, \fBTcl_FreeEncoding\fR should be called to release it. When an \fIencoding\fR is no longer in use anywhere (i.e., it has been freed as many times as it has been gotten) \fBTcl_FreeEncoding\fR will release all storage the encoding was using -and delete it from the database. +and delete it from the database. .PP +.VS 8.5 \fBTcl_GetEncodingFromObj\fR treats the string representation of \fIobjPtr\fR as an encoding name, and finds an encoding with that name, just as \fBTcl_GetEncoding\fR does. When an encoding is found, it is cached within the \fBobjPtr\fR value for future reference, the \fBTcl_Encoding\fR token is written to the storage pointed to by @@ -185,13 +212,14 @@ encoding is found, the value \fBTCL_ERROR\fR is returned, and no writing to \fB*\fR\fIencodingPtr\fR takes place. Just as with \fBTcl_GetEncoding\fR, the caller should call \fBTcl_FreeEncoding\fR on the resulting encoding token when that token will no longer be used. +.VE 8.5 .PP \fBTcl_ExternalToUtfDString\fR converts a source buffer \fIsrc\fR from the -specified \fIencoding\fR into UTF-8. The converted bytes are stored in +specified \fIencoding\fR into UTF-8. The converted bytes are stored in \fIdstPtr\fR, which is then null-terminated. The caller should eventually call \fBTcl_DStringFree\fR to free any information stored in \fIdstPtr\fR. When converting, if any of the characters in the source buffer cannot be represented in the target encoding, a default fallback character will be used. The return value is a pointer to the value stored in the DString. @@ -213,21 +241,21 @@ The last few bytes in the source buffer were the beginning of a multibyte sequence, but more bytes were needed to complete this sequence. A subsequent call to the conversion routine should pass a buffer containing the unconverted bytes that remained in \fIsrc\fR plus some further bytes from the source stream to properly convert the formerly split-up multibyte -sequence. +sequence. .IP \fBTCL_CONVERT_SYNTAX\fR 29 The source buffer contained an invalid character sequence. This may occur if the input stream has been damaged or if the input encoding method was misidentified. .IP \fBTCL_CONVERT_UNKNOWN\fR 29 The source buffer contained a character that could not be represented in -the target encoding and \fBTCL_ENCODING_STOPONERROR\fR was specified. +the target encoding and \fBTCL_ENCODING_STOPONERROR\fR was specified. .RE .LP -\fBTcl_UtfToExternalDString\fR converts a source buffer \fIsrc\fR from UTF-8 +\fBTcl_UtfToExternalDString\fR converts a source buffer \fIsrc\fR from UTF-8 into the specified \fIencoding\fR. The converted bytes are stored in \fIdstPtr\fR, which is then terminated with the appropriate encoding-specific null. The caller should eventually call \fBTcl_DStringFree\fR to free any information stored in \fIdstPtr\fR. When converting, if any of the characters in the source buffer cannot be represented in the target @@ -240,14 +268,56 @@ \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. On Windows 95 +(as with the Unix operating system), +all strings exchanged between Tcl and the operating system are +.QW "char" +based. On Windows NT, some strings exchanged between Tcl and the +operating system are +.QW "char" +oriented while others are in Unicode. By +convention, in Windows a TCHAR is a character in the ANSI code page +on Windows 95 and a Unicode character on Windows NT. +.PP +If you planned to use the same +.QW "char" +based interfaces on both Windows +95 and Windows NT, you could use \fBTcl_UtfToExternal\fR and +\fBTcl_ExternalToUtf\fR (or their \fBTcl_DString\fR equivalents) with an +encoding of NULL (the current system encoding). On the other hand, +if you planned to use the Unicode interface when running on Windows NT +and the +.QW "char" +interfaces when running on Windows 95, you would have +to perform the following type of test over and over in your program +(as represented in pseudo-code): +.CS +if (running NT) { + encoding <- Tcl_GetEncoding("unicode"); + nativeBuffer <- Tcl_UtfToExternal(encoding, utfBuffer); + Tcl_FreeEncoding(encoding); +} else { + nativeBuffer <- Tcl_UtfToExternal(NULL, utfBuffer); +} +.CE +\fBTcl_WinUtfToTChar\fR and \fBTcl_WinTCharToUtf\fR automatically +handle this test and use the proper encoding based on the current +operating system. \fBTcl_WinUtfToTChar\fR returns a pointer to +a TCHAR string, and \fBTcl_WinTCharToUtf\fR expects a TCHAR string +pointer as the \fIsrc\fR string. Otherwise, these functions +behave identically to \fBTcl_UtfToExternalDString\fR and +\fBTcl_ExternalToUtfDString\fR. .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 +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 \fBTcl_SetSystemEncoding\fR sets the default encoding that should be used whenever the user passes a NULL value for the \fIencoding\fR argument to @@ -257,21 +327,23 @@ returned and an error message is left in \fIinterp\fR. Otherwise, this procedure increments the reference count of the new system encoding, decrements the reference count of the old system encoding, and returns \fBTCL_OK\fR. .PP +.VS 8.5 \fBTcl_GetEncodingNameFromEnvironment\fR provides a means for the Tcl library to report the encoding name it believes to be the correct one to use as the system encoding, based on system calls and examination of 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. +.VE 8.5 .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_SetEncodingSearchPath\fR. This procedure does not ensure that the +\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 @@ -282,25 +354,25 @@ encoding functions. \fBTcl_CreateEncoding\fR returns an encoding with a reference count of 1. If an encoding with the specified \fIname\fR already exists, then its entry in the database is replaced with the new encoding; the token for the old encoding will remain valid and continue to behave as before, but users of the new token will now call the new -encoding procedures. +encoding procedures. .PP -The \fItypePtr\fR argument to \fBTcl_CreateEncoding\fR contains information +The \fItypePtr\fR argument to \fBTcl_CreateEncoding\fR contains information about the name of the encoding and the procedures that will be called to convert between this encoding and UTF-8. It is defined as follows: .PP .CS typedef struct Tcl_EncodingType { - const char *\fIencodingName\fR; - Tcl_EncodingConvertProc *\fItoUtfProc\fR; - Tcl_EncodingConvertProc *\fIfromUtfProc\fR; - Tcl_EncodingFreeProc *\fIfreeProc\fR; - void *\fIclientData\fR; - int \fInullSize\fR; -} \fBTcl_EncodingType\fR; + const char *\fIencodingName\fR; + Tcl_EncodingConvertProc *\fItoUtfProc\fR; + Tcl_EncodingConvertProc *\fIfromUtfProc\fR; + Tcl_EncodingFreeProc *\fIfreeProc\fR; + ClientData \fIclientData\fR; + int \fInullSize\fR; +} Tcl_EncodingType; .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 @@ -324,18 +396,18 @@ .PP The callback procedures \fItoUtfProc\fR and \fIfromUtfProc\fR should match the type \fBTcl_EncodingConvertProc\fR: .PP .CS -typedef int \fBTcl_EncodingConvertProc\fR( - void *\fIclientData\fR, - const char *\fIsrc\fR, - int \fIsrcLen\fR, - int \fIflags\fR, +typedef int Tcl_EncodingConvertProc( + ClientData \fIclientData\fR, + const char *\fIsrc\fR, + int \fIsrcLen\fR, + int \fIflags\fR, Tcl_EncodingState *\fIstatePtr\fR, - char *\fIdst\fR, - int \fIdstLen\fR, + char *\fIdst\fR, + int \fIdstLen\fR, int *\fIsrcReadPtr\fR, int *\fIdstWrotePtr\fR, int *\fIdstCharsPtr\fR); .CE .PP @@ -347,30 +419,30 @@ arguments to the callback procedures are the same as the arguments, documented at the top, to \fBTcl_ExternalToUtf\fR or \fBTcl_UtfToExternal\fR, with the following exceptions. If the \fIsrcLen\fR argument to one of those high-level functions is negative, the value passed to the callback procedure will be the appropriate -encoding-specific string length of \fIsrc\fR. If any of the \fIsrcReadPtr\fR, +encoding-specific string length of \fIsrc\fR. If any of the \fIsrcReadPtr\fR, \fIdstWrotePtr\fR, or \fIdstCharsPtr\fR arguments to one of the high-level functions is NULL, the corresponding value passed to the callback procedure will be a non-NULL location. .PP -The callback procedure \fIfreeProc\fR, if non-NULL, should match the type +The callback procedure \fIfreeProc\fR, if non-NULL, should match the type \fBTcl_EncodingFreeProc\fR: -.PP .CS -typedef void \fBTcl_EncodingFreeProc\fR( - void *\fIclientData\fR); +typedef void Tcl_EncodingFreeProc( + 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. +specified to \fBTcl_CreateEncoding\fR when the encoding was created. .PP +.VS 8.5 \fBTcl_GetEncodingSearchPath\fR and \fBTcl_SetEncodingSearchPath\fR are called to access and set the list of filesystem directories searched -for encoding data files. +for encoding data files. .PP The value returned by \fBTcl_GetEncodingSearchPath\fR is the value stored by the last successful call to \fBTcl_SetEncodingSearchPath\fR. If no calls to \fBTcl_SetEncodingSearchPath\fR have occurred, Tcl will compute an initial @@ -382,19 +454,29 @@ 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. +.VE 8.5 .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 external encoding may consist of single-byte, multi-byte, or double-byte -characters. +characters. .PP Each dynamically-loadable encoding is represented as a text file. The initial line of the file, beginning with a .QW # symbol, is a comment @@ -414,19 +496,18 @@ lead bytes and represent themselves. An example is \fBshiftjis\fR, used by many Japanese computers. .IP "[4] \fBE\fR" An escape-sequence encoding, specifying that certain sequences of bytes do not represent characters, but commands that describe how following bytes -should be interpreted. +should be interpreted. .PP -The rest of the lines in the file depend on the type. +The rest of the lines in the file depend on the type. .PP Cases [1], [2], and [3] are collectively referred to as table-based encoding files. The lines in a table-based encoding file are in the same format as this example taken from the \fBshiftjis\fR encoding (this is not the complete file): -.PP .CS # Encoding file: shiftjis, multi-byte M 003F 0 40 00 @@ -467,11 +548,11 @@ .PP The third line of the file is three numbers. The first number is the fallback character (in base 16) to use when converting from UTF-8 to this encoding. The second number is a \fB1\fR if this file represents the encoding for a symbol font, or \fB0\fR otherwise. The last number (in base -10) is how many pages of data follow. +10) is how many pages of data follow. .PP Subsequent lines in the example above are pages that describe how to map from the encoding into 2-byte Unicode. The first line in a page identifies the page number. Following it are 256 double-byte numbers, arranged as 16 rows of 16 numbers. Given a character in the encoding, the high byte of @@ -488,11 +569,10 @@ If all characters on a page would map to 0000, that page can be omitted. .PP Case [4] is the escape-sequence encoding file. The lines in an this type of file are in the same format as this example taken from the \fBiso2022-jp\fR encoding: -.PP .CS .ta 1.5i # Encoding file: iso2022-jp, escape-driven E init {} Index: doc/Ensemble.3 ================================================================== --- doc/Ensemble.3 +++ doc/Ensemble.3 @@ -1,18 +1,18 @@ '\" '\" Copyright (c) 2005 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" '\" This documents the C API introduced in TIP#235 -'\" +'\" .TH Tcl_Ensemble 3 8.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_CreateEnsemble, Tcl_FindEnsemble, Tcl_GetEnsembleFlags, Tcl_GetEnsembleMappingDict, Tcl_GetEnsembleNamespace, Tcl_GetEnsembleParameterList, Tcl_GetEnsembleUnknownHandler, Tcl_GetEnsembleSubcommandList, Tcl_IsEnsemble, Tcl_SetEnsembleFlags, Tcl_SetEnsembleMappingDict, Tcl_SetEnsembleParameterList, Tcl_SetEnsembleSubcommandList, Tcl_SetEnsembleUnknownHandler \- manipulate ensemble commands +Tcl_CreateEnsemble, Tcl_FindEnsemble, Tcl_GetEnsembleFlags, Tcl_GetEnsembleMappingDict, Tcl_GetEnsembleNamespace, Tcl_GetEnsembleUnknownHandler, Tcl_GetEnsembleSubcommandList, Tcl_IsEnsemble, Tcl_SetEnsembleFlags, Tcl_SetEnsembleMappingDict, Tcl_SetEnsembleSubcommandList, Tcl_SetEnsembleUnknownHandler \- manipulate ensemble commands .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_Command @@ -34,16 +34,10 @@ \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) @@ -68,44 +62,43 @@ .AP Tcl_Namespace *namespacePtr in The namespace to which the ensemble command is to be bound, or NULL for the current namespace. .AP int ensFlags in An ORed set of flag bits describing the basic configuration of the -ensemble. Currently only one bit has meaning, \fBTCL_ENSEMBLE_PREFIX\fR, +ensemble. Currently only one bit has meaning, TCL_ENSEMBLE_PREFIX, which is present when the ensemble command should also match unambiguous prefixes of subcommands. .AP Tcl_Obj *cmdNameObj in A value holding the name of the ensemble command to look up. .AP int flags in An ORed set of flag bits controlling the behavior of -\fBTcl_FindEnsemble\fR. Currently only \fBTCL_LEAVE_ERR_MSG\fR is supported. +\fBTcl_FindEnsemble\fR. Currently only TCL_LEAVE_ERR_MSG is supported. .AP Tcl_Command token in A normal command token that refers to an ensemble command, or which you wish to use for testing as an ensemble command in \fBTcl_IsEnsemble\fR. .AP int *ensFlagsPtr out Pointer to a variable into which to write the current ensemble flag -bits; currently only the bit \fBTCL_ENSEMBLE_PREFIX\fR is defined. +bits; currently only the bit TCL_ENSEMBLE_PREFIX is defined. .AP Tcl_Obj *dictObj in A dictionary value to use for the subcommand to implementation command prefix mapping dictionary in the ensemble. May be NULL if the mapping dictionary is to be removed. .AP Tcl_Obj **dictObjPtr out Pointer to a variable into which to write the current ensemble mapping dictionary. .AP Tcl_Obj *listObj in -A list value to use for the list of formal pre-subcommand parameters, the -defined list of subcommands in the dictionary or the unknown subcommand -handler command prefix. May be NULL if the subcommand list or unknown handler -are to be removed. +A list value to use for the defined list of subcommands in the +dictionary or the unknown subcommmand handler command prefix. May be +NULL if the subcommand list or unknown handler are to be removed. .AP Tcl_Obj **listObjPtr out -Pointer to a variable into which to write the current list of formal -pre-subcommand parameters, the defined list of subcommands or the current -unknown handler prefix. +Pointer to a variable into which to write the current defiend list of +subcommands or the current unknown handler prefix. .AP Tcl_Namespace **namespacePtrPtr out Pointer to a variable into which to write the handle of the namespace to which the ensemble is bound. .BE + .SH DESCRIPTION An ensemble is a command, bound to some namespace, which consists of a collection of subcommands implemented by other Tcl commands. The first argument to the ensemble command is always interpreted as a selector that states what subcommand to execute. @@ -113,17 +106,17 @@ Ensembles are created using \fBTcl_CreateEnsemble\fR, which takes four arguments: the interpreter to work within, the name of the ensemble to create, the namespace within the interpreter to bind the ensemble to, and the default set of ensemble flags. The result of the function is the command token for the ensemble, which may be used to further -configure the ensemble using the API described below in -\fBENSEMBLE PROPERTIES\fR. +configure the ensemble using the API described below in \fBENSEMBLE +PROPERTIES\fR. .PP Given the name of an ensemble command, the token for that command may be retrieved using \fBTcl_FindEnsemble\fR. If the given command name (in \fIcmdNameObj\fR) does not refer to an ensemble command, the -result of the function is NULL and (if the \fBTCL_LEAVE_ERR_MSG\fR bit is +result of the function is NULL and (if the TCL_LEAVE_ERR_MSG bit is set in \fIflags\fR) an error message is left in the interpreter result. .PP A command token may be checked to see if it refers to an ensemble using \fBTcl_IsEnsemble\fR. This returns 1 if the token refers to an @@ -131,85 +124,65 @@ .SS "ENSEMBLE PROPERTIES" Every ensemble has four read-write properties and a read-only property. The properties are: .TP \fBflags\fR (read-write) -. The set of flags for the ensemble, expressed as a -bit-field. Currently, the only public flag is \fBTCL_ENSEMBLE_PREFIX\fR +bit-field. Currently, the only public flag is TCL_ENSEMBLE_PREFIX which is set when unambiguous prefixes of subcommands are permitted to be resolved to implementations as well as exact matches. The flags may be read and written using \fBTcl_GetEnsembleFlags\fR and \fBTcl_SetEnsembleFlags\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). +functions is a Tcl result code (TCL_OK, or TCL_ERROR if the token does +not refer to an ensemble). .TP \fBmapping dictionary\fR (read-write) -. A dictionary containing a mapping from subcommand names to lists of words to use as a command prefix (replacing the first two words of the command which are the ensemble command itself and the subcommand name), or NULL if every subcommand is to be mapped to the command with the same unqualified name in the ensemble's bound namespace. Defaults to NULL. May be read and written using \fBTcl_GetEnsembleMappingDict\fR and \fBTcl_SetEnsembleMappingDict\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 +code (TCL_OK, or TCL_ERROR if the token does not refer to an 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 \fBTcl_GetEnsembleSubcommandList\fR and \fBTcl_SetEnsembleSubcommandList\fR respectively. The result of both -of those functions is a Tcl result code (\fBTCL_OK\fR, or -\fBTCL_ERROR\fR if the +of those functions is a Tcl result code (TCL_OK, or TCL_ERROR if the token does not refer to an ensemble) and the list obtained from \fBTcl_GetEnsembleSubcommandList\fR should always be treated as immutable even if it is unshared. .TP \fBunknown subcommand handler command prefix\fR (read-write) -. A list of words to prepend on the front of any subcommand when the subcommand is unknown to the ensemble (according to the current prefix handling rule); see the \fBnamespace ensemble\fR command for more details. If NULL, the default behavior \- generate a suitable error message \- will be used when an unknown subcommand is encountered. May be read and written using \fBTcl_GetEnsembleUnknownHandler\fR and \fBTcl_SetEnsembleUnknownHandler\fR respectively. The result of both -functions is a Tcl result code (\fBTCL_OK\fR, or \fBTCL_ERROR\fR if -the token does +functions is a Tcl result code (TCL_OK, or TCL_ERROR if the token does not refer to an ensemble) and the list obtained from \fBTcl_GetEnsembleUnknownHandler\fR should always be treated as immutable even if it is unshared. .TP \fBbound namespace\fR (read-only) -. The namespace to which the ensemble is bound; when the namespace is deleted, so too will the ensemble, and this namespace is also the namespace whose list of exported commands is used if both the mapping dictionary and the subcommand list properties are NULL. May be read using \fBTcl_GetEnsembleNamespace\fR which returns a Tcl result code -(\fBTCL_OK\fR, or \fBTCL_ERROR\fR if the token does not refer to an ensemble). +(TCL_OK, or TCL_ERROR if the token does not refer to an ensemble). + .SH "SEE ALSO" namespace(n), Tcl_DeleteCommandFromToken(3) -.SH KEYWORDS -command, ensemble Index: doc/Environment.3 ================================================================== --- doc/Environment.3 +++ doc/Environment.3 @@ -1,11 +1,11 @@ '\" '\" 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_PutEnv 3 "7.5" Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_PutEnv \- procedures to manipulate the environment @@ -31,8 +31,8 @@ intended to be a stand-in for the UNIX \fBputenv\fR system call. All Tcl-based applications using \fBputenv\fR should redefine it to \fBTcl_PutEnv\fR so that they will interface properly to the Tcl runtime. .SH "SEE ALSO" -env(n) +tclvars(n) .SH KEYWORDS environment, variable Index: doc/Eval.3 ================================================================== --- doc/Eval.3 +++ doc/Eval.3 @@ -3,16 +3,16 @@ '\" 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 \- execute Tcl scripts +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 \fR .sp int @@ -36,36 +36,42 @@ 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. +A Tcl object containing the script to execute. .AP int flags in ORed combination of flag bits that specify additional options. \fBTCL_EVAL_GLOBAL\fR and \fBTCL_EVAL_DIRECT\fR are currently supported. .AP "const char" *fileName in Name of a file containing a Tcl script. .AP int objc in -The number of values in the array pointed to by \fIobjPtr\fR; +The number of objects in the array pointed to by \fIobjPtr\fR; this is also the number of words in the command. .AP Tcl_Obj **objv in -Points to an array of pointers to values; each value holds the +Points to an array of pointers to objects; each object holds the value of a single word in the command to execute. .AP int numBytes in 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 @@ -75,11 +81,11 @@ until either an error occurs or the end of the script is reached. If this is the first time \fIobjPtr\fR has been executed, its commands are compiled into bytecode instructions which are then executed. The bytecodes are saved in \fIobjPtr\fR so that the compilation step -can be skipped if the value is evaluated again in the future. +can be skipped if the object is evaluated again in the future. .PP The return value from \fBTcl_EvalObjEx\fR (and all the other procedures described here) 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 @@ -103,31 +109,37 @@ which will be safely substituted by the Tcl interpreter into .QW ^Z . .PP \fBTcl_EvalObjv\fR executes a single pre-parsed command instead of a script. The \fIobjc\fR and \fIobjv\fR arguments contain the values -of the words for the Tcl command, one word in each value in +of the words for the Tcl command, one word in each object in \fIobjv\fR. \fBTcl_EvalObjv\fR evaluates the command and returns a completion code and result just like \fBTcl_EvalObjEx\fR. The caller of \fBTcl_EvalObjv\fR has to manage the reference count of the -elements of \fIobjv\fR, insuring that the values are valid until -\fBTcl_EvalObjv\fR returns. +elements of \fIobjv\fR, insuring that the objects are valid until +\fBTcl_EvalObjv\fR returns. .PP \fBTcl_Eval\fR is similar to \fBTcl_EvalObjEx\fR except that the script to -be executed is supplied as a string instead of a value and no compilation +be executed is supplied as a string instead of an object and no compilation occurs. The string should be a proper UTF-8 string as converted by \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. + \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 object 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. +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 @@ -136,36 +148,37 @@ .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. +\fIinterp->result\fR 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. Like \fBTcl_VarEval\fR, \fBTcl_VarEvalVA\fR is deprecated. .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 -. This flag is only used by \fBTcl_EvalObjEx\fR; it is ignored by other procedures. If this flag bit is set, the script is not compiled to bytecodes; instead it is executed directly as is done by \fBTcl_EvalEx\fR. The \fBTCL_EVAL_DIRECT\fR flag is useful in situations where the -contents of a value are going to change immediately, so the +contents of an object are going to change immediately, so the bytecodes will not be reused in a future execution. In this case, it is faster to execute the script directly. .TP 23 \fBTCL_EVAL_GLOBAL\fR -. -If this flag is set, the script is evaluated in the global namespace instead of -the current namespace and its variable context consists of global variables -only (it ignores any Tcl procedures that are active). -.\" TODO: document TCL_EVAL_INVOKE and TCL_EVAL_NOERR. +If this flag is set, the script is processed at global level. This +means that it is evaluated in the global namespace and its variable +context consists of global variables only (it ignores any Tcl +procedures at are active). .SH "MISCELLANEOUS DETAILS" .PP During the processing of a Tcl command it is legal to make nested calls to evaluate other commands (this is how procedures and @@ -187,9 +200,9 @@ it converts the return code to \fBTCL_ERROR\fR and sets \fIinterp\fR's result to an error message indicating that the \fBreturn\fR, \fBbreak\fR, or \fBcontinue\fR command was invoked in an inappropriate place. This means that top-level applications should never see a return code -from \fBTcl_EvalObjEx\fR other than \fBTCL_OK\fR or \fBTCL_ERROR\fR. +from \fBTcl_EvalObjEx\fR other then \fBTCL_OK\fR or \fBTCL_ERROR\fR. .SH KEYWORDS -execute, file, global, result, script, value +execute, file, global, object, result, script Index: doc/Exit.3 ================================================================== --- doc/Exit.3 +++ doc/Exit.3 @@ -1,11 +1,11 @@ '\" '\" 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_Exit 3 8.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_Exit, Tcl_Finalize, Tcl_CreateExitHandler, Tcl_DeleteExitHandler, Tcl_ExitThread, Tcl_FinalizeThread, Tcl_CreateThreadExitHandler, Tcl_DeleteThreadExitHandler, Tcl_SetExitProc \- end the application or thread (and invoke exit handlers) @@ -27,12 +27,14 @@ .sp \fBTcl_CreateThreadExitHandler\fR(\fIproc, clientData\fR) .sp \fBTcl_DeleteThreadExitHandler\fR(\fIproc, clientData\fR) .sp +.VS 8.5 Tcl_ExitProc * \fBTcl_SetExitProc\fR(\fIproc\fR) +.VE 8.5 .SH ARGUMENTS .AS Tcl_ExitProc clientData .AP int status in Provides information about why the application or thread exited. Exact meaning may @@ -40,11 +42,11 @@ 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 void *clientData in +.AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR. .BE .SH DESCRIPTION .PP @@ -60,22 +62,28 @@ 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. +.VS 8.5 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 void *); the application +consisting of the exit status (cast to ClientData); the application exit handler should not return control to Tcl. +.VE 8.5 .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. -Your code should always invoke \fBTcl_Finalize\fR when \fBTcl\fR is being -unloaded, to ensure proper cleanup. \fBTcl_Finalize\fR can be safely called +On some systems \fBTcl\fR is automatically notified when it is being +unloaded, and it calls \fBTcl_Finalize\fR internally; on these systems it +not necessary for the caller to explicitly call \fBTcl_Finalize\fR. +However, to ensure portability, your code should always invoke +\fBTcl_Finalize\fR when \fBTcl\fR is being unloaded, to ensure that the +code will work on all platforms. \fBTcl_Finalize\fR can be safely called more than once. .PP \fBTcl_ExitThread\fR is used to terminate the current thread and invoke per-thread exit handlers. This finalization is done by \fBTcl_FinalizeThread\fR, which you can call if you just want to clean @@ -88,16 +96,13 @@ \fBTcl_CreateThreadExitHandler\fR arranges for \fIproc\fR to be invoked 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( - void *\fIclientData\fR); +typedef void Tcl_ExitProc(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 @@ -108,10 +113,11 @@ called to delete a previously-created exit handler. It removes the handler indicated by \fIproc\fR and \fIclientData\fR so that no call to \fIproc\fR will be made. If no such handler exists then \fBTcl_DeleteExitHandler\fR or \fBTcl_DeleteThreadExitHandler\fR does nothing. +.PP .PP \fBTcl_Finalize\fR and \fBTcl_Exit\fR execute all registered exit handlers, in reverse order from the order in which they were registered. This matches the natural order in which extensions are loaded and unloaded; if extension \fBA\fR loads extension \fBB\fR, it usually @@ -118,25 +124,24 @@ unloads \fBB\fR before it itself is unloaded. If extension \fBA\fR registers its exit handlers before loading extension \fBB\fR, this ensures that any exit handlers for \fBB\fR will be executed before the exit handlers for \fBA\fR. .PP -\fBTcl_Finalize\fR and \fBTcl_Exit\fR call \fBTcl_FinalizeThread\fR +\fBTcl_Finalize\fR and \fBTcl_Exit\fR call \fBTcl_FinalizeThread\fR and the thread exit handlers \fIafter\fR the process-wide exit handlers. This is because thread finalization shuts down the I/O channel system, so any attempt at I/O by the global exit handlers will vanish into the bitbucket. .PP +.VS 8.5 \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 void *value. -.PP -\fBTcl_SetExitProc\fR can not be used in stub-enabled extensions. -.SH "SEE ALSO" -exit(n) +cast to a ClientData value. +.VE 8.5 + .SH KEYWORDS -abort, callback, cleanup, dynamic loading, end application, exit, unloading, thread +callback, cleanup, dynamic loading, end application, exit, unloading, thread Index: doc/ExprLong.3 ================================================================== --- doc/ExprLong.3 +++ doc/ExprLong.3 @@ -2,11 +2,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_ExprLong 3 7.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean, Tcl_ExprString \- evaluate an expression @@ -28,11 +28,11 @@ .SH ARGUMENTS .AS Tcl_Interp *booleanPtr out .AP Tcl_Interp *interp in Interpreter in whose context to evaluate \fIexpr\fR. .AP "const char" *expr in -Expression to be evaluated. +Expression to be evaluated. .AP long *longPtr out Pointer to location in which to store the integer value of the expression. .AP int *doublePtr out Pointer to location in which to store the floating-point value of the @@ -47,15 +47,15 @@ These four procedures all evaluate the expression given by the \fIexpr\fR argument and return the result in one of four different forms. The expression can have any of the forms accepted by the \fBexpr\fR command. Note that these procedures have been largely replaced by the -value-based procedures \fBTcl_ExprLongObj\fR, \fBTcl_ExprDoubleObj\fR, +object-based procedures \fBTcl_ExprLongObj\fR, \fBTcl_ExprDoubleObj\fR, \fBTcl_ExprBooleanObj\fR, and \fBTcl_ExprObj\fR. -Those value-based procedures evaluate an expression held in a Tcl value +Those object-based procedures evaluate an expression held in a Tcl object instead of a string. -The value argument can retain an internal representation +The object argument can retain an internal representation that is more efficient to execute. .PP The \fIinterp\fR argument refers to an interpreter used to evaluate the expression (e.g. for variables and nested Tcl commands) and to return error information. @@ -101,6 +101,6 @@ .SH "SEE ALSO" Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj, Tcl_ExprObj .SH KEYWORDS -boolean, double, evaluate, expression, integer, value, string +boolean, double, evaluate, expression, integer, object, string Index: doc/ExprLongObj.3 ================================================================== --- doc/ExprLongObj.3 +++ doc/ExprLongObj.3 @@ -1,11 +1,11 @@ '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Tcl_ExprLongObj 3 8.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj, Tcl_ExprObj \- evaluate an expression @@ -27,11 +27,11 @@ .SH ARGUMENTS .AS Tcl_Interp **resultPtrPtr out .AP Tcl_Interp *interp in Interpreter in whose context to evaluate \fIobjPtr\fR. .AP Tcl_Obj *objPtr in -Pointer to a value containing the expression to evaluate. +Pointer to an object containing the expression to evaluate. .AP long *longPtr out Pointer to location in which to store the integer value of the expression. .AP int *doublePtr out Pointer to location in which to store the floating-point value of the @@ -38,11 +38,11 @@ expression. .AP int *booleanPtr out Pointer to location in which to store the 0/1 boolean value of the expression. .AP Tcl_Obj **resultPtrPtr out -Pointer to location in which to store a pointer to the value +Pointer to location in which to store a pointer to the object that is the result of the expression. .BE .SH DESCRIPTION .PP @@ -91,16 +91,16 @@ or .QW no , or else an error occurs. .PP If \fBTcl_ExprObj\fR successfully evaluates the expression, -it stores a pointer to the Tcl value +it stores a pointer to the Tcl object containing the expression's value at \fI*resultPtrPtr\fR. In this case, the caller is responsible for calling -\fBTcl_DecrRefCount\fR to decrement the value's reference count -when it is finished with the value. +\fBTcl_DecrRefCount\fR to decrement the object's reference count +when it is finished with the object. .SH "SEE ALSO" Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean, Tcl_ExprString, Tcl_GetObjResult .SH KEYWORDS -boolean, double, evaluate, expression, integer, value, string +boolean, double, evaluate, expression, integer, object, string Index: doc/FileSystem.3 ================================================================== --- doc/FileSystem.3 +++ doc/FileSystem.3 @@ -1,17 +1,16 @@ '\" '\" Copyright (c) 2001 Vincent Darley -'\" Copyright (c) 2008-2010 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Filesystem 3 8.4 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_FSRegister, Tcl_FSUnregister, Tcl_FSData, Tcl_FSMountsChanged, Tcl_FSGetFileSystemForPath, Tcl_FSGetPathType, Tcl_FSCopyFile, Tcl_FSCopyDirectory, Tcl_FSCreateDirectory, Tcl_FSDeleteFile, Tcl_FSRemoveDirectory, Tcl_FSRenameFile, Tcl_FSListVolumes, Tcl_FSEvalFile, Tcl_FSEvalFileEx, Tcl_FSLoadFile, Tcl_FSUnloadFile, Tcl_FSMatchInDirectory, Tcl_FSLink, Tcl_FSLstat, Tcl_FSUtime, Tcl_FSFileAttrsGet, Tcl_FSFileAttrsSet, Tcl_FSFileAttrStrings, Tcl_FSStat, Tcl_FSAccess, Tcl_FSOpenFileChannel, Tcl_FSGetCwd, Tcl_FSChdir, Tcl_FSPathSeparator, Tcl_FSJoinPath, Tcl_FSSplitPath, Tcl_FSEqualPaths, Tcl_FSGetNormalizedPath, Tcl_FSJoinToPath, Tcl_FSConvertToPathType, Tcl_FSGetInternalRep, Tcl_FSGetTranslatedPath, Tcl_FSGetTranslatedStringPath, Tcl_FSNewNativePath, Tcl_FSGetNativePath, Tcl_FSFileSystemInfo, Tcl_GetAccessTimeFromStat, Tcl_GetBlockSizeFromStat, Tcl_GetBlocksFromStat, Tcl_GetChangeTimeFromStat, Tcl_GetDeviceTypeFromStat, Tcl_GetFSDeviceFromStat, Tcl_GetFSInodeFromStat, Tcl_GetGroupIdFromStat, Tcl_GetLinkCountFromStat, Tcl_GetModeFromStat, Tcl_GetModificationTimeFromStat, Tcl_GetSizeFromStat, Tcl_GetUserIdFromStat, Tcl_AllocStatBuf \- procedures to interact with any filesystem +Tcl_FSRegister, Tcl_FSUnregister, Tcl_FSData, Tcl_FSMountsChanged, Tcl_FSGetFileSystemForPath, Tcl_FSGetPathType, Tcl_FSCopyFile, Tcl_FSCopyDirectory, Tcl_FSCreateDirectory, Tcl_FSDeleteFile, Tcl_FSRemoveDirectory, Tcl_FSRenameFile, Tcl_FSListVolumes, Tcl_FSEvalFile, Tcl_FSEvalFileEx, Tcl_FSLoadFile, Tcl_FSMatchInDirectory, Tcl_FSLink, Tcl_FSLstat, Tcl_FSUtime, Tcl_FSFileAttrsGet, Tcl_FSFileAttrsSet, Tcl_FSFileAttrStrings, Tcl_FSStat, Tcl_FSAccess, Tcl_FSOpenFileChannel, Tcl_FSGetCwd, Tcl_FSChdir, Tcl_FSPathSeparator, Tcl_FSJoinPath, Tcl_FSSplitPath, Tcl_FSEqualPaths, Tcl_FSGetNormalizedPath, Tcl_FSJoinToPath, Tcl_FSConvertToPathType, Tcl_FSGetInternalRep, Tcl_FSGetTranslatedPath, Tcl_FSGetTranslatedStringPath, Tcl_FSNewNativePath, Tcl_FSGetNativePath, Tcl_FSFileSystemInfo, Tcl_AllocStatBuf \- procedures to interact with any filesystem .SH SYNOPSIS .nf \fB#include \fR .sp int @@ -18,17 +17,17 @@ \fBTcl_FSRegister\fR(\fIclientData, fsPtr\fR) .sp int \fBTcl_FSUnregister\fR(\fIfsPtr\fR) .sp -void * +ClientData \fBTcl_FSData\fR(\fIfsPtr\fR) .sp void \fBTcl_FSMountsChanged\fR(\fIfsPtr\fR) .sp -const Tcl_Filesystem * +Tcl_Filesystem* \fBTcl_FSGetFileSystemForPath\fR(\fIpathPtr\fR) .sp Tcl_PathType \fBTcl_FSGetPathType\fR(\fIpathPtr\fR) .sp @@ -48,30 +47,29 @@ \fBTcl_FSRemoveDirectory\fR(\fIpathPtr, int recursive, errorPtr\fR) .sp int \fBTcl_FSRenameFile\fR(\fIsrcPathPtr, destPathPtr\fR) .sp -Tcl_Obj * +Tcl_Obj* \fBTcl_FSListVolumes\fR(\fIvoid\fR) .sp +.VS 8.5 int \fBTcl_FSEvalFileEx\fR(\fIinterp, pathPtr, encodingName\fR) +.VE 8.5 .sp 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) + handlePtr, unloadProcPtr\fR) .sp int \fBTcl_FSMatchInDirectory\fR(\fIinterp, resultPtr, pathPtr, pattern, types\fR) .sp -Tcl_Obj * +Tcl_Obj* \fBTcl_FSLink\fR(\fIlinkNamePtr, toPtr, linkAction\fR) .sp int \fBTcl_FSLstat\fR(\fIpathPtr, statPtr\fR) .sp @@ -82,11 +80,11 @@ \fBTcl_FSFileAttrsGet\fR(\fIinterp, int index, pathPtr, objPtrRef\fR) .sp int \fBTcl_FSFileAttrsSet\fR(\fIinterp, int index, pathPtr, Tcl_Obj *objPtr\fR) .sp -const char *const * +const char** \fBTcl_FSFileAttrStrings\fR(\fIpathPtr, objPtrRef\fR) .sp int \fBTcl_FSStat\fR(\fIpathPtr, statPtr\fR) .sp @@ -94,104 +92,65 @@ \fBTcl_FSAccess\fR(\fIpathPtr, mode\fR) .sp Tcl_Channel \fBTcl_FSOpenFileChannel\fR(\fIinterp, pathPtr, modeString, permissions\fR) .sp -Tcl_Obj * +Tcl_Obj* \fBTcl_FSGetCwd\fR(\fIinterp\fR) .sp int \fBTcl_FSChdir\fR(\fIpathPtr\fR) .sp -Tcl_Obj * +Tcl_Obj* \fBTcl_FSPathSeparator\fR(\fIpathPtr\fR) .sp -Tcl_Obj * +Tcl_Obj* \fBTcl_FSJoinPath\fR(\fIlistObj, elements\fR) .sp -Tcl_Obj * +Tcl_Obj* \fBTcl_FSSplitPath\fR(\fIpathPtr, lenPtr\fR) .sp int \fBTcl_FSEqualPaths\fR(\fIfirstPtr, secondPtr\fR) .sp -Tcl_Obj * +Tcl_Obj* \fBTcl_FSGetNormalizedPath\fR(\fIinterp, pathPtr\fR) .sp -Tcl_Obj * +Tcl_Obj* \fBTcl_FSJoinToPath\fR(\fIbasePtr, objc, objv\fR) .sp int \fBTcl_FSConvertToPathType\fR(\fIinterp, pathPtr\fR) .sp -void * +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 * +Tcl_Obj* \fBTcl_FSNewNativePath\fR(\fIfsPtr, clientData\fR) .sp -const void * +const char * \fBTcl_FSGetNativePath\fR(\fIpathPtr\fR) .sp -Tcl_Obj * +Tcl_Obj* \fBTcl_FSFileSystemInfo\fR(\fIpathPtr\fR) .sp -Tcl_StatBuf * +Tcl_StatBuf* \fBTcl_AllocStatBuf\fR() -.sp -Tcl_WideInt -\fBTcl_GetAccessTimeFromStat\fR(\fIstatPtr\fR) -.sp -unsigned -\fBTcl_GetBlockSizeFromStat\fR(\fIstatPtr\fR) -.sp -Tcl_WideUInt -\fBTcl_GetBlocksFromStat\fR(\fIstatPtr\fR) -.sp -Tcl_WideInt -\fBTcl_GetChangeTimeFromStat\fR(\fIstatPtr\fR) -.sp -int -\fBTcl_GetDeviceTypeFromStat\fR(\fIstatPtr\fR) -.sp -unsigned -\fBTcl_GetFSDeviceFromStat\fR(\fIstatPtr\fR) -.sp -unsigned -\fBTcl_GetFSInodeFromStat\fR(\fIstatPtr\fR) -.sp -int -\fBTcl_GetGroupIdFromStat\fR(\fIstatPtr\fR) -.sp -int -\fBTcl_GetLinkCountFromStat\fR(\fIstatPtr\fR) -.sp -unsigned -\fBTcl_GetModeFromStat\fR(\fIstatPtr\fR) -.sp -Tcl_WideInt -\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 +.AS Tcl_FSUnloadFileProc **unloadProcPtr out +.AP Tcl_Filesystem *fsPtr in Points to a structure containing the addresses of procedures that can be called to perform the various filesystem operations. .AP Tcl_Obj *pathPtr in -The path represented by this value is used for the operation in -question. If the value does not already have an internal \fBpath\fR +The path represented by this object is used for the operation in +question. If the object does not already have an internal \fBpath\fR representation, it will be converted to have one. .AP Tcl_Obj *srcPathPtr in As for \fIpathPtr\fR, but used for the source file for a copy or rename operation. .AP Tcl_Obj *destPathPtr in @@ -202,40 +161,40 @@ file identified by \fIpathPtr\fR and to be evaluated. .AP "const char" *pattern in 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. +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 void *clientData in -The native description of the path value to create. +.AP ClientData clientData in +The native description of the path object to create. .AP Tcl_Obj *firstPtr in -The first of two path values to compare. The value may be converted +The first of two path objects to compare. The object 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 +The second of two path objects to compare. The object may be converted to \fBpath\fR type. .AP Tcl_Obj *listObj in The list of path elements to operate on with a \fBjoin\fR operation. .AP int elements in If non-negative, the number of elements in the \fIlistObj\fR which should -be joined together. If negative, then all elements are joined. +be joined together. If negative, then all elements are joined. .AP Tcl_Obj **errorPtr out -In the case of an error, filled with a value containing the name of +In the case of an error, filled with an object containing the name of the file which caused an error in the various copy/rename operations. .AP Tcl_Obj **objPtrRef out -Filled with a value containing the result of the operation. +Filled with an object containing the result of the operation. .AP Tcl_Obj *resultPtr out -Pre-allocated value in which to store (using +Pre-allocated object in which to store (using \fBTcl_ListObjAppendElement\fR) the list of files or directories which are successfully matched. .AP int mode in -Mask consisting of one or more of R_OK, W_OK, X_OK and F_OK. R_OK, +Mask consisting of one or more of R_OK, W_OK, X_OK and F_OK. R_OK, W_OK and X_OK request checking whether the file exists and has read, -write and execute permissions, respectively. F_OK just requests +write and execute permissions, respectively. F_OK just requests checking for the existence of the file. .AP Tcl_StatBuf *statPtr out The structure that contains the result of a stat or lstat operation. .AP "const char" *sym1 in Name of a procedure to look up in the file's symbol table @@ -243,32 +202,30 @@ 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 void **clientDataPtr out +.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 +.AP Tcl_LoadHandle *handlePtr 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 -Handle to the loaded library to be unloaded. .AP utimbuf *tval in The access and modification times in this structure are read and used to set those values for a given file. .AP "const char" *modeString in -Specifies how the file is to be accessed. May have any of the values +Specifies how the file is to be accessed. May have any of the values allowed for the \fImode\fR argument to the Tcl \fBopen\fR command. .AP int permissions in -POSIX-style permission flags such as 0644. If a new file is created, these +POSIX-style permission flags such as 0644. If a new file is created, these permissions will be set on the created file. .AP int *lenPtr out If non-NULL, filled with the number of elements in the split path. .AP Tcl_Obj *basePtr in -The base path on to which to join the given elements. May be NULL. +The base path on to which to join the given elements. May be NULL. .AP int objc in The number of elements in \fIobjv\fR. .AP "Tcl_Obj *const" objv[] in The elements to join to the given base path. .AP Tcl_Obj *linkNamePtr in @@ -281,34 +238,35 @@ created (will be ignored if \fItoPtr\fR is NULL). Valid bits to set are \fBTCL_CREATE_SYMBOLIC_LINK\fR and \fBTCL_CREATE_HARD_LINK\fR. When both flags are set and the underlying filesystem can do either, symbolic links are preferred. .BE + .SH DESCRIPTION .PP There are several reasons for calling the \fBTcl_FS\fR API functions -(e.g.\ \fBTcl_FSAccess\fR and \fBTcl_FSStat\fR) +(e.g. \fBTcl_FSAccess\fR and \fBTcl_FSStat\fR) rather than calling system level functions like \fBaccess\fR and -\fBstat\fR directly. First, they will work cross-platform, so an +\fBstat\fR directly. First, they will work cross-platform, so an extension which calls them should work unmodified on Unix and -Windows. Second, the Windows implementation of some of these functions -fixes some bugs in the system level calls. Third, these function calls +Windows. Second, the Windows implementation of some of these functions +fixes some bugs in the system level calls. Third, these function calls deal with any .QW "Utf to platform-native" path conversions which may be required (and may cache the results of such conversions for greater -efficiency on subsequent calls). Fourth, and perhaps most importantly, +efficiency on subsequent calls). Fourth, and perhaps most importantly, all of these functions are .QW "virtual filesystem aware" . Any virtual filesystem (VFS for short) which has been registered (through \fBTcl_FSRegister\fR) may reroute file access to alternative -media or access methods. This means that all of these functions (and +media or access methods. This means that all of these functions (and therefore the corresponding \fBfile\fR, \fBglob\fR, \fBpwd\fR, \fBcd\fR, -\fBopen\fR, etc.\ Tcl commands) may be operate on +\fBopen\fR, etc. Tcl commands) may be operate on .QW files which are not -native files in the native filesystem. This also means that any Tcl +native files in the native filesystem. This also means that any Tcl extension which accesses the filesystem (FS for short) through this API is automatically .QW "virtual filesystem aware" . Of course, if an extension accesses the native filesystem directly (through platform-specific @@ -315,49 +273,47 @@ APIs, for example), then Tcl cannot intercept such calls. .PP If appropriate VFSes have been registered, the .QW files may, to give two -examples, be remote (e.g.\ situated on a remote ftp server) or archived -(e.g.\ lying inside a .zip archive). Such registered filesystems provide +examples, be remote (e.g. situated on a remote ftp server) or archived +(e.g. lying inside a .zip archive). Such registered filesystems provide a lookup table of functions to implement all or some of the functionality -listed here. Finally, the \fBTcl_FSStat\fR and \fBTcl_FSLstat\fR calls +listed here. Finally, the \fBTcl_FSStat\fR and \fBTcl_FSLstat\fR calls abstract away from what the .QW "struct stat" buffer is actually declared to be, allowing the same code to be used both on systems with and systems without support for files larger than 2GB in size. .PP -The \fBTcl_FS\fR API is \fBTcl_Obj\fR-ified and may cache internal -representations and other path-related strings (e.g.\ the current working -directory). One side-effect of this is that one must not pass in values -with a reference count of zero to any of these functions. If such calls were +The \fBTcl_FS\fR API is objectified and may cache internal +representations and other path-related strings (e.g. the current working +directory). One side-effect of this is that one must not pass in objects +with a reference count of zero to any of these functions. If such calls were handled, they might result in memory leaks (under some circumstances, the filesystem code may wish -to retain a reference to the passed in value, and so one must not assume -that after any of these calls return, the value still has a reference count of +to retain a reference to the passed in object, and so one must not assume +that after any of these calls return, the object still has a reference count of zero - it may have been incremented) or in a direct segmentation fault (or other memory access error) -due to the value being freed part way through the complex value +due to the object being freed part way through the complex object manipulation required to ensure that the path is fully normalized and -absolute for filesystem determination. The practical lesson to learn +absolute for filesystem determination. The practical lesson to learn from this is that -.PP .CS Tcl_Obj *path = Tcl_NewStringObj(...); Tcl_FS\fIWhatever\fR(path); Tcl_DecrRefCount(path); .CE -.PP is wrong, and may cause memory errors. The \fIpath\fR must have its reference count incremented before passing it in, or -decrementing it. For this reason, values with a reference count of zero are +decrementing it. For this reason, objects with a reference count of zero are considered not to be valid filesystem paths and calling any Tcl_FS API -function with such a value will result in no action being taken. +function with such an object will result in no action being taken. .SS "FS API FUNCTIONS" \fBTcl_FSCopyFile\fR attempts to copy the file given by \fIsrcPathPtr\fR to the -path name given by \fIdestPathPtr\fR. If the two paths given lie in the same +path name given by \fIdestPathPtr\fR. If the two paths given lie in the same filesystem (according to \fBTcl_FSGetFileSystemForPath\fR) then that filesystem's .QW "copy file" function is called (if it is non-NULL). Otherwise the function returns -1 and sets the \fBerrno\fR global C @@ -365,11 +321,11 @@ .QW EXDEV POSIX error code (which signifies a .QW "cross-domain link" ). .PP \fBTcl_FSCopyDirectory\fR attempts to copy the directory given by \fIsrcPathPtr\fR to the -path name given by \fIdestPathPtr\fR. If the two paths given lie in the same +path name given by \fIdestPathPtr\fR. If the two paths given lie in the same filesystem (according to \fBTcl_FSGetFileSystemForPath\fR) then that filesystem's .QW "copy file" function is called (if it is non-NULL). Otherwise the function returns -1 and sets the \fBerrno\fR global C @@ -392,31 +348,32 @@ \fIpathPtr\fR by calling the owning filesystem's .QW "remove directory" function. .PP \fBTcl_FSRenameFile\fR attempts to rename the file or directory given by -\fIsrcPathPtr\fR to the path name given by \fIdestPathPtr\fR. If the two paths +\fIsrcPathPtr\fR to the path name given by \fIdestPathPtr\fR. If the two paths given lie in the same filesystem (according to \fBTcl_FSGetFileSystemForPath\fR) then that filesystem's .QW "rename file" -function is called (if it is non-NULL). Otherwise the function returns -1 +function is called (if it is non-NULL). Otherwise the function returns -1 and sets the \fBerrno\fR global C variable to the .QW EXDEV POSIX error code (which signifies a .QW "cross-domain link" ). .PP \fBTcl_FSListVolumes\fR calls each filesystem which has a non-NULL .QW "list volumes" -function and asks them to return their list of root volumes. It +function and asks them to return their list of root volumes. It accumulates the return values in a list which is returned to the caller (with a reference count of 0). .PP +.VS 8.5 \fBTcl_FSEvalFileEx\fR reads the file given by \fIpathPtr\fR using the encoding identified by \fIencodingName\fR and evaluates -its contents as a Tcl script. It returns the same information as +its contents as a Tcl script. It returns the same information as \fBTcl_EvalObjEx\fR. -If \fIencodingName\fR is NULL, the utf-8 encoding is used for +If \fIencodingName\fR is NULL, the system encoding is used for reading the file contents. If the file could not be read then a Tcl error is returned to describe why the file could not be read. The eofchar for files is .QW \e32 @@ -428,139 +385,129 @@ or .QW \eu001a , which will be safely substituted by the Tcl interpreter into .QW ^Z . \fBTcl_FSEvalFile\fR is a simpler version of -\fBTcl_FSEvalFileEx\fR that always uses the utf-8 encoding +\fBTcl_FSEvalFileEx\fR that always uses the system encoding when reading the file. +.VE 8.5 .PP \fBTcl_FSLoadFile\fR dynamically loads a binary code file into memory and returns the addresses of two procedures within that file, if they are -defined. The appropriate function for the filesystem to which \fIpathPtr\fR -belongs will be called. If that filesystem does not implement this +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 +Returns a standard Tcl completion code. If an error occurs, an error +message is left in the \fIinterp\fR's result. .PP \fBTcl_FSMatchInDirectory\fR is used by the globbing code to search a -directory for all files which match a given pattern. The appropriate +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 -interp is NULL, which is allowed), but good results are placed in the +occurred in globbing. Error messages are placed in interp (unless +interp is NULL, which is allowed), but good results are placed in the resultPtr given. .PP Note that the \fBglob\fR code implements recursive patterns internally, so this function will only ever be passed simple patterns, which can be -matched using the logic of \fBstring match\fR. To handle recursion, Tcl +matched using the logic of \fBstring match\fR. To handle recursion, Tcl will call this function frequently asking only for directories to be -returned. A special case of being called with a NULL pattern indicates +returned. A special case of being called with a NULL pattern indicates that the path needs to be checked only for the correct type. .PP \fBTcl_FSLink\fR replaces the library version of \fBreadlink\fR, and -extends it to support the creation of links. The appropriate function +extends it to support the creation of links. The appropriate function for the filesystem to which \fIlinkNamePtr\fR belongs will be called. .PP If the \fItoPtr\fR is NULL, a .QW "read link" -action is performed. The result +action is performed. The result is a Tcl_Obj specifying the contents of the symbolic link given by -\fIlinkNamePtr\fR, or NULL if the link could not be read. The result is owned -by the caller, which should call \fBTcl_DecrRefCount\fR when the result is no -longer needed. If the \fItoPtr\fR is not NULL, Tcl should create a link -of one of the types passed in in the \fIlinkAction\fR flag. This flag is +\fIlinkNamePtr\fR, or NULL if the link could not be read. The result is owned +by the caller, which should call Tcl_DecrRefCount when the result is no +longer needed. If the \fItoPtr\fR is not NULL, Tcl should create a link +of one of the types passed in in the \fIlinkAction\fR flag. This flag is an ORed combination of \fBTCL_CREATE_SYMBOLIC_LINK\fR and \fBTCL_CREATE_HARD_LINK\fR. -Where a choice exists (i.e.\ more than one flag is passed in), the Tcl -convention is to prefer symbolic links. When a link is successfully +Where a choice exists (i.e. more than one flag is passed in), the Tcl +convention is to prefer symbolic links. When a link is successfully created, the return value should be \fItoPtr\fR (which is therefore -already owned by the caller). If unsuccessful, NULL is returned. +already owned by the caller). If unsuccessful, NULL is returned. .PP -\fBTcl_FSLstat\fR fills the \fITcl_StatBuf\fR structure \fIstatPtr\fR with -information about the specified file. You do not need any access rights to the +\fBTcl_FSLstat\fR fills the stat structure \fIstatPtr\fR with information +about the specified file. You do not need any access rights to the file to get this information but you need search rights to all -directories named in the path leading to the file. The \fITcl_StatBuf\fR -structure includes info regarding device, inode (always 0 on Windows), +directories named in the path leading to the file. The stat structure +includes info regarding device, inode (always 0 on Windows), privilege mode, nlink (always 1 on Windows), user id (always 0 on Windows), group id (always 0 on Windows), rdev (same as device on Windows), size, last access time, last modification time, and last metadata change time. -See \fBPORTABLE STAT RESULT API\fR for a description of how to write -portable code to allocate and access the \fITcl_StatBuf\fR structure. .PP If \fIpath\fR exists, \fBTcl_FSLstat\fR returns 0 and the stat structure -is filled with data. Otherwise, -1 is returned, and no stat info is +is filled with data. Otherwise, -1 is returned, and no stat info is given. .PP \fBTcl_FSUtime\fR replaces the library version of utime. .PP This returns 0 on success and -1 on error (as per the \fButime\fR -documentation). If successful, the function +documentation). If successful, the function will update the .QW atime and .QW mtime values of the file given. .PP \fBTcl_FSFileAttrsGet\fR implements read access for the hookable \fBfile -attributes\fR subcommand. The appropriate function for the filesystem to +attributes\fR subcommand. The appropriate function for the filesystem to which \fIpathPtr\fR belongs will be called. .PP -If the result is \fBTCL_OK\fR, then a value was placed in +If the result is \fBTCL_OK\fR, then an object was placed in \fIobjPtrRef\fR, which will only be temporarily valid (unless \fBTcl_IncrRefCount\fR is called). .PP \fBTcl_FSFileAttrsSet\fR implements write access for the hookable \fBfile -attributes\fR subcommand. The appropriate function for the filesystem to +attributes\fR subcommand. The appropriate function for the filesystem to which \fIpathPtr\fR belongs will be called. .PP \fBTcl_FSFileAttrStrings\fR implements part of the hookable \fBfile -attributes\fR subcommand. The appropriate function for the filesystem +attributes\fR subcommand. The appropriate function for the filesystem to which \fIpathPtr\fR belongs will be called. .PP The called procedure may either return an array of strings, or may -instead return NULL and place a Tcl list into the given \fIobjPtrRef\fR. Tcl +instead return NULL and place a Tcl list into the given \fIobjPtrRef\fR. Tcl will take that list and first increment its reference count before using it. -On completion of that use, Tcl will decrement its reference count. Hence if +On completion of that use, Tcl will decrement its reference count. Hence if the list should be disposed of by Tcl when done, it should have a reference count of zero, and if the list should not be disposed of, the -filesystem should ensure it retains a reference count to the value. +filesystem should ensure it retains a reference count to the object. .PP \fBTcl_FSAccess\fR checks whether the process would be allowed to read, write or test for existence of the file (or other filesystem object) -whose name is \fIpathname\fR. If \fIpathname\fR is a symbolic link on Unix, +whose name is \fIpathname\fR. If \fIpathname\fR is a symbolic link on Unix, then permissions of the file referred by this symbolic link are tested. .PP -On success (all requested permissions granted), zero is returned. On +On success (all requested permissions granted), zero is returned. On error (at least one bit in mode asked for a permission that is denied, or some other error occurred), -1 is returned. .PP -\fBTcl_FSStat\fR fills the \fITcl_StatBuf\fR structure \fIstatPtr\fR with -information about the specified file. You do not need any access rights to the +\fBTcl_FSStat\fR fills the stat structure \fIstatPtr\fR with information +about the specified file. You do not need any access rights to the file to get this information but you need search rights to all -directories named in the path leading to the file. The \fITcl_StatBuf\fR -structure includes info regarding device, inode (always 0 on Windows), +directories named in the path leading to the file. The stat structure +includes info regarding device, inode (always 0 on Windows), privilege mode, nlink (always 1 on Windows), user id (always 0 on Windows), group id (always 0 on Windows), rdev (same as device on Windows), size, last access time, last modification time, and last metadata change time. -See \fBPORTABLE STAT RESULT API\fR for a description of how to write -portable code to allocate and access the \fITcl_StatBuf\fR structure. .PP If \fIpath\fR exists, \fBTcl_FSStat\fR returns 0 and the stat structure -is filled with data. Otherwise, -1 is returned, and no stat info is +is filled with data. Otherwise, -1 is returned, and no stat info is given. .PP \fBTcl_FSOpenFileChannel\fR opens a file specified by \fIpathPtr\fR and returns a channel handle that can be used to perform input and output on the file. This API is modeled after the \fBfopen\fR procedure of @@ -573,205 +520,206 @@ In addition, if \fIinterp\fR is non-NULL, \fBTcl_FSOpenFileChannel\fR leaves an error message in \fIinterp\fR's result after any error. .PP The newly created channel is not registered in the supplied interpreter; to register it, use \fBTcl_RegisterChannel\fR. -If one of the standard channels, \fBstdin\fR, \fBstdout\fR or \fBstderr\fR was +If one of the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was previously closed, the act of creating the new channel also assigns it as a replacement for the standard channel. .PP \fBTcl_FSGetCwd\fR replaces the library version of \fBgetcwd\fR. .PP -It returns the Tcl library's current working directory. This may be +It returns the Tcl library's current working directory. This may be different to the native platform's working directory, which happens when the current working directory is not in the native filesystem. .PP The result is a pointer to a Tcl_Obj specifying the current directory, -or NULL if the current directory could not be determined. If NULL is +or NULL if the current directory could not be determined. If NULL is returned, an error message is left in the \fIinterp\fR's result. .PP -The result already has its reference count incremented for the caller. When -it is no longer needed, that reference count should be decremented. This is +The result already has its reference count incremented for the caller. When +it is no longer needed, that reference count should be decremented. This is needed for thread-safety purposes, to allow multiple threads to access this and related functions, while ensuring the results are always valid. .PP -\fBTcl_FSChdir\fR replaces the library version of \fBchdir\fR. The path is -normalized and then passed to the filesystem which claims it. If that +\fBTcl_FSChdir\fR replaces the library version of \fBchdir\fR. The path is +normalized and then passed to the filesystem which claims it. If that filesystem does not implement this function, Tcl will fallback to a combination of \fBstat\fR and \fBaccess\fR to check whether the directory exists and has appropriate permissions. .PP -For results, see \fBchdir\fR documentation. If successful, we keep a +For results, see \fBchdir\fR documentation. If successful, we keep a record of the successful path in \fIcwdPathPtr\fR for subsequent calls to \fBTcl_FSGetCwd\fR. .PP \fBTcl_FSPathSeparator\fR returns the separator character to be used for -most specific element of the path specified by \fIpathPtr\fR (i.e.\ the last +most specific element of the path specified by \fIpathPtr\fR (i.e. the last part of the path). .PP The separator is returned as a Tcl_Obj containing a string of length -1. If the path is invalid, NULL is returned. +1. If the path is invalid, NULL is returned. .PP \fBTcl_FSJoinPath\fR takes the given Tcl_Obj, which must be a valid list (which is allowed to have a reference count of zero), and returns the path -value given by considering the first \fIelements\fR elements as valid path +object given by considering the first \fIelements\fR elements as valid path segments (each path segment may be a complete path, a partial path or -just a single possible directory or file name). If any path segment is +just a single possible directory or file name). If any path segment is actually an absolute path, then all prior path segments are discarded. If \fIelements\fR is less than 0, we use the entire list. .PP -It is possible that the returned value is actually an element +It is possible that the returned object is actually an element of the given list, so the caller should be careful to increment the reference count of the result before freeing the list. .PP -The returned value, typically with a reference count of zero (but it +The returned object, typically with a reference count of zero (but it could be shared -under some conditions), contains the joined path. The caller must -add a reference count to the value before using it. In particular, the -returned value could be an element of the given list, so freeing the -list might free the value prematurely if no reference count has been taken. -If the number of elements is zero, then the returned value will be +under some conditions), contains the joined path. The caller must +add a reference count to the object before using it. In particular, the +returned object could be an element of the given list, so freeing the +list might free the object prematurely if no reference count has been taken. +If the number of elements is zero, then the returned object will be an empty-string Tcl_Obj. .PP \fBTcl_FSSplitPath\fR takes the given Tcl_Obj, which should be a valid path, -and returns a Tcl list value containing each segment of that path as +and returns a Tcl list object containing each segment of that path as an element. -It returns a list value with a reference count of zero. If the +It returns a list object with a reference count of zero. If the passed in \fIlenPtr\fR is non-NULL, the variable it points to will be updated to contain the number of elements in the returned list. .PP \fBTcl_FSEqualPaths\fR tests whether the two paths given represent the same -filesystem object. -It returns 1 if the paths are equal, and 0 if they are different. If +filesystem object +.PP +It returns 1 if the paths are equal, and 0 if they are different. If either path is NULL, 0 is always returned. .PP \fBTcl_FSGetNormalizedPath\fR this important function attempts to extract from the given Tcl_Obj a unique normalized path representation, whose string value can be used as a unique identifier for the file. .PP -It returns the normalized path value, owned by Tcl, or NULL if the path +It returns the normalized path object, owned by Tcl, or NULL if the path was invalid or could otherwise not be successfully converted. Extraction of absolute, normalized paths is very efficient (because the filesystem operates on these representations internally), although the result when the filesystem contains numerous symbolic links may not be -the most user-friendly version of a path. The return value is owned by +the most user-friendly version of a path. The return value is owned by Tcl and has a lifetime equivalent to that of the \fIpathPtr\fR passed in (unless that is a relative path, in which case the normalized path -value may be freed any time the cwd changes) - the caller can of -course increment the reference count if it wishes to maintain a copy for longer. +object may be freed any time the cwd changes) - the caller can of +course increment the refCount if it wishes to maintain a copy for longer. .PP -\fBTcl_FSJoinToPath\fR takes the given value, which should usually be a +\fBTcl_FSJoinToPath\fR takes the given object, which should usually be a valid path or NULL, and joins onto it the array of paths segments given. .PP -Returns a value, typically with reference count of zero (but it could be shared -under some conditions), containing the joined path. The caller must -add a reference count to the value before using it. If any of the values -passed into this function (\fIpathPtr\fR or \fIpath\fR elements) have -a reference count +Returns object, typically with refCount of zero (but it could be shared +under some conditions), containing the joined path. The caller must +add a refCount to the object before using it. If any of the objects +passed into this function (pathPtr or path elements) have a refCount of zero, they will be freed when this function returns. .PP \fBTcl_FSConvertToPathType\fR tries to convert the given Tcl_Obj to a valid Tcl path type, taking account of the fact that the cwd may have changed -even if this value is already supposedly of the correct type. +even if this object is already supposedly of the correct type. The filename may begin with .QW ~ (to indicate current user's home directory) or .QW ~ (to indicate any user's home directory). .PP -If the conversion succeeds (i.e.\ the value is a valid path in one of -the current filesystems), then \fBTCL_OK\fR is returned. Otherwise +If the conversion succeeds (i.e. the object is a valid path in one of +the current filesystems), then \fBTCL_OK\fR is returned. Otherwise \fBTCL_ERROR\fR is returned, and an error message may be left in the interpreter. .PP \fBTcl_FSGetInternalRep\fR extracts the internal representation of a given -path value, in the given filesystem. If the path value belongs to a +path object, in the given filesystem. If the path object belongs to a different filesystem, we return NULL. If the internal representation is currently NULL, we attempt to generate it, by calling the filesystem's \fBTcl_FSCreateInternalRepProc\fR. .PP -Returns NULL or a valid internal path representation. This internal +Returns NULL or a valid internal path representation. This internal representation is cached, so that repeated calls to this function will not require additional conversions. .PP \fBTcl_FSGetTranslatedPath\fR attempts to extract the translated path from the given Tcl_Obj. .PP -If the translation succeeds (i.e.\ the value is a valid path), then it is -returned. Otherwise NULL will be returned, and an error message may be -left in the interpreter. A +If the translation succeeds (i.e. the object is a valid path), then it is +returned. Otherwise NULL will be returned, and an error message may be +left in the interpreter. A .QW translated path is one which contains no .QW ~ or .QW ~user sequences (these have been expanded to their current -representation in the filesystem). The value returned is owned by the -caller, which must store it or call \fBTcl_DecrRefCount\fR to ensure memory is -freed. This function is of little practical use, and -\fBTcl_FSGetNormalizedPath\fR or \fBTcl_FSGetNativePath\fR are usually +representation in the filesystem). The object returned is owned by the +caller, which must store it or call Tcl_DecrRefCount to ensure memory is +freed. This function is of little practical use, and +\fBTcl_FSGetNormalizedPath\fR or \fBTcl_GetNativePath\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 \fBTcl_Free\fR to ensure it is freed. Again, -\fBTcl_FSGetNormalizedPath\fR or \fBTcl_FSGetNativePath\fR are usually +which must store it or call \fBckfree\fR to ensure it is freed. Again, +\fBTcl_FSGetNormalizedPath\fR or \fBTcl_GetNativePath\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 +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 -efficient way of creating the appropriate path value type. +efficient way of creating the appropriate path object type. .PP -The resulting value is a pure +The resulting object is a pure .QW path -value, which will only receive +object, which will only receive a UTF-8 string representation if that is required by some Tcl code. .PP \fBTcl_FSGetNativePath\fR is for use by the Win/Unix native filesystems, so that they can easily retrieve the native (char* or -TCHAR*) representation of a path. This function is a convenience -wrapper around \fBTcl_FSGetInternalRep\fR. It may be desirable in the -future to have non-string-based native representations (for example, -on MacOSX, a representation using a fileSpec of FSRef structure would -probably be more efficient). On Windows a full Unicode representation -would allow for paths of unlimited length. Currently the representation -is simply a character string which may contain either the relative path -or a complete, absolute normalized path in the native encoding (complex +TCHAR*) representation of a path. This function is a convenience +wrapper around \fBTcl_FSGetInternalRep\fR, and assumes the native +representation is string-based. It may be desirable in the future to +have non-string-based native representations (for example, on MacOSX, a +representation using a fileSpec of FSRef structure would probably be +more efficient). On Windows a full Unicode representation would allow +for paths of unlimited length. Currently the representation is simply a +character string which may contain either the relative path or a +complete, absolute normalized path in the native encoding (complex conditions dictate which of these will be provided, so neither can be -relied upon, unless the path is known to be absolute). If you need a +relied upon, unless the path is known to be absolute). If you need a native path which must be absolute, then you should ask for the native -version of a normalized path. If for some reason a non-absolute, +version of a normalized path. If for some reason a non-absolute, non-normalized version of the path is needed, that must be constructed -separately (e.g.\ using \fBTcl_FSGetTranslatedPath\fR). +separately (e.g. using \fBTcl_FSGetTranslatedPath\fR). .PP The native representation is cached so that repeated calls to this -function will not require additional conversions. The return value is +function will not require additional conversions. The return value is owned by Tcl and has a lifetime equivalent to that of the \fIpathPtr\fR passed in (unless that is a relative path, in which case the native representation may be freed any time the cwd changes). .PP -\fBTcl_FSFileSystemInfo\fR returns a list of two elements. The first +\fBTcl_FSFileSystemInfo\fR returns a list of two elements. The first element is the name of the filesystem (e.g. .QW native , .QW vfs , .QW zip , or .QW prowrap , perhaps), and the second is the particular type of the -given path within that filesystem (which is filesystem dependent). The +given path within that filesystem (which is filesystem dependent). The second element may be empty if the filesystem does not provide a further categorization of files. .PP -A valid list value is returned, unless the path value is not +A valid list object is returned, unless the path object is not recognized, when NULL will be returned. .PP -\fBTcl_FSGetFileSystemForPath\fR returns a pointer to the +\fBTcl_FSGetFileSystemForPath\fR returns the a pointer to the \fBTcl_Filesystem\fR which accepts this path as valid. .PP If no filesystem will accept the path, NULL is returned. .PP \fBTcl_FSGetPathType\fR determines whether the given path is relative @@ -778,40 +726,16 @@ to the current directory, relative to the current volume, or absolute. .PP It returns one of \fBTCL_PATH_ABSOLUTE\fR, \fBTCL_PATH_RELATIVE\fR, or \fBTCL_PATH_VOLUME_RELATIVE\fR -.SS "PORTABLE STAT RESULT API" -.PP -\fBTcl_AllocStatBuf\fR allocates a \fITcl_StatBuf\fR on the system heap (which -may be deallocated by being passed to \fBTcl_Free\fR). This allows extensions to -invoke \fBTcl_FSStat\fR and \fBTcl_FSLstat\fR without being dependent on the -size of the buffer. That in turn depends on the flags used to build Tcl. -.PP -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 -.ta \w'\fBTcl_GetModificationTimeFromStat\fR\0\0\0\0'u -\fIAccess Function\fR \fIField\fR - \fBTcl_GetFSDeviceFromStat\fR st_dev - \fBTcl_GetFSInodeFromStat\fR st_ino - \fBTcl_GetModeFromStat\fR st_mode - \fBTcl_GetLinkCountFromStat\fR st_nlink - \fBTcl_GetUserIdFromStat\fR st_uid - \fBTcl_GetGroupIdFromStat\fR st_gid - \fBTcl_GetDeviceTypeFromStat\fR st_rdev - \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 +.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. .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 @@ -819,32 +743,31 @@ .PP The \fBTcl_Filesystem\fR structures are manipulated using the following methods. .PP \fBTcl_FSRegister\fR takes a pointer to a filesystem structure and an -optional piece of data to associated with that filesystem. On calling +optional piece of data to associated with that filesystem. On calling this function, Tcl will attach the filesystem to the list of known -filesystems, and it will become fully functional immediately. Tcl does +filesystems, and it will become fully functional immediately. Tcl does 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. +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 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 +\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. .SS "THE TCL_FILESYSTEM STRUCTURE" .PP The \fBTcl_Filesystem\fR structure contains the following fields: -.PP .CS typedef struct Tcl_Filesystem { const char *\fItypeName\fR; int \fIstructureLength\fR; Tcl_FSVersion \fIversion\fR; @@ -874,11 +797,11 @@ Tcl_FSCopyDirectoryProc *\fIcopyDirectoryProc\fR; Tcl_FSLstatProc *\fIlstatProc\fR; Tcl_FSLoadFileProc *\fIloadFileProc\fR; Tcl_FSGetCwdProc *\fIgetCwdProc\fR; Tcl_FSChdirProc *\fIchdirProc\fR; -} \fBTcl_Filesystem\fR; +} Tcl_Filesystem; .CE .PP Except for the first three fields in this structure which contain simple data elements, all entries contain addresses of functions called by the generic filesystem layer to perform the complete range of @@ -888,34 +811,33 @@ categories: infrastructure functions (almost all of which must be implemented), operational functions (which must be implemented if a complete filesystem is provided), and efficiency functions (which need only be implemented if they can be done so efficiently, or if they have side-effects which are required by the filesystem; Tcl has less -efficient emulations it can fall back on). It is important to note +efficient emulations it can fall back on). It is important to note that, in the current version of Tcl, most of these fallbacks are only used to handle commands initiated in Tcl, not in C. What this means is, that if a \fBfile rename\fR command is issued in Tcl, and the relevant filesystem(s) do not implement their \fITcl_FSRenameFileProc\fR, Tcl's core will instead fallback on a combination of other filesystem functions (it will use \fITcl_FSCopyFileProc\fR followed by \fITcl_FSDeleteFileProc\fR, and if \fITcl_FSCopyFileProc\fR is not -implemented there is a further fallback). However, if a +implemented there is a further fallback). However, if a \fITcl_FSRenameFileProc\fR command is issued at the C level, no such -fallbacks occur. This is true except for the last four entries in the +fallbacks occur. This is true except for the last four entries in the filesystem table (\fBlstat\fR, \fBload\fR, \fBgetcwd\fR and \fBchdir\fR) for which fallbacks do in fact occur at the C level. .PP Any functions which take path names in Tcl_Obj form take -those names in UTF\-8 form. The filesystem infrastructure API is +those names in UTF\-8 form. The filesystem infrastructure API is designed to support efficient, cached conversion of these UTF\-8 paths to other native representations. .SS "EXAMPLE FILESYSTEM DEFINITION" .PP Here is the filesystem lookup table used by the .QW vfs extension which allows filesystem actions to be implemented in Tcl. -.PP .CS static Tcl_Filesystem vfsFilesystem = { "tclvfs", sizeof(Tcl_Filesystem), TCL_FILESYSTEM_VERSION_1, @@ -990,309 +912,308 @@ .PP The \fIversion\fR field should be set to \fBTCL_FILESYSTEM_VERSION_1\fR. .SS PATHINFILESYSTEMPROC .PP The \fIpathInFilesystemProc\fR field contains the address of a function -which is called to determine whether a given path value belongs to this -filesystem or not. Tcl will only call the rest of the filesystem +which is called to determine whether a given path object belongs to this +filesystem or not. Tcl will only call the rest of the filesystem functions with a path for which this function has returned \fBTCL_OK\fR. -If the path does not belong, -1 should be returned (the behavior of Tcl -for any other return value is not defined). If \fBTCL_OK\fR is returned, +If the path does not belong, -1 should be returned (the behaviour of Tcl +for any other return value is not defined). If \fBTCL_OK\fR is returned, then the optional \fIclientDataPtr\fR output parameter can be used to return an internal (filesystem specific) representation of the path, -which will be cached inside the path value, and may be retrieved -efficiently by the other filesystem functions. Tcl will simultaneously -cache the fact that this path belongs to this filesystem. Such caches +which will be cached inside the path object, and may be retrieved +efficiently by the other filesystem functions. Tcl will simultaneously +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( +typedef int Tcl_FSPathInFilesystemProc( Tcl_Obj *\fIpathPtr\fR, - void **\fIclientDataPtr\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 +called when Tcl needs to duplicate a path object. If NULL, Tcl will simply not copy the internal representation, which may then need to be regenerated later. .PP .CS -typedef void *\fBTcl_FSDupInternalRepProc\fR( - void *\fIclientData\fR); +typedef ClientData Tcl_FSDupInternalRepProc( + 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 +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( - void *\fIclientData\fR); +typedef void Tcl_FSFreeInternalRepProc( + 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 +Function to convert internal representation to a normalized path. Only +required if the filesystem creates pure path objects with no string/path +representation. The return value is a Tcl object whose string representation is the normalized path. .PP .CS -typedef Tcl_Obj *\fBTcl_FSInternalToNormalizedProc\fR( - void *\fIclientData\fR); +typedef Tcl_Obj* Tcl_FSInternalToNormalizedProc( + ClientData \fIclientData\fR); .CE .SS CREATEINTERNALREPPROC .PP -Function to take a path value, and calculate an internal +Function to take a path object, 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 +object. 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 void *\fBTcl_FSCreateInternalRepProc\fR( +typedef ClientData Tcl_FSCreateInternalRepProc( Tcl_Obj *\fIpathPtr\fR); .CE .SS NORMALIZEPATHPROC .PP -Function to normalize a path. Should be implemented for all +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 +path object. In Tcl, every .QW path must have a single unique .QW normalized -string representation. Depending on the filesystem, +string representation. Depending on the filesystem, there may be more than one unnormalized string representation which -refers to that path (e.g.\ a relative path, a path with different +refers to that path (e.g. a relative path, a path with different character case if the filesystem is case insensitive, a path contain a reference to a home directory such as .QW ~ , a path containing symbolic -links, etc). If the very last component in the path is a symbolic -link, it should not be converted into the value it points to (but -its case or other aspects should be made unique). All other path -components should be converted from symbolic links. This one +links, etc). If the very last component in the path is a symbolic +link, it should not be converted into the object it points to (but +its case or other aspects should be made unique). All other path +components should be converted from symbolic links. This one exception is required to agree with Tcl's semantics with \fBfile delete\fR, \fBfile rename\fR, \fBfile copy\fR operating on symbolic links. This function may be called with \fInextCheckpoint\fR either -at the beginning of the path (i.e.\ zero), at the end of the path, or -at any intermediate file separator in the path. It will never +at the beginning of the path (i.e. zero), at the end of the path, or +at any intermediate file separator in the path. It will never point to any other arbitrary position in the path. In the last of the three valid cases, the implementation can assume that the path up to and including the file separator is known and normalized. .PP .CS -typedef int \fBTcl_FSNormalizePathProc\fR( +typedef int Tcl_FSNormalizePathProc( Tcl_Interp *\fIinterp\fR, Tcl_Obj *\fIpathPtr\fR, int \fInextCheckpoint\fR); .CE .SH "FILESYSTEM OPERATIONS" .PP The fields in this section of the structure contain addresses of functions which are called to carry out the basic filesystem -operations. A filesystem which expects to be used with the complete -standard Tcl command set must implement all of these. If some of +operations. A filesystem which expects to be used with the complete +standard Tcl command set must implement all of these. If some of them are not implemented, then certain Tcl commands may fail when -operating on paths within that filesystem. However, in some instances +operating on paths within that filesystem. However, in some instances this may be desirable (for example, a read-only filesystem should not implement the last four functions, and a filesystem which does not support symbolic links need not implement the \fBreadlink\fR function, -etc. The Tcl core expects filesystems to behave in this way). +etc. The Tcl core expects filesystems to behave in this way). .SS FILESYSTEMPATHTYPEPROC .PP -Function to determine the type of a path in this filesystem. May be +Function to determine the type of a path in this filesystem. May be NULL, in which case no type information will be available to users of -the filesystem. The +the filesystem. The .QW type is used only for informational purposes, and should be returned as the string representation of the Tcl_Obj -which is returned. A typical return value might be +which is returned. A typical return value might be .QW networked , .QW zip or .QW ftp . The Tcl_Obj result is owned by the filesystem and so Tcl will -increment the reference count of that value if it wishes to retain a reference +increment the refCount of that object if it wishes to retain a reference to it. .PP .CS -typedef Tcl_Obj *\fBTcl_FSFilesystemPathTypeProc\fR( +typedef Tcl_Obj* Tcl_FSFilesystemPathTypeProc( Tcl_Obj *\fIpathPtr\fR); .CE .SS FILESYSTEMSEPARATORPROC .PP Function to return the separator character(s) for this filesystem. This need only be implemented if the filesystem wishes to use a different separator than the standard string .QW / . Amongst other -uses, it is returned by the \fBfile separator\fR command. The -return value should be a value with reference count of zero. +uses, it is returned by the \fBfile separator\fR command. The +return value should be an object with refCount of zero. .PP .CS -typedef Tcl_Obj *\fBTcl_FSFilesystemSeparatorProc\fR( +typedef Tcl_Obj* Tcl_FSFilesystemSeparatorProc( Tcl_Obj *\fIpathPtr\fR); .CE .SS STATPROC .PP -Function to process a \fBTcl_FSStat\fR call. Must be implemented for any +Function to process a \fBTcl_FSStat\fR call. Must be implemented for any reasonable filesystem, since many Tcl level commands depend crucially -upon it (e.g.\ \fBfile atime\fR, \fBfile isdirectory\fR, \fBfile size\fR, +upon it (e.g. \fBfile atime\fR, \fBfile isdirectory\fR, \fBfile size\fR, \fBglob\fR). .PP .CS -typedef int \fBTcl_FSStatProc\fR( +typedef int Tcl_FSStatProc( Tcl_Obj *\fIpathPtr\fR, Tcl_StatBuf *\fIstatPtr\fR); .CE .PP The \fBTcl_FSStatProc\fR fills the stat structure \fIstatPtr\fR with -information about the specified file. You do not need any access +information about the specified file. You do not need any access rights to the file to get this information but you need search rights -to all directories named in the path leading to the file. The stat +to all directories named in the path leading to the file. The stat structure includes info regarding device, inode (always 0 on Windows), privilege mode, nlink (always 1 on Windows), user id (always 0 on Windows), group id (always 0 on Windows), rdev (same as device on Windows), size, last access time, last modification time, and last metadata change time. .PP If the file represented by \fIpathPtr\fR exists, the \fBTcl_FSStatProc\fR returns 0 and the stat structure is filled with -data. Otherwise, -1 is returned, and no stat info is given. +data. Otherwise, -1 is returned, and no stat info is given. .SS ACCESSPROC .PP -Function to process a \fBTcl_FSAccess\fR call. Must be implemented for +Function to process a \fBTcl_FSAccess\fR call. Must be implemented for any reasonable filesystem, since many Tcl level commands depend crucially -upon it (e.g.\ \fBfile exists\fR, \fBfile readable\fR). +upon it (e.g. \fBfile exists\fR, \fBfile readable\fR). .PP .CS -typedef int \fBTcl_FSAccessProc\fR( +typedef int Tcl_FSAccessProc( Tcl_Obj *\fIpathPtr\fR, int \fImode\fR); .CE .PP The \fBTcl_FSAccessProc\fR checks whether the process would be allowed to read, write or test for existence of the file (or other filesystem -object) whose name is in \fIpathPtr\fR. If the pathname refers to a +object) whose name is in \fIpathPtr\fR. If the pathname refers to a symbolic link, then the permissions of the file referred by this symbolic link should be tested. .PP -On success (all requested permissions granted), zero is returned. On +On success (all requested permissions granted), zero is returned. On error (at least one bit in mode asked for a permission that is denied, or some other error occurred), -1 is returned. .SS OPENFILECHANNELPROC .PP -Function to process a \fBTcl_FSOpenFileChannel\fR call. Must be +Function to process a \fBTcl_FSOpenFileChannel\fR call. Must be implemented for any reasonable filesystem, since any operations which require open or accessing a file's contents will use it -(e.g.\ \fBopen\fR, \fBencoding\fR, and many Tk commands). +(e.g. \fBopen\fR, \fBencoding\fR, and many Tk commands). .PP .CS -typedef Tcl_Channel \fBTcl_FSOpenFileChannelProc\fR( +typedef Tcl_Channel Tcl_FSOpenFileChannelProc( Tcl_Interp *\fIinterp\fR, Tcl_Obj *\fIpathPtr\fR, int \fImode\fR, int \fIpermissions\fR); .CE .PP The \fBTcl_FSOpenFileChannelProc\fR opens a file specified by \fIpathPtr\fR and returns a channel handle that can be used to perform -input and output on the file. This API is modeled after the \fBfopen\fR -procedure of the Unix standard I/O library. The syntax and meaning of +input and output on the file. This API is modeled after the \fBfopen\fR +procedure of the Unix standard I/O library. The syntax and meaning of all arguments is similar to those given in the Tcl \fBopen\fR command when opening a file, where the \fImode\fR argument is a combination of -the POSIX flags O_RDONLY, O_WRONLY, etc. If an error occurs while +the POSIX flags O_RDONLY, O_WRONLY, etc. If an error occurs while opening the channel, the \fBTcl_FSOpenFileChannelProc\fR returns NULL and records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. In addition, if \fIinterp\fR is non-NULL, the \fBTcl_FSOpenFileChannelProc\fR leaves an error message in \fIinterp\fR's result after any error. .PP -The newly created channel must not be registered in the supplied interpreter -by a \fBTcl_FSOpenFileChannelProc\fR; that task is up to the caller of +The newly created channel must not registered in the supplied +interpreter; that task is up to the caller of \fBTcl_FSOpenFileChannel\fR (if necessary). If one of -the standard channels, \fBstdin\fR, \fBstdout\fR or \fBstderr\fR was +the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was previously closed, the act of creating the new channel also assigns it as a replacement for the standard channel. .SS MATCHINDIRECTORYPROC .PP -Function to process a \fBTcl_FSMatchInDirectory\fR call. If not +Function to process a \fBTcl_FSMatchInDirectory\fR call. If not implemented, then glob and recursive copy functionality will be lacking in the filesystem (and this may impact commands like \fBencoding names\fR which use glob functionality internally). .PP .CS -typedef int \fBTcl_FSMatchInDirectoryProc\fR( - Tcl_Interp *\fIinterp\fR, +typedef int Tcl_FSMatchInDirectoryProc( + Tcl_Interp* \fIinterp\fR, Tcl_Obj *\fIresultPtr\fR, Tcl_Obj *\fIpathPtr\fR, const char *\fIpattern\fR, Tcl_GlobTypeData *\fItypes\fR); .CE .PP The function should return all files or directories (or other filesystem objects) which match the given pattern and accord with the \fItypes\fR -specification given. There are two ways in which this function may be -called. If \fIpattern\fR is NULL, then \fIpathPtr\fR is a full path +specification given. There are two ways in which this function may be +called. If \fIpattern\fR is NULL, then \fIpathPtr\fR is a full path specification of a single file or directory which should be checked for -existence and correct type. Otherwise, \fIpathPtr\fR is a directory, the +existence and correct type. Otherwise, \fIpathPtr\fR is a directory, the contents of which the function should search for files or directories -which have the correct type. In either case, \fIpathPtr\fR can be -assumed to be both non-NULL and non-empty. It is not currently +which have the correct type. In either case, \fIpathPtr\fR can be +assumed to be both non-NULL and non-empty. It is not currently documented whether \fIpathPtr\fR will have a file separator at its end of not, so code should be flexible to both possibilities. .PP The return value is a standard Tcl result indicating whether an error -occurred in the matching process. Error messages are placed in +occurred in the matching process. Error messages are placed in \fIinterp\fR, unless \fIinterp\fR in NULL in which case no error -message need be generated; on a \fBTCL_OK\fR result, results should be -added to the \fIresultPtr\fR value given (which can be assumed to be a -valid unshared Tcl list). The matches added +message need be generated; on a \fBTCL_OK\fR result, results should be +added to the \fIresultPtr\fR object given (which can be assumed to be a +valid unshared Tcl list). The matches added to \fIresultPtr\fR should include any path prefix given in \fIpathPtr\fR (this usually means they will be absolute path specifications). Note that if no matches are found, that simply leads to an empty result; errors are only signaled for actual file or filesystem problems which may occur during the matching process. .PP -The \fBTcl_GlobTypeData\fR structure passed in the \fItypes\fR +The \fBTcl_GlobTypeData\fR structure passed in the \fItypes\fR parameter contains the following fields: -.PP .CS typedef struct Tcl_GlobTypeData { - /* Corresponds to bcdpfls as in 'find -t' */ - int \fItype\fR; - /* Corresponds to file permissions */ - int \fIperm\fR; - /* Acceptable mac type */ - Tcl_Obj *\fImacType\fR; - /* Acceptable mac creator */ - Tcl_Obj *\fImacCreator\fR; -} \fBTcl_GlobTypeData\fR; + /* Corresponds to bcdpfls as in 'find -t' */ + int \fItype\fR; + /* Corresponds to file permissions */ + int \fIperm\fR; + /* Acceptable mac type */ + Tcl_Obj *\fImacType\fR; + /* Acceptable mac creator */ + Tcl_Obj *\fImacCreator\fR; +} Tcl_GlobTypeData; .CE .PP There are two specific cases which it is important to handle correctly, both when \fItypes\fR is non-NULL. The two cases are when \fItypes->types & TCL_GLOB_TYPE_DIR\fR or \fItypes->types & TCL_GLOB_TYPE_MOUNT\fR are -true (and in particular when the other flags are false). In the first of -these cases, the function must list the contained directories. Tcl uses +true (and in particular when the other flags are false). In the first of +these cases, the function must list the contained directories. Tcl uses this to implement recursive globbing, so it is critical that filesystems -implement directory matching correctly. In the second of these cases, +implement directory matching correctly. In the second of these cases, with \fBTCL_GLOB_TYPE_MOUNT\fR, the filesystem must list the mount points which lie within the given \fIpathPtr\fR (and in this case, \fIpathPtr\fR need not lie within the same filesystem - different to all other cases in -which this function is called). Support for this is critical if Tcl is +which this function is called). Support for this is critical if Tcl is to have seamless transitions between from one filesystem to another. .SS UTIMEPROC .PP -Function to process a \fBTcl_FSUtime\fR call. Required to allow setting +Function to process a \fBTcl_FSUtime\fR call. Required to allow setting (not reading) of times with \fBfile mtime\fR, \fBfile atime\fR and the open-r/open-w/fcopy implementation of \fBfile copy\fR. .PP .CS -typedef int \fBTcl_FSUtimeProc\fR( +typedef int Tcl_FSUtimeProc( Tcl_Obj *\fIpathPtr\fR, struct utimbuf *\fItval\fR); .CE .PP The access and modification times of the file specified by \fIpathPtr\fR @@ -1300,107 +1221,107 @@ .PP The return value should be 0 on success and -1 on an error, as with the system \fButime\fR. .SS LINKPROC .PP -Function to process a \fBTcl_FSLink\fR call. Should be implemented +Function to process a \fBTcl_FSLink\fR call. Should be implemented only if the filesystem supports links, and may otherwise be NULL. .PP .CS -typedef Tcl_Obj *\fBTcl_FSLinkProc\fR( +typedef Tcl_Obj* Tcl_FSLinkProc( Tcl_Obj *\fIlinkNamePtr\fR, Tcl_Obj *\fItoPtr\fR, int \fIlinkAction\fR); .CE .PP If \fItoPtr\fR is NULL, the function is being asked to read the -contents of a link. The result is a Tcl_Obj specifying the contents of +contents of a link. The result is a Tcl_Obj specifying the contents of the link given by \fIlinkNamePtr\fR, or NULL if the link could -not be read. The result is owned by the caller (and should therefore -have its ref count incremented before being returned). Any callers -should call \fBTcl_DecrRefCount\fR on this result when it is no longer needed. +not be read. The result is owned by the caller (and should therefore +have its ref count incremented before being returned). Any callers +should call Tcl_DecrRefCount on this result when it is no longer needed. If \fItoPtr\fR is not NULL, the function should attempt to create a link. The result in this case should be \fItoPtr\fR if the link was successful -and NULL otherwise. In this case the result is not owned by the caller -(i.e.\ no reference count manipulations on either end are needed). See +and NULL otherwise. In this case the result is not owned by the caller +(i.e. no ref count manipulation on either end is needed). See the documentation for \fBTcl_FSLink\fR for the correct interpretation of the \fIlinkAction\fR flags. .SS LISTVOLUMESPROC .PP Function to list any filesystem volumes added by this filesystem. Should be implemented only if the filesystem adds volumes at the head of the filesystem, so that they can be returned by \fBfile volumes\fR. .PP .CS -typedef Tcl_Obj *\fBTcl_FSListVolumesProc\fR(void); +typedef Tcl_Obj* Tcl_FSListVolumesProc(void); .CE .PP The result should be a list of volumes added by this filesystem, or -NULL (or an empty list) if no volumes are provided. The result value +NULL (or an empty list) if no volumes are provided. The result object is considered to be owned by the filesystem (not by Tcl's core), but -should be given a reference count for Tcl. Tcl will use the contents of the -list and then decrement that reference count. This allows filesystems to +should be given a refCount for Tcl. Tcl will use the contents of the +list and then decrement that refCount. This allows filesystems to choose whether they actually want to retain a -.QW "global list" +.QW "master list" of volumes or not (if not, they generate the list on the fly and pass it to Tcl -with a reference count of 1 and then forget about the list, if yes, then -they simply increment the reference count of their global list and pass it +with a refCount of 1 and then forget about the list, if yes, then +they simply increment the refCount of their master list and pass it to Tcl which will copy the contents and then decrement the count back to where it was). .PP Therefore, Tcl considers return values from this proc to be read-only. .SS FILEATTRSTRINGSPROC .PP Function to list all attribute strings which are valid for this -filesystem. If not implemented the filesystem will not support -the \fBfile attributes\fR command. This allows arbitrary additional -information to be attached to files in the filesystem. If it is +filesystem. If not implemented the filesystem will not support +the \fBfile attributes\fR command. This allows arbitrary additional +information to be attached to files in the filesystem. If it is not implemented, there is no need to implement the \fBget\fR and \fBset\fR methods. .PP .CS -typedef const char *const *\fBTcl_FSFileAttrStringsProc\fR( +typedef const char** Tcl_FSFileAttrStringsProc( Tcl_Obj *\fIpathPtr\fR, - Tcl_Obj **\fIobjPtrRef\fR); + Tcl_Obj** \fIobjPtrRef\fR); .CE .PP The called function may either return an array of strings, or may -instead return NULL and place a Tcl list into the given \fIobjPtrRef\fR. Tcl +instead return NULL and place a Tcl list into the given \fIobjPtrRef\fR. Tcl will take that list and first increment its reference count before using it. -On completion of that use, Tcl will decrement its reference count. Hence if +On completion of that use, Tcl will decrement its reference count. Hence if the list should be disposed of by Tcl when done, it should have a reference count of zero, and if the list should not be disposed of, the -filesystem should ensure it returns a value with a reference count +filesystem should ensure it returns an object with a reference count of at least one. .SS FILEATTRSGETPROC .PP Function to process a \fBTcl_FSFileAttrsGet\fR call, used by \fBfile attributes\fR. .PP .CS -typedef int \fBTcl_FSFileAttrsGetProc\fR( +typedef int Tcl_FSFileAttrsGetProc( Tcl_Interp *\fIinterp\fR, int \fIindex\fR, Tcl_Obj *\fIpathPtr\fR, Tcl_Obj **\fIobjPtrRef\fR); .CE .PP -Returns a standard Tcl return code. The attribute value retrieved, +Returns a standard Tcl return code. The attribute value retrieved, which corresponds to the \fIindex\fR'th element in the list returned by the \fBTcl_FSFileAttrStringsProc\fR, is a Tcl_Obj placed in \fIobjPtrRef\fR (if -\fBTCL_OK\fR was returned) and is likely to have a reference count of zero. Either -way we must either store it somewhere (e.g.\ the Tcl result), or +\fBTCL_OK\fR was returned) and is likely to have a reference count of zero. Either +way we must either store it somewhere (e.g. the Tcl result), or Incr/Decr its reference count to ensure it is properly freed. .SS FILEATTRSSETPROC .PP Function to process a \fBTcl_FSFileAttrsSet\fR call, used by \fBfile -attributes\fR. If the filesystem is read-only, there is no need +attributes\fR. If the filesystem is read-only, there is no need to implement this. .PP .CS -typedef int \fBTcl_FSFileAttrsSetProc\fR( +typedef int Tcl_FSFileAttrsSetProc( Tcl_Interp *\fIinterp\fR, int \fIindex\fR, Tcl_Obj *\fIpathPtr\fR, Tcl_Obj *\fIobjPtr\fR); .CE @@ -1407,57 +1328,57 @@ .PP The attribute value of the \fIindex\fR'th element in the list returned by the Tcl_FSFileAttrStringsProc should be set to the \fIobjPtr\fR given. .SS CREATEDIRECTORYPROC .PP -Function to process a \fBTcl_FSCreateDirectory\fR call. Should be +Function to process a \fBTcl_FSCreateDirectory\fR call. Should be implemented unless the FS is read-only. .PP .CS -typedef int \fBTcl_FSCreateDirectoryProc\fR( +typedef int Tcl_FSCreateDirectoryProc( Tcl_Obj *\fIpathPtr\fR); .CE .PP The return value is a standard Tcl result indicating whether an error -occurred in the process. If successful, a new directory should have +occurred in the process. If successful, a new directory should have been added to the filesystem in the location specified by \fIpathPtr\fR. .SS REMOVEDIRECTORYPROC .PP -Function to process a \fBTcl_FSRemoveDirectory\fR call. Should be +Function to process a \fBTcl_FSRemoveDirectory\fR call. Should be implemented unless the FS is read-only. .PP .CS -typedef int \fBTcl_FSRemoveDirectoryProc\fR( +typedef int Tcl_FSRemoveDirectoryProc( Tcl_Obj *\fIpathPtr\fR, int \fIrecursive\fR, Tcl_Obj **\fIerrorPtr\fR); .CE .PP The return value is a standard Tcl result indicating whether an error -occurred in the process. If successful, the directory specified by -\fIpathPtr\fR should have been removed from the filesystem. If the +occurred in the process. If successful, the directory specified by +\fIpathPtr\fR should have been removed from the filesystem. If the \fIrecursive\fR flag is given, then a non-empty directory should be -deleted without error. If this flag is not given, then and the +deleted without error. If this flag is not given, then and the directory is non-empty a POSIX .QW EEXIST -error should be signaled. If an +error should be signaled. If an error does occur, the name of the file or directory which caused the error should be placed in \fIerrorPtr\fR. .SS DELETEFILEPROC .PP -Function to process a \fBTcl_FSDeleteFile\fR call. Should be implemented +Function to process a \fBTcl_FSDeleteFile\fR call. Should be implemented unless the FS is read-only. .PP .CS -typedef int \fBTcl_FSDeleteFileProc\fR( +typedef int Tcl_FSDeleteFileProc( Tcl_Obj *\fIpathPtr\fR); .CE .PP The return value is a standard Tcl result indicating whether an error -occurred in the process. If successful, the file specified by -\fIpathPtr\fR should have been removed from the filesystem. Note that, +occurred in the process. If successful, the file specified by +\fIpathPtr\fR should have been removed from the filesystem. Note that, if the filesystem supports symbolic links, Tcl will always call this function and not Tcl_FSRemoveDirectoryProc when needed to delete them (even if they are symbolic links to directories). .SH "FILESYSTEM EFFICIENCY" .PP @@ -1464,17 +1385,17 @@ These functions need not be implemented for a particular filesystem because the core has a fallback implementation available. See each individual description for the consequences of leaving the field NULL. .SS LSTATPROC .PP -Function to process a \fBTcl_FSLstat\fR call. If not implemented, Tcl -will attempt to use the \fIstatProc\fR defined above instead. Therefore +Function to process a \fBTcl_FSLstat\fR call. If not implemented, Tcl +will attempt to use the \fIstatProc\fR defined above instead. Therefore it need only be implemented if a filesystem can differentiate between \fBstat\fR and \fBlstat\fR calls. .PP .CS -typedef int \fBTcl_FSLstatProc\fR( +typedef int Tcl_FSLstatProc( Tcl_Obj *\fIpathPtr\fR, Tcl_StatBuf *\fIstatPtr\fR); .CE .PP The behavior of this function is very similar to that of the @@ -1481,154 +1402,154 @@ \fBTcl_FSStatProc\fR defined above, except that if it is applied to a symbolic link, it returns information about the link, not about the target file. .SS COPYFILEPROC .PP -Function to process a \fBTcl_FSCopyFile\fR call. If not implemented Tcl +Function to process a \fBTcl_FSCopyFile\fR call. If not implemented Tcl will fall back on \fBopen\fR-r, \fBopen\fR-w and \fBfcopy\fR as a copying mechanism. Therefore it need only be implemented if the filesystem can perform that action more efficiently. .PP .CS -typedef int \fBTcl_FSCopyFileProc\fR( +typedef int Tcl_FSCopyFileProc( Tcl_Obj *\fIsrcPathPtr\fR, Tcl_Obj *\fIdestPathPtr\fR); .CE .PP The return value is a standard Tcl result indicating whether an error -occurred in the copying process. Note that, \fIdestPathPtr\fR is the +occurred in the copying process. Note that, \fIdestPathPtr\fR is the name of the file which should become the copy of \fIsrcPathPtr\fR. It is never the name of a directory into which \fIsrcPathPtr\fR could be -copied (i.e.\ the function is much simpler than the Tcl level \fBfile -copy\fR subcommand). Note that, +copied (i.e. the function is much simpler than the Tcl level \fBfile +copy\fR subcommand). Note that, if the filesystem supports symbolic links, Tcl will always call this function and not \fIcopyDirectoryProc\fR when needed to copy them -(even if they are symbolic links to directories). Finally, if the +(even if they are symbolic links to directories). Finally, if the filesystem determines it cannot support the \fBfile copy\fR action, calling \fBTcl_SetErrno(EXDEV)\fR and returning a non-\fBTCL_OK\fR result will tell Tcl to use its standard fallback mechanisms. .SS RENAMEFILEPROC .PP -Function to process a \fBTcl_FSRenameFile\fR call. If not implemented, -Tcl will fall back on a copy and delete mechanism. Therefore it need +Function to process a \fBTcl_FSRenameFile\fR call. If not implemented, +Tcl will fall back on a copy and delete mechanism. Therefore it need only be implemented if the filesystem can perform that action more efficiently. .PP .CS -typedef int \fBTcl_FSRenameFileProc\fR( +typedef int Tcl_FSRenameFileProc( Tcl_Obj *\fIsrcPathPtr\fR, Tcl_Obj *\fIdestPathPtr\fR); .CE .PP The return value is a standard Tcl result indicating whether an error -occurred in the renaming process. If the +occurred in the renaming process. If the filesystem determines it cannot support the \fBfile rename\fR action, calling \fBTcl_SetErrno(EXDEV)\fR and returning a non-\fBTCL_OK\fR result will tell Tcl to use its standard fallback mechanisms. .SS COPYDIRECTORYPROC .PP -Function to process a \fBTcl_FSCopyDirectory\fR call. If not +Function to process a \fBTcl_FSCopyDirectory\fR call. If not implemented, Tcl will fall back on a recursive \fBfile mkdir\fR, \fBfile copy\fR -mechanism. Therefore it need only be implemented if the filesystem can +mechanism. Therefore it need only be implemented if the filesystem can perform that action more efficiently. .PP .CS -typedef int \fBTcl_FSCopyDirectoryProc\fR( +typedef int Tcl_FSCopyDirectoryProc( Tcl_Obj *\fIsrcPathPtr\fR, Tcl_Obj *\fIdestPathPtr\fR, Tcl_Obj **\fIerrorPtr\fR); .CE .PP The return value is a standard Tcl result indicating whether an error -occurred in the copying process. If an error does occur, the name of +occurred in the copying process. If an error does occur, the name of the file or directory which caused the error should be placed in \fIerrorPtr\fR. Note that, \fIdestPathPtr\fR is the name of the directory-name which should become the mirror-image of \fIsrcPathPtr\fR. It is not the name of a directory into which -\fIsrcPathPtr\fR should be copied (i.e.\ the function is much simpler -than the Tcl level \fBfile copy\fR subcommand). Finally, if the +\fIsrcPathPtr\fR should be copied (i.e. the function is much simpler +than the Tcl level \fBfile copy\fR subcommand). Finally, if the filesystem determines it cannot support the directory copy action, calling \fBTcl_SetErrno(EXDEV)\fR and returning a non-\fBTCL_OK\fR result will tell Tcl to use its standard fallback mechanisms. .SS LOADFILEPROC .PP -Function to process a \fBTcl_FSLoadFile\fR call. If not implemented, Tcl +Function to process a \fBTcl_FSLoadFile\fR call. If not implemented, Tcl will fall back on a copy to native-temp followed by a \fBTcl_FSLoadFile\fR on -that temporary copy. Therefore it need only be implemented if the +that temporary copy. Therefore it need only be implemented if the filesystem can load code directly, or it can be implemented simply to return \fBTCL_ERROR\fR to disable load functionality in this filesystem entirely. .PP .CS -typedef int \fBTcl_FSLoadFileProc\fR( +typedef int Tcl_FSLoadFileProc( Tcl_Interp *\fIinterp\fR, Tcl_Obj *\fIpathPtr\fR, Tcl_LoadHandle *\fIhandlePtr\fR, Tcl_FSUnloadFileProc *\fIunloadProcPtr\fR); .CE .PP -Returns a standard Tcl completion code. If an error occurs, an error -message is left in the \fIinterp\fR's result. The function dynamically loads a -binary code file into memory. On a successful load, the \fIhandlePtr\fR +Returns a standard Tcl completion code. If an error occurs, an error +message is left in the \fIinterp\fR's result. The function dynamically loads a +binary code file into memory. On a successful load, the \fIhandlePtr\fR should be filled with a token for the dynamically loaded file, and the \fIunloadProcPtr\fR should be filled in with the address of a procedure. The unload procedure will be called with the given \fBTcl_LoadHandle\fR as its -only parameter when Tcl needs to unload the file. For example, for the +only parameter when Tcl needs to unload the file. For example, for the native filesystem, the \fBTcl_LoadHandle\fR returned is currently a token which can be used in the private \fBTclpFindSymbol\fR to access functions -in the new code. Each filesystem is free to define the -\fBTcl_LoadHandle\fR as it requires. Finally, if the +in the new code. Each filesystem is free to define the +\fBTcl_LoadHandle\fR as it requires. Finally, if the filesystem determines it cannot support the file load action, calling \fBTcl_SetErrno(EXDEV)\fR and returning a non-\fBTCL_OK\fR result will tell Tcl to use its standard fallback mechanisms. .SS UNLOADFILEPROC .PP -Function to unload a previously successfully loaded file. If load was +Function to unload a previously successfully loaded file. If load was implemented, then this should also be implemented, if there is any cleanup action required. .PP .CS -typedef void \fBTcl_FSUnloadFileProc\fR( +typedef void Tcl_FSUnloadFileProc( Tcl_LoadHandle \fIloadHandle\fR); .CE -.SS GETCWDPROC +.SS GETCWDPROC .PP -Function to process a \fBTcl_FSGetCwd\fR call. Most filesystems need not -implement this. It will usually only be called once, if \fBgetcwd\fR is -called before \fBchdir\fR. May be NULL. +Function to process a \fBTcl_FSGetCwd\fR call. Most filesystems need not +implement this. It will usually only be called once, if \fBgetcwd\fR is +called before \fBchdir\fR. May be NULL. .PP .CS -typedef Tcl_Obj *\fBTcl_FSGetCwdProc\fR( +typedef Tcl_Obj* Tcl_FSGetCwdProc( Tcl_Interp *\fIinterp\fR); .CE .PP If the filesystem supports a native notion of a current working directory (which might perhaps change independent of Tcl), this function should return that cwd as the result, or NULL if the current -directory could not be determined (e.g.\ the user does not have -appropriate permissions on the cwd directory). If NULL is returned, an +directory could not be determined (e.g. the user does not have +appropriate permissions on the cwd directory). If NULL is returned, an error message is left in the \fIinterp\fR's result. .SS CHDIRPROC .PP -Function to process a \fBTcl_FSChdir\fR call. If filesystems do not +Function to process a \fBTcl_FSChdir\fR call. If filesystems do not implement this, it will be emulated by a series of directory access -checks. Otherwise, virtual filesystems which do implement it need only +checks. Otherwise, virtual filesystems which do implement it need only respond with a positive return result if the \fIpathPtr\fR is a valid, -accessible directory in their filesystem. They need not remember the +accessible directory in their filesystem. They need not remember the result, since that will be automatically remembered for use by \fBTcl_FSGetCwd\fR. -Real filesystems should carry out the correct action (i.e.\ call the +Real filesystems should carry out the correct action (i.e. call the correct system \fBchdir\fR API). .PP .CS -typedef int \fBTcl_FSChdirProc\fR( +typedef int Tcl_FSChdirProc( Tcl_Obj *\fIpathPtr\fR); .CE .PP The \fBTcl_FSChdirProc\fR changes the applications current working directory to the value specified in \fIpathPtr\fR. The function returns -1 on error or 0 on success. .SH "SEE ALSO" -cd(n), file(n), filename(n), load(n), open(n), pwd(n), source(n), unload(n) +cd(n), file(n), load(n), open(n), pwd(n), unload(n) .SH KEYWORDS -stat, access, filesystem, vfs, virtual filesystem +stat, access, filesystem, vfs, virtual Index: doc/FindExec.3 ================================================================== --- doc/FindExec.3 +++ doc/FindExec.3 @@ -1,11 +1,11 @@ '\" '\" 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_FindExecutable 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_FindExecutable, Tcl_GetNameOfExecutable \- identify or return the name of the binary file containing the application @@ -43,22 +43,14 @@ along with the \fBPATH\fR environment variable to find the application's executable, if possible. If it fails to find the binary, then future calls to \fBinfo nameofexecutable\fR will return an empty string. .PP -On Windows platforms this procedure is typically invoked as the very -first thing in the application's main program as well; Its \fIargv[0]\fR -argument is only used to indicate whether the executable has a stderr -channel (any non-null value) or not (the value null). If \fBTcl_SetPanicProc\fR -is never called and no debugger is running, this determines whether -the panic message is sent to stderr or to a standard system dialog. -.PP \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. + .SH KEYWORDS binary, executable file Index: doc/GetCwd.3 ================================================================== --- doc/GetCwd.3 +++ doc/GetCwd.3 @@ -1,11 +1,11 @@ '\" '\" Copyright (c) 1998-1999 Scriptics Corporation '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Tcl_GetCwd 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_GetCwd, Tcl_Chdir \- manipulate the current working directory Index: doc/GetHostName.3 ================================================================== --- doc/GetHostName.3 +++ doc/GetHostName.3 @@ -1,9 +1,9 @@ '\" '\" Copyright (c) 1998-2000 by Scriptics Corporation. '\" All rights reserved. -'\" +'\" .TH Tcl_GetHostName 3 8.3 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_GetHostName \- get the name of the local host @@ -16,12 +16,12 @@ .BE .SH DESCRIPTION .PP \fBTcl_GetHostName\fR is a utility procedure used by some of the -Tcl commands. It returns a pointer to a string containing the name +Tcl commands. It returns a pointer to a string containing the name for the current machine, or an empty string if the name cannot be determined. The string is statically allocated, and the caller must not modify of free it. .PP .SH KEYWORDS hostname Index: doc/GetIndex.3 ================================================================== --- doc/GetIndex.3 +++ doc/GetIndex.3 @@ -1,11 +1,11 @@ '\" '\" 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_GetIndexFromObj 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_GetIndexFromObj, Tcl_GetIndexFromObjStruct \- lookup string in table of keywords @@ -24,27 +24,24 @@ .AS "const char" *structTablePtr in/out .AP Tcl_Interp *interp in Interpreter to use for error reporting; if NULL, then no message is provided on errors. .AP Tcl_Obj *objPtr in/out -The string value of this value is used to search through \fItablePtr\fR. -If the \fBTCL_INDEX_TEMP_TABLE\fR flag is not specified, -the internal representation is modified to hold the index of the matching +The string value of this object is used to search through \fItablePtr\fR. +The internal representation is modified to hold the index of the matching table entry. -.AP "const char *const" *tablePtr in +.AP "const char" **tablePtr in An array of null-terminated strings. The end of the array is marked by a NULL string pointer. -Note that, unless the \fBTCL_INDEX_TEMP_TABLE\fR flag is specified, -references to the \fItablePtr\fR may be retained in the +Note that references to the \fItablePtr\fR may be retained in the internal representation of \fIobjPtr\fR, so this should represent the address of a statically-allocated array. .AP "const void" *structTablePtr in An array of arbitrary type, typically some \fBstruct\fR type. The first member of the structure must be a null-terminated string. The size of the structure is given by \fIoffset\fR. -Note that, unless the \fBTCL_INDEX_TEMP_TABLE\fR flag is specified, -references to the \fIstructTablePtr\fR may be retained in the +Note that references to the \fIstructTablePtr\fR may be retained in the internal representation of \fIobjPtr\fR, so this should represent the address of a statically-allocated array of structures. .AP int offset in The offset to add to structTablePtr to get to the next entry. The end of the array is marked by a NULL string pointer. @@ -51,21 +48,21 @@ .AP "const char" *msg in Null-terminated string describing what is being looked up, such as \fBoption\fR. This string is included in error messages. .AP int flags in OR-ed combination of bits providing additional information for -operation. The only bits that are currently defined are \fBTCL_EXACT\fR -and \fBTCL_INDEX_TEMP_TABLE\fR. +operation. The only bit that is currently defined is \fBTCL_EXACT\fR. .AP int *indexPtr out The index of the string in \fItablePtr\fR that matches the value of \fIobjPtr\fR is returned here. .BE + .SH DESCRIPTION .PP These procedures provide an efficient way for looking up keywords, -switch names, option names, and similar things where the literal value of -a Tcl value must be chosen from a predefined set. +switch names, option names, and similar things where the value of +an object must be one of a predefined set of values. \fBTcl_GetIndexFromObj\fR compares \fIobjPtr\fR against each of the strings in \fItablePtr\fR to find a match. A match occurs if \fIobjPtr\fR's string value is identical to one of the strings in \fItablePtr\fR, or if it is a non-empty unique abbreviation for exactly one of the strings in \fItablePtr\fR and the @@ -78,22 +75,19 @@ result if \fIinterp\fR is not NULL. \fIMsg\fR is included in the error message to indicate what was being looked up. For example, if \fImsg\fR is \fBoption\fR the error message will have a form like .QW "\fBbad option \N'34'firt\N'34': must be first, second, or third\fR" . .PP -If the \fBTCL_INDEX_TEMP_TABLE\fR was not specified, when -\fBTcl_GetIndexFromObj\fR completes successfully it modifies the +If \fBTcl_GetIndexFromObj\fR completes successfully it modifies the internal representation of \fIobjPtr\fR to hold the address of the table and the index of the matching entry. If \fBTcl_GetIndexFromObj\fR is invoked again with the same \fIobjPtr\fR and \fItablePtr\fR arguments (e.g. during a reinvocation of a Tcl command), it returns the matching index immediately without having to redo the lookup operation. Note: \fBTcl_GetIndexFromObj\fR assumes that the entries in \fItablePtr\fR are static: they must not change between -invocations. This caching mechanism can be disallowed by specifying -the \fBTCL_INDEX_TEMP_TABLE\fR flag. -If the value of \fIobjPtr\fR is the empty string, +invocations. If the value of \fIobjPtr\fR is the empty string, \fBTcl_GetIndexFromObj\fR will treat it as a non-matching value and return \fBTCL_ERROR\fR. .PP \fBTcl_GetIndexFromObjStruct\fR works just like \fBTcl_GetIndexFromObj\fR, except that instead of treating @@ -103,9 +97,11 @@ first array of characters at \fItablePtr\fR, a pointer to the second array of characters at \fItablePtr\fR+\fIoffset\fR bytes, etc.) This is particularly useful when processing things like \fBTk_ConfigurationSpec\fR, whose string keys are in the same place in each of several array elements. + .SH "SEE ALSO" -prefix(n), Tcl_WrongNumArgs(3) +Tcl_WrongNumArgs + .SH KEYWORDS -index, option, value, table lookup +index, object, table lookup Index: doc/GetInt.3 ================================================================== --- doc/GetInt.3 +++ doc/GetInt.3 @@ -2,11 +2,11 @@ '\" 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_GetInt 3 "" Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_GetInt, Tcl_GetDouble, Tcl_GetBoolean \- convert from string to integer, double, or boolean @@ -49,46 +49,31 @@ desired type then \fBTCL_ERROR\fR is returned, an error message is left in the interpreter's result, and nothing is stored at *\fIintPtr\fR or *\fIdoublePtr\fR or *\fIboolPtr\fR. .PP \fBTcl_GetInt\fR expects \fIsrc\fR to consist of a collection -of integer digits, optionally signed and optionally preceded and -followed by white space. If the first two characters of \fIsrc\fR +of integer digits, optionally signed and optionally preceded by +white space. If the first two characters of \fIsrc\fR after the optional white space and sign are -.QW \fB0x\fR +.QW 0x then \fIsrc\fR is expected to be in hexadecimal form; otherwise, -if the first such characters are -.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 +if the first such character is +.QW 0 then \fIsrc\fR -is expected to be in binary form; otherwise, \fIsrc\fR is +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 ; +decimal point; a sequence of digits; the letter +.QW e ; a signed decimal exponent; and more white space. Any of the fields may be omitted, except that the digits either before or after the decimal point must be present and if the -.QW \fBe\fR -is present then it must be followed by the exponent number. If there -are no fields apart from the sign and initial sequence of digits -(i.e., no decimal point or exponent indicator), that -initial sequence of digits should take one of the forms that -\fBTcl_GetInt\fR supports, described above. The use of -.QW \fB,\fR -as a decimal point is not supported nor should any other sort of -inter-digit separator be present. +.QW e +is present then it must be followed by the exponent number. .PP \fBTcl_GetBoolean\fR expects \fIsrc\fR to specify a boolean value. If \fIsrc\fR is any of \fB0\fR, \fBfalse\fR, \fBno\fR, or \fBoff\fR, then \fBTcl_GetBoolean\fR stores a zero value at \fI*boolPtr\fR. Index: doc/GetOpnFl.3 ================================================================== --- doc/GetOpnFl.3 +++ doc/GetOpnFl.3 @@ -1,11 +1,11 @@ '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Tcl_GetOpenFile 3 8.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_GetOpenFile \- Return a FILE* for a channel registered in the given interpreter (Unix only) @@ -26,11 +26,11 @@ 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 void **filePtr out +.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 Index: doc/GetStdChan.3 ================================================================== --- doc/GetStdChan.3 +++ doc/GetStdChan.3 @@ -1,11 +1,11 @@ '\" '\" Copyright (c) 1996 by Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Tcl_GetStdChannel 3 7.5 Tcl "Tcl Library Procedures" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -32,41 +32,39 @@ .PP Tcl defines three special channels that are used by various I/O related commands if no other channels are specified. The standard input channel has a channel name of \fBstdin\fR and is used by \fBread\fR and \fBgets\fR. The standard output channel is named \fBstdout\fR and is used by -\fBputs\fR. The standard error channel is named \fBstderr\fR and is used for +\fBputs\fR. The standard error channel is named \fBstderr\fR and is used for reporting errors. In addition, the standard channels are inherited by any child processes created using \fBexec\fR or \fBopen\fR in the absence of any other redirections. .PP The standard channels are actually aliases for other normal channels. The current channel associated with a standard channel can be retrieved by calling -\fBTcl_GetStdChannel\fR with one of +\fBTcl_GetStdChannel\fR with one of \fBTCL_STDIN\fR, \fBTCL_STDOUT\fR, or \fBTCL_STDERR\fR as the \fItype\fR. The return value will be a valid channel, or NULL. .PP -A new channel can be set for the standard channel specified by \fItype\fR +A new channel can be set for the standard channel specified by \fItype\fR by calling \fBTcl_SetStdChannel\fR with a new channel or NULL in the \fIchannel\fR argument. If the specified channel is closed by a later call to \fBTcl_Close\fR, then the corresponding standard channel will automatically be set to NULL. .PP If a non-NULL value for \fIchannel\fR is passed to \fBTcl_SetStdChannel\fR, then that same value should be passed to \fBTcl_RegisterChannel\fR, like so: -.PP .CS Tcl_RegisterChannel(NULL, channel); .CE -.PP This is a workaround for a misfeature in \fBTcl_SetStdChannel\fR that it fails to do some reference counting housekeeping. This misfeature cannot be corrected without contradicting the assumptions of some existing code that calls \fBTcl_SetStdChannel\fR. .PP If \fBTcl_GetStdChannel\fR is called before \fBTcl_SetStdChannel\fR, Tcl will -construct a new channel to wrap the appropriate platform-specific standard +construct a new channel to wrap the appropriate platform-specific standard file handle. If \fBTcl_SetStdChannel\fR is called before \fBTcl_GetStdChannel\fR, then the default channel will not be created. .PP If one of the standard channels is set to NULL, either by calling \fBTcl_SetStdChannel\fR with a NULL \fIchannel\fR argument, or by calling @@ -75,12 +73,12 @@ more than one standard channel is NULL, then the standard channels will be assigned starting with standard input, followed by standard output, with standard error being last. .PP See \fBTcl_StandardChannels\fR for a general treatise about standard -channels and the behavior of the Tcl library with regard to them. +channels and the behaviour of the Tcl library with regard to them. .SH "SEE ALSO" Tcl_Close(3), Tcl_CreateChannel(3), Tcl_Main(3), tclsh(1) .SH KEYWORDS standard channel, standard input, standard output, standard error Index: doc/GetTime.3 ================================================================== --- doc/GetTime.3 +++ doc/GetTime.3 @@ -1,11 +1,11 @@ '\" '\" Copyright (c) 2001 by Kevin B. Kenny . '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Tcl_GetTime 3 8.4 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_GetTime, Tcl_SetTimeProc, Tcl_QueryTimeProc \- get date and time @@ -17,38 +17,43 @@ .sp \fBTcl_SetTimeProc\fR(\fIgetProc, scaleProc, clientData\fR) .sp \fBTcl_QueryTimeProc\fR(\fIgetProcPtr, scaleProcPtr, clientDataPtr\fR) .SH ARGUMENTS -.AS Tcl_GetTimeProc *getProc in -.AP Tcl_Time *timePtr out +.AS "Tcl_Time *" timePtr out +.AP "Tcl_Time *" timePtr out Points to memory in which to store the date and time information. -.AP Tcl_GetTimeProc getProc in +.AS "Tcl_GetTimeProc *" getProc in +.AP "Tcl_GetTimeProc *" getProc in Pointer to handler function replacing \fBTcl_GetTime\fR's access to the OS. -.AP Tcl_ScaleTimeProc scaleProc in +.AS "Tcl_ScaleTimeProc *" scaleProc in +.AP "Tcl_ScaleTimeProc *" scaleProc in Pointer to handler function for the conversion of time delays in the virtual domain to real-time. -.AP void *clientData in +.AS "ClientData *" clientData in +.AP "ClientData *" clientData in Value passed through to the two handler functions. -.AP Tcl_GetTimeProc *getProcPtr out +.AS "Tcl_GetTimeProc **" getProcPtr inout +.AP "Tcl_GetTimeProc **" getProcPtr inout Pointer to place the currently registered get handler function into. -.AP Tcl_ScaleTimeProc *scaleProcPtr out +.AS "Tcl_ScaleTimeProc **" scaleProcPtr inout +.AP "Tcl_ScaleTimeProc **" scaleProcPtr inout Pointer to place the currently registered scale handler function into. -.AP void **clientDataPtr out +.AS "ClientData **" clientDataPtr inout +.AP "ClientData **" clientDataPtr inout 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: -.PP .CS typedef struct Tcl_Time { - long \fIsec\fR; - long \fIusec\fR; -} \fBTcl_Time\fR; + long sec; + long usec; +} Tcl_Time; .CE .PP On return, the \fIsec\fR member of the structure is filled in with the number of seconds that have elapsed since the \fIepoch:\fR the epoch is the point in time of 00:00 UTC, 1 January 1970. This number does @@ -61,49 +66,35 @@ this number as precise as possible, subject to the limitations of the computer system. On multiprocessor variants of Windows, this number may be limited to the 10- or 20-ms granularity of the system clock. (On single-processor Windows systems, the \fIusec\fR field is derived from a performance counter and is highly precise.) -.SS "VIRTUALIZED TIME" .PP -The \fBTcl_SetTimeProc\fR function registers two related handler functions +The \fBTcl_SetTime\fR function registers two related handler functions with the core. The first handler function is a replacement for \fBTcl_GetTime\fR, or rather the OS access made by \fBTcl_GetTime\fR. The other handler function is used by the Tcl notifier to convert wait/block times from the virtual domain into real time. .PP -The \fBTcl_QueryTimeProc\fR function returns the currently registered +The \fBTcl_QueryTime\fR function returns the currently registered handler functions. If no external handlers were set then this will return the standard handlers accessing and processing the native time of the OS. The arguments to the function are allowed to be NULL; and 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, - void *\fIclientData\fR); -typedef void \fBTcl_ScaleTimeProc\fR( - Tcl_Time *\fItimebuf\fR, - void *\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 -them. In other words, setting one handler of the pair to something assuming a -10-times slowdown, and the other handler of the pair to something assuming a -two-times slowdown is wrong and not allowed. -.PP -The set handler functions are allowed to run the delivered time backwards, -however this should be avoided. We have to allow it as the native time can run -backwards as the user can fiddle with the system time one way or other. Note -that the insertion of the hooks will not change the behavior of the Tcl core -with regard to this situation, i.e. the existing behavior is retained. -.SH "SEE ALSO" -clock(n) +Any handler pair specified has to return data which is consistent +between them. In other words, setting one handler of the pair to +something assuming a 10-times slowdown, and the other handler of the +pair to something assuming a two-times slowdown is wrong and not +allowed. +.PP +The set handler functions are allowed to run the delivered time +backwards, however this should be avoided. We have to allow it as the +native time can run backwards as the user can fiddle with the system +time one way or other. Note that the insertion of the hooks will not +change the behaviour of the Tcl core with regard to this situation, +i.e. the existing behaviour is retained. +.SH "SEE ALSO" +clock .SH KEYWORDS date, time Index: doc/GetVersion.3 ================================================================== --- doc/GetVersion.3 +++ doc/GetVersion.3 @@ -1,11 +1,11 @@ '\" '\" Copyright (c) 1999 Scriptics Corporation '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Tcl_GetVersion 3 7.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_GetVersion \- get the version of the library at runtime @@ -22,27 +22,27 @@ Minor version number of the Tcl library. .AP int *patchLevel out The patch level of the Tcl library (or alpha or beta number). .AP Tcl_ReleaseType *type out The type of release, also indicates the type of patch level. Can be -one of \fBTCL_ALPHA_RELEASE\fR, \fBTCL_BETA_RELEASE\fR, or +one of \fBTCL_ALPHA_RELEASE\fR, \fBTCL_BETA_RELEASE\fR, or \fBTCL_FINAL_RELEASE\fR. .BE .SH DESCRIPTION .PP \fBTcl_GetVersion\fR should be used to query the version number -of the Tcl library at runtime. This is useful when using a +of the Tcl library at runtime. This is useful when using a dynamically loaded Tcl library or when writing a stubs-aware extension. For instance, if you write an extension that is linked against the Tcl stubs library, it could be loaded into a program linked to an older version of Tcl than you expected. Use \fBTcl_GetVersion\fR to verify that fact, and possibly to change the behavior of your extension. .PP -\fBTcl_GetVersion\fR accepts NULL for any of the arguments. For instance if +\fBTcl_GetVersion\fR accepts NULL for any of the arguments. For instance if you do not care about the \fIpatchLevel\fR of the library, pass a NULL for the \fIpatchLevel\fR argument. .SH KEYWORDS version, patchlevel, major, minor, alpha, beta, release Index: doc/Hash.3 ================================================================== --- doc/Hash.3 +++ doc/Hash.3 @@ -2,11 +2,11 @@ '\" 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_Hash 3 "" Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_InitHashTable, Tcl_InitCustomHashTable, Tcl_InitObjHashTable, Tcl_DeleteHashTable, Tcl_CreateHashEntry, Tcl_DeleteHashEntry, Tcl_FindHashEntry, Tcl_GetHashValue, Tcl_SetHashValue, Tcl_GetHashKey, Tcl_FirstHashEntry, Tcl_NextHashEntry, Tcl_HashStats \- procedures to manage hash tables @@ -28,16 +28,16 @@ \fBTcl_DeleteHashEntry\fR(\fIentryPtr\fR) .sp Tcl_HashEntry * \fBTcl_FindHashEntry\fR(\fItablePtr, key\fR) .sp -void * +ClientData \fBTcl_GetHashValue\fR(\fIentryPtr\fR) .sp \fBTcl_SetHashValue\fR(\fIentryPtr, value\fR) .sp -void * +char * \fBTcl_GetHashKey\fR(\fItablePtr, entryPtr\fR) .sp Tcl_HashEntry * \fBTcl_FirstHashEntry\fR(\fItablePtr, searchPtr\fR) .sp @@ -45,31 +45,32 @@ \fBTcl_NextHashEntry\fR(\fIsearchPtr\fR) .sp char * \fBTcl_HashStats\fR(\fItablePtr\fR) .SH ARGUMENTS -.AS "const Tcl_HashKeyType" *searchPtr out +.AS Tcl_HashKeyType *searchPtr out .AP Tcl_HashTable *tablePtr in Address of hash table structure (for all procedures but \fBTcl_InitHashTable\fR, this must have been initialized by previous call to \fBTcl_InitHashTable\fR). .AP int keyType in Kind of keys to use for new hash table. Must be either \fBTCL_STRING_KEYS\fR, \fBTCL_ONE_WORD_KEYS\fR, \fBTCL_CUSTOM_TYPE_KEYS\fR, \fBTCL_CUSTOM_PTR_KEYS\fR, or an integer value greater than 1. .AP Tcl_HashKeyType *typePtr in -Address of structure which defines the behavior of the hash table. -.AP "const void" *key in +Address of structure which defines the behaviour of the hash table. +.AP "const char" *key in 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 void *value in -New value to assign 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 @@ -78,12 +79,12 @@ key and a value. Given the key for an entry, the hashing routines can very quickly locate the entry, and hence its value. There may be at most one entry in a hash table with a particular key, but many entries may have the same value. Keys can take one of four forms: strings, one-word values, integer arrays, or custom keys defined by a -Tcl_HashKeyType structure (See section \fBTHE TCL_HASHKEYTYPE STRUCTURE\fR -below). All of the keys in a given table have the same +Tcl_HashKeyType structure (See section \fBTHE TCL_HASHKEYTYPE +STRUCTURE\fR below). All of the keys in a given table have the same form, which is specified when the table is initialized. .PP The value of a hash table entry can be anything that fits in the same space as a .QW "char *" @@ -128,17 +129,17 @@ values. The pointer value is the key; it need not (and usually does not) actually point to a string. .IP \fBTCL_CUSTOM_TYPE_KEYS\fR 25 Keys are of arbitrary type, and are stored in the entry. Hashing -and comparison is determined by \fItypePtr\fR. The Tcl_HashKeyType -structure is described in the section +and comparison is determined by \fItypePtr\fR. The Tcl_HashKeyType +structure is described in the section \fBTHE TCL_HASHKEYTYPE STRUCTURE\fR below. .IP \fBTCL_CUSTOM_PTR_KEYS\fR 25 Keys are pointers to an arbitrary type, and are stored in the entry. Hashing -and comparison is determined by \fItypePtr\fR. The Tcl_HashKeyType -structure is described in the section +and comparison is determined by \fItypePtr\fR. The Tcl_HashKeyType +structure is described in the section \fBTHE TCL_HASHKEYTYPE STRUCTURE\fR below. .IP \fIother\fR 25 If \fIkeyType\fR is not one of the above, then it must be an integer value greater than 1. In this case the keys will be arrays of @@ -183,10 +184,15 @@ 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 @@ -221,11 +227,11 @@ \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 \fBTcl_Free\fR. +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 @@ -237,20 +243,19 @@ .PP Extension writers can define new hash key types by defining four procedures, initializing a \fBTcl_HashKeyType\fR structure to describe the type, and calling \fBTcl_InitCustomHashTable\fR. The \fBTcl_HashKeyType\fR structure is defined as follows: -.PP .CS typedef struct Tcl_HashKeyType { int \fIversion\fR; int \fIflags\fR; Tcl_HashKeyProc *\fIhashKeyProc\fR; Tcl_CompareHashKeysProc *\fIcompareKeysProc\fR; Tcl_AllocHashEntryProc *\fIallocEntryProc\fR; Tcl_FreeHashEntryProc *\fIfreeEntryProc\fR; -} \fBTcl_HashKeyType\fR; +} Tcl_HashKeyType; .CE .PP The \fIversion\fR member is the version of the table. If this structure is extended in future then the version can be used to distinguish between different structures. It should be set to \fBTCL_HASH_KEY_TYPE_VERSION\fR. @@ -261,68 +266,61 @@ There are some things, pointers for example which do not hash well because they do not use the lower bits. If this flag is set then the hash table will attempt to rectify this by randomizing the bits and then using the upper N bits as the index into the table. .IP \fBTCL_HASH_KEY_SYSTEM_HASH\fR 25 +.VS 8.5 This flag forces Tcl to use the memory allocation procedures provided by the operating system when allocating and freeing memory used to store the hash table data structures, and not any of Tcl's own customized memory allocation routines. This is important if the hash table is to be used in the implementation of a custom set of allocation routines, or something that a custom set of allocation routines might depend on, in order to avoid any circular dependency. +.VE 8.5 .PP The \fIhashKeyProc\fR member contains the address of a function called to calculate a hash value for the key. -.PP .CS -typedef TCL_HASH_TYPE \fBTcl_HashKeyProc\fR( +typedef unsigned int (Tcl_HashKeyProc) ( Tcl_HashTable *\fItablePtr\fR, void *\fIkeyPtr\fR); .CE -.PP If this is NULL then \fIkeyPtr\fR is used and \fBTCL_HASH_KEY_RANDOMIZE_HASH\fR is assumed. .PP The \fIcompareKeysProc\fR member contains the address of a function called to compare two keys. -.PP .CS -typedef int \fBTcl_CompareHashKeysProc\fR( +typedef int (Tcl_CompareHashKeysProc) ( void *\fIkeyPtr\fR, Tcl_HashEntry *\fIhPtr\fR); .CE -.PP If this is NULL then the \fIkeyPtr\fR pointers are compared. If the keys do not match then the function returns 0, otherwise it returns 1. .PP The \fIallocEntryProc\fR member contains the address of a function called to allocate space for an entry and initialize the key and clientData. -.PP .CS -typedef Tcl_HashEntry *\fBTcl_AllocHashEntryProc\fR( +typedef Tcl_HashEntry *(Tcl_AllocHashEntryProc) ( Tcl_HashTable *\fItablePtr\fR, void *\fIkeyPtr\fR); .CE -.PP -If this is NULL then \fBTcl_Alloc\fR is used to allocate enough space for a +If this is NULL then Tcl_Alloc is used to allocate enough space for a Tcl_HashEntry, the key pointer is assigned to key.oneWordValue and the clientData is set to NULL. String keys and array keys use this function to allocate enough space for the entry and the key in one block, rather than doing it in two blocks. This saves space for a pointer to the key from the entry and another memory allocation. Tcl_Obj* keys use this function to allocate enough space for an entry and increment the reference count on the -value. +object. .PP The \fIfreeEntryProc\fR member contains the address of a function called to free space for an entry. -.PP .CS -typedef void \fBTcl_FreeHashEntryProc\fR( - Tcl_HashEntry *\fIhPtr\fR); +typedef void (Tcl_FreeHashEntryProc) (Tcl_HashEntry *\fIhPtr\fR); .CE -.PP -If this is NULL then \fBTcl_Free\fR is used to free the space for the entry. +If this is NULL then Tcl_Free is used to free the space for the entry. Tcl_Obj* keys use this function to decrement the reference count on the -value. +object. .SH KEYWORDS hash table, key, lookup, search, value Index: doc/Init.3 ================================================================== --- doc/Init.3 +++ doc/Init.3 @@ -1,9 +1,9 @@ '\" '\" Copyright (c) 1998-2000 by Scriptics Corporation. '\" All rights reserved. -'\" +'\" .TH Tcl_Init 3 8.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_Init \- find and source initialization script Index: doc/InitStubs.3 ================================================================== --- doc/InitStubs.3 +++ doc/InitStubs.3 @@ -1,11 +1,11 @@ '\" '\" Copyright (c) 1998-1999 Scriptics Corporation '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Tcl_InitStubs 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_InitStubs \- initialize the Tcl stubs mechanism @@ -21,15 +21,15 @@ Tcl interpreter handle. .AP "const char" *version in A version string consisting of one or more decimal numbers separated by dots. .AP int exact in -1 means that only the particular version specified by +Non-zero means that only the particular version specified by \fIversion\fR is acceptable. -0 means that versions newer than \fIversion\fR are also +Zero means that versions newer than \fIversion\fR are also acceptable as long as they have the same major version number -as \fIversion\fR. Other bits have no effect. +as \fIversion\fR. .BE .SH INTRODUCTION .PP The Tcl stubs mechanism defines a way to dynamically bind extensions to a particular Tcl implementation at run time. @@ -61,13 +61,13 @@ .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 9.0 ABI on Unix platforms, -the library name is \fIlibtclstub9.0.a\fR; on Windows platforms, the -library name is \fItclstub90.lib\fR. +Tcl library. On Unix platforms, the library name is +\fIlibtclstub8.5.a\fR; on Windows platforms, the library name is +\fItclstub85.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. DELETED doc/InitSubSyst.3 Index: doc/InitSubSyst.3 ================================================================== --- doc/InitSubSyst.3 +++ /dev/null @@ -1,31 +0,0 @@ -'\" -'\" 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 \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 utf-8, -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 utf-8. -.SH KEYWORDS -binary, executable file Index: doc/IntObj.3 ================================================================== --- doc/IntObj.3 +++ doc/IntObj.3 @@ -1,16 +1,16 @@ '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Tcl_IntObj 3 8.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_NewIntObj, Tcl_NewLongObj, Tcl_NewWideIntObj, Tcl_SetIntObj, Tcl_SetLongObj, Tcl_SetWideIntObj, Tcl_GetIntFromObj, Tcl_GetIntForIndex, Tcl_GetLongFromObj, Tcl_GetWideIntFromObj, Tcl_NewBignumObj, Tcl_SetBignumObj, Tcl_GetBignumFromObj, Tcl_TakeBignumFromObj \- manipulate Tcl values as integers +Tcl_NewIntObj, Tcl_NewLongObj, Tcl_NewWideIntObj, Tcl_SetIntObj, Tcl_SetLongObj, Tcl_SetWideIntObj, Tcl_GetIntFromObj, Tcl_GetLongFromObj, Tcl_GetWideIntFromObj, Tcl_NewBignumObj, Tcl_SetBignumObj, Tcl_GetBignumFromObj, Tcl_TakeBignumFromObj \- manipulate Tcl objects as integer values .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_Obj * @@ -29,20 +29,18 @@ \fBTcl_SetWideIntObj\fR(\fIobjPtr, wideValue\fR) .sp int \fBTcl_GetIntFromObj\fR(\fIinterp, objPtr, intPtr\fR) .sp -int -\fBTcl_GetIntForIndex\fR(\fIinterp, objPtr, endValue, intPtr\fR) -.sp int \fBTcl_GetLongFromObj\fR(\fIinterp, objPtr, longPtr\fR) .sp int \fBTcl_GetWideIntFromObj\fR(\fIinterp, objPtr, widePtr\fR) .sp .sp +.VS 8.5 \fB#include \fR .sp Tcl_Obj * \fBTcl_NewBignumObj\fR(\fIbigValue\fR) .sp @@ -54,26 +52,25 @@ int \fBTcl_TakeBignumFromObj\fR(\fIinterp, objPtr, bigValue\fR) .sp int \fBTcl_InitBignumFromDouble\fR(\fIinterp, doubleValue, bigValue\fR) +.VE 8.5 .SH ARGUMENTS .AS Tcl_WideInt doubleValue in/out -.AP int endValue in -\fBTcl_GetIntForIndex\fR will return this when the input value is "end". .AP int intValue in -Integer value used to initialize or set a Tcl value. +Integer value used to initialize or set a Tcl object. .AP long longValue in -Long integer value used to initialize or set a Tcl value. +Long integer value used to initialize or set a Tcl object. .AP Tcl_WideInt wideValue in -Wide integer value used to initialize or set a Tcl value. +Wide integer value used to initialize or set a Tcl object. .AP Tcl_Obj *objPtr in/out For \fBTcl_SetIntObj\fR, \fBTcl_SetLongObj\fR, \fBTcl_SetWideIntObj\fR, -and \fBTcl_SetBignumObj\fR, this points to the value in which to store an +and \fBTcl_SetBignumObj\fR, this points to the object in which to store an integral value. For \fBTcl_GetIntFromObj\fR, \fBTcl_GetLongFromObj\fR, \fBTcl_GetWideIntFromObj\fR, \fBTcl_GetBignumFromObj\fR, and -\fBTcl_TakeBignumFromObj\fR, this refers to the value from which +\fBTcl_TakeBignumFromObj\fR, this refers to the object from which to retrieve an integral value. .AP Tcl_Interp *interp in/out When non-NULL, an error message is left here when integral value retrieval fails. .AP int *intPtr out @@ -81,70 +78,66 @@ .AP long *longPtr out Points to place to store the long integer value retrieved from \fIobjPtr\fR. .AP Tcl_WideInt *widePtr out Points to place to store the wide integer value retrieved from \fIobjPtr\fR. .AP mp_int *bigValue in/out +.VS 8.5 Points to a multi-precision integer structure declared by the LibTomMath library. +.VE 8.5 .AP double doubleValue in +.VS 8.5 Double value from which the integer part is determined and used to initialize a multi-precision integer value. +.VE 8.5 .BE + .SH DESCRIPTION .PP -These procedures are used to create, modify, and read Tcl values -that hold integral values. +.VS 8.5 +These procedures are used to create, modify, and read Tcl objects +that hold integral values. .PP The different routines exist to accommodate different integral types in C with which values might be exchanged. The C integral types for which Tcl provides value exchange routines are \fBint\fR, \fBlong int\fR, \fBTcl_WideInt\fR, and \fBmp_int\fR. The \fBint\fR and \fBlong int\fR types are provided by the C language standard. The \fBTcl_WideInt\fR type is a typedef defined to be whatever signed integral type covers at least the 64-bit integer range (-9223372036854775808 to 9223372036854775807). Depending on the platform and the C compiler, the actual type might be -\fBlong long int\fR, \fB__int64\fR, or something else. +\fBlong int\fR, \fBlong long int\fR, \fBint64\fR, or something else. The \fBmp_int\fR type is a multiple-precision integer type defined -by the LibTomMath multiple-precision integer library. +by the LibTomMath multiple-precision integer library. .PP The \fBTcl_NewIntObj\fR, \fBTcl_NewLongObj\fR, \fBTcl_NewWideIntObj\fR, and \fBTcl_NewBignumObj\fR routines each create and return a new -Tcl value initialized to the integral value of the argument. The -returned Tcl value is unshared. +Tcl object initialized to the integral value of the argument. The +returned Tcl object is unshared. .PP The \fBTcl_SetIntObj\fR, \fBTcl_SetLongObj\fR, \fBTcl_SetWideIntObj\fR, and \fBTcl_SetBignumObj\fR routines each set the value of an existing -Tcl value pointed to by \fIobjPtr\fR to the integral value provided +Tcl object pointed to by \fIobjPtr\fR to the integral value provided by the other argument. The \fIobjPtr\fR argument must point to an -unshared Tcl value. Any attempt to set the value of a shared Tcl value +unshared Tcl object. Any attempt to set the value of a shared Tcl object violates Tcl's copy-on-write policy. Any existing string representation -or internal representation in the unshared Tcl value will be freed +or internal representation in the unshared Tcl object will be freed as a consequence of setting the new value. .PP -The \fBTcl_GetIntForIndex\fR routine attempts to retrieve an index -value from the Tcl value \fIobjPtr\fR. If the attempt succeeds, -then \fBTCL_OK\fR is returned, and the value is written to the -storage provided by the caller. The attempt might fail if -\fIobjPtr\fR does not hold an index value. If the attempt fails, -then \fBTCL_ERROR\fR is returned, and if \fIinterp\fR is non-NULL, -an error message is left in \fIinterp\fR. The \fBTcl_ObjType\fR -of \fIobjPtr\fR may be changed to make subsequent calls to the -same routine more efficient. -.PP The \fBTcl_GetIntFromObj\fR, \fBTcl_GetLongFromObj\fR, \fBTcl_GetWideIntFromObj\fR, \fBTcl_GetBignumFromObj\fR, and \fBTcl_TakeBignumFromObj\fR routines attempt to retrieve an integral -value of the appropriate type from the Tcl value \fIobjPtr\fR. If the +value of the appropriate type from the Tcl object \fIobjPtr\fR. If the attempt succeeds, then \fBTCL_OK\fR is returned, and the value is written to the storage provided by the caller. The attempt might fail if \fIobjPtr\fR does not hold an integral value, or if the value exceeds the range of the target type. If the attempt fails, then \fBTCL_ERROR\fR is returned, and if \fIinterp\fR is non-NULL, an error message is left in \fIinterp\fR. The \fBTcl_ObjType\fR of \fIobjPtr\fR may be changed to make subsequent calls to the same routine more efficient. Unlike the other functions, -\fBTcl_TakeBignumFromObj\fR may set the content of the Tcl value +\fBTcl_TakeBignumFromObj\fR may set the content of the Tcl object \fIobjPtr\fR to an empty string in the process of retrieving the multiple-precision integer value. .PP The choice between \fBTcl_GetBignumFromObj\fR and \fBTcl_TakeBignumFromObj\fR is governed by how the caller will @@ -158,10 +151,10 @@ \fBTcl_GetBignumFromObj\fR must be chosen. .PP The \fBTcl_InitBignumFromDouble\fR routine is a utility procedure that extracts the integer part of \fIdoubleValue\fR and stores that integer value in the \fBmp_int\fR value \fIbigValue\fR. +.VE 8.5 .SH "SEE ALSO" Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult .SH KEYWORDS -integer, integer value, integer type, internal representation, value, -value type, string representation +integer, integer object, integer type, internal representation, object, object type, string representation ADDED doc/Interp.3 Index: doc/Interp.3 ================================================================== --- /dev/null +++ doc/Interp.3 @@ -0,0 +1,126 @@ +'\" +'\" 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 7.5 Tcl "Tcl Library Procedures" +.so man.macros +.BS +.SH NAME +Tcl_Interp \- client-visible fields of interpreter structures +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +typedef struct { + char *\fIresult\fR; + Tcl_FreeProc *\fIfreeProc\fR; + int \fIerrorLine\fR; +} Tcl_Interp; + +typedef void Tcl_FreeProc(char *\fIblockPtr\fR); +.BE + +.SH DESCRIPTION +.PP +The \fBTcl_CreateInterp\fR procedure returns a pointer to a Tcl_Interp +structure. This pointer is then passed into other Tcl procedures +to process commands in the interpreter and perform other operations +on the interpreter. Interpreter structures contain many fields +that are used by Tcl, but only three that may be accessed by +clients: \fIresult\fR, \fIfreeProc\fR, and \fIerrorLine\fR. +.PP +.VS 8.5 +\fBNote that access to all three fields, \fIresult\fB, \fIfreeProc\fB and +\fIerrorLine\fB is deprecated.\fR Use \fBTcl_SetResult\fR, +\fBTcl_GetResult\fR, and \fBTcl_GetReturnOptions\fR instead. +.VE 8.5 +.PP +The \fIresult\fR and \fIfreeProc\fR fields are used to return +results or error messages from commands. +This information is returned by command procedures back to \fBTcl_Eval\fR, +and by \fBTcl_Eval\fR back to its callers. +The \fIresult\fR field points to the string that represents the +result or error message, and the \fIfreeProc\fR field tells how +to dispose of the storage for the string when it is not needed anymore. +The easiest way for command procedures to manipulate these +fields is to call procedures like \fBTcl_SetResult\fR +or \fBTcl_AppendResult\fR; they +will hide all the details of managing the fields. +The description below is for those procedures that manipulate the +fields directly. +.PP +Whenever a command procedure returns, it must ensure +that the \fIresult\fR field of its interpreter points to the string +being returned by the command. +The \fIresult\fR field must always point to a valid string. +If a command wishes to return no result then \fIinterp->result\fR +should point to an empty string. +Normally, results are assumed to be statically allocated, +which means that the contents will not change before the next time +\fBTcl_Eval\fR is called or some other command procedure is invoked. +In this case, the \fIfreeProc\fR field must be zero. +Alternatively, a command procedure may dynamically +allocate its return value (e.g. using \fBTcl_Alloc\fR) +and store a pointer to it in \fIinterp->result\fR. +In this case, the command procedure must also set \fIinterp->freeProc\fR +to the address of a procedure that can free the value, or \fBTCL_DYNAMIC\fR +if the storage was allocated directly by Tcl or by a call to +\fBTcl_Alloc\fR. +If \fIinterp->freeProc\fR is non-zero, then Tcl will call \fIfreeProc\fR +to free the space pointed to by \fIinterp->result\fR before it +invokes the next command. +If a client procedure overwrites \fIinterp->result\fR when +\fIinterp->freeProc\fR is non-zero, then it is responsible for calling +\fIfreeProc\fR to free the old \fIinterp->result\fR (the \fBTcl_FreeResult\fR +macro should be used for this purpose). +.PP +\fIFreeProc\fR should have arguments and result that match the +\fBTcl_FreeProc\fR declaration above: it receives a single +argument which is a pointer to the result value to free. +In most applications \fBTCL_DYNAMIC\fR is the only non-zero value ever +used for \fIfreeProc\fR. +However, an application may store a different procedure address +in \fIfreeProc\fR in order to use an alternate memory allocator +or in order to do other cleanup when the result memory is freed. +.PP +As part of processing each command, \fBTcl_Eval\fR initializes +\fIinterp->result\fR +and \fIinterp->freeProc\fR just before calling the command procedure for +the command. The \fIfreeProc\fR field will be initialized to zero, +and \fIinterp->result\fR will point to an empty string. Commands that +do not return any value can simply leave the fields alone. +Furthermore, the empty string pointed to by \fIresult\fR is actually +part of an array of \fBTCL_RESULT_SIZE\fR characters (approximately 200). +If a command wishes to return a short string, it can simply copy +it to the area pointed to by \fIinterp->result\fR. Or, it can use +the sprintf procedure to generate a short result string at the location +pointed to by \fIinterp->result\fR. +.PP +It is a general convention in Tcl-based applications that the result +of an interpreter is normally in the initialized state described +in the previous paragraph. +Procedures that manipulate an interpreter's result (e.g. by +returning an error) will generally assume that the result +has been initialized when the procedure is called. +If such a procedure is to be called after the result has been +changed, then \fBTcl_ResetResult\fR should be called first to +reset the result to its initialized state. The direct use of +\fIinterp->result\fR is strongly deprecated (see \fBTcl_SetResult\fR). +.PP +The \fIerrorLine\fR +field is valid only after \fBTcl_Eval\fR returns +a \fBTCL_ERROR\fR return code. In this situation the \fIerrorLine\fR +field identifies the line number of the command being executed when +the error occurred. The line numbers are relative to the command +being executed: 1 means the first line of the command passed to +\fBTcl_Eval\fR, 2 means the second line, and so on. +The \fIerrorLine\fR field is typically used in conjunction with +\fBTcl_AddErrorInfo\fR to report information about where an error +occurred. +\fIErrorLine\fR should not normally be modified except by \fBTcl_Eval\fR. + +.SH KEYWORDS +free, initialized, interpreter, malloc, result Index: doc/Limit.3 ================================================================== --- doc/Limit.3 +++ doc/Limit.3 @@ -1,11 +1,11 @@ '\" '\" Copyright (c) 2004 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Tcl_LimitCheck 3 8.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_LimitAddHandler, Tcl_LimitCheck, Tcl_LimitExceeded, Tcl_LimitGetCommands, Tcl_LimitGetGranularity, Tcl_LimitGetTime, Tcl_LimitReady, Tcl_LimitRemoveHandler, Tcl_LimitSetCommands, Tcl_LimitSetGranularity, Tcl_LimitSetTime, Tcl_LimitTypeEnabled, Tcl_LimitTypeExceeded, Tcl_LimitTypeReset, Tcl_LimitTypeSet \- manage and check resource limits on interpreters @@ -81,17 +81,18 @@ 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 void *clientData in +.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 .PP Tcl's interpreter resource limit subsystem allows for close control over how much computation time a script may use, and is useful for cases where a program is divided into multiple pieces where some parts @@ -114,11 +115,11 @@ When a limit is exceeded (and the callbacks have run; the order of execution of the callbacks is unspecified) execution in the limited interpreter is stopped by raising an error and setting a flag that prevents the \fBcatch\fR command in that interpreter from trapping that error. It is up to the context that started execution in that -interpreter (typically the main interpreter) to handle the error. +interpreter (typically a master interpreter) to handle the error. .SH "LIMIT CHECKING API" .PP To check the resource limits for an interpreter, call \fBTcl_LimitCheck\fR, which returns \fBTCL_OK\fR if the limit was not exceeded (after processing callbacks) and \fBTCL_ERROR\fR if the limit was @@ -159,12 +160,12 @@ \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( - void *\fIclientData\fR, +typedef void Tcl_LimitHandlerProc( + 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, @@ -176,17 +177,18 @@ \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( - void *\fIclientData\fR); +typedef void Tcl_LimitHandlerDeleteProc( + 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 Index: doc/LinkVar.3 ================================================================== --- doc/LinkVar.3 +++ doc/LinkVar.3 @@ -2,70 +2,51 @@ '\" 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_LinkVar 3 7.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_LinkArray, Tcl_LinkVar, Tcl_UnlinkVar, Tcl_UpdateLinkedVar \- link Tcl variable to C variable +Tcl_LinkVar, Tcl_UnlinkVar, Tcl_UpdateLinkedVar \- link Tcl variable to C variable .SH SYNOPSIS .nf \fB#include \fR .sp int \fBTcl_LinkVar\fR(\fIinterp, varName, addr, type\fR) .sp -.VS "TIP 312" -int -\fBTcl_LinkArray\fR(\fIinterp, varName, addr, type, size\fR) -.VE "TIP 312" -.sp \fBTcl_UnlinkVar\fR(\fIinterp, varName\fR) .sp \fBTcl_UpdateLinkedVar\fR(\fIinterp, varName\fR) .SH ARGUMENTS -.AS Tcl_Interp varName in +.AS Tcl_Interp writable .AP Tcl_Interp *interp in Interpreter that contains \fIvarName\fR. Also used by \fBTcl_LinkVar\fR to return error messages. .AP "const char" *varName in Name of global variable. -.AP void *addr in +.AP char *addr in Address of C variable that is to be linked to \fIvarName\fR. -.sp -.VS "TIP 312" -In \fBTcl_LinkArray\fR, may be NULL to tell Tcl to create the storage -for the array in the variable. -.VE "TIP 312" .AP int type in -Type of C variable for \fBTcl_LinkVar\fR or type of array element for -\fBTcl_LinkArray\fR. Must be one of \fBTCL_LINK_INT\fR, +Type of C variable. Must be one of \fBTCL_LINK_INT\fR, +.VS 8.5 \fBTCL_LINK_UINT\fR, \fBTCL_LINK_CHAR\fR, \fBTCL_LINK_UCHAR\fR, \fBTCL_LINK_SHORT\fR, \fBTCL_LINK_USHORT\fR, \fBTCL_LINK_LONG\fR, -\fBTCL_LINK_ULONG\fR, \fBTCL_LINK_WIDE_INT\fR, -\fBTCL_LINK_WIDE_UINT\fR, \fBTCL_LINK_FLOAT\fR, \fBTCL_LINK_DOUBLE\fR, -\fBTCL_LINK_BOOLEAN\fR, or one of the extra ones listed below. -.sp -In \fBTcl_LinkVar\fR, the additional linked type \fBTCL_LINK_STRING\fR may be -used. -.sp -.VS "TIP 312" -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 size_t size in -.VS "TIP 312" -The number of elements in the C array. Must be greater than zero. -.VE "TIP 312" +\fBTCL_LINK_ULONG\fR, +.VE 8.5 +\fBTCL_LINK_WIDE_INT\fR, +.VS 8.5 +\fBTCL_LINK_WIDE_UINT\fR, \fBTCL_LINK_FLOAT\fR, +.VE 8.5 +\fBTCL_LINK_DOUBLE\fR, \fBTCL_LINK_BOOLEAN\fR, or +\fBTCL_LINK_STRING\fR, optionally OR'ed with \fBTCL_LINK_READ_ONLY\fR +to make Tcl variable read-only. .BE + .SH DESCRIPTION .PP \fBTcl_LinkVar\fR uses variable traces to keep the Tcl variable named by \fIvarName\fR in sync with the C variable at the address given by \fIaddr\fR. @@ -75,183 +56,116 @@ \fBTcl_LinkVar\fR normally returns \fBTCL_OK\fR; if an error occurs while setting up the link (e.g. because \fIvarName\fR is the name of array) then \fBTCL_ERROR\fR is returned and the interpreter's result contains an error message. .PP -.VS "TIP 312" -\fBTcl_LinkArray\fR is similar, but for arrays of fixed size (given by -the \fIsize\fR argument). When asked to allocate the backing C array -storage (via the \fIaddr\fR argument being NULL), it writes the -address that it allocated to the Tcl interpreter result. -.VE "TIP 312" -.PP The \fItype\fR argument specifies the type of the C variable, -or the type of the elements of the C array, and must have one of the following values, optionally OR'ed with \fBTCL_LINK_READ_ONLY\fR: .TP \fBTCL_LINK_INT\fR -. -The C variable, or each element of the C array, is of type \fBint\fR. +The C variable 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. +Tcl errors. +.VS 8.5 .TP \fBTCL_LINK_UINT\fR -. -The C variable, or each element of the C array, is of type \fBunsigned int\fR. +The C variable 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. +\fIvarName\fR will be rejected with Tcl errors. .TP \fBTCL_LINK_CHAR\fR -. -The C variable, or each element of the C array, is of type \fBchar\fR. +The C variable 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 -\fBTCL_LINK_CHARS\fR -.VS "TIP 312" -The C array is of type \fBchar *\fR and is mapped into Tcl as a string. -Any value written into the Tcl variable must have the same length as -the underlying storage. Only supported with \fBTcl_LinkArray\fR. -.VE "TIP 312" +values into \fIvarName\fR will be rejected with Tcl errors. .TP \fBTCL_LINK_UCHAR\fR -. -The C variable, or each element of the C array, is of type \fBunsigned char\fR. +The C variable 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 -.TP -\fBTCL_LINK_BYTES\fR -.VS "TIP 312" -The C array is of type \fBunsigned char *\fR and is mapped into Tcl -as a bytearray. -Any value written into the Tcl variable must have the same length as -the underlying storage. Only supported with \fBTcl_LinkArray\fR. -.VE "TIP 312" +\fIvarName\fR will be rejected with Tcl errors. .TP \fBTCL_LINK_SHORT\fR -. -The C variable, or each element of the C array, is of type \fBshort\fR. +The C variable 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. +values into \fIvarName\fR will be rejected with Tcl errors. .TP \fBTCL_LINK_USHORT\fR -. -The C variable, or each element of the C array, is of type \fBunsigned short\fR. +The C variable 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. +\fIvarName\fR will be rejected with Tcl errors. .TP \fBTCL_LINK_LONG\fR -. -The C variable, or each element of the C array, is of type \fBlong\fR. +The C variable 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. +values into \fIvarName\fR will be rejected with Tcl errors. .TP \fBTCL_LINK_ULONG\fR -. -The C variable, or each element of the C array, is of type \fBunsigned long\fR. +The C variable 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. +\fIvarName\fR will be rejected with Tcl errors. +.VE 8.5 .TP \fBTCL_LINK_DOUBLE\fR -. -The C variable, or each element of the C array, is of type \fBdouble\fR. +The C variable 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. +Tcl errors. +.VS 8.5 .TP \fBTCL_LINK_FLOAT\fR -. -The C variable, or each element of the C array, is of type \fBfloat\fR. +The C variable 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. +\fIvarName\fR will be rejected with Tcl errors. +.VE 8.5 .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 +The C variable 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. +Tcl errors. +.VS 8.5 .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.) +The C variable 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. +rejected with Tcl errors. +.VE 8.5 .TP \fBTCL_LINK_BOOLEAN\fR -. -The C variable, or each element of the C array, is of type \fBint\fR. +The C variable 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 @@ -260,21 +174,19 @@ 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. +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. .PP If the \fBTCL_LINK_READ_ONLY\fR flag is present in \fItype\fR then the variable will be read-only from Tcl, so that its value can only be changed by modifying the C variable. Attempts to write the variable from Tcl will be rejected with errors. @@ -290,18 +202,8 @@ However, if a trace has been set on the Tcl variable (such as a Tk widget that wishes to display the value of the variable), the trace will not trigger when the C variable has changed. \fBTcl_UpdateLinkedVar\fR ensures that any traces on the Tcl variable are invoked. -.PP -Note that, as with any call to a Tcl interpreter, \fBTcl_UpdateLinkedVar\fR -must be called from the same thread that created the interpreter. The safest -mechanism is to ensure that the C variable is only ever updated from the same -thread that created the interpreter (possibly in response to an event posted -with \fBTcl_ThreadQueueEvent\fR), but when it is necessary to update the -variable in a separate thread, it is advised that \fBTcl_AsyncMark\fR be used -to indicate to the thread hosting the interpreter that it is ready to run -\fBTcl_UpdateLinkedVar\fR. -.SH "SEE ALSO" -Tcl_TraceVar(3) + .SH KEYWORDS -boolean, integer, link, read-only, real, string, trace, variable +boolean, integer, link, read-only, real, string, traces, variable Index: doc/ListObj.3 ================================================================== --- doc/ListObj.3 +++ doc/ListObj.3 @@ -1,16 +1,16 @@ '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Tcl_ListObj 3 8.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_ListObjAppendList, Tcl_ListObjAppendElement, Tcl_NewListObj, Tcl_SetListObj, Tcl_ListObjGetElements, Tcl_ListObjLength, Tcl_ListObjIndex, Tcl_ListObjReplace \- manipulate Tcl values as lists +Tcl_ListObjAppendList, Tcl_ListObjAppendElement, Tcl_NewListObj, Tcl_SetListObj, Tcl_ListObjGetElements, Tcl_ListObjLength, Tcl_ListObjIndex, Tcl_ListObjReplace \- manipulate Tcl objects as lists .SH SYNOPSIS .nf \fB#include \fR .sp int @@ -36,58 +36,58 @@ int \fBTcl_ListObjReplace\fR(\fIinterp, listPtr, first, count, objc, objv\fR) .SH ARGUMENTS .AS "Tcl_Obj *const" *elemListPtr in/out .AP Tcl_Interp *interp in -If an error occurs while converting a value to be a list value, -an error message is left in the interpreter's result value +If an error occurs while converting an object to be a list object, +an error message is left in the interpreter's result object unless \fIinterp\fR is NULL. .AP Tcl_Obj *listPtr in/out -Points to the list value to be manipulated. -If \fIlistPtr\fR does not already point to a list value, +Points to the list object to be manipulated. +If \fIlistPtr\fR does not already point to a list object, an attempt will be made to convert it to one. .AP Tcl_Obj *elemListPtr in/out -For \fBTcl_ListObjAppendList\fR, this points to a list value +For \fBTcl_ListObjAppendList\fR, this points to a list object containing elements to be appended onto \fIlistPtr\fR. Each element of *\fIelemListPtr\fR will become a new element of \fIlistPtr\fR. If *\fIelemListPtr\fR is not NULL and -does not already point to a list value, +does not already point to a list object, an attempt will be made to convert it to one. .AP Tcl_Obj *objPtr in For \fBTcl_ListObjAppendElement\fR, -points to the Tcl value that will be appended to \fIlistPtr\fR. +points to the Tcl object that will be appended to \fIlistPtr\fR. For \fBTcl_SetListObj\fR, -this points to the Tcl value that will be converted to a list value +this points to the Tcl object that will be converted to a list object containing the \fIobjc\fR elements of the array referenced by \fIobjv\fR. .AP int *objcPtr in Points to location where \fBTcl_ListObjGetElements\fR -stores the number of element values in \fIlistPtr\fR. +stores the number of element objects in \fIlistPtr\fR. .AP Tcl_Obj ***objvPtr out A location where \fBTcl_ListObjGetElements\fR stores a pointer to an array -of pointers to the element values of \fIlistPtr\fR. +of pointers to the element objects of \fIlistPtr\fR. .AP int objc in -The number of Tcl values that \fBTcl_NewListObj\fR -will insert into a new list value, +The number of Tcl objects that \fBTcl_NewListObj\fR +will insert into a new list object, and \fBTcl_ListObjReplace\fR will insert into \fIlistPtr\fR. For \fBTcl_SetListObj\fR, -the number of Tcl values to insert into \fIobjPtr\fR. +the number of Tcl objects to insert into \fIobjPtr\fR. .AP "Tcl_Obj *const" objv[] in -An array of pointers to values. -\fBTcl_NewListObj\fR will insert these values into a new list value +An array of pointers to objects. +\fBTcl_NewListObj\fR will insert these objects into a new list object and \fBTcl_ListObjReplace\fR will insert them into an existing \fIlistPtr\fR. -Each value will become a separate list element. +Each object will become a separate list element. .AP int *intPtr out Points to location where \fBTcl_ListObjLength\fR stores the length of the list. .AP int index in Index of the list element that \fBTcl_ListObjIndex\fR is to return. The first element has index 0. .AP Tcl_Obj **objPtrPtr out Points to place where \fBTcl_ListObjIndex\fR is to store -a pointer to the resulting list element value. +a pointer to the resulting list element object. .AP int first in Index of the starting list element that \fBTcl_ListObjReplace\fR is to replace. The list's first element has index 0. .AP int count in @@ -95,111 +95,111 @@ is to replace. .BE .SH DESCRIPTION .PP -Tcl list values have an internal representation that supports +Tcl list objects have an internal representation that supports the efficient indexing and appending. The procedures described in this man page are used to -create, modify, index, and append to Tcl list values from C code. +create, modify, index, and append to Tcl list objects from C code. .PP \fBTcl_ListObjAppendList\fR and \fBTcl_ListObjAppendElement\fR -both add one or more values -to the end of the list value referenced by \fIlistPtr\fR. -\fBTcl_ListObjAppendList\fR appends each element of the list value +both add one or more objects +to the end of the list object referenced by \fIlistPtr\fR. +\fBTcl_ListObjAppendList\fR appends each element of the list object referenced by \fIelemListPtr\fR while -\fBTcl_ListObjAppendElement\fR appends the single value +\fBTcl_ListObjAppendElement\fR appends the single object referenced by \fIobjPtr\fR. -Both procedures will convert the value referenced by \fIlistPtr\fR -to a list value if necessary. +Both procedures will convert the object referenced by \fIlistPtr\fR +to a list object if necessary. If an error occurs during conversion, both procedures return \fBTCL_ERROR\fR and leave an error message -in the interpreter's result value if \fIinterp\fR is not NULL. -Similarly, if \fIelemListPtr\fR does not already refer to a list value, +in the interpreter's result object if \fIinterp\fR is not NULL. +Similarly, if \fIelemListPtr\fR does not already refer to a list object, \fBTcl_ListObjAppendList\fR will attempt to convert it to one and if an error occurs during conversion, will return \fBTCL_ERROR\fR -and leave an error message in the interpreter's result value +and leave an error message in the interpreter's result object if interp is not NULL. Both procedures invalidate any old string representation of \fIlistPtr\fR -and, if it was converted to a list value, +and, if it was converted to a list object, free any old internal representation. Similarly, \fBTcl_ListObjAppendList\fR frees any old internal representation -of \fIelemListPtr\fR if it converts it to a list value. +of \fIelemListPtr\fR if it converts it to a list object. After appending each element in \fIelemListPtr\fR, \fBTcl_ListObjAppendList\fR increments the element's reference count since \fIlistPtr\fR now also refers to it. For the same reason, \fBTcl_ListObjAppendElement\fR increments \fIobjPtr\fR's reference count. If no error occurs, -the two procedures return \fBTCL_OK\fR after appending the values. +the two procedures return \fBTCL_OK\fR after appending the objects. .PP \fBTcl_NewListObj\fR and \fBTcl_SetListObj\fR -create a new value or modify an existing value to hold +create a new object or modify an existing object to hold the \fIobjc\fR elements of the array referenced by \fIobjv\fR -where each element is a pointer to a Tcl value. +where each element is a pointer to a Tcl object. If \fIobjc\fR is less than or equal to zero, -they return an empty value. If \fIobjv\fR is NULL, the resulting list +they return an empty object. 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 new object'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 +of the elements in \fIobjc\fR since the list object now refers to them. +The new list object returned by \fBTcl_NewListObj\fR has reference count zero. .PP \fBTcl_ListObjGetElements\fR returns a count and a pointer to an array of -the elements in a list value. It returns the count by storing it in the +the elements in a list object. It returns the count by storing it in the address \fIobjcPtr\fR. Similarly, it returns the array pointer by storing it in the address \fIobjvPtr\fR. The memory pointed to is managed by Tcl and should not be freed or written to by the caller. If the list is empty, 0 is stored at \fIobjcPtr\fR and NULL at \fIobjvPtr\fR. -If \fIlistPtr\fR is not already a list value, \fBTcl_ListObjGetElements\fR +If \fIlistPtr\fR is not already a list object, \fBTcl_ListObjGetElements\fR will attempt to convert it to one; if the conversion fails, it returns \fBTCL_ERROR\fR and leaves an error message in the interpreter's result -value if \fIinterp\fR is not NULL. +object if \fIinterp\fR is not NULL. Otherwise it returns \fBTCL_OK\fR after storing the count and array pointer. .PP -\fBTcl_ListObjLength\fR returns the number of elements in the list value +\fBTcl_ListObjLength\fR returns the number of elements in the list object referenced by \fIlistPtr\fR. It returns this count by storing an integer in the address \fIintPtr\fR. -If the value is not already a list value, +If the object is not already a list object, \fBTcl_ListObjLength\fR will attempt to convert it to one; if the conversion fails, it returns \fBTCL_ERROR\fR -and leaves an error message in the interpreter's result value +and leaves an error message in the interpreter's result object if \fIinterp\fR is not NULL. Otherwise it returns \fBTCL_OK\fR after storing the list's length. .PP -The procedure \fBTcl_ListObjIndex\fR returns a pointer to the value +The procedure \fBTcl_ListObjIndex\fR returns a pointer to the object at element \fIindex\fR in the list referenced by \fIlistPtr\fR. -It returns this value by storing a pointer to it +It returns this object by storing a pointer to it in the address \fIobjPtrPtr\fR. -If \fIlistPtr\fR does not already refer to a list value, +If \fIlistPtr\fR does not already refer to a list object, \fBTcl_ListObjIndex\fR will attempt to convert it to one; if the conversion fails, it returns \fBTCL_ERROR\fR -and leaves an error message in the interpreter's result value +and leaves an error message in the interpreter's result object if \fIinterp\fR is not NULL. If the index is out of range, that is, \fIindex\fR is negative or greater than or equal to the number of elements in the list, \fBTcl_ListObjIndex\fR stores a NULL in \fIobjPtrPtr\fR and returns \fBTCL_OK\fR. Otherwise it returns \fBTCL_OK\fR after storing the element's -value pointer. +object pointer. The reference count for the list element is not incremented; the caller must do that if it needs to retain a pointer to the element. .PP \fBTcl_ListObjReplace\fR replaces zero or more elements of the list referenced by \fIlistPtr\fR -with the \fIobjc\fR values in the array referenced by \fIobjv\fR. -If \fIlistPtr\fR does not point to a list value, +with the \fIobjc\fR objects in the array referenced by \fIobjv\fR. +If \fIlistPtr\fR does not point to a list object, \fBTcl_ListObjReplace\fR will attempt to convert it to one; if the conversion fails, it returns \fBTCL_ERROR\fR -and leaves an error message in the interpreter's result value +and leaves an error message in the interpreter's result object if \fIinterp\fR is not NULL. -Otherwise, it returns \fBTCL_OK\fR after replacing the values. +Otherwise, it returns \fBTCL_OK\fR after replacing the objects. If \fIobjv\fR is NULL, no new elements are added. If the argument \fIfirst\fR is zero or negative, it refers to the first element. If \fIfirst\fR is greater than or equal to the number of elements in the list, then no elements are deleted; @@ -210,44 +210,43 @@ designated by \fIfirst\fR. \fBTcl_ListObjReplace\fR invalidates \fIlistPtr\fR's old string representation. The reference counts of any elements inserted from \fIobjv\fR are incremented since the resulting list now refers to them. -Similarly, the reference counts for any replaced values are decremented. +Similarly, the reference counts for any replaced objects are decremented. .PP Because \fBTcl_ListObjReplace\fR combines both element insertion and deletion, it can be used to implement a number of list operations. -For example, the following code inserts the \fIobjc\fR values -referenced by the array of value pointers \fIobjv\fR +For example, the following code inserts the \fIobjc\fR objects +referenced by the array of object pointers \fIobjv\fR just before the element \fIindex\fR of the list referenced by \fIlistPtr\fR: .PP .CS -result = \fBTcl_ListObjReplace\fR(interp, listPtr, index, 0, +result = Tcl_ListObjReplace(interp, listPtr, index, 0, objc, objv); .CE .PP -Similarly, the following code appends the \fIobjc\fR values +Similarly, the following code appends the \fIobjc\fR objects referenced by the array \fIobjv\fR to the end of the list \fIlistPtr\fR: .PP .CS -result = \fBTcl_ListObjLength\fR(interp, listPtr, &length); +result = Tcl_ListObjLength(interp, listPtr, &length); if (result == TCL_OK) { - result = \fBTcl_ListObjReplace\fR(interp, listPtr, length, 0, + result = Tcl_ListObjReplace(interp, listPtr, length, 0, objc, objv); } .CE .PP The \fIcount\fR list elements starting at \fIfirst\fR can be deleted by simply calling \fBTcl_ListObjReplace\fR with a NULL \fIobjvPtr\fR: .PP .CS -result = \fBTcl_ListObjReplace\fR(interp, listPtr, first, count, +result = Tcl_ListObjReplace(interp, listPtr, first, count, 0, NULL); .CE .SH "SEE ALSO" -Tcl_NewObj(3), Tcl_DecrRefCount(3), Tcl_IncrRefCount(3), Tcl_GetObjResult(3) +Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult .SH KEYWORDS -append, index, insert, internal representation, length, list, list value, -list type, value, value type, replace, string representation +append, index, insert, internal representation, length, list, list object, list type, object, object type, replace, string representation DELETED doc/Load.3 Index: doc/Load.3 ================================================================== --- doc/Load.3 +++ /dev/null @@ -1,70 +0,0 @@ -'\" -'\" Copyright (c) 2009-2010 Kevin B. Kenny -'\" Copyright (c) 2010 Donal K. Fellows -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH Load 3 8.6 Tcl "Tcl Library Procedures" -.so man.macros -.BS -.SH NAME -Tcl_LoadFile, Tcl_FindSymbol \- platform-independent dynamic library loading -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -int -\fBTcl_LoadFile\fR(\fIinterp, pathPtr, symbols, flags, procPtrs, loadHandlePtr\fR) -.sp -void * -\fBTcl_FindSymbol\fR(\fIinterp, loadHandle, symbol\fR) -.SH ARGUMENTS -.AS Tcl_LoadHandle loadHandle in -.AP Tcl_Interp *interp in -Interpreter to use for reporting error messages. -.AP Tcl_Obj *pathPtr in -The name of the file to load. If it is a single name, the library search path -of the current environment will be used to resolve it. -.AP "const char *const" symbols[] in -Array of names of symbols to be resolved during the load of the library, or -NULL if no symbols are to be resolved. If an array is given, the last entry in -the array must be NULL. -.AP int flags in -The value should normally be 0, but \fITCL_LOAD_GLOBAL\fR or \fITCL_LOAD_LAZY\fR -or a combination of those two is allowed as well. -.AP void *procPtrs out -Points to an array that will hold the addresses of the functions described in -the \fIsymbols\fR argument. Should be NULL if no symbols are to be resolved. -.AP Tcl_LoadHandle *loadHandlePtr out -Points to a variable that will hold the handle to the abstract token -describing the library that has been loaded. -.AP Tcl_LoadHandle loadHandle in -Abstract token describing the library to look up a symbol in. -.AP "const char" *symbol in -The name of the symbol to look up. -.BE -.SH DESCRIPTION -.PP -\fBTcl_LoadFile\fR loads a file from the filesystem (including potentially any -virtual filesystem that has been installed) and provides a handle to it that -may be used in further operations. The \fIsymbols\fR array, if non-NULL, -supplies a set of names of symbols (typically functions) that must be resolved -from the library and which will be stored in the array indicated by -\fIprocPtrs\fR. If any of the symbols is not resolved, the loading of the file -will fail with an error message left in the interpreter (if that is non-NULL). -The result of \fBTcl_LoadFile\fR is a standard Tcl error code. The library may -be unloaded with \fBTcl_FSUnloadFile\fR. -.PP -\fBTcl_FindSymbol\fR locates a symbol in a loaded library and returns it. If -the symbol cannot be found, it returns NULL and sets an error message in the -given \fIinterp\fR (if that is non-NULL). Note that it is unsafe to use this -operation on a handle that has been passed to \fBTcl_FSUnloadFile\fR. -.SH "SEE ALSO" -Tcl_FSLoadFile(3), Tcl_FSUnloadFile(3), load(n), unload(n) -.SH KEYWORDS -binary code, loading, shared library -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: DELETED doc/Method.3 Index: doc/Method.3 ================================================================== --- doc/Method.3 +++ /dev/null @@ -1,269 +0,0 @@ -'\" -'\" Copyright (c) 2007 Donal K. Fellows -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH Tcl_Method 3 0.1 TclOO "TclOO Library Functions" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -Tcl_ClassSetConstructor, Tcl_ClassSetDestructor, Tcl_MethodDeclarerClass, Tcl_MethodDeclarerObject, Tcl_MethodIsPublic, Tcl_MethodIsPrivate, Tcl_MethodIsType, Tcl_MethodName, Tcl_NewInstanceMethod, Tcl_NewMethod, Tcl_ObjectContextInvokeNext, Tcl_ObjectContextIsFiltering, Tcl_ObjectContextMethod, Tcl_ObjectContextObject, Tcl_ObjectContextSkippedArgs \- manipulate methods and method-call contexts -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -Tcl_Method -\fBTcl_NewMethod\fR(\fIinterp, class, nameObj, flags, methodTypePtr, - clientData\fR) -.sp -Tcl_Method -\fBTcl_NewInstanceMethod\fR(\fIinterp, object, nameObj, flags, methodTypePtr, - clientData\fR) -.sp -\fBTcl_ClassSetConstructor\fR(\fIinterp, class, method\fR) -.sp -\fBTcl_ClassSetDestructor\fR(\fIinterp, class, method\fR) -.sp -Tcl_Class -\fBTcl_MethodDeclarerClass\fR(\fImethod\fR) -.sp -Tcl_Object -\fBTcl_MethodDeclarerObject\fR(\fImethod\fR) -.sp -Tcl_Obj * -\fBTcl_MethodName\fR(\fImethod\fR) -.sp -.VS TIP500 -int -\fBTcl_MethodIsPublic\fR(\fImethod\fR) -.VE TIP500 -.sp -int -\fBTcl_MethodIsPrivate\fR(\fImethod\fR) -.sp -int -\fBTcl_MethodIsType\fR(\fImethod, methodTypePtr, clientDataPtr\fR) -.sp -int -\fBTcl_ObjectContextInvokeNext\fR(\fIinterp, context, objc, objv, skip\fR) -.sp -int -\fBTcl_ObjectContextIsFiltering\fR(\fIcontext\fR) -.sp -Tcl_Method -\fBTcl_ObjectContextMethod\fR(\fIcontext\fR) -.sp -Tcl_Object -\fBTcl_ObjectContextObject\fR(\fIcontext\fR) -.sp -int -\fBTcl_ObjectContextSkippedArgs\fR(\fIcontext\fR) -.SH ARGUMENTS -.AS void *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 -The name of the method to create. Should not be NULL unless creating -constructors or destructors. -.AP int flags in -A flag saying (currently) what the visibility of the method is. The supported -public values of this flag are \fBTCL_OO_METHOD_PUBLIC\fR (which is fixed at 1 -for backward compatibility) for an exported method, -\fBTCL_OO_METHOD_UNEXPORTED\fR (which is fixed at 0 for backward -compatibility) for a non-exported method, -.VS TIP500 -and \fBTCL_OO_METHOD_PRIVATE\fR for a private method. -.VE TIP500 -.AP Tcl_MethodType *methodTypePtr in -A description of the type of the method to create, or the type of method to -compare against. -.AP void *clientData in -A piece of data that is passed to the implementation of the method without -interpretation. -.AP void **clientDataPtr out -A pointer to a variable in which to write the \fIclientData\fR value supplied -when the method was created. If NULL, the \fIclientData\fR value will not be -retrieved. -.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 -retain a reference to a context. -.AP int objc in -The number of arguments to pass to the method implementation. -.AP "Tcl_Obj *const" *objv in -An array of arguments to pass to the method implementation. -.AP int skip in -The number of arguments passed to the method implementation that do not -represent "real" arguments. -.BE -.SH DESCRIPTION -.PP -A method is an operation carried out on an object that is associated with the -object. Every method must be attached to either an object or a class; methods -attached to a class are associated with all instances (direct and indirect) of -that class. -.PP -Given a method, the entity that declared it can be found using -\fBTcl_MethodDeclarerClass\fR which returns the class that the method is -attached to (or NULL if the method is not attached to any class) and -\fBTcl_MethodDeclarerObject\fR which returns the object that the method is -attached to (or NULL if the method is not attached to an object). The name of -the method can be retrieved with \fBTcl_MethodName\fR, whether the method -is exported is retrieved with \fBTcl_MethodIsPublic\fR, -.VS TIP500 -and whether the method is private is retrieved with \fBTcl_MethodIsPrivate\fR. -.VE TIP500 -The type of the method -can also be introspected upon to a limited degree; the function -\fBTcl_MethodIsType\fR returns whether a method is of a particular type, -assigning the per-method \fIclientData\fR to the variable pointed to by -\fIclientDataPtr\fR if (that is non-NULL) if the type is matched. -.SS "METHOD CREATION" -.PP -Methods are created by \fBTcl_NewMethod\fR and \fBTcl_NewInstanceMethod\fR, -which -create a method attached to a class or an object respectively. In both cases, -the \fInameObj\fR argument gives the name of the method to create, the -\fIflags\fR argument states whether the method should be exported -initially -.VS TIP500 -or be marked as a private method, -.VE TIP500 -the \fImethodTypePtr\fR argument describes the implementation of -the method (see the \fBMETHOD TYPES\fR section below) and the \fIclientData\fR -argument gives some implementation-specific data that is passed on to the -implementation of the method when it is called. -.PP -When the \fInameObj\fR argument to \fBTcl_NewMethod\fR is NULL, an -unnamed method is created, which is used for constructors and destructors. -Constructors should be installed into their class using the -\fBTcl_ClassSetConstructor\fR function, and destructors (which must not -require any arguments) should be installed into their class using the -\fBTcl_ClassSetDestructor\fR function. Unnamed methods should not be used for -any other purpose, and named methods should not be used as either constructors -or destructors. Also note that a NULL \fImethodTypePtr\fR is used to provide -internal signaling, and should not be used in client code. -.SS "METHOD CALL CONTEXTS" -.PP -When a method is called, a method-call context reference is passed in as one -of the arguments to the implementation function. This context can be inspected -to provide information about the caller, but should not be retained beyond the -moment when the method call terminates. -.PP -The method that is being called can be retrieved from the context by using -\fBTcl_ObjectContextMethod\fR, and the object that caused the method to be -invoked can be retrieved with \fBTcl_ObjectContextObject\fR. The number of -arguments that are to be skipped (e.g. the object name and method name in a -normal method call) is read with \fBTcl_ObjectContextSkippedArgs\fR, and the -context can also report whether it is working as a filter for another method -through \fBTcl_ObjectContextIsFiltering\fR. -.PP -During the execution of a method, the method implementation may choose to -invoke the stages of the method call chain that come after the current method -implementation. This (the core of the \fBnext\fR command) is done using -\fBTcl_ObjectContextInvokeNext\fR. Note that this function does not manipulate -the call-frame stack, unlike the \fBnext\fR command; if the method -implementation has pushed one or more extra frames on the stack as part of its -implementation, it is also responsible for temporarily popping those frames -from the stack while the \fBTcl_ObjectContextInvokeNext\fR function is -executing. Note also that the method-call context is \fInever\fR deleted -during the execution of this function. -.SH "METHOD TYPES" -.PP -The types of methods are described by a pointer to a Tcl_MethodType structure, -which is defined as: -.PP -.CS -typedef struct { - int \fIversion\fR; - const char *\fIname\fR; - Tcl_MethodCallProc *\fIcallProc\fR; - Tcl_MethodDeleteProc *\fIdeleteProc\fR; - Tcl_CloneProc *\fIcloneProc\fR; -} \fBTcl_MethodType\fR; -.CE -.PP -The \fIversion\fR field allows for future expansion of the structure, and -should always be declared equal to TCL_OO_METHOD_VERSION_CURRENT. The -\fIname\fR field provides a human-readable name for the type, and is the value -that is exposed via the \fBinfo class methodtype\fR and -\fBinfo object methodtype\fR Tcl commands. -.PP -The \fIcallProc\fR field gives a function that is called when the method is -invoked; it must never be NULL. -.PP -The \fIdeleteProc\fR field gives a function that is used to delete a -particular method, and is called when the method is replaced or removed; if -the field is NULL, it is assumed that the method's \fIclientData\fR needs no -special action to delete. -.PP -The \fIcloneProc\fR field is either a function that is used to copy a method's -\fIclientData\fR (as part of \fBTcl_CopyObjectInstance\fR) or NULL to indicate -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( - void *\fIclientData\fR, - Tcl_Interp *\fIinterp\fR, - Tcl_ObjectContext \fIobjectContext\fR, - int \fIobjc\fR, - Tcl_Obj *const *\fIobjv\fR); -.CE -.PP -The \fIclientData\fR argument to a Tcl_MethodCallProc is the value that was -given when the method was created, the \fIinterp\fR is a place in which to -execute scripts and access variables as well as being where to put the result -of the method, and the \fIobjc\fR and \fIobjv\fR fields give the parameter -objects to the method. The calling context of the method can be discovered -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( - void *\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, - void *\fIoldClientData\fR, - void **\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 -a variable in which to write the value for the method being copied to. -.SH "SEE ALSO" -Class(3), oo::class(n), oo::define(n), oo::object(n) -.SH KEYWORDS -constructor, method, object - -.\" Local variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: DELETED doc/NRE.3 Index: doc/NRE.3 ================================================================== --- doc/NRE.3 +++ /dev/null @@ -1,236 +0,0 @@ -.\" -.\" Copyright (c) 2008 by Kevin B. Kenny. -.\" Copyright (c) 2018 by Nathan Coulter. -.\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH NRE 3 8.6 Tcl "Tcl Library Procedures" -.so man.macros -.BS -.SH NAME -Tcl_NRCreateCommand, Tcl_NRCallObjProc, Tcl_NREvalObj, Tcl_NREvalObjv, Tcl_NRCmdSwap, Tcl_NRExprObj, Tcl_NRAddCallback \- Non-Recursive (stackless) evaluation of Tcl scripts. -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -Tcl_Command -\fBTcl_NRCreateCommand\fR(\fIinterp, cmdName, proc, nreProc, clientData, - deleteProc\fR) -.sp -int -\fBTcl_NRCallObjProc\fR(\fIinterp, nreProc, clientData, objc, objv\fR) -.sp -int -\fBTcl_NREvalObj\fR(\fIinterp, objPtr, flags\fR) -.sp -int -\fBTcl_NREvalObjv\fR(\fIinterp, objc, objv, flags\fR) -.sp -int -\fBTcl_NRCmdSwap\fR(\fIinterp, cmd, objc, objv, flags\fR) -.sp -int -\fBTcl_NRExprObj\fR(\fIinterp, objPtr, resultPtr\fR) -.sp -void -\fBTcl_NRAddCallback\fR(\fIinterp, postProcPtr, data0, data1, data2, data3\fR) -.fi -.SH ARGUMENTS -.AS Tcl_CmdDeleteProc *interp in -.AP Tcl_Interp *interp in -The relevant Interpreter. -.AP char *cmdName in -Name of the command to create. -.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 void *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. -.AP Tcl_Obj **objv in -Words in the command. -.AP Tcl_Obj *objPtr in -A script or expression to evaluate. -.AP int flags in -As described for \fITcl_EvalObjv\fR. -.PP -.AP Tcl_Command cmd in -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 void *data0 in -.AP void *data1 in -.AP void *data2 in -.AP void *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 -implemented by an initial function and any additional functions that the -routine pushes onto the stack as it progresses. The interpreter itself pushes -functions onto the stack to react to the end of a routine and to exercise other -forms of control such as switching between in-progress stacks and the -evaluation of other scripts at additional levels without adding frames to the C -stack. To execute a routine, the initial function for the routine is called -and then a small bit of code called a \fItrampoline\fR iteratively takes -functions off the stack and calls them, using the value of the last call as the -value of the routine. -.PP -\fBTcl_NRCallObjProc\fR calls \fInreProc\fR using a new trampoline. -.PP -\fBTcl_NRCreateCommand\fR, an alternative to \fBTcl_CreateObjCommand\fR, -resolves \fIcmdName\fR, which may contain namespace qualifiers, relative to the -current namespace, creates a command by that name, and returns a token for the -command which may be used in subsequent calls to \fBTcl_GetCommandName\fR. -Except for a few cases noted below any existing command by the same name is -first deleted. If \fIinterp\fR is in the process of being deleted -\fBTcl_NRCreateCommand\fR does not create any command, does not delete any -command, and returns NULL. -.PP -\fBTcl_NREvalObj\fR pushes a function that is like \fBTcl_EvalObjEx\fR but -consumes no space on the C stack. -.PP -\fBTcl_NREvalObjv\fR pushes a function that is like \fBTcl_EvalObjv\fR but -consumes no space on the C stack. -.PP -\fBTcl_NRCmdSwap\fR is like \fBTcl_NREvalObjv\fR, but uses \fIcmd\fR, a token -previously returned by \fBTcl_CreateObjCommand\fR or -\fBTcl_GetCommandFromObj\fR, instead of resolving the first word of \fIobjv\fR. -. The name of this command must be the same as \fIobjv[0]\fR. -.PP -\fBTcl_NRExprObj\fR pushes a function that evaluates \fIobjPtr\fR as an -expression in the same manner as \fBTcl_ExprObj\fR but without consuming space -on the C stack. -.PP -All of the functions return \fBTCL_OK\fR if the evaluation of the script, -command, or expression has been scheduled successfully. Otherwise (for example -if the command name cannot be resolved), they return \fBTCL_ERROR\fR and store -a message as the interpreter's result. -.PP -\fBTcl_NRAddCallback\fR pushes \fIpostProcPtr\fR. The signature for -\fBTcl_NRPostProc\fR is: -.PP -.CS -typedef int -\fBTcl_NRPostProc\fR( - \fBvoid *\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( - void *clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - int result; - Tcl_Obj *objPtr; - - \fI... preparation ...\fR - - result = \fBTcl_EvalObjEx\fR(interp, objPtr, 0); - - \fI... postprocessing ...\fR - - return result; -} -\fBTcl_CreateObjCommand\fR(interp, "theCommand", - \fITheCmdOldObjProc\fR, clientData, TheCmdDeleteProc); -.CE -.PP -To avoid consuming space on the C stack, \fITheCmdOldObjProc\fR is renamed to -\fITheCmdNRObjProc\fR and the postprocessing step is split into a separate -function, \fITheCmdPostProc\fR, which is pushed onto the function stack. -\fITcl_EvalObjEx\fR is replaced with \fITcl_NREvalObj\fR, which uses a -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( - void *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 - void *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( - void *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 - - return result; -} -.CE -.PP -Any function comprising a routine can push other functions, making it possible -implement looping and sequencing constructs using the function stack. -.PP -.SH "SEE ALSO" -Tcl_CreateCommand(3), Tcl_CreateObjCommand(3), Tcl_EvalObjEx(3), Tcl_GetCommandFromObj(3), Tcl_ExprObj(3) -.SH KEYWORDS -stackless, nonrecursive, execute, command, global, value, result, script -.SH COPYRIGHT -Copyright (c) 2008 by Kevin B. Kenny. -Copyright (c) 2018 by Nathan Coulter. Index: doc/Namespace.3 ================================================================== --- doc/Namespace.3 +++ doc/Namespace.3 @@ -1,14 +1,14 @@ '\" '\" Copyright (c) 2003 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" '\" Note that some of these functions do not seem to belong, but they '\" were all introduced with the same TIP (#139) -'\" +'\" .TH Tcl_Namespace 3 8.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_AppendExportList, Tcl_CreateNamespace, Tcl_DeleteNamespace, Tcl_Export, Tcl_FindCommand, Tcl_FindNamespace, Tcl_ForgetImport, Tcl_GetCurrentNamespace, Tcl_GetGlobalNamespace, Tcl_GetNamespaceUnknownHandler, Tcl_Import, Tcl_SetNamespaceUnknownHandler \- manipulate namespaces @@ -55,21 +55,21 @@ .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 void *clientData in +.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 \fBTcl_DeleteNamespace\fR) to manipulate the current namespace. .AP Tcl_Obj *objPtr out -A reference to an unshared value to which the function output will be +A reference to an unshared object to which the function output will be written. .AP "const char" *pattern in The glob-style pattern (see \fBTcl_StringMatch\fR) that describes the commands to be imported or exported. .AP int resetListFirst in @@ -93,10 +93,11 @@ message should be left in the interpreter if the search fails.) .AP Tcl_Obj *handlerPtr in A script fragment to be installed as the unknown command handler for the namespace, or NULL to reset the handler to its default. .BE + .SH DESCRIPTION .PP Namespaces are hierarchic naming contexts that can contain commands and variables. They also maintain a list of patterns that describes what commands are exported, and can import commands that have been @@ -112,18 +113,15 @@ \fIparentPtr\fR (a pointer to the containing namespace, or NULL for 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( - void *\fIclientData\fR); +typedef void (Tcl_NamespaceDeleteProc) (ClientData clientData); .CE .PP -\fBTcl_DeleteNamespace\fR deletes a namespace, calling the -\fIdeleteProc\fR defined for the namespace (if any). +\fBTcl_DeleteNamespace\fR deletes a namespace. .PP \fBTcl_AppendExportList\fR retrieves the export patterns for a namespace given namespace and appends them (as list items) to \fIobjPtr\fR. .PP @@ -157,9 +155,11 @@ for the namespace, or NULL if none is set. .PP \fBTcl_SetNamespaceUnknownHandler\fR sets the unknown command handler for the namespace. If \fIhandlerPtr\fR is NULL, then the handler is reset to its default. + .SH "SEE ALSO" -Tcl_CreateCommand(3), Tcl_ListObjAppendList(3), Tcl_SetVar(3) +Tcl_CreateCommand, Tcl_ListObjAppendElements, Tcl_SetVar + .SH KEYWORDS namespace, command Index: doc/Notifier.3 ================================================================== --- doc/Notifier.3 +++ doc/Notifier.3 @@ -2,16 +2,16 @@ '\" Copyright (c) 1998-1999 Scriptics Corporation '\" Copyright (c) 1995-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Notifier 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_CreateEventSource, Tcl_DeleteEventSource, Tcl_SetMaxBlockTime, Tcl_QueueEvent, Tcl_ThreadQueueEvent, Tcl_ThreadAlert, Tcl_GetCurrentThread, Tcl_DeleteEvents, Tcl_InitNotifier, Tcl_FinalizeNotifier, Tcl_WaitForEvent, Tcl_AlertNotifier, Tcl_SetTimer, Tcl_ServiceAll, Tcl_ServiceEvent, Tcl_GetServiceMode, Tcl_SetServiceMode, Tcl_ServiceModeHook, Tcl_SetNotifier \- the event queue and notifier interfaces +Tcl_CreateEventSource, Tcl_DeleteEventSource, Tcl_SetMaxBlockTime, Tcl_QueueEvent, Tcl_ThreadQueueEvent, Tcl_ThreadAlert, Tcl_GetCurrentThread, Tcl_DeleteEvents, Tcl_InitNotifier, Tcl_FinalizeNotifier, Tcl_WaitForEvent, Tcl_AlertNotifier, Tcl_SetTimer, Tcl_ServiceAll, Tcl_ServiceEvent, Tcl_GetServiceMode, Tcl_SetServiceMode \- the event queue and notifier interfaces .SH SYNOPSIS .nf \fB#include \fR .sp void @@ -36,11 +36,11 @@ \fBTcl_GetCurrentThread\fR() .sp void \fBTcl_DeleteEvents\fR(\fIdeleteProc, clientData\fR) .sp -void * +ClientData \fBTcl_InitNotifier\fR() .sp void \fBTcl_FinalizeNotifier\fR(\fIclientData\fR) .sp @@ -76,22 +76,22 @@ 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 void *clientData in +.AP ClientData clientData in Arbitrary one-word value to pass to \fIsetupProc\fR, \fIcheckProc\fR, or \fIdeleteProc\fR. -.AP "const Tcl_Time" *timePtr in +.AP 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. +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. @@ -106,10 +106,11 @@ .AP Tcl_NotifierProcs* notifierProcPtr in Structure of function pointers describing notifier procedures that are to replace the ones installed in the executable. See \fBREPLACING THE NOTIFIER\fR for details. .BE + .SH INTRODUCTION .PP The interfaces described here are used to customize the Tcl event loop. The two most common customizations are to add new sources of events and to merge Tcl's event loop with some other event loop, such @@ -130,21 +131,26 @@ 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. +The event queue: for non-threaded applications, +there is a single queue for the whole application, +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. Threaded applications work in a +similar manner, except that there is a separate event queue for +each thread containing a Tcl interpreter. \fBTcl_QueueEvent\fR is used (primarily -by event sources) to add events to the current thread's event queue and +by event sources) to add events to the event queue and \fBTcl_DeleteEvents\fR is used to remove events from the queue without -processing them. +processing them. In a threaded application, \fBTcl_QueueEvent\fR adds +an event to the current thread's queue, and \fBTcl_ThreadQueueEvent\fR +adds an event to a queue in a specific thread. .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 @@ -207,10 +213,11 @@ See if there are idle callbacks pending. If so, invoke all of them and return. .IP [7] Either return 0 to indicate that no events were ready, or go back to step [2] if blocking was requested by the caller. + .SH "CREATING A NEW EVENT SOURCE" .PP An event source consists of three procedures invoked by the notifier, plus additional C procedures that are invoked by higher-level code to arrange for event-driven callbacks. The three procedures called @@ -220,17 +227,15 @@ .PP 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( - void *\fIclientData\fR, +typedef void Tcl_EventSetupProc( + 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 argument passed to \fBTcl_DoOneEvent\fR except that it will never @@ -261,18 +266,16 @@ \fBTcl_WaitForEvent\fR does not block if there is no new data on the X connection. The \fItimePtr\fR argument to \fBTcl_WaitForEvent\fR points to a structure that describes a time interval in seconds and microseconds: -.PP .CS typedef struct Tcl_Time { - long \fIsec\fR; - long \fIusec\fR; -} \fBTcl_Time\fR; + long \fIsec\fR; + long \fIusec\fR; +} Tcl_Time; .CE -.PP The \fIusec\fR field should be less than 1000000. .PP Information provided to \fBTcl_SetMaxBlockTime\fR is only used for the next call to \fBTcl_WaitForEvent\fR; it is discarded after \fBTcl_WaitForEvent\fR returns. @@ -298,17 +301,15 @@ .PP 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( - void *\fIclientData\fR, +typedef void Tcl_EventCheckProc( + 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 in turn, so they all have a chance to queue any events that are ready. @@ -323,18 +324,16 @@ define its own event structure with whatever information is relevant to that event source. However, the first element of the structure must be a structure of type \fBTcl_Event\fR, and the address of this structure is used when communicating between the event source and the rest of the notifier. A \fBTcl_Event\fR has the following definition: -.PP .CS typedef struct { Tcl_EventProc *\fIproc\fR; struct Tcl_Event *\fInextPtr\fR; -} \fBTcl_Event\fR; +} Tcl_Event; .CE -.PP The event source must fill in the \fIproc\fR field of the event before calling \fBTcl_QueueEvent\fR. The \fInextPtr\fR is used to link together the events in the queue and should not be modified by the event source. .PP @@ -358,17 +357,15 @@ .PP When it is time to handle an event from the queue (steps 1 and 4 above) \fBTcl_ServiceEvent\fR will invoke the \fIproc\fR specified in the first queued \fBTcl_Event\fR structure. \fIProc\fR must match the following prototype: -.PP .CS -typedef int \fBTcl_EventProc\fR( +typedef int Tcl_EventProc( Tcl_Event *\fIevPtr\fR, int \fIflags\fR); .CE -.PP The first argument to \fIproc\fR is a pointer to the event, which will be the same as the first argument to the \fBTcl_QueueEvent\fR call that added the event to the queue. The second argument to \fIproc\fR is the \fIflags\fR argument for the current call to \fBTcl_ServiceEvent\fR; this is used by the event source @@ -392,19 +389,23 @@ 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) +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. +Threaded applications work in a +similar manner, except that there is a separate event queue for +each thread containing a Tcl interpreter. +Calling \fBTcl_QueueEvent\fR in a multithreaded application 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 +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" @@ -413,26 +414,25 @@ \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( +typedef int Tcl_EventDeleteProc( Tcl_Event *\fIevPtr\fR, - void *\fIclientData\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 \fBTcl_DeleteEventSource\fR deletes an event source. The \fIsetupProc\fR, \fIcheckProc\fR, and \fIclientData\fR arguments must exactly match those provided to the \fBTcl_CreateEventSource\fR for the event source to be deleted. If no such source exists, \fBTcl_DeleteEventSource\fR has no effect. + .SH "CREATING A NEW NOTIFIER" .PP The notifier consists of all the procedures described in this manual entry, plus \fBTcl_DoOneEvent\fR and \fBTcl_Sleep\fR, which are available on all platforms, and \fBTcl_CreateFileHandler\fR and @@ -487,11 +487,12 @@ 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 +\fBTcl_AlertNotifier\fR is used in multithreaded applications 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 @@ -523,10 +524,11 @@ in their respective manual pages. .PP The easiest way to create a new notifier is to look at the code for an existing notifier, such as the files \fBunix/tclUnixNotfy.c\fR or \fBwin/tclWinNotify.c\fR in the Tcl source distribution. + .SH "REPLACING THE NOTIFIER" .PP A notifier that has been written according to the conventions above can also be installed in a running process in place of the standard notifier. This mechanism is used so that a single executable can be @@ -535,31 +537,30 @@ to another program, such as a Web browser plugin. .PP To do this, the extension makes a call to \fBTcl_SetNotifier\fR passing a pointer to a \fBTcl_NotifierProcs\fR data structure. The structure has the following layout: -.PP .CS typedef struct Tcl_NotifierProcs { - Tcl_SetTimerProc *\fIsetTimerProc\fR; - Tcl_WaitForEventProc *\fIwaitForEventProc\fR; - Tcl_CreateFileHandlerProc *\fIcreateFileHandlerProc\fR; - Tcl_DeleteFileHandlerProc *\fIdeleteFileHandlerProc\fR; - Tcl_InitNotifierProc *\fIinitNotifierProc\fR; - Tcl_FinalizeNotifierProc *\fIfinalizeNotifierProc\fR; - Tcl_AlertNotifierProc *\fIalertNotifierProc\fR; - Tcl_ServiceModeHookProc *\fIserviceModeHookProc\fR; -} \fBTcl_NotifierProcs\fR; + Tcl_SetTimerProc *setTimerProc; + Tcl_WaitForEventProc *waitForEventProc; + Tcl_CreateFileHandlerProc *createFileHandlerProc; + Tcl_DeleteFileHandlerProc *deleteFileHandlerProc; + Tcl_InitNotifierProc *initNotifierProc; + Tcl_FinalizeNotifierProc *finalizeNotifierProc; + Tcl_AlertNotifierProc *alertNotifierProc; + Tcl_ServiceModeHookProc *serviceModeHookProc; +} Tcl_NotifierProcs; .CE -.PP Following the call to \fBTcl_SetNotifier\fR, the pointers given in the \fBTcl_NotifierProcs\fR structure replace whatever notifier had been installed in the process. .PP It is extraordinarily unwise to replace a running notifier. Normally, \fBTcl_SetNotifier\fR should be called at process initialization time before the first call to \fBTcl_InitNotifier\fR. + .SH "EXTERNAL EVENT LOOPS" .PP The notifier interfaces are designed so that Tcl can be embedded into applications that have their own private event loops. In this case, the application does not call \fBTcl_DoOneEvent\fR except in the case @@ -616,10 +617,11 @@ then calls to \fBTcl_ServiceAll\fR will behave normally. \fBTcl_SetServiceMode\fR returns the previous value of the service mode, which should be restored when the recursive loop exits. \fBTcl_GetServiceMode\fR returns the current value of the service mode. + .SH "SEE ALSO" -Tcl_CreateFileHandler(3), Tcl_DeleteFileHandler(3), Tcl_Sleep(3), -Tcl_DoOneEvent(3), Thread(3) +\fBTcl_CreateFileHandler\fR, \fBTcl_DeleteFileHandler\fR, \fBTcl_Sleep\fR, +\fBTcl_DoOneEvent\fR, \fBThread(3)\fR .SH KEYWORDS event, notifier, event queue, event sources, file events, timer, idle, service mode, threads DELETED doc/OOInitStubs.3 Index: doc/OOInitStubs.3 ================================================================== --- doc/OOInitStubs.3 +++ /dev/null @@ -1,54 +0,0 @@ -'\" -'\" Copyright (c) 2012 Donal K. Fellows -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH Tcl_OOInitStubs 3 1.0 TclOO "TclOO Library Functions" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -Tcl_OOInitStubs \- initialize library access to TclOO functionality -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -const char * -\fBTcl_OOInitStubs\fR(\fIinterp\fR) -.fi -.SH ARGUMENTS -.AS Tcl_Interp *interp in -.AP Tcl_Interp *interp in -The Tcl interpreter that the TclOO API is integrated with and whose C -interface is going to be used. -.BE -.SH DESCRIPTION -.PP -When an extension library is going to use the C interface exposed by TclOO, it -should use \fBTcl_OOInitStubs\fR to initialize its access to that interface -from within its \fI*\fB_Init\fR (or \fI*\fB_SafeInit\fR) function, passing in -the \fIinterp\fR that was passed into that routine as context. If the result -of calling \fBTcl_OOInitStubs\fR is NULL, the initialization failed and an -error message will have been left in the interpreter's result. Otherwise, the -initialization succeeded and the TclOO API may thereafter be used; the -version of the TclOO API is returned. -.PP -When using this function, either the C #define symbol \fBUSE_TCLOO_STUBS\fR -should be defined and your library code linked against the Tcl stub library, -or that #define symbol should \fInot\fR be defined and your library code -linked against the Tcl main library directly. -.SH "BACKWARD COMPATIBILITY NOTE" -.PP -If you are linking against the Tcl 8.5 forward compatibility package for -TclOO, \fIonly\fR the stub-enabled configuration is supported and you should -also link against the TclOO independent stub library; that library is an -integrated part of the main Tcl stub library in Tcl 8.6. -.SH KEYWORDS -stubs -.SH "SEE ALSO" -Tcl_InitStubs(3) -.\" Local variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: Index: doc/Object.3 ================================================================== --- doc/Object.3 +++ doc/Object.3 @@ -6,11 +6,11 @@ '\" .TH Tcl_Obj 3 8.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_NewObj, Tcl_DuplicateObj, Tcl_IncrRefCount, Tcl_DecrRefCount, Tcl_IsShared, Tcl_InvalidateStringRep \- manipulate Tcl values +Tcl_NewObj, Tcl_DuplicateObj, Tcl_IncrRefCount, Tcl_DecrRefCount, Tcl_IsShared, Tcl_InvalidateStringRep \- manipulate Tcl objects .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_Obj * @@ -28,40 +28,40 @@ .sp \fBTcl_InvalidateStringRep\fR(\fIobjPtr\fR) .SH ARGUMENTS .AS Tcl_Obj *objPtr .AP Tcl_Obj *objPtr in -Points to a value; +Points to an object; must have been the result of a previous call to \fBTcl_NewObj\fR. .BE + .SH INTRODUCTION .PP -This man page presents an overview of Tcl values (called \fBTcl_Obj\fRs for -historical reasons) and how they are used. -It also describes generic procedures for managing Tcl values. -These procedures are used to create and copy values, -and increment and decrement the count of references (pointers) to values. +This man page presents an overview of Tcl objects and how they are used. +It also describes generic procedures for managing Tcl objects. +These procedures are used to create and copy objects, +and increment and decrement the count of references (pointers) to objects. The procedures are used in conjunction with ones -that operate on specific types of values such as +that operate on specific types of objects such as \fBTcl_GetIntFromObj\fR and \fBTcl_ListObjAppendElement\fR. The individual procedures are described along with the data structures they manipulate. .PP -Tcl's \fIdual-ported\fR values provide a general-purpose mechanism +Tcl's \fIdual-ported\fR objects provide a general-purpose mechanism for storing and exchanging Tcl values. They largely replace the use of strings in Tcl. For example, they are used to store variable values, command arguments, command results, and scripts. -Tcl values behave like strings but also hold an internal representation +Tcl objects behave like strings but also hold an internal representation that can be manipulated more efficiently. -For example, a Tcl list is now represented as a value +For example, a Tcl list is now represented as an object that holds the list's string representation -as well as an array of pointers to the values for each list element. -Dual-ported values avoid most runtime type conversions. +as well as an array of pointers to the objects for each list element. +Dual-ported objects avoid most runtime type conversions. They also improve the speed of many operations since an appropriate representation is immediately available. -The compiler itself uses Tcl values to +The compiler itself uses Tcl objects to cache the instruction bytecodes resulting from compiling scripts. .PP The two representations are a cache of each other and are computed lazily. That is, each representation is only computed when necessary, it is computed from the other representation, @@ -72,128 +72,126 @@ representation without having to constantly convert between integers and strings. Only when it needs a string representing the variable's value, say to print it, will the program regenerate the string representation from the integer. -Although values contain an internal representation, +Although objects contain an internal representation, their semantics are defined in terms of strings: an up-to-date string can always be obtained, -and any change to the value will be reflected in that string -when the value's string representation is fetched. +and any change to the object will be reflected in that string +when the object's string representation is fetched. Because of this representation invalidation and regeneration, it is dangerous for extension writers to access \fBTcl_Obj\fR fields directly. It is better to access Tcl_Obj information using procedures like \fBTcl_GetStringFromObj\fR and \fBTcl_GetString\fR. .PP -Values are allocated on the heap +Objects are allocated on the heap and are referenced using a pointer to their \fBTcl_Obj\fR structure. -Values are shared as much as possible. +Objects are shared as much as possible. This significantly reduces storage requirements -because some values such as long lists are very large. +because some objects such as long lists are very large. Also, most Tcl values are only read and never modified. This is especially true for procedure arguments, which can be shared between the caller and the called procedure. Assignment and argument binding is done by simply assigning a pointer to the value. Reference counting is used to determine when it is safe to -reclaim a value's storage. +reclaim an object's storage. .PP -Tcl values are typed. -A value's internal representation is controlled by its type. +Tcl objects are typed. +An object's internal representation is controlled by its type. Several types are predefined in the Tcl core including integer, double, list, and bytecode. Extension writers can extend the set of types by defining their own \fBTcl_ObjType\fR structs. .SH "THE TCL_OBJ STRUCTURE" .PP -Each Tcl value is represented by a \fBTcl_Obj\fR structure +Each Tcl object is represented by a \fBTcl_Obj\fR structure which is defined as follows. -.PP .CS typedef struct Tcl_Obj { - size_t \fIrefCount\fR; - char *\fIbytes\fR; - size_t \fIlength\fR; - const Tcl_ObjType *\fItypePtr\fR; - union { - long \fIlongValue\fR; - double \fIdoubleValue\fR; - void *\fIotherValuePtr\fR; - Tcl_WideInt \fIwideValue\fR; - struct { - void *\fIptr1\fR; - void *\fIptr2\fR; - } \fItwoPtrValue\fR; - struct { - void *\fIptr\fR; - unsigned long \fIvalue\fR; - } \fIptrAndLongRep\fR; - } \fIinternalRep\fR; -} \fBTcl_Obj\fR; + int \fIrefCount\fR; + char *\fIbytes\fR; + int \fIlength\fR; + Tcl_ObjType *\fItypePtr\fR; + union { + long \fIlongValue\fR; + double \fIdoubleValue\fR; + void *\fIotherValuePtr\fR; + Tcl_WideInt \fIwideValue\fR; + struct { + void *\fIptr1\fR; + void *\fIptr2\fR; + } \fItwoPtrValue\fR; + struct { + void *\fIptr\fR; + unsigned long \fIvalue\fR; + } \fIptrAndLongRep\fR; + } \fIinternalRep\fR; +} Tcl_Obj; .CE -.PP The \fIbytes\fR and the \fIlength\fR members together hold -a value's UTF-8 string representation, +an object's UTF-8 string representation, which is a \fIcounted string\fR not containing null bytes (UTF-8 null characters should be encoded as a two byte sequence: 192, 128.) \fIbytes\fR points to the first byte of the string representation. The \fIlength\fR member gives the number of bytes. The byte array must always have a null byte after the last data byte, at offset \fIlength\fR; this allows string representations to be treated as conventional null-terminated C strings. C programs use \fBTcl_GetStringFromObj\fR and \fBTcl_GetString\fR to get -a value's string representation. +an object's string representation. If \fIbytes\fR is NULL, the string representation is invalid. .PP -A value's type manages its internal representation. +An object's type manages its internal representation. The member \fItypePtr\fR points to the Tcl_ObjType structure that describes the type. If \fItypePtr\fR is NULL, the internal representation is invalid. .PP The \fIinternalRep\fR union member holds -a value's internal representation. +an object's internal representation. This is either a (long) integer, a double-precision floating-point number, a pointer to a value containing additional information -needed by the value's type to represent the value, a Tcl_WideInt +needed by the object's type to represent the object, a Tcl_WideInt integer, two arbitrary pointers, or a pair made up of an unsigned long integer and a pointer. .PP The \fIrefCount\fR member is used to tell when it is safe to free -a value's storage. -It holds the count of active references to the value. +an object's storage. +It holds the count of active references to the object. Maintaining the correct reference count is a key responsibility of extension writers. Reference counting is discussed below -in the section \fBSTORAGE MANAGEMENT OF VALUES\fR. +in the section \fBSTORAGE MANAGEMENT OF OBJECTS\fR. .PP Although extension writers can directly access the members of a Tcl_Obj structure, it is much better to use the appropriate procedures and macros. For example, extension writers should never read or update \fIrefCount\fR directly; they should use macros such as \fBTcl_IncrRefCount\fR and \fBTcl_IsShared\fR instead. .PP -A key property of Tcl values is that they hold two representations. -A value typically starts out containing only a string representation: +A key property of Tcl objects is that they hold two representations. +An object typically starts out containing only a string representation: it is untyped and has a NULL \fItypePtr\fR. -A value containing an empty string or a copy of a specified string +An object containing an empty string or a copy of a specified string is created using \fBTcl_NewObj\fR or \fBTcl_NewStringObj\fR respectively. -A value's string value is gotten with +An object's string value is gotten with \fBTcl_GetStringFromObj\fR or \fBTcl_GetString\fR and changed with \fBTcl_SetStringObj\fR. -If the value is later passed to a procedure like \fBTcl_GetIntFromObj\fR +If the object is later passed to a procedure like \fBTcl_GetIntFromObj\fR that requires a specific internal representation, -the procedure will create one and set the value's \fItypePtr\fR. +the procedure will create one and set the object's \fItypePtr\fR. The internal representation is computed from the string representation. -A value's two representations are duals of each other: +An object's two representations are duals of each other: changes made to one are reflected in the other. -For example, \fBTcl_ListObjReplace\fR will modify a value's +For example, \fBTcl_ListObjReplace\fR will modify an object's internal representation and the next call to \fBTcl_GetStringFromObj\fR or \fBTcl_GetString\fR will reflect that change. .PP Representations are recomputed lazily for efficiency. A change to one representation made by a procedure @@ -202,151 +200,142 @@ Instead, the other representation is marked invalid so that it is only regenerated if it is needed later. Most C programmers never have to be concerned with how this is done and simply use procedures such as \fBTcl_GetBooleanFromObj\fR or \fBTcl_ListObjIndex\fR. -Programmers that implement their own value types +Programmers that implement their own object types must check for invalid representations and mark representations invalid when necessary. The procedure \fBTcl_InvalidateStringRep\fR is used -to mark a value's string representation invalid and to +to mark an object's string representation invalid and to free any storage associated with the old string representation. .PP -Values usually remain one type over their life, -but occasionally a value must be converted from one type to another. -For example, a C program might build up a string in a value +Objects usually remain one type over their life, +but occasionally an object must be converted from one type to another. +For example, a C program might build up a string in an object with repeated calls to \fBTcl_AppendToObj\fR, and then call \fBTcl_ListObjIndex\fR to extract a list element from -the value. -The same value holding the same string value +the object. +The same object holding the same string value can have several different internal representations at different times. -Extension writers can also force a value to be converted from one type +Extension writers can also force an object to be converted from one type to another using the \fBTcl_ConvertToType\fR procedure. -Only programmers that create new value types need to be concerned +Only programmers that create new object types need to be concerned about how this is done. -A procedure defined as part of the value type's implementation -creates a new internal representation for a value +A procedure defined as part of the object type's implementation +creates a new internal representation for an object and changes its \fItypePtr\fR. See the man page for \fBTcl_RegisterObjType\fR -to see how to create a new value type. -.SH "EXAMPLE OF THE LIFETIME OF A VALUE" +to see how to create a new object type. +.SH "EXAMPLE OF THE LIFETIME OF AN OBJECT" .PP -As an example of the lifetime of a value, +As an example of the lifetime of an object, consider the following sequence of commands: -.PP .CS \fBset x 123\fR .CE -.PP -This assigns to \fIx\fR an untyped value whose +This assigns to \fIx\fR an untyped object whose \fIbytes\fR member points to \fB123\fR and \fIlength\fR member contains 3. -The value's \fItypePtr\fR member is NULL. -.PP +The object's \fItypePtr\fR member is NULL. .CS \fBputs "x is $x"\fR .CE -.PP \fIx\fR's string representation is valid (since \fIbytes\fR is non-NULL) and is fetched for the command. -.PP .CS \fBincr x\fR .CE -.PP -The \fBincr\fR command first gets an integer from \fIx\fR's value +The \fBincr\fR command first gets an integer from \fIx\fR's object by calling \fBTcl_GetIntFromObj\fR. -This procedure checks whether the value is already an integer value. -Since it is not, it converts the value -by setting the value's internal representation +This procedure checks whether the object is already an integer object. +Since it is not, it converts the object +by setting the object's internal representation to the integer \fB123\fR -and setting the value's \fItypePtr\fR +and setting the object's \fItypePtr\fR to point to the integer Tcl_ObjType structure. Both representations are now valid. -\fBincr\fR increments the value's integer internal representation +\fBincr\fR increments the object's integer internal representation then invalidates its string representation (by calling \fBTcl_InvalidateStringRep\fR) since the string representation no longer corresponds to the internal representation. -.PP .CS \fBputs "x is now $x"\fR .CE -.PP -The string representation of \fIx\fR's value is needed +The string representation of \fIx\fR's object is needed and is recomputed. The string representation is now \fB124\fR and both representations are again valid. -.SH "STORAGE MANAGEMENT OF VALUES" +.SH "STORAGE MANAGEMENT OF OBJECTS" .PP -Tcl values are allocated on the heap and are shared as much as possible +Tcl objects are allocated on the heap and are shared as much as possible to reduce storage requirements. -Reference counting is used to determine when a value is +Reference counting is used to determine when an object is no longer needed and can safely be freed. -A value just created by \fBTcl_NewObj\fR or \fBTcl_NewStringObj\fR +An object just created by \fBTcl_NewObj\fR or \fBTcl_NewStringObj\fR has \fIrefCount\fR 0. The macro \fBTcl_IncrRefCount\fR increments the reference count -when a new reference to the value is created. +when a new reference to the object is created. The macro \fBTcl_DecrRefCount\fR decrements the count when a reference is no longer needed and, -if the value's reference count drops to zero, frees its storage. -A value shared by different code or data structures has +if the object's reference count drops to zero, frees its storage. +An object shared by different code or data structures has \fIrefCount\fR greater than 1. -Incrementing a value's reference count ensures that +Incrementing an object's reference count ensures that it will not be freed too early or have its value change accidentally. .PP -As an example, the bytecode interpreter shares argument values -between calling and called Tcl procedures to avoid having to copy values. -It assigns the call's argument values to the procedure's +As an example, the bytecode interpreter shares argument objects +between calling and called Tcl procedures to avoid having to copy objects. +It assigns the call's argument objects to the procedure's formal parameter variables. In doing so, it calls \fBTcl_IncrRefCount\fR to increment the reference count of each argument since there is now a new reference to it from the formal parameter. When the called procedure returns, the interpreter calls \fBTcl_DecrRefCount\fR to decrement each argument's reference count. -When a value's reference count drops less than or equal to zero, +When an object's reference count drops less than or equal to zero, \fBTcl_DecrRefCount\fR reclaims its storage. Most command procedures do not have to be concerned about -reference counting since they use a value's value immediately -and do not retain a pointer to the value after they return. -However, if they do retain a pointer to a value in a data structure, +reference counting since they use an object's value immediately +and do not retain a pointer to the object after they return. +However, if they do retain a pointer to an object in a data structure, they must be careful to increment its reference count since the retained pointer is a new reference. .PP -Command procedures that directly modify values +Command procedures that directly modify objects such as those for \fBlappend\fR and \fBlinsert\fR must be careful to -copy a shared value before changing it. -They must first check whether the value is shared +copy a shared object before changing it. +They must first check whether the object is shared by calling \fBTcl_IsShared\fR. -If the value is shared they must copy the value +If the object is shared they must copy the object by using \fBTcl_DuplicateObj\fR; -this returns a new duplicate of the original value +this returns a new duplicate of the original object that has \fIrefCount\fR 0. -If the value is not shared, +If the object is not shared, the command procedure .QW "owns" -the value and can safely modify it directly. +the object and can safely modify it directly. For example, the following code appears in the command procedure that implements \fBlinsert\fR. -This procedure modifies the list value passed to it in \fIobjv[1]\fR +This procedure modifies the list object passed to it in \fIobjv[1]\fR by inserting \fIobjc-3\fR new elements before \fIindex\fR. .PP .CS listPtr = objv[1]; -if (\fBTcl_IsShared\fR(listPtr)) { - listPtr = \fBTcl_DuplicateObj\fR(listPtr); +if (Tcl_IsShared(listPtr)) { + listPtr = Tcl_DuplicateObj(listPtr); } result = Tcl_ListObjReplace(interp, listPtr, index, 0, (objc-3), &(objv[3])); .CE .PP As another example, \fBincr\fR's command procedure -must check whether the variable's value is shared before +must check whether the variable's object is shared before incrementing the integer in its internal representation. -If it is shared, it needs to duplicate the value +If it is shared, it needs to duplicate the object in order to avoid accidentally changing values in other data structures. .SH "SEE ALSO" Tcl_ConvertToType(3), Tcl_GetIntFromObj(3), Tcl_ListObjAppendElement(3), Tcl_ListObjIndex(3), Tcl_ListObjReplace(3), Tcl_RegisterObjType(3) .SH KEYWORDS -internal representation, value, value creation, value type, -reference counting, string representation, type conversion +internal representation, object, object creation, object type, reference counting, string representation, type conversion Index: doc/ObjectType.3 ================================================================== --- doc/ObjectType.3 +++ doc/ObjectType.3 @@ -1,59 +1,58 @@ '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Tcl_ObjType 3 8.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_RegisterObjType, Tcl_GetObjType, Tcl_AppendAllObjTypes, Tcl_ConvertToType \- manipulate Tcl value types +Tcl_RegisterObjType, Tcl_GetObjType, Tcl_AppendAllObjTypes, Tcl_ConvertToType \- manipulate Tcl object types .SH SYNOPSIS .nf \fB#include \fR .sp \fBTcl_RegisterObjType\fR(\fItypePtr\fR) .sp -const Tcl_ObjType * +Tcl_ObjType * \fBTcl_GetObjType\fR(\fItypeName\fR) .sp int \fBTcl_AppendAllObjTypes\fR(\fIinterp, objPtr\fR) .sp int \fBTcl_ConvertToType\fR(\fIinterp, objPtr, typePtr\fR) .SH ARGUMENTS .AS "const char" *typeName -.AP "const Tcl_ObjType" *typePtr in -Points to the structure containing information about the Tcl value type. +.AP Tcl_ObjType *typePtr in +Points to the structure containing information about the Tcl object type. This storage must live forever, typically by being statically allocated. .AP "const char" *typeName in -The name of a Tcl value type that \fBTcl_GetObjType\fR should look up. +The name of a Tcl object type that \fBTcl_GetObjType\fR should look up. .AP Tcl_Interp *interp in Interpreter to use for error reporting. .AP Tcl_Obj *objPtr in -For \fBTcl_AppendAllObjTypes\fR, this points to the value onto which -it appends the name of each value type as a list element. -For \fBTcl_ConvertToType\fR, this points to a value that +For \fBTcl_AppendAllObjTypes\fR, this points to the object onto which +it appends the name of each object type as a list element. +For \fBTcl_ConvertToType\fR, this points to an object that must have been the result of a previous call to \fBTcl_NewObj\fR. .BE .SH DESCRIPTION .PP -The procedures in this man page manage Tcl value types (sometimes -referred to as object types or \fBTcl_ObjType\fRs for historical reasons). -They are used to register new value types, look up types, +The procedures in this man page manage Tcl object types. +They are used to register new object types, look up types, and force conversions from one type to another. .PP -\fBTcl_RegisterObjType\fR registers a new Tcl value type -in the table of all value types that \fBTcl_GetObjType\fR -can look up by name. There are other value types supported by Tcl +\fBTcl_RegisterObjType\fR registers a new Tcl object type +in the table of all object types that \fBTcl_GetObjType\fR +can look up by name. There are other object types supported by Tcl as well, which Tcl chooses not to register. Extensions can likewise -choose to register the value types they create or not. +choose to register the object types they create or not. The argument \fItypePtr\fR points to a Tcl_ObjType structure that describes the new type by giving its name and by supplying pointers to four procedures that implement the type. If the type table already contains a type @@ -64,38 +63,40 @@ .PP \fBTcl_GetObjType\fR returns a pointer to the registered Tcl_ObjType with name \fItypeName\fR. It returns NULL if no type with that name is registered. .PP -\fBTcl_AppendAllObjTypes\fR appends the name of each registered value type -as a list element onto the Tcl value referenced by \fIobjPtr\fR. +\fBTcl_AppendAllObjTypes\fR appends the name of each registered object type +as a list element onto the Tcl object referenced by \fIobjPtr\fR. The return value is \fBTCL_OK\fR unless there was an error -converting \fIobjPtr\fR to a list value; +converting \fIobjPtr\fR to a list object; in that case \fBTCL_ERROR\fR is returned. .PP -\fBTcl_ConvertToType\fR converts a value from one type to another +\fBTcl_ConvertToType\fR converts an object from one type to another if possible. It creates a new internal representation for \fIobjPtr\fR appropriate for the target type \fItypePtr\fR -and sets its \fItypePtr\fR member as determined by calling the -\fItypePtr->setFromAnyProc\fR routine. +and sets its \fItypePtr\fR member as determined by calling the +\fItypePtr->setFromAnyProc\fR routine. 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 +and leaves an error message in the result object 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). +.VS 8.5 .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. +.VE 8.5 .SH "THE TCL_OBJTYPE STRUCTURE" .PP -Extension writers can define new value types by defining four +Extension writers can define new object 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 other extensions to look up their Tcl_ObjType by name with @@ -102,40 +103,39 @@ the \fBTcl_GetObjType\fR routine. The \fBTcl_ObjType\fR structure is defined as follows: .PP .CS typedef struct Tcl_ObjType { - const char *\fIname\fR; + char *\fIname\fR; Tcl_FreeInternalRepProc *\fIfreeIntRepProc\fR; Tcl_DupInternalRepProc *\fIdupIntRepProc\fR; Tcl_UpdateStringProc *\fIupdateStringProc\fR; Tcl_SetFromAnyProc *\fIsetFromAnyProc\fR; -} \fBTcl_ObjType\fR; +} Tcl_ObjType; .CE .SS "THE NAME FIELD" .PP The \fIname\fR member describes the name of the type, e.g. \fBint\fR. When a type is registered, this is the name used by callers of \fBTcl_GetObjType\fR to lookup the type. For unregistered types, the \fIname\fR field is primarily of value for debugging. The remaining four members are pointers to procedures -called by the generic Tcl value code: +called by the generic Tcl object code: .SS "THE SETFROMANYPROC FIELD" .PP The \fIsetFromAnyProc\fR member contains the address of a function called to create a valid internal representation -from a value's string representation. +from an object's string representation. .PP .CS -typedef int \fBTcl_SetFromAnyProc\fR( - Tcl_Interp *\fIinterp\fR, +typedef int (Tcl_SetFromAnyProc) (Tcl_Interp *\fIinterp\fR, Tcl_Obj *\fIobjPtr\fR); .CE .PP If an internal representation cannot be created from the string, it returns \fBTCL_ERROR\fR and puts a message -describing the error in the result value for \fIinterp\fR +describing the error in the result object for \fIinterp\fR unless \fIinterp\fR is NULL. If \fIsetFromAnyProc\fR is successful, it stores the new internal representation, sets \fIobjPtr\fR's \fItypePtr\fR member to point to the \fBTcl_ObjType\fR struct corresponding to the new @@ -159,35 +159,34 @@ replace it with a new one or reset the \fItypePtr\fR member to NULL. .PP The \fIsetFromAnyProc\fR member may be set to NULL, if the routines making use of the internal representation have no need to derive that internal representation from an arbitrary string value. However, in -this case, passing a pointer to the type to \fBTcl_ConvertToType\fR will +this case, passing a pointer to the type to Tcl_ConvertToType() will lead to a panic, so to avoid this possibility, the type should \fInot\fR be registered. .SS "THE UPDATESTRINGPROC FIELD" .PP The \fIupdateStringProc\fR member contains the address of a function called to create a valid string representation -from a value's internal representation. +from an object's internal representation. .PP .CS -typedef void \fBTcl_UpdateStringProc\fR( - Tcl_Obj *\fIobjPtr\fR); +typedef void (Tcl_UpdateStringProc) (Tcl_Obj *\fIobjPtr\fR); .CE .PP \fIobjPtr\fR's \fIbytes\fR member is always NULL when it is called. It must always set \fIbytes\fR non-NULL before returning. 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 +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. -Note that \fIupdateStringProc\fRs must allocate +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 @@ -200,23 +199,22 @@ obligation will lead to panics or crashes when \fBTcl_GetStringFromObj\fR or other similar routines ask for the string representation. .SS "THE DUPINTREPPROC FIELD" .PP The \fIdupIntRepProc\fR member contains the address of a function -called to copy an internal representation from one value to another. +called to copy an internal representation from one object to another. .PP .CS -typedef void \fBTcl_DupInternalRepProc\fR( - Tcl_Obj *\fIsrcPtr\fR, +typedef void (Tcl_DupInternalRepProc) (Tcl_Obj *\fIsrcPtr\fR, Tcl_Obj *\fIdupPtr\fR); .CE .PP \fIdupPtr\fR's internal representation is made a copy of \fIsrcPtr\fR's internal representation. Before the call, \fIsrcPtr\fR's internal representation is valid and \fIdupPtr\fR's is not. -\fIsrcPtr\fR's value type determines what +\fIsrcPtr\fR's object type determines what copying its internal representation means. .PP For example, the \fIdupIntRepProc\fR for the Tcl integer type simply copies an integer. The built-in list type's \fIdupIntRepProc\fR uses a far more @@ -223,32 +221,31 @@ sophisticated scheme to continue sharing storage as much as it reasonably can. .SS "THE FREEINTREPPROC FIELD" .PP The \fIfreeIntRepProc\fR member contains the address of a function -that is called when a value is freed. +that is called when an object is freed. .PP .CS -typedef void \fBTcl_FreeInternalRepProc\fR( - Tcl_Obj *\fIobjPtr\fR); +typedef void (Tcl_FreeInternalRepProc) (Tcl_Obj *\fIobjPtr\fR); .CE .PP The \fIfreeIntRepProc\fR function can deallocate the storage -for the value's internal representation -and do other type-specific processing necessary when a value is freed. +for the object's internal representation +and do other type-specific processing necessary when an object is freed. .PP For example, the list type's \fIfreeIntRepProc\fR respects the storage sharing scheme established by the \fIdupIntRepProc\fR -so that it only frees storage when the last value sharing it +so that it only frees storage when the last object sharing it is being freed. .PP The \fIfreeIntRepProc\fR member can be set to NULL to indicate that the internal representation does not require freeing. The \fIfreeIntRepProc\fR implementation must not access the -\fIbytes\fR member of the value, since Tcl makes its own internal -uses of that field during value deletion. The defined tasks for +\fIbytes\fR member of the object, since Tcl makes its own internal +uses of that field during object deletion. The defined tasks for the \fIfreeIntRepProc\fR have no need to consult the \fIbytes\fR member. .SH "SEE ALSO" -Tcl_NewObj(3), Tcl_DecrRefCount(3), Tcl_IncrRefCount(3) +Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount .SH KEYWORDS -internal representation, value, value type, string representation, type conversion +internal representation, object, object type, string representation, type conversion Index: doc/OpenFileChnl.3 ================================================================== --- doc/OpenFileChnl.3 +++ doc/OpenFileChnl.3 @@ -51,32 +51,32 @@ \fBTcl_ReadChars\fR(\fIchannel, readObjPtr, charsToRead, appendFlag\fR) .sp int \fBTcl_Read\fR(\fIchannel, readBuf, bytesToRead\fR) .sp -size_t +int \fBTcl_GetsObj\fR(\fIchannel, lineObjPtr\fR) .sp -size_t +int \fBTcl_Gets\fR(\fIchannel, lineRead\fR) .sp -size_t +int \fBTcl_Ungets\fR(\fIchannel, input, inputLen, addAtEnd\fR) .sp -size_t +int \fBTcl_WriteObj\fR(\fIchannel, writeObjPtr\fR) .sp -size_t +int \fBTcl_WriteChars\fR(\fIchannel, charBuf, bytesToWrite\fR) .sp -size_t +int \fBTcl_Write\fR(\fIchannel, byteBuf, bytesToWrite\fR) .sp -size_t +int \fBTcl_ReadRaw\fR(\fIchannel, readBuf, bytesToRead\fR) .sp -size_t +int \fBTcl_WriteRaw\fR(\fIchannel, byteBuf, bytesToWrite\fR) .sp int \fBTcl_Eof\fR(\fIchannel\fR) .sp @@ -96,12 +96,14 @@ \fBTcl_Seek\fR(\fIchannel, offset, seekMode\fR) .sp Tcl_WideInt \fBTcl_Tell\fR(\fIchannel\fR) .sp +.VS 8.5 int \fBTcl_TruncateChannel\fR(\fIchannel, length\fR) +.VE 8.5 .sp int \fBTcl_GetChannelOption\fR(\fIinterp, channel, optionName, optionValue\fR) .sp int @@ -113,11 +115,11 @@ Used for error reporting and to look up a channel registered in it. .AP "const char" *fileName in The name of a local or network file. .AP "const char" *mode in Specifies how the file is to be accessed. May have any of the values -allowed for the \fImode\fR argument to the Tcl \fBopen\fR command. +allowed for the \fImode\fR argument to the Tcl \fBopen\fR command. .AP int permissions in POSIX-style permission flags such as 0644. If a new file is created, these permissions will be set on the created file. .AP int argc in The number of elements in \fIargv\fR. @@ -132,18 +134,18 @@ 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 void *handle in +.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. +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 @@ -150,46 +152,46 @@ 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 +A pointer to a Tcl Object in which to store the characters read from the channel. -.AP size_t 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 +.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. +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. .AP char *readBuf out A buffer in which to store the bytes read from the channel. -.AP size_t bytesToRead in +.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 +A pointer to a Tcl object in which to store the line read from the channel. The line read will be appended to the current value of the -value. +object. .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 size_t inputLen in +.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. +A pointer to a Tcl Object 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 size_t bytesToWrite in +.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 @@ -207,10 +209,11 @@ Where to store the value of an option or a list of all options and their values. Must have been initialized by the caller. .AP "const char" *newValue in New value for the option given by \fIoptionName\fR. .BE + .SH DESCRIPTION .PP The Tcl channel mechanism provides a device-independent and platform-independent mechanism for performing buffered input and output operations on a variety of file, socket, and device @@ -224,10 +227,11 @@ .PP The procedures described in this manual entry comprise the C APIs of the generic layer of the channel architecture. For a description of the channel driver architecture and how to implement channel drivers for new types of channels, see the manual entry for \fBTcl_CreateChannel\fR. + .SH TCL_OPENFILECHANNEL .PP \fBTcl_OpenFileChannel\fR opens a file specified by \fIfileName\fR and returns a channel handle that can be used to perform input and output on the file. This API is modeled after the \fBfopen\fR procedure of @@ -236,19 +240,20 @@ given in the Tcl \fBopen\fR command when opening a file. If an error occurs while opening the channel, \fBTcl_OpenFileChannel\fR returns NULL and records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. In addition, if \fIinterp\fR is non-NULL, \fBTcl_OpenFileChannel\fR -leaves an error message in \fIinterp\fR's result after any error. -As of Tcl 8.4, the value-based API \fBTcl_FSOpenFileChannel\fR should +leaves an error message in \fIinterp\fR's result after any error. +As of Tcl 8.4, the object-based API \fBTcl_FSOpenFileChannel\fR should be used in preference to \fBTcl_OpenFileChannel\fR wherever possible. .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 +If one of the standard channels, \fBstdin, stdout\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_OPENCOMMANDCHANNEL .PP \fBTcl_OpenCommandChannel\fR provides a C-level interface to the functions of the \fBexec\fR and \fBopen\fR commands. It creates a sequence of subprocesses specified @@ -275,26 +280,28 @@ .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. +the interpreter's result if \fIinterp\fR is not 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 +If one of the standard channels, \fBstdin, stdout\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 .PP \fBTcl_MakeFileChannel\fR makes a \fBTcl_Channel\fR from an existing, platform-specific, file handle. 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 +If one of the standard channels, \fBstdin, stdout\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_GETCHANNEL .PP \fBTcl_GetChannel\fR returns a channel given the \fIchannelName\fR used to create it with \fBTcl_CreateChannel\fR and a pointer to a Tcl interpreter in \fIinterp\fR. If a channel by that name is not registered in that interpreter, @@ -303,15 +310,16 @@ \fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR describing whether the channel is open for reading and writing. .PP \fBTcl_GetChannelNames\fR and \fBTcl_GetChannelNamesEx\fR write the names of the registered channels to the interpreter's result as a -list value. \fBTcl_GetChannelNamesEx\fR will filter these names +list object. \fBTcl_GetChannelNamesEx\fR will filter these names according to the \fIpattern\fR. If \fIpattern\fR is NULL, then it will not do any filtering. The return value is \fBTCL_OK\fR if no errors occurred writing to the result, otherwise it is \fBTCL_ERROR\fR, and the error message is left in the interpreter's result. + .SH TCL_REGISTERCHANNEL .PP \fBTcl_RegisterChannel\fR adds a channel to the set of channels accessible in \fIinterp\fR. After this call, Tcl programs executing in that interpreter can refer to the channel in input or output operations using @@ -330,12 +338,13 @@ .PP This procedure interacts with the code managing the standard channels. If no standard channels were initialized before the first call to \fBTcl_RegisterChannel\fR, they will get initialized by that call. See \fBTcl_StandardChannels\fR for a general treatise about -standard channels and the behavior of the Tcl library with regard to +standard channels and the behaviour of the Tcl library with regard to them. + .SH TCL_UNREGISTERCHANNEL .PP \fBTcl_UnregisterChannel\fR removes a channel from the set of channels accessible in \fIinterp\fR. After this call, Tcl programs will no longer be able to use the channel's name to refer to the channel in that interpreter. @@ -346,32 +355,35 @@ \fBTcl_UnregisterChannel\fR with \fIinterp\fR as NULL, to indicate to Tcl that it no longer holds a reference to that channel. If this is the last reference to the channel, it will now be closed. \fBTcl_UnregisterChannel\fR is very similar to \fBTcl_DetachChannel\fR except that it will also close the channel if no further references to it exist. + .SH TCL_DETACHCHANNEL .PP \fBTcl_DetachChannel\fR removes a channel from the set of channels accessible in \fIinterp\fR. After this call, Tcl programs will no longer be able to use the channel's name to refer to the channel in that interpreter. Beyond that, this command has no further effect. It cannot be used on -the standard channels (\fBstdout\fR, \fBstderr\fR, \fBstdin\fR), and will return +the standard channels (stdout, stderr, stdin), and will return \fBTCL_ERROR\fR if passed one of those channels. .PP Code not associated with a Tcl interpreter can call \fBTcl_DetachChannel\fR with \fIinterp\fR as NULL, to indicate to Tcl that it no longer holds a reference to that channel. If this is the last -reference to the channel, unlike \fBTcl_UnregisterChannel\fR, +reference to the channel, unlike \fBTcl_UnregisterChannel\fR, it will not be closed. + .SH TCL_ISSTANDARDCHANNEL .PP \fBTcl_IsStandardChannel\fR tests whether a channel is one of the -three standard channels, \fBstdin\fR, \fBstdout\fR or \fBstderr\fR. -If so, it returns 1, otherwise 0. +three standard channels, stdin, stdout or stderr. If so, it returns +1, otherwise 0. .PP -No attempt is made to check whether the given channel or the standard +No attempt is made to check whether the given channel or the standard channels are initialized or otherwise valid. + .SH TCL_CLOSE .PP \fBTcl_Close\fR destroys the channel \fIchannel\fR, which must denote a currently open channel. The channel should not be registered in any interpreter when \fBTcl_Close\fR is called. Buffered output is flushed to @@ -397,14 +409,15 @@ been given as the \fBchan\fR argument in a call to \fBTcl_RegisterChannel\fR, you should instead use \fBTcl_UnregisterChannel\fR, which will internally call \fBTcl_Close\fR when all calls to \fBTcl_RegisterChannel\fR have been matched by corresponding calls to \fBTcl_UnregisterChannel\fR. + .SH "TCL_READCHARS AND TCL_READ" .PP \fBTcl_ReadChars\fR consumes bytes from \fIchannel\fR, converting the bytes -to UTF-8 based on the channel's encoding and storing the produced data in +to UTF-8 based on the channel's encoding and storing the produced data in \fIreadObjPtr\fR's string representation. The return value of \fBTcl_ReadChars\fR is the number of characters, up to \fIcharsToRead\fR, that were stored in \fIreadObjPtr\fR. If an error occurs while reading, the return value is \-1 and \fBTcl_ReadChars\fR records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. @@ -433,11 +446,11 @@ \fBfconfigure\fR command. .PP As a performance optimization, when reading from a channel with the encoding \fBbinary\fR, the bytes are not converted to UTF-8 as they are read. Instead, they are stored in \fIreadObjPtr\fR's internal representation as a -byte-array value. The string representation of this value will only be +byte-array object. The string representation of this object will only be constructed if it is needed (e.g., because of a call to \fBTcl_GetStringFromObj\fR). In this way, byte-oriented data can be read from a channel, manipulated by calling \fBTcl_GetByteArrayFromObj\fR and related functions, and then written to a channel without the expense of ever converting to or from UTF-8. @@ -448,19 +461,20 @@ extensions. It consumes bytes from \fIchannel\fR and stores them in \fIreadBuf\fR, performing end-of-line translations on the way. The return value of \fBTcl_Read\fR is the number of bytes, up to \fIbytesToRead\fR, written in \fIreadBuf\fR. The buffer produced by \fBTcl_Read\fR is not null-terminated. Its contents are valid from the zeroth position up to and excluding the -position indicated by the return value. +position indicated by the return value. .PP \fBTcl_ReadRaw\fR is the same as \fBTcl_Read\fR but does not compensate for stacking. While \fBTcl_Read\fR (and the other functions in the API) always get their data from the topmost channel in the stack the supplied channel is part of, \fBTcl_ReadRaw\fR does not. Thus this function is \fBonly\fR usable for transformational channel drivers, i.e. drivers used in the middle of a stack of channels, to move data from the channel below into the transformation. + .SH "TCL_GETSOBJ AND TCL_GETS" .PP \fBTcl_GetsObj\fR consumes bytes from \fIchannel\fR, converting the bytes to UTF-8 based on the channel's encoding, until a full line of input has been seen. If the channel's encoding is \fBbinary\fR, each byte read from the @@ -482,11 +496,12 @@ procedure may be invoked to determine if the channel is blocked because of input unavailability. .PP \fBTcl_Gets\fR is the same as \fBTcl_GetsObj\fR except the resulting characters are appended to the dynamic string given by -\fIlineRead\fR rather than a Tcl value. +\fIlineRead\fR rather than a Tcl object. + .SH "TCL_UNGETS" .PP \fBTcl_Ungets\fR is used to add data to the input queue of a channel, at either the head or tail of the queue. The pointer \fIinput\fR points to the data that is to be added. The length of the input to add is given @@ -495,10 +510,11 @@ head of the queue. If \fIchannel\fR has a .QW sticky EOF set, no data will be added to the input queue. \fBTcl_Ungets\fR returns \fIinputLen\fR or \-1 if an error occurs. + .SH "TCL_WRITECHARS, TCL_WRITEOBJ, AND TCL_WRITE" .PP \fBTcl_WriteChars\fR accepts \fIbytesToWrite\fR bytes of character data at \fIcharBuf\fR. The UTF-8 characters in the buffer are converted to the channel's encoding and queued for output to \fIchannel\fR. If @@ -505,11 +521,11 @@ \fIbytesToWrite\fR is negative, \fBTcl_WriteChars\fR expects \fIcharBuf\fR to be null-terminated and it outputs everything up to the null. .PP Data queued for output may not appear on the output device immediately, due to internal buffering. If the data should appear immediately, call -\fBTcl_Flush\fR after the call to \fBTcl_WriteChars\fR, or set the +\fBTcl_Flush\fR after the call to \fBTcl_WriteChars\fR, or set the \fB\-buffering\fR option on the channel to \fBnone\fR. If you wish the data to appear as soon as a complete line is accepted for output, set the \fB\-buffering\fR option on the channel to \fBline\fR mode. .PP The return value of \fBTcl_WriteChars\fR is a count of how many bytes were @@ -521,18 +537,18 @@ Newline characters in the output data are translated to platform-specific end-of-line sequences according to the \fB\-translation\fR option for the channel. This is done even if the channel has no encoding. .PP \fBTcl_WriteObj\fR is similar to \fBTcl_WriteChars\fR except it -accepts a Tcl value whose contents will be output to the channel. The +accepts a Tcl object whose contents will be output to the channel. The UTF-8 characters in \fIwriteObjPtr\fR's string representation are converted -to the channel's encoding and queued for output to \fIchannel\fR. +to the channel's encoding and queued for output to \fIchannel\fR. As a performance optimization, when writing to a channel with the encoding \fBbinary\fR, UTF-8 characters are not converted as they are written. Instead, the bytes in \fIwriteObjPtr\fR's internal representation as a -byte-array value are written to the channel. The byte-array representation -of the value will be constructed if it is needed. In this way, +byte-array object are written to the channel. The byte-array representation +of the object will be constructed if it is needed. In this way, byte-oriented data can be read from a channel, manipulated by calling \fBTcl_GetByteArrayFromObj\fR and related functions, and then written to a channel without the expense of ever converting to or from UTF-8. .PP \fBTcl_Write\fR is similar to \fBTcl_WriteChars\fR except that it does not do @@ -549,10 +565,11 @@ in the stack the supplied channel is part of, \fBTcl_WriteRaw\fR does not. Thus this function is \fBonly\fR usable for transformational channel drivers, i.e. drivers used in the middle of a stack of channels, to move data from the transformation into the channel below it. + .SH TCL_FLUSH .PP \fBTcl_Flush\fR causes all of the buffered output data for \fIchannel\fR to be written to its underlying file or device as soon as possible. If the channel is in blocking mode, the call does not return until @@ -562,10 +579,11 @@ eventually, as fast as the channel is able to absorb it. .PP The return value is normally \fBTCL_OK\fR. If an error occurs, \fBTcl_Flush\fR returns \fBTCL_ERROR\fR and records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. + .SH TCL_SEEK .PP \fBTcl_Seek\fR moves the access point in \fIchannel\fR where subsequent data will be read or written. Buffered output is flushed to the channel and buffered input is discarded, prior to the seek operation. @@ -572,19 +590,24 @@ .PP \fBTcl_Seek\fR normally returns the new access point. If an error occurs, \fBTcl_Seek\fR returns \-1 and records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. After an error, the access point may or may not have been moved. + .SH TCL_TELL .PP \fBTcl_Tell\fR returns the current access point for a channel. The returned value is \-1 if the channel does not support seeking. + .SH TCL_TRUNCATECHANNEL .PP +.VS 8.5 \fBTcl_TruncateChannel\fR truncates the file underlying \fIchannel\fR to a given \fIlength\fR of bytes. It returns \fBTCL_OK\fR if the operation succeeded, and \fBTCL_ERROR\fR otherwise. +.VE 8.5 + .SH TCL_GETCHANNELOPTION .PP \fBTcl_GetChannelOption\fR retrieves, in \fIoptionValue\fR, the value of one of the options currently in effect for a channel, or a list of all options and their values. The \fIchannel\fR argument identifies the channel for which @@ -602,37 +625,42 @@ additional options for TCP based channels are described in the manual entry for the Tcl \fBsocket\fR command. The procedure normally returns \fBTCL_OK\fR. If an error occurs, it returns \fBTCL_ERROR\fR and calls \fBTcl_SetErrno\fR to store an appropriate POSIX error code. + .SH TCL_SETCHANNELOPTION .PP \fBTcl_SetChannelOption\fR sets a new value \fInewValue\fR for an option \fIoptionName\fR on \fIchannel\fR. The procedure normally returns \fBTCL_OK\fR. If an error occurs, it returns \fBTCL_ERROR\fR; in addition, if \fIinterp\fR is non-NULL, \fBTcl_SetChannelOption\fR leaves an error message in the interpreter's result. + .SH TCL_EOF .PP \fBTcl_Eof\fR returns a nonzero value if \fIchannel\fR encountered an end of file during the last input operation. + .SH TCL_INPUTBLOCKED .PP \fBTcl_InputBlocked\fR returns a nonzero value if \fIchannel\fR is in nonblocking mode and the last input operation returned less data than requested because there was insufficient data available. The call always returns zero if the channel is in blocking mode. + .SH TCL_INPUTBUFFERED .PP \fBTcl_InputBuffered\fR returns the number of bytes of input currently buffered in the internal buffers for a channel. If the channel is not open for reading, this function always returns zero. + .SH TCL_OUTPUTBUFFERED -.PP \fBTcl_OutputBuffered\fR returns the number of bytes of output currently buffered in the internal buffers for a channel. If the channel is not open for writing, this function always returns zero. + .SH "PLATFORM ISSUES" .PP The handles returned from \fBTcl_GetChannelHandle\fR depend on the platform and the channel type. On Unix platforms, the handle is always a Unix file descriptor as returned from the \fBopen\fR system @@ -639,10 +667,12 @@ call. On Windows platforms, the handle is a file \fBHANDLE\fR when the channel was created with \fBTcl_OpenFileChannel\fR, \fBTcl_OpenCommandChannel\fR, or \fBTcl_MakeFileChannel\fR. Other channel types may return a different type of handle on Windows platforms. + .SH "SEE ALSO" DString(3), fconfigure(n), filename(n), fopen(3), Tcl_CreateChannel(3) + .SH KEYWORDS access point, blocking, buffered I/O, channel, channel driver, end of file, flush, input, nonblocking, output, read, seek, write Index: doc/OpenTcp.3 ================================================================== --- doc/OpenTcp.3 +++ doc/OpenTcp.3 @@ -2,16 +2,16 @@ '\" Copyright (c) 1996-7 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH Tcl_OpenTcpClient 3 8.7 Tcl "Tcl Library Procedures" +.TH Tcl_OpenTcpClient 3 8.0 Tcl "Tcl Library Procedures" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -Tcl_OpenTcpClient, Tcl_MakeTcpClientChannel, Tcl_OpenTcpServer, Tcl_OpenTcpServerEx \- procedures to open channels using TCP sockets +Tcl_OpenTcpClient, Tcl_MakeTcpClientChannel, Tcl_OpenTcpServer \- procedures to open channels using TCP sockets .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_Channel @@ -21,23 +21,17 @@ \fBTcl_MakeTcpClientChannel\fR(\fIsock\fR) .sp Tcl_Channel \fBTcl_OpenTcpServer\fR(\fIinterp, port, myaddr, proc, clientData\fR) .sp -Tcl_Channel -\fBTcl_OpenTcpServerEx\fR(\fIinterp, service, myaddr, flags, proc, clientData\fR) -.sp .SH ARGUMENTS .AS Tcl_TcpAcceptProc clientData .AP Tcl_Interp *interp in Tcl interpreter to use for error reporting. If non-NULL and an error occurs, an error message is left in the interpreter's result. .AP int port in A port number to connect to as a client or to listen on as a server. -.AP "const char" *service in -A string specifying the port number to connect to as a client or to listen on as - a server. .AP "const char" *host in A string specifying a host name or address for the remote end of the connection. .AP int myport in A port number for the client's end of the socket. If 0, a port number is allocated at random. @@ -45,28 +39,27 @@ A string specifying the host name or address for network interface to use 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 void *sock in +.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 void *clientData in +.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 are described in the manual entry for \fBTcl_OpenFileChannel\fR. -.SS TCL_OPENTCPCLIENT + +.SH TCL_OPENTCPCLIENT .PP \fBTcl_OpenTcpClient\fR opens a client TCP socket connected to a \fIport\fR on a specific \fIhost\fR, and returns a channel that can be used to communicate with the server. The host to connect to can be specified either as a domain name style name (e.g. \fBwww.sunlabs.com\fR), or as a string @@ -99,37 +92,38 @@ In addition, if \fIinterp\fR is non-NULL, an error message is left in the interpreter's result. .PP The newly created channel is not registered in the supplied interpreter; to register it, use \fBTcl_RegisterChannel\fR. -If one of the standard channels, \fBstdin\fR, \fBstdout\fR or \fBstderr\fR was +If one of the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was previously closed, the act of creating the new channel also assigns it as a replacement for the standard channel. -.SS TCL_MAKETCPCLIENTCHANNEL + +.SH TCL_MAKETCPCLIENTCHANNEL .PP \fBTcl_MakeTcpClientChannel\fR creates a \fBTcl_Channel\fR around an existing, platform specific, handle for a client TCP socket. .PP The newly created channel is not registered in the supplied interpreter; to register it, use \fBTcl_RegisterChannel\fR. -If one of the standard channels, \fBstdin\fR, \fBstdout\fR or \fBstderr\fR was +If one of the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was previously closed, the act of creating the new channel also assigns it as a replacement for the standard channel. -.SS TCL_OPENTCPSERVER + +.SH TCL_OPENTCPSERVER .PP \fBTcl_OpenTcpServer\fR opens a TCP socket on the local host on a specified \fIport\fR and uses the Tcl event mechanism to accept requests from clients to connect to it. The \fImyaddr\fR argument specifies the network interface. If \fImyaddr\fR is NULL the special address INADDR_ANY should be used to 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( - void *\fIclientData\fR, +typedef void Tcl_TcpAcceptProc( + ClientData \fIclientData\fR, Tcl_Channel \fIchannel\fR, char *\fIhostName\fR, int \fIport\fR); .CE .PP @@ -137,11 +131,11 @@ argument to \fBTcl_OpenTcpServer\fR, \fIchannel\fR will be the handle for the new channel, \fIhostName\fR points to a string containing the name of the client host making the connection, and \fIport\fR will contain the client's port number. The new channel -is opened for both input and output. +is opened for both input and output. If \fIproc\fR raises an error, the connection is closed automatically. \fIProc\fR has no return value, but if it wishes to reject the connection it can close \fIchannel\fR. .PP \fBTcl_OpenTcpServer\fR normally returns a pointer to a channel @@ -162,22 +156,20 @@ \fBvwait\fR; otherwise Tcl will never notice that a connection request from a remote client is pending. .PP The newly created channel is not registered in the supplied interpreter; to register it, use \fBTcl_RegisterChannel\fR. -If one of the standard channels, \fBstdin\fR, \fBstdout\fR or \fBstderr\fR was +If one of the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was previously closed, the act of creating the new channel also assigns it as a replacement for the standard channel. -.SS TCL_OPENTCPSERVEREX -.PP -\fBTcl_OpenTcpServerEx\fR behaviour is identical to \fBTcl_OpenTcpServer\fR but -gives more flexibility to the user by providing a mean to further customize some -aspects of the socket via the \fIflags\fR parameter. + .SH "PLATFORM ISSUES" .PP On Unix platforms, the socket handle is a Unix file descriptor as returned by the \fBsocket\fR system call. On the Windows platform, the socket handle is a \fBSOCKET\fR as defined in the WinSock API. + .SH "SEE ALSO" Tcl_OpenFileChannel(3), Tcl_RegisterChannel(3), vwait(n) + .SH KEYWORDS -channel, client, server, socket, TCP +client, server, TCP Index: doc/Panic.3 ================================================================== --- doc/Panic.3 +++ doc/Panic.3 @@ -1,27 +1,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_SetPanicProc, Tcl_ConsolePanic \- report fatal error and abort +Tcl_Panic, Tcl_PanicVA, Tcl_SetPanicProc \- report fatal error and abort .SH SYNOPSIS .nf \fB#include \fR .sp void \fBTcl_Panic\fR(\fIformat\fR, \fIarg\fR, \fIarg\fR, \fI...\fR) .sp void -\fBTcl_SetPanicProc\fR(\fIpanicProc\fR) +\fBTcl_PanicVA\fR(\fIformat\fR, \fIargList\fR) .sp void -\fBTcl_ConsolePanic\fR(\fIformat\fR, \fIarg\fR, \fIarg\fR, \fI...\fR) +\fBTcl_SetPanicProc\fR(\fIpanicProc\fR) .sp .SH ARGUMENTS .AS Tcl_PanicProc *panicProc .AP "const char*" format in A printf-style format string. @@ -31,11 +31,13 @@ An argument list of arguments matching the format string. Must have been initialized using \fBva_start\fR, and cleared using \fBva_end\fR. .AP Tcl_PanicProc *panicProc in Procedure to report fatal error message and abort. + .BE + .SH DESCRIPTION .PP When the Tcl library detects that its internal data structures are in an inconsistent state, or that its C procedures have been called in a manner inconsistent with their documentation, it calls \fBTcl_Panic\fR @@ -47,52 +49,48 @@ \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. +return. .PP \fBTcl_SetPanicProc\fR may be used to modify the behavior of \fBTcl_Panic\fR. The \fIpanicProc\fR argument should match the type \fBTcl_PanicProc\fR: .PP .CS -typedef void \fBTcl_PanicProc\fR( +typedef void Tcl_PanicProc( const char *\fBformat\fR, \fBarg\fR, \fBarg\fR,...); .CE .PP After \fBTcl_SetPanicProc\fR returns, any future calls to \fBTcl_Panic\fR will call \fIpanicProc\fR, passing along the -\fIformat\fR and \fIarg\fR arguments. \fIpanicProc\fR should avoid -making calls into the Tcl library, or into other libraries that may -call the Tcl library, since the original call to \fBTcl_Panic\fR -indicates the Tcl library is not in a state of reliable operation. +\fIformat\fR and \fIarg\fR arguments. To maintain consistency with the +callers of \fBTcl_Panic\fR, \fIpanicProc\fR must not return; it must +call \fBabort\fR. \fIpanicProc\fR should avoid making calls into the +Tcl library, or into other libraries that may 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 safely by stub-enabled extensions, so its -symbol is not included in the stub table. +application or the platform. As an example, the Windows implementation +of \fBwish\fR calls \fBTcl_SetPanicProc\fR to force all panic messages +to be displayed in a system dialog box, rather than to be printed to the +standard error file (usually not visible under Windows). .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. + .SH "SEE ALSO" abort(3), printf(3), exec(n), format(n) + .SH KEYWORDS abort, fatal, error + DELETED doc/ParseArgs.3 Index: doc/ParseArgs.3 ================================================================== --- doc/ParseArgs.3 +++ /dev/null @@ -1,198 +0,0 @@ -'\" -'\" Copyright (c) 2008 Donal K. Fellows -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH Tcl_ParseArgsObjv 3 8.6 Tcl "Tcl Library Procedures" -.so man.macros -.BS -.SH NAME -Tcl_ParseArgsObjv \- parse arguments according to a tabular description -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -int -\fBTcl_ParseArgsObjv\fR(\fIinterp, argTable, objcPtr, objv, remObjv\fR) -.SH ARGUMENTS -.AS "const Tcl_ArgvInfo" ***remObjv in/out -.AP Tcl_Interp *interp out -Where to store error messages. -.AP "const Tcl_ArgvInfo" *argTable in -Pointer to array of option descriptors. -.AP int *objcPtr in/out -A pointer to variable holding number of arguments in \fIobjv\fR. Will be -modified to hold number of arguments left in the unprocessed argument list -stored in \fIremObjv\fR. -.AP "Tcl_Obj *const" *objv in -The array of arguments to be parsed. -.AP Tcl_Obj ***remObjv out -Pointer to a variable that will hold the array of unprocessed arguments. -Should be NULL if no return of unprocessed arguments is required. If -\fIobjcPtr\fR is updated to a non-zero value, the array returned through this -must be deallocated using \fBTcl_Free\fR. -.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 -in the arguments to an individual Tcl command. This parser assumes that the -order of the arguments does not matter, other than in so far as later copies -of a duplicated option overriding earlier ones. -.PP -The argument array is described by the \fIobjcPtr\fR and \fIobjv\fR -parameters, and an array of unprocessed arguments is returned through the -\fIobjcPtr\fR and \fIremObjv\fR parameters; if no return of unprocessed -arguments is desired, the \fIremObjv\fR parameter should be NULL. If any -problems happen, including if the -.QW "generate help" -option is selected, an error message is left in the interpreter result and -TCL_ERROR is returned. Otherwise, the interpreter result is left unchanged and -TCL_OK is returned. -.PP -The collection of arguments to be parsed is described by the \fIargTable\fR -parameter. This points to a table of descriptor structures that is terminated -by an entry with the \fItype\fR field set to TCL_ARGV_END. As convenience, the -following prototypical entries are provided: -.TP -\fBTCL_ARGV_AUTO_HELP\fR -. -Enables the argument processor to provide help when passed the argument -.QW \fB\-help\fR . -.TP -\fBTCL_ARGV_AUTO_REST\fR -. -Instructs the argument processor that arguments after -.QW \fB\-\-\fR -are to be unprocessed. -.TP -\fBTCL_ARGV_TABLE_END\fR -. -Marks the end of the table of argument descriptors. -.SS "ARGUMENT DESCRIPTOR ENTRIES" -.PP -Each entry of the argument descriptor table must be a structure of type -\fBTcl_ArgvInfo\fR. The structure is defined as this: -.PP -.CS -typedef struct { - int \fItype\fR; - const char *\fIkeyStr\fR; - void *\fIsrcPtr\fR; - void *\fIdstPtr\fR; - const char *\fIhelpStr\fR; - void *\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 -\fBTCL_ARGV_FLOAT\fR -. -This argument takes a following floating point value argument. The value (once -parsed by \fBTcl_GetDoubleFromObj\fR) will be stored as a double-precision -value in the variable pointed to by the \fIdstPtr\fR field. The \fIsrcPtr\fR -and \fIclientData\fR fields are ignored. -.TP -\fBTCL_ARGV_FUNC\fR -. -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)( - void *\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 -there are no following arguments at all, and the \fIdstPtr\fR argument to the -\fBTcl_ArgvFuncProc\fR is the location to write the parsed value to. -.RE -.TP -\fBTCL_ARGV_GENFUNC\fR -. -This argument takes zero or more following arguments; the handler callback -function passed in \fIsrcPtr\fR returns how many (or a negative number to -signal an error, in which case it should also set the interpreter result). The -function will have the following signature: -.RS -.PP -.CS -typedef int (\fBTcl_ArgvGenFuncProc\fR)( - void *\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 -where to store any error messages, the \fIkeyStr\fR is the name of the -argument, \fIobjc\fR and \fIobjv\fR describe an array of all the remaining -arguments, and \fIdstPtr\fR argument to the \fBTcl_ArgvGenFuncProc\fR is the -location to write the parsed value (or values) to. -.RE -.TP -\fBTCL_ARGV_HELP\fR -. -This special argument does not take any following value argument, but instead -causes \fBTcl_ParseArgsObjv\fR to generate an error message describing the -arguments supported. All other fields except the \fIhelpStr\fR field are -ignored. -.TP -\fBTCL_ARGV_INT\fR -. -This argument takes a following integer value argument. The value (once parsed -by \fBTcl_GetIntFromObj\fR) will be stored as an int in the variable pointed -to by the \fIdstPtr\fR field. The \fIsrcPtr\fR field is ignored. -.TP -\fBTCL_ARGV_REST\fR -. -This special argument does not take any following value argument, but instead -marks all following arguments to be left unprocessed. The \fIsrcPtr\fR, -\fIdstPtr\fR and \fIclientData\fR fields are ignored. -.TP -\fBTCL_ARGV_STRING\fR -. -This argument takes a following string value argument. A pointer to the string -will be stored at \fIdstPtr\fR; the string inside will have a lifetime linked -to the lifetime of the string representation of the argument value that it -came from, and so should be copied if it needs to be retained. The -\fIsrcPtr\fR and \fIclientData\fR fields are ignored. -.SH "SEE ALSO" -Tcl_GetIndexFromObj(3), Tcl_Main(3), Tcl_CreateObjCommand(3) -.SH KEYWORDS -argument, parse -'\" Local Variables: -'\" fill-column: 78 -'\" End: Index: doc/ParseCmd.3 ================================================================== --- doc/ParseCmd.3 +++ doc/ParseCmd.3 @@ -1,16 +1,16 @@ '\" '\" 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_EvalTokensStandard \- parse Tcl scripts and expressions +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 \fR .sp int @@ -31,30 +31,34 @@ 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 and -\fBTcl_EvalTokensStandard\fR, used only for error reporting; +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_EvalTokensStandard\fR, determines the context for evaluating -the script and also is used for error reporting; must not be NULL. +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 Non-zero means that the script is part of a command substitution so an unquoted close bracket should be treated as a command terminator. If zero, -close brackets have no special meaning. +close brackets have no special meaning. .AP int append in Non-zero means that \fI*parsePtr\fR already contains valid tokens; the new tokens should be appended to those already present. Zero means that \fI*parsePtr\fR is uninitialized; any information in it is ignored. This argument is normally 0. @@ -74,10 +78,11 @@ if the parse was successful. .AP Tcl_Parse *usedParsePtr in Points to structure that was filled in by a previous call to \fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseVarName\fR, etc. .BE + .SH DESCRIPTION .PP These procedures parse Tcl commands or portions of Tcl commands such as expressions or references to variables. Each procedure takes a pointer to a script (or portion thereof) @@ -112,11 +117,11 @@ .PP \fBTcl_ParseBraces\fR parses a string or command argument enclosed in braces such as \fB{hello}\fR or \fB{string \et with \et tabs}\fR from the beginning of its argument \fIstart\fR. -The first character of \fIstart\fR must be \fB{\fR. +The first character of \fIstart\fR must be \fB{\fR. If the braced string was parsed successfully, \fBTcl_ParseBraces\fR returns \fBTCL_OK\fR, fills in the structure pointed to by \fIparsePtr\fR with information about the structure of the string (see below for details), @@ -128,11 +133,11 @@ and no information is left at \fI*parsePtr\fR or \fI*termPtr\fR. .PP \fBTcl_ParseQuotedString\fR parses a double-quoted string such as \fB"sum is [expr {$a+$b}]"\fR from the beginning of the argument \fIstart\fR. -The first character of \fIstart\fR must be \fB\N'34'\fR. +The first character of \fIstart\fR must be \fB\N'34'\fR. If the double-quoted string was parsed successfully, \fBTcl_ParseQuotedString\fR returns \fBTCL_OK\fR, fills in the structure pointed to by \fIparsePtr\fR with information about the structure of the string (see below for details), @@ -144,11 +149,11 @@ and no information is left at \fI*parsePtr\fR or \fI*termPtr\fR. .PP \fBTcl_ParseVarName\fR parses a Tcl variable reference such as \fB$abc\fR or \fB$x([expr {$index + 1}])\fR from the beginning of its \fIstart\fR argument. -The first character of \fIstart\fR must be \fB$\fR. +The first character of \fIstart\fR must be \fB$\fR. If a variable name was parsed successfully, \fBTcl_ParseVarName\fR returns \fBTCL_OK\fR and fills in the structure pointed to by \fIparsePtr\fR with information about the structure of the variable name (see below for details). If an error occurs while parsing the command then \fBTCL_ERROR\fR is returned, an @@ -178,41 +183,51 @@ \fBTcl_EvalTokensStandard\fR evaluates a sequence of parse tokens from a Tcl_Parse structure. The tokens typically consist of all the tokens in a word or all the tokens that make up the index for a reference to an array variable. \fBTcl_EvalTokensStandard\fR performs the substitutions requested by the tokens and concatenates the -resulting values. +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 object returned as result has been +incremented, so the caller must +invoke \fBTcl_DecrRefCount\fR when it is finished with the object. +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 typedef struct Tcl_Parse { - const char *\fIcommentStart\fR; - int \fIcommentSize\fR; - const char *\fIcommandStart\fR; - int \fIcommandSize\fR; - int \fInumWords\fR; - Tcl_Token *\fItokenPtr\fR; - int \fInumTokens\fR; - ... -} \fBTcl_Parse\fR; + const char *\fIcommentStart\fR; + int \fIcommentSize\fR; + const char *\fIcommandStart\fR; + int \fIcommandSize\fR; + int \fInumWords\fR; + Tcl_Token *\fItokenPtr\fR; + int \fInumTokens\fR; + ... +} Tcl_Parse; typedef struct Tcl_Token { - int \fItype\fR; - const char *\fIstart\fR; - size_t \fIsize\fR; - size_t \fInumComponents\fR; -} \fBTcl_Token\fR; + int \fItype\fR; + const char *\fIstart\fR; + int \fIsize\fR; + int \fInumComponents\fR; +} Tcl_Token; .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. @@ -226,11 +241,11 @@ in all of the comments preceding the command, including the newline character that terminates the last comment. If the command is not preceded by any comments, \fIcommentSize\fR is 0. \fBTcl_ParseCommand\fR also sets the \fIcommandStart\fR field to point to the first character of the first -word in the command (skipping any comments and leading space) and +word in the command (skipping any comments and leading space) and \fIcommandSize\fR gives the total number of bytes in the command, including the character pointed to by \fIcommandStart\fR up to and including the newline, close bracket, or semicolon character that terminates the command. The \fInumWords\fR field gives the total number of words in the command. @@ -250,11 +265,10 @@ several component tokens, which immediately follow the parent token; the \fInumComponents\fR field describes how many of these there are. The \fItype\fR field has one of the following values: .TP 20 \fBTCL_TOKEN_WORD\fR -. This token ordinarily describes one word of a command but it may also describe a quoted or braced string in an expression. The token describes a component of the script that is the result of concatenating together a sequence of subcomponents, each described by a separate subtoken. @@ -265,44 +279,40 @@ terminates the component. The \fInumComponents\fR field counts the total number of sub-tokens that make up the word, including sub-tokens of \fBTCL_TOKEN_VARIABLE\fR and \fBTCL_TOKEN_BS\fR tokens. .TP \fBTCL_TOKEN_SIMPLE_WORD\fR -. This token has the same meaning as \fBTCL_TOKEN_WORD\fR, except that the word is guaranteed to consist of a single \fBTCL_TOKEN_TEXT\fR sub-token. The \fInumComponents\fR field is always 1. .TP \fBTCL_TOKEN_EXPAND_WORD\fR -. +.VS 8.5 This token has the same meaning as \fBTCL_TOKEN_WORD\fR, except that the command parser notes this word began with the expansion prefix \fB{*}\fR, indicating that after substitution, the list value of this word should be expanded to form multiple arguments in command evaluation. This token type can only be created by Tcl_ParseCommand. +.VE 8.5 .TP \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 is not parsed; call \fBTcl_ParseCommand\fR recursively if you want to see its tokens). .TP \fBTCL_TOKEN_VARIABLE\fR -. The token describes a variable substitution, including the \fB$\fR, variable name, and array index (if there is one) up through the close parenthesis that terminates the index. This token is followed by one or more additional tokens that describe the variable name and array index. If \fInumComponents\fR is 1 then the variable is a @@ -314,11 +324,10 @@ \fBTCL_TOKEN_VARIABLE\fR tokens that must be concatenated to produce the array index. The \fInumComponents\fR field includes nested sub-tokens that are part of \fBTCL_TOKEN_VARIABLE\fR tokens in the array index. .TP \fBTCL_TOKEN_SUB_EXPR\fR -. The token describes one subexpression of an expression (or an entire expression). A subexpression may consist of a value such as an integer literal, variable substitution, or parenthesized subexpression; @@ -334,18 +343,17 @@ If the operator has no operands, the subexpression consists of just the \fBTCL_TOKEN_OPERATOR\fR token. Each operand is described by a \fBTCL_TOKEN_SUB_EXPR\fR token. Otherwise, the subexpression is a value described by one of the token types \fBTCL_TOKEN_WORD\fR, \fBTCL_TOKEN_TEXT\fR, -\fBTCL_TOKEN_BS\fR, \fBTCL_TOKEN_COMMAND\fR, +\fBTCL_TOKEN_BS\fR, \fBTCL_TOKEN_COMMAND\fR, \fBTCL_TOKEN_VARIABLE\fR, and \fBTCL_TOKEN_SUB_EXPR\fR. The \fInumComponents\fR field counts the total number of sub-tokens that make up the subexpression; this includes the sub-tokens for any nested \fBTCL_TOKEN_SUB_EXPR\fR tokens. .TP \fBTCL_TOKEN_OPERATOR\fR -. The token describes one operator of an expression such as \fB&&\fR or \fBhypot\fR. A \fBTCL_TOKEN_OPERATOR\fR token is always preceded by a \fBTCL_TOKEN_SUB_EXPR\fR token that describes the operator and its operands; @@ -373,18 +381,20 @@ is always 0. .PP After \fBTcl_ParseCommand\fR returns, the first token pointed to by the \fItokenPtr\fR field of the Tcl_Parse structure always has type \fBTCL_TOKEN_WORD\fR or -\fBTCL_TOKEN_SIMPLE_WORD\fR or \fBTCL_TOKEN_EXPAND_WORD\fR. +.VS 8.5 +\fBTCL_TOKEN_SIMPLE_WORD\fR or \fBTCL_TOKEN_EXPAND_WORD\fR. It is followed by the sub-tokens that must be concatenated to produce the value of that word. The next token is the \fBTCL_TOKEN_WORD\fR or \fBTCL_TOKEN_SIMPLE_WORD\fR of \fBTCL_TOKEN_EXPAND_WORD\fR token for the second word, followed by sub-tokens for that word, and so on until all \fInumWords\fR have been accounted for. +.VE 8.5 .PP After \fBTcl_ParseExpr\fR returns, the first token pointed to by the \fItokenPtr\fR field of the Tcl_Parse structure always has type \fBTCL_TOKEN_SUB_EXPR\fR. It is followed by the sub-tokens that must be evaluated @@ -447,7 +457,8 @@ There are additional fields in the Tcl_Parse structure after the \fInumTokens\fR field, but these are for the private use of \fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR, \fBTcl_ParseQuotedString\fR, and \fBTcl_ParseVarName\fR; they should not be referenced by code outside of these procedures. + .SH KEYWORDS backslash substitution, braces, command, expression, parse, token, variable substitution Index: doc/PkgRequire.3 ================================================================== --- doc/PkgRequire.3 +++ doc/PkgRequire.3 @@ -1,11 +1,11 @@ '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Tcl_PkgRequire 3 7.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_PkgRequire, Tcl_PkgRequireEx, Tcl_PkgRequireProc, Tcl_PkgPresent, Tcl_PkgPresentEx, Tcl_PkgProvide, Tcl_PkgProvideEx \- package version control @@ -32,11 +32,11 @@ \fBTcl_PkgProvide\fR(\fIinterp, name, version\fR) .sp int \fBTcl_PkgProvideEx\fR(\fIinterp, name, version, clientData\fR) .SH ARGUMENTS -.AS void *clientDataPtr out +.AS ClientData clientDataPtr out .AP Tcl_Interp *interp in Interpreter where package is needed or available. .AP "const char" *name in Name of package. .AP "const char" *version in @@ -46,22 +46,22 @@ Non-zero means that only the particular version specified by \fIversion\fR is acceptable. Zero means that newer versions than \fIversion\fR are also acceptable as long as they have the same major version number as \fIversion\fR. -.AP "const void" *clientData in +.AP ClientData clientData in Arbitrary value to be associated with the package. -.AP void *clientDataPtr out +.AP ClientData *clientDataPtr out Pointer to place to store the value associated with the matching package. It is only changed if the pointer is not NULL and the -function completed successfully. The storage can be any pointer -type with the same size as a void pointer. +function completed successfully. .AP int objc in Number of requirements. .AP Tcl_Obj* objv[] in Array of requirements. .BE + .SH DESCRIPTION .PP These procedures provide C-level interfaces to Tcl's package and version management facilities. .PP @@ -73,12 +73,12 @@ See the documentation for the Tcl commands for details on what these procedures do. .PP If \fBTcl_PkgPresent\fR or \fBTcl_PkgRequire\fR complete successfully they return a pointer to the version string for the version of the package -that is provided in the interpreter (which may be different than -\fIversion\fR); if an error occurs they return NULL and leave an error +that is provided in the interpreter (which may be different than +\fIversion\fR); if an error occurs they return NULL and leave an error message in the interpreter's result. .PP \fBTcl_PkgProvide\fR returns \fBTCL_OK\fR if it completes successfully; if an error occurs it returns \fBTCL_ERROR\fR and leaves an error message in the interpreter's result. @@ -89,9 +89,8 @@ functions. .PP \fBTcl_PkgRequireProc\fR is the form of \fBpackage require\fR handling multiple requirements. The other forms are present for backward compatibility and translate their invocations to this form. + .SH KEYWORDS package, present, provide, require, version -.SH "SEE ALSO" -package(n), Tcl_StaticPackage(3) Index: doc/Preserve.3 ================================================================== --- doc/Preserve.3 +++ doc/Preserve.3 @@ -2,11 +2,11 @@ '\" Copyright (c) 1990 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_Preserve 3 7.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_Preserve, Tcl_Release, Tcl_EventuallyFree \- avoid freeing storage while it is being used @@ -19,16 +19,17 @@ \fBTcl_Release\fR(\fIclientData\fR) .sp \fBTcl_EventuallyFree\fR(\fIclientData, freeProc\fR) .SH ARGUMENTS .AS Tcl_FreeProc clientData -.AP void *clientData in +.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 These three procedures help implement a simple reference count mechanism for managing storage. They are designed to solve a problem having to do with widget deletion, but are also useful in many other @@ -75,25 +76,22 @@ \fBTcl_Release\fR to do the cleanup. .PP All the work of freeing the object is carried out by \fIfreeProc\fR. \fIFreeProc\fR must have arguments and result that match the type \fBTcl_FreeProc\fR: -.PP .CS -typedef void \fBTcl_FreeProc\fR( - char *\fIblockPtr\fR); +typedef void Tcl_FreeProc(char *\fIblockPtr\fR); .CE -.PP The \fIblockPtr\fR argument to \fIfreeProc\fR will be the 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 or another function of the Tcl library, +\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 @@ -102,9 +100,11 @@ are pending on the stack); it will not work efficiently as a mechanism for long-term reference counts. The implementation does not depend in any way on the internal structure of the objects being freed; it keeps the reference counts in a separate structure. + .SH "SEE ALSO" Tcl_Interp, Tcl_Alloc + .SH KEYWORDS free, reference count, storage Index: doc/PrintDbl.3 ================================================================== --- doc/PrintDbl.3 +++ doc/PrintDbl.3 @@ -2,11 +2,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_PrintDouble 3 8.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_PrintDouble \- Convert floating value to string @@ -16,17 +16,21 @@ .sp \fBTcl_PrintDouble\fR(\fIinterp, value, dst\fR) .SH ARGUMENTS .AS Tcl_Interp *interp out .AP Tcl_Interp *interp in -This argument is ignored. +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 @@ -35,12 +39,17 @@ 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 . +.VS 8.5 .PP -The result will have the fewest digits needed to +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. +.VE + .SH KEYWORDS conversion, double-precision, floating-point, string Index: doc/RecEvalObj.3 ================================================================== --- doc/RecEvalObj.3 +++ doc/RecEvalObj.3 @@ -1,11 +1,11 @@ '\" '\" 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_RecordAndEvalObj 3 8.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_RecordAndEvalObj \- save command on history list before evaluating @@ -18,11 +18,11 @@ .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in Tcl interpreter in which to evaluate command. .AP Tcl_Obj *cmdPtr in -Points to a Tcl value containing a command (or sequence of commands) +Points to a Tcl object containing a command (or sequence of commands) to execute. .AP int flags in An OR'ed combination of flag bits. \fBTCL_NO_EVAL\fR means record the command but do not evaluate it. \fBTCL_EVAL_GLOBAL\fR means evaluate the command at global level instead of the current stack level. @@ -29,13 +29,15 @@ .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. +on the history list and then execute it using \fBTcl_EvalObjEx\fR +(or \fBTcl_GlobalEvalObj\fR if the \fBTCL_EVAL_GLOBAL\fR bit is set +in \fIflags\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 +as well as a result object 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 @@ -46,6 +48,6 @@ .SH "SEE ALSO" Tcl_EvalObjEx, Tcl_GetObjResult .SH KEYWORDS -command, event, execute, history, interpreter, value, record +command, event, execute, history, interpreter, object, record Index: doc/RecordEval.3 ================================================================== --- doc/RecordEval.3 +++ doc/RecordEval.3 @@ -2,11 +2,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_RecordAndEval 3 7.4 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_RecordAndEval \- save command on history list before evaluating @@ -42,14 +42,14 @@ allow the user to re-issue recently-invoked commands. If the \fIflags\fR argument contains the \fBTCL_NO_EVAL\fR bit then the command is recorded without being evaluated. .PP Note that \fBTcl_RecordAndEval\fR has been largely replaced by the -value-based procedure \fBTcl_RecordAndEvalObj\fR. -That value-based procedure records and optionally executes -a command held in a Tcl value instead of a string. +object-based procedure \fBTcl_RecordAndEvalObj\fR. +That object-based procedure records and optionally executes +a command held in a Tcl object instead of a string. .SH "SEE ALSO" Tcl_RecordAndEvalObj .SH KEYWORDS command, event, execute, history, interpreter, record Index: doc/RegConfig.3 ================================================================== --- doc/RegConfig.3 +++ doc/RegConfig.3 @@ -24,20 +24,21 @@ registered for. Must not be NULL. .AP "const char" *pkgName in Contains the name of the package registering the embedded configuration as ASCII string. This means that this information is in UTF-8 too. Must not be NULL. -.AP "const Tcl_Config" *configuration in +.AP Tcl_Config *configuration in Refers to an array of Tcl_Config entries containing the information embedded in the binary library. Must not be NULL. The end of the array is signaled by either a key identical to NULL, or a key referring to the empty string. .AP "const char" *valEncoding in Contains the name of the encoding used to store the configuration values as ASCII string. This means that this information is in UTF-8 too. Must not be NULL. .BE + .SH DESCRIPTION .PP The function described here has its base in TIP 59 and provides extensions with support for the embedding of configuration information into their binary library and the generation of a @@ -78,11 +79,11 @@ .IP (1) create a namespace having the provided \fIpkgName\fR, if not yet existing. .IP (2) create the command \fBpkgconfig\fR in that namespace and link it to -the provided information so that the keys from \fIconfiguration\fR and +the provided information so that the keys from _configuration_ and their associated values can be retrieved through calls to \fBpkgconfig\fR. .PP The command \fBpkgconfig\fR will provide two subcommands, \fBlist\fR and \fBget\fR: @@ -99,13 +100,13 @@ .PP The \fBTcl_Config\fR structure contains the following fields: .PP .CS typedef struct Tcl_Config { - const char *\fIkey\fR; - const char *\fIvalue\fR; -} \fBTcl_Config\fR; + const char* key; + const char* value; +} Tcl_Config; .CE .\" No cross references yet. .\" .SH "SEE ALSO" .SH KEYWORDS embedding, configuration, binary library Index: doc/RegExp.3 ================================================================== --- doc/RegExp.3 +++ doc/RegExp.3 @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 1998-1999 Scriptics Corporation '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Tcl_RegExpMatch 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_RegExpMatch, Tcl_RegExpCompile, Tcl_RegExpExec, Tcl_RegExpRange, Tcl_GetRegExpFromObj, Tcl_RegExpMatchObj, Tcl_RegExpExecObj, Tcl_RegExpGetInfo \- Pattern matching with regular expressions @@ -43,16 +43,16 @@ .AS Tcl_RegExpInfo *interp in/out .AP Tcl_Interp *interp in Tcl interpreter to use for error reporting. The interpreter may be NULL if no error reporting is desired. .AP Tcl_Obj *textObj in/out -Refers to the value from which to get the text to search. The -internal representation of the value may be converted to a form that +Refers to the object from which to get the text to search. The +internal representation of the object may be converted to a form that can be efficiently searched. .AP Tcl_Obj *patObj in/out -Refers to the value from which to get a regular expression. The -compiled regular expression is cached in the value. +Refers to the object from which to get a regular expression. The +compiled regular expression is cached in the object. .AP char *text in Text to search for a match with a regular expression. .AP "const char" *pattern in String in the form of a regular expression pattern. .AP Tcl_RegExp regexp in @@ -62,11 +62,11 @@ 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 size_t index in +.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 @@ -78,18 +78,18 @@ 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 size_t offset in +.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 size_t nmatches in +.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 TCL_INDEX_NONE, then +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 @@ -101,19 +101,19 @@ .SH DESCRIPTION .PP \fBTcl_RegExpMatch\fR determines whether its \fIpattern\fR argument matches \fIregexp\fR, where \fIregexp\fR is interpreted as a regular expression using the rules in the \fBre_syntax\fR -reference page. +reference page. If there is a match then \fBTcl_RegExpMatch\fR returns 1. If there is no match then \fBTcl_RegExpMatch\fR returns 0. If an error occurs in the matching process (e.g. \fIpattern\fR is not a valid regular expression) then \fBTcl_RegExpMatch\fR returns \-1 and leaves an error message in the interpreter result. \fBTcl_RegExpMatchObj\fR is similar to \fBTcl_RegExpMatch\fR except it -operates on the Tcl values \fItextObj\fR and \fIpatObj\fR instead of -UTF strings. +operates on the Tcl objects \fItextObj\fR and \fIpatObj\fR instead of +UTF strings. \fBTcl_RegExpMatchObj\fR is generally more efficient than \fBTcl_RegExpMatch\fR, so it is the preferred interface. .PP \fBTcl_RegExpCompile\fR, \fBTcl_RegExpExec\fR, and \fBTcl_RegExpRange\fR provide lower-level access to the regular expression pattern matcher. @@ -162,22 +162,22 @@ \fIindex\fR'th parenthesized subexpression within the pattern. If there is no range corresponding to \fIindex\fR then NULL is stored in \fI*startPtr\fR and \fI*endPtr\fR. .PP \fBTcl_GetRegExpFromObj\fR, \fBTcl_RegExpExecObj\fR, and -\fBTcl_RegExpGetInfo\fR are value interfaces that provide the most +\fBTcl_RegExpGetInfo\fR are object interfaces that provide the most direct control of Henry Spencer's regular expression library. For users that need to modify compilation and execution options directly, it is recommended that you use these interfaces instead of calling the internal regexp functions. These interfaces handle the details of UTF to Unicode translations as well as providing improved performance -through caching in the pattern and string values. +through caching in the pattern and string objects. .PP \fBTcl_GetRegExpFromObj\fR attempts to return a compiled regular -expression from the \fIpatObj\fR. If the value does not already +expression from the \fIpatObj\fR. If the object does not already contain a compiled regular expression it will attempt to create one -from the string in the value and assign it to the internal +from the string in the object and assign it to the internal representation of the \fIpatObj\fR. The return value of this function is of type \fBTcl_RegExp\fR. The return value is a token for this compiled form, which can be used in subsequent calls to \fBTcl_RegExpExecObj\fR or \fBTcl_RegExpGetInfo\fR. If an error occurs while compiling the regular expression then @@ -199,11 +199,11 @@ \fBTCL_REG_EXTENDED\fR Compile extended regular expressions .PQ ERE s . This mode corresponds to the regular expression syntax recognized by Tcl 8.0 and earlier -versions. +versions. .TP \fBTCL_REG_BASIC\fR Compile basic regular expressions .PQ BRE s . This mode corresponds @@ -335,14 +335,14 @@ \fIinfoPtr\fR argument contains a pointer to a structure that is defined as follows: .PP .CS typedef struct Tcl_RegExpInfo { - size_t \fInsubs\fR; - Tcl_RegExpIndices *\fImatches\fR; - size_t \fIextendStart\fR; -} \fBTcl_RegExpInfo\fR; + int \fInsubs\fR; + Tcl_RegExpIndices *\fImatches\fR; + long \fIextendStart\fR; +} Tcl_RegExpInfo; .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 @@ -353,13 +353,13 @@ appear in the pattern. Each element is a structure that is defined as follows: .PP .CS typedef struct Tcl_RegExpIndices { - size_t \fIstart\fR; - size_t \fIend\fR; -} \fBTcl_RegExpIndices\fR; + long \fIstart\fR; + long \fIend\fR; +} Tcl_RegExpIndices; .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 @@ -373,11 +373,11 @@ \fBTCL_REG_CANMATCH\fR flag was used. It indicates the first character in the string where a match could occur. If a match was found, this will be the same as the beginning of the current match. If no match was found, then it indicates the earliest point at which a match might occur if additional text is appended to the string. If it -is no match is possible even with further text, this field will be set +is no match is possible even with further text, this field will be set to \-1. .SH "SEE ALSO" re_syntax(n) .SH KEYWORDS match, pattern, regular expression, string, subexpression, Tcl_RegExpIndices, Tcl_RegExpInfo Index: doc/SaveResult.3 ================================================================== --- doc/SaveResult.3 +++ doc/SaveResult.3 @@ -1,20 +1,17 @@ '\" '\" Copyright (c) 1997 by Sun Microsystems, Inc. '\" Contributions from Don Porter, NIST, 2004. (not subject to US copyright) -'\" Copyright (c) 2018 Nathan Coulter. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_SaveResult 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_SaveInterpState, Tcl_RestoreInterpState, Tcl_DiscardInterpState, -Tcl_SaveResult, Tcl_RestoreResult, Tcl_DiscardResult \- Save and restore the -state of an an interpreter. +Tcl_SaveInterpState, Tcl_RestoreInterpState, Tcl_DiscardInterpState, Tcl_SaveResult, Tcl_RestoreResult, Tcl_DiscardResult \- save and restore an interpreter's state .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_InterpState @@ -31,55 +28,96 @@ .sp \fBTcl_DiscardResult\fR(\fIsavedPtr\fR) .SH ARGUMENTS .AS Tcl_InterpState savedPtr .AP Tcl_Interp *interp in -The interpreter for the operation. +Interpreter for which state should be saved. .AP int status in -The return code for the state. +Return code value to save as part of interpreter state. .AP Tcl_InterpState state in -A token for saved state. +Saved state token to be restored or discarded. .AP Tcl_SavedResult *savedPtr in -A pointer to storage for saved state. +Pointer to location where interpreter result should be saved or restored. .BE + .SH DESCRIPTION .PP -These routines save the state of an interpreter before a call to a routine such -as \fBTcl_Eval\fR, and restore the state afterwards. -.PP -\fBTcl_SaveInterpState\fR saves the parts of \fIinterp\fR that comprise the -result of a script, including the resulting value, the return code passed as -\fIstatus\fR, and any options such as \fB\-errorinfo\fR and \fB\-errorcode\fR. -It returns a token for the saved state. The interpreter result is not reset -and no interpreter state is changed. -.PP -\fBTcl_RestoreInterpState\fR restores the state indicated by \fIstate\fR and -returns the \fIstatus\fR originally passed in the corresponding call to -\fBTcl_SaveInterpState\fR. -.PP -If a saved state is not restored, \fBTcl_DiscardInterpState\fR must be called -to release it. A token used to discard or restore state must not be used -again. -.PP -\fBTcl_SaveResult\fR, \fBTcl_RestoreResult\fR, and \fBTcl_DiscardResult\fR are -deprecated. Instead use \fBTcl_SaveInterpState\fR, -\fBTcl_RestoreInterpState\fR, and \fBTcl_DiscardInterpState\fR, which are more -capable. -.PP -\fBTcl_SaveResult\fR moves the result of \fIinterp\fR to the location -\fIstatePtr\fR points to and returns the interpreter result to its initial -state. It does not save options such as \fB\-errorcode\fR or -\fB\-errorinfo\fR. -.PP -\fBTcl_RestoreResult\fR clears any existing result or error in \fIinterp\fR and -moves the result from \fIstatePtr\fR back to \fIinterp\fR. \fIstatePtr\fR is -then in an undefined state and must not be used until passed again to -\fBTcl_SaveResult\fR. -.PP -\fBTcl_DiscardResult\fR releases the state stored at \fBstatePtr\fR, which is -then in an undefined state and must not be used until passed again to -\fBTcl_SaveResult\fR. -.PP -If a saved result is not restored, \fBTcl_DiscardResult\fR must be called to -release it. +.VS 8.5 +These routines allows a C procedure to take a snapshot of the current +state of an interpreter so that it can be restored after a call +to \fBTcl_Eval\fR or some other routine that modifies the interpreter +state. There are two triplets of routines meant to work together. +.PP +The first triplet stores the snapshot of interpreter state in +an opaque token returned by \fBTcl_SaveInterpState\fR. That token +value may then be passed back to one of \fBTcl_RestoreInterpState\fR +or \fBTcl_DiscardInterpState\fR, depending on whether the interp +state is to be restored. So long as one of the latter two routines +is called, Tcl will take care of memory management. +.PP +The second triplet stores the snapshot of only the interpreter +result (not its complete state) in memory allocated by the caller. +These routines are passed a pointer to \fBTcl_SavedResult\fR +that is used to store enough information to restore the interpreter result. +\fBTcl_SavedResult\fR can be allocated on the stack of the calling +procedure. These routines do not save the state of any error +information in the interpreter (e.g. the \fB\-errorcode\fR or +\fB\-errorinfo\fR return options, when an error is in progress). +.PP +Because the routines \fBTcl_SaveInterpState\fR, +\fBTcl_RestoreInterpState\fR, and \fBTcl_DiscardInterpState\fR perform +a superset of the functions provided by the other routines, +any new code should only make use of the more powerful routines. +The older, weaker routines \fBTcl_SaveResult\fR, \fBTcl_RestoreResult\fR, +and \fBTcl_DiscardResult\fR continue to exist only for the sake +of existing programs that may already be using them. +.PP +\fBTcl_SaveInterpState\fR takes a snapshot of those portions of +interpreter state that make up the full result of script evaluation. +This include the interpreter result, the return code (passed in +as the \fIstatus\fR argument, and any return options, including +\fB\-errorinfo\fR and \fB\-errorcode\fR when an error is in progress. +This snapshot is returned as an opaque token of type \fBTcl_InterpState\fR. +The call to \fBTcl_SaveInterpState\fR does not itself change the +state of the interpreter. Unlike \fBTcl_SaveResult\fR, it does +not reset the interpreter. +.PP +\fBTcl_RestoreInterpState\fR accepts a \fBTcl_InterpState\fR token +previously returned by \fBTcl_SaveInterpState\fR and restores the +state of the interp to the state held in that snapshot. The return +value of \fBTcl_RestoreInterpState\fR is the status value originally +passed to \fBTcl_SaveInterpState\fR when the snapshot token was +created. +.PP +\fBTcl_DiscardInterpState\fR is called to release a \fBTcl_InterpState\fR +token previously returned by \fBTcl_SaveInterpState\fR when that +snapshot is not to be restored to an interp. +.PP +The \fBTcl_InterpState\fR token returned by \fBTcl_SaveInterpState\fR +must eventually be passed to either \fBTcl_RestoreInterpState\fR +or \fBTcl_DiscardInterpState\fR to avoid a memory leak. Once +the \fBTcl_InterpState\fR token is passed to one of them, the +token is no longer valid and should not be used anymore. +.VE 8.5 +.PP +\fBTcl_SaveResult\fR moves the string and object results +of \fIinterp\fR into the location specified by \fIstatePtr\fR. +\fBTcl_SaveResult\fR clears the result for \fIinterp\fR and +leaves the result in its normal empty initialized state. +.PP +\fBTcl_RestoreResult\fR moves the string and object results from +\fIstatePtr\fR back into \fIinterp\fR. Any result or error that was +already in the interpreter will be cleared. The \fIstatePtr\fR is left +in an uninitialized state and cannot be used until another call to +\fBTcl_SaveResult\fR. +.PP +\fBTcl_DiscardResult\fR releases the saved interpreter state +stored at \fBstatePtr\fR. The state structure is left in an +uninitialized state and cannot be used until another call to +\fBTcl_SaveResult\fR. +.PP +Once \fBTcl_SaveResult\fR is called to save the interpreter +result, either \fBTcl_RestoreResult\fR or +\fBTcl_DiscardResult\fR must be called to properly clean up the +memory associated with the saved state. .SH KEYWORDS result, state, interp Index: doc/SetChanErr.3 ================================================================== --- doc/SetChanErr.3 +++ doc/SetChanErr.3 @@ -31,106 +31,123 @@ .AP Tcl_Channel chan in Refers to the Tcl channel whose bypass area is accessed. .AP Tcl_Interp* interp in Refers to the Tcl interpreter whose bypass area is accessed. .AP Tcl_Obj* msg in -Error message put into a bypass area. A list of return options and values, -followed by a string message. Both message and the option/value information -are optional. +Error message put into a bypass area. A list of return options and +values, followed by a string message. Both message and the +option/value information are optional. .AP Tcl_Obj** msgPtr out -Reference to a place where the message stored in the accessed bypass area can -be stored in. +Reference to a place where the message stored in the accessed bypass +area can be stored in. .BE .SH DESCRIPTION .PP -The current definition of a Tcl channel driver does not permit the direct -return of arbitrary error messages, except for the setting and retrieval of -channel options. All other functions are restricted to POSIX error codes. -.PP -The functions described here overcome this limitation. Channel drivers are -allowed to use \fBTcl_SetChannelError\fR and \fBTcl_SetChannelErrorInterp\fR -to place arbitrary error messages in \fBbypass areas\fR defined for channels -and interpreters. And the generic I/O layer uses \fBTcl_GetChannelError\fR and -\fBTcl_GetChannelErrorInterp\fR to look for messages in the bypass areas and -arrange for their return as errors. The POSIX error codes set by a driver are -used now if and only if no messages are present. -.PP -\fBTcl_SetChannelError\fR stores error information in the bypass area of the -specified channel. The number of references to the \fBmsg\fR value goes up by -one. Previously stored information will be discarded, by releasing the -reference held by the channel. The channel reference must not be NULL. -.PP -\fBTcl_SetChannelErrorInterp\fR stores error information in the bypass area of -the specified interpreter. The number of references to the \fBmsg\fR value -goes up by one. Previously stored information will be discarded, by releasing -the reference held by the interpreter. The interpreter reference must not be -NULL. -.PP -\fBTcl_GetChannelError\fR places either the error message held in the bypass -area of the specified channel into \fImsgPtr\fR, or NULL; and resets the -bypass, that is, after an invocation all following invocations will return -NULL, until an intervening invocation of \fBTcl_SetChannelError\fR with a -non-NULL message. The \fImsgPtr\fR must not be NULL. The reference count of -the message is not touched. The reference previously held by the channel is -now held by the caller of the function and it is its responsibility to release -that reference when it is done with the value. -.PP -\fBTcl_GetChannelErrorInterp\fR places either the error message held in the -bypass area of the specified interpreter into \fImsgPtr\fR, or NULL; and -resets the bypass, that is, after an invocation all following invocations will -return NULL, until an intervening invocation of -\fBTcl_SetChannelErrorInterp\fR with a non-NULL message. The \fImsgPtr\fR must -not be NULL. The reference count of the message is not touched. The reference -previously held by the interpreter is now held by the caller of the function -and it is its responsibility to release that reference when it is done with -the value. -.PP -Which functions of a channel driver are allowed to use which bypass function -is listed below, as is which functions of the public channel API may leave a -messages in the bypass areas. +The current definition of a Tcl channel driver does not permit the +direct return of arbitrary error messages, except for the setting and +retrieval of channel options. All other functions are restricted to +POSIX error codes. +.PP +The functions described here overcome this limitation. Channel drivers +are allowed to use \fBTcl_SetChannelError\fR and +\fBTcl_SetChannelErrorInterp\fR to place arbitrary error messages in +\fBbypass areas\fI defined for channels and interpreters. And the +generic I/O layer uses \fBTcl_GetChannelError\fR and +\fBTcl_GetChannelErrorInterp\fR to look for messages in the bypass +areas and arrange for their return as errors. The posix error codes +set by a driver are used now if and only if no messages are present. +.PP +\fBTcl_SetChannelError\fR stores error information in the bypass area +of the specified channel. The number of references to the \fBmsg\fR +object goes up by one. Previously stored information will be +discarded, by releasing the reference held by the channel. The channel +reference must not be NULL. +.PP +\fBTcl_SetChannelErrorInterp\fR stores error information in the bypass +area of the specified interpreter. The number of references to the +\fBmsg\fR object goes up by one. Previously stored information will be +discarded, by releasing the reference held by the interpreter. The +interpreter reference must not be NULL. +.PP +\fBTcl_GetChannelError\fR places either the error message held in the +bypass area of the specified channel into \fImsgPtr\fR, or NULL; and +resets the bypass. I.e. after an invocation all following invocations +will return NULL, until an intervening invocation of +\fBTcl_SetChannelError\fR with a non-NULL message. The \fImsgPtr\fR +must not be NULL. The reference count of the message is not touched. +The reference previously held by the channel is now held by the caller +of the function and it is its responsibility to release that reference +when it is done with the object. +.PP +\fBTcl_GetChannelErrorInterp\fR places either the error message held +in the bypass area of the specified interpreter into \fImsgPtr\fR, or +NULL; and resets the bypass. I.e. after an invocation all following +invocations will return NULL, until an intervening invocation of +\fBTcl_SetChannelErrorInterp\fR with a non-NULL message. The +\fImsgPtr\fR must not be NULL. The reference count of the message is +not touched. The reference previously held by the interpreter is now +held by the caller of the function and it is its responsibility to +release that reference when it is done with the object. +.PP +Which functions of a channel driver are allowed to use which bypass +function is listed below, as is which functions of the public channel +API may leave a messages in the bypass areas. +.PP +.IP \fBTcl_DriverCloseProc\fR +May use \fBTcl_SetChannelErrorInterp\fR, and only this function. .IP \fBTcl_DriverInputProc\fR May use \fBTcl_SetChannelError\fR, and only this function. .IP \fBTcl_DriverOutputProc\fR +May use \fBTcl_SetChannelError\fR, and only this function. +.IP \fBTcl_DriverSeekProc\fR May use \fBTcl_SetChannelError\fR, and only this function. .IP \fBTcl_DriverWideSeekProc\fR May use \fBTcl_SetChannelError\fR, and only this function. .IP \fBTcl_DriverSetOptionProc\fR -Has already the ability to pass arbitrary error messages. Must \fInot\fR use -any of the new functions. +Has already the ability to pass arbitrary error messages. Must +\fBnot\fR use any of the new functions. .IP \fBTcl_DriverGetOptionProc\fR Has already the ability to pass arbitrary error messages. Must -\fInot\fR use any of the new functions. +\fBnot\fR use any of the new functions. .IP \fBTcl_DriverWatchProc\fR -Must \fInot\fR use any of the new functions. Is internally called and has no -ability to return any type of error whatsoever. +Must \fBnot\fR use any of the new functions. Is internally called and +has no ability to return any type of error whatsoever. .IP \fBTcl_DriverBlockModeProc\fR May use \fBTcl_SetChannelError\fR, and only this function. .IP \fBTcl_DriverGetHandleProc\fR -Must \fInot\fR use any of the new functions. It is only a low-level function, -and not used by Tcl commands. +Must \fBnot\fR use any of the new functions. It is only a low-level +function, and not used by Tcl commands. .IP \fBTcl_DriverHandlerProc\fR -Must \fInot\fR use any of the new functions. Is internally called and has no -ability to return any type of error whatsoever. -.PP -Given the information above the following public functions of the Tcl C API -are affected by these changes; when these functions are called, the channel -may now contain a stored arbitrary error message requiring processing by the -caller. -.DS -.ta 1.9i 4i -\fBTcl_Flush\fR \fBTcl_GetsObj\fR \fBTcl_Gets\fR -\fBTcl_ReadChars\fR \fBTcl_ReadRaw\fR \fBTcl_Read\fR -\fBTcl_Seek\fR \fBTcl_StackChannel\fR \fBTcl_Tell\fR -\fBTcl_WriteChars\fR \fBTcl_WriteObj\fR \fBTcl_WriteRaw\fR -\fBTcl_Write\fR -.DE -.PP -All other API functions are unchanged. In particular, the functions below +Must \fBnot\fR use any of the new functions. Is internally called and +has no ability to return any type of error whatsoever. +.PP +Given the information above the following public functions of the Tcl +C API are affected by these changes. I.e. when these functions are +called the channel may now contain a stored arbitrary error message +requiring processing by the caller. +.PP +.IP \fBTcl_StackChannel\fR +.IP \fBTcl_Seek\fR +.IP \fBTcl_Tell\fR +.IP \fBTcl_ReadRaw\fR +.IP \fBTcl_Read\fR +.IP \fBTcl_ReadChars\fR +.IP \fBTcl_Gets\fR +.IP \fBTcl_GetsObj\fR +.IP \fBTcl_Flush\fR +.IP \fBTcl_WriteRaw\fR +.IP \fBTcl_WriteObj\fR +.IP \fBTcl_Write\fR +.IP \fBTcl_WriteChars\fR +.PP +All other API functions are unchanged. Especially the functions below leave all their error information in the interpreter result. -.DS -.ta 1.9i 4i -\fBTcl_Close\fR \fBTcl_UnstackChannel\fR \fBTcl_UnregisterChannel\fR -.DE +.PP +.IP \fBTcl_Close\fR +.IP \fBTcl_UnregisterChannel\fR +.IP \fBTcl_UnstackChannel\fR + .SH "SEE ALSO" Tcl_Close(3), Tcl_OpenFileChannel(3), Tcl_SetErrno(3) + .SH KEYWORDS channel driver, error messages, channel type Index: doc/SetErrno.3 ================================================================== --- doc/SetErrno.3 +++ doc/SetErrno.3 @@ -1,11 +1,11 @@ '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Tcl_SetErrno 3 8.3 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_SetErrno, Tcl_GetErrno, Tcl_ErrnoId, Tcl_ErrnoMsg \- manipulate errno to store and retrieve error codes Index: doc/SetRecLmt.3 ================================================================== --- doc/SetRecLmt.3 +++ doc/SetRecLmt.3 @@ -2,11 +2,11 @@ '\" 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_SetRecursionLimit 3 7.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_SetRecursionLimit \- set maximum allowable nesting depth in interpreter @@ -27,11 +27,11 @@ .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_EvalEx\fR. +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 Index: doc/SetResult.3 ================================================================== --- doc/SetResult.3 +++ doc/SetResult.3 @@ -2,16 +2,16 @@ '\" 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" +'\" +.TH Tcl_SetResult 3 8.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_SetObjResult, Tcl_GetObjResult, Tcl_SetResult, Tcl_GetStringResult, Tcl_AppendResult, Tcl_AppendElement, Tcl_ResetResult, Tcl_TransferResult \- manipulate Tcl result +Tcl_SetObjResult, Tcl_GetObjResult, Tcl_SetResult, Tcl_GetStringResult, Tcl_AppendResult, Tcl_AppendResultVA, Tcl_AppendElement, Tcl_ResetResult, Tcl_FreeResult \- manipulate Tcl result .SH SYNOPSIS .nf \fB#include \fR .sp \fBTcl_SetObjResult\fR(\fIinterp, objPtr\fR) @@ -24,71 +24,67 @@ const char * \fBTcl_GetStringResult\fR(\fIinterp\fR) .sp \fBTcl_AppendResult\fR(\fIinterp, result, result, ... , \fB(char *) NULL\fR) .sp -\fBTcl_ResetResult\fR(\fIinterp\fR) -.sp -\fBTcl_TransferResult\fR(\fIsourceInterp, code, targetInterp\fR) +\fBTcl_AppendResultVA\fR(\fIinterp, argList\fR) .sp \fBTcl_AppendElement\fR(\fIinterp, element\fR) +.sp +\fBTcl_ResetResult\fR(\fIinterp\fR) +.sp +\fBTcl_FreeResult\fR(\fIinterp\fR) .SH ARGUMENTS -.AS Tcl_FreeProc sourceInterp out +.AS Tcl_FreeProc freeProc out .AP Tcl_Interp *interp out Interpreter whose result is to be modified or read. .AP Tcl_Obj *objPtr in -Tcl value to become result for \fIinterp\fR. +Object value to become result for \fIinterp\fR. .AP char *result in String value to become result for \fIinterp\fR or to be appended to the existing result. -.AP "const char" *element in +.AP char *element in String value to append as a list element to the existing result of \fIinterp\fR. .AP Tcl_FreeProc *freeProc in Address of procedure to call to release storage at \fIresult\fR, or \fBTCL_STATIC\fR, \fBTCL_DYNAMIC\fR, or \fBTCL_VOLATILE\fR. .AP 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. +The interpreter result may be either a Tcl object or a string. For example, \fBTcl_SetObjResult\fR and \fBTcl_SetResult\fR -set the interpreter result to, respectively, a value and a string. +set the interpreter result to, respectively, an object and a string. Similarly, \fBTcl_GetObjResult\fR and \fBTcl_GetStringResult\fR -return the interpreter result as a value and as a string. -The procedures always keep the string and value forms +return the interpreter result as an object and as a string. +The procedures always keep the string and object forms of the interpreter result consistent. For example, if \fBTcl_SetObjResult\fR is called to set -the result to a value, +the result to an object, then \fBTcl_GetStringResult\fR is called, -it will return the value's string representation. +it will return the object's string value. .PP \fBTcl_SetObjResult\fR arranges for \fIobjPtr\fR to be the result for \fIinterp\fR, replacing any existing result. -The result is left pointing to the value +The result is left pointing to the object referenced by \fIobjPtr\fR. \fIobjPtr\fR's reference count is incremented since there is now a new reference to it from \fIinterp\fR. -The reference count for any old result value -is decremented and the old result value is freed if no +The reference count for any old result object +is decremented and the old result object is freed if no references to it remain. .PP -\fBTcl_GetObjResult\fR returns the result for \fIinterp\fR as a value. -The value's reference count is not incremented; -if the caller needs to retain a long-term pointer to the value +\fBTcl_GetObjResult\fR returns the result for \fIinterp\fR as an object. +The object's reference count is not incremented; +if the caller needs to retain a long-term pointer to the object they should use \fBTcl_IncrRefCount\fR to increment its reference count in order to keep it from being freed too early or accidentally changed. .PP \fBTcl_SetResult\fR arranges for \fIresult\fR to be the result for the current Tcl @@ -100,23 +96,23 @@ If \fIresult\fR is \fBNULL\fR, then \fIfreeProc\fR is ignored and \fBTcl_SetResult\fR re-initializes \fIinterp\fR's result to point to an empty string. .PP \fBTcl_GetStringResult\fR returns the result for \fIinterp\fR as a string. -If the result was set to a value by a \fBTcl_SetObjResult\fR call, -the value form will be converted to a string and returned. -If the value's string representation contains null bytes, +If the result was set to an object by a \fBTcl_SetObjResult\fR call, +the object form will be converted to a string and returned. +If the object's string representation contains null bytes, this conversion will lose information. For this reason, programmers are encouraged to -write their code to use the new value API procedures +write their code to use the new object API procedures and to call \fBTcl_GetObjResult\fR instead. .PP \fBTcl_ResetResult\fR clears the result for \fIinterp\fR and leaves the result in its normal empty initialized state. -If the result is a value, +If the result is an object, its reference count is decremented and the result is left -pointing to an unshared value representing an empty string. +pointing to an unshared object representing an empty string. If the result is a dynamically allocated string, its memory is free*d and the result is left as a empty string. \fBTcl_ResetResult\fR also clears the error state managed by \fBTcl_AddErrorInfo\fR, \fBTcl_AddObjErrorInfo\fR, and \fBTcl_SetErrorCode\fR. @@ -137,25 +133,18 @@ \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_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" +\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. +.SH "OLD STRING PROCEDURES" .PP -Use of the following procedures is deprecated +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 +that manipulate the result as an object can be significantly more efficient. .PP \fBTcl_AppendElement\fR is similar to \fBTcl_AppendResult\fR in that it allows results to be built up in pieces. However, \fBTcl_AppendElement\fR takes only a single \fIelement\fR @@ -173,13 +162,31 @@ single character .QW { , or ends in the characters .QW " {" ) then no space is added. +.PP +\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 "DIRECT ACCESS TO INTERP->RESULT IS DEPRECATED" +.PP +It used to be legal for programs to +directly read and write \fIinterp->result\fR +to manipulate the interpreter result. +Direct access to \fIinterp->result\fR is now strongly deprecated +because it can make the result's string and object forms inconsistent. +Programs should always read the result +using the procedures \fBTcl_GetObjResult\fR or \fBTcl_GetStringResult\fR, +and write the result using \fBTcl_SetObjResult\fR or \fBTcl_SetResult\fR. .SH "THE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT" .PP -\fBTcl_SetResult\fR's \fIfreeProc\fR argument specifies how +\fBTcl_SetResult\fR's \fIfreeProc\fR argument specifies how the Tcl system is to manage the storage for the \fIresult\fR argument. If \fBTcl_SetResult\fR or \fBTcl_SetObjResult\fR are called at a time when \fIinterp\fR holds a string result, they do whatever is necessary to dispose of the old string result (see the \fBTcl_Interp\fR manual entry for details on this). @@ -204,18 +211,14 @@ of a procedure that Tcl should call to free the string. This allows applications to use non-standard storage allocators. When Tcl no longer needs the storage for the string, it will call \fIfreeProc\fR. \fIFreeProc\fR should have arguments and result that match the type \fBTcl_FreeProc\fR: -.PP .CS -typedef void \fBTcl_FreeProc\fR( - char *\fIblockPtr\fR); +typedef void Tcl_FreeProc(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 +Tcl_AddErrorInfo, Tcl_CreateObjCommand, Tcl_SetErrorCode, Tcl_Interp .SH KEYWORDS -append, command, element, list, value, result, return value, interpreter +append, command, element, list, object, result, return value, interpreter Index: doc/SetVar.3 ================================================================== --- doc/SetVar.3 +++ doc/SetVar.3 @@ -2,11 +2,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_SetVar 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_SetVar2Ex, Tcl_SetVar, Tcl_SetVar2, Tcl_ObjSetVar2, Tcl_GetVar2Ex, Tcl_GetVar, Tcl_GetVar2, Tcl_ObjGetVar2, Tcl_UnsetVar, Tcl_UnsetVar2 \- manipulate Tcl variables @@ -55,11 +55,11 @@ to specify a variable in a particular namespace. .AP "const char" *name2 in If non-NULL, gives name of element within array; in this case \fIname1\fR must refer to an array variable. .AP Tcl_Obj *newValuePtr in -Points to a Tcl value containing the new value for the variable. +Points to a Tcl object containing the new value for the variable. .AP int flags in OR-ed combination of bits providing additional information. See below for valid values. .AP "const char" *varName in Name of variable. @@ -69,26 +69,26 @@ an array. .AP "const char" *newValue in New value for variable, specified as a null-terminated string. A copy of this value is stored in the variable. .AP Tcl_Obj *part1Ptr in -Points to a Tcl value containing the variable's name. +Points to a Tcl object containing the variable's name. The name may include a series of \fB::\fR namespace qualifiers to specify a variable in a particular namespace. May refer to a scalar variable or an element of an array variable. .AP Tcl_Obj *part2Ptr in -If non-NULL, points to a value containing the name of an element +If non-NULL, points to an object containing the name of an element within an array and \fIpart1Ptr\fR must refer to an array variable. .BE .SH DESCRIPTION .PP These procedures are used to create, modify, read, and delete Tcl variables from C code. .PP \fBTcl_SetVar2Ex\fR, \fBTcl_SetVar\fR, \fBTcl_SetVar2\fR, and -\fBTcl_ObjSetVar2\fR +\fBTcl_ObjSetVar2\fR will create a new variable or modify an existing one. These procedures set the given variable to the value given by \fInewValuePtr\fR or \fInewValue\fR and return a pointer to the variable's new value, which is stored in Tcl's variable structure. @@ -244,6 +244,6 @@ .SH "SEE ALSO" Tcl_GetObjResult, Tcl_GetStringResult, Tcl_TraceVar .SH KEYWORDS -array, get variable, interpreter, scalar, set, unset, value, variable +array, get variable, interpreter, object, scalar, set, unset, variable Index: doc/Signal.3 ================================================================== --- doc/Signal.3 +++ doc/Signal.3 @@ -1,11 +1,11 @@ '\" '\" Copyright (c) 2001 ActiveState Tool Corp. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Tcl_SignalId 3 8.3 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_SignalId, Tcl_SignalMsg \- Convert signal codes Index: doc/Sleep.3 ================================================================== --- doc/Sleep.3 +++ doc/Sleep.3 @@ -2,11 +2,11 @@ '\" Copyright (c) 1990 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_Sleep 3 7.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_Sleep \- delay execution for a given number of milliseconds Index: doc/SplitList.3 ================================================================== --- doc/SplitList.3 +++ doc/SplitList.3 @@ -2,11 +2,11 @@ '\" 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_SplitList 3 8.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_SplitList, Tcl_Merge, Tcl_ScanElement, Tcl_ConvertElement, Tcl_ScanCountedElement, Tcl_ConvertCountedElement \- manipulate Tcl lists @@ -18,20 +18,20 @@ \fBTcl_SplitList\fR(\fIinterp, list, argcPtr, argvPtr\fR) .sp char * \fBTcl_Merge\fR(\fIargc, argv\fR) .sp -size_t +int \fBTcl_ScanElement\fR(\fIsrc, flagsPtr\fR) .sp -size_t +int \fBTcl_ScanCountedElement\fR(\fIsrc, length, flagsPtr\fR) .sp -size_t +int \fBTcl_ConvertElement\fR(\fIsrc, dst, flags\fR) .sp -size_t +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 @@ -53,20 +53,21 @@ .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 size_t length in +.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 with \fBTCL_DONT_USE_BRACES\fR. .BE + .SH DESCRIPTION .PP These procedures may be used to disassemble and reassemble Tcl lists. \fBTcl_SplitList\fR breaks a list up into its constituent elements, returning an array of pointers to the elements using @@ -77,22 +78,19 @@ addition to the array of pointers, it also holds copies of all the list elements. It is the caller's responsibility to free up all of this storage. For example, suppose that you have called \fBTcl_SplitList\fR with the following code: -.PP .CS int argc, code; char *string; char **argv; \&... -code = \fBTcl_SplitList\fR(interp, string, &argc, &argv); +code = Tcl_SplitList(interp, string, &argc, &argv); .CE -.PP Then you should eventually free the storage with a call like the following: -.PP .CS Tcl_Free((char *) argv); .CE .PP \fBTcl_SplitList\fR normally returns \fBTCL_OK\fR, which means the list was @@ -164,10 +162,11 @@ special situations, such as when \fBTcl_ConvertElement\fR is being used to generate a portion of an argument for a Tcl command. In this case, surrounding \fIsrc\fR with curly braces would cause the command not to be parsed correctly. .PP +.VS 8.5 By default, \fBTcl_ConvertElement\fR will use quoting in its output to be sure the first character of an element is not the hash character .PQ # . This is to be sure the first element of any list @@ -175,14 +174,14 @@ When a list element is not the first element of a list, this quoting is not necessary. When the caller can be sure that the element is not the first element of a list, it can disable quoting of the leading hash character by OR-ing the flag value returned by \fBTcl_ScanElement\fR with \fBTCL_DONT_QUOTE_HASH\fR. +.VE 8.5 .PP \fBTcl_ScanCountedElement\fR and \fBTcl_ConvertCountedElement\fR are the same as \fBTcl_ScanElement\fR and \fBTcl_ConvertElement\fR, except the length of string \fIsrc\fR is specified by the \fIlength\fR argument, and the string may contain embedded nulls. -.SH "SEE ALSO" -Tcl_ListObjGetElements(3) + .SH KEYWORDS backslash, convert, element, list, merge, split, strings Index: doc/SplitPath.3 ================================================================== --- doc/SplitPath.3 +++ doc/SplitPath.3 @@ -1,11 +1,11 @@ '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Tcl_SplitPath 3 7.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_SplitPath, Tcl_JoinPath, Tcl_GetPathType \- manipulate platform-dependent file paths @@ -41,11 +41,11 @@ \fBTcl_JoinPath\fR will be appended. .BE .SH DESCRIPTION .PP -These procedures have been superseded by the Tcl-value-aware procedures in +These procedures have been superceded by the objectified procedures in the \fBFileSystem\fR man page, which are more efficient. .PP These procedures may be used to disassemble and reassemble file paths in a platform independent manner: they provide C-level access to the same functionality as the \fBfile split\fR, \fBfile join\fR, and @@ -57,22 +57,19 @@ dynamically allocated; in addition to the array of pointers, it also holds copies of all the path elements. It is the caller's responsibility to free all of this storage. For example, suppose that you have called \fBTcl_SplitPath\fR with the following code: -.PP .CS int argc; char *path; char **argv; \&... Tcl_SplitPath(string, &argc, &argv); .CE -.PP Then you should eventually free the storage with a call like the following: -.PP .CS Tcl_Free((char *) argv); .CE .PP \fBTcl_JoinPath\fR is the inverse of \fBTcl_SplitPath\fR: it takes a Index: doc/StaticPkg.3 ================================================================== --- doc/StaticPkg.3 +++ doc/StaticPkg.3 @@ -1,11 +1,11 @@ '\" '\" 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_StaticPackage 3 7.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_StaticPackage \- make a statically linked package available via the 'load' command @@ -27,13 +27,14 @@ .AP Tcl_PackageInitProc *initProc in Procedure to invoke to incorporate this package into a trusted interpreter. .AP Tcl_PackageInitProc *safeInitProc in Procedure to call to incorporate this package into a safe interpreter -(one that will execute untrusted scripts). NULL means the package +(one that will execute untrusted scripts). NULL means the package cannot be used in safe interpreters. .BE + .SH DESCRIPTION .PP This procedure may be invoked to announce that a package has been linked statically with a Tcl application and, optionally, that it has already been loaded into an interpreter. @@ -49,25 +50,18 @@ an interpreter, one of \fIinitProc\fR and \fIsafeInitProc\fR will be invoked, depending on whether the target interpreter is safe or not. \fIinitProc\fR and \fIsafeInitProc\fR must both match the following prototype: -.PP .CS -typedef int \fBTcl_PackageInitProc\fR( - Tcl_Interp *\fIinterp\fR); +typedef int Tcl_PackageInitProc(Tcl_Interp *\fIinterp\fR); .CE -.PP The \fIinterp\fR argument identifies the interpreter in which the package 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 safely used by stub-enabled extensions, -so its symbol is not included in the stub table. + .SH KEYWORDS initialization procedure, package, static linking -.SH "SEE ALSO" -load(n), package(n), Tcl_PkgRequire(3) Index: doc/StdChannels.3 ================================================================== --- doc/StdChannels.3 +++ doc/StdChannels.3 @@ -1,11 +1,11 @@ '\" '\" Copyright (c) 2001 by ActiveState Corporation '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH "Standard Channels" 3 7.5 Tcl "Tcl Library Procedures" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME Index: doc/StrMatch.3 ================================================================== --- doc/StrMatch.3 +++ doc/StrMatch.3 @@ -2,11 +2,11 @@ '\" 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_StringMatch 3 8.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_StringMatch, Tcl_StringCaseMatch \- test whether a string matches a pattern Index: doc/StringObj.3 ================================================================== --- doc/StringObj.3 +++ doc/StringObj.3 @@ -1,16 +1,16 @@ '\" '\" 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_AppendLimitedToObj, Tcl_Format, Tcl_AppendFormatToObj, Tcl_ObjPrintf, Tcl_AppendPrintfToObj, Tcl_SetObjLength, Tcl_AttemptSetObjLength, Tcl_ConcatObj \- manipulate Tcl values as strings +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 objects as strings .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_Obj * @@ -35,11 +35,11 @@ \fBTcl_GetUnicodeFromObj\fR(\fIobjPtr, lengthPtr\fR) .sp Tcl_UniChar * \fBTcl_GetUnicode\fR(\fIobjPtr\fR) .sp -int +Tcl_UniChar \fBTcl_GetUniChar\fR(\fIobjPtr, index\fR) .sp int \fBTcl_GetCharLength\fR(\fIobjPtr\fR) .sp @@ -56,10 +56,14 @@ \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) +.VS 8.5 +.sp void \fBTcl_AppendLimitedToObj\fR(\fIobjPtr, bytes, length, limit, ellipsis\fR) .sp Tcl_Obj * \fBTcl_Format\fR(\fIinterp, format, objc, objv\fR) @@ -68,12 +72,13 @@ \fBTcl_AppendFormatToObj\fR(\fIinterp, objPtr, format, objc, objv\fR) .sp Tcl_Obj * \fBTcl_ObjPrintf\fR(\fIformat, ...\fR) .sp -void +int \fBTcl_AppendPrintfToObj\fR(\fIobjPtr, format, ...\fR) +.VE 8.5 .sp void \fBTcl_SetObjLength\fR(\fIobjPtr, newLength\fR) .sp int @@ -83,101 +88,100 @@ \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. +used to set or append to a string object. This byte array may contain embedded null characters -unless \fInumChars\fR is TCL_INDEX_NONE. (Applications needing null bytes -should represent them as the two-byte sequence \fI\e300\e200\fR, use +unless \fInumChars\fR is negative. (Applications needing null bytes +should represent them as the two-byte sequence \fI\e700\e600\fR, use \fBTcl_ExternalToUtf\fR to convert, or \fBTcl_NewByteArrayObj\fR if the string is a collection of uninterpreted bytes.) -.AP size_t length in +.AP int length in The number of bytes to copy from \fIbytes\fR when -initializing, setting, or appending to a string value. -If TCL_INDEX_NONE, all bytes up to the first null are used. +initializing, setting, or appending to a string object. +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. +used to set or append to a string object. This byte array may contain embedded null characters unless \fInumChars\fR is negative. -.AP size_t numChars in +.AP int numChars in The number of Unicode characters to copy from \fIunicode\fR when -initializing, setting, or appending to a string value. -If TCL_INDEX_NONE, all characters up to the first null character are used. -.AP size_t index in +initializing, setting, or appending to a string object. +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 size_t first in +.AP int first in The index of the first Unicode character in the Unicode range to be -returned as a new value. -.AP size_t last in +returned as a new object. +.AP int last in The index of the last Unicode character in the Unicode range to be -returned as a new value. +returned as a new object. .AP Tcl_Obj *objPtr in/out -Points to a value to manipulate. +Points to an object to manipulate. .AP Tcl_Obj *appendObjPtr in -The value to append to \fIobjPtr\fR in \fBTcl_AppendObjToObj\fR. +The object 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. +the length of an object'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 +An argument list which must have been initialised using \fBva_start\fR, and cleared using \fBva_end\fR. -.AP size_t limit in +.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. +If NULL is passed then the suffix "..." 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 size_t newLength in +The array of objects 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 +The procedures described in this manual entry allow Tcl objects to be manipulated as string values. They use the internal representation -of the value to store additional information to make the string +of the object to store additional information to make the string manipulations more efficient. In particular, they make a series of append operations efficient by allocating extra storage space for the string so that it does not have to be copied for each append. Also, indexing and length computations are optimized because the Unicode string representation is calculated and cached as needed. When using the \fBTcl_Append*\fR family of functions where the -interpreter's result is the value being appended to, it is important +interpreter's result is the object being appended to, it is important to call Tcl_ResetResult first to ensure you are not unintentionally -appending to existing data in the result value. +appending to existing data in the result object. .PP -\fBTcl_NewStringObj\fR and \fBTcl_SetStringObj\fR create a new value -or modify an existing value to hold a copy of the string given by +\fBTcl_NewStringObj\fR and \fBTcl_SetStringObj\fR create a new object +or modify an existing object to hold a copy of the string given by \fIbytes\fR and \fIlength\fR. \fBTcl_NewUnicodeObj\fR and -\fBTcl_SetUnicodeObj\fR create a new value or modify an existing -value to hold a copy of the Unicode string given by \fIunicode\fR and +\fBTcl_SetUnicodeObj\fR create a new object or modify an existing +object to hold a copy of the Unicode string given by \fIunicode\fR and \fInumChars\fR. \fBTcl_NewStringObj\fR and \fBTcl_NewUnicodeObj\fR -return a pointer to a newly created value with reference count zero. -All four procedures set the value to hold a copy of the specified +return a pointer to a newly created object with reference count zero. +All four procedures set the object to hold a copy of the specified string. \fBTcl_SetStringObj\fR and \fBTcl_SetUnicodeObj\fR free any old string representation as well as any old internal representation -of the value. +of the object. .PP -\fBTcl_GetStringFromObj\fR and \fBTcl_GetString\fR return a value's +\fBTcl_GetStringFromObj\fR and \fBTcl_GetString\fR return an object's string representation. This is given by the returned byte pointer and (for \fBTcl_GetStringFromObj\fR) length, which is stored in -\fIlengthPtr\fR if it is non-NULL. If the value's UTF string +\fIlengthPtr\fR if it is non-NULL. If the object's UTF string representation is invalid (its byte pointer is NULL), the string -representation is regenerated from the value's internal +representation is regenerated from the object's internal representation. The storage referenced by the returned byte pointer -is owned by the value manager. It is passed back as a writable +is owned by the object manager. It is passed back as a writable pointer so that extension author creating their own \fBTcl_ObjType\fR will be able to modify the string representation within the \fBTcl_UpdateStringProc\fR of their \fBTcl_ObjType\fR. Except for that limited purpose, the pointer returned by \fBTcl_GetStringFromObj\fR or \fBTcl_GetString\fR should be treated as read-only. It is @@ -189,50 +193,49 @@ in-place modification of the string representation. The procedure \fBTcl_GetString\fR is used in the common case where the caller does not need the length of the string representation. .PP -\fBTcl_GetUnicodeFromObj\fR and \fBTcl_GetUnicode\fR return a value's +\fBTcl_GetUnicodeFromObj\fR and \fBTcl_GetUnicode\fR return an object's value as a Unicode string. This is given by the returned pointer and (for \fBTcl_GetUnicodeFromObj\fR) length, which is stored in \fIlengthPtr\fR if it is non-NULL. The storage referenced by the returned -byte pointer is owned by the value manager and should not be modified by +byte pointer is owned by the object manager and should not be modified by the caller. The procedure \fBTcl_GetUnicode\fR is used in the common case where the caller does not need the length of the unicode string representation. .PP \fBTcl_GetUniChar\fR returns the \fIindex\fR'th character in the -value's Unicode representation. If the index is out of range or -it references a low surrogate preceded by a high surrogate, it returns -1; +object's Unicode representation. .PP -\fBTcl_GetRange\fR returns a newly created value comprised of the +\fBTcl_GetRange\fR returns a newly created object comprised of the characters between \fIfirst\fR and \fIlast\fR (inclusive) in the -value's Unicode representation. If the value's Unicode +object's Unicode representation. If the object's Unicode representation is invalid, the Unicode representation is regenerated -from the value's string representation. +from the object's string representation. .PP \fBTcl_GetCharLength\fR returns the number of characters (as opposed -to bytes) in the string value. +to bytes) in the string object. .PP \fBTcl_AppendToObj\fR appends the data given by \fIbytes\fR and -\fIlength\fR to the string representation of the value specified by -\fIobjPtr\fR. If the value has an invalid string representation, +\fIlength\fR to the string representation of the object specified by +\fIobjPtr\fR. If the object has an invalid string representation, then an attempt is made to convert \fIbytes\fR is to the Unicode format. If the conversion is successful, then the converted form of -\fIbytes\fR is appended to the value's Unicode representation. -Otherwise, the value's Unicode representation is invalidated and +\fIbytes\fR is appended to the object's Unicode representation. +Otherwise, the object's Unicode representation is invalidated and converted to the UTF format, and \fIbytes\fR is appended to the -value's new string representation. +object's new string representation. .PP \fBTcl_AppendUnicodeToObj\fR appends the Unicode string given by -\fIunicode\fR and \fInumChars\fR to the value specified by -\fIobjPtr\fR. If the value has an invalid Unicode representation, +\fIunicode\fR and \fInumChars\fR to the object specified by +\fIobjPtr\fR. If the object has an invalid Unicode representation, then \fIunicode\fR is converted to the UTF format and appended to the -value's string representation. Appends are optimized to handle -repeated appends relatively efficiently (it over-allocates the string +object's string representation. Appends are optimized to handle +repeated appends relatively efficiently (it overallocates the string or Unicode space to avoid repeated reallocations and copies of -value's string value). +object's string value). .PP \fBTcl_AppendObjToObj\fR is similar to \fBTcl_AppendToObj\fR, but it appends the string or Unicode value (whichever exists and is best suited to be appended to \fIobjPtr\fR) of \fIappendObjPtr\fR to \fIobjPtr\fR. @@ -242,10 +245,15 @@ 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. +.PP +.VS 8.5 \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 @@ -265,46 +273,39 @@ bytes is necessary to append only whole multi-byte characters. .PP \fBTcl_Format\fR is the C-level interface to the engine of the \fBformat\fR command. The actual command procedure for \fBformat\fR is little more than -.PP .CS -\fBTcl_Format\fR(interp, \fBTcl_GetString\fR(objv[1]), objc-2, objv+2); +Tcl_Format(interp, Tcl_GetString(objv[1]), objc-2, objv+2); .CE -.PP The \fIobjc\fR Tcl_Obj values in \fIobjv\fR are formatted into a string according to the conversion specification in \fIformat\fR argument, following the documentation for the \fBformat\fR command. The resulting formatted string is converted to a new Tcl_Obj with refcount of zero and returned. If some error happens during production of the formatted string, NULL is returned, and an error message is recorded in \fIinterp\fR, if \fIinterp\fR is non-NULL. .PP \fBTcl_AppendFormatToObj\fR is an appending alternative form -of \fBTcl_Format\fR with functionality equivalent to: -.PP +of \fBTcl_Format\fR with functionality equivalent to .CS -Tcl_Obj *newPtr = \fBTcl_Format\fR(interp, format, objc, objv); +Tcl_Obj *newPtr = Tcl_Format(interp, format, objc, objv); if (newPtr == NULL) return TCL_ERROR; -\fBTcl_AppendObjToObj\fR(objPtr, newPtr); -\fBTcl_DecrRefCount\fR(newPtr); +Tcl_AppendObjToObj(objPtr, newPtr); return TCL_OK; .CE -.PP but with greater convenience and efficiency when the appending functionality is needed. .PP \fBTcl_ObjPrintf\fR serves as a replacement for the common sequence -.PP .CS char buf[SOME_SUITABLE_LENGTH]; sprintf(buf, format, ...); -\fBTcl_NewStringObj\fR(buf, -1); +Tcl_NewStringObj(buf, -1); .CE -.PP -but with greater convenience and no need to +but with greater convenience and no need to determine \fBSOME_SUITABLE_LENGTH\fR. The formatting is done with the same core formatting engine used by \fBTcl_Format\fR. This means the set of supported conversion specifiers is that of the \fBformat\fR command and not that of the \fBsprintf\fR routine where the two sets differ. When a conversion specifier passed to \fBTcl_ObjPrintf\fR includes a precision, @@ -312,70 +313,64 @@ as a number of characters, as \fBformat\fR does. This is done on the assumption that C code is more likely to know how many bytes it is passing around than the number of encoded characters those bytes happen to represent. The variable number of arguments passed in should be of the types that would be suitable for passing to \fBsprintf\fR. Note in -this example usage, \fIx\fR is of type \fBint\fR. -.PP +this example usage, \fIx\fR is of type \fBlong\fR. .CS -int x = 5; -Tcl_Obj *objPtr = \fBTcl_ObjPrintf\fR("Value is %d", x); +long x = 5; +Tcl_Obj *objPtr = Tcl_ObjPrintf("Value is %d", x); .CE -.PP If the value of \fIformat\fR contains internal inconsistencies or invalid specifier formats, the formatted string result produced by \fBTcl_ObjPrintf\fR will be an error message describing the error. -It is impossible however to provide runtime protection against -mismatches between the format and any subsequent arguments. -Compile-time protection may be provided by some compilers. .PP \fBTcl_AppendPrintfToObj\fR is an appending alternative form of \fBTcl_ObjPrintf\fR with functionality equivalent to -.PP .CS -Tcl_Obj *newPtr = \fBTcl_ObjPrintf\fR(format, ...); -\fBTcl_AppendObjToObj\fR(objPtr, newPtr); -\fBTcl_DecrRefCount\fR(newPtr); +Tcl_AppendObjToObj(objPtr, Tcl_ObjPrintf(format, ...)); .CE -.PP but with greater convenience and efficiency when the appending functionality is needed. +.VE 8.5 .PP The \fBTcl_SetObjLength\fR procedure changes the length of the string value of its \fIobjPtr\fR argument. If the \fInewLength\fR -argument is greater than the space allocated for the value's +argument is greater than the space allocated for the object's string, then the string space is reallocated and the old value is copied to the new space; the bytes between the old length of the string and the new length may have arbitrary values. If the \fInewLength\fR argument is less than the current length -of the value's string, with \fIobjPtr->length\fR is reduced without +of the object's string, with \fIobjPtr->length\fR is reduced without reallocating the string space; the original allocated size for the -string is recorded in the value, so that the string length can be +string is recorded in the object, so that the string length can be enlarged in a subsequent call to \fBTcl_SetObjLength\fR without reallocating storage. In all cases \fBTcl_SetObjLength\fR leaves a null character at \fIobjPtr->bytes[newLength]\fR. .PP \fBTcl_AttemptSetObjLength\fR is identical in function to \fBTcl_SetObjLength\fR except that if sufficient memory to satisfy the request cannot be allocated, it does not cause the Tcl interpreter to \fBpanic\fR. Thus, if \fInewLength\fR is greater than the space -allocated for the value's string, and there is not enough memory +allocated for the object's string, and there is not enough memory available to satisfy the request, \fBTcl_AttemptSetObjLength\fR will take no action and return 0 to indicate failure. If there is enough memory to satisfy the request, \fBTcl_AttemptSetObjLength\fR behaves just like \fBTcl_SetObjLength\fR and returns 1 to indicate success. .PP -The \fBTcl_ConcatObj\fR function returns a new string value whose +The \fBTcl_ConcatObj\fR function returns a new string object whose value is the space-separated concatenation of the string -representations of all of the values in the \fIobjv\fR +representations of all of the objects in the \fIobjv\fR array. \fBTcl_ConcatObj\fR eliminates leading and trailing white space as it copies the string representations of the \fIobjv\fR array to the result. If an element of the \fIobjv\fR array consists of nothing but -white space, then that value is ignored entirely. This white-space +white space, then that object is ignored entirely. This white-space removal was added to make the output of the \fBconcat\fR command cleaner-looking. \fBTcl_ConcatObj\fR returns a pointer to a -newly-created value whose ref count is zero. +newly-created object whose ref count is zero. + .SH "SEE ALSO" -Tcl_NewObj(3), Tcl_IncrRefCount(3), Tcl_DecrRefCount(3), format(n), sprintf(3) +Tcl_NewObj, Tcl_IncrRefCount, Tcl_DecrRefCount, format, sprintf + .SH KEYWORDS -append, internal representation, value, value type, string value, +append, internal representation, object, object type, string object, string type, string representation, concat, concatenate, unicode Index: doc/SubstObj.3 ================================================================== --- doc/SubstObj.3 +++ doc/SubstObj.3 @@ -1,16 +1,16 @@ '\" '\" Copyright (c) 2001 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Tcl_SubstObj 3 8.4 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_SubstObj \- perform substitutions on Tcl values +Tcl_SubstObj \- perform substitutions on Tcl objects .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_Obj * @@ -20,11 +20,11 @@ .AP Tcl_Interp *interp in Interpreter in which to execute Tcl scripts and lookup variables. If an error occurs, the interpreter's result is modified to hold an error message. .AP Tcl_Obj *objPtr in -A Tcl value containing the string to perform substitutions on. +A Tcl object containing the string to perform substitutions on. .AP int flags in ORed combination of flag bits that specify which substitutions to perform. The flags \fBTCL_SUBST_COMMANDS\fR, \fBTCL_SUBST_VARIABLES\fR and \fBTCL_SUBST_BACKSLASHES\fR are currently supported, and \fBTCL_SUBST_ALL\fR is provided as a @@ -34,11 +34,11 @@ .PP The \fBTcl_SubstObj\fR function is used to perform substitutions on strings in the fashion of the \fBsubst\fR command. It gets the value of the string contained in \fIobjPtr\fR and scans it, copying characters and performing the chosen substitutions as it goes to an -output value which is returned as the result of the function. In the +output object which is returned as the result of the function. In the event of an error occurring during the execution of a command or variable substitution, the function returns NULL and an error message is left in \fIinterp\fR's result. .PP Three kinds of substitutions are supported. When the Index: doc/TCL_MEM_DEBUG.3 ================================================================== --- doc/TCL_MEM_DEBUG.3 +++ doc/TCL_MEM_DEBUG.3 @@ -1,10 +1,10 @@ -'\" +'\" '\" Copyright (c) 1992-1999 Karl Lehenbauer and Mark Diekhans. '\" Copyright (c) 2000 by Scriptics Corporation. '\" All rights reserved. -'\" +'\" .TH TCL_MEM_DEBUG 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME TCL_MEM_DEBUG \- Compile-time flag to enable Tcl memory debugging @@ -32,30 +32,30 @@ 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 \fBTcl_Alloc\fR is +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 \fBTcl_Free\fR, the guard zones of the space being freed are +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 \fBTcl_Free\fR. +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 @@ -64,17 +64,17 @@ 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 -\fBTcl_Alloc\fR, again, at a large performance impact. +\fBckalloc\fR, again, at a large performance impact. .PP If you are desperate and validating memory on every call to -\fBTcl_Alloc\fR and \fBTcl_Free\fR is not enough, you can explicitly call +\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" -Tcl_Alloc, memory, Tcl_ValidateAllMemory, Tcl_DumpActiveMemory +ckalloc, memory, Tcl_ValidateAllMemory, Tcl_DumpActiveMemory .SH KEYWORDS memory, debug Index: doc/Tcl.n ================================================================== --- doc/Tcl.n +++ doc/Tcl.n @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH Tcl n "8.6" Tcl "Tcl Built-In Commands" +.TH Tcl n "8.5" Tcl "Tcl Built-In Commands" .so man.macros .BS .SH NAME Tcl \- Tool Command Language .SH SYNOPSIS @@ -26,14 +26,14 @@ A command is evaluated in two steps. First, the Tcl interpreter breaks the command into \fIwords\fR and performs substitutions as described below. These substitutions are performed in the same way for all commands. -Secondly, the first word is used to locate a routine to -carry out the command, and the remaining words of the command are -passed to that routine. -The routine is free to interpret each of its words +The first word is used to locate a command procedure to +carry out the command, then all of the words of the command are +passed to the command procedure. +The command procedure is free to interpret each of its words in any way it likes, such as an integer, variable name, list, or Tcl script. Different commands interpret their words differently. .IP "[3] \fBWords.\fR" Words of a command are separated by white space (except for @@ -46,10 +46,11 @@ (including newlines) appear between the quotes then they are treated as ordinary characters and included in the word. Command substitution, variable substitution, and backslash substitution are performed on the characters between the quotes as described below. The double-quotes are not retained as part of the word. +.VS 8.5 br .IP "[5] \fBArgument expansion.\fR" If a word starts with the string .QW {*} followed by a non-whitespace character, then the leading .QW {*} @@ -57,13 +58,14 @@ word. After substitution, the word is parsed as a list (without command or variable substitutions; backslash substitutions are performed as is normal for a list and individual internal words may be surrounded by either braces or double-quote characters), and its words are added to the command being substituted. For instance, -.QW "cmd a {*}{b [c]} d {*}{$e f {g h}}" +.QW "cmd a {*}{b [c]} d {*}{$e f \N'34'g h\N'34'}" is equivalent to -.QW "cmd a b {[c]} d {$e} f {g h}" . +.QW "cmd a b {[c]} d {$e} f \N'34'g h\N'34'" . +.VE 8.5 .IP "[6] \fBBraces.\fR" If the first character of a word is an open brace .PQ { and rule [5] does not apply, then the word is terminated by the matching close brace @@ -102,48 +104,28 @@ replaced in the word by the value of a variable. Variable substitution may take any of the following forms: .RS .TP 15 \fB$\fIname\fR -. \fIName\fR is the name of a scalar variable; the name is a sequence of one or more characters that are a letter, digit, underscore, or namespace separators (two or more colons). -Letters and digits are \fIonly\fR the standard ASCII ones (\fB0\fR\(en\fB9\fR, -\fBA\fR\(en\fBZ\fR and \fBa\fR\(en\fBz\fR). .TP 15 \fB$\fIname\fB(\fIindex\fB)\fR -. \fIName\fR gives the name of an array variable and \fIindex\fR gives the name of an element within that array. \fIName\fR must contain only letters, digits, underscores, and namespace separators, and may be an empty string. -Letters and digits are \fIonly\fR the standard ASCII ones (\fB0\fR\(en\fB9\fR, -\fBA\fR\(en\fBZ\fR and \fBa\fR\(en\fBz\fR). Command substitutions, variable substitutions, and backslash substitutions are performed on the characters of \fIindex\fR. .TP 15 \fB${\fIname\fB}\fR -. -\fIName\fR is the name of a scalar variable or array element. It may contain -any characters whatsoever except for close braces. It indicates an array -element if \fIname\fR is in the form -.QW \fIarrayName\fB(\fIindex\fB)\fR -where \fIarrayName\fR does not contain any open parenthesis characters, -.QW \fB(\fR , -or close brace characters, -.QW \fB}\fR , -and \fIindex\fR can be any sequence of characters except for close brace -characters. No further -substitutions are performed during the parsing of \fIname\fR. -.PP +\fIName\fR is the name of a scalar variable. It may contain any +characters whatsoever except for close braces. +.LP There may be any number of variable substitutions in a single word. Variable substitution is not performed on words enclosed in braces. -.PP -Note that variables may contain character sequences other than those listed -above, but in that case other mechanisms must be used to access them (e.g., -via the \fBset\fR command's single-argument form). .RE .IP "[9] \fBBackslash substitution.\fR" If a backslash .PQ \e appears within a word then \fIbackslash substitution\fR occurs. @@ -156,29 +138,29 @@ The following table lists the backslash sequences that are handled specially, along with the value that replaces each sequence. .RS .TP 7 \e\fBa\fR -Audible alert (bell) (Unicode U+000007). +Audible alert (bell) (0x7). .TP 7 \e\fBb\fR -Backspace (Unicode U+000008). +Backspace (0x8). .TP 7 \e\fBf\fR -Form feed (Unicode U+00000C). +Form feed (0xC). .TP 7 \e\fBn\fR -Newline (Unicode U+00000A). +Newline (0xA). .TP 7 \e\fBr\fR -Carriage-return (Unicode U+00000D). +Carriage-return (0xD). .TP 7 \e\fBt\fR -Tab (Unicode U+000009). +Tab (0x9). .TP 7 \e\fBv\fR -Vertical tab (Unicode U+00000B). +Vertical tab (0xB). .TP 7 \e\fB\fIwhiteSpace\fR . A single space character replaces the backslash, newline, and all spaces and tabs after the newline. This backslash sequence is unique in that it @@ -189,48 +171,30 @@ .TP 7 \e\e Backslash .PQ \e "" . .TP 7 -\e\fIooo\fR -. -The digits \fIooo\fR (one, two, or three of them) give a eight-bit octal -value for the Unicode character that will be inserted, in the range -\fI000\fR\(en\fI377\fR (i.e., the range U+000000\(enU+0000FF). -The parser will stop just before this range overflows, or when -the maximum of three digits is reached. The upper bits of the Unicode -character will be 0. -.TP 7 -\e\fBx\fIhh\fR -. -The hexadecimal digits \fIhh\fR (one or two of them) give an eight-bit -hexadecimal value for the Unicode character that will be inserted. The upper -bits of the Unicode character will be 0 (i.e., the character will be in the -range U+000000\(enU+0000FF). -.TP 7 -\e\fBu\fIhhhh\fR +\e\fIooo\fR +. +The digits \fIooo\fR (one, two, or three of them) give an eight-bit octal +value for the Unicode character that will be inserted. The upper bits of the +Unicode character will be 0. +.TP 7 +\e\fBx\fIhh\fR +. +The hexadecimal digits \fIhh\fR give an eight-bit hexadecimal value for the +Unicode character that will be inserted. Any number of hexadecimal digits +may be present; however, all but the last two are ignored (the result is +always a one-byte quantity). The upper bits of the Unicode character will +be 0. +.TP 7 +\e\fBu\fIhhhh\fR . The hexadecimal digits \fIhhhh\fR (one, two, three, or four of them) give a sixteen-bit hexadecimal value for the Unicode character that will be -inserted. The upper bits of the Unicode character will be 0 (i.e., the -character will be in the range U+000000\(enU+00FFFF). -.TP 7 -\e\fBU\fIhhhhhhhh\fR -. -The hexadecimal digits \fIhhhhhhhh\fR (one up to eight of them) give a -twenty-one-bit hexadecimal value for the Unicode character that will be -inserted, in the range U+000000\(enU+10FFFF. The parser will stop just -before this range overflows, or when the maximum of eight digits -is reached. The upper bits of the Unicode character will be 0. -.RS -.PP -The range U+00D800\(enU+00DFFF is reserved for surrogates, which -are illegal on its own. Therefore, such sequences will result in -the replacement character U+FFFD. Surrogate pairs should be -encoded as single \e\fBU\fIhhhhhhhh\fR character. -.RE -.PP +inserted. +.LP Backslash substitution is not performed on words enclosed in braces, except for backslash-newline as described above. .RE .IP "[10] \fBComments.\fR" If a hash character @@ -251,28 +215,20 @@ processed entirely by the recursive call to the Tcl interpreter; no substitutions are performed before making the recursive call and no additional substitutions are performed on the result of the nested script. .RS -.PP +.LP Substitutions take place from left to right, and each substitution is evaluated completely before attempting to evaluate the next. Thus, a sequence like -.PP .CS set y [set x 0][incr x][incr x] .CE -.PP will always set the variable \fIy\fR to the value, \fI012\fR. .RE .IP "[12] \fBSubstitution and word boundaries.\fR" Substitutions do not affect the word boundaries of a command, except for argument expansion as specified in rule [5]. For example, during variable substitution the entire value of the variable becomes part of a single word, even if the variable's value contains spaces. -.SH KEYWORDS -backslash, command, comment, script, substitution, variable -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: DELETED doc/TclZlib.3 Index: doc/TclZlib.3 ================================================================== --- doc/TclZlib.3 +++ /dev/null @@ -1,276 +0,0 @@ -'\" -'\" Copyright (c) 2008 Donal K. Fellows -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH TclZlib 3 8.6 Tcl "Tcl Library Procedures" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -Tcl_ZlibAdler32, Tcl_ZlibCRC32, Tcl_ZlibDeflate, Tcl_ZlibInflate, Tcl_ZlibStreamChecksum, Tcl_ZlibStreamClose, Tcl_ZlibStreamEof, Tcl_ZlibStreamGet, Tcl_ZlibStreamGetCommandName, Tcl_ZlibStreamInit, Tcl_ZlibStreamPut \- compression and decompression functions -.SH SYNOPSIS -.nf -#include -.sp -int -\fBTcl_ZlibDeflate\fR(\fIinterp, format, dataObj, level, dictObj\fR) -.sp -int -\fBTcl_ZlibInflate\fR(\fIinterp, format, dataObj, dictObj\fR) -.sp -unsigned int -\fBTcl_ZlibCRC32\fR(\fIinitValue, bytes, length\fR) -.sp -unsigned int -\fBTcl_ZlibAdler32\fR(\fIinitValue, bytes, length\fR) -.sp -int -\fBTcl_ZlibStreamInit\fR(\fIinterp, mode, format, level, dictObj, zshandlePtr\fR) -.sp -Tcl_Obj * -\fBTcl_ZlibStreamGetCommandName\fR(\fIzshandle\fR) -.sp -int -\fBTcl_ZlibStreamEof\fR(\fIzshandle\fR) -.sp -int -\fBTcl_ZlibStreamClose\fR(\fIzshandle\fR) -.sp -int -\fBTcl_ZlibStreamReset\fR(\fIzshandle\fR) -.sp -int -\fBTcl_ZlibStreamChecksum\fR(\fIzshandle\fR) -.sp -int -\fBTcl_ZlibStreamPut\fR(\fIzshandle, dataObj, flush\fR) -.sp -int -\fBTcl_ZlibStreamGet\fR(\fIzshandle, dataObj, count\fR) -.sp -\fBTcl_ZlibStreamSetCompressionDictionary\fR(\fIzshandle, compDict\fR) -.fi -.SH ARGUMENTS -.AS Tcl_ZlibStream zshandle in -.AP Tcl_Interp *interp in -The interpreter to store resulting compressed or uncompressed data in. Also -where any error messages are written. For \fBTcl_ZlibStreamInit\fR, this can -be NULL to create a stream that is not bound to a command. -.AP int format in -What format of compressed data to work with. Must be one of -\fBTCL_ZLIB_FORMAT_ZLIB\fR for zlib-format data, \fBTCL_ZLIB_FORMAT_GZIP\fR -for gzip-format data, or \fBTCL_ZLIB_FORMAT_RAW\fR for raw compressed data. In -addition, for decompression only, \fBTCL_ZLIB_FORMAT_AUTO\fR may also be -chosen which can automatically detect whether the compressed data was in zlib -or gzip format. -.AP Tcl_Obj *dataObj in/out -A byte-array value containing the data to be compressed or decompressed, or -to which the data extracted from the stream is appended when passed to -\fBTcl_ZlibStreamGet\fR. -.AP int level in -What level of compression to use. Should be a number from 0 to 9 or one of the -following: \fBTCL_ZLIB_COMPRESS_NONE\fR for no compression, -\fBTCL_ZLIB_COMPRESS_FAST\fR for fast but inefficient compression, -\fBTCL_ZLIB_COMPRESS_BEST\fR for slow but maximal compression, or -\fBTCL_ZLIB_COMPRESS_DEFAULT\fR for the level recommended by the zlib library. -.AP Tcl_Obj *dictObj in/out -A dictionary that contains, or which will be updated to contain, a description -of the gzip header associated with the compressed data. Only useful when the -\fIformat\fR is \fBTCL_ZLIB_FORMAT_GZIP\fR or \fBTCL_ZLIB_FORMAT_AUTO\fR. If -a NULL is passed, a default header will be used on compression and the header -will be ignored (apart from integrity checks) on decompression. See the -section \fBGZIP OPTIONS DICTIONARY\fR for details about the contents of this -dictionary. -.AP "unsigned int" initValue in -The initial value for the checksum algorithm. -.AP "unsigned char" *bytes in -An array of bytes to run the checksum algorithm over, or NULL to get the -recommended initial value for the checksum algorithm. -.AP size_t 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 size_t count in -The maximum number of bytes to get from the stream, or TCL_INDEX_NONE 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. -.BE -.SH DESCRIPTION -These functions form the interface from the Tcl library to the Zlib -library by Jean-loup Gailly and Mark Adler. -.PP -\fBTcl_ZlibDeflate\fR and \fBTcl_ZlibInflate\fR respectively compress and -decompress the data contained in the \fIdataObj\fR argument, according to the -\fIformat\fR and, for compression, \fIlevel\fR arguments. The dictionary in -the \fIdictObj\fR parameter is used to convey additional header information -about the compressed data when the compression format supports it; currently, -the dictionary is only used when the \fIformat\fR parameter is -\fBTCL_ZLIB_FORMAT_GZIP\fR or \fBTCL_ZLIB_FORMAT_AUTO\fR. For details of the -contents of the dictionary, see the \fBGZIP OPTIONS DICTIONARY\fR section -below. Upon success, both functions leave the resulting compressed or -decompressed data in a byte-array value that is the Tcl interpreter's result; -the returned value is a standard Tcl result code. -.PP -\fBTcl_ZlibAdler32\fR and \fBTcl_ZlibCRC32\fR compute checksums on arrays of -bytes, returning the computed checksum. Checksums are computed incrementally, -allowing data to be processed one block at a time, but this requires the -caller to maintain the current checksum and pass it in as the \fIinitValue\fR -parameter; the initial value to use for this can be obtained by using NULL for -the \fIbytes\fR parameter instead of a pointer to the array of bytes to -compute the checksum over. Thus, typical usage in the single data block case -is like this: -.PP -.CS -checksum = \fBTcl_ZlibCRC32\fR(\fBTcl_ZlibCRC32\fR(0,NULL,0), data, length); -.CE -.PP -Note that the Adler-32 algorithm is not a real checksum, but instead is a -related type of hash that works best on longer data. -.SS "ZLIB STREAMS" -.PP -\fBTcl_ZlibStreamInit\fR creates a compressing or decompressing stream that is -linked to a Tcl command, according to its arguments, and provides an abstract -token for the stream and returns a normal Tcl result code; -\fBTcl_ZlibStreamGetCommandName\fR returns the name of that command given the -stream token, or NULL if the stream has no command. Streams are not designed -to be thread-safe; each stream should only ever be used from the thread that -created it. When working with gzip streams, a dictionary (fields as given in -the \fBGZIP OPTIONS DICTIONARY\fR section below) can be given via the -\fIdictObj\fR parameter that on compression allows control over the generated -headers, and on decompression allows discovery of the existing headers. Note -that the dictionary will be written to on decompression once sufficient data -has been read to have a complete header. This means that the dictionary must -be an unshared value in that case; a blank value created with -\fBTcl_NewObj\fR is suggested. -.PP -Once a stream has been constructed, \fBTcl_ZlibStreamPut\fR is used to add -data to the stream and \fBTcl_ZlibStreamGet\fR is used to retrieve data from -the stream after processing. Both return normal Tcl result codes and leave an -error message in the result of the interpreter that the stream is registered -with in the error case (if such a registration has been performed). With -\fBTcl_ZlibStreamPut\fR, the data buffer value passed to it should not be -modified afterwards. With \fBTcl_ZlibStreamGet\fR, the data buffer value -passed to it will have the data bytes appended to it. Internally to the -stream, data is kept compressed so as to minimize the cost of buffer space. -.PP -\fBTcl_ZlibStreamChecksum\fR returns the checksum computed over the -uncompressed data according to the format, and \fBTcl_ZlibStreamEof\fR returns -a boolean value indicating whether the end of the uncompressed data has been -reached. -.PP -\fBTcl_ZlibStreamSetCompressionDictionary\fR is used to control the -compression dictionary used with the stream, a compression dictionary being an -array of bytes (such as might be created with \fBTcl_NewByteArrayObj\fR) that -is used to initialize the compression engine rather than leaving it to create -it on the fly from the data being compressed. Setting a compression dictionary -allows for more efficient compression in the case where the start of the data -is highly regular, but it does require both the compressor and the -decompressor to agreee on the value to use. Compression dictionaries are only -fully supported for zlib-format data; on compression, they must be set before -any data is sent in with \fBTcl_ZlibStreamPut\fR, and on decompression they -should be set when \fBTcl_ZlibStreamGet\fR produces an \fBerror\fR with its -\fB\-errorcode\fR set to -.QW "\fBZLIB NEED_DICT\fI code\fR" ; -the \fIcode\fR will be the Adler-32 checksum (see \fBTcl_ZlibAdler32\fR) of -the compression dictionary sought. (Note that this is only true for -zlib-format streams; gzip streams ignore compression dictionaries as the -format specification doesn't permit them, and raw streams just produce a data -error if the compression dictionary is missing or incorrect.) -.PP -If you wish to clear a stream and reuse it for a new compression or -decompression action, \fBTcl_ZlibStreamReset\fR will do this and return a -normal Tcl result code to indicate whether it was successful; if the stream is -registered with an interpreter, an error message will be left in the -interpreter result when this function returns TCL_ERROR. -Finally, \fBTcl_ZlibStreamClose\fR will clean up the stream and delete the -associated command: using \fBTcl_DeleteCommand\fR on the stream's command is -equivalent (when such a command exists). -.SH "GZIP OPTIONS DICTIONARY" -.PP -The \fIdictObj\fR parameter to \fBTcl_ZlibDeflate\fR, \fBTcl_ZlibInflate\fR -and \fBTcl_ZlibStreamInit\fR is used to pass a dictionary of options about -that is used to describe the gzip header in the compressed data. When creating -compressed data, the dictionary is read and when unpacking compressed data the -dictionary is written (in which case the \fIdictObj\fR parameter must refer to -an unshared dictionary value). -.PP -The following fields in the dictionary value are understood. All other fields -are ignored. No field is required when creating a gzip-format stream. -.TP -\fBcomment\fR -. -This holds the comment field of the header, if present. If absent, no comment -was supplied (on decompression) or will be created (on compression). -.TP -\fBcrc\fR -. -A boolean value describing whether a CRC of the header is computed. Note that -the \fBgzip\fR program does \fInot\fR use or allow a CRC on the header. -.TP -\fBfilename\fR -. -The name of the file that held the uncompressed data. This should not contain -any directory separators, and should be sanitized before use on decompression -with \fBfile tail\fR. -.TP -\fBos\fR -. -The operating system type code field from the header (if not the -.QW unknown -value). See RFC 1952 for the meaning of these codes. On compression, if this -is absent then the field will be set to the -.QW unknown -value. -.TP -\fBsize\fR -. -The size of the uncompressed data. This is ignored on compression; the size -of the data compressed depends on how much data is supplied to the -compression engine. -.TP -\fBtime\fR -. -The time field from the header if non-zero, expected to be the time that the -file named by the \fBfilename\fR field was modified. Suitable for use with -\fBclock format\fR. On creation, the right value to use is that from -\fBclock seconds\fR or \fBfile mtime\fR. -.TP -\fBtype\fR -. -The type of the uncompressed data (either \fBbinary\fR or \fBtext\fR) if -known. -.SH "PORTABILITY NOTES" -These functions will fail gracefully if Tcl is not linked with the zlib -library. -.SH "SEE ALSO" -Tcl_NewByteArrayObj(3), zlib(n) -'\"Tcl_StackChannel(3) -.SH "KEYWORDS" -compress, decompress, deflate, gzip, inflate -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/Tcl_Main.3 ================================================================== --- doc/Tcl_Main.3 +++ doc/Tcl_Main.3 @@ -3,64 +3,52 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" 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. -'\" +'\" .TH Tcl_Main 3 8.4 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_Main, Tcl_SetStartupScript, Tcl_GetStartupScript, Tcl_SetMainLoop \- main program, startup script, and event loop definition for Tcl-based applications +Tcl_Main, Tcl_SetMainLoop \- main program and event loop definition for Tcl-based applications .SH SYNOPSIS .nf \fB#include \fR .sp \fBTcl_Main\fR(\fIargc, argv, appInitProc\fR) .sp -\fBTcl_SetStartupScript\fR(\fIpath, encoding\fR) -.sp -Tcl_Obj * -\fBTcl_GetStartupScript\fR(\fIencodingPtr\fR) -.sp \fBTcl_SetMainLoop\fR(\fImainLoopProc\fR) .SH ARGUMENTS .AS Tcl_MainLoopProc *mainLoopProc .AP int argc in Number of elements in \fIargv\fR. .AP char *argv[] in -Array of strings containing command-line arguments. On Windows, when -using -DUNICODE, the parameter type changes to wchar_t *. +Array of strings containing command-line arguments. .AP Tcl_AppInitProc *appInitProc in Address of an application-specific initialization procedure. The value for this argument is usually \fBTcl_AppInit\fR. -.AP Tcl_Obj *path in -Name of file to use as startup script, or NULL. -.AP "const char" *encoding in -Encoding of file to use as startup script, or NULL. -.AP "const char" **encodingPtr out -If non-NULL, location to write a copy of the (const char *) -pointing to the encoding name. .AP Tcl_MainLoopProc *mainLoopProc in Address of an application-specific event loop procedure. .BE + .SH DESCRIPTION .PP \fBTcl_Main\fR can serve as the main program for Tcl-based shell applications. A .QW "shell application" is a program like tclsh or wish that supports both interactive interpretation of Tcl and evaluation of a script contained in a file given as a command line argument. \fBTcl_Main\fR is offered as a convenience -to developers of shell applications, so they do not have to +to developers of shell applications, so they do not have to reproduce all of the code for proper initialization of the Tcl library and interactive shell operation. Other styles of embedding Tcl in an application are not supported by \fBTcl_Main\fR. Those must be achieved by calling lower level functions in the Tcl library directly. -.PP + The \fBTcl_Main\fR function has been offered by the Tcl library since release Tcl 7.4. In older releases of Tcl, the Tcl library itself defined a function \fBmain\fR, but that lacks flexibility of embedding style and having a function \fBmain\fR in a library (particularly a shared library) causes problems on many systems. @@ -77,96 +65,62 @@ stub library. Programs that call \fBTcl_Main\fR must be linked against the standard Tcl library. Extensions (stub-enabled or not) are not intended to call \fBTcl_Main\fR. .PP \fBTcl_Main\fR is not thread-safe. It should only be called by -a single main thread of a multi-threaded application. This +a single master thread of a multi-threaded application. This restriction is not a problem with normal use described above. .PP \fBTcl_Main\fR and therefore all applications based upon it, like \fBtclsh\fR, use \fBTcl_GetStdChannel\fR to initialize the standard channels to their default values. See \fBTcl_StandardChannels\fR for more information. .PP -\fBTcl_Main\fR supports two modes of operation, depending on -whether the filename and encoding of a startup script has been -established. The routines \fBTcl_SetStartupScript\fR and -\fBTcl_GetStartupScript\fR are the tools for controlling this -configuration of \fBTcl_Main\fR. -.PP -\fBTcl_SetStartupScript\fR registers the value \fIpath\fR -as the name of the file for \fBTcl_Main\fR to evaluate as -its startup script. The value \fIencoding\fR is Tcl's name -for the encoding used to store the text in that file. A -value of \fBNULL\fR for \fIencoding\fR is a signal to use -the system encoding. A value of \fBNULL\fR for \fIpath\fR -erases any existing registration so that \fBTcl_Main\fR -will not evaluate any startup script. -.PP -\fBTcl_GetStartupScript\fR queries the registered file name -and encoding set by the most recent \fBTcl_SetStartupScript\fR -call in the same thread. The stored file name is returned, -and the stored encoding name is written to space pointed to -by \fIencodingPtr\fR, when that is not NULL. -.PP -The file name and encoding values managed by the routines -\fBTcl_SetStartupScript\fR and \fBTcl_GetStartupScript\fR -are stored per-thread. Although the storage and retrieval -functions of these routines work in any thread, only those -calls in the same main thread as \fBTcl_Main\fR can have -any influence on it. -.PP -The caller of \fBTcl_Main\fR may call \fBTcl_SetStartupScript\fR -first to establish its desired startup script. If \fBTcl_Main\fR -finds that no such startup script has been established, it consults -the first few arguments in \fIargv\fR. If they match -?\fB\-encoding \fIname\fR? \fIfileName\fR, +\fBTcl_Main\fR supports two modes of operation, depending on the +values of \fIargc\fR and \fIargv\fR. If the first few arguments +in \fIargv\fR match ?\fB\-encoding \fIname\fR? \fIfileName\fR, where \fIfileName\fR does not begin with the character \fI\-\fR, then \fIfileName\fR is taken to be the name of a file containing a \fIstartup script\fR, and \fIname\fR is taken to be the name -of the encoding of the contents of that file. \fBTcl_Main\fR -then calls \fBTcl_SetStartupScript\fR with these values. +of the encoding of the contents of that file, which \fBTcl_Main\fR +will attempt to evaluate. Otherwise, \fBTcl_Main\fR will enter an +interactive mode. .PP -\fBTcl_Main\fR then defines in its main interpreter +In either mode, \fBTcl_Main\fR will define in its master interpreter the Tcl variables \fIargc\fR, \fIargv\fR, \fIargv0\fR, and \fItcl_interactive\fR, as described in the documentation for \fBtclsh\fR. .PP When it has finished its own initialization, but before it processes commands, \fBTcl_Main\fR calls the procedure given by the \fIappInitProc\fR argument. This procedure provides a .QW hook for the application to perform its own initialization of the interpreter created by \fBTcl_Main\fR, such as defining application-specific -commands. The application initialization routine might also -call \fBTcl_SetStartupScript\fR to (re-)set the file and encoding -to be used as a startup script. The procedure must have an interface -that matches the type \fBTcl_AppInitProc\fR: -.PP +commands. The procedure must have an interface that matches the +type \fBTcl_AppInitProc\fR: .CS -typedef int \fBTcl_AppInitProc\fR( - Tcl_Interp *\fIinterp\fR); +typedef int Tcl_AppInitProc(Tcl_Interp *\fIinterp\fR); .CE -.PP + \fIAppInitProc\fR is almost always a pointer to \fBTcl_AppInit\fR; for more details on this procedure, see the documentation for \fBTcl_AppInit\fR. .PP -When the \fIappInitProc\fR is finished, \fBTcl_Main\fR calls -\fBTcl_GetStartupScript\fR to determine what startup script has -been requested, if any. If a startup script has been provided, -\fBTcl_Main\fR attempts to evaluate it. Otherwise, interactive -mode begins with examination of the variable \fItcl_rcFileName\fR -in the main interpreter. If that variable exists and holds the -name of a readable file, the contents of that file are evaluated -in the main interpreter. Then interactive operations begin, +When the \fIappInitProc\fR is finished, \fBTcl_Main\fR enters one +of its two modes. If a startup script has been provided, \fBTcl_Main\fR +attempts to evaluate it. Otherwise, interactive mode begins with +examination of the variable \fItcl_rcFileName\fR in the master +interpreter. If that variable exists and holds the name of a readable +file, the contents of that file are evaluated in the master interpreter. +Then interactive operations begin, with prompts and command evaluation results written to the standard output channel, and commands read from the standard input channel and then evaluated. The prompts written to the standard output channel may be customized by defining the Tcl variables \fItcl_prompt1\fR and \fItcl_prompt2\fR as described in the documentation for \fBtclsh\fR. The prompts and command evaluation results are written to the standard output channel only if the Tcl variable \fItcl_interactive\fR in the -main interpreter holds a non-zero integer value. +master interpreter holds a non-zero integer value. .PP \fBTcl_SetMainLoop\fR allows setting an event loop procedure to be run. This allows, for example, Tk to be dynamically loaded and set its event loop. The event loop will run following the startup script. If you are in interactive mode, setting the main loop procedure will cause the @@ -173,13 +127,12 @@ prompt to become fileevent based and then the loop procedure is called. When the loop procedure returns in interactive mode, interactive operation will continue. The main loop procedure must have an interface that matches the type \fBTcl_MainLoopProc\fR: -.PP .CS -typedef void \fBTcl_MainLoopProc\fR(void); +typedef void Tcl_MainLoopProc(void); .CE .PP \fBTcl_Main\fR does not return. Normally a program based on \fBTcl_Main\fR will terminate when the \fBexit\fR command is evaluated. In interactive mode, if an EOF or channel error @@ -187,12 +140,12 @@ 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) +exit(n) + .SH KEYWORDS application-specific initialization, command-line arguments, main program Index: doc/Thread.3 ================================================================== --- doc/Thread.3 +++ doc/Thread.3 @@ -2,11 +2,11 @@ '\" Copyright (c) 1999 Scriptics Corporation '\" Copyright (c) 1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Threads 3 "8.1" Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_ConditionNotify, Tcl_ConditionWait, Tcl_ConditionFinalize, Tcl_GetThreadData, Tcl_MutexLock, Tcl_MutexUnlock, Tcl_MutexFinalize, Tcl_CreateThread, Tcl_JoinThread \- Tcl thread support @@ -34,23 +34,21 @@ .sp void \fBTcl_MutexFinalize\fR(\fImutexPtr\fR) .sp int -\fBTcl_CreateThread\fR(\fIidPtr, proc, clientData, stackSize, flags\fR) +\fBTcl_CreateThread\fR(\fIidPtr, threadProc, clientData, stackSize, flags\fR) .sp int \fBTcl_JoinThread\fR(\fIid, result\fR) .SH ARGUMENTS -.AS Tcl_CreateThreadProc proc out +.AS Tcl_CreateThreadProc threadProc out .AP Tcl_Condition *condPtr in A condition variable, which must be associated with a mutex lock. .AP Tcl_Mutex *mutexPtr in -.VS TIP509 -A recursive mutex lock. -.VE TIP509 -.AP "const Tcl_Time" *timePtr in +A mutex lock. +.AP Tcl_Time *timePtr in A time limit on the condition wait. NULL to wait forever. Note that a polling value of 0 seconds does not make much sense. .AP Tcl_ThreadDataKey *keyPtr in This identifies a block of thread local storage. The key should be static and process-wide, yet each thread will end up associating @@ -62,49 +60,48 @@ .AP Tcl_ThreadId *idPtr out 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 +.AP Tcl_ThreadCreateProc threadProc in This procedure will act as the \fBmain()\fR of the newly created thread. The specified \fIclientData\fR will be its sole argument. -.AP void *clientData in -Arbitrary information. Passed as sole argument to the \fIproc\fR. +.AP ClientData clientData in +Arbitrary information. Passed as sole argument to the \fIthreadProc\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 +Bitmask containing flags allowing the caller to modify behaviour of the new thread. .AP int *result out The referred storage is used to place the exit code of the thread waited upon into it. .BE .SH INTRODUCTION Beginning with the 8.1 release, the Tcl core is thread safe, which allows you to incorporate Tcl into multithreaded applications without -customizing the Tcl core. Starting with the 8.6 release, Tcl -multithreading support is on by default. To disable Tcl multithreading -support, you must include the \fB\-\|\-disable-threads\fR option to -\fBconfigure\fR when you configure and compile your Tcl core. +customizing the Tcl core. To enable Tcl multithreading support, +you must include the \fB\-\|\-enable-threads\fR option to \fBconfigure\fR +when you configure and compile your Tcl core. .PP An important constraint of the Tcl threads implementation is that \fIonly the thread that created a Tcl interpreter can use that interpreter\fR. In other words, multiple threads can not access the same Tcl interpreter. (However, a single thread can safely create and use multiple interpreters.) .SH DESCRIPTION Tcl provides \fBTcl_CreateThread\fR for creating threads. The caller can determine the size of the stack given to the new thread and -modify the behavior through the supplied \fIflags\fR. The value +modify the behaviour through the supplied \fIflags\fR. The value \fBTCL_THREAD_STACK_DEFAULT\fR for the \fIstackSize\fR indicates that the default size as specified by the operating system is to be used for the new thread. As for the flags, currently only the values \fBTCL_THREAD_NOFLAGS\fR and \fBTCL_THREAD_JOINABLE\fR are defined. The -first of them invokes the default behavior with no special settings. -Using the second value marks the new thread as \fIjoinable\fR. This -means that another thread can wait for the such marked thread to exit -and join it. +first of them invokes the default behaviour with no +specialties. Using the second value marks the new thread as +\fIjoinable\fR. This means that another thread can wait for the such +marked thread to exit and join it. .PP Restrictions: On some UNIX systems the pthread-library does not contain the functionality to specify the stack size of a thread. The specified value for the stack size is ignored on these systems. Windows currently does not support joinable threads. This @@ -127,11 +124,11 @@ This means that not calling \fBTcl_JoinThread\fR for a joinable thread will cause a memory leak. .PP The \fBTcl_GetThreadData\fR call returns a pointer to a block of thread-private data. Its argument is a key that is shared by all threads -and a size for the block of storage. The storage is automatically +and a size for the block of storage. The storage is automatically allocated and initialized to all zeros the first time each thread asks for it. The storage is automatically deallocated by \fBTcl_FinalizeThread\fR. .SS "SYNCHRONIZATION AND COMMUNICATION" Tcl provides \fBTcl_ThreadQueueEvent\fR and \fBTcl_ThreadAlert\fR for handling event queuing in multithreaded applications. See @@ -140,16 +137,12 @@ A mutex is a lock that is used to serialize all threads through a piece of code by calling \fBTcl_MutexLock\fR and \fBTcl_MutexUnlock\fR. If one thread holds a mutex, any other thread calling \fBTcl_MutexLock\fR will block until \fBTcl_MutexUnlock\fR is called. A mutex can be destroyed after its use by calling \fBTcl_MutexFinalize\fR. -.VS TIP509 -Mutexes are reentrant: they can be locked several times from the same -thread. However there must be exactly one call to -\fBTcl_MutexUnlock\fR for each call to \fBTcl_MutexLock\fR in order -for a thread to release a mutex completely. -.VE TIP509 +The result of locking a mutex twice from the same thread is undefined. +On some platforms it will result in a deadlock. The \fBTcl_MutexLock\fR, \fBTcl_MutexUnlock\fR and \fBTcl_MutexFinalize\fR procedures are defined as empty macros if not compiling with threads enabled. For declaration of mutexes the \fBTCL_DECLARE_MUTEX\fR macro should be used. This macro assures correct mutex handling even when the core is compiled without threads enabled. @@ -185,64 +178,18 @@ either cleaned up by process exit handlers (if living that long) or explicitly by calls to \fBTcl_MutexFinalize\fR or \fBTcl_ConditionFinalize\fR. Thread local storage is reclaimed during \fBTcl_FinalizeThread\fR. .SH "SCRIPT-LEVEL ACCESS TO THREADS" -.PP +.VS 8.5 Tcl provides no built-in commands for scripts to use to create, manage, or join threads, nor any script-level access to mutex or condition variables. It provides such facilities only via C interfaces, and leaves it up to packages to expose these matters to the script level. One such package is the \fBThread\fR package. -.SH EXAMPLE -.PP -To create a thread with portable code, its implementation function should be -declared as follows: -.PP -.CS -static \fBTcl_ThreadCreateProc\fR MyThreadImplFunc; -.CE -.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( - void *clientData) -{ - int i, limit = (int) clientData; - for (i=0 ; i\fR .sp -int +Tcl_UniChar \fBTcl_UniCharToUpper\fR(\fIch\fR) .sp -int +Tcl_UniChar \fBTcl_UniCharToLower\fR(\fIch\fR) .sp -int +Tcl_UniChar \fBTcl_UniCharToTitle\fR(\fIch\fR) .sp int \fBTcl_UtfToUpper\fR(\fIstr\fR) .sp @@ -31,11 +31,11 @@ int \fBTcl_UtfToTitle\fR(\fIstr\fR) .SH ARGUMENTS .AS char *str in/out .AP int ch in -The Unicode character to be converted. +The Tcl_UniChar to be converted. .AP char *str in/out Pointer to UTF-8 string to be converted in place. .BE .SH DESCRIPTION @@ -76,7 +76,13 @@ .PP \fBTcl_UtfToTitle\fR is the same as \fBTcl_UtfToUpper\fR except it turns the first character in the string into its title-case equivalent and all following characters into their lower-case equivalents. +.SH BUGS +.PP +At this time, the case conversions are only defined for the ISO8859-1 +characters. Unicode characters above 0x00FF are not modified by these +routines. + .SH KEYWORDS utf, unicode, toupper, tolower, totitle, case Index: doc/TraceCmd.3 ================================================================== --- doc/TraceCmd.3 +++ doc/TraceCmd.3 @@ -1,21 +1,21 @@ '\" '\" Copyright (c) 2002 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Tcl_TraceCommand 3 7.4 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_CommandTraceInfo, Tcl_TraceCommand, Tcl_UntraceCommand \- monitor renames and deletes of a command .SH SYNOPSIS .nf \fB#include \fR .sp -void * +ClientData \fBTcl_CommandTraceInfo(\fIinterp, cmdName, flags, proc, prevClientData\fB)\fR .sp int \fBTcl_TraceCommand(\fIinterp, cmdName, flags, proc, clientData\fB)\fR .sp @@ -30,13 +30,13 @@ .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 void *clientData in +.AP ClientData clientData in Arbitrary argument to pass to \fIproc\fR. -.AP void *prevClientData in +.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 @@ -60,23 +60,21 @@ Invoke \fIproc\fR when the command is deleted. .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( - void *\fIclientData\fR, +typedef void Tcl_CommandTraceProc( + 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 +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 Index: doc/TraceVar.3 ================================================================== --- doc/TraceVar.3 +++ doc/TraceVar.3 @@ -2,12 +2,12 @@ '\" 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 9.0 Tcl "Tcl Library Procedures" +'\" +.TH Tcl_TraceVar 3 7.4 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 @@ -22,17 +22,17 @@ .sp \fBTcl_UntraceVar(\fIinterp, varName, flags, proc, clientData\fB)\fR .sp \fBTcl_UntraceVar2(\fIinterp, name1, name2, flags, proc, clientData\fB)\fR .sp -void * +ClientData \fBTcl_VarTraceInfo(\fIinterp, varName, flags, proc, prevClientData\fB)\fR .sp -void * +ClientData \fBTcl_VarTraceInfo2(\fIinterp, name1, name2, flags, proc, prevClientData\fB)\fR .SH ARGUMENTS -.AS void *prevClientData +.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 @@ -44,19 +44,19 @@ \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 void *clientData in +.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 void *prevClientData in +.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 @@ -93,11 +93,11 @@ .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 +automatically unset) or when the interpreter 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 @@ -105,11 +105,11 @@ 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 -\fBTcl_Free\fR. Must not be specified at the same time as +\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 @@ -119,24 +119,22 @@ .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( - void *\fIclientData\fR, +typedef char *Tcl_VarTraceProc( + 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 +\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). @@ -158,10 +156,14 @@ 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). +Lastly, the bit \fBTCL_INTERP_DESTROYED\fR will be set if the entire +interpreter is being destroyed. +When this bit is set, \fIproc\fR must be especially careful in +the things it does (see the section \fBTCL_INTERP_DESTROYED\fR below). 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 @@ -197,11 +199,11 @@ \fBTcl_VarTraceInfo2\fR are identical to \fBTcl_TraceVar\fR, \fBTcl_UntraceVar\fR, and \fBTcl_VarTraceInfo\fR, respectively, except that the name of the variable consists of two parts. \fIName1\fR gives the name of a scalar variable or array, and \fIname2\fR gives the name of an element within an array. -When \fIname2\fR is NULL, +When \fIname2\fR is NULL, \fIname1\fR may contain both an array and an element name: if the name contains an open parenthesis and ends with a close parenthesis, then the value between the parentheses is treated as an element name (which can have any string value) and the characters before the first open @@ -208,11 +210,11 @@ parenthesis are treated as the name of an array variable. If \fIname2\fR is NULL and \fIname1\fR does not refer to an array element it means that either the variable is a scalar or the trace is to be set on the entire array rather than an individual element (see WHOLE-ARRAY TRACES below for -more information). +more information). .SH "ACCESSING VARIABLES DURING TRACES" .PP During read, write, and array traces, the trace procedure can read, write, or unset the traced variable using \fBTcl_GetVar2\fR, \fBTcl_SetVar2\fR, and @@ -306,11 +308,11 @@ 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 \fBTcl_Free\fR) or a +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. @@ -324,20 +326,10 @@ 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 Tcl 9 no longer supports this. Any supported code -must 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 @@ -358,13 +350,27 @@ 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 "TCL_INTERP_DESTROYED" +.PP +When an interpreter is destroyed, unset traces are called for +all of its variables. +The \fBTCL_INTERP_DESTROYED\fR bit will be set in the \fIflags\fR +argument passed to the trace procedures. +Trace procedures must be extremely careful in what they do if +the \fBTCL_INTERP_DESTROYED\fR bit is set. +It is not safe for the procedures to invoke any Tcl procedures +on the interpreter, since its state is partially deleted. +All that trace procedures should do under these circumstances is +to clean up and free their own internal data structures. .SH BUGS +.PP +Tcl does not do any error checking to prevent trace procedures +from misusing the interpreter during traces with \fBTCL_INTERP_DESTROYED\fR +set. .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 Index: doc/Translate.3 ================================================================== --- doc/Translate.3 +++ doc/Translate.3 @@ -2,11 +2,11 @@ '\" Copyright (c) 1989-1993 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. -'\" +'\" .TH Tcl_TranslateFileName 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_TranslateFileName \- convert file name to native form and replace tilde with home directory @@ -27,23 +27,24 @@ If needed, this dynamic string is used to store the new file name. At the time of the call it should be uninitialized or free. The caller must eventually call \fBTcl_DStringFree\fR to free up anything stored here. .BE + .SH DESCRIPTION .PP This utility procedure translates a file name to a platform-specific form which, after being converted to the appropriate encoding, is suitable for passing to the local operating system. In particular, it converts -network names into native form and does tilde substitution. +network names into native form and does tilde substitution. .PP However, with the advent of the newer \fBTcl_FSGetNormalizedPath\fR and -\fBTcl_FSGetNativePath\fR, there is no longer any need to use this -procedure. In particular, \fBTcl_FSGetNativePath\fR performs all the +\fBTcl_GetNativePath\fR, there is no longer any need to use this +procedure. In particular, \fBTcl_GetNativePath\fR performs all the necessary translation and encoding conversion, is virtual-filesystem aware, and caches the native result for faster repeated calls. -Finally \fBTcl_FSGetNativePath\fR does not require you to free anything +Finally \fBTcl_GetNativePath\fR does not require you to free anything afterwards. .PP If \fBTcl_TranslateFileName\fR has to do tilde substitution or translate the name then it uses @@ -63,9 +64,11 @@ frees the dynamic string itself so that the caller need not call \fBTcl_DStringFree\fR. .PP The caller is responsible for making sure that the interpreter's result has its default empty value when \fBTcl_TranslateFileName\fR is invoked. + .SH "SEE ALSO" -filename(n) +filename + .SH KEYWORDS file name, home directory, tilde, translate, user Index: doc/UniCharIsAlpha.3 ================================================================== --- doc/UniCharIsAlpha.3 +++ doc/UniCharIsAlpha.3 @@ -1,11 +1,11 @@ '\" '\" 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_UniCharIsAlpha 3 "8.1" Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_UniCharIsAlnum, Tcl_UniCharIsAlpha, Tcl_UniCharIsControl, Tcl_UniCharIsDigit, Tcl_UniCharIsGraph, Tcl_UniCharIsLower, Tcl_UniCharIsPrint, Tcl_UniCharIsPunct, Tcl_UniCharIsSpace, Tcl_UniCharIsUpper, Tcl_UniCharIsWordChar \- routines for classification of Tcl_UniChar characters @@ -46,20 +46,23 @@ int \fBTcl_UniCharIsWordChar\fR(\fIch\fR) .SH ARGUMENTS .AS int ch .AP int ch in -The Unicode character to be examined. +The Tcl_UniChar to be examined. .BE .SH DESCRIPTION .PP -All of the routines described examine Unicode characters and return a +All of the routines described examine Tcl_UniChars and return a boolean value. A non-zero return value means that the character does belong to the character class associated with the called routine. The rest of this document just describes the character classes associated with the various routines. +.PP +Note: A Tcl_UniChar is a Unicode character represented as an unsigned, +fixed-size quantity. .SH "CHARACTER CLASSES" .PP \fBTcl_UniCharIsAlnum\fR tests if the character is an alphanumeric Unicode character. .PP Index: doc/UpVar.3 ================================================================== --- doc/UpVar.3 +++ doc/UpVar.3 @@ -2,11 +2,11 @@ '\" Copyright (c) 1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Tcl_UpVar 3 7.4 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_UpVar, Tcl_UpVar2 \- link one variable to another @@ -38,11 +38,11 @@ an upvar-ed variable. .AP int flags in One of \fBTCL_GLOBAL_ONLY\fR, \fBTCL_NAMESPACE_ONLY\fR or 0; if non-zero, then \fIdestName\fR is a global or namespace variable; otherwise it is local to the current procedure (or current namespace if no procedure is -active). +active). .AP "const char" *name1 in First part of source variable's name (scalar name, or name of array without array index). .AP "const char" *name2 in If source variable is an element of an array, gives the index of the element. Index: doc/Utf.3 ================================================================== --- doc/Utf.3 +++ doc/Utf.3 @@ -6,11 +6,11 @@ '\" .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 +Tcl_UniChar, Tcl_UniCharToUtf, Tcl_UtfToUniChar, Tcl_UniCharToUtfDString, Tcl_UtfToUniCharDString, 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 \fR .sp typedef ... \fBTcl_UniChar\fR; @@ -19,51 +19,33 @@ \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, uniLength\fR) +\fBTcl_UniCharNcmp\fR(\fIucs, uct, numChars\fR) .sp int -\fBTcl_UniCharNcasecmp\fR(\fIucs, uct, uniLength\fR) +\fBTcl_UniCharNcasecmp\fR(\fIucs, uct, numChars\fR) .sp int \fBTcl_UniCharCaseMatch\fR(\fIuniStr, uniPattern, nocase\fR) .sp int -\fBTcl_UtfNcmp\fR(\fIcs, ct, length\fR) +\fBTcl_UtfNcmp\fR(\fIcs, ct, numChars\fR) .sp int -\fBTcl_UtfNcasecmp\fR(\fIcs, ct, length\fR) +\fBTcl_UtfNcasecmp\fR(\fIcs, ct, numChars\fR) .sp int \fBTcl_UtfCharComplete\fR(\fIsrc, length\fR) .sp int @@ -79,31 +61,27 @@ \fBTcl_UtfNext\fR(\fIsrc\fR) .sp const char * \fBTcl_UtfPrev\fR(\fIsrc, start\fR) .sp -int +Tcl_UniChar \fBTcl_UniCharAtIndex\fR(\fIsrc, index\fR) .sp const char * \fBTcl_UtfAtIndex\fR(\fIsrc, index\fR) .sp -size_t +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. +\fBTCL_UTF_MAX\fR bytes are stored in the buffer. .AP int ch in -The Unicode character to be converted or examined. +The Tcl_UniChar 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 @@ -114,75 +92,63 @@ 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 size_t length in +.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 size_t uniLength in -The length of the Unicode string in characters. +.AP int uniLength in +The length of the Unicode string in characters. Must be greater than or +equal to 0. .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 size_t index in +.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. +At most \fBTCL_UTF_MAX\fR 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 +These routines convert between UTF-8 strings and Tcl_UniChars. A +Tcl_UniChar is a Unicode character represented as an unsigned, fixed-size +quantity. A UTF-8 character is a Unicode character represented as +a varying-length sequence of up to \fBTCL_UTF_MAX\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 it takes to +represent one Unicode character in the UTF-8 representation. +.PP +\fBTcl_UniCharToUtf\fR stores the Tcl_UniChar \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. +in \fIbuf\fR. .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. +byte of \fIsrc\fR in \fI*chPtr\fR as a Tcl_UniChar between 0x80 and +0xFF 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. +You must specify \fIuniLength\fR, the length of the given Unicode string. 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, @@ -201,11 +167,11 @@ 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 \fIuniLength\fR 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. @@ -215,11 +181,11 @@ 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 \fIlength\fR +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. @@ -229,35 +195,36 @@ differences in case when comparing upper, lower or title case characters. .PP \fBTcl_UtfCharComplete\fR returns 1 if the source UTF-8 string \fIsrc\fR of \fIlength\fR bytes is long enough to be decoded by -\fBTcl_UtfToUniChar\fR, or 0 otherwise. This function does not guarantee -that the UTF-8 string is properly formed. This routine is used by -procedures that are operating on a byte at a time and need to know if a -full Unicode character has been seen. +\fBTcl_UtfToUniChar\fR/\fBTcl_UtfNext\fR, or 0 otherwise. This function +does not guarantee that the UTF-8 string is properly formed. This routine +is used by procedures that are operating on a byte at a time and need to +know if a full Tcl_UniChar has been seen. .PP \fBTcl_NumUtfChars\fR corresponds to \fBstrlen\fR for UTF-8 strings. It returns the number of Tcl_UniChars that are represented by the UTF-8 string \fIsrc\fR. The length of the source string is \fIlength\fR bytes. If the length is negative, all bytes up to the first null byte are used. .PP \fBTcl_UtfFindFirst\fR corresponds to \fBstrchr\fR for UTF-8 strings. It -returns a pointer to the first occurrence of the Unicode character \fIch\fR +returns a pointer to the first occurrence of the Tcl_UniChar \fIch\fR in the null-terminated UTF-8 string \fIsrc\fR. The null terminator is considered part of the UTF-8 string. .PP \fBTcl_UtfFindLast\fR corresponds to \fBstrrchr\fR for UTF-8 strings. It -returns a pointer to the last occurrence of the Unicode character \fIch\fR +returns a pointer to the last occurrence of the Tcl_UniChar \fIch\fR in the null-terminated UTF-8 string \fIsrc\fR. The null terminator is considered part of the UTF-8 string. .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. +character. \fBTcl_UtfCharComplete\fR can be used in that case to +make sure enough bytes are available before calling \fBTcl_UtfNext\fR. .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 @@ -278,26 +245,25 @@ 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 +Pascal Ord() function. It returns the Tcl_UniChar represented at the specified character (not byte) \fIindex\fR in the UTF-8 string \fIsrc\fR. The source string must contain at least \fIindex\fR -characters. If \fIindex\fR is TCL_INDEX_NONE or \fIindex\fR points -to the second half of a surrogate pair, it returns -1. +characters. Behavior is undefined if a negative \fIindex\fR is given. .PP \fBTcl_UtfAtIndex\fR returns a pointer to the specified character (not byte) \fIindex\fR in the UTF-8 string \fIsrc\fR. The source string must contain at least \fIindex\fR characters. This is equivalent to calling -\fBTcl_UtfToUniChar\fR \fIindex\fR times. If \fIindex\fR is TCL_INDEX_NONE, +\fBTcl_UtfToUniChar\fR \fIindex\fR times. If a negative \fIindex\fR is given, the return 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. +buffer \fIdst\fR. At most \fBTCL_UTF_MAX\fR 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 Index: doc/WrongNumArgs.3 ================================================================== --- doc/WrongNumArgs.3 +++ doc/WrongNumArgs.3 @@ -1,11 +1,11 @@ '\" '\" 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_WrongNumArgs 3 8.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_WrongNumArgs \- generate standard error message for wrong number of arguments @@ -16,11 +16,11 @@ \fBTcl_WrongNumArgs\fR(\fIinterp, objc, objv, message\fR) .SH ARGUMENTS .AS "Tcl_Obj *const" *message .AP Tcl_Interp interp in Interpreter in which error will be reported: error message gets stored -in its result value. +in its result object. .AP int objc in Number of leading arguments from \fIobjv\fR to include in error message. .AP "Tcl_Obj *const" objv[] in Arguments to command that had the wrong number of arguments. @@ -27,53 +27,51 @@ .AP "const char" *message in Additional error information to print after leading arguments from \fIobjv\fR. This typically gives the acceptable syntax of the command. This argument may be NULL. .BE + .SH DESCRIPTION .PP \fBTcl_WrongNumArgs\fR is a utility procedure that is invoked by command procedures when they discover that they have received the wrong number of arguments. \fBTcl_WrongNumArgs\fR generates a -standard error message and stores it in the result value of +standard error message and stores it in the result object of \fIinterp\fR. The message includes the \fIobjc\fR initial elements of \fIobjv\fR plus \fImessage\fR. For example, if \fIobjv\fR consists of the values \fBfoo\fR and \fBbar\fR, \fIobjc\fR is 1, and \fImessage\fR is .QW "\fBfileName count\fR" -then \fIinterp\fR's result value will be set to the following +then \fIinterp\fR's result object will be set to the following string: -.PP .CS wrong # args: should be "foo fileName count" .CE -.PP If \fIobjc\fR is 2, the result will be set to the following string: -.PP .CS wrong # args: should be "foo bar fileName count" .CE -.PP \fIObjc\fR is usually 1, but may be 2 or more for commands like \fBstring\fR and the Tk widget commands, which use the first argument -as a subcommand. +as a subcommand. .PP -Some of the values in the \fIobjv\fR array may be abbreviations for +Some of the objects in the \fIobjv\fR array may be abbreviations for a subcommand. The command -\fBTcl_GetIndexFromObj\fR will convert the abbreviated string value +\fBTcl_GetIndexFromObj\fR will convert the abbreviated string object into an \fIindexObject\fR. If an error occurs in the parsing of the subcommand we would like to use the full subcommand name rather than the abbreviation. If the \fBTcl_WrongNumArgs\fR command finds any \fIindexObjects\fR in the \fIobjv\fR array it will use the full subcommand name in the error message instead of the abbreviated name that was originally passed in. Using the above example, let us assume that -\fIbar\fR is actually an abbreviation for \fIbarfly\fR and the value -is now an \fIindexObject\fR because it was passed to +\fIbar\fR is actually an abbreviation for \fIbarfly\fR and the object +is now an indexObject because it was passed to \fBTcl_GetIndexFromObj\fR. In this case the error message would be: -.PP .CS wrong # args: should be "foo barfly fileName count" .CE + .SH "SEE ALSO" -Tcl_GetIndexFromObj(3) +Tcl_GetIndexFromObj + .SH KEYWORDS command, error message, wrong number of arguments DELETED doc/abstract.n Index: doc/abstract.n ================================================================== --- doc/abstract.n +++ /dev/null @@ -1,77 +0,0 @@ -'\" -'\" Copyright (c) 2018 Donal K. Fellows -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH abstract n 0.3 TclOO "TclOO Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -oo::abstract \- a class that does not allow direct instances of itself -.SH SYNOPSIS -.nf -package require TclOO - -\fBoo::abstract\fI method \fR?\fIarg ...\fR? -.fi -.SH "CLASS HIERARCHY" -.nf -\fBoo::object\fR - \(-> \fBoo::class\fR - \(-> \fBoo::abstract\fR -.fi -.BE -.SH DESCRIPTION -Abstract classes are classes that can contain definitions, but which cannot be -directly manufactured; they are intended to only ever be inherited from and -instantiated indirectly. The characteristic methods of \fBoo::class\fR -(\fBcreate\fR and \fBnew\fR) are not exported by an instance of -\fBoo::abstract\fR. -.PP -Note that \fBoo::abstract\fR is not itself an instance of \fBoo::abstract\fR. -.SS CONSTRUCTOR -The \fBoo::abstract\fR class does not define an explicit constructor; this -means that it is effectively the same as the constructor of the -\fBoo::class\fR class. -.SS DESTRUCTOR -The \fBoo::abstract\fR class does not define an explicit destructor; -destroying an instance of it is just like destroying an ordinary class (and -will destroy all its subclasses). -.SS "EXPORTED METHODS" -The \fBoo::abstract\fR class defines no new exported methods. -.SS "NON-EXPORTED METHODS" -The \fBoo::abstract\fR class explicitly states that \fBcreate\fR, -\fBcreateWithNamespace\fR, and \fBnew\fR are unexported. -.SH EXAMPLES -.PP -This example defines a simple class hierarchy and creates a new instance of -it. It then invokes a method of the object before destroying the hierarchy and -showing that the destruction is transitive. -.PP -.CS -\fBoo::abstract\fR create fruit { - method eat {} { - puts "yummy!" - } -} -oo::class create banana { - superclass fruit - method peel {} { - puts "skin now off" - } -} -set b [banana \fBnew\fR] -$b peel \fI\(-> prints 'skin now off'\fR -$b eat \fI\(-> prints 'yummy!'\fR -set f [fruit new] \fI\(-> error 'unknown method "new"...'\fR -.CE -.SH "SEE ALSO" -oo::define(n), oo::object(n) -.SH KEYWORDS -abstract class, class, metaclass, object -.\" Local variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: Index: doc/after.n ================================================================== --- doc/after.n +++ doc/after.n @@ -2,11 +2,11 @@ '\" Copyright (c) 1990-1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH after n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -22,80 +22,75 @@ .sp \fBafter idle \fR?\fIscript script script ...\fR? .sp \fBafter info \fR?\fIid\fR? .BE + .SH DESCRIPTION .PP This command is used to delay execution of the program or to execute a command in background sometime in the future. It has several forms, depending on the first argument to the command: .TP \fBafter \fIms\fR -. \fIMs\fR must be an integer giving a time in milliseconds. The command sleeps for \fIms\fR milliseconds and then returns. While the command is sleeping the application does not respond to events. .TP \fBafter \fIms \fR?\fIscript script script ...\fR? -. In this form the command returns immediately, but it arranges for a Tcl command to be executed \fIms\fR milliseconds later as an event handler. The command will be executed exactly once, at the given time. The delayed command is formed by concatenating all the \fIscript\fR arguments in the same fashion as the \fBconcat\fR command. The command will be executed at global level (outside the context of any Tcl procedure). -If an error occurs while executing the delayed command then +If an error occurs while executing the delayed command then the background error will be reported by the command -registered with \fBinterp bgerror\fR. +registered with \fB interp bgerror\fR. The \fBafter\fR command returns an identifier that can be used to cancel the delayed command using \fBafter cancel\fR. .TP \fBafter cancel \fIid\fR -. Cancels the execution of a delayed command that was previously scheduled. \fIId\fR indicates which command should be canceled; it must have been the return value from a previous \fBafter\fR command. If the command given by \fIid\fR has already been executed then the \fBafter cancel\fR command has no effect. .TP \fBafter cancel \fIscript script ...\fR -. This command also cancels the execution of a delayed command. The \fIscript\fR arguments are concatenated together with space separators (just as in the \fBconcat\fR command). If there is a pending command that matches the string, it is -canceled and will never be executed; if no such command is +cancelled and will never be executed; if no such command is currently pending then the \fBafter cancel\fR command has no effect. .TP \fBafter idle \fIscript \fR?\fIscript script ...\fR? -. Concatenates the \fIscript\fR arguments together with space separators (just as in the \fBconcat\fR command), and arranges for the resulting script to be evaluated later as an idle callback. The script will be run exactly once, the next time the event loop is entered and there are no events to process. The command returns an identifier that can be used to cancel the delayed command using \fBafter cancel\fR. If an error occurs while executing the script then the background error will be reported by the command -registered with \fBinterp bgerror\fR. +registered with \fB interp bgerror\fR. .TP \fBafter info \fR?\fIid\fR? -. This command returns information about existing event handlers. If no \fIid\fR argument is supplied, the command returns a list of the identifiers for all existing event handlers created by the \fBafter\fR command for this interpreter. If \fIid\fR is supplied, it specifies an existing handler; \fIid\fR must have been the return value from some previous call -to \fBafter\fR and it must not have triggered yet or been canceled. +to \fBafter\fR and it must not have triggered yet or been cancelled. In this case the command returns a list with two elements. The first element of the list is the script associated with \fIid\fR, and the second element is either \fBidle\fR or \fBtimer\fR to indicate what kind of event handler it is. @@ -107,20 +102,18 @@ \fBtclsh\fR, the event loop can be entered with the \fBvwait\fR and \fBupdate\fR commands. .SH "EXAMPLES" This defines a command to make Tcl do nothing at all for \fIN\fR seconds: -.PP .CS proc sleep {N} { - \fBafter\fR [expr {int($N * 1000)}] + \fBafter\fR [expr {int($N * 1000)}] } .CE .PP This arranges for the command \fIwake_up\fR to be run in eight hours (providing the event loop is active at that time): -.PP .CS \fBafter\fR [expr {1000 * 60 * 60 * 8}] wake_up .CE .PP The following command can be used to do long-running calculations (as @@ -131,21 +124,19 @@ ensure that the event loop is not starved by the rescheduling of processing steps (arranging for the next step to be done using an already-triggered timer event only when the event queue has been drained) and is useful when you want to ensure that a Tk GUI remains responsive during a slow task. -.PP .CS proc doOneStep {} { - if {[::my_calc::one_step]} { - \fBafter idle\fR [list \fBafter\fR 0 doOneStep] - } + if {[::my_calc::one_step]} { + \fBafter idle\fR [list \fBafter\fR 0 doOneStep] + } } doOneStep .CE + .SH "SEE ALSO" concat(n), interp(n), update(n), vwait(n) + .SH KEYWORDS cancel, delay, idle callback, sleep, time -'\" Local Variables: -'\" mode: nroff -'\" End: Index: doc/append.n ================================================================== --- doc/append.n +++ doc/append.n @@ -2,31 +2,27 @@ '\" 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 append n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME append \- Append to variable .SH SYNOPSIS \fBappend \fIvarName \fR?\fIvalue value value ...\fR? .BE + .SH DESCRIPTION .PP Append all of the \fIvalue\fR arguments to the current value of variable \fIvarName\fR. If \fIvarName\fR does not exist, it is given a value equal to the concatenation of all the \fIvalue\fR arguments. -.VS TIP508 -If \fIvarName\fR indicate an element that does not exist of an array that has -a default value set, the concatenation of the default value and all the -\fIvalue\fR arguments will be stored in the array element. -.VE TIP508 The result of this command is the new value stored in variable \fIvarName\fR. This command provides an efficient way to build up long variables incrementally. For example, @@ -34,22 +30,19 @@ is much more efficient than .QW "\fBset a $a$b\fR" if \fB$a\fR is long. .SH EXAMPLE Building a string of comma-separated numbers piecemeal using a loop. -.PP .CS set var 0 for {set i 1} {$i<=10} {incr i} { - \fBappend\fR var "," $i + \fBappend\fR var "," $i } puts $var # Prints 0,1,2,3,4,5,6,7,8,9,10 .CE + .SH "SEE ALSO" concat(n), lappend(n) + .SH KEYWORDS append, variable -.\" Local variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: Index: doc/apply.n ================================================================== --- doc/apply.n +++ doc/apply.n @@ -12,15 +12,15 @@ \fBapply \fIfunc\fR ?\fIarg1 arg2 ...\fR? .BE .SH DESCRIPTION .PP The command \fBapply\fR applies the function \fIfunc\fR to the arguments -\fIarg1 arg2 ...\fR and returns the result. +\fIarg1 arg2 ...\fR and returns the result. .PP The function \fIfunc\fR is a two element list \fI{args body}\fR or a three element list \fI{args body namespace}\fR (as if the -\fBlist\fR command had been used). +\fBlist\fR command had been used). The first element \fIargs\fR specifies the formal arguments to \fIfunc\fR. The specification of the formal arguments \fIargs\fR is shared with the \fBproc\fR command, and is described in detail in the corresponding manual page. .PP @@ -46,57 +46,51 @@ .PP The semantics of \fBapply\fR can also be described by: .PP .CS proc apply {fun args} { - set len [llength $fun] - if {($len < 2) || ($len > 3)} { - error "can't interpret \e"$fun\e" as anonymous function" - } - lassign $fun argList body ns - set name ::$ns::[getGloballyUniqueName] - set body0 { - rename [lindex [info level 0] 0] {} - } - proc $name $argList ${body0}$body - set code [catch {uplevel 1 $name $args} res opt] - return -options $opt $res + set len [llength $fun] + if {($len < 2) || ($len > 3)} { + error "can't interpret \e"$fun\e" as anonymous function" + } + lassign $fun argList body ns + set name ::$ns::[getGloballyUniqueName] + set body0 { + rename [lindex [info level 0] 0] {} + } + proc $name $argList ${body0}$body + set code [catch {uplevel 1 $name $args} res opt] + return -options $opt $res } .CE .SH EXAMPLES -.PP This shows how to make a simple general command that applies a transformation to each element of a list. -.PP .CS proc map {lambda list} { - set result {} - foreach item $list { - lappend result [\fBapply\fR $lambda $item] - } - return $result + set result {} + foreach item $list { + lappend result [\fBapply\fR $lambda $item] + } + return $result } map {x {return [string length $x]:$x}} {a bb ccc dddd} \fI\(-> 1:a 2:bb 3:ccc 4:dddd\fR map {x {expr {$x**2 + 3*$x - 2}}} {-4 -3 -2 -1 0 1 2 3 4} \fI\(-> 2 -2 -4 -4 -2 2 8 16 26\fR .CE .PP The \fBapply\fR command is also useful for defining callbacks for use in the \fBtrace\fR command: -.PP .CS set vbl "123abc" trace add variable vbl write {\fBapply\fR {{v1 v2 op} { - upvar 1 $v1 v - puts "updated variable to \e"$v\e"" + upvar 1 $v1 v + puts "updated variable to \e"$v\e"" }}} set vbl 123 set vbl abc .CE .SH "SEE ALSO" proc(n), uplevel(n) .SH KEYWORDS -anonymous function, argument, lambda, procedure, -'\" Local Variables: -'\" mode: nroff -'\" End: +argument, procedure, anonymous function Index: doc/array.n ================================================================== --- doc/array.n +++ doc/array.n @@ -2,12 +2,12 @@ '\" Copyright (c) 1993-1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH array n 8.7 Tcl "Tcl Built-In Commands" +'\" +.TH array n 8.3 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME array \- Manipulate array variables @@ -33,57 +33,10 @@ invocation of \fBarray startsearch\fR. This option is particularly useful if an array has an element with an empty name, since the return value from \fBarray nextelement\fR will not indicate whether the search has been completed. -.TP -\fBarray default \fIsubcommand arrayName args...\fR -.VS TIP508 -Manages the default value of the array. Arrays initially have no default -value, but this command allows you to set one; the default value will be -returned when reading from an element of the array \fIarrayName\fR if the read -would otherwise result in an error. Note that this may cause the \fBappend\fR, -\fBdict\fR, \fBincr\fR and \fBlappend\fR commands to change their behavior in -relation to non-existing array elements. -.RS -.PP -The \fIsubcommand\fR argument controls what exact operation will be performed -on the default value of \fIarrayName\fR. Supported \fIsubcommand\fRs are: -.VE TIP508 -.TP -\fBarray default exists \fIarrayName\fR -.VS TIP508 -This returns a boolean value indicating whether a default value has been set -for the array \fIarrayName\fR. Returns a false value if \fIarrayName\fR does -not exist. Raises an error if \fIarrayName\fR is an existing variable that is -not an array. -.VE TIP508 -.TP -\fBarray default get \fIarrayName\fR -.VS TIP508 -This returns the current default value for the array \fIarrayName\fR. Raises -an error if \fIarrayName\fR is an existing variable that is not an array, or -if \fIarrayName\fR is an array without a default value. -.VE TIP508 -.TP -\fBarray default set \fIarrayName value\fR -.VS TIP508 -This sets the default value for the array \fIarrayName\fR to \fIvalue\fR. -Returns the empty string. Raises an error if \fIarrayName\fR is an existing -variable that is not an array, or if \fIarrayName\fR is an illegal name for an -array. If \fIarrayName\fR does not currently exist, it is created as an empty -array as well as having its default value set. -.VE TIP508 -.TP -\fBarray default unset \fIarrayName\fR -.VS TIP508 -This removes the default value for the array \fIarrayName\fR and returns the -empty string. Does nothing if \fIarrayName\fR does not have a default -value. Raises an error if \fIarrayName\fR is an existing variable that is not -an array. -.VE TIP508 -.RE .TP \fBarray donesearch \fIarrayName searchId\fR This command terminates an array search and destroys all the state associated with that search. \fISearchId\fR indicates which search on \fIarrayName\fR to destroy, and must have @@ -92,19 +45,10 @@ .TP \fBarray exists \fIarrayName\fR Returns 1 if \fIarrayName\fR is an array variable, 0 if there is no variable by that name or if it is a scalar variable. .TP -\fBarray for {\fIkeyVariable valueVariable\fB} \fIarrayName body\fP -The first argument is a two element list of variable names for the -key and value of each entry in the array. The second argument is the -array name to iterate over. The third argument is the body to execute -for each key and value returned. -The ordering of the returned keys is undefined. -If an array element is deleted or a new array element is inserted during -the \fIarray for\fP process, the command will terminate with an error. -.TP \fBarray get \fIarrayName\fR ?\fIpattern\fR? Returns a list containing pairs of elements. The first element in each pair is the name of an element in \fIarrayName\fR and the second element of each pair is the value of the array element. The order of the pairs is undefined. @@ -190,34 +134,34 @@ an array variable, then the command unsets the entire array. The command always returns an empty string. .SH EXAMPLES .CS \fBarray set\fR colorcount { - red 1 - green 5 - blue 4 - white 9 + red 1 + green 5 + blue 4 + white 9 } foreach {color count} [\fBarray get\fR colorcount] { - puts "Color: $color Count: $count" + puts "Color: $color Count: $count" } \fB\(->\fR Color: blue Count: 4 Color: white Count: 9 Color: green Count: 5 Color: red Count: 1 foreach color [\fBarray names\fR colorcount] { - puts "Color: $color Count: $colorcount($color)" + puts "Color: $color Count: $colorcount($color)" } \fB\(->\fR Color: blue Count: 4 Color: white Count: 9 Color: green Count: 5 Color: red Count: 1 foreach color [lsort [\fBarray names\fR colorcount]] { - puts "Color: $color Count: $colorcount($color)" + puts "Color: $color Count: $colorcount($color)" } \fB\(->\fR Color: blue Count: 4 Color: green Count: 5 Color: red Count: 1 Color: white Count: 9 @@ -239,9 +183,5 @@ .CE .SH "SEE ALSO" list(n), string(n), variable(n), trace(n), foreach(n) .SH KEYWORDS array, element names, search -.\" Local variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: Index: doc/bgerror.n ================================================================== --- doc/bgerror.n +++ doc/bgerror.n @@ -2,22 +2,23 @@ '\" Copyright (c) 1990-1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH bgerror n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME bgerror \- Command invoked to process background errors .SH SYNOPSIS \fBbgerror \fImessage\fR .BE + .SH DESCRIPTION -.PP +.VS 8.5 Release 8.5 of Tcl supports the \fBinterp bgerror\fR command, which allows applications to register in an interpreter the command that will handle background errors in that interpreter. In older releases of Tcl, this level of control was not available, and applications could control the handling of background errors only by creating @@ -25,10 +26,11 @@ global namespace of an interpreter. The following documentation describes the interface requirements of the \fBbgerror\fR command an application might define to retain compatibility with pre-8.5 releases of Tcl. Applications intending to support only Tcl releases 8.5 and later should simply make use of \fBinterp bgerror\fR. +.VE 8.5 .PP The \fBbgerror\fR command does not exist as built-in part of Tcl. Instead, individual applications or users can define a \fBbgerror\fR command (e.g. as a Tcl procedure) if they wish to handle background errors. @@ -71,23 +73,20 @@ package or other kind of library, consider avoiding \fBbgerror\fR. The reason for this is that the application programmer may also want to define a \fBbgerror\fR, or use other code that does and thus will have trouble integrating your code. .SH "EXAMPLE" -.PP This \fBbgerror\fR procedure appends errors to a file, with a timestamp. -.PP .CS proc bgerror {message} { set timestamp [clock format [clock seconds]] set fl [open mylog.txt {WRONLY CREAT APPEND}] puts $fl "$timestamp: bgerror in $::argv '$message'" close $fl } .CE + .SH "SEE ALSO" -after(n), errorCode(n), errorInfo(n), interp(n) +after(n), interp(n), tclvars(n) + .SH KEYWORDS background error, reporting -'\" Local Variables: -'\" mode: nroff -'\" End: Index: doc/binary.n ================================================================== --- doc/binary.n +++ doc/binary.n @@ -1,137 +1,31 @@ '\" '\" Copyright (c) 1997 by Sun Microsystems, Inc. -'\" Copyright (c) 2008 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. -'\" +'\" .TH binary n 8.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME binary \- Insert and extract fields from binary strings .SH SYNOPSIS -\fBbinary decode \fIformat\fR ?\fI\-option value ...\fR? \fIdata\fR -.br -\fBbinary encode \fIformat\fR ?\fI\-option value ...\fR? \fIdata\fR -.br \fBbinary format \fIformatString \fR?\fIarg arg ...\fR? .br \fBbinary scan \fIstring formatString \fR?\fIvarName varName ...\fR? .BE .SH DESCRIPTION .PP This command provides facilities for manipulating binary data. The -subcommand \fBbinary format\fR creates a binary string from normal +first form, \fBbinary format\fR, creates a binary string from normal Tcl values. For example, given the values 16 and 22, on a 32-bit architecture, it might produce an 8-byte binary string consisting of -two 4-byte integers, one for each of the numbers. The subcommand -\fBbinary scan\fR, does the opposite: it extracts data +two 4-byte integers, one for each of the numbers. The second form of +the command, \fBbinary scan\fR, does the opposite: it extracts data from a binary string and returns it as ordinary Tcl string values. -The \fBbinary encode\fR and \fBbinary decode\fR subcommands convert -binary data to or from string encodings such as base64 (used in MIME -messages for example). -.PP -Note that other operations on binary data, such as taking a subsequence of it, -getting its length, or reinterpreting it as a string in some encoding, are -done by other Tcl commands (respectively \fBstring range\fR, -\fBstring length\fR and \fBencoding convertfrom\fR in the example cases). A -binary string in Tcl is merely one where all the characters it contains are in -the range \eu0000\-\eu00FF. -.SH "BINARY ENCODE AND DECODE" -.PP -When encoding binary data as a readable string, the starting binary data is -passed to the \fBbinary encode\fR command, together with the name of the -encoding to use and any encoding-specific options desired. Data which has been -encoded can be converted back to binary form using \fBbinary decode\fR. The -following formats and options are supported. -.TP -\fBbase64\fR -. -The \fBbase64\fR binary encoding is commonly used in mail messages and XML -documents, and uses mostly upper and lower case letters and digits. It has the -distinction of being able to be rewrapped arbitrarily without losing -information. -.RS -.PP -During encoding, the following options are supported: -.TP -\fB\-maxlen \fIlength\fR -. -Indicates that the output should be split into lines of no more than -\fIlength\fR characters. By default, lines are not split. -.TP -\fB\-wrapchar \fIcharacter\fR -. -Indicates that, when lines are split because of the \fB\-maxlen\fR option, -\fIcharacter\fR should be used to separate lines. By default, this is a -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 is specified by the \fIformatString\fR and whose contents come from the additional arguments. The resulting binary value is returned. @@ -142,21 +36,18 @@ by an optional numeric \fIcount\fR. Most field specifiers consume one argument to obtain the value to be formatted. The type character specifies how the value is to be formatted. The \fIcount\fR typically indicates how many items of the specified type are taken from the value. If present, the \fIcount\fR -is a non-negative decimal integer or -.QW \fB*\fR , -which normally indicates +is a non-negative decimal integer or \fB*\fR, which normally indicates that all of the items in the value are to be used. If the number of arguments does not match the number of fields in the format string that consume arguments, then an error is generated. The flag character -is ignored for \fBbinary format\fR. +is ignored for for \fBbinary format\fR. .PP Here is a small example to clarify the relation between the field specifiers and the arguments: -.PP .CS \fBbinary format\fR d3d {1.0 2.0 3.0 4.0} 0.1 .CE .PP The first argument is a list of four numbers, but because of the count @@ -180,313 +71,218 @@ if this truncation is not desired (i.e. if the characters are not part of the ISO 8859\-1 character set.) If \fIarg\fR has fewer than \fIcount\fR bytes, then additional zero bytes are used to pad out the field. If \fIarg\fR is longer than the specified length, the extra characters will be ignored. If -\fIcount\fR is -.QW \fB*\fR , -then all of the bytes in \fIarg\fR will be +\fIcount\fR is \fB*\fR, then all of the bytes in \fIarg\fR will be formatted. If \fIcount\fR is omitted, then one character will be -formatted. For example, the command: +formatted. For example, .RS -.PP .CS \fBbinary format\fR a7a*a alpha bravo charlie .CE -.PP -will return a binary string equivalent to: -.PP -.CS -\fBalpha\e000\e000bravoc\fR -.CE -.PP -the command: -.PP +will return a string equivalent to \fBalpha\e000\e000bravoc\fR, .CS \fBbinary format\fR a* [encoding convertto utf-8 \eu20ac] .CE -.PP -will return a binary string equivalent to: -.PP -.CS -\fB\e342\e202\e254\fR -.CE -.PP -(which is the -UTF-8 byte sequence for a Euro-currency character), and the command: -.PP +will return a string equivalent to \fB\e342\e202\e254\fR (which is the +UTF-8 byte sequence for a Euro-currency character) and .CS \fBbinary format\fR a* [encoding convertto iso8859-15 \eu20ac] .CE -.PP -will return a binary string equivalent to: -.PP -.CS -\fB\e244\fR -.CE -.PP -(which is the ISO +will return a string equivalent to \fB\e244\fR (which is the ISO 8859\-15 byte sequence for a Euro-currency character). Contrast these last two with: -.PP .CS \fBbinary format\fR a* \eu20ac .CE -.PP -which returns a binary string equivalent to: -.PP -.CS -\fB\e254\fR -.CE -.PP -(i.e. \fB\exac\fR) by +which returns a string equivalent to \fB\e254\fR (i.e. \fB\exac\fR) by truncating the high-bits of the character, and which is probably not what is desired. .RE .IP \fBA\fR 5 This form is the same as \fBa\fR except that spaces are used for padding instead of nulls. For example, .RS -.PP .CS \fBbinary format\fR A6A*A alpha bravo charlie .CE -.PP -will return -.PP -.CS -\fBalpha bravoc\fR -.CE +will return \fBalpha bravoc\fR. .RE .IP \fBb\fR 5 Stores a string of \fIcount\fR binary digits in low-to-high order -within each byte in the output binary string. \fIArg\fR must contain a +within each byte in the output string. \fIArg\fR must contain a sequence of \fB1\fR and \fB0\fR characters. The resulting bytes are emitted in first to last order with the bits being formatted in low-to-high order within each byte. If \fIarg\fR has fewer than \fIcount\fR digits, then zeros will be used for the remaining bits. If \fIarg\fR has more than the specified number of digits, the extra -digits will be ignored. If \fIcount\fR is -.QW \fB*\fR , -then all of the +digits will be ignored. If \fIcount\fR is \fB*\fR, then all of the digits in \fIarg\fR will be formatted. If \fIcount\fR is omitted, then one digit will be formatted. If the number of bits formatted does not end at a byte boundary, the remaining bits of the last byte will be zeros. For example, .RS -.PP .CS \fBbinary format\fR b5b* 11100 111000011010 .CE -.PP -will return a binary string equivalent to: -.PP -.CS -\fB\ex07\ex87\ex05\fR -.CE +will return a string equivalent to \fB\ex07\ex87\ex05\fR. .RE .IP \fBB\fR 5 This form is the same as \fBb\fR except that the bits are stored in high-to-low order within each byte. For example, .RS -.PP .CS \fBbinary format\fR B5B* 11100 111000011010 .CE -.PP -will return a binary string equivalent to: -.PP -.CS -\fB\exe0\exe1\exa0\fR -.CE +will return a string equivalent to \fB\exe0\exe1\exa0\fR. .RE .IP \fBH\fR 5 Stores a string of \fIcount\fR hexadecimal digits in high-to-low -within each byte in the output binary string. \fIArg\fR must contain a +within each byte in the output string. \fIArg\fR must contain a sequence of characters in the set .QW 0123456789abcdefABCDEF . The resulting bytes are emitted in first to last order with the hex digits being formatted in high-to-low order within each byte. If \fIarg\fR has fewer than \fIcount\fR digits, then zeros will be used for the remaining digits. If \fIarg\fR has more than the specified number of digits, the extra digits will be ignored. If \fIcount\fR is -.QW \fB*\fR , -then all of the digits in \fIarg\fR will be formatted. If +\fB*\fR, then all of the digits in \fIarg\fR will be formatted. If \fIcount\fR is omitted, then one digit will be formatted. If the number of digits formatted does not end at a byte boundary, the remaining bits of the last byte will be zeros. For example, .RS -.PP .CS \fBbinary format\fR H3H*H2 ab DEF 987 .CE -.PP -will return a binary string equivalent to: -.PP -.CS -\fB\exab\ex00\exde\exf0\ex98\fR -.CE +will return a string equivalent to \fB\exab\ex00\exde\exf0\ex98\fR. .RE .IP \fBh\fR 5 This form is the same as \fBH\fR except that the digits are stored in low-to-high order within each byte. This is seldom required. For example, .RS -.PP .CS \fBbinary format\fR h3h*h2 AB def 987 .CE -.PP -will return a binary string equivalent to: -.PP -.CS -\fB\exba\ex00\exed\ex0f\ex89\fR -.CE +will return a string equivalent to \fB\exba\ex00\exed\ex0f\ex89\fR. .RE .IP \fBc\fR 5 Stores one or more 8-bit integer values in the output string. If no \fIcount\fR is specified, then \fIarg\fR must consist of an integer value. If \fIcount\fR is specified, \fIarg\fR must consist of a list containing at least that many integers. The low-order 8 bits of each integer -are stored as a one-byte value at the cursor position. If \fIcount\fR is -.QW \fB*\fR , -then all of the integers in the list are formatted. If the +are stored as a one-byte value at the cursor position. If \fIcount\fR +is \fB*\fR, then all of the integers in the list are formatted. If the number of elements in the list is greater than \fIcount\fR, then the extra elements are ignored. For example, .RS -.PP .CS \fBbinary format\fR c3cc* {3 -3 128 1} 260 {2 5} .CE -.PP -will return a binary string equivalent to: -.PP -.CS -\fB\ex03\exfd\ex80\ex04\ex02\ex05\fR -.CE -.PP -whereas: -.PP +will return a string equivalent to +\fB\ex03\exfd\ex80\ex04\ex02\ex05\fR, whereas .CS \fBbinary format\fR c {2 5} .CE -.PP will generate an error. .RE .IP \fBs\fR 5 This form is the same as \fBc\fR except that it stores one or more 16-bit integers in little-endian byte order in the output string. The low-order 16-bits of each integer are stored as a two-byte value at the cursor position with the least significant byte stored first. For example, .RS -.PP .CS \fBbinary format\fR s3 {3 -3 258 1} .CE -.PP -will return a binary string equivalent to: -.PP -.CS -\fB\ex03\ex00\exfd\exff\ex02\ex01\fR -.CE +will return a string equivalent to +\fB\ex03\ex00\exfd\exff\ex02\ex01\fR. .RE .IP \fBS\fR 5 This form is the same as \fBs\fR except that it stores one or more 16-bit integers in big-endian byte order in the output string. For example, .RS -.PP .CS \fBbinary format\fR S3 {3 -3 258 1} .CE -.PP -will return a binary string equivalent to: -.PP -.CS -\fB\ex00\ex03\exff\exfd\ex01\ex02\fR -.CE +will return a string equivalent to +\fB\ex00\ex03\exff\exfd\ex01\ex02\fR. .RE .IP \fBt\fR 5 +.VS 8.5 This form (mnemonically \fItiny\fR) is the same as \fBs\fR and \fBS\fR except that it stores the 16-bit integers in the output string in the native byte order of the machine where the Tcl script is running. To determine what the native byte order of the machine is, refer to the \fBbyteOrder\fR element of the \fBtcl_platform\fR array. +.VE 8.5 .IP \fBi\fR 5 This form is the same as \fBc\fR except that it stores one or more 32-bit integers in little-endian byte order in the output string. The low-order 32-bits of each integer are stored as a four-byte value at the cursor position with the least significant byte stored first. For example, .RS -.PP .CS \fBbinary format\fR i3 {3 -3 65536 1} .CE -.PP -will return a binary string equivalent to: -.PP -.CS +will return a string equivalent to \fB\ex03\ex00\ex00\ex00\exfd\exff\exff\exff\ex00\ex00\ex01\ex00\fR -.CE .RE .IP \fBI\fR 5 This form is the same as \fBi\fR except that it stores one or more one or more 32-bit integers in big-endian byte order in the output string. For example, .RS -.PP .CS \fBbinary format\fR I3 {3 -3 65536 1} .CE -.PP -will return a binary string equivalent to: -.PP -.CS +will return a string equivalent to \fB\ex00\ex00\ex00\ex03\exff\exff\exff\exfd\ex00\ex01\ex00\ex00\fR -.CE .RE .IP \fBn\fR 5 +.VS 8.5 This form (mnemonically \fInumber\fR or \fInormal\fR) is the same as \fBi\fR and \fBI\fR except that it stores the 32-bit integers in the output string in the native byte order of the machine where the Tcl script is running. To determine what the native byte order of the machine is, refer to the \fBbyteOrder\fR element of the \fBtcl_platform\fR array. +.VE 8.5 .IP \fBw\fR 5 This form is the same as \fBc\fR except that it stores one or more 64-bit integers in little-endian byte order in the output string. The low-order 64-bits of each integer are stored as an eight-byte value at the cursor position with the least significant byte stored first. For example, .RS -.PP .CS \fBbinary format\fR w 7810179016327718216 .CE -.PP -will return the binary string \fBHelloTcl\fR. +will return the string \fBHelloTcl\fR .RE .IP \fBW\fR 5 This form is the same as \fBw\fR except that it stores one or more one or more 64-bit integers in big-endian byte order in the output string. For example, .RS -.PP .CS \fBbinary format\fR Wc 4785469626960341345 110 .CE -.PP -will return the binary string \fBBigEndian\fR +will return the string \fBBigEndian\fR .RE .IP \fBm\fR 5 +.VS 8.5 This form (mnemonically the mirror of \fBw\fR) is the same as \fBw\fR and \fBW\fR except that it stores the 64-bit integers in the output string in the native byte order of the machine where the Tcl script is running. To determine what the native byte order of the machine is, refer to the \fBbyteOrder\fR element of the \fBtcl_platform\fR array. +.VE 8.5 .IP \fBf\fR 5 This form is the same as \fBc\fR except that it stores one or more one or more single-precision floating point numbers in the machine's native representation in the output string. This representation is not portable across architectures, so it should not be used to communicate @@ -497,113 +293,92 @@ as defined by the system will be used instead. Because Tcl uses double-precision floating point numbers internally, there may be some loss of precision in the conversion to single-precision. For example, on a Windows system running on an Intel Pentium processor, .RS -.PP .CS \fBbinary format\fR f2 {1.6 3.4} .CE -.PP -will return a binary string equivalent to: -.PP -.CS -\fB\excd\excc\excc\ex3f\ex9a\ex99\ex59\ex40\fR -.CE +will return a string equivalent to +\fB\excd\excc\excc\ex3f\ex9a\ex99\ex59\ex40\fR. .RE .IP \fBr\fR 5 +.VS 8.5 This form (mnemonically \fIreal\fR) is the same as \fBf\fR except that it stores the single-precision floating point numbers in little-endian order. This conversion only produces meaningful output when used on machines which use the IEEE floating point representation (very common, but not universal.) +.VE 8.5 .IP \fBR\fR 5 +.VS 8.5 This form is the same as \fBr\fR except that it stores the single-precision floating point numbers in big-endian order. +.VE 8.5 .IP \fBd\fR 5 This form is the same as \fBf\fR except that it stores one or more one or more double-precision floating point numbers in the machine's native representation in the output string. For example, on a Windows system running on an Intel Pentium processor, .RS -.PP .CS \fBbinary format\fR d1 {1.6} .CE -.PP -will return a binary string equivalent to: -.PP -.CS -\fB\ex9a\ex99\ex99\ex99\ex99\ex99\exf9\ex3f\fR -.CE +will return a string equivalent to +\fB\ex9a\ex99\ex99\ex99\ex99\ex99\exf9\ex3f\fR. .RE .IP \fBq\fR 5 +.VS 8.5 This form (mnemonically the mirror of \fBd\fR) is the same as \fBd\fR except that it stores the double-precision floating point numbers in little-endian order. This conversion only produces meaningful output when used on machines which use the IEEE floating point representation (very common, but not universal.) +.VE 8.5 .IP \fBQ\fR 5 +.VS 8.5 This form is the same as \fBq\fR except that it stores the double-precision floating point numbers in big-endian order. +.VE 8.5 .IP \fBx\fR 5 Stores \fIcount\fR null bytes in the output string. If \fIcount\fR is -not specified, stores one null byte. If \fIcount\fR is -.QW \fB*\fR , +not specified, stores one null byte. If \fIcount\fR is \fB*\fR, generates an error. This type does not consume an argument. For example, .RS -.PP .CS \fBbinary format\fR a3xa3x2a3 abc def ghi .CE -.PP -will return a binary string equivalent to: -.PP -.CS -\fBabc\e000def\e000\e000ghi\fR -.CE +will return a string equivalent to \fBabc\e000def\e000\e000ghi\fR. .RE .IP \fBX\fR 5 Moves the cursor back \fIcount\fR bytes in the output string. If -\fIcount\fR is -.QW \fB*\fR -or is larger than the current cursor position, +\fIcount\fR is \fB*\fR or is larger than the current cursor position, then the cursor is positioned at location 0 so that the next byte stored will be the first byte in the result string. If \fIcount\fR is omitted then the cursor is moved back one byte. This type does not consume an argument. For example, .RS -.PP .CS \fBbinary format\fR a3X*a3X2a3 abc def ghi .CE -.PP will return \fBdghi\fR. .RE .IP \fB@\fR 5 Moves the cursor to the absolute location in the output string specified by \fIcount\fR. Position 0 refers to the first byte in the output string. If \fIcount\fR refers to a position beyond the last byte stored so far, then null bytes will be placed in the uninitialized locations and the cursor will be placed at the specified location. If -\fIcount\fR is -.QW \fB*\fR , -then the cursor is moved to the current end of +\fIcount\fR is \fB*\fR, then the cursor is moved to the current end of the output string. If \fIcount\fR is omitted, then an error will be generated. This type does not consume an argument. For example, .RS -.PP .CS \fBbinary format\fR a5@2a1@*a3@10a1 abcde f ghi j .CE -.PP -will return -.PP -.CS -\fBabfdeghi\e000\e000j\fR -.CE +will return \fBabfdeghi\e000\e000j\fR. .RE .SH "BINARY SCAN" .PP The \fBbinary scan\fR command parses fields from a binary string, returning the number of conversions performed. \fIString\fR gives the @@ -621,13 +396,12 @@ Most field specifiers consume one argument to obtain the variable into which the scanned values should be placed. The type character specifies how the binary data is to be interpreted. The \fIcount\fR typically indicates how many items of the specified type are taken from the data. If present, the -\fIcount\fR is a non-negative decimal integer or -.QW \fB*\fR , -which normally indicates that all of the remaining items in the data are to +\fIcount\fR is a non-negative decimal integer or \fB*\fR, which +normally indicates that all of the remaining items in the data are to be used. If there are not enough bytes left after the current cursor position to satisfy the current field specifier, then the corresponding variable is left untouched and \fBbinary scan\fR returns immediately with the number of variables that were set. If there are not enough arguments for all of the fields in the format string that @@ -637,11 +411,10 @@ is accepted for all field types but is ignored for non-integer fields. .PP A similar example as with \fBbinary format\fR should explain the relation between field specifiers and arguments in case of the binary scan subcommand: -.PP .CS \fBbinary scan\fR $bytes s3s first second .CE .PP This command (provided the binary string in the variable \fIbytes\fR @@ -649,19 +422,16 @@ \fIfirst\fR and assigns a single value to the variable \fIsecond\fR. If \fIbytes\fR contains fewer than 8 bytes (i.e. four 2-byte integers), no assignment to \fIsecond\fR will be made, and if \fIbytes\fR contains fewer than 6 bytes (i.e. three 2-byte integers), no assignment to \fIfirst\fR will be made. Hence: -.PP .CS puts [\fBbinary scan\fR abcdefg s3s first second] puts $first puts $second .CE -.PP will print (assuming neither variable is set previously): -.PP .CS 1 25185 25699 26213 can't read "second": no such variable .CE @@ -669,21 +439,18 @@ It is \fIimportant\fR to note that the \fBc\fR, \fBs\fR, and \fBS\fR (and \fBi\fR and \fBI\fR on 64bit systems) will be scanned into long data size values. In doing this, values that have their high bit set (0x80 for chars, 0x8000 for shorts, 0x80000000 for ints), will be sign extended. Thus the following will occur: -.PP .CS set signShort [\fBbinary format\fR s1 0x8000] \fBbinary scan\fR $signShort s1 val; \fI# val == 0xFFFF8000\fR .CE -.PP If you require unsigned values you can include the .QW u flag character following the field type. For example, to read an unsigned short value: -.PP .CS set signShort [\fBbinary format\fR s1 0x8000] \fBbinary scan\fR $signShort su1 val; \fI# val == 0x00008000\fR .CE .PP @@ -690,45 +457,38 @@ Each type-count pair moves an imaginary cursor through the binary data, reading bytes from the current position. The cursor is initially at position 0 at the beginning of the data. The type may be any one of the following characters: .IP \fBa\fR 5 -The data is a byte string of length \fIcount\fR. If \fIcount\fR is -.QW \fB*\fR , -then all of the remaining bytes in \fIstring\fR will be +The data is a byte string of length \fIcount\fR. If \fIcount\fR +is \fB*\fR, then all of the remaining bytes in \fIstring\fR will be scanned into the variable. If \fIcount\fR is omitted, then one byte will be scanned. All bytes scanned will be interpreted as being characters in the range \eu0000-\eu00ff so the \fBencoding convertfrom\fR command will be needed if the string is not a binary string or a string encoded in ISO 8859\-1. For example, .RS -.PP .CS \fBbinary scan\fR abcde\e000fghi a6a10 var1 var2 .CE -.PP will return \fB1\fR with the string equivalent to \fBabcde\e000\fR stored in \fIvar1\fR and \fIvar2\fR left unmodified, and -.PP .CS \fBbinary scan\fR \e342\e202\e254 a* var1 set var2 [encoding convertfrom utf-8 $var1] .CE -.PP will store a Euro-currency character in \fIvar2\fR. .RE .IP \fBA\fR 5 This form is the same as \fBa\fR, except trailing blanks and nulls are stripped from the scanned value before it is stored in the variable. For example, .RS -.PP .CS \fBbinary scan\fR "abc efghi \e000" A* var1 .CE -.PP will return \fB1\fR with \fBabc efghi\fR stored in \fIvar1\fR. .RE .IP \fBb\fR 5 The data is turned into a string of \fIcount\fR binary digits in low-to-high order represented as a sequence of @@ -735,32 +495,27 @@ .QW 1 and .QW 0 characters. The data bytes are scanned in first to last order with the bits being taken in low-to-high order within each byte. Any extra -bits in the last byte are ignored. If \fIcount\fR is -.QW \fB*\fR , -then all of the remaining bits in \fIstring\fR will be scanned. If +bits in the last byte are ignored. If \fIcount\fR is \fB*\fR, then +all of the remaining bits in \fIstring\fR will be scanned. If \fIcount\fR is omitted, then one bit will be scanned. For example, .RS -.PP .CS \fBbinary scan\fR \ex07\ex87\ex05 b5b* var1 var2 .CE -.PP will return \fB2\fR with \fB11100\fR stored in \fIvar1\fR and \fB1110000110100000\fR stored in \fIvar2\fR. .RE .IP \fBB\fR 5 This form is the same as \fBb\fR, except the bits are taken in high-to-low order within each byte. For example, .RS -.PP .CS \fBbinary scan\fR \ex70\ex87\ex05 B5B* var1 var2 .CE -.PP will return \fB2\fR with \fB01110\fR stored in \fIvar1\fR and \fB1000011100000101\fR stored in \fIvar2\fR. .RE .IP \fBH\fR 5 The data is turned into a string of \fIcount\fR hexadecimal digits in @@ -767,267 +522,247 @@ high-to-low order represented as a sequence of characters in the set .QW 0123456789abcdef . The data bytes are scanned in first to last order with the hex digits being taken in high-to-low order within each byte. Any extra bits in the last byte are ignored. If \fIcount\fR is -.QW \fB*\fR , -then all of the remaining hex digits in \fIstring\fR will be +\fB*\fR, then all of the remaining hex digits in \fIstring\fR will be scanned. If \fIcount\fR is omitted, then one hex digit will be scanned. For example, .RS -.PP .CS \fBbinary scan\fR \ex07\exC6\ex05\ex1f\ex34 H3H* var1 var2 .CE -.PP will return \fB2\fR with \fB07c\fR stored in \fIvar1\fR and \fB051f34\fR stored in \fIvar2\fR. .RE .IP \fBh\fR 5 This form is the same as \fBH\fR, except the digits are taken in reverse (low-to-high) order within each byte. For example, .RS -.PP .CS \fBbinary scan\fR \ex07\ex86\ex05\ex12\ex34 h3h* var1 var2 .CE -.PP will return \fB2\fR with \fB706\fR stored in \fIvar1\fR and \fB502143\fR stored in \fIvar2\fR. -.PP +.RE Note that most code that wishes to parse the hexadecimal digits from multiple bytes in order should use the \fBH\fR format. -.RE .IP \fBc\fR 5 The data is turned into \fIcount\fR 8-bit signed integers and stored -in the corresponding variable as a list, or as unsigned if \fBu\fR is placed -immediately after the \fBc\fR. If \fIcount\fR is -.QW \fB*\fR , +in the corresponding variable as a list. If \fIcount\fR is \fB*\fR, then all of the remaining bytes in \fIstring\fR will be scanned. If \fIcount\fR is omitted, then one 8-bit integer will be scanned. For example, .RS -.PP .CS \fBbinary scan\fR \ex07\ex86\ex05 c2c* var1 var2 .CE -.PP will return \fB2\fR with \fB7 -122\fR stored in \fIvar1\fR and \fB5\fR -stored in \fIvar2\fR. Note that the integers returned are signed unless -\fBcu\fR in place of \fBc\fR. +stored in \fIvar2\fR. Note that the integers returned are signed, but +they can be converted to unsigned 8-bit quantities using an expression +like: +.CS +set num [expr { $num & 0xFF }] +.CE .RE .IP \fBs\fR 5 The data is interpreted as \fIcount\fR 16-bit signed integers -represented in little-endian byte order, or as unsigned if \fBu\fR is placed -immediately after the \fBs\fR. The integers are stored in -the corresponding variable as a list. If \fIcount\fR is -.QW \fB*\fR , -then all of the remaining bytes in \fIstring\fR will be scanned. If +represented in little-endian byte order. The integers are stored in +the corresponding variable as a list. If \fIcount\fR is \fB*\fR, then +all of the remaining bytes in \fIstring\fR will be scanned. If \fIcount\fR is omitted, then one 16-bit integer will be scanned. For example, .RS -.PP .CS \fBbinary scan\fR \ex05\ex00\ex07\ex00\exf0\exff s2s* var1 var2 .CE -.PP will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB\-16\fR -stored in \fIvar2\fR. Note that the integers returned are signed unless -\fBsu\fR is used in place of \fBs\fR. +stored in \fIvar2\fR. Note that the integers returned are signed, but +they can be converted to unsigned 16-bit quantities using an expression +like: +.CS +set num [expr { $num & 0xFFFF }] +.CE .RE .IP \fBS\fR 5 This form is the same as \fBs\fR except that the data is interpreted -as \fIcount\fR 16-bit integers represented in big-endian byte +as \fIcount\fR 16-bit signed integers represented in big-endian byte order. For example, .RS -.PP .CS \fBbinary scan\fR \ex00\ex05\ex00\ex07\exff\exf0 S2S* var1 var2 .CE -.PP will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB\-16\fR -stored in \fIvar2\fR. +stored in \fIvar2\fR. .RE .IP \fBt\fR 5 +.VS 8.5 The data is interpreted as \fIcount\fR 16-bit signed integers represented in the native byte order of the machine running the Tcl -script, or as unsigned if \fBu\fR is placed -immediately after the \fBt\fR. It is otherwise identical to \fBs\fR and \fBS\fR. +script. It is otherwise identical to \fBs\fR and \fBS\fR. To determine what the native byte order of the machine is, refer to the \fBbyteOrder\fR element of the \fBtcl_platform\fR array. +.VE 8.5 .IP \fBi\fR 5 The data is interpreted as \fIcount\fR 32-bit signed integers -represented in little-endian byte order, or as unsigned if \fBu\fR is placed -immediately after the \fBi\fR. The integers are stored in -the corresponding variable as a list. If \fIcount\fR is -.QW \fB*\fR , -then all of the remaining bytes in \fIstring\fR will be scanned. If +represented in little-endian byte order. The integers are stored in +the corresponding variable as a list. If \fIcount\fR is \fB*\fR, then +all of the remaining bytes in \fIstring\fR will be scanned. If \fIcount\fR is omitted, then one 32-bit integer will be scanned. For example, .RS -.PP .CS set str \ex05\ex00\ex00\ex00\ex07\ex00\ex00\ex00\exf0\exff\exff\exff \fBbinary scan\fR $str i2i* var1 var2 .CE -.PP will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB\-16\fR -stored in \fIvar2\fR. Note that the integers returned are signed unless -\fBiu\fR is used in place of \fBi\fR. +stored in \fIvar2\fR. Note that the integers returned are signed, but +they can be converted to unsigned 32-bit quantities using an expression +like: +.CS +set num [expr { $num & 0xFFFFFFFF }] +.CE .RE .IP \fBI\fR 5 This form is the same as \fBI\fR except that the data is interpreted as \fIcount\fR 32-bit signed integers represented in big-endian byte -order, or as unsigned if \fBu\fR is placed -immediately after the \fBI\fR. For example, +order. For example, .RS -.PP .CS set str \ex00\ex00\ex00\ex05\ex00\ex00\ex00\ex07\exff\exff\exff\exf0 \fBbinary scan\fR $str I2I* var1 var2 .CE -.PP will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB\-16\fR stored in \fIvar2\fR. .RE .IP \fBn\fR 5 +.VS 8.5 The data is interpreted as \fIcount\fR 32-bit signed integers represented in the native byte order of the machine running the Tcl -script, or as unsigned if \fBu\fR is placed -immediately after the \fBn\fR. It is otherwise identical to \fBi\fR and \fBI\fR. +script. It is otherwise identical to \fBi\fR and \fBI\fR. To determine what the native byte order of the machine is, refer to the \fBbyteOrder\fR element of the \fBtcl_platform\fR array. +.VE 8.5 .IP \fBw\fR 5 The data is interpreted as \fIcount\fR 64-bit signed integers -represented in little-endian byte order, or as unsigned if \fBu\fR is placed -immediately after the \fBw\fR. The integers are stored in -the corresponding variable as a list. If \fIcount\fR is -.QW \fB*\fR , -then all of the remaining bytes in \fIstring\fR will be scanned. If +represented in little-endian byte order. The integers are stored in +the corresponding variable as a list. If \fIcount\fR is \fB*\fR, then +all of the remaining bytes in \fIstring\fR will be scanned. If \fIcount\fR is omitted, then one 64-bit integer will be scanned. For example, .RS -.PP .CS set str \ex05\ex00\ex00\ex00\ex07\ex00\ex00\ex00\exf0\exff\exff\exff \fBbinary scan\fR $str wi* var1 var2 .CE -.PP will return \fB2\fR with \fB30064771077\fR stored in \fIvar1\fR and -\fB\-16\fR stored in \fIvar2\fR. +\fB\-16\fR stored in \fIvar2\fR. Note that the integers returned are +signed and cannot be represented by Tcl as unsigned values. .RE .IP \fBW\fR 5 This form is the same as \fBw\fR except that the data is interpreted as \fIcount\fR 64-bit signed integers represented in big-endian byte -order, or as unsigned if \fBu\fR is placed -immediately after the \fBW\fR. For example, +order. For example, .RS -.PP .CS set str \ex00\ex00\ex00\ex05\ex00\ex00\ex00\ex07\exff\exff\exff\exf0 \fBbinary scan\fR $str WI* var1 var2 .CE -.PP will return \fB2\fR with \fB21474836487\fR stored in \fIvar1\fR and \fB\-16\fR stored in \fIvar2\fR. .RE .IP \fBm\fR 5 +.VS 8.5 The data is interpreted as \fIcount\fR 64-bit signed integers represented in the native byte order of the machine running the Tcl -script, or as unsigned if \fBu\fR is placed -immediately after the \fBm\fR. It is otherwise identical to \fBw\fR and \fBW\fR. +script. It is otherwise identical to \fBw\fR and \fBW\fR. To determine what the native byte order of the machine is, refer to the \fBbyteOrder\fR element of the \fBtcl_platform\fR array. +.VE 8.5 .IP \fBf\fR 5 The data is interpreted as \fIcount\fR single-precision floating point numbers in the machine's native representation. The floating point numbers are stored in the corresponding variable as a list. If -\fIcount\fR is -.QW \fB*\fR , -then all of the remaining bytes in +\fIcount\fR is \fB*\fR, then all of the remaining bytes in \fIstring\fR will be scanned. If \fIcount\fR is omitted, then one single-precision floating point number will be scanned. The size of a floating point number may vary across architectures, so the number of bytes that are scanned may vary. If the data does not represent a valid floating point number, the resulting value is undefined and compiler dependent. For example, on a Windows system running on an Intel Pentium processor, .RS -.PP .CS \fBbinary scan\fR \ex3f\excc\excc\excd f var1 .CE -.PP will return \fB1\fR with \fB1.6000000238418579\fR stored in \fIvar1\fR. .RE .IP \fBr\fR 5 +.VS 8.5 This form is the same as \fBf\fR except that the data is interpreted as \fIcount\fR single-precision floating point number in little-endian order. This conversion is not portable to the minority of systems not using IEEE floating point representations. +.VE 8.5 .IP \fBR\fR 5 +.VS 8.5 This form is the same as \fBf\fR except that the data is interpreted as \fIcount\fR single-precision floating point number in big-endian order. This conversion is not portable to the minority of systems not using IEEE floating point representations. +.VE 8.5 .IP \fBd\fR 5 This form is the same as \fBf\fR except that the data is interpreted as \fIcount\fR double-precision floating point numbers in the machine's native representation. For example, on a Windows system running on an Intel Pentium processor, .RS -.PP .CS \fBbinary scan\fR \ex9a\ex99\ex99\ex99\ex99\ex99\exf9\ex3f d var1 .CE -.PP will return \fB1\fR with \fB1.6000000000000001\fR stored in \fIvar1\fR. .RE .IP \fBq\fR 5 +.VS 8.5 This form is the same as \fBd\fR except that the data is interpreted as \fIcount\fR double-precision floating point number in little-endian order. This conversion is not portable to the minority of systems not using IEEE floating point representations. +.VE 8.5 .IP \fBQ\fR 5 +.VS 8.5 This form is the same as \fBd\fR except that the data is interpreted as \fIcount\fR double-precision floating point number in big-endian order. This conversion is not portable to the minority of systems not using IEEE floating point representations. +.VE 8.5 .IP \fBx\fR 5 Moves the cursor forward \fIcount\fR bytes in \fIstring\fR. If -\fIcount\fR is -.QW \fB*\fR -or is larger than the number of bytes after the +\fIcount\fR is \fB*\fR or is larger than the number of bytes after the current cursor position, then the cursor is positioned after the last byte in \fIstring\fR. If \fIcount\fR is omitted, then the cursor is moved forward one byte. Note that this type does not consume an argument. For example, .RS -.PP .CS \fBbinary scan\fR \ex01\ex02\ex03\ex04 x2H* var1 .CE -.PP will return \fB1\fR with \fB0304\fR stored in \fIvar1\fR. .RE .IP \fBX\fR 5 Moves the cursor back \fIcount\fR bytes in \fIstring\fR. If -\fIcount\fR is -.QW \fB*\fR -or is larger than the current cursor position, +\fIcount\fR is \fB*\fR or is larger than the current cursor position, then the cursor is positioned at location 0 so that the next byte scanned will be the first byte in \fIstring\fR. If \fIcount\fR is omitted then the cursor is moved back one byte. Note that this type does not consume an argument. For example, .RS -.PP .CS \fBbinary scan\fR \ex01\ex02\ex03\ex04 c2XH* var1 var2 .CE -.PP will return \fB2\fR with \fB1 2\fR stored in \fIvar1\fR and \fB020304\fR stored in \fIvar2\fR. .RE .IP \fB@\fR 5 Moves the cursor to the absolute location in the data string specified @@ -1034,31 +769,26 @@ by \fIcount\fR. Note that position 0 refers to the first byte in \fIstring\fR. If \fIcount\fR refers to a position beyond the end of \fIstring\fR, then the cursor is positioned after the last byte. If \fIcount\fR is omitted, then an error will be generated. For example, .RS -.PP .CS \fBbinary scan\fR \ex01\ex02\ex03\ex04 c2@1H* var1 var2 .CE -.PP will return \fB2\fR with \fB1 2\fR stored in \fIvar1\fR and \fB020304\fR stored in \fIvar2\fR. .RE .SH "PORTABILITY ISSUES" -.PP The \fBr\fR, \fBR\fR, \fBq\fR and \fBQ\fR conversions will only work reliably for transferring data between computers which are all using IEEE floating point representations. This is very common, but not universal. To transfer floating-point numbers portably between all architectures, use their textual representation (as produced by \fBformat\fR) instead. .SH EXAMPLES -.PP This is a procedure to write a Tcl string to a binary-encoded channel as UTF-8 data preceded by a length word: -.PP .CS proc \fIwriteString\fR {channel string} { set data [encoding convertto utf-8 $string] puts -nonewline [\fBbinary format\fR Ia* \e [string length $data] $data] @@ -1065,33 +795,18 @@ } .CE .PP This procedure reads a string from a channel that was written by the previously presented \fIwriteString\fR procedure: -.PP .CS proc \fIreadString\fR {channel} { if {![\fBbinary scan\fR [read $channel 4] I length]} { error "missing length" } set data [read $channel $length] return [encoding convertfrom utf-8 $data] } .CE -.PP -This converts the contents of a file (named in the variable \fIfilename\fR) to -base64 and prints them: -.PP -.CS -set f [open $filename rb] -set data [read $f] -close $f -puts [\fBbinary encode\fR base64 \-maxlen 64 $data] -.CE .SH "SEE ALSO" -encoding(n), format(n), scan(n), string(n), tcl_platform(n) +format(n), scan(n), tclvars(n) .SH KEYWORDS binary, format, scan -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/break.n ================================================================== --- doc/break.n +++ doc/break.n @@ -2,46 +2,44 @@ '\" Copyright (c) 1993-1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH break n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME break \- Abort looping command .SH SYNOPSIS \fBbreak\fR .BE + .SH DESCRIPTION .PP This command is typically invoked inside the body of a looping command such as \fBfor\fR or \fBforeach\fR or \fBwhile\fR. -It returns a 3 (\fBTCL_BREAK\fR) result code, which causes a break exception +It returns a \fBTCL_BREAK\fR code, which causes a break exception to occur. The exception causes the current script to be aborted out to the innermost containing loop command, which then aborts its execution and returns normally. Break exceptions are also handled in a few other situations, such as the \fBcatch\fR command, Tk event bindings, and the outermost scripts of procedure bodies. .SH EXAMPLE -.PP Print a line for each of the integers from 0 to 5: -.PP .CS for {set x 0} {$x<10} {incr x} { - if {$x > 5} { - \fBbreak\fR - } - puts "x is $x" + if {$x > 5} { + \fBbreak\fR + } + puts "x is $x" } .CE + .SH "SEE ALSO" catch(n), continue(n), for(n), foreach(n), return(n), while(n) + .SH KEYWORDS abort, break, loop -'\" Local Variables: -'\" mode: nroff -'\" End: DELETED doc/callback.n Index: doc/callback.n ================================================================== --- doc/callback.n +++ /dev/null @@ -1,88 +0,0 @@ -'\" -'\" Copyright (c) 2018 Donal K. Fellows -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH callback n 0.3 TclOO "TclOO Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -callback, mymethod \- generate callbacks to methods -.SH SYNOPSIS -.nf -package require TclOO - -\fBcallback\fR \fImethodName\fR ?\fIarg ...\fR? -\fBmymethod\fR \fImethodName\fR ?\fIarg ...\fR? -.fi -.BE -.SH DESCRIPTION -The \fBcallback\fR command, -'\" Based on notes in the tcllib docs, we know the provenance of mymethod -also called \fBmymethod\fR for compatibility with the ooutil and snit packages -of Tcllib, -and which should only be used from within the context of a call to a method -(i.e. inside a method, constructor or destructor body) is used to generate a -script fragment that will invoke the method, \fImethodName\fR, on the current -object (as reported by \fBself\fR) when executed. Any additional arguments -provided will be provided as leading arguments to the callback. The resulting -script fragment shall be a proper list. -.PP -Note that it is up to the caller to ensure that the current object is able to -handle the call of \fImethodName\fR; this command does not check that. -\fImethodName\fR may refer to any exported or unexported method, but may not -refer to a private method as those can only be invoked directly from within -methods. If there is no such method present at the point when the callback is -invoked, the standard \fBunknown\fR method handler will be called. -.SH EXAMPLE -This is a simple echo server class. The \fBcallback\fR command is used in two -places, to arrange for the incoming socket connections to be handled by the -\fIAccept\fR method, and to arrange for the incoming bytes on those -connections to be handled by the \fIReceive\fR method. -.PP -.CS -oo::class create EchoServer { - variable server clients - constructor {port} { - set server [socket -server [\fBcallback\fR Accept] $port] - set clients {} - } - destructor { - chan close $server - foreach client [dict keys $clients] { - chan close $client - } - } - - method Accept {channel clientAddress clientPort} { - dict set clients $channel [dict create \e - address $clientAddress port $clientPort] - chan event $channel readable [\fBcallback\fR Receive $channel] - } - method Receive {channel} { - if {[chan gets $channel line] >= 0} { - my echo $channel $line - } else { - chan close $channel - dict unset clients $channel - } - } - - method echo {channel line} { - dict with clients $channel { - chan puts $channel \e - [format {[%s:%d] %s} $address $port $line] - } - } -} -.CE -.SH "SEE ALSO" -chan(n), fileevent(n), my(n), self(n), socket(n), trace(n) -.SH KEYWORDS -callback, object -.\" Local Variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: ADDED doc/case.n Index: doc/case.n ================================================================== --- /dev/null +++ doc/case.n @@ -0,0 +1,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 Index: doc/catch.n ================================================================== --- doc/catch.n +++ doc/catch.n @@ -3,25 +3,26 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Contributions from Don Porter, NIST, 2003. (not subject to US copyright) '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH catch n "8.5" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME catch \- Evaluate script and trap exceptional returns .SH SYNOPSIS \fBcatch\fI script \fR?\fIresultVarName\fR? ?\fIoptionsVarName\fR? .BE + .SH DESCRIPTION .PP The \fBcatch\fR command may be used to prevent errors from aborting command -interpretation. The \fBcatch\fR command calls the Tcl interpreter recursively -to execute \fIscript\fR, and always returns without raising an error, +interpretation. The \fBcatch\fR command calls the Tcl interpreter recursively to +execute \fIscript\fR, and always returns without raising an error, regardless of any errors that might occur while executing \fIscript\fR. .PP If \fIscript\fR raises an error, \fBcatch\fR will return a non-zero integer value corresponding to the exceptional return code returned by evaluation of \fIscript\fR. Tcl defines the normal return code from script @@ -30,90 +31,66 @@ and 4 (\fBTCL_CONTINUE\fR). Errors during evaluation of a script are indicated by a return code of \fBTCL_ERROR\fR. The other exceptional return codes are returned by the \fBreturn\fR, \fBbreak\fR, and \fBcontinue\fR commands and in other special situations as documented. Tcl packages can define new commands that return other integer values as return codes as well, -and scripts that make use of the \fBreturn \-code\fR command can also +and scripts that make use of the \fBreturn -code\fR command can also have return codes other than the five defined by Tcl. .PP If the \fIresultVarName\fR argument is given, then the variable it names is -set to the result of the script evaluation. When the return code from the -script is 1 (\fBTCL_ERROR\fR), the value stored in \fIresultVarName\fR is an -error message. When the return code from the script is 0 (\fBTCL_OK\fR), the -value stored in \fIresultVarName\fR is the value returned from \fIscript\fR. +set to the result of the script evaluation. When the return code from +the script is 1 (\fBTCL_ERROR\fR), the value stored in \fIresultVarName\fR is an error +message. When the return code from the script is 0 (\fBTCL_OK\fR), the value +stored in \fIresultVarName\fR is the value returned from \fIscript\fR. .PP +.VS 8.5 If the \fIoptionsVarName\fR argument is given, then the variable it names is set to a dictionary of return options returned by evaluation -of \fIscript\fR. Tcl specifies two entries that are always +of \fIscript\fR. Tcl specifies two entries that are always defined in the dictionary: \fB\-code\fR and \fB\-level\fR. When the return code from evaluation of \fIscript\fR is not \fBTCL_RETURN\fR, the value of the \fB\-level\fR entry will be 0, and the value of the \fB\-code\fR entry will be the same as the return code. Only when the return code is \fBTCL_RETURN\fR will the values of 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. +When the return code from evaluation of \fIscript\fR is \fBTCL_ERROR\fR, +three additional entries are defined in the dictionary of return options +stored in \fIoptionsVarName\fR: \fB\-errorinfo\fR, \fB\-errorcode\fR, +and \fB\-errorline\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 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. .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. +.VE 8.5 .SH EXAMPLES -.PP The \fBcatch\fR command may be used in an \fBif\fR to branch based on the success of a script. -.PP .CS if { [\fBcatch\fR {open $someFile w} fid] } { puts stderr "Could not open $someFile for writing\en$fid" exit 1 } .CE .PP There are more complex examples of \fBcatch\fR usage in the documentation for the \fBreturn\fR command. -.SH "SEE ALSO" -break(n), continue(n), dict(n), error(n), errorCode(n), errorInfo(n), info(n), -return(n) + +.SH "SEE ALSO" +break(n), continue(n), dict(n), error(n), return(n), tclvars(n) + .SH KEYWORDS -catch, error, exception -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: +catch, error Index: doc/cd.n ================================================================== --- doc/cd.n +++ doc/cd.n @@ -2,46 +2,42 @@ '\" 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 cd n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME cd \- Change working directory .SH SYNOPSIS \fBcd \fR?\fIdirName\fR? .BE + .SH DESCRIPTION .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. +and (in a threaded environment) all threads. .SH EXAMPLES -.PP Change to the home directory of the user \fBfred\fR: -.PP .CS \fBcd\fR ~fred .CE .PP Change to the directory \fBlib\fR that is a sibling directory of the current one: -.PP .CS \fBcd\fR ../lib .CE + .SH "SEE ALSO" filename(n), glob(n), pwd(n) + .SH KEYWORDS working directory -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/chan.n ================================================================== --- doc/chan.n +++ doc/chan.n @@ -1,6 +1,6 @@ -'\" +'\" '\" Copyright (c) 2005-2006 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. .TH chan n 8.5 Tcl "Tcl Built-In Commands" @@ -29,64 +29,46 @@ process to block, and returns 1 if that was the case. It returns 0 otherwise. Note that this only ever returns 1 when the channel has been configured to be non-blocking; all Tcl channels have blocking turned on by default. .TP -\fBchan close \fIchannelId\fR ?\fIdirection\fR? +\fBchan close \fIchannelId\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 -closed). +channel's output device, any buffered input is discarded, the +underlying operating system resource is closed and \fIchannelId\fR +becomes unavailable for future use. .PP -If the channel is blocking and the channel is ceasing to be writable, the -command does not return until all output is flushed. If the channel is -non-blocking and there is unflushed output, the channel remains open and the -command returns immediately; output will be flushed in the background and the -channel will be closed when all the flushing is complete. +If the channel is blocking, the command does not return until all +output is flushed. If the channel is nonblocking and there is +unflushed output, the channel remains open and the command returns +immediately; output will be flushed in the background and the channel +will be closed when all the flushing is complete. .PP If \fIchannelId\fR is a blocking channel for a command pipeline then \fBchan close\fR waits for the child processes to complete. .PP If the channel is shared between interpreters, then \fBchan close\fR makes \fIchannelId\fR unavailable in the invoking interpreter but has no other effect until all of the sharing interpreters have closed the channel. When the last interpreter in which the channel is registered invokes \fBchan close\fR (or \fBclose\fR), the cleanup actions -described above occur. With half-closing, the half-close of the channel only -applies to the current interpreter's view of the channel until all channels -have closed it in that direction (or completely). -See the \fBinterp\fR command for a description of channel sharing. +described above occur. See the \fBinterp\fR command for a description +of channel sharing. .PP -Channels are automatically fully closed when an interpreter is destroyed and +Channels are automatically closed when an interpreter is destroyed and when the process exits. Channels are switched to blocking mode, to ensure that all output is correctly flushed before the process exits. .PP The command returns an empty string, and may generate an error if an error occurs while flushing output. If a command in a command pipeline created with \fBopen\fR returns an error, \fBchan close\fR generates an error (similar to the \fBexec\fR command.) -.PP -Note that half-closes of sockets and command pipelines can have important side -effects because they result in a shutdown() or close() of the underlying -system resource, which can change how other processes or systems respond to -the Tcl program. .RE .TP \fBchan configure \fIchannelId\fR ?\fIoptionName\fR? ?\fIvalue\fR? ?\fIoptionName value\fR?... . Query or set the configuration options of the channel named @@ -101,25 +83,24 @@ the command sets each of the named options to the corresponding \fIvalue\fR; in this case the return value is an empty string. .PP The options described below are supported for all channels. In addition, each channel type may add options that only it supports. See -the manual entry for the command that creates each type of channel -for the options supported by that specific type of channel. For -example, see the manual entry for the \fBsocket\fR command for additional -options for sockets, and the \fBopen\fR command for additional options for -serial devices. +the manual entry for the command that creates each type of channels +for the options that that specific type of channel supports. For +example, see the manual entry for the \fBsocket\fR command for its +additional options. .TP \fB\-blocking\fR \fIboolean\fR . The \fB\-blocking\fR option determines whether I/O operations on the channel can cause the process to block indefinitely. The value of the option must be a proper boolean value. Channels are normally in -blocking mode; if a channel is placed into non-blocking mode it will +blocking mode; if a channel is placed into nonblocking mode it will affect the operation of the \fBchan gets\fR, \fBchan read\fR, \fBchan puts\fR, \fBchan flush\fR, and \fBchan close\fR commands; see the -documentation for those commands for details. For non-blocking mode to +documentation for those commands for details. For nonblocking mode to work correctly, the application must be using the Tcl event loop (e.g. by calling \fBTcl_DoOneEvent\fR or invoking the \fBvwait\fR command). .TP \fB\-buffering\fR \fInewValue\fR @@ -194,11 +175,11 @@ attempting to set \fB\-eofchar\fR to a value outside of this range will generate an error. .TP \fB\-translation\fR \fImode\fR .TP -\fB\-translation\fR \fB{\fIinMode outMode\fB}\fR +\fB\-translation\fR \fB{\fIinMode outMode\fB}\fR . In Tcl scripts the end of a line is always represented using a single newline character (\en). However, in actual files and devices the end of a line may be represented differently on different platforms, or even for different devices on the same platform. For example, under @@ -234,11 +215,11 @@ all platforms Tcl chooses \fBcrlf\fR, for all Unix flavors, it chooses \fBlf\fR, and for the various flavors of Windows it chooses \fBcrlf\fR. The default setting for \fB\-translation\fR is \fBauto\fR for both input and output. .TP -\fBbinary\fR +\fBbinary\fR . No end-of-line translations are performed. This is nearly identical to \fBlf\fR mode, except that in addition \fBbinary\fR mode also sets the end-of-file character to the empty string (which disables it) and sets the encoding to \fBbinary\fR (which disables encoding filtering). @@ -281,18 +262,16 @@ buffering too much data in main memory when copying large files to slow destinations like network sockets. .RS .PP The \fBchan copy\fR command transfers data from \fIinputChan\fR until -end of file or \fIsize\fR bytes or characters have been transferred; -\fIsize\fR is in bytes if the two channels are using the same encoding, -and is in characters otherwise. If no \fB\-size\fR argument is given, -then the copy goes until end of file. All the data read from -\fIinputChan\fR is copied to \fIoutputChan\fR. Without the -\fB\-command\fR option, \fBchan copy\fR blocks until the copy is -complete and returns the number of bytes or characters (using the same -rules as for the \fB\-size\fR option) written to \fIoutputChan\fR. +end of file or \fIsize\fR bytes have been transferred. If no +\fB\-size\fR argument is given, then the copy goes until end of file. +All the data read from \fIinputChan\fR is copied to \fIoutputChan\fR. +Without the \fB\-command\fR option, \fBchan copy\fR blocks until the +copy is complete and returns the number of bytes written to +\fIoutputChan\fR. .PP The \fB\-command\fR argument makes \fBchan copy\fR work in the background. In this case it returns immediately and the \fIcallback\fR is invoked later when the copy completes. The \fIcallback\fR is called with one or two additional arguments that @@ -347,11 +326,11 @@ . This subcommand creates a new script level channel using the command prefix \fIcmdPrefix\fR as its handler. Any such channel is called a \fBreflected\fR channel. The specified command prefix, \fBcmdPrefix\fR, must be a non-empty list, and should provide the API described in the -\fBrefchan\fR manual page. The handle of the new channel is +\fBreflectedchan\fR manual page. The handle of the new channel is returned as the result of the \fBchan create\fR command, and the channel is open. Use either \fBclose\fR or \fBchan close\fR to remove the channel. .RS .PP @@ -366,11 +345,11 @@ sense. The handler command for the new channel must support the chosen mode, or an error is thrown. .PP The command prefix is executed in the global namespace, at the top of call stack, following the appending of arguments as described in the -\fBrefchan\fR manual page. Command resolution happens at the +\fBreflectedchan\fR manual page. Command resolution happens at the time of the call. Renaming the command, or destroying it means that the next call of a handler method may fail, causing the channel command invoking the handler to fail as well. Depending on the subcommand being invoked, the error message may not be able to explain the reason for that failure. @@ -395,11 +374,11 @@ commands. .PP When a thread or interpreter is deleted, all channels created with this subcommand and using this thread/interpreter as their computing base are deleted as well, in all interpreters they have been shared -with or moved into, and in whatever thread they have been transferred +with or moved into, and in whatever thread they have been transfered to. While this pulls the rug out under the other thread(s) and/or interpreter(s), this cannot be avoided. Trying to use such a channel will cause the generation of a regular error about unknown channel handles. .PP @@ -449,11 +428,11 @@ available on the underlying device. A channel is also considered to be readable if there is unread data in an input buffer, except in the special case where the most recent attempt to read from the channel was a \fBchan gets\fR call that could not find a complete line in the input buffer. This feature allows a file to be read a line at a time -in non-blocking mode using events. A channel is also considered to be +in nonblocking mode using events. A channel is also considered to be readable if an end of file or error condition is present on the underlying file or device. It is important for \fIscript\fR to check for these conditions and handle them appropriately; for example, if there is no special check for end of file, an infinite loop may occur where \fIscript\fR reads no data, returns, and is immediately invoked @@ -464,16 +443,16 @@ if an error condition is present on the underlying file or device. Note that client sockets opened in asynchronous mode become writable when they become connected or if the connection fails. .PP Event-driven I/O works best for channels that have been placed into -non-blocking mode with the \fBchan configure\fR command. In blocking +nonblocking mode with the \fBchan configure\fR command. In blocking mode, a \fBchan puts\fR command may block if you give it more data than the underlying file or device can accept, and a \fBchan gets\fR or \fBchan read\fR command will block if you attempt to read more data than is ready; no events will be processed while the commands block. -In non-blocking mode \fBchan puts\fR, \fBchan read\fR, and \fBchan +In nonblocking mode \fBchan puts\fR, \fBchan read\fR, and \fBchan gets\fR never block. .PP The script for a file event is executed at global level (outside the context of any Tcl procedure) in the interpreter in which the \fBchan event\fR command was invoked. If an error occurs while executing the @@ -489,11 +468,11 @@ is written. .RS .PP If the channel is in blocking mode the command does not return until all the buffered output has been flushed to the channel. If the -channel is in non-blocking mode, the command may return before all +channel is in nonblocking mode, the command may return before all buffered output has been flushed; the remainder will be flushed in the background as fast as the underlying file or device is able to absorb it. .RE .TP @@ -512,11 +491,11 @@ .PP If an end-of-file occurs while part way through reading a line, the partial line will be returned (or written into \fIvarName\fR). When \fIvarName\fR is not specified, the end-of-file case can be distinguished from an empty line using the \fBchan eof\fR command, and -the partial-line-but-non-blocking case can be distinguished with the +the partial-line-but-nonblocking case can be distinguished with the \fBchan blocked\fR command. .RE .TP \fBchan names\fR ?\fIpattern\fR? . @@ -526,46 +505,17 @@ .TP \fBchan pending \fImode channelId\fR . Depending on whether \fImode\fR is \fBinput\fR or \fBoutput\fR, returns the number of -bytes of input or output (respectively) currently buffered -internally for \fIchannelId\fR (especially useful in a readable event +bytes of input or output (respectively) currently buffered +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 @@ -587,11 +537,11 @@ other interpreter will cause this subcommand to report an error. .PP Another restriction is that it is not possible to post events that the I/O core has not registered an interest in. Trying to do so will cause the method to throw an error. See the command handler method -\fBwatch\fR described in \fBrefchan\fR, the document specifying +\fBwatch\fR described in \fBreflectedchan\fR, the document specifying the API of command handlers for reflected channels. .PP This command is \fBsafe\fR and made accessible to safe interpreters. It can trigger the execution of \fBchan event\fR handlers, whether in the current interpreter or in other interpreters or other threads, even @@ -598,20 +548,10 @@ 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 @@ -632,20 +572,20 @@ closed. You can force output to appear immediately with the \fBchan flush\fR command. .PP When the output buffer fills up, the \fBchan puts\fR command will normally block until all the buffered data has been accepted for -output by the operating system. If \fIchannelId\fR is in non-blocking +output by the operating system. If \fIchannelId\fR is in nonblocking mode then the \fBchan puts\fR command will not block even if the operating system cannot accept the data. Instead, Tcl continues to buffer the data and writes it in the background as fast as the underlying file or device can accept it. The application must use the -Tcl event loop for non-blocking output to work; otherwise Tcl never +Tcl event loop for nonblocking output to work; otherwise Tcl never finds out that the file or device is ready for more output data. It is possible for an arbitrarily large amount of data to be buffered for -a channel in non-blocking mode, which could consume a large amount of -memory. To avoid wasting memory, non-blocking I/O should normally be +a channel in nonblocking mode, which could consume a large amount of +memory. To avoid wasting memory, nonblocking I/O should normally be used in an event-driven fashion with the \fBchan event\fR command (do not invoke \fBchan puts\fR unless you have recently been notified via a file event that the channel is ready for more output data). .RE .TP @@ -661,11 +601,11 @@ \fInumChars\fR has been omitted) the flag \fB\-nonewline\fR may be given to indicate that any trailing newline in the string that has been read should be trimmed. .RS .PP -If \fIchannelId\fR is in non-blocking mode, \fBchan read\fR may not +If \fIchannelId\fR is in nonblocking mode, \fBchan read\fR may not read as many characters as requested: once all available input has been read, the command will return the data that is available rather than blocking for more input. If the channel is configured to use a multi-byte encoding, then there may actually be some bytes remaining in the internal buffers that do not form a complete character. These @@ -677,16 +617,14 @@ newline characters according to the \fB\-translation\fR option for the channel (see \fBchan configure\fR above for a discussion on the ways in which \fBchan configure\fR will alter input). .PP When reading from a serial port, most applications should configure -the serial port channel to be non-blocking, like this: -.PP +the serial port channel to be nonblocking, like this: .CS \fBchan configure \fIchannelId \fB\-blocking \fI0\fR. .CE -.PP Then \fBchan read\fR behaves much like described above. Note that most serial ports are comparatively slow; it is entirely possible to get a \fBreadable\fR event for each character read from them. Care must be taken when using \fBchan read\fR on blocking serial ports: .TP @@ -730,11 +668,11 @@ position after the end of file. .PP The \fIorigin\fR argument defaults to \fBstart\fR. .PP \fBChan seek\fR flushes all buffered output for the channel before the -command returns, even if the channel is in non-blocking mode. It also +command returns, even if the channel is in nonblocking mode. It also discards any buffered and unread input. This command returns an empty string. An error occurs if this command is applied to channels whose underlying file or device does not support seeking. .PP Note that \fIoffset\fR values are byte offsets, not character offsets. @@ -755,13 +693,11 @@ . Sets the byte length of the underlying data stream for the channel named \fIchannelId\fR to be \fIlength\fR (or to the current byte offset within the underlying data stream if \fIlength\fR is omitted). The channel is flushed before truncation. -. -.SH EXAMPLES -.PP +.SH EXAMPLE This opens a file using a known encoding (CP1252, a very common encoding on Windows), searches for a string, rewrites that part, and truncates the file after a further two lines. .PP .CS @@ -769,72 +705,32 @@ \fBchan configure\fR $f -encoding cp1252 set offset 0 \fI# Search for string "FOOBAR" in the file\fR while {[\fBchan gets\fR $f line] >= 0} { - set idx [string first FOOBAR $line] - if {$idx >= 0} { - \fI# Found it; rewrite line\fR - - \fBchan seek\fR $f [expr {$offset + $idx}] - \fBchan puts\fR -nonewline $f BARFOO - - \fI# Skip to end of following line, and truncate\fR - \fBchan gets\fR $f - \fBchan gets\fR $f - \fBchan truncate\fR $f - - \fI# Stop searching the file now\fR - break - } - - \fI# Save offset of start of next line for later\fR - set offset [\fBchan tell\fR $f] + set idx [string first FOOBAR $line] + if {$idx > -1} { + \fI# Found it; rewrite line\fR + + \fBchan seek\fR $f [expr {$offset + $idx}] + \fBchan puts\fR -nonewline $f BARFOO + + \fI# Skip to end of following line, and truncate\fR + \fBchan gets\fR $f + \fBchan gets\fR $f + \fBchan truncate\fR $f + + \fI# Stop searching the file now\fR + break + } + + \fI# Save offset of start of next line for later\fR + set offset [\fBchan tell\fR $f] } \fBchan close\fR $f .CE -.PP -A network server that does echoing of its input line-by-line without -preventing servicing of other connections at the same time. -.PP -.CS -# This is a very simple logger... -proc log {message} { - \fBchan puts\fR stdout $message -} - -# This is called whenever a new client connects to the server -proc connect {chan host port} { - set clientName [format <%s:%d> $host $port] - log "connection from $clientName" - \fBchan configure\fR $chan -blocking 0 -buffering line - \fBchan event\fR $chan readable [list echoLine $chan $clientName] -} - -# This is called whenever either at least one byte of input -# data is available, or the channel was closed by the client. -proc echoLine {chan clientName} { - \fBchan gets\fR $chan line - if {[\fBchan eof\fR $chan]} { - log "finishing connection from $clientName" - \fBchan close\fR $chan - } elseif {![\fBchan blocked\fR $chan]} { - # Didn't block waiting for end-of-line - log "$clientName - $line" - \fBchan puts\fR $chan $line - } -} - -# Create the server socket and enter the event-loop to wait -# for incoming connections... -socket -server connect 12345 -vwait forever -.CE .SH "SEE ALSO" close(n), eof(n), fblocked(n), fconfigure(n), fcopy(n), file(n), fileevent(n), flush(n), gets(n), open(n), puts(n), read(n), seek(n), -socket(n), tell(n), refchan(n), transchan(n) +socket(n), tell(n), refchan(n) .SH KEYWORDS channel, input, output, events, offset -'\" Local Variables: -'\" mode: nroff -'\" End: DELETED doc/class.n Index: doc/class.n ================================================================== --- doc/class.n +++ /dev/null @@ -1,136 +0,0 @@ -'\" -'\" Copyright (c) 2007 Donal K. Fellows -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH class n 0.1 TclOO "TclOO Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -oo::class \- class of all classes -.SH SYNOPSIS -.nf -package require TclOO - -\fBoo::class\fI method \fR?\fIarg ...\fR? -.fi -.SH "CLASS HIERARCHY" -.nf -\fBoo::object\fR - \(-> \fBoo::class\fR -.fi -.BE -.SH DESCRIPTION -.PP -Classes are objects that can manufacture other objects according to a pattern -stored in the factory object (the class). An instance of the class is created -by calling one of the class's factory methods, typically either \fBcreate\fR -if an explicit name is being given, or \fBnew\fR if an arbitrary unique name -is to be automatically selected. -.PP -The \fBoo::class\fR class is the class of all classes; every class is an -instance of this class, which is consequently an instance of itself. This -class is a subclass of \fBoo::object\fR, so every class is also an object. -Additional metaclasses (i.e., classes of classes) can be defined if necessary -by subclassing \fBoo::class\fR. Note that the \fBoo::class\fR object hides the -\fBnew\fR method on itself, so new classes should always be made using the -\fBcreate\fR method. -.SS CONSTRUCTOR -.PP -The constructor of the \fBoo::class\fR class takes an optional argument which, -if present, is sent to the \fBoo::define\fR command (along with the name of -the newly-created class) to allow the class to be conveniently configured at -creation time. -.SS DESTRUCTOR -The \fBoo::class\fR class does not define an explicit destructor. However, -when a class is destroyed, all its subclasses and instances are also -destroyed, along with all objects that it has been mixed into. -.SS "EXPORTED METHODS" -.TP -\fIcls \fBcreate \fIname \fR?\fIarg ...\fR? -. -This creates a new instance of the class \fIcls\fR called \fIname\fR (which is -resolved within the calling context's namespace if not fully qualified), -passing the arguments, \fIarg ...\fR, to the constructor, and (if that returns -a successful result) returning the fully qualified name of the created object -(the result of the constructor is ignored). If the constructor fails (i.e. -returns a non-OK result) then the object is destroyed and the error message is -the result of this method call. -.TP -\fIcls \fBnew \fR?\fIarg ...\fR? -. -This creates a new instance of the class \fIcls\fR with a new unique name, -passing the arguments, \fIarg ...\fR, to the constructor, and (if that returns -a successful result) returning the fully qualified name of the created object -(the result of the constructor is ignored). If the constructor fails (i.e., -returns a non-OK result) then the object is destroyed and the error message is -the result of this method call. -.RS -.PP -Note that this method is not exported by the \fBoo::class\fR object itself, so -classes should not be created using this method. -.RE -.SS "NON-EXPORTED METHODS" -.PP -The \fBoo::class\fR class supports the following non-exported methods: -.TP -\fIcls \fBcreateWithNamespace\fI name nsName\fR ?\fIarg ...\fR? -. -This creates a new instance of the class \fIcls\fR called \fIname\fR (which is -resolved within the calling context's namespace if not fully qualified), -passing the arguments, \fIarg ...\fR, to the constructor, and (if that returns -a successful result) returning the fully qualified name of the created object -(the result of the constructor is ignored). The name of the instance's -internal namespace will be \fInsName\fR unless that namespace already exists -(when an arbitrary name will be chosen instead). If the constructor fails -(i.e., returns a non-OK result) then the object is destroyed and the error -message is the result of this method call. -.SH EXAMPLES -.PP -This example defines a simple class hierarchy and creates a new instance of -it. It then invokes a method of the object before destroying the hierarchy and -showing that the destruction is transitive. -.PP -.CS -\fBoo::class create\fR fruit { - method eat {} { - puts "yummy!" - } -} -\fBoo::class create\fR banana { - superclass fruit - constructor {} { - my variable peeled - set peeled 0 - } - method peel {} { - my variable peeled - set peeled 1 - puts "skin now off" - } - method edible? {} { - my variable peeled - return $peeled - } - method eat {} { - if {![my edible?]} { - my peel - } - next - } -} -set b [banana \fBnew\fR] -$b eat \fI\(-> prints "skin now off" and "yummy!"\fR -fruit destroy -$b eat \fI\(-> error "unknown command"\fR -.CE -.SH "SEE ALSO" -oo::define(n), oo::object(n) -.SH KEYWORDS -class, metaclass, object -.\" Local variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: DELETED doc/classvariable.n Index: doc/classvariable.n ================================================================== --- doc/classvariable.n +++ /dev/null @@ -1,78 +0,0 @@ -'\" -'\" Copyright (c) 2011-2015 Andreas Kupries -'\" Copyright (c) 2018 Donal K. Fellows -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH classvariable n 0.3 TclOO "TclOO Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -classvariable \- create link from local variable to variable in class -.SH SYNOPSIS -.nf -package require TclOO - -\fBclassvariable\fR \fIvariableName\fR ?\fI...\fR? -.fi -.BE -.SH DESCRIPTION -The \fBclassvariable\fR command is available within methods. It takes a series -of one or more variable names and makes them available in the method's scope; -those variable names must not be qualified and must not refer to array -elements. The originating scope for the variables is the namespace of the -class that the method was defined by. In other words, the referenced variables -are shared between all instances of that class. -.PP -Note: This command is equivalent to the command \fBtypevariable\fR provided by -the snit package in tcllib for approximately the same purpose. If used in a -method defined directly on a class instance (e.g., through the -\fBoo::objdefine\fR \fBmethod\fR definition) this is very much like just -using: -.PP -.CS -namespace upvar [namespace current] $var $var -.CE -.PP -for each variable listed to \fBclassvariable\fR. -.SH EXAMPLE -This class counts how many instances of it have been made. -.PP -.CS -oo::class create Counted { - initialise { - variable count 0 - } - - variable number - constructor {} { - \fBclassvariable\fR count - set number [incr count] - } - - method report {} { - \fBclassvariable\fR count - puts "This is instance $number of $count" - } -} - -set a [Counted new] -set b [Counted new] -$a report - \fI\(-> This is instance 1 of 2\fR -set c [Counted new] -$b report - \fI\(-> This is instance 2 of 3\fR -$c report - \fI\(-> This is instance 3 of 3\fR -.CE -.SH "SEE ALSO" -global(n), namespace(n), oo::class(n), oo::define(n), upvar(n), variable(n) -.SH KEYWORDS -class, class variable, variable -.\" Local Variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: Index: doc/clock.n ================================================================== --- doc/clock.n +++ doc/clock.n @@ -40,16 +40,16 @@ time value as a system-dependent integer value. The unit of the value is system-dependent but should be the highest resolution clock available on the system such as a CPU cycle counter. See \fBHIGH RESOLUTION TIMERS\fR for a full description. .RS .PP -If the \fI\-option\fR argument is \fB\-milliseconds\fR, then the command +If the \fI\-option\fR argument is \fI\-milliseconds\fR, then the command is synonymous with \fBclock milliseconds\fR (see below). This usage is obsolete, and \fBclock milliseconds\fR is to be considered the preferred way of obtaining a count of milliseconds. .PP -If the \fI\-option\fR argument is \fB\-microseconds\fR, then the command +If the \fI\-option\fR argument is \fI\-microseconds\fR, then the command is synonymous with \fBclock microseconds\fR (see below). This usage is obsolete, and \fBclock microseconds\fR is to be considered the preferred way of obtaining a count of microseconds. .RE .TP @@ -87,13 +87,14 @@ back in sync with UTC; its data model does not represent minutes that have 59 or 61 seconds. .TP \fIunit\fR One of the words, \fBseconds\fR, \fBminutes\fR, \fBhours\fR, -\fBdays\fR, \fBweekdays\fR, \fBweeks\fR, \fBmonths\fR, or \fByears\fR. -Used in conjunction with \fIcount\fR to identify an interval of time, -for example, \fI3 seconds\fR or \fI1 year\fR. +\fBdays\fR, \fBweeks\fR, \fBmonths\fR, or \fByears\fR, or +any unique prefix of such a word. Used in conjunction with \fIcount\fR +to identify an interval of time, for example, \fI3 seconds\fR or +\fI1 year\fR. .SS "OPTIONS" .TP \fB\-base\fR time Specifies that any relative times present in a \fBclock scan\fR command are to be given relative to \fItime\fR. \fItime\fR must be expressed as @@ -108,16 +109,15 @@ sequences beginning with the per-cent sign. The permissible format groups, and their interpretation, are described under \fBFORMAT GROUPS\fR. .RS .PP On \fBclock format\fR, the default format is -.PP .CS %a %b %d %H:%M:%S %Z %Y .CE .PP -On \fBclock scan\fR, the lack of a \fB\-format\fR option indicates that a +On \fBclock scan\fR, the lack of a \fI\-format\fR option indicates that a .QW "free format scan" is requested; see \fBFREE FORM SCAN\fR for a description of what happens. .RE .TP \fB\-gmt\fR boolean @@ -158,25 +158,24 @@ .IP [2] the environment variable \fBTZ\fR. .IP [3] on Windows systems, the time zone settings from the Control Panel. .RE -.PP If none of these is present, the C \fBlocaltime\fR and \fBmktime\fR functions are used to attempt to convert times between local and Greenwich. On 32-bit systems, this approach is likely to have bugs, particularly for times that lie outside the window (approximately the years 1902 to 2037) that can be represented in a 32-bit integer. .SH "CLOCK ARITHMETIC" -.PP The \fBclock add\fR command performs clock arithmetic on a value (expressed as nominal seconds from the epoch time of 1 January 1970, 00:00 UTC) given as its first argument. The remaining arguments (other than the possible \fB\-timezone\fR, \fB\-locale\fR and \fB\-gmt\fR options) are integers and keywords in alternation, where the keywords are chosen from \fBseconds\fR, \fBminutes\fR, \fBhours\fR, -\fBdays\fR, \fBweekdays\fR, \fBweeks\fR, \fBmonths\fR, or \fByears\fR. +\fBdays\fR, \fBweeks\fR, \fBmonths\fR, or \fByears\fR, or +any unique prefix of such a word. .PP Addition of seconds, minutes and hours is fairly straightforward; the given time increment (times sixty for minutes, or 3600 for hours) is simply added to the \fItimeVal\fR given to the \fBclock add\fR command. The result is interpreted as @@ -194,11 +193,10 @@ The fact that adding and subtracting hours is defined in terms of absolute time means that it will add fixed amounts of time in time zones that observe summer time (Daylight Saving Time). For example, the following code sets the value of \fBx\fR to \fB04:00:00\fR because the clock has changed in the interval in question. -.PP .CS set s [\fBclock scan\fR {2004-10-30 05:00:00} \e -format {%Y-%m-%d %H:%M:%S} \e -timezone :America/New_York] set a [\fBclock add\fR $s 24 hours -timezone :America/New_York] @@ -209,18 +207,16 @@ Adding and subtracting days and weeks is accomplished by converting the given time to a calendar day and time of day in the appropriate time zone and locale. The requisite number of days (weeks are converted to days by multiplying by seven) is added to the calendar day, and the date and time are then converted back to a count of seconds from -the epoch time. The \fBweekdays\fR keyword is similar to \fBdays\fR, -with the only difference that weekends - Saturdays and Sundays - are skipped. +the epoch time. .PP Adding and subtracting a given number of days across the point that the time changes at the start or end of summer time (Daylight Saving Time) results in the \fIsame local time\fR on the day in question. For instance, the following code sets the value of \fBx\fR to \fB05:00:00\fR. -.PP .CS set s [\fBclock scan\fR {2004-10-30 05:00:00} \e -format {%Y-%m-%d %H:%M:%S} \e -timezone :America/New_York] set a [\fBclock add\fR $s 1 day -timezone :America/New_York] @@ -232,11 +228,10 @@ on the same day, the earlier time is used. In cases where the conversion yields an impossible time (for instance, 02:30 during the Spring Daylight Saving Time change using US rules), the time is converted as if the clock had not changed. Thus, the following code will set the value of \fBx\fR to \fB03:30:00\fR. -.PP .CS set s [\fBclock scan\fR {2004-04-03 02:30:00} \e -format {%Y-%m-%d %H:%M:%S} \e -timezone :America/New_York] set a [\fBclock add\fR $s 1 day -timezone :America/New_York] @@ -245,11 +240,10 @@ .CE .PP Adding a given number of days or weeks works correctly across the conversion between the Julian and Gregorian calendars; the omitted days are skipped. The following code sets \fBz\fR to \fB1752-09-14\fR. -.PP .CS set x [\fBclock scan\fR 1752-09-02 -format %Y-%m-%d -locale en_US] set y [\fBclock add\fR $x 1 day -locale en_US] set z [\fBclock format\fR $y -format %Y-%m-%d -locale en_US] .CE @@ -274,11 +268,10 @@ years as they are when adding/subtracting days and weeks. .PP If multiple \fIcount unit\fR pairs are present on the command, they are evaluated consecutively, from left to right. .SH "HIGH RESOLUTION TIMERS" -.PP Most of the subcommands supported by the \fBclock\fR command deal with times represented as a count of seconds from the epoch time, and this is the representation that \fBclock seconds\fR returns. There are three exceptions, which are all intended for use where higher-resolution times are required. \fBclock milliseconds\fR returns the count of milliseconds from the @@ -289,11 +282,10 @@ of \fBclock clicks\fR is not guaranteed to be tied to any fixed epoch; it is simply intended to be the most precise interval timer available, and is intended only for relative timing studies such as benchmarks. .SH "FORMATTING TIMES" -.PP The \fBclock format\fR command produces times for display to a user or writing to an external medium. The command accepts times that are expressed in seconds from the epoch time of 1 January 1970, 00:00 UTC, as returned by \fBclock seconds\fR, \fBclock scan\fR, \fBclock add\fR, \fBfile atime\fR or \fBfile mtime\fR. @@ -328,11 +320,10 @@ Panel can be obtained by using the \fBsystem\fR locale. On platforms that do not define a user selection of date and time formats separate from \fBLC_TIME\fR, \fB\-locale\fR \fBsystem\fR is synonymous with \fB\-locale\fR \fBcurrent\fR. .SH "SCANNING TIMES" -.PP The \fBclock scan\fR command accepts times that are formatted as strings and converts them to counts of seconds from the epoch time of 1 January 1970, 00:00 UTC. It normally takes a \fB\-format\fR option that is followed by a string describing the expected format of the input. (See @@ -450,25 +441,11 @@ in the same day, once without and once with Daylight Saving Time. If this situation occurs, the first occurrence of the time is chosen. (For this reason, it is wise to have the input string contain the time zone when converting local times. This caveat does not apply to UTC times.) -.PP -If the interpretation of the groups yields an impossible time because -a field is out of range, enough of that field's unit will be added to -or subtracted from the time to bring it in range. Thus, if attempting to -scan or format day 0 of the month, one day will be subtracted from day -1 of the month, yielding the last day of the previous month. -.PP -If the interpretation of the groups yields an impossible time because -a Daylight Saving Time change skips over that time, or an ambiguous -time because a Daylight Saving Time change skips back so that the clock -observes the given time twice, and no time zone specifier (\fB%z\fR -or \fB%Z\fR) is present in the format, the time is interpreted as -if the clock had not changed. .SH "FORMAT GROUPS" -.PP The following format groups are recognized by the \fBclock scan\fR and \fBclock format\fR commands. .TP \fB%a\fR On output, produces an abbreviation (\fIe.g.,\fR \fBMon\fR) for the day @@ -755,11 +732,10 @@ .TP \fB%+\fR Synonymous with .QW "\fB%a %b %e %H:%M:%S %Z %Y\fR" . .SH "TIME ZONES" -.PP When the \fBclock\fR command is processing a local time, it has several possible sources for the time zone to use. In order of preference, they are: .IP [1] A time zone specified inside a string being parsed and matched by a \fB%z\fR @@ -777,11 +753,10 @@ The C library's idea of the local time zone, as defined by the \fBmktime\fR and \fBlocaltime\fR functions. .PP In case [1] \fIonly,\fR the string is tested to see if it is one of the strings: -.PP .CS gmt ut utc bst wet wat at nft nst ndt ast adt est edt cst cdt mst mdt pst pdt yst ydt hst hdt cat ahst nt idlw @@ -789,11 +764,10 @@ eet eest bt it zp4 zp5 ist zp6 wast wadt jt cct jst cast cadt east eadt gst nzt nzst nzdt idle .CE -.PP If it is a string in the above list, it designates a known time zone, and is interpreted as such. .PP For time zones in case [1] that do not match any of the above strings, and always for cases [2]-[6], the following rules apply. @@ -823,36 +797,17 @@ A time zone string conforming to the Posix specification of the \fBTZ\fR environment variable will be recognized. The specification may be found at \fIhttp://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap08.html\fR. .PP -If the Posix time zone string contains a DST (Daylight Savings Time) -part, but doesn't contain a rule stating when DST starts or ends, -then default rules are used. For Timezones with an offset between 0 -and +12, the current European/Russian rules are used, otherwise the -current US rules are used. In Europe (offset +0 to +2) the switch -to summertime is done each last Sunday in March at 1:00 GMT, and -the switch back is each last Sunday in October at 2:00 GMT. In -Russia (offset +3 to +12), the switch dates are the same, only -the switch to summertime is at 2:00 local time, and the switch -back is at 3:00 local time in all time zones. The US switch to -summertime takes place each second Sunday in March at 2:00 local -time, and the switch back is each first Sunday in November at -3:00 local time. These default rules mean that in all European, -Russian and US (or compatible) time zones, DST calculations will -be correct for dates in 2007 and later, unless in the future the -rules change again. -.PP Any other time zone string is processed by prefixing a colon and attempting to use it as a location name, as above. .SH "LOCALIZATION" -.PP Developers wishing to localize the date and time formatting and parsing are referred to \fIhttp://tip.tcl.tk/173\fR for a specification. .SH "FREE FORM SCAN" -.PP If the \fBclock scan\fR command is invoked without a \fB\-format\fR option, then it requests a \fIfree-form scan.\fR \fI This form of scan is deprecated.\fR The reason for the deprecation is that there are too many ambiguities. (Does the string .QW 2000 @@ -884,51 +839,44 @@ .PP The \fIinputString\fR argument consists of zero or more specifications of the following form: .TP \fItime\fR -. -A time of day, which is of the form: -.QW "\fIhh\fR?\fB:\fImm\fR?\fB:\fIss\fR?? ?\fImeridian\fR? ?\fIzone\fR?" -or -.QW "\fBhhmm \fR?\fBmeridian\fR? ?\fBzone\fR?" . -If no \fImeridian\fR is specified, \fIhh\fR is interpreted on +A time of day, which is of the form: \fBhh?:mm?:ss?? ?meridian? ?zone?\fR +or \fBhhmm ?meridian? ?zone?\fR +If no meridian is specified, \fBhh\fR is interpreted on a 24-hour clock. .TP \fIdate\fR -. A specific month and day with optional year. The acceptable formats are -.QW "\fImm\fB/\fIdd\fR?\fB/\fIyy\fR?" , -.QW "\fImonthname dd\fR?\fB, \fIyy\fR?" , -.QW "\fIday\fB, \fIdd monthname \fR?\fIyy\fR?" , -.QW "\fIdd monthname yy\fR" , -.QW "?\fICC\fR?\fIyymmdd\fR" , +.QW "\fBmm/dd\fR?\fB/yy\fR?" , +.QW "\fBmonthname dd\fR?\fB, yy\fR?" , +.QW "\fBday, dd monthname \fR?\fByy\fR?" , +.QW "\fBdd monthname yy\fR" , +.QW "?\fBCC\fR?\fByymmdd\fR" , and -.QW "\fIdd\fB-\fImonthname\fB-\fR?\fICC\fR?\fIyy\fR" . +.QW "\fBdd-monthname-\fR?\fBCC\fR?\fByy\fR" . The default year is the current year. If the year is less than 100, we treat the years 00-68 as 2000-2068 and the years 69-99 as 1969-1999. Not all platforms can represent the years 38-70, so an error may result if these years are used. .TP \fIISO 8601 point-in-time\fR -. An ISO 8601 point-in-time specification, such as -.QW "\fICCyymmdd\fBT\fIhhmmss\fR", +.QW \fICCyymmdd\fBT\fIhhmmss\fR, where \fBT\fR is the literal .QW T , .QW "\fICCyymmdd hhmmss\fR" , -.QW "\fICCyymmdd\fBT\fIhh:mm:ss\fR" , or -.QW "\fICCyy-mm-dd\fBT\fIhh\fB:\fImm\fB:\fIss\fR". -Note that only these four formats are accepted. +.QW \fICCyymmdd\fBT\fIhh:mm:ss\fR . +Note that only these three formats are accepted. The command does \fInot\fR accept the full range of point-in-time specifications specified in ISO8601. Other formats can be recognized by -giving an explicit \fB\-format\fR option to the \fBclock scan\fR command. +giving an explicit \fI\-format\fR option to the \fBclock scan\fR command. .TP \fIrelative time\fR -. A specification relative to the current time. The format is \fBnumber unit\fR. Acceptable units are \fByear\fR, \fBfortnight\fR, \fBmonth\fR, \fBweek\fR, \fBday\fR, \fBhour\fR, \fBminute\fR (or \fBmin\fR), and \fBsecond\fR (or \fBsec\fR). The unit can be specified as a singular or plural, as in \fB3 weeks\fR. @@ -950,8 +898,5 @@ msgcat(n) .SH KEYWORDS clock, date, time .SH "COPYRIGHT" Copyright (c) 2004 Kevin B. Kenny . All rights reserved. -'\" Local Variables: -'\" mode: nroff -'\" End: Index: doc/close.n ================================================================== --- doc/close.n +++ doc/close.n @@ -2,32 +2,31 @@ '\" 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 close n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME close \- Close an open channel .SH SYNOPSIS -\fBclose \fIchannelId\fR ?r(ead)|w(rite)? +\fBclose \fIchannelId\fR .BE + .SH DESCRIPTION .PP -Closes or half-closes the channel given by \fIchannelId\fR. +Closes the channel given by \fIchannelId\fR. .PP \fIChannelId\fR must be an identifier for an open channel such as a Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR), the return value from an invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel creation command provided by a Tcl extension. .PP -The single-argument form is a simple -.QW "full-close" : -all buffered output is flushed to the channel's output device, +All buffered output is flushed to the channel's output device, any buffered input is discarded, the underlying file or device is closed, and \fIchannelId\fR becomes unavailable for use. .PP If the channel is blocking, the command does not return until all output is flushed. @@ -46,45 +45,21 @@ 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. +when the process exits. Channels are switched to blocking mode, to ensure +that all output is correctly flushed before the process exits. .PP The command returns an empty string, and may generate an error if an error occurs while flushing output. If a command in a command pipeline created with \fBopen\fR returns an error, \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 -the other direction is still open. -.PP -A single-argument close on an already half-closed bidirectional channel is -defined to just -.QW "finish the job" . -A half-close on an already closed half, or on a wrong-sided unidirectional -channel, raises an error. -.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 proc withOpenFile {filename channelVar script} { upvar 1 $channelVar chan set chan [open $filename] catch { @@ -92,13 +67,11 @@ } result options \fBclose\fR $chan return -options $options $result } .CE + .SH "SEE ALSO" file(n), open(n), socket(n), eof(n), Tcl_StandardChannels(3) + .SH KEYWORDS -blocking, channel, close, nonblocking, half-close -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: +blocking, channel, close, nonblocking Index: doc/concat.n ================================================================== --- doc/concat.n +++ doc/concat.n @@ -2,24 +2,25 @@ '\" 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 concat n 8.3 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME concat \- Join lists together .SH SYNOPSIS \fBconcat\fI \fR?\fIarg arg ...\fR? .BE + .SH DESCRIPTION .PP This command joins each of its arguments together with spaces after -trimming leading and trailing white-space from each of them. If all of the +trimming leading and trailing white-space from each of them. If all the arguments are lists, this has the same effect as concatenating them into a single list. Arguments that are empty (after trimming) are ignored entirely. It permits any number of arguments; if no \fIarg\fRs are supplied, the result is an empty string. @@ -51,9 +52,6 @@ (i.e., there are three spaces between each of the \fBa\fR, the \fBb\fR and the \fBc\fR). .SH "SEE ALSO" append(n), eval(n), join(n) .SH KEYWORDS -concatenate, join, list -'\" Local Variables: -'\" mode: nroff -'\" End: +concatenate, join, lists Index: doc/continue.n ================================================================== --- doc/continue.n +++ doc/continue.n @@ -2,46 +2,44 @@ '\" Copyright (c) 1993-1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH continue n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME continue \- Skip to the next iteration of a loop .SH SYNOPSIS \fBcontinue\fR .BE + .SH DESCRIPTION .PP This command is typically invoked inside the body of a looping command such as \fBfor\fR or \fBforeach\fR or \fBwhile\fR. -It returns a 4 (\fBTCL_CONTINUE\fR) result code, which causes a continue -exception to occur. +It returns a \fBTCL_CONTINUE\fR code, which causes a continue exception +to occur. The exception causes the current script to be aborted out to the innermost containing loop command, which then continues with the next iteration of the loop. -Continue exceptions are also handled in a few other situations, such +Catch exceptions are also handled in a few other situations, such as the \fBcatch\fR command and the outermost scripts of procedure bodies. .SH EXAMPLE -.PP Print a line for each of the integers from 0 to 10 \fIexcept\fR 5: -.PP .CS for {set x 0} {$x<10} {incr x} { - if {$x == 5} { - \fBcontinue\fR - } - puts "x is $x" + if {$x == 5} { + \fBcontinue\fR + } + puts "x is $x" } .CE + .SH "SEE ALSO" break(n), for(n), foreach(n), return(n), while(n) + .SH KEYWORDS continue, iteration, loop -'\" Local Variables: -'\" mode: nroff -'\" End: DELETED doc/cookiejar.n Index: doc/cookiejar.n ================================================================== --- doc/cookiejar.n +++ /dev/null @@ -1,217 +0,0 @@ -'\" -'\" Copyright (c) 2014-2018 Donal K. Fellows. -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH "cookiejar" n 0.1 http "Tcl Bundled Packages" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -cookiejar \- Implementation of the Tcl http package cookie jar protocol -.SH SYNOPSIS -.nf -\fBpackage require\fR \fBcookiejar\fR ?\fB0.1\fR? - -\fB::http::cookiejar configure\fR ?\fIoptionName\fR? ?\fIoptionValue\fR? -\fB::http::cookiejar create\fR \fIname\fR ?\fIfilename\fR? -\fB::http::cookiejar new\fR ?\fIfilename\fR? - -\fIcookiejar\fR \fBdestroy\fR -\fIcookiejar\fR \fBforceLoadDomainData\fR -\fIcookiejar\fR \fBgetCookies\fR \fIprotocol host path\fR -\fIcookiejar\fR \fBstoreCookie\fR \fIoptions\fR -\fIcookiejar\fR \fBlookup\fR ?\fIhost\fR? ?\fIkey\fR? -.fi -.SH DESCRIPTION -.PP -The cookiejar package provides an implementation of the http package's cookie -jar protocol using an SQLite database. It provides one main command, -\fB::http::cookiejar\fR, which is a TclOO class that should be instantiated to -create a cookie jar that manages a particular HTTP session. -.PP -The database management policy can be controlled at the package level by the -\fBconfigure\fR method on the \fB::http::cookiejar\fR class object: -.TP -\fB::http::cookiejar configure\fR ?\fIoptionName\fR? ?\fIoptionValue\fR? -. -If neither \fIoptionName\fR nor \fIoptionValue\fR are supplied, this returns a -copy of the configuration as a Tcl dictionary. If just \fIoptionName\fR is -supplied, just the value of the named option is returned. If both -\fIoptionName\fR and \fIoptionValue\fR are given, the named option is changed -to be the given value. -.RS -.PP -Supported options are: -.TP -\fB\-domainfile \fIfilename\fR -. -A file (defaulting to within the cookiejar package) with a description of the -list of top-level domains (e.g., \fB.com\fR or \fB.co.jp\fR). Such domains -\fImust not\fR accept cookies set upon them. Note that the list of such -domains is both security-sensitive and \fInot\fR constant and should be -periodically refetched. Cookie jars maintain their own cache of the domain -list. -.TP -\fB\-domainlist \fIurl\fR -. -A URL to fetch the list of top-level domains (e.g., \fB.com\fR or -\fB.co.jp\fR) from. Such domains \fImust not\fR accept cookies set upon -them. Note that the list of such domains is both security-sensitive and -\fInot\fR constant and should be periodically refetched. Cookie jars maintain -their own cache of the domain list. -.TP -\fB\-domainrefresh \fIintervalMilliseconds\fR -. -The number of milliseconds between checks of the \fI\-domainlist\fR for new -domains. -.TP -\fB\-loglevel \fIlevel\fR -. -The logging level of this package. The logging level must be (in order of -decreasing verbosity) one of \fBdebug\fR, \fBinfo\fR, \fBwarn\fR, or -\fBerror\fR. -.TP -\fB\-offline \fIflag\fR -. -Allows the cookie managment engine to be placed into offline mode. In offline -mode, the list of domains is read immediately from the file configured in the -\fB\-domainfile\fR option, and the \fB\-domainlist\fR option is not used; it -also makes the \fB\-domainrefresh\fR option be effectively ignored. -.TP -\fB\-purgeold \fIintervalMilliseconds\fR -. -The number of milliseconds between checks of the database for expired -cookies; expired cookies are deleted. -.TP -\fB\-retain \fIcookieCount\fR -. -The maximum number of cookies to retain in the database. -.TP -\fB\-vacuumtrigger \fIdeletionCount\fR -. -A count of the number of persistent cookie deletions to go between vacuuming -the database. -.RE -.PP -Cookie jar instances may be made with any of the standard TclOO instance -creation methods (\fBcreate\fR or \fBnew\fR). -.TP -\fB::http::cookiejar new\fR ?\fIfilename\fR? -. -If a \fIfilename\fR argument is provided, it is the name of a file containing -an SQLite database that will contain the persistent cookies maintained by the -cookie jar; the database will be created if the file does not already -exist. If \fIfilename\fR is not supplied, the database will be held entirely within -memory, which effectively forces all cookies within it to be session cookies. -.SS "INSTANCE METHODS" -.PP -The following methods are supported on the instances: -.TP -\fIcookiejar\fR \fBdestroy\fR -. -This is the standard TclOO destruction method. It does \fInot\fR delete the -SQLite database if it is written to disk. Callers are responsible for ensuring -that the cookie jar is not in use by the http package at the time of -destruction. -.TP -\fIcookiejar\fR \fBforceLoadDomainData\fR -. -This method causes the cookie jar to immediately load (and cache) the domain -list data. The domain list will be loaded from the \fB\-domainlist\fR -configured a the package level if that is enabled, and otherwise will be -obtained from the \fB\-domainfile\fR configured at the package level. -.TP -\fIcookiejar\fR \fBgetCookies\fR \fIprotocol host path\fR -. -This method obtains the cookies for a particular HTTP request. \fIThis -implements the http cookie jar protocol.\fR -.TP -\fIcookiejar\fR \fBpolicyAllow\fR \fIoperation domain path\fR -. -This method is called by the \fBstoreCookie\fR method to get a decision on -whether to allow \fIoperation\fR to be performed for the \fIdomain\fR and -\fIpath\fR. This is checked immediately before the database is updated but -after the built-in security checks are done, and should return a boolean -value; if the value is false, the operation is rejected and the database is -not modified. The supported \fIoperation\fRs are: -.RS -.TP -\fBdelete\fR -. -The \fIdomain\fR is seeking to delete a cookie. -.TP -\fBsession\fR -. -The \fIdomain\fR is seeking to create or update a session cookie. -.TP -\fBset\fR -. -The \fIdomain\fR is seeking to create or update a persistent cookie (with a -defined lifetime). -.PP -The default implementation of this method just returns true, but subclasses of -this class may impose their own rules. -.RE -.TP -\fIcookiejar\fR \fBstoreCookie\fR \fIoptions\fR -. -This method stores a single cookie from a particular HTTP response. Cookies -that fail security checks are ignored. \fIThis implements the http cookie jar -protocol.\fR -.TP -\fIcookiejar\fR \fBlookup\fR ?\fIhost\fR? ?\fIkey\fR? -. -This method looks a cookie by exact host (or domain) matching. If neither -\fIhost\fR nor \fIkey\fR are supplied, the list of hosts for which a cookie is -stored is returned. If just \fIhost\fR (which may be a hostname or a domain -name) is supplied, the list of cookie keys stored for that host is returned. -If both \fIhost\fR and \fIkey\fR are supplied, the value for that key is -returned; it is an error if no such host or key match exactly. -.SH "EXAMPLES" -.PP -The simplest way of using a cookie jar is to just permanently configure it at -the start of the application. -.PP -.CS -package require http -\fBpackage require cookiejar\fR - -set cookiedb ~/.tclcookies.db -http::configure -cookiejar [\fBhttp::cookiejar new\fR $cookiedb] - -# No further explicit steps are required to use cookies -set tok [http::geturl http://core.tcl.tk/] -.CE -.PP -To only allow a particular domain to use cookies, perhaps because you only -want to enable a particular host to create and manipulate sessions, create a -subclass that imposes that policy. -.PP -.CS -package require http -\fBpackage require cookiejar\fR - -oo::class create MyCookieJar { - superclass \fBhttp::cookiejar\fR - - method \fBpolicyAllow\fR {operation domain path} { - return [expr {$domain eq "my.example.com"}] - } -} - -set cookiedb ~/.tclcookies.db -http::configure -cookiejar [MyCookieJar new $cookiedb] - -# No further explicit steps are required to use cookies -set tok [http::geturl http://core.tcl.tk/] -.CE -.SH "SEE ALSO" -http(n), oo::class(n), sqlite3(n) -.SH KEYWORDS -cookie, internet, security policy, www -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: DELETED doc/copy.n Index: doc/copy.n ================================================================== --- doc/copy.n +++ /dev/null @@ -1,76 +0,0 @@ -'\" -'\" Copyright (c) 2007 Donal K. Fellows -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH copy n 0.1 TclOO "TclOO Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -oo::copy \- create copies of objects and classes -.SH SYNOPSIS -.nf -package require TclOO - -\fBoo::copy\fI sourceObject \fR?\fItargetObject\fR? ?\fItargetNamespace\fR? -.fi -.BE -.SH DESCRIPTION -.PP -The \fBoo::copy\fR command creates a copy of an object or class. It takes the -name of the object or class to be copied, \fIsourceObject\fR, and optionally -the name of the object or class to create, \fItargetObject\fR, which will be -resolved relative to the current namespace if not an absolute qualified name -and -.VS TIP473 -\fItargetNamespace\fR which is the name of the namespace that will hold the -internal state of the object (\fBmy\fR command, etc.); it \fImust not\fR -refer to an existing namespace. -If either \fItargetObject\fR or \fItargetNamespace\fR is omitted or is given -as the empty string, a new name is chosen. Names, unless specified, are -chosen with the same algorithm used by the \fBnew\fR method of -\fBoo::class\fR. -.VE TIP473 -The copied object will be of the same class as the source object, and will have -all its per-object methods copied. If it is a class, it will also have all the -class methods in the class copied, but it will not have any of its instances -copied. -.PP -.VS -After the \fItargetObject\fR has been created and all definitions of its -configuration (e.g., methods, filters, mixins) copied, the \fB\fR -method of \fItargetObject\fR will be invoked, to allow for customization of -the created object such as installing related variable traces. The only -argument given will be \fIsourceObject\fR. The default implementation of this -method (in \fBoo::object\fR) just copies the procedures and variables in the -namespace of \fIsourceObject\fR to the namespace of \fItargetObject\fR. If -this method call does not return a result that is successful (i.e., an error -or other kind of exception) then the \fItargetObject\fR will be deleted and an -error returned. -.VE -.PP -The result of the \fBoo::copy\fR command will be the fully-qualified name of -the new object or class. -.SH EXAMPLES -.PP -This example creates an object, copies it, modifies the source object, and -then demonstrates that the copied object is indeed a copy. -.PP -.CS -oo::object create src -oo::objdefine src method msg {} {puts foo} -\fBoo::copy\fR src dst -oo::objdefine src method msg {} {puts bar} -src msg \fI\(-> prints "bar"\fR -dst msg \fI\(-> prints "foo"\fR -.CE -.SH "SEE ALSO" -oo::class(n), oo::define(n), oo::object(n) -.SH KEYWORDS -clone, copy, duplication, object -.\" Local variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: DELETED doc/coroutine.n Index: doc/coroutine.n ================================================================== --- doc/coroutine.n +++ /dev/null @@ -1,293 +0,0 @@ -'\" -'\" 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 -.VS "8.7, TIP383" -\fBcoroinject \fIcoroName command\fR ?\fIarg...\fR? -\fBcoroprobe \fIcoroName command\fR ?\fIarg...\fR? -.VE "8.7, TIP383" -.fi -.BE -.SH DESCRIPTION -.PP -The \fBcoroutine\fR command creates a new coroutine context (with associated -command) named \fIname\fR and executes that context by calling \fIcommand\fR, -passing in the other remaining arguments without further interpretation. Once -\fIcommand\fR returns normally or with an exception (e.g., an error) the -coroutine context \fIname\fR is deleted. -.PP -Within the context, values may be generated as results by using the -\fByield\fR command; if no \fIvalue\fR is supplied, the empty string is used. -When that is called, the context will suspend execution and the -\fBcoroutine\fR command will return the argument to \fByield\fR. The execution -of the context can then be resumed by calling the context command, optionally -passing in the \fIsingle\fR value to use as the result of the \fByield\fR call -that caused -the context to be suspended. If the coroutine context never yields and instead -returns conventionally, the result of the \fBcoroutine\fR command will be the -result of the evaluation of the context. -.PP -The coroutine may also suspend its execution by use of the \fByieldto\fR -command, which instead of returning, cedes execution to some command called -\fIcommand\fR (resolved in the context of the coroutine) and to which \fIany -number\fR of arguments may be passed. Since every coroutine has a context -command, \fByieldto\fR can be used to transfer control directly from one -coroutine to another (this is only advisable if the two coroutines are -expecting this to happen) but \fIany\fR command may be the target. If a -coroutine is suspended by this mechanism, the coroutine processing can be -resumed by calling the context command optionally passing in an arbitrary -number of arguments. The return value of the \fByieldto\fR call will be the -list of arguments passed to the context command; it is up to the caller to -decide what to do with those values. -.PP -The recommended way of writing a version of \fByield\fR that allows resumption -with multiple arguments is by using \fByieldto\fR and the \fBreturn\fR -command, like this: -.PP -.CS -proc yieldMultiple {value} { - tailcall \fByieldto\fR string cat $value -} -.CE -.PP -The coroutine can also be deleted by destroying the command \fIname\fR, and -the name of the current coroutine can be retrieved by using -\fBinfo coroutine\fR. -If there are deletion traces on variables in the coroutine's -implementation, they will fire at the point when the coroutine is explicitly -deleted (or, naturally, if the command returns conventionally). -.PP -At the point when \fIcommand\fR is called, the current namespace will be the -global namespace and there will be no stack frames above it (in the sense of -\fBupvar\fR and \fBuplevel\fR). However, which command to call will be -determined in the namespace that the \fBcoroutine\fR command was called from. -.PP -.VS "8.7, TIP383" -A suspended coroutine (i.e., one that has \fByield\fRed or \fByieldto\fR-d) -may have its state inspected (or modified) at that point by using -\fBcoroprobe\fR to run a command at the point where the coroutine is at. The -command takes the name of the coroutine to run the command in, \fIcoroName\fR, -and the name of a command (any any arguments it requires) to immediately run -at that point. The result of that command is the result of the \fBcoroprobe\fR -command, and the gross state of the coroutine remains the same afterwards -(i.e., the coroutine is still expecting the results of a \fByield\fR or -\fByieldto\fR as before) though variables may have been changed. -.PP -Similarly, the \fBcoroinject\fR command may be used to place a command to be -run inside a suspended coroutine (when it is resumed) to process arguments, -with quite a bit of similarity to \fBcoroprobe\fR. However, with -\fBcoroinject\fR there are several key differences: -.VE "8.7, TIP383" -.IP \(bu -.VS "8.7, TIP383" -The coroutine is not immediately resumed after the injection has been done. A -consequence of this is that multiple injections may be done before the -coroutine is resumed. There injected commands are performed in \fIreverse -order of definition\fR (that is, they are internally stored on a stack). -.VE "8.7, TIP383" -.IP \(bu -.VS "8.7, TIP383" -An additional two arguments are appended to the list of arguments to be run -(that is, the \fIcommand\fR and its \fIargs\fR are extended by two elements). -The first is the name of the command that suspended the coroutine (\fByield\fR -or \fByieldto\fR), and the second is the argument (or list of arguments, in -the case of \fByieldto\fR) that is the current resumption value. -.VE "8.7, TIP383" -.IP \(bu -.VS "8.7, TIP383" -The result of the injected command is used as the result of the \fByield\fR or -\fByieldto\fR that caused the coroutine to become suspended. Where there are -multiple injected commands, the result of one becomes the resumption value -processed by the next. -.PP -The injection is a one-off. It is not retained once it has been executed. It -may \fByield\fR or \fByieldto\fR as part of its execution. -.PP -Note that running coroutines may be neither probed nor injected; the -operations may only be applied to -.VE "8.7, TIP383" -.SH EXAMPLES -.PP -This example shows a coroutine that will produce an infinite sequence of -even values, and a loop that consumes the first ten of them. -.PP -.CS -proc allNumbers {} { - \fByield\fR - set i 0 - while 1 { - \fByield\fR $i - incr i 2 - } -} -\fBcoroutine\fR nextNumber allNumbers -for {set i 0} {$i < 10} {incr i} { - puts "received [\fInextNumber\fR]" -} -rename nextNumber {} -.CE -.PP -In this example, the coroutine acts to add up the arguments passed to it. -.PP -.CS -\fBcoroutine\fR accumulator apply {{} { - set x 0 - while 1 { - incr x [\fByield\fR $x] - } -}} -for {set i 0} {$i < 10} {incr i} { - puts "$i -> [\fIaccumulator\fR $i]" -} -.CE -.PP -This example demonstrates the use of coroutines to implement the classic Sieve -of Eratosthenes algorithm for finding prime numbers. Note the creation of -coroutines inside a coroutine. -.PP -.CS -proc filterByFactor {source n} { - \fByield\fR [info coroutine] - while 1 { - set x [\fI$source\fR] - if {$x % $n} { - \fByield\fR $x - } - } -} -\fBcoroutine\fR allNumbers apply {{} {while 1 {\fByield\fR [incr x]}}} -\fBcoroutine\fR eratosthenes apply {c { - \fByield\fR - while 1 { - set n [\fI$c\fR] - \fByield\fR $n - set c [\fBcoroutine\fR prime$n filterByFactor $c $n] - } -}} allNumbers -for {set i 1} {$i <= 20} {incr i} { - puts "prime#$i = [\fIeratosthenes\fR]" -} -.CE -.PP -This example shows how a value can be passed around a group of three -coroutines that yield to each other: -.PP -.CS -proc juggler {name target {value ""}} { - if {$value eq ""} { - set value [\fByield\fR [info coroutine]] - } - while {$value ne ""} { - puts "$name : $value" - set value [string range $value 0 end-1] - lassign [\fByieldto\fR \fI$target\fR $value] value - } -} -\fBcoroutine\fR j1 juggler Larry [ - \fBcoroutine\fR j2 juggler Curly [ - \fBcoroutine\fR j3 juggler Moe j1]] "Nyuck!Nyuck!Nyuck!" -.CE -.PP -.VS "8.7, TIP383" -This example shows a simple coroutine that collects non-empty values and -returns a list of them when not given an argument. It also shows how we can -look inside the coroutine to find out what it is doing, and how we can modify -the input on a one-off basis. -.PP -.CS -proc collectorImpl {} { - set me [info coroutine] - set accumulator {} - for {set val [\fByield\fR $me]} {$val ne ""} {set val [\fByield\fR]} { - lappend accumulator $val - } - return $accumulator -} - -\fBcoroutine\fR collect collectorImpl -\fIcollect\fR 123 -\fIcollect\fR "abc def" -\fIcollect\fR 456 - -puts [\fBcoroprobe \fIcollect\fR set accumulator] -# ==> 123 {abc def} 456 - -\fIcollect\fR "pqr" - -\fBcoroinject \fIcollect\fR apply {{type value} { - puts "Received '$value' at a $type in [info coroutine]" - return [string toupper $value] -}} - -\fIcollect\fR rst -# ==> Received 'rst' at a yield in ::collect -\fIcollect\fR xyz - -puts [\fIcollect\fR] -# ==> 123 {abc def} 456 pqr RST xyz -.CE -.PP -This example shows a simple coroutine that collects non-empty values and -returns a list of them when not given an argument. It also shows how we can -look inside the coroutine to find out what it is doing. -.VE "8.7, TIP383" -.SS "DETAILED SEMANTICS" -.PP -This example demonstrates that coroutines start from the global namespace, and -that \fIcommand\fR resolution happens before the coroutine stack is created. -.PP -.CS -proc report {where level} { - # Where was the caller called from? - set ns [uplevel 2 {namespace current}] - \fByield\fR "made $where $level context=$ns name=[info coroutine]" -} -proc example {} { - report outer [info level] -} -namespace eval demo { - proc example {} { - report inner [info level] - } - proc makeExample {} { - puts "making from [info level]" - puts [\fBcoroutine\fR coroEg example] - } - makeExample -} -.CE -.PP -Which produces the output below. In particular, we can see that stack -manipulation has occurred (comparing the levels from the first and second -line) and that the parent level in the coroutine is the global namespace. We -can also see that coroutine names are local to the current namespace if not -qualified, and that coroutines may yield at depth (e.g., in called -procedures). -.PP -.CS -making from 2 -made inner 1 context=:: name=::demo::coroEg -.CE -.SH "SEE ALSO" -apply(n), info(n), proc(n), return(n) -.SH KEYWORDS -coroutine, generator -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/dde.n ================================================================== --- doc/dde.n +++ doc/dde.n @@ -2,26 +2,26 @@ '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" Copyright (c) 2001 ActiveState Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH dde n 1.4 dde "Tcl Bundled Packages" +'\" +.TH dde n 1.3 dde "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME dde \- Execute a Dynamic Data Exchange command .SH SYNOPSIS .sp -\fBpackage require dde 1.4\fR +\fBpackage require dde 1.3\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 +\fBdde execute\fR ?\fB\-async\fR? \fIservice topic data\fR .sp -\fBdde poke\fR ?\fB\-binary\fR? \fIservice topic item data\fR +\fBdde poke\fR \fIservice topic item data\fR .sp \fBdde request\fR ?\fB\-binary\fR? \fIservice topic item\fR .sp \fBdde services \fIservice topic\fR .sp @@ -67,11 +67,11 @@ safe interpreter then a \fB\-handler\fR procedure must be defined. The procedure is called with all the arguments provided by the remote call. .RE .TP -\fBdde execute\fR ?\fB\-async\fR? ?\fB\-binary\fR? \fIservice topic data\fR +\fBdde execute\fR ?\fB\-async\fR? \fIservice topic data\fR . \fBdde execute\fR takes the \fIdata\fR and sends it to the server indicated by \fIservice\fR with the topic indicated by \fItopic\fR. Typically, \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. @@ -78,30 +78,20 @@ 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 \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 @@ -131,11 +121,10 @@ service. 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. This command can be used to replace send on Windows. .SH "DDE AND TCL" -.PP A Tcl interpreter always has a service name of \fBTclEval\fR. Each different interpreter of all running Tcl applications must be given a unique name specified by \fBdde servername\fR. Each interp is available as a DDE topic only if the \fBdde servername\fR command was used to set the @@ -164,20 +153,15 @@ without adding the \fB&\fR to place the process in the background). If for any reason the event queue is not flushed, DDE commands may hang until the event queue is flushed. This can create a deadlock situation. .SH EXAMPLE -.PP This asks Internet Explorer (which must already be running) to go to a particularly important website: -.PP .CS package require dde \fBdde execute\fR -async iexplore WWW_OpenURL http://www.tcl.tk/ .CE .SH "SEE ALSO" tk(n), winfo(n), send(n) .SH KEYWORDS application, dde, name, remote execution -'\"Local Variables: -'\"mode: nroff -'\"End: DELETED doc/define.n Index: doc/define.n ================================================================== --- doc/define.n +++ /dev/null @@ -1,783 +0,0 @@ -'\" -'\" Copyright (c) 2007-2018 Donal K. Fellows -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH define n 0.3 TclOO "TclOO Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -oo::define, oo::objdefine \- define and configure classes and objects -.SH SYNOPSIS -.nf -package require TclOO - -\fBoo::define\fI class defScript\fR -\fBoo::define\fI class subcommand arg\fR ?\fIarg ...\fR? -\fBoo::objdefine\fI object defScript\fR -\fBoo::objdefine\fI object subcommand arg\fR ?\fIarg ...\fR? -.fi -.BE - -.SH DESCRIPTION -The \fBoo::define\fR command is used to control the configuration of classes, -and the \fBoo::objdefine\fR command is used to control the configuration of -objects (including classes as instance objects), with the configuration being -applied to the entity named in the \fIclass\fR or the \fIobject\fR argument. -Configuring a class also updates the -configuration of all subclasses of the class and all objects that are -instances of that class or which mix it in (as modified by any per-instance -configuration). The way in which the configuration is done is controlled by -either the \fIdefScript\fR argument or by the \fIsubcommand\fR and following -\fIarg\fR arguments; when the second is present, it is exactly as if all the -arguments from \fIsubcommand\fR onwards are made into a list and that list is -used as the \fIdefScript\fR argument. -.PP -Note that the constructor for \fBoo::class\fR will call \fBoo::define\fR on -the script argument that it is provided. This is a convenient way to create -and define a class in one step. -.SH "CONFIGURING CLASSES" -.PP -The following commands are supported in the \fIdefScript\fR for -\fBoo::define\fR, each of which may also be used in the \fIsubcommand\fR form: -.TP -\fBclassmethod\fI name\fR ?\fIargList bodyScrip\fR? -.VS TIP478 -This creates a class method, or (if \fIargList\fR and \fIbodyScript\fR are -omitted) promotes an existing method on the class object to be a class -method. The \fIname\fR, \fIargList\fR and \fIbodyScript\fR arguments are as in -the \fBmethod\fR definition, below. -.RS -.PP -Class methods can be called on either the class itself or on the instances of -that class. When they are called, the current object (see the \fBsel\fR and -\fBmy\fR commands) is the class on which they are called or the class of the -instance on which they are called, depending on whether they are called on the -class or an instance of the class, respectively. If called on a subclass or -instance of the subclass, the current object is the subclass. -.PP -In a private definition context, the methods as invoked on classes are -\fInot\fR private, but the methods as invoked on instances of classes are -private. -.RE -.VE TIP478 -.TP -\fBconstructor\fI argList bodyScript\fR -. -This creates or updates the constructor for a class. The formal arguments to -the constructor (defined using the same format as for the Tcl \fBproc\fR -command) will be \fIargList\fR, and the body of the constructor will be -\fIbodyScript\fR. When the body of the constructor is evaluated, the current -namespace of the constructor will be a namespace that is unique to the object -being constructed. Within the constructor, the \fBnext\fR command should be -used to call the superclasses' constructors. If \fIbodyScript\fR is the empty -string, the constructor will be deleted. -.RS -.PP -Classes do not need to have a constructor defined. If none is specified, the -superclass's constructor will be used instead. -.RE -.TP -\fBdestructor\fI bodyScript\fR -. -This creates or updates the destructor for a class. Destructors take no -arguments, and the body of the destructor will be \fIbodyScript\fR. The -destructor is called when objects of the class are deleted, and when called -will have the object's unique namespace as the current namespace. Destructors -should use the \fBnext\fR command to call the superclasses' destructors. Note -that destructors are not called in all situations (e.g. if the interpreter is -destroyed). If \fIbodyScript\fR is the empty string, the destructor will be -deleted. -.RS -Note that errors during the evaluation of a destructor \fIare not returned\fR -to the code that causes the destruction of an object. Instead, they are passed -to the currently-defined \fBbgerror\fR handler. -.RE -.TP -\fBexport\fI name \fR?\fIname ...\fR? -. -This arranges for each of the named methods, \fIname\fR, to be exported -(i.e. usable outside an instance through the instance object's command) by the -class being defined. Note that the methods themselves may be actually defined -by a superclass; subclass exports override superclass visibility, and may in -turn be overridden by instances. -.TP -\fBforward\fI name cmdName \fR?\fIarg ...\fR? -. -This creates or updates a forwarded method called \fIname\fR. The method is -defined be forwarded to the command called \fIcmdName\fR, with additional -arguments, \fIarg\fR etc., added before those arguments specified by the -caller of the method. The \fIcmdName\fR will always be resolved using the -rules of the invoking objects' namespaces, i.e., when \fIcmdName\fR is not -fully-qualified, the command will be searched for in each object's namespace, -using the instances' namespace's path, or by looking in the global namespace. -The method will be exported if \fIname\fR starts with a lower-case letter, and -non-exported otherwise. -.RS -.PP -.VS TIP500 -If in a private definition context (see the \fBprivate\fR definition command, -below), this command creates private forwarded methods. -.VE TIP500 -.RE -.TP -\fBinitialise\fI script\fR -.TP -\fBinitialize\fI script\fR -.VS TIP478 -This evaluates \fIscript\fR in a context which supports local variables and -where the current namespace is the instance namespace of the class object -itself. This is useful for setting up, e.g., class-scoped variables. -.VE TIP478 -.TP -\fBmethod\fI name \fR?\fIoption\fR? \fIargList bodyScript\fR -. -This creates or updates a method that is implemented as a procedure-like -script. The name of the method is \fIname\fR, the formal arguments to the -method (defined using the same format as for the Tcl \fBproc\fR command) will -be \fIargList\fR, and the body of the method will be \fIbodyScript\fR. When -the body of the method is evaluated, the current namespace of the method will -be a namespace that is unique to the current object. The method will be -exported if \fIname\fR starts with a lower-case letter, and non-exported -otherwise; this behavior can be overridden via \fBexport\fR and -\fBunexport\fR -.VS TIP519 -or by specifying \fB\-export\fR, \fB\-private\fR or \fB\-unexport\fR in the -optional parameter \fIoption\fR. -.VE TIP519 -.RS -.PP -.VS TIP500 -If in a private definition context (see the \fBprivate\fR definition command, -below) or if the \fB\-private\fR flag is given for \fIoption\fR, this command -creates private procedure-like methods. -.VE TIP500 -.RE -.TP -\fBprivate \fIcmd arg...\fR -.TP -\fBprivate \fIscript\fR -. -.VS TIP500 -This evaluates the \fIscript\fR (or the list of command and arguments given by -\fIcmd\fR and \fIarg\fRs) in a context where the definitions made on the -current class will be private definitions. -.RS -.PP -The following class definition commands are affected by \fBprivate\fR: -\fBforward\fR, \fBmethod\fR, \fBself\fR, and \fBvariable\fR. Nesting -\fBprivate\fR inside \fBprivate\fR has no cumulative effect; the innermost -definition context is just a private definition context. All other definition -commands have no difference in behavior when used in a private definition -context. -.RE -.VE TIP500 -.TP -\fBself\fI subcommand arg ...\fR -.TP -\fBself\fI script\fR -.TP -\fBself\fR -. -This command is equivalent to calling \fBoo::objdefine\fR on the class being -defined (see \fBCONFIGURING OBJECTS\fR below for a description of the -supported values of \fIsubcommand\fR). It follows the same general pattern of -argument handling as the \fBoo::define\fR and \fBoo::objdefine\fR commands, -and -.QW "\fBoo::define \fIcls \fBself \fIsubcommand ...\fR" -operates identically to -.QW "\fBoo::objdefine \fIcls subcommand ...\fR" . -.RS -.PP -.VS TIP470 -If no arguments at all are used, this gives the name of the class currently -being configured. -.VE TIP470 -.VS TIP500 -If in a private definition context (see the \fBprivate\fR definition command, -below), the definitions on the class object will also be made in a private -definition context. -.VE TIP500 -.RE -.TP -\fBsuperclass\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR? -. -This slot (see \fBSLOTTED DEFINITIONS\fR below) -allows the alteration of the superclasses of the class being defined. -Each \fIclassName\fR argument names one class that is to be a superclass of -the defined class. Note that objects must not be changed from being classes to -being non-classes or vice-versa, that an empty parent class is equivalent to -\fBoo::object\fR, and that the parent classes of \fBoo::object\fR and -\fBoo::class\fR may not be modified. -By default, this slot works by replacement. -.TP -\fBunexport\fI name \fR?\fIname ...\fR? -. -This arranges for each of the named methods, \fIname\fR, to be not exported -(i.e. not usable outside the instance through the instance object's command, -but instead just through the \fBmy\fR command visible in each object's -context) by the class being defined. Note that the methods themselves may be -actually defined by a superclass; subclass unexports override superclass -visibility, and may be overridden by instance unexports. -.TP -\fBvariable\fR ?\fI\-slotOperation\fR? ?\fIname ...\fR? -. -This slot (see \fBSLOTTED DEFINITIONS\fR below) arranges for each of the named -variables to be automatically made -available in the methods, constructor and destructor declared by the class -being defined. Each variable name must not have any namespace -separators and must not look like an array access. All variables will be -actually present in the namespace of the instance object on which the method -is executed. Note -that the variable lists declared by a superclass or subclass are completely -disjoint, as are variable lists declared by instances; the list of variable -names is just for methods (and constructors and destructors) declared by this -class. By default, this slot works by appending. -.RS -.PP -.VS TIP500 -If in a private definition context (see the \fBprivate\fR definition command, -below), this slot manipulates the list of private variable bindings for this -class. In a private variable binding, the name of the variable within the -instance object is different to the name given in the definition; the name -used in the definition is the name that you use to access the variable within -the methods of this class, and the name of the variable in the instance -namespace has a unique prefix that makes accidental use from other classes -extremely unlikely. -.VE TIP500 -.RE -.SS "ADVANCED CLASS CONFIGURATION OPTIONS" -.PP -The following definitions are also supported, but are not required in simple -programs: -.TP -\fBdefinitionnamespace\fR ?\fIkind\fR? \fInamespaceName\fR -.VS TIP524 -This allows control over what namespace will be used by the \fBoo::define\fR -and \fBoo::objdefine\fR commands to look up the definition commands they -use. When any object has a definition operation applied to it, \fIthe class that -it is an instance of\fR (and its superclasses and mixins) is consulted for -what definition namespace to use. \fBoo::define\fR gets the class definition -namespace, and \fB::oo::objdefine\fR gets the instance definition namespace, -but both otherwise use the identical lookup operation. -.RS -.PP -This sets the definition namespace of kind \fIkind\fR provided by the current -class to \fInamespaceName\fR. The \fInamespaceName\fR must refer to a -currently existing namespace, or must be the empty string (to stop the current -class from having such a namespace connected). The \fIkind\fR, if supplied, -must be either \fB\-class\fR (the default) or \fB\-instance\fR to specify the -whether the namespace for use with \fBoo::define\fR or \fBoo::objdefine\fR -respectively is being set. -.PP -The class \fBoo::object\fR has its instance namespace locked to -\fB::oo::objdefine\fR, and the class \fBoo::class\fR has its class namespace -locked to \fB::oo::define\fR. A consequence of this is that effective use of -this feature for classes requires the definition of a metaclass. -.RE -.VE TIP524 -.TP -\fBdeletemethod\fI name\fR ?\fIname ...\fR? -. -This deletes each of the methods called \fIname\fR from a class. The methods -must have previously existed in that class. Does not affect the superclasses -of the class, nor does it affect the subclasses or instances of the class -(except when they have a call chain through the class being modified) or the -class object itself. -.TP -\fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR? -. -This slot (see \fBSLOTTED DEFINITIONS\fR below) -sets or updates the list of method names that are used to guard whether -method call to instances of the class may be called and what the method's -results are. Each \fImethodName\fR names a single filtering method (which may -be exposed or not exposed); it is not an error for a non-existent method to be -named since they may be defined by subclasses. -By default, this slot works by appending. -.TP -\fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR? -. -This slot (see \fBSLOTTED DEFINITIONS\fR below) -sets or updates the list of additional classes that are to be mixed into -all the instances of the class being defined. Each \fIclassName\fR argument -names a single class that is to be mixed in. -By default, this slot works by replacement. -.TP -\fBrenamemethod\fI fromName toName\fR -. -This renames the method called \fIfromName\fR in a class to \fItoName\fR. The -method must have previously existed in the class, and \fItoName\fR must not -previously refer to a method in that class. Does not affect the superclasses -of the class, nor does it affect the subclasses or instances of the class -(except when they have a call chain through the class being modified), or the -class object itself. Does -not change the export status of the method; if it was exported before, it will -be afterwards. -.SH "CONFIGURING OBJECTS" -.PP -The following commands are supported in the \fIdefScript\fR for -\fBoo::objdefine\fR, each of which may also be used in the \fIsubcommand\fR -form: -.TP -\fBexport\fI name \fR?\fIname ...\fR? -. -This arranges for each of the named methods, \fIname\fR, to be exported -(i.e. usable outside the object through the object's command) by the object -being defined. Note that the methods themselves may be actually defined by a -class or superclass; object exports override class visibility. -.TP -\fBforward\fI name cmdName \fR?\fIarg ...\fR? -. -This creates or updates a forwarded object method called \fIname\fR. The -method is defined be forwarded to the command called \fIcmdName\fR, with -additional arguments, \fIarg\fR etc., added before those arguments specified -by the caller of the method. Forwarded methods should be deleted using the -\fBmethod\fR subcommand. The method will be exported if \fIname\fR starts with -a lower-case letter, and non-exported otherwise. -.RS -.PP -.VS TIP500 -If in a private definition context (see the \fBprivate\fR definition command, -below), this command creates private forwarded methods. -.VE TIP500 -.RE -.TP -\fBmethod\fI name \fR?\fIoption\fR? \fIargList bodyScript\fR -. -This creates, updates or deletes an object method. The name of the method is -\fIname\fR, the formal arguments to the method (defined using the same format -as for the Tcl \fBproc\fR command) will be \fIargList\fR, and the body of the -method will be \fIbodyScript\fR. When the body of the method is evaluated, the -current namespace of the method will be a namespace that is unique to the -object. The method will be exported if \fIname\fR starts with a lower-case -letter, and non-exported otherwise; -.VS TIP519 -this can be overridden by specifying \fB\-export\fR, \fB\-private\fR or -\fB\-unexport\fR in the optional parameter \fIoption\fR, or via the -\fBexport\fR and \fBunexport\fR definitions. -.VE TIP519 -.RS -.PP -.VS TIP500 -If in a private definition context (see the \fBprivate\fR definition command, -below) or if the \fB\-private\fR flag is given for \fIoption\fR, this command -creates private procedure-like methods. -.VE TIP500 -.RE -.TP -\fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR? -. -This slot (see \fBSLOTTED DEFINITIONS\fR below) -sets or updates a per-object list of additional classes that are to be -mixed into the object. Each argument, \fIclassName\fR, names a single class -that is to be mixed in. -By default, this slot works by replacement. -.TP -\fBprivate \fIcmd arg...\fR -.TP -\fBprivate \fIscript\fR -.VS TIP500 -This evaluates the \fIscript\fR (or the list of command and arguments given by -\fIcmd\fR and \fIarg\fRs) in a context where the definitions made on the -current object will be private definitions. -.RS -.PP -The following class definition commands are affected by \fBprivate\fR: -\fBforward\fR, \fBmethod\fR, and \fBvariable\fR. Nesting \fBprivate\fR inside -\fBprivate\fR has no cumulative effect; the innermost definition context is -just a private definition context. All other definition commands have no -difference in behavior when used in a private definition context. -.RE -.VE TIP500 -.TP -\fBunexport\fI name \fR?\fIname ...\fR? -. -This arranges for each of the named methods, \fIname\fR, to be not exported -(i.e. not usable outside the object through the object's command, but instead -just through the \fBmy\fR command visible in the object's context) by the -object being defined. Note that the methods themselves may be actually defined -by a class; instance unexports override class visibility. -.TP -\fBvariable\fR ?\fI\-slotOperation\fR? ?\fIname ...\fR? -. -This slot (see \fBSLOTTED DEFINITIONS\fR below) arranges for each of the named -variables to be automatically made available in the methods declared by the -object being defined. Each variable name must not have any namespace -separators and must not look like an array access. All variables will be -actually present in the namespace of the object on which the method is -executed. Note that the -variable lists declared by the classes and mixins of which the object is an -instance are completely disjoint; the list of variable names is just for -methods declared by this object. By default, this slot works by appending. -.RS -.PP -.VS TIP500 -If in a private definition context (see the \fBprivate\fR definition command, -below), this slot manipulates the list of private variable bindings for this -object. In a private variable binding, the name of the variable within the -instance object is different to the name given in the definition; the name -used in the definition is the name that you use to access the variable within -the methods of this instance object, and the name of the variable in the -instance namespace has a unique prefix that makes accidental use from -superclass methods extremely unlikely. -.VE TIP500 -.RE -.SS "ADVANCED OBJECT CONFIGURATION OPTIONS" -.PP -The following definitions are also supported, but are not required in simple -programs: -.TP -\fBclass\fI className\fR -. -This allows the class of an object to be changed after creation. Note that the -class's constructors are not called when this is done, and so the object may -well be in an inconsistent state unless additional configuration work is done. -.TP -\fBdeletemethod\fI name\fR ?\fIname ...\fR -. -This deletes each of the methods called \fIname\fR from an object. The methods -must have previously existed in that object (e.g., because it was created -through \fBoo::objdefine method\fR). Does not affect the classes that the -object is an instance of, or remove the exposure of those class-provided -methods in the instance of that class. -.TP -\fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR? -. -This slot (see \fBSLOTTED DEFINITIONS\fR below) -sets or updates the list of method names that are used to guard whether a -method call to the object may be called and what the method's results are. -Each \fImethodName\fR names a single filtering method (which may be exposed or -not exposed); it is not an error for a non-existent method to be named. Note -that the actual list of filters also depends on the filters set upon any -classes that the object is an instance of. -By default, this slot works by appending. -.TP -\fBrenamemethod\fI fromName toName\fR -. -This renames the method called \fIfromName\fR in an object to \fItoName\fR. -The method must have previously existed in the object, and \fItoName\fR must -not previously refer to a method in that object. Does not affect the classes -that the object is an instance of and cannot rename in an instance object the -methods provided by those classes (though a \fBoo::objdefine forward\fRed -method may provide an equivalent capability). Does not change the export -status of the method; if it was exported before, it will be afterwards. -.TP -\fBself \fR -.VS TIP470 -This gives the name of the object currently being configured. -.VE TIP470 -.SH "PRIVATE METHODS" -.VS TIP500 -When a class or instance has a private method, that private method can only be -invoked from within methods of that class or instance. Other callers of the -object's methods \fIcannot\fR invoke private methods, it is as if the private -methods do not exist. However, a private method of a class \fIcan\fR be -invoked from the class's methods when those methods are being used on another -instance object; this means that a class can use them to coordinate behaviour -between several instances of itself without interfering with how other -classes (especially either subclasses or superclasses) interact. Private -methods precede all mixed in classes in the method call order (as reported by -\fBself call\fR). -.VE TIP500 -.SH "SLOTTED DEFINITIONS" -Some of the configurable definitions of a class or object are \fIslotted -definitions\fR. This means that the configuration is implemented by a slot -object, that is an instance of the class \fBoo::Slot\fR, which manages a list -of values (class names, variable names, etc.) that comprises the contents of -the slot. The class defines five operations (as methods) that may be done on -the slot: -.TP -\fIslot\fR \fB\-append\fR ?\fImember ...\fR? -. -This appends the given \fImember\fR elements to the slot definition. -.TP -\fIslot\fR \fB\-clear\fR -. -This sets the slot definition to the empty list. -.TP -\fIslot\fR \fB\-prepend\fR ?\fImember ...\fR? -.VS TIP516 -This prepends the given \fImember\fR elements to the slot definition. -.VE TIP516 -.TP -\fIslot\fR \fB\-remove\fR ?\fImember ...\fR? -.VS TIP516 -This removes the given \fImember\fR elements from the slot definition. -.VE TIP516 -.TP -\fIslot\fR \fB\-set\fR ?\fImember ...\fR? -. -This replaces the slot definition with the given \fImember\fR elements. -.PP -A consequence of this is that any use of a slot's default operation where the -first member argument begins with a hyphen will be an error. One of the above -operations should be used explicitly in those circumstances. -.SS "SLOT IMPLEMENTATION" -Internally, slot objects also define a method \fB\-\-default\-operation\fR -which is forwarded to the default operation of the slot (thus, for the class -.QW \fBvariable\fR -slot, this is forwarded to -.QW "\fBmy \-append\fR" ), -and these methods which provide the implementation interface: -.TP -\fIslot\fR \fBGet\fR -. -Returns a list that is the current contents of the slot, but does not modify -the slot. This method must always be called from a stack frame created by a -call to \fBoo::define\fR or \fBoo::objdefine\fR. This method \fIshould not\fR -return an error unless it is called from outside a definition context or with -the wrong number of arguments. -.RS -.PP -.VS TIP516 -The elements of the list should be fully resolved, if that is a meaningful -concept to the slot. -.VE TIP516 -.RE -.TP -\fIslot\fR \fBResolve\fR \fIslotElement\fR -.VS TIP516 -Returns \fIslotElement\fR with a resolution operation applied to it, but does -not modify the slot. For slots of simple strings, this is an operation that -does nothing, whereas for slots of classes, this maps a class name to its -fully-qualified class name. This method must always be called from a stack -frame created by a call to \fBoo::define\fR or \fBoo::objdefine\fR. This -method \fIshould not\fR return an error unless it is called from outside a -definition context or with the wrong number of arguments; unresolvable -arguments should be returned as is (as not all slot operations strictly -require that values are resolvable to work). -.RS -.PP -Implementations \fIshould not\fR enforce uniqueness and ordering constraints -in this method; that is the responsibility of the \fBSet\fR method. -.RE -.VE TIP516 -.TP -\fIslot\fR \fBSet \fIelementList\fR -. -Sets the contents of the slot to the list \fIelementList\fR and returns the -empty string. This method must always be called from a stack frame created by -a call to \fBoo::define\fR or \fBoo::objdefine\fR. This method may return an -error if it rejects the change to the slot contents (e.g., because of invalid -values) as well as if it is called from outside a definition context or with -the wrong number of arguments. -.RS -.PP -This method \fImay\fR reorder and filter the elements if this is necessary in -order to satisfy the underlying constraints of the slot. (For example, slots -of classes enforce a uniqueness constraint that places each element in the -earliest location in the slot that it can.) -.RE -.PP -The implementation of these methods is slot-dependent (and responsible for -accessing the correct part of the class or object definition). Slots also have -an unknown method handler to tie all these pieces together, and they hide -their \fBdestroy\fR method so that it is not invoked inadvertently. It is -\fIrecommended\fR that any user changes to the slot mechanism be restricted to -defining new operations whose names start with a hyphen. -.PP -.VS TIP516 -Most slot operations will initially \fBResolve\fR their argument list, combine -it with the results of the \fBGet\fR method, and then \fBSet\fR the result. -Some operations omit one or both of the first two steps; omitting the third -would result in an idempotent read-only operation (but the standard mechanism -for reading from slots is via \fBinfo class\fR and \fBinfo object\fR). -.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 their subcommands. -.PP -.CS -oo::class create c -c create o -\fBoo::define\fR c \fBmethod\fR foo {} { - puts "world" -} -\fBoo::objdefine\fR o { - \fBmethod\fR bar {} { - my Foo "hello " - my foo - } - \fBforward\fR Foo ::puts -nonewline - \fBunexport\fR foo -} -o bar \fI\(-> prints "hello world"\fR -o foo \fI\(-> error "unknown method foo"\fR -o Foo Bar \fI\(-> error "unknown method Foo"\fR -\fBoo::objdefine\fR o \fBrenamemethod\fR bar lollipop -o lollipop \fI\(-> prints "hello world"\fR -.CE -.PP -This example shows how additional classes can be mixed into an object. It also -shows how \fBmixin\fR is a slot that supports appending: -.PP -.CS -oo::object create inst -inst m1 \fI\(-> error "unknown method m1"\fR -inst m2 \fI\(-> error "unknown method m2"\fR - -oo::class create A { - \fBmethod\fR m1 {} { - puts "red brick" - } -} -\fBoo::objdefine\fR inst { - \fBmixin\fR A -} -inst m1 \fI\(-> prints "red brick"\fR -inst m2 \fI\(-> error "unknown method m2"\fR - -oo::class create B { - \fBmethod\fR m2 {} { - puts "blue brick" - } -} -\fBoo::objdefine\fR inst { - \fBmixin -append\fR B -} -inst m1 \fI\(-> prints "red brick"\fR -inst m2 \fI\(-> prints "blue brick"\fR -.CE -.PP -.VS TIP478 -This example shows how to create and use class variables. It is a class that -counts how many instances of itself have been made. -.PP -.CS -oo::class create Counted -\fBoo::define\fR Counted { - \fBinitialise\fR { - variable count 0 - } - - \fBvariable\fR number - \fBconstructor\fR {} { - classvariable count - set number [incr count] - } - - \fBmethod\fR report {} { - classvariable count - puts "This is instance $number of $count" - } -} - -set a [Counted new] -set b [Counted new] -$a report - \fI\(-> This is instance 1 of 2\fR -set c [Counted new] -$b report - \fI\(-> This is instance 2 of 3\fR -$c report - \fI\(-> This is instance 3 of 3\fR -.CE -.PP -This example demonstrates how to use class methods. (Note that the constructor -for \fBoo::class\fR calls \fBoo::define\fR on the class.) -.PP -.CS -oo::class create DBTable { - \fBclassmethod\fR find {description} { - puts "DB: locate row from [self] matching $description" - return [my new] - } - \fBclassmethod\fR insert {description} { - puts "DB: create row in [self] matching $description" - return [my new] - } - \fBmethod\fR update {description} { - puts "DB: update row [self] with $description" - } - \fBmethod\fR delete {} { - puts "DB: delete row [self]" - my destroy; # Just delete the object, not the DB row - } -} - -oo::class create Users { - \fBsuperclass\fR DBTable -} -oo::class create Groups { - \fBsuperclass\fR DBTable -} - -set u1 [Users insert "username=abc"] - \fI\(-> DB: create row from ::Users matching username=abc\fR -set u2 [Users insert "username=def"] - \fI\(-> DB: create row from ::Users matching username=def\fR -$u2 update "group=NULL" - \fI\(-> DB: update row ::oo::Obj124 with group=NULL\fR -$u1 delete - \fI\(-> DB: delete row ::oo::Obj123\fR -set g [Group find "groupname=webadmins"] - \fI\(-> DB: locate row ::Group with groupname=webadmins\fR -$g update "emailaddress=admins" - \fI\(-> DB: update row ::oo::Obj125 with emailaddress=admins\fR -.CE -.VE TIP478 -.PP -.VS TIP524 -This example shows how to make a custom definition for a class. Note that it -explicitly includes delegation to the existing definition commands via -\fBnamespace path\fR. -.PP -.CS -namespace eval myDefinitions { - # Delegate to existing definitions where not overridden - namespace path \fB::oo::define\fR - - # A custom type of method - proc exprmethod {name arguments body} { - tailcall \fBmethod\fR $name $arguments [list expr $body] - } - - # A custom way of building a constructor - proc parameters args { - uplevel 1 [list \fBvariable\fR {*}$args] - set body [join [lmap a $args { - string map [list VAR $a] { - set [my varname VAR] [expr {double($VAR)}] - } - }] ";"] - tailcall \fBconstructor\fR $args $body - } -} - -# Bind the namespace into a (very simple) metaclass for use -oo::class create exprclass { - \fBsuperclass\fR oo::class - \fBdefinitionnamespace\fR myDefinitions -} - -# Use the custom definitions -exprclass create quadratic { - parameters a b c - exprmethod evaluate {x} { - ($a * $x**2) + ($b * $x) + $c - } -} - -# Showing the resulting class and object in action -quadratic create quad 1 2 3 -for {set x 0} {$x <= 4} {incr x} { - puts [format "quad(%d) = %.2f" $x [quad evaluate $x]] -} - \fI\(-> quad(0) = 3.00\fR - \fI\(-> quad(1) = 6.00\fR - \fI\(-> quad(2) = 11.00\fR - \fI\(-> quad(3) = 18.00\fR - \fI\(-> quad(4) = 27.00\fR -.CE -.VE TIP524 -.SH "SEE ALSO" -next(n), oo::class(n), oo::object(n) -.SH KEYWORDS -class, definition, method, object, slot -.\" Local variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: Index: doc/dict.n ================================================================== --- doc/dict.n +++ doc/dict.n @@ -19,50 +19,39 @@ containing dictionary values (see the \fBDICTIONARY VALUES\fR section below for a description), depending on \fIoption\fR. The legal \fIoption\fRs (which may be abbreviated) are: .TP \fBdict append \fIdictionaryVariable key \fR?\fIstring ...\fR? -. This appends the given string (or strings) to the value that the given key maps to in the dictionary value contained in the given variable, writing the resulting dictionary value back to that variable. -Non-existent keys are treated as if they map to an empty string. The -updated dictionary value is returned. -.VS TIP508 -If \fIdictionaryVariable\fR indicates an element that does not exist of an -array that has a default value set, the default value and will be used as the -value of the dictionary prior to the appending operation. -.VE TIP508 +Non-existent keys are treated as if they map to an empty string. .TP \fBdict create \fR?\fIkey value ...\fR? -. -Return a new dictionary that contains each of the key/value mappings +Create a new dictionary that contains each of the key/value mappings listed as arguments (keys and values alternating, with each key being followed by its associated value.) .TP \fBdict exists \fIdictionaryValue key \fR?\fIkey ...\fR? -. This returns a boolean value indicating whether the given key (or path of keys through a set of nested dictionaries) exists in the given dictionary value. This returns a true value exactly when \fBdict get\fR on that path will succeed. .TP \fBdict filter \fIdictionaryValue filterType arg \fR?\fIarg ...\fR? -. 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.) +\fBdict filter \fIdictionaryValue \fBkey \fIglobPattern\fR +The key rule only matches those key/value pairs whose keys match the +given pattern (in the style of \fBstring match\fR.) .TP -\fBdict filter \fIdictionaryValue \fBscript {\fIkeyVariable valueVariable\fB} \fIscript\fR -. +\fBdict filter \fIdictionaryValue \fBscript {\fIkeyVar valueVar\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 +\fIkeyVar\fR and the value to the \fIvalueVar\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 @@ -69,17 +58,16 @@ 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.) +\fBdict filter \fIdictionaryValue \fBvalue \fIglobPattern\fR +The value rule only matches those key/value pairs whose values match +the given pattern (in the style of \fBstring match\fR.) .RE .TP -\fBdict for {\fIkeyVariable valueVariable\fB} \fIdictionaryValue body\fR -. +\fBdict for {\fIkeyVar valueVar\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, and the third a script to be evaluated for each mapping with the key and value variables set appropriately (in the manner of \fBforeach\fR.) @@ -90,11 +78,10 @@ generates a \fBTCL_CONTINUE\fR result, this shall be treated exactly like a normal \fBTCL_OK\fR result. The order of iteration is the order in which the keys were inserted into the dictionary. .TP \fBdict get \fIdictionaryValue \fR?\fIkey ...\fR? -. Given a dictionary value (first argument) and a key (second argument), this will retrieve the value for that key. Where several keys are supplied, the behaviour of the command shall be as if the result of \fBdict get $dictVal $key\fR was passed as the first argument to \fBdict get\fR with the remaining arguments as second (and possibly @@ -114,155 +101,80 @@ .PP It is an error to attempt to retrieve a value for a key that is not present in the dictionary. .RE .TP -\fBdict getdef \fIdictionaryValue \fR?\fIkey ...\fR? \fIkey default\fR -.TP -\fBdict getwithdefault \fIdictionaryValue \fR?\fIkey ...\fR? \fIkey default\fR -.VS "8.7, TIP342" -This behaves the same as \fBdict get\fR (with at least one \fIkey\fR -argument), returning the value that the key path maps to in the -dictionary \fIdictionaryValue\fR, except that instead of producing an -error because the \fIkey\fR (or one of the \fIkey\fRs on the key path) -is absent, it returns the \fIdefault\fR argument instead. -.RS -.PP -Note that there must always be at least one \fIkey\fR provided, and that -\fBdict getdef\fR and \fBdict getwithdefault\fR are aliases for each other. -.RE -.VE "8.7, TIP342" -.TP \fBdict incr \fIdictionaryVariable key \fR?\fIincrement\fR? -. This adds the given increment value (an integer that defaults to 1 if not specified) to the value that the given key maps to in the dictionary value contained in the given variable, writing the resulting dictionary value back to that variable. Non-existent keys are treated as if they map to 0. It is an error to increment a value -for an existing key if that value is not an integer. The updated -dictionary value is returned. -.VS TIP508 -If \fIdictionaryVariable\fR indicates an element that does not exist of an -array that has a default value set, the default value and will be used as the -value of the dictionary prior to the incrementing operation. -.VE TIP508 +for an existing key if that value is not an integer. .TP \fBdict info \fIdictionaryValue\fR -. This returns information (intended for display to people) about the given dictionary though the format of this data is dependent on the implementation of the dictionary. For dictionaries that are implemented by hash tables, it is expected that this will return the string produced by \fBTcl_HashStats\fR, similar to \fBarray statistics\fR. .TP \fBdict keys \fIdictionaryValue \fR?\fIglobPattern\fR? -. Return a list of all keys in the given dictionary value. If a pattern is supplied, only those keys that match it (according to the rules of \fBstring match\fR) will be returned. The returned keys will be in the order that they were inserted into the dictionary. .TP \fBdict lappend \fIdictionaryVariable key \fR?\fIvalue ...\fR? -. This appends the given items to the list value that the given key maps to in the dictionary value contained in the given variable, writing the resulting dictionary value back to that variable. Non-existent keys are treated as if they map to an empty list, and it is legal for there to be no items to append to the list. It is an error for the -value that the key maps to to not be representable as a list. The -updated dictionary value is returned. -.VS TIP508 -If \fIdictionaryVariable\fR indicates an element that does not exist of an -array that has a default value set, the default value and will be used as the -value of the dictionary prior to the list-appending operation. -.VE TIP508 -.TP -\fBdict map \fR{\fIkeyVariable valueVariable\fR} \fIdictionaryValue body\fR -. -This command applies a transformation to each element of a dictionary, -returning a new dictionary. It takes three arguments: the first is 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, -and the third a script to be evaluated for each mapping with the key and value -variables set appropriately (in the manner of \fBlmap\fR). In an iteration -where the evaluated script completes normally (\fBTCL_OK\fR, as opposed to an -\fBerror\fR, etc.) the result of the script is put into an accumulator -dictionary using the key that is the current contents of the \fIkeyVariable\fR -variable at that point. The result of the \fBdict map\fR command is the -accumulator dictionary after all keys have been iterated over. -.RS -.PP -If the evaluation of the body for any particular step generates a \fBbreak\fR, -no further pairs from the dictionary will be iterated over and the \fBdict -map\fR command will terminate successfully immediately. If the evaluation of -the body for a particular step generates a \fBcontinue\fR result, the current -iteration is aborted and the accumulator dictionary is not modified. The order -of iteration is the natural order of the dictionary (typically the order in -which the keys were added to the dictionary; the order is the same as that -used in \fBdict for\fR). -.RE +value that the key maps to to not be representable as a list. .TP \fBdict merge \fR?\fIdictionaryValue ...\fR? -. Return a dictionary that contains the contents of each of the \fIdictionaryValue\fR arguments. Where two (or more) dictionaries contain a mapping for the same key, the resulting dictionary maps that key to the value according to the last dictionary on the command line containing a mapping for that key. .TP \fBdict remove \fIdictionaryValue \fR?\fIkey ...\fR? -. Return a new dictionary that is a copy of an old one passed in as first argument except without mappings for each of the keys listed. It is legal for there to be no keys to remove, and it also legal for any of the keys to be removed to not be present in the input dictionary in the first place. .TP \fBdict replace \fIdictionaryValue \fR?\fIkey value ...\fR? -. Return a new dictionary that is a copy of an old one passed in as first argument except with some values different or some extra key/value pairs added. It is legal for this command to be called with no key/value pairs, but illegal for this command to be called with a key but no value. .TP \fBdict set \fIdictionaryVariable key \fR?\fIkey ...\fR? \fIvalue\fR -. This operation takes the name of a variable containing a dictionary value and places an updated dictionary value in that variable containing a mapping from the given key to the given value. When multiple keys are present, this operation creates or updates a chain -of nested dictionaries. The updated dictionary value is returned. -.VS TIP508 -If \fIdictionaryVariable\fR indicates an element that does not exist of an -array that has a default value set, the default value and will be used as the -value of the dictionary prior to the value insert/update operation. -.VE TIP508 +of nested dictionaries. .TP \fBdict size \fIdictionaryValue\fR -. Return the number of key/value mappings in the given dictionary value. .TP \fBdict unset \fIdictionaryVariable key \fR?\fIkey ...\fR? -. This operation (the companion to \fBdict set\fR) takes the name of a variable containing a dictionary value and places an updated dictionary value in that variable that does not contain a mapping for the given key. Where multiple keys are present, this describes a path through nested dictionaries to the mapping to remove. At least one key must be specified, but the last key on the key-path need not exist. -All other components on the path must exist. The updated dictionary -value is returned. -.VS TIP508 -If \fIdictionaryVariable\fR indicates an element that does not exist of an -array that has a default value set, the default value and will be used as the -value of the dictionary prior to the value remove operation. -.VE TIP508 +All other components on the path must exist. .TP \fBdict update \fIdictionaryVariable key varName \fR?\fIkey varName ...\fR? \fIbody\fR -. Execute the Tcl script in \fIbody\fR with the value for each \fIkey\fR (as found by reading the dictionary value in \fIdictionaryVariable\fR) mapped to the variable \fIvarName\fR. There may be multiple \fIkey\fR/\fIvarName\fR pairs. If a \fIkey\fR does not have a mapping, that corresponds to an unset \fIvarName\fR. When \fIbody\fR @@ -271,37 +183,30 @@ \fIdictionaryVariable\fR itself becomes unreadable, when all updates are silently discarded), even if the result of \fIbody\fR is an error or some other kind of exceptional exit. The result of \fBdict update\fR is (unless some kind of error occurs) the result of the evaluation of \fIbody\fR. -.VS TIP508 -If \fIdictionaryVariable\fR indicates an element that does not exist of an -array that has a default value set, the default value and will be used as the -value of the dictionary prior to the update operation. -.VE TIP508 .RS .PP Each \fIvarName\fR is mapped in the scope enclosing the \fBdict update\fR; it is recommended that this command only be used in a local scope -(\fBproc\fRedure, lambda term for \fBapply\fR, or method). Because of +(\fBproc\fRedure or lambda term for \fBapply\fR). Because of this, the variables set by \fBdict update\fR will continue to exist after the command finishes (unless explicitly \fBunset\fR). Note that the mapping of values to variables does not use traces; changes to the \fIdictionaryVariable\fR's contents only happen when \fIbody\fR terminates. .RE .TP \fBdict values \fIdictionaryValue \fR?\fIglobPattern\fR? -. Return a list of all values in the given dictionary value. If a pattern is supplied, only those values that match it (according to the rules of \fBstring match\fR) will be returned. The returned values will be in the order of that the keys associated with those values were inserted into the dictionary. .TP \fBdict with \fIdictionaryVariable \fR?\fIkey ...\fR? \fIbody\fR -. Execute the Tcl script in \fIbody\fR with the value for each key in \fIdictionaryVariable\fR mapped (in a manner similarly to \fBdict update\fR) to a variable with the same name. Where one or more \fIkey\fRs are available, these indicate a chain of nested dictionaries, with the innermost dictionary being the one opened out @@ -310,20 +215,15 @@ dictionary be discarded, and this also happens if the contents of \fIdictionaryVariable\fR are adjusted so that the chain of dictionaries no longer exists. The result of \fBdict with\fR is (unless some kind of error occurs) the result of the evaluation of \fIbody\fR. -.VS TIP508 -If \fIdictionaryVariable\fR indicates an element that does not exist of an -array that has a default value set, the default value and will be used as the -value of the dictionary prior to the updating operation. -.VE TIP508 .RS .PP The variables are mapped in the scope enclosing the \fBdict with\fR; it is recommended that this command only be used in a local scope -(\fBproc\fRedure, lambda term for \fBapply\fR, or method). Because of +(\fBproc\fRedure or lambda term for \fBapply\fR). Because of this, the variables set by \fBdict with\fR will continue to exist after the command finishes (unless explicitly \fBunset\fR). Note that the mapping of values to variables does not use traces; changes to the \fIdictionaryVariable\fR's contents only happen when \fIbody\fR terminates. @@ -409,30 +309,30 @@ # Print out some employee info set i 0 puts "There are [\fBdict size\fR $employeeInfo] employees" \fBdict for\fR {id info} $employeeInfo { - puts "Employee #[incr i]: $id" - \fBdict with\fR info { - puts " Name: $forenames $surname" - puts " Address: $street, $city" - puts " Telephone: $phone" - } + puts "Employee #[incr i]: $id" + \fBdict with\fR info { + puts " Name: $forenames $surname" + puts " Address: $street, $city" + puts " Telephone: $phone" + } } # Another way to iterate and pick out names... foreach id [\fBdict keys\fR $employeeInfo] { - puts "Hello, [\fBdict get\fR $employeeInfo $id forenames]!" + puts "Hello, [\fBdict get\fR $employeeInfo $id forenames]!" } .CE .PP A localizable version of \fBstring toupper\fR: .PP .CS # Set up the basic C locale set capital [\fBdict create\fR C [\fBdict create\fR]] foreach c [split {abcdefghijklmnopqrstuvwxyz} ""] { - \fBdict set\fR capital C $c [string toupper $c] + \fBdict set\fR capital C $c [string toupper $c] } # English locales can luckily share the "C" locale \fBdict set\fR capital en [\fBdict get\fR $capital C] \fBdict set\fR capital en_US [\fBdict get\fR $capital C] @@ -447,26 +347,26 @@ .PP Showing the detail of \fBdict with\fR: .PP .CS proc sumDictionary {varName} { - upvar 1 $varName vbl - foreach key [\fBdict keys\fR $vbl] { - # Manufacture an entry in the subdictionary - \fBdict set\fR vbl $key total 0 - # Add the values and remove the old - \fBdict with\fR vbl $key { - set total [expr {$x + $y + $z}] - unset x y z - } - } - puts "last total was $total, for key $key" + upvar 1 $varName vbl + foreach key [\fBdict keys\fR $vbl] { + # Manufacture an entry in the subdictionary + \fBdict set\fR vbl $key total 0 + # Add the values and remove the old + \fBdict with\fR vbl $key { + set total [expr {$x + $y + $z}] + unset x y z + } + } + puts "last total was $total, for key $key" } set myDict { - a {x 1 y 2 z 3} - b {x 6 y 5 z 4} + a {x 1 y 2 z 3} + b {x 6 y 5 z 4} } sumDictionary myDict # prints: \fIlast total was 15, for key b\fR @@ -482,11 +382,8 @@ \fBdict with\fR foo {} puts $foo # prints: \fIa b foo {a b} bar 2 baz 3\fR .CE .SH "SEE ALSO" -append(n), array(n), foreach(n), incr(n), list(n), lappend(n), lmap(n), set(n) +append(n), array(n), foreach(n), incr(n), list(n), lappend(n), set(n) .SH KEYWORDS -dictionary, create, update, lookup, iterate, filter, map -'\" Local Variables: -'\" mode: nroff -'\" End: +dictionary, create, update, lookup, iterate, filter Index: doc/encoding.n ================================================================== --- doc/encoding.n +++ doc/encoding.n @@ -1,83 +1,64 @@ '\" '\" 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. -'\" +'\" .TH encoding n "8.1" Tcl "Tcl Built-In Commands" .so man.macros .BS .SH NAME encoding \- Manipulate encodings .SH SYNOPSIS \fBencoding \fIoption\fR ?\fIarg arg ...\fR? .BE + .SH INTRODUCTION .PP -Strings in Tcl are logically a sequence of 16-bit Unicode characters. -These strings are represented in memory as a sequence of bytes that -may be in one of several encodings: modified UTF\-8 (which uses 1 to 3 -bytes per character), 16-bit -.QW Unicode -(which uses 2 bytes per character, with an endianness that is -dependent on the host architecture), and binary (which uses a single -byte per character but only handles a restricted range of characters). -Tcl does not guarantee to always use the same encoding for the same -string. -.PP -Different operating system interfaces or applications may generate -strings in other encodings such as Shift\-JIS. The \fBencoding\fR -command helps to bridge the gap between Unicode and these other -formats. +Strings in Tcl are encoded using 16-bit Unicode characters. Different +operating system interfaces or applications may generate strings in +other encodings such as Shift-JIS. The \fBencoding\fR command helps +to bridge the gap between Unicode and these other formats. .SH DESCRIPTION .PP Performs one of several encoding related operations, depending on \fIoption\fR. The legal \fIoption\fRs are: .TP \fBencoding convertfrom\fR ?\fIencoding\fR? \fIdata\fR -. Convert \fIdata\fR to Unicode from the specified \fIencoding\fR. The characters in \fIdata\fR are treated as binary data where the lower 8-bits of each character is taken as a single byte. The resulting sequence of bytes is treated as a string in the specified \fIencoding\fR. If \fIencoding\fR is not specified, the current system encoding is used. .TP \fBencoding convertto\fR ?\fIencoding\fR? \fIstring\fR -. Convert \fIstring\fR from Unicode to the specified \fIencoding\fR. The result is a sequence of bytes that represents the converted string. Each byte is stored in the lower 8-bits of a Unicode -character (indeed, the resulting string is a binary string as far as -Tcl is concerned, at least initially). If \fIencoding\fR is not -specified, the current system encoding is used. +character. If \fIencoding\fR is not specified, the current +system encoding is used. .TP \fBencoding dirs\fR ?\fIdirectoryList\fR? -. +.VS 8.5 Tcl can load encoding data files from the file system that describe additional encodings for it to work with. This command sets the search path for \fB*.enc\fR encoding data files to the list of directories \fIdirectoryList\fR. If \fIdirectoryList\fR is omitted then the command returns the current list of directories that make up the search path. It is an error for \fIdirectoryList\fR to not be a valid list. If, when a search for an encoding data file is happening, an element in \fIdirectoryList\fR does not refer to a readable, searchable directory, that element is ignored. +.VE 8.5 .TP \fBencoding names\fR -. Returns a list containing the names of all of the encodings that are -currently available. -The encodings -.QW utf-8 -and -.QW iso8859-1 -are guaranteed to be present in the list. +currently available. .TP \fBencoding system\fR ?\fIencoding\fR? -. Set the system encoding to \fIencoding\fR. If \fIencoding\fR is omitted then the command returns the current system encoding. The system encoding is used whenever Tcl passes strings to system calls. .SH EXAMPLE .PP @@ -88,28 +69,25 @@ characters by simply typing the strings in place in the script. However, because the \fBsource\fR command always reads files using the current system encoding, Tcl will only source such files correctly when the encoding used to write the file is the same. This tends not to be true in an internationalized setting. For example, if such a -file was sourced in North America (where the ISO8859\-1 is normally +file was sourced in North America (where the ISO8859-1 is normally used), each byte in the file would be treated as a separate character that maps to the 00 page in Unicode. The resulting Tcl strings will not contain the expected Japanese characters. Instead, they will contain a sequence of Latin-1 characters that correspond to the bytes of the original string. The \fBencoding\fR command can be used to convert this string to the expected Japanese Unicode characters. For example, -.PP .CS set s [\fBencoding convertfrom\fR euc-jp "\exA4\exCF"] .CE -.PP would return the Unicode string .QW "\eu306F" , which is the Hiragana letter HA. + .SH "SEE ALSO" Tcl_GetEncoding(3) + .SH KEYWORDS -encoding, unicode -.\" Local Variables: -.\" mode: nroff -.\" End: +encoding Index: doc/eof.n ================================================================== --- doc/eof.n +++ doc/eof.n @@ -2,20 +2,21 @@ '\" 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 eof n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME eof \- Check for end of file condition on channel .SH SYNOPSIS \fBeof \fIchannelId\fR .BE + .SH DESCRIPTION .PP Returns 1 if an end of file condition occurred during the most recent input operation on \fIchannelId\fR (such as \fBgets\fR), 0 otherwise. @@ -23,13 +24,11 @@ \fIChannelId\fR must be an identifier for an open channel such as a Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR), the return value from an invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel creation command provided by a Tcl extension. .SH EXAMPLES -.PP Read and print out the contents of a file line-by-line: -.PP .CS set f [open somefile.txt] while {1} { set line [gets $f] if {[\fBeof\fR $f]} { @@ -39,11 +38,10 @@ puts "Read line: $line" } .CE .PP Read and print out the contents of a file by fixed-size records: -.PP .CS set f [open somefile.dat] fconfigure $f -translation binary set recordSize 40 while {1} { @@ -53,13 +51,11 @@ break } puts "Read record: $record" } .CE + .SH "SEE ALSO" file(n), open(n), close(n), fblocked(n), Tcl_StandardChannels(3) + .SH KEYWORDS channel, end of file -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/error.n ================================================================== --- doc/error.n +++ doc/error.n @@ -2,11 +2,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 error n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -26,53 +26,47 @@ error occurred; as nested commands unwind, the Tcl interpreter adds information to the \fB\-errorinfo\fR return option. If the \fIinfo\fR argument is present, it is used to initialize the \fB\-errorinfo\fR return options and the first increment of unwind information -will not be added by the Tcl interpreter. +will not be added by the Tcl interpreter. In other words, the command containing the \fBerror\fR command will not appear in the stack trace; in its place will be \fIinfo\fR. Historically, this feature had been most useful in conjunction with the \fBcatch\fR command: if a caught error cannot be handled successfully, \fIinfo\fR can be used to return a stack trace reflecting the original point of occurrence of the error: -.PP .CS -catch {...} errMsg +\fBcatch {...} errMsg set savedInfo $::errorInfo \&... -\fBerror\fR $errMsg $savedInfo +error $errMsg $savedInfo\fR .CE -.PP When working with Tcl 8.5 or later, the following code should be used instead: -.PP .CS -catch {...} errMsg options +\fBcatch {...} errMsg options \&... -return -options $options $errMsg +return -options $options $errMsg\fR .CE .PP If the \fIcode\fR argument is present, then its value is stored in the \fB\-errorcode\fR return option. The \fB\-errorcode\fR return option is intended to hold a machine-readable description of the error in cases where such information is available; see the \fBreturn\fR manual page for information on the proper format for this option's value. .SH EXAMPLE -.PP Generate an error if a basic mathematical operation fails: -.PP .CS if {1+2 != 3} { \fBerror\fR "something is very wrong with addition" } .CE + .SH "SEE ALSO" catch(n), return(n) + .SH KEYWORDS -error, exception -'\" Local Variables: -'\" mode: nroff -'\" End: +error Index: doc/eval.n ================================================================== --- doc/eval.n +++ doc/eval.n @@ -2,20 +2,21 @@ '\" 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 eval n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME eval \- Evaluate a Tcl script .SH SYNOPSIS \fBeval \fIarg \fR?\fIarg ...\fR? .BE + .SH DESCRIPTION .PP \fBEval\fR takes one or more arguments, which together comprise a Tcl script containing one or more commands. \fBEval\fR concatenates all its arguments in the same @@ -23,17 +24,15 @@ Tcl interpreter recursively, and returns the result of that evaluation (or any error generated by it). Note that the \fBlist\fR command quotes sequences of words in such a way that they are not further expanded by the \fBeval\fR command. .SH EXAMPLES -.PP Often, it is useful to store a fragment of a script in a variable and execute it later on with extra values appended. This technique is used in a number of places throughout the Tcl core (e.g. in \fBfcopy\fR, \fBlsort\fR and \fBtrace\fR command callbacks). This example shows how to do this using core Tcl commands: -.PP .CS set script { puts "logging now" lappend $myCurrentLogVar } @@ -47,38 +46,37 @@ update ;# Check for the asynch log switch \fBeval\fR $script $i [clock clicks] } .CE .PP +.VS 8.5 Note that in the most common case (where the script fragment is actually just a list of words forming a command prefix), it is better to use \fB{*}$script\fR when doing this sort of invocation pattern. It is less general than the \fBeval\fR command, and hence easier to make robust in practice. +.VE 8.5 The following procedure acts in a way that is analogous to the \fBlappend\fR command, except it inserts the argument values at the start of the list in the variable: -.PP .CS proc lprepend {varName args} { - upvar 1 $varName var - # Ensure that the variable exists and contains a list - lappend var - # Now we insert all the arguments in one go - set var [\fBeval\fR [list linsert $var 0] $args] + upvar 1 $varName var + # Ensure that the variable exists and contains a list + lappend var + # Now we insert all the arguments in one go + set var [\fBeval\fR [list linsert $var 0] $args] } .CE -.PP +.VS 8.5 However, the last line would now normally be written without \fBeval\fR, like this: -.PP .CS set var [linsert $var 0 {*}$args] .CE +.VE 8.5 + .SH "SEE ALSO" -catch(n), concat(n), error(n), errorCode(n), errorInfo(n), interp(n), list(n), -namespace(n), subst(n), uplevel(n) +catch(n), concat(n), error(n), interp(n), list(n), namespace(n), subst(n), tclvars(n), uplevel(n) + .SH KEYWORDS concatenate, evaluate, script -'\" Local Variables: -'\" mode: nroff -'\" End: Index: doc/exec.n ================================================================== --- doc/exec.n +++ doc/exec.n @@ -3,45 +3,49 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2006 Donal K. Fellows. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH exec n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME exec \- Invoke subprocesses .SH SYNOPSIS -\fBexec \fR?\fIswitches\fR? \fIarg \fR?\fIarg ...\fR? ?\fB&\fR? +\fBexec \fR?\fIswitches\fR? \fIarg \fR?\fIarg ...\fR? .BE + .SH DESCRIPTION .PP This command treats its arguments as the specification of one or more subprocesses to execute. The arguments take the form of a standard shell pipeline where each \fIarg\fR becomes one word of a command, and each distinct command becomes a subprocess. +The result of the command is the standard output of the final subprocess in +the pipeline, interpreted using the system \fBencoding\fR; to use any other +encoding (especially including binary data), the pipeline must be +\fBopen\fRed, configured and read explicitly. .PP If the initial arguments to \fBexec\fR start with \fB\-\fR then they are treated as command-line switches and are not part of the pipeline specification. The following switches are currently supported: .TP 13 \fB\-ignorestderr\fR -. +.VS 8.5 Stops the \fBexec\fR command from treating the output of messages to the pipeline's standard error channel as an error case. +.VE 8.5 .TP 13 \fB\-keepnewline\fR -. Retains a trailing newline in the pipeline's output. Normally a trailing newline will be deleted. .TP 13 \fB\-\|\-\fR -. Marks the end of switches. The argument following this one will be treated as the first \fIarg\fR even if it starts with a \fB\-\fR. .PP If an \fIarg\fR (or pair of \fIarg\fRs) has one of the forms described below then it is used by \fBexec\fR to control the @@ -53,115 +57,105 @@ .QW \fB<\fR or in the same argument with no intervening space (i.e. .QW \fB<\fIfileName\fR ). .TP 15 \fB|\fR -. Separates distinct commands in the pipeline. The standard output of the preceding command will be piped into the standard input of the next command. .TP 15 \fB|&\fR -. Separates distinct commands in the pipeline. Both standard output and standard error of the preceding command will be piped into the standard input of the next command. This form of redirection overrides forms such as 2> and >&. .TP 15 \fB<\0\fIfileName\fR -. The file named by \fIfileName\fR is opened and used as the standard input for the first command in the pipeline. .TP 15 \fB<@\0\fIfileId\fR -. \fIFileId\fR must be the identifier for an open file, such as the return value from a previous call to \fBopen\fR. It is used as the standard input for the first command in the pipeline. \fIFileId\fR must have been opened for reading. .TP 15 \fB<<\0\fIvalue\fR -. \fIValue\fR is passed to the first command as its standard input. .TP 15 \fB>\0\fIfileName\fR -. Standard output from the last command is redirected to the file named \fIfileName\fR, overwriting its previous contents. .TP 15 \fB2>\0\fIfileName\fR -. Standard error from all commands in the pipeline is redirected to the file named \fIfileName\fR, overwriting its previous contents. .TP 15 \fB>&\0\fIfileName\fR -. Both standard output from the last command and standard error from all commands are redirected to the file named \fIfileName\fR, overwriting its previous contents. .TP 15 \fB>>\0\fIfileName\fR -. Standard output from the last command is redirected to the file named \fIfileName\fR, appending to it rather than overwriting it. .TP 15 \fB2>>\0\fIfileName\fR -. Standard error from all commands in the pipeline is redirected to the file named \fIfileName\fR, appending to it rather than overwriting it. .TP 15 \fB>>&\0\fIfileName\fR -. Both standard output from the last command and standard error from all commands are redirected to the file named \fIfileName\fR, appending to it rather than overwriting it. .TP 15 \fB>@\0\fIfileId\fR -. \fIFileId\fR must be the identifier for an open file, such as the return value from a previous call to \fBopen\fR. Standard output from the last command is redirected to \fIfileId\fR's file, which must have been opened for writing. .TP 15 \fB2>@\0\fIfileId\fR -. \fIFileId\fR must be the identifier for an open file, such as the return value from a previous call to \fBopen\fR. Standard error from all commands in the pipeline is redirected to \fIfileId\fR's file. The file must have been opened for writing. .TP 15 \fB2>@1\0\fR -. Standard error from all commands in the pipeline is redirected to the command result. This operator is only valid at the end of the command pipeline. .TP 15 \fB>&@\0\fIfileId\fR -. \fIFileId\fR must be the identifier for an open file, such as the return value from a previous call to \fBopen\fR. Both standard output from the last command and standard error from all commands are redirected to \fIfileId\fR's file. The file must have been opened for writing. .PP If standard output has not been redirected then the \fBexec\fR command returns the standard output from the last command -in the pipeline, unless +in the pipeline, +.VS 8.5 +unless .QW 2>@1 was specified, in which case standard error is included as well. +.VE 8.5 If any of the commands in the pipeline exit abnormally or are killed or suspended, then \fBexec\fR will return an error and the error message will include the pipeline's output followed by error messages describing the abnormal terminations; the \fB\-errorcode\fR return option will contain additional information about the last abnormal termination encountered. If any of the commands writes to its standard error file and that standard error is not redirected +.VS 8.5 and \fB\-ignorestderr\fR is not specified, +.VE 8.5 then \fBexec\fR will return an error; the error message will include the pipeline's standard output, followed by messages about abnormal terminations (if any), followed by the standard error output. .PP @@ -222,20 +216,20 @@ with the windows batch files (excepting the newline, see below). Although it is the common escape algorithm, but, in fact, the way how the executable parses the command-line (resp. splits it into single arguments) is decisive. .PP -Unfortunately, there is currently no way to supply newline character within -an argument to the batch files (\fB.cmd\fR or \fB.bat\fR) or to the command +Unfortunately, there is currently no way to supply newline character within +an argument to the batch files (\fB.cmd\fR or \fB.bat\fR) or to the command processor (\fBcmd.exe /c\fR), because this causes truncation of command-line -(also the argument chain) on the first newline character. +(also the argument chain) on the first newline character. But it works properly with an executable (using CommandLineToArgv, etc). .PP The Tk console text widget does not provide real standard IO capabilities. Under Tk, when redirecting from standard input, all applications will see an immediate end-of-file; information redirected to standard output or standard -error will be discarded. +error will be discarded. .PP Either forward or backward slashes are accepted as path separators for arguments to Tcl commands. When executing an application, the path name specified for the application may also contain forward or backward slashes as path separators. Bear in mind, however, that most Windows applications @@ -242,19 +236,19 @@ accept arguments with forward slashes only as option delimiters and backslashes only in paths. Any arguments to an application that specify a path name with forward slashes will not automatically be converted to use the backslash character. If an argument contains forward slashes as the path separator, it may or may not be recognized as a path name, depending on -the program. +the program. .PP Additionally, when calling a 16-bit DOS or Windows 3.X application, all path names must use the short, cryptic, path format (e.g., using .QW applba~1.def instead of .QW applbakery.default ), which can be obtained with the -.QW "\fBfile attributes\fI fileName \fB\-shortname\fR" +.QW "\fBfile attributes \fIfileName \fB\-shortname\fR" command. .PP Two or more forward or backward slashes in a row in a path refer to a network path. For example, a simple concatenation of the root directory \fBc:/\fR with a subdirectory \fB/windows/system\fR will yield @@ -280,80 +274,127 @@ \fBexec\fR will not work well with TUI applications when a console is not present, as is done when launching applications under wish. It is desirable to have console applications hidden and detached. This is a designed-in limitation as \fBexec\fR wants to communicate over pipes. The Expect extension addresses this issue when communicating with a TUI application. -.PP +.RE +.TP +\fBWindows NT\fR +. When attempting to execute an application, \fBexec\fR first searches for -the name as it was specified. Then, in order, -\fB.com\fR, \fB.exe\fR, \fB.bat\fR and \fB.cmd\fR -are appended to the end of the specified name and it searches +the name as it was specified. Then, in order, \fB.com\fR, \fB.exe\fR, and +\fB.bat\fR are appended to the end of the specified name and it searches for the longer name. If a directory name was not specified as part of the application name, the following directories are automatically searched in order when attempting to locate the application: -.IP \(bu 3 +.RS +.IP \(bu The directory from which the Tcl executable was loaded. -.IP \(bu 3 +.IP \(bu The current directory. -.IP \(bu 3 +.IP \(bu The Windows NT 32-bit system directory. -.IP \(bu 3 +.IP \(bu The Windows NT 16-bit system directory. -.IP \(bu 3 +.IP \(bu The Windows NT home directory. -.IP \(bu 3 +.IP \(bu The directories listed in the path. .PP In order to execute shell built-in commands like \fBdir\fR and \fBcopy\fR, the caller must prepend the desired command with .QW "\fBcmd.exe /c\0\fR" because built-in commands are not implemented using executables. .RE .TP -\fBUnix\fR (including Mac OS X) +\fBWindows 9x\fR . +When attempting to execute an application, \fBexec\fR first searches for +the name as it was specified. Then, in order, \fB.com\fR, \fB.exe\fR, and +\fB.bat\fR are appended to the end of the specified name and it searches +for the longer name. If a directory name was not specified as part of the +application name, the following directories are automatically searched in +order when attempting to locate the application: +.RS +.IP \(bu +The directory from which the Tcl executable was loaded. +.IP \(bu +The current directory. +.IP \(bu +The Windows 9x system directory. +.IP \(bu +The Windows 9x home directory. +.IP \(bu +The directories listed in the path. +.RE +.RS +.PP +In order to execute shell built-in commands like \fBdir\fR and \fBcopy\fR, +the caller must prepend the desired command with +.QW "\fBcommand.com /c\0\fR" +because built-in commands are not implemented using executables. +.PP +Once a 16-bit DOS application has read standard input from a console and +then quit, all subsequently run 16-bit DOS applications will see the +standard input as already closed. 32-bit applications do not have this +problem and will run correctly, even after a 16-bit DOS application thinks +that standard input is closed. There is no known workaround for this bug +at this time. +.PP +Redirection between the \fBNUL:\fR device and a 16-bit application does not +always work. When redirecting from \fBNUL:\fR, some applications may hang, +others will get an infinite stream of +.QW 0x01 +bytes, and some will actually +correctly get an immediate end-of-file; the behavior seems to depend upon +something compiled into the application itself. When redirecting greater than +4K or so to \fBNUL:\fR, some applications will hang. The above problems do not +happen with 32-bit applications. +.PP +All DOS 16-bit applications are run synchronously. All standard input from +a pipe to a 16-bit DOS application is collected into a temporary file; the +other end of the pipe must be closed before the 16-bit DOS application +begins executing. All standard output or error from a 16-bit DOS +application to a pipe is collected into temporary files; the application +must terminate before the temporary files are redirected to the next stage +of the pipeline. This is due to a workaround for a Windows 95 bug in the +implementation of pipes, and is how the standard Windows 95 DOS shell +handles pipes itself. +.PP +Certain applications, such as \fBcommand.com\fR, should not be executed +interactively. Applications which directly access the console window, +rather than reading from their standard input and writing to their standard +output may fail, hang Tcl, or even hang the system if their own private +console window is not available to them. +.RE +.TP +\fBUnix\fR\0\0\0\0\0\0\0 The \fBexec\fR command is fully functional and works as described. .SH "UNIX EXAMPLES" -.PP Here are some examples of the use of the \fBexec\fR command on Unix. +.PP To execute a simple program and get its result: .PP .CS \fBexec\fR uname -a .CE -.SS "WORKING WITH NON-ZERO RESULTS" .PP To execute a program that can return a non-zero result, you should wrap the call to \fBexec\fR in \fBcatch\fR and check the contents of the \fB\-errorcode\fR return option if you have an error: .PP .CS set status 0 if {[catch {\fBexec\fR grep foo bar.txt} results options]} { - set details [dict get $options -errorcode] - if {[lindex $details 0] eq "CHILDSTATUS"} { - 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" + set details [dict get $options -errorcode] + if {[lindex $details 0] eq "CHILDSTATUS"} { + set status [lindex $details 2] + } else { + # Some kind of unexpected failure + } +} +.CE .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 @@ -364,39 +405,22 @@ would be translated into something like: .PP .CS \fBexec\fR awk {{sum += $1} END {print sum}} numbers.list .CE -.SS "WORKING WITH GLOBBING" .PP If you are converting invocations involving shell globbing, you should remember that Tcl does not handle globbing or expand things into multiple arguments by default. Instead you should write things like this: .PP .CS \fBexec\fR ls -l {*}[glob *.tcl] .CE -.SS "WORKING WITH USER-SUPPLIED SHELL SCRIPT FRAGMENTS" -.PP -One useful technique can be to expose to users of a script the ability -to specify a fragment of shell script to execute that will have some -data passed in on standard input that was produced by the Tcl program. -This is a common technique for using the \fIlpr\fR program for -printing. By far the simplest way of doing this is to pass the user's -script to the user's shell for processing, as this avoids a lot of -complexity with parsing other languages. -.PP -.CS -set lprScript [\fIget from user...\fR] -set postscriptData [\fIgenerate somehow...\fR] - -\fBexec\fR $env(SHELL) -c $lprScript << $postscriptData -.CE .SH "WINDOWS EXAMPLES" -.PP Here are some examples of the use of the \fBexec\fR command on Windows. +.PP To start an instance of \fInotepad\fR editing a file without waiting for the user to finish editing the file: .PP .CS \fBexec\fR notepad myfile.txt & @@ -405,11 +429,18 @@ To print a text file using \fInotepad\fR: .PP .CS \fBexec\fR notepad /p myfile.txt .CE -.SS "WORKING WITH CONSOLE PROGRAMS" +.PP +To print a text file in a directory other than the current one using +\fInotepad\fR, you need to use \fBfile nativename\fR to convert the name into +a form that will be understood by the other program: +.PP +.CS +\fBexec\fR notepad /p [file nativename some/dir/myfile.txt] +.CE .PP If a program calls other programs, such as is common with compilers, then you may need to resort to batch files to hide the console windows that sometimes pop up: .PP @@ -420,15 +451,16 @@ With the file \fIcmp.bat\fR looking something like: .PP .CS @gcc %* .CE +.PP or like another variant using single parameters: +.PP .CS @gcc %1 %2 %3 %4 %5 %6 %7 %8 %9 .CE -.SS "WORKING WITH COMMAND BUILT-INS" .PP Sometimes you need to be careful, as different programs may have the same name and be in the path. It can then happen that typing a command at the DOS prompt finds \fIa different program\fR than the same command run via \fBexec\fR. This is because of the (documented) @@ -443,25 +475,9 @@ the \fBglob\fR command.) To do that, use this: .PP .CS \fBexec\fR {*}[auto_execok dir] *.tcl .CE -.SS "WORKING WITH NATIVE FILENAMES" -.PP -Many programs on Windows require filename arguments to be passed in with -backslashes as pathname separators. This is done with the help of the -\fBfile nativename\fR command. For example, to make a directory (on NTFS) -encrypted so that only the current user can access it requires use of -the \fICIPHER\fR command, like this: -.PP -.CS -set secureDir "~/Desktop/Secure Directory" -file mkdir $secureDir -\fBexec\fR CIPHER /e /s:[file nativename $secureDir] -.CE .SH "SEE ALSO" -error(n), file(n), open(n) +error(n), open(n) .SH KEYWORDS execute, pipeline, redirection, subprocess -'\" Local Variables: -'\" mode: nroff -'\" End: Index: doc/exit.n ================================================================== --- doc/exit.n +++ doc/exit.n @@ -2,11 +2,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 exit n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -20,36 +20,32 @@ Terminate the process, returning \fIreturnCode\fR to the system as the exit status. If \fIreturnCode\fR is not specified then it defaults to 0. .SH EXAMPLE -.PP Since non-zero exit codes are usually interpreted as error cases by the calling process, the \fBexit\fR command is an important part of signaling that something fatal has gone wrong. This code fragment is useful in scripts to act as a general problem trap: -.PP .CS proc main {} { # ... put the real main code in here ... } if {[catch {main} msg options]} { puts stderr "unexpected script error: $msg" - if {[info exists env(DEBUG)]} { + if {[info exist env(DEBUG)]} { puts stderr "---- BEGIN TRACE ----" puts stderr [dict get $options -errorinfo] puts stderr "---- END TRACE ----" } # Reserve code 1 for "expected" error exits... \fBexit\fR 2 } .CE + .SH "SEE ALSO" exec(n) + .SH KEYWORDS -abort, exit, process -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: +exit, process Index: doc/expr.n ================================================================== --- doc/expr.n +++ doc/expr.n @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-2000 Sun Microsystems, Inc. '\" 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. -'\" +'\" .TH expr n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -15,337 +15,298 @@ .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 +Concatenates \fIarg\fRs (adding separator spaces between them), +evaluates the result as a Tcl expression, and returns the value. +The operators permitted in Tcl expressions 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. +Expressions almost always yield numeric results +(integer or floating-point values). For example, the expression .PP .CS -\fBexpr\fR 8.2 + 6 +\fBexpr 8.2 + 6\fR .CE .PP evaluates to 14.2. -Expressions differ from C expressions in the way that -operands are specified. Expressions also support -non-numeric operands, string comparisons, and some +Tcl expressions differ from C expressions in the way that +operands are specified. Also, Tcl expressions support +non-numeric operands and string comparisons, as well as some additional operators not found in C. -.PP -When an expression evaluates to an integer, the value is the decimal form of -the integer, and when an expression evaluates to a floating-point number, the -value is the form produced by the \fB%g\fR format specifier of Tcl's -\fBformat\fR command. .SS OPERANDS .PP -An expression consists of a combination of operands, operators, parentheses and -commas, possibly with whitespace between any of these elements, which is -ignored. +A Tcl expression consists of a combination of operands, operators, +and parentheses. +White space may be used between the operands and operators and +parentheses; it is ignored by the expression's instructions. +Where possible, operands are interpreted as integer values. +.VS 8.5 +Integer values may be specified in decimal (the normal case), in binary +(if the first two characters of the operand are \fB0b\fR), in octal +(if the first two characters of the operand are \fB0o\fR), or in hexadecimal +(if the first two characters of the operand are \fB0x\fR). For +compatibility with older Tcl releases, an octal integer value is also +indicated simply when the first character of the operand is \fB0\fR, +whether or not the second character is also \fBo\fR. +If an operand does not have one of the integer formats given +above, then it is treated as a floating-point number if that is +possible. Floating-point numbers may be specified in any of several +common formats making use of the decimal digits, the decimal point \fB.\fR, +the characters \fBe\fR or \fBE\fR indicating scientific notation, and +the sign characters \fB+\fR or \fB\-\fR. For example, all of the +following are valid floating-point numbers: 2.1, 3., 6e4, 7.91e+16. +Also recognized as floating point values are the strings \fBInf\fR +and \fBNaN\fR making use of any case for each character. +.VE 8.5 +If no numeric interpretation is possible (note that all literal +operands that are not numeric or boolean must be quoted with either +braces or with double quotes), then an operand is left as a string +(and only a limited set of operators may be applied to it). .PP -An operand may be specified in any of the following ways: +Operands 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. +As a boolean value, using any form understood by \fBstring is boolean\fR. .IP [3] -As a variable, using standard \fB$\fR notation. -The value of the variable is then the value of the operand. +As a Tcl variable, using standard \fB$\fR notation. +The variable's value will be used as the operand. .IP [4] As a string enclosed in double-quotes. -Backslash, variable, and command substitution are performed as described in -\fBTcl\fR. +The expression parser will perform backslash, variable, and +command substitutions on the information between the quotes, +and use the resulting value as the operand .IP [5] As a string enclosed in braces. -The operand is treated as a braced value as described in \fBTcl\fR. +The characters between the open brace and matching close brace +will be used as the operand without any substitutions. .IP [6] As a Tcl command enclosed in brackets. -Command substitution is performed as described in \fBTcl\fR. +The command will be executed and its result will be used as +the operand. .IP [7] -As a mathematical function such as \fBsin($x)\fR, whose arguments have any of the above -forms for operands. See \fBMATH FUNCTIONS\fR below for +As a mathematical function whose arguments have any of the above +forms for operands, such as \fBsin($x)\fR. See \fBMATH FUNCTIONS\fR below for a discussion of how mathematical functions are handled. -.PP -Because \fBexpr\fR parses and performs substitutions on values that have -already been parsed and substituted by \fBTcl\fR, it is usually best to enclose -expressions in braces to avoid the first round of substitutions by -\fBTcl\fR. -.PP -Below are some examples of simple expressions where the value of \fBa\fR is 3 -and the value of \fBb\fR is 6. The command on the left side of each line -produces the value on the right side. +.LP +Where the above substitutions occur (e.g. inside quoted strings), they +are performed by the expression's instructions. +However, the command parser may already have performed one round of +substitution before the expression processor was called. +As discussed below, it is usually best to enclose expressions +in braces to prevent the command parser from performing substitutions +on the contents. +.PP +For some examples of simple expressions, suppose the variable +\fBa\fR has the value 3 and +the variable \fBb\fR has the value 6. +Then the command on the left side of each of the lines below +will produce the value on the right side of the line: .PP .CS .ta 9c \fBexpr\fR 3.1 + $a \fI6.1\fR \fBexpr\fR 2 + "$a.$b" \fI5.6\fR \fBexpr\fR 4*[llength "6 2"] \fI8\fR \fBexpr\fR {{word one} < "word $a"} \fI0\fR .CE -.PP -\fBInteger value\fR -.PP -An integer operand may be specified in decimal (the normal case, the optional -first two characters are \fB0d\fR), binary -(the first two characters are \fB0b\fR), octal -(the first two characters are \fB0o\fR), or hexadecimal -(the first two characters are \fB0x\fR) form. For -.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 -more versatile operators such as \fB==\fR. -.PP -Unless otherwise specified, operators accept non-numeric operands. The value -of a boolean operation is 1 if true, 0 otherwise. See also \fBstring is\fR -\fBboolean\fR. The valid operators, most of which are also available as -commands in the \fBtcl::mathop\fR namespace (see \fBmathop\fR(n)), are listed -below, grouped in decreasing order of precedence: +The valid operators (most of which are also available as commands in +the \fBtcl::mathop\fR namespace; see the \fBmathop\fR(n) manual page +for details) are listed below, grouped in decreasing order of precedence: .TP 20 \fB\-\0\0+\0\0~\0\0!\fR -. -Unary minus, unary plus, bit-wise NOT, logical NOT. These operators -may only be applied to numeric operands, and bit-wise NOT may only be -applied to integers. +Unary minus, unary plus, bit-wise NOT, logical NOT. None of these operators +may be applied to string operands, and bit-wise NOT may be +applied only to integers. .TP 20 \fB**\fR -. -Exponentiation. Valid for numeric operands. The maximum exponent value -that Tcl can handle if the first number is an integer > 1 is 268435455. +.VS 8.5 +Exponentiation. Valid for any numeric operands. +.VE 8.5 .TP 20 \fB*\0\0/\0\0%\fR -. -Multiply and divide, which are valid for numeric operands, and remainder, which -is valid for integers. The remainder, an absolute value smaller than the -absolute value of the divisor, has the same sign as the divisor. +Multiply, divide, remainder. None of these operators may be +applied to string operands, and remainder may be applied only +to integers. +The remainder will always have the same sign as the divisor and +an absolute value smaller than the absolute value of the divisor. .RS .PP -When applied to integers, division and remainder can be -considered to partition the number line into a sequence of -adjacent non-overlapping pieces, where each piece is the size of the divisor; -the quotient identifies which piece the dividend lies within, and the -remainder identifies where within that piece the dividend lies. A +When applied to integers, the division and remainder operators can be +considered to partition the number line into a sequence of equal-sized +adjacent non-overlapping pieces where each piece is the size of the divisor; +the division result identifies which piece the divisor lay within, and the +remainder result identifies where within that piece the divisor lay. A consequence of this is that the result of .QW "-57 \fB/\fR 10" is always -6, and the result of .QW "-57 \fB%\fR 10" is always 3. .RE .TP 20 \fB+\0\0\-\fR -. -Add and subtract. Valid for numeric operands. +Add and subtract. Valid for any numeric operands. .TP 20 \fB<<\0\0>>\fR -. -Left and right shift. Valid for integers. +Left and right shift. Valid for integer operands only. A right shift always propagates the sign bit. .TP 20 \fB<\0\0>\0\0<=\0\0>=\fR -. -Boolean numeric-preferring comparisons: less than, greater than, less than or -equal, and greater than or equal. If either argument is not numeric, the -comparison is done using UNICODE string comparison, as with the string -comparison operators below, which have the same precedence. -.TP 20 -\fBlt\0\0gt\0\0le\0\0ge\fR -.VS "8.7, TIP461" -Boolean string comparisons: less than, greater than, less than or equal, and -greater than or equal. These always compare values using their UNICODE strings -(also see \fBstring compare\fR), unlike with the numeric-preferring -comparisons abov, which have the same precedence. -.VE "8.7, TIP461" +Boolean less, greater, less than or equal, and greater than or equal. +Each operator produces 1 if the condition is true, 0 otherwise. +These operators may be applied to strings as well as numeric operands, +in which case string comparison is used. .TP 20 \fB==\0\0!=\fR -. -Boolean equal and not equal. +Boolean equal and not equal. Each operator produces a zero/one result. +Valid for all operand types. .TP 20 \fBeq\0\0ne\fR -. -Boolean string equal and string not equal. +Boolean string equal and string not equal. Each operator produces a +zero/one result. The operand types are interpreted only as strings. .TP 20 \fBin\0\0ni\fR -. -List containment and negated list containment. The first argument is -interpreted as a string, the second as a list. \fBin\fR tests for membership -in the list, and \fBni\fR is the inverse. +.VS 8.5 +List containment and negated list containment. Each operator produces +a zero/one result and treats its first argument as a string and its +second argument as a Tcl list. The \fBin\fR operator indicates +whether the first argument is a member of the second argument list; +the \fBni\fR operator inverts the sense of the result. +.VE 8.5 .TP 20 \fB&\fR -. -Bit-wise AND. Valid for integer operands. +Bit-wise AND. Valid for integer operands only. .TP 20 \fB^\fR -. -Bit-wise exclusive OR. Valid for integer operands. +Bit-wise exclusive OR. Valid for integer operands only. .TP 20 \fB|\fR -. -Bit-wise OR. Valid for integer operands. +Bit-wise OR. Valid for integer operands only. .TP 20 \fB&&\fR -. -Logical AND. If both operands are true, the result is 1, or 0 otherwise. -This operator evaluates lazily; it only evaluates its second operand if it -must in order to determine its result. -This operator evaluates lazily; it only evaluates its second operand if it +Logical AND. Produces a 1 result if both operands are non-zero, +0 otherwise. +Valid for boolean and numeric (integers or floating-point) operands only. +This operator evaluates lazily; it only evaluates its right-hand side if it must in order to determine its result. .TP 20 \fB||\fR -. -Logical OR. If both operands are false, the result is 0, or 1 otherwise. -This operator evaluates lazily; it only evaluates its second operand if it +Logical OR. Produces a 0 result if both operands are zero, 1 otherwise. +Valid for boolean and numeric (integers or floating-point) operands only. +This operator evaluates lazily; it only evaluates its right-hand side if it must in order to determine its result. .TP 20 -\fIx \fB?\fI y \fB:\fI z\fR -. -If-then-else, as in C. If \fIx\fR is false , the result is the value of -\fIy\fR. Otherwise the result is the value of \fIz\fR. -This operator evaluates lazily; it evaluates only one of \fIy\fR or \fIz\fR. -.PP -The exponentiation operator promotes types in the same way that the multiply -and divide operators do, and the result is is the same as the result of -\fBpow\fR. -Exponentiation groups right-to-left within a precedence level. Other binary -operators group left-to-right. For example, the value of -.PP +\fIx \fB? \fIy \fB: \fIz\fR +If-then-else, as in C. If \fIx\fR +evaluates to non-zero, then the result is the value of \fIy\fR. +Otherwise the result is the value of \fIz\fR. +The \fIx\fR operand must have a boolean or numeric value. +This operator evaluates lazily; it only evaluates one of \fIy\fR or \fIz\fR. +.LP +See the C manual for more details on the results +produced by each operator. +.VS 8.5 +The exponentiation operator promotes types like the multiply and +divide operators, and produces a result that is the same as the output +of the \fBpow\fR function (after any type conversions.) +.VE 8.5 +All of the binary operators group left-to-right within the same +precedence level. For example, the command .PP .CS \fBexpr\fR {4*2 < 7} .CE .PP -is 0, while the value of -.PP -.CS -\fBexpr\fR {2**3**2} -.CE -.PP -is 512. -.PP -As in C, \fB&&\fR, \fB||\fR, and \fB?:\fR feature +returns 0. +.PP +The \fB&&\fR, \fB||\fR, and \fB?:\fR operators have .QW "lazy evaluation" , -which means that operands are not evaluated if they are -not needed to determine the outcome. For example, in +just as in C, which means that operands are not evaluated if they are +not needed to determine the outcome. For example, in the command .PP .CS \fBexpr\fR {$v ? [a] : [b]} .CE .PP -only one of \fB[a]\fR or \fB[b]\fR is evaluated, -depending on the value of \fB$v\fR. This is not true of the normal Tcl parser, -so it is normally recommended to enclose the arguments to \fBexpr\fR in braces. -Without braces, as in -\fBexpr\fR $v ? [a] : [b] -both \fB[a]\fR and \fB[b]\fR are evaluated before \fBexpr\fR is even called. -.PP -For more details on the results -produced by each operator, see the documentation for C. +only one of +.QW \fB[a]\fR +or +.QW \fB[b]\fR +will actually be evaluated, +depending on the value of \fB$v\fR. Note, however, that this is +only true if the entire expression is enclosed in braces; otherwise +the Tcl parser will evaluate both +.QW \fB[a]\fR +and +.QW \fB[b]\fR +before invoking the \fBexpr\fR command. .SS "MATH FUNCTIONS" .PP -A mathematical function such as \fBsin($x)\fR is replaced with a call to an ordinary -Tcl command in the \fBtcl::mathfunc\fR namespace. The evaluation -of an expression such as +.VS 8.5 +When the expression parser encounters a mathematical function +such as \fBsin($x)\fR, it replaces it with a call to an ordinary +Tcl command in the \fBtcl::mathfunc\fR namespace. The processing +of an expression such as: .PP .CS \fBexpr\fR {sin($x+$y)} .CE .PP -is the same in every way as the evaluation of +is the same in every way as the processing of: .PP .CS \fBexpr\fR {[tcl::mathfunc::sin [\fBexpr\fR {$x+$y}]]} .CE .PP -which in turn is the same as the evaluation of +which in turn is the same as the processing of: .PP .CS tcl::mathfunc::sin [\fBexpr\fR {$x+$y}] .CE .PP -\fBtcl::mathfunc::sin\fR is resolved as described in -\fBNAMESPACE RESOLUTION\fR in the \fBnamespace\fR(n) documentation. Given the -default value of \fBnamespace path\fR, \fB[namespace -current]::tcl::mathfunc::sin\fR or \fB::tcl::mathfunc::sin\fR are the typical -resolutions. -.PP -As in C, a mathematical function may accept multiple arguments separated by commas. Thus, -.PP -.CS -\fBexpr\fR {hypot($x,$y)} -.CE -.PP -becomes -.PP -.CS -tcl::mathfunc::hypot $x $y -.CE -.PP -See the \fBmathfunc\fR(n) documentation for the math functions that are +The executor will search for \fBtcl::mathfunc::sin\fR using the usual +rules for resolving functions in namespaces. Either +\fB::tcl::mathfunc::sin\fR or \fB[namespace +current]::tcl::mathfunc::sin\fR will satisfy the request, and others +may as well (depending on the current \fBnamespace path\fR setting). +.PP +See the \fBmathfunc\fR(n) manual page for the math functions that are available by default. +.VE 8.5 .SS "TYPES, OVERFLOW, AND PRECISION" .PP -When needed to guarantee exact performance, internal computations involving -integers use the LibTomMath multiple precision integer library. In Tcl releases -prior to 8.5, integer calculations were performed using one of the C types +.VS 8.5 +All internal computations involving integers are done calling on the +LibTomMath multiple precision integer library as required so that all +integer calculations are performed exactly. Note that in Tcl releases +prior to 8.5, integer calculations were performed with one of the C types \fIlong int\fR or \fITcl_WideInt\fR, causing implicit range truncation in those calculations where values overflowed the range of those types. -Any code that relied on these implicit truncations should instead call -\fBint()\fR or \fBwide()\fR, which do truncate. +Any code that relied on these implicit truncations will need to explicitly +add \fBint()\fR or \fBwide()\fR function calls to expressions at the points +where such truncation is required to take place. +.VE 8.5 .PP -Internal floating-point computations are -performed using the \fIdouble\fR C type. -When converting a string to floating-point value, exponent overflow is +All internal computations involving floating-point are +done with the C type \fIdouble\fR. +When converting a string to floating-point, exponent overflow is detected and results in the \fIdouble\fR value of \fBInf\fR or \fB\-Inf\fR as appropriate. Floating-point overflow and underflow are detected to the degree supported by the hardware, which is generally -fairly reliable. +pretty reliable. .PP -Conversion among internal representations for integer, floating-point, and -string operands is done automatically as needed. For arithmetic computations, -integers are used until some floating-point number is introduced, after which -floating-point values are used. For example, +Conversion among internal representations for integer, floating-point, +and string operands is done automatically as needed. +For arithmetic computations, integers are used until some +floating-point number is introduced, after which floating-point is used. +For example, .PP .CS \fBexpr\fR {5 / 4} .CE .PP @@ -355,58 +316,83 @@ \fBexpr\fR {5 / 4.0} \fBexpr\fR {5 / ( [string length "abcd"] + 0.0 )} .CE .PP both return 1.25. -A floating-point result can be distinguished from an integer result by the -presence of either +Floating-point values are always returned with a .QW \fB.\fR -or +or an .QW \fBe\fR -.PP -. For example, +so that they will not look like integer values. For example, .PP .CS \fBexpr\fR {20.0/5.0} .CE .PP returns \fB4.0\fR, not \fB4\fR. +.SS "STRING OPERATIONS" +.PP +String values may be used as operands of the comparison operators, +although the expression evaluator tries to do comparisons as integer +or floating-point when it can, +i.e., when all arguments to the operator allow numeric interpretations, +except in the case of the \fBeq\fR and \fBne\fR operators. +If one of the operands of a comparison is a string and the other +has a numeric value, a canonical string representation of the numeric +operand value is generated to compare with the string operand. +Canonical string representation for integer values is a decimal string +format. Canonical string representation for floating-point values +is that produced by the \fB%g\fR format specifier of Tcl's +\fBformat\fR command. For example, the commands +.PP +.CS +\fBexpr\fR {"0x03" > "2"} +\fBexpr\fR {"0y" > "0x12"} +.CE +.PP +both return 1. The first comparison is done using integer +comparison, and the second is done using string comparison. +Because of Tcl's tendency to treat values as numbers whenever +possible, it is not generally a good idea to use operators like \fB==\fR +when you really want string comparison and the values of the +operands could be arbitrary; it is better in these cases to use +the \fBeq\fR or \fBne\fR operators, or the \fBstring\fR command instead. .SH "PERFORMANCE CONSIDERATIONS" .PP -Where an expression contains syntax that Tcl would otherwise perform -substitutions on, enclosing an expression in braces or otherwise quoting it -so that it's a static value allows the Tcl compiler to generate bytecode for -the expression, resulting in better speed and smaller storage requirements. -This also avoids issues that can arise if Tcl is allowed to perform -substitution on the value before \fBexpr\fR is called. +Enclose expressions in braces for the best speed and the smallest +storage requirements. +This allows the Tcl bytecode compiler to generate the best code. .PP -In the following example, the value of the expression is 11 because the Tcl parser first -substitutes \fB$b\fR and \fBexpr\fR then substitutes \fB$a\fR as part -of evaluating the expression -.QW "$a + 2*4" . -Enclosing the -expression in braces would result in a syntax error as \fB$b\fR does -not evaluate to a numeric value. +As mentioned above, expressions are substituted twice: +once by the Tcl parser and once by the \fBexpr\fR command. +For example, the commands .PP .CS set a 3 set b {$a + 2} \fBexpr\fR $b*4 .CE .PP -When an expression is generated at runtime, like the one above is, the bytecode -compiler must ensure that new code is generated each time the expression -is evaluated. This is the most costly kind of expression from a performance -perspective. In such cases, consider directly using the commands described in -the \fBmathfunc\fR(n) or \fBmathop\fR(n) documentation instead of \fBexpr\fR. +return 11, not a multiple of 4. +This is because the Tcl parser will first substitute +.QW "\fB$a + 2\fR" +for the variable \fBb\fR, +then the \fBexpr\fR command will evaluate the expression +.QW "\fB$a + 2*4\fR" . .PP -Most expressions are not formed at runtime, but are literal strings or contain -substitutions that don't introduce other substitutions. To allow the bytecode -compiler to work with an expression as a string literal at compilation time, -ensure that it contains no substitutions or that it is enclosed in braces or -otherwise quoted to prevent Tcl from performing substitutions, allowing -\fBexpr\fR to perform them instead. +Most expressions do not require a second round of substitutions. +Either they are enclosed in braces or, if not, +their variable and command substitutions yield numbers or strings +that do not themselves require substitutions. +However, because a few unbraced expressions +need two rounds of substitutions, +the bytecode compiler must emit +additional instructions to handle this situation. +The most expensive code is required for +unbraced expressions that contain command substitutions. +These expressions must be implemented by generating new code +each time the expression is executed. .PP If it is necessary to include a non-constant expression string within the wider context of an otherwise-constant expression, the most efficient technique is to put the varying part inside a recursive \fBexpr\fR, as this at least allows for the compilation of the outer part, though it does mean that @@ -418,37 +404,16 @@ set a 3 set b {$a + 2} \fBexpr\fR {[\fBexpr\fR $b] * 4} .CE .PP -In general, you should enclose your expression in braces wherever possible, -and where not possible, the argument to \fBexpr\fR should be an expression -defined elsewhere as simply as possible. It is usually more efficient and -safer to use other techniques (e.g., the commands in the \fBtcl::mathop\fR -namespace) than it is to do complex expression generation. +.VS 8.5 +When the expression is unbraced to allow the substitution of a function or +operator, consider using the commands documented in the \fBmathfunc\fR(n) or +\fBmathop\fR(n) manual pages directly instead. +.VE 8.5 .SH EXAMPLES -.PP -A numeric comparison whose result is 1: -.PP -.CS -\fBexpr\fR {"0x03" > "2"} -.CE -.PP -A string comparison whose result is 1: -.PP -.CS -\fBexpr\fR {"0y" > "0x12"} -.CE -.PP -.VS "8.7, TIP461" -A forced string comparison whose result is 0: -.PP -.CS -\fBexpr\fR {"0x03" gt "2"} -.CE -.VE "8.7, TIP461" -.PP Define a procedure that computes an .QW interesting mathematical function: .PP .CS @@ -478,12 +443,12 @@ .PP .CS puts "a and b are [\fBexpr\fR {$a eq $b ? {equal} : {different}}]" .CE .PP -Set a variable indicating whether an environment variable is defined and has -value of true: +Set a variable to whether an environment variable is both defined at +all and also set to a true boolean value: .PP .CS set isTrue [\fBexpr\fR { [info exists ::env(SOME_ENV_VAR)] && [string is true -strict $::env(SOME_ENV_VAR)] @@ -497,15 +462,12 @@ .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 +arithmetic, boolean, compare, expression, fuzzy comparison .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 . All rights reserved. +Copyright (c) 1993 The Regents of the University of California. +Copyright (c) 1994-2000 Sun Microsystems Incorporated. +Copyright (c) 2005 by Kevin B. Kenny . All rights reserved. .fi -'\" Local Variables: -'\" mode: nroff -'\" End: Index: doc/fblocked.n ================================================================== --- doc/fblocked.n +++ doc/fblocked.n @@ -1,12 +1,13 @@ -'\" +'\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH fblocked n 7.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fblocked \- Test whether the last input operation exhausted all available input .SH SYNOPSIS @@ -59,13 +60,11 @@ # Create the server socket and enter the event-loop to wait # for incoming connections... socket -server connect 12345 vwait forever .CE + .SH "SEE ALSO" gets(n), open(n), read(n), socket(n), Tcl_StandardChannels(3) + .SH KEYWORDS blocking, nonblocking -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/fconfigure.n ================================================================== --- doc/fconfigure.n +++ doc/fconfigure.n @@ -1,6 +1,6 @@ -'\" +'\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" @@ -37,12 +37,11 @@ .PP The options described below are supported for all channels. In addition, each channel type may add options that only it supports. See the manual entry for the command that creates each type of channels for the options that that specific type of channel supports. For example, see the manual -entry for the \fBsocket\fR command for additional options for sockets, and -the \fBopen\fR command for additional options for serial devices. +entry for the \fBsocket\fR command for its additional options. .TP \fB\-blocking\fR \fIboolean\fR The \fB\-blocking\fR option determines whether I/O operations on the channel can cause the process to block indefinitely. The value of the option must be a proper boolean value. @@ -70,12 +69,12 @@ .TP \fB\-buffersize\fR \fInewSize\fR . \fINewvalue\fR must be an integer; its value is used to set the size of buffers, in bytes, subsequently allocated for this channel to store input -or output. \fINewvalue\fR must be between one and one million, allowing -buffers of one to one million bytes in size. +or output. \fINewvalue\fR must be between ten and one million, allowing +buffers of ten to one million bytes in size. .TP \fB\-encoding\fR \fIname\fR . This option is used to specify the encoding of the channel, so that the data can be converted to and from Unicode for use in Tcl. For instance, in @@ -123,11 +122,11 @@ attempting to set \fB\-eofchar\fR to a value outside of this range will generate an error. .TP \fB\-translation\fR \fImode\fR .TP -\fB\-translation\fR \fB{\fIinMode outMode\fB}\fR +\fB\-translation\fR \fB{\fIinMode outMode\fB}\fR . In Tcl scripts the end of a line is always represented using a single newline character (\en). However, in actual files and devices the end of a line may be represented differently on different platforms, or even for different devices on the same platform. For example, under UNIX newlines @@ -161,11 +160,11 @@ chooses a platform specific representation; for sockets on all platforms Tcl chooses \fBcrlf\fR, for all Unix flavors, it chooses \fBlf\fR, and for the various flavors of Windows it chooses \fBcrlf\fR. The default setting for \fB\-translation\fR is \fBauto\fR for both input and output. .TP -\fBbinary\fR +\fBbinary\fR . No end-of-line translations are performed. This is nearly identical to \fBlf\fR mode, except that in addition \fBbinary\fR mode also sets the end-of-file character to the empty string (which disables it) and sets the encoding to \fBbinary\fR (which disables encoding filtering). See the @@ -212,59 +211,55 @@ will also support any special option according to their current type. If, for example, a Tcl application is started by the \fBinet\fR super-server common on Unix system its Tcl standard channels will be sockets and thus support the socket options. .SH EXAMPLES -.PP Instruct Tcl to always send output to \fBstdout\fR immediately, whether or not it is to a terminal: -.PP .CS \fBfconfigure\fR stdout -buffering none .CE .PP Open a socket and read lines from it without ever blocking the processing of other events: -.PP .CS set s [socket some.where.com 12345] \fBfconfigure\fR $s -blocking 0 fileevent $s readable "readMe $s" proc readMe chan { - if {[gets $chan line] < 0} { - if {[eof $chan]} { - close $chan - return - } - # Could not read a complete line this time; Tcl's - # internal buffering will hold the partial line for us - # until some more data is available over the socket. - } else { - puts stdout $line - } + if {[gets $chan line] < 0} { + if {[eof $chan]} { + close $chan + return + } + # Could not read a complete line this time; Tcl's + # internal buffering will hold the partial line for us + # until some more data is available over the socket. + } else { + puts stdout $line + } } .CE .PP Read a PPM-format image from a file: -.PP .CS # Open the file and put it into Unix ASCII mode set f [open teapot.ppm] \fBfconfigure\fR $f \-encoding ascii \-translation lf # Get the header if {[gets $f] ne "P6"} { - error "not a raw\-bits PPM" + error "not a raw\-bits PPM" } # Read lines until we have got non-comment lines # that supply us with three decimal values. set words {} while {[llength $words] < 3} { - gets $f line - if {[string match "#*" $line]} continue - lappend words {*}[join [scan $line %d%d%d]] + gets $f line + if {[string match "#*" $line]} continue + lappend words {*}[join [scan $line %d%d%d]] } # Those words supply the size of the image and its # overall depth per channel. Assign to variables. lassign $words xSize ySize depth @@ -275,15 +270,14 @@ set numDataBytes [expr {3 * $xSize * $ySize}] set data [read $f $numDataBytes] close $f .CE + .SH "SEE ALSO" close(n), flush(n), gets(n), open(n), puts(n), read(n), socket(n), Tcl_StandardChannels(3) + .SH KEYWORDS blocking, buffering, carriage return, end of line, flushing, linemode, newline, nonblocking, platform, translation, encoding, filter, byte array, binary -'\" Local Variables: -'\" mode: nroff -'\" End: Index: doc/fcopy.n ================================================================== --- doc/fcopy.n +++ doc/fcopy.n @@ -2,11 +2,11 @@ '\" 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 fcopy n 8.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -21,51 +21,45 @@ The \fBfcopy\fR command leverages the buffering in the Tcl I/O system to avoid extra copies and to avoid buffering too much data in main memory when copying large files to slow destinations like network sockets. .PP -The \fBfcopy\fR +The \fBfcopy\fR command transfers data from \fIinchan\fR until end of file -or \fIsize\fR bytes or characters have been -transferred; \fIsize\fR is in bytes if the two channels are using the -same encoding, and is in characters otherwise. -If no \fB\-size\fR argument is given, +or \fIsize\fR bytes have been +transferred. If no \fB\-size\fR argument is given, then the copy goes until end of file. All the data read from \fIinchan\fR is copied to \fIoutchan\fR. Without the \fB\-command\fR option, \fBfcopy\fR blocks until the copy is complete -and returns the number of bytes or characters (using the same rules as -for the \fB\-size\fR option) written to \fIoutchan\fR. +and returns the number of bytes written to \fIoutchan\fR. .PP The \fB\-command\fR argument makes \fBfcopy\fR work in the background. In this case it returns immediately and the \fIcallback\fR is invoked later when the copy completes. The \fIcallback\fR is called with -one or two additional +one or two additional arguments that indicates how many bytes were written to \fIoutchan\fR. If an error occurred during the background copy, the second argument is the error string associated with the error. With a background copy, it is not necessary to put \fIinchan\fR or \fIoutchan\fR into non-blocking mode; the \fBfcopy\fR command takes care of that automatically. However, it is necessary to enter the event loop by using the \fBvwait\fR command or by using Tk. .PP -You are not allowed to do other input operations with \fIinchan\fR, or -output operations with \fIoutchan\fR, during a background -\fBfcopy\fR. The converse is entirely legitimate, as exhibited by the -bidirectional fcopy example below. -.PP +You are not allowed to do other I/O operations with +\fIinchan\fR or \fIoutchan\fR during a background \fBfcopy\fR. If either \fIinchan\fR or \fIoutchan\fR get closed while the copy is in progress, the current copy is stopped and the command callback is \fInot\fR made. If \fIinchan\fR is closed, then all data already queued for \fIoutchan\fR is written out. .PP Note that \fIinchan\fR can become readable during a background copy. You should turn off any \fBfileevent\fR handlers during a background copy so those handlers do not interfere with the copy. -Any wrong-sided I/O attempted (by a \fBfileevent\fR handler or otherwise) will get a +Any I/O attempted by a \fBfileevent\fR handler will get a .QW "channel busy" error. .PP \fBFcopy\fR translates end-of-line sequences in \fIinchan\fR and \fIoutchan\fR according to the \fB\-translation\fR option @@ -94,58 +88,56 @@ .QW binary the system will assume that the incoming bytes are valid UTF-8 characters and convert them according to the output encoding. The behaviour of the system for bytes which are not valid UTF-8 characters is undefined in this case. + .SH EXAMPLES .PP The first example transfers the contents of one channel exactly to another. Note that when copying one file to another, it is better to use \fBfile copy\fR which also copies file metadata (e.g. the file access permissions) where possible. -.PP .CS fconfigure $in -translation binary fconfigure $out -translation binary \fBfcopy\fR $in $out .CE .PP This second example shows how the callback gets passed the number of bytes transferred. It also uses vwait to put the application into the event loop. -Of course, this simplified example could be done without the command +Of course, this simplified example could be done without the command callback. -.PP .CS proc Cleanup {in out bytes {error {}}} { global total set total $bytes close $in close $out if {[string length $error] != 0} { - # error occurred during the copy + # error occurred during the copy } } set in [open $file1] set out [socket $server $port] \fBfcopy\fR $in $out -command [list Cleanup $in $out] vwait total .CE .PP The third example copies in chunks and tests for end of file -in the command callback. -.PP +in the command callback .CS proc CopyMore {in out chunk bytes {error {}}} { global total done incr total $bytes if {([string length $error] != 0) || [eof $in]} { - set done $total - close $in - close $out + set done $total + close $in + close $out } else { - \fBfcopy\fR $in $out -size $chunk \e + \fBfcopy\fR $in $out -size $chunk \e -command [list CopyMore $in $out $chunk] } } set in [open $file1] set out [socket $server $port] @@ -153,30 +145,11 @@ set total 0 \fBfcopy\fR $in $out -size $chunk \e -command [list CopyMore $in $out $chunk] vwait done .CE -.PP -The fourth example starts an asynchronous, bidirectional fcopy between -two sockets. Those could also be pipes from two [open "|hal 9000" r+] -(though their conversation would remain secret to the script, since -all four fileevent slots are busy). -.PP -.CS -set flows 2 -proc Done {dir args} { - global flows done - puts "$dir is over." - incr flows -1 - if {$flows<=0} {set done 1} -} -\fBfcopy\fR $sok1 $sok2 -command [list Done UP] -\fBfcopy\fR $sok2 $sok1 -command [list Done DOWN] -vwait done -.CE + .SH "SEE ALSO" eof(n), fblocked(n), fconfigure(n), file(n) + .SH KEYWORDS blocking, channel, end of line, end of file, nonblocking, read, translation -'\" Local Variables: -'\" mode: nroff -'\" End: Index: doc/file.n ================================================================== --- doc/file.n +++ doc/file.n @@ -2,11 +2,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 file n 8.3 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -21,11 +21,11 @@ substitution is done before executing the command (see the manual entry for \fBfilename\fR for details). \fIOption\fR indicates what to do with the file name. Any unique abbreviation for \fIoption\fR is acceptable. The valid options are: .TP -\fBfile atime \fIname\fR ?\fItime\fR? +\fBfile atime \fIname\fR ?\fBtime\fR? . Returns a decimal string giving the time at which file \fIname\fR was last accessed. If \fItime\fR is specified, it is an access time to set for the file. The time is measured in the standard POSIX fashion as seconds from a fixed starting time (often January 1, 1970). If the file @@ -32,36 +32,39 @@ does not exist or its access time cannot be queried or set then an error is generated. On Windows, FAT file systems do not support access time. .TP \fBfile attributes \fIname\fR .TP -\fBfile attributes \fIname\fR ?\fIoption\fR? -.TP -\fBfile attributes \fIname\fR ?\fIoption value option value...\fR? -. -This subcommand returns or sets platform specific values associated -with a file. The first form returns a list of the platform specific -flags and their values. The second form returns the value for the -specific option. The third form sets one or more of the values. The -values are as follows: +\fBfile attributes \fIname\fR ?\fBoption\fR? +.TP +\fBfile attributes \fIname\fR ?\fBoption value option value...\fR? +. +This subcommand returns or sets platform-specific values associated +with a file. The first form returns a list of the platform-specific +options and their values. The second form returns the value for the +given option. The third form sets one or more of the values. The values +are as follows: .RS .PP -On Unix, \fB\-group\fR gets or sets the group name for the file. A group id -can be given to the command, but it returns a group name. \fB\-owner\fR gets -or sets the user name of the owner of the file. The command returns the -owner name, but the numerical id can be passed when setting the -owner. \fB\-permissions\fR sets or retrieves the octal code that chmod(1) -uses. This command does also has limited support for setting using the -symbolic attributes for chmod(1), of the form [ugo]?[[+\-=][rwxst],[...]], -where multiple symbolic attributes can be separated by commas (example: -\fBu+s,go\-rw\fR add sticky bit for user, remove read and write -permissions for group and other). A simplified \fBls\fR style string, -of the form rwxrwxrwx (must be 9 characters), is also supported -(example: \fBrwxr\-xr\-t\fR is equivalent to 01755). -On versions of Unix supporting file flags, \fB\-readonly\fR gives the -value or sets or clears the readonly attribute of the file, -i.e. the user immutable flag \fBuchg\fR to chflags(1). +On Unix, \fB\-group\fR gets or sets the group name for the file. A +group id can be given to the command, but it returns a group name. +\fB\-owner\fR gets or sets the user name of the owner of the file. The +command returns the owner name, but the numerical id can be passed when +setting the owner. \fB\-permissions\fR retrieves or sets a file's +access permissions, using octal notation by default. This option also +provides limited support for setting permissions using the symbolic +notation accepted by the \fBchmod\fR command, following the form +[\fBugo\fR]?[[\fB+-=\fR][\fBrwxst\fR]\fB,\fR[...]]. Multiple permission +specifications may be given, separated by commas. E.g., \fBu+s,go-rw\fR +would set the setuid bit for a file's owner as well as remove read and +write permission for the file's group and other users. An +\fBls\fR-style string of the form \fBrwxrwxrwx\fR is also accepted but +must always be 9 characters long. E.g., \fBrwxr-xr-t\fR is equivalent +to \fB01755\fR. On versions of Unix supporting file flags, +\fB-readonly\fR returns the value of, or sets, or clears the readonly +attribute of a file, i.e., the user immutable flag (\fBuchg\fR) to the +\fBchflags\fR command. .PP On Windows, \fB\-archive\fR gives the value or sets or clears the archive attribute of the file. \fB\-hidden\fR gives the value or sets or clears the hidden attribute of the file. \fB\-longname\fR will expand each path element to its long version. This attribute cannot be @@ -78,11 +81,11 @@ the length of the resource fork of the file, this attribute can only be set to the value 0, which results in the resource fork being stripped off the file. .RE .TP -\fBfile channels\fR ?\fIpattern\fR? +\fBfile channels ?\fIpattern\fR? . If \fIpattern\fR is not specified, returns a list of names of all registered open channels in this interpreter. If \fIpattern\fR is specified, only those names matching \fIpattern\fR are returned. Matching is determined using the same rules as for \fBstring match\fR. @@ -102,16 +105,16 @@ if that is necessary to allow the copy to proceed). When copying within a single filesystem, \fIfile copy\fR will copy soft links (i.e. the links themselves are copied, not the things they point to). Trying to overwrite a non-empty directory, overwrite a directory with a file, or overwrite a file with a directory will all result in errors even if -\fB\-force\fR was specified. Arguments are processed in the order +\fI\-force\fR was specified. Arguments are processed in the order specified, halting at the first error, if any. A \fB\-\|\-\fR marks the end of switches; the argument following the \fB\-\|\-\fR will be treated as a \fIsource\fR even if it starts with a \fB\-\fR. .TP -\fBfile delete \fR?\fB\-force\fR? ?\fB\-\|\-\fR? ?\fIpathname\fR ... ? +\fBfile delete \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIpathname\fR ?\fIpathname\fR ... ? . Removes the file or directory specified by each \fIpathname\fR argument. Non-empty directories will be removed only if the \fB\-force\fR option is specified. When operating on symbolic links, the links themselves will be deleted, not the objects they point to. @@ -134,39 +137,33 @@ only contains one path element, then returns .QW \fB.\fR . If \fIname\fR refers to a root directory, then the root directory is returned. For example, .RS -.PP .CS -\fBfile dirname\fR c:/ +\fBfile dirname c:/\fR .CE -.PP -returns \fBc:/\fR. +returns \fBc:/\fR. .PP Note that tilde substitution will only be performed if it is necessary to complete the command. For example, -.PP .CS -\fBfile dirname\fR ~/src/foo.c +\fBfile dirname ~/src/foo.c\fR .CE -.PP returns \fB~/src\fR, whereas -.PP .CS -\fBfile dirname\fR ~ +\fBfile dirname ~\fR .CE -.PP returns \fB/home\fR (or something similar). .RE .TP \fBfile executable \fIname\fR . Returns \fB1\fR if file \fIname\fR is executable by the current user, \fB0\fR otherwise. On Windows, which does not have an executable attribute, the command treats all directories and any files with extensions -\fBexe\fR, \fBcom\fR, \fBcmd\fR or \fBbat\fR as executable. +\fBexe\fR, \fBcom\fR, \fBcmd\fR, \fBbat\fR or \fBps1\fR as executable. .TP \fBfile exists \fIname\fR . Returns \fB1\fR if file \fIname\fR exists and the current user has search privileges for the directories leading to it, \fB0\fR otherwise. @@ -191,23 +188,21 @@ separator for the current platform. If a particular \fIname\fR is relative, then it will be joined to the previous file name argument. Otherwise, any earlier arguments will be discarded, and joining will proceed from the current argument. For example, .RS -.PP .CS -\fBfile join\fR a b /foo bar +\fBfile join a b /foo bar\fR .CE -.PP returns \fB/foo/bar\fR. .PP Note that any of the names can contain separators, and that the result is always canonical for the current platform: \fB/\fR for Unix and Windows. .RE .TP -\fBfile link\fR ?\fI\-linktype\fR? \fIlinkName\fR ?\fItarget\fR? +\fBfile link ?\fI\-linktype\fR? \fIlinkName\fR ?\fItarget\fR? . If only one argument is given, that argument is assumed to be \fIlinkName\fR, and this command returns the value of the link given by \fIlinkName\fR (i.e. the name of the file it points to). If \fIlinkName\fR is not a link or its value cannot be read (as, for example, @@ -227,13 +222,13 @@ .PP If the user wishes to make a link of a specific type only, (and signal an error if for some reason that is not possible), then the optional \fI\-linktype\fR argument should be given. Accepted values for \fI\-linktype\fR are -.QW \fB\-symbolic\fR +.QW \-symbolic and -.QW \fB\-hard\fR . +.QW \-hard . .PP On Unix, symbolic links can be made to relative paths, and those paths must be relative to the actual \fIlinkName\fR's location (not to the cwd), but on all other platforms where relative links are not supported, target paths will always be converted to absolute, normalized form @@ -241,13 +236,15 @@ as relative to the cwd). Furthermore, .QW ~user paths are always expanded to absolute form. When creating links on filesystems that either do not support any links, or do not support the specific type requested, an -error message will be returned. Most Unix platforms support both -symbolic and hard links (the latter for files only). Windows -supports symbolic directory links and hard file links on NTFS drives. +error message will be returned. In particular Windows 95, 98 and ME do +not support any links at present, but most Unix platforms support both +symbolic and hard links (the latter for files only) and Windows +NT/2000/XP (on NTFS drives) support symbolic +directory links and hard file links. .RE .TP \fBfile lstat \fIname varName\fR . Same as \fBstat\fR option (see below) except uses the \fIlstat\fR @@ -255,11 +252,11 @@ refers to a symbolic link the information returned in \fIvarName\fR is for the link rather than the file it refers to. On systems that do not support symbolic links this option behaves exactly the same as the \fBstat\fR option. .TP -\fBfile mkdir\fR ?\fIdir\fR ...? +\fBfile mkdir \fIdir\fR ?\fIdir\fR ...? . Creates each directory specified. For each pathname \fIdir\fR specified, this command will create all non-existing parent directories as well as \fIdir\fR itself. If an existing directory is specified, then no action is taken and no error is returned. Trying to overwrite an existing @@ -300,11 +297,11 @@ last link in the path is necessary, because Tcl or the user may wish to operate on the actual symbolic link itself (for example \fBfile delete\fR, \fBfile rename\fR, \fBfile copy\fR are defined to operate on symbolic links, not on the things that they point to). .TP -\fBfile owned \fIname\fR +\fBfile owned \fIname\fR . Returns \fB1\fR if file \fIname\fR is owned by the current user, \fB0\fR otherwise. .TP \fBfile pathtype \fIname\fR @@ -318,11 +315,11 @@ type is \fBvolumerelative\fR. .TP \fBfile readable \fIname\fR . Returns \fB1\fR if file \fIname\fR is readable by the current user, -\fB0\fR otherwise. +\fB0\fR otherwise. .TP \fBfile readlink \fIname\fR . Returns the value of the symbolic link given by \fIname\fR (i.e. the name of the file it points to). If \fIname\fR is not a symbolic link or its @@ -356,11 +353,11 @@ character in the last component of name. If the last component of \fIname\fR does not contain a dot, then returns \fIname\fR. .TP \fBfile separator\fR ?\fIname\fR? . -If no argument is given, returns the character which is used to separate +If no argument is given, returns the character which is used to separate path segments for native files on this platform. If a path is given, the filesystem responsible for that path is asked to return its separator character. If no file system accepts \fIname\fR, an error is generated. .TP @@ -376,23 +373,19 @@ first element of the list will have the same path type as \fIname\fR. All other elements will be relative. Path separators will be discarded unless they are needed to ensure that an element is unambiguously relative. For example, under Unix .RS -.PP .CS -\fBfile split\fR /foo/~bar/baz +file split /foo/~bar/baz .CE -.PP -returns -.QW \fB/\0\0foo\0\0./~bar\0\0baz\fR -to ensure that later commands +returns \fB/\0\0foo\0\0./~bar\0\0baz\fR to ensure that later commands that use the third component do not attempt to perform tilde substitution. .RE .TP -\fBfile stat \fIname varName\fR +\fBfile stat \fIname varName\fR . Invokes the \fBstat\fR kernel call on \fIname\fR, and uses the variable given by \fIvarName\fR to hold information returned from the kernel call. \fIVarName\fR is treated as an array variable, and the following elements of that variable are set: \fBatime\fR, \fBctime\fR, \fBdev\fR, \fBgid\fR, @@ -427,69 +420,22 @@ .TP \fBfile tail \fIname\fR . Returns all of the characters in the last filesystem component of \fIname\fR. Any trailing directory separator in \fIname\fR is ignored. -If \fIname\fR contains no separators then returns \fIname\fR. So, +If \fIname\fR contains no separators then returns \fIname\fR. So, \fBfile tail a/b\fR, \fBfile tail a/b/\fR and \fBfile tail b\fR all return \fBb\fR. -.TP -\fBfile tempdir\fR ?\fItemplate\fR? -.VS "8.7, TIP 431" -Creates a temporary directory (guaranteed to be newly created and writable by -the current script) and returns its name. If \fItemplate\fR is given, it -specifies one of or both of the existing directory (on a filesystem controlled -by the operating system) to contain the temporary directory, and the base part -of the directory name; it is considered to have the location of the directory -if there is a directory separator in the name, and the base part is everything -after the last directory separator (if non-empty). The default containing -directory is determined by system-specific operations, and the default base -name prefix is -.QW \fBtcl\fR . -.RS -.PP -The following output is typical and illustrative; the actual output will vary -between platforms: -.PP -.CS -% \fBfile tempdir\fR -/var/tmp/tcl_u0kuy5 - % \fBfile tempdir\fR /tmp/myapp -/tmp/myapp_8o7r9L -% \fBfile tempdir\fR /tmp/ -/tmp/tcl_1mOJHD -% \fBfile tempdir\fR myapp -/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 \fBfile volumes\fR -. +. Returns the absolute paths to the volumes mounted on the system, as a proper Tcl list. Without any virtual filesystems mounted as root volumes, on UNIX, the command will always return .QW / , since all filesystems are locally mounted. @@ -506,53 +452,44 @@ .SH "PORTABILITY ISSUES" .TP \fBUnix\fR\0\0\0\0\0\0\0 . These commands always operate using the real user and group identifiers, -not the effective ones. -.TP -\fBWindows\fR\0\0\0\0 -. -The \fBfile owned\fR subcommand uses the user identifier (SID) of -the process token, not the thread token which may be impersonating -some other user. +not the effective ones. .SH EXAMPLES -.PP This procedure shows how to search for C files in a given directory that have a correspondingly-named object file in the current directory: -.PP .CS proc findMatchingCFiles {dir} { - set files {} - switch $::tcl_platform(platform) { - windows { - set ext .obj - } - unix { - set ext .o - } - } - foreach file [glob \-nocomplain \-directory $dir *.c] { - set objectFile [\fBfile tail\fR [\fBfile rootname\fR $file]]$ext - if {[\fBfile exists\fR $objectFile]} { - lappend files $file - } - } - return $files + set files {} + switch $::tcl_platform(platform) { + windows { + set ext .obj + } + unix { + set ext .o + } + } + foreach file [glob \-nocomplain \-directory $dir *.c] { + set objectFile [\fBfile tail\fR [\fBfile rootname\fR $file]]$ext + if {[\fBfile exists\fR $objectFile]} { + lappend files $file + } + } + return $files } .CE .PP Rename a file and leave a symbolic link pointing from the old location to the new place: -.PP .CS set oldName foobar.txt set newName foo/bar.txt # Make sure that where we're going to move to exists... if {![\fBfile isdirectory\fR [\fBfile dirname\fR $newName]]} { - \fBfile mkdir\fR [\fBfile dirname\fR $newName] + \fBfile mkdir\fR [\fBfile dirname\fR $newName] } \fBfile rename\fR $oldName $newName \fBfile link\fR \-symbolic $oldName $newName .CE .PP @@ -559,19 +496,13 @@ On Windows, a file can be .QW started easily enough (equivalent to double-clicking on it in the Explorer interface) but the name passed to the operating system must be in native format: -.PP .CS exec {*}[auto_execok start] {} [\fBfile nativename\fR ~/example.txt] .CE .SH "SEE ALSO" filename(n), open(n), close(n), eof(n), gets(n), tell(n), seek(n), fblocked(n), flush(n) .SH KEYWORDS -attributes, copy files, delete files, directory, file, move files, name, -rename files, stat, user -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: +attributes, copy files, delete files, directory, file, move files, name, rename files, stat Index: doc/fileevent.n ================================================================== --- doc/fileevent.n +++ doc/fileevent.n @@ -1,13 +1,12 @@ '\" '\" Copyright (c) 1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. -'\" Copyright (c) 2008 Pat Thoyts '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH fileevent n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -78,83 +77,48 @@ .PP A channel is considered to be writable if at least one byte of data can be written to the underlying file or device without blocking, or if an error condition is present on the underlying file or device. .PP -Event-driven I/O works best for channels that have been placed into -nonblocking mode with the \fBfconfigure\fR command. In blocking mode, -a \fBputs\fR command may block if you give it more data than the -underlying file or device can accept, and a \fBgets\fR or \fBread\fR -command will block if you attempt to read more data than is ready; a -readable underlying file or device may not even guarantee that a -blocking [read 1] will succeed (counter-examples being multi-byte -encodings, compression or encryption transforms ). In all such cases, -no events will be processed while the commands block. -.PP +Event-driven I/O works best for channels that have been +placed into nonblocking mode with the \fBfconfigure\fR command. +In blocking mode, a \fBputs\fR command may block if you give it +more data than the underlying file or device can accept, and a +\fBgets\fR or \fBread\fR command will block if you attempt to read +more data than is ready; no events will be processed while the +commands block. In nonblocking mode \fBputs\fR, \fBread\fR, and \fBgets\fR never block. See the documentation for the individual commands for information on how they handle blocking and nonblocking channels. .PP -Testing for the end of file condition should be done after any attempts -read the channel data. The eof flag is set once an attempt to read the -end of data has occurred and testing before this read will require an -additional event to be fired. -.PP The script for a file event is executed at global level (outside the context of any Tcl procedure) in the interpreter in which the \fBfileevent\fR command was invoked. If an error occurs while executing the script then the command registered with \fBinterp bgerror\fR is used to report the error. In addition, the file event handler is deleted if it ever returns an error; this is done in order to prevent infinite loops due to buggy handlers. .SH EXAMPLE -.PP -In this setup \fBGetData\fR will be called with the channel as an -argument whenever $chan becomes readable. The \fBread\fR call will -read whatever binary data is currently available without blocking. -Here the channel has the fileevent removed when an end of file -occurs to avoid being continually called (see above). Alternatively -the channel may be closed on this condition. -.PP -.CS -proc GetData {chan} { - set data [read $chan] - puts "[string length $data] $data" - if {[eof $chan]} { - fileevent $chan readable {} - } -} - -fconfigure $chan -blocking 0 -encoding binary -\fBfileevent\fR $chan readable [list GetData $chan] -.CE -.PP -The next example demonstrates use of \fBgets\fR to read line-oriented -data. -.PP -.CS -proc GetData {chan} { - if {[gets $chan line] >= 0} { - puts $line - } - if {[eof $chan]} { - close $chan - } -} - -fconfigure $chan -blocking 0 -buffering line -translation crlf -\fBfileevent\fR $chan readable [list GetData $chan] -.CE +In this setup \fBGetData\fR will be called with the channel as an +argument whenever $chan becomes readable. +.CS +proc GetData {chan} { + if {![eof $chan]} { + puts [gets $chan] + } +} + +\fBfileevent\fR $chan readable [list GetData $chan] +.CE + .SH CREDITS .PP \fBfileevent\fR is based on the \fBaddinput\fR command created by Mark Diekhans. + .SH "SEE ALSO" fconfigure(n), gets(n), interp(n), puts(n), read(n), Tcl_StandardChannels(3) + .SH KEYWORDS asynchronous I/O, blocking, channel, event handler, nonblocking, readable, script, writable. -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/filename.n ================================================================== --- doc/filename.n +++ doc/filename.n @@ -1,11 +1,11 @@ '\" '\" 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 filename n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -27,20 +27,20 @@ .PP File names are grouped into three general types based on the starting point for the path used to specify the file: absolute, relative, and volume-relative. Absolute names are completely qualified, giving a path to the file relative to a particular volume and the root directory on that -volume. Relative names are unqualified, giving a path to the file relative +volume. Relative names are unqualified, giving a path to the file relative to the current working directory. Volume-relative names are partially qualified, either giving the path relative to the root directory on the current volume, or relative to the current directory of the specified volume. The \fBfile pathtype\fR command can be used to determine the type of a given path. .SH "PATH SYNTAX" .PP The rules for native names depend on the value reported in the Tcl -\fBplatform\fR element of the \fBtcl_platform\fR array: +array element \fBtcl_platform(platform)\fR: .TP 10 \fBUnix\fR On Unix and Apple MacOS X platforms, Tcl uses path names where the components are separated by slashes. Path names may be relative or absolute, and file names may contain any character other than slash. @@ -73,20 +73,20 @@ Relative path to the file \fBbar\fR in the directory \fBfoo\fR in the current directory. .TP 15 \fB\&../foo\fR Relative path to the file \fBfoo\fR in the directory above the current -directory. +directory. .RE .TP \fBWindows\fR On Microsoft Windows platforms, Tcl supports both drive-relative and UNC style names. Both \fB/\fR and \fB\e\fR may be used as directory separators in either type of name. Drive-relative names consist of an optional drive specifier followed by an absolute or relative path. UNC paths follow the general form \fB\e\eservername\esharename\epath\efile\fR, but must at -the very least contain the server and share components, i.e. +the very least contain the server and share components, i.e. \fB\e\eservername\esharename\fR. In both forms, the file names \fB.\fR and \fB..\fR are special and refer to the current directory and the parent of the current directory respectively. The following examples illustrate various forms of path names: .RS @@ -152,11 +152,11 @@ filenames where the backslash is the directory separator (Windows native path names). Also Windows 3.1 only supports file names with a root of no more than 8 characters and an extension of no more than 3 characters. .PP -On Windows platforms there are file and path length restrictions. +On Windows platforms there are file and path length restrictions. Complete paths or filenames longer than about 260 characters will lead to errors in most file operations. .PP Another Windows peculiarity is that any number of trailing dots .QW . @@ -174,9 +174,5 @@ .SH "SEE ALSO" file(n), glob(n) .SH KEYWORDS current directory, absolute file name, relative file name, volume-relative file name, portability -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/flush.n ================================================================== --- doc/flush.n +++ doc/flush.n @@ -2,20 +2,21 @@ '\" 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 flush n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME flush \- Flush buffered output for a channel .SH SYNOPSIS \fBflush \fIchannelId\fR .BE + .SH DESCRIPTION .PP Flushes any output that has been buffered for \fIchannelId\fR. .PP \fIChannelId\fR must be an identifier for an open channel such as a @@ -28,22 +29,18 @@ buffered output has been flushed to the channel. If the channel is in nonblocking mode, the command may return before all buffered output has been flushed; the remainder will be flushed in the background as fast as the underlying file or device is able to absorb it. .SH EXAMPLE -.PP Prompt for the user to type some information in on the console: -.PP .CS puts -nonewline "Please type your name: " \fBflush\fR stdout gets stdin name puts "Hello there, $name!" .CE + .SH "SEE ALSO" file(n), open(n), socket(n), Tcl_StandardChannels(3) + .SH KEYWORDS blocking, buffer, channel, flush, nonblocking, output -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/for.n ================================================================== --- doc/for.n +++ doc/for.n @@ -2,11 +2,11 @@ '\" 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 for n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -46,16 +46,14 @@ enclosed in braces, variable substitutions are delayed until the expression is evaluated (before each loop iteration), so changes in the variables will be visible. See below for an example: .SH EXAMPLES -.PP Print a line for each of the integers from 0 to 9: -.PP .CS -\fBfor\fR {set x 0} {$x<10} {incr x} { - puts "x is $x" +for {set x 0} {$x<10} {incr x} { + puts "x is $x" } .CE .PP Either loop infinitely or not at all because the expression being evaluated is actually the constant, or even generate an error! The @@ -62,26 +60,23 @@ actual behaviour will depend on whether the variable \fIx\fR exists before the \fBfor\fR command is run and whether its value is a value that is less than or greater than/equal to ten, and this is because the expression will be substituted before the \fBfor\fR command is executed. -.PP .CS -\fBfor\fR {set x 0} $x<10 {incr x} { - puts "x is $x" +for {set x 0} $x<10 {incr x} { + puts "x is $x" } .CE .PP Print out the powers of two from 1 to 1024: -.PP .CS -\fBfor\fR {set x 1} {$x<=1024} {set x [expr {$x * 2}]} { - puts "x is $x" +for {set x 1} {$x<=1024} {set x [expr {$x * 2}]} { + puts "x is $x" } .CE + .SH "SEE ALSO" -break(n), continue(n), foreach(n), while(n) +break, continue, foreach, while + .SH KEYWORDS -boolean, for, iteration, loop -'\" Local Variables: -'\" mode: nroff -'\" End: +for, iteration, looping Index: doc/foreach.n ================================================================== --- doc/foreach.n +++ doc/foreach.n @@ -2,11 +2,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 foreach n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -47,14 +47,12 @@ .PP The \fBbreak\fR and \fBcontinue\fR statements may be invoked inside \fIbody\fR, with the same effect as in the \fBfor\fR command. \fBForeach\fR returns an empty string. .SH EXAMPLES -.PP This loop prints every value in a list together with the square and cube of the value: -.PP .CS '\" Maintainers: notice the tab hacking below! .ta 3i set values {1 3 5 7 2 4 6 8} ;# Odd numbers first, for fun! puts "Value\etSquare\etCube" ;# Neat-looking header @@ -63,11 +61,10 @@ } .CE .PP The following loop uses i and j as loop variables to iterate over pairs of elements of a single list. -.PP .CS set x {} \fBforeach\fR {i j} {a b c d e f} { lappend x $j $i } @@ -74,11 +71,10 @@ # The value of x is "b a d c f e" # There are 3 iterations of the loop. .CE .PP The next loop uses i and j to iterate over two lists in parallel. -.PP .CS set x {} \fBforeach\fR i {a b c} j {d e f g} { lappend x $i $j } @@ -85,11 +81,10 @@ # The value of x is "a d b e c f {} g" # There are 4 iterations of the loop. .CE .PP The two forms are combined in the following example. -.PP .CS set x {} \fBforeach\fR i {a b c} {j k} {d e f g} { lappend x $i $j $k } @@ -99,10 +94,6 @@ .SH "SEE ALSO" for(n), while(n), break(n), continue(n) .SH KEYWORDS -foreach, iteration, list, loop -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: +foreach, iteration, list, looping Index: doc/format.n ================================================================== --- doc/format.n +++ doc/format.n @@ -2,11 +2,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 format n 8.1 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -23,18 +23,18 @@ \fB%\fR conversion specifiers as in \fBsprintf\fR, and the additional arguments, if any, provide values to be substituted into the result. The return value from \fBformat\fR is the formatted string. .SH "DETAILS ON FORMATTING" .PP -The command operates by scanning \fIformatString\fR from left to right. +The command operates by scanning \fIformatString\fR from left to right. Each character from the format string is appended to the result string unless it is a percent sign. If the character is a \fB%\fR then it is not copied to the result string. Instead, the characters following the \fB%\fR character are treated as a conversion specifier. The conversion specifier controls the conversion of the next successive -\fIarg\fR to a particular format and the result is appended to +\fIarg\fR to a particular format and the result is appended to the result string in place of the conversion specifier. If there are multiple conversion specifiers in the format string, then each one controls the conversion of one additional \fIarg\fR. The \fBformat\fR command must be given enough \fIarg\fRs to meet the needs of all of the conversion specifiers in \fIformatString\fR. @@ -44,11 +44,10 @@ a set of flags, a minimum field width, a precision, a size modifier, and a conversion character. Any of these fields may be omitted except for the conversion character. The fields that are present must appear in the order given above. The paragraphs below discuss each of these fields in turn. -.SS "OPTIONAL POSITIONAL SPECIFIER" .PP If the \fB%\fR is followed by a decimal number and a \fB$\fR, as in .QW \fB%2$d\fR , then the value to convert is not taken from the next sequential argument. Instead, it is taken from the argument indicated by the number, @@ -58,63 +57,55 @@ successive arguments are used, starting with the argument given by the number. This follows the XPG3 conventions for positional specifiers. If there are any positional specifiers in \fIformatString\fR then all of the specifiers must be positional. -.SS "OPTIONAL FLAGS" .PP The second portion of a conversion specifier may contain any of the following flag characters, in any order: .TP 10 \fB\-\fR -Specifies that the converted argument should be left-justified -in its field (numbers are normally right-justified with leading +Specifies that the converted argument should be left-justified +in its field (numbers are normally right-justified with leading spaces if needed). .TP 10 \fB+\fR -Specifies that a number should always be printed with a sign, +Specifies that a number should always be printed with a sign, even if positive. .TP 10 \fIspace\fR Specifies that a space should be added to the beginning of the number if the first character is not a sign. .TP 10 \fB0\fR -Specifies that the number should be padded on the left with +Specifies that the number should be padded on the left with zeroes instead of spaces. .TP 10 \fB#\fR -Requests an alternate output form. For \fBo\fR conversions, -\fB0o\fR will be added to the beginning of the result unless -it is zero. For \fBx\fR or \fBX\fR conversions, \fB0x\fR -will be added to the beginning of the result unless it is zero. -For \fBb\fR conversions, \fB0b\fR -will be added to the beginning of the result unless it is zero. -For \fBd\fR conversions, \fB0d\fR there is no effect unless -the \fB0\fR specifier is used as well: In that case, \fB0d\fR -will be added to the beginning. -For all floating-point conversions (\fBe\fR, \fBE\fR, \fBf\fR, -\fBg\fR, and \fBG\fR) it guarantees that the result always -has a decimal point. -For \fBg\fR and \fBG\fR conversions it specifies that -trailing zeroes should not be removed. -.SS "OPTIONAL FIELD WIDTH" +Requests an alternate output form. For \fBo\fR and \fBO\fR +conversions it guarantees that the first digit is always \fB0\fR. +For \fBx\fR or \fBX\fR conversions, \fB0x\fR or \fB0X\fR (respectively) +will be added to the beginning of the result unless it is zero. +For all floating-point conversions (\fBe\fR, \fBE\fR, \fBf\fR, +\fBg\fR, and \fBG\fR) it guarantees that the result always +has a decimal point. +For \fBg\fR and \fBG\fR conversions it specifies that +trailing zeroes should not be removed. .PP The third portion of a conversion specifier is a decimal number giving a minimum field width for this conversion. It is typically used to make columns line up in tabular printouts. If the converted argument contains fewer characters than the minimum field width then it will be padded so that it is as wide as the minimum field width. Padding normally occurs by adding extra spaces on the left of the -converted argument, but the \fB0\fR and \fB\-\fR flags +converted argument, but the \fB0\fR and \fB\-\fR flags may be used to specify padding with zeroes on the left or with spaces on the right, respectively. If the minimum field width is specified as \fB*\fR rather than a number, then the next argument to the \fBformat\fR command determines the minimum field width; it must be an integer value. -.SS "OPTIONAL PRECISION/BOUND" .PP The fourth portion of a conversion specifier is a precision, which consists of a period followed by a number. The number is used in different ways for different conversions. For \fBe\fR, \fBE\fR, and \fBf\fR conversions it specifies the number @@ -123,34 +114,29 @@ of digits to appear, including those on both sides of the decimal point (however, trailing zeroes after the decimal point will still be omitted unless the \fB#\fR flag has been specified). For integer conversions, it specifies a minimum number of digits to print (leading zeroes will be added if necessary). -For \fBs\fR conversions it specifies the maximum number of characters to be +For \fBs\fR conversions it specifies the maximum number of characters to be printed; if the string is longer than this then the trailing characters will be dropped. If the precision is specified with \fB*\fR rather than a number then the next argument to the \fBformat\fR command determines the precision; it must be a numeric string. -.SS "OPTIONAL SIZE MODIFIER" .PP The fifth part of a conversion specifier is a size modifier, -which must be \fBll\fR, \fBh\fR, \fBl\fR, or \fBL\fR. +which must be \fBll\fR, \fBh\fR, or \fBl\fR. If it is \fBll\fR it specifies that an integer value is taken without truncation for conversion to a formatted substring. If it is \fBh\fR it specifies that an integer value is truncated to a 16-bit range before converting. This option is rarely useful. -If it is \fBl\fR it specifies that the integer value is +If it is \fBl\fR it specifies that the integer value is truncated to the same range as that produced by the \fBwide()\fR function of the \fBexpr\fR command (at least a 64-bit range). -If it is \fBL\fR it specifies that an integer or double value is taken -without truncation for conversion to a formatted substring. -If neither \fBh\fR nor \fBl\fR nor \fBL\fR are present, the integer value is +If neither \fBh\fR nor \fBl\fR are present, the integer value is truncated to the same range as that produced by the \fBint()\fR function of the \fBexpr\fR command (at least a 32-bit range, but -determined by the value of the \fBwordSize\fR element of the -\fBtcl_platform\fR array). -.SS "MANDATORY CONVERSION TYPE" +determined by the value of \fBtcl_platform(wordSize)\fR). .PP The last thing in a conversion specifier is an alphabetic character that determines what kind of conversion to perform. The following conversion characters are currently supported: .TP 10 @@ -171,107 +157,85 @@ .QW 0123456789abcdef for \fBx\fR and .QW 0123456789ABCDEF for \fBX\fR). .TP 10 -\fBb\fR -Convert integer to unsigned binary string, using digits 0 and 1. -.TP 10 \fBc\fR Convert integer to the Unicode character it represents. .TP 10 \fBs\fR No conversion; just insert string. .TP 10 \fBf\fR -Convert number to signed decimal string of -the form \fIxx.yyy\fR, where the number of \fIy\fR's is determined by +Convert number to signed decimal string of +the form \fIxx.yyy\fR, where the number of \fIy\fR's is determined by the precision (default: 6). If the precision is 0 then no decimal point is output. .TP 10 \fBe\fR or \fBE\fR -Convert number to scientific notation in the -form \fIx.yyy\fBe\(+-\fIzz\fR, where the number of \fIy\fR's is determined +Convert number to scientific notation in the +form \fIx.yyy\fBe\(+-\fIzz\fR, where the number of \fIy\fR's is determined by the precision (default: 6). If the precision is 0 then no decimal point is output. -If the \fBE\fR form is used then \fBE\fR is +If the \fBE\fR form is used then \fBE\fR is printed instead of \fBe\fR. .TP 10 \fBg\fR or \fBG\fR -If the exponent is less than \-4 or greater than or equal to the -precision, then convert number as for \fB%e\fR or +If the exponent is less than \-4 or greater than or equal to the +precision, then convert number as for \fB%e\fR or \fB%E\fR. Otherwise convert as for \fB%f\fR. Trailing zeroes and a trailing decimal point are omitted. .TP 10 -\fBa\fR or \fBA\fR -Convert double to hexadecimal notation in the form -\fI0x1.yyy\fBp\(+-\fIzz\fR, where the number of \fIy\fR's is -determined by the precision (default: 13). -If the \fBA\fR form is used then the hex characters -are printed in uppercase. -.TP 10 \fB%\fR No conversion: just insert \fB%\fR. -.TP 10 -\fBp\fR -Shorthand form for \fB0x%zx\fR, so it outputs the integer in -hexadecimal form with \fB0x\fR prefix. .SH "DIFFERENCES FROM ANSI SPRINTF" .PP The behavior of the format command is the same as the ANSI C \fBsprintf\fR procedure except for the following differences: .IP [1] -Tcl guarantees that it will be working with UNICODE characters. +\fB%p\fR and \fB%n\fR specifiers are not supported. .IP [2] -\fB%n\fR specifier is not supported. -.IP [3] For \fB%c\fR conversions the argument must be an integer value, which will then be converted to the corresponding character value. -.IP [4] +.IP [3] The size modifiers are ignored when formatting floating-point values. -The \fBb\fR specifier has no \fBsprintf\fR counterpart. +The \fBll\fR modifier has no \fBsprintf\fR counterpart. .SH EXAMPLES -.PP Convert the numeric value of a UNICODE character to the character itself: -.PP .CS set value 120 set char [\fBformat\fR %c $value] .CE .PP Convert the output of \fBtime\fR into seconds to an accuracy of hundredths of a second: -.PP .CS set us [lindex [time $someTclCode] 0] puts [\fBformat\fR "%.2f seconds to execute" [expr {$us / 1e6}]] .CE .PP Create a packed X11 literal color specification: -.PP .CS # Each color-component should be in range (0..255) set color [\fBformat\fR "#%02x%02x%02x" $r $g $b] .CE .PP Use XPG3 format codes to allow reordering of fields (a technique that is often used in localized message catalogs; see \fBmsgcat\fR) without reordering the data values passed to \fBformat\fR: -.PP .CS set fmt1 "Today, %d shares in %s were bought at $%.2f each" puts [\fBformat\fR $fmt1 123 "Global BigCorp" 19.37] set fmt2 "Bought %2\e$s equity ($%3$.2f x %1\e$d) today" puts [\fBformat\fR $fmt2 123 "Global BigCorp" 19.37] .CE .PP Print a small table of powers of three: -.PP .CS # Set up the column widths set w1 5 set w2 10 @@ -282,19 +246,16 @@ puts $sep # Print the contents of the table set p 1 for {set i 0} {$i<=20} {incr i} { - puts [\fBformat\fR "| %*d | %*ld |" $w1 $i $w2 $p] - set p [expr {wide($p) * 3}] + puts [\fBformat\fR "| %*d | %*ld |" $w1 $i $w2 $p] + set p [expr {wide($p) * 3}] } # Finish off by printing the separator again puts $sep .CE .SH "SEE ALSO" scan(n), sprintf(3), string(n) .SH KEYWORDS conversion specifier, format, sprintf, string, substitution -'\" Local Variables: -'\" mode: nroff -'\" End: DELETED doc/fpclassify.n Index: doc/fpclassify.n ================================================================== --- doc/fpclassify.n +++ /dev/null @@ -1,83 +0,0 @@ -'\" -'\" Copyright (c) 2018 by Kevin B. Kenny . All rights reserved -'\" Copyright (c) 2019 by Donal Fellows -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH fpclassify n 8.7 Tcl "Tcl Float Classifier" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -fpclassify \- Floating point number classification of Tcl values -.SH SYNOPSIS -package require \fBTcl 8.7\fR -.sp -\fBfpclassify \fIvalue\fR -.BE -.SH DESCRIPTION -The \fBfpclassify\fR command takes a floating point number, \fIvalue\fR, and -returns one of the following strings that describe it: -.TP -\fBzero\fR -. -\fIvalue\fR is a floating point zero. -.TP -\fBsubnormal\fR -. -\fIvalue\fR is the result of a gradual underflow. -.TP -\fBnormal\fR -. -\fIvalue\fR is an ordinary floating-point number (not zero, subnormal, -infinite, nor NaN). -.TP -\fBinfinite\fR -. -\fIvalue\fR is a floating-point infinity. -.TP -\fBnan\fR -. -\fIvalue\fR is Not-a-Number. -.PP -The \fBfpclassify\fR command throws an error if value is not a floating-point -value and cannot be converted to one. -.SH EXAMPLE -.PP -This shows how to check whether the result of a computation is numerically -safe or not. (Note however that it does not guard against numerical errors; -just against representational problems.) -.PP -.CS -set value [command-that-computes-a-value] -switch [\fBfpclassify\fR $value] { - normal - zero { - puts "Result is $value" - } - infinite { - puts "Result is infinite" - } - subnormal { - puts "Result is $value - WARNING! precision lost" - } - nan { - puts "Computation completely failed" - } -} -.CE -.SH "SEE ALSO" -expr(n), mathfunc(n) -.SH KEYWORDS -floating point -.SH STANDARDS -This command depends on the \fBfpclassify\fR() C macro conforming to -.QW "ISO C99" -(i.e., to ISO/IEC 9899:1999). -.SH COPYRIGHT -.nf -Copyright \(co 2018 by Kevin B. Kenny . All rights reserved -.fi -'\" Local Variables: -'\" mode: nroff -'\" End: Index: doc/gets.n ================================================================== --- doc/gets.n +++ doc/gets.n @@ -2,11 +2,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 gets n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -33,16 +33,16 @@ that name and the return value is a count of the number of characters returned. .PP If end of file occurs while scanning for an end of line, the command returns whatever input is available up to the end of file. -If \fIchannelId\fR is in non-blocking mode and there is not a full +If \fIchannelId\fR is in nonblocking mode and there is not a full line of input available, the command returns an empty string and does not consume any input. If \fIvarName\fR is specified and an empty string is returned in \fIvarName\fR because of end-of-file or because of insufficient -data in non-blocking mode, then the return count is -1. +data in nonblocking mode, then the return count is -1. Note that if \fIvarName\fR is not specified then the end-of-file and no-full-line-available cases can produce the same results as if there were an input line consisting only of the end-of-line character(s). The \fBeof\fR and \fBfblocked\fR commands can be used to distinguish @@ -62,10 +62,6 @@ .SH "SEE ALSO" file(n), eof(n), fblocked(n), Tcl_StandardChannels(3) .SH KEYWORDS -blocking, channel, end of file, end of line, line, non-blocking, read -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: +blocking, channel, end of file, end of line, line, nonblocking, read Index: doc/glob.n ================================================================== --- doc/glob.n +++ doc/glob.n @@ -2,171 +2,153 @@ '\" 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 glob n 8.3 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME glob \- Return names of files that match patterns .SH SYNOPSIS -\fBglob \fR?\fIswitches\fR? ?\fIpattern ...\fR? +\fBglob \fR?\fIswitches\fR? \fIpattern \fR?\fIpattern ...\fR? .BE + .SH DESCRIPTION .PP This command performs file name .QW globbing in a fashion similar to -the csh shell or bash shell. -It returns a list of the files whose names match any -of the \fIpattern\fR arguments. No particular order is guaranteed -in the list, so if a sorted list is required the caller should use +the csh shell. It returns a list of the files whose names match any +of the \fIpattern\fR arguments. No particular order is guaranteed +in the list, so if a sorted list is required the caller should use \fBlsort\fR. -.SS OPTIONS -.PP +.LP If the initial arguments to \fBglob\fR start with \fB\-\fR then -they are treated as switches. The following switches are +they are treated as switches. The following switches are currently supported: .TP \fB\-directory\fR \fIdirectory\fR -. Search for files which match the given patterns starting in the given -\fIdirectory\fR. This allows searching of directories whose name +\fIdirectory\fR. This allows searching of directories whose name contains glob-sensitive characters without the need to quote such -characters explicitly. This option may not be used in conjunction with +characters explicitly. This option may not be used in conjunction with \fB\-path\fR, which is used to allow searching for complete file paths whose names may contain glob-sensitive characters. .TP \fB\-join\fR -. The remaining pattern arguments, after option processing, are treated as a single pattern obtained by joining the arguments with directory separators. .TP \fB\-nocomplain\fR -. -Allows an empty list to be returned without error; without this +Allows an empty list to be returned without error; without this switch an error is returned if the result list would be empty. .TP \fB\-path\fR \fIpathPrefix\fR -. Search for files with the given \fIpathPrefix\fR where the rest of the name -matches the given patterns. This allows searching for files with names -similar to a given file (as opposed to a directory) even when the names -contain glob-sensitive -characters. This option may not be used in conjunction with -\fB\-directory\fR. For example, to find all files with the same root name -as $path, but differing extensions, you should use -.QW "\fBglob \-path [file rootname $path] .*\fR" -which will work even if \fB$path\fR contains +matches the given patterns. This allows searching for files with names +similar to a given file (as opposed to a directory) even when the names +contain glob-sensitive +characters. This option may not be used in conjunction with +\fB\-directory\fR. For example, to find all files with the same root name +as $path, but differing extensions, you should use \fBglob +-path [file rootname $path] .*\fR which will work even if $path contains numerous glob-sensitive characters. .TP \fB\-tails\fR -. Only return the part of each file found which follows the last directory -named in any \fB\-directory\fR or \fB\-path\fR path specification. -Thus -.QW "\fBglob \-tails \-directory $dir *\fR" -is equivalent to -.QW "\fBset pwd [pwd]; cd $dir; glob *; cd $pwd\fR" . -For \fB\-path\fR specifications, the returned names will include the last -path segment, so -.QW "\fBglob \-tails \-path [file rootname ~/foo.tex] .*\fR" +named in any \fB\-directory\fR or \fB\-path\fR path specification. +Thus \fBglob -tails -directory $dir *\fR is equivalent to +\fBset pwd [pwd] ; cd $dir ; glob *; cd $pwd\fR. For +\fB\-path\fR specifications, the returned names will include the last +path segment, so \fBglob -tails -path [file rootname ~/foo.tex] .*\fR will return paths like \fBfoo.aux foo.bib foo.tex\fR etc. .TP \fB\-types\fR \fItypeList\fR -. Only list files or directories which match \fItypeList\fR, where the items -in the list have two forms. The first form is like the \-type option of +in the list have two forms. The first form is like the \-type option of the Unix find command: \fIb\fR (block special file), \fIc\fR (character special file), \fId\fR (directory), \fIf\fR (plain file), \fIl\fR (symbolic link), \fIp\fR (named pipe), or \fIs\fR (socket), where multiple types may be specified in the list. \fBGlob\fR will return all files which match at least one of the types given. -Note that symbolic links will be returned both if \fB\-types l\fR is given, -or if the target of a link matches the requested type. So, a link to +Note that symbolic links will be returned both if \fB\-types l\fR is given, +or if the target of a link matches the requested type. So, a link to a directory will be returned if \fB\-types d\fR was specified. .RS .PP The second form specifies types where all the types given must match. These are \fIr\fR, \fIw\fR, \fIx\fR as file permissions, and -\fIreadonly\fR, \fIhidden\fR as special permission cases. On the +\fIreadonly\fR, \fIhidden\fR as special permission cases. On the Macintosh, MacOS types and creators are also supported, where any item which is four characters long is assumed to be a MacOS type -(e.g. \fBTEXT\fR). Items which are of the form \fI{macintosh type XXXX}\fR +(e.g. \fBTEXT\fR). Items which are of the form \fI{macintosh type XXXX}\fR or \fI{macintosh creator XXXX}\fR will match types or creators -respectively. Unrecognized types, or specifications of multiple MacOS +respectively. Unrecognized types, or specifications of multiple MacOS types/creators will signal an error. .PP The two forms may be mixed, so \fB\-types {d f r w}\fR will find all regular files OR directories that have both read AND write permissions. The following are equivalent: -.PP +.RS .CS \fBglob \-type d *\fR \fBglob */\fR .CE -.PP +.RE except that the first case doesn't return the trailing .QW / and is more platform independent. .RE .TP \fB\-\|\-\fR -. -Marks the end of switches. The argument following this one will +Marks the end of switches. The argument following this one will be treated as a \fIpattern\fR even if it starts with a \fB\-\fR. -.SS "GLOBBING PATTERNS" .PP The \fIpattern\fR arguments may contain any of the following -special characters, which are a superset of those supported by -\fBstring match\fR: +special characters: .TP 10 \fB?\fR -. Matches any single character. .TP 10 \fB*\fR -. Matches any sequence of zero or more characters. .TP 10 \fB[\fIchars\fB]\fR -. -Matches any single character in \fIchars\fR. If \fIchars\fR +Matches any single character in \fIchars\fR. If \fIchars\fR contains a sequence of the form \fIa\fB\-\fIb\fR then any character between \fIa\fR and \fIb\fR (inclusive) will match. .TP 10 \fB\e\fIx\fR -. Matches the character \fIx\fR. .TP 10 \fB{\fIa\fB,\fIb\fB,\fI...\fR} -. -Matches any of the sub-patterns \fIa\fR, \fIb\fR, etc. -.PP +Matches any of the strings \fIa\fR, \fIb\fR, etc. +.LP On Unix, as with csh, a -.QW . \| +.QW . at the beginning of a file's name or just after a .QW / must be matched explicitly or with a {} construct, unless the \fB\-types hidden\fR flag is given (since -.QW . \| -at the beginning of a file's name indicates that it is hidden). On +.QW . +at the beginning of a file's name indicates that it is hidden). On other platforms, files beginning with a -.QW . \| +.QW . are handled no differently to any others, except the special directories -.QW . \| +.QW . and -.QW .. \| +.QW .. which must be matched explicitly (this is to avoid a recursive pattern like -.QW "glob \-join * * * *" +.QW "glob -join * * * *" from recursing up the directory hierarchy as well as down). In addition, all .QW / characters must be matched explicitly. .LP If the first character in a \fIpattern\fR is @@ -176,76 +158,67 @@ If the .QW ~ is followed immediately by .QW / then the value of the HOME environment variable is used. -.PP +.LP The \fBglob\fR command differs from csh globbing in two ways. First, it does not sort its result list (use the \fBlsort\fR command if you want the list sorted). Second, \fBglob\fR only returns the names of files that actually -exist; in csh no check for existence is made unless a pattern +exist; in csh no check for existence is made unless a pattern contains a ?, *, or [] construct. .LP When the \fBglob\fR command returns relative paths whose filenames start with a tilde .QW ~ -(for example through \fBglob *\fR or \fBglob \-tails\fR, the returned +(for example through \fBglob *\fR or \fBglob -tails\fR, the returned list will not quote the tilde with .QW ./ . This means care must be taken if those names are later to be used with \fBfile join\fR, to avoid them being interpreted as absolute paths pointing to a given user's home directory. -.SH "WINDOWS PORTABILITY ISSUES" +.SH "PORTABILITY ISSUES" .PP +\fBWindows\fR +. For Windows UNC names, the servername and sharename components of the path -may not contain ?, *, or [] constructs. On Windows NT, if \fIpattern\fR is +may not contain ?, *, or [] constructs. On Windows NT, if \fIpattern\fR is of the form .QW \fB~\fIusername\fB@\fIdomain\fR , it refers to the home directory of the user whose account information resides on the specified NT -domain server. Otherwise, user account information is obtained from -the local computer. -.PP -Since the backslash character has a special meaning to the glob -command, glob patterns containing Windows style path separators need -special care. The pattern -.QW \fIC:\e\efoo\e\e*\fR -is interpreted as -.QW \fIC:\efoo\e*\fR -where -.QW \fI\ef\fR -will match the single character -.QW \fIf\fR +domain server. Otherwise, user account information is obtained from +the local computer. On Windows 95 and 98, \fBglob\fR accepts patterns +like +.QW .../ and -.QW \fI\e*\fR -will match the single character -.QW \fI*\fR -and will not be -interpreted as a wildcard character. One solution to this problem is -to use the Unix style forward slash as a path separator. Windows style -paths can be converted to Unix style paths with the command -.QW "\fBfile join\fR \fB$path\fR" -or -.QW "\fBfile normalize\fR \fB$path\fR" . +.QW ..../ +for successively higher up parent directories. +.PP +Since the backslash character has a special meaning to the glob +command, glob patterns containing Windows style path separators need +special care. The pattern \fIC:\e\efoo\e\e*\fR is interpreted as +\fIC:\efoo\e*\fR where \fI\ef\fR will match the single character \fIf\fR +and \fI\e*\fR will match the single character \fI*\fR and will not be +interpreted as a wildcard character. One solution to this problem is +to use the Unix style forward slash as a path separator. Windows style +paths can be converted to Unix style paths with the command \fBfile +join $path\fR (or \fBfile normalize $path\fR in Tcl 8.4). .SH EXAMPLES -.PP Find all the Tcl files in the current directory: -.PP .CS \fBglob\fR *.tcl .CE .PP Find all the Tcl files in the user's home directory, irrespective of what the current directory is: -.PP .CS \fBglob\fR \-directory ~ *.tcl .CE .PP Find all subdirectories of the current directory: -.PP .CS \fBglob\fR \-type d * .CE .PP Find all files whose name contains an @@ -252,16 +225,14 @@ .QW a , a .QW b or the sequence .QW cde : -.PP .CS \fBglob\fR \-type f *{a,b,cde}* .CE + .SH "SEE ALSO" file(n) + .SH KEYWORDS exist, file, glob, pattern -'\" Local Variables: -'\" mode: nroff -'\" End: Index: doc/global.n ================================================================== --- doc/global.n +++ doc/global.n @@ -2,20 +2,21 @@ '\" 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 global n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME global \- Access global variables .SH SYNOPSIS -\fBglobal \fR?\fIvarname ...\fR? +\fBglobal \fIvarname \fR?\fIvarname ...\fR? .BE + .SH DESCRIPTION .PP This command has no effect unless executed in the context of a proc body. If the \fBglobal\fR command is executed in the context of a proc body, it creates local variables linked to the corresponding global variables (though @@ -22,19 +23,17 @@ these linked variables, like those created by \fBupvar\fR, are not included in the list returned by \fBinfo locals\fR). .PP If \fIvarname\fR contains namespace qualifiers, the local variable's name is the unqualified name of the global variable, as determined by the -\fBnamespace tail\fR command. +\fBnamespace tail\fR command. .PP \fIvarname\fR is always treated as the name of a variable, not an array element. An error is returned if the name looks like an array element, such as \fBa(b)\fR. .SH EXAMPLES -.PP This procedure sets the namespace variable \fI::a::x\fR -.PP .CS proc reset {} { \fBglobal\fR a::x set x 0 } @@ -43,20 +42,17 @@ This procedure accumulates the strings passed to it in a global buffer, separated by newlines. It is useful for situations when you want to build a message piece-by-piece (as if with \fBputs\fR) but send that full message in a single piece (e.g. over a connection opened with \fBsocket\fR or as part of a counted HTTP response). -.PP .CS proc accum {string} { \fBglobal\fR accumulator append accumulator $string \en } .CE + .SH "SEE ALSO" namespace(n), upvar(n), variable(n) + .SH KEYWORDS global, namespace, procedure, variable -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/history.n ================================================================== --- doc/history.n +++ doc/history.n @@ -2,11 +2,11 @@ '\" 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 history n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -98,9 +98,5 @@ If you want to redo an event without modifying history, then use the \fBevent\fR operation to retrieve some event, and the \fBadd\fR operation to add it to history and execute it. .SH KEYWORDS event, history, record -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/http.n ================================================================== --- doc/http.n +++ doc/http.n @@ -3,29 +3,27 @@ '\" Copyright (c) 1998-2000 by Ajuba Solutions. '\" Copyright (c) 2004 ActiveState Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH "http" n 2.9 http "Tcl Bundled Packages" +'\" +.TH "http" n 2.7 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? +\fBpackage require http ?2.7?\fR .\" See Also -useragent option documentation in body! .sp -\fB::http::config\fR ?\fI\-option value\fR ...? +\fB::http::config \fI?options?\fR .sp -\fB::http::geturl \fIurl\fR ?\fI\-option value\fR ...? +\fB::http::geturl \fIurl ?options?\fR .sp \fB::http::formatQuery\fR \fIkey value\fR ?\fIkey value\fR ...? .sp -\fB::http::quoteString\fR \fIvalue\fR -.sp \fB::http::reset\fR \fItoken\fR ?\fIwhy\fR? .sp \fB::http::wait \fItoken\fR .sp \fB::http::status \fItoken\fR @@ -44,18 +42,16 @@ .sp \fB::http::cleanup \fItoken\fR .sp \fB::http::register \fIproto port command\fR .sp -\fB::http::registerError \fIport\fR ?\fImessage\fR? -.sp \fB::http::unregister \fIproto\fR .BE .SH DESCRIPTION .PP The \fBhttp\fR package provides the client side of the HTTP/1.1 -protocol, as defined in RFC 7230 to RFC 7235, which supersede RFC 2616. +protocol, as defined in RFC 2616. The package implements the GET, POST, and HEAD operations of HTTP/1.1. It allows configuration of a proxy host to get through firewalls. The package is compatible with the \fBSafesock\fR security policy, so it can be used by untrusted applets to do URL fetching from a restricted set of hosts. This package can be extended to support @@ -62,11 +58,11 @@ additional HTTP transport protocols, such as HTTPS, by providing a custom \fBsocket\fR command, via \fB::http::register\fR. .PP The \fB::http::geturl\fR procedure does a HTTP transaction. Its \fIoptions \fR determine whether a GET, POST, or HEAD transaction -is performed. +is performed. The return value of \fB::http::geturl\fR is a token for the transaction. The value is also the name of an array in the ::http namespace that contains state information about the transaction. The elements of this array are described in the \fBSTATE ARRAY\fR section. .PP @@ -79,11 +75,10 @@ applications, the caller can use \fB::http::wait\fR after calling \fB::http::geturl\fR to start the event loop. .SH COMMANDS .TP \fB::http::config\fR ?\fIoptions\fR? -. The \fB::http::config\fR command is used to set and query the name of the proxy server and port, and the User-Agent name used in the HTTP requests. If no options are specified, then the current configuration is returned. If a single argument is specified, then it should be one of the flags described below. In this case the current value of @@ -90,50 +85,24 @@ that setting is returned. Otherwise, the options should be a set of flags and values that define the configuration: .RS .TP \fB\-accept\fR \fImimetypes\fR -. The Accept header of the request. The default is */*, which means that -all types of documents are accepted. Otherwise you can supply a +all types of documents are accepted. Otherwise you can supply a comma-separated list of mime type patterns that you are willing to receive. For example, .QW "image/gif, image/jpeg, text/*" . .TP -\fB\-cookiejar\fR \fIcommand\fR -.VS TIP406 -The cookie store for the package to use to manage HTTP cookies. -\fIcommand\fR is a command prefix list; if the empty list (the -default value) is used, no cookies will be sent by requests or stored -from responses. The command indicated by \fIcommand\fR, if supplied, -must obey the \fBCOOKIE JAR PROTOCOL\fR described below. -.VE TIP406 -.TP -\fB\-pipeline\fR \fIboolean\fR -. -Specifies whether HTTP/1.1 transactions on a persistent socket will be -pipelined. See the \fBPERSISTENT SOCKETS\fR section for details. The default -is 1. -.TP -\fB\-postfresh\fR \fIboolean\fR -. -Specifies whether requests that use the \fBPOST\fR method will always use a -fresh socket, overriding the \fB-keepalive\fR option of -command \fBhttp::geturl\fR. See the \fBPERSISTENT SOCKETS\fR section for details. -The default is 0. -.TP \fB\-proxyhost\fR \fIhostname\fR -. The name of the proxy host, if any. If this value is the empty string, the URL host is contacted directly. .TP \fB\-proxyport\fR \fInumber\fR -. The proxy port number. .TP \fB\-proxyfilter\fR \fIcommand\fR -. The command is a callback that is made during \fB::http::geturl\fR to determine if a proxy is required for a given host. One argument, a host name, is added to \fIcommand\fR when it is invoked. If a proxy is required, the callback should return a two-element list containing @@ -140,55 +109,25 @@ the proxy server and proxy port. Otherwise the filter should return an empty list. The default filter returns the values of the \fB\-proxyhost\fR and \fB\-proxyport\fR settings if they are non-empty. .TP -\fB\-repost\fR \fIboolean\fR -. -Specifies what to do if a POST request over a persistent connection fails -because the server has half-closed the connection. If boolean \fBtrue\fR, the -request -will be automatically retried; if boolean \fBfalse\fR it will not, and the -application -that uses \fBhttp::geturl\fR is expected to seek user confirmation before -retrying the POST. The value \fBtrue\fR should be used only under certain -conditions. See the \fBPERSISTENT SOCKETS\fR section for details. The -default is 0. -.TP \fB\-urlencoding\fR \fIencoding\fR -. The \fIencoding\fR used for creating the x-url-encoded URLs with -\fB::http::formatQuery\fR and \fB::http::quoteString\fR. -The default is \fButf-8\fR, as specified by RFC +\fB::http::formatQuery\fR. The default is \fButf-8\fR, as specified by RFC 2718. Prior to http 2.5 this was unspecified, and that behavior can be returned by specifying the empty string (\fB{}\fR), although \fIiso8859-1\fR is recommended to restore similar behavior but without the -\fB::http::formatQuery\fR or \fB::http::quoteString\fR -throwing an error processing non-latin-1 characters. +\fB::http::formatQuery\fR 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 -.QW "\fBAccept-Encoding: gzip,deflate,compress\fR" . -If the value is boolean \fBfalse\fR, then by default this header will not be sent. -In either case the default can be overridden for an individual request by -supplying a custom \fBAccept-Encoding\fR header in the \fB-headers\fR option -of \fBhttp::geturl\fR. The default is 1. +The value of the User-Agent header in the HTTP request. The default is +.QW "\fBTcl http client package 2.7\fR" . .RE .TP -\fB::http::geturl\fR \fIurl\fR ?\fIoptions\fR? -. +\fB::http::geturl\fR \fIurl\fR ?\fIoptions\fR? The \fB::http::geturl\fR command is the main procedure in the package. The \fB\-query\fR option causes a POST operation and the \fB\-validate\fR option causes a HEAD operation; otherwise, a GET operation is performed. The \fB::http::geturl\fR command returns a \fItoken\fR value that can be used to get @@ -199,56 +138,49 @@ that is invoked when the HTTP transaction completes. \fB::http::geturl\fR takes several options: .RS .TP \fB\-binary\fR \fIboolean\fR -. Specifies whether to force interpreting the URL data as binary. Normally this is auto-detected (anything not beginning with a \fBtext\fR content type or whose content encoding is \fBgzip\fR or \fBcompress\fR is considered binary data). .TP \fB\-blocksize\fR \fIsize\fR -. The block size used when reading the URL. At most \fIsize\fR bytes are read at once. After each block, a call to the \fB\-progress\fR callback is made (if that option is specified). .TP \fB\-channel\fR \fIname\fR -. Copy the URL contents to channel \fIname\fR instead of saving it in \fBstate(body)\fR. .TP \fB\-command\fR \fIcallback\fR -. Invoke \fIcallback\fR after the HTTP transaction completes. This option causes \fB::http::geturl\fR to return immediately. The \fIcallback\fR gets an additional argument that is the \fItoken\fR returned from \fB::http::geturl\fR. This token is the name of an array that is described in the \fBSTATE ARRAY\fR section. Here is a template for the callback: .RS -.PP .CS proc httpCallback {token} { upvar #0 $token state # Access state as a Tcl array } .CE .RE .TP \fB\-handler\fR \fIcallback\fR -. Invoke \fIcallback\fR whenever HTTP data is available; if present, nothing else will be done with the HTTP data. This procedure gets two additional arguments: the socket for the HTTP data and the \fItoken\fR returned from \fB::http::geturl\fR. The token is the name of a global array that is described in the \fBSTATE ARRAY\fR section. The procedure is expected to return the number of bytes read from the socket. Here is a template for the callback: .RS -.PP .CS proc httpHandlerCallback {socket token} { upvar #0 $token state # Access socket, and state as a Tcl array # For example... @@ -257,91 +189,73 @@ set nbytes [string length $data] ... return $nbytes } .CE -.PP -The \fBhttp::geturl\fR code for the \fB-handler\fR option is not compatible with either compression or chunked transfer-encoding. If \fB-handler\fR is specified, then to work around these issues \fBhttp::geturl\fR will reduce the HTTP protocol to 1.0, and override the \fB-zip\fR option (i.e. it will not send the header "\fBAccept-Encoding: gzip,deflate,compress\fR"). -.PP -If options \fB-handler\fR and \fB-channel\fR are used together, the handler is responsible for copying the data from the HTTP socket to the specified channel. The name of the channel is available to the handler as element \fB-channel\fR of the token array. .RE .TP \fB\-headers\fR \fIkeyvaluelist\fR -. -This option is used to add headers not already specified -by \fB::http::config\fR to the HTTP request. The +This option is used to add extra headers to the HTTP request. The \fIkeyvaluelist\fR argument must be a list with an even number of elements that alternate between keys and values. The keys become header field names. Newlines are stripped from the values so the header cannot be corrupted. For example, if \fIkeyvaluelist\fR is \fBPragma no-cache\fR then the following header is included in the HTTP request: -.RS -.PP .CS Pragma: no-cache .CE -.RE .TP \fB\-keepalive\fR \fIboolean\fR -. -If boolean \fBtrue\fR, attempt to keep the connection open for servicing +If true, attempt to keep the connection open for servicing multiple requests. Default is 0. .TP \fB\-method\fR \fItype\fR -. Force the HTTP request method to \fItype\fR. \fB::http::geturl\fR will auto-select GET, POST or HEAD based on other options, but this option enables choices like PUT and DELETE for webdav support. .TP \fB\-myaddr\fR \fIaddress\fR -. Pass an specific local address to the underlying \fBsocket\fR call in case multiple interfaces are available. .TP \fB\-progress\fR \fIcallback\fR -. The \fIcallback\fR is made after each transfer of data from the URL. The callback gets three additional arguments: the \fItoken\fR from \fB::http::geturl\fR, the expected total size of the contents from the \fBContent-Length\fR meta-data, and the current number of bytes transferred so far. The expected total size may be unknown, in which case zero is passed to the callback. Here is a template for the progress callback: .RS -.PP .CS proc httpProgress {token total current} { upvar #0 $token state } .CE .RE .TP \fB\-protocol\fR \fIversion\fR -. Select the HTTP protocol version to use. This should be 1.0 or 1.1 (the default). Should only be necessary for servers that do not understand or otherwise complain about HTTP/1.1. .TP \fB\-query\fR \fIquery\fR -. This flag causes \fB::http::geturl\fR to do a POST request that passes the \fIquery\fR to the server. The \fIquery\fR must be an x-url-encoding formatted query. The \fB::http::formatQuery\fR procedure can be used to do the formatting. .TP \fB\-queryblocksize\fR \fIsize\fR -. The block size used when posting query data to the URL. -At most +At most \fIsize\fR bytes are written at once. After each block, a call to the \fB\-queryprogress\fR callback is made (if that option is specified). .TP \fB\-querychannel\fR \fIchannelID\fR -. This flag causes \fB::http::geturl\fR to do a POST request that passes the data contained in \fIchannelID\fR to the server. The data contained in \fIchannelID\fR must be an x-url-encoding formatted query unless the \fB\-type\fR option below is used. If a Content-Length header is not specified via the \fB\-headers\fR options, @@ -348,111 +262,89 @@ \fB::http::geturl\fR attempts to determine the size of the post data in order to create that header. If it is unable to determine the size, it returns an error. .TP \fB\-queryprogress\fR \fIcallback\fR -. The \fIcallback\fR is made after each transfer of data to the URL (i.e. POST) and acts exactly like the \fB\-progress\fR option (the callback format is the same). .TP \fB\-strict\fR \fIboolean\fR -. Whether to enforce RFC 3986 URL validation on the request. Default is 1. .TP \fB\-timeout\fR \fImilliseconds\fR -. If \fImilliseconds\fR is non-zero, then \fB::http::geturl\fR sets up a timeout to occur after the specified number of milliseconds. A timeout results in a call to \fB::http::reset\fR and to the \fB\-command\fR callback, if specified. The return value of \fB::http::status\fR is \fBtimeout\fR after a timeout has occurred. .TP \fB\-type\fR \fImime-type\fR -. Use \fImime-type\fR as the \fBContent-Type\fR value, instead of the default value (\fBapplication/x-www-form-urlencoded\fR) during a POST operation. .TP \fB\-validate\fR \fIboolean\fR -. If \fIboolean\fR is non-zero, then \fB::http::geturl\fR does an HTTP HEAD request. This request returns meta information about the URL, but the contents are not returned. The meta information is available in the \fBstate(meta) \fR variable after the transaction. See the \fBSTATE ARRAY\fR section for details. .RE .TP \fB::http::formatQuery\fR \fIkey value\fR ?\fIkey value\fR ...? -. This procedure does x-url-encoding of query data. It takes an even number of arguments that are the keys and values of the query. It encodes the keys and values, and generates one string that has the proper & and = separators. The result is suitable for the \fB\-query\fR value passed to \fB::http::geturl\fR. .TP -\fB::http::quoteString\fR \fIvalue\fR -. -This procedure does x-url-encoding of string. It takes a single argument and -encodes it. -.TP \fB::http::reset\fR \fItoken\fR ?\fIwhy\fR? -. -This command resets the HTTP transaction identified by \fItoken\fR, if any. -This sets the \fBstate(status)\fR value to \fIwhy\fR, which defaults to -\fBreset\fR, and then calls the registered \fB\-command\fR callback. +This command resets the HTTP transaction identified by \fItoken\fR, if +any. This sets the \fBstate(status)\fR value to \fIwhy\fR, which defaults to \fBreset\fR, and then calls the registered \fB\-command\fR callback. .TP \fB::http::wait\fR \fItoken\fR -. This is a convenience procedure that blocks and waits for the transaction to complete. This only works in trusted code because it uses \fBvwait\fR. Also, it is not useful for the case where \fB::http::geturl\fR is called \fIwithout\fR the \fB\-command\fR option because in this case the \fB::http::geturl\fR call does not return until the HTTP transaction is complete, and thus there is nothing to wait for. .TP \fB::http::data\fR \fItoken\fR -. This is a convenience procedure that returns the \fBbody\fR element (i.e., the URL data) of the state array. .TP \fB::http::error\fR \fItoken\fR -. This is a convenience procedure that returns the \fBerror\fR element of the state array. .TP \fB::http::status\fR \fItoken\fR -. This is a convenience procedure that returns the \fBstatus\fR element of the state array. .TP \fB::http::code\fR \fItoken\fR -. This is a convenience procedure that returns the \fBhttp\fR element of the state array. .TP \fB::http::ncode\fR \fItoken\fR -. This is a convenience procedure that returns just the numeric return code (200, 404, etc.) from the \fBhttp\fR element of the state array. .TP \fB::http::size\fR \fItoken\fR -. This is a convenience procedure that returns the \fBcurrentsize\fR element of the state array, which represents the number of bytes received from the URL in the \fB::http::geturl\fR call. .TP \fB::http::meta\fR \fItoken\fR -. This is a convenience procedure that returns the \fBmeta\fR element of the state array which contains the HTTP response headers. See below for an explanation of this element. .TP \fB::http::cleanup\fR \fItoken\fR -. This procedure cleans up the state associated with the connection identified by \fItoken\fR. After this call, the procedures like \fB::http::data\fR cannot be used to get information about the operation. It is \fIstrongly\fR recommended that you call this function after you are done with a given HTTP request. Not doing @@ -459,16 +351,14 @@ so will result in memory not being freed, and if your app calls \fB::http::geturl\fR enough times, the memory leak could cause a performance hit...or worse. .TP \fB::http::register\fR \fIproto port command\fR -. This procedure allows one to provide custom HTTP transport types such as HTTPS, by registering a prefix, the default port, and the command to execute to create the Tcl \fBchannel\fR. E.g.: .RS -.PP .CS package require http package require tls ::http::register https 443 ::tls::socket @@ -475,23 +365,11 @@ set token [::http::geturl https://my.secure.site/] .CE .RE .TP -\fB::http::registerError\fR \fIport\fR ?\fImessage\fR? -. -This procedure allows a registered protocol handler to deliver an error -message for use by \fBhttp\fR. Calling this command does not raise an -error. The command is useful when a registered protocol detects an problem -(for example, an invalid TLS certificate) that will cause an error to -propagate to \fBhttp\fR. The command allows \fBhttp\fR to provide a -precise error message rather than a general one. The command returns the -value provided by the last call with argument \fImessage\fR, or the empty -string if no such call has been made. -.TP \fB::http::unregister\fR \fIproto\fR -. This procedure unregisters a protocol handler that was previously registered via \fB::http::register\fR, returning a two-item list of the default port and handler command that was previously installed (via \fB::http::register\fR) if there was such a handler, and an error if there was no such handler. @@ -531,26 +409,23 @@ .PP There are other possible results of the HTTP transaction determined by examining the status from \fB::http::status\fR. These are described below. .TP -\fBok\fR -. +ok If the HTTP transaction completes entirely, then status will be \fBok\fR. However, you should still check the \fB::http::code\fR value to get the HTTP status. The \fB::http::ncode\fR procedure provides just the numeric error (e.g., 200, 404 or 500) while the \fB::http::code\fR procedure returns a value like .QW "HTTP 404 File not found" . .TP -\fBeof\fR -. +eof If the server closes the socket without replying, then no error is raised, but the status of the transaction will be \fBeof\fR. .TP -\fBerror\fR -. +error The error message will also be stored in the \fBerror\fR status array element, accessible via \fB::http::error\fR. .PP Another error possibility is that \fB::http::geturl\fR is unable to write all the post query data to the server before the server @@ -563,371 +438,134 @@ an \fBeof\fR status. .SH "STATE ARRAY" The \fB::http::geturl\fR procedure returns a \fItoken\fR that can be used to get to the state of the HTTP transaction in the form of a Tcl array. Use this construct to create an easy-to-use array variable: -.PP .CS upvar #0 $token state .CE -.PP Once the data associated with the URL is no longer needed, the state array should be unset to free up storage. The \fB::http::cleanup\fR procedure is provided for that purpose. The following elements of the array are supported: .RS .TP -\fBbinary\fR -. -This is boolean \fBtrue\fR if (after decoding any compression specified -by the -.QW "Content-Encoding" -response header) the HTTP response is binary. It is boolean \fBfalse\fR -if the HTTP response is text. -.TP \fBbody\fR -. The contents of the URL. This will be empty if the \fB\-channel\fR option has been specified. This value is returned by the \fB::http::data\fR command. .TP \fBcharset\fR -. The value of the charset attribute from the \fBContent-Type\fR meta-data value. If none was specified, this defaults to the RFC standard \fBiso8859-1\fR, or the value of \fB$::http::defaultCharset\fR. Incoming text data will be automatically converted from this charset to utf-8. .TP \fBcoding\fR -. A copy of the \fBContent-Encoding\fR meta-data value. .TP \fBcurrentsize\fR -. The current number of bytes fetched from the URL. This value is returned by the \fB::http::size\fR command. .TP \fBerror\fR -. If defined, this is the error string seen when the HTTP transaction was aborted. .TP \fBhttp\fR -. The HTTP status reply from the server. This value is returned by the \fB::http::code\fR command. The format of this value is: .RS -.PP .CS \fIHTTP/1.1 code string\fR .CE -.PP The \fIcode\fR is a three-digit number defined in the HTTP standard. A code of 200 is OK. Codes beginning with 4 or 5 indicate errors. Codes beginning with 3 are redirection errors. In this case the \fBLocation\fR meta-data specifies a new URL that contains the requested information. .RE .TP \fBmeta\fR -. The HTTP protocol returns meta-data that describes the URL contents. The \fBmeta\fR element of the state array is a list of the keys and values of the meta-data. This is in a format useful for initializing an array that just contains the meta-data: .RS -.PP .CS array set meta $state(meta) .CE -.PP Some of the meta-data keys are listed below, but the HTTP standard defines more, and servers are free to add their own. .TP \fBContent-Type\fR -. The type of the URL contents. Examples include \fBtext/html\fR, \fBimage/gif,\fR \fBapplication/postscript\fR and \fBapplication/x-tcl\fR. .TP \fBContent-Length\fR -. The advertised size of the contents. The actual size obtained by -\fB::http::geturl\fR is available as \fBstate(currentsize)\fR. +\fB::http::geturl\fR is available as \fBstate(size)\fR. .TP \fBLocation\fR -. An alternate URL that contains the requested data. .RE .TP \fBposterror\fR -. The error, if any, that occurred while writing the post query data to the server. .TP \fBstatus\fR -. Either \fBok\fR, for successful completion, \fBreset\fR for user-reset, \fBtimeout\fR if a timeout occurred before the transaction could complete, or \fBerror\fR for an error condition. During the transaction this value is the empty string. .TP \fBtotalsize\fR -. A copy of the \fBContent-Length\fR meta-data value. .TP \fBtype\fR -. A copy of the \fBContent-Type\fR meta-data value. .TP \fBurl\fR -. The requested URL. .RE -.SH "PERSISTENT CONNECTIONS" -.PP -.SS "BASICS" -.PP -See RFC 7230 Sec 6, which supersedes RFC 2616 Sec 8.1. -.PP -A persistent connection allows multiple HTTP/1.1 transactions to be -carried over the same TCP connection. Pipelining allows a -client to make multiple requests over a persistent connection without -waiting for each response. The server sends responses in the same order -that the requests were received. -.PP -If a POST request fails to complete, typically user confirmation is -needed before sending the request again. The user may wish to verify -whether the server was modified by the failed POST request, before -sending the same request again. -.PP -A HTTP request will use a persistent socket if the call to -\fBhttp::geturl\fR has the option \fB-keepalive true\fR. It will use -pipelining where permitted if the \fBhttp::config\fR option -\fB-pipeline\fR is boolean \fBtrue\fR (its default value). -.PP -The http package maintains no more than one persistent connection to each -server (i.e. each value of -.QW "domain:port" ). -If \fBhttp::geturl\fR is called to make a request over a persistent -connection while the connection is busy with another request, the new -request will be held in a queue until the connection is free. -.PP -The http package does not support HTTP/1.0 persistent connections -controlled by the \fBKeep-Alive\fR header. -.SS "SPECIAL CASES" -.PP -This subsection discusses issues related to closure of the -persistent connection by the server, automatic retry of failed requests, -the special treatment necessary for POST requests, and the options for -dealing with these cases. -.PP -In accordance with RFC 7230, \fBhttp::geturl\fR does not pipeline -requests that use the POST method. If a POST uses a persistent -connection and is not the first request on that connection, -\fBhttp::geturl\fR waits until it has received the response for the previous -request; or (if \fBhttp::config\fR option \fB-postfresh\fR is boolean \fBtrue\fR) it -uses a new connection for each POST. -.PP -If the server is processing a number of pipelined requests, and sends a -response header -.QW "\fBConnection: close\fR" -with one of the responses (other than the last), then subsequent responses -are unfulfilled. \fBhttp::geturl\fR will send the unfulfilled requests again -over a new connection. -.PP -A difficulty arises when a HTTP client sends a request over a persistent -connection that has been idle for a while. The HTTP server may -half-close an apparently idle connection while the client is sending a -request, but before the request arrives at the server: in this case (an -.QW "asynchronous close event" ) -the request will fail. The difficulty arises because the client cannot -be certain whether the POST modified the state of the server. For HEAD or -GET requests, \fBhttp::geturl\fR opens another connection and retransmits -the failed request. However, if the request was a POST, RFC 7230 forbids -automatic retry by default, suggesting either user confirmation, or -confirmation by user-agent software that has semantic understanding of -the application. The \fBhttp::config\fR option \fB-repost\fR allows for -either possibility. -.PP -Asynchronous close events can occur only in a short interval of time. The -\fBhttp\fR package monitors each persistent connection for closure by the -server. Upon detection, the connection is also closed at the client end, -and subsequent requests will use a fresh connection. -.PP -If the \fBhttp::geturl\fR command is called with option \fB-keepalive true\fR, -then it will both try to use an existing persistent connection -(if one is available), and it will send the server a -.QW "\fBConnection: keep-alive\fR" -request header asking to keep the connection open for future requests. -.PP -The \fBhttp::config\fR options \fB-pipeline\fR, \fB-postfresh\fR, and -\fB-repost\fR relate to persistent connections. -.PP -Option \fB-pipeline\fR, if boolean \fBtrue\fR, will pipeline GET and HEAD requests -made -over a persistent connection. POST requests will not be pipelined - if the -POST is not the first transaction on the connection, its request will not -be sent until the previous response has finished. GET and HEAD requests -made after a POST will not be sent until the POST response has been -delivered, and will not be sent if the POST fails. -.PP -Option \fB-postfresh\fR, if boolean \fBtrue\fR, will override the \fBhttp::geturl\fR option -\fB-keepalive\fR, and always open a fresh connection for a POST request. -.PP -Option \fB-repost\fR, if \fBtrue\fR, permits automatic retry of a POST request -that fails because it uses a persistent connection that the server has -half-closed (an -.QW "asynchronous close event" ). -Subsequent GET and HEAD requests in a failed pipeline will also be retried. -\fIThe -repost option should be used only if the application understands -that the retry is appropriate\fR - specifically, the application must know -that if the failed POST successfully modified the state of the server, a repeat POST -would have no adverse effect. -.VS TIP406 -.SH "COOKIE JAR PROTOCOL" -.PP -Cookies are short key-value pairs used to implement sessions within the -otherwise-stateless HTTP protocol. (See RFC 6265 for details; Tcl does not -implement the Cookie2 protocol as that is rarely seen in the wild.) -.PP -Cookie storage managment commands \(em -.QW "cookie jars" -\(em must support these subcommands which form the HTTP cookie storage -management protocol. Note that \fIcookieJar\fR below does not have to be a -command name; it is properly a command prefix (a Tcl list of words that will -be expanded in place) and admits many possible implementations. -.PP -Though not formally part of the protocol, it is expected that particular -values of \fIcookieJar\fR will correspond to sessions; it is up to the caller -of \fB::http::config\fR to decide what session applies and to manage the -deletion of said sessions when they are no longer desired (which should be -when they not configured as the current cookie jar). -.TP -\fIcookieJar \fBgetCookies \fIprotocol host requestPath\fR -. -This command asks the cookie jar what cookies should be supplied for a -particular request. It should take the \fIprotocol\fR (typically \fBhttp\fR or -\fBhttps\fR), \fIhost\fR name and \fIrequestPath\fR (parsed from the \fIurl\fR -argument to \fB::http::geturl\fR) and return a list of cookie keys and values -that describe the cookies to supply to the remote host. The list must have an -even number of elements. -.RS -.PP -There should only ever be at most one cookie with a particular key for any -request (typically the one with the most specific \fIhost\fR/domain match and -most specific \fIrequestPath\fR/path match), but there may be many cookies -with different names in any request. -.RE -.TP -\fIcookieJar \fBstoreCookie \fIcookieDictionary\fR -. -This command asks the cookie jar to store a particular cookie that was -returned by a request; the result of this command is ignored. The cookie -(which will have been parsed by the http package) is described by a -dictionary, \fIcookieDictionary\fR, that may have the following keys: -.RS -.TP -\fBdomain\fR -. -This is always present. Its value describes the domain hostname \fIor -prefix\fR that the cookie should be returned for. The checking of the domain -against the origin (below) should be careful since sites that issue cookies -should only do so for domains related to themselves. Cookies that do not obey -a relevant origin matching rule should be ignored. -.TP -\fBexpires\fR -. -This is optional. If present, the cookie is intended to be a persistent cookie -and the value of the option is the Tcl timestamp (in seconds from the same -base as \fBclock seconds\fR) of when the cookie expires (which may be in the -past, which should result in the cookie being deleted immediately). If absent, -the cookie is intended to be a session cookie that should be not persisted -beyond the lifetime of the cookie jar. -.TP -\fBhostonly\fR -. -This is always present. Its value is a boolean that describes whether the -cookie is a single host cookie (true) or a domain-level cookie (false). -.TP -\fBhttponly\fR -. -This is always present. Its value is a boolean that is true when the site -wishes the cookie to only ever be used with HTTP (or HTTPS) traffic. -.TP -\fBkey\fR -. -This is always present. Its value is the \fIkey\fR of the cookie, which is -part of the information that must be return when sending this cookie back in a -future request. -.TP -\fBorigin\fR -. -This is always present. Its value describes where the http package believes it -received the cookie from, which may be useful for checking whether the -cookie's domain is valid. -.TP -\fBpath\fR -. -This is always present. Its value describes the path prefix of requests to the -cookie domain where the cookie should be returned. -.TP -\fBsecure\fR -. -This is always present. Its value is a boolean that is true when the cookie -should only used on requests sent over secure channels (typically HTTPS). -.TP -\fBvalue\fR -. -This is always present. Its value is the value of the cookie, which is part of -the information that must be return when sending this cookie back in a future -request. -.PP -Other keys may always be ignored; they have no meaning in this protocol. -.RE -.VE TIP406 -.SH EXAMPLE -.PP -This example creates a procedure to copy a URL to a file while printing a -progress meter, and prints the meta-data associated with the URL. -.PP -.CS -proc httpcopy { url file {chunk 4096} } { - set out [open $file w] - set token [\fB::http::geturl\fR $url -channel $out \e - -progress httpCopyProgress -blocksize $chunk] - close $out - - # This ends the line started by httpCopyProgress - puts stderr "" - - upvar #0 $token state - set max 0 - foreach {name value} $state(meta) { - if {[string length $name] > $max} { - set max [string length $name] - } - if {[regexp -nocase ^location$ $name]} { - # Handle URL redirects - puts stderr "Location:$value" - return [httpcopy [string trim $value] $file $chunk] - } - } - incr max - foreach {name value} $state(meta) { - puts [format "%-*s %s" $max $name: $value] - } - - return $token +.SH EXAMPLE +.CS +# Copy a URL to a file and print meta-data +proc httpcopy { url file {chunk 4096} } { + set out [open $file w] + set token [\fB::http::geturl\fR $url -channel $out \e + -progress httpCopyProgress -blocksize $chunk] + close $out + + # This ends the line started by httpCopyProgress + puts stderr "" + + upvar #0 $token state + set max 0 + foreach {name value} $state(meta) { + if {[string length $name] > $max} { + set max [string length $name] + } + if {[regexp -nocase ^location$ $name]} { + # Handle URL redirects + puts stderr "Location:$value" + return [httpcopy [string trim $value] $file $chunk] + } + } + incr max + foreach {name value} $state(meta) { + puts [format "%-*s %s" $max $name: $value] + } + + return $token } proc httpCopyProgress {args} { - puts -nonewline stderr . - flush stderr + puts -nonewline stderr . + flush stderr } .CE .SH "SEE ALSO" safe(n), socket(n), safesock(n) .SH KEYWORDS -internet, security policy, socket, www -'\" Local Variables: -'\" mode: nroff -'\" End: +security policy, socket DELETED doc/idna.n Index: doc/idna.n ================================================================== --- doc/idna.n +++ /dev/null @@ -1,88 +0,0 @@ -'\" -'\" Copyright (c) 2014-2018 Donal K. Fellows. -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH "idna" n 0.1 http "Tcl Bundled Packages" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -tcl::idna \- Support for normalization of Internationalized Domain Names -.SH SYNOPSIS -.nf -package require tcl::idna 1.0 - -\fBtcl::idna decode\fR \fIhostname\fR -\fBtcl::idna encode\fR \fIhostname\fR -\fBtcl::idna puny decode\fR \fIstring\fR ?\fIcase\fR? -\fBtcl::idna puny encode\fR \fIstring\fR ?\fIcase\fR? -\fBtcl::idna version\fR -.fi -.SH DESCRIPTION -This package provides an implementation of the punycode scheme used in -Internationalised Domain Names, and some access commands. (See RFC 3492 for a -description of punycode.) -.TP -\fBtcl::idna decode\fR \fIhostname\fR -. -This command takes the name of a host that potentially contains -punycode-encoded character sequences, \fIhostname\fR, and returns the hostname -as might be displayed to the user. Note that there are often UNICODE -characters that have extremely similar glyphs, so care should be taken with -displaying hostnames to users. -.TP -\fBtcl::idna encode\fR \fIhostname\fR -. -This command takes the name of a host as might be displayed to the user, -\fIhostname\fR, and returns the version of the hostname with characters not -permitted in basic hostnames encoded with punycode. -.TP -\fBtcl::idna puny\fR \fIsubcommand ...\fR -. -This command provides direct access to the basic punycode encoder and -decoder. It supports two \fIsubcommand\fRs: -.RS -.TP -\fBtcl::idna puny decode\fR \fIstring\fR ?\fIcase\fR? -. -This command decodes the punycode-encoded string, \fIstring\fR, and returns -the result. If \fIcase\fR is provided, it is a boolean to make the case be -folded to upper case (if \fIcase\fR is true) or lower case (if \fIcase\fR is -false) during the decoding process; if omitted, no case transformation is -applied. -.TP -\fBtcl::idna puny encode\fR \fIstring\fR ?\fIcase\fR? -. -This command encodes the string, \fIstring\fR, and returns the -punycode-encoded version of the string. If \fIcase\fR is provided, it is a -boolean to make the case be folded to upper case (if \fIcase\fR is true) or -lower case (if \fIcase\fR is false) during the encoding process; if omitted, -no case transformation is applied. -.RE -.TP -\fBtcl::idna version\fR -. -This returns the version of the \fBtcl::idna\fR package. -.SH "EXAMPLE" -.PP -This is an example of how punycoding of a string works: -.PP -.CS -package require tcl::idna - -puts [\fBtcl::idna puny encode\fR "abc\(->def"] -# prints: \fIabcdef-kn2c\fR -puts [\fBtcl::idna puny decode\fR "abcdef-kn2c"] -# prints: \fIabc\(->def\fR -.CE -'\" TODO: show how it handles a real domain name -.SH "SEE ALSO" -http(n), cookiejar(n) -.SH KEYWORDS -internet, www -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/if.n ================================================================== --- doc/if.n +++ doc/if.n @@ -2,11 +2,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 if n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -36,53 +36,45 @@ \fIBodyN\fR may also be omitted as long as \fBelse\fR is omitted too. The return value from the command is the result of the body script that was executed, or an empty string if none of the expressions was non-zero and there was no \fIbodyN\fR. .SH EXAMPLES -.PP A simple conditional: -.PP .CS \fBif\fR {$vbl == 1} { puts "vbl is one" } .CE .PP With an \fBelse\fR-clause: -.PP .CS \fBif\fR {$vbl == 1} { - puts "vbl is one" + puts "vbl is one" } \fBelse\fR { - puts "vbl is not one" + puts "vbl is not one" } .CE .PP With an \fBelseif\fR-clause too: -.PP .CS \fBif\fR {$vbl == 1} { - puts "vbl is one" + puts "vbl is one" } \fBelseif\fR {$vbl == 2} { - puts "vbl is two" + puts "vbl is two" } \fBelse\fR { - puts "vbl is not one or two" + puts "vbl is not one or two" } .CE .PP Remember, expressions can be multi-line, but in that case it can be a good idea to use the optional \fBthen\fR keyword for clarity: -.PP .CS \fBif\fR { - $vbl == 1 - || $vbl == 2 - || $vbl == 3 + $vbl == 1 || $vbl == 2 || $vbl == 3 } \fBthen\fR { - puts "vbl is one, two or three" + puts "vbl is one, two or three" } .CE + .SH "SEE ALSO" expr(n), for(n), foreach(n) + .SH KEYWORDS boolean, conditional, else, false, if, true -'\" Local Variables: -'\" mode: nroff -'\" End: Index: doc/incr.n ================================================================== --- doc/incr.n +++ doc/incr.n @@ -2,20 +2,21 @@ '\" 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 incr n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME incr \- Increment the value of a variable .SH SYNOPSIS \fBincr \fIvarName \fR?\fIincrement\fR? .BE + .SH DESCRIPTION .PP Increments the value stored in the variable whose name is \fIvarName\fR. The value of the variable must be an integer. If \fIincrement\fR is supplied then its value (which must be an @@ -22,49 +23,39 @@ integer) is added to the value of variable \fIvarName\fR; otherwise 1 is added to \fIvarName\fR. The new value is stored as a decimal string in variable \fIvarName\fR and also returned as result. .PP +.VS 8.5 Starting with the Tcl 8.5 release, the variable \fIvarName\fR passed to \fBincr\fR may be unset, and in that case, it will be set to the value \fIincrement\fR or to the default increment value of \fB1\fR. -.VS TIP508 -If \fIvarName\fR indicate an element that does not exist of an array that has -a default value set, the sum of the default value and the \fIincrement\fR (or -1) will be stored in the array element. -.VE TIP508 +.VE 8.5 .SH EXAMPLES -.PP Add one to the contents of the variable \fIx\fR: -.PP .CS \fBincr\fR x .CE .PP Add 42 to the contents of the variable \fIx\fR: -.PP .CS \fBincr\fR x 42 .CE .PP Add the contents of the variable \fIy\fR to the contents of the variable \fIx\fR: -.PP .CS \fBincr\fR x $y .CE .PP Add nothing at all to the variable \fIx\fR (often useful for checking whether an argument to a procedure is actually integral and generating an error if it is not): -.PP .CS \fBincr\fR x 0 .CE + .SH "SEE ALSO" -expr(n), set(n) +expr(n) + .SH KEYWORDS add, increment, variable, value -.\" Local variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: Index: doc/info.n ================================================================== --- doc/info.n +++ doc/info.n @@ -1,710 +1,327 @@ '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies '\" Copyright (c) 1998-2000 Ajuba Solutions -'\" Copyright (c) 2007-2012 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH info n 8.4 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -info \- Information about the state of the Tcl interpreter +info \- Return information about the state of the Tcl interpreter .SH SYNOPSIS \fBinfo \fIoption \fR?\fIarg arg ...\fR? .BE + .SH DESCRIPTION .PP -Available commands: +This command provides information about various internals of the Tcl +interpreter. +The legal \fIoption\fRs (which may be abbreviated) are: .TP \fBinfo args \fIprocname\fR -. -Returns the names of the parameters to the procedure named \fIprocname\fR. +Returns a list containing the names of the arguments to procedure +\fIprocname\fR, in order. \fIProcname\fR must be the name of a +Tcl command procedure. .TP \fBinfo body \fIprocname\fR -. -Returns the body of the procedure named \fIprocname\fR. -.TP -\fBinfo class\fI subcommand class\fR ?\fIarg ...\fR -. -Returns information about the class named \fIclass\fR. -See \fBCLASS INTROSPECTION\fR below. +Returns the body of procedure \fIprocname\fR. \fIProcname\fR must be +the name of a Tcl command procedure. .TP \fBinfo cmdcount\fR -. -Returns the total number of commands evaluated in this interpreter. -.TP -\fBinfo cmdtype \fIcommandName\fR -.VS TIP426 -Returns a the type of the command named \fIcommandName\fR. -Built-in types are: -.RS -.IP \fBalias\fR -\fIcommandName\fR was created by \fBinterp alias\fR. -In a safe interpreter an alias is only visible if both the alias and the -target are visible. -.IP \fBcoroutine\fR -\fIcommandName\fR was created by \fBcoroutine\fR. -.IP \fBensemble\fR -\fIcommandName\fR was created by \fBnamespace ensemble\fR. -.IP \fBimport\fR -\fIcommandName\fR was created by \fBnamespace import\fR. -.IP \fBnative\fR -\fIcommandName\fR was created by the \fBTcl_CreateObjProc\fR -interface directly without further registration of the type of command. -.IP \fBobject\fR -\fIcommandName\fR is the public command that represents an -instance of \fBoo::object\fR or one of its subclasses. -.IP \fBprivateObject\fR -\fIcommandName\fR is the private command, \fBmy\fR by default, -that represents an instance of \fBoo::object\fR or one of its subclasses. -.IP \fBproc\fR -\fIcommandName\fR was created by \fBproc\fR. -.IP \fBinterp\fR -\fIcommandName\fR was created by \fBinterp create\fR. -.IP \fBzlibStream\fR -\fIcommandName\fR was created by \fBzlib stream\fR. -.PP -Other types may be also registered as well. See \fBTcl_RegisterCommandTypeName\fR. -.RE -.VE TIP426 +Returns a count of the total number of commands that have been invoked +in this interpreter. .TP \fBinfo commands \fR?\fIpattern\fR? -. -Returns the names of all commands visible in the current namespace. If -\fIpattern\fR is given, returns only those names that match according to -\fBstring match\fR. Only the last component of \fIpattern\fR is a pattern. -Other components identify a namespace. See \fBNAMESPACE RESOLUTION\fR in the -\fBnamespace\fR(n) documentation. +If \fIpattern\fR is not specified, +.\" Do not move this .VS above the .TP +.VS 8.5 +returns a list of names of all the Tcl commands visible +(i.e. executable without using a qualified name) to the current namespace, +including both the built-in commands written in C and +the command procedures defined using the \fBproc\fR command. +If \fIpattern\fR is specified, +only those names matching \fIpattern\fR are returned. +Matching is determined using the same rules as for \fBstring match\fR. +\fIpattern\fR can be a qualified name like \fBFoo::print*\fR. +That is, it may specify a particular namespace +using a sequence of namespace names separated by double colons (\fB::\fR), +and may have pattern matching special characters +at the end to specify a set of commands in that namespace. +If \fIpattern\fR is a qualified name, +the resulting list of command names has each one qualified with the name +of the specified namespace, and only the commands defined in the named +namespace are returned. +.\" Technically, most of this hasn't changed; that's mostly just the +.\" way it always worked. Hardly anyone knew that though. +.VE 8.5 .TP \fBinfo complete \fIcommand\fR -. -Returns 1 if \fIcommand\fR is a complete command, and \fB0\fR otherwise. -Typically used in line-oriented input environments -to allow users to type in commands that span multiple lines. -.TP -\fBinfo coroutine\fR -. -Returns the name of the current \fBcoroutine\fR, or the empty -string if there is no current coroutine or the current coroutine -has been deleted. -.TP -\fBinfo default \fIprocname parameter varname\fR -. -If the parameter \fIparameter\fR for the procedure named \fIprocname\fR has a -default value, stores that value in \fIvarname\fR and returns \fB1\fR. -Otherwise, returns \fB0\fR. -.TP -\fBinfo errorstack \fR?\fIinterp\fR? -. -Returns a description of the active command at each level for the -last error in the current interpreter, or in the interpreter named -\fIinterp\fR if given. -.RS -.PP -The description is a dictionary of tokens and parameters. Tokens are -currently either \fBCALL\fR, \fBUP\fR, or \fBINNER\fR, but other values may be -introduced in the future. \fBCALL\fR indicates a command call, and its -parameter is the corresponding \fBinfo level\fR \fB0\fR. \fBUP\fR indicates a -shift in variable frames generated by \fBuplevel\fR or similar, and applies to -the previous \fBCALL\fR item. Its parameter is the level offset. \fBINNER\fR -identifies the -.QW "inner context" , -which is the innermost atomic command or bytecode instruction that raised the -error, along with its arguments when available. While \fBCALL\fR and \fBUP\fR -provide a trail of the call path, \fBINNER\fR provides details of the offending -operation in the innermost procedure call, even to sub-expression -granularity. -.PP -This information is also present in the \fB\-errorstack\fR entry of the -options dictionary returned by 3-argument \fBcatch\fR; \fBinfo errorstack\fR -is a convenient way of retrieving it for uncaught errors at top-level in an -interactive \fBinterpreter\fR. -.RE -.TP -\fBinfo exists \fIvarName\fR -. -Returns \fB1\fR if a variable named \fIvarName\fR is visible and has been -defined, and \fB0\fR otherwise. -.TP -\fBinfo frame\fR ?\fIdepth\fR? -. -Returns the depth of the call to \fBinfo frame\fR itself. Otherwise, returns a -dictionary describing the active command at the \fIdepth\fR, which counts all -commands visible to \fBinfo level\fR, plus commands that don't create a new -level, such as \fBeval\fR, \fBsource\fR, or \fIuplevel\fR. The frame depth is -always greater than the current level. -.RS -.PP -If \fIdepth\fR is greater than \fB0\fR it is the frame at that depth. Otherwise -it is the number of frames up from the current frame. -.PP -As with \fBinfo level\fR and error traces, for nested commands like +Returns 1 if \fIcommand\fR is a complete Tcl command in the sense of +having no unclosed quotes, braces, brackets or array element names. +If the command does not appear to be complete then 0 is returned. +This command is typically used in line-oriented input environments +to allow users to type in commands that span multiple lines; if the +command is not complete, the script can delay evaluating it until additional +lines have been typed to complete the command. +.TP +\fBinfo default \fIprocname arg varname\fR +\fIProcname\fR must be the name of a Tcl command procedure and \fIarg\fR +must be the name of an argument to that procedure. If \fIarg\fR +does not have a default value then the command returns \fB0\fR. +Otherwise it returns \fB1\fR and places the default value of \fIarg\fR +into variable \fIvarname\fR. +.TP +\fBinfo exists \fIvarName\fR +Returns \fB1\fR if the variable named \fIvarName\fR exists in the +current context (either as a global or local variable) and has been +defined by being given a value, returns \fB0\fR otherwise. +.TP +\fBinfo frame\fR ?\fInumber\fR? +This command provides access to all frames on the stack, even those +hidden from \fBinfo level\fR. If \fInumber\fR is not specified, this +command returns a number giving the frame level of the command. This +is 1 if the command is invoked at top-level. If \fInumber\fR is +specified, then the result is a dictionary containing the location +information for the command at the \fInumber\fRed level on the stack. +.RS +.PP +If \fInumber\fR is positive (> 0) then it selects a particular stack +level (1 refers to the top-most active command, i.e., \fBinfo frame\fR +itself, 2 to the command it was called from, and so on); otherwise it +gives a level relative to the current command (0 refers to the current +command, i.e., \fBinfo frame\fR itself, -1 to its caller, and so on). +.PP +This is similar to how \fBinfo level\fR works, except that this +subcommand reports all frames, like \fBsource\fRd scripts, +\fBeval\fRs, \fBuplevel\fRs, etc. +.PP +Note that for nested commands, like .QW "foo [bar [x]]" , only .QW x -is seen by \fBinfo frame\fR invoked within +will be seen by an \fBinfo frame\fR invoked within .QW x . +This is the same as for \fBinfo level\fR and error stack traces. .PP -The dictionary may contain the following keys: +The result dictionary may contain the keys listed below, with the +specified meanings for their values: .TP \fBtype\fR -. -Always present. Possible values are \fBsource\fR, \fBproc\fR, +This entry is always present and describes the nature of the location +for the command. The recognized values are \fBsource\fR, \fBproc\fR, \fBeval\fR, and \fBprecompiled\fR. .RS .TP \fBsource\fR\0\0\0\0\0\0\0\0 -. -A script loaded via the \fBsource\fR +means that the command is found in a script loaded by the \fBsource\fR command. .TP \fBproc\fR\0\0\0\0\0\0\0\0 -. -The body of a procedure that could not be traced back to a -line in a particular script. +means that the command is found in dynamically created procedure body. .TP \fBeval\fR\0\0\0\0\0\0\0\0 -. -The body of a script provided to \fBeval\fR or \fBuplevel\fR. +means that the command is executed by \fBeval\fR or \fBuplevel\fR. .TP \fBprecompiled\fR\0\0\0\0\0\0\0\0 -. -A pre-compiled script (loadable by the package -\fBtbcload\fR), and no further information is available. +means that the command is found in a precompiled script (loadable by +the package \fBtbcload\fR), and no further information will be +available. .RE .TP \fBline\fR -. -The line number of of the command inside its script. Not available for -\fBprecompiled\fR commands. When the type is \fBsource\fR, the line number is -relative to the beginning of the file, whereas for the last two types it is -relative to the start of the script. +This entry provides the number of the line the command is at inside of +the script it is a part of. This information is not present for type +\fBprecompiled\fR. For type \fBsource\fR this information is counted +relative to the beginning of the file, whereas for the last two types +the line is counted relative to the start of the script. .TP \fBfile\fR -. -For type \fBsource\fR, provides the normalized path of the file that contains -the command. +This entry is present only for type \fBsource\fR. It provides the +normalized path of the file the command is in. .TP \fBcmd\fR -. -The command before substitutions were performed. +This entry provides the string representation of the command. This is +usually the unsubstituted form, however for commands which are a pure +list executed by eval it is the substituted form as they have no other +string representation. Care is taken that the pure-List property of +the latter is not spoiled. .TP \fBproc\fR -. -For type \fBprod\fR, the name of the procedure containing the command. +This entry is present only if the command is found in the body of a +regular Tcl procedure. It then provides the name of that procedure. .TP \fBlambda\fR -. -For a command in a script evaluated as the body of an unnamed routine via the -\fBapply\fR command, the definition of that routine. +This entry is present only if the command is found in the body of an +anonymous Tcl procedure, i.e. a lambda. It then provides the entire +definition of the lambda in question. .TP \fBlevel\fR -. -For a frame that corresponds to a level, (to be determined). -.PP -When a command can be traced to its literal definition in some script, e.g. -procedures nested in statically defined procedures, and literal eval scripts in -files or statically defined procedures, its type is \fBsource\fR and its -location is the absolute line number in the script. Otherwise, its type is -\fBproc\fR and its location is its line number within the body of the -procedure. -.PP -In contrast, procedure definitions and \fBeval\fR within a dynamically -\fBeval\fRuated environment count line numbers relative to the start of +This entry is present only if the queried frame has a corresponding +frame returned by \fBinfo level\fR. It provides the index of this +frame, relative to the current level (0 and negative numbers). +.PP +A thing of note is that for procedures statically defined in files the +locations of commands in their bodies will be reported with type +\fBsource\fR and absolute line numbers, and not as type +\fBproc\fR. The same is true for procedures nested in statically +defined procedures, and literal eval scripts in files or statically +defined procedures. +.PP +In contrast, a procedure definition or \fBeval\fR within a dynamically +\fBeval\fRuated environment count linenumbers relative to the start of their script, even if they would be able to count relative to the start of the outer dynamic script. That type of number usually makes more sense. .PP -A different way of describing this behaviour is that file-based +A different way of describing this behaviour is that file based locations are tracked as deeply as possible, and where this is not possible the lines are counted based on the smallest possible \fBeval\fR or procedure body, as that scope is usually easier to find than any dynamic outer scope. .PP The syntactic form \fB{*}\fR is handled like \fBeval\fR. I.e. if it -is given a literal list argument the system tracks the line number -within the list words as well, and otherwise all line numbers are +is given a literal list argument the system tracks the linenumber +within the list words as well, and otherwise all linenumbers are counted relative to the start of each word (smallest scope) .RE .TP \fBinfo functions \fR?\fIpattern\fR? -. -If \fIpattern\fR is not given, returns a list of all the math +If \fIpattern\fR is not specified, returns a list of all the math functions currently defined. -If \fIpattern\fR is given, returns only those names that match -\fIpattern\fR according to \fBstring match\fR. +If \fIpattern\fR is specified, only those functions whose name matches +\fIpattern\fR are returned. Matching is determined using the same +rules as for \fBstring match\fR. .TP \fBinfo globals \fR?\fIpattern\fR? -. -If \fIpattern\fR is not given, returns a list of all the names +If \fIpattern\fR is not specified, returns a list of all the names of currently-defined global variables. Global variables are variables in the global namespace. -If \fIpattern\fR is given, only those names matching \fIpattern\fR +If \fIpattern\fR is specified, only those names matching \fIpattern\fR are returned. Matching is determined using the same rules as for \fBstring match\fR. .TP \fBinfo hostname\fR -. -Returns the name of the current host. - -This name is not guaranteed to be the fully-qualified domain -name of the host. Where machines have several different names, as is +Returns the name of the computer on which this invocation is being +executed. +Note that this name is not guaranteed to be the fully qualified domain +name of the host. Where machines have several different names (as is common on systems with both TCP/IP (DNS) and NetBIOS-based networking -installed, it is the name that is suitable for TCP/IP networking that +installed,) it is the name that is suitable for TCP/IP networking that is returned. .TP -\fBinfo level\fR ?\fIlevel\fR? -. -If \fInumber\fR is not given, the level this routine was called from. -Otherwise returns the complete command active at the given level. If -\fInumber\fR is greater than \fB0\fR, it is the desired level. Otherwise, it -is \fInumber\fR levels up from the current level. A complete command is the -words in the command, with all subsitutions performed, meaning that it is a -list. See \fBuplevel\fR for more information on levels. +\fBinfo level\fR ?\fInumber\fR? +If \fInumber\fR is not specified, this command returns a number +giving the stack level of the invoking procedure, or 0 if the +command is invoked at top-level. If \fInumber\fR is specified, +then the result is a list consisting of the name and arguments for the +procedure call at level \fInumber\fR on the stack. If \fInumber\fR +is positive then it selects a particular stack level (1 refers +to the top-most active procedure, 2 to the procedure it called, and +so on); otherwise it gives a level relative to the current level +(0 refers to the current procedure, -1 to its caller, and so on). +See the \fBuplevel\fR command for more information on what stack +levels mean. .TP \fBinfo library\fR -. -Returns the value of \fBtcl_library\fR, which is the name of the library -directory in which the scripts distributed with Tcl scripts are stored. +Returns the name of the library directory in which standard Tcl +scripts are stored. +This is actually the value of the \fBtcl_library\fR +variable and may be changed by setting \fBtcl_library\fR. +See the \fBtclvars\fR manual entry for more information. .TP -\fBinfo loaded \fR?\fIinterp\fR? ?\fIpackage\fR? -. -Returns the name of each file loaded in \fIinterp\fR va \fBload\fR as part of -\fIpackage\fR . If \fIpackage\fR is not given, returns a list where each item -is the name of the loaded file and the name of the package for which the file -was loaded. For a statically-loaded package the name of the file is the empty -string. For \fIinterp\fR, the empty string is the current interpreter. +\fBinfo loaded \fR?\fIinterp\fR? +Returns a list describing all of the packages that have been loaded into +\fIinterp\fR with the \fBload\fR command. +Each list element is a sub-list with two elements consisting of the +name of the file from which the package was loaded and the name of +the package. +For statically-loaded packages the file name will be an empty string. +If \fIinterp\fR is omitted then information is returned for all packages +loaded in any interpreter in the process. +To get a list of just the packages in the current interpreter, specify +an empty string for the \fIinterp\fR argument. .TP \fBinfo locals \fR?\fIpattern\fR? -. -If \fIpattern\fR is given, returns the name of each local variable matching -\fIpattern\fR according to \fBstring match\fR. Otherwise, returns the name of -each local variable. A variables defined with the \fBglobal\fR, \fBupvar\fR or -\fBvariable\fR is not local. - +If \fIpattern\fR is not specified, returns a list of all the names +of currently-defined local variables, including arguments to the +current procedure, if any. +Variables defined with the \fBglobal\fR, \fBupvar\fR and +\fBvariable\fR commands will not be returned. +If \fIpattern\fR is specified, only those names matching \fIpattern\fR +are returned. Matching is determined using the same rules as for +\fBstring match\fR. .TP \fBinfo nameofexecutable\fR -. -Returns the absolute pathname of the program for the current interpreter. If -such a file can not be identified an empty string is returned. -.TP -\fBinfo object\fI subcommand object\fR ?\fIarg ...\fR -. -Returns information about the object named \fIobject\fR. \fIsubcommand\fR is -described \fBOBJECT INTROSPECTION\fR below. +Returns the full path name of the binary file from which the application +was invoked. If Tcl was unable to identify the file, then an empty +string is returned. .TP \fBinfo patchlevel\fR -. -Returns the value of the global variable \fBtcl_patchLevel\fR, in which the -exact version of the Tcl library initially stored. +Returns the value of the global variable \fBtcl_patchLevel\fR; see +the \fBtclvars\fR manual entry for more information. .TP \fBinfo procs \fR?\fIpattern\fR? -. -Returns the names of all visible procedures. If \fIpattern\fR is given, returns -only those names that match according to \fBstring match\fR. Only the final -component in \fIpattern\fR is actually considered a pattern. Any qualifying -components simply select a namespace. See \fBNAMESPACE RESOLUTION\fR in the -\fBnamespace\fR(n) documentation. +If \fIpattern\fR is not specified, returns a list of all the +names of Tcl command procedures in the current namespace. +If \fIpattern\fR is specified, +only those procedure names in the current namespace +matching \fIpattern\fR are returned. +Matching is determined using the same rules as for +\fBstring match\fR. +If \fIpattern\fR contains any namespace separators, they are used to +select a namespace relative to the current namespace (or relative to +the global namespace if \fIpattern\fR starts with \fB::\fR) to match +within; the matching pattern is taken to be the part after the last +namespace separator. .TP \fBinfo script\fR ?\fIfilename\fR? -. -Returns the pathname of the innermost script currently being evaluated, or the -empty string if no pathname can be determined. If \fIfilename\fR is given, -sets the return value of any future calls to \fBinfo script\fR for the duration -of the innermost active script. This is useful in virtual file system -applications. +If a Tcl script file is currently being evaluated (i.e. there is a +call to \fBTcl_EvalFile\fR active or there is an active invocation +of the \fBsource\fR command), then this command returns the name +of the innermost file being processed. If \fIfilename\fR is specified, +then the return value of this command will be modified for the +duration of the active invocation to return that name. This is +useful in virtual file system applications. +Otherwise the command returns an empty string. .TP \fBinfo sharedlibextension\fR -. -Returns the extension used on this platform for names of shared libraries, e.g. -\fB.so\fR under Solaris. Returns the empty string if shared libraries are not -supported on this platform. +Returns the extension used on this platform for the names of files +containing shared libraries (for example, \fB.so\fR under Solaris). +If shared libraries are not supported on this platform then an empty +string is returned. .TP \fBinfo tclversion\fR -. -Returns the value of the global variable \fBtcl_version\fR, in which the -major and minor version of the Tcl library are stored. +Returns the value of the global variable \fBtcl_version\fR; see +the \fBtclvars\fR manual entry for more information. .TP \fBinfo vars\fR ?\fIpattern\fR? -. -If \fIpattern\fR is not given, returns the names of all visible variables. If -\fIpattern\fR is given, returns only those names that match according to -\fBstring match\fR. Only the last component of \fIpattern\fR is a pattern. -Other components identify a namespace. See \fBNAMESPACE RESOLUTION\fR in the -\fBnamespace\fR(n) documentation. When \fIpattern\fR is a qualified name, -results are fully qualified. - -A variable that has declared but not yet defined is included in the results. -.SS "CLASS INTROSPECTION" -.PP -The following \fIsubcommand\fR values are supported by \fBinfo class\fR: -.TP -\fBinfo class call\fI class method\fR -. -Returns a description of the method implementations that are used to provide a -stereotypical instance of \fIclass\fR's implementation of \fImethod\fR -(stereotypical instances being objects instantiated by a class without having -any object-specific definitions added). This consists of a list of lists of -four elements, where each sublist consists of a word that describes the -general type of method implementation (being one of \fBmethod\fR for an -ordinary method, \fBfilter\fR for an applied filter, -.VS TIP500 -\fBprivate\fR for a private method, -.VE TIP500 -and \fBunknown\fR for a -method that is invoked as part of unknown method handling), a word giving the -name of the particular method invoked (which is always the same as -\fImethod\fR for the \fBmethod\fR type, and -.QW \fBunknown\fR -for the \fBunknown\fR type), a word giving the fully qualified name of the -class that defined the method, and a word describing the type of method -implementation (see \fBinfo class methodtype\fR). -.RS -.PP -Note that there is no inspection of whether the method implementations -actually use \fBnext\fR to transfer control along the call chain, -.VS TIP500 -and the call chains that this command files do not actually contain private -methods. -.VE TIP500 -.RE -.TP -\fBinfo class constructor\fI class\fR -. -This subcommand returns a description of the definition of the constructor of -class \fIclass\fR. The definition is described as a two element list; the first -element is the list of arguments to the constructor in a form suitable for -passing to another call to \fBproc\fR or a method definition, and the second -element is the body of the constructor. If no constructor is present, this -returns the empty list. -.TP -\fBinfo class definition\fI class method\fR -. -This subcommand returns a description of the definition of the method named -\fImethod\fR of class \fIclass\fR. The definition is described as a two element -list; the first element is the list of arguments to the method in a form -suitable for passing to another call to \fBproc\fR or a method definition, and -the second element is the body of the method. -.TP -\fBinfo class definitionnamespace\fI class\fR ?\fIkind\fR? -.VS TIP524 -This subcommand returns the definition namespace for \fIkind\fR definitions of -the class \fIclass\fR; the definition namespace only affects the instances of -\fIclass\fR, not \fIclass\fR itself. The \fIkind\fR can be either -\fB\-class\fR to return the definition namespace used for \fBoo::define\fR, or -\fB\-instance\fR to return the definition namespace used for -\fBoo::objdefine\fR; the \fB\-class\fR kind is default (though this is only -actually useful on classes that are subclasses of \fBoo::class\fR). -.RS -.PP -If \fIclass\fR does not provide a definition namespace of the given kind, -this command returns the empty string. In those circumstances, the -\fBoo::define\fR and \fBoo::objdefine\fR commands look up which definition -namespace to use using the class inheritance hierarchy. -.RE -.VE TIP524 -.TP -\fBinfo class destructor\fI class\fR -. -This subcommand returns the body of the destructor of class \fIclass\fR. If no -destructor is present, this returns the empty string. -.TP -\fBinfo class filters\fI class\fR -. -This subcommand returns the list of filter methods set on the class. -.TP -\fBinfo class forward\fI class method\fR -. -This subcommand returns the argument list for the method forwarding called -\fImethod\fR that is set on the class called \fIclass\fR. -.TP -\fBinfo class instances\fI class\fR ?\fIpattern\fR? -. -This subcommand returns a list of instances of class \fIclass\fR. If the -optional \fIpattern\fR argument is present, it constrains the list of returned -instances to those that match it according to the rules of \fBstring match\fR. -.TP -\fBinfo class methods\fI class\fR ?\fIoptions...\fR? -. -This subcommand returns a list of all public (i.e. exported) methods of the -class called \fIclass\fR. Any of the following \fIoption\fRs may be -given, controlling exactly which method names are returned: -.RS -.TP -\fB\-all\fR -. -If the \fB\-all\fR flag is given, -.VS TIP500 -and the \fB\-scope\fR flag is not given, -.VE TIP500 -the list of methods will include those -methods defined not just by the class, but also by the class's superclasses -and mixins. -.TP -\fB\-private\fR -. -If the \fB\-private\fR flag is given, -.VS TIP500 -and the \fB\-scope\fR flag is not given, -.VE TIP500 -the list of methods will also include -the non-exported methods of the class (and superclasses and -mixins, if \fB\-all\fR is also given). -.VS TIP500 -Note that this naming is an unfortunate clash with true private methods; this -option name is retained for backward compatibility. -.VE TIP500 -.TP -\fB\-scope\fI scope\fR -.VS TIP500 -Returns a list of all methods on \fIclass\fR that have the given visibility -\fIscope\fR. When this option is supplied, both the \fB\-all\fR and -\fB\-private\fR options are ignored. The valid values for \fIscope\fR are: -.RS -.IP \fBpublic\fR 3 -Only methods with \fIpublic\fR scope (i.e., callable from anywhere by any instance -of this class) are to be returned. -.IP \fBunexported\fR 3 -Only methods with \fIunexported\fR scope (i.e., only callable via \fBmy\fR) are to -be returned. -.IP \fBprivate\fR 3 -Only methods with \fIprivate\fR scope (i.e., only callable from within this class's -methods) are to be returned. -.RE -.VE TIP500 -.RE -.TP -\fBinfo class methodtype\fI class method\fR -. -This subcommand returns a description of the type of implementation used for -the method named \fImethod\fR of class \fIclass\fR. When the result is -\fBmethod\fR, further information can be discovered with \fBinfo class -definition\fR, and when the result is \fBforward\fR, further information can -be discovered with \fBinfo class forward\fR. -.TP -\fBinfo class mixins\fI class\fR -. -This subcommand returns a list of all classes that have been mixed into the -class named \fIclass\fR. -.TP -\fBinfo class subclasses\fI class\fR ?\fIpattern\fR? -. -This subcommand returns a list of direct subclasses of class \fIclass\fR. If -the optional \fIpattern\fR argument is present, it constrains the list of -returned classes to those that match it according to the rules of +If \fIpattern\fR is not specified, +returns a list of all the names of currently-visible variables. +This includes locals and currently-visible globals. +If \fIpattern\fR is specified, only those names matching \fIpattern\fR +are returned. Matching is determined using the same rules as for \fBstring match\fR. -.TP -\fBinfo class superclasses\fI class\fR -. -This subcommand returns a list of direct superclasses of class \fIclass\fR in -inheritance precedence order. -.TP -\fBinfo class variables\fI class\fR ?\fB\-private\fR? -. -This subcommand returns a list of all variables that have been declared for -the class named \fIclass\fR (i.e. that are automatically present in the -class's methods, constructor and destructor). -.VS TIP500 -If the \fB\-private\fR option is given, this lists the private variables -declared instead. -.VE TIP500 -.SS "OBJECT INTROSPECTION" -.PP -The following \fIsubcommand\fR values are supported by \fBinfo object\fR: -.TP -\fBinfo object call\fI object method\fR -. -Returns a description of the method implementations that are used to provide -\fIobject\fR's implementation of \fImethod\fR. This consists of a list of -lists of four elements, where each sublist consists of a word that describes -the general type of method implementation (being one of \fBmethod\fR for an -ordinary method, \fBfilter\fR for an applied filter, -.VS TIP500 -\fBprivate\fR for a private method, -.VE TIP500 -and \fBunknown\fR for a -method that is invoked as part of unknown method handling), a word giving the -name of the particular method invoked (which is always the same as -\fImethod\fR for the \fBmethod\fR type, and -.QW \fBunknown\fR -for the \fBunknown\fR type), a word giving what defined the method (the fully -qualified name of the class, or the literal string \fBobject\fR if the method -implementation is on an instance), and a word describing the type of method -implementation (see \fBinfo object methodtype\fR). -.RS -.PP -Note that there is no inspection of whether the method implementations -actually use \fBnext\fR to transfer control along the call chain, -.VS TIP500 -and the call chains that this command files do not actually contain private -methods. -.VE TIP500 -.RE -.TP -\fBinfo object class\fI object\fR ?\fIclassName\fR? -. -If \fIclassName\fR is not given, this subcommand returns class of the -\fIobject\fR object. If \fIclassName\fR is present, this subcommand returns a -boolean value indicating whether the \fIobject\fR is of that class. -.TP -\fBinfo object creationid\fI object\fR -.VS TIP500 -Returns the unique creation identifier for the \fIobject\fR object. This -creation identifier is unique to the object (within a Tcl interpreter) and -cannot be controlled at object creation time or altered afterwards. -.RS -.PP -\fIImplementation note:\fR the creation identifier is used to generate unique -identifiers associated with the object, especially for private variables. -.RE -.VE TIP500 -.TP -\fBinfo object definition\fI object method\fR -. -This subcommand returns a description of the definition of the method named -\fImethod\fR of object \fIobject\fR. The definition is described as a two -element list; the first element is the list of arguments to the method in a -form suitable for passing to another call to \fBproc\fR or a method definition, -and the second element is the body of the method. -.TP -\fBinfo object filters\fI object\fR -. -This subcommand returns the list of filter methods set on the object. -.TP -\fBinfo object forward\fI object method\fR -. -This subcommand returns the argument list for the method forwarding called -\fImethod\fR that is set on the object called \fIobject\fR. -.TP -\fBinfo object isa\fI category object\fR ?\fIarg\fR? -. -This subcommand tests whether an object belongs to a particular category, -returning a boolean value that indicates whether the \fIobject\fR argument -meets the criteria for the category. The supported categories are: -.RS -.TP -\fBinfo object isa class\fI object\fR -. -This returns whether \fIobject\fR is a class (i.e. an instance of -\fBoo::class\fR or one of its subclasses). -.TP -\fBinfo object isa metaclass\fI object\fR -. -This returns whether \fIobject\fR is a class that can manufacture classes -(i.e. is \fBoo::class\fR or a subclass of it). -.TP -\fBinfo object isa mixin\fI object class\fR -. -This returns whether \fIclass\fR is directly mixed into \fIobject\fR. -.TP -\fBinfo object isa object\fI object\fR -. -This returns whether \fIobject\fR really is an object. -.TP -\fBinfo object isa typeof\fI object class\fR -. -This returns whether \fIclass\fR is the type of \fIobject\fR (i.e. whether -\fIobject\fR is an instance of \fIclass\fR or one of its subclasses, whether -direct or indirect). -.RE -.TP -\fBinfo object methods\fI object\fR ?\fIoption...\fR? -. -This subcommand returns a list of all public (i.e. exported) methods of the -object called \fIobject\fR. Any of the following \fIoption\fRs may be -given, controlling exactly which method names are returned: -.RS -.TP -\fB\-all\fR -. -If the \fB\-all\fR flag is given, -.VS TIP500 -and the \fB\-scope\fR flag is not given, -.VE TIP500 -the list of methods will include those -methods defined not just by the object, but also by the object's class and -mixins, plus the superclasses of those classes. -.TP -\fB\-private\fR -. -If the \fB\-private\fR flag is given, -.VS TIP500 -and the \fB\-scope\fR flag is not given, -.VE TIP500 -the list of methods will also include -the non-exported methods of the object (and classes, if -\fB\-all\fR is also given). -.VS TIP500 -Note that this naming is an unfortunate clash with true private methods; this -option name is retained for backward compatibility. -.VE TIP500 -.TP -\fB\-scope\fI scope\fR -.VS TIP500 -Returns a list of all methods on \fIobject\fR that have the given visibility -\fIscope\fR. When this option is supplied, both the \fB\-all\fR and -\fB\-private\fR options are ignored. The valid values for \fIscope\fR are: -.RS -.IP \fBpublic\fR 3 -Only methods with \fIpublic\fR scope (i.e., callable from anywhere) are to be -returned. -.IP \fBunexported\fR 3 -Only methods with \fIunexported\fR scope (i.e., only callable via \fBmy\fR) are to -be returned. -.IP \fBprivate\fR 3 -Only methods with \fIprivate\fR scope (i.e., only callable from within this object's -instance methods) are to be returned. -.RE -.VE TIP500 -.RE -.TP -\fBinfo object methodtype\fI object method\fR -. -This subcommand returns a description of the type of implementation used for -the method named \fImethod\fR of object \fIobject\fR. When the result is -\fBmethod\fR, further information can be discovered with \fBinfo object -definition\fR, and when the result is \fBforward\fR, further information can -be discovered with \fBinfo object forward\fR. -.TP -\fBinfo object mixins\fI object\fR -. -This subcommand returns a list of all classes that have been mixed into the -object named \fIobject\fR. -.TP -\fBinfo object namespace\fI object\fR -. -This subcommand returns the name of the internal namespace of the object named -\fIobject\fR. -.TP -\fBinfo object variables\fI object\fRR ?\fB\-private\fR? -. -This subcommand returns a list of all variables that have been declared for -the object named \fIobject\fR (i.e. that are automatically present in the -object's methods). -.VS TIP500 -If the \fB\-private\fR option is given, this lists the private variables -declared instead. -.VE TIP500 -.TP -\fBinfo object vars\fI object\fR ?\fIpattern\fR? -. -This subcommand returns a list of all variables in the private namespace of -the object named \fIobject\fR. If the optional \fIpattern\fR argument is -given, it is a filter (in the syntax of a \fBstring match\fR glob pattern) -that constrains the list of variables returned. Note that this is different -from the list returned by \fBinfo object variables\fR; that can include -variables that are currently unset, whereas this can include variables that -are not automatically included by any of \fIobject\fR's methods (or those of -its class, superclasses or mixins). -.SH EXAMPLES -.PP +\fIpattern\fR can be a qualified name like \fBFoo::option*\fR. +That is, it may specify a particular namespace +using a sequence of namespace names separated by double colons (\fB::\fR), +and may have pattern matching special characters +at the end to specify a set of variables in that namespace. +If \fIpattern\fR is a qualified name, +the resulting list of variable names +has each matching namespace variable qualified with the name +of its namespace. +Note that a currently-visible variable may not yet +.QW exist +if it has not +been set (e.g. a variable declared but not set by \fBvariable\fR). +.SH EXAMPLE This command prints out a procedure suitable for saving in a Tcl script: .PP .CS proc printProc {procName} { @@ -719,78 +336,13 @@ lappend formals [list $var] } } puts [lappend result $formals [\fBinfo body\fR $procName]] } -.CE -.SS "EXAMPLES WITH OBJECTS" -.PP -Every object necessarily knows what its class is; this information is -trivially extractable through introspection: -.PP -.CS -oo::class create c -c create o -puts [\fBinfo object class\fR o] - \fI\(-> prints "::c"\fR -puts [\fBinfo object class\fR c] - \fI\(-> prints "::oo::class"\fR -.CE -.PP -The introspection capabilities can be used to discover what class implements a -method and get how it is defined. This procedure illustrates how: -.PP -.CS -proc getDef {obj method} { - foreach inf [\fBinfo object call\fR $obj $method] { - lassign $inf calltype name locus methodtype - - # Assume no forwards or filters, and hence no $calltype - # or $methodtype checks... - - if {$locus eq "object"} { - return [\fBinfo object definition\fR $obj $name] - } else { - return [\fBinfo class definition\fR $locus $name] - } - } - error "no definition for $method" -} -.CE -.PP -This is an alternate way of looking up the definition; it is implemented by -manually scanning the list of methods up the inheritance tree. This code -assumes that only single inheritance is in use, and that there is no complex -use of mixed-in classes (in such cases, using \fBinfo object call\fR as above -is the simplest way of doing this by far): -.PP -.CS -proc getDef {obj method} { - if {$method in [\fBinfo object methods\fR $obj]} { - # Assume no forwards - return [\fBinfo object definition\fR $obj $method] - } - - set cls [\fBinfo object class\fR $obj] - - while {$method ni [\fBinfo class methods\fR $cls]} { - # Assume the simple case - set cls [lindex [\fBinfo class superclass\fR $cls] 0] - if {$cls eq ""} { - error "no definition for $method" - } - } - - # Assume no forwards - return [\fBinfo class definition\fR $cls $method] -} .CE .SH "SEE ALSO" -global(n), oo::class(n), oo::define(n), oo::object(n), proc(n), self(n), -tcl_library(n), tcl_patchLevel(n), tcl_version(n) +global(n), proc(n) .SH KEYWORDS -command, information, interpreter, introspection, level, namespace, -object, procedure, variable -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: +command, information, interpreter, level, namespace, procedure, variable +.\" Local Variables: +.\" mode: nroff +.\" End: Index: doc/interp.n ================================================================== --- doc/interp.n +++ doc/interp.n @@ -1,14 +1,13 @@ '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" Copyright (c) 2004 Donal K. Fellows -'\" Copyright (c) 2006-2008 Joe Mistachkin. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH interp n 8.6 Tcl "Tcl Built-In Commands" +'\" +.TH interp n 7.6 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME interp \- Create and manipulate Tcl interpreters @@ -17,33 +16,36 @@ .BE .SH DESCRIPTION .PP This command makes it possible to create one or more new Tcl interpreters that co-exist with the creating interpreter in the -same application. The creating interpreter is called the \fIparent\fR -and the new interpreter is called a \fIchild\fR. -A parent can create any number of children, and each child can -itself create additional children for which it is parent, resulting +same application. The creating interpreter is called the \fImaster\fR +and the new interpreter is called a \fIslave\fR. +A master can create any number of slaves, and each slave can +itself create additional slaves for which it is master, resulting in a hierarchy of interpreters. .PP Each interpreter is independent from the others: it has its own name space for commands, procedures, and global variables. -A parent interpreter may create connections between its children and +A master interpreter may create connections between its slaves and itself using a mechanism called an \fIalias\fR. An \fIalias\fR is -a command in a child interpreter which, when invoked, causes a -command to be invoked in its parent interpreter or in another child +a command in a slave interpreter which, when invoked, causes a +command to be invoked in its master interpreter or in another slave interpreter. The only other connections between interpreters are through environment variables (the \fBenv\fR variable), which are normally shared among all interpreters in the application, -and by resource limit exceeded callbacks. Note that the +.VS 8.5 +and by resource limit exceeded callbacks. +.VE 8.5 +Note that the name space for files (such as the names returned by the \fBopen\fR command) is no longer shared between interpreters. Explicit commands are provided to share files and to transfer references to open files from one interpreter to another. .PP The \fBinterp\fR command also provides support for \fIsafe\fR -interpreters. A safe interpreter is a child whose functions have +interpreters. A safe interpreter is a slave whose functions have been greatly restricted, so that it is safe to execute untrusted scripts without fear of them damaging other interpreters or the application's environment. For example, all IO channel creation commands and subprocess creation commands are made inaccessible to safe interpreters. @@ -52,78 +54,65 @@ The dangerous functionality is not removed from the safe interpreter; instead, it is \fIhidden\fR, so that only trusted interpreters can obtain access to it. For a detailed explanation of hidden commands, see \fBHIDDEN COMMANDS\fR, below. The alias mechanism can be used for protected communication (analogous to a -kernel call) between a child interpreter and its parent. +kernel call) between a slave interpreter and its master. See \fBALIAS INVOCATION\fR, below, for more details on how the alias mechanism works. .PP -A qualified interpreter name is a proper Tcl list containing a subset of its +A qualified interpreter name is a proper Tcl lists containing a subset of its ancestors in the interpreter hierarchy, terminated by the string naming the -interpreter in its immediate parent. Interpreter names are relative to the -interpreter in which they are used. For example, if -.QW \fBa\fR -is a child of the current interpreter and it has a child -.QW \fBa1\fR , -which in turn has a child -.QW \fBa11\fR , -the qualified name of -.QW \fBa11\fR -in -.QW \fBa\fR -is the list -.QW "\fBa1 a11\fR" . +interpreter in its immediate master. Interpreter names are relative to the +interpreter in which they are used. For example, if \fBa\fR is a slave of +the current interpreter and it has a slave \fBa1\fR, which in turn has a +slave \fBa11\fR, the qualified name of \fBa11\fR in \fBa\fR is the list +\fBa1 a11\fR. .PP The \fBinterp\fR command, described below, accepts qualified interpreter names as arguments; the interpreter in which the command is being evaluated can always be referred to as \fB{}\fR (the empty list or string). Note that -it is impossible to refer to a parent (ancestor) interpreter by name in a -child interpreter except through aliases. Also, there is no global name by +it is impossible to refer to a master (ancestor) interpreter by name in a +slave interpreter except through aliases. Also, there is no global name by which one can refer to the first interpreter created in an application. Both restrictions are motivated by safety concerns. .SH "THE INTERP COMMAND" .PP The \fBinterp\fR command is used to create, delete, and manipulate -child interpreters, and to share or transfer +slave interpreters, and to share or transfer channels between interpreters. It can have any of several forms, depending on the \fIsubcommand\fR argument: .TP \fBinterp\fR \fBalias\fR \fIsrcPath\fR \fIsrcToken\fR -. Returns a Tcl list whose elements are the \fItargetCmd\fR and \fIarg\fRs associated with the alias represented by \fIsrcToken\fR (this is the value returned when the alias was created; it is possible that the name of the source command in the -child is different from \fIsrcToken\fR). +slave is different from \fIsrcToken\fR). .TP \fBinterp\fR \fBalias\fR \fIsrcPath\fR \fIsrcToken\fR \fB{}\fR -. -Deletes the alias for \fIsrcToken\fR in the child interpreter identified by +Deletes the alias for \fIsrcToken\fR in the slave interpreter identified by \fIsrcPath\fR. \fIsrcToken\fR refers to the value returned when the alias was created; if the source command has been renamed, the renamed command will be deleted. .TP \fBinterp\fR \fBalias\fR \fIsrcPath\fR \fIsrcCmd\fR \fItargetPath\fR \fItargetCmd \fR?\fIarg arg ...\fR? -. -This command creates an alias between one child and another (see the -\fBalias\fR child command below for creating aliases between a child -and its parent). In this command, either of the child interpreters +This command creates an alias between one slave and another (see the +\fBalias\fR slave command below for creating aliases between a slave +and its master). In this command, either of the slave interpreters may be anywhere in the hierarchy of interpreters under the interpreter invoking the command. \fISrcPath\fR and \fIsrcCmd\fR identify the source of the alias. \fISrcPath\fR is a Tcl list whose elements select a particular interpreter. For example, .QW "\fBa b\fR" identifies an interpreter -.QW \fBb\fR , -which is a child of interpreter -.QW \fBa\fR , -which is a child of the invoking interpreter. An empty list specifies -the interpreter invoking the command. \fIsrcCmd\fR gives the name of -a new command, which will be created in the source interpreter. +\fBb\fR, which is a slave of interpreter \fBa\fR, which is a slave +of the invoking interpreter. An empty list specifies the interpreter +invoking the command. \fIsrcCmd\fR gives the name of a new +command, which will be created in the source interpreter. \fITargetPath\fR and \fItargetCmd\fR specify a target interpreter and command, and the \fIarg\fR arguments, if any, specify additional arguments to \fItargetCmd\fR which are prepended to any arguments specified in the invocation of \fIsrcCmd\fR. \fITargetCmd\fR may be undefined at the time of this call, or it may @@ -135,77 +124,62 @@ The command returns a token that uniquely identifies the command created \fIsrcCmd\fR, even if the command is renamed afterwards. The token may but does not have to be equal to \fIsrcCmd\fR. .TP \fBinterp\fR \fBaliases \fR?\fIpath\fR? -. This command returns a Tcl list of the tokens of all the source commands for aliases defined in the interpreter identified by \fIpath\fR. The tokens correspond to the values returned when the aliases were created (which may not be the same as the current names of the commands). .TP \fBinterp bgerror \fIpath\fR ?\fIcmdPrefix\fR? -. -This command either gets or sets the current background exception handler +.VS 8.5 +This command either gets or sets the current background error handler for the interpreter identified by \fIpath\fR. If \fIcmdPrefix\fR is -absent, the current background exception handler is returned, and if it is +absent, the current background error 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. +what to set the interpreter's background error to. See the +\fBBACKGROUND ERROR HANDLING\fR section for more details. +.VE 8.5 .TP \fBinterp\fR \fBcreate \fR?\fB\-safe\fR? ?\fB\-\|\-\fR? ?\fIpath\fR? -. -Creates a child interpreter identified by \fIpath\fR and a new command, -called a \fIchild command\fR. The name of the child command is the last -component of \fIpath\fR. The new child interpreter and the child command +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 the last component from \fIpath\fR. For example, if \fIpath\fR is \fBa b -c\fR then a new child interpreter and child command named \fBc\fR are +c\fR then a new slave interpreter and slave command named \fBc\fR are created in the interpreter identified by the path \fBa b\fR. -The child command may be used to manipulate the new interpreter as +The slave command may be used to manipulate the new interpreter as described below. If \fIpath\fR is omitted, Tcl creates a unique name of the form \fBinterp\fIx\fR, where \fIx\fR is an integer, and uses it for the -interpreter and the child command. If the \fB\-safe\fR switch is specified -(or if the parent interpreter is a safe interpreter), the new child +interpreter and the slave command. If the \fB\-safe\fR switch is specified +(or if the master interpreter is a safe interpreter), the new slave interpreter will be created as a safe interpreter with limited -functionality; otherwise the child will include the full set of Tcl +functionality; otherwise the slave will include the full set of Tcl built-in commands and variables. The \fB\-\|\-\fR switch can be used to mark the end of switches; it may be needed if \fIpath\fR is an unusual value such as \fB\-safe\fR. The result of the command is the name of the -new interpreter. The name of a child interpreter must be unique among all -the children for its parent; an error occurs if a child interpreter by the -given name already exists in this parent. -The initial recursion limit of the child interpreter is set to the +new interpreter. The name of a slave interpreter must be unique among all +the slaves for its master; an error occurs if a slave interpreter by the +given name already exists in this master. +The initial recursion limit of the slave interpreter is set to the current recursion limit of its parent interpreter. .TP -\fBinterp\fR \fBdebug \fIpath\fR ?\fB\-frame\fR ?\fIbool\fR?? +\fBinterp\fR \fBdebug \fIpath\fR ?\fI\-frame\fR ?\fIbool\fR?? . Controls whether frame-level stack information is captured in the -child interpreter identified by \fIpath\fR. If no arguments are -given, option and current setting are returned. If \fB\-frame\fR +slave interpreter identified by \fIpath\fR. If no arguments are +given, option and current setting are returned. If \fI\-frame\fR is given, the debug setting is set to the given boolean if provided and the current setting is returned. -This only affects the output of \fBinfo frame\fR, in that exact +This only effects the output of \fBinfo frame\fR, in that exact frame-level information for command invocation at the bytecode level is only captured with this setting on. -.RS .PP +.RS For example, with code like .PP .CS \fBproc\fR mycontrol {... script} { ... @@ -226,46 +200,38 @@ \fBeval\fR. With frame-debug active on the other hand the tracking extends so far that the system will be able to determine the file and absolute line number of this command, and return a frame of type \fBsource\fR. This more exact information is paid for with slower execution of all commands. -.PP -Note that once it is on, this flag cannot be switched back off: such -attempts are silently ignored. This is needed to maintain the -consistency of the underlying interpreter's state. .RE .TP -\fBinterp\fR \fBdelete \fR?\fIpath ...\fR? -. +\fBinterp\fR \fBdelete \fR?\fIpath ...?\fR Deletes zero or more interpreters given by the optional \fIpath\fR -arguments, and for each interpreter, it also deletes its children. The -command also deletes the child command for each interpreter deleted. +arguments, and for each interpreter, it also deletes its slaves. The +command also deletes the slave command for each interpreter deleted. For each \fIpath\fR argument, if no interpreter by that name exists, the command raises an error. .TP \fBinterp\fR \fBeval\fR \fIpath arg \fR?\fIarg ...\fR? -. This command concatenates all of the \fIarg\fR arguments in the same fashion as the \fBconcat\fR command, then evaluates the resulting string as -a Tcl script in the child interpreter identified by \fIpath\fR. The result +a Tcl script in the slave interpreter identified by \fIpath\fR. The result of this evaluation (including all \fBreturn\fR options, such as \fB\-errorinfo\fR and \fB\-errorcode\fR information, if an error occurs) is returned to the invoking interpreter. Note that the script will be executed in the current context stack frame of the -\fIpath\fR interpreter; this is so that the implementations (in a parent -interpreter) of aliases in a child interpreter can execute scripts in -the child that find out information about the child's current state +\fIpath\fR interpreter; this is so that the implementations (in a master +interpreter) of aliases in a slave interpreter can execute scripts in +the slave that find out information about the slave's current state and stack frame. .TP \fBinterp exists \fIpath\fR -. -Returns \fB1\fR if a child interpreter by the specified \fIpath\fR -exists in this parent, \fB0\fR otherwise. If \fIpath\fR is omitted, the +Returns \fB1\fR if a slave interpreter by the specified \fIpath\fR +exists in this master, \fB0\fR otherwise. If \fIpath\fR is omitted, the invoking interpreter is used. .TP \fBinterp expose \fIpath\fR \fIhiddenName\fR ?\fIexposedCmdName\fR? -. Makes the hidden command \fIhiddenName\fR exposed, eventually bringing it back under a new \fIexposedCmdName\fR name (this name is currently accepted only if it is a valid global name space name without any ::), in the interpreter denoted by \fIpath\fR. @@ -272,11 +238,10 @@ If an exposed command with the targeted name already exists, this command fails. Hidden commands are explained in more detail in \fBHIDDEN COMMANDS\fR, below. .TP \fBinterp\fR \fBhide\fR \fIpath\fR \fIexposedCmdName\fR ?\fIhiddenCmdName\fR? -. Makes the exposed command \fIexposedCmdName\fR hidden, renaming it to the hidden command \fIhiddenCmdName\fR, or keeping the same name if \fIhiddenCmdName\fR is not given, in the interpreter denoted by \fIpath\fR. If a hidden command with the targeted name already exists, this command @@ -283,21 +248,19 @@ fails. Currently both \fIexposedCmdName\fR and \fIhiddenCmdName\fR can not contain namespace qualifiers, or an error is raised. Commands to be hidden by \fBinterp hide\fR are looked up in the global namespace even if the current namespace is not the global one. This -prevents children from fooling a parent interpreter into hiding the wrong +prevents slaves from fooling a master interpreter into hiding the wrong command, by making the current namespace be different from the global one. Hidden commands are explained in more detail in \fBHIDDEN COMMANDS\fR, below. .TP \fBinterp\fR \fBhidden\fR \fIpath\fR -. Returns a list of the names of all hidden commands in the interpreter identified by \fIpath\fR. .TP \fBinterp\fR \fBinvokehidden\fR \fIpath\fR ?\fI\-option ...\fR? \fIhiddenCmdName\fR ?\fIarg ...\fR? -. Invokes the hidden command \fIhiddenCmdName\fR with the arguments supplied in the interpreter denoted by \fIpath\fR. No substitutions or evaluation are applied to the arguments. Three \fI\-option\fRs are supported, all of which start with \fB\-\fR: \fB\-namespace\fR (which takes a single argument afterwards, \fInsName\fR), \fB\-global\fR, and \fB\-\|\-\fR. @@ -314,39 +277,37 @@ \fB\-namespace\fR flag is ignored. Note that the hidden command will be executed (by default) in the current context stack frame of the \fIpath\fR interpreter. Hidden commands are explained in more detail in \fBHIDDEN COMMANDS\fR, below. .TP -\fBinterp issafe\fR ?\fIpath\fR? -. -Returns \fB1\fR if the interpreter identified by the specified \fIpath\fR -is safe, \fB0\fR otherwise. -.TP \fBinterp\fR \fBlimit\fR \fIpath\fR \fIlimitType\fR ?\fI\-option\fR? ?\fIvalue\fR \fI...\fR? -. +.VS 8.5 Sets up, manipulates and queries the configuration of the resource limit \fIlimitType\fR for the interpreter denoted by \fIpath\fR. If no \fI\-option\fR is specified, return the current configuration of the limit. If \fI\-option\fR is the sole argument, return the value of that option. Otherwise, a list of \fI\-option\fR/\fIvalue\fR argument pairs must supplied. See \fBRESOURCE LIMITS\fR below for a more detailed explanation of what limits and options are supported. +.VE 8.5 +.TP +\fBinterp issafe\fR ?\fIpath\fR? +Returns \fB1\fR if the interpreter identified by the specified \fIpath\fR +is safe, \fB0\fR otherwise. .TP \fBinterp marktrusted\fR \fIpath\fR -. Marks the interpreter identified by \fIpath\fR as trusted. Does not expose the hidden commands. This command can only be invoked from a trusted interpreter. The command has no effect if the interpreter identified by \fIpath\fR is already trusted. .TP \fBinterp\fR \fBrecursionlimit\fR \fIpath\fR ?\fInewlimit\fR? -. Returns the maximum allowable nesting depth for the interpreter specified by \fIpath\fR. If \fInewlimit\fR is specified, the interpreter recursion limit will be set so that nesting -of more than \fInewlimit\fR calls to \fBTcl_Eval\fR +of more than \fInewlimit\fR calls to \fBTcl_Eval()\fR and related procedures in that interpreter will return an error. The \fInewlimit\fR value is also returned. The \fInewlimit\fR value must be a positive integer between 1 and the maximum value of a non-long integer on the platform. .RS @@ -358,27 +319,24 @@ this happens, see if there is a mechanism in your system for increasing the maximum size of the C stack. .RE .TP \fBinterp\fR \fBshare\fR \fIsrcPath channelId destPath\fR -. Causes the IO channel identified by \fIchannelId\fR to become shared between the interpreter identified by \fIsrcPath\fR and the interpreter identified by \fIdestPath\fR. Both interpreters have the same permissions on the IO channel. Both interpreters must close it to close the underlying IO channel; IO channels accessible in an interpreter are automatically closed when an interpreter is destroyed. .TP -\fBinterp\fR \fBchildren\fR ?\fIpath\fR? -. -Returns a Tcl list of the names of all the child interpreters associated +\fBinterp\fR \fBslaves\fR ?\fIpath\fR? +Returns a Tcl list of the names of all the slave interpreters associated with the interpreter identified by \fIpath\fR. If \fIpath\fR is omitted, the invoking interpreter is used. .TP \fBinterp\fR \fBtarget\fR \fIpath alias\fR -. Returns a Tcl list describing the target interpreter for an alias. The alias is specified with an interpreter path and source command name, just as in \fBinterp alias\fR above. The name of the target interpreter is returned as an interpreter path, relative to the invoking interpreter. If the target interpreter for the alias is the invoking interpreter then an @@ -385,165 +343,152 @@ empty list is returned. If the target interpreter for the alias is not the invoking interpreter or one of its descendants then an error is generated. The target command does not have to be defined at the time of this invocation. .TP \fBinterp\fR \fBtransfer\fR \fIsrcPath channelId destPath\fR -. Causes the IO channel identified by \fIchannelId\fR to become available in the interpreter identified by \fIdestPath\fR and unavailable in the interpreter identified by \fIsrcPath\fR. -.SH "CHILD COMMAND" +.SH "SLAVE COMMAND" .PP -For each child interpreter created with the \fBinterp\fR command, a -new Tcl command is created in the parent interpreter with the same +For each slave interpreter created with the \fBinterp\fR command, a +new Tcl command is created in the master interpreter with the same name as the new interpreter. This command may be used to invoke various operations on the interpreter. It has the following general form: -.PP .CS -\fIchild command \fR?\fIarg arg ...\fR? +\fIslave command \fR?\fIarg arg ...\fR? .CE -.PP -\fIChild\fR is the name of the interpreter, and \fIcommand\fR +\fISlave\fR is the name of the interpreter, and \fIcommand\fR and the \fIarg\fRs determine the exact behavior of the command. The valid forms of this command are: .TP -\fIchild \fBaliases\fR -. +\fIslave \fBaliases\fR Returns a Tcl list whose elements are the tokens of all the -aliases in \fIchild\fR. The tokens correspond to the values returned when +aliases in \fIslave\fR. The tokens correspond to the values returned when the aliases were created (which may not be the same as the current names of the commands). .TP -\fIchild \fBalias \fIsrcToken\fR -. +\fIslave \fBalias \fIsrcToken\fR Returns a Tcl list whose elements are the \fItargetCmd\fR and \fIarg\fRs associated with the alias represented by \fIsrcToken\fR (this is the value returned when the alias was created; it is possible that the actual source command in the -child is different from \fIsrcToken\fR). +slave is different from \fIsrcToken\fR). .TP -\fIchild \fBalias \fIsrcToken \fB{}\fR -. -Deletes the alias for \fIsrcToken\fR in the child interpreter. +\fIslave \fBalias \fIsrcToken \fB{}\fR +Deletes the alias for \fIsrcToken\fR in the slave interpreter. \fIsrcToken\fR refers to the value returned when the alias was created; if the source command has been renamed, the renamed command will be deleted. .TP -\fIchild \fBalias \fIsrcCmd targetCmd \fR?\fIarg ..\fR? -. +\fIslave \fBalias \fIsrcCmd targetCmd \fR?\fIarg ..\fR? Creates an alias such that whenever \fIsrcCmd\fR is invoked -in \fIchild\fR, \fItargetCmd\fR is invoked in the parent. +in \fIslave\fR, \fItargetCmd\fR is invoked in the master. The \fIarg\fR arguments will be passed to \fItargetCmd\fR as additional arguments, prepended before any arguments passed in the invocation of \fIsrcCmd\fR. See \fBALIAS INVOCATION\fR below for details. The command returns a token that uniquely identifies the command created \fIsrcCmd\fR, even if the command is renamed afterwards. The token may but does not have to be equal to \fIsrcCmd\fR. .TP -\fIchild \fBbgerror\fR ?\fIcmdPrefix\fR? -. -This command either gets or sets the current background exception handler -for the \fIchild\fR interpreter. If \fIcmdPrefix\fR is -absent, the current background exception handler is returned, and if it is +\fIslave \fBbgerror\fR ?\fIcmdPrefix\fR? +.VS 8.5 +This command either gets or sets the current background error handler +for the \fIslave\fR interpreter. If \fIcmdPrefix\fR is +absent, the current background error 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. +what to set the interpreter's background error to. See the +\fBBACKGROUND ERROR HANDLING\fR section for more details. +.VE 8.5 .TP -\fIchild \fBeval \fIarg \fR?\fIarg ..\fR? -. +\fIslave \fBeval \fIarg \fR?\fIarg ..\fR? This command concatenates all of the \fIarg\fR arguments in the same fashion as the \fBconcat\fR command, then evaluates -the resulting string as a Tcl script in \fIchild\fR. +the resulting string as a Tcl script in \fIslave\fR. The result of this evaluation (including all \fBreturn\fR options, such as \fB\-errorinfo\fR and \fB\-errorcode\fR information, if an error occurs) is returned to the invoking interpreter. Note that the script will be executed in the current context stack frame -of \fIchild\fR; this is so that the implementations (in a parent -interpreter) of aliases in a child interpreter can execute scripts in -the child that find out information about the child's current state +of \fIslave\fR; this is so that the implementations (in a master +interpreter) of aliases in a slave interpreter can execute scripts in +the slave that find out information about the slave's current state and stack frame. .TP -\fIchild \fBexpose \fIhiddenName \fR?\fIexposedCmdName\fR? -. +\fIslave \fBexpose \fIhiddenName \fR?\fIexposedCmdName\fR? This command exposes the hidden command \fIhiddenName\fR, eventually bringing it back under a new \fIexposedCmdName\fR name (this name is currently accepted only if it is a valid global name space name without any ::), -in \fIchild\fR. +in \fIslave\fR. If an exposed command with the targeted name already exists, this command fails. For more details on hidden commands, see \fBHIDDEN COMMANDS\fR, below. .TP -\fIchild \fBhide \fIexposedCmdName\fR ?\fIhiddenCmdName\fR? -. +\fIslave \fBhide \fIexposedCmdName\fR ?\fIhiddenCmdName\fR? This command hides the exposed command \fIexposedCmdName\fR, renaming it to the hidden command \fIhiddenCmdName\fR, or keeping the same name if the -argument is not given, in the \fIchild\fR interpreter. +argument is not given, in the \fIslave\fR interpreter. If a hidden command with the targeted name already exists, this command fails. Currently both \fIexposedCmdName\fR and \fIhiddenCmdName\fR can not contain namespace qualifiers, or an error is raised. Commands to be hidden are looked up in the global namespace even if the current namespace is not the global one. This -prevents children from fooling a parent interpreter into hiding the wrong +prevents slaves from fooling a master interpreter into hiding the wrong command, by making the current namespace be different from the global one. For more details on hidden commands, see \fBHIDDEN COMMANDS\fR, below. .TP -\fIchild \fBhidden\fR -. -Returns a list of the names of all hidden commands in \fIchild\fR. +\fIslave \fBhidden\fR +Returns a list of the names of all hidden commands in \fIslave\fR. .TP -\fIchild \fBinvokehidden\fR ?\fI\-option ...\fR? \fIhiddenName \fR?\fIarg ..\fR? -. +\fIslave \fBinvokehidden\fR ?\fI\-option ...\fR? \fIhiddenName \fR?\fIarg ..\fR? This command invokes the hidden command \fIhiddenName\fR with the -supplied arguments, in \fIchild\fR. No substitutions or evaluations are +supplied arguments, in \fIslave\fR. No substitutions or evaluations are applied to the arguments. Three \fI\-option\fRs are supported, all of which start with \fB\-\fR: \fB\-namespace\fR (which takes a single argument afterwards, \fInsName\fR), \fB\-global\fR, and \fB\-\|\-\fR. If the \fB\-namespace\fR flag is given, the hidden command is invoked in -the specified namespace in the child. +the specified namespace in the slave. If the \fB\-global\fR flag is given, the command is invoked at the global -level in the child; otherwise it is invoked at the current call frame and +level in the slave; otherwise it is invoked at the current call frame and can access local variables in that or outer call frames. The \fB\-\|\-\fR flag allows the \fIhiddenCmdName\fR argument to start with a .QW \- character, and is otherwise unnecessary. If both the \fB\-namespace\fR and \fB\-global\fR flags are given, the \fB\-namespace\fR flag is ignored. Note that the hidden command will be executed (by default) in the -current context stack frame of \fIchild\fR. +current context stack frame of \fIslave\fR. For more details on hidden commands, see \fBHIDDEN COMMANDS\fR, below. .TP -\fIchild \fBissafe\fR -. -Returns \fB1\fR if the child interpreter is safe, \fB0\fR otherwise. +\fIslave \fBissafe\fR +Returns \fB1\fR if the slave interpreter is safe, \fB0\fR otherwise. .TP -\fIchild \fBlimit\fR \fIlimitType\fR ?\fI\-option\fR? ?\fIvalue\fR \fI...\fR? -. +\fIslave \fBlimit\fR \fIlimitType\fR ?\fI\-option\fR? ?\fIvalue\fR \fI...\fR? +.VS 8.5 Sets up, manipulates and queries the configuration of the resource -limit \fIlimitType\fR for the child interpreter. If no \fI\-option\fR +limit \fIlimitType\fR for the slave interpreter. If no \fI\-option\fR is specified, return the current configuration of the limit. If \fI\-option\fR is the sole argument, return the value of that option. Otherwise, a list of \fI\-option\fR/\fIvalue\fR argument pairs must supplied. See \fBRESOURCE LIMITS\fR below for a more detailed explanation of what limits and options are supported. +.VE 8.5 .TP -\fIchild \fBmarktrusted\fR -. -Marks the child interpreter as trusted. Can only be invoked by a +\fIslave \fBmarktrusted\fR +Marks the slave interpreter as trusted. Can only be invoked by a trusted interpreter. This command does not expose any hidden -commands in the child interpreter. The command has no effect if the child +commands in the slave interpreter. The command has no effect if the slave is already trusted. .TP -\fIchild\fR \fBrecursionlimit\fR ?\fInewlimit\fR? -. -Returns the maximum allowable nesting depth for the \fIchild\fR interpreter. -If \fInewlimit\fR is specified, the recursion limit in \fIchild\fR will be +\fIslave\fR \fBrecursionlimit\fR ?\fInewlimit\fR? +Returns the maximum allowable nesting depth for the \fIslave\fR interpreter. +If \fInewlimit\fR is specified, the recursion limit in \fIslave\fR will be set so that nesting of more than \fInewlimit\fR calls to \fBTcl_Eval()\fR -and related procedures in \fIchild\fR will return an error. +and related procedures in \fIslave\fR will return an error. The \fInewlimit\fR value is also returned. The \fInewlimit\fR value must be a positive integer between 1 and the maximum value of a non-long integer on the platform. .RS .PP @@ -563,18 +508,18 @@ safe, certain commands and variables are removed from the interpreter. For example, commands to create files on disk are removed, and the \fBexec\fR command is removed, since it could be used to cause damage through subprocesses. Limited access to these facilities can be provided, by creating -aliases to the parent interpreter which check their arguments carefully +aliases to the master interpreter which check their arguments carefully and provide restricted access to a safe subset of facilities. For example, file creation might be allowed in a particular subdirectory and subprocess invocation might be allowed for a carefully selected and fixed set of programs. .PP A safe interpreter is created by specifying the \fB\-safe\fR switch -to the \fBinterp create\fR command. Furthermore, any child created +to the \fBinterp create\fR command. Furthermore, any slave created by a safe interpreter will also be safe. .PP A safe interpreter is created with exactly the following set of built-in commands: .DS @@ -657,19 +602,19 @@ A safe interpreter may not alter the recursion limit of any interpreter, including itself. .SH "ALIAS INVOCATION" .PP The alias mechanism has been carefully designed so that it can -be used safely in an untrusted script which is being executed in a -safe interpreter even if the target of the alias is not a safe -interpreter. The most important thing in guaranteeing safety is to -ensure that information passed from the child to the parent is -never evaluated or substituted in the parent; if this were to -occur, it would enable an evil script in the child to invoke -arbitrary functions in the parent, which would compromise security. +be used safely when an untrusted script is executing +in a safe slave and the target of the alias is a trusted +master. The most important thing in guaranteeing safety is to +ensure that information passed from the slave to the master is +never evaluated or substituted in the master; if this were to +occur, it would enable an evil script in the slave to invoke +arbitrary functions in the master, which would compromise security. .PP -When the source for an alias is invoked in the child interpreter, the +When the source for an alias is invoked in the slave interpreter, the usual Tcl substitutions are performed when parsing that command. These substitutions are carried out in the source interpreter just as they would be for any other command invoked in that interpreter. The command procedure for the source command takes its arguments and merges them with the \fItargetCmd\fR and \fIarg\fRs for the @@ -692,12 +637,12 @@ the alias's source command is parsed in the source interpreter. .PP When writing the \fItargetCmd\fRs for aliases in safe interpreters, it is very important that the arguments to that command never be evaluated or substituted, since this would provide an escape -mechanism whereby the child interpreter could execute arbitrary -code in the parent. This in turn would compromise the security +mechanism whereby the slave interpreter could execute arbitrary +code in the master. This in turn would compromise the security of the system. .SH "HIDDEN COMMANDS" .PP Safe interpreters greatly restrict the functionality available to Tcl programs executing within them. @@ -720,32 +665,32 @@ interpreter, in the context of the safe interpreter, using \fBinterp invoke\fR. Hidden commands and exposed commands reside in separate name spaces. It is possible to define a hidden command and an exposed command by the same name within one interpreter. .PP -Hidden commands in a child interpreter can be invoked in the body of -procedures called in the parent during alias invocation. For example, an -alias for \fBsource\fR could be created in a child interpreter. When it is -invoked in the child interpreter, a procedure is called in the parent +Hidden commands in a slave interpreter can be invoked in the body of +procedures called in the master during alias invocation. For example, an +alias for \fBsource\fR could be created in a slave interpreter. When it is +invoked in the slave interpreter, a procedure is called in the master interpreter to check that the operation is allowable (e.g. it asks to -source a file that the child interpreter is allowed to access). The -procedure then it invokes the hidden \fBsource\fR command in the child +source a file that the slave interpreter is allowed to access). The +procedure then it invokes the hidden \fBsource\fR command in the slave interpreter to actually source in the contents of the file. Note that two -commands named \fBsource\fR exist in the child interpreter: the alias, and +commands named \fBsource\fR exist in the slave interpreter: the alias, and the hidden command. .PP -Because a parent interpreter may invoke a hidden command as part of +Because a master interpreter may invoke a hidden command as part of handling an alias invocation, great care must be taken to avoid evaluating any arguments passed in through the alias invocation. -Otherwise, malicious child interpreters could cause a trusted parent +Otherwise, malicious slave interpreters could cause a trusted master interpreter to execute dangerous commands on their behalf. See the section on \fBALIAS INVOCATION\fR for a more complete discussion of this topic. To help avoid this problem, no substitutions or evaluations are applied to arguments of \fBinterp invokehidden\fR. .PP Safe interpreters are not allowed to invoke hidden commands in themselves -or in their descendants. This prevents them from gaining access to +or in their descendants. This prevents safe slaves from gaining access to hidden functionality in themselves or their descendants. .PP The set of hidden commands in an interpreter can be manipulated by a trusted interpreter using \fBinterp expose\fR and \fBinterp hide\fR. The \fBinterp expose\fR command moves a hidden command to the @@ -760,25 +705,26 @@ Currently, the names of hidden commands cannot contain namespace qualifiers, and you must first rename a command in a namespace to the global namespace before you can hide it. Commands to be hidden by \fBinterp hide\fR are looked up in the global namespace even if the current namespace is not the global one. This -prevents children from fooling a parent interpreter into hiding the wrong +prevents slaves from fooling a master interpreter into hiding the wrong command, by making the current namespace be different from the global one. .SH "RESOURCE LIMITS" +.VS 8.5 .PP Every interpreter has two kinds of resource limits that may be imposed by any -parent interpreter upon its children. Command limits (of type \fBcommand\fR) +master interpreter upon its slaves. Command limits (of type \fBcommand\fR) restrict the total number of Tcl commands that may be executed by an interpreter (as can be inspected via the \fBinfo cmdcount\fR command), and time limits (of type \fBtime\fR) place a limit by which execution within the interpreter must complete. Note that time limits are expressed as \fIabsolute\fR times (as in \fBclock seconds\fR) and not relative times (as in \fBafter\fR) because they may be modified after creation. .PP When a limit is exceeded for an interpreter, first any handler callbacks -defined by parent interpreters are called. If those callbacks increase or +defined by master interpreters are called. If those callbacks increase or remove the limit, execution within the (previously) limited interpreter continues. If the limit is still in force, an error is generated at that point and normal processing of errors within the interpreter (by the \fBcatch\fR command) is disabled, so the error propagates outwards (building a stack-trace as it goes) to the point where the limited interpreter was invoked (e.g. by @@ -787,122 +733,120 @@ .SS "LIMIT OPTIONS" .PP Every limit has a number of options associated with it, some of which are common across all kinds of limits, and others of which are particular to the kind of limit. +.VE 8.5 .TP \fB\-command\fR -. +.VS 8.5 This option (common for all limit types) specifies (if non-empty) a Tcl script to be executed in the global namespace of the interpreter reading and writing the option when the particular limit in the limited interpreter is exceeded. The callback may modify the limit on the interpreter if it wishes the limited -interpreter to continue executing. If the callback generates an exception, it -is reported through the background exception mechanism (see -\fBBACKGROUND EXCEPTION HANDLING\fR). -Note that the callbacks defined by one interpreter are +interpreter to continue executing. If the callback generates an error, it is +reported through the background error mechanism (see \fBBACKGROUND ERROR +HANDLING\fR). Note that the callbacks defined by one interpreter are completely isolated from the callbacks defined by another, and that the order in which those callbacks are called is undefined. +.VE 8.5 .TP \fB\-granularity\fR -. +.VS 8.5 This option (common for all limit types) specifies how frequently (out of the points when the Tcl interpreter is in a consistent state where limit checking is possible) that the limit is actually checked. This allows the tuning of how frequently a limit is checked, and hence how often the limit-checking overhead (which may be substantial in the case of time limits) is incurred. +.VE 8.5 .TP \fB\-milliseconds\fR -. +.VS 8.5 This option specifies the number of milliseconds after the moment defined in the \fB\-seconds\fR option that the time limit will fire. It should only ever be specified in conjunction with the \fB\-seconds\fR option (whether it was set previously or is being set this invocation.) +.VE 8.5 .TP \fB\-seconds\fR -. +.VS 8.5 This option specifies the number of seconds after the epoch (see \fBclock seconds\fR) that the time limit for the interpreter will be triggered. The limit will be triggered at the start of the second unless specified at a sub-second level using the \fB\-milliseconds\fR option. This option may be the empty string, which indicates that a time limit is not set for the interpreter. +.VE 8.5 .TP \fB\-value\fR -. +.VS 8.5 This option specifies the number of commands that the interpreter may execute before triggering the command limit. This option may be the empty string, which indicates that a command limit is not set for the interpreter. .PP -Where an interpreter with a resource limit set on it creates a child -interpreter, that child interpreter will have resource limits imposed on it -that are at least as restrictive as the limits on the creating parent -interpreter. If the parent interpreter of the limited parent wishes to relax +Where an interpreter with a resource limit set on it creates a slave +interpreter, that slave interpreter will have resource limits imposed on it +that are at least as restrictive as the limits on the creating master +interpreter. If the master interpreter of the limited master wishes to relax these conditions, it should hide the \fBinterp\fR command in the child and then use aliases and the \fBinterp invokehidden\fR subcommand to provide such -access as it chooses to the \fBinterp\fR command to the limited parent as +access as it chooses to the \fBinterp\fR command to the limited master as necessary. -.SH "BACKGROUND EXCEPTION HANDLING" +.SH "BACKGROUND ERROR HANDLING" .PP -When an exception happens in a situation where it cannot be reported directly up +When an error happens in a situation where it cannot be reported directly up the stack (e.g. when processing events in an \fBupdate\fR or \fBvwait\fR call) -the exception is instead reported through the background exception handling mechanism. -Every interpreter has a background exception handler registered; the default exception +the error is instead reported through the background error handling mechanism. +Every interpreter has a background error handler registered; the default error handler arranges for the \fBbgerror\fR command in the interpreter's global -namespace to be called, but other exception handlers may be installed and process -background exceptions in substantially different ways. +namespace to be called, but other error handlers may be installed and process +background errors in substantially different ways. .PP -A background exception handler consists of a non-empty list of words to which will +A background error handler consists of a non-empty list of words to which will be appended two further words at invocation time. The first word will be the -interpreter result at time of the exception, typically an error message, -and the second will be the dictionary of return options at the time of -the exception. These are the same values that \fBcatch\fR can capture -when it controls script evaluation in a non-background situation. -The resulting list will then be executed +error message string, and the second will a dictionary of return options (this +is also the sort of information that can be obtained by trapping a normal +error using \fBcatch\fR of course.) The resulting list will then be executed in the interpreter's global namespace without further substitutions being performed. +.VE 8.5 .SH CREDITS The safe interpreter mechanism is based on the Safe-Tcl prototype implemented by Nathaniel Borenstein and Marshall Rose. .SH EXAMPLES -.PP Creating and using an alias for a command in the current interpreter: -.PP .CS \fBinterp alias\fR {} getIndex {} lsearch {alpha beta gamma delta} set idx [getIndex delta] .CE .PP Executing an arbitrary command in a safe interpreter where every invocation of \fBlappend\fR is logged: -.PP .CS set i [\fBinterp create\fR -safe] \fBinterp hide\fR $i lappend \fBinterp alias\fR $i lappend {} loggedLappend $i proc loggedLappend {i args} { - puts "logged invocation of lappend $args" - \fBinterp invokehidden\fR $i lappend {*}$args + puts "logged invocation of lappend $args" + \fBinterp invokehidden\fR $i lappend {*}$args } \fBinterp eval\fR $i $someUntrustedScript .CE .PP +.VS 8.5 Setting a resource limit on an interpreter so that an infinite loop terminates. -.PP .CS set i [\fBinterp create\fR] \fBinterp limit\fR $i command -value 1000 \fBinterp eval\fR $i { - set x 0 - while {1} { - puts "Counting up... [incr x]" - } + set x 0 + while {1} { + puts "Counting up... [incr x]" + } } .CE +.VE 8.5 .SH "SEE ALSO" -bgerror(n), load(n), safe(n), Tcl_CreateChild(3), Tcl_Eval(3), Tcl_BackgroundException(3) +bgerror(n), load(n), safe(n), Tcl_CreateSlave(3) .SH KEYWORDS -alias, parent interpreter, safe interpreter, child interpreter -'\"Local Variables: -'\"mode: nroff -'\"End: +alias, master interpreter, safe interpreter, slave interpreter Index: doc/join.n ================================================================== --- doc/join.n +++ doc/join.n @@ -2,47 +2,43 @@ '\" 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 join n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME join \- Create a string by joining together list elements .SH SYNOPSIS \fBjoin \fIlist \fR?\fIjoinString\fR? .BE + .SH DESCRIPTION .PP The \fIlist\fR argument must be a valid Tcl list. This command returns the string formed by joining all of the elements of \fIlist\fR together with \fIjoinString\fR separating each adjacent pair of elements. The \fIjoinString\fR argument defaults to a space character. .SH EXAMPLES -.PP Making a comma-separated list: -.PP .CS set data {1 2 3 4 5} \fBjoin\fR $data ", " \fB\(-> 1, 2, 3, 4, 5\fR .CE .PP Using \fBjoin\fR to flatten a list by a single level: -.PP .CS set data {1 {2 3} 4 {5 {6 7} 8}} \fBjoin\fR $data \fB\(-> 1 2 3 4 5 {6 7} 8\fR .CE + .SH "SEE ALSO" list(n), lappend(n), split(n) + .SH KEYWORDS element, join, list, separator -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/lappend.n ================================================================== --- doc/lappend.n +++ doc/lappend.n @@ -3,58 +3,48 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny . All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH lappend n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lappend \- Append list elements onto a variable .SH SYNOPSIS \fBlappend \fIvarName \fR?\fIvalue value value ...\fR? .BE + .SH DESCRIPTION .PP This command treats the variable given by \fIvarName\fR as a list and appends each of the \fIvalue\fR arguments to that list as a separate element, with spaces between elements. If \fIvarName\fR does not exist, it is created as a list with elements given by the \fIvalue\fR arguments. -.VS TIP508 -If \fIvarName\fR indicate an element that does not exist of an array that has -a default value set, list that is comprised of the default value with all the -\fIvalue\fR arguments appended as elements will be stored in the array -element. -.VE TIP508 \fBLappend\fR is similar to \fBappend\fR except that the \fIvalue\fRs are appended as list elements rather than raw text. This command provides a relatively efficient way to build up large lists. For example, .QW "\fBlappend a $b\fR" is much more efficient than .QW "\fBset a [concat $a [list $b]]\fR" when \fB$a\fR is long. .SH EXAMPLE -.PP Using \fBlappend\fR to build up a list of numbers. -.PP .CS % set var 1 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) +list(n), lindex(n), linsert(n), llength(n), lset(n), +lsort(n), lrange(n) + .SH KEYWORDS append, element, list, variable -.\" Local variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: Index: doc/lassign.n ================================================================== --- doc/lassign.n +++ doc/lassign.n @@ -2,61 +2,54 @@ '\" Copyright (c) 1992-1999 Karl Lehenbauer & Mark Diekhans '\" Copyright (c) 2004 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH lassign n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lassign \- Assign list elements to variables .SH SYNOPSIS -\fBlassign \fIlist \fR?\fIvarName ...\fR? +\fBlassign \fIlist varName \fR?\fIvarName ...\fR? .BE + .SH DESCRIPTION .PP This command treats the value \fIlist\fR as a list and assigns successive elements from that list to the variables given by the \fIvarName\fR arguments in order. If there are more variable names than list elements, the remaining variables are set to the empty string. If there are more list elements than variables, a list of unassigned elements is returned. .SH EXAMPLES -.PP An illustration of how multiple assignment works, and what happens when there are either too few or too many elements. -.PP .CS -\fBlassign\fR {a b c} x y z ;# Empty return +lassign {a b c} x y z ;# Empty return puts $x ;# Prints "a" puts $y ;# Prints "b" puts $z ;# Prints "c" -\fBlassign\fR {d e} x y z ;# Empty return +lassign {d e} x y z ;# Empty return puts $x ;# Prints "d" puts $y ;# Prints "e" puts $z ;# Prints "" -\fBlassign\fR {f g h i} x y ;# Returns "h i" +lassign {f g h i} x y ;# Returns "h i" puts $x ;# Prints "f" puts $y ;# Prints "g" .CE -.PP The \fBlassign\fR command has other uses. It can be used to create the analogue of the .QW shift command in many shell languages like this: -.PP .CS -set ::argv [\fBlassign\fR $::argv argumentToReadOff] +set ::argv [lassign $::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) +lindex(n), list(n), lset(n), set(n) + .SH KEYWORDS assign, element, list, multiple, set, variable -'\"Local Variables: -'\"mode: nroff -'\"End: Index: doc/library.n ================================================================== --- doc/library.n +++ doc/library.n @@ -7,17 +7,18 @@ '\" .TH library n "8.0" Tcl "Tcl Built-In Commands" .so man.macros .BS .SH NAME -auto_execok, auto_import, auto_load, auto_mkindex, auto_qualify, auto_reset, tcl_findLibrary, parray, tcl_endOfWord, tcl_startOfNextWord, tcl_startOfPreviousWord, tcl_wordBreakAfter, tcl_wordBreakBefore \- standard library of Tcl procedures +auto_execok, auto_import, auto_load, auto_mkindex, auto_mkindex_old, auto_qualify, auto_reset, tcl_findLibrary, parray, tcl_endOfWord, tcl_startOfNextWord, tcl_startOfPreviousWord, tcl_wordBreakAfter, tcl_wordBreakBefore \- standard library of Tcl procedures .SH SYNOPSIS .nf \fBauto_execok \fIcmd\fR \fBauto_import \fIpattern\fR \fBauto_load \fIcmd\fR \fBauto_mkindex \fIdir pattern pattern ...\fR +\fBauto_mkindex_old \fIdir pattern pattern ...\fR \fBauto_qualify \fIcommand namespace\fR \fBauto_reset\fR \fBtcl_findLibrary \fIbasename version patch initScript enVarName varName\fR \fBparray \fIarrayName\fR ?\fIpattern\fR? \fBtcl_endOfWord \fIstr start\fR @@ -36,20 +37,18 @@ In addition to the Tcl library, each application will normally have its own library of support procedures as well; the location of this library is normally given by the value of the \fB$\fIapp\fB_library\fR global variable, where \fIapp\fR is the name of the application. For example, the location of the Tk library is kept in the variable -\fBtk_library\fR. +\fB$tk_library\fR. .PP To access the procedures in the Tcl library, an application should source the file \fBinit.tcl\fR in the library, for example with the Tcl command -.PP .CS \fBsource [file join [info library] init.tcl]\fR .CE -.PP If the library procedure \fBTcl_Init\fR is invoked from an application's \fBTcl_AppInit\fR procedure, this happens automatically. The code in \fBinit.tcl\fR will define the \fBunknown\fR procedure and arrange for the other procedures to be loaded on-demand using the auto-load mechanism defined below. @@ -82,12 +81,12 @@ .TP \fBauto_load \fIcmd\fR This command attempts to load the definition for a Tcl command named \fIcmd\fR. To do this, it searches an \fIauto-load path\fR, which is a list of one or more directories. The auto-load path is given by the -global variable \fBauto_path\fR if it exists. If there is no -\fBauto_path\fR variable, then the TCLLIBPATH environment variable is +global variable \fB$auto_path\fR if it exists. If there is no +\fB$auto_path\fR variable, then the TCLLIBPATH environment variable is used, if it exists. Otherwise the auto-load path consists of just the Tcl library directory. Within each directory in the auto-load path there must be a file \fBtclIndex\fR that describes one or more commands defined in that directory and a script to evaluate to load each of the commands. The \fBtclIndex\fR file should be generated @@ -104,53 +103,47 @@ cached index information may be deleted with the command \fBauto_reset\fR. This will force the next \fBauto_load\fR command to reload the index database from disk. .TP \fBauto_mkindex \fIdir pattern pattern ...\fR -. Generates an index suitable for use by \fBauto_load\fR. The command searches \fIdir\fR for all files whose names match any of the \fIpattern\fR arguments (matching is done with the \fBglob\fR command), generates an index of all the Tcl command procedures defined in all the matching files, and stores the index information in a file named \fBtclIndex\fR in \fIdir\fR. If no pattern is given a pattern of \fB*.tcl\fR will be assumed. For example, the command .RS -.PP .CS \fBauto_mkindex foo *.tcl\fR .CE -.PP +.LP will read all the \fB.tcl\fR files in subdirectory \fBfoo\fR and generate a new index file \fBfoo/tclIndex\fR. .PP \fBAuto_mkindex\fR parses the Tcl scripts by sourcing them into a -child interpreter and monitoring the proc and namespace commands that +slave interpreter and monitoring the proc and namespace commands that are executed. Extensions can use the (undocumented) auto_mkindex_parser package to register other commands that can contribute to the auto_load index. You will have to read through auto.tcl to see how this works. .PP -\fBAuto_mkindex_old\fR -(which has the same syntax as \fBauto_mkindex\fR) -parses the Tcl scripts in a relatively -unsophisticated way: if any line contains the word -.QW \fBproc\fR +\fBAuto_mkindex_old\fR parses the Tcl scripts in a relatively +unsophisticated way: if any line contains the word \fBproc\fR as its first characters then it is assumed to be a procedure definition and the next word of the line is taken as the procedure's name. -Procedure definitions that do not appear in this way (e.g.\ they +Procedure definitions that do not appear in this way (e.g. they have spaces before the \fBproc\fR) will not be indexed. If your script contains .QW dangerous code, such as global initialization code or procedure names with special characters like \fB$\fR, -\fB*\fR, \fB[\fR or \fB]\fR, you are safer using \fBauto_mkindex_old\fR. +\fB*\fR, \fB[\fR or \fB]\fR, you are safer using auto_mkindex_old. .RE .TP \fBauto_reset\fR -. Destroys all the information cached by \fBauto_execok\fR and \fBauto_load\fR. This information will be re-read from disk the next time it is needed. \fBAuto_reset\fR also deletes any procedures listed in the auto-load index, so that fresh copies of them will be loaded the next time that they are used. @@ -199,11 +192,11 @@ \fBparray \fIarrayName\fR ?\fIpattern\fR? Prints on standard output the names and values of all the elements in the array \fIarrayName\fR, or just the names that match \fIpattern\fR (using the matching rules of \fBstring match\fR) and their values if \fIpattern\fR is given. -\fIArrayName\fR must be an array accessible to the caller of \fBparray\fR. +\fBArrayName\fR must be an array accessible to the caller of \fBparray\fR. It may be either local or global. .TP \fBtcl_endOfWord \fIstr start\fR Returns the index of the first end-of-word location that occurs after a starting index \fIstart\fR in the string \fIstr\fR. An end-of-word @@ -241,13 +234,11 @@ returned refers to the second character of the pair that comprises a boundary. .SH "VARIABLES" .PP The following global variables are defined or used by the procedures in -the Tcl library. They fall into two broad classes, handling unknown -commands and packages, and determining what are words. -.SS "AUTOLOADING AND PACKAGE MANAGEMENT VARIABLES" +the Tcl library: .TP \fBauto_execs\fR Used by \fBauto_execok\fR to record information about whether particular commands exist as executable files. .TP @@ -262,21 +253,17 @@ \fBauto_noload\fR If set to any value, then \fBunknown\fR will not attempt to auto-load any commands. .TP \fBauto_path\fR -. If set, then it must contain a valid Tcl list giving directories to -search during auto-load operations (including for package index -files when using the default \fBpackage unknown\fR handler). +search during auto-load operations. This variable is initialized during startup to contain, in order: -the directories listed in the \fBTCLLIBPATH\fR environment variable, -the directory named by the \fBtcl_library\fR global variable, -the parent directory of \fBtcl_library\fR, -the directories listed in the \fBtcl_pkgPath\fR variable. -Additional locations to look for files and package indices should -normally be added to this variable using \fBlappend\fR. +the directories listed in the TCLLIBPATH environment variable, +the directory named by the $tcl_library variable, +the parent directory of $tcl_library, +the directories listed in the $tcl_pkgPath variable. .TP \fBenv(TCL_LIBRARY)\fR If set, then it specifies the location of the directory containing library scripts (the value of this variable will be assigned to the \fBtcl_library\fR variable and therefore returned by @@ -288,28 +275,26 @@ search during auto-load operations. Directories must be specified in Tcl format, using .QW / as the path separator, regardless of platform. This variable is only used when initializing the \fBauto_path\fR variable. -.SS "WORD BOUNDARY DETERMINATION VARIABLES" -These variables are only used in the \fBtcl_endOfWord\fR, -\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". +considered to be a non-word character. On Windows platforms, spaces, +tabs, and newlines are considered non-word characters. Under Unix, +everything but numbers, letters and underscores are considered +non-word characters. .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". +considered to be a word character. On Windows platforms, words are +comprised of any character that is not a space, tab, or newline. Under +Unix, words are comprised of numbers, letters or underscores. .SH "SEE ALSO" -env(n), info(n), re_syntax(n) +info(n), re_syntax(n) .SH KEYWORDS auto-exec, auto-load, library, unknown, word, whitespace -'\"Local Variables: -'\"mode: nroff -'\"End: Index: doc/lindex.n ================================================================== --- doc/lindex.n +++ doc/lindex.n @@ -3,19 +3,19 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 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. -'\" +'\" .TH lindex n 8.4 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lindex \- Retrieve an element from a list .SH SYNOPSIS -\fBlindex \fIlist\fR ?\fIindex ...\fR? +\fBlindex \fIlist ?index...?\fR .BE .SH DESCRIPTION .PP The \fBlindex\fR command accepts a parameter, \fIlist\fR, which it treats as a Tcl list. It also accepts zero or more \fIindices\fR into @@ -22,21 +22,17 @@ the list. The indices may be presented either consecutively on the command line, or grouped in a Tcl list and presented as a single argument. .PP If no indices are presented, the command takes the form: -.PP .CS -\fBlindex \fIlist\fR +lindex list .CE -.PP or -.PP .CS -\fBlindex \fIlist\fR {} +lindex list {} .CE -.PP In this case, the return value of \fBlindex\fR is simply the value of the \fIlist\fR parameter. .PP When presented with a single index, the \fBlindex\fR command treats \fIlist\fR as a Tcl list and returns the @@ -46,81 +42,57 @@ interpreter; however, variable substitution and command substitution do not occur. If \fIindex\fR is negative or greater than or equal to the number of elements in \fIvalue\fR, then an empty string is returned. -The interpretation of each simple \fIindex\fR value is the same as +.VS 8.5 +The interpretation of each simple \fIindex\fR value is the same as for the command \fBstring index\fR, supporting simple index arithmetic and indices relative to the end of the list. +.VE 8.5 .PP If additional \fIindex\fR arguments are supplied, then each argument is used in turn to select an element from the previous indexing operation, allowing the script to select elements from sublists. The command, -.PP -.CS -\fBlindex\fR $a 1 2 3 -.CE -.PP -or -.PP -.CS -\fBlindex\fR $a {1 2 3} -.CE -.PP -is synonymous with -.PP -.CS -\fBlindex\fR [\fBlindex\fR [\fBlindex\fR $a 1] 2] 3 +.CS +lindex $a 1 2 3 +.CE +or +.CS +lindex $a {1 2 3} +.CE +is synonymous with +.CS +lindex [lindex [lindex $a 1] 2] 3 .CE .SH EXAMPLES -.PP -Lists can be indexed into from either end: -.PP .CS +\fBlindex\fR {a b c} + \fI\(-> a b c\fR +\fBlindex\fR {a b c} {} + \fI\(-> a b c\fR \fBlindex\fR {a b c} 0 \fI\(-> a\fR \fBlindex\fR {a b c} 2 \fI\(-> c\fR \fBlindex\fR {a b c} end \fI\(-> c\fR \fBlindex\fR {a b c} end-1 \fI\(-> b\fR -.CE -.PP -Lists or sequences of indices allow selection into lists of lists: -.PP -.CS -\fBlindex\fR {a b c} - \fI\(-> a b c\fR -\fBlindex\fR {a b c} {} - \fI\(-> a b c\fR \fBlindex\fR {{a b c} {d e f} {g h i}} 2 1 \fI\(-> h\fR \fBlindex\fR {{a b c} {d e f} {g h i}} {2 1} \fI\(-> h\fR \fBlindex\fR {{{a b} {c d}} {{e f} {g h}}} 1 1 0 \fI\(-> g\fR \fBlindex\fR {{{a b} {c d}} {{e f} {g h}}} {1 1 0} \fI\(-> g\fR .CE -.PP -List indices may also perform limited computation, adding or subtracting fixed -amounts from other indices: -.PP -.CS -set idx 1 -\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), +list(n), lappend(n), linsert(n), llength(n), lsearch(n), +lset(n), lsort(n), lrange(n), lreplace(n), +.VS 8.5 string(n) +.VE + .SH KEYWORDS element, index, list -'\"Local Variables: -'\"mode: nroff -'\"End: DELETED doc/link.n Index: doc/link.n ================================================================== --- doc/link.n +++ /dev/null @@ -1,124 +0,0 @@ -'\" -'\" Copyright (c) 2011-2015 Andreas Kupries -'\" Copyright (c) 2018 Donal K. Fellows -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH link n 0.3 TclOO "TclOO Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -link \- create link from command to method of object -.SH SYNOPSIS -.nf -package require TclOO - -\fBlink\fR \fImethodName\fR ?\fI...\fR? -\fBlink\fR \fB{\fIcommandName methodName\fB}\fR ?\fI...\fR? -.fi -.BE -.SH DESCRIPTION -The \fBlink\fR command is available within methods. It takes a series of one -or more method names (\fImethodName ...\fR) and/or pairs of command- and -method-name (\fB{\fIcommandName methodName\fB}\fR) and makes the named methods -available as commands without requiring the explicit use of the name of the -object or the \fBmy\fR command. The method does not need to exist at the time -that the link is made; if the link command is invoked when the method does not -exist, the standard \fBunknown\fR method handling system is used. -.PP -The command name under which the method becomes available defaults to the -method name, except where explicitly specified through an alias/method pair. -Formally, every argument must be a list; if the list has two elements, the -first element is the name of the command to create and the second element is -the name of the method of the current object to which the command links; -otherwise, the name of the command and the name of the method are the same -string (the first element of the list). -.PP -If the name of the command is not a fully-qualified command name, it will be -resolved with respect to the current namespace (i.e., the object namespace). -.SH EXAMPLES -This demonstrates linking a single method in various ways. First it makes a -simple link, then a renamed link, then an external link. Note that the method -itself is unexported, but that it can still be called directly from outside -the class. -.PP -.CS -oo::class create ABC { - method Foo {} { - puts "This is Foo in [self]" - } - - constructor {} { - \fBlink\fR Foo - # The method foo is now directly accessible as foo here - \fBlink\fR {bar Foo} - # The method foo is now directly accessible as bar - \fBlink\fR {::ExternalCall Foo} - # The method foo is now directly accessible in the global - # namespace as ExternalCall - } - - method grill {} { - puts "Step 1:" - Foo - puts "Step 2:" - bar - } -} - -ABC create abc -abc grill - \fI\(-> Step 1:\fR - \fI\(-> This is foo in ::abc\fR - \fI\(-> Step 2:\fR - \fI\(-> This is foo in ::abc\fR -# Direct access via the linked command -puts "Step 3:"; ExternalCall - \fI\(-> Step 3:\fR - \fI\(-> This is foo in ::abc\fR -.CE -.PP -This example shows that multiple linked commands can be made in a call to -\fBlink\fR, and that they can handle arguments. -.PP -.CS -oo::class create Ex { - constructor {} { - \fBlink\fR a b c - # The methods a, b, and c (defined below) are all now - # directly acessible within methods under their own names. - } - - method a {} { - puts "This is a" - } - method b {x} { - puts "This is b($x)" - } - method c {y z} { - puts "This is c($y,$z)" - } - - method call {p q r} { - a - b $p - c $q $r - } -} - -set o [Ex new] -$o 3 5 7 - \fI\(-> This is a\fR - \fI\(-> This is b(3)\fR - \fI\(-> This is c(5,7)\fR -.CE -.SH "SEE ALSO" -interp(n), my(n), oo::class(n), oo::define(n) -.SH KEYWORDS -command, method, object -.\" Local Variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: Index: doc/linsert.n ================================================================== --- doc/linsert.n +++ doc/linsert.n @@ -3,54 +3,48 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny . All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH linsert n 8.2 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME linsert \- Insert elements into a list .SH SYNOPSIS -\fBlinsert \fIlist index \fR?\fIelement element ...\fR? +\fBlinsert \fIlist index element \fR?\fIelement element ...\fR? .BE + .SH DESCRIPTION .PP This command produces a new list from \fIlist\fR by inserting all of the \fIelement\fR arguments just before the \fIindex\fR'th element of \fIlist\fR. Each \fIelement\fR argument will become a separate element of the new list. If \fIindex\fR is less than or equal to zero, then the new -elements are inserted at the beginning of the list, and if \fIindex\fR is -greater or equal to the length of \fIlist\fR, it is as if it was \fBend\fR. -As with \fBstring index\fR, the \fIindex\fR value supports both simple index -arithmetic and end-relative indexing. -.PP -Subject to the restrictions that indices must refer to locations inside the -list and that the \fIelement\fRs will always be inserted in order, insertions -are done so that when \fIindex\fR is start-relative, the first \fIelement\fR -will be at that index in the resulting list, and when \fIindex\fR is -end-relative, the last \fIelement\fR will be at that index in the resulting -list. +elements are inserted at the beginning of the list. +.VS 8.5 +The interpretation of the \fIindex\fR value is the same as +for the command \fBstring index\fR, supporting simple index +arithmetic and indices relative to the end of the list. +.VE .SH EXAMPLE -.PP Putting some values into a list, first indexing from the start and then indexing from the end, and then chaining them together: -.PP .CS 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), +list(n), lappend(n), lindex(n), llength(n), lsearch(n), +lset(n), lsort(n), lrange(n), lreplace(n), +.VS 8.5 string(n) +.VE + .SH KEYWORDS element, insert, list -'\" Local Variables: -'\" mode: nroff -'\" End: Index: doc/list.n ================================================================== --- doc/list.n +++ doc/list.n @@ -3,20 +3,21 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny . All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH list n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME list \- Create a list .SH SYNOPSIS \fBlist \fR?\fIarg arg ...\fR? .BE + .SH DESCRIPTION .PP This command returns a list comprised of all the \fIarg\fRs, or an empty string if no \fIarg\fRs are specified. Braces and backslashes get added as necessary, so that the \fBlindex\fR command @@ -25,32 +26,27 @@ \fIarg1\fR comprising the command's name and the other \fIarg\fRs comprising its arguments. \fBList\fR produces slightly different results than \fBconcat\fR: \fBconcat\fR removes one level of grouping before forming the list, while \fBlist\fR works directly from the original arguments. .SH EXAMPLE -.PP The command -.PP .CS \fBlist\fR a b "c d e " " f {g h}" .CE -.PP will return -.PP .CS \fBa b {c d e } { f {g h}}\fR .CE -.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) +lappend(n), lindex(n), linsert(n), llength(n), lrange(n), +.VS 8.5 +lrepeat(n), +.VE 8.5 +lreplace(n), lsearch(n), lset(n), lsort(n) + .SH KEYWORDS -element, list, quoting -'\"Local Variables: -'\"mode: nroff -'\"End: +element, list Index: doc/llength.n ================================================================== --- doc/llength.n +++ doc/llength.n @@ -3,28 +3,28 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny . All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH llength n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME llength \- Count the number of elements in a list .SH SYNOPSIS \fBllength \fIlist\fR .BE + .SH DESCRIPTION .PP Treats \fIlist\fR as a list and returns a decimal string giving the number of elements in it. + .SH EXAMPLES -.PP The result is the number of elements: -.PP .CS % \fBllength\fR {a b c d e} 5 % \fBllength\fR {a b c} 3 @@ -32,29 +32,24 @@ 0 .CE .PP Elements are not guaranteed to be exactly words in a dictionary sense of course, especially when quoting is used: -.PP .CS % \fBllength\fR {a b {c d} e} 4 % \fBllength\fR {a b { } c d e} 6 .CE .PP 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) +list(n), lappend(n), lindex(n), linsert(n), lsearch(n), +lset(n), lsort(n), lrange(n), lreplace(n) + .SH KEYWORDS element, list, length -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: DELETED doc/lmap.n Index: doc/lmap.n ================================================================== --- doc/lmap.n +++ /dev/null @@ -1,88 +0,0 @@ -'\" -'\" Copyright (c) 2012 Trevor Davel -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH lmap n "" Tcl "Tcl Built-In Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -lmap \- Iterate over all elements in one or more lists and collect results -.SH SYNOPSIS -\fBlmap \fIvarname list body\fR -.br -\fBlmap \fIvarlist1 list1\fR ?\fIvarlist2 list2 ...\fR? \fIbody\fR -.BE -.SH DESCRIPTION -.PP -The \fBlmap\fR command implements a loop where the loop variable(s) take on -values from one or more lists, and the loop returns a list of results -collected from each iteration. -.PP -In the simplest case there is one loop variable, \fIvarname\fR, and one list, -\fIlist\fR, that is a list of values to assign to \fIvarname\fR. The -\fIbody\fR argument is a Tcl script. For each element of \fIlist\fR (in order -from first to last), \fBlmap\fR assigns the contents of the element to -\fIvarname\fR as if the \fBlindex\fR command had been used to extract the -element, then calls the Tcl interpreter to execute \fIbody\fR. If execution of -the body completes normally then the result of the body is appended to an -accumulator list. \fBlmap\fR returns the accumulator list. -.PP -In the general case there can be more than one value list (e.g., \fIlist1\fR -and \fIlist2\fR), and each value list can be associated with a list of loop -variables (e.g., \fIvarlist1\fR and \fIvarlist2\fR). During each iteration of -the loop the variables of each \fIvarlist\fR are assigned consecutive values -from the corresponding \fIlist\fR. Values in each \fIlist\fR are used in order -from first to last, and each value is used exactly once. The total number of -loop iterations is large enough to use up all the values from all the value -lists. If a value list does not contain enough elements for each of its loop -variables in each iteration, empty values are used for the missing elements. -.PP -The \fBbreak\fR and \fBcontinue\fR statements may be invoked inside -\fIbody\fR, with the same effect as in the \fBfor\fR and \fBforeach\fR -commands. In these cases the body does not complete normally and the result is -not appended to the accumulator list. -.SH EXAMPLES -.PP -Zip lists together: -.PP -.CS -set list1 {a b c d} -set list2 {1 2 3 4} -set zipped [\fBlmap\fR a $list1 b $list2 {list $a $b}] -# The value of zipped is "{a 1} {b 2} {c 3} {d 4}" -.CE -.PP -Filter a list to remove odd values: -.PP -.CS -set values {1 2 3 4 5 6 7 8} -proc isEven {n} {expr {($n % 2) == 0}} -set goodOnes [\fBlmap\fR x $values {expr { - [isEven $x] ? $x : [continue] -}}] -# The value of goodOnes is "2 4 6 8" -.CE -.PP -Take a prefix from a list based on the contents of the list: -.PP -.CS -set values {8 7 6 5 4 3 2 1} -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: Index: doc/load.n ================================================================== --- doc/load.n +++ doc/load.n @@ -1,24 +1,25 @@ '\" '\" 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 load n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME load \- Load machine code and initialize new commands .SH SYNOPSIS -\fBload\fR ?\fB\-global\fR? ?\fB\-lazy\fR? ?\fB\-\-\fR? \fIfileName\fR +\fBload \fIfileName\fR .br -\fBload\fR ?\fB\-global\fR? ?\fB\-lazy\fR? ?\fB\-\-\fR? \fIfileName packageName\fR +\fBload \fIfileName packageName\fR .br -\fBload\fR ?\fB\-global\fR? ?\fB\-lazy\fR? ?\fB\-\-\fR? \fIfileName packageName interp\fR +\fBload \fIfileName packageName interp\fR .BE + .SH DESCRIPTION .PP This command loads binary code from a file into the application's address space and calls an initialization procedure in the package to incorporate it into an interpreter. \fIfileName\fR @@ -53,16 +54,13 @@ initializes the safe interpreter only with partial functionality provided by the package that is safe for use by untrusted code. For more information on Safe\-Tcl, see the \fBsafe\fR manual entry. .PP The initialization procedure must match the following prototype: -.PP .CS -typedef int \fBTcl_PackageInitProc\fR( - Tcl_Interp *\fIinterp\fR); +typedef int Tcl_PackageInitProc(Tcl_Interp *\fIinterp\fR); .CE -.PP The \fIinterp\fR argument identifies the interpreter in which the package 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 of the \fBload\fR command @@ -71,14 +69,16 @@ The actual loading of a file will only be done once for each \fIfileName\fR in an application. If a given \fIfileName\fR is loaded into multiple interpreters, then the first \fBload\fR will load the code and call the initialization procedure; subsequent \fBload\fRs will call the initialization procedure without loading the code again. +.VS 8.5 For Tcl versions lower than 8.5, it is not possible to unload or reload a package. From version 8.5 however, the \fBunload\fR command allows the unloading of libraries loaded with \fBload\fR, for libraries that are aware of the Tcl's unloading mechanism. +.VE 8.5 .PP The \fBload\fR command also supports packages that are statically linked with the application, if those packages have been registered by calling the \fBTcl_StaticPackage\fR procedure. If \fIfileName\fR is an empty string, then \fIpackageName\fR must @@ -102,26 +102,10 @@ procedure) by that name; if one is found, it is used. Otherwise, the \fBload\fR command searches for a dynamically loaded package by that name, and uses it if it is found. If several different files have been \fBload\fRed with different versions of the package, Tcl picks the file that was loaded first. -.PP -If \fB\-global\fR is specified preceding the filename, all symbols -found in the shared library are exported for global use by other -libraries. The option \fB\-lazy\fR delays the actual loading of -symbols until their first actual use. The options may be abbreviated. -The option \fB\-\-\fR indicates the end of the options, and should -be used if you wish to use a filename which starts with \fB\-\fR -and you provide a packageName to the \fBload\fR command. -.PP -On platforms which do not support the \fB\-global\fR or \fB\-lazy\fR -options, the options still exist but have no effect. Note that use -of the \fB\-global\fR or \fB\-lazy\fR option may lead to crashes -in your application later (in case of symbol conflicts resp. missing -symbols), which cannot be detected during the \fBload\fR. So, only -use this when you know what you are doing, you will not get a nice -error message when something is wrong with the loaded library. .SH "PORTABILITY ISSUES" .TP \fBWindows\fR\0\0\0\0\0 . When a load fails with @@ -133,30 +117,26 @@ in a DOS console to see what the library must import. When loading a DLL in the current directory, Windows will ignore .QW ./ as a path specifier and use a search heuristic to find the DLL instead. To avoid this, load the DLL with: -.RS -.PP .CS \fBload\fR [file join [pwd] mylib.DLL] .CE -.RE .SH BUGS .PP If the same file is \fBload\fRed by different \fIfileName\fRs, it will be loaded into the process's address space multiple times. The behavior of this varies from system to system (some systems may detect the redundant loads, others may not). .SH EXAMPLE -.PP The following is a minimal extension: .PP .CS #include #include -static int fooCmd(void *clientData, +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) { @@ -174,23 +154,22 @@ it can then be loaded into Tcl with the following: .PP .CS # Load the extension switch $tcl_platform(platform) { - windows { - \fBload\fR [file join [pwd] foo.dll] - } - unix { - \fBload\fR [file join [pwd] libfoo[info sharedlibextension]] - } + windows { + \fBload\fR [file join [pwd] foo.dll] + } + unix { + \fBload\fR [file join [pwd] libfoo[info sharedlibextension]] + } } # Now execute the command defined by the extension foo .CE + .SH "SEE ALSO" -info sharedlibextension, package(n), Tcl_StaticPackage(3), safe(n) +info sharedlibextension, Tcl_StaticPackage(3), safe(n) + .SH KEYWORDS -binary code, dynamic library, load, safe interpreter, shared library -'\"Local Variables: -'\"mode: nroff -'\"End: +binary code, loading, safe interpreter, shared library DELETED doc/lpop.n Index: doc/lpop.n ================================================================== --- doc/lpop.n +++ /dev/null @@ -1,97 +0,0 @@ -'\" -'\" Copyright (c) 2018 by Peter Spjuth. All rights reserved. -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH lpop n 8.7 Tcl "Tcl Built-In Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -lpop \- Get and remove an element in a list -.SH SYNOPSIS -\fBlpop \fIvarName ?index ...?\fR -.BE -.SH DESCRIPTION -.PP -The \fBlpop\fR command accepts a parameter, \fIvarName\fR, which -it interprets as the name of a variable containing a Tcl list. -It also accepts one or more \fIindices\fR into -the list. If no indices are presented, it defaults to "end". -.PP -When presented with a single index, the \fBlpop\fR command -addresses the \fIindex\fR'th element in it, removes if from the list -and returns the element. -.PP -If \fIindex\fR is negative or greater or equal than the number -of elements in \fI$varName\fR, then an error occurs. -.PP -The interpretation of each simple \fIindex\fR value is the same as -for the command \fBstring index\fR, supporting simple index -arithmetic and indices relative to the end of the list. -.PP -If additional \fIindex\fR arguments are supplied, then each argument is -used in turn to address an element within a sublist designated -by the previous indexing operation, -allowing the script to remove elements in sublists. -The command, -.PP -.CS -\fBlpop\fR a 1 2 -.CE -.PP -gets and removes element 2 of sublist 1. -.PP -.SH EXAMPLES -.PP -In each of these examples, the initial value of \fIx\fR is: -.PP -.CS -set x [list [list a b c] [list d e f] [list g h i]] - \fI\(-> {a b c} {d e f} {g h i}\fR -.CE -.PP -The indicated value becomes the new value of \fIx\fR -(except in the last case, which is an error which leaves the value of -\fIx\fR unchanged.) -.PP -.CS -\fBlpop\fR x 0 - \fI\(-> {d e f} {g h i}\fR -\fBlpop\fR x 2 - \fI\(-> {a b c} {d e f}\fR -\fBlpop\fR x end - \fI\(-> {a b c} {d e f}\fR -\fBlpop\fR x end-1 - \fI\(-> {a b c} {g h i}\fR -\fBlpop\fR x 2 1 - \fI\(-> {a b c} {d e f} {g i}\fR -\fBlpop\fR x 2 3 j - \fI\(-> list index out of range\fR -.CE -.PP -In the following examples, the initial value of \fIx\fR is: -.PP -.CS -set x [list [list [list a b] [list c d]] \e - [list [list e f] [list g h]]] - \fI\(-> {{a b} {c d}} {{e f} {g h}}\fR -.CE -.PP -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: Index: doc/lrange.n ================================================================== --- doc/lrange.n +++ doc/lrange.n @@ -3,29 +3,32 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny . All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH lrange n 7.4 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lrange \- Return one or more adjacent elements from a list .SH SYNOPSIS \fBlrange \fIlist first last\fR .BE + .SH DESCRIPTION .PP \fIList\fR must be a valid Tcl list. This command will return a new list consisting of elements \fIfirst\fR through \fIlast\fR, inclusive. +.VS 8.5 The index values \fIfirst\fR and \fIlast\fR are interpreted the same as index values for the command \fBstring index\fR, supporting simple index arithmetic and indices relative to the end of the list. +.VE If \fIfirst\fR is less than zero, it is treated as if it were zero. If \fIlast\fR is greater than or equal to the number of elements in the list, then it is treated as if it were \fBend\fR. If \fIfirst\fR is greater than \fIlast\fR then an empty string is returned. @@ -35,49 +38,43 @@ .QW "\fBlindex \fIlist first\fR" (although it often does for simple fields that are not enclosed in braces); it does, however, produce exactly the same results as .QW "\fBlist [lindex \fIlist first\fB]\fR" .SH EXAMPLES -.PP Selecting the first two elements: -.PP .CS % \fBlrange\fR {a b c d e} 0 1 a b .CE .PP Selecting the last three elements: -.PP .CS % \fBlrange\fR {a b c d e} end-2 end c d e .CE .PP Selecting everything except the first and last element: -.PP .CS % \fBlrange\fR {a b c d e} 1 end-1 b c d .CE .PP Selecting a single element with \fBlrange\fR is not the same as doing so with \fBlindex\fR: -.PP .CS % set var {some {elements to} select} 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), +list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), +lset(n), lreplace(n), lsort(n), +.VS 8.5 string(n) +.VE + .SH KEYWORDS element, list, range, sublist -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: DELETED doc/lremove.n Index: doc/lremove.n ================================================================== --- doc/lremove.n +++ /dev/null @@ -1,57 +0,0 @@ -'\" -'\" Copyright (c) 2019 Donal K. Fellows. -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH lremove n 8.7 Tcl "Tcl Built-In Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -lremove \- Remove elements from a list by index -.SH SYNOPSIS -\fBlremove \fIlist\fR ?\fIindex ...\fR? -.BE -.SH DESCRIPTION -.PP -\fBlremove\fR returns a new list formed by simultaneously removing zero or -more elements of \fIlist\fR at each of the indices given by an arbirary number -of \fIindex\fR arguments. The indices may be in any order and may be repeated; -the element at index will only be removed once. The index values are -interpreted the same as index values for the command \fBstring index\fR, -supporting simple index arithmetic and indices relative to the end of the -list. 0 refers to the first element of the list, and \fBend\fR refers to the -last element of the list. -.SH EXAMPLES -.PP -Removing the third element of a list: -.PP -.CS -% \fBlremove\fR {a b c d e} 2 -a b d e -.CE -.PP -Removing two elements from a list: -.PP -.CS -% \fBlremove\fR {a b c d e} end-1 1 -a c e -.CE -.PP -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: Index: doc/lrepeat.n ================================================================== --- doc/lrepeat.n +++ doc/lrepeat.n @@ -1,27 +1,28 @@ '\" '\" Copyright (c) 2003 by Simon Geard. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH lrepeat n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lrepeat \- Build a list by repeating elements .SH SYNOPSIS -\fBlrepeat \fIcount \fR?\fIelement ...\fR? +\fBlrepeat \fInumber element1 \fR?\fIelement2 element3 ...\fR? .BE .SH DESCRIPTION .PP -The \fBlrepeat\fR command creates a list of size \fIcount * number of -elements\fR by repeating \fIcount\fR times the sequence of elements -\fIelement ...\fR. \fIcount\fR must be a non-negative integer, -\fIelement\fR can be any Tcl value. Note that \fBlrepeat 1 element ...\fR -is identical to \fBlist element ...\fR. +The \fBlrepeat\fR command creates a list of size \fInumber * number of +elements\fR by repeating \fInumber\fR times the sequence of elements +\fIelement1 element2 ...\fR. \fInumber\fR must be a positive integer, +\fIelementn\fR can be any Tcl value. Note that \fBlrepeat 1 arg ...\fR +is identical to \fBlist arg ...\fR, though the \fIarg\fR is required +with \fBlrepeat\fR. .SH EXAMPLES .CS \fBlrepeat\fR 3 a \fI\(-> a a a\fR \fBlrepeat\fR 3 [\fBlrepeat\fR 3 0] @@ -30,14 +31,9 @@ \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) +list(n), lappend(n), linsert(n), llength(n), lset(n) + .SH KEYWORDS element, index, list -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/lreplace.n ================================================================== --- doc/lreplace.n +++ doc/lreplace.n @@ -15,93 +15,71 @@ .SH SYNOPSIS \fBlreplace \fIlist first last \fR?\fIelement element ...\fR? .BE .SH DESCRIPTION .PP -\fBlreplace\fR returns a new list formed by replacing zero or more elements of +\fBlreplace\fR returns a new list formed by replacing one or more elements of \fIlist\fR with the \fIelement\fR arguments. +.VS 8.5 \fIfirst\fR and \fIlast\fR are index values specifying the first and last elements of the range to replace. The index values \fIfirst\fR and \fIlast\fR are interpreted the same as index values for the command \fBstring index\fR, supporting simple index arithmetic and indices relative to the end of the list. 0 refers to the first element of the list, and \fBend\fR refers to the last element of the list. +If \fIlist\fR is empty, then \fIfirst\fR and \fIlast\fR are ignored. +.VE .PP -If either \fIfirst\fR or \fIlast\fR is less than zero, it is considered -to refer to before the first element of the list. This allows \fBlreplace\fR -to prepend elements to \fIlist\fR. -.VS TIP505 -If either \fIfirst\fR or \fIlast\fR indicates a position greater than the -index of the last element of the list, it is treated as if it is an -index one greater than the last element. This allows \fBlreplace\fR to -append elements to \fIlist\fR. -.VE TIP505 +If \fIfirst\fR is less than zero, it is considered to refer to before the +first element of the list. For non-empty lists, the element indicated +by \fIfirst\fR must exist or \fIfirst\fR must indicate before the +start of the list. .PP If \fIlast\fR is less than \fIfirst\fR, then any specified elements -will be inserted into the list before the element specified by \fIfirst\fR +will be inserted into the list at the point specified by \fIfirst\fR with no elements being deleted. .PP -The \fIelement\fR arguments specify zero or more new elements to +The \fIelement\fR arguments specify zero or more new arguments to be added to the list in place of those that were deleted. Each \fIelement\fR argument will become a separate element of the list. If no \fIelement\fR arguments are specified, then the elements -between \fIfirst\fR and \fIlast\fR are simply deleted. +between \fIfirst\fR and \fIlast\fR are simply deleted. If \fIlist\fR +is empty, any \fIelement\fR arguments are added to the end of the list. .SH EXAMPLES -.PP Replacing an element of a list with another: -.PP .CS % \fBlreplace\fR {a b c d e} 1 1 foo a foo c d e .CE .PP Replacing two elements of a list with three: -.PP .CS % \fBlreplace\fR {a b c d e} 1 2 three more elements a three more elements d e .CE .PP Deleting the last element from a list in a variable: -.PP .CS % set var {a b c d e} a b c d e % set var [\fBlreplace\fR $var end end] a b c d .CE .PP A procedure to delete a given element from a list: -.PP .CS proc lremove {listVariable value} { upvar 1 $listVariable var set idx [lsearch -exact $var $value] set var [\fBlreplace\fR $var $idx $idx] } .CE -.PP -.VS TIP505 -Appending elements to the list; note that \fBend+2\fR will initially -be treated as if it is \fB6\fR here, but both that and \fB12345\fR are greater -than the index of the final item so they behave identically: -.PP -.CS -% 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), +list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), +lset(n), lrange(n), lsort(n), +.VS 8.5 string(n) +.VE .SH KEYWORDS element, list, replace -.\" Local variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: Index: doc/lreverse.n ================================================================== --- doc/lreverse.n +++ doc/lreverse.n @@ -1,11 +1,11 @@ -'\" +'\" -*- nroff -*- '\" Copyright (c) 2006 by Donal K. Fellows. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH lreverse n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -23,13 +23,9 @@ \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) +list(n), lsearch(n), lsort(n) + .SH KEYWORDS element, list, reverse -'\" Local Variables: -'\" mode: nroff -'\" End: Index: doc/lsearch.n ================================================================== --- doc/lsearch.n +++ doc/lsearch.n @@ -1,194 +1,154 @@ -'\" +'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny . All rights reserved. '\" Copyright (c) 2003-2004 Donal K. Fellows. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH lsearch n 8.6 Tcl "Tcl Built-In Commands" +'\" +.TH lsearch n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lsearch \- See if a list contains a particular element .SH SYNOPSIS \fBlsearch \fR?\fIoptions\fR? \fIlist pattern\fR .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 +If not, the command returns \fB\-1\fR. 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. .TP \fB\-exact\fR -. \fIPattern\fR is a literal string that is compared for exact equality against each list element. .TP \fB\-glob\fR -. \fIPattern\fR is a glob-style pattern which is matched against each list element using the same rules as the \fBstring match\fR command. .TP \fB\-regexp\fR -. \fIPattern\fR is treated as a regular expression and matched against each list element using the rules described in the \fBre_syntax\fR reference page. .TP \fB\-sorted\fR -. The list elements are in sorted order. If this option is specified, \fBlsearch\fR will use a more efficient searching algorithm to search \fIlist\fR. If no other options are specified, \fIlist\fR is assumed to be sorted in increasing order, and to contain ASCII strings. This option is mutually exclusive with \fB\-glob\fR and \fB\-regexp\fR, and is treated exactly like \fB\-exact\fR when either \fB\-all\fR or \fB\-not\fR are specified. .SS "GENERAL MODIFIER OPTIONS" -.PP These options may be given with all matching styles. .TP \fB\-all\fR . Changes the result to be the list of all matching indices (or all matching values if \fB\-inline\fR is specified as well.) If indices are returned, the -indices will be in ascending numeric order. If values are returned, the order -of the values will be the order of those values within the input \fIlist\fR. +indices will be in numeric order. If values are returned, the order of the +values will be the order of those values within the input \fIlist\fR. .TP \fB\-inline\fR -. The matching value is returned instead of its index (or an empty string if no value matches.) If \fB\-all\fR is also specified, then the result of the command is the list of all values that matched. .TP \fB\-not\fR -. This negates the sense of the match, returning the index of the first non-matching value in the list. .TP \fB\-start\fR\0\fIindex\fR -. The list is searched starting at position \fIindex\fR. +.VS 8.5 The interpretation of the \fIindex\fR value is the same as for the command \fBstring index\fR, supporting simple index arithmetic and indices relative to the end of the list. +.VE 8.5 .SS "CONTENTS DESCRIPTION OPTIONS" -.PP These options describe how to interpret the items in the list being searched. They are only meaningful when used with the \fB\-exact\fR and \fB\-sorted\fR options. If more than one is specified, the last one takes precedence. The default is \fB\-ascii\fR. .TP \fB\-ascii\fR -. The list elements are to be examined as Unicode strings (the name is for backward-compatibility reasons.) .TP \fB\-dictionary\fR -. The list elements are to be compared using dictionary-style comparisons (see \fBlsort\fR for a fuller description). Note that this only makes a meaningful difference from the \fB\-ascii\fR option when the \fB\-sorted\fR option is given, because values are only dictionary-equal when exactly equal. .TP \fB\-integer\fR -. The list elements are to be compared as integers. +.VS 8.5 .TP \fB\-nocase\fR -. Causes comparisons to be handled in a case-insensitive manner. Has no -effect if combined with the \fB\-dictionary\fR, \fB\-integer\fR, or +effect if combined with the \fB\-dictionary\fR, \fB\-integer\fR, or \fB\-real\fR options. +.VE 8.5 .TP \fB\-real\fR -. The list elements are to be compared as floating-point values. .SS "SORTED LIST OPTIONS" -.PP These options (only meaningful with the \fB\-sorted\fR option) specify how the list is sorted. If more than one is given, the last one takes precedence. The default option is \fB\-increasing\fR. .TP \fB\-decreasing\fR -. The list elements are sorted in decreasing order. This option is only meaningful when used with \fB\-sorted\fR. .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 +.VS 8.5 These options are used to search lists of lists. They may be used with any other options. .TP -\fB\-stride\0\fIstrideLength\fR -. -If this option is specified, the list is treated as consisting of -groups of \fIstrideLength\fR elements and the groups are searched by -either their first element or, if the \fB\-index\fR option is used, -by the element within each group given by the first index passed to -\fB\-index\fR (which is then ignored by \fB\-index\fR). The resulting -index always points to the first element in a group. -.PP -The list length must be an integer multiple of \fIstrideLength\fR, which -in turn must be at least 1. A \fIstrideLength\fR of 1 is the default and -indicates no grouping. -.TP \fB\-index\fR\0\fIindexList\fR -. This option is designed for use when searching within nested lists. The \fIindexList\fR argument gives a path of indices (much as might be used with the \fBlindex\fR or \fBlset\fR commands) within each element to allow the location of the term being matched against. .TP \fB\-subindices\fR -. If this option is given, the index result from this command (or every index result when \fB\-all\fR is also specified) will be a complete path (suitable for use with \fBlindex\fR or \fBlset\fR) within the overall list to the term found. This option has no effect unless the -\fB\-index\fR is also specified, and is just a convenience short-cut. +\fI\-index\fR is also specified, and is just a convenience short-cut. +.VE 8.5 .SH EXAMPLES -.PP Basic searching: -.PP .CS \fBlsearch\fR {a b c d e} c \fI\(-> 2\fR \fBlsearch\fR -all {a b c a b c} c \fI\(-> 2 5\fR .CE .PP Using \fBlsearch\fR to filter lists: -.PP .CS \fBlsearch\fR -inline {a20 b35 c47} b* \fI\(-> b35\fR \fBlsearch\fR -inline -not {a20 b35 c47} b* \fI\(-> a20\fR @@ -199,43 +159,32 @@ .CE .PP This can even do a .QW set-like removal operation: -.PP .CS \fBlsearch\fR -all -inline -not -exact {a b c a d e a f g a} a \fI\(-> b c d e f g\fR .CE .PP Searching may start part-way through the list: -.PP .CS \fBlsearch\fR -start 3 {a b c a b c} c \fI\(-> 5\fR .CE .PP It is also possible to search inside elements: -.PP .CS \fBlsearch\fR -index 1 -all -inline {{a abc} {b bcd} {c cde}} *bc* \fI\(-> {a abc} {b bcd}\fR .CE -.PP -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), +foreach(n), list(n), lappend(n), lindex(n), linsert(n), llength(n), +lset(n), lsort(n), lrange(n), lreplace(n), +.VS 8.5 string(n) +.VE .SH KEYWORDS -binary search, linear search, list, match, pattern, regular expression, search, string '\" Local Variables: '\" mode: nroff '\" End: Index: doc/lset.n ================================================================== --- doc/lset.n +++ doc/lset.n @@ -1,48 +1,44 @@ '\" '\" Copyright (c) 2001 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. -'\" +'\" .TH lset n 8.4 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lset \- Change an element in a list .SH SYNOPSIS -\fBlset \fIvarName ?index ...? newValue\fR +\fBlset \fIvarName ?index...? newValue\fR .BE .SH DESCRIPTION .PP The \fBlset\fR command accepts a parameter, \fIvarName\fR, which -it interprets as the name of a variable containing a Tcl list. +it interprets as the name of a variable containing a Tcl list. It also accepts zero or more \fIindices\fR into the list. The indices may be presented either consecutively on the command line, or grouped in a Tcl list and presented as a single argument. Finally, it accepts a new value for an element of \fIvarName\fR. .PP If no indices are presented, the command takes the form: -.PP .CS -\fBlset\fR varName newValue +lset varName newValue .CE -.PP or -.PP .CS -\fBlset\fR varName {} newValue +lset varName {} newValue .CE -.PP In this case, \fInewValue\fR replaces the old value of the variable \fIvarName\fR. .PP When presented with a single index, the \fBlset\fR command treats the content of the \fIvarName\fR variable as a Tcl list. -It addresses the \fIindex\fR'th element in it +It addresses the \fIindex\fR'th element in it (0 refers to the first element of the list). When interpreting the list, \fBlset\fR observes the same rules concerning braces and quotes and backslashes as the Tcl command interpreter; however, variable substitution and command substitution do not occur. @@ -49,57 +45,46 @@ The command constructs a new list in which the designated element is replaced with \fInewValue\fR. This new list is stored in the variable \fIvarName\fR, and is also the return value from the \fBlset\fR command. .PP -If \fIindex\fR is negative or greater than the number +If \fIindex\fR is negative or greater than or equal to the number of elements in \fI$varName\fR, then an error occurs. .PP -If \fIindex\fR is equal to the number of elements in \fI$varName\fR, -then the given element is appended to the list. -.PP +.VS 8.5 The interpretation of each simple \fIindex\fR value is the same as for the command \fBstring index\fR, supporting simple index arithmetic and indices relative to the end of the list. +.VE 8.5 .PP If additional \fIindex\fR arguments are supplied, then each argument is used in turn to address an element within a sublist designated by the previous indexing operation, -allowing the script to alter elements in sublists (or append elements -to sublists). The command, -.PP +allowing the script to alter elements in sublists. The command, .CS -\fBlset\fR a 1 2 newValue +lset a 1 2 newValue .CE -.PP or -.PP .CS -\fBlset\fR a {1 2} newValue +lset a {1 2} newValue .CE -.PP replaces element 2 of sublist 1 with \fInewValue\fR. .PP The integer appearing in each \fIindex\fR argument must be greater than or equal to zero. The integer appearing in each \fIindex\fR -argument must be less than or equal to the length of the corresponding -list. In other words, the \fBlset\fR command can change the size -of a list only by appending an element (setting the one after the current -end). If an index is outside the permitted range, an error is reported. +argument must be strictly less than the length of the corresponding +list. In other words, the \fBlset\fR command cannot change the size +of a list. If an index is outside the permitted range, an error is reported. .SH EXAMPLES -.PP In each of these examples, the initial value of \fIx\fR is: -.PP .CS set x [list [list a b c] [list d e f] [list g h i]] \fI\(-> {a b c} {d e f} {g h i}\fR .CE -.PP The indicated return value also becomes the new value of \fIx\fR (except in the last case, which is an error which leaves the value of \fIx\fR unchanged.) -.PP .CS \fBlset\fR x {j k l} \fI\(-> j k l\fR \fBlset\fR x {} {j k l} \fI\(-> j k l\fR @@ -114,36 +99,30 @@ \fBlset\fR x 2 1 j \fI\(-> {a b c} {d e f} {g j i}\fR \fBlset\fR x {2 1} j \fI\(-> {a b c} {d e f} {g j i}\fR \fBlset\fR x {2 3} j - \fI\(-> {a b c} {d e f} {g h i j}\fR -\fBlset\fR x {2 4} j \fI\(-> list index out of range\fR .CE -.PP In the following examples, the initial value of \fIx\fR is: -.PP .CS set x [list [list [list a b] [list c d]] \e [list [list e f] [list g h]]] \fI\(-> {{a b} {c d}} {{e f} {g h}}\fR .CE -.PP The indicated return value also becomes the new value of \fIx\fR. -.PP .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) +list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), +lsort(n), lrange(n), lreplace(n), +.VS 8.5 string(n) +.VE + + .SH KEYWORDS element, index, list, replace, set -'\"Local Variables: -'\"mode: nroff -'\"End: Index: doc/lsort.n ================================================================== --- doc/lsort.n +++ doc/lsort.n @@ -4,20 +4,21 @@ '\" Copyright (c) 1999 Scriptics Corporation '\" Copyright (c) 2001 Kevin B. Kenny . All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH lsort n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lsort \- Sort the elements of a list .SH SYNOPSIS \fBlsort \fR?\fIoptions\fR? \fIlist\fR .BE + .SH DESCRIPTION .PP This command sorts the elements of \fIlist\fR, returning a new list in sorted order. The implementation of the \fBlsort\fR command uses the merge\-sort algorithm which is a stable sort that has O(n log @@ -25,146 +26,105 @@ .PP By default ASCII sorting is used with the result returned in increasing order. However, any of the following options may be specified before \fIlist\fR to control the sorting process (unique abbreviations are accepted): -.TP +.TP 20 \fB\-ascii\fR -. Use string comparison with Unicode code-point collation order (the name is for backward-compatibility reasons.) This is the default. -.TP +.TP 20 \fB\-dictionary\fR -. Use dictionary-style comparison. This is the same as \fB\-ascii\fR except (a) case is ignored except as a tie-breaker and (b) if two strings contain embedded numbers, the numbers compare as integers, not characters. For example, in \fB\-dictionary\fR mode, \fBbigBoy\fR sorts between \fBbigbang\fR and \fBbigboy\fR, and \fBx10y\fR -sorts between \fBx9y\fR and \fBx11y\fR. Overrides the \fB\-nocase\fR -option. -.TP +sorts between \fBx9y\fR and \fBx11y\fR. +.TP 20 \fB\-integer\fR -. Convert list elements to integers and use integer comparison. -.TP +.TP 20 \fB\-real\fR -. Convert list elements to floating-point values and use floating comparison. -.TP +.TP 20 \fB\-command\0\fIcommand\fR -. Use \fIcommand\fR as a comparison command. To compare two elements, evaluate a Tcl script consisting of \fIcommand\fR with the two elements appended as additional arguments. The script should return an integer less than, equal to, or greater than zero if the first element is to be considered less than, equal to, or greater than the second, respectively. -.TP +.TP 20 \fB\-increasing\fR -. Sort the list in increasing order .PQ smallest "items first" . This is the default. -.TP +.TP 20 \fB\-decreasing\fR -. Sort the list in decreasing order .PQ largest "items first" . -.TP +.TP 20 \fB\-indices\fR -. +.VS "8.5 (TIP#217)" Return a list of indices into \fIlist\fR in sorted order instead of the values themselves. -.TP +.VE "8.5 (TIP#217)" +.TP 20 \fB\-index\0\fIindexList\fR -. If this option is specified, each of the elements of \fIlist\fR must -itself be a proper Tcl sublist (unless \fB\-stride\fR is used). -Instead of sorting based on whole sublists, \fBlsort\fR will extract -the \fIindexList\fR'th element from each sublist (as if the overall -element and the \fIindexList\fR were passed to \fBlindex\fR) and sort -based on the given element. +itself be a proper Tcl sublist. Instead of sorting based on whole +sublists, \fBlsort\fR will extract the \fIindexList\fR'th element from +each sublist +.VS 8.5 +(as if the overall element and the \fIindexList\fR were passed to +\fBlindex\fR) and sort based on the given element. +.VE 8.5 For example, .RS -.PP .CS -\fBlsort\fR -integer -index 1 \e +lsort -integer -index 1 \e {{First 24} {Second 18} {Third 30}} .CE -.PP -returns \fB{Second 18} {First 24} {Third 30}\fR, -.PP +returns \fB{Second 18} {First 24} {Third 30}\fR, and '\" '\" This example is from the test suite! '\" .CS -\fBlsort\fR -index end-1 \e - {{a 1 e i} {b 2 3 f g} {c 4 5 6 d h}} -.CE -.PP -returns \fB{c 4 5 6 d h} {a 1 e i} {b 2 3 f g}\fR, -and -.PP -.CS -\fBlsort\fR -index {0 1} { - {{b i g} 12345} - {{d e m o} 34512} - {{c o d e} 54321} -} -.CE -.PP -returns \fB{{d e m o} 34512} {{b i g} 12345} {{c o d e} 54321}\fR -(because \fBe\fR sorts before \fBi\fR which sorts before \fBo\fR.) +lsort -index end-1 \e + {{a 1 e i} {b 2 3 f g} {c 4 5 6 d h}} +.CE +returns \fB{c 4 5 6 d h} {a 1 e i} {b 2 3 f g}\fR, +.VS 8.5 +and +.CS +lsort -index {0 1} { + {{b i g} 12345} + {{d e m o} 34512} + {{c o d e} 54321} +} +.CE +returns \fB{{d e m o} 34512} {{b i g} 12345} {{c o d e} 54321}\fR +(because \fBe\fR sorts before \fBi\fR which sorts before \fBo\fR.) +.VE 8.5 This option is much more efficient than using \fB\-command\fR to achieve the same effect. .RE -.TP -\fB\-stride\0\fIstrideLength\fR -. -If this option is specified, the list is treated as consisting of -groups of \fIstrideLength\fR elements and the groups are sorted by -either their first element or, if the \fB\-index\fR option is used, -by the element within each group given by the first index passed to -\fB\-index\fR (which is then ignored by \fB\-index\fR). Elements -always remain in the same position within their group. -.RS -.PP -The list length must be an integer multiple of \fIstrideLength\fR, which -in turn must be at least 2. -.PP -For example, -.PP -.CS -\fBlsort\fR \-stride 2 {carrot 10 apple 50 banana 25} -.CE -.PP -returns -.QW "apple 50 banana 25 carrot 10" , -and -.PP -.CS -\fBlsort\fR \-stride 2 \-index 1 \-integer {carrot 10 apple 50 banana 25} -.CE -.PP -returns -.QW "carrot 10 banana 25 apple 50" . -.RE -.TP +.VS 8.5 +.TP 20 \fB\-nocase\fR -. Causes comparisons to be handled in a case-insensitive manner. Has no -effect if combined with the \fB\-dictionary\fR, \fB\-integer\fR, or +effect if combined with the \fB\-dictionary\fR, \fB\-integer\fR, or \fB\-real\fR options. -.TP +.VE 8.5 +.TP 20 \fB\-unique\fR -. If this option is specified, then only the last set of duplicate elements found in the list will be retained. Note that duplicates are -determined relative to the comparison used in the sort. Thus if -\fB\-index 0\fR is used, \fB{1 a}\fR and \fB{1 b}\fR would be +determined relative to the comparison used in the sort. Thus if +\fI\-index 0\fR is used, \fB{1 a}\fR and \fB{1 b}\fR would be considered duplicates and only the second element, \fB{1 b}\fR, would be retained. .SH "NOTES" .PP The options to \fBlsort\fR only control what sort of comparison is @@ -176,99 +136,72 @@ part of the implementation of a command used in the \fB\-command\fR option. .SH "EXAMPLES" .PP Sorting a list using ASCII sorting: -.PP .CS -\fI%\fR \fBlsort\fR {a10 B2 b1 a1 a2} +% \fBlsort\fR {a10 B2 b1 a1 a2} B2 a1 a10 a2 b1 .CE .PP Sorting a list using Dictionary sorting: -.PP .CS -\fI%\fR \fBlsort\fR -dictionary {a10 B2 b1 a1 a2} +% \fBlsort\fR -dictionary {a10 B2 b1 a1 a2} a1 a2 a10 b1 B2 .CE .PP Sorting lists of integers: -.PP .CS -\fI%\fR \fBlsort\fR -integer {5 3 1 2 11 4} +% \fBlsort\fR -integer {5 3 1 2 11 4} 1 2 3 4 5 11 -\fI%\fR \fBlsort\fR -integer {1 2 0x5 7 0 4 -1} +% \fBlsort\fR -integer {1 2 0x5 7 0 4 -1} -1 0 1 2 4 0x5 7 .CE .PP Sorting lists of floating-point numbers: -.PP .CS -\fI%\fR \fBlsort\fR -real {5 3 1 2 11 4} +% \fBlsort\fR -real {5 3 1 2 11 4} 1 2 3 4 5 11 -\fI%\fR \fBlsort\fR -real {.5 0.07e1 0.4 6e-1} +% \fBlsort\fR -real {.5 0.07e1 0.4 6e-1} 0.4 .5 6e-1 0.07e1 .CE .PP Sorting using indices: -.PP .CS -\fI%\fR # Note the space character before the c -\fI%\fR \fBlsort\fR {{a 5} { c 3} {b 4} {e 1} {d 2}} +% # Note the space character before the c +% \fBlsort\fR {{a 5} { c 3} {b 4} {e 1} {d 2}} { 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}} +% \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}} +% \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} +Stripping duplicate values using sorting: +.CS +% \fBlsort\fR -unique {a b c a b c a b c} a b c .CE .PP More complex sorting using a comparison function: -.PP .CS -\fI%\fR proc compare {a b} { +% proc compare {a b} { set a0 [lindex $a 0] set b0 [lindex $b 0] if {$a0 < $b0} { return -1 } elseif {$a0 > $b0} { return 1 } return [string compare [lindex $a 1] [lindex $b 1]] } -\fI%\fR \fBlsort\fR -command compare \e +% \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) +list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), +lset(n), lrange(n), lreplace(n) + .SH KEYWORDS element, list, order, sort -'\" Local Variables: -'\" mode: nroff -'\" End: Index: doc/mathfunc.n ================================================================== --- doc/mathfunc.n +++ doc/mathfunc.n @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-2000 Sun Microsystems, Inc. '\" 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. -'\" +'\" .TH mathfunc n 8.5 Tcl "Tcl Mathematical Functions" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -33,12 +33,14 @@ .br \fB::tcl::mathfunc::cosh\fR \fIarg\fR .br \fB::tcl::mathfunc::double\fR \fIarg\fR .br +.VS 8.5 \fB::tcl::mathfunc::entier\fR \fIarg\fR .br +.VE 8.5 \fB::tcl::mathfunc::exp\fR \fIarg\fR .br \fB::tcl::mathfunc::floor\fR \fIarg\fR .br \fB::tcl::mathfunc::fmod\fR \fIx\fR \fIy\fR @@ -45,28 +47,12 @@ .br \fB::tcl::mathfunc::hypot\fR \fIx\fR \fIy\fR .br \fB::tcl::mathfunc::int\fR \fIarg\fR .br -.VS "8.7, TIP 521" -\fB::tcl::mathfunc::isfinite\fR \fIarg\fR -.br -\fB::tcl::mathfunc::isinf\fR \fIarg\fR -.br -\fB::tcl::mathfunc::isnan\fR \fIarg\fR -.br -\fB::tcl::mathfunc::isnormal\fR \fIarg\fR -.VE "8.7, TIP 521" -.br \fB::tcl::mathfunc::isqrt\fR \fIarg\fR .br -.VS "8.7, TIP 521" -\fB::tcl::mathfunc::issubnormal\fR \fIarg\fR -.br -\fB::tcl::mathfunc::isunordered\fR \fIx y\fR -.VE "8.7, TIP 521" -.br \fB::tcl::mathfunc::log\fR \fIarg\fR .br \fB::tcl::mathfunc::log10\fR \fIarg\fR .br \fB::tcl::mathfunc::max\fR \fIarg\fR ?\fIarg\fR ...? @@ -106,260 +92,180 @@ directly. .PP Tcl supports the following mathematical functions in expressions, all of which work solely with floating-point numbers unless otherwise noted: .DS -.ta 3.2c 6.4c 9.6c +.ta 3c 6c 9c \fBabs\fR \fBacos\fR \fBasin\fR \fBatan\fR \fBatan2\fR \fBbool\fR \fBceil\fR \fBcos\fR \fBcosh\fR \fBdouble\fR \fBentier\fR \fBexp\fR \fBfloor\fR \fBfmod\fR \fBhypot\fR \fBint\fR -\fBisfinite\fR \fBisinf\fR \fBisnan\fR \fBisnormal\fR -\fBisqrt\fR \fBissubnormal\fR \fBisunordered\fR \fBlog\fR -\fBlog10\fR \fBmax\fR \fBmin\fR \fBpow\fR -\fBrand\fR \fBround\fR \fBsin\fR \fBsinh\fR -\fBsqrt\fR \fBsrand\fR \fBtan\fR \fBtanh\fR -\fBwide\fR +\fBisqrt\fR \fBlog\fR \fBlog10\fR \fBmax\fR +\fBmin\fR \fBpow\fR \fBrand\fR \fBround\fR +\fBsin\fR \fBsinh\fR \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. +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 \fBacos \fIarg\fR -. Returns the arc cosine of \fIarg\fR, in the range [\fI0\fR,\fIpi\fR] radians. \fIArg\fR should be in the range [\fI\-1\fR,\fI1\fR]. .TP \fBasin \fIarg\fR -. Returns the arc sine of \fIarg\fR, in the range [\fI\-pi/2\fR,\fIpi/2\fR] radians. \fIArg\fR should be in the range [\fI\-1\fR,\fI1\fR]. .TP \fBatan \fIarg\fR -. Returns the arc tangent of \fIarg\fR, in the range [\fI\-pi/2\fR,\fIpi/2\fR] radians. .TP \fBatan2 \fIy x\fR -. Returns the arc tangent of \fIy\fR/\fIx\fR, in the range [\fI\-pi\fR,\fIpi\fR] radians. \fIx\fR and \fIy\fR cannot both be 0. If \fIx\fR is greater than \fI0\fR, this is equivalent to .QW "\fBatan \fR[\fBexpr\fR {\fIy\fB/\fIx\fR}]" . .TP \fBbool \fIarg\fR -. Accepts any numeric value, or any string acceptable to -\fBstring is boolean\fR, and returns the corresponding +\fBstring is boolean\fR, and returns the corresponding boolean value \fB0\fR or \fB1\fR. Non-zero numbers are true. Other numbers are false. Non-numeric strings produce boolean value in agreement with \fBstring is true\fR and \fBstring is false\fR. .TP \fBceil \fIarg\fR -. Returns the smallest integral floating-point value (i.e. with a zero fractional part) not less than \fIarg\fR. The argument may be any numeric value. .TP \fBcos \fIarg\fR -. Returns the cosine of \fIarg\fR, measured in radians. .TP \fBcosh \fIarg\fR -. Returns the hyperbolic cosine of \fIarg\fR. If the result would cause an overflow, an error is returned. .TP \fBdouble \fIarg\fR -. The argument may be any numeric value, If \fIarg\fR is a floating-point value, returns \fIarg\fR, otherwise converts \fIarg\fR to floating-point and returns the converted value. May return \fBInf\fR or \fB\-Inf\fR when the argument is a numeric value that exceeds the floating-point range. .TP \fBentier \fIarg\fR -. +.VS 8.5 The argument may be any numeric value. The integer part of \fIarg\fR is determined and returned. The integer range returned by this function is unlimited, unlike \fBint\fR and \fBwide\fR which truncate their range to fit in particular storage widths. +.VE 8.5 .TP \fBexp \fIarg\fR -. Returns the exponential of \fIarg\fR, defined as \fIe\fR**\fIarg\fR. If the result would cause an overflow, an error is returned. .TP \fBfloor \fIarg\fR -. Returns the largest integral floating-point value (i.e. with a zero fractional part) not greater than \fIarg\fR. The argument may be any numeric value. .TP \fBfmod \fIx y\fR -. Returns the floating-point remainder of the division of \fIx\fR by \fIy\fR. If \fIy\fR is 0, an error is returned. .TP \fBhypot \fIx y\fR -. -Computes the length of the hypotenuse of a right-angled triangle, -approximately -.QW "\fBsqrt\fR [\fBexpr\fR {\fIx\fB*\fIx\fB+\fIy\fB*\fIy\fR}]" -except for being more numerically stable when the two arguments have -substantially different magnitudes. +Computes the length of the hypotenuse of a right-angled triangle +.QW "\fBsqrt\fR [\fBexpr\fR {\fIx\fB*\fIx\fB+\fIy\fB*\fIy\fR}]". .TP \fBint \fIarg\fR -. The argument may be any numeric value. The integer part of \fIarg\fR is determined, and then the low order bits of that integer value up to the machine word size are returned as an integer value. For reference, -the number of bytes in the machine word are stored in the \fBwordSize\fR -element of the \fBtcl_platform\fR array. -.TP -\fBisfinite \fIarg\fR -.VS "8.7, TIP 521" -Returns 1 if the floating-point number \fIarg\fR is finite. That is, if it is -zero, subnormal, or normal. Returns 0 if the number is infinite or NaN. Throws -an error if \fIarg\fR cannot be promoted to a floating-point value. -.VE "8.7, TIP 521" -.TP -\fBisinf \fIarg\fR -.VS "8.7, TIP 521" -Returns 1 if the floating-point number \fIarg\fR is infinite. Returns 0 if the -number is finite or NaN. Throws an error if \fIarg\fR cannot be promoted to a -floating-point value. -.VE "8.7, TIP 521" -.TP -\fBisnan \fIarg\fR -.VS "8.7, TIP 521" -Returns 1 if the floating-point number \fIarg\fR is Not-a-Number. Returns 0 if -the number is finite or infinite. Throws an error if \fIarg\fR cannot be -promoted to a floating-point value. -.VE "8.7, TIP 521" -.TP -\fBisnormal \fIarg\fR -.VS "8.7, TIP 521" -Returns 1 if the floating-point number \fIarg\fR is normal. Returns 0 if the -number is zero, subnormal, infinite or NaN. Throws an error if \fIarg\fR -cannot be promoted to a floating-point value. -.VE "8.7, TIP 521" +the number of bytes in the machine word are stored in +\fBtcl_platform(wordSize)\fR. .TP \fBisqrt \fIarg\fR -. Computes the integer part of the square root of \fIarg\fR. \fIArg\fR must be a positive value, either an integer or a floating point number. Unlike \fBsqrt\fR, which is limited to the precision of a floating point number, \fIisqrt\fR will return a result of arbitrary precision. .TP -\fBissubnormal \fIarg\fR -.VS "8.7, TIP 521" -Returns 1 if the floating-point number \fIarg\fR is subnormal, i.e., the -result of gradual underflow. Returns 0 if the number is zero, normal, infinite -or NaN. Throws an error if \fIarg\fR cannot be promoted to a floating-point -value. -.VE "8.7, TIP 521" -.TP -\fBisunordered \fIx y\fR -.VS "8.7, TIP 521" -Returns 1 if \fIx\fR and \fIy\fR cannot be compared for ordering, that is, if -either one is NaN. Returns 0 if both values can be ordered, that is, if they -are both chosen from among the set of zero, subnormal, normal and infinite -values. Throws an error if either \fIx\fR or \fIy\fR cannot be promoted to a -floating-point value. -.VE "8.7, TIP 521" -.TP \fBlog \fIarg\fR -. Returns the natural logarithm of \fIarg\fR. \fIArg\fR must be a positive value. .TP \fBlog10 \fIarg\fR -. Returns the base 10 logarithm of \fIarg\fR. \fIArg\fR must be a positive value. .TP \fBmax \fIarg\fB \fI...\fR -. Accepts one or more numeric arguments. Returns the one argument with the greatest value. .TP \fBmin \fIarg\fB \fI...\fR -. Accepts one or more numeric arguments. Returns the one argument with the least value. .TP \fBpow \fIx y\fR -. Computes the value of \fIx\fR raised to the power \fIy\fR. If \fIx\fR is negative, \fIy\fR must be an integer value. .TP \fBrand\fR -. -Returns a pseudo-random floating-point value in the range (\fI0\fR,\fI1\fR). +Returns a pseudo-random floating-point value in the range (\fI0\fR,\fI1\fR). The generator algorithm is a simple linear congruential generator that is not cryptographically secure. Each result from \fBrand\fR completely determines all future results from subsequent calls to \fBrand\fR, so \fBrand\fR should not be used to generate a sequence of secrets, such as one-time passwords. The seed of the generator is initialized from the internal clock of the machine or may be set with the \fBsrand\fR function. .TP \fBround \fIarg\fR -. If \fIarg\fR is an integer value, returns \fIarg\fR, otherwise converts \fIarg\fR to integer by rounding and returns the converted value. .TP \fBsin \fIarg\fR -. Returns the sine of \fIarg\fR, measured in radians. .TP \fBsinh \fIarg\fR -. Returns the hyperbolic sine of \fIarg\fR. If the result would cause an overflow, an error is returned. .TP \fBsqrt \fIarg\fR -. The argument may be any non-negative numeric value. Returns a floating-point value that is the square root of \fIarg\fR. May return \fBInf\fR when the argument is a numeric value that exceeds the square of the maximum value of the floating-point range. .TP \fBsrand \fIarg\fR -. The \fIarg\fR, which must be an integer, is used to reset the seed for the random number generator of \fBrand\fR. Returns the first random number (see \fBrand\fR) from that seed. Each interpreter has its own seed. .TP \fBtan \fIarg\fR -. Returns the tangent of \fIarg\fR, measured in radians. .TP \fBtanh \fIarg\fR -. Returns the hyperbolic tangent of \fIarg\fR. .TP \fBwide \fIarg\fR -. The argument may be any numeric value. The integer part of \fIarg\fR is determined, and then the low order 64 bits of that integer value -are returned as an integer value. +are returned as an integer value. .SH "SEE ALSO" -expr(n), fpclassify(n), mathop(n), namespace(n) +expr(n), mathop(n), namespace(n) .SH "COPYRIGHT" .nf -Copyright \(co 1993 The Regents of the University of California. -Copyright \(co 1994-2000 Sun Microsystems Incorporated. -Copyright \(co 2005, 2006 by Kevin B. Kenny . +Copyright (c) 1993 The Regents of the University of California. +Copyright (c) 1994-2000 Sun Microsystems Incorporated. +Copyright (c) 2005, 2006 by Kevin B. Kenny . .fi -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/mathop.n ================================================================== --- doc/mathop.n +++ doc/mathop.n @@ -1,6 +1,6 @@ -.\" +.\" -*- nroff -*- .\" Copyright (c) 2006-2007 Donal K. Fellows. .\" .\" See the file "license.terms" for information on usage and redistribution .\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. .\" @@ -53,20 +53,10 @@ .br \fB::tcl::mathop::eq\fR ?\fIarg\fR ...? .br \fB::tcl::mathop::ne\fR \fIarg arg\fR .br -.VS "8.7, TIP461" -\fB::tcl::mathop::lt\fR ?\fIarg\fR ...? -.br -\fB::tcl::mathop::le\fR ?\fIarg\fR ...? -.br -\fB::tcl::mathop::gt\fR ?\fIarg\fR ...? -.br -\fB::tcl::mathop::ge\fR ?\fIarg\fR ...? -.VE "8.7, TIP461" -.br \fB::tcl::mathop::in\fR \fIarg list\fR .br \fB::tcl::mathop::ni\fR \fIarg list\fR .sp .BE @@ -84,12 +74,11 @@ .ta 2c 4c 6c 8c \fB~\fR \fB!\fR \fB+\fR \fB\-\fR \fB*\fR \fB/\fR \fB%\fR \fB**\fR \fB&\fR \fB|\fR \fB^\fR \fB>>\fR \fB<<\fR \fB==\fR \fBeq\fR \fB!=\fR \fBne\fR \fB<\fR \fB<=\fR \fB>\fR -\fB>=\fR \fBin\fR \fBni\fR \fBlt\fR \fBle\fR -\fBgt\fR \fBge\fR +\fB>=\fR \fBin\fR \fBni\fR .DE .SS "MATHEMATICAL OPERATORS" .PP The behaviors of the mathematical operator commands are as follows: .TP @@ -147,11 +136,11 @@ Note that Tcl defines this operation exactly even for negative numbers, so that the following command returns a true value (omitting the namespace for clarity): .PP .CS -\fB==\fR [\fB*\fR [\fB/\fI x y\fR] \fIy\fR] [\fB\-\fI x\fR [\fB%\fI x y\fR]] +\fB==\fR [\fB*\fR [\fB/\fI x y\fR] \fIy\fR] [\fB-\fI x\fR [\fB%\fI x y\fR]] .CE .RE .TP \fB**\fR ?\fInumber\fR ...? . @@ -160,15 +149,14 @@ .QW "\fB** 2 3 4\fR" is the same as .QW "\fB** 2 [** 3 4]\fR" . Each \fInumber\fR may be any numeric value, though the second number must not be fractional if the -first is negative. The maximum exponent value that Tcl can handle if the -first number is an integer > 1 is 268435455. If no arguments are given, -the result will be one, and if only one argument is given, the result will -be that argument. The result will have an integral value only when all -arguments are integral values. +first is negative. If no arguments are given, the result will be one, and if +only one argument is given, the result will be that argument. The +result will have an integral value only when all arguments are +integral values. .SS "COMPARISON OPERATORS" .PP The behaviors of the comparison operator commands (most of which operate preferentially on numeric arguments) are as follows: .TP @@ -201,74 +189,42 @@ Returns whether the arbitrarily-many arguments are ordered, with each argument after the first having to be strictly more than the one preceding it. Comparisons are performed preferentially on the numeric values, and are otherwise performed using UNICODE string comparison. If fewer than two arguments are present, this operation always returns a true value. When the -arguments are numeric but should be compared as strings, the \fBlt\fR -operator or the \fBstring compare\fR command should be used instead. +arguments are numeric but should be compared as strings, the \fBstring +compare\fR command should be used instead. .TP \fB<=\fR ?\fIarg\fR ...? . Returns whether the arbitrarily-many arguments are ordered, with each argument after the first having to be equal to or more than the one preceding it. Comparisons are performed preferentially on the numeric values, and are otherwise performed using UNICODE string comparison. If fewer than two arguments are present, this operation always returns a true value. When the -arguments are numeric but should be compared as strings, the \fBle\fR -operator or the \fBstring compare\fR command should be used instead. +arguments are numeric but should be compared as strings, the \fBstring +compare\fR command should be used instead. .TP \fB>\fR ?\fIarg\fR ...? . Returns whether the arbitrarily-many arguments are ordered, with each argument after the first having to be strictly less than the one preceding it. Comparisons are performed preferentially on the numeric values, and are otherwise performed using UNICODE string comparison. If fewer than two arguments are present, this operation always returns a true value. When the -arguments are numeric but should be compared as strings, the \fBgt\fR -operator or the \fBstring compare\fR command should be used instead. +arguments are numeric but should be compared as strings, the \fBstring +compare\fR command should be used instead. .TP \fB>=\fR ?\fIarg\fR ...? . Returns whether the arbitrarily-many arguments are ordered, with each argument after the first having to be equal to or less than the one preceding it. Comparisons are performed preferentially on the numeric values, and are otherwise performed using UNICODE string comparison. If fewer than two arguments are present, this operation always returns a true value. When the -arguments are numeric but should be compared as strings, the \fBge\fR -operator or the \fBstring compare\fR command should be used instead. -.TP -\fBlt\fR ?\fIarg\fR ...? -.VS "8.7, TIP461" -Returns whether the arbitrarily-many arguments are ordered, with each argument -after the first having to be strictly more than the one preceding it. -Comparisons are performed using UNICODE string comparison. If fewer than two -arguments are present, this operation always returns a true value. -.VE "8.7, TIP461" -.TP -\fBle\fR ?\fIarg\fR ...? -.VS "8.7, TIP461" -Returns whether the arbitrarily-many arguments are ordered, with each argument -after the first having to be equal to or strictly more than the one preceding it. -Comparisons are performed using UNICODE string comparison. If fewer than two -arguments are present, this operation always returns a true value. -.VE "8.7, TIP461" -.TP -\fBgt\fR ?\fIarg\fR ...? -.VS "8.7, TIP461" -Returns whether the arbitrarily-many arguments are ordered, with each argument -after the first having to be strictly less than the one preceding it. -Comparisons are performed using UNICODE string comparison. If fewer than two -arguments are present, this operation always returns a true value. -.VE "8.7, TIP461" -.TP -\fBge\fR ?\fIarg\fR ...? -.VS "8.7, TIP461" -Returns whether the arbitrarily-many arguments are ordered, with each argument -after the first having to be equal to or strictly less than the one preceding it. -Comparisons are performed using UNICODE string comparison. If fewer than two -arguments are present, this operation always returns a true value. -.VE "8.7, TIP461" +arguments are numeric but should be compared as strings, the \fBstring +compare\fR command should be used instead. .SS "BIT-WISE OPERATORS" .PP The behaviors of the bit-wise operator commands (all of which only operate on integral arguments) are as follows: .TP @@ -319,15 +275,13 @@ \fBni\fR \fIarg list\fR . Returns whether the value \fIarg\fR is not present in the list \fIlist\fR (according to exact string comparison of elements). .SH EXAMPLES -.PP The simplest way to use the operators is often by using \fBnamespace path\fR to make the commands available. This has the advantage of not affecting the set of commands defined by the current namespace. -.PP .CS namespace path {\fB::tcl::mathop\fR ::tcl::mathfunc} \fI# Compute the sum of some numbers\fR set sum [\fB+\fR 1 2 3] @@ -340,19 +294,12 @@ set gotIt [\fBin\fR 3 $list] \fI# Test to see if a value is within some defined range\fR set inRange [\fB<=\fR 1 $x 5] -\fI# Test to see if a list is numerically sorted\fR +\fI# Test to see if a list is sorted\fR set sorted [\fB<=\fR {*}$list] - -\fI# Test to see if a list is lexically sorted\fR -set alphaList {a b c d e f} -set sorted [\fBle\fR {*}$alphaList] .CE .SH "SEE ALSO" expr(n), mathfunc(n), namespace(n) .SH KEYWORDS command, expression, operator -'\" Local Variables: -'\" mode: nroff -'\" End: Index: doc/memory.n ================================================================== --- doc/memory.n +++ doc/memory.n @@ -1,10 +1,10 @@ '\" '\" Copyright (c) 1992-1999 by Karl Lehenbauer and Mark Diekhans '\" Copyright (c) 2000 by Scriptics Corporation. '\" All rights reserved. -'\" +'\" .TH memory n 8.1 Tcl "Tcl Built-In Commands" .so man.macros .BS .SH NAME memory \- Control Tcl memory debugging capabilities @@ -23,22 +23,22 @@ . 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, \fBTcl_Alloc\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 +Returns a report containing the total allocations and frees since Tcl began, the current packets allocated (the current -number of calls to \fBTcl_Alloc\fR not met by a corresponding call -to \fBTcl_Free\fR), the current bytes allocated, and the maximum number +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 @@ -57,59 +57,56 @@ 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 \fBTcl_Alloc\fR can have associated +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 \fBTcl_Alloc\fR to be \fIstring\fR. +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 \fBTcl_Alloc\fR causes a line of trace information to be written to -\fIstderr\fR, consisting of the word \fITcl_Alloc\fR, followed by the +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 -Tcl_Alloc 40e478 98 tclProc.c 1406 +ckalloc 40e478 98 tclProc.c 1406 .CE .PP -Calls to \fBTcl_Free\fR are traced in the same manner. +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 \fBTcl_Alloc\fRs have been performed. +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 \fBTcl_Alloc\fR, memory trace information will begin +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 +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 \fBTcl_Alloc\fR or \fBTcl_Free\fR, the guard zones are +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 \fBTcl_Alloc\fR. This has a large performance impact and +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 \fBTcl_Alloc\fR or -\fBTcl_Free\fR after the overwrite occurred, rather than when the +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" -Tcl_Alloc, Tcl_Free, Tcl_ValidateAllMemory, Tcl_DumpActiveMemory, TCL_MEM_DEBUG +ckalloc, ckfree, Tcl_ValidateAllMemory, Tcl_DumpActiveMemory, TCL_MEM_DEBUG .SH KEYWORDS memory, debug -'\"Local Variables: -'\"mode: nroff -'\"End: Index: doc/msgcat.n ================================================================== --- doc/msgcat.n +++ doc/msgcat.n @@ -1,67 +1,43 @@ '\" '\" Copyright (c) 1998 Mark Harrison. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH "msgcat" n 1.5 msgcat "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME msgcat \- Tcl message catalog .SH SYNOPSIS -\fBpackage require Tcl 8.7\fR +\fBpackage require Tcl 8.5\fR .sp -\fBpackage require msgcat 1.7\fR +\fBpackage require msgcat 1.5\fR .sp \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR? .sp \fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR? .sp -.VS "TIP 412" -\fB::msgcat::mcexists\fR ?\fB-exactnamespace\fR? ?\fB-exactlocale\fR? \fIsrc-string\fR -.VE "TIP 412" -.sp -.VS "TIP 490" -\fB::msgcat::mcpackagenamespaceget\fR -.VE "TIP 490" -.sp \fB::msgcat::mclocale \fR?\fInewLocale\fR? .sp -.VS "TIP 499" -\fB::msgcat::mcpreferences\fR ?\fIlocale preference\fR? ... -.VE "TIP 499" -.sp -.VS "TIP 412" -\fB::msgcat::mcloadedlocales subcommand\fR ?\fIlocale\fR? -.VE "TIP 412" +\fB::msgcat::mcpreferences\fR .sp \fB::msgcat::mcload \fIdirname\fR .sp \fB::msgcat::mcset \fIlocale src-string \fR?\fItranslate-string\fR? .sp \fB::msgcat::mcmset \fIlocale src-trans-list\fR .sp +.VS "TIP 404" \fB::msgcat::mcflset \fIsrc-string \fR?\fItranslate-string\fR? .sp \fB::msgcat::mcflmset \fIsrc-trans-list\fR +.VE "TIP 404" .sp \fB::msgcat::mcunknown \fIlocale src-string\fR ?\fIarg arg ...\fR? -.sp -.VS "TIP 412" -\fB::msgcat::mcpackagelocale subcommand\fR ?\fIlocale\fR? -.sp -\fB::msgcat::mcpackageconfig subcommand\fR \fIoption\fR ?\fIvalue\fR? -.sp -\fB::msgcat::mcforgetpackage\fR -.VE "TIP 412" -.sp -.VS "TIP 499" -\fB::msgcat::mcutil subcommand\fR ?\fIlocale\fR? -.VS "TIP 499" .BE .SH DESCRIPTION .PP The \fBmsgcat\fR package provides a set of functions that can be used to manage multi-lingual user interfaces. @@ -68,32 +44,22 @@ Text strings are defined in a .QW "message catalog" which is independent from the application, and which can be edited or localized without modifying the application source code. New languages -or locales may be provided by adding a new file to +or locales are provided by adding a new file to the message catalog. .PP -\fBmsgcat\fR distinguises packages by its namespace. -Each package has its own message catalog and configuration settings in \fBmsgcat\fR. -.PP -A \fIlocale\fR is a specification string describing a user language like \fBde_ch\fR for Swiss German. -In \fBmsgcat\fR, there is a global locale initialized by the system locale of the current system. -Each package may decide to use the global locale or to use a package specific locale. -.PP -The global locale may be changed on demand, for example by a user initiated language change or within a multi user application like a web server. -.PP -.VS tip490 -Object oriented programming is supported by the use of a package namespace. -.VE tip490 -.PP +Use of the message catalog is optional by any application +or package, but is encouraged if the application or package +wishes to be enabled for multi-lingual applications. .SH COMMANDS .TP \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR? . Returns a translation of \fIsrc-string\fR according to the -current locale. If additional arguments past \fIsrc-string\fR +user's current locale. If additional arguments past \fIsrc-string\fR are given, the \fBformat\fR command is used to substitute the additional arguments in the translation of \fIsrc-string\fR. .RS .PP \fB::msgcat::mc\fR will search the messages defined @@ -108,150 +74,52 @@ application can pass the English string through \fB::msgcat::mc\fR and use the result. If an application is written for a single language in this fashion, then it is easy to add support for additional languages later simply by defining new message catalog entries. .RE -.VS "TIP 490" -.TP -\fB::msgcat::mcn \fInamespace\fR \fIsrc-string\fR ?\fIarg arg ...\fR? -. -Like \fB::msgcat::mc\fR, but with the message namespace specified as first argument. -.PP -.RS -\fBmcn\fR may be used for cases where the package namespace is not the namespace of the caller. -An example is shown within the description of the command \fB::msgcat::mcpackagenamespaceget\fR below. -.RE -.PP .TP \fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR? . Given several source strings, \fB::msgcat::mcmax\fR returns the length of the longest translated string. This is useful when designing localized GUIs, which may require that all buttons, for example, be a fixed width (which will be the width of the widest button). -.VS "TIP 412" -.TP -\fB::msgcat::mcexists\fR ?\fB-exactnamespace\fR? ?\fB-exactlocale\fR? ?\fB-namespace\fR \fInamespace\fR? \fIsrc-string\fR -. -Return true, if there is a translation for the given \fIsrc-string\fR. -.PP -.RS -The search may be limited by the option \fB\-exactnamespace\fR to only check the current namespace and not any parent namespaces. -.PP -It may also be limited by the option \fB\-exactlocale\fR to only check the first prefered locale (e.g. first element returned by \fB::msgcat::mcpreferences\fR if global locale is used). -.PP -.VE "TIP 412" -.VS "TIP 490" -An explicit package namespace may be specified by the option \fB-namespace\fR. -The namespace of the caller is used if not explicitly specified. -.RE -.PP -.VE "TIP 490" -.VS "TIP 490" -.TP -\fB::msgcat::mcpackagenamespaceget\fR -. -Return the package namespace of the caller. -This command handles all cases described in section \fBOBJECT ORIENTED PROGRAMMING\fR. -.PP -.RS -Example usage is a tooltip package, which saves the caller package namespace to update the translation each time the tooltip is shown: -.CS -proc ::tooltip::tooltip {widget message} { - ... - set messagenamespace [uplevel 1 {::msgcat::mcpackagenamespaceget}] - ... - bind $widget [list ::tooltip::show $widget $messagenamespace $message] -} - -proc ::tooltip::show {widget messagenamespace message} { - ... - set message [::msgcat::mcn $messagenamespace $message] - ... -} -.CE -.RE -.PP -.VE "TIP 490" .TP \fB::msgcat::mclocale \fR?\fInewLocale\fR? . -If \fInewLocale\fR is omitted, the current locale is returned, otherwise the current locale -is set to \fInewLocale\fR. -.PP -.RS -If the new locale is set to \fInewLocale\fR, the corresponding preferences are calculated and set. -For example, if the current locale is en_US_funky, then \fB::msgcat::mcpreferences\fR returns \fB{en_us_funky en_us en {}}\fR. -.PP -The same result may be acheved by \fB::msgcat::mcpreferences\fR {*}[\fB::msgcat::mcutil getpreferences\fR \fInewLocale\fR]. -.PP -The current locale is always the first element of the list returned by \fBmcpreferences\fR. -.PP -msgcat stores and compares the locale in a +This function sets the locale to \fInewLocale\fR. If \fInewLocale\fR +is omitted, the current locale is returned, otherwise the current locale +is set to \fInewLocale\fR. msgcat stores and compares the locale in a case-insensitive manner, and returns locales in lowercase. The initial locale is determined by the locale specified in the user's environment. See \fBLOCALE SPECIFICATION\fR below for a description of the locale string format. -.PP -.VS "TIP 412" -If the locale is set, the preference list of locales is evaluated. -Locales in this list are loaded now, if not jet loaded. -.VE "TIP 412" -.RE -.TP -\fB::msgcat::mcpreferences\fR ?\fIlocale preference\fR? ... -. -Without arguments, returns an ordered list of the locales preferred by -the user. -The list is ordered from most specific to least preference. -.PP -.VS "TIP 499" -.RS -A set of locale preferences may be given to set the list of locale preferences. -The current locale is also set, which is the first element of the locale preferences list. -.PP -Locale preferences are loaded now, if not jet loaded. -.PP -As an example, the user may prefer French or English text. This may be configured by: -.CS -::msgcat::mcpreferences fr en {} -.CE -.RE -.PP -.VS "TIP 499" -.TP -\fB::msgcat:mcloadedlocales subcommand\fR ?\fIlocale\fR? -. -This group of commands manage the list of loaded locales for packages not setting a package locale. -.PP -.RS -The subcommand \fBget\fR returns the list of currently loaded locales. -.PP -The subcommand \fBpresent\fR requires the argument \fIlocale\fR and returns true, if this locale is loaded. -.PP -The subcommand \fBclear\fR removes all locales and their data, which are not in the current preference list. -.RE +.TP +\fB::msgcat::mcpreferences\fR +. +Returns an ordered list of the locales preferred by +the user, based on the user's language specification. +The list is ordered from most specific to least +preference. The list is derived from the current +locale set in msgcat by \fB::msgcat::mclocale\fR, and +cannot be set independently. For example, if the +current locale is en_US_funky, then \fB::msgcat::mcpreferences\fR +returns \fB{en_US_funky en_US en {}}\fR. .TP \fB::msgcat::mcload \fIdirname\fR . -.VS "TIP 412" Searches the specified directory for files that match -the language specifications returned by \fB::msgcat::mcloadedlocales get\fR -(or \fBmsgcat::mcpackagelocale preferences\fR if a package locale is set) (note that these are all lowercase), extended by the file extension +the language specifications returned by \fB::msgcat::mcpreferences\fR +(note that these are all lowercase), extended by the file extension .QW .msg . Each matching file is read in order, assuming a UTF-8 encoding. The file contents are then evaluated as a Tcl script. This means that Unicode characters may be present in the message file either directly in their UTF-8 encoded form, or by use of the backslash-u quoting recognized by Tcl evaluation. The number of message files which matched the specification and were loaded is returned. -.RS -.PP -In addition, the given folder is stored in the \fBmsgcat\fR package configuration option \fImcfolder\fR to eventually load message catalog files required by a locale change. -.VE "TIP 412" -.RE .TP \fB::msgcat::mcset \fIlocale src-string \fR?\fItranslate-string\fR? . Sets the translation for \fIsrc-string\fR to \fItranslate-string\fR in the specified \fIlocale\fR and the current namespace. If @@ -268,24 +136,28 @@ translate-string ...\fR?} \fB::msgcat::mcmset\fR can be significantly faster than multiple invocations of \fB::msgcat::mcset\fR. The function returns the number of translations set. .TP \fB::msgcat::mcflset \fIsrc-string \fR?\fItranslate-string\fR? +.VS "TIP 404" Sets the translation for \fIsrc-string\fR to \fItranslate-string\fR in the current namespace for the locale implied by the name of the message catalog being loaded via \fB::msgcat::mcload\fR. If \fItranslate-string\fR is not specified, \fIsrc-string\fR is used for both. The function returns \fItranslate-string\fR. +.VE "TIP 404" .TP \fB::msgcat::mcflmset \fIsrc-trans-list\fR +.VS "TIP 404" Sets the translation for multiple source strings in \fIsrc-trans-list\fR in the current namespace for the locale implied by the name of the message catalog being loaded via \fB::msgcat::mcload\fR. \fIsrc-trans-list\fR must have an even number of elements and is in the form {\fIsrc-string translate-string\fR ?\fIsrc-string translate-string ...\fR?} \fB::msgcat::mcflmset\fR can be significantly faster than multiple invocations of \fB::msgcat::mcflset\fR. The function returns the number of translations set. +.VE "TIP 404" .TP \fB::msgcat::mcunknown \fIlocale src-string\fR ?\fIarg arg ...\fR? . This routine is called by \fB::msgcat::mc\fR in the case when a translation for \fIsrc-string\fR is not defined in the @@ -294,38 +166,11 @@ procedure can be redefined by the application, for example to log error messages for each unknown string. The \fB::msgcat::mcunknown\fR procedure is invoked at the same stack context as the call to \fB::msgcat::mc\fR. The return value of \fB::msgcat::mcunknown\fR is used as the return value for the call -to \fB::msgcat::mc\fR. -.VS "TIP 412" -.RS -.PP -Note that this routine is only called if the concerned package did not set a package locale unknown command name. -.RE -.TP -\fB::msgcat::mcforgetpackage\fR -. -The calling package clears all its state within the \fBmsgcat\fR package including all settings and translations. -.VE "TIP 412" -.PP -.VS "TIP 499" -.TP -\fB::msgcat::mcutil getpreferences\fR \fIlocale\fR -. -Return the preferences list of the given locale as described in section \fBLOCALE SPECIFICATION\fR. -An example is the composition of a preference list for the bilingual region "Biel/Bienne" as a concatenation of swiss german and swiss french: -.CS -% concat [lrange [msgcat::mcutil getpreferences fr_CH] 0 end-1] [msgcat::mcutil getpreferences de_CH] -fr_ch fr de_ch de {} -.CE -.TP -\fB::msgcat::mcutil getsystemlocale\fR -. -The system locale is returned as described by the section \fBLOCALE SPECIFICATION\fR. -.VE "TIP 499" -.PP +to \fB::msgcat::mc\fR. .SH "LOCALE SPECIFICATION" .PP The locale is specified to \fBmsgcat\fR by a locale string passed to \fB::msgcat::mclocale\fR. The locale string consists of @@ -349,11 +194,11 @@ .CS language[_country][.codeset][@modifier] .CE .PP to extract its parts. The initial locale is then set by calling -\fB::msgcat::mclocale\fR with the argument +\fB::msgcat::mclocale\fR with the argument .PP .CS language[_country][_modifier] .CE .PP @@ -370,19 +215,19 @@ When a locale is specified by the user, a .QW "best match" search is performed during string translation. For example, if a user specifies en_GB_Funky, the locales -.QW en_gb_funky , -.QW en_gb , +.QW en_GB_Funky , +.QW en_GB , .QW en and .MT (the empty string) are searched in order until a matching translation string is found. If no translation string is available, then -the unknown handler is called. +\fB::msgcat::mcunknown\fR is called. .SH "NAMESPACES AND MESSAGE CATALOGS" .PP Strings stored in the message catalog are stored relative to the namespace from which they were added. This allows multiple packages to use the same strings without fear @@ -526,277 +371,15 @@ .CS \fBmsgcat::mc\fR {Produced %1$d at %2$s} $num $city # ... where that key is mapped to one of the # human-oriented versions by \fBmsgcat::mcset\fR .CE -.VS "TIP 412" -.SH "PACKAGE PRIVATE LOCALE" -.PP -A package using \fBmsgcat\fR may choose to use its own package private -locale and its own set of loaded locales, independent to the global -locale set by \fB::msgcat::mclocale\fR. -.PP -This allows a package to change its locale without causing any locales load or removal in other packages and not to invoke the global locale change callback (see below). -.PP -This action is controled by the following ensemble: -.TP -\fB::msgcat::mcpackagelocale set\fR ?\fIlocale\fR? -. -Set or change a package private locale. -The package private locale is set to the given \fIlocale\fR if the \fIlocale\fR is given. -If the option \fIlocale\fR is not given, the package is set to package private locale mode, but no locale is changed (e.g. if the global locale was valid for the package before, it is copied to the package private locale). -.PP -.RS -This command may cause the load of locales. -.RE -.TP -\fB::msgcat::mcpackagelocale get\fR -. -Return the package private locale or the global locale, if no package private locale is set. -.TP -\fB::msgcat::mcpackagelocale preferences\fR ?\fIlocale preference\fR? ... -. -With no parameters, return the package private preferences or the global preferences, -if no package private locale is set. -The package locale state (set or not) is not changed (in contrast to the command \fB::msgcat::mcpackagelocale set\fR). -.PP -.RS -.VS "TIP 499" -If a set of locale preferences is given, it is set as package locale preference list. -The package locale is set to the first element of the preference list. -A package locale is activated, if it was not set so far. -.PP -Locale preferences are loaded now for the package, if not jet loaded. -.VE "TIP 499" -.RE -.PP -.TP -\fB::msgcat::mcpackagelocale loaded\fR -. -Return the list of locales loaded for this package. -.TP -\fB::msgcat::mcpackagelocale isset\fR -. -Returns true, if a package private locale is set. -.TP -\fB::msgcat::mcpackagelocale unset\fR -. -Unset the package private locale and use the globale locale. -Load and remove locales to adjust the list of loaded locales for the -package to the global loaded locales list. -.TP -\fB::msgcat::mcpackagelocale present\fR \fIlocale\fR -. -Returns true, if the given locale is loaded for the package. -.TP -\fB::msgcat::mcpackagelocale clear\fR -. -Clear any loaded locales of the package not present in the package preferences. -.PP -.SH "CHANGING PACKAGE OPTIONS" -.PP -Each package using msgcat has a set of options within \fBmsgcat\fR. -The package options are described in the next sectionPackage options. -Each package option may be set or unset individually using the following ensemble: -.TP -\fB::msgcat::mcpackageconfig get\fR \fIoption\fR -. -Return the current value of the given \fIoption\fR. -This call returns an error if the option is not set for the package. -.TP -\fB::msgcat::mcpackageconfig isset\fR \fIoption\fR -. -Returns 1, if the given \fIoption\fR is set for the package, 0 otherwise. -.TP -\fB::msgcat::mcpackageconfig set\fR \fIoption\fR \fIvalue\fR -. -Set the given \fIoption\fR to the given \fIvalue\fR. -This may invoke additional actions in dependency of the \fIoption\fR. -The return value is 0 or the number of loaded packages for the option \fBmcfolder\fR. -.TP -\fB::msgcat::mcpackageconfig unset\fR \fIoption\fR -. -Unsets the given \fIoption\fR for the package. -No action is taken if the \fIoption\fR is not set for the package. -The empty string is returned. -.SS Package options -.PP -The following package options are available for each package: -.TP -\fBmcfolder\fR -. -This is the message folder of the package. This option is set by mcload and by the subcommand set. Both are identical and both return the number of loaded message catalog files. -.RS -.PP -Setting or changing this value will load all locales contained in the preferences valid for the package. This implies also to invoke any set loadcmd (see below). -.PP -Unsetting this value will disable message file load for the package. -.RE -.TP -\fBloadcmd\fR -. -This callback is invoked before a set of message catalog files are loaded for the package which has this property set. -.PP -.RS -This callback may be used to do any preparation work for message file load or to get the message data from another source like a data base. In this case, no message files are used (mcfolder is unset). -.PP -See section \fBcallback invocation\fR below. -The parameter list appended to this callback is the list of locales to load. -.PP -If this callback is changed, it is called with the preferences valid for the package. -.RE -.TP -\fBchangecmd\fR -. -This callback is invoked when a default local change was performed. Its purpose is to allow a package to update any dependency on the default locale like showing the GUI in another language. -.PP -.RS -See the callback invocation section below. -The parameter list appended to this callback is \fBmcpreferences\fR. -The registered callbacks are invoked in no particular order. -.RE -.TP -\fBunknowncmd\fR -. -Use a package locale mcunknown procedure instead of the standard version supplied by the msgcat package (msgcat::mcunknown). -.PP -.RS -The called procedure must return the formatted message which will finally be returned by msgcat::mc. -.PP -A generic unknown handler is used if set to the empty string. This consists in returning the key if no arguments are given. With given arguments, format is used to process the arguments. -.PP -See section \fBcallback invocation\fR below. -The appended arguments are identical to \fB::msgcat::mcunknown\fR. -.RE -.SH "Callback invocation" -A package may decide to register one or multiple callbacks, as described above. -.PP -Callbacks are invoked, if: -.PP -1. the callback command is set, -.PP -2. the command is not the empty string, -.PP -3. the registering namespace exists. -.PP -If a called routine fails with an error, the \fBbgerror\fR routine for the interpreter is invoked after command completion. -Only exception is the callback \fBunknowncmd\fR, where an error causes the invoking \fBmc\fR-command to fail with that error. -.PP -.VS tip490 -.SH "OBJECT ORIENTED PROGRAMMING" -\fBmsgcat\fR supports packages implemented by object oriented programming. -Objects and classes should be defined within a package namespace. -.PP -There are 3 supported cases where package namespace sensitive commands of msgcat (\fBmc\fR, \fBmcexists\fR, \fBmcpackagelocale\fR, \fBmcforgetpackage\fR, \fBmcpackagenamespaceget\fR, \fBmcpackageconfig\fR, \fBmcset\fR and \fBmcmset\fR) may be called: -.PP -.TP -\fB1) In class definition script\fR -. -\fBmsgcat\fR command is called within a class definition script. -.CS -namespace eval ::N2 { - mcload $dir/msgs - oo::class create C1 {puts [mc Hi!]} -} -.CE -.PP -.TP -\fB2) method defined in a class\fR -. -\fBmsgcat\fR command is called from a method in an object and the method is defined in a class. -.CS -namespace eval ::N3Class { - mcload $dir/msgs - oo::class create C1 - oo::define C1 method m1 { - puts [mc Hi!] - } -} -.CE -.PP -.TP -\fB3) method defined in a classless object\fR -. -\fBmsgcat\fR command is called from a method of a classless object. -.CS -namespace eval ::N4 { - mcload $dir/msgs - oo::object create O1 - oo::objdefine O1 method m1 {} { - puts [mc Hi!] - } -} -.CE -.PP -.VE tip490 -.SH EXAMPLES -Packages which display a GUI may update their widgets when the global locale changes. -To register to a callback, use: -.CS -namespace eval gui { - msgcat::mcpackageconfig changecmd updateGUI - - proc updateGui args { - puts "New locale is '[lindex $args 0]'." - } -} -% msgcat::mclocale fr -fr -% New locale is 'fr'. -.CE -.PP -If locales (or additional locales) are contained in another source like a data base, a package may use the load callback and not mcload: -.CS -namespace eval db { - msgcat::mcpackageconfig loadcmd loadMessages - - proc loadMessages args { - foreach locale $args { - if {[LocaleInDB $locale]} { - msgcat::mcmset $locale [GetLocaleList $locale] - } - } - } -} -.CE -.PP -The \fBclock\fR command implementation uses \fBmsgcat\fR with a package locale to implement the command line parameter \fB-locale\fR. -Here are some sketches of the implementation: -.PP -First, a package locale is initialized and the generic unknown function is desactivated: -.CS -msgcat::mcpackagelocale set -msgcat::mcpackageconfig unknowncmd "" -.CE -As an example, the user requires the week day in a certain locale as follows: -.CS -clock format clock seconds -format %A -locale fr -.CE -\fBclock\fR sets the package locale to \fBfr\fR and looks for the day name as follows: -.CS -msgcat::mcpackagelocale set $locale -return [lindex [msgcat::mc DAYS_OF_WEEK_FULL] $day] -### Returns "mercredi" -.CE -Within \fBclock\fR, some message-catalog items are heavy in computation and thus are dynamically cached using: -.CS -proc ::tcl::clock::LocalizeFormat { locale format } { - set key FORMAT_$format - if { [::msgcat::mcexists -exactlocale -exactnamespace $key] } { - return [mc $key] - } - #...expensive computation of format clipped... - mcset $locale $key $format - return $format -} -.CE -.VE "TIP 412" .SH CREDITS .PP The message catalog code was developed by Mark Harrison. .SH "SEE ALSO" -format(n), scan(n), namespace(n), package(n), oo::class(n), oo::object +format(n), scan(n), namespace(n), package(n) .SH KEYWORDS -internationalization, i18n, localization, l10n, message, text, translation, class, object +internationalization, i18n, localization, l10n, message, text, translation .\" Local Variables: .\" mode: nroff .\" End: DELETED doc/my.n Index: doc/my.n ================================================================== --- doc/my.n +++ /dev/null @@ -1,131 +0,0 @@ -'\" -'\" Copyright (c) 2007 Donal K. Fellows -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH my n 0.1 TclOO "TclOO Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -my, myclass \- invoke any method of current object or its class -.SH SYNOPSIS -.nf -package require TclOO - -\fBmy\fI methodName\fR ?\fIarg ...\fR? -\fBmyclass\fI methodName\fR ?\fIarg ...\fR? -.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 -defined by that object or class. -.VE TIP500 -.PP -The object upon which the method is invoked via \fBmy\fR is the one that owns -the namespace that the \fBmy\fR command is contained in initially (\fBNB:\fR the link -remains if the command is renamed), which is the currently invoked object by -default. -.VS TIP478 -Similarly, the object on which the method is invoked via \fBmyclass\fR is the -object that is the current class of the object that owns the namespace that -the \fBmyclass\fR command is contained in initially. As with \fBmy\fR, the -link remains even if the command is renamed into another namespace, and -defaults to being the manufacturing class of the current object. -.VE TIP478 -.PP -Each object has its own \fBmy\fR and \fBmyclass\fR commands, contained in its -instance namespace. -.SH EXAMPLES -.PP -This example shows basic use of \fBmy\fR to use the \fBvariables\fR method of -the \fBoo::object\fR class, which is not publicly visible by default: -.PP -.CS -oo::class create c { - method count {} { - \fBmy\fR variable counter - puts [incr counter] - } -} - -c create o -o count \fI\(-> prints "1"\fR -o count \fI\(-> prints "2"\fR -o count \fI\(-> prints "3"\fR -.CE -.PP -This example shows how you can use \fBmy\fR to make callbacks to private -methods from outside the object (from a \fBtrace\fR), using -\fBnamespace code\fR to enter the correct context. (See the \fBcallback\fR -command for the recommended way of doing this.) -.PP -.CS -oo::class create HasCallback { - method makeCallback {} { - return [namespace code { - \fBmy\fR Callback - }] - } - - method Callback {args} { - puts "callback: $args" - } -} - -set o [HasCallback new] -trace add variable xyz write [$o makeCallback] -set xyz "called" \fI\(-> prints "callback: xyz {} write"\fR -.CE -.PP -.VS TIP478 -This example shows how to access a private method of a class from an instance -of that class. (See the \fBclassmethod\fR declaration in \fBoo::define\fR for -a higher level interface for doing this.) -.PP -.CS -oo::class create CountedSteps { - self { - variable count - method Count {} { - return [incr count] - } - } - method advanceTwice {} { - puts "in [self] step A: [\fBmyclass\fR Count]" - puts "in [self] step B: [\fBmyclass\fR Count]" - } -} - -CountedSteps create x -CountedSteps create y -x advanceTwice \fI\(-> prints "in ::x step A: 1"\fR - \fI\(-> prints "in ::x step B: 2"\fR -y advanceTwice \fI\(-> prints "in ::y step A: 3"\fR - \fI\(-> prints "in ::y step B: 4"\fR -x advanceTwice \fI\(-> prints "in ::x step A: 5"\fR - \fI\(-> prints "in ::x step B: 6"\fR -y advanceTwice \fI\(-> prints "in ::y step A: 7"\fR - \fI\(-> prints "in ::y step B: 8"\fR -.CE -.VE TIP478 -.SH "SEE ALSO" -next(n), oo::object(n), self(n) -.SH KEYWORDS -method, method visibility, object, private method, public method -.\" Local variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: Index: doc/namespace.n ================================================================== --- doc/namespace.n +++ doc/namespace.n @@ -24,11 +24,10 @@ for a brief overview of namespaces. The legal values of \fIsubcommand\fR are listed below. Note that you can abbreviate the \fIsubcommand\fRs. .TP \fBnamespace children \fR?\fInamespace\fR? ?\fIpattern\fR? -. Returns a list of all child namespaces that belong to the namespace \fInamespace\fR. If \fInamespace\fR is not specified, then the children are returned for the current namespace. This command returns fully-qualified names, @@ -40,11 +39,10 @@ otherwise the namespace \fInamespace\fR (or the fully-qualified name of the current namespace) is prepended onto the pattern. .TP \fBnamespace code \fIscript\fR -. Captures the current namespace context for later execution of the script \fIscript\fR. It returns a new script in which \fIscript\fR has been wrapped in a \fBnamespace inscope\fR command. The new script has two important properties. @@ -68,20 +66,18 @@ in a way that allows it to be executed properly later. See the section \fBSCOPED SCRIPTS\fR for some examples of how this is used to create callback scripts. .TP \fBnamespace current\fR -. Returns the fully-qualified name for the current namespace. The actual name of the global namespace is .MT (i.e., an empty string), but this command returns \fB::\fR for the global namespace as a convenience to programmers. .TP \fBnamespace delete \fR?\fInamespace namespace ...\fR? -. Each namespace \fInamespace\fR is deleted and all variables, procedures, and child namespaces contained in the namespace are deleted. If a procedure is currently executing inside the namespace, the namespace will be kept alive until the procedure returns; @@ -89,17 +85,17 @@ looking it up by name. If a namespace does not exist, this command returns an error. If no namespace names are given, this command does nothing. .TP \fBnamespace ensemble\fR \fIsubcommand\fR ?\fIarg ...\fR? -. +.VS 8.5 Creates and manipulates a command that is formed out of an ensemble of subcommands. See the section \fBENSEMBLES\fR below for further details. +.VE 8.5 .TP \fBnamespace eval\fR \fInamespace arg\fR ?\fIarg ...\fR? -. Activates a namespace called \fInamespace\fR and evaluates some code in that context. If the namespace does not already exist, it is created. If more than one \fIarg\fR argument is specified, the arguments are concatenated together with a space between each one @@ -111,16 +107,14 @@ and any leading namespaces do not exist, they are automatically created. .RE .TP \fBnamespace exists\fR \fInamespace\fR -. Returns \fB1\fR if \fInamespace\fR is a valid namespace in the current context, returns \fB0\fR otherwise. .TP -\fBnamespace export \fR?\fB\-clear\fR? ?\fIpattern pattern ...\fR? -. +\fBnamespace export \fR?\-\fBclear\fR? ?\fIpattern pattern ...\fR? Specifies which commands are exported from a namespace. The exported commands are those that can be later imported into another namespace using a \fBnamespace import\fR command. Both commands defined in a namespace and commands the namespace has previously imported @@ -137,11 +131,10 @@ \fIpattern\fR arguments are appended. If no \fIpattern\fRs are given and the \fB\-clear\fR flag is not given, this command returns the namespace's current export list. .TP \fBnamespace forget \fR?\fIpattern pattern ...\fR? -. Removes previously imported commands from a namespace. Each \fIpattern\fR is a simple or qualified name such as \fBx\fR, \fBfoo::x\fR or \fBa::b::p*\fR. Qualified names contain double colons (\fB::\fR) and qualify a name with the name of one or more namespaces. @@ -162,54 +155,46 @@ were previously imported by the current namespace. If so, this command deletes the corresponding imported commands. In effect, this un-does the action of a \fBnamespace import\fR command. .TP \fBnamespace import \fR?\fB\-force\fR? ?\fIpattern\fR \fIpattern ...\fR? -. +.VS 8.5 Imports commands into a namespace, or queries the set of imported commands in a namespace. When no arguments are present, \fBnamespace import\fR returns the list of commands in the current namespace that have been imported from other namespaces. The commands in the returned list are in the format of simple names, with no namespace qualifiers at all. This format is suitable for composition with \fBnamespace forget\fR (see \fBEXAMPLES\fR below). -.RS -.PP +.VE 8.5 When \fIpattern\fR arguments are present, each \fIpattern\fR is a qualified name like \fBfoo::x\fR or \fBa::p*\fR. That is, it includes the name of an exporting namespace and may have glob-style special characters in the command name at the end of the qualified name. Glob characters may not appear in a namespace name. -When the namespace name is not fully qualified (i.e., does not start -with a namespace separator) it is resolved as a namespace name in the -way described in the \fBNAME RESOLUTION\fR section; it is an error if -no namespace with that name can be found. -.PP All the commands that match a \fIpattern\fR string and which are currently exported from their namespace are added to the current namespace. This is done by creating a new command in the current namespace that points to the exported command in its original namespace; when the new imported command is called, it invokes the exported command. This command normally returns an error if an imported command conflicts with an existing command. -However, if the \fB\-force\fR option is given, +However, if the \-\fBforce\fR option is given, imported commands will silently replace existing commands. The \fBnamespace import\fR command has snapshot semantics: that is, only requested commands that are currently defined in the exporting namespace are imported. In other words, you can import only the commands that are in a namespace at the time when the \fBnamespace import\fR command is executed. If another command is defined and exported in this namespace later on, it will not be imported. -.RE .TP \fBnamespace inscope\fR \fInamespace\fR \fIscript\fR ?\fIarg ...\fR? -. Executes a script in the context of the specified \fInamespace\fR. This command is not expected to be used directly by programmers; calls to it are generated implicitly when applications use \fBnamespace code\fR commands to create callback scripts that the applications then register with, e.g., Tk widgets. @@ -220,23 +205,19 @@ .RS .PP .CS \fBnamespace inscope ::foo $script $x $y $z\fR .CE -.PP is equivalent to -.PP .CS \fBnamespace eval ::foo [concat $script [list $x $y $z]]\fR .CE -.PP thus additional arguments will not undergo a second round of substitution, as is the case with \fBnamespace eval\fR. .RE .TP \fBnamespace origin \fIcommand\fR -. Returns the fully-qualified name of the original command to which the imported command \fIcommand\fR refers. When a command is imported into a namespace, a new command is created in that namespace that points to the actual command in the exporting namespace. @@ -247,27 +228,27 @@ in the first namespace, \fIa\fR. If \fIcommand\fR does not refer to an imported command, the command's own fully-qualified name is returned. .TP \fBnamespace parent\fR ?\fInamespace\fR? -. Returns the fully-qualified name of the parent namespace for namespace \fInamespace\fR. If \fInamespace\fR is not specified, the fully-qualified name of the current namespace's parent is returned. .TP \fBnamespace path\fR ?\fInamespaceList\fR? -. +.\" Should really have the .TP inside the .VS, but that triggers a groff bug +.VS 8.5 Returns the command resolution path of the current namespace. If \fInamespaceList\fR is specified as a list of named namespaces, the current namespace's command resolution path is set to those namespaces and returns the empty list. The default command resolution path is always empty. See the section \fBNAME RESOLUTION\fR below for an explanation of the rules regarding name resolution. +.VE 8.5 .TP \fBnamespace qualifiers\fR \fIstring\fR -. Returns any leading namespace qualifiers for \fIstring\fR. Qualifiers are namespace names separated by double colons (\fB::\fR). For the \fIstring\fR \fB::foo::bar::x\fR, this command returns \fB::foo::bar\fR, and for \fB::\fR it returns an empty string. @@ -275,46 +256,41 @@ Note that it does not check whether the namespace names are, in fact, the names of currently defined namespaces. .TP \fBnamespace tail\fR \fIstring\fR -. Returns the simple name at the end of a qualified string. Qualifiers are namespace names separated by double colons (\fB::\fR). For the \fIstring\fR \fB::foo::bar::x\fR, this command returns \fBx\fR, and for \fB::\fR it returns an empty string. This command is the complement of the \fBnamespace qualifiers\fR command. It does not check whether the namespace names are, in fact, the names of currently defined namespaces. .TP -\fBnamespace upvar\fR \fInamespace\fR ?\fIotherVar myVar \fR...? -. -This command arranges for zero or more local variables in the current +\fBnamespace upvar\fR \fInamespace\fR \fIotherVar myVar \fR?\fIotherVar myVar \fR... +This command arranges for one or more local variables in the current procedure to refer to variables in \fInamespace\fR. The namespace name is resolved as described in section \fBNAME RESOLUTION\fR. The command \fBnamespace upvar $ns a b\fR has the same behaviour as \fBupvar 0 ${ns}::a b\fR, with the sole exception of the resolution rules used for qualified namespace or variable names. \fBnamespace upvar\fR returns an empty string. .TP \fBnamespace unknown\fR ?\fIscript\fR? -. Sets or returns the unknown command handler for the current namespace. The handler is invoked when a command called from within the namespace -cannot be found in the current namespace, the namespace's path nor in -the global namespace. +cannot be found (in either the current namespace or the global namespace). The \fIscript\fR argument, if given, should be a well formed list representing a command name and optional arguments. When the handler is invoked, the full invocation line will be appended to the script and the result evaluated in the context of the namespace. The default handler for all namespaces is \fB::unknown\fR. If no argument is given, it returns the handler for the current namespace. .TP -\fBnamespace which\fR ?\fB\-command\fR? ?\fB\-variable\fR? \fIname\fR -. +\fBnamespace which\fR ?\-\fBcommand\fR? ?\-\fBvariable\fR? \fIname\fR Looks up \fIname\fR as either a command or variable and returns its fully-qualified name. For example, if \fIname\fR does not exist in the current namespace but does exist in the global namespace, this command returns a fully-qualified name in the global namespace. @@ -334,23 +310,21 @@ Tcl has always had one such collection, which we refer to as the \fIglobal namespace\fR. The global namespace holds all global variables and commands. The \fBnamespace eval\fR command lets you create new namespaces. For example, -.PP .CS \fBnamespace eval\fR Counter { - \fBnamespace export\fR bump - variable num 0 + \fBnamespace export\fR bump + variable num 0 - proc bump {} { - variable num - incr num - } + proc bump {} { + variable num + incr num + } } .CE -.PP creates a new namespace containing the variable \fBnum\fR and the procedure \fBbump\fR. The commands and variables in this namespace are separate from other commands and variables in the same program. If there is a command named \fBbump\fR in the global namespace, @@ -366,29 +340,27 @@ You can add and delete commands and variables at any time, so you can build up the contents of a namespace over time using a series of \fBnamespace eval\fR commands. For example, the following series of commands has the same effect as the namespace definition shown above: -.PP -.CS -\fBnamespace eval\fR Counter { - variable num 0 - proc bump {} { - variable num - return [incr num] - } -} -\fBnamespace eval\fR Counter { - proc test {args} { - return $args - } -} -\fBnamespace eval\fR Counter { - rename test "" -} -.CE -.PP +.CS +\fBnamespace eval\fR Counter { + variable num 0 + proc bump {} { + variable num + return [incr num] + } +} +\fBnamespace eval\fR Counter { + proc test {args} { + return $args + } +} +\fBnamespace eval\fR Counter { + rename test "" +} +.CE Note that the \fBtest\fR procedure is added to the \fBCounter\fR namespace, and later removed via the \fBrename\fR command. .PP Namespaces can have other namespaces within them, so they nest hierarchically. @@ -416,42 +388,34 @@ If you want to access commands and variables from another namespace, you must use some extra syntax. Names must be qualified by the namespace that contains them. From the global namespace, we might access the \fBCounter\fR procedures like this: -.PP .CS Counter::bump 5 Counter::Reset .CE -.PP We could access the current count like this: -.PP .CS puts "count = $Counter::num" .CE -.PP When one namespace contains another, you may need more than one qualifier to reach its elements. If we had a namespace \fBFoo\fR that contained the namespace \fBCounter\fR, you could invoke its \fBbump\fR procedure from the global namespace like this: -.PP .CS Foo::Counter::bump 3 .CE .PP You can also use qualified names when you create and rename commands. For example, you could add a procedure to the \fBFoo\fR namespace like this: -.PP .CS proc Foo::Test {args} {return $args} .CE -.PP And you could move the same procedure to another namespace like this: -.PP .CS rename Foo::Test Bar::Test .CE .PP There are a few remaining points about qualified names @@ -474,71 +438,64 @@ there is no question about what command, variable, or namespace you mean. However, if the name does not start with a \fB::\fR (i.e., is \fIrelative\fR), Tcl follows basic rules for looking it up: -.IP \(bu -\fBVariable names\fR are always resolved by looking first in the current -namespace, and then in the global namespace. -.IP \(bu -\fBCommand names\fR are always resolved by looking in the current namespace -first. If not found there, they are searched for in every namespace on the -current namespace's command path (which is empty by default). If not found -there, command names are looked up in the global namespace (or, failing that, -are processed by the appropriate \fBnamespace unknown\fR handler.) -.IP \(bu -\fBNamespace names\fR are always resolved by looking in only the current -namespace. +Variable names are always resolved +by looking first in the current namespace, +and then in the global namespace. +.VS 8.5 +Command names are also always resolved by looking in the current +namespace first. If not found there, they are searched for in every +namespace on the current namespace's command path (which is empty by +default). If not found there, command names are looked up in the +global namespace (or, failing that, are processed by the \fBunknown\fR +command.) +.VE 8.5 +Namespace names, on the other hand, are always resolved +by looking in only the current namespace. .PP In the following example, -.PP .CS set traceLevel 0 \fBnamespace eval\fR Debug { - printTrace $traceLevel + printTrace $traceLevel } .CE -.PP Tcl looks for \fBtraceLevel\fR in the namespace \fBDebug\fR and then in the global namespace. It looks up the command \fBprintTrace\fR in the same way. If a variable or command name is not found in either context, the name is undefined. To make this point absolutely clear, consider the following example: -.PP .CS set traceLevel 0 \fBnamespace eval\fR Foo { - variable traceLevel 3 + variable traceLevel 3 - \fBnamespace eval\fR Debug { - printTrace $traceLevel - } + \fBnamespace eval\fR Debug { + printTrace $traceLevel + } } .CE -.PP Here Tcl looks for \fBtraceLevel\fR first in the namespace \fBFoo::Debug\fR. Since it is not found there, Tcl then looks for it in the global namespace. The variable \fBFoo::traceLevel\fR is completely ignored during the name resolution process. .PP You can use the \fBnamespace which\fR command to clear up any question about name resolution. For example, the command: -.PP .CS \fBnamespace eval\fR Foo::Debug {\fBnamespace which\fR \-variable traceLevel} .CE -.PP returns \fB::traceLevel\fR. On the other hand, the command, -.PP .CS \fBnamespace eval\fR Foo {\fBnamespace which\fR \-variable traceLevel} .CE -.PP returns \fB::Foo::traceLevel\fR. .PP As mentioned above, namespace names are looked up differently than the names of variables and commands. @@ -572,46 +529,38 @@ Some library commands are used so frequently that it is a nuisance to type their qualified names. For example, suppose that all of the commands in a package like BLT are contained in a namespace called \fBBlt\fR. Then you might access these commands like this: -.PP .CS Blt::graph .g \-background red Blt::table . .g 0,0 .CE -.PP If you use the \fBgraph\fR and \fBtable\fR commands frequently, you may want to access them without the \fBBlt::\fR prefix. You can do this by importing the commands into the current namespace, like this: -.PP .CS \fBnamespace import\fR Blt::* .CE -.PP This adds all exported commands from the \fBBlt\fR namespace into the current namespace context, so you can write code like this: -.PP .CS graph .g \-background red table . .g 0,0 .CE -.PP The \fBnamespace import\fR command only imports commands from a namespace that that namespace exported with a \fBnamespace export\fR command. .PP Importing \fIevery\fR command from a namespace is generally a bad idea since you do not know what you will get. It is better to import just the specific commands you need. For example, the command -.PP .CS \fBnamespace import\fR Blt::graph Blt::table .CE -.PP imports only the \fBgraph\fR and \fBtable\fR commands into the current context. .PP If you try to import a command that already exists, you will get an error. This prevents you from importing the same command from two @@ -618,71 +567,61 @@ different packages. But from time to time (perhaps when debugging), you may want to get around this restriction. You may want to reissue the \fBnamespace import\fR command to pick up new commands that have appeared in a namespace. In that case, you can use the \fB\-force\fR option, and existing commands will be silently overwritten: -.PP .CS \fBnamespace import\fR \-force Blt::graph Blt::table .CE -.PP If for some reason, you want to stop using the imported commands, you can remove them with a \fBnamespace forget\fR command, like this: -.PP .CS \fBnamespace forget\fR Blt::* .CE -.PP This searches the current namespace for any commands imported from \fBBlt\fR. If it finds any, it removes them. Otherwise, it does nothing. After this, the \fBBlt\fR commands must be accessed with the \fBBlt::\fR prefix. .PP When you delete a command from the exporting namespace like this: -.PP .CS rename Blt::graph "" .CE -.PP the command is automatically removed from all namespaces that import it. .SH "EXPORTING COMMANDS" You can export commands from a namespace like this: -.PP .CS \fBnamespace eval\fR Counter { - \fBnamespace export\fR bump reset - variable Num 0 - variable Max 100 - - proc bump {{by 1}} { - variable Num - incr Num $by - Check - return $Num - } - proc reset {} { - variable Num - set Num 0 - } - proc Check {} { - variable Num - variable Max - if {$Num > $Max} { - error "too high!" - } - } + \fBnamespace export\fR bump reset + variable Num 0 + variable Max 100 + + proc bump {{by 1}} { + variable Num + incr Num $by + Check + return $Num + } + proc reset {} { + variable Num + set Num 0 + } + proc Check {} { + variable Num + variable Max + if {$Num > $Max} { + error "too high!" + } + } } .CE -.PP The procedures \fBbump\fR and \fBreset\fR are exported, so they are included when you import from the \fBCounter\fR namespace, like this: -.PP .CS \fBnamespace import\fR Counter::* .CE -.PP However, the \fBCheck\fR procedure is not exported, so it is ignored by the import operation. .PP The \fBnamespace import\fR command only imports commands that were declared as exported by their namespace. @@ -699,17 +638,17 @@ code indicates how to direct a variable \fBtrace\fR callback into the current namespace: .PP .CS \fBnamespace eval\fR a { - variable b - proc theTraceCallback { n1 n2 op } { - upvar 1 $n1 var - puts "the value of $n1 has changed to $var" - return - } - trace add variable b write [\fBnamespace code\fR theTraceCallback] + variable b + proc theTraceCallback { n1 n2 op } { + upvar 1 $n1 var + puts "the value of $n1 has changed to $var" + return + } + trace add variable b write [\fBnamespace code\fR theTraceCallback] } set a::b c .CE .PP When executed, it prints the message: @@ -717,10 +656,11 @@ .CS the value of a::b has changed to c .CE .SH ENSEMBLES .PP +.VS 8.5 The \fBnamespace ensemble\fR is used to create and manipulate ensemble commands, which are commands formed by grouping subcommands together. The commands typically come from the current namespace when the ensemble was created, though this is configurable. Note that there may be any number of ensembles associated with any namespace @@ -730,11 +670,10 @@ namespace is maintained however the ensemble is renamed. .PP Three subcommands of the \fBnamespace ensemble\fR command are defined: .TP \fBnamespace ensemble create\fR ?\fIoption value ...\fR? -. Creates a new ensemble command linked to the current namespace, returning the fully qualified name of the command created. The arguments to \fBnamespace ensemble create\fR allow the configuration of the command as if with the \fBnamespace ensemble configure\fR command. If not overridden with the \fB\-command\fR option, this @@ -741,18 +680,16 @@ command creates an ensemble with exactly the same name as the linked namespace. See the section \fBENSEMBLE OPTIONS\fR below for a full list of options supported and their effects. .TP \fBnamespace ensemble configure \fIcommand\fR ?\fIoption\fR? ?\fIvalue ...\fR? -. Retrieves the value of an option associated with the ensemble command named \fIcommand\fR, or updates some options associated with that ensemble command. See the section \fBENSEMBLE OPTIONS\fR below for a full list of options supported and their effects. .TP \fBnamespace ensemble exists\fR \fIcommand\fR -. Returns a boolean value that describes whether the command \fIcommand\fR exists and is an ensemble command. This command only ever returns an error if the number of arguments to the command is wrong. .PP @@ -771,11 +708,10 @@ The following options, supported by the \fBnamespace ensemble create\fR and \fBnamespace ensemble configure\fR commands, control how an ensemble command behaves: .TP \fB\-map\fR -. When non-empty, this option supplies a dictionary that provides a mapping from subcommand names to a list of prefix words to substitute in place of the ensemble command and subcommand words (in a manner similar to an alias created with \fBinterp alias\fR; the words are not reparsed after substitution); if the first word of any target is not @@ -785,25 +721,17 @@ 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. .TP \fB\-subcommands\fR -. When non-empty, this option lists exactly what subcommands are in the ensemble. The mapping for each of those commands will be either whatever is defined in the \fB\-map\fR option, or to the command with the same name in the namespace linked to the ensemble. If this option is empty, the subcommands of the namespace will either be the keys of the @@ -810,11 +738,10 @@ dictionary listed in the \fB\-map\fR option or the exported commands of the linked namespace at the time of the invocation of the ensemble command. .TP \fB\-unknown\fR -. When non-empty, this option provides a partial command (to which all the words that are arguments to the ensemble command, including the fully-qualified name of the ensemble, are appended) to handle the case where an ensemble subcommand is not recognized and would otherwise generate an error. When empty (the default) an error (in the style of @@ -824,11 +751,10 @@ .PP The following extra option is allowed by \fBnamespace ensemble create\fR: .TP \fB\-command\fR -. This write-only option allows the name of the ensemble created by \fBnamespace ensemble create\fR to be anything in any existing namespace. The default value for this option is the fully-qualified name of the namespace in which the \fBnamespace ensemble create\fR command is invoked. @@ -835,11 +761,10 @@ .PP The following extra option is allowed by \fBnamespace ensemble configure\fR: .TP \fB\-namespace\fR -. This read-only option allows the retrieval of the fully-qualified name of the namespace which the ensemble was created within. .SS "UNKNOWN HANDLER BEHAVIOUR" .PP If an unknown handler is specified for an ensemble, that handler is @@ -887,79 +812,57 @@ commands that the ensemble has defined (formatted similarly to the error message from \fBTcl_GetIndexFromObj\fR). This is the error that will be thrown when the subcommand is still not recognized during reparsing. It is also an error for an \fB\-unknown\fR handler to delete its namespace. +.VE 8.5 .SH EXAMPLES Create a namespace containing a variable and an exported command: -.PP .CS \fBnamespace eval\fR foo { - variable bar 0 - proc grill {} { - variable bar - puts "called [incr bar] times" - } - \fBnamespace export\fR grill + variable bar 0 + proc grill {} { + variable bar + puts "called [incr bar] times" + } + \fBnamespace export\fR grill } .CE .PP Call the command defined in the previous example in various ways. -.PP .CS # Direct call ::foo::grill # Use the command resolution path to find the name \fBnamespace eval\fR boo { - \fBnamespace path\fR ::foo - grill + \fBnamespace path\fR ::foo + grill } # Import into current namespace, then call local alias \fBnamespace import\fR foo::grill grill # Create two ensembles, one with the default name and one with a # specified name. Then call through the ensembles. \fBnamespace eval\fR foo { - \fBnamespace ensemble\fR create - \fBnamespace ensemble\fR create -command ::foobar + \fBnamespace ensemble\fR create + \fBnamespace ensemble\fR create -command ::foobar } foo grill foobar grill .CE .PP Look up where the command imported in the previous example came from: -.PP .CS puts "grill came from [\fBnamespace origin\fR grill]" .CE .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: DELETED doc/next.n Index: doc/next.n ================================================================== --- doc/next.n +++ /dev/null @@ -1,213 +0,0 @@ -'\" -'\" Copyright (c) 2007 Donal K. Fellows -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH next n 0.1 TclOO "TclOO Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -next, nextto \- invoke superclass method implementations -.SH SYNOPSIS -.nf -package require TclOO - -\fBnext\fR ?\fIarg ...\fR? -\fBnextto\fI class\fR ?\fIarg ...\fR? -.fi -.BE - -.SH DESCRIPTION -.PP -The \fBnext\fR command is used to call implementations of a method by a class, -superclass or mixin that are overridden by the current method. It can only be -used from within a method. It is also used within filters to indicate the -point where a filter calls the actual implementation (the filter may decide to -not go along the chain, and may process the results of going along the chain -of methods as it chooses). The result of the \fBnext\fR command is the result -of the next method in the method chain; if there are no further methods in the -method chain, the result of \fBnext\fR will be an error. The arguments, -\fIarg\fR, to \fBnext\fR are the arguments to pass to the next method in the -chain. -.PP -The \fBnextto\fR command is the same as the \fBnext\fR command, except that it -takes an additional \fIclass\fR argument that identifies a class whose -implementation of the current method chain (see \fBinfo object\fR \fBcall\fR) should -be used; the method implementation selected will be the one provided by the -given class, and it must refer to an existing non-filter invocation that lies -further along the chain than the current implementation. -.SH "THE METHOD CHAIN" -.PP -When a method of an object is invoked, things happen in several stages: -.IP [1] -The structure of the object, its class, superclasses, filters, and mixins, are -examined to build a \fImethod chain\fR, which contains a list of method -implementations to invoke. -.IP [2] -The first method implementation on the chain is invoked. -.IP [3] -If that method implementation invokes the \fBnext\fR command, the next method -implementation is invoked (with its arguments being those that were passed to -\fBnext\fR). -.IP [4] -The result from the overall method call is the result from the outermost -method implementation; inner method implementations return their results -through \fBnext\fR. -.IP [5] -The method chain is cached for future use. -.SS "METHOD SEARCH ORDER" -.PP -When constructing the method chain, method implementations are searched for in -the following order: -.IP [1] -In the classes mixed into the object, in class traversal order. The list of -mixins is checked in natural order. -.IP [2] -In the classes mixed into the classes of the object, with sources of mixing in -being searched in class traversal order. Within each class, the list of mixins -is processed in natural order. -.IP [3] -In the object itself. -.IP [4] -In the object's class. -.IP [5] -In the superclasses of the class, following each superclass in a depth-first -fashion in the natural order of the superclass list. -.PP -Any particular method implementation always comes as \fIlate\fR in the -resulting list of implementations as possible; this means that if some class, -A, is both mixed into a class, B, and is also a superclass of B, the instances -of B will always treat A as a superclass from the perspective of inheritance. -This is true even when the multiple inheritance is processed indirectly. -.SS FILTERS -.PP -When an object has a list of filter names set upon it, or is an instance of a -class (or has mixed in a class) that has a list of filter names set upon it, -before every invocation of any method the filters are processed. Filter -implementations are found in class traversal order, as are the lists of filter -names (each of which is traversed in natural list order). Explicitly invoking -a method used as a filter will cause that method to be invoked twice, once as -a filter and once as a normal method. -.PP -Each filter should decide for itself whether to permit the execution to go -forward to the proper implementation of the method (which it does by invoking -the \fBnext\fR command as filters are inserted into the front of the method -call chain) and is responsible for returning the result of \fBnext\fR. -.PP -Filters are invoked when processing an invokation of the \fBunknown\fR -method because of a failure to locate a method implementation, but \fInot\fR -when invoking either constructors or destructors. (Note however that the -\fBdestroy\fR method is a conventional method, and filters are invoked as -normal when it is called.) -.SH EXAMPLES -.PP -This example demonstrates how to use the \fBnext\fR command to call the -(super)class's implementation of a method. The script: -.PP -.CS -oo::class create theSuperclass { - method example {args} { - puts "in the superclass, args = $args" - } -} - -oo::class create theSubclass { - superclass theSuperclass - method example {args} { - puts "before chaining from subclass, args = $args" - \fBnext\fR a {*}$args b - \fBnext\fR pureSynthesis - puts "after chaining from subclass" - } -} - -theSubclass create obj -oo::objdefine obj method example args { - puts "per-object method, args = $args" - \fBnext\fR x {*}$args y - \fBnext\fR -} -obj example 1 2 3 -.CE -.PP -prints the following: -.PP -.CS -per-object method, args = 1 2 3 -before chaining from subclass, args = x 1 2 3 y -in the superclass, args = a x 1 2 3 y b -in the superclass, args = pureSynthesis -after chaining from subclass -before chaining from subclass, args = -in the superclass, args = a b -in the superclass, args = pureSynthesis -after chaining from subclass -.CE -.PP -This example demonstrates how to build a simple cache class that applies -memoization to all the method calls of the objects it is mixed into, and shows -how it can make a difference to computation times: -.PP -.CS -oo::class create cache { - filter Memoize - method Memoize args { - \fI# Do not filter the core method implementations\fR - if {[lindex [self target] 0] eq "::oo::object"} { - return [\fBnext\fR {*}$args] - } - - \fI# Check if the value is already in the cache\fR - my variable ValueCache - set key [self target],$args - if {[info exist ValueCache($key)]} { - return $ValueCache($key) - } - - \fI# Compute value, insert into cache, and return it\fR - return [set ValueCache($key) [\fBnext\fR {*}$args]] - } - - method flushCache {} { - my variable ValueCache - unset ValueCache - \fI# Skip the caching\fR - return -level 2 "" - } -} - -oo::object create demo -oo::objdefine demo { - mixin cache - - method compute {a b c} { - after 3000 \fI;# Simulate deep thought\fR - return [expr {$a + $b * $c}] - } - - method compute2 {a b c} { - after 3000 \fI;# Simulate deep thought\fR - return [expr {$a * $b + $c}] - } -} - -puts [demo compute 1 2 3] \fI\(-> prints "7" after delay\fR -puts [demo compute2 4 5 6] \fI\(-> prints "26" after delay\fR -puts [demo compute 1 2 3] \fI\(-> prints "7" instantly\fR -puts [demo compute2 4 5 6] \fI\(-> prints "26" instantly\fR -puts [demo compute 4 5 6] \fI\(-> prints "34" after delay\fR -puts [demo compute 4 5 6] \fI\(-> prints "34" instantly\fR -puts [demo compute 1 2 3] \fI\(-> prints "7" instantly\fR -demo flushCache -puts [demo compute 1 2 3] \fI\(-> prints "7" after delay\fR -.CE -.SH "SEE ALSO" -oo::class(n), oo::define(n), oo::object(n), self(n) -.SH KEYWORDS -call, method, method chain -.\" Local variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: DELETED doc/object.n Index: doc/object.n ================================================================== --- doc/object.n +++ /dev/null @@ -1,128 +0,0 @@ -'\" -'\" Copyright (c) 2007-2008 Donal K. Fellows -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH object n 0.1 TclOO "TclOO Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -oo::object \- root class of the class hierarchy -.SH SYNOPSIS -.nf -package require TclOO - -\fBoo::object\fI method \fR?\fIarg ...\fR? -.fi -.SH "CLASS HIERARCHY" -.nf -\fBoo::object\fR -.fi -.BE -.SH DESCRIPTION -.PP -The \fBoo::object\fR class is the root class of the object hierarchy; every -object is an instance of this class. Since classes are themselves objects, -they are instances of this class too. Objects are always referred to by their -name, and may be \fBrename\fRd while maintaining their identity. -.PP -Instances of objects may be made with either the \fBcreate\fR or \fBnew\fR -methods of the \fBoo::object\fR object itself, or by invoking those methods on -any of the subclass objects; see \fBoo::class\fR for more details. The -configuration of individual objects (i.e., instance-specific methods, mixed-in -classes, etc.) may be controlled with the \fBoo::objdefine\fR command. -.PP -Each object has a unique namespace associated with it, the instance namespace. -This namespace holds all the instance variables of the object, and will be the -current namespace whenever a method of the object is invoked (including a -method of the class of the object). When the object is destroyed, its instance -namespace is deleted. The instance namespace contains the object's \fBmy\fR -command, which may be used to invoke non-exported methods of the object or to -create a reference to the object for the purpose of invocation which persists -across renamings of the object. -.SS CONSTRUCTOR -The \fBoo::object\fR class does not define an explicit constructor. -.SS DESTRUCTOR -The \fBoo::object\fR class does not define an explicit destructor. -.SS "EXPORTED METHODS" -The \fBoo::object\fR class supports the following exported methods: -.TP -\fIobj \fBdestroy\fR -. -This method destroys the object, \fIobj\fR, that it is invoked upon, invoking -any destructors on the object's class in the process. It is equivalent to -using \fBrename\fR to delete the object command. The result of this method is -always the empty string. -.SS "NON-EXPORTED METHODS" -.PP -The \fBoo::object\fR class supports the following non-exported methods: -.TP -\fIobj \fBeval\fR ?\fIarg ...\fR? -. -This method concatenates the arguments, \fIarg\fR, as if with \fBconcat\fR, -and then evaluates the resulting script in the namespace that is uniquely -associated with \fIobj\fR, returning the result of the evaluation. -.TP -\fIobj \fBunknown ?\fImethodName\fR? ?\fIarg ...\fR? -. -This method is called when an attempt to invoke the method \fImethodName\fR on -object \fIobj\fR fails. The arguments that the user supplied to the method are -given as \fIarg\fR arguments. -.VS -If \fImethodName\fR is absent, the object was invoked with no method name at -all (or any other arguments). -.VE -The default implementation (i.e., the one defined by the \fBoo::object\fR -class) generates a suitable error, detailing what methods the object supports -given whether the object was invoked by its public name or through the -\fBmy\fR command. -.TP -\fIobj \fBvariable \fR?\fIvarName ...\fR? -. -This method arranges for each variable called \fIvarName\fR to be linked from -the object \fIobj\fR's unique namespace into the caller's context. Thus, if it -is invoked from inside a procedure then the namespace variable in the object -is linked to the local variable in the procedure. Each \fIvarName\fR argument -must not have any namespace separators in it. The result is the empty string. -.TP -\fIobj \fBvarname \fIvarName\fR -. -This method returns the globally qualified name of the variable \fIvarName\fR -in the unique namespace for the object \fIobj\fR. -.TP -\fIobj \fB \fIsourceObjectName\fR -.VS -This method is used by the \fBoo::object\fR command to copy the state of one -object to another. It is responsible for copying the procedures and variables -of the namespace of the source object (\fIsourceObjectName\fR) to the current -object. It does not copy any other types of commands or any traces on the -variables; that can be added if desired by overriding this method in a -subclass. -.VE -.SH EXAMPLES -.PP -This example demonstrates basic use of an object. -.PP -.CS -set obj [\fBoo::object\fR new] -$obj foo \fI\(-> error "unknown method foo"\fR -oo::objdefine $obj method foo {} { - my \fBvariable\fR count - puts "bar[incr count]" -} -$obj foo \fI\(-> prints "bar1"\fR -$obj foo \fI\(-> prints "bar2"\fR -$obj variable count \fI\(-> error "unknown method variable"\fR -$obj \fBdestroy\fR -$obj foo \fI\(-> error "unknown command obj"\fR -.CE -.SH "SEE ALSO" -my(n), oo::class(n) -.SH KEYWORDS -base class, class, object, root class -.\" Local variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: Index: doc/open.n ================================================================== --- doc/open.n +++ doc/open.n @@ -2,11 +2,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 open n 8.3 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -32,121 +32,107 @@ The \fIaccess\fR argument, if present, indicates the way in which the file (or command pipeline) is to be accessed. In the first form \fIaccess\fR may have any of the following values: .TP 15 \fBr\fR -. Open the file for reading only; the file must already exist. This is the default value if \fIaccess\fR is not specified. .TP 15 \fBr+\fR -. Open the file for both reading and writing; the file must already exist. .TP 15 \fBw\fR -. Open the file for writing only. Truncate it if it exists. If it does not exist, create a new file. .TP 15 \fBw+\fR -. Open the file for reading and writing. Truncate it if it exists. If it does not exist, create a new file. .TP 15 \fBa\fR -. Open the file for writing only. If the file does not exist, create a new empty file. Set the file pointer to the end of the file prior to each write. .TP 15 \fBa+\fR -. Open the file for reading and writing. If the file does not exist, create a new empty file. Set the initial access position to the end of the file. +.VS 8.5 .PP All of the legal \fIaccess\fR values above may have the character \fBb\fR added as the second or third character in the value to -indicate that the opened channel should be configured as if with the -\fBfconfigure\fR \fB\-translation binary\fR option, making the channel suitable for +indicate that the opened channel should be configured with the +\fB\-translation binary\fR option, making the channel suitable for reading or writing of binary data. +.VE 8.5 .PP In the second form, \fIaccess\fR consists of a list of any of the -following flags, all of which have the standard POSIX meanings. +following flags, most of which have the standard POSIX meanings. One of the flags must be either \fBRDONLY\fR, \fBWRONLY\fR or \fBRDWR\fR. .TP 15 \fBRDONLY\fR -. Open the file for reading only. .TP 15 \fBWRONLY\fR -. Open the file for writing only. .TP 15 \fBRDWR\fR -. Open the file for both reading and writing. .TP 15 \fBAPPEND\fR -. Set the file pointer to the end of the file prior to each write. +.VS 8.5 .TP 15 \fBBINARY\fR -. Configure the opened channel with the \fB\-translation binary\fR option. +.VE 8.5 .TP 15 \fBCREAT\fR -. Create the file if it does not already exist (without this flag it is an error for the file not to exist). .TP 15 \fBEXCL\fR -. If \fBCREAT\fR is also specified, an error is returned if the file already exists. .TP 15 \fBNOCTTY\fR -. If the file is a terminal device, this flag prevents the file from becoming the controlling terminal of the process. .TP 15 \fBNONBLOCK\fR -. Prevents the process from blocking while opening the file, and possibly in subsequent I/O operations. The exact behavior of this flag is system- and device-dependent; its use is discouraged (it is better to use the \fBfconfigure\fR command to put a file in nonblocking mode). For details refer to your system documentation on the \fBopen\fR system call's \fBO_NONBLOCK\fR flag. .TP 15 \fBTRUNC\fR -. If the file exists it is truncated to zero length. .PP If a new file is created as part of opening it, \fIpermissions\fR (an integer) is used to set the permissions for the new file in conjunction with the process's file mode creation mask. \fIPermissions\fR defaults to 0666. .SH "COMMAND PIPELINES" .PP If the first character of \fIfileName\fR is -.QW \fB|\fR +.QW | then the remaining characters of \fIfileName\fR are treated as a list of arguments that describe a command pipeline to invoke, in the same style as the arguments for \fBexec\fR. In this case, the channel identifier returned by \fBopen\fR may be used to write to the command's input pipe or read from its output pipe, depending on the value of \fIaccess\fR. -If write-only access is used (e.g. \fIaccess\fR is -.QW \fBw\fR ), -then standard output for the pipeline is directed to the current standard +If write-only access is used (e.g. \fIaccess\fR is \fBw\fR), then +standard output for the pipeline is directed to the current standard output unless overridden by the command. -If read-only access is used (e.g. \fIaccess\fR is -.QW \fBr\fR ), +If read-only access is used (e.g. \fIaccess\fR is \fBr\fR), standard input for the pipeline is taken from the current standard input unless overridden by the command. The id of the spawned process is accessible through the \fBpid\fR command, using the channel id returned by \fBopen\fR as argument. .PP @@ -164,16 +150,14 @@ If \fIfileName\fR refers to a serial port, then the specified serial port is opened and initialized in a platform-dependent manner. Acceptable values for the \fIfileName\fR to use to open a serial port are described in the PORTABILITY ISSUES section. .PP -The \fBchan configure\fR and \fBfconfigure\fR commands can be used to query -and set additional configuration options specific to serial ports (where -supported): +The \fBfconfigure\fR command can be used to query and set additional +configuration options specific to serial ports (where supported): .TP \fB\-mode\fR \fIbaud\fB,\fIparity\fB,\fIdata\fB,\fIstop\fR -. This option is a set of 4 comma-separated values: the baud rate, parity, number of data bits, and number of stop bits for this serial port. The \fIbaud\fR rate is a simple integer that specifies the connection speed. \fIParity\fR is one of the following letters: \fBn\fR, \fBo\fR, \fBe\fR, \fBm\fR, \fBs\fR; respectively signifying the parity options of @@ -186,11 +170,10 @@ \fIData\fR is the number of data bits and should be an integer from 5 to 8, while \fIstop\fR is the number of stop bits and should be the integer 1 or 2. .TP \fB\-handshake\fR \fItype\fR -. (Windows and Unix). This option is used to setup automatic handshake control. Note that not all handshake types maybe supported by your operating system. The \fItype\fR parameter is case-independent. .RS .PP @@ -204,27 +187,24 @@ on your operating system settings. The \fB\-handshake\fR option cannot be queried. .RE .TP \fB\-queue\fR -. (Windows and Unix). The \fB\-queue\fR option can only be queried. It returns a list of two integers representing the current number of bytes in the input and output queue respectively. .TP \fB\-timeout\fR \fImsec\fR -. (Windows and Unix). This option is used to set the timeout for blocking read operations. It specifies the maximum interval between the reception of two bytes in milliseconds. For Unix systems the granularity is 100 milliseconds. The \fB\-timeout\fR option does not affect write operations or nonblocking reads. This option cannot be queried. .TP \fB\-ttycontrol\fR \fI{signal boolean signal boolean ...}\fR -. (Windows and Unix). This option is used to setup the handshake output lines (see below) permanently or to send a BREAK over the serial line. The \fIsignal\fR names are case-independent. \fB{RTS 1 DTR 0}\fR sets the RTS output to high and the DTR output to low. The BREAK condition (see below) is enabled and disabled with \fB{BREAK 1}\fR and @@ -233,96 +213,24 @@ with active hardware handshake \fBrtscts\fR (or \fBdtrdsr\fR). The result is unpredictable. The \fB\-ttycontrol\fR option cannot be queried. .TP \fB\-ttystatus\fR -. (Windows and Unix). The \fB\-ttystatus\fR option can only be queried. It returns the current modem status and handshake input signals (see below). The result is a list of signal,value pairs with a fixed order, e.g. \fB{CTS 1 DSR 0 RING 1 DCD 0}\fR. The \fIsignal\fR names are returned upper case. .TP \fB\-xchar\fR \fI{xonChar xoffChar}\fR -. (Windows and Unix). This option is used to query or change the software handshake characters. Normally the operating system default should be DC1 (0x11) and DC3 (0x13) representing the ASCII standard XON and XOFF characters. .TP -\fB\-closemode\fR \fIcloseMode\fR -.VS "8.7, TIP 160" -(Windows and Unix). This option is used to query or change the close mode of -the serial channel, which defines how pending output in operating system -buffers is handled when the channel is closed. The following values for -\fIcloseMode\fR are supported: -.RS -.TP -\fBdefault\fR -. -indicates that a system default operation should be used; all serial channels -default to this. -.TP -\fBdiscard\fR -. -indicates that the contents of the OS buffers should be discarded. Note that -this is \fInot recommended\fR when writing to a POSIX terminal, as it can -interact unexpectedly with handling of \fBstderr\fR. -.TP -\fBdrain\fR -. -indicates that Tcl should wait when closing the channel until all output has -been consumed. This may slow down \fBclose\fR noticeably. -.RE -.VE "8.7, TIP 160" -.TP -\fB\-inputmode\fR \fIinputMode\fR -.VS "8.7, TIP 160" -(Unix only; Windows has the equivalent option on console channels). This -option is used to query or change the input mode of the serial channel under -the assumption that it is talking to a terminal, which controls how interactive -input from users is handled. The following values for \fIinputMode\fR are -supported: -.RS -.TP -\fBnormal\fR -. -indicates that normal line-oriented input should be used, with standard -terminal editing capabilities enabled. -.TP -\fBpassword\fR -. -indicates that non-echoing input should be used, with standard terminal -editing capabilities enabled but no writing of typed characters to the -terminal (except for newlines). Some terminals may indicate this specially. -.TP -\fBraw\fR -. -indicates that all keyboard input should be given directly to Tcl with the -terminal doing no processing at all. It does not echo the keys, leaving it up -to the Tcl script to interpret what to do. -.TP -\fBreset\fR (set only) -. -indicates that the terminal should be reset to what state it was in when the -terminal was opened. -.PP -Note that setting this option (technically, anything that changes the terminal -state from its initial value \fIvia this option\fR) will cause the channel to -turn on an automatic reset of the terminal when the channel is closed. -.RE -.TP -\fB\-winsize\fR -. -(Unix only; Windows has the equivalent option on console channels). This -option is query only. It retrieves a two-element list with the the current -width and height of the terminal. -.VE "8.7, TIP 160" -.TP \fB\-pollinterval\fR \fImsec\fR -. (Windows only). This option is used to set the maximum time between polling for fileevents. This affects the time interval between checking for events throughout the Tcl interpreter (the smallest value always wins). Use this option only if you want to poll the serial port more or less often than 10 msec @@ -329,121 +237,112 @@ (the default). .TP \fB\-sysbuffer\fR \fIinSize\fR .TP \fB\-sysbuffer\fR \fI{inSize outSize}\fR -. (Windows only). This option is used to change the size of Windows system buffers for a serial channel. Especially at higher communication rates the default input buffer size of 4096 bytes can overrun for latent systems. The first form specifies the input buffer size, in the second form both input and output buffers are defined. .TP \fB\-lasterror\fR -. (Windows only). This option is query only. In case of a serial communication error, \fBread\fR or \fBputs\fR returns a general Tcl file I/O error. -\fBfconfigure\fR \fB\-lasterror\fR can be called to get a list of error details. +\fBfconfigure -lasterror\fR can be called to get a list of error details. See below for an explanation of the various error codes. -.SS "SERIAL PORT SIGNALS" +.SH "SERIAL PORT SIGNALS" .PP RS-232 is the most commonly used standard electrical interface for serial communications. A negative voltage (-3V..-12V) define a mark (on=1) bit and a positive voltage (+3..+12V) define a space (off=0) bit (RS-232C). The following signals are specified for incoming and outgoing data, status lines and handshaking. Here we are using the terms \fIworkstation\fR for your computer and \fImodem\fR for the external device, because some signal names (DCD, RI) come from modems. Of course your external device may use these signal lines for other purposes. -.IP \fBTXD\fR(output) +.IP \fBTXD(output)\fR \fBTransmitted Data:\fR Outgoing serial data. -.IP \fBRXD\fR(input) +.IP \fBRXD(input)\fR \fBReceived Data:\fRIncoming serial data. -.IP \fBRTS\fR(output) +.IP \fBRTS(output)\fR \fBRequest To Send:\fR This hardware handshake line informs the modem that your workstation is ready to receive data. Your workstation may automatically reset this signal to indicate that the input buffer is full. -.IP \fBCTS\fR(input) +.IP \fBCTS(input)\fR \fBClear To Send:\fR The complement to RTS. Indicates that the modem is ready to receive data. -.IP \fBDTR\fR(output) +.IP \fBDTR(output)\fR \fBData Terminal Ready:\fR This signal tells the modem that the workstation is ready to establish a link. DTR is often enabled automatically whenever a serial port is opened. -.IP \fBDSR\fR(input) +.IP \fBDSR(input)\fR \fBData Set Ready:\fR The complement to DTR. Tells the workstation that the modem is ready to establish a link. -.IP \fBDCD\fR(input) +.IP \fBDCD(input)\fR \fBData Carrier Detect:\fR This line becomes active when a modem detects a .QW Carrier signal. -.IP \fBRI\fR(input) +.IP \fBRI(input)\fR \fBRing Indicator:\fR Goes active when the modem detects an incoming call. .IP \fBBREAK\fR A BREAK condition is not a hardware signal line, but a logical zero on the TXD or RXD lines for a long period of time, usually 250 to 500 milliseconds. Normally a receive or transmit data signal stays at the mark (on=1) voltage until the next character is transferred. A BREAK is sometimes used to reset the communications line or change the operating mode of communications hardware. -.SS "ERROR CODES (Windows only)" +.SH "ERROR CODES (Windows only)" .PP A lot of different errors may occur during serial read operations or during event polling in background. The external device may have been switched off, the data lines may be noisy, system buffers may overrun or your mode settings may be wrong. That is why a reliable software should always \fBcatch\fR serial read operations. In cases of an error Tcl returns a -general file I/O error. Then \fBfconfigure\fR \fB\-lasterror\fR may help to +general file I/O error. Then \fBfconfigure -lasterror\fR may help to locate the problem. The following error codes may be returned. .TP 10 \fBRXOVER\fR -. Windows input buffer overrun. The data comes faster than your scripts reads -it or your system is overloaded. Use \fBfconfigure\fR \fB\-sysbuffer\fR to avoid a +it or your system is overloaded. Use \fBfconfigure -sysbuffer\fR to avoid a temporary bottleneck and/or make your script faster. .TP 10 \fBTXFULL\fR -. Windows output buffer overrun. Complement to RXOVER. This error should practically not happen, because Tcl cares about the output buffer status. .TP 10 \fBOVERRUN\fR -. UART buffer overrun (hardware) with data lost. The data comes faster than the system driver receives it. Check your advanced serial port settings to enable the FIFO (16550) buffer and/or setup a lower(1) interrupt threshold value. .TP 10 \fBRXPARITY\fR -. A parity error has been detected by your UART. -Wrong parity settings with \fBfconfigure\fR \fB\-mode\fR or a noisy data line (RXD) +Wrong parity settings with \fBfconfigure -mode\fR or a noisy data line (RXD) may cause this error. .TP 10 \fBFRAME\fR -. A stop-bit error has been detected by your UART. -Wrong mode settings with \fBfconfigure\fR \fB\-mode\fR or a noisy data line (RXD) +Wrong mode settings with \fBfconfigure -mode\fR or a noisy data line (RXD) may cause this error. .TP 10 \fBBREAK\fR -. A BREAK condition has been detected by your UART (see above). -.SS "PORTABILITY ISSUES" +.SH "PORTABILITY ISSUES" .TP \fBWindows \fR -. Valid values for \fIfileName\fR to open a serial port are of the form \fBcom\fIX\fB\fR, where \fIX\fR is a number, generally from 1 to 9. A legacy form accepted as well is \fBcom\fIX\fB:\fR. This notation only works for serial ports from 1 to 9. An attempt to open a serial port that does not exist or has a number greater than 9 will fail. An alternate form of opening serial ports is to use the filename \fB//./comX\fR, where X is any number that corresponds to a serial port. -.PP .RS +.PP When running Tcl interactively, there may be some strange interactions between the real console, if one is present, and a command pipeline that uses standard input or output. If a command pipeline is opened for reading, some of the lines entered at the console will be sent to the command pipeline and some will be sent to the Tcl evaluator. If a command pipeline is opened for @@ -451,14 +350,19 @@ pipe is closed. These problems only occur because both Tcl and the child application are competing for the console at the same time. If the command pipeline is started from a script, so that Tcl is not accessing the console, or if the command pipeline does not use standard input or output, but is redirected from or to a file, then the above problems do not occur. +.PP +Files opened in the +.QW \fBa\fR +mode or with the \fBAPPEND\fR flag set are implemented by seeking immediately +before each write, which is not an atomic operation and does not carry the +guarantee of strict appending that is present on POSIX platforms. .RE .TP \fBUnix\fR\0\0\0\0\0\0\0 -. Valid values for \fIfileName\fR to open a serial port are generally of the form \fB/dev/tty\fIX\fR, where \fIX\fR is \fBa\fR or \fBb\fR, but the name of any pseudo-file that maps to a serial port may be used. Advanced configuration options are only supported for serial ports when Tcl is built to use the POSIX serial interface. @@ -470,65 +374,30 @@ of the lines entered at the console will be sent to the command pipeline and some will be sent to the Tcl evaluator. This problem only occurs because both Tcl and the child application are competing for the console at the same time. If the command pipeline is started from a script, so that Tcl is not accessing the console, or if the command pipeline does not use standard -input, but is redirected from a file, then the above problem does not occur. +input, but is redirected from a file, then the above problem does not occur. .RE .PP See the \fBPORTABILITY ISSUES\fR section of the \fBexec\fR command for additional information not specific to command pipelines about executing applications on the various platforms -.SH "CONSOLE CHANNELS" -.VS "8.7, TIP 160" -On Windows only, console channels (usually \fBstdin\fR or \fBstdout\fR) -support the following options: -.TP -\fB\-inputmode\fR \fIinputMode\fR -. -This option is used to query or change the input mode of the console channel, -which controls how interactive input from users is handled. The following -values for \fIinputMode\fR are supported: -.RS -.TP -\fBnormal\fR -. -indicates that normal line-oriented input should be used, with standard -console editing capabilities enabled. -.TP -\fBpassword\fR -. -indicates that non-echoing input should be used, with standard console -editing capabilitied enabled but no writing of typed characters to the -terminal (except for newlines). -.TP -\fBraw\fR -. -indicates that all keyboard input should be given directly to Tcl with the -console doing no processing at all. It does not echo the keys, leaving it up -to the Tcl script to interpret what to do. -.TP -\fBreset\fR (set only) -. -indicates that the console should be reset to what state it was in when the -console channel was opened. -.PP -Note that setting this option (technically, anything that changes the console -state from its default \fIvia this option\fR) will cause the channel to turn -on an automatic reset of the console when the channel is closed. -.RE -.TP -\fB\-winsize\fR -. -This option is query only. -It retrieves a two-element list with the the current width and height of the -console that this channel is talking to. -.PP -Note that the equivalent options exist on Unix, but are on the serial channel -type. -.VE "8.7, TIP 160" -.SH "EXAMPLES" +.SH "EXAMPLES" +Open a file for writing, forcing it to be created and raising an error if it +already exists. +.PP +.CS +set myNewFile [\fBopen\fR filename.txt {WRONLY CREAT EXCL}] +.CE +.PP +Open a file for writing as a log file. +.PP +.CS +set myLogFile [\fBopen\fR filename.log "a"] +fconfigure $myLogFile -buffering line +.CE .PP Open a command pipeline and catch any errors: .PP .CS set fl [\fBopen\fR "| ls this_file_does_not_exist"] @@ -536,29 +405,22 @@ if {[catch {close $fl} err]} { puts "ls command failed: $err" } .CE .PP -.VS "8.7, TIP 160" -Read a password securely from the user (assuming that the script is being run -interactively): +Open a command pipeline and read binary data from it. Note the unusual form +with +.QW |[list +that handles non-trivial edge cases with arguments that potentially have +spaces in. .PP .CS -chan configure stdin \fB-inputmode password\fR -try { - chan puts -nonewline "Password: " - chan flush stdout - set thePassword [chan gets stdin] -} finally { - chan configure stdin \fB-inputmode reset\fR -} +set fl [\fBopen\fR |[list create_image_data $input] "rb"] +set binData [read $fl] +close $fl .CE -.VE "8.7, TIP 160" .SH "SEE ALSO" file(n), close(n), filename(n), fconfigure(n), gets(n), read(n), puts(n), exec(n), pid(n), fopen(3) .SH KEYWORDS access mode, append, create, file, non-blocking, open, permissions, pipeline, process, serial -'\"Local Variables: -'\"mode: nroff -'\"End: Index: doc/package.n ================================================================== --- doc/package.n +++ doc/package.n @@ -1,21 +1,20 @@ '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH package n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME package \- Facilities for package loading and version control .SH SYNOPSIS .nf -\fBpackage files\fR \fIpackage\fR -\fBpackage forget\fR ?\fIpackage package ...\fR? +\fBpackage forget ?\fIpackage package ...\fR? \fBpackage ifneeded \fIpackage version\fR ?\fIscript\fR? \fBpackage names\fR \fBpackage present \fIpackage \fR?\fIrequirement...\fR? \fBpackage present \-exact \fIpackage version\fR \fBpackage provide \fIpackage \fR?\fIversion\fR? @@ -26,10 +25,11 @@ \fBpackage versions \fIpackage\fR \fBpackage vsatisfies \fIversion requirement...\fR \fBpackage prefer \fR?\fBlatest\fR|\fBstable\fR? .fi .BE + .SH DESCRIPTION .PP This command keeps a simple database of the packages available for use by the current interpreter and how to load them into the interpreter. @@ -42,25 +42,16 @@ primarily by system scripts that maintain the package database. .PP The behavior of the \fBpackage\fR command is determined by its first argument. The following forms are permitted: .TP -\fBpackage files\fR \fIpackage\fR -. -Lists all files forming part of \fIpackage\fR. Auto-loaded files are not -included in this list, only files which were directly sourced during package -initialization. The list order corresponds with the order in which the -files were sourced. -.TP -\fBpackage forget\fR ?\fIpackage package ...\fR? -. +\fBpackage forget ?\fIpackage package ...\fR? Removes all information about each specified package from this interpreter, including information provided by both \fBpackage ifneeded\fR and \fBpackage provide\fR. .TP \fBpackage ifneeded \fIpackage version\fR ?\fIscript\fR? -. This command typically appears only in system configuration scripts to set up the package database. It indicates that a particular version of a particular package is available if needed, and that the package can be added to the interpreter by executing \fIscript\fR. @@ -78,11 +69,10 @@ version \fIversion\fR of package \fIpackage\fR is returned, or an empty string if no \fBpackage ifneeded\fR command has been invoked for this \fIpackage\fR and \fIversion\fR. .TP \fBpackage names\fR -. Returns a list of the names of all packages in the interpreter for which a version has been provided (via \fBpackage provide\fR) or for which a \fBpackage ifneeded\fR script is available. The order of elements in the list is arbitrary. @@ -91,24 +81,22 @@ . This command is equivalent to \fBpackage require\fR except that it does not try and load the package if it is not already loaded. .TP \fBpackage provide \fIpackage \fR?\fIversion\fR? -. This command is invoked to indicate that version \fIversion\fR of package \fIpackage\fR is now present in the interpreter. It is typically invoked once as part of an \fBifneeded\fR script, and again by the package itself when it is finally loaded. An error occurs if a different version of \fIpackage\fR has been provided by a previous \fBpackage provide\fR command. If the \fIversion\fR argument is omitted, then the command returns the version number that is currently provided, or an empty string if no \fBpackage provide\fR command has been -invoked for \fIpackage\fR in this interpreter. +invoked for \fIpackage\fR in this interpreter. .TP -\fBpackage require \fR\fIpackage \fR?\fIrequirement...\fR? -. +\fBpackage require\fR \fIpackage \fR?\fIrequirement...\fR? This command is typically invoked by Tcl code that wishes to use a particular version of a particular package. The arguments indicate which package is wanted, and the command ensures that a suitable version of the package is loaded into the interpreter. If the command succeeds, it returns the version number that is @@ -150,17 +138,15 @@ If all of these steps fail to provide an acceptable version of the package, then the command returns an error. .RE .TP \fBpackage require \-exact \fIpackage version\fR -. This form of the command is used when only the given \fIversion\fR of \fIpackage\fR is acceptable to the caller. This command is equivalent to \fBpackage require \fIpackage version\fR-\fIversion\fR. .TP \fBpackage unknown \fR?\fIcommand\fR? -. This command supplies a .QW "last resort" command to invoke during \fBpackage require\fR if no suitable version of a package can be found in the \fBpackage ifneeded\fR database. @@ -178,40 +164,34 @@ or an empty string if there is none. If \fIcommand\fR is specified as an empty string, then the current \fBpackage unknown\fR script is removed, if there is one. .TP \fBpackage vcompare \fIversion1 version2\fR -. Compares the two version numbers given by \fIversion1\fR and \fIversion2\fR. Returns -1 if \fIversion1\fR is an earlier version than \fIversion2\fR, -0 if they are equal, and 1 if \fIversion1\fR is later than \fIversion2\fR. +0 if they are equal, and 1 if \fIversion1\fR is later than \fBversion2\fR. .TP \fBpackage versions \fIpackage\fR -. Returns a list of all the version numbers of \fIpackage\fR for which information has been provided by \fBpackage ifneeded\fR commands. .TP \fBpackage vsatisfies \fIversion requirement...\fR -. Returns 1 if the \fIversion\fR satisfies at least one of the given requirements, and 0 otherwise. Each \fIrequirement\fR is allowed to have any of the forms: .RS .TP min -. This form is called .QW min-bounded . .TP min- -. This form is called .QW min-unbound . .TP min-max -. This form is called .QW bounded . .RE .RS .PP @@ -289,12 +269,12 @@ When passed any other value as an argument, raise an invalid argument error. .PP When an interpreter is created, its initial selection mode value is set to .QW stable -unless the environment variable \fBTCL_PKG_PREFER_LATEST\fR is set -(to any value) or the Tcl package itself is unstable. Otherwise +unless the environment variable \fBTCL_PKG_PREFER_LATEST\fR +is set. If that environment variable is defined (with any value) then the initial (and permanent) selection mode value is set to .QW latest . .RE .SH "VERSION NUMBERS" .PP @@ -346,33 +326,27 @@ \fBpkg_mkIndex\fR to create package index files. Once you have done this, packages will be loaded automatically in response to \fBpackage require\fR commands. See the documentation for \fBpkg_mkIndex\fR for details. .SH EXAMPLES -.PP To state that a Tcl script requires the Tk and http packages, put this at the top of the script: -.PP .CS \fBpackage require\fR Tk \fBpackage require\fR http .CE .PP To test to see if the Snack package is available and load if it is (often useful for optional enhancements to programs where the loss of the functionality is not critical) do this: -.PP .CS if {[catch {\fBpackage require\fR Snack}]} { - # Error thrown - package not found. - # Set up a dummy interface to work around the absence + # Error thrown - package not found. + # Set up a dummy interface to work around the absence } else { - # We have the package, configure the app to use it + # We have the package, configure the app to use it } .CE .SH "SEE ALSO" msgcat(n), packagens(n), pkgMkIndex(n) .SH KEYWORDS package, version -'\" Local Variables: -'\" mode: nroff -'\" End: Index: doc/packagens.n ================================================================== --- doc/packagens.n +++ doc/packagens.n @@ -1,17 +1,17 @@ '\" '\" Copyright (c) 1998-2000 by Scriptics Corporation. '\" All rights reserved. -'\" +'\" .TH pkg::create n 8.3 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME pkg::create \- Construct an appropriate 'package ifneeded' command for a given package specification .SH SYNOPSIS -\fB::pkg::create\fR \fB\-name \fIpackageName \fB\-version \fIpackageVersion\fR ?\fB\-load \fIfilespec\fR? ... ?\fB\-source \fIfilespec\fR? ... +\fB::pkg::create \fI\-name packageName\fR \fI\-version packageVersion\fR ?\fI\-load filespec\fR? ... ?\fI\-source filespec\fR? ... .BE .SH DESCRIPTION .PP \fB::pkg::create\fR is a utility procedure that is part of the standard Tcl @@ -20,26 +20,26 @@ \fBpkgIndex.tcl\fR file for use with the \fBpackage\fR mechanism. .SH OPTIONS The parameters supported are: .TP -\fB\-name \fIpackageName\fR +\fB\-name\fR\0\fIpackageName\fR This parameter specifies the name of the package. It is required. .TP -\fB\-version \fIpackageVersion\fR +\fB\-version\fR\0\fIpackageVersion\fR This parameter specifies the version of the package. It is required. .TP -\fB\-load \fIfilespec\fR +\fB\-load\fR\0\fIfilespec\fR This parameter specifies a binary library that must be loaded with the \fBload\fR command. \fIfilespec\fR is a list with two elements. The first element is the name of the file to load. The second, optional element is a list of commands supplied by loading that file. If the list of procedures is empty or omitted, \fB::pkg::create\fR will set up the library for direct loading (see \fBpkg_mkIndex\fR). Any number of \fB\-load\fR parameters may be specified. .TP -\fB\-source \fIfilespec\fR +\fB\-source\fR\0\fIfilespec\fR This parameter is similar to the \fB\-load\fR parameter, except that it specifies a Tcl library that must be loaded with the \fBsource\fR command. Any number of \fB\-source\fR parameters may be specified. .PP @@ -46,9 +46,5 @@ At least one \fB\-load\fR or \fB\-source\fR parameter must be given. .SH "SEE ALSO" package(n) .SH KEYWORDS auto-load, index, package, version -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/pid.n ================================================================== --- doc/pid.n +++ doc/pid.n @@ -2,11 +2,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 pid n 7.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -41,11 +41,8 @@ close $pipeline .CE .SH "SEE ALSO" exec(n), open(n) + .SH KEYWORDS file, pipeline, process identifier -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/pkgMkIndex.n ================================================================== --- doc/pkgMkIndex.n +++ doc/pkgMkIndex.n @@ -1,20 +1,20 @@ '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH pkg_mkIndex n 8.3 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME pkg_mkIndex \- Build an index for automatic loading of packages .SH SYNOPSIS .nf -\fBpkg_mkIndex\fR ?\fIoptions...\fR? \fIdir\fR ?\fIpattern pattern ...\fR? +\fBpkg_mkIndex ?\fI\-direct\fR? ?\fI\-lazy\fR? ?\fI\-load pkgPat\fR? ?\fI\-verbose\fR? \fIdir\fR ?\fIpattern pattern ...\fR? .fi .BE .SH DESCRIPTION .PP \fBPkg_mkIndex\fR is a utility procedure that is part of the standard @@ -40,16 +40,16 @@ .RS .PP \fBPkg_mkIndex\fR will create a file \fBpkgIndex.tcl\fR in \fIdir\fR with package information about all the files given by the \fIpattern\fR arguments. -It does this by loading each file into a child +It does this by loading each file into a slave interpreter and seeing what packages and new commands appear (this is why it is essential to have \fBpackage provide\fR commands or \fBTcl_PkgProvide\fR calls in the files, as described above). -If you have a package split among scripts and binary files, +If you have a package split among scripts and binary files, or if you have dependencies among files, you may have to use the \fB\-load\fR option or adjust the order in which \fBpkg_mkIndex\fR processes the files. See \fBCOMPLEX CASES\fR below. .RE @@ -107,14 +107,14 @@ it immediately upon \fBpackage require\fR. This is not compatible with the use of \fIauto_reset\fR, and therefore its use is discouraged. .TP 15 \fB\-load \fIpkgPat\fR The index process will pre-load any packages that exist in the -current interpreter and match \fIpkgPat\fR into the child interpreter used to +current interpreter and match \fIpkgPat\fR into the slave interpreter used to generate the index. The pattern match uses string match rules, but without making case distinctions. -See \fBCOMPLEX CASES\fR below. +See COMPLEX CASES below. .TP 15 \fB\-verbose\fR Generate output during the indexing process. Output is via the \fBtclLog\fR procedure, which by default prints to stderr. .TP 15 @@ -130,11 +130,11 @@ rather than \fBauto_mkindex\fR because the package mechanism provides version control: several versions of a package can be made available in the index files, with different applications using different versions based on \fBpackage require\fR commands. In contrast, \fBauto_mkindex\fR does not understand versions so -it can only handle a single version of each package. +it can only handle a single version of each package. It is probably not a good idea to index a given package with both \fBpkg_mkIndex\fR and \fBauto_mkindex\fR. If you use \fBpkg_mkIndex\fR to index a package, its commands cannot be invoked until \fBpackage require\fR has been used to select a version; in contrast, packages indexed with \fBauto_mkindex\fR @@ -151,11 +151,11 @@ The \fBpkgIndex.tcl\fR files contain \fBpackage ifneeded\fR commands for each version of each available package; these commands invoke \fBpackage provide\fR commands to announce the availability of the package, and they setup auto-loader information to load the files of the package. -If the \fB\-lazy\fR flag was provided when the \fBpkgIndex.tcl\fR +If the \fI\-lazy\fR flag was provided when the \fBpkgIndex.tcl\fR was generated, a given file of a given version of a given package is not actually loaded until the first time one of its commands is invoked. Thus, after invoking \fBpackage require\fR you may @@ -166,11 +166,11 @@ Some packages, for instance packages which use namespaces and export commands or those which require special initialization, might select that their package files be loaded immediately upon \fBpackage require\fR instead of delaying the actual loading to the first use of one of the package's command. This is the default mode when generating the package -index. It can be overridden by specifying the \fB\-lazy\fR argument. +index. It can be overridden by specifying the \fI\-lazy\fR argument. .SH "COMPLEX CASES" Most complex cases of dependencies among scripts and binary files, and packages being split among scripts and binary files are handled OK. However, you may have to adjust the order in which files are processed by \fBpkg_mkIndex\fR. @@ -226,8 +226,5 @@ the binary file may mask the package defined by the scripts. .SH "SEE ALSO" package(n) .SH KEYWORDS auto-load, index, package, version -'\"Local Variables: -'\"mode: nroff -'\"End: Index: doc/platform.n ================================================================== --- doc/platform.n +++ doc/platform.n @@ -1,20 +1,20 @@ '\" '\" Copyright (c) 2006 ActiveState Software Inc '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH "platform" n 1.0.4 platform "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME platform \- System identification support code and utilities .SH SYNOPSIS .nf -\fBpackage require platform\fR ?\fB1.0.10\fR? +\fBpackage require platform ?1.0.4?\fR .sp \fBplatform::generic\fR \fBplatform::identify\fR \fBplatform::patterns \fIidentifier\fR .fi @@ -43,44 +43,24 @@ and makes it more convenient for developers to identify the current architecture a Tcl program is running on. .SH COMMANDS .TP \fBplatform::identify\fR -. This command returns an identifier describing the platform the Tcl core is running on. The returned identifier has the general format \fIOS\fR-\fICPU\fR. The \fIOS\fR part of the identifier may contain details like kernel version, libc version, etc., and this information may contain dashes as well. The \fICPU\fR part will not contain dashes, making the preceding dash the last dash in the result. .TP \fBplatform::generic\fR -. This command returns a simplified identifier describing the platform the Tcl core is running on. In contrast to \fBplatform::identify\fR it leaves out details like kernel version, libc version, etc. The returned identifier has the general format \fIOS\fR-\fICPU\fR. .TP -\fBplatform::patterns \fIidentifier\fR -. +\fBplatform::patterns \fIidentifier\fR This command takes an identifier as returned by \fBplatform::identify\fR and returns a list of identifiers describing compatible architectures. -.SH EXAMPLE -.PP -This can be used to allow an application to be shipped with multiple builds of -a shared library, so that the same package works on many versions of an -operating system. For example: -.PP -.CS -\fBpackage require platform\fR -# Assume that app script is .../theapp/bin/theapp.tcl -set binDir [file dirname [file normalize [info script]]] -set libDir [file join $binDir .. lib] -set platLibDir [file join $libDir [\fBplatform::identify\fR]] -load [file join $platLibDir support[info sharedlibextension]] -.CE .SH KEYWORDS operating system, cpu architecture, platform, architecture -'\" Local Variables: -'\" mode: nroff -'\" End: Index: doc/platform_shell.n ================================================================== --- doc/platform_shell.n +++ doc/platform_shell.n @@ -1,20 +1,20 @@ '\" '\" Copyright (c) 2006-2008 ActiveState Software Inc '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH "platform::shell" n 1.1.4 platform::shell "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME platform::shell \- System identification support code and utilities .SH SYNOPSIS .nf -\fBpackage require platform::shell\fR ?\fB1.1.4\fR? +\fBpackage require platform::shell ?1.1.4?\fR .sp \fBplatform::shell::generic \fIshell\fR \fBplatform::shell::identify \fIshell\fR \fBplatform::shell::platform \fIshell\fR .fi @@ -53,9 +53,5 @@ \fBplatform::shell::platform \fIshell\fR This command returns the contents of \fBtcl_platform(platform)\fR for the specified Tcl shell. .SH KEYWORDS operating system, cpu architecture, platform, architecture -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: DELETED doc/prefix.n Index: doc/prefix.n ================================================================== --- doc/prefix.n +++ /dev/null @@ -1,116 +0,0 @@ -'\" -'\" Copyright (c) 2008 Peter Spjuth -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH prefix n 8.6 Tcl "Tcl Built-In Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -tcl::prefix \- facilities for prefix matching -.SH SYNOPSIS -.nf -\fB::tcl::prefix all\fR \fItable string\fR -\fB::tcl::prefix longest\fR \fItable string\fR -\fB::tcl::prefix match\fR ?\fIoption ...\fR? \fItable string\fR -.fi -.BE -.SH DESCRIPTION -.PP -This document describes commands looking up a prefix in a list of strings. -The following commands are supported: -.TP -\fB::tcl::prefix all\fR \fItable string\fR -. -Returns a list of all elements in \fItable\fR that begin with the prefix -\fIstring\fR. -.TP -\fB::tcl::prefix longest\fR \fItable string\fR -. -Returns the longest common prefix of all elements in \fItable\fR that -begin with the prefix \fIstring\fR. -.TP -\fB::tcl::prefix match\fR ?\fIoptions\fR? \fItable string\fR -. -If \fIstring\fR equals one element in \fItable\fR or is a prefix to exactly -one element, the matched element is returned. If not, the result depends -on the \fB\-error\fR option. (It is recommended that the \fItable\fR be sorted -before use with this subcommand, so that the list of matches presented in the -error message also becomes sorted, though this is not strictly necessary for -the operation of this subcommand itself.) -.RS -.TP -\fB\-exact\fR\0 -. -Accept only exact matches. -.TP -\fB\-message\0\fIstring\fR -. -Use \fIstring\fR in the error message at a mismatch. Default is -.QW option . -.TP -\fB\-error\0\fIoptions\fR -. -The \fIoptions\fR are used when no match is found. If \fIoptions\fR is empty, -no error is generated and an empty string is returned. Otherwise the -\fIoptions\fR are used as \fBreturn\fR options when generating the error -message. The default corresponds to setting -.QW "\-level 0" . -Example: If -.QW "\fB\-error\fR {\-errorcode MyError \-level 1}" -is used, an error would be generated as: -.RS -.PP -.CS -return \-errorcode MyError \-level 1 \-code error \e - "ambiguous option ..." -.CE -.RE -.RE -.SH "EXAMPLES" -.PP -Basic use: -.PP -.CS -namespace import ::tcl::prefix -\fBprefix match\fR {apa bepa cepa} apa - \fI\(-> apa\fR -\fBprefix match\fR {apa bepa cepa} a - \fI\(-> apa\fR -\fBprefix match\fR \-exact {apa bepa cepa} a - \fI\(-> bad option "a": must be apa, bepa, or cepa\fR -\fBprefix match\fR \-message "switch" {apa ada bepa cepa} a - \fI\(-> ambiguous switch "a": must be apa, ada, bepa, or cepa\fR -\fBprefix longest\fR {fblocked fconfigure fcopy file fileevent flush} fc - \fI\(-> fco\fR -\fBprefix all\fR {fblocked fconfigure fcopy file fileevent flush} fc - \fI\(-> fconfigure fcopy\fR -.CE -.PP -Simplifying option matching: -.PP -.CS -array set opts {\-apa 1 \-bepa "" \-cepa 0} -foreach {arg val} $args { - set opts([\fBprefix match\fR {\-apa \-bepa \-cepa} $arg]) $val -} -.CE -.PP -Creating a \fBswitch\fR that supports prefixes: -.PP -.CS -switch [\fBprefix match\fR {apa bepa cepa} $arg] { - apa { } - bepa { } - cepa { } -} -.CE -.SH "SEE ALSO" -lsearch(n), namespace(n), string(n), Tcl_GetIndexFromObj(3) -.SH "KEYWORDS" -prefix, table lookup -'\" Local Variables: -'\" mode: nroff -'\" End: Index: doc/proc.n ================================================================== --- doc/proc.n +++ doc/proc.n @@ -2,20 +2,21 @@ '\" 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 proc n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME proc \- Create a Tcl procedure .SH SYNOPSIS \fBproc \fIname args body\fR .BE + .SH DESCRIPTION .PP The \fBproc\fR command creates a new Tcl procedure named \fIname\fR, replacing any existing command or procedure there may have been by that name. @@ -30,15 +31,14 @@ procedure. It consists of a list, possibly empty, each of whose elements specifies one argument. Each argument specifier is also a list with either one or two fields. If there is only a single field in the specifier then it is the name of the argument; if there are two fields, then -the first is the argument name and the second is its default value. +the first is the argument name and the second is its default value. Arguments with default values that are followed by non-defaulted -arguments become required arguments; enough actual arguments must be -supplied to allow all arguments up to and including the last required -formal argument. +arguments become required arguments. In 8.6 this will be considered an +error. .PP When \fIname\fR is invoked a local variable will be created for each of the formal arguments to the procedure; its value will be the value of corresponding argument in the invoking command or the argument's default value. @@ -45,84 +45,57 @@ Actual arguments are assigned to formal arguments strictly in order. Arguments with default values need not be specified in a procedure invocation. However, there must be enough actual arguments for all the formal arguments that do not have defaults, and there must not be any extra -actual arguments. +actual arguments. Arguments with default values that are followed by non-defaulted -arguments become de-facto required arguments, though this may change -in a future version of Tcl; portable code should ensure that all -optional arguments come after all required arguments. -.PP +arguments become required arguments (in 8.6 it will be considered an +error). There is one special case to permit procedures with variable numbers of arguments. If the last formal argument has the name -.QW \fBargs\fR , -then a call to the procedure may contain more actual arguments -than the procedure has formal arguments. In this case, all of the actual arguments +\fBargs\fR, then a call to the procedure may contain more actual arguments +than the procedure has formals. In this case, all of the actual arguments starting at the one that would be assigned to \fBargs\fR are combined into a list (as if the \fBlist\fR command had been used); this combined value is assigned to the local variable \fBargs\fR. .PP When \fIbody\fR is being executed, variable names normally refer to local variables, which are created automatically when referenced and deleted when the procedure returns. One local variable is automatically created for each of the procedure's arguments. -Other variables can only be accessed by invoking one of the \fBglobal\fR, +Other variables can only be accessed by invoking one of the \fBglobal\fR, \fBvariable\fR, \fBupvar\fR or \fBnamespace upvar\fR commands. -The current namespace when \fIbody\fR is executed will be the -namespace that the procedure's name exists in, which will be the -namespace that it was created in unless it has been changed with -\fBrename\fR. -'\" We may change this! It makes [variable] unstable when renamed and is -'\" frankly pretty crazy, but doing it right is harder than it looks. .PP The \fBproc\fR command returns an empty string. When a procedure is invoked, the procedure's return value is the value specified in a \fBreturn\fR command. If the procedure does not execute an explicit \fBreturn\fR, then its return value is the value of the last command executed in the procedure's body. If an error occurs while executing the procedure body, then the procedure-as-a-whole will return that same error. .SH EXAMPLES -.PP -This is a procedure that takes two arguments and prints both their sum -and their product. It also returns the string -.QW OK -to the caller as an explicit result. -.PP -.CS -\fBproc\fR printSumProduct {x y} { - set sum [expr {$x + $y}] - set prod [expr {$x * $y}] - puts "sum is $sum, product is $prod" - return "OK" -} -.CE -.PP This is a procedure that accepts arbitrarily many arguments and prints them out, one by one. -.PP .CS \fBproc\fR printArguments args { - foreach arg $args { - puts $arg - } + foreach arg $args { + puts $arg + } } .CE .PP This procedure is a bit like the \fBincr\fR command, except it multiplies the contents of the named variable by the value, which defaults to \fB2\fR: -.PP .CS \fBproc\fR mult {varName {multiplier 2}} { - upvar 1 $varName var - set var [expr {$var * $multiplier}] + upvar 1 $varName var + set var [expr {$var * $multiplier}] } .CE + .SH "SEE ALSO" info(n), unknown(n) + .SH KEYWORDS argument, procedure -'\" Local Variables: -'\" mode: nroff -'\" End: DELETED doc/process.n Index: doc/process.n ================================================================== --- doc/process.n +++ /dev/null @@ -1,150 +0,0 @@ -'\" -'\" Copyright (c) 2017 Frederic Bonnet. -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH process n 8.7 Tcl "Tcl Built-In Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -tcl::process \- Subprocess management -.SH SYNOPSIS -\fB::tcl::process \fIoption \fR?\fIarg arg ...\fR? -.BE -.SH DESCRIPTION -.PP -This command provides a way to manage subprocesses created by the \fBopen\fR -and \fBexec\fR commands, as identified by the process identifiers (PIDs) of -those subprocesses. The legal \fIoptions\fR (which may be abbreviated) are: -.TP -\fB::tcl::process autopurge\fR ?\fIflag\fR? -. -Automatic purge facility. If \fIflag\fR is specified as a boolean value then -it activates or deactivate autopurge. In all cases it returns the current -status as a boolean value. When autopurge is active, -\fBTcl_ReapDetachedProcs\fR is called each time the \fBexec\fR command is -executed or a pipe channel created by \fBopen\fR is closed. When autopurge is -inactive, \fB::tcl::process\fR purge must be called explicitly. By default -autopurge is active. -.TP -\fB::tcl::process list\fR -. -Returns the list of subprocess PIDs. This includes all currently executing -subprocesses and all terminated subprocesses that have not yet had their -corresponding process table entries purged. -.TP -\fB::tcl::process purge\fR ?\fIpids\fR? -. -Cleans up all data associated with terminated subprocesses. If \fIpids\fR is -specified as a list of PIDs then the command only cleanup data for the matching -subprocesses if they exist, and raises an error otherwise. If a process listed is -still active, this command does nothing to that process. -.TP -\fB::tcl::process status\fR ?\fIswitches\fR? ?\fIpids\fR? -. -Returns a dictionary mapping subprocess PIDs to their respective status. If -\fIpids\fR is specified as a list of PIDs then the command only returns the -status of the matching subprocesses if they exist, and raises an error -otherwise. For active processes, the status is an empty value. For terminated -processes, the status is a list with the following format: -.QW "\fB{\fIcode\fR ?\fImsg errorCode\fR?\fB}\fR" , -where: -.RS -.TP -\fIcode\fR\0 -. -is a standard Tcl return code, i.e., \fB0\fR for TCL_OK and \fB1\fR -for TCL_ERROR, -.TP -\fImsg\fR\0 -. -is the human-readable error message, -.TP -\fIerrorCode\fR\0 -. -uses the same format as the \fBerrorCode\fR global variable -.PP -Note that \fBmsg\fR and \fBerrorCode\fR are only present for abnormally -terminated processes (i.e. those where the \fIcode\fR is nonzero). Under the -hood this command calls \fBTcl_WaitPid\fR with the \fBWNOHANG\fR flag set for -non-blocking behavior, unless the \fB\-wait\fR switch is set (see below). -.PP -Additionally, \fB::tcl::process status\fR accepts the following switches: -.TP -\fB\-wait\fR\0 -. -By default the command returns immediately (the underlying \fBTcl_WaitPid\fR is -called with the \fBWNOHANG\fR flag set) unless this switch is set. If \fIpids\fR -is specified as a list of PIDs then the command waits until the status of the -matching subprocesses are available. If \fIpids\fR was not specified, this -command will wait for all known subprocesses. -.TP -\fB\-\|\-\fR -. -Marks the end of switches. The argument following this one will -be treated as the first \fIarg\fR even if it starts with a \fB\-\fR. -.RE -.SH "EXAMPLES" -.PP -These show the use of \fB::tcl::process\fR. Some of the results from -\fB::tcl::process status\fR are split over multiple lines for readability. -.PP -.CS -\fB::tcl::process autopurge\fR - \fI\(-> true\fR -\fB::tcl::process autopurge\fR false - \fI\(-> false\fR - -set pid1 [exec command1 a b c | command2 d e f &] - \fI\(-> 123 456\fR -set chan [open "|command1 a b c | command2 d e f"] - \fI\(-> file123\fR -set pid2 [pid $chan] - \fI\(-> 789 1011\fR - -\fB::tcl::process list\fR - \fI\(-> 123 456 789 1011\fR - -\fB::tcl::process status\fR - \fI\(-> 123 0 - 456 {1 "child killed: write on pipe with no readers" { - CHILDKILLED 456 SIGPIPE "write on pipe with no readers"}} - 789 {1 "child suspended: background tty read" { - CHILDSUSP 789 SIGTTIN "background tty read"}} - 1011 {}\fR - -\fB::tcl::process status\fR 123 - \fI\(-> 123 0\fR - -\fB::tcl::process status\fR 1011 - \fI\(-> 1011 {}\fR - -\fB::tcl::process status\fR -wait - \fI\(-> 123 0 - 456 {1 "child killed: write on pipe with no readers" { - CHILDKILLED 456 SIGPIPE "write on pipe with no readers"}} - 789 {1 "child suspended: background tty read" { - CHILDSUSP 789 SIGTTIN "background tty read"}} - 1011 {1 "child process exited abnormally" { - CHILDSTATUS 1011 -1}}\fR - -\fB::tcl::process status\fR 1011 - \fI\(-> 1011 {1 "child process exited abnormally" { - CHILDSTATUS 1011 -1}}\fR - -\fB::tcl::process purge\fR -exec command1 1 2 3 & - \fI\(-> 1213\fR -\fB::tcl::process list\fR - \fI\(-> 1213\fR -.CE -.SH "SEE ALSO" -exec(n), open(n), pid(n), -Tcl_DetachPids(3), Tcl_WaitPid(3), Tcl_ReapDetachedProcs(3) -.SH "KEYWORDS" -background, child, detach, process, wait -'\" Local Variables: -'\" mode: nroff -'\" End: Index: doc/puts.n ================================================================== --- doc/puts.n +++ doc/puts.n @@ -2,20 +2,21 @@ '\" 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 puts n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME puts \- Write to a channel .SH SYNOPSIS \fBputs \fR?\fB\-nonewline\fR? ?\fIchannelId\fR? \fIstring\fR .BE + .SH DESCRIPTION .PP Writes the characters given by \fIstring\fR to the channel given by \fIchannelId\fR. .PP @@ -61,42 +62,35 @@ To avoid wasting memory, nonblocking I/O should normally be used in an event-driven fashion with the \fBfileevent\fR command (do not invoke \fBputs\fR unless you have recently been notified via a file event that the channel is ready for more output data). .SH EXAMPLES -.PP Write a short message to the console (or wherever \fBstdout\fR is directed): -.PP .CS \fBputs\fR "Hello, World!" .CE .PP Print a message in several parts: -.PP .CS \fBputs\fR -nonewline "Hello, " \fBputs\fR "World!" .CE .PP Print a message to the standard error channel: -.PP .CS \fBputs\fR stderr "Hello, World!" .CE .PP Append a log message to a file: -.PP .CS set chan [open my.log a] set timestamp [clock format [clock seconds]] \fBputs\fR $chan "$timestamp - Hello, World!" close $chan .CE + .SH "SEE ALSO" file(n), fileevent(n), Tcl_StandardChannels(3) + .SH KEYWORDS channel, newline, output, write -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/pwd.n ================================================================== --- doc/pwd.n +++ doc/pwd.n @@ -2,42 +2,38 @@ '\" 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 pwd n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME pwd \- Return the absolute path of the current working directory .SH SYNOPSIS \fBpwd\fR .BE + .SH DESCRIPTION .PP Returns the absolute path name of the current working directory. .SH EXAMPLE -.PP Sometimes it is useful to change to a known directory when running some external command using \fBexec\fR, but it is important to keep the application usually running in the directory that it was started in (unless the user specifies otherwise) since that minimizes user confusion. The way to do this is to save the current directory while the external command is being run: -.PP .CS set tarFile [file normalize somefile.tar] set savedDir [\fBpwd\fR] cd /tmp exec tar -xf $tarFile cd $savedDir .CE .SH "SEE ALSO" file(n), cd(n), glob(n), filename(n) + .SH KEYWORDS working directory -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/re_syntax.n ================================================================== --- doc/re_syntax.n +++ doc/re_syntax.n @@ -3,14 +3,12 @@ '\" Copyright (c) 1999 Scriptics Corporation '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros -.ie '\w'o''\w'\C'^o''' .ds qo \C'^o' -.el .ds qo u .TH re_syntax n "8.1" Tcl "Tcl Built-In Commands" +.so man.macros .BS .SH NAME re_syntax \- Syntax of Tcl regular expressions .BE .SH DESCRIPTION @@ -135,15 +133,30 @@ later, under \fBESCAPES\fR. .RS 2 .TP 8 \fB^\fR . -matches at the beginning of a line +matches at the beginning of the string or a line (according to whether +matching is newline-sensitive or not, as described in \fBMATCHING\fR, +below). .TP \fB$\fR . -matches at the end of a line +matches at the end of the string or a line (according to whether +matching is newline-sensitive or not, as described in \fBMATCHING\fR, +below). +.RS +.PP +The difference between string and line matching modes is immaterial +when the string does not contain a newline character. The \fB\eA\fR +and \fB\eZ\fR constraint escapes have a similar purpose but are +always constraints for the overall string. +.PP +The default newline-sensitivity depends on the command that uses the +regular expression, and can be overridden as described in +\fBMETASYNTAX\fR, below. +.RE .TP \fB(?=\fIre\fB)\fR . \fIpositive lookahead\fR (AREs only), matches at any point where a substring matching \fIre\fR begins @@ -221,12 +234,11 @@ .IP \fBspace\fR 8 A character producing white space in displayed text. .IP \fBpunct\fR 8 A punctuation character. .IP \fBgraph\fR 8 -A character with a visible representation (includes both \fBalnum\fR -and \fBpunct\fR). +A character with a visible representation (includes both alnum and punct). .IP \fBcntrl\fR 8 A control character. .PP A locale may provide others. A character class may not be used as an endpoint of a range. @@ -291,16 +303,16 @@ itself. (If there are no other equivalent collating elements, the treatment is as if the enclosing delimiters were .QW \fB[.\fR \& and .QW \fB.]\fR .) -For example, if \fBo\fR and \fB\[^o]\fR are the members of an +For example, if \fBo\fR and \fB\N'244'\fR are the members of an equivalence class, then .QW \fB[[=o=]]\fR , -.QW \fB[[=\[^o]=]]\fR , +.QW \fB[[=\N'244'=]]\fR , and -.QW \fB[o\[^o]]\fR \& +.QW \fB[o\N'244']\fR \& are all synonymous. An equivalence class may not be an endpoint of a range. .RS .PP (\fINote:\fR Tcl implements only the Unicode locale. It does not define any equivalence classes. The examples above are just illustrations.) @@ -360,46 +372,43 @@ . horizontal tab, as in C .TP \fB\eu\fIwxyz\fR . -(where \fIwxyz\fR is one up to four hexadecimal digits) the Unicode +(where \fIwxyz\fR is exactly four hexadecimal digits) the Unicode character \fBU+\fIwxyz\fR in the local byte ordering .TP \fB\eU\fIstuvwxyz\fR . -(where \fIstuvwxyz\fR is one up to eight hexadecimal digits) reserved -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. +(where \fIstuvwxyz\fR is exactly eight hexadecimal digits) reserved +for a somewhat-hypothetical Unicode extension to 32 bits .TP \fB\ev\fR . -vertical tab, as in C +vertical tab, as in C are all available. .TP -\fB\ex\fIhh\fR +\fB\ex\fIhhh\fR . -(where \fIhh\fR is one or two hexadecimal digits) the character -whose hexadecimal value is \fB0x\fIhh\fR. +(where \fIhhh\fR is any sequence of hexadecimal digits) the character +whose hexadecimal value is \fB0x\fIhhh\fR (a single character no +matter how many hexadecimal digits are used). .TP \fB\e0\fR . the character whose value is \fB0\fR .TP -\fB\e\fIxyz\fR -. -(where \fIxyz\fR is exactly three octal digits, and is not a \fIback -reference\fR (see below)) the character whose octal value is -\fB0\fIxyz\fR. The first digit must be in the range 0-3, otherwise -the two-digit form is assumed. -.TP \fB\e\fIxy\fR . (where \fIxy\fR is exactly two octal digits, and is not a \fIback reference\fR (see below)) the character whose octal value is \fB0\fIxy\fR +.TP +\fB\e\fIxyz\fR +. +(where \fIxyz\fR is exactly three octal digits, and is not a back +reference (see below)) the character whose octal value is +\fB0\fIxyz\fR .RE .PP Hexadecimal digits are .QR \fB0\fR \fB9\fR , .QR \fBa\fR \fBf\fR , @@ -681,37 +690,13 @@ substrings, based on their preferences, with subexpressions starting earlier in the RE taking priority over ones starting later. Note that outer subexpressions thus take priority over their component subexpressions. .PP -The quantifiers \fB{1,1}\fR and \fB{1,1}?\fR can be used to +Note that the quantifiers \fB{1,1}\fR and \fB{1,1}?\fR can be used to force longest and shortest preference, respectively, on a subexpression or a whole RE. -.RS -.PP -\fBNOTE:\fR This means that you can usually make a RE be non-greedy overall by -putting \fB{1,1}?\fR after one of the first non-constraint atoms or -parenthesized sub-expressions in it. \fIIt pays to experiment\fR with the -placing of this non-greediness override on a suitable range of input texts -when you are writing a RE if you are using this level of complexity. -.PP -For example, this regular expression is non-greedy, and will match the -shortest substring possible given that -.QW \fBabc\fR -will be matched as early as possible (the quantifier does not change that): -.PP -.CS -ab{1,1}?c.*x.*cba -.CE -.PP -The atom -.QW \fBa\fR -has no greediness preference, we explicitly give one for -.QW \fBb\fR , -and the remaining quantifiers are overridden to be non-greedy by the preceding -non-greedy quantifier. -.RE .PP Match lengths are measured in characters, not collating elements. An empty string is considered longer than no match at all. For example, .QW \fBbb*\fR matches the three middle characters of Index: doc/read.n ================================================================== --- doc/read.n +++ doc/read.n @@ -2,11 +2,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 read n 8.1 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -14,10 +14,11 @@ .SH SYNOPSIS \fBread \fR?\fB\-nonewline\fR? \fIchannelId\fR .sp \fBread \fIchannelId numChars\fR .BE + .SH DESCRIPTION .PP In the first form, the \fBread\fR command reads all of the data from \fIchannelId\fR up to the end of the file. If the \fB\-nonewline\fR switch is specified then the last character of the file is discarded @@ -48,42 +49,38 @@ \fBRead\fR translates end-of-line sequences in the input into newline characters according to the \fB\-translation\fR option for the channel. See the \fBfconfigure\fR manual entry for a discussion on ways in which \fBfconfigure\fR will alter input. + .SH "USE WITH SERIAL PORTS" '\" Note: this advice actually applies to many versions of Tcl -.PP + For most applications a channel connected to a serial port should be -configured to be nonblocking: \fBfconfigure\fI channelId \fB\-blocking +configured to be nonblocking: \fBfconfigure \fIchannelId \fB\-blocking \fI0\fR. Then \fBread\fR behaves much like described above. Care must be taken when using \fBread\fR on blocking serial ports: .TP -\fBread \fIchannelId numChars\fR -. +\fBread \fIchannelId numChars\fR In this form \fBread\fR blocks until \fInumChars\fR have been received from the serial port. .TP -\fBread \fIchannelId\fR -. +\fBread \fIchannelId\fR In this form \fBread\fR blocks until the reception of the end-of-file -character, see \fBfconfigure\fR \fB\-eofchar\fR. If there no end-of-file +character, see \fBfconfigure -eofchar\fR. If there no end-of-file character has been configured for the channel, then \fBread\fR will block forever. .SH "EXAMPLE" -.PP This example code reads a file all at once, and splits it into a list, with each line in the file corresponding to an element in the list: -.PP .CS set fl [open /proc/meminfo] set data [\fBread\fR $fl] close $fl set lines [split $data \en] .CE + .SH "SEE ALSO" file(n), eof(n), fblocked(n), fconfigure(n), Tcl_StandardChannels(3) + .SH KEYWORDS blocking, channel, end of line, end of file, nonblocking, read, translation, encoding -'\"Local Variables: -'\"mode: nroff -'\"End: Index: doc/refchan.n ================================================================== --- doc/refchan.n +++ doc/refchan.n @@ -1,6 +1,6 @@ -'\" +'\" '\" Copyright (c) 2006 Andreas Kupries '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" @@ -7,22 +7,21 @@ .TH refchan n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS .\" Note: do not modify the .SH NAME line immediately below! .SH NAME -refchan \- command handler API of reflected channels +refchan \- Command handler API of reflected channels, version 1 .SH SYNOPSIS \fBcmdPrefix \fIoption\fR ?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP The Tcl-level handler for a reflected channel has to be a command with subcommands (termed an \fIensemble\fR, as it is a command such as that -created by \fBnamespace ensemble\fR \fBcreate\fR, though the implementation +created by \fBnamespace ensemble create\fR, though the implementation of handlers for reflected channel \fIis not\fR tied to \fBnamespace -ensemble\fRs in any way; see \fBEXAMPLE\fR below for how to build an -\fBoo::class\fR that supports the API). Note that \fIcmdPrefix\fR is whatever was +ensemble\fRs in any way). Note that \fIcmdPrefix\fR is whatever was specified in the call to \fBchan create\fR, and may consist of multiple arguments; this will be expanded to multiple words in place of the prefix. .PP Of all the possible subcommands, the handler \fImust\fR support @@ -44,11 +43,11 @@ this command handler. .PP Any error thrown by the method will abort the creation of the channel and no channel will be created. The thrown error will appear as error thrown by \fBchan create\fR. Any exception other than an \fBerror\fR -(e.g.,\ \fBbreak\fR, etc.) is treated as (and converted to) an error. +(e.g. \fBbreak\fR, etc.) is treated as (and converted to) an error. .PP \fBNote:\fR If the creation of the channel was aborted due to failures here, then the \fBfinalize\fR subcommand will not be called. .PP The \fImode\fR argument tells the handler whether the channel was @@ -72,12 +71,12 @@ .RS .PP The return value of this subcommand is ignored. .PP If the subcommand throws an error the command which caused its -invocation (usually \fBchan close\fR) will appear to have thrown this -error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR, etc.) is +invocation (usually \fBclose\fR) will appear to have thrown this +error. Any exception beyond \fIerror\fR (e.g. \fIbreak\fR, etc.) is treated as (and converted to) an error. .PP This subcommand is not invoked if the creation of the channel was aborted during \fBinitialize\fR (See above). .RE @@ -91,11 +90,11 @@ channel does not wish to be notified of any events. In that situation, the handler should disable event generation completely. .RS .PP \fBWarning:\fR Any return value of the subcommand is ignored. This -includes all errors thrown by the subcommand, \fBbreak\fR, \fBcontinue\fR, and +includes all errors thrown by the subcommand, break, continue, and custom return codes. .PP This subcommand interacts with \fBchan postevent\fR. Trying to post an event which was not listed in the last call to \fBwatch\fR will cause \fBchan postevent\fR to throw an error. @@ -103,11 +102,11 @@ .SS "OPTIONAL SUBCOMMANDS" .TP \fIcmdPrefix \fBread \fIchannelId count\fR . This \fIoptional\fR subcommand is called when the user requests data from the -channel \fIchannelId\fR. \fIcount\fR specifies how many \fIbytes\fR have been +channel \fIchannelId\fR. \fIcount\fR specifies how many \fBbytes\fR have been requested. If the subcommand is not supported then it is not possible to read from the channel handled by the command. .RS .PP The return value of this subcommand is taken as the requested data @@ -129,35 +128,28 @@ error EAGAIN .CE .PP For extensibility any error whose value is a negative integer number will cause the higher layers to set the C-level variable "\fBerrno\fR" -to the absolute value of this number, signaling a system error. -However, note that the exact mapping between these error numbers and -their meanings is operating system dependent. -.PP -For example, while on Linux both +to the absolute value of this number, signaling a system error. This +means that both .PP .CS return -code error -11 .CE and .CS error -11 .CE .PP -are equivalent to the examples above, using the more readable string "EAGAIN", -this is not true for BSD, where the equivalent number is -35. -.PP -The symbolic string however is the same across systems, and internally -translated to the correct number. No other error value has such a mapping -to a symbolic string. +are equivalent to the examples above, using the more readable string "EAGAIN". +No other error value has such a mapping to a symbolic string. .PP If the subcommand throws any other error, the command which caused its invocation (usually \fBgets\fR, or \fBread\fR) will appear to have -thrown this error. Any exception beyond \fBerror\fR, (e.g.,\ \fBbreak\fR, -etc.) is treated as and converted to an error. +thrown this error. Any exception beyond \fIerror\fR, (e.g. +\fIbreak\fR, etc.) is treated as and converted to an error. .RE .TP \fIcmdPrefix \fBwrite \fIchannelId data\fR . This \fIoptional\fR subcommand is called when the user writes data to @@ -209,24 +201,22 @@ translated to the correct number. No other error value has such a mapping to a symbolic string. .PP If the subcommand throws any other error the command which caused its invocation (usually \fBputs\fR) will appear to have thrown this error. -Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR, etc.) is treated +Any exception beyond \fIerror\fR (e.g.\ \fIbreak\fR, etc.) is treated as and converted to an error. .RE .TP \fIcmdPrefix \fBseek \fIchannelId offset base\fR . This \fIoptional\fR subcommand is responsible for the handling of -\fBchan seek\fR and \fBchan tell\fR requests on the channel -\fIchannelId\fR. If it is not supported then seeking will not be possible for -the channel. +\fBseek\fR and \fBtell\fR requests on the channel \fIchannelId\fR. If it is not +supported then seeking will not be possible for the channel. .RS .PP -The \fIbase\fR argument is the same as the equivalent argument of the -builtin \fBchan seek\fR, namely: +The \fIbase\fR argument is one of .TP 10 \fBstart\fR . Seeking is relative to the beginning of the channel. .TP 10 @@ -235,27 +225,32 @@ Seeking is relative to the current seek position. .TP 10 \fBend\fR . Seeking is relative to the end of the channel. +.PP +The \fIbase\fR argument of the builtin \fBchan seek\fR command takes +the same names. .PP The \fIoffset\fR is an integer number specifying the amount of \fBbytes\fR to seek forward or backward. A positive number should seek forward, and a negative number should seek backward. +.PP A channel may provide only limited seeking. For example sockets can seek forward, but not backward. .PP The return value of the subcommand is taken as the (new) location of the channel, counted from the start. This has to be an integer number greater than or equal to zero. +.PP If the subcommand throws an error the command which caused its -invocation (usually \fBchan seek\fR, or \fBchan tell\fR) will appear to have -thrown this error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR, +invocation (usually \fBseek\fR, or \fBtell\fR) will appear to have +thrown this error. Any exception beyond \fIerror\fR (e.g. \fIbreak\fR, etc.) is treated as and converted to an error. .PP -The offset/base combination of 0/\fBcurrent\fR signals a \fBchan tell\fR -request, i.e.,\ seek nothing relative to the current location, making +The offset/base combination of 0/\fBcurrent\fR signals a \fBtell\fR +request, i.e. seek nothing relative to the current location, making the new location identical to the current one, which is then returned. .RE .TP \fIcmdPrefix \fBconfigure \fIchannelId option value\fR . @@ -268,13 +263,13 @@ time; that is behavior implemented in the Tcl channel core. .PP The return value of the subcommand is ignored. .PP If the subcommand throws an error the command which performed the -(re)configuration or query (usually \fBfconfigure\fR or -\fBchan configure\fR) will appear to have thrown this error. Any exception -beyond \fBerror\fR (e.g.,\ \fBbreak\fR, etc.) is treated as and +(re)configuration or query (usually \fBfconfigure\fR or \fBchan +configure\fR) will appear to have thrown this error. Any exception +beyond \fIerror\fR (e.g. \fIbreak\fR, etc.) is treated as and converted to an error. .RE .TP \fIcmdPrefix \fBcget \fIchannelId option\fR . @@ -284,13 +279,13 @@ .RS .PP The subcommand should return the value of the specified \fIoption\fR. .PP If the subcommand throws an error, the command which performed the -(re)configuration or query (usually \fBfconfigure\fR or \fBchan configure\fR) -will appear to have thrown this error. Any exception beyond \fIerror\fR -(e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error. +(re)configuration or query (usually \fBfconfigure\fR) will appear to +have thrown this error. Any exception beyond \fIerror\fR (e.g. +\fIbreak\fR, etc.) is treated as and converted to an error. .RE .TP \fIcmdPrefix \fBcgetall \fIchannelId\fR . This \fIoptional\fR subcommand is used for reading all type-specific options @@ -300,13 +295,13 @@ .PP The subcommand should return a list of all options and their values. This list must have an even number of elements. .PP If the subcommand throws an error the command which performed the -(re)configuration or query (usually \fBfconfigure\fR or \fBchan configure\fR) -will appear to have thrown this error. Any exception beyond \fBerror\fR -(e.g.,\ \fBbreak\fR, etc.) is treated as and converted to an error. +(re)configuration or query (usually \fBfconfigure\fR) will appear to +have thrown this error. Any exception beyond \fIerror\fR (e.g. +\fIbreak\fR, etc.) is treated as and converted to an error. .RE .TP \fIcmdPrefix \fBblocking \fIchannelId mode\fR . This \fIoptional\fR subcommand handles changes to the blocking mode of the @@ -316,96 +311,30 @@ .RS .PP The return value of the subcommand is ignored. .PP If the subcommand throws an error the command which caused its -invocation (usually \fBfconfigure\fR or \fBchan configure\fR) will appear to -have thrown this error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR, -etc.) is treated as and converted to an error. +invocation (usually \fBfconfigure\fR) will appear to have thrown this +error. Any exception beyond \fIerror\fR (e.g. \fIbreak\fR, etc.) is +treated as and converted to an error. .RE .SH NOTES Some of the functions supported in channels defined in Tcl's C interface are not available to channels reflected to the Tcl level. .PP -The function \fBTcl_DriverGetHandleProc\fR is not supported; -i.e.,\ reflected channels do not have OS specific handles. +The function \fBTcl_DriverGetHandleProc\fR is not supported; i.e. +reflected channels do not have OS specific handles. .PP The function \fBTcl_DriverHandlerProc\fR is not supported. This driver -function is relevant only for stacked channels, i.e.,\ transformations. +function is relevant only for stacked channels, i.e. transformations. Reflected channels are always base channels, not transformations. .PP The function \fBTcl_DriverFlushProc\fR is not supported. This is because the current generic I/O layer of Tcl does not use this function anywhere at all. Therefore support at the Tcl level makes no sense either. This may be altered in the future (through extending the API defined here and changing its version number) should the function be used at some time in the future. -.SH EXAMPLE -.PP -This demonstrates how to make a channel that reads from a string. -.PP -.CS -oo::class create stringchan { - variable data pos - constructor {string {encoding {}}} { - if {$encoding eq ""} {set encoding [encoding system]} - set data [encoding convertto $encoding $string] - set pos 0 - } - - method \fBinitialize\fR {ch mode} { - return "initialize finalize watch read seek" - } - method \fBfinalize\fR {ch} { - my destroy - } - method \fBwatch\fR {ch events} { - # Must be present but we ignore it because we do not - # post any events - } - - # Must be present on a readable channel - method \fBread\fR {ch count} { - set d [string range $data $pos [expr {$pos+$count-1}]] - incr pos [string length $d] - return $d - } - - # This method is optional, but useful for the example below - method \fBseek\fR {ch offset base} { - switch $base { - start { - set pos $offset - } - current { - incr pos $offset - } - end { - set pos [string length $data] - incr pos $offset - } - } - if {$pos < 0} { - set pos 0 - } elseif {$pos > [string length $data]} { - set pos [string length $data] - } - return $pos - } -} - -# Now we create an instance... -set string "The quick brown fox jumps over the lazy dog.\\n" -set ch [\fBchan create\fR read [stringchan new $string]] - -puts [gets $ch]; # Prints the whole string - -seek $ch -5 end; -puts [read $ch]; # Prints just the last word -.CE .SH "SEE ALSO" -chan(n), transchan(n) +chan(n) .SH KEYWORDS -API, channel, ensemble, prefix, reflection -'\" Local Variables: -'\" mode: nroff -'\" End: +channel, reflection Index: doc/regexp.n ================================================================== --- doc/regexp.n +++ doc/regexp.n @@ -1,28 +1,30 @@ '\" '\" Copyright (c) 1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH regexp n 8.3 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME regexp \- Match a regular expression against a string + .SH SYNOPSIS \fBregexp \fR?\fIswitches\fR? \fIexp string \fR?\fImatchVar\fR? ?\fIsubMatchVar subMatchVar ...\fR? .BE + .SH DESCRIPTION .PP Determines whether the regular expression \fIexp\fR matches part or all of \fIstring\fR and returns 1 if it does, 0 if it does not, unless \fB\-inline\fR is specified (see below). (Regular expression matching is described in the \fBre_syntax\fR reference page.) -.PP +.LP If additional arguments are specified after \fIstring\fR then they are treated as the names of variables in which to return information about which part(s) of \fIstring\fR matched \fIexp\fR. \fIMatchVar\fR will be set to the range of \fIstring\fR that matched all of \fIexp\fR. The first \fIsubMatchVar\fR will contain @@ -34,34 +36,30 @@ If the initial arguments to \fBregexp\fR start with \fB\-\fR then they are treated as switches. The following switches are currently supported: .TP 15 \fB\-about\fR -. Instead of attempting to match the regular expression, returns a list containing information about the regular expression. The first element of the list is a subexpression count. The second element is a list of property names that describe various attributes of the regular expression. This switch is primarily intended for debugging purposes. .TP 15 \fB\-expanded\fR -. Enables use of the expanded regular expression syntax where whitespace and comments are ignored. This is the same as specifying the \fB(?x)\fR embedded option (see the \fBre_syntax\fR manual page). .TP 15 \fB\-indices\fR -. -Changes what is stored in the \fImatchVar\fR and \fIsubMatchVar\fRs. +Changes what is stored in the \fIsubMatchVar\fRs. Instead of storing the matching characters from \fIstring\fR, each variable will contain a list of two decimal strings giving the indices in \fIstring\fR of the first and last characters in the matching range of characters. .TP 15 \fB\-line\fR -. Enables newline-sensitive matching. By default, newline is a completely ordinary character with no special meaning. With this flag, .QW [^ bracket expressions and @@ -75,21 +73,19 @@ addition to its normal function. This flag is equivalent to specifying both \fB\-linestop\fR and \fB\-lineanchor\fR, or the \fB(?n)\fR embedded option (see the \fBre_syntax\fR manual page). .TP 15 \fB\-linestop\fR -. Changes the behavior of .QW [^ bracket expressions and .QW . so that they stop at newlines. This is the same as specifying the \fB(?p)\fR embedded option (see the \fBre_syntax\fR manual page). .TP 15 \fB\-lineanchor\fR -. Changes the behavior of .QW ^ and .QW $ (the @@ -98,56 +94,50 @@ beginning and end of a line respectively. This is the same as specifying the \fB(?w)\fR embedded option (see the \fBre_syntax\fR manual page). .TP 15 \fB\-nocase\fR -. Causes upper-case characters in \fIstring\fR to be treated as lower case during the matching process. .TP 15 \fB\-all\fR -. Causes the regular expression to be matched as many times as possible in the string, returning the total number of matches found. If this is specified with match variables, they will contain information for the last match only. .TP 15 \fB\-inline\fR -. Causes the command to return, as a list, the data that would otherwise be placed in match variables. When using \fB\-inline\fR, match variables may not be specified. If used with \fB\-all\fR, the list will be concatenated at each iteration, such that a flat list is always returned. For each match iteration, the command will append the overall match data, plus one element for each subexpression in the regular expression. Examples are: -.RS -.PP .CS \fBregexp\fR -inline -- {\ew(\ew)} " inlined " \fI\(-> in n\fR \fBregexp\fR -all -inline -- {\ew(\ew)} " inlined " \fI\(-> in n li i ne e\fR .CE -.RE .TP 15 \fB\-start\fR \fIindex\fR -. Specifies a character index offset into the string to start -matching the regular expression at. +matching the regular expression at. +.VS 8.5 The \fIindex\fR value is interpreted in the same manner as the \fIindex\fR argument to \fBstring index\fR. +.VE 8.5 When using this switch, .QW ^ will not match the beginning of the line, and \eA will still match the start of the string at \fIindex\fR. If \fB\-indices\fR is specified, the indices will be indexed starting from the absolute beginning of the input string. \fIindex\fR will be constrained to the bounds of the input string. .TP 15 \fB\-\|\-\fR -. Marks the end of switches. The argument following this one will be treated as \fIexp\fR even if it starts with a \fB\-\fR. .PP If there are more \fIsubMatchVar\fRs than parenthesized subexpressions within \fIexp\fR, or if a particular subexpression @@ -159,50 +149,43 @@ .SH EXAMPLES .PP Find the first occurrence of a word starting with \fBfoo\fR in a string that is not actually an instance of \fBfoobar\fR, and get the letters following it up to the end of the word into a variable: -.PP .CS \fBregexp\fR {\emfoo(?!bar\eM)(\ew*)} $string \-> restOfWord .CE -.PP Note that the whole matched substring has been placed in the variable .QW \fB\->\fR , which is a name chosen to look nice given that we are not actually interested in its contents. .PP Find the index of the word \fBbadger\fR (in any case) within a string and store that in the variable \fBlocation\fR: -.PP .CS \fBregexp\fR \-indices {(?i)\embadger\eM} $string location .CE -.PP This could also be written as a \fIbasic\fR regular expression (as opposed to using the default syntax of \fIadvanced\fR regular expressions) match by prefixing the expression with a suitable flag: -.PP .CS \fBregexp\fR \-indices {(?ib)\e} $string location .CE .PP This counts the number of octal digits in a string: -.PP .CS \fBregexp\fR \-all {[0\-7]} $string .CE .PP This lists all words (consisting of all sequences of non-whitespace characters) in a string, and is useful as a more powerful version of the \fBsplit\fR command: -.PP .CS \fBregexp\fR \-all \-inline {\eS+} $string .CE .SH "SEE ALSO" -re_syntax(n), regsub(n), string(n) +re_syntax(n), regsub(n), +.VS 8.5 +string(n) +.VE .SH KEYWORDS match, parsing, pattern, regular expression, splitting, string -'\" Local Variables: -'\" mode: nroff -'\" End: Index: doc/registry.n ================================================================== --- doc/registry.n +++ doc/registry.n @@ -11,13 +11,13 @@ '\" Note: do not modify the .SH NAME line immediately below! .SH NAME registry \- Manipulate the Windows registry .SH SYNOPSIS .sp -\fBpackage require registry 1.3\fR +\fBpackage require registry 1.1\fR .sp -\fBregistry \fR?\fI\-mode\fR? \fIoption\fR \fIkeyName\fR ?\fIarg arg ...\fR? +\fBregistry \fIoption\fR \fIkeyName\fR ?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP The \fBregistry\fR package provides a general set of operations for manipulating the Windows registry. The package implements the @@ -42,16 +42,10 @@ \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? @@ -99,11 +93,11 @@ \fBregistry keys \fIkeyName\fR ?\fIpattern\fR? . If \fIpattern\fR is not specified, returns a list of names of all the subkeys of \fIkeyName\fR. If \fIpattern\fR is specified, only those names matching \fIpattern\fR are returned. Matching is determined -using the same rules as for \fBstring match\fR. If the +using the same rules as for \fBstring\fR \fBmatch\fR. If the specified \fIkeyName\fR does not exist, then an error is generated. .TP \fBregistry set \fIkeyName\fR ?\fIvalueName data \fR?\fItype\fR?? . If \fIvalueName\fR is not specified, creates the key \fIkeyName\fR if @@ -123,11 +117,11 @@ \fBregistry values \fIkeyName\fR ?\fIpattern\fR? . If \fIpattern\fR is not specified, returns a list of names of all the values of \fIkeyName\fR. If \fIpattern\fR is specified, only those names matching \fIpattern\fR are returned. Matching is determined -using the same rules as for \fBstring match\fR. +using the same rules as for \fBstring\fR \fBmatch\fR. .SH "SUPPORTED TYPES" Each value under a key in the registry contains some data of a particular type in a type-specific representation. The \fBregistry\fR command converts between this internal representation and one that can be manipulated by Tcl scripts. In most cases, the data is simply @@ -148,11 +142,11 @@ type. The data is represented exactly in Tcl, including any embedded nulls. .TP \fBsz\fR . -The registry value contains a null-terminated string. The data is +The registry value contains a null-terminated string. The data is represented in Tcl as a string. .TP \fBexpand_sz\fR . The registry value contains a null-terminated string that contains @@ -209,8 +203,5 @@ puts "$ext opens with $command" .CE .SH KEYWORDS registry -'\" Local Variables: -'\" mode: nroff -'\" End: Index: doc/regsub.n ================================================================== --- doc/regsub.n +++ doc/regsub.n @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 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 regsub n 8.3 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -52,13 +52,12 @@ backslashes. .LP If the initial arguments to \fBregsub\fR start with \fB\-\fR then they are treated as switches. The following switches are currently supported: -.TP +.TP 10 \fB\-all\fR -. All ranges in \fIstring\fR that match \fIexp\fR are found and substitution is performed for each of these ranges. Without this switch only the first matching range is found and substituted. If \fB\-all\fR is specified, then @@ -65,46 +64,17 @@ .QW & and .QW \e\fIn\fR sequences are handled for each substitution using the information from the corresponding match. -.TP -\fB\-command\fR -.VS 8.7 -Changes the handling of \fIsubSpec\fR so that it is not treated -as a template for a substitution string and the substrings -.QW & -and -.QW \e\fIn\fR -no longer have special meaning. Instead \fIsubSpec\fR must be a -command prefix, that is, a non-empty list. The substring of \fIstring\fR -that matches \fIexp\fR, and then each substring that matches each -capturing sub-RE within \fIexp\fR are appended as additional elements -to that list. (The items appended to the list are much like what -\fBregexp\fR \fB-inline\fR would return). The completed list is then -evaluated as a Tcl command, and the result of that command is the -substitution string. Any error or exception from command evaluation -becomes an error or exception from the \fBregsub\fR command. -.RS -.PP -If \fB\-all\fR is not also given, the command callback will be invoked at most -once (exactly when the regular expression matches). If \fB\-all\fR is given, -the command callback will be invoked for each matched location, in sequence. -The exact location indices that matched are not made available to the script. -.PP -See \fBEXAMPLES\fR below for illustrative cases. -.RE -.VE 8.7 -.TP +.TP 15 \fB\-expanded\fR -. Enables use of the expanded regular expression syntax where whitespace and comments are ignored. This is the same as specifying the \fB(?x)\fR embedded option (see the \fBre_syntax\fR manual page). -.TP +.TP 15 \fB\-line\fR -. Enables newline-sensitive matching. By default, newline is a completely ordinary character with no special meaning. With this flag, .QW [^ bracket expressions and .QW . @@ -115,23 +85,21 @@ .QW $ matches an empty string before any newline in addition to its normal function. This flag is equivalent to specifying both \fB\-linestop\fR and \fB\-lineanchor\fR, or the \fB(?n)\fR embedded option (see the \fBre_syntax\fR manual page). -.TP +.TP 15 \fB\-linestop\fR -. Changes the behavior of .QW [^ bracket expressions and .QW . so that they stop at newlines. This is the same as specifying the \fB(?p)\fR embedded option (see the \fBre_syntax\fR manual page). -.TP +.TP 15 \fB\-lineanchor\fR -. Changes the behavior of .QW ^ and .QW $ (the @@ -138,31 +106,30 @@ .QW anchors ) so they match the beginning and end of a line respectively. This is the same as specifying the \fB(?w)\fR embedded option (see the \fBre_syntax\fR manual page). -.TP +.TP 10 \fB\-nocase\fR -. Upper-case characters in \fIstring\fR will be converted to lower-case before matching against \fIexp\fR; however, substitutions specified by \fIsubSpec\fR use the original unconverted form of \fIstring\fR. -.TP +.TP 10 \fB\-start\fR \fIindex\fR -. Specifies a character index offset into the string to start -matching the regular expression at. +matching the regular expression at. +.VS 8.5 The \fIindex\fR value is interpreted in the same manner as the \fIindex\fR argument to \fBstring index\fR. +.VE 8.5 When using this switch, .QW ^ will not match the beginning of the line, and \eA will still match the start of the string at \fIindex\fR. \fIindex\fR will be constrained to the bounds of the input string. -.TP +.TP 10 \fB\-\|\-\fR -. Marks the end of switches. The argument following this one will be treated as \fIexp\fR even if it starts with a \fB\-\fR. .PP If \fIvarName\fR is supplied, the command returns a count of the number of matching ranges that were found and replaced, otherwise the @@ -171,33 +138,28 @@ of regular expressions. .SH EXAMPLES .PP Replace (in the string in variable \fIstring\fR) every instance of \fBfoo\fR which is a word by itself with \fBbar\fR: -.PP .CS \fBregsub\fR -all {\emfoo\eM} $string bar string .CE -.PP or (using the .QW "basic regular expression" syntax): -.PP .CS \fBregsub\fR -all {(?b)\e} $string bar string .CE .PP Insert double-quotes around the first instance of the word \fBinteresting\fR, however it is capitalized. -.PP .CS \fBregsub\fR -nocase {\eyinteresting\ey} $string {"&"} string .CE .PP Convert all non-ASCII and Tcl-significant characters into \eu escape sequences by using \fBregsub\fR and \fBsubst\fR in combination: -.PP .CS # This RE is just a character class for almost everything "bad" set RE {[][{};#\e\e\e$ \er\et\eu0080-\euffff]} # We will substitute with a fragment of Tcl script in brackets @@ -208,59 +170,12 @@ # that newline is handled specially through \fBstring map\fR since # backslash-newline is a special sequence. set quoted [subst [string map {\en {\e\eu000a}} \e [\fBregsub\fR -all $RE $string $substitution]]] .CE -.PP -.VS 8.7 -The above operation can be done using \fBregsub \-command\fR instead, which is -often faster. (A full pre-computed \fBstring map\fR would be faster still, but -the cost of computing the map for a transformation as complex as this can be -quite large.) -.PP -.CS -# This RE is just a character class for everything "bad" -set RE {[][{};#\e\e\e$\es\eu0080-\euffff]} - -# This encodes what the RE described above matches -proc encodeChar {ch} { - # newline is handled specially since backslash-newline is a - # special sequence. - if {$ch eq "\en"} { - return "\e\eu000a" - } - # No point in writing this as a one-liner - scan $ch %c charNumber - format "\e\eu%04x" $charNumber -} - -set quoted [\fBregsub\fR -all -command $RE $string encodeChar] -.CE -.PP -Decoding a URL-encoded string using \fBregsub \-command\fR, a lambda term and -the \fBapply\fR command. -.PP -.CS -# Match one of the sequences in a URL-encoded string that needs -# fixing, converting + to space and %XX to the right character -# (e.g., %7e becomes ~) -set RE {(\e+)|%([0-9A-Fa-f]{2})} - -# Note that -command uses a command prefix, not a command name -set decoded [\fBregsub\fR -all -command $RE $string {apply {{- p h} { - # + is a special case; handle directly - if {$p eq "+"} { - return " " - } - # convert hex to a char - scan $h %x charNumber - format %c $charNumber -}}}] -.CE -.VE 8.7 .SH "SEE ALSO" -regexp(n), re_syntax(n), subst(n), string(n) +regexp(n), re_syntax(n), subst(n), +.VS 8.5 +string(n) +.VE .SH KEYWORDS -match, pattern, quoting, regular expression, substitution -'\" Local Variables: -'\" mode: nroff -'\" End: +match, pattern, quoting, regular expression, substitute Index: doc/rename.n ================================================================== --- doc/rename.n +++ doc/rename.n @@ -2,20 +2,21 @@ '\" 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 rename n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME rename \- Rename or delete a command .SH SYNOPSIS \fBrename \fIoldName newName\fR .BE + .SH DESCRIPTION .PP Rename the command that used to be called \fIoldName\fR so that it is now called \fInewName\fR. If \fInewName\fR is an empty string then \fIoldName\fR is deleted. @@ -23,27 +24,23 @@ (names of containing namespaces). If a command is renamed into a different namespace, future invocations of it will execute in the new namespace. The \fBrename\fR command returns an empty string as result. .SH EXAMPLE -.PP The \fBrename\fR command can be used to wrap the standard Tcl commands with your own monitoring machinery. For example, you might wish to count how often the \fBsource\fR command is called: -.PP .CS \fBrename\fR ::source ::theRealSource set sourceCount 0 proc ::source args { global sourceCount puts "called source for the [incr sourceCount]'th time" uplevel 1 ::theRealSource $args } .CE + .SH "SEE ALSO" namespace(n), proc(n) + .SH KEYWORDS command, delete, namespace, rename -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/return.n ================================================================== --- doc/return.n +++ doc/return.n @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Contributions from Don Porter, NIST, 2003. (not subject to US copyright) '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH return n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -22,11 +22,11 @@ .SH DESCRIPTION .PP In its simplest usage, the \fBreturn\fR command is used without options in the body of a procedure to immediately return control to the caller of the procedure. If a \fIresult\fR argument is provided, its value -becomes the result of the procedure passed back to the caller. +becomes the result of the procedure passed back to the caller. If \fIresult\fR is not specified then an empty string will be returned to the caller as the result of the procedure. .PP The \fBreturn\fR command serves a similar function within script files that are evaluated by the \fBsource\fR command. When \fBsource\fR @@ -43,42 +43,36 @@ specified the procedure will return normally. However, the \fB\-code\fR option may be used to generate an exceptional return from the procedure. \fICode\fR may have any of the following values: .TP 13 -\fBok\fR (or \fB0\fR) -. +\fBok (or 0)\fR Normal return: same as if the option is omitted. The return code of the procedure is 0 (\fBTCL_OK\fR). .TP 13 -\fBerror\fR (or \fB1\fR) -. +\fBerror (1)\fR Error return: the return code of the procedure is 1 (\fBTCL_ERROR\fR). The procedure command behaves in its calling context as if it -were the command \fBerror\fR \fIresult\fR. See below for additional +were the command \fBerror \fIresult\fR. See below for additional options. .TP 13 -\fBreturn\fR (or \fB2\fR) -. +\fBreturn (2)\fR The return code of the procedure is 2 (\fBTCL_RETURN\fR). The procedure command behaves in its calling context as if it were the command \fBreturn\fR (with no arguments). .TP 13 -\fBbreak\fR (or \fB3\fR) -. +\fBbreak (3)\fR The return code of the procedure is 3 (\fBTCL_BREAK\fR). The procedure command behaves in its calling context as if it were the command \fBbreak\fR. .TP 13 -\fBcontinue\fR (or \fB4\fR) -. +\fBcontinue (4)\fR The return code of the procedure is 4 (\fBTCL_CONTINUE\fR). The procedure command behaves in its calling context as if it were the command \fBcontinue\fR. .TP 13 \fIvalue\fR -. \fIValue\fR must be an integer; it will be returned as the return code for the current procedure. .LP When a procedure wants to signal that it has received invalid arguments from its caller, it may use \fBreturn -code error\fR @@ -91,42 +85,42 @@ evaluation of the contents of a file as a script by \fBsource\fR, an invocation of the \fBreturn \-code \fIcode\fR command will cause the return code of \fBsource\fR to be \fIcode\fR. .SH "RETURN OPTIONS" .PP +.VS 8.5 In addition to a result and a return code, evaluation of a command in Tcl also produces a dictionary of return options. In general usage, all \fIoption value\fR pairs given as arguments to \fBreturn\fR become entries in the return options dictionary, and any values at all are acceptable except as noted below. The \fBcatch\fR command may be used to capture all of this information \(em the return code, the result, and the return options dictionary \(em that arise from evaluation of a script. +.VE 8.5 .PP As documented above, the \fB\-code\fR entry in the return options dictionary receives special treatment by Tcl. There are other return options also recognized and treated specially by Tcl. They are: .TP \fB\-errorcode \fIlist\fR -. The \fB\-errorcode\fR option receives special treatment only when the value of the \fB\-code\fR option is \fBTCL_ERROR\fR. Then the \fIlist\fR value is meant to be additional information about the error, presented as a Tcl list for further processing by programs. If no \fB\-errorcode\fR option is provided to \fBreturn\fR when the \fB\-code error\fR option is provided, Tcl will set the value -of the \fB\-errorcode\fR entry in the return options dictionary +of the \fB\-errorcode\fR entry in the return options dictionary to the default value of \fBNONE\fR. The \fB\-errorcode\fR return option will also be stored in the global variable \fBerrorCode\fR. .TP \fB\-errorinfo \fIinfo\fR -. The \fB\-errorinfo\fR option receives special treatment only when the value of the \fB\-code\fR option is \fBTCL_ERROR\fR. Then \fIinfo\fR is the initial stack trace, meant to provide to a human reader additional information about the context in which the error occurred. The stack trace will -also be stored in the global variable \fBerrorInfo\fR. +also be stored in the global variable \fBerrorInfo\fR. If no \fB\-errorinfo\fR option is provided to \fBreturn\fR when the \fB\-code error\fR option is provided, Tcl will provide its own initial stack trace value in the entry for \fB\-errorinfo\fR. Tcl's initial stack trace will include only the call to the procedure, and stack unwinding will append information about higher stack levels, but @@ -134,43 +128,29 @@ 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 -. +.VS 8.5 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 at which the return code of a command currently being evaluated should be \fIcode\fR. If no \fB\-level\fR option is provided, the default value of \fIlevel\fR is 1, so that \fBreturn\fR sets the return code that the current procedure returns to its caller, 1 level up the call stack. The mechanism by which these options work is described in more detail below. +.VE 8.5 .TP \fB\-options \fIoptions\fR -. +.VS 8.5 The value \fIoptions\fR must be a valid dictionary. The entries of that dictionary are treated as additional \fIoption value\fR pairs for the \fBreturn\fR command. +.VE 8.5 .SH "RETURN CODE HANDLING MECHANISMS" .PP Return codes are used in Tcl to control program flow. A Tcl script is a sequence of Tcl commands. So long as each command evaluation returns a return code of \fBTCL_OK\fR, evaluation will continue to the next @@ -192,13 +172,14 @@ loop. If evaluation of the loop body returns the return code of \fBTCL_BREAK\fR or \fBTCL_CONTINUE\fR, the loop command can react in such a way as to give the \fBbreak\fR and \fBcontinue\fR commands their documented interpretation in loops. .PP +.VS 8.5 Procedure invocation also involves evaluation of a script, the body of the procedure. Procedure invocation provides special treatment -when evaluation of the procedure body returns the return code +when evaluation of the procedure body returns the return code \fBTCL_RETURN\fR. In that circumstance, the \fB\-level\fR entry in the return options dictionary is decremented. If after decrementing, the value of the \fB\-level\fR entry is 0, then the value of the \fB\-code\fR entry becomes the return code of the procedure. If after decrementing, the value of the \fB\-level\fR entry is @@ -219,106 +200,97 @@ of the \fBreturn\fR command itself will be the value \fIcode\fR of the \fB\-code\fR option (or \fBTCL_OK\fR by default). Any other value for the \fB\-level\fR option (including the default value of 1) will cause the return code of the \fBreturn\fR command itself to be \fBTCL_RETURN\fR, triggering a return from the enclosing procedure. +.VE 8.5 .SH EXAMPLES -.PP First, a simple example of using \fBreturn\fR to return from a procedure, interrupting the procedure body. -.PP .CS proc printOneLine {} { - puts "line 1" ;# This line will be printed. - \fBreturn\fR - puts "line 2" ;# This line will not be printed. + puts "line 1" ;# This line will be printed. + \fBreturn\fR + puts "line 2" ;# This line will not be printed. } .CE .PP Next, an example of using \fBreturn\fR to set the value returned by the procedure. -.PP .CS proc returnX {} {\fBreturn\fR X} puts [returnX] ;# prints "X" .CE .PP Next, a more complete example, using \fBreturn -code error\fR to report invalid arguments. -.PP .CS proc factorial {n} { - if {![string is integer $n] || ($n < 0)} { - \fBreturn\fR -code error \e - "expected non-negative integer,\e - but got \e"$n\e"" - } - if {$n < 2} { - \fBreturn\fR 1 - } - set m [expr {$n - 1}] - set code [catch {factorial $m} factor] - if {$code != 0} { - \fBreturn\fR -code $code $factor - } - set product [expr {$n * $factor}] - if {$product < 0} { - \fBreturn\fR -code error \e - "overflow computing factorial of $n" - } - \fBreturn\fR $product + if {![string is integer $n] || ($n < 0)} { + \fBreturn\fR -code error \e + "expected non-negative integer,\e + but got \e"$n\e"" + } + if {$n < 2} { + \fBreturn\fR 1 + } + set m [expr {$n - 1}] + set code [catch {factorial $m} factor] + if {$code != 0} { + \fBreturn\fR -code $code $factor + } + set product [expr {$n * $factor}] + if {$product < 0} { + \fBreturn\fR -code error \e + "overflow computing factorial of $n" + } + \fBreturn\fR $product } .CE .PP Next, a procedure replacement for \fBbreak\fR. -.PP .CS proc myBreak {} { - \fBreturn\fR -code break + \fBreturn\fR -code break } .CE .PP +.VS 8.5 With the \fB\-level 0\fR option, \fBreturn\fR itself can serve -as a replacement for \fBbreak\fR, with the help of \fBinterp alias\fR. -.PP +as a replacement for \fBbreak\fR. .CS interp alias {} Break {} \fBreturn\fR -level 0 -code break .CE .PP An example of using \fBcatch\fR and \fBreturn -options\fR to re-raise a caught error: -.PP .CS proc doSomething {} { - set resource [allocate] - catch { - # Long script of operations - # that might raise an error - } result options - deallocate $resource - \fBreturn\fR -options $options $result + set resource [allocate] + catch { + # Long script of operations + # that might raise an error + } result options + deallocate $resource + \fBreturn\fR -options $options $result } .CE .PP Finally an example of advanced use of the \fBreturn\fR options to create a procedure replacement for \fBreturn\fR itself: -.PP .CS proc myReturn {args} { - set result "" - if {[llength $args] % 2} { - set result [lindex $args end] - set args [lrange $args 0 end-1] - } - set options [dict merge {-level 1} $args] - dict incr options -level - \fBreturn\fR -options $options $result + set result "" + if {[llength $args] % 2} { + set result [lindex $args end] + set args [lrange $args 0 end-1] + } + set options [dict merge {-level 1} $args] + dict incr options -level + \fBreturn\fR -options $options $result } .CE +.VE 8.5 .SH "SEE ALSO" -break(n), catch(n), continue(n), dict(n), error(n), errorCode(n), -errorInfo(n), proc(n), source(n), throw(n), try(n) +break(n), catch(n), continue(n), dict(n), error(n), proc(n), source(n), tclvars(n) .SH KEYWORDS -break, catch, continue, error, exception, procedure, result, return -.\" Local Variables: -.\" mode: nroff -.\" End: +break, catch, continue, error, procedure, return Index: doc/safe.n ================================================================== --- doc/safe.n +++ doc/safe.n @@ -1,29 +1,29 @@ '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH "Safe Tcl" n 8.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -safe \- Creating and manipulating safe interpreters +Safe\ Base \- A mechanism for creating and manipulating safe interpreters .SH SYNOPSIS -\fB::safe::interpCreate\fR ?\fIchild\fR? ?\fIoptions...\fR? -.sp -\fB::safe::interpInit\fR \fIchild\fR ?\fIoptions...\fR? -.sp -\fB::safe::interpConfigure\fR \fIchild\fR ?\fIoptions...\fR? -.sp -\fB::safe::interpDelete\fR \fIchild\fR -.sp -\fB::safe::interpAddToAccessPath\fR \fIchild\fR \fIdirectory\fR -.sp -\fB::safe::interpFindInAccessPath\fR \fIchild\fR \fIdirectory\fR +\fB::safe::interpCreate\fR ?\fIslave\fR? ?\fIoptions...\fR? +.sp +\fB::safe::interpInit\fR \fIslave\fR ?\fIoptions...\fR? +.sp +\fB::safe::interpConfigure\fR \fIslave\fR ?\fIoptions...\fR? +.sp +\fB::safe::interpDelete\fR \fIslave\fR +.sp +\fB::safe::interpAddToAccessPath\fR \fIslave\fR \fIdirectory\fR +.sp +\fB::safe::interpFindInAccessPath\fR \fIslave\fR \fIdirectory\fR .sp \fB::safe::setLogCmd\fR ?\fIcmd arg...\fR? .SS OPTIONS .PP ?\fB\-accessPath\fR \fIpathList\fR? @@ -34,68 +34,60 @@ .SH DESCRIPTION Safe Tcl is a mechanism for executing untrusted Tcl scripts safely and for providing mediated access by such scripts to potentially dangerous functionality. .PP -Safe Tcl ensures that untrusted Tcl scripts cannot harm the +The Safe Base ensures that untrusted Tcl scripts cannot harm the hosting application. -It prevents integrity and privacy attacks. Untrusted Tcl +The Safe Base prevents integrity and privacy attacks. Untrusted Tcl scripts are prevented from corrupting the state of the hosting application or computer. Untrusted scripts are also prevented from disclosing information stored on the hosting computer or in the hosting application to any party. .PP -Safe Tcl allows a parent interpreter to create safe, restricted +The Safe Base allows a master interpreter to create safe, restricted interpreters that contain a set of predefined aliases for the \fBsource\fR, \fBload\fR, \fBfile\fR, \fBencoding\fR, and \fBexit\fR commands and are able to use the auto-loading and package mechanisms. .PP No knowledge of the file system structure is leaked to the safe interpreter, because it has access only to a virtualized path containing tokens. When the safe interpreter requests to source a file, it uses the token in the virtual path as part of the file name to source; the -parent interpreter transparently -translates the token into a real directory name and executes the +master interpreter transparently +translates the token into a real directory name and executes the requested operation (see the section \fBSECURITY\fR below for details). Different levels of security can be selected by using the optional flags of the commands described below. .PP -All commands provided in the parent interpreter by Safe Tcl reside in +All commands provided in the master interpreter by the Safe Base reside in the \fBsafe\fR namespace. .SH COMMANDS -The following commands are provided in the parent interpreter: +The following commands are provided in the master interpreter: .TP -\fB::safe::interpCreate\fR ?\fIchild\fR? ?\fIoptions...\fR? +\fB::safe::interpCreate\fR ?\fIslave\fR? ?\fIoptions...\fR? Creates a safe interpreter, installs the aliases described in the section \fBALIASES\fR and initializes the auto-loading and package mechanism as specified by the supplied \fIoptions\fR. See the \fBOPTIONS\fR section below for a description of the optional arguments. -If the \fIchild\fR argument is omitted, a name will be generated. +If the \fIslave\fR argument is omitted, a name will be generated. \fB::safe::interpCreate\fR always returns the interpreter name. -.sp -The interpreter name \fIchild\fR may include namespace separators, -but may not have leading or trailing namespace separators, or excess -colon characters in namespace separators. The interpreter name is -qualified relative to the global namespace ::, not the namespace in which -the \fB::safe::interpCreate\fR command is evaluated. .TP -\fB::safe::interpInit\fR \fIchild\fR ?\fIoptions...\fR? +\fB::safe::interpInit\fR \fIslave\fR ?\fIoptions...\fR? This command is similar to \fBinterpCreate\fR except it that does not -create the safe interpreter. \fIchild\fR must have been created by some -other means, like \fBinterp create\fR \fB\-safe\fR. The interpreter -name \fIchild\fR may include namespace separators, subject to the same -restrictions as for \fBinterpCreate\fR. +create the safe interpreter. \fIslave\fR must have been created by some +other means, like \fBinterp create \-safe\fR. .TP -\fB::safe::interpConfigure\fR \fIchild\fR ?\fIoptions...\fR? +\fB::safe::interpConfigure\fR \fIslave\fR ?\fIoptions...\fR? If no \fIoptions\fR are given, returns the settings for all options for the named safe interpreter as a list of options and their current values -for that \fIchild\fR. +for that \fIslave\fR. If a single additional argument is provided, it will return a list of 2 elements \fIname\fR and \fIvalue\fR where \fIname\fR is the full name of that option and \fIvalue\fR the current value -for that option and the \fIchild\fR. +for that option and the \fIslave\fR. If more than two additional arguments are provided, it will reconfigure the safe interpreter and change each and only the provided options. See the section on \fBOPTIONS\fR below for options description. Example of use: .RS @@ -111,41 +103,41 @@ # interp and its deleteHook (leaving the rest unchanged): safe::interpConfigure $i0 \-delete {foo bar} \-statics 0 .CE .RE .TP -\fB::safe::interpDelete\fR \fIchild\fR -Deletes the safe interpreter and cleans up the corresponding -parent interpreter data structures. +\fB::safe::interpDelete\fR \fIslave\fR +Deletes the safe interpreter and cleans up the corresponding +master interpreter data structures. If a \fIdeleteHook\fR script was specified for this interpreter it is evaluated before the interpreter is deleted, with the name of the interpreter as an additional argument. .TP -\fB::safe::interpFindInAccessPath\fR \fIchild\fR \fIdirectory\fR +\fB::safe::interpFindInAccessPath\fR \fIslave\fR \fIdirectory\fR This command finds and returns the token for the real directory \fIdirectory\fR in the safe interpreter's current virtual access path. It generates an error if the directory is not found. Example of use: .RS .PP .CS -$child eval [list set tk_library \e +$slave eval [list set tk_library \e [::safe::interpFindInAccessPath $name $tk_library]] .CE .RE .TP -\fB::safe::interpAddToAccessPath\fR \fIchild\fR \fIdirectory\fR +\fB::safe::interpAddToAccessPath\fR \fIslave\fR \fIdirectory\fR This command adds \fIdirectory\fR to the virtual path maintained for the -safe interpreter in the parent, and returns the token that can be used in +safe interpreter in the master, and returns the token that can be used in the safe interpreter to obtain access to files in that directory. If the directory is already in the virtual path, it only returns the token without adding the directory to the virtual path again. Example of use: .RS .PP .CS -$child eval [list set tk_library \e +$slave eval [list set tk_library \e [::safe::interpAddToAccessPath $name $tk_library]] .CE .RE .TP \fB::safe::setLogCmd\fR ?\fIcmd arg...\fR? @@ -174,37 +166,37 @@ attempted to source a file not found in its virtual access path. Note that the safe interpreter only received an error message saying that the file was not found: .PP .CS -NOTICE for child interp10 : Created -NOTICE for child interp10 : Setting accessPath=(/foo/bar) staticsok=1 nestedok=0 deletehook=() -NOTICE for child interp10 : auto_path in interp10 has been set to {$p(:0:)} -ERROR for child interp10 : /foo/bar/init.tcl: no such file or directory +NOTICE for slave interp10 : Created +NOTICE for slave interp10 : Setting accessPath=(/foo/bar) staticsok=1 nestedok=0 deletehook=() +NOTICE for slave interp10 : auto_path in interp10 has been set to {$p(:0:)} +ERROR for slave interp10 : /foo/bar/init.tcl: no such file or directory .CE .RE .SS OPTIONS -The following options are common to -\fB::safe::interpCreate\fR, \fB::safe::interpInit\fR, +The following options are common to +\fB::safe::interpCreate\fR, \fB::safe::interpInit\fR, and \fB::safe::interpConfigure\fR. -Any option name can be abbreviated to its minimal +Any option name can be abbreviated to its minimal non-ambiguous name. Option names are not case sensitive. -.TP +.TP \fB\-accessPath\fR \fIdirectoryList\fR This option sets the list of directories from which the safe interpreter can \fBsource\fR and \fBload\fR files. If this option is not specified, or if it is given as the empty list, the safe interpreter will use the same directories as its -parent for auto-loading. -See the section \fBSECURITY\fR below for more detail about virtual paths, +master for auto-loading. +See the section \fBSECURITY\fR below for more detail about virtual paths, tokens and access control. .TP \fB\-statics\fR \fIboolean\fR This option specifies if the safe interpreter will be allowed to load statically linked packages (like \fBload {} Tk\fR). -The default value is \fBtrue\fR : +The default value is \fBtrue\fR : safe interpreters are allowed to load statically linked packages. .TP \fB\-noStatics\fR This option is a convenience shortcut for \fB\-statics false\fR and thus specifies that the safe interpreter will not be allowed @@ -211,22 +203,22 @@ to load statically linked packages. .TP \fB\-nested\fR \fIboolean\fR This option specifies if the safe interpreter will be allowed to load packages into its own sub-interpreters. -The default value is \fBfalse\fR : +The default value is \fBfalse\fR : safe interpreters are not allowed to load packages into their own sub-interpreters. .TP \fB\-nestedLoadOk\fR This option is a convenience shortcut for \fB\-nested true\fR and thus specifies the safe interpreter will be allowed to load packages into its own sub-interpreters. -.TP +.TP \fB\-deleteHook\fR \fIscript\fR When this option is given a non-empty \fIscript\fR, it will be -evaluated in the parent with the name of +evaluated in the master with the name of the safe interpreter as an additional argument just before actually deleting the safe interpreter. Giving an empty value removes any currently installed deletion hook script for that safe interpreter. The default value (\fB{}\fR) is not to have any deletion call back. @@ -267,17 +259,17 @@ .TP \fBexit\fR The calling interpreter is deleted and its computation is stopped, but the Tcl process in which this interpreter exists is not terminated. .SH SECURITY -Safe Tcl does not attempt to completely prevent annoyance and +The Safe Base does not attempt to completely prevent annoyance and denial of service attacks. These forms of attack prevent the application or user from temporarily using the computer to perform useful work, for example by consuming all available CPU time or all available screen real estate. These attacks, while aggravating, are deemed to be of lesser importance -in general than integrity and privacy attacks that Safe Tcl +in general than integrity and privacy attacks that the Safe Base is to prevent. .PP The commands available in a safe interpreter, in addition to the safe set as defined in \fBinterp\fR manual page, are mediated aliases for \fBsource\fR, \fBload\fR, \fBexit\fR, and safe subsets of @@ -287,26 +279,26 @@ Because some of these commands access the local file system, there is a potential for information leakage about its directory structure. To prevent this, commands that take file names as arguments in a safe interpreter use tokens instead of the real directory names. These tokens are translated to the real directory name while a request to, -e.g., source a file is mediated by the parent interpreter. -This virtual path system is maintained in the parent interpreter for each safe +e.g., source a file is mediated by the master interpreter. +This virtual path system is maintained in the master interpreter for each safe interpreter created by \fB::safe::interpCreate\fR or initialized by \fB::safe::interpInit\fR and the path maps tokens accessible in the safe interpreter into real path -names on the local file system thus preventing safe interpreters +names on the local file system thus preventing safe interpreters from gaining knowledge about the structure of the file system of the host on which the interpreter is executing. The only valid file names arguments -for the \fBsource\fR and \fBload\fR aliases provided to the child -are path in the form of -\fB[file join \fItoken filename\fB]\fR (i.e. when using the -native file path formats: \fItoken\fB/\fIfilename\fR -on Unix and \fItoken\fB\e\fIfilename\fR on Windows), -where \fItoken\fR is representing one of the directories +for the \fBsource\fR and \fBload\fR aliases provided to the slave +are path in the form of +\fB[file join \fR\fItoken filename\fR\fB]\fR (i.e. when using the +native file path formats: \fItoken\fR\fB/\fR\fIfilename\fR +on Unix and \fItoken\fR\fB\e\fIfilename\fR on Windows), +where \fItoken\fR is representing one of the directories of the \fIaccessPath\fR list and \fIfilename\fR is one file in that directory (no sub directories access are allowed). .PP When a token is used in a safe interpreter in a request to source or load a file, the token is checked and @@ -326,32 +318,32 @@ or be called .PQ \fBtclIndex\fR . .PP Each element of the initial access path list will be assigned a token that will be set in -the child \fBauto_path\fR and the first element of that list will be set as -the \fBtcl_library\fR for that child. +the slave \fBauto_path\fR and the first element of that list will be set as +the \fBtcl_library\fR for that slave. .PP -If the access path argument is not given or is the empty list, -the default behavior is to let the child access the same packages -as the parent has access to (Or to be more precise: +If the access path argument is not given or is the empty list, +the default behavior is to let the slave access the same packages +as the master has access to (Or to be more precise: only packages written in Tcl (which by definition cannot be dangerous -as they run in the child interpreter) and C extensions that -provides a _SafeInit entry point). For that purpose, the parent's -\fBauto_path\fR will be used to construct the child access path. -In order that the child successfully loads the Tcl library files +as they run in the slave interpreter) and C extensions that +provides a _SafeInit entry point). For that purpose, the master's +\fBauto_path\fR will be used to construct the slave access path. +In order that the slave successfully loads the Tcl library files (which includes the auto-loading mechanism itself) the \fBtcl_library\fR will be -added or moved to the first position if necessary, in the -child access path, so the child -\fBtcl_library\fR will be the same as the parent's (its real -path will still be invisible to the child though). -In order that auto-loading works the same for the child and -the parent in this by default case, the first-level -sub directories of each directory in the parent \fBauto_path\fR will -also be added (if not already included) to the child access path. +added or moved to the first position if necessary, in the +slave access path, so the slave +\fBtcl_library\fR will be the same as the master's (its real +path will still be invisible to the slave though). +In order that auto-loading works the same for the slave and +the master in this by default case, the first-level +sub directories of each directory in the master \fBauto_path\fR will +also be added (if not already included) to the slave access path. You can always specify a more -restrictive path for which sub directories will never be searched by +restrictive path for which sub directories will never be searched by explicitly specifying your directory list with the \fB\-accessPath\fR flag instead of relying on this default mechanism. .PP When the \fIaccessPath\fR is changed after the first creation or initialization (i.e. through \fBinterpConfigure -accessPath \fR\fIlist\fR), @@ -358,10 +350,7 @@ an \fBauto_reset\fR is automatically evaluated in the safe interpreter to synchronize its \fBauto_index\fR with the new token list. .SH "SEE ALSO" interp(n), library(n), load(n), package(n), source(n), unknown(n) .SH KEYWORDS -alias, auto\-loading, auto_mkindex, load, parent interpreter, safe -interpreter, child interpreter, source -'\" Local Variables: -'\" mode: nroff -'\" End: +alias, auto\-loading, auto_mkindex, load, master interpreter, safe +interpreter, slave interpreter, source Index: doc/scan.n ================================================================== --- doc/scan.n +++ doc/scan.n @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 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 scan n 8.4 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -35,11 +35,11 @@ .PP \fBScan\fR operates by scanning \fIstring\fR and \fIformat\fR together. If the next character in \fIformat\fR is a blank or tab then it matches any number of white space characters in \fIstring\fR (including zero). -Otherwise, if it is not a \fB%\fR character then it +Otherwise, if it is not a \fB%\fR character then it must match the next character of \fIstring\fR. When a \fB%\fR is encountered in \fIformat\fR, it indicates the start of a conversion specifier. A conversion specifier contains up to four fields after the \fB%\fR: a XPG3 position specifier (or a \fB*\fR to indicate the converted @@ -50,14 +50,13 @@ The fields that are present must appear in the order given above. .PP When \fBscan\fR finds a conversion specifier in \fIformat\fR, it first skips any white-space characters in \fIstring\fR (unless the conversion character is \fB[\fR or \fBc\fR). -Then it converts the next input characters according to the +Then it converts the next input characters according to the conversion specifier and stores the result in the variable given by the next argument to \fBscan\fR. -.SS "OPTIONAL POSITIONAL SPECIFIER" .PP If the \fB%\fR is followed by a decimal number and a \fB$\fR, as in .QW \fB%2$d\fR , then the variable to use is not taken from the next sequential argument. Instead, it is taken from the argument indicated @@ -65,12 +64,12 @@ there are any positional specifiers in \fIformat\fR then all of the specifiers must be positional. Every \fIvarName\fR on the argument list must correspond to exactly one conversion specifier or an error is generated, or in the inline case, any position can be specified at most once and the empty positions will be filled in with empty strings. -.SS "OPTIONAL SIZE MODIFIER" .PP +.VS 8.5 The size modifier field is used only when scanning a substring into one of Tcl's integer values. The size modifier field dictates the integer range acceptable to be stored in a variable, or, for the inline case, in a position in the result list. The syntactically valid values for the size modifier are \fBh\fR, \fBL\fR, @@ -81,76 +80,63 @@ command. The \fBL\fR size modifier is equivalent to the \fBl\fR size modifier. Either one indicates the integer range to be stored is limited to the same range produced by the \fBwide()\fR function of the \fBexpr\fR command. The \fBll\fR size modifier indicates that the integer range to be stored is unlimited. -.SS "MANDATORY CONVERSION CHARACTER" +.VE 8.5 .PP The following conversion characters are supported: -.TP +.TP 10 \fBd\fR -. The input substring must be a decimal integer. It is read in and the integer value is stored in the variable, truncated as required by the size modifier value. -.TP +.TP 10 \fBo\fR -. -The input substring must be an octal integer. It is read in and the +The input substring must be an octal integer. It is read in and the integer value is stored in the variable, truncated as required by the size modifier value. -.TP +.TP 10 \fBx\fR or \fBX\fR -. The input substring must be a hexadecimal integer. It is read in and the integer value is stored in the variable, truncated as required by the size modifier value. -.TP -\fBb\fR -. -The input substring must be a binary integer. -It is read in and the integer value is stored in the variable, -truncated as required by the size modifier value. -.TP +.TP 10 \fBu\fR -. The input substring must be a decimal integer. The integer value is truncated as required by the size modifier value, and the corresponding unsigned value for that truncated range is computed and stored in the variable as a decimal string. The conversion makes no sense without reference to a truncation range, so the size modifier \fBll\fR is not permitted in combination with conversion character \fBu\fR. -.TP -\fBi\fR -. -The input substring must be an integer. The base (i.e. decimal, octal, or hexadecimal) is determined by the C convention (leading 0 for octal; prefix 0x for hexadecimal). The integer value is stored in the variable, +.TP 10 +\fBi\fR +The input substring must be an integer. The base (i.e. decimal, binary, +octal, or hexadecimal) is determined in the same fashion as described in +\fBexpr\fR. The integer value is stored in the variable, truncated as required by the size modifier value. -.TP +.TP 10 \fBc\fR -. -A single character is read in and its Unicode value is stored in +A single character is read in and its Unicode value is stored in the variable as an integer value. Initial white space is not skipped in this case, so the input substring may be a white-space character. -.TP +.TP 10 \fBs\fR -. -The input substring consists of all the characters up to the next +The input substring consists of all the characters up to the next white-space character; the characters are copied to the variable. -.TP +.TP 10 \fBe\fR or \fBf\fR or \fBg\fR or \fBE\fR or \fBG\fR -. -The input substring must be a floating-point number consisting +The input substring must be a floating-point number consisting of an optional sign, a string of decimal digits possibly -containing a decimal point, and an optional exponent consisting -of an \fBe\fR or \fBE\fR followed by an optional sign and a string of +containing a decimal point, and an optional exponent consisting +of an \fBe\fR or \fBE\fR followed by an optional sign and a string of decimal digits. It is read in and stored in the variable as a floating-point value. -.TP +.TP 10 \fB[\fIchars\fB]\fR -. The input substring consists of one or more characters in \fIchars\fR. The matching string is stored in the variable. If the first character between the brackets is a \fB]\fR then it is treated as part of \fIchars\fR rather than the closing bracket for the set. @@ -157,38 +143,36 @@ If \fIchars\fR contains a sequence of the form \fIa\fB\-\fIb\fR then any character between \fIa\fR and \fIb\fR (inclusive) will match. If the first or last character between the brackets is a \fB\-\fR, then it is treated as part of \fIchars\fR rather than indicating a range. -.TP +.TP 10 \fB[^\fIchars\fB]\fR -. The input substring consists of one or more characters not in \fIchars\fR. The matching string is stored in the variable. -If the character immediately following the \fB^\fR is a \fB]\fR then it is -treated as part of the set rather than the closing bracket for +If the character immediately following the \fB^\fR is a \fB]\fR then it is +treated as part of the set rather than the closing bracket for the set. If \fIchars\fR contains a sequence of the form \fIa\fB\-\fIb\fR then any character between \fIa\fR and \fIb\fR (inclusive) will be excluded from the set. If the first or last character between the brackets is a \fB\-\fR, then it is treated as part of \fIchars\fR rather than indicating a range value. -.TP +.TP 10 \fBn\fR -. No input is consumed from the input string. Instead, the total number of characters scanned from the input string so far is stored in the variable. -.PP +.LP The number of characters read from the input for a conversion is the largest number that makes sense for that particular conversion (e.g. -as many decimal digits as possible for \fB%d\fR, as +as many decimal digits as possible for \fB%d\fR, as many octal digits as possible for \fB%o\fR, and so on). The input substring for a given conversion terminates either when a -white-space character is encountered or when the maximum substring +white-space character is encountered or when the maximum substring width has been reached, whichever comes first. -If a \fB*\fR is present in the conversion specifier +If a \fB*\fR is present in the conversion specifier then no variable is assigned and the next scan argument is not consumed. .SH "DIFFERENCES FROM ANSI SSCANF" .PP The behavior of the \fBscan\fR command is the same as the behavior of the ANSI C \fBsscanf\fR procedure except for the following differences: @@ -206,84 +190,78 @@ modifier has no \fBsscanf\fR counterpart. .IP [4] If the end of the input string is reached before any conversions have been performed and no variables are given, an empty string is returned. .SH EXAMPLES -.PP Convert a UNICODE character to its numeric value: -.PP .CS set char "x" set value [\fBscan\fR $char %c] .CE .PP Parse a simple color specification of the form \fI#RRGGBB\fR using 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: -.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): .CS -set string "08:08" +set string "08:08" ;# *Not* octal! if {[\fBscan\fR $string "%d:%d" hours minutes] != 2} { - error "not a valid time string" + error "not a valid time string" } # We have to understand numeric ranges ourselves... if {$minutes < 0 || $minutes > 59} { - error "invalid number of minutes" + error "invalid number of minutes" } .CE .PP Break a string up into sequences of non-whitespace characters (note the use of the \fB%n\fR conversion so that we get skipping over leading whitespace correct): -.PP .CS set string " a string {with braced words} + leading space " set words {} while {[\fBscan\fR $string %s%n word length] == 2} { - lappend words $word - set string [string range $string $length end] + lappend words $word + set string [string range $string $length end] } .CE .PP Parse a simple coordinate string, checking that it is complete by looking for the terminating character explicitly: -.PP .CS set string "(5.2,-4e-2)" # Note that the spaces before the literal parts of # the scan pattern are significant, and that ")" is # the Unicode character \eu0029 if { - [\fBscan\fR $string " (%f ,%f %c" x y last] != 3 - || $last != 0x0029 + [\fBscan\fR $string " (%f ,%f %c" x y last] != 3 + || $last != 0x0029 } then { - error "invalid coordinate string" + error "invalid coordinate string" } puts "X=$x, Y=$y" .CE .PP +.VS 8.5 An interactive session demonstrating the truncation of integer values determined by size modifiers: -.PP -.CS -\fI%\fR set tcl_platform(wordSize) -4 -\fI%\fR scan 20000000000000000000 %d -2147483647 -\fI%\fR scan 20000000000000000000 %ld -9223372036854775807 -\fI%\fR scan 20000000000000000000 %lld +.CS +% set tcl_platform(wordSize) +4 +% scan 20000000000000000000 %d +2147483647 +% scan 20000000000000000000 %ld +9223372036854775807 +% scan 20000000000000000000 %lld 20000000000000000000 .CE +.VE 8.5 .SH "SEE ALSO" format(n), sscanf(3) .SH KEYWORDS conversion specifier, parse, scan -'\" Local Variables: -'\" mode: nroff -'\" End: Index: doc/seek.n ================================================================== --- doc/seek.n +++ doc/seek.n @@ -2,20 +2,21 @@ '\" 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 seek n 8.1 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME seek \- Change the access position for an open channel .SH SYNOPSIS \fBseek \fIchannelId offset \fR?\fIorigin\fR? .BE + .SH DESCRIPTION .PP Changes the current access position for \fIchannelId\fR. .PP \fIChannelId\fR must be an identifier for an open channel such as a @@ -27,66 +28,58 @@ arguments specify the position at which the next read or write will occur for \fIchannelId\fR. \fIOffset\fR must be an integer (which may be negative) and \fIorigin\fR must be one of the following: .TP 10 \fBstart\fR -. The new access position will be \fIoffset\fR bytes from the start of the underlying file or device. .TP 10 \fBcurrent\fR -. The new access position will be \fIoffset\fR bytes from the current access position; a negative \fIoffset\fR moves the access position backwards in the underlying file or device. .TP 10 \fBend\fR -. The new access position will be \fIoffset\fR bytes from the end of the file or device. A negative \fIoffset\fR places the access position before the end of file, and a positive \fIoffset\fR places the access position after the end of file. -.PP +.LP The \fIorigin\fR argument defaults to \fBstart\fR. .PP The command flushes all buffered output for the channel before the command -returns, even if the channel is in non-blocking mode. +returns, even if the channel is in nonblocking mode. It also discards any buffered and unread input. This command returns an empty string. An error occurs if this command is applied to channels whose underlying file or device does not support seeking. .PP Note that \fIoffset\fR values are byte offsets, not character offsets. Both \fBseek\fR and \fBtell\fR operate in terms of bytes, not characters, unlike \fBread\fR. .SH EXAMPLES -.PP Read a file twice: -.PP .CS set f [open file.txt] set data1 [read $f] \fBseek\fR $f 0 set data2 [read $f] close $f -# $data1 eq $data2 if the file wasn't updated +# $data1 == $data2 if the file wasn't updated .CE .PP Read the last 10 bytes from a file: -.PP .CS set f [open file.data] # This is guaranteed to work with binary data but # may fail with other encodings... fconfigure $f -translation binary \fBseek\fR $f -10 end set data [read $f 10] close $f .CE + .SH "SEE ALSO" file(n), open(n), close(n), gets(n), tell(n), Tcl_StandardChannels(3) + .SH KEYWORDS access position, file, seek -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: DELETED doc/self.n Index: doc/self.n ================================================================== --- doc/self.n +++ /dev/null @@ -1,157 +0,0 @@ -'\" -'\" Copyright (c) 2007 Donal K. Fellows -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH self n 0.1 TclOO "TclOO Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -self \- method call internal introspection -.SH SYNOPSIS -.nf -package require TclOO - -\fBself\fR ?\fIsubcommand\fR? -.fi -.BE -.SH DESCRIPTION -The \fBself\fR command, which should only be used from within the context of a -call to a method (i.e. inside a method, constructor or destructor body) is -used to allow the method to discover information about how it was called. It -takes an argument, \fIsubcommand\fR, that tells it what sort of information is -actually desired; if omitted the result will be the same as if \fBself -object\fR was invoked. The supported subcommands are: -.TP -\fBself call\fR -. -This returns a two-element list describing the method implementations used to -implement the current call chain. The first element is the same as would be -reported by \fBinfo object\fR \fBcall\fR for the current method (except that this -also reports useful values from within constructors and destructors, whose -names are reported as \fB\fR and \fB\fR -respectively, -.VS TIP500 -and for private methods, which are described as being \fBprivate\fR instead of -being a \fBmethod\fR), -.VE TIP500 -and the second element is an index into the first element's -list that indicates which actual implementation is currently executing (the -first implementation to execute is always at index 0). -.TP -\fBself caller\fR -. -When the method was invoked from inside another object method, this subcommand -returns a three element list describing the containing object and method. The -first element describes the declaring object or class of the method, the -second element is the name of the object on which the containing method was -invoked, and the third element is the name of the method (with the strings -\fB\fR and \fB\fR indicating constructors and -destructors respectively). -.TP -\fBself class\fR -. -This returns the name of the class that the current method was defined within. -Note that this will change as the chain of method implementations is traversed -with \fBnext\fR, and that if the method was defined on an object then this -will fail. -.RS -.PP -If you want the class of the current object, you need to use this other -construct: -.PP -.CS -info object class [\fBself object\fR] -.CE -.RE -.TP -\fBself filter\fR -. -When invoked inside a filter, this subcommand returns a three element list -describing the filter. The first element gives the name of the object or class -that declared the filter (note that this may be different from the object or -class that provided the implementation of the filter), the second element is -either \fBobject\fR or \fBclass\fR depending on whether the declaring entity -was an object or class, and the third element is the name of the filter. -.TP -\fBself method\fR -. -This returns the name of the current method (with the strings -\fB\fR and \fB\fR indicating constructors and -destructors respectively). -.TP -\fBself namespace\fR -. -This returns the name of the unique namespace of the object that the method -was invoked upon. -.TP -\fBself next\fR -. -When invoked from a method that is not at the end of a call chain (i.e. where -the \fBnext\fR command will invoke an actual method implementation), this -subcommand returns a two element list describing the next element in the -method call chain; the first element is the name of the class or object that -declares the next part of the call chain, and the second element is the name -of the method (with the strings \fB\fR and \fB\fR -indicating constructors and destructors respectively). If invoked from a -method that is at the end of a call chain, this subcommand returns the empty -string. -.TP -\fBself object\fR -. -This returns the name of the object that the method was invoked upon. -.TP -\fBself target\fR -. -When invoked inside a filter implementation, this subcommand returns a two -element list describing the method being filtered. The first element will be -the name of the declarer of the method, and the second element will be the -actual name of the method. -.SH EXAMPLES -.PP -This example shows basic use of \fBself\fR to provide information about the -current object: -.PP -.CS -oo::class create c { - method foo {} { - puts "this is the [\fBself\fR] object" - } -} -c create a -c create b -a foo \fI\(-> prints "this is the ::a object"\fR -b foo \fI\(-> prints "this is the ::b object"\fR -.CE -.PP -This demonstrates what a method call chain looks like, and how traversing -along it changes the index into it: -.PP -.CS -oo::class create c { - method x {} { - puts "Cls: [\fBself call\fR]" - } -} -c create a -oo::objdefine a { - method x {} { - puts "Obj: [\fBself call\fR]" - next - puts "Obj: [\fBself call\fR]" - } -} -a x \fI\(-> Obj: {{method x object method} {method x ::c method}} 0\fR - \fI\(-> Cls: {{method x object method} {method x ::c method}} 1\fR - \fI\(-> Obj: {{method x object method} {method x ::c method}} 0\fR -.CE -.SH "SEE ALSO" -info(n), next(n) -.SH KEYWORDS -call, introspection, object -.\" Local variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: Index: doc/set.n ================================================================== --- doc/set.n +++ doc/set.n @@ -2,11 +2,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 set n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -27,44 +27,39 @@ Otherwise \fIvarName\fR refers to a scalar variable. .PP If \fIvarName\fR includes namespace qualifiers (in the array name if it refers to an array element), or if \fIvarName\fR is unqualified (does not include the names of any containing namespaces) -but no procedure is active, +but no procedure is active, \fIvarName\fR refers to a namespace variable resolved according to the rules described under \fBNAME RESOLUTION\fR in the \fBnamespace\fR manual page. .PP If a procedure is active and \fIvarName\fR is unqualified, then \fIvarName\fR refers to a parameter or local variable of the procedure, -unless \fIvarName\fR was declared to resolve differently through one of the +unless \fIvarName\fR was declared to resolve differently through one of the \fBglobal\fR, \fBvariable\fR or \fBupvar\fR commands. .SH EXAMPLES -.PP Store a random number in the variable \fIr\fR: -.PP .CS \fBset\fR r [expr {rand()}] .CE .PP Store a short message in an array element: -.PP .CS \fBset\fR anAry(msg) "Hello, World!" .CE .PP Store a short message in an array element specified by a variable: -.PP .CS \fBset\fR elemName "msg" \fBset\fR anAry($elemName) "Hello, World!" .CE .PP Copy a value into the variable \fIout\fR from a variable whose name is stored in the \fIvbl\fR (note that it is often easier to use arrays in practice instead of doing double-dereferencing): -.PP .CS \fBset\fR in0 "small random" \fBset\fR in1 "large random" \fBset\fR vbl in[expr {rand() >= 0.5}] \fBset\fR out [\fBset\fR $vbl] @@ -71,9 +66,5 @@ .CE .SH "SEE ALSO" expr(n), global(n), namespace(n), proc(n), trace(n), unset(n), upvar(n), variable(n) .SH KEYWORDS read, write, variable -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: DELETED doc/singleton.n Index: doc/singleton.n ================================================================== --- doc/singleton.n +++ /dev/null @@ -1,99 +0,0 @@ -'\" -'\" Copyright (c) 2018 Donal K. Fellows -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH singleton n 0.3 TclOO "TclOO Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -oo::singleton \- a class that does only allows one instance of itself -.SH SYNOPSIS -.nf -package require TclOO - -\fBoo::singleton\fI method \fR?\fIarg ...\fR? -.fi -.SH "CLASS HIERARCHY" -.nf -\fBoo::object\fR - \(-> \fBoo::class\fR - \(-> \fBoo::singleton\fR -.fi -.BE -.SH DESCRIPTION -Singleton classes are classes that only permit at most one instance of -themselves to exist. They unexport the \fBcreate\fR and -\fBcreateWithNamespace\fR methods entirely, and override the \fBnew\fR method -so that it only makes a new instance if there is no existing instance. It is -not recommended to inherit from a singleton class; singleton-ness is \fInot\fR -inherited. It is not recommended that a singleton class's constructor take any -arguments. -.PP -Instances have their\fB destroy\fR method overridden with a method that always -returns an error in order to discourage destruction of the object, but -destruction remains possible if strictly necessary (e.g., by destroying the -class or using \fBrename\fR to delete it). They also have a (non-exported) -\fB\fR method defined on them that similarly always returns errors to -make attempts to use the singleton instance with \fBoo::copy\fR fail. -.SS CONSTRUCTOR -The \fBoo::singleton\fR class does not define an explicit constructor; this -means that it is effectively the same as the constructor of the -\fBoo::class\fR class. -.SS DESTRUCTOR -The \fBoo::singleton\fR class does not define an explicit destructor; -destroying an instance of it is just like destroying an ordinary class (and -will destroy the singleton object). -.SS "EXPORTED METHODS" -.TP -\fIcls \fBnew \fR?\fIarg ...\fR? -. -This returns the current instance of the singleton class, if one exists, and -creates a new instance only if there is no existing instance. The additional -arguments, \fIarg ...\fR, are only used if a new instance is actually -manufactured; that construction is via the \fBoo::class\fR class's \fBnew\fR -method. -.RS -.PP -This is an override of the behaviour of a superclass's method with an -identical call signature to the superclass's implementation. -.RE -.SS "NON-EXPORTED METHODS" -The \fBoo::singleton\fR class explicitly states that \fBcreate\fR and -\fBcreateWithNamespace\fR are unexported; callers should not assume that they -have control over either the name or the namespace name of the singleton instance. -.SH EXAMPLE -.PP -This example demonstrates that there is only one instance even though the -\fBnew\fR method is called three times. -.PP -.CS -\fBoo::singleton\fR create Highlander { - method say {} { - puts "there can be only one" - } -} - -set h1 [Highlander new] -set h2 [Highlander new] -if {$h1 eq $h2} { - puts "equal objects" \fI\(-> prints "equal objects"\fR -} -set h3 [Highlander new] -if {$h1 eq $h3} { - puts "equal objects" \fI\(-> prints "equal objects"\fR -} -.CE -.PP -Note that the name of the instance of the singleton is not guaranteed to be -anything in particular. -.SH "SEE ALSO" -oo::class(n) -.SH KEYWORDS -class, metaclass, object, single instance -.\" Local variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: Index: doc/socket.n ================================================================== --- doc/socket.n +++ doc/socket.n @@ -3,11 +3,11 @@ '\" 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. '\" -.TH socket n 8.6 Tcl "Tcl Built-In Commands" +.TH socket n 8.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME socket \- Open a TCP network connection @@ -15,23 +15,25 @@ .sp \fBsocket \fR?\fIoptions\fR? \fIhost port\fR .sp \fBsocket\fR \fB\-server \fIcommand\fR ?\fIoptions\fR? \fIport\fR .BE + .SH DESCRIPTION .PP -This command opens a network socket and returns a channel identifier -that may be used in future invocations of commands like \fBread\fR, -\fBputs\fR and \fBflush\fR. At present only the TCP network protocol -is supported over IPv4 and IPv6; future releases may include support -for additional protocols. The \fBsocket\fR command may be used to -open either the client or server side of a connection, depending on -whether the \fB\-server\fR switch is specified. +This command opens a network socket and returns a channel +identifier that may be used in future invocations of commands like +\fBread\fR, \fBputs\fR and \fBflush\fR. +At present only the TCP network protocol is supported; future +releases may include support for additional protocols. +The \fBsocket\fR command may be used to open either the client or +server side of a connection, depending on whether the \fB\-server\fR +switch is specified. .PP Note that the default encoding for \fIall\fR sockets is the system encoding, as returned by \fBencoding system\fR. Most of the time, you -will need to use \fBchan configure\fR to alter this to something else, +will need to use \fBfconfigure\fR to alter this to something else, such as \fIutf\-8\fR (ideal for communicating with other Tcl processes) or \fIiso8859\-1\fR (useful for many network protocols, especially the older ones). .SH "CLIENT SOCKETS" .PP @@ -42,107 +44,73 @@ to connect to; there must be a server accepting connections on this port. \fIPort\fR is an integer port number (or service name, where supported and understood by the host operating system) and \fIhost\fR is either a domain-style name such as \fBwww.tcl.tk\fR or -a numerical IPv4 or IPv6 address such as \fB127.0.0.1\fR or \fB2001:DB8::1\fR. +a numerical IP address such as \fB127.0.0.1\fR. Use \fIlocalhost\fR to refer to the host on which the command is invoked. .PP The following options may also be present before \fIhost\fR to specify additional information about the connection: .TP \fB\-myaddr\fI addr\fR -. \fIAddr\fR gives the domain-style name or numerical IP address of the client-side network interface to use for the connection. This option may be useful if the client machine has multiple network interfaces. If the option is omitted then the client-side interface will be chosen by the system software. .TP \fB\-myport\fI port\fR -. \fIPort\fR specifies an integer port number (or service name, where supported and understood by the host operating system) to use for the client's side of the connection. If this option is omitted, the client's port number will be chosen at random by the system software. .TP \fB\-async\fR -. -This option will cause the client socket to be connected -asynchronously. This means that the socket will be created immediately -but may not yet be connected to the server, when the call to -\fBsocket\fR returns. +The \fB\-async\fR option will cause the client socket to be connected +asynchronously. This means that the socket will be created immediately but +may not yet be connected to the server, when the call to \fBsocket\fR +returns. When a \fBgets\fR or \fBflush\fR is done on the socket before the +connection attempt succeeds or fails, if the socket is in blocking mode, the +operation will wait until the connection is completed or fails. If the +socket is in nonblocking mode and a \fBgets\fR or \fBflush\fR is done on +the socket before the connection attempt succeeds or fails, the operation +returns immediately and \fBfblocked\fR on the socket returns 1. Synchronous +client sockets may be switched (after they have connected) to operating in +asynchronous mode using: .RS -.PP -When a \fBgets\fR or \fBflush\fR is done on the socket before the -connection attempt succeeds or fails, if the socket is in blocking -mode, the operation will wait until the connection is completed or -fails. If the socket is in nonblocking mode and a \fBgets\fR or -\fBflush\fR is done on the socket before the connection attempt -succeeds or fails, the operation returns immediately and -\fBfblocked\fR on the socket returns 1. Synchronous client sockets may -be switched (after they have connected) to operating in asynchronous -mode using: -.PP .CS -\fBchan configure \fIchan \fB\-blocking 0\fR +\fBfconfigure \fIchan \fB\-blocking 0\fR .CE .PP -See the \fBchan configure\fR command for more details. -.PP -The Tcl event loop should be running while an asynchronous connection -is in progress, because it may have to do several connection attempts -in the background. Running the event loop also allows you to set up a -writable channel event on the socket to get notified when the -asynchronous connection has succeeded or failed. See the \fBvwait\fR -and the \fBchan\fR commands for more details on the event loop and -channel events. -.PP -The \fBchan configure\fR option \fB-connecting\fR may be used to check if the connect is still running. To verify a successful connect, the option \fB-error\fR may be checked when \fB-connecting\fR returned 0. -.PP -Operation without the event queue requires at the moment calls to \fBchan configure\fR to advance the internal state machine. +See the \fBfconfigure\fR command for more details. .RE .SH "SERVER SOCKETS" .PP -If the \fB\-server\fR option is specified then the new socket will be -a server that listens on the given \fIport\fR (either an integer or a -service name, where supported and understood by the host operating -system; if \fIport\fR is zero, the operating system will allocate a -free port to the server socket which may be discovered by using -\fBchan configure\fR to read the \fB\-sockname\fR option). If the host -supports both, IPv4 and IPv6, the socket will listen on both address -families. Tcl will automatically accept connections to the given port. +If the \fB\-server\fR option is specified then the new socket +will be a server for the port given by \fIport\fR (either an integer +or a service name, where supported and understood by the host +operating system; if \fIport\fR is zero, the operating system will +allocate a free port to the server socket which may be discovered by +using \fBfconfigure\fR to read the \fB\-sockname\fR option). +Tcl will automatically accept connections to the given port. For each connection Tcl will create a new channel that may be used to -communicate with the client. Tcl then invokes \fIcommand\fR (properly -a command prefix list, see the \fBEXAMPLES\fR below) with three -additional arguments: the name of the new channel, the address, in -network address notation, of the client's host, and the client's port -number. +communicate with the client. Tcl then invokes \fIcommand\fR +with three additional arguments: the name of the new channel, the +address, in network address notation, of the client's host, and +the client's port number. .PP The following additional option may also be specified before \fIport\fR: .TP \fB\-myaddr\fI addr\fR -. -\fIAddr\fR gives the domain-style name or numerical IP address of the -server-side network interface to use for the connection. This option -may be useful if the server machine has multiple network interfaces. -If the option is omitted then the server socket is bound to the -wildcard address so that it can accept connections from any -interface. If \fIaddr\fR is a domain name that resolves to multiple IP -addresses that are available on the local machine, the socket will -listen on all of them. -.TP -\fB\-reuseaddr\fI boolean\fR -. -Tells the kernel whether to reuse the local address if there is no socket -actively listening on it. This is the default on Windows. -.TP -\fB\-reuseport\fI boolean\fR -. -Tells the kernel whether to allow the binding of multiple sockets to the same -address and port. +\fIAddr\fR gives the domain-style name or numerical IP address of +the server-side network interface to use for the connection. +This option may be useful if the server machine has multiple network +interfaces. If the option is omitted then the server socket is bound +to the special address INADDR_ANY so that it can accept connections from +any interface. .PP Server channels cannot be used for input or output; their sole use is to accept new client connections. The channels created for each incoming client connection are opened for input and output. Closing the server channel shuts down the server so that no new connections will be @@ -155,91 +123,60 @@ will be accepted. .PP If \fIport\fR is specified as zero, the operating system will allocate an unused port for use as a server socket. The port number actually allocated may be retrieved from the created server socket using the -\fBchan configure\fR command to retrieve the \fB\-sockname\fR option as +\fBfconfigure\fR command to retrieve the \fB\-sockname\fR option as described below. .SH "CONFIGURATION OPTIONS" -.PP -The \fBchan configure\fR command can be used to query several readonly +The \fBfconfigure\fR command can be used to query several readonly configuration options for socket channels: .TP \fB\-error\fR -. This option gets the current error status of the given socket. This is useful when you need to determine if an asynchronous connect operation succeeded. If there was an error, the error message is returned. If there was no error, an empty string is returned. -.RS -.PP + Note that the error status is reset by the read operation; this mimics the underlying getsockopt(SO_ERROR) call. -.RE .TP \fB\-sockname\fR -. -For client sockets (including the channels that get created when a -client connects to a server socket) this option returns a list of -three elements, the address, the host name and the port number for the -socket. If the host name cannot be computed, the second element is -identical to the address, the first element of the list. -.RS -.PP -For server sockets this option returns a list of a multiple of three -elements each group of which have the same meaning as described -above. The list contains more than one group when the server socket -was created without \fB\-myaddr\fR or with the argument to -\fB\-myaddr\fR being a domain name that resolves multiple IP addresses -that are local to the invoking host. -.RE +This option returns a list of three elements, the address, the host name +and the port number for the socket. If the host name cannot be computed, +the second element is identical to the address, the first element of the +list. .TP \fB\-peername\fR -. This option is not supported by server sockets. For client and accepted sockets, this option returns a list of three elements; these are the address, the host name and the port to which the peer socket is connected or bound. If the host name cannot be computed, the second element of the list is identical to the address, its first element. -.TP -\fB\-connecting\fR -. -This option is not supported by server sockets. For client sockets, this option returns 1 if an asyncroneous connect is still in progress, 0 otherwise. .PP .SH "EXAMPLES" -.PP Here is a very simple time server: -.PP .CS -proc Server {startTime channel clientaddr clientport} { - puts "Connection from $clientaddr registered" - set now [clock seconds] - puts $channel [clock format $now] - puts $channel "[expr {$now - $startTime}] since start" - close $channel +proc Server {channel clientaddr clientport} { + puts "Connection from $clientaddr registered" + puts $channel [clock format [clock seconds]] + close $channel } -\fBsocket -server\fR [list Server [clock seconds]] 9900 +\fBsocket\fR -server Server 9900 vwait forever .CE .PP -And here is the corresponding client to talk to the server and extract -some information: -.PP +And here is the corresponding client to talk to the server: .CS set server localhost set sockChan [\fBsocket\fR $server 9900] -gets $sockChan line1 -gets $sockChan line2 +gets $sockChan line close $sockChan -puts "The time on $server is $line1" -puts "That is [lindex $line2 0]s since the server started" +puts "The time on $server is $line" .CE -.SH "HISTORY" -Support for IPv6 was added in Tcl 8.6. + .SH "SEE ALSO" -chan(n), flush(n), open(n), read(n) +fconfigure(n), flush(n), open(n), read(n) + .SH KEYWORDS -asynchronous I/O, bind, channel, connection, domain name, host, network address, socket, tcp -'\" Local Variables: -'\" mode: nroff -'\" End: +bind, channel, connection, domain name, host, network address, socket, tcp Index: doc/source.n ================================================================== --- doc/source.n +++ doc/source.n @@ -3,21 +3,23 @@ '\" Copyright (c) 1994-1996 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 source n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME source \- Evaluate a file or resource as a Tcl script .SH SYNOPSIS \fBsource \fIfileName\fR .sp +.VS 8.5 \fBsource\fR \fB\-encoding \fIencodingName fileName\fR +.VE 8.5 .BE .SH DESCRIPTION .PP This command takes the contents of the specified file or resource and passes it to the Tcl interpreter as a text script. The return @@ -41,35 +43,29 @@ 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). +A leading BOM (Byte order mark) contained in the file is ignored for unicode encodings (utf-8, unicode). .PP +.VS 8.5 The \fB\-encoding\fR option is used to specify the encoding of the data stored in \fIfileName\fR. When the \fB\-encoding\fR option -is omitted, the utf-8 encoding is assumed. +is omitted, the system encoding is assumed. +.VE 8.5 .SH EXAMPLE -.PP Run the script in the file \fBfoo.tcl\fR and then the script in the file \fBbar.tcl\fR: -.PP .CS \fBsource\fR foo.tcl \fBsource\fR bar.tcl .CE -.PP Alternatively: -.PP .CS foreach scriptFile {foo.tcl bar.tcl} { - \fBsource\fR $scriptFile + \fBsource\fR $scriptFile } .CE .SH "SEE ALSO" file(n), cd(n), encoding(n), info(n) .SH KEYWORDS file, script -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/split.n ================================================================== --- doc/split.n +++ doc/split.n @@ -2,20 +2,21 @@ '\" 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 split n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME split \- Split a string into a proper Tcl list .SH SYNOPSIS \fBsplit \fIstring \fR?\fIsplitChars\fR? .BE + .SH DESCRIPTION .PP Returns a list created by splitting \fIstring\fR at each character that is in the \fIsplitChars\fR argument. Each element of the result list will consist of the @@ -26,45 +27,38 @@ character of \fIstring\fR is in \fIsplitChars\fR. If \fIsplitChars\fR is an empty string then each character of \fIstring\fR becomes a separate element of the result list. \fISplitChars\fR defaults to the standard white-space characters. .SH EXAMPLES -.PP Divide up a USENET group name into its hierarchical components: -.PP .CS -\fBsplit\fR "comp.lang.tcl" . - \fI\(-> comp lang tcl\fR +\fBsplit\fR "comp.lang.tcl.announce" . + \fI\(-> comp lang tcl announce\fR .CE .PP See how the \fBsplit\fR command splits on \fIevery\fR character in \fIsplitChars\fR, which can result in information loss if you are not careful: -.PP .CS \fBsplit\fR "alpha beta gamma" "temp" \fI\(-> al {ha b} {} {a ga} {} a\fR .CE .PP Extract the list words from a string that is not a well-formed list: -.PP .CS \fBsplit\fR "Example with {unbalanced brace character" \fI\(-> Example with \e{unbalanced brace character\fR .CE .PP Split a string into its constituent characters -.PP .CS \fBsplit\fR "Hello world" {} \fI\(-> H e l l o { } w o r l d\fR .CE .SS "PARSING RECORD-ORIENTED FILES" -.PP Parse a Unix /etc/passwd file, which consists of one entry per line, with each line consisting of a colon-separated list of fields: -.PP .CS ## Read the file set fid [open /etc/passwd] set content [read $fid] close $fid @@ -73,21 +67,20 @@ set records [\fBsplit\fR $content "\en"] ## Iterate over the records foreach rec $records { - ## Split into fields on colons - set fields [\fBsplit\fR $rec ":"] + ## Split into fields on colons + set fields [\fBsplit\fR $rec ":"] - ## Assign fields to variables and print some out... - lassign $fields \e - userName password uid grp longName homeDir shell - puts "$longName uses [file tail $shell] for a login shell" + ## Assign fields to variables and print some out... + lassign $fields \e + userName password uid grp longName homeDir shell + puts "$longName uses [file tail $shell] for a login shell" } .CE + .SH "SEE ALSO" join(n), list(n), string(n) + .SH KEYWORDS list, split, string -'\" Local Variables: -'\" mode: nroff -'\" End: Index: doc/string.n ================================================================== --- doc/string.n +++ doc/string.n @@ -2,114 +2,118 @@ .\" 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 string n 8.1 Tcl "Tcl Built-In Commands" .so man.macros .BS .\" Note: do not modify the .SH NAME line immediately below! .SH NAME string \- Manipulate strings .SH SYNOPSIS -\fBstring \fIoption arg \fR?\fIarg ...\fR? +\fBstring \fIoption arg \fR?\fIarg ...?\fR .BE + .SH DESCRIPTION .PP Performs one of several string operations, depending on \fIoption\fR. The legal \fIoption\fRs (which may be abbreviated) are: .TP -\fBstring cat\fR ?\fIstring1\fR? ?\fIstring2...\fR? -. -Concatenate the given \fIstring\fRs just like placing them directly -next to each other and return the resulting compound string. If no -\fIstring\fRs are present, the result is an empty string. -.RS -.PP -This primitive is occasionally handier than juxtaposition of strings -when mixed quoting is wanted, or when the aim is to return the result -of a concatenation without resorting to \fBreturn\fR \fB\-level 0\fR, -and is more efficient than building a list of arguments and using -\fBjoin\fR with an empty join string. -.RE -.TP -\fBstring compare\fR ?\fB\-nocase\fR? ?\fB\-length\fI length\fR? \fIstring1 string2\fR -. +\fBstring compare\fR ?\fB\-nocase\fR? ?\fB\-length int\fR? \fIstring1 string2\fR Perform a character-by-character comparison of strings \fIstring1\fR and \fIstring2\fR. Returns \-1, 0, or 1, depending on whether \fIstring1\fR is lexicographically less than, equal to, or greater than \fIstring2\fR. If \fB\-length\fR is specified, then only the first \fIlength\fR characters are used in the comparison. If \fB\-length\fR is negative, it is ignored. If \fB\-nocase\fR is specified, then the strings are compared in a case-insensitive manner. .TP -\fBstring equal\fR ?\fB\-nocase\fR? ?\fB\-length\fI length\fR? \fIstring1 string2\fR -. +\fBstring equal\fR ?\fB\-nocase\fR? ?\fB\-length int\fR? \fIstring1 string2\fR Perform a character-by-character comparison of strings \fIstring1\fR and \fIstring2\fR. Returns 1 if \fIstring1\fR and \fIstring2\fR are identical, or 0 when not. If \fB\-length\fR is specified, then only the first \fIlength\fR characters are used in the comparison. If \fB\-length\fR is negative, it is ignored. If \fB\-nocase\fR is specified, then the strings are compared in a case-insensitive manner. .TP \fBstring first \fIneedleString haystackString\fR ?\fIstartIndex\fR? -. Search \fIhaystackString\fR for a sequence of characters that exactly match the characters in \fIneedleString\fR. If found, return the index of the first character in the first such match within \fIhaystackString\fR. If not found, return \-1. If \fIstartIndex\fR is specified (in any of the -forms described in \fBSTRING INDICES\fR), then the search is +forms accepted by the \fBindex\fR method), then the search is constrained to start with the character in \fIhaystackString\fR specified by the index. For example, .RS -.PP .CS \fBstring first a 0a23456789abcdef 5\fR .CE -.PP will return \fB10\fR, but -.PP .CS \fBstring first a 0123456789abcdef 11\fR .CE -.PP will return \fB\-1\fR. .RE .TP \fBstring index \fIstring charIndex\fR -. Returns the \fIcharIndex\fR'th character of the \fIstring\fR argument. A \fIcharIndex\fR of 0 corresponds to the first character of the -string. \fIcharIndex\fR may be specified as described in the -\fBSTRING INDICES\fR section. +string. \fIcharIndex\fR may be specified as follows: +.VS 8.5 .RS +.IP \fIinteger\fR 10 +For any index value that passes \fBstring is integer -strict\fR, +the char specified at this integral index +(e.g. \fB2\fR would refer to the +.QW c +in +.QW abcd ). +.IP \fBend\fR 10 +The last char of the string +(e.g. \fBend\fR would refer to the +.QW d +in +.QW abcd ). +.IP \fBend\fR\-\fIN\fR 10 +The last char of the string minus the specified integer offset \fIN\fR +(e.g. \fBend\fR\-1 would refer to the +.QW c +in +.QW abcd ). +.IP \fBend\fR+\fIN\fR 10 +The last char of the string plus the specified integer offset \fIN\fR +(e.g. \fBend\fR+\-1 would refer to the +.QW c +in +.QW abcd ). +.IP \fIM\fR+\fIN\fR 10 +The char specified at the integral index that is the sum of +integer values \fIM\fR and \fIN\fR +(e.g. \fB1+1\fR would refer to the +.QW c +in +.QW abcd ). +.IP \fIM\fR\-\fIN\fR 10 +The char specified at the integral index that is the difference of +integer values \fIM\fR and \fIN\fR +(e.g. \fB2\-1\fR would refer to the +.QW b +in +.QW abcd ). +.PP +In the specifications above, the integer value \fIM\fR contains no +trailing whitespace and the integer value \fIN\fR contains no +leading whitespace. .PP If \fIcharIndex\fR is less than 0 or greater than or equal to the length of the string then this command returns an empty string. .RE -.TP -\fBstring insert \fIstring index insertString\fR -.VS "TIP 504" -Returns a copy of \fIstring\fR with \fIinsertString\fR inserted at the -\fIindex\fR'th character. The \fIindex\fR may be specified as described in the -\fBSTRING INDICES\fR section. -.RS -.PP -If \fIindex\fR is start-relative, the first character inserted in the returned -string will be at the specified index. If \fIindex\fR is end-relative, the last -character inserted in the returned string will be at the specified index. -.PP -If \fIindex\fR is at or before the start of \fIstring\fR (e.g., \fIindex\fR is -\fB0\fR), \fIinsertString\fR is prepended to \fIstring\fR. If \fIindex\fR is at -or after the end of \fIstring\fR (e.g., \fIindex\fR is \fBend\fR), -\fIinsertString\fR is appended to \fIstring\fR. -.RE -.VE "TIP 504" +.VE .TP \fBstring is \fIclass\fR ?\fB\-strict\fR? ?\fB\-failindex \fIvarname\fR? \fIstring\fR -. Returns 1 if \fIstring\fR is a valid member of the specified character class, otherwise returns 0. If \fB\-strict\fR is specified, then an empty string returns 0, otherwise an empty string will return 1 on any class. If \fB\-failindex\fR is specified, then if the function returns 0, the index in the string where the class was no longer valid @@ -126,28 +130,15 @@ 7\-bit ascii range). .IP \fBboolean\fR 12 Any of the forms allowed to \fBTcl_GetBoolean\fR. .IP \fBcontrol\fR 12 Any Unicode control character. -.IP \fBdict\fR 12 -.VS TIP501 -Any proper dict structure, with optional surrounding whitespace. In -case of improper dict structure, 0 is returned and the \fIvarname\fR -will contain the index of the -.QW element -where the dict parsing fails, or \-1 if this cannot be determined. -.VE TIP501 .IP \fBdigit\fR 12 Any Unicode digit character. Note that this includes characters outside of the [0\-9] range. .IP \fBdouble\fR 12 Any of the forms allowed to \fBTcl_GetDoubleFromObj\fR. -.IP \fBentier\fR 12 -. -Any of the valid string formats for an integer value of arbitrary size -in Tcl, with optional surrounding whitespace. The formats accepted are -exactly those accepted by the C routine \fBTcl_GetBignumFromObj\fR. .IP \fBfalse\fR 12 Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is false. .IP \fBgraph\fR 12 Any Unicode printing character, except space. @@ -166,22 +157,23 @@ .IP \fBprint\fR 12 Any Unicode printing character, including space. .IP \fBpunct\fR 12 Any Unicode punctuation character. .IP \fBspace\fR 12 -Any Unicode whitespace character, mongolian vowel separator -(U+180e), zero width space (U+200b), word joiner (U+2060) or -zero width no-break space (U+feff) (=BOM). +Any Unicode whitespace character or mongolian vowel separator (U+180e), +but not NEL/Next Line (U+0085). .IP \fBtrue\fR 12 Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is true. .IP \fBupper\fR 12 Any upper case alphabet character in the Unicode character set. +.VS 8.5 .IP \fBwideinteger\fR 12 Any of the valid forms for a wide integer in Tcl, with optional surrounding whitespace. In case of overflow in the value, 0 is returned and the \fIvarname\fR will contain \-1. +.VE 8.5 .IP \fBwordchar\fR 12 Any Unicode word character. That is any alphanumeric character, and any Unicode connector punctuation characters (e.g. underscore). .IP \fBxdigit\fR 12 Any hexadecimal digit character ([0\-9A\-Fa\-f]). @@ -190,43 +182,36 @@ function will return 0, then the \fIvarname\fR will always be set to 0, due to the varied nature of a valid boolean value. .RE .TP \fBstring last \fIneedleString haystackString\fR ?\fIlastIndex\fR? -. Search \fIhaystackString\fR for a sequence of characters that exactly match the characters in \fIneedleString\fR. If found, return the index of the first character in the last such match within \fIhaystackString\fR. If there is no match, then return \-1. If \fIlastIndex\fR is specified (in any -of the forms described in \fBSTRING INDICES\fR), then only the +of the forms accepted by the \fBindex\fR method), then only the characters in \fIhaystackString\fR at or before the specified \fIlastIndex\fR will be considered by the search. For example, .RS -.PP .CS \fBstring last a 0a23456789abcdef 15\fR .CE -.PP will return \fB10\fR, but -.PP .CS \fBstring last a 0a23456789abcdef 9\fR .CE -.PP will return \fB1\fR. .RE .TP \fBstring length \fIstring\fR -. Returns a decimal string giving the number of characters in \fIstring\fR. Note that this is not necessarily the same as the -number of bytes used to store the string. If the value is a -byte array value (such as those returned from reading a binary encoded -channel), then this will return the actual byte length of the value. +number of bytes used to store the string. If the object is a +ByteArray object (such as those returned from reading a binary encoded +channel), then this will return the actual byte length of the object. .TP \fBstring map\fR ?\fB\-nocase\fR? \fImapping string\fR -. Replaces substrings in \fIstring\fR based on the key-value pairs in \fImapping\fR. \fImapping\fR is a list of \fIkey value key value ...\fR as in the form returned by \fBarray get\fR. Each instance of a key in the string will be replaced with its corresponding value. If \fB\-nocase\fR is specified, then matching is done without regard to @@ -234,30 +219,25 @@ characters. Replacement is done in an ordered manner, so the key appearing first in the list will be checked first, and so on. \fIstring\fR is only iterated over once, so earlier key replacements will have no affect for later key matches. For example, .RS -.PP .CS \fBstring map {abc 1 ab 2 a 3 1 0} 1abcaababcabababc\fR .CE -.PP will return the string \fB01321221\fR. .PP Note that if an earlier \fIkey\fR is a prefix of a later one, it will completely mask the later one. So if the previous example is reordered like this, -.PP .CS \fBstring map {1 0 ab 2 a 3 abc 1} 1abcaababcabababc\fR .CE -.PP it will return the string \fB02c322c222c\fR. .RE .TP \fBstring match\fR ?\fB\-nocase\fR? \fIpattern\fR \fIstring\fR -. See if \fIpattern\fR matches \fIstring\fR; return 1 if it does, 0 if it does not. If \fB\-nocase\fR is specified, then the pattern attempts to match against the string in a case insensitive manner. For the two strings to match, their contents must be identical except that the following special sequences may appear in \fIpattern\fR: @@ -287,226 +267,133 @@ the special interpretation of the characters \fB*?[]\e\fR in \fIpattern\fR. .RE .TP \fBstring range \fIstring first last\fR -. Returns a range of consecutive characters from \fIstring\fR, starting with the character whose index is \fIfirst\fR and ending with the -character whose index is \fIlast\fR (using the forms described in -\fBSTRING INDICES\fR). An index of \fB0\fR refers to the first -character of the string; an index of \fBend\fR refers to last +character whose index is \fIlast\fR. An index of 0 refers to the first character of the string. \fIfirst\fR and \fIlast\fR may be specified as for the \fBindex\fR method. If \fIfirst\fR is less than zero then it is treated as if it were zero, and if \fIlast\fR is greater than or equal to the length of the string then it is treated as if it were \fBend\fR. If \fIfirst\fR is greater than \fIlast\fR then an empty string is returned. .TP \fBstring repeat \fIstring count\fR -. -Returns a string consisting of \fIstring\fR concatenated with itself -\fIcount\fR times. If \fIcount\fR is 0, the empty string will be -returned. +Returns \fIstring\fR repeated \fIcount\fR number of times. .TP \fBstring replace \fIstring first last\fR ?\fInewstring\fR? -. Removes a range of consecutive characters from \fIstring\fR, starting with the character whose index is \fIfirst\fR and ending with the -character whose index is \fIlast\fR (using the forms described in -\fBSTRING INDICES\fR). An index of 0 refers to the +character whose index is \fIlast\fR. An index of 0 refers to the first character of the string. \fIFirst\fR and \fIlast\fR may be specified as for the \fBindex\fR method. If \fInewstring\fR is specified, then it is placed in the removed character range. If \fIfirst\fR is less than zero then it is treated as if it were zero, and if \fIlast\fR is greater than or equal to the length of the string then it is treated as if it were \fBend\fR. If \fIfirst\fR is greater than \fIlast\fR or the length of the initial string, or \fIlast\fR is less than 0, then the initial string is returned untouched. +.VS 8.5 .TP \fBstring reverse \fIstring\fR -. Returns a string that is the same length as \fIstring\fR but with its characters in the reverse order. +.VE 8.5 .TP \fBstring tolower \fIstring\fR ?\fIfirst\fR? ?\fIlast\fR? -. Returns a value equal to \fIstring\fR except that all upper (or title) case letters have been converted to lower case. If \fIfirst\fR is specified, it refers to the first char index in the string to start modifying. If \fIlast\fR is specified, it refers to the char index in the string to stop at (inclusive). \fIfirst\fR and \fIlast\fR may be -specified using the forms described in \fBSTRING INDICES\fR. +specified as for the \fBindex\fR method. .TP \fBstring totitle \fIstring\fR ?\fIfirst\fR? ?\fIlast\fR? -. Returns a value equal to \fIstring\fR except that the first character in \fIstring\fR is converted to its Unicode title case variant (or upper case if there is no title case variant) and the rest of the string is converted to lower case. If \fIfirst\fR is specified, it refers to the first char index in the string to start modifying. If \fIlast\fR is specified, it refers to the char index in the string to -stop at (inclusive). \fIfirst\fR and \fIlast\fR may be specified -using the forms described in \fBSTRING INDICES\fR. +stop at (inclusive). \fIfirst\fR and \fIlast\fR may be specified as +for the \fBindex\fR method. .TP \fBstring toupper \fIstring\fR ?\fIfirst\fR? ?\fIlast\fR? -. Returns a value equal to \fIstring\fR except that all lower (or title) case letters have been converted to upper case. If \fIfirst\fR is specified, it refers to the first char index in the string to start modifying. If \fIlast\fR is specified, it refers to the char index in the string to stop at (inclusive). \fIfirst\fR and \fIlast\fR may be -specified using the forms described in \fBSTRING INDICES\fR. +specified as for the \fBindex\fR method. .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"). +\fIchars\fR is not specified then white space is removed (spaces, +tabs, newlines, and carriage returns). .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"). +\fIchars\fR is not specified then white space is removed (spaces, +tabs, newlines, and carriage returns). .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" +\fIchars\fR is not specified then white space is removed (spaces, +tabs, newlines, and carriage returns). +.SH "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 -. Returns a decimal string giving the number of bytes used to represent -\fIstring\fR in memory when encoded as Tcl's internal modified UTF\-8; -Tcl may use other encodings for \fIstring\fR as well, and does not -guarantee to only use a single encoding for a particular \fIstring\fR. -Because UTF\-8 uses a variable number of bytes to represent Unicode -characters, the byte length will not be the same as the character -length in general. The cases where a script cares about the byte -length are rare. -.RS -.PP -In almost all cases, you should use the +\fIstring\fR in memory. Because UTF\-8 uses one to three bytes to +represent Unicode characters, the byte length will not be the same as +the character length in general. The cases where a script cares about +the byte length are rare. In almost all cases, you should use the \fBstring length\fR operation (including determining the length of a -Tcl byte array value). Refer to the \fBTcl_NumUtfChars\fR manual +Tcl ByteArray object). Refer to the \fBTcl_NumUtfChars\fR manual entry for more details on the UTF\-8 representation. -.PP -Formally, the \fBstring bytelength\fR operation returns the content of -the \fIlength\fR field of the \fBTcl_Obj\fR structure, after calling -\fBTcl_GetString\fR to ensure that the \fIbytes\fR field is populated. -This is highly unlikely to be useful to Tcl scripts, as Tcl's internal -encoding is not strict UTF\-8, but rather a modified CESU\-8 with a -denormalized NUL (identical to that used in a number of places by -Java's serialization mechanism) to enable basic processing with -non-Unicode-aware C functions. As this representation should only -ever be used by Tcl's implementation, the number of bytes used to -store the representation is of very low value (except to C extension -code, which has direct access for the purpose of memory management, -etc.) -.PP -\fICompatibility note:\fR it is likely that this subcommand will be -withdrawn in a future version of Tcl. It is better to use the -\fBencoding convertto\fR command to convert a string to a known -encoding and then apply \fBstring length\fR to that. -.PP -.CS -\fBstring length\fR [encoding convertto utf-8 $theString] -.CE -.RE .TP \fBstring wordend \fIstring charIndex\fR -. Returns the index of the character just after the last one in the word containing character \fIcharIndex\fR of \fIstring\fR. \fIcharIndex\fR -may be specified using the forms in \fBSTRING INDICES\fR. A word is +may be specified as for the \fBindex\fR method. A word is considered to be any contiguous range of alphanumeric (Unicode letters or decimal digits) or underscore (Unicode connector punctuation) characters, or any single character other than these. .TP \fBstring wordstart \fIstring charIndex\fR -. -Returns the index of the first character in the word containing character -\fIcharIndex\fR of \fIstring\fR. \fIcharIndex\fR may be specified using the -forms in \fBSTRING INDICES\fR. A word is considered to be any contiguous -range of alphanumeric (Unicode letters or decimal digits) or underscore -(Unicode connector punctuation) characters, or any single character other than -these. -.SH "STRING INDICES" -.PP -When referring to indices into a string (e.g., for \fBstring index\fR -or \fBstring range\fR) the following formats are supported: -.IP \fIinteger\fR 10 -For any index value that passes \fBstring is integer \-strict\fR, -the char specified at this integral index (e.g., \fB2\fR would refer to the -.QW c -in -.QW abcd ). -.IP \fBend\fR 10 -The last char of the string (e.g., \fBend\fR would refer to the -.QW d -in -.QW abcd ). -.IP \fBend\-\fIN\fR 10 -The last char of the string minus the specified integer offset \fIN\fR (e.g., -.QW \fBend\-1\fR -would refer to the -.QW c -in -.QW abcd ). -.IP \fBend+\fIN\fR 10 -The last char of the string plus the specified integer offset \fIN\fR (e.g., -.QW \fBend+\-1\fR -would refer to the -.QW c -in -.QW abcd ). -.IP \fIM\fB+\fIN\fR 10 -The char specified at the integral index that is the sum of -integer values \fIM\fR and \fIN\fR (e.g., -.QW \fB1+1\fR -would refer to the -.QW c -in -.QW abcd ). -.IP \fIM\fB\-\fIN\fR 10 -The char specified at the integral index that is the difference of -integer values \fIM\fR and \fIN\fR (e.g., -.QW \fB2\-1\fR -would refer to the -.QW b -in -.QW abcd ). -.PP -In the specifications above, the integer value \fIM\fR contains no -trailing whitespace and the integer value \fIN\fR contains no -leading whitespace. +Returns the index of the first character in the word containing +character \fIcharIndex\fR of \fIstring\fR. \fIcharIndex\fR may be +specified as for the \fBindex\fR method. A word is considered to be any +contiguous range of alphanumeric (Unicode letters or decimal digits) +or underscore (Unicode connector punctuation) characters, or any +single character other than these. .SH EXAMPLE -.PP Test if the string in the variable \fIstring\fR is a proper non-empty prefix of the string \fBfoobar\fR. -.PP .CS set length [\fBstring length\fR $string] if {$length == 0} { set isPrefix 0 } else { - set isPrefix [\fBstring equal\fR \-length $length $string "foobar"] + 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, +case conversion, compare, index, match, pattern, string, word, equal, ctype, character, reverse + .\" Local Variables: .\" mode: nroff .\" End: Index: doc/subst.n ================================================================== --- doc/subst.n +++ doc/subst.n @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 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 subst n 7.4 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -31,11 +31,11 @@ are not performed. For example, if \fB\-nocommands\fR is specified, command substitution is not performed: open and close brackets are treated as ordinary characters with no special interpretation. .PP -Note that the substitution of one kind can include substitution of +Note that the substitution of one kind can include substitution of other kinds. For example, even when the \fB\-novariables\fR option is specified, command substitution is performed without restriction. This means that any variable substitution necessary to complete the command substitution will still take place. Likewise, any command substitution necessary to complete a variable substitution will @@ -60,105 +60,86 @@ .SH EXAMPLES .PP When it performs its substitutions, \fIsubst\fR does not give any special treatment to double quotes or curly braces (except within command substitutions) so the script -.PP .CS set a 44 \fBsubst\fR {xyz {$a}} .CE -.PP returns .QW "\fBxyz {44}\fR" , not .QW "\fBxyz {$a}\fR" and the script -.PP .CS set a "p\e} q \e{r" \fBsubst\fR {xyz {$a}} .CE -.PP returns .QW "\fBxyz {p} q {r}\fR" , not .QW "\fBxyz {p\e} q \e{r}\fR". .PP When command substitution is performed, it includes any variable substitution necessary to evaluate the script. -.PP .CS set a 44 \fBsubst\fR -novariables {$a [format $a]} .CE -.PP returns .QW "\fB$a 44\fR" , not .QW "\fB$a $a\fR" . Similarly, when variable substitution is performed, it includes any command substitution necessary to retrieve the value of the variable. -.PP .CS proc b {} {return c} array set a {c c [b] tricky} \fBsubst\fR -nocommands {[b] $a([b])} .CE -.PP returns .QW "\fB[b] c\fR" , not .QW "\fB[b] tricky\fR" . .PP The continue and break exceptions allow command substitutions to prevent substitution of the rest of the command substitution and the rest of \fIstring\fR respectively, giving script authors more options when processing text using \fIsubst\fR. For example, the script -.PP .CS \fBsubst\fR {abc,[break],def} .CE -.PP returns .QW \fBabc,\fR , not .QW \fBabc,,def\fR and the script -.PP .CS \fBsubst\fR {abc,[continue;expr {1+2}],def} .CE -.PP returns .QW \fBabc,,def\fR , not .QW \fBabc,3,def\fR . .PP Other exceptional return codes substitute the returned value -.PP .CS \fBsubst\fR {abc,[return foo;expr {1+2}],def} .CE -.PP returns .QW \fBabc,foo,def\fR , not .QW \fBabc,3,def\fR and -.PP .CS \fBsubst\fR {abc,[return -code 10 foo;expr {1+2}],def} .CE -.PP also returns .QW \fBabc,foo,def\fR , not .QW \fBabc,3,def\fR . .SH "SEE ALSO" Tcl(n), eval(n), break(n), continue(n) .SH KEYWORDS -backslash substitution, command substitution, quoting, substitution, variable substitution -.\" Local Variables: -.\" mode: nroff -.\" End: +backslash substitution, command substitution, variable substitution Index: doc/switch.n ================================================================== --- doc/switch.n +++ doc/switch.n @@ -2,11 +2,11 @@ '\" 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 switch n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -29,37 +29,36 @@ matches \fIstring\fR and no default is given, then the \fBswitch\fR command returns an empty string. .PP If the initial arguments to \fBswitch\fR start with \fB\-\fR then they are treated as options +.VS 8.5 unless there are exactly two arguments to \fBswitch\fR (in which case the first must the \fIstring\fR and the second must be the \fIpattern\fR/\fIbody\fR list). +.VE 8.5 The following options are currently supported: .TP 10 \fB\-exact\fR -. Use exact matching when comparing \fIstring\fR to a pattern. This is the default. .TP 10 \fB\-glob\fR -. When matching \fIstring\fR to the patterns, use glob-style matching (i.e. the same as implemented by the \fBstring match\fR command). .TP 10 \fB\-regexp\fR -. When matching \fIstring\fR to the patterns, use regular expression matching (as described in the \fBre_syntax\fR reference page). +'\" Options defined by TIP#75 +.VS 8.5 .TP 10 \fB\-nocase\fR -. Causes comparisons to be handled in a case-insensitive manner. .TP 10 \fB\-matchvar\fR \fIvarName\fR -. This option (only legal when \fB\-regexp\fR is also specified) specifies the name of a variable into which the list of matches found by the regular expression engine will be written. The first element of the list written will be the overall substring of the input string (i.e. the \fIstring\fR argument to \fBswitch\fR) matched, the @@ -68,11 +67,10 @@ on. When a \fBdefault\fR branch is taken, the variable will have the empty list written to it. This option may be specified at the same time as the \fB\-indexvar\fR option. .TP 10 \fB\-indexvar\fR \fIvarName\fR -. This option (only legal when \fB\-regexp\fR is also specified) specifies the name of a variable into which the list of indices referring to matching substrings found by the regular expression engine will be written. The first element of the list written will be a two-element list specifying the @@ -83,17 +81,19 @@ obtain. Similarly, the second element of the list refers to the first capturing parenthesis in the regular expression that matched, and so on. When a \fBdefault\fR branch is taken, the variable will have the empty list written to it. This option may be specified at the same time as the \fB\-matchvar\fR option. +.VE 8.5 .TP 10 \fB\-\|\-\fR -. Marks the end of options. The argument following this one will be treated as \fIstring\fR even if it starts with a \fB\-\fR. +.VS 8.5 This is not required when the matching patterns and bodies are grouped together in a single argument. +.VE 8.5 .PP Two syntaxes are provided for the \fIpattern\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. @@ -120,67 +120,64 @@ .PP Beware of how you place comments in \fBswitch\fR commands. Comments should only be placed \fBinside\fR the execution body of one of the patterns, and not intermingled with the patterns. .SH "EXAMPLES" -.PP The \fBswitch\fR command can match against variables and not just literals, as shown here (the result is \fI2\fR): -.PP .CS set foo "abc" \fBswitch\fR abc a \- b {expr {1}} $foo {expr {2}} default {expr {3}} .CE .PP Using glob matching and the fall-through body is an alternative to writing regular expressions with alternations, as can be seen here (this returns \fI1\fR): -.PP .CS \fBswitch\fR \-glob aaab { - a*b \- - b {expr {1}} - a* {expr {2}} - default {expr {3}} + a*b \- + b {expr {1}} + a* {expr {2}} + default {expr {3}} } .CE .PP Whenever nothing matches, the \fBdefault\fR clause (which must be last) is taken. This example has a result of \fI3\fR: -.PP -.CS -\fBswitch\fR xyz { - a \- - b { - # Correct Comment Placement - expr {1} - } - c { - expr {2} - } - default { - expr {3} - } -} -.CE -.PP -When matching against regular expressions, information about what -exactly matched is easily obtained using the \fB\-matchvar\fR option: -.PP -.CS -\fBswitch\fR \-regexp \-matchvar foo \-\- $bar { - a(b*)c { - puts "Found [string length [lindex $foo 1]] 'b's" - } - d(e*)f(g*)h { - puts "Found [string length [lindex $foo 1]] 'e's and\e - [string length [lindex $foo 2]] 'g's" - } -} -.CE +.CS +\fBswitch\fR xyz { + a \- + b { + # Correct Comment Placement + expr {1} + } + c { + expr {2} + } + default { + expr {3} + } +} +.CE +.PP +.VS 8.5 +When matching against regular expressions, information about what +exactly matched is easily obtained using the \fB\-matchvar\fR option: +.CS +\fBswitch\fR \-regexp \-matchvar foo \-\- $bar { + a(b*)c { + puts "Found [string length [lindex $foo 1]] 'b's" + } + d(e*)f(g*)h { + puts "Found [string length [lindex $foo 1]] 'e's and\e + [string length [lindex $foo 2]] 'g's" + } +} +.CE +.VE 8.5 .SH "SEE ALSO" for(n), if(n), regexp(n) .SH KEYWORDS switch, match, regular expression .\" Local Variables: .\" mode: nroff .\" End: DELETED doc/tailcall.n Index: doc/tailcall.n ================================================================== --- doc/tailcall.n +++ /dev/null @@ -1,69 +0,0 @@ -'\" -'\" 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 tailcall n 8.6 Tcl "Tcl Built-In Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -tailcall \- Replace the current procedure with another command -.SH SYNOPSIS -\fBtailcall \fIcommand\fR ?\fIarg ...\fR? -.BE -.SH DESCRIPTION -.PP -The \fBtailcall\fR command replaces the currently executing procedure, lambda -application, or method with another command. The \fIcommand\fR, which will -have \fIarg ...\fR passed as arguments if they are supplied, will be looked up -in the current namespace context, not in the caller's. Apart from that -difference in resolution, it is equivalent to: -.PP -.CS -return [uplevel 1 [list \fIcommand\fR ?\fIarg ...\fR?]] -.CE -.PP -This command may not be invoked from within an \fBuplevel\fR into a procedure -or inside a \fBcatch\fR inside a procedure or lambda. -'\" TODO: sort out the mess with the [try] command! -.SH EXAMPLE -.PP -Compute the factorial of a number. -.PP -.CS -proc factorial {n {accum 1}} { - if {$n < 2} { - return $accum - } - \fBtailcall\fR factorial [expr {$n - 1}] [expr {$accum * $n}] -} -.CE -.PP -Print the elements of a list with alternating lines having different -indentations. -.PP -.CS -proc printList {theList} { - if {[llength $theList]} { - puts "> [lindex $theList 0]" - \fBtailcall\fR printList2 [lrange $theList 1 end] - } -} -proc printList2 {theList} { - if {[llength $theList]} { - puts "< [lindex $theList 0]" - \fBtailcall\fR printList [lrange $theList 1 end] - } -} -.CE -.SH "SEE ALSO" -apply(n), proc(n), uplevel(n) -.SH KEYWORDS -call, recursion, tail recursion -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/tclsh.1 ================================================================== --- doc/tclsh.1 +++ doc/tclsh.1 @@ -2,20 +2,21 @@ '\" 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 tclsh 1 "" Tcl "Tcl Applications" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tclsh \- Simple shell containing Tcl interpreter .SH SYNOPSIS -\fBtclsh\fR ?\fB\-encoding \fIname\fR? ?\fIfileName arg arg ...\fR? +\fBtclsh\fR ?-encoding \fIname\fR? ?\fIfileName arg arg ...\fR? .BE + .SH DESCRIPTION .PP \fBTclsh\fR is a shell-like application that reads Tcl commands from its standard input or from a file and evaluates them. If invoked with no arguments then it runs interactively, reading @@ -25,15 +26,19 @@ reaches end-of-file on its standard input. If there exists a file \fB.tclshrc\fR (or \fBtclshrc.tcl\fR on the Windows platforms) in the home directory of the user, interactive \fBtclsh\fR evaluates the file as a Tcl script just before reading the first command from standard input. + .SH "SCRIPT FILES" .PP +.VS 8.5 If \fBtclsh\fR is invoked with arguments then the first few arguments specify the name of a script file, and, optionally, the encoding of -the text data stored in that script file. Any additional arguments +the text data stored in that script file. +.VE 8.5 +Any additional arguments are made available to the script as variables (see below). Instead of reading commands from standard input \fBtclsh\fR will read Tcl commands from the named file; \fBtclsh\fR will exit when it reaches the end of the file. The end of the file may be marked either by the physical end of @@ -51,15 +56,13 @@ There is no automatic evaluation of \fB.tclshrc\fR when the name of a script file is presented on the \fBtclsh\fR command line, but the script file can always \fBsource\fR it if desired. .PP If you create a Tcl script in a file whose first line is -.PP .CS \fB#!/usr/local/bin/tclsh\fR .CE -.PP then you can invoke the script file directly from your shell if you mark the file as executable. This assumes that \fBtclsh\fR has been installed in the default location in /usr/local/bin; if it is installed somewhere else then you will have to modify the above line to match. @@ -67,17 +70,15 @@ 30 characters in length, so be sure that the \fBtclsh\fR executable can be accessed with a short file name. .PP An even better approach is to start your script files with the following three lines: -.PP .CS \fB#!/bin/sh # the next line restarts using tclsh \e exec tclsh "$0" ${1+"$@"}\fR .CE -.PP This approach has three advantages over the approach in the previous paragraph. First, the location of the \fBtclsh\fR binary does not have to be hard-wired into the script: it can be anywhere in your shell search path. Second, it gets around the 30-character file name limit in the previous approach. @@ -98,61 +99,51 @@ You should note that it is also common practice to install tclsh with its version number as part of the name. This has the advantage of allowing multiple versions of Tcl to exist on the same system at once, but also the disadvantage of making it harder to write scripts that start up uniformly across different versions of Tcl. + .SH "VARIABLES" .PP -\fBTclsh\fR sets the following global Tcl variables in addition to those -created by the Tcl library itself (such as \fBenv\fR, which maps -environment variables such as \fBPATH\fR into Tcl): +\fBTclsh\fR sets the following Tcl variables: .TP 15 \fBargc\fR -. Contains a count of the number of \fIarg\fR arguments (0 if none), not including the name of the script file. .TP 15 \fBargv\fR -. Contains a Tcl list whose elements are the \fIarg\fR arguments, in order, or an empty string if there are no \fIarg\fR arguments. .TP 15 \fBargv0\fR -. Contains \fIfileName\fR if it was specified. Otherwise, contains the name by which \fBtclsh\fR was invoked. .TP 15 \fBtcl_interactive\fR -. Contains 1 if \fBtclsh\fR is running interactively (no \fIfileName\fR was specified and standard input is a terminal-like device), 0 otherwise. + .SH PROMPTS .PP When \fBtclsh\fR is invoked interactively it normally prompts for each command with .QW "\fB% \fR" . -You can change the prompt by setting the global +You can change the prompt by setting the variables \fBtcl_prompt1\fR and \fBtcl_prompt2\fR. If variable \fBtcl_prompt1\fR exists then it must consist of a Tcl script to output a prompt; instead of outputting a prompt \fBtclsh\fR will evaluate the script in \fBtcl_prompt1\fR. The variable \fBtcl_prompt2\fR is used in a similar way when a newline is typed but the current command is not yet complete; if \fBtcl_prompt2\fR is not set then no prompt is output for incomplete commands. + .SH "STANDARD CHANNELS" .PP See \fBTcl_StandardChannels\fR for more explanations. -.SH ZIPVFS -.PP -When a zipfile is concatenated to the end of a \fBtclsh\fR, on -startup the contents of the zip archive will be mounted as the -virtual file system /zvfs. If a top level directory tcl8.6 is -present in the zip archive, it will become the directory loaded -as env(TCL_LIBRARY). If a file named \fBmain.tcl\fR is present -in the top level directory of the zip archive, it will be sourced -instead of the shell's normal command line handing. + .SH "SEE ALSO" -auto_path(n), encoding(n), env(n), fconfigure(n) +encoding(n), fconfigure(n), tclvars(n) + .SH KEYWORDS -application, argument, interpreter, prompt, script file, shell +argument, interpreter, prompt, script file, shell Index: doc/tcltest.n ================================================================== --- doc/tcltest.n +++ doc/tcltest.n @@ -201,11 +201,11 @@ array. Returns an empty string. .RE .TP \fBrunAllTests\fR . -This is a main command meant to run an entire suite of tests, +This is a master command meant to run an entire suite of tests, spanning multiple files and/or directories, as governed by the configurable options of \fBtcltest\fR. See \fBRUNNING ALL TESTS\fR below for a complete description of the many variations possible with \fBrunAllTests\fR. .SS "CONFIGURATION COMMANDS" @@ -802,21 +802,21 @@ be \fBsource\fRd in the caller's context. If it is false, then a copy of \fBinterpreter\fR will be \fBexec\fR'd to evaluate each file. The multi-process operation is useful when testing can cause errors so severe that a process terminates. Although such an error may terminate a child -process evaluating one file, the main process can continue +process evaluating one file, the master process can continue with the rest of the test suite. In multi-process operation, -the configuration of \fBtcltest\fR in the main process is +the configuration of \fBtcltest\fR in the master process is passed to the child processes as command line arguments, with the exception of \fBconfigure \-outfile\fR. The \fBrunAllTests\fR command in the -main process collects all output from the child processes -and collates their results into one main report. Any +master process collects all output from the child processes +and collates their results into one master report. Any reports of individual test failures, or messages requested by a \fBconfigure \-verbose\fR setting are passed directly -on to \fBoutputChannel\fR by the main process. +on to \fBoutputChannel\fR by the master process. .PP After evaluating all selected test files, a summary of the results is printed to \fBoutputChannel\fR. The summary includes the total number of \fBtest\fRs evaluated, broken down into those skipped, those passed, and those failed. @@ -1132,11 +1132,11 @@ in a namespace that is deleted when the test file evaluation is complete. A good namespace to use is a child namespace \fBtest\fR of the namespace of the module you are testing. .PP A test file should also be able to be evaluated directly as a script, -not depending on being called by a main \fBrunAllTests\fR. This +not depending on being called by a master \fBrunAllTests\fR. This means that each test file should process command line arguments to give the tester all the configuration control that \fBtcltest\fR provides. .PP After all \fBtest\fRs in a test file, the command \fBcleanupTests\fR should be called. @@ -1143,11 +1143,11 @@ .IP [7] Here is a sketch of a sample test file illustrating those points: .RS .PP .CS -package require tcltest 2.5 +package require tcltest 2.2 eval \fB::tcltest::configure\fR $argv package require example namespace eval ::example::test { namespace import ::tcltest::* \fBtestConstraint\fR X [expr {...}] @@ -1173,16 +1173,16 @@ basic function of this script is to call \fBrunAllTests\fR after doing any necessary setup. This script is usually named \fBall.tcl\fR because that is the default name used by \fBrunAllTests\fR when combining multiple test suites into one testing run. .IP [8] -Here is a sketch of a sample test suite main script: +Here is a sketch of a sample test suite master script: .RS .PP .CS -package require Tcl 8.6 -package require tcltest 2.5 +package require Tcl 8.4 +package require tcltest 2.2 package require example \fB::tcltest::configure\fR -testdir \e [file dirname [file normalize [info script]]] eval \fB::tcltest::configure\fR $argv \fB::tcltest::runAllTests\fR Index: doc/tclvars.n ================================================================== --- doc/tclvars.n +++ doc/tclvars.n @@ -2,45 +2,25 @@ '\" 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_rcFileName, tcl_traceCompile, tcl_traceExec, tcl_wordchars, tcl_version \- Variables used by Tcl +tclvars \- 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 -\fBauto_path\fR -. -If set, then it must contain a valid Tcl list giving directories to -search during auto-load operations (including for package index -files when using the default \fBpackage unknown\fR handler). -This variable is initialized during startup to contain, in order: -the directories listed in the \fBTCLLIBPATH\fR environment variable, -the directory named by the \fBtcl_library\fR global variable, -the parent directory of \fBtcl_library\fR, -the directories listed in the \fBtcl_pkgPath\fR variable. -Additional locations to look for files and package indices should -normally be added to this variable using \fBlappend\fR. -.RS -.PP -Additional variables relating to package management exist. More -details are listed in the \fBVARIABLES\fR section of the \fBlibrary\fR -manual page. -.RE .TP \fBenv\fR -. This variable is maintained by Tcl as an array whose elements are the environment variables for the process. Reading an element will return the value of the corresponding environment variable. Setting an element of the array will modify the corresponding @@ -92,36 +72,23 @@ .RE .TP \fBenv(TCLLIBPATH)\fR . If set, then it must contain a valid Tcl list giving directories to -search during auto-load operations. Directories must be specified in +search during auto-load operations. Directories must be specified in Tcl format, using .QW / as the path separator, regardless of platform. This variable is only used when initializing the \fBauto_path\fR variable. .TP -\fBenv(TCL_TZ)\fR, \fBenv(TZ)\fR -. -These specify the default timezone used for parsing and formatting times and -dates in the \fBclock\fR command. On many platforms, the TZ environment -variable is set up by the operating system. -.TP -\fBenv(LC_ALL)\fR, \fBenv(LC_MESSAGES)\fR, \fBenv(LANG)\fR -. -These environment variables are used by the \fBmsgcat\fR package to -determine what locale to format messages using. -.TP \fBenv(TCL_INTERP_DEBUG_FRAME)\fR . -If existing, it has the same effect as running \fBinterp debug\fR -\fB{} -frame 1\fR +If existing, it has the same effect as running \fBinterp debug {} -frame 1\fR as the very first command of each new Tcl interpreter. .RE .TP \fBerrorCode\fR -. This variable holds the value of the \fB\-errorcode\fR return option set by the most recent error that occurred in this interpreter. This list value represents additional information about the error in a form that is easy to process with programs. The first element of the list identifies a general class of @@ -147,11 +114,10 @@ Detection of these errors depends in part on the underlying hardware and system libraries. .RE .TP \fBCHILDKILLED\fI pid sigName msg\fR -. This format is used when a child process has been killed because of a signal. The \fIpid\fR element will be the process's identifier (in decimal). The \fIsigName\fR element will be the symbolic name of the signal that caused the process to terminate; it will be one of the names from the include file signal.h, such as \fBSIGPIPE\fR. @@ -159,18 +125,16 @@ describing the signal, such as .QW "write on pipe with no readers" for \fBSIGPIPE\fR. .TP \fBCHILDSTATUS\fI pid code\fR -. This format is used when a child process has exited with a non-zero exit status. The \fIpid\fR element will be the process's identifier (in decimal) and the \fIcode\fR element will be the exit code returned by the process (also in decimal). .TP \fBCHILDSUSP\fI pid sigName msg\fR -. This format is used when a child process has been suspended because of a signal. The \fIpid\fR element will be the process's identifier, in decimal. The \fIsigName\fR element will be the symbolic name of the signal that caused the process to suspend; this will be one of the names from the @@ -179,59 +143,55 @@ describing the signal, such as .QW "background tty read" for \fBSIGTTIN\fR. .TP \fBNONE\fR -. This format is used for errors where no additional information is available for an error besides the message returned with the error. In these cases the \fB\-errorcode\fR return option will consist of a list containing a single element whose contents are \fBNONE\fR. .TP \fBPOSIX \fIerrName msg\fR -. If the first element is \fBPOSIX\fR, then the error occurred during a POSIX kernel call. The \fIerrName\fR element will contain the symbolic name of the error that occurred, such as \fBENOENT\fR; this will be one of the values defined in the include file errno.h. The \fImsg\fR element will be a human-readable message corresponding to \fIerrName\fR, such as .QW "no such file or directory" for the \fBENOENT\fR case. -.TP -\fBTCL\fR ... -. -Indicates some sort of problem generated in relation to Tcl itself, e.g. a -failure to look up a channel or variable. .PP To set the \fB\-errorcode\fR return option, applications should use library procedures such as \fBTcl_SetObjErrorCode\fR, \fBTcl_SetReturnOptions\fR, and \fBTcl_PosixError\fR, or they may invoke the \fB\-errorcode\fR option of the \fBreturn\fR command. If none of these methods for setting the error code has been used, the Tcl interpreter will reset the variable to \fBNONE\fR after the next error. .RE +.\" .TP +.\" \fBTCL\fR ... +.\" . +.\" Indicates some sort of problem generated in relation to Tcl itself, +.\" e.g. a failure to look up a channel or variable. .TP \fBerrorInfo\fR -. This variable holds the value of the \fB\-errorinfo\fR return option set by the most recent error that occurred in this interpreter. This string value will contain one or more lines identifying the Tcl commands and procedures that were being executed when the most recent error occurred. Its contents take the form of a stack trace showing the various nested Tcl commands that had been invoked at the time of the error. .TP \fBtcl_library\fR -. This variable holds the name of a directory containing the system library of Tcl scripts, such as those used for auto-loading. The value of this variable is returned by the \fBinfo library\fR command. -See the \fBlibrary\fR manual entry for details of the facilities +See the \fBlibrary\fR manual entry for details of the facilities provided by the Tcl script library. Normally each application or package will have its own application-specific script library in addition to the Tcl script library; each application should set a global variable with a name like \fB$\fIapp\fB_library\fR (where \fIapp\fR is the application's name) @@ -254,30 +214,27 @@ \fB8.5b3\fR for the third beta release of Tcl 8.5. The value of this variable is returned by the \fBinfo patchlevel\fR command. .TP \fBtcl_pkgPath\fR -. This variable holds a list of directories indicating where packages are normally installed. It is not used on Windows. It typically contains either one or two entries; if it contains two entries, the first is normally a directory for platform-dependent packages (e.g., shared library binaries) and the second is normally a directory for platform-independent packages (e.g., script files). Typically a package is installed as a -subdirectory of one of the entries in the \fBtcl_pkgPath\fR -variable. The directories in the \fBtcl_pkgPath\fR variable are -included by default in the \fBauto_path\fR +subdirectory of one of the entries in \fB$tcl_pkgPath\fR. The directories +in \fB$tcl_pkgPath\fR are included by default in the \fBauto_path\fR variable, so they and their immediate subdirectories are automatically searched for packages during \fBpackage require\fR commands. Note: \fBtcl_pkgPath\fR is not intended to be modified by the application. Its value is added to \fBauto_path\fR at startup; changes to \fBtcl_pkgPath\fR are not reflected in \fBauto_path\fR. If you want Tcl to search additional directories for packages you should add the names of those directories to \fBauto_path\fR, not \fBtcl_pkgPath\fR. .TP \fBtcl_platform\fR -. This is an associative array whose elements contain information about the platform on which the application is running, such as the name of the operating system, its current release number, and the machine's instruction set. The elements listed below will always be defined, but they may have empty strings as values if Tcl could not @@ -285,16 +242,14 @@ and applications may add additional values to the array. The predefined elements are: .RS .TP \fBbyteOrder\fR -. The native byte order of this machine: either \fBlittleEndian\fR or -\fBbigEndian\fR. +\fBbigEndian\fR. .TP \fBdebug\fR -. If this variable exists, then the interpreter was compiled with and linked to a debug-enabled C run-time. This variable will only exist on Windows, so extension writers can specify which package to load depending on the C run-time library that is in use. This is not an indication that this core contains symbols. @@ -303,68 +258,122 @@ . The name of the Tcl language implementation. When the interpreter is first created, this is always set to the string \fBTcl\fR. .TP \fBmachine\fR -. The instruction set executed by this machine, such as \fBintel\fR, \fBPPC\fR, \fB68k\fR, or \fBsun4m\fR. On UNIX machines, this is the value returned by \fBuname -m\fR. .TP -\fBos\fR -. +\fBos\fR The name of the operating system running on this machine, -such as \fBWindows NT\fR or \fBSunOS\fR. +such as \fBWindows 95\fR, \fBWindows NT\fR, or \fBSunOS\fR. On UNIX machines, this is the value returned by \fBuname -s\fR. +On Windows 95 and Windows 98, the value returned will be \fBWindows +95\fR to provide better backwards compatibility to Windows 95; to +distinguish between the two, check the \fBosVersion\fR. .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. +On UNIX machines, this is the value returned by \fBuname -r\fR. On +Windows 95, the version will be 4.0; on Windows 98, the version will +be 4.10. .TP \fBplatform\fR -. Either \fBwindows\fR, or \fBunix\fR. This identifies the general operating environment of the machine. .TP -\fBpointerSize\fR -. -This gives the size of the native-machine pointer in bytes (strictly, it -is same as the result of evaluating \fIsizeof(void*)\fR in C.) -.TP \fBthreaded\fR -. If this variable exists, then the interpreter was compiled with threads enabled. .TP \fBuser\fR -. This identifies the current user based on the login information available on the platform. This value comes from the getuid() and getpwuid() system calls on Unix, 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.) +.TP +\fBpointerSize\fR +This gives the size of the native-machine pointer in bytes (strictly, it +is same as the result of evaluating \fIsizeof(void*)\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. -Setting \fBtcl_traceCompile\fR to 1 generates a one-line summary in \fBstdout\fR +By default, tcl_traceCompile is zero and no information is displayed. +Setting tcl_traceCompile to 1 generates a one-line summary in stdout whenever a procedure or top-level command is compiled. -Setting it to 2 generates a detailed listing in \fBstdout\fR of the +Setting it to 2 generates a detailed listing in stdout of the bytecode instructions emitted during every compilation. This variable is useful in tracking down suspected problems with the Tcl compiler. .PP .RS @@ -371,23 +380,22 @@ This variable and functionality only exist if \fBTCL_COMPILE_DEBUG\fR was defined during Tcl's compilation. .RE .TP \fBtcl_traceExec\fR -. The value of this variable can be set to control how much tracing information is displayed during bytecode execution. -By default, \fBtcl_traceExec\fR is zero and no information is displayed. -Setting \fBtcl_traceExec\fR to 1 generates a one-line trace in \fBstdout\fR +By default, tcl_traceExec is zero and no information is displayed. +Setting tcl_traceExec to 1 generates a one-line trace in stdout on each call to a Tcl procedure. Setting it to 2 generates a line of output whenever any Tcl command is invoked that contains the name of the command and its arguments. Setting it to 3 produces a detailed trace showing the result of executing each bytecode instruction. -Note that when \fBtcl_traceExec\fR is 2 or 3, +Note that when tcl_traceExec is 2 or 3, commands such as \fBset\fR and \fBincr\fR that have been entirely replaced by a sequence of bytecode instructions are not shown. Setting this variable is useful in tracking down suspected problems with the bytecode compiler @@ -397,11 +405,10 @@ This variable and functionality only exist if \fBTCL_COMPILE_DEBUG\fR was defined during Tcl's compilation. .RE .TP \fBtcl_wordchars\fR -. The value of this variable is a regular expression that can be set to control what are considered .QW word characters, for instances like selecting a word by double-clicking in text in Tk. It is platform @@ -408,11 +415,10 @@ dependent. On Windows, it defaults to \fB\eS\fR, meaning anything but a Unicode space character. Otherwise it defaults to \fB\ew\fR, which is any Unicode word character (number, letter, or underscore). .TP \fBtcl_nonwordchars\fR -. The value of this variable is a regular expression that can be set to control what are considered .QW non-word characters, for instances like selecting a word by double-clicking in text in Tk. It is platform @@ -419,82 +425,43 @@ dependent. On Windows, it defaults to \fB\es\fR, meaning any Unicode space character. Otherwise it defaults to \fB\eW\fR, which is anything but a Unicode word character (number, letter, or underscore). .TP \fBtcl_version\fR -. When an interpreter is created Tcl initializes this variable to hold the version number for this version of Tcl in the form \fIx.y\fR. Changes to \fIx\fR represent major changes with probable incompatibilities and changes to \fIy\fR represent small enhancements and bug fixes that retain backward compatibility. The value of this variable is returned by the \fBinfo tclversion\fR command. .SH "OTHER GLOBAL VARIABLES" -.PP The following variables are only guaranteed to exist in \fBtclsh\fR and \fBwish\fR executables; the Tcl library does not define them itself but many Tcl environments do. .TP 6 \fBargc\fR -. The number of arguments to \fBtclsh\fR or \fBwish\fR. .TP 6 \fBargv\fR -. Tcl list of arguments to \fBtclsh\fR or \fBwish\fR. .TP 6 \fBargv0\fR -. The script that \fBtclsh\fR or \fBwish\fR started executing (if it was specified) or otherwise the name by which \fBtclsh\fR or \fBwish\fR was invoked. .TP 6 \fBtcl_interactive\fR -. Contains 1 if \fBtclsh\fR or \fBwish\fR is running interactively (no script was specified and standard input is a terminal-like device), 0 otherwise. -.SH EXAMPLES -.PP -To add a directory to the collection of locations searched by -\fBpackage require\fR, e.g., because of some application-specific -packages that are used, the \fBauto_path\fR variable needs to be -updated: -.PP -.CS -lappend ::\fBauto_path\fR [file join [pwd] "theLibDir"] -.CE -.PP -A simple though not very robust way to handle command line arguments -of the form -.QW "\-foo 1 \-bar 2" -is to load them into an array having first loaded in the default settings: -.CS -array set arguments {-foo 0 -bar 0 -grill 0} -array set arguments $::\fBargv\fR -puts "foo is $arguments(-foo)" -puts "bar is $arguments(-bar)" -puts "grill is $arguments(-grill)" -.CE -.PP -The \fBargv0\fR global variable can be used (in conjunction with the -\fBinfo script\fR command) to determine whether the current script is -being executed as the main script or loaded as a library. This is -useful because it allows a single script to be used as both a library -and a demonstration of that library: -.PP -.CS -if {$::\fBargv0\fR eq [info script]} { - # running as: tclsh example.tcl -} else { - package provide Example 1.0 -} -.CE -.SH "SEE ALSO" -eval(n), library(n), tclsh(1), tkvars(n), wish(1) -.SH KEYWORDS -arithmetic, bytecode, compiler, error, environment, POSIX, precision, -subprocess, user, variables -'\" Local Variables: -'\" mode: nroff -'\" End: +.PP +The \fBwish\fR executable additionally specifies the following global +variable: +.TP 6 +\fBgeometry\fR +If set, contains the user-supplied geometry specification to use for +the main Tk window. +.SH "SEE ALSO" +eval(n), tclsh(1), wish(1) +.SH KEYWORDS +arithmetic, bytecode, compiler, error, environment, POSIX, precision, subprocess, variables Index: doc/tell.n ================================================================== --- doc/tell.n +++ doc/tell.n @@ -2,23 +2,24 @@ '\" 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 tell n 8.1 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tell \- Return current access position for an open channel .SH SYNOPSIS \fBtell \fIchannelId\fR .BE + .SH DESCRIPTION .PP -Returns an integer giving the current access position in +Returns an integer string giving the current access position in \fIchannelId\fR. This value returned is a byte offset that can be passed to \fBseek\fR in order to set the channel to a particular position. Note that this value is in terms of bytes, not characters like \fBread\fR. The value returned is -1 for channels that do not support seeking. @@ -26,13 +27,11 @@ \fIChannelId\fR must be an identifier for an open channel such as a Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR), the return value from an invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel creation command provided by a Tcl extension. .SH EXAMPLE -.PP Read a line from a file channel only if it starts with \fBfoobar\fR: -.PP .CS # Save the offset in case we need to undo the read... set offset [\fBtell\fR $chan] if {[read $chan 6] eq "foobar"} { gets $chan line @@ -40,13 +39,11 @@ set line {} # Undo the read... seek $chan $offset } .CE + .SH "SEE ALSO" file(n), open(n), close(n), gets(n), seek(n), Tcl_StandardChannels(3) + .SH KEYWORDS access position, channel, seeking -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: DELETED doc/throw.n Index: doc/throw.n ================================================================== --- doc/throw.n +++ /dev/null @@ -1,48 +0,0 @@ -'\" -'\" Copyright (c) 2008 Donal K. Fellows -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH throw n 8.6 Tcl "Tcl Built-In Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -throw \- Generate a machine-readable error -.SH SYNOPSIS -\fBthrow\fI type message\fR -.BE -.SH DESCRIPTION -.PP -This command causes the current evaluation to be unwound with an error. The -error created is described by the \fItype\fR and \fImessage\fR arguments: -\fItype\fR must contain a list of words describing the error in a form that is -machine-readable (and which will form the error-code part of the result -dictionary), and \fImessage\fR should contain text that is intended for -display to a human being. -.PP -The stack will be unwound until the error is trapped by a suitable \fBcatch\fR -or \fBtry\fR command. If it reaches the event loop without being trapped, it -will be reported through the \fBbgerror\fR mechanism. If it reaches the top -level of script evaluation in \fBtclsh\fR, it will be printed on the console -before, in the non-interactive case, causing an exit (the behavior in other -programs will depend on the details of how Tcl is embedded and used). -.PP -By convention, the words in the \fItype\fR argument should go from most -general to most specific. -.SH EXAMPLES -.PP -The following produces an error that is identical to that produced by -\fBexpr\fR when trying to divide a value by zero. -.PP -.CS -\fBthrow\fR {ARITH DIVZERO {divide by zero}} {divide by zero} -.CE -.SH "SEE ALSO" -catch(n), error(n), errorCode(n), errorInfo(n), return(n), try(n) -.SH "KEYWORDS" -error, exception -'\" Local Variables: -'\" mode: nroff -'\" End: Index: doc/time.n ================================================================== --- doc/time.n +++ doc/time.n @@ -2,46 +2,43 @@ '\" 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 time n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME time \- Time the execution of a script .SH SYNOPSIS \fBtime \fIscript\fR ?\fIcount\fR? .BE + .SH DESCRIPTION .PP This command will call the Tcl interpreter \fIcount\fR times to evaluate \fIscript\fR (or once if \fIcount\fR is not specified). It will then return a string of the form -.PP .CS -\fB503.2 microseconds per iteration\fR +\fB503 microseconds per iteration\fR .CE -.PP which indicates the average amount of time required per iteration, in microseconds. Time is measured in elapsed time, not CPU time. .SH EXAMPLE Estimate how long it takes for a simple Tcl \fBfor\fR loop to count to a thousand: -.PP .CS time { for {set i 0} {$i<1000} {incr i} { # empty body } } .CE + .SH "SEE ALSO" clock(n) + .SH KEYWORDS script, time -.\" Local Variables: -.\" mode: nroff -.\" End: Index: doc/tm.n ================================================================== --- doc/tm.n +++ doc/tm.n @@ -1,11 +1,11 @@ '\" '\" Copyright (c) 2004-2010 Andreas Kupries '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH tm n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -17,11 +17,10 @@ \fB::tcl::tm::path list\fR \fB::tcl::tm::roots \fR?\fIpath\fR...? .fi .BE .SH DESCRIPTION -.PP This document describes the facilities for locating and loading Tcl Modules (see \fBMODULE DEFINITION\fR for the definition of a Tcl Module). The following commands are supported: .TP \fB::tcl::tm::path add \fR?\fIpath\fR...? @@ -74,15 +73,13 @@ .PP The command has been exposed to allow a build system to define additional root paths beyond those described by this document. .RE .SH "MODULE DEFINITION" -.PP A Tcl Module is a Tcl Package contained in a single file, and no other files required by it. This file has to be \fBsource\fRable. In other words, a Tcl Module is always imported via: -.PP .CS source module_file .CE .PP The \fBload\fR command is not directly used. This restriction is not @@ -92,25 +89,23 @@ arbitrary binary data into one file, where the script processes the attached data in any it chooses to fully import and activate the package. .PP The name of a module file has to match the regular expression: -.PP .CS ([_[:alpha:]][:_[:alnum:]]*)-([[:digit:]].*)\e.tm .CE .PP The first capturing parentheses provides the name of the package, the second clause its version. In addition to matching the pattern, the extracted version number must not raise an error when used in the command: -.PP .CS package vcompare $version 0 .CE -.SH "FINDING MODULES" .PP +.SH "FINDING MODULES" The directory tree for storing Tcl modules is separate from other parts of the filesystem and independent of \fBauto_path\fR. .PP Tcl Modules are searched for in all directories listed in the result of the command \fB::tcl::tm::path list\fR. @@ -167,25 +162,21 @@ .PP Note that packages in module form have \fIno\fR control over the \fIindex\fR and \fIprovide script\fRs entered into the package database for them. For a module file \fBMF\fR the \fIindex script\fR is always: -.PP .CS package ifneeded \fBPNAME PVERSION\fR [list source \fBMF\fR] .CE -.PP and the \fIprovide script\fR embedded in the above is: -.PP .CS source \fBMF\fR .CE .PP Both package name \fBPNAME\fR and package version \fBPVERSION\fR are extracted from the filename \fBMF\fR according to the definition below: -.PP .CS \fBMF\fR = /module_path/\fBPNAME\(fm\fR-\fBPVERSION\fR.tm .CE .PP Where \fBPNAME\(fm\fR is the partial path of the module as defined in @@ -206,11 +197,10 @@ comparing names in a case-insensitive manner. In other words, if a package \fBFoo\fR is deployed in the form of a Tcl Module, packages like \fBfoo\fR, \fBfOo\fR, etc. are not allowed anymore. .SH "DEFAULT PATHS" -.PP The default list of paths on the module path is computed by a \fBtclsh\fR as follows, where \fIX\fR is the major version of the Tcl interpreter and \fIy\fR is less than or equal to the minor version of the Tcl interpreter. .PP @@ -231,11 +221,10 @@ by its major version and whose minor versions are less than or equal to the minor version of the interpreter. .RS .PP For example for Tcl 8.4 the paths searched are: -.PP .CS \fB[info library]/../tcl8/8.4\fR \fB[info library]/../tcl8/8.3\fR \fB[info library]/../tcl8/8.2\fR \fB[info library]/../tcl8/8.1\fR @@ -283,13 +272,12 @@ .PP These paths are seen and therefore shared by all Tcl shells in the \fB$::env(PATH)\fR of the user. .PP Note that \fIX\fR and \fIy\fR follow the general rules set out -above. In other words, Tcl 8.4, for example, will look at these 10 +above. In other words, Tcl 8.4, for example, will look at these 5 environment variables: -.PP .CS \fB$::env(TCL8.4_TM_PATH)\fR \fB$::env(TCL8_4_TM_PATH)\fR \fB$::env(TCL8.3_TM_PATH)\fR \fB$::env(TCL8_3_TM_PATH)\fR \fB$::env(TCL8.2_TM_PATH)\fR \fB$::env(TCL8_2_TM_PATH)\fR \fB$::env(TCL8.1_TM_PATH)\fR \fB$::env(TCL8_1_TM_PATH)\fR @@ -301,8 +289,5 @@ (online at http://tip.tcl.tk/189.html), Tcl Improvement Proposal #190 .QW "\fIImplementation Choices for Tcl Modules\fR" (online at http://tip.tcl.tk/190.html) .SH "KEYWORDS" modules, package -.\" Local Variables: -.\" mode: nroff -.\" End: Index: doc/trace.n ================================================================== --- doc/trace.n +++ doc/trace.n @@ -3,11 +3,11 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" 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. -'\" +'\" .TH trace n "8.4" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -18,12 +18,11 @@ .SH DESCRIPTION .PP This command causes Tcl commands to be executed whenever certain operations are invoked. The legal \fIoption\fRs (which may be abbreviated) are: .TP -\fBtrace add \fItype name ops\fR ?\fIargs\fR? -. +\fBtrace add \fItype name ops ?args?\fR Where \fItype\fR is \fBcommand\fR, \fBexecution\fR, or \fBvariable\fR. .RS .TP \fBtrace add command\fR \fIname ops commandPrefix\fR . @@ -53,15 +52,13 @@ execute them. .PP When the trace triggers, depending on the operations being traced, a number of arguments are appended to \fIcommandPrefix\fR so that the actual command is as follows: -.PP .CS \fIcommandPrefix oldName newName op\fR .CE -.PP \fIOldName\fR and \fInewName\fR give the traced command's current (old) name, and the name to which it is being renamed (the empty string if this is a .QW delete operation). \fIOp\fR indicates what operation is being performed on the @@ -122,15 +119,13 @@ When the trace triggers, depending on the operations being traced, a number of arguments are appended to \fIcommandPrefix\fR so that the actual command is as follows: .PP For \fBenter\fR and \fBenterstep\fR operations: -.PP .CS \fIcommandPrefix command-string op\fR .CE -.PP \fICommand-string\fR gives the complete current command being executed (the traced command for a \fBenter\fR operation, an arbitrary command for a \fBenterstep\fR operation), including all arguments in their fully expanded form. \fIOp\fR indicates what operation is being performed on the @@ -140,15 +135,13 @@ course when the command is subsequently executed, an .QW "invalid command" error will occur. .PP For \fBleave\fR and \fBleavestep\fR operations: -.PP .CS \fIcommandPrefix command-string code result op\fR .CE -.PP \fICommand-string\fR gives the complete current command being executed (the traced command for a \fBenter\fR operation, an arbitrary command for a \fBenterstep\fR operation), including all arguments in their fully expanded form. \fICode\fR gives the result code of that execution, and \fIresult\fR @@ -222,15 +215,13 @@ deleted, but traces will not be invoked because there is no interpreter in which to execute them. .PP When the trace triggers, three arguments are appended to \fIcommandPrefix\fR so that the actual command is as follows: -.PP .CS \fIcommandPrefix name1 name2 op\fR .CE -.PP \fIName1\fR and \fIname2\fR give the name(s) for the variable being accessed: if the variable is a scalar then \fIname1\fR gives the variable's name and \fIname2\fR is an empty string; if the variable is an array element then \fIname1\fR gives the name of the array and name2 gives the index into the array; @@ -375,15 +366,13 @@ \fBread\fR, \fBwrite\fR, \fBunset\fR are replaced by \fBa\fR, \fBr\fR, \fBw\fR and \fBu\fR respectively, and the \fIops\fR argument is not a list, but simply a string concatenation of the operations, such as \fBrwua\fR. .SH EXAMPLES -.PP Print a message whenever either of the global variables \fBfoo\fR and \fBbar\fR are updated, even if they have a different local name at the time (which can be done with the \fBupvar\fR command): -.PP .CS proc tracer {varname args} { upvar #0 $varname var puts "$varname was updated to be \e"$var\e"" } @@ -391,11 +380,10 @@ \fBtrace add\fR variable bar write "tracer bar" .CE .PP Ensure that the global variable \fBfoobar\fR always contains the product of the global variables \fBfoo\fR and \fBbar\fR: -.PP .CS proc doMult args { global foo bar foobar set foobar [expr {$foo * $bar}] } @@ -403,11 +391,10 @@ \fBtrace add\fR variable bar write doMult .CE .PP Print a trace of what commands are executed during the processing of a Tcl procedure: -.PP .CS proc x {} { y } proc y {} { z } proc z {} { puts hello } proc report args {puts [info level 0]} @@ -420,8 +407,5 @@ .CE .SH "SEE ALSO" set(n), unset(n) .SH KEYWORDS read, command, rename, variable, write, trace, unset -.\" Local Variables: -.\" mode: nroff -.\" End: DELETED doc/transchan.n Index: doc/transchan.n ================================================================== --- doc/transchan.n +++ /dev/null @@ -1,160 +0,0 @@ -'\" -'\" Copyright (c) 2008 Donal K. Fellows -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH transchan n 8.6 Tcl "Tcl Built-In Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -transchan \- command handler API of channel transforms -.SH SYNOPSIS -\fBcmdPrefix \fIoption\fR ?\fIarg arg ...\fR? -.BE -.SH DESCRIPTION -.PP -The Tcl-level handler for a channel transformation has to be a command with -subcommands (termed an \fIensemble\fR despite not implying that it must be -created with \fBnamespace ensemble create\fR; this mechanism is not tied to -\fBnamespace ensemble\fR in any way). Note that \fIcmdPrefix\fR is whatever -was specified in the call to \fBchan push\fR, and may consist of multiple -arguments; this will be expanded to multiple words in place of the prefix. -.PP -Of all the possible subcommands, the handler \fImust\fR support -\fBinitialize\fR and \fBfinalize\fR. Transformations for writable channels -must also support \fBwrite\fR, and transformations for readable channels must -also support \fBread\fR. -.PP -Note that in the descriptions below \fIcmdPrefix\fR may be more than one word, -and \fIhandle\fR is the value returned by the \fBchan push\fR call used to -create the transformation. -.SS "GENERIC SUBCOMMANDS" -.PP -The following subcommands are relevant to all types of channel. -.TP -\fIcmdPrefix \fBclear \fIhandle\fR -. -This optional subcommand is called to signify to the transformation that any -data stored in internal buffers (either incoming or outgoing) must be -cleared. It is called when a \fBchan seek\fR is performed on the channel being -transformed. -.TP -\fIcmdPrefix \fBfinalize \fIhandle\fR -. -This mandatory subcommand is called last for the given \fIhandle\fR, and then -never again, and it exists to allow for cleaning up any Tcl-level data -structures associated with the transformation. \fIWarning!\fR Any errors -thrown by this subcommand will be ignored. It is not guaranteed to be called -if the interpreter is deleted. -.TP -\fIcmdPrefix \fBinitialize \fIhandle mode\fR -. -This mandatory subcommand is called first, and then never again (for the given -\fIhandle\fR). Its responsibility is to initialize all parts of the -transformation at the Tcl level. The \fImode\fR is a list containing any of -\fBread \fRand \fBwrite\fR. -.RS -.TP -\fBwrite\fR -. -implies that the channel is writable. -.TP -\fBread\fR -. -implies that the channel is readable. -.PP -The return value of the subcommand should be a list containing the names of -all subcommands supported by this handler. Any error thrown by the subcommand -will prevent the creation of the transformation. The thrown error will appear -as error thrown by \fBchan push\fR. -.RE -.SS "READ-RELATED SUBCOMMANDS" -.PP -These subcommands are used for handling transformations applied to readable -channels; though strictly \fBread \fRis optional, it must be supported if any -of the others is or the channel will be made non-readable. -.TP -\fIcmdPrefix \fBdrain \fIhandle\fR -. -This optional subcommand is called whenever data in the transformation input -(i.e. read) buffer has to be forced upward, i.e. towards the user or script. -The result returned by the method is taken as the \fIbinary\fR data to push -upward to the level above this transformation (the reader or a higher-level -transformation). -.RS -.PP -In other words, when this method is called the transformation cannot defer the -actual transformation operation anymore and has to transform all data waiting -in its internal read buffers and return the result of that action. -.RE -.TP -\fIcmdPrefix \fBlimit? \fIhandle\fR -. -This optional subcommand is called to allow the Tcl I/O engine to determine -how far ahead it should read. If present, it should return an integer number -greater than zero which indicates how many bytes ahead should be read, or an -integer less than zero to indicate that the I/O engine may read as far ahead -as it likes. -.TP -\fIcmdPrefix \fBread \fIhandle buffer\fR -. -This subcommand, which must be present if the transformation is to work with -readable channels, is called whenever the base channel, or a transformation -below this transformation, pushes data upward. The \fIbuffer\fR contains the -binary data which has been given to us from below. It is the responsibility of -this subcommand to actually transform the data. The result returned by the -subcommand is taken as the binary data to push further upward to the -transformation above this transformation. This can also be the user or script -that originally read from the channel. -.RS -.PP -Note that the result is allowed to be empty, or even less than the data we -received; the transformation is not required to transform everything given to -it right now. It is allowed to store incoming data in internal buffers and to -defer the actual transformation until it has more data. -.RE -.SS "WRITE-RELATED SUBCOMMANDS" -.PP -These subcommands are used for handling transformations applied to writable -channels; though strictly \fBwrite\fR is optional, it must be supported if any -of the others is or the channel will be made non-writable. -.TP -\fIcmdPrefix \fBflush \fIhandle\fR -. -This optional subcommand is called whenever data in the transformation 'write' -buffer has to be forced downward, i.e. towards the base channel. The result -returned by the subcommand is taken as the binary data to write to the -transformation below the current transformation. This can be the base channel -as well. -.RS -.PP -In other words, when this subcommand is called the transformation cannot defer -the actual transformation operation anymore and has to transform all data -waiting in its internal write buffers and return the result of that action. -.RE -.TP -\fIcmdPrefix \fBwrite \fIhandle buffer\fR -. -This subcommand, which must be present if the transformation is to work with -writable channels, is called whenever the user, or a transformation above this -transformation, writes data downward. The \fIbuffer\fR contains the binary -data which has been written to us. It is the responsibility of this subcommand -to actually transform the data. -.RS -.PP -The result returned by the subcommand is taken as the binary data to write to -the transformation below this transformation. This can be the base channel as -well. Note that the result is allowed to be empty, or less than the data we -got; the transformation is not required to transform everything which was -written to it right now. It is allowed to store this data in internal buffers -and to defer the actual transformation until it has more data. -.RE -.SH "SEE ALSO" -chan(n), refchan(n) -.SH KEYWORDS -API, channel, ensemble, prefix, transformation -'\" Local Variables: -'\" mode: nroff -'\" End: DELETED doc/try.n Index: doc/try.n ================================================================== --- doc/try.n +++ /dev/null @@ -1,103 +0,0 @@ -'\" -'\" Copyright (c) 2008 Donal K. Fellows -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH try n 8.6 Tcl "Tcl Built-In Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -try \- Trap and process errors and exceptions -.SH SYNOPSIS -\fBtry\fI body\fR ?\fIhandler...\fR? ?\fBfinally\fI script\fR? -.BE -.SH DESCRIPTION -.PP -This command executes the script \fIbody\fR and, depending on what the outcome -of that script is (normal exit, error, or some other exceptional result), runs -a handler script to deal with the case. Once that has all happened, if the -\fBfinally\fR clause is present, the \fIscript\fR it includes will be run and -the result of the handler (or the \fIbody\fR if no handler matched) is allowed -to continue to propagate. Note that the \fBfinally\fR clause is processed even -if an error occurs and irrespective of which, if any, \fIhandler\fR is used. -.PP -The \fIhandler\fR clauses are each expressed as several words, and must have -one of the following forms: -.TP -\fBon \fIcode variableList script\fR -. -This clause matches if the evaluation of \fIbody\fR completed with the -exception code \fIcode\fR. The \fIcode\fR may be expressed as an integer or -one of the following literal words: \fBok\fR, \fBerror\fR, \fBreturn\fR, -\fBbreak\fR, or \fBcontinue\fR. Those literals correspond to the integers 0 -through 4 respectively. -.TP -\fBtrap \fIpattern variableList script\fR -. -This clause matches if the evaluation of \fIbody\fR resulted in an error and -the prefix of the \fB\-errorcode\fR from the interpreter's status dictionary -is equal to the \fIpattern\fR. The number of prefix words taken from the -\fB\-errorcode\fR is equal to the list-length of \fIpattern\fR, and inter-word -spaces are normalized in both the \fB\-errorcode\fR and \fIpattern\fR before -comparison. -.PP -The \fIvariableList\fR word in each \fIhandler\fR is always interpreted as a -list of variable names. If the first word of the list is present and -non-empty, it names a variable into which the result of the evaluation of -\fIbody\fR (from the main \fBtry\fR) will be placed; this will contain the -human-readable form of any errors. If the second word of the list is present -and non-empty, it names a variable into which the options dictionary of the -interpreter at the moment of completion of execution of \fIbody\fR -will be placed. -.PP -The \fIscript\fR word of each \fIhandler\fR is also always interpreted the -same: as a Tcl script to evaluate if the clause is matched. If \fIscript\fR is -a literal -.QW \- -and the \fIhandler\fR is not the last one, the \fIscript\fR of the following -\fIhandler\fR is invoked instead (just like with the \fBswitch\fR command). -.PP -Note that \fIhandler\fR clauses are matched against in order, and that the -first matching one is always selected. At most one \fIhandler\fR clause will -selected. As a consequence, an \fBon error\fR will mask any subsequent -\fBtrap\fR in the \fBtry\fR. Also note that \fBon error\fR is equivalent to -\fBtrap {}\fR. -.PP -If an exception (i.e. any non-\fBok\fR result) occurs during the evaluation of -either the \fIhandler\fR or the \fBfinally\fR clause, the original exception's -status dictionary will be added to the new exception's status dictionary under -the \fB\-during\fR key. -.SH EXAMPLES -.PP -Ensure that a file is closed no matter what: -.PP -.CS -set f [open /some/file/name a] -\fBtry\fR { - puts $f "some message" - # ... -} \fBfinally\fR { - close $f -} -.CE -.PP -Handle different reasons for a file to not be openable for reading: -.PP -.CS -\fBtry\fR { - set f [open /some/file/name w] -} \fBtrap\fR {POSIX EISDIR} {} { - puts "failed to open /some/file/name: it's a directory" -} \fBtrap\fR {POSIX ENOENT} {} { - puts "failed to open /some/file/name: it doesn't exist" -} -.CE -.SH "SEE ALSO" -catch(n), error(n), return(n), throw(n) -.SH "KEYWORDS" -cleanup, error, exception, final, resource management -'\" Local Variables: -'\" mode: nroff -'\" End: Index: doc/unknown.n ================================================================== --- doc/unknown.n +++ doc/unknown.n @@ -2,11 +2,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 unknown n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -19,18 +19,18 @@ This command is invoked by the Tcl interpreter whenever a script tries to invoke a command that does not exist. The default implementation of \fBunknown\fR is a library procedure defined when Tcl initializes an interpreter. You can override the default \fBunknown\fR to change its functionality, or you can register a new handler for individual namespaces -using the \fBnamespace unknown\fR command. Note that there is no default +using the \fBnamespace unknown\fR command. Note that there is no default implementation of \fBunknown\fR in a safe interpreter. .PP If the Tcl interpreter encounters a command name for which there -is not a defined command (in either the current namespace, or the +is not a defined command (in either the current namespace, or the global namespace), then Tcl checks for the existence of an unknown handler for the current namespace. By default, this -handler is a command named \fB::unknown\fR. If there is no such +handler is a command named \fB::unknown\fR. If there is no such command, then the interpreter returns an error. If the \fBunknown\fR command exists (or a new handler has been registered for the current namespace), then it is invoked with arguments consisting of the fully-substituted name and arguments for the original non-existent command. @@ -86,10 +86,6 @@ } .CE .SH "SEE ALSO" info(n), proc(n), interp(n), library(n), namespace(n) .SH KEYWORDS -error, non-existent command, unknown -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: +error, non-existent command Index: doc/unload.n ================================================================== --- doc/unload.n +++ doc/unload.n @@ -1,11 +1,11 @@ '\" '\" Copyright (c) 2003 George Petasis . '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH unload n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -43,11 +43,11 @@ never report an error. .TP \fB\-keeplibrary\fR . This switch will prevent \fBunload\fR from issuing the operating system call -that will unload the library from the process. +that will unload the library from the process. .TP \fB\-\|\-\fR . Marks the end of switches. The argument following this one will be treated as a \fIfileName\fR even if it starts with a \fB\-\fR. @@ -86,15 +86,12 @@ type). When both reference counts have reached 0, the library will be detached from the process. .SS "UNLOAD HOOK PROTOTYPE" .PP The unload procedure must match the following prototype: -.PP .CS -typedef int \fBTcl_PackageUnloadProc\fR( - Tcl_Interp *\fIinterp\fR, - int \fIflags\fR); +typedef int Tcl_PackageUnloadProc(Tcl_Interp *\fIinterp\fR, int \fIflags\fR); .CE .PP The \fIinterp\fR argument identifies the interpreter from which the library is to be unloaded. The unload procedure must return \fBTCL_OK\fR or \fBTCL_ERROR\fR to indicate whether or not it completed @@ -107,11 +104,11 @@ attached to the process after the unload procedure returns (i.e. because the library is used by other interpreters), \fBTCL_UNLOAD_DETACH_FROM_INTERPRETER\fR will be defined. However, if the library is used only by the target interpreter and the library will be detached from the application as soon as the unload procedure returns, -the \fIflags\fR argument will be set to \fBTCL_UNLOAD_DETACH_FROM_PROCESS\fR. +the \fIflags\fR argument will be set to \fBTCL_UNLOAD_DETACH_FROM_PROCESS\fR. .SS NOTES .PP The \fBunload\fR command cannot unload libraries that are statically linked with the application. If \fIfileName\fR is an empty string, then the \fIpackageName\fR argument must @@ -143,20 +140,16 @@ silently detached by the operating system (and as a result Tcl thinks the library is still loaded), it may be dangerous to use \fBunload\fR on such a library (as the library will be completely detached from the application while some interpreters will continue to use it). .SH EXAMPLE -.PP If an unloadable module in the file \fBfoobar.dll\fR had been loaded using the \fBload\fR command like this (on Windows): -.PP .CS load c:/some/dir/foobar.dll .CE -.PP then it would be unloaded like this: -.PP .CS \fBunload\fR c:/some/dir/foobar.dll .CE .PP This allows a C code module to be installed temporarily into a @@ -165,8 +158,5 @@ without having to shut down the overall Tcl process. .SH "SEE ALSO" info sharedlibextension, load(n), safe(n) .SH KEYWORDS binary code, unloading, safe interpreter, shared library -.\" Local Variables: -.\" mode: nroff -.\" End: Index: doc/unset.n ================================================================== --- doc/unset.n +++ doc/unset.n @@ -3,19 +3,19 @@ '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" 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. -'\" +'\" .TH unset n 8.4 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME unset \- Delete variables .SH SYNOPSIS -\fBunset \fR?\fB\-nocomplain\fR? ?\fB\-\-\fR? ?\fIname name name ...\fR? +\fBunset \fR?\fI\-nocomplain\fR? ?\fI\-\-\fR? ?\fIname name name ...\fR? .BE .SH DESCRIPTION .PP This command removes one or more variables. Each \fIname\fR is a variable name, specified in any of the @@ -23,25 +23,23 @@ If a \fIname\fR refers to an element of an array then that element is removed without affecting the rest of the array. If a \fIname\fR consists of an array name with no parenthesized index, then the entire array is deleted. The \fBunset\fR command returns an empty string as result. -If \fB\-nocomplain\fR is specified as the first argument, any possible +If \fI\-nocomplain\fR is specified as the first argument, any possible errors are suppressed. The option may not be abbreviated, in order to -disambiguate it from possible variable names. The option \fB\-\-\fR +disambiguate it from possible variable names. The option \fI\-\-\fR indicates the end of the options, and should be used if you wish to remove a variable with the same name as any of the options. -If an error occurs during variable deletion, any variables after the named one -causing the error are not +If an error occurs, any variables after the named one causing the error +are not deleted. An error can occur when the named variable does not exist, or the name refers to an array element but the variable is a scalar, or the name refers to a variable in a non-existent namespace. .SH EXAMPLE -.PP Create an array containing a mapping from some numbers to their squares and remove the array elements for non-prime numbers: -.PP .CS array set squares { 1 1 6 36 2 4 7 49 3 9 8 64 @@ -60,9 +58,5 @@ .CE .SH "SEE ALSO" set(n), trace(n), upvar(n) .SH KEYWORDS remove, variable -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: Index: doc/update.n ================================================================== --- doc/update.n +++ doc/update.n @@ -2,20 +2,21 @@ '\" Copyright (c) 1990-1992 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 update n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME update \- Process pending events and idle callbacks .SH SYNOPSIS \fBupdate\fR ?\fBidletasks\fR? .BE + .SH DESCRIPTION .PP This command is used to bring the application .QW "up to date" by entering the event loop repeatedly until all pending events @@ -40,13 +41,11 @@ you are performing a long-running computation but you still want the application to respond to events such as user interactions; if you occasionally call \fBupdate\fR then user input will be processed during the next call to \fBupdate\fR. .SH EXAMPLE -.PP Run computations for about a second and then finish: -.PP .CS set x 1000 set done 0 after 1000 set done 1 while {!$done} { @@ -57,13 +56,11 @@ # also give a chance for serving network sockets and, if # the Tk package is loaded, updating a user interface. \fBupdate\fR } .CE + .SH "SEE ALSO" after(n), interp(n) + .SH KEYWORDS -asynchronous I/O, event, flush, handler, idle, update -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: +event, flush, handler, idle, update Index: doc/uplevel.n ================================================================== --- doc/uplevel.n +++ doc/uplevel.n @@ -2,11 +2,11 @@ '\" 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 uplevel n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -22,13 +22,13 @@ the result of that evaluation. .PP If \fIlevel\fR is an integer then it gives a distance (up the procedure calling stack) to move before executing the command. If \fIlevel\fR consists of \fB#\fR followed by -a integer then the level gives an absolute level. If \fIlevel\fR +a number then the number gives an absolute level number. If \fIlevel\fR is omitted then it defaults to \fB1\fR. \fILevel\fR cannot be -defaulted if the first \fIcommand\fR argument is an integer or starts with \fB#\fR. +defaulted if the first \fIcommand\fR argument starts with a digit or \fB#\fR. .PP For example, suppose that procedure \fBa\fR was invoked from top-level, and that it called \fBb\fR, and that \fBb\fR called \fBc\fR. Suppose that \fBc\fR invokes the \fBuplevel\fR command. If \fIlevel\fR is \fB1\fR or \fB#2\fR or omitted, then the command will be executed @@ -38,24 +38,20 @@ at top-level (only global variables will be visible). .PP The \fBuplevel\fR command causes the invoking procedure to disappear from the procedure calling stack while the command is being executed. In the above example, suppose \fBc\fR invokes the command -.PP .CS \fBuplevel\fR 1 {set x 43; d} .CE -.PP where \fBd\fR is another Tcl procedure. The \fBset\fR command will modify the variable \fBx\fR in \fBb\fR's context, and \fBd\fR will execute at level 3, as if called from \fBb\fR. If it in turn executes the command -.PP .CS \fBuplevel\fR {set x 42} .CE -.PP then the \fBset\fR command will modify the same variable \fBx\fR in \fBb\fR's context: the procedure \fBc\fR does not appear to be on the call stack when \fBd\fR is executing. The \fBinfo level\fR command may be used to obtain the level of the current procedure. .PP @@ -77,11 +73,10 @@ As stated above, the \fBuplevel\fR command is useful for creating new control constructs. This example shows how (without error handling) it can be used to create a \fBdo\fR command that is the counterpart of \fBwhile\fR except for always performing the test after running the loop body: -.PP .CS proc do {body while condition} { if {$while ne "while"} { error "required word missing" } @@ -95,9 +90,6 @@ } .CE .SH "SEE ALSO" apply(n), namespace(n), upvar(n) .SH KEYWORDS -context, level, namespace, stack frame, variable -.\" Local Variables: -.\" mode: nroff -.\" End: +context, level, namespace, stack frame, variables Index: doc/upvar.n ================================================================== --- doc/upvar.n +++ doc/upvar.n @@ -2,11 +2,11 @@ '\" 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 upvar n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -19,11 +19,12 @@ .PP This command arranges for one or more local variables in the current procedure to refer to variables in an enclosing procedure call or to global variables. \fILevel\fR may have any of the forms permitted for the \fBuplevel\fR -command, and may be omitted (it defaults to \fB1\fR). +command, and may be omitted if the first letter of the first \fIotherVar\fR +is not \fB#\fR or a digit (it defaults to \fB1\fR). For each \fIotherVar\fR argument, \fBupvar\fR makes the variable by that name in the procedure frame given by \fIlevel\fR (or at global level, if \fIlevel\fR is \fB#0\fR) accessible in the current procedure by the name given in the corresponding \fImyVar\fR argument. @@ -40,30 +41,28 @@ .PP The \fBupvar\fR command simplifies the implementation of call-by-name procedure calling and also makes it easier to build new control constructs as Tcl procedures. For example, consider the following procedure: -.PP .CS proc \fIadd2\fR name { - \fBupvar\fR $name x - set x [expr {$x + 2}] + \fBupvar\fR $name x + set x [expr {$x + 2}] } .CE -.PP If \fIadd2\fR is invoked with an argument giving the name of a variable, it adds two to the value of that variable. Although \fIadd2\fR could have been implemented using \fBuplevel\fR -instead of \fBupvar\fR, \fBupvar\fR makes it simpler for \fIadd2\fR +instead of \fBupvar\fR, \fBupvar\fR makes it simpler for \fBadd2\fR to access the variable in the caller's procedure frame. .PP \fBnamespace eval\fR is another way (besides procedure calls) that the Tcl naming context can change. It adds a call frame to the stack to represent the namespace context. This means each \fBnamespace eval\fR command counts as another call level for \fBuplevel\fR and \fBupvar\fR commands. -For example, \fBinfo level\fR \fB1\fR will return a list +For example, \fBinfo level 1\fR will return a list describing a command that is either the outermost procedure call or the outermost \fBnamespace eval\fR command. Also, \fBuplevel #0\fR evaluates a script at top-level in the outermost namespace (the global namespace). .PP @@ -82,18 +81,17 @@ than the name of \fIotherVar\fR. Thus, the output of the following code will be .QW "\fIlocalVar\fR" rather than .QW "\fIoriginalVar\fR" : -.PP .CS proc \fItraceproc\fR { name index op } { - puts $name + puts $name } proc \fIsetByUpvar\fR { name value } { - \fBupvar\fR $name localVar - set localVar $value + \fBupvar\fR $name localVar + set localVar $value } set originalVar 1 trace variable originalVar w \fItraceproc\fR \fIsetByUpvar\fR originalVar 2 .CE @@ -104,19 +102,17 @@ invoked). In particular, if the array is \fBenv\fR, then changes made to \fImyVar\fR will not be passed to subprocesses correctly. .SH EXAMPLE A \fBdecr\fR command that works like \fBincr\fR except it subtracts the value from the variable instead of adding it: -.PP .CS proc decr {varName {decrement 1}} { \fBupvar\fR 1 $varName var incr var [expr {-$decrement}] } .CE + .SH "SEE ALSO" global(n), namespace(n), uplevel(n), variable(n) + .SH KEYWORDS -context, frame, global, level, namespace, procedure, upvar, variable -.\" Local Variables: -.\" mode: nroff -.\" End: +context, frame, global, level, namespace, procedure, variable Index: doc/variable.n ================================================================== --- doc/variable.n +++ doc/variable.n @@ -2,22 +2,21 @@ '\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies '\" 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 variable n 8.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME variable \- create and initialize a namespace variable .SH SYNOPSIS -\fBvariable \fR\fIname\fR -.sp -\fBvariable \fR?\fIname value...\fR? +\fBvariable \fR?\fIname value...\fR? \fIname \fR?\fIvalue\fR? .BE + .SH DESCRIPTION .PP This command is normally used within a \fBnamespace eval\fR command to create one or more variables within a namespace. @@ -43,12 +42,11 @@ it creates local variables linked to the corresponding namespace variables (and therefore these variables are listed by \fBinfo vars\fR.) In this way the \fBvariable\fR command resembles the \fBglobal\fR command, although the \fBglobal\fR command -resolves variable names with respect to the global namespace instead -of the current namespace of the procedure. +only links to variables in the global namespace. If any \fIvalue\fRs are given, they are used to modify the values of the associated namespace variables. If a namespace variable does not exist, it is created and optionally initialized. .PP @@ -57,21 +55,18 @@ and the initialization \fIvalue\fR should be left off. After the variable has been declared, elements within the array can be set using ordinary \fBset\fR or \fBarray\fR commands. .SH EXAMPLES -.PP Create a variable in a namespace: -.PP .CS namespace eval foo { \fBvariable\fR bar 12345 } .CE .PP Create an array in a namespace: -.PP .CS namespace eval someNS { \fBvariable\fR someAry array set someAry { someName someValue @@ -79,11 +74,10 @@ } } .CE .PP Access variables in namespaces from a procedure: -.PP .CS namespace eval foo { proc spong {} { # Variable in this namespace \fBvariable\fR bar @@ -93,13 +87,11 @@ \fBvariable\fR ::someNS::someAry parray someAry } } .CE + .SH "SEE ALSO" global(n), namespace(n), upvar(n) + .SH KEYWORDS global, namespace, procedure, variable -.\" Local variables: -.\" mode: nroff -.\" fill-column: 78 -.\" End: Index: doc/vwait.n ================================================================== --- doc/vwait.n +++ doc/vwait.n @@ -1,71 +1,58 @@ '\" '\" 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 vwait n 8.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME vwait \- Process events until a variable is written .SH SYNOPSIS \fBvwait\fR \fIvarName\fR .BE + .SH DESCRIPTION .PP This command enters the Tcl event loop to process events, blocking the application if no events are ready. It continues processing -events until some event handler sets the value of the global variable +events until some event handler sets the value of variable \fIvarName\fR. Once \fIvarName\fR has been set, the \fBvwait\fR command will return as soon as the event handler that modified -\fIvarName\fR completes. The \fIvarName\fR argument is always interpreted as -a variable name with respect to the global namespace, but can refer to any -namespace's variables if the fully-qualified name is given. +\fIvarName\fR completes. \fIvarName\fR must be globally scoped +(either with a call to \fBglobal\fR for the \fIvarName\fR, or with +the full namespace path specification). .PP In some cases the \fBvwait\fR command may not return immediately -after \fIvarName\fR is set. This happens if the event handler +after \fIvarName\fR is set. This can happen if the event handler that sets \fIvarName\fR does not complete immediately. For example, if an event handler sets \fIvarName\fR and then itself calls \fBvwait\fR to wait for a different variable, then it may not return for a long time. During this time the top-level \fBvwait\fR is blocked waiting for the event handler to complete, so it cannot -return either. (See the \fBNESTED VWAITS BY EXAMPLE\fR below.) -.PP -To be clear, \fImultiple \fBvwait\fI calls will nest and will not happen in -parallel\fR. The outermost call to \fBvwait\fR will not return until all the -inner ones do. It is recommended that code should never nest \fBvwait\fR -calls (by avoiding putting them in event callbacks) but when that is not -possible, care should be taken to add interlock variables to the code to -prevent all reentrant calls to \fBvwait\fR that are not \fIstrictly\fR -necessary. Be aware that the synchronous modes of operation of some Tcl -packages (e.g.,\ \fBhttp\fR) use \fBvwait\fR internally; if using the event -loop, it is best to use the asynchronous callback-based modes of operation of -those packages where available. +return either. .SH EXAMPLES -.PP Run the event-loop continually until some event calls \fBexit\fR. (You can use any variable not mentioned elsewhere, but the name \fIforever\fR reminds you at a glance of the intent.) -.PP .CS \fBvwait\fR forever .CE .PP Wait five seconds for a connection to a server socket, otherwise close the socket and continue running the script: -.PP .CS # Initialise the state after 5000 set state timeout set server [socket -server accept 12345] proc accept {args} { - global state connectionInfo - set state accepted - set connectionInfo $args + global state connectionInfo + set state accepted + set connectionInfo $args } # Wait for something to happen \fBvwait\fR state @@ -73,174 +60,20 @@ close $server after cancel set state timeout # Do something based on how the vwait finished... switch $state { - timeout { - puts "no connection on port 12345" - } - accepted { - puts "connection: $connectionInfo" - puts [lindex $connectionInfo 0] "Hello there!" - } -} -.CE -.PP -A command that will wait for some time delay by waiting for a namespace -variable to be set. Includes an interlock to prevent nested waits. -.PP -.CS -namespace eval example { - variable v done - proc wait {delay} { - variable v - if {$v ne "waiting"} { - set v waiting - after $delay [namespace code {set v done}] - \fBvwait\fR [namespace which -variable v] - } - return $v - } -} -.CE -.PP -When running inside a \fBcoroutine\fR, an alternative to using \fBvwait\fR is -to \fByield\fR to an outer event loop and to get recommenced when the variable -is set, or at an idle moment after that. -.PP -.CS -coroutine task apply {{} { - # simulate [after 1000] - after 1000 [info coroutine] - yield - - # schedule the setting of a global variable, as normal - after 2000 {set var 1} - - # simulate [\fBvwait\fR var] - proc updatedVar {task args} { - after idle $task - trace remove variable ::var write "updatedVar $task" - } - trace add variable ::var write "updatedVar [info coroutine]" - yield -}} -.CE -.SS "NESTED VWAITS BY EXAMPLE" -.PP -This example demonstrates what can happen when the \fBvwait\fR command is -nested. The script will never finish because the waiting for the \fIa\fR -variable never finishes; that \fBvwait\fR command is still waiting for a -script scheduled with \fBafter\fR to complete, which just happens to be -running an inner \fBvwait\fR (for \fIb\fR) even though the event that the -outer \fBvwait\fR was waiting for (the setting of \fIa\fR) has occurred. -.PP -.CS -after 500 { - puts "waiting for b" - \fBvwait\fR b - puts "b was set" -} -after 1000 { - puts "setting a" - set a 10 -} -puts "waiting for a" -\fBvwait\fR a -puts "a was set" -puts "setting b" -set b 42 -.CE -.PP -If you run the above code, you get this output: -.PP -.CS -waiting for a -waiting for b -setting a -.CE -.PP -The script will never print -.QW "a was set" -until after it has printed -.QW "b was set" -because of the nesting of \fBvwait\fR commands, and yet \fIb\fR will not be -set until after the outer \fBvwait\fR returns, so the script has deadlocked. -The only ways to avoid this are to either structure the overall program in -continuation-passing style or to use \fBcoroutine\fR to make the continuations -implicit. The first of these options would be written as: -.PP -.CS -after 500 { - puts "waiting for b" - trace add variable b write {apply {args { - global a b - trace remove variable ::b write \e - [lrange [info level 0] 0 1] - puts "b was set" - set ::done ok - }}} -} -after 1000 { - puts "setting a" - set a 10 -} -puts "waiting for a" -trace add variable a write {apply {args { - global a b - trace remove variable a write [lrange [info level 0] 0 1] - puts "a was set" - puts "setting b" - set b 42 -}}} -\fBvwait\fR done -.CE -.PP -The second option, with \fBcoroutine\fR and some helper procedures, is done -like this: -.PP -.CS -# A coroutine-based wait-for-variable command -proc waitvar globalVar { - trace add variable ::$globalVar write \e - [list apply {{v c args} { - trace remove variable $v write \e - [lrange [info level 0] 0 3] - after 0 $c - }} ::$globalVar [info coroutine]] - yield -} -# A coroutine-based wait-for-some-time command -proc waittime ms { - after $ms [info coroutine] - yield -} - -coroutine task-1 eval { - puts "waiting for a" - waitvar a - puts "a was set" - puts "setting b" - set b 42 -} -coroutine task-2 eval { - waittime 500 - puts "waiting for b" - waitvar b - puts "b was set" - set done ok -} -coroutine task-3 eval { - waittime 1000 - puts "setting a" - set a 10 -} -\fBvwait\fR done -.CE -.SH "SEE ALSO" -global(n), update(n) -.SH KEYWORDS -asynchronous I/O, event, variable, wait -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: + timeout { + puts "no connection on port 12345" + } + accepted { + puts "connection: $connectionInfo" + puts [lindex $connectionInfo 0] "Hello there!" + } +} +.CE + +.SH "SEE ALSO" +global(n), update(n) + +.SH KEYWORDS +event, variable, wait Index: doc/while.n ================================================================== --- doc/while.n +++ doc/while.n @@ -2,20 +2,21 @@ '\" 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 while n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME while \- Execute script repeatedly as long as a condition is met .SH SYNOPSIS \fBwhile \fItest body\fR .BE + .SH DESCRIPTION .PP The \fBwhile\fR command evaluates \fItest\fR as an expression (in the same way that \fBexpr\fR evaluates its argument). The value of the expression must a proper boolean @@ -38,32 +39,27 @@ enclosed in braces, variable substitutions are delayed until the expression is evaluated (before each loop iteration), so changes in the variables will be visible. For an example, try the following script with and without the braces around \fB$x<10\fR: -.PP .CS set x 0 \fBwhile\fR {$x<10} { puts "x is $x" incr x } .CE .SH EXAMPLE -.PP Read lines from a channel until we get to the end of the stream, and print them out with a line-number prepended: -.PP .CS set lineCount 0 \fBwhile\fR {[gets $chan line] >= 0} { puts "[incr lineCount]: $line" } .CE + .SH "SEE ALSO" break(n), continue(n), for(n), foreach(n) + .SH KEYWORDS -boolean, loop, test, while -'\" Local Variables: -'\" mode: nroff -'\" fill-column: 78 -'\" End: +boolean value, loop, test, while DELETED doc/zipfs.3 Index: doc/zipfs.3 ================================================================== --- doc/zipfs.3 +++ /dev/null @@ -1,120 +0,0 @@ -'\" -'\" Copyright (c) 2015 Jan Nijtmans -'\" Copyright (c) 2015 Christian Werner -'\" Copyright (c) 2017 Sean Woods -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH Tclzipfs 3 8.7 Tcl "Tcl Library Procedures" -.so man.macros -.BS -.SH NAME -TclZipfs_AppHook, Tclzipfs_Mount, TclZipfs_MountBuffer, Tclzipfs_Unmount \- handle ZIP files as Tcl virtual filesystems -.SH SYNOPSIS -.nf -int -\fBTclZipfs_AppHook(\fIargcPtr, argvPtr\fR) -.sp -int -\fBTclzipfs_Mount\fR(\fIinterp, mountpoint, zipname, password\fR) -.sp -int -\fBTclZipfs_MountBuffer\fR(\fIinterp, mountpoint, data, dataLen, copy\fR) -.sp -int -\fBTclzipfs_Unmount\fR(\fIinterp, mountpoint\fR) -.fi -.SH ARGUMENTS -.AS Tcl_Interp *mountpoint in -.AP "int" *argcPtr in -Pointer to a variable holding the number of command line arguments from -\fBmain\fR(). -.AP "char" ***argvPtr in -Pointer to an array of strings containing the command line arguments to -\fBmain\fR(). -.AP Tcl_Interp *interp in -Interpreter in which the ZIP file system is mounted. The interpreter's result is -modified to hold the result or error message from the script. -.AP "const char" *zipname in -Name of a ZIP file. Must not be NULL when either mounting or unmounting a ZIP. -.AP "const char" *mountpoint in -Name of a mount point, which must be a legal Tcl file or directory name. May -be NULL to query current mount points. -.AP "const char" *password in -An (optional) password. Use NULL if no password is wanted to read the file. -.AP "unsigned char" *data in -A data buffer to mount. The data buffer must hold the contents of a ZIP -archive, and must not be NULL. -.AP size_t dataLen in -The number of bytes in the supplied data buffer argument, \fIdata\fR. -.AP int copy in -If non-zero, the ZIP archive in the data buffer will be internally copied -before mounting, allowing the data buffer to be disposed once -\fBTclZipfs_MountBuffer\fR returns. If zero, the caller guarantees that the -buffer will be valid to read from for the duration of the mount. -.BE -.SH DESCRIPTION -\fBTclZipfs_AppHook\fR is a utility function to perform standard application -initialization procedures, taking into account available ZIP archives as -follows: -.IP [1] -If the current application has a mountable ZIP archive, that archive is -mounted under \fIZIPFS_VOLUME\fB/app\fR as a read-only Tcl virtual file -system. \fIZIPFS_VOLUME\fR is usually \fB//zipfs:\fR on all platforms, but -\fBzipfs:\fR may also be used on Windows (due to differences in the -platform's filename parsing). -.IP [2] -If a file named \fBmain.tcl\fR is located in the root directory of that file -system (i.e., at \fIZIPROOT\fB/app/main.tcl\fR after the ZIP archive is -mounted as described above) it is treated as the startup script for the -process. -.IP [3] -If the file \fIZIPROOT\fB/app/tcl_library/init.tcl\fR is present, the -\fBtcl_library\fR global variable in the initial Tcl interpreter is set to -\fIZIPROOT\fB/app/tcl_library\fR. -.IP [4] -If the directory \fBtcl_library\fR was not found in the main application -mount, the system will then search for it as either a VFS attached to the -application dynamic library, or as a zip archive named -\fBlibtcl_\fImajor\fB_\fIminor\fB_\fIpatchlevel\fB.zip\fR either in the -present working directory or in the standard Tcl install location. (For -example, the Tcl 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 -that this will be true in the future. -.PP -\fBTclzipfs_Mount\fR mounts the ZIP archive \fIzipname\fR on the mount point -given in \fImountpoint\fR using the optional ZIP password \fIpassword\fR. -Errors during that process are reported in the interpreter \fIinterp\fR. If -\fImountpoint\fR is a NULL pointer, information on all currently mounted ZIP -file systems is written into \fIinterp\fR's result as a sequence of mount -points and ZIP file names. The result of this call is a standard Tcl result -code. -.PP -\fBTclzipfs_MountBuffer\fR mounts the ZIP archive in the buffer pointed to by -\fIdata\fR on the mount point given in \fImountpoint\fR. The ZIP archive is -assumed to be not password protected. Errors during that process are reported -in the interpreter \fIinterp\fR. The \fIcopy\fR argument determines whether -the buffer is internally copied before mounting or not. The result of this -call is a standard Tcl result code. -.PP -\fBTclzipfs_Unmount\fR undoes the effect of \fBTclzipfs_Mount\fR, i.e., it -unmounts the mounted ZIP file system that was mounted from \fIzipname\fR (at -\fImountpoint\fR). Errors are reported in the interpreter \fIinterp\fR. The -result of this call is a standard Tcl result code. -.PP -\fBTclZipfs_AppHook\fR can not be used in stub-enabled extensions. -.SH "SEE ALSO" -zipfs(n) -.SH KEYWORDS -compress, filesystem, zip DELETED doc/zipfs.n Index: doc/zipfs.n ================================================================== --- doc/zipfs.n +++ /dev/null @@ -1,254 +0,0 @@ -'\" -'\" Copyright (c) 2015 Jan Nijtmans -'\" Copyright (c) 2015 Christian Werner -'\" Copyright (c) 2015 Sean Woods -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH zipfs n 1.0 Zipfs "zipfs Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -zipfs \- Mount and work with ZIP files within Tcl -.SH SYNOPSIS -.nf -\fBpackage require zipfs \fR?\fB1.0\fR? -.sp -\fBzipfs canonical\fR ?\fImntpnt\fR? \fIfilename\fR ?\fIZIPFS\fR? -\fBzipfs exists\fR \fIfilename\fR -\fBzipfs find\fR \fIdirectoryName\fR -\fBzipfs info\fR \fIfilename\fR -\fBzipfs list\fR ?(\fB\-glob\fR|\fB\-regexp\fR)? ?\fIpattern\fR? -\fBzipfs lmkimg\fR \fIoutfile inlist\fR ?\fIpassword infile\fR? -\fBzipfs lmkzip\fR \fIoutfile inlist\fR ?\fIpassword\fR? -\fBzipfs mkimg\fR \fIoutfile indir\fR ?\fIstrip\fR? ?\fIpassword\fR? ?\fIinfile\fR? -\fBzipfs mkkey\fR \fIpassword\fR -\fBzipfs mkzip\fR \fIoutfile indir\fR ?\fIstrip\fR? ?\fIpassword\fR? -\fBzipfs mount\fR ?\fImountpoint\fR? ?\fIzipfile\fR? ?\fIpassword\fR? -\fBzipfs root\fR -\fBzipfs unmount\fR \fImountpoint\fR -.fi -'\" The following subcommand is *UNDOCUMENTED* -'\" \fBzipfs mount_data\fR ?\fImountpoint\fR? ?\fIdata\fR? -.BE -.SH DESCRIPTION -.PP -The \fBzipfs\fR command (the sole public command provided by the built-in -package with the same name) provides Tcl with the ability to mount the -contents of a ZIP archive file as a virtual file system. ZIP archives support -simple encryption, sufficient to prevent casual inspection of their contents -but not able to prevent access by even a moderately determined attacker. -.TP -\fBzipfs canonical\fR ?\fImountpoint\fR? \fIfilename\fR ?\fIinZipfs\fR? -. -This takes the name of a file, \fIfilename\fR, and produces where it would be -mapped into a zipfs mount as its result. If specified, \fImountpoint\fR says -within which mount the mapping will be done; if omitted, the main root of the -zipfs system is used. The \fIinZipfs\fR argument is a an optional boolean -which controls whether to fully canonicalise the name; it defaults to true. -.TP -\fBzipfs exists\fR \fIfilename\fR -. -Return 1 if the given filename exists in the mounted zipfs and 0 if it does not. -.TP -\fBzipfs find\fR \fIdirectoryName\fR -. -Recursively lists files including and below the directory \fIdirectoryName\fR. -The result list consists of relative path names starting from the given -directory. This command is also used by the \fBzipfs mkzip\fR and \fBzipfs -mkimg\fR commands. -.TP -\fBzipfs info\fR \fIfile\fR -. -Return information about the given \fIfile\fR in the mounted zipfs. The -information consists of: -.RS -.IP (1) -the name of the ZIP archive file that contains the file, -.IP (2) -the size of the file after decompressions, -.IP (3) -the compressed size of the file, and -.IP (4) -the offset of the compressed data in the ZIP archive file. -.PP -Note: querying the mount point gives the start of the zip data as the offset -in (4), which can be used to truncate the zip information from an executable. -.RE -.TP -\fBzipfs list\fR ?(\fB\-glob\fR|\fB\-regexp\fR)? ?\fIpattern\fR? -. -Return a list of all files in the mounted zipfs, or just those matching -\fIpattern\fR (optionally controlled by the option parameters). The order of -the names in the list is arbitrary. -.TP -\fBzipfs mount ?\fImountpoint\fR? ?\fIzipfile\fR? ?\fIpassword\fR? -. -The \fBzipfs mount\fR command mounts a ZIP archive file as a Tcl virtual -filesystem at \fImountpoint\fR. After this command executes, files contained -in \fIzipfile\fR will appear to Tcl to be regular files at the mount point. -.RS -.PP -With no \fIzipfile\fR, returns the zipfile mounted at \fImountpoint\fR. With -no \fImountpoint\fR, return all zipfile/mount pairs. If \fImountpoint\fR is -specified as an empty string, mount on file path. -.PP -\fBNB:\fR because the current working directory is a concept maintained by the -operating system, using \fBcd\fR into a mounted archive will only work in the -current process, and then not entirely consistently (e.g., if a shared library -uses direct access to the OS rather than through Tcl's filesystem API, it will -not see the current directory as being inside the mount and will not be able -to access the files inside the mount). -.RE -.TP -\fBzipfs root\fR -. -Returns a constant string which indicates the mount point for zipfs volumes -for the current platform. On Windows, this value is -.QW \fBzipfs:/\fR . -On Unix, this value is -.QW \fB//zipfs:/\fR . -.TP -\fBzipfs unmount \fImountpoint\fR -. -Unmounts a previously mounted ZIP archive mounted to \fImountpoint\fR. -.SS "ZIP CREATION COMMANDS" -This package also provides several commands to aid the creation of ZIP -archives as Tcl applications. -.TP -\fBzipfs mkzip\fR \fIoutfile indir\fR ?\fIstrip\fR? ?\fIpassword\fR? -. -Creates a ZIP archive file named \fIoutfile\fR from the contents of the input -directory \fIindir\fR (contained regular files only) with optional ZIP -password \fIpassword\fR. While processing the files below \fIindir\fR the -optional file name prefix given in \fIstrip\fR is stripped off the beginning -of the respective file name. When stripping, it is common to remove either -the whole source directory name or the name of its parent directory. -.RS -.PP -\fBCaution:\fR the choice of the \fIindir\fR parameter (less the optional -stripped prefix) determines the later root name of the archive's content. -.RE -.TP -\fBzipfs mkimg\fR \fIoutfile indir\fR ?\fIstrip\fR? ?\fIpassword\fR? ?\fIinfile\fR? -. -Creates an image (potentially a new executable file) similar to \fBzipfs -mkzip\fR; see that command for a description of most parameters to this -command, as they behave identically here. -.RS -.PP -If the \fIinfile\fR parameter is specified, this file is prepended in front of -the ZIP archive, otherwise the file returned by \fBinfo nameofexecutable\fR -(i.e., the executable file of the running process) is used. If the -\fIpassword\fR parameter is not empty, an obfuscated version of that password -(see \fBzipfs mkkey\fR) is placed between the image and ZIP chunks of the -output file and the contents of the ZIP chunk are protected with that -password. -.PP -If there is a file, \fBmain.tcl\fR, in the root directory of the resulting -archive and the image file that the archive is attached to is a \fBtclsh\fR -(or \fBwish\fR) instance (true by default, but depends on your configuration), -then the resulting image is an executable that will \fBsource\fR the script in -that \fBmain.tcl\fR after mounting the ZIP archive, and will \fBexit\fR once -that script has been executed. -.PP -\fBCaution:\fR highly experimental, not usable on Android, only partially -tested on Linux and Windows. -.RE -.TP -\fBzipfs mkkey\fR \fIpassword\fR -. -Given the clear text \fIpassword\fR argument, an obfuscated string version is -returned with the same format used in the \fBzipfs mkimg\fR command. -.TP -\fBzipfs lmkimg\fR \fIoutfile inlist\fR ?\fIpassword infile\fR? -. -This command is like \fBzipfs mkimg\fR, but instead of an input directory, -\fIinlist\fR must be a Tcl list where the odd elements are the names of files -to be copied into the archive in the image, and the even elements are their -respective names within that archive. -.TP -\fBzipfs lmkzip\fR \fIoutfile inlist\fR ?\fIpassword\fR? -. -This command is like \fBzipfs mkzip\fR, but instead of an input directory, -\fIinlist\fR must be a Tcl list where the odd elements are the names of files -to be copied into the archive, and the even elements are their respective -names within that archive. -.SH "EXAMPLES" -.PP -Mounting an ZIP archive as an application directory and running code out of it -before unmounting it again: -.PP -.CS -set zip myApp.zip -set base [file join [\fBzipfs root\fR] myApp] - -\fBzipfs mount\fR $base $zip -# $base now has the contents of myApp.zip - -source [file join $base app.tcl] -# use the contents, load libraries from it, etc... - -\fBzipfs unmount\fR $zip -.CE -.PP -Creating a ZIP archive, given that a directory exists containing the content -to put in the archive. Note that the source directory is given twice, in order -to strip the exterior directory name from each filename in the archive. -.PP -.CS -set sourceDirectory [file normalize myApp] -set targetZip myApp.zip - -\fBzipfs mkzip\fR $targetZip $sourceDirectory $sourceDirectory -.CE -.PP -Encryption can be applied to ZIP archives by providing a password when -building the ZIP and when mounting it. -.PP -.CS -set zip myApp.zip -set sourceDir [file normalize myApp] -set password "hunter2" -set base [file join [\fBzipfs root\fR] myApp] - -# Create with password -\fBzipfs mkzip\fR $targetZip $sourceDir $sourceDir $password - -# Mount with password -\fBzipfs mount\fR $base $zip $password -.CE -.PP -When creating an executable image with a password, the password is placed -within the executable in a shrouded form so that the application can read -files inside the embedded ZIP archive yet casual inspection cannot read it. -.PP -.CS -set appDir [file normalize myApp] -set img "myApp.bin" -set password "hunter2" - -# Create some simple content to define a basic application -file mkdir $appDir -set f [open $appDir/main.tcl] -puts $f { - puts "Hi. This is [info script]" -} -close $f - -# Create the executable -\fBzipfs mkimg\fR $img $appDir $appDir $password - -# Launch the executable, printing its output to stdout -exec $img >@stdout -# prints: \fIHi. This is //zipfs:/app/main.tcl\fR -.CE -.SH "SEE ALSO" -tclsh(1), file(n), zipfs(3), zlib(n) -.SH "KEYWORDS" -compress, filesystem, zip -'\" Local Variables: -'\" mode: nroff -'\" End: DELETED doc/zlib.n Index: doc/zlib.n ================================================================== --- doc/zlib.n +++ /dev/null @@ -1,472 +0,0 @@ -'\" -'\" Copyright (c) 2008-2012 Donal K. Fellows -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH zlib n 8.6 Tcl "Tcl Built-In Commands" -.so man.macros -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -zlib \- compression and decompression operations -.SH SYNOPSIS -.nf -\fBzlib \fIsubcommand arg ...\fR -.fi -.BE -.SH DESCRIPTION -.PP -The \fBzlib\fR command provides access to the compression and check-summing -facilities of the Zlib library by Jean-loup Gailly and Mark Adler. It has the -following subcommands. -.SS "COMPRESSION SUBCOMMANDS" -.TP -\fBzlib compress\fI string\fR ?\fIlevel\fR? -. -Returns the zlib-format compressed binary data of the binary string in -\fIstring\fR. If present, \fIlevel\fR gives the compression level to use (from -0, which is uncompressed, to 9, maximally compressed). -.TP -\fBzlib decompress\fI string\fR ?\fIbufferSize\fR? -. -Returns the uncompressed version of the raw compressed binary data in -\fIstring\fR. If present, \fIbufferSize\fR is a hint as to what size of buffer -is to be used to receive the data. -.TP -\fBzlib deflate\fI string\fR ?\fIlevel\fR? -. -Returns the raw compressed binary data of the binary string in \fIstring\fR. -If present, \fIlevel\fR gives the compression level to use (from 0, which is -uncompressed, to 9, maximally compressed). -.TP -\fBzlib gunzip\fI string\fR ?\fB\-headerVar \fIvarName\fR? -. -Return the uncompressed contents of binary string \fIstring\fR, which must -have been in gzip format. If \fB\-headerVar\fR is given, store a dictionary -describing the contents of the gzip header in the variable called -\fIvarName\fR. The keys of the dictionary that may be present are: -.RS -.TP -\fBcomment\fR -. -The comment field from the header, if present. -.TP -\fBcrc\fR -. -A boolean value describing whether a CRC of the header is computed. -.TP -\fBfilename\fR -. -The filename field from the header, if present. -.TP -\fBos\fR -. -The operating system type code field from the header (if not the -QW unknown -value). See RFC 1952 for the meaning of these codes. -.TP -\fBsize\fR -. -The size of the uncompressed data. -.TP -\fBtime\fR -. -The time field from the header if non-zero, expected to be time that the file -named by the \fBfilename\fR field was modified. Suitable for use with -\fBclock format\fR. -.TP -\fBtype\fR -. -The type of the uncompressed data (\fBbinary\fR or \fBtext\fR) if known. -.RE -.TP -\fBzlib gzip\fI string\fR ?\fB\-level \fIlevel\fR? ?\fB\-header \fIdict\fR? -. -Return the compressed contents of binary string \fIstring\fR in gzip format. -If \fB\-level\fR is given, \fIlevel\fR gives the compression level to use -(from 0, which is uncompressed, to 9, maximally compressed). If \fB\-header\fR -is given, \fIdict\fR is a dictionary containing values used for the gzip -header. The following keys may be defined: -.RS -.TP -\fBcomment\fR -. -Add the given comment to the header of the gzip-format data. -.TP -\fBcrc\fR -. -A boolean saying whether to compute a CRC of the header. Note that if the data -is to be interchanged with the \fBgzip\fR program, a header CRC should -\fInot\fR be computed. -.TP -\fBfilename\fR -. -The name of the file that the data to be compressed came from. -.TP -\fBos\fR -. -The operating system type code, which should be one of the values described in -RFC 1952. -.TP -\fBtime\fR -. -The time that the file named in the \fBfilename\fR key was last modified. This -will be in the same as is returned by \fBclock seconds\fR or \fBfile mtime\fR. -.TP -\fBtype\fR -. -The type of the data being compressed, being \fBbinary\fR or \fBtext\fR. -.RE -.TP -\fBzlib inflate\fI string\fR ?\fIbufferSize\fR? -. -Returns the uncompressed version of the raw compressed binary data in -\fIstring\fR. If present, \fIbufferSize\fR is a hint as to what size of buffer -is to be used to receive the data. -.SS "CHANNEL SUBCOMMAND" -.TP -\fBzlib push\fI mode channel\fR ?\fIoptions ...\fR? -. -Pushes a compressing or decompressing transformation onto the channel -\fIchannel\fR. -The transformation can be removed again with \fBchan pop\fR. -The \fImode\fR argument determines what type of transformation -is pushed; the following are supported: -.RS -.TP -\fBcompress\fR -. -The transformation will be a compressing transformation that produces -zlib-format data on \fIchannel\fR, which must be writable. -.TP -\fBdecompress\fR -. -The transformation will be a decompressing transformation that reads -zlib-format data from \fIchannel\fR, which must be readable. -.TP -\fBdeflate\fR -. -The transformation will be a compressing transformation that produces raw -compressed data on \fIchannel\fR, which must be writable. -.TP -\fBgunzip\fR -. -The transformation will be a decompressing transformation that reads -gzip-format data from \fIchannel\fR, which must be readable. -.TP -\fBgzip\fR -. -The transformation will be a compressing transformation that produces -gzip-format data on \fIchannel\fR, which must be writable. -.TP -\fBinflate\fR -. -The transformation will be a decompressing transformation that reads raw -compressed data from \fIchannel\fR, which must be readable. -.PP -The following options may be set when creating a transformation via -the -.QW "\fIoptions ...\fR" -to the \fBzlib push\fR command: -.TP -\fB\-dictionary\fI binData\fR -.VS "TIP 400" -Sets the compression dictionary to use when working with compressing or -decompressing the data to be \fIbinData\fR. Not valid for transformations that -work with gzip-format data. The dictionary should consist of strings (byte -sequences) that are likely to be encountered later in the data to be compressed, -with the most commonly used strings preferably put towards the end of the -dictionary. Tcl provides no mechanism for choosing a good such dictionary for -a particular data sequence. -.VE -.TP -\fB\-header\fI dictionary\fR -. -Passes a description of the gzip header to create, in the same format that -\fBzlib gzip\fR understands. -.TP -\fB\-level\fI compressionLevel\fR -. -How hard to compress the data. Must be an integer from 0 (uncompressed) to 9 -(maximally compressed). -.TP -\fB\-limit\fI readaheadLimit\fR -. -The maximum number of bytes ahead to read when decompressing. -.RS -.PP -This option has become \fBirrelevant\fR. It was originally introduced -to prevent Tcl from reading beyond the end of a compressed stream in -multi-stream channels to ensure that the data after was left alone for -further reading, at the cost of speed. -.PP -Tcl now automatically returns any bytes it has read beyond the end of -a compressed stream back to the channel, making them appear as unread -to further readers. -.RE -.PP -Both compressing and decompressing channel transformations add extra -configuration options that may be accessed through \fBchan configure\fR. The -options are: -.TP -\fB\-checksum\fI checksum\fR -. -This read-only option gets the current checksum for the uncompressed data that -the compression engine has seen so far. It is valid for both compressing and -decompressing transforms, but not for the raw inflate and deflate formats. The -compression algorithm depends on what format is being produced or consumed. -.TP -\fB\-dictionary\fI binData\fR -.VS "TIP 400" -This read-write options gets or sets the initial compression dictionary to use -when working with compressing or decompressing the data to be \fIbinData\fR. -It is not valid for transformations that work with gzip-format data, and should -not normally be set on compressing transformations other than at the point where -the transformation is stacked. Note that this cannot be used to get the -current active compression dictionary mid-stream, as that information is not -exposed by the underlying library. -.VE -.TP -\fB\-flush\fI type\fR -. -This write-only operation flushes the current state of the compressor to the -underlying channel. It is only valid for compressing transformations. The -\fItype\fR must be either \fBsync\fR or \fBfull\fR for a normal flush or an -expensive flush respectively. Flushing degrades the compression ratio, but -makes it easier for a decompressor to recover more of the file in the case of -data corruption. -.TP -\fB\-header\fI dictionary\fR -. -This read-only option, only valid for decompressing transforms that are -processing gzip-format data, returns the dictionary describing the header read -off the data stream. -.TP -\fB\-limit\fI readaheadLimit\fR -. -This read-write option is used by decompressing channels to control the -maximum number of bytes ahead to read from the underlying data source. See -above for more information. -.RE -.SS "STREAMING SUBCOMMAND" -.TP -\fBzlib stream\fI mode\fR ?\fIoptions\fR? -. -Creates a streaming compression or decompression command based on the -\fImode\fR, and return the name of the command. For a description of how that -command works, see \fBSTREAMING INSTANCE COMMAND\fR below. The following modes -and \fIoptions\fR are supported: -.RS -.TP -\fBzlib stream compress\fR ?\fB\-dictionary \fIbindata\fR? ?\fB\-level \fIlevel\fR? -. -The stream will be a compressing stream that produces zlib-format output, -using compression level \fIlevel\fR (if specified) which will be an integer -from 0 to 9, -.VS "TIP 400" -and the compression dictionary \fIbindata\fR (if specified). -.VE -.TP -\fBzlib stream decompress\fR ?\fB\-dictionary \fIbindata\fR? -. -The stream will be a decompressing stream that takes zlib-format input and -produces uncompressed output. -.VS "TIP 400" -If \fIbindata\fR is supplied, it is a compression dictionary to use if -required. -.VE -.TP -\fBzlib stream deflate\fR ?\fB\-dictionary \fIbindata\fR? ?\fB\-level \fIlevel\fR? -. -The stream will be a compressing stream that produces raw output, using -compression level \fIlevel\fR (if specified) which will be an integer from 0 -to 9, -.VS "TIP 400" -and the compression dictionary \fIbindata\fR (if specified). Note that -the raw compressed data includes no metadata about what compression -dictionary was used, if any; that is a feature of the zlib-format data. -.VE -.TP -\fBzlib stream gunzip\fR -. -The stream will be a decompressing stream that takes gzip-format input and -produces uncompressed output. -.TP -\fBzlib stream gzip\fR ?\fB\-header \fIheader\fR? ?\fB\-level \fIlevel\fR? -. -The stream will be a compressing stream that produces gzip-format output, -using compression level \fIlevel\fR (if specified) which will be an integer -from 0 to 9, and the header descriptor dictionary \fIheader\fR (if specified; -for keys see \fBzlib gzip\fR). -.TP -\fBzlib stream inflate\fR ?\fB\-dictionary \fIbindata\fR? -. -The stream will be a decompressing stream that takes raw compressed input and -produces uncompressed output. -.VS "TIP 400" -If \fIbindata\fR is supplied, it is a compression dictionary to use. Note that -there are no checks in place to determine whether the compression dictionary -is correct. -.VE -.RE -.SS "CHECKSUMMING SUBCOMMANDS" -.TP -\fBzlib adler32\fI string\fR ?\fIinitValue\fR? -. -Compute a checksum of binary string \fIstring\fR using the Adler-32 algorithm. -If given, \fIinitValue\fR is used to initialize the checksum engine. -.TP -\fBzlib crc32\fI string\fR ?\fIinitValue\fR? -. -Compute a checksum of binary string \fIstring\fR using the CRC-32 algorithm. -If given, \fIinitValue\fR is used to initialize the checksum engine. -.SH "STREAMING INSTANCE COMMAND" -.PP -Streaming compression instance commands are produced by the \fBzlib stream\fR -command. They are used by calling their \fBput\fR subcommand one or more times -to load data in, and their \fBget\fR subcommand one or more times to extract -the transformed data. -.PP -The full set of subcommands supported by a streaming instance command, -\fIstream\fR, is as follows: -.TP -\fIstream \fBadd\fR ?\fIoption...\fR? \fIdata\fR -. -A short-cut for -.QW "\fIstream \fBput \fR?\fIoption...\fR? \fIdata\fR" -followed by -.QW "\fIstream \fBget\fR" . -.TP -\fIstream \fBchecksum\fR -. -Returns the checksum of the uncompressed data seen so far by this stream. -.TP -\fIstream \fBclose\fR -. -Deletes this stream and frees up all resources associated with it. -.TP -\fIstream \fBeof\fR -. -Returns a boolean indicating whether the end of the stream (as determined by -the compressed data itself) has been reached. Not all formats support -detection of the end of the stream. -.TP -\fIstream \fBfinalize\fR -. -A short-cut for -.QW "\fIstream \fBput \-finalize {}\fR" . -.TP -\fIstream \fBflush\fR -. -A short-cut for -.QW "\fIstream \fBput \-flush {}\fR" . -.TP -\fIstream \fBfullflush\fR -. -A short-cut for -.QW "\fIstream \fBput \-fullflush {}\fR" . -.TP -\fIstream \fBget \fR?\fIcount\fR? -. -Return up to \fIcount\fR bytes from \fIstream\fR's internal buffers with the -transformation applied. If \fIcount\fR is omitted, the entire contents of the -buffers are returned. -. -\fIstream \fBheader\fR -. -Return the gzip header description dictionary extracted from the stream. Only -supported for streams created with their \fImode\fR parameter set to -\fBgunzip\fR. -.TP -\fIstream \fBput\fR ?\fIoption...\fR? \fIdata\fR -. -Append the contents of the binary string \fIdata\fR to \fIstream\fR's internal -buffers while applying the transformation. The following \fIoption\fRs are -supported (or an unambiguous prefix of them), which are used to modify the -way in which the transformation is applied: -.RS -.TP -\fB\-dictionary\fI binData\fR -.VS "TIP 400" -Sets the compression dictionary to use when working with compressing or -decompressing the data to be \fIbinData\fR. -.VE -.TP -\fB\-finalize\fR -. -Mark the stream as finished, ensuring that all bytes have been wholly -compressed or decompressed. For gzip streams, this also ensures that the -footer is written to the stream. The stream will need to be reset before -having more data written to it after this, though data can still be read out -of the stream with the \fBget\fR subcommand. -.RS -.PP -This option is mutually exclusive with the \fB\-flush\fR and \fB\-fullflush\fR -options. -.RE -.TP -\fB\-flush\fR -. -Ensure that a decompressor consuming the bytes that the current (compressing) -stream is producing will be able to produce all the bytes that have been -compressed so far, at some performance penalty. -.RS -.PP -This option is mutually exclusive with the \fB\-finalize\fR and -\fB\-fullflush\fR options. -.RE -.TP -\fB\-fullflush\fR -. -Ensure that not only can a decompressor handle all the bytes produced so far -(as with \fB\-flush\fR above) but also that it can restart from this point if -it detects that the stream is partially corrupt. This incurs a substantial -performance penalty. -.RS -.PP -This option is mutually exclusive with the \fB\-finalize\fR and \fB\-flush\fR -options. -.RE -.RE -.TP -\fIstream \fBreset\fR -. -Puts any stream, including those that have been finalized or that have reached -eof, back into a state where it can process more data. Throws away all -internally buffered data. -.SH EXAMPLES -.PP -To compress a Tcl string, it should be first converted to a particular charset -encoding since the \fBzlib\fR command always operates on binary strings. -.PP -.CS -set binData [encoding convertto utf-8 $string] -set compData [\fBzlib compress\fR $binData] -.CE -.PP -When converting back, it is also important to reverse the charset encoding: -.PP -.CS -set binData [\fBzlib decompress\fR $compData] -set string [encoding convertfrom utf-8 $binData] -.CE -.PP -The compression operation from above can also be done with streams, which is -especially helpful when you want to accumulate the data by stages: -.PP -.CS -set strm [\fBzlib stream\fR compress] -$\fIstrm \fBput\fR [encoding convertto utf-8 $string] -# ... -$\fIstrm \fBfinalize\fR -set compData [$\fIstrm \fBget\fR] -$\fIstrm \fBclose\fR -.CE -.SH "SEE ALSO" -binary(n), chan(n), encoding(n), Tcl_ZlibDeflate(3), RFC1950 \- RFC1952 -.SH "KEYWORDS" -compress, decompress, deflate, gzip, inflate, zlib -'\" Local Variables: -'\" mode: nroff -'\" End: Index: generic/regc_color.c ================================================================== --- generic/regc_color.c +++ generic/regc_color.c @@ -35,11 +35,11 @@ #define CISERR() VISERR(cm->v) #define CERR(e) VERR(cm->v, (e)) /* - initcm - set up new colormap - ^ static void initcm(struct vars *, struct colormap *); + ^ static VOID initcm(struct vars *, struct colormap *); */ static void initcm( struct vars *v, struct colormap *cm) @@ -86,11 +86,11 @@ cd->block = t; } /* - freecm - free dynamically-allocated things in a colormap - ^ static void freecm(struct colormap *); + ^ static VOID freecm(struct colormap *); */ static void freecm( struct colormap *cm) { @@ -114,11 +114,11 @@ } } /* - cmtreefree - free a non-terminal part of a colormap tree - ^ static void cmtreefree(struct colormap *, union tree *, int); + ^ static VOID cmtreefree(struct colormap *, union tree *, int); */ static void cmtreefree( struct colormap *cm, union tree *tree, @@ -292,11 +292,11 @@ return (color) (cd - cm->cd); } /* - freecolor - free a color (must have no arcs or subcolor) - ^ static void freecolor(struct colormap *, pcolor); + ^ static VOID freecolor(struct colormap *, pcolor); */ static void freecolor( struct colormap *cm, pcolor co) @@ -325,11 +325,11 @@ assert(cm->free >= 0); while ((size_t) cm->free > cm->max) { cm->free = cm->cd[cm->free].sub; } if (cm->free > 0) { - assert((size_t)cm->free < cm->max); + assert(cm->free < cm->max); pco = cm->free; nco = cm->cd[pco].sub; while (nco > 0) { if ((size_t) nco > cm->max) { /* @@ -337,11 +337,11 @@ */ nco = cm->cd[nco].sub; cm->cd[pco].sub = nco; } else { - assert((size_t)nco < cm->max); + assert(nco < cm->max); pco = nco; nco = cm->cd[pco].sub; } } } @@ -427,11 +427,11 @@ return sco; } /* - subrange - allocate new subcolors to this range of chrs, fill in arcs - ^ static void subrange(struct vars *, pchr, pchr, struct state *, + ^ static VOID subrange(struct vars *, pchr, pchr, struct state *, ^ struct state *); */ static void subrange( struct vars *v, @@ -475,11 +475,11 @@ } } /* - subblock - allocate new subcolors for one tree block of chrs, fill in arcs - ^ static void subblock(struct vars *, pchr, struct state *, struct state *); + ^ static VOID subblock(struct vars *, pchr, struct state *, struct state *); */ static void subblock( struct vars *v, pchr start, /* first of BYTTAB chrs */ @@ -580,11 +580,11 @@ } } /* - okcolors - promote subcolors to full colors - ^ static void okcolors(struct nfa *, struct colormap *); + ^ static VOID okcolors(struct nfa *, struct colormap *); */ static void okcolors( struct nfa *nfa, struct colormap *cm) @@ -641,11 +641,11 @@ } } /* - colorchain - add this arc to the color chain of its color - ^ static void colorchain(struct colormap *, struct arc *); + ^ static VOID colorchain(struct colormap *, struct arc *); */ static void colorchain( struct colormap *cm, struct arc *a) @@ -660,11 +660,11 @@ cd->arcs = a; } /* - uncolorchain - delete this arc from the color chain of its color - ^ static void uncolorchain(struct colormap *, struct arc *); + ^ static VOID uncolorchain(struct colormap *, struct arc *); */ static void uncolorchain( struct colormap *cm, struct arc *a) @@ -686,11 +686,11 @@ a->colorchainRev = NULL; } /* - rainbow - add arcs of all full colors (but one) between specified states - ^ static void rainbow(struct nfa *, struct colormap *, int, pcolor, + ^ static VOID rainbow(struct nfa *, struct colormap *, int, pcolor, ^ struct state *, struct state *); */ static void rainbow( struct nfa *nfa, @@ -713,11 +713,11 @@ } /* - colorcomplement - add arcs of complementary colors * The calling sequence ought to be reconciled with cloneouts(). - ^ static void colorcomplement(struct nfa *, struct colormap *, int, + ^ static VOID colorcomplement(struct nfa *, struct colormap *, int, ^ struct state *, struct state *, struct state *); */ static void colorcomplement( struct nfa *nfa, @@ -746,11 +746,11 @@ ^ #ifdef REG_DEBUG */ /* - dumpcolors - debugging output - ^ static void dumpcolors(struct colormap *, FILE *); + ^ static VOID dumpcolors(struct colormap *, FILE *); */ static void dumpcolors( struct colormap *cm, FILE *f) @@ -775,31 +775,30 @@ } else { fprintf(f, "#%2ld%s(%2d): ", (long) co, has, cd->nchrs); } /* - * Unfortunately, it's hard to do this next bit more efficiently. - * - * Spencer's original coding has the loop iterating from CHR_MIN - * to CHR_MAX, but that's utterly unusable for 32-bit chr, or - * even 16-bit. For debugging purposes it seems fine to print - * only chr codes up to 1000 or so. + * It's hard to do this more efficiently. */ - for (c=CHR_MIN ; c<1000 ; c++) { + for (c=CHR_MIN ; cnchrs < cv->chrspace); cv->chrs[cv->nchrs++] = (chr)c; } /* - addrange - add a range to a cvec - ^ static void addrange(struct cvec *, pchr, pchr); + ^ static VOID addrange(struct cvec *, pchr, pchr); */ static void addrange( struct cvec *cv, /* character vector */ pchr from, /* first character of range */ @@ -127,11 +126,11 @@ return v->cv; } /* - freecvec - free a cvec - ^ static void freecvec(struct cvec *); + ^ static VOID freecvec(struct cvec *); */ static void freecvec( struct cvec *cv) /* character vector */ { Index: generic/regc_lex.c ================================================================== --- generic/regc_lex.c +++ generic/regc_lex.c @@ -425,11 +425,11 @@ break; case CHR('\\'): /* BRE bound ends with \} */ if (INCON(L_BBND) && NEXT1('}')) { v->now++; INTOCON(L_BRE); - RET('}'); + RETV('}', 1); } else { FAILW(REG_BADBR); } break; default: @@ -455,11 +455,11 @@ } NOTE(REG_UNONPOSIX); if (ATEOS()) { FAILW(REG_EESCAPE); } - (void)lexescape(v); + (DISCARD)lexescape(v); switch (v->nexttype) { /* not all escapes okay here */ case PLAIN: return 1; break; case CCLASS: @@ -714,11 +714,11 @@ NOTE(REG_UBSALNUM); NOTE(REG_UUNSPEC); } RETV(PLAIN, *v->now++); } - (void)lexescape(v); + (DISCARD)lexescape(v); if (ISERR()) { FAILW(REG_EESCAPE); } if (v->nexttype == CCLASS) {/* fudge at lexical level */ switch (v->nextvalue) { @@ -830,27 +830,31 @@ break; case CHR('t'): RETV(PLAIN, CHR('\t')); break; case CHR('u'): - c = (uchr) lexdigits(v, 16, 1, 4); + c = (uchr) lexdigits(v, 16, 4, 4); if (ISERR()) { FAILW(REG_EESCAPE); } RETV(PLAIN, c); break; case CHR('U'): - i = lexdigits(v, 16, 1, 8); + i = lexdigits(v, 16, 8, 8); if (ISERR()) { FAILW(REG_EESCAPE); } - if (i > 0xFFFF) { - /* TODO: output a Surrogate pair - */ +#if CHRBITS > 16 + if ((unsigned)i > 0x10FFFF) { + i = 0xFFFD; + } +#else + if ((unsigned)i & ~0xFFFF) { i = 0xFFFD; } - RETV(PLAIN, (uchr) i); +#endif + RETV(PLAIN, (uchr)i); break; case CHR('v'): RETV(PLAIN, CHR('\v')); break; case CHR('w'): @@ -861,11 +865,11 @@ NOTE(REG_ULOCALE); RETV(CCLASS, 'W'); break; case CHR('x'): NOTE(REG_UUNPORT); - c = (uchr) lexdigits(v, 16, 1, 2); + c = lexdigits(v, 16, 1, 255); /* REs >255 long outside spec */ if (ISERR()) { FAILW(REG_EESCAPE); } RETV(PLAIN, c); break; @@ -883,20 +887,20 @@ case CHR('1'): case CHR('2'): case CHR('3'): case CHR('4'): case CHR('5'): case CHR('6'): case CHR('7'): case CHR('8'): case CHR('9'): save = v->now; v->now--; /* put first digit back */ - c = (uchr) lexdigits(v, 10, 1, 255); /* REs >255 long outside spec */ + c = lexdigits(v, 10, 1, 255); /* REs >255 long outside spec */ if (ISERR()) { FAILW(REG_EESCAPE); } /* * Ugly heuristic (first test is "exactly 1 digit?") */ - if (v->now - save == 0 || ((int) c > 0 && (size_t)c <= v->nsubexp)) { + if (v->now - save == 0 || ((int) c > 0 && (int)c <= v->nsubexp)) { NOTE(REG_UBACKREF); RETV(BACKREF, (chr)c); } /* @@ -908,19 +912,14 @@ /* FALLTHRU */ case CHR('0'): NOTE(REG_UUNPORT); v->now--; /* put first digit back */ - c = (uchr) lexdigits(v, 8, 1, 3); + c = 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: assert(iscalpha(c)); FAILW(REG_EESCAPE); /* unknown alphabetic escape */ @@ -929,31 +928,27 @@ assert(NOTREACHED); } /* - lexdigits - slurp up digits and return chr value - ^ static int lexdigits(struct vars *, int, int, int); + ^ static chr lexdigits(struct vars *, int, int, int); */ -static int /* chr value; errors signalled via ERR */ +static chr /* chr value; errors signalled via ERR */ lexdigits( struct vars *v, int base, int minlen, int maxlen) { - int n; + uchr n; /* unsigned to avoid overflow misbehavior */ int len; chr c; int d; - const uchr ub = (uchr) base; + 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'): case CHR('8'): case CHR('9'): @@ -982,11 +977,11 @@ } if (len < minlen) { ERR(REG_EESCAPE); } - return n; + return (chr)n; } /* - brenext - get next BRE token * This is much like EREs except for all the stupid backslashes and the @@ -1003,11 +998,11 @@ switch (c) { case CHR('*'): if (LASTTYPE(EMPTY) || LASTTYPE('(') || LASTTYPE('^')) { RETV(PLAIN, c); } - RET('*'); + RETV('*', 1); break; case CHR('['): if (HAVE(6) && *(v->now+0) == CHR('[') && *(v->now+1) == CHR(':') && (*(v->now+2) == CHR('<') || *(v->now+2) == CHR('>')) && @@ -1104,11 +1099,11 @@ assert(NOTREACHED); } /* - skip - skip white space and comments in expanded form - ^ static void skip(struct vars *); + ^ static VOID skip(struct vars *); */ static void skip( struct vars *v) { @@ -1139,18 +1134,36 @@ } /* - newline - return the chr for a newline * This helps confine use of CHR to this source file. - ^ static chr newline(void); + ^ static chr newline(NOPARMS); */ static chr newline(void) { return CHR('\n'); } +/* + - ch - return the chr sequence for regc_locale.c's fake collating element ch + * This helps confine use of CHR to this source file. Beware that the caller + * knows how long the sequence is. + ^ #ifdef REG_DEBUG + ^ static const chr *ch(NOPARMS); + ^ #endif + */ +#ifdef REG_DEBUG +static const chr * +ch(void) +{ + static const chr chstr[] = { CHR('c'), CHR('h'), CHR('\0') }; + + return chstr; +} +#endif + /* - chrnamed - return the chr known by a given (chr string) name * The code is a bit clumsy, but this routine gets only such specialized * use that it hardly matters. ^ static chr chrnamed(struct vars *, const chr *, const chr *, pchr); Index: generic/regc_locale.c ================================================================== --- generic/regc_locale.c +++ generic/regc_locale.c @@ -138,115 +138,121 @@ {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}, + {0x800, 0x815}, {0x840, 0x858}, {0x860, 0x86A}, {0x870, 0x887}, + {0x889, 0x88E}, {0x8A0, 0x8C9}, {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, 0x1711}, {0x171F, 0x1731}, {0x1740, 0x1751}, {0x1760, 0x176C}, {0x176E, 0x1770}, {0x1780, 0x17B3}, {0x1820, 0x1878}, {0x1880, 0x1884}, {0x1887, 0x18A8}, {0x18B0, 0x18F5}, {0x1900, 0x191E}, {0x1950, 0x196D}, {0x1970, 0x1974}, {0x1980, 0x19AB}, {0x19B0, 0x19C9}, - {0x1A00, 0x1A16}, {0x1A20, 0x1A54}, {0x1B05, 0x1B33}, {0x1B45, 0x1B4B}, + {0x1A00, 0x1A16}, {0x1A20, 0x1A54}, {0x1B05, 0x1B33}, {0x1B45, 0x1B4C}, {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} + {0x2145, 0x2149}, {0x2C00, 0x2CE4}, {0x2CEB, 0x2CEE}, {0x2D00, 0x2D25}, + {0x2D30, 0x2D67}, {0x2D80, 0x2D96}, {0x2DA0, 0x2DA6}, {0x2DA8, 0x2DAE}, + {0x2DB0, 0x2DB6}, {0x2DB8, 0x2DBE}, {0x2DC0, 0x2DC6}, {0x2DC8, 0x2DCE}, + {0x2DD0, 0x2DD6}, {0x2DD8, 0x2DDE}, {0x3031, 0x3035}, {0x3041, 0x3096}, + {0x309D, 0x309F}, {0x30A1, 0x30FA}, {0x30FC, 0x30FF}, {0x3105, 0x312F}, + {0x3131, 0x318E}, {0x31A0, 0x31BF}, {0x31F0, 0x31FF}, {0x3400, 0x4DBF}, + {0x4E00, 0xA48C}, {0xA4D0, 0xA4FD}, {0xA500, 0xA60C}, {0xA610, 0xA61F}, + {0xA640, 0xA66E}, {0xA67F, 0xA69D}, {0xA6A0, 0xA6E5}, {0xA717, 0xA71F}, + {0xA722, 0xA788}, {0xA78B, 0xA7CA}, {0xA7D5, 0xA7D9}, {0xA7F2, 0xA801}, + {0xA803, 0xA805}, {0xA807, 0xA80A}, {0xA80C, 0xA822}, {0xA840, 0xA873}, + {0xA882, 0xA8B3}, {0xA8F2, 0xA8F7}, {0xA90A, 0xA925}, {0xA930, 0xA946}, + {0xA960, 0xA97C}, {0xA984, 0xA9B2}, {0xA9E0, 0xA9E4}, {0xA9E6, 0xA9EF}, + {0xA9FA, 0xA9FE}, {0xAA00, 0xAA28}, {0xAA40, 0xAA42}, {0xAA44, 0xAA4B}, + {0xAA60, 0xAA76}, {0xAA7E, 0xAAAF}, {0xAAB9, 0xAABD}, {0xAADB, 0xAADD}, + {0xAAE0, 0xAAEA}, {0xAAF2, 0xAAF4}, {0xAB01, 0xAB06}, {0xAB09, 0xAB0E}, + {0xAB11, 0xAB16}, {0xAB20, 0xAB26}, {0xAB28, 0xAB2E}, {0xAB30, 0xAB5A}, + {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}, + {0x10570, 0x1057A}, {0x1057C, 0x1058A}, {0x1058C, 0x10592}, {0x10597, 0x105A1}, + {0x105A3, 0x105B1}, {0x105B3, 0x105B9}, {0x10600, 0x10736}, {0x10740, 0x10755}, + {0x10760, 0x10767}, {0x10780, 0x10785}, {0x10787, 0x107B0}, {0x107B2, 0x107BA}, + {0x10800, 0x10805}, {0x1080A, 0x10835}, {0x1083F, 0x10855}, {0x10860, 0x10876}, + {0x10880, 0x1089E}, {0x108E0, 0x108F2}, {0x10900, 0x10915}, {0x10920, 0x10939}, + {0x10980, 0x109B7}, {0x10A10, 0x10A13}, {0x10A15, 0x10A17}, {0x10A19, 0x10A35}, + {0x10A60, 0x10A7C}, {0x10A80, 0x10A9C}, {0x10AC0, 0x10AC7}, {0x10AC9, 0x10AE4}, + {0x10B00, 0x10B35}, {0x10B40, 0x10B55}, {0x10B60, 0x10B72}, {0x10B80, 0x10B91}, + {0x10C00, 0x10C48}, {0x10C80, 0x10CB2}, {0x10CC0, 0x10CF2}, {0x10D00, 0x10D23}, + {0x10E80, 0x10EA9}, {0x10F00, 0x10F1C}, {0x10F30, 0x10F45}, {0x10F70, 0x10F81}, + {0x10FB0, 0x10FC4}, {0x10FE0, 0x10FF6}, {0x11003, 0x11037}, {0x11083, 0x110AF}, + {0x110D0, 0x110E8}, {0x11103, 0x11126}, {0x11150, 0x11172}, {0x11183, 0x111B2}, + {0x111C1, 0x111C4}, {0x11200, 0x11211}, {0x11213, 0x1122B}, {0x11280, 0x11286}, + {0x1128A, 0x1128D}, {0x1128F, 0x1129D}, {0x1129F, 0x112A8}, {0x112B0, 0x112DE}, + {0x11305, 0x1130C}, {0x11313, 0x11328}, {0x1132A, 0x11330}, {0x11335, 0x11339}, + {0x1135D, 0x11361}, {0x11400, 0x11434}, {0x11447, 0x1144A}, {0x1145F, 0x11461}, + {0x11480, 0x114AF}, {0x11580, 0x115AE}, {0x115D8, 0x115DB}, {0x11600, 0x1162F}, + {0x11680, 0x116AA}, {0x11700, 0x1171A}, {0x11740, 0x11746}, {0x11800, 0x1182B}, + {0x118A0, 0x118DF}, {0x118FF, 0x11906}, {0x1190C, 0x11913}, {0x11918, 0x1192F}, + {0x119A0, 0x119A7}, {0x119AA, 0x119D0}, {0x11A0B, 0x11A32}, {0x11A5C, 0x11A89}, + {0x11AB0, 0x11AF8}, {0x11C00, 0x11C08}, {0x11C0A, 0x11C2E}, {0x11C72, 0x11C8F}, + {0x11D00, 0x11D06}, {0x11D0B, 0x11D30}, {0x11D60, 0x11D65}, {0x11D6A, 0x11D89}, + {0x11EE0, 0x11EF2}, {0x11F04, 0x11F10}, {0x11F12, 0x11F33}, {0x12000, 0x12399}, + {0x12480, 0x12543}, {0x12F90, 0x12FF0}, {0x13000, 0x1342F}, {0x13441, 0x13446}, + {0x14400, 0x14646}, {0x16800, 0x16A38}, {0x16A40, 0x16A5E}, {0x16A70, 0x16ABE}, {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} + {0x17000, 0x187F7}, {0x18800, 0x18CD5}, {0x18D00, 0x18D08}, {0x1AFF0, 0x1AFF3}, + {0x1AFF5, 0x1AFFB}, {0x1B000, 0x1B122}, {0x1B150, 0x1B152}, {0x1B164, 0x1B167}, + {0x1B170, 0x1B2FB}, {0x1BC00, 0x1BC6A}, {0x1BC70, 0x1BC7C}, {0x1BC80, 0x1BC88}, + {0x1BC90, 0x1BC99}, {0x1D400, 0x1D454}, {0x1D456, 0x1D49C}, {0x1D4A9, 0x1D4AC}, + {0x1D4AE, 0x1D4B9}, {0x1D4BD, 0x1D4C3}, {0x1D4C5, 0x1D505}, {0x1D507, 0x1D50A}, + {0x1D50D, 0x1D514}, {0x1D516, 0x1D51C}, {0x1D51E, 0x1D539}, {0x1D53B, 0x1D53E}, + {0x1D540, 0x1D544}, {0x1D54A, 0x1D550}, {0x1D552, 0x1D6A5}, {0x1D6A8, 0x1D6C0}, + {0x1D6C2, 0x1D6DA}, {0x1D6DC, 0x1D6FA}, {0x1D6FC, 0x1D714}, {0x1D716, 0x1D734}, + {0x1D736, 0x1D74E}, {0x1D750, 0x1D76E}, {0x1D770, 0x1D788}, {0x1D78A, 0x1D7A8}, + {0x1D7AA, 0x1D7C2}, {0x1D7C4, 0x1D7CB}, {0x1DF00, 0x1DF1E}, {0x1DF25, 0x1DF2A}, + {0x1E030, 0x1E06D}, {0x1E100, 0x1E12C}, {0x1E137, 0x1E13D}, {0x1E290, 0x1E2AD}, + {0x1E2C0, 0x1E2EB}, {0x1E4D0, 0x1E4EB}, {0x1E7E0, 0x1E7E6}, {0x1E7E8, 0x1E7EB}, + {0x1E7F0, 0x1E7FE}, {0x1E800, 0x1E8C4}, {0x1E900, 0x1E943}, {0x1EE00, 0x1EE03}, + {0x1EE05, 0x1EE1F}, {0x1EE29, 0x1EE32}, {0x1EE34, 0x1EE37}, {0x1EE4D, 0x1EE4F}, + {0x1EE67, 0x1EE6A}, {0x1EE6C, 0x1EE72}, {0x1EE74, 0x1EE77}, {0x1EE79, 0x1EE7C}, + {0x1EE80, 0x1EE89}, {0x1EE8B, 0x1EE9B}, {0x1EEA1, 0x1EEA3}, {0x1EEA5, 0x1EEA9}, + {0x1EEAB, 0x1EEBB}, {0x20000, 0x2A6DF}, {0x2A700, 0x2B739}, {0x2B740, 0x2B81D}, + {0x2B820, 0x2CEA1}, {0x2CEB0, 0x2EBE0}, {0x2F800, 0x2FA1D}, {0x30000, 0x3134A}, + {0x31350, 0x323AF} #endif }; #define NUM_ALPHA_RANGE (sizeof(alphaRangeTable)/sizeof(crange)) @@ -257,31 +263,33 @@ 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 + 0xC3D, 0xC5D, 0xC60, 0xC61, 0xC80, 0xCBD, 0xCDD, 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, 0xA7D0, + 0xA7D1, 0xA7D3, 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, + ,0x1003C, 0x1003D, 0x10594, 0x10595, 0x105BB, 0x105BC, 0x10808, 0x10837, 0x10838, + 0x1083C, 0x108F4, 0x108F5, 0x109BE, 0x109BF, 0x10A00, 0x10EB0, 0x10EB1, 0x10F27, + 0x11071, 0x11072, 0x11075, 0x11144, 0x11147, 0x11176, 0x111DA, 0x111DC, 0x1123F, + 0x11240, 0x11288, 0x1130F, 0x11310, 0x11332, 0x11333, 0x1133D, 0x11350, 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 + 0x11D46, 0x11D67, 0x11D68, 0x11D98, 0x11F02, 0x11FB0, 0x16F50, 0x16FE0, 0x16FE1, + 0x16FE3, 0x1AFFD, 0x1AFFE, 0x1B132, 0x1B155, 0x1D49E, 0x1D49F, 0x1D4A2, 0x1D4A5, + 0x1D4A6, 0x1D4BB, 0x1D546, 0x1E14E, 0x1E7ED, 0x1E7EE, 0x1E94B, 0x1EE21, 0x1EE22, + 0x1EE24, 0x1EE27, 0x1EE39, 0x1EE3B, 0x1EE42, 0x1EE47, 0x1EE49, 0x1EE4B, 0x1EE51, + 0x1EE52, 0x1EE54, 0x1EE57, 0x1EE59, 0x1EE5B, 0x1EE5D, 0x1EE5F, 0x1EE61, 0x1EE62, + 0x1EE64, 0x1EE7E #endif }; #define NUM_ALPHA_CHAR (sizeof(alphaCharTable)/sizeof(chr)) @@ -292,19 +300,19 @@ 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}, + ,{0x13430, 0x1343F}, {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 + 0xAD, 0x61C, 0x6DD, 0x70F, 0x890, 0x891, 0x8E2, 0x180E, 0xFEFF #if CHRBITS > 16 ,0x110BD, 0x110CD, 0xE0001 #endif }; @@ -328,12 +336,13 @@ #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} + {0x11DA0, 0x11DA9}, {0x11F50, 0x11F59}, {0x16A60, 0x16A69}, {0x16AC0, 0x16AC9}, + {0x16B50, 0x16B59}, {0x1D7CE, 0x1D7FF}, {0x1E140, 0x1E149}, {0x1E2F0, 0x1E2F9}, + {0x1E4F0, 0x1E4F9}, {0x1E950, 0x1E959}, {0x1FBF0, 0x1FBF9} #endif }; #define NUM_DIGIT_RANGE (sizeof(digitRangeTable)/sizeof(crange)) @@ -345,55 +354,57 @@ * 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} + {0x55A, 0x55F}, {0x61D, 0x61F}, {0x66A, 0x66D}, {0x700, 0x70D}, + {0x7F7, 0x7F9}, {0x830, 0x83E}, {0xF04, 0xF12}, {0xF3A, 0xF3D}, + {0xFD0, 0xFD4}, {0x104A, 0x104F}, {0x1360, 0x1368}, {0x16EB, 0x16ED}, + {0x17D4, 0x17D6}, {0x17D8, 0x17DA}, {0x1800, 0x180A}, {0x1AA0, 0x1AA6}, + {0x1AA8, 0x1AAD}, {0x1B5A, 0x1B60}, {0x1BFC, 0x1BFF}, {0x1C3B, 0x1C3F}, + {0x1CC0, 0x1CC7}, {0x2010, 0x2027}, {0x2030, 0x2043}, {0x2045, 0x2051}, + {0x2053, 0x205E}, {0x2308, 0x230B}, {0x2768, 0x2775}, {0x27E6, 0x27EF}, + {0x2983, 0x2998}, {0x29D8, 0x29DB}, {0x2CF9, 0x2CFC}, {0x2E00, 0x2E2E}, + {0x2E30, 0x2E4F}, {0x2E52, 0x2E5D}, {0x3001, 0x3003}, {0x3008, 0x3011}, + {0x3014, 0x301F}, {0xA60D, 0xA60F}, {0xA6F2, 0xA6F7}, {0xA874, 0xA877}, + {0xA8F8, 0xA8FA}, {0xA9C1, 0xA9CD}, {0xAA5C, 0xAA5F}, {0xFE10, 0xFE19}, + {0xFE30, 0xFE52}, {0xFE54, 0xFE61}, {0xFF01, 0xFF03}, {0xFF05, 0xFF0A}, + {0xFF0C, 0xFF0F}, {0xFF3B, 0xFF3D}, {0xFF5F, 0xFF65} #if CHRBITS > 16 ,{0x10100, 0x10102}, {0x10A50, 0x10A58}, {0x10AF0, 0x10AF6}, {0x10B39, 0x10B3F}, - {0x10B99, 0x10B9C}, {0x10F55, 0x10F59}, {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} + {0x10B99, 0x10B9C}, {0x10F55, 0x10F59}, {0x10F86, 0x10F89}, {0x11047, 0x1104D}, + {0x110BE, 0x110C1}, {0x11140, 0x11143}, {0x111C5, 0x111C8}, {0x111DD, 0x111DF}, + {0x11238, 0x1123D}, {0x1144B, 0x1144F}, {0x115C1, 0x115D7}, {0x11641, 0x11643}, + {0x11660, 0x1166C}, {0x1173C, 0x1173E}, {0x11944, 0x11946}, {0x11A3F, 0x11A46}, + {0x11A9A, 0x11A9C}, {0x11A9E, 0x11AA2}, {0x11B00, 0x11B09}, {0x11C41, 0x11C45}, + {0x11F43, 0x11F4F}, {0x12470, 0x12474}, {0x16B37, 0x16B3B}, {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, + 0x60D, 0x61B, 0x6D4, 0x85E, 0x964, 0x965, 0x970, 0x9FD, 0xA76, + 0xAF0, 0xC77, 0xC84, 0xDF4, 0xE4F, 0xE5A, 0xE5B, 0xF14, 0xF85, + 0xFD9, 0xFDA, 0x10FB, 0x1400, 0x166E, 0x169B, 0x169C, 0x1735, 0x1736, + 0x1944, 0x1945, 0x1A1E, 0x1A1F, 0x1B7D, 0x1B7E, 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 + 0x29FD, 0x2CFE, 0x2CFF, 0x2D70, 0x3030, 0x303D, 0x30A0, 0x30FB, 0xA4FE, + 0xA4FF, 0xA673, 0xA67E, 0xA8CE, 0xA8CF, 0xA8FC, 0xA92E, 0xA92F, 0xA95F, + 0xA9DE, 0xA9DF, 0xAADE, 0xAADF, 0xAAF0, 0xAAF1, 0xABEB, 0xFD3E, 0xFD3F, + 0xFE63, 0xFE68, 0xFE6A, 0xFE6B, 0xFF1A, 0xFF1B, 0xFF1F, 0xFF20, 0xFF3F, + 0xFF5B, 0xFF5D #if CHRBITS > 16 ,0x1039F, 0x103D0, 0x1056F, 0x10857, 0x1091F, 0x1093F, 0x10A7F, 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 + 0x114C6, 0x116B9, 0x1183B, 0x119E2, 0x11C70, 0x11C71, 0x11EF7, 0x11EF8, 0x11FFF, + 0x12FF1, 0x12FF2, 0x16A6E, 0x16A6F, 0x16AF5, 0x16B44, 0x16FE2, 0x1BC9F, 0x1E95E, + 0x1E95F #endif }; #define NUM_PUNCT_CHAR (sizeof(punctCharTable)/sizeof(chr)) @@ -406,11 +417,11 @@ }; #define NUM_SPACE_RANGE (sizeof(spaceRangeTable)/sizeof(crange)) static const chr spaceCharTable[] = { - 0x20, 0x85, 0xA0, 0x1680, 0x180E, 0x2028, 0x2029, 0x202F, 0x205F, + 0x20, 0xA0, 0x1680, 0x180E, 0x2028, 0x2029, 0x202F, 0x205F, 0x2060, 0x3000, 0xFEFF }; #define NUM_SPACE_CHAR (sizeof(spaceCharTable)/sizeof(chr)) @@ -427,22 +438,24 @@ {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}, + {0x2C30, 0x2C5F}, {0x2C76, 0x2C7B}, {0x2D00, 0x2D25}, {0xA72F, 0xA731}, {0xA771, 0xA778}, {0xA793, 0xA795}, {0xAB30, 0xAB5A}, {0xAB60, 0xAB68}, {0xAB70, 0xABBF}, {0xFB00, 0xFB06}, {0xFB13, 0xFB17}, {0xFF41, 0xFF5A} #if CHRBITS > 16 - ,{0x10428, 0x1044F}, {0x104D8, 0x104FB}, {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} + ,{0x10428, 0x1044F}, {0x104D8, 0x104FB}, {0x10597, 0x105A1}, {0x105A3, 0x105B1}, + {0x105B3, 0x105B9}, {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}, {0x1DF00, 0x1DF09}, {0x1DF0B, 0x1DF1E}, + {0x1DF25, 0x1DF2A}, {0x1E922, 0x1E943} #endif }; #define NUM_LOWER_RANGE (sizeof(lowerRangeTable)/sizeof(crange)) @@ -508,14 +521,14 @@ 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 + 0xA7AF, 0xA7B5, 0xA7B7, 0xA7B9, 0xA7BB, 0xA7BD, 0xA7BF, 0xA7C1, 0xA7C3, + 0xA7C8, 0xA7CA, 0xA7D1, 0xA7D3, 0xA7D5, 0xA7D7, 0xA7D9, 0xA7F6, 0xA7FA #if CHRBITS > 16 - ,0x1D4BB, 0x1D7CB + ,0x105BB, 0x105BC, 0x1D4BB, 0x1D7CB #endif }; #define NUM_LOWER_CHAR (sizeof(lowerCharTable)/sizeof(chr)) @@ -530,22 +543,22 @@ {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}, + {0x2119, 0x211D}, {0x212A, 0x212D}, {0x2130, 0x2133}, {0x2C00, 0x2C2F}, {0x2C62, 0x2C64}, {0x2C6D, 0x2C70}, {0x2C7E, 0x2C80}, {0xA7AA, 0xA7AE}, {0xA7B0, 0xA7B4}, {0xA7C4, 0xA7C7}, {0xFF21, 0xFF3A} #if CHRBITS > 16 - ,{0x10400, 0x10427}, {0x104B0, 0x104D3}, {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} + ,{0x10400, 0x10427}, {0x104B0, 0x104D3}, {0x10570, 0x1057A}, {0x1057C, 0x1058A}, + {0x1058C, 0x10592}, {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)) @@ -611,14 +624,15 @@ 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 + 0xA7B8, 0xA7BA, 0xA7BC, 0xA7BE, 0xA7C0, 0xA7C2, 0xA7C9, 0xA7D0, 0xA7D6, + 0xA7D8, 0xA7F5 #if CHRBITS > 16 - ,0x1D49C, 0x1D49E, 0x1D49F, 0x1D4A2, 0x1D4A5, 0x1D4A6, 0x1D504, 0x1D505, 0x1D538, - 0x1D539, 0x1D546, 0x1D7CA + ,0x10594, 0x10595, 0x1D49C, 0x1D49E, 0x1D49F, 0x1D4A2, 0x1D4A5, 0x1D4A6, 0x1D504, + 0x1D505, 0x1D538, 0x1D539, 0x1D546, 0x1D7CA #endif }; #define NUM_UPPER_CHAR (sizeof(upperCharTable)/sizeof(chr)) @@ -628,150 +642,156 @@ 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}, + {0x5EF, 0x5F4}, {0x606, 0x61B}, {0x61D, 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}, + {0x830, 0x83E}, {0x840, 0x85B}, {0x860, 0x86A}, {0x870, 0x88E}, + {0x898, 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}, {0xC3C, 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}, {0xCF1, 0xCF3}, {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}, + {0xEC8, 0xECE}, {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}, + {0x1400, 0x167F}, {0x1681, 0x169C}, {0x16A0, 0x16F8}, {0x1700, 0x1715}, + {0x171F, 0x1736}, {0x1740, 0x1753}, {0x1760, 0x176C}, {0x176E, 0x1770}, + {0x1780, 0x17DD}, {0x17E0, 0x17E9}, {0x17F0, 0x17F9}, {0x1800, 0x180D}, + {0x180F, 0x1819}, {0x1820, 0x1878}, {0x1880, 0x18AA}, {0x18B0, 0x18F5}, + {0x1900, 0x191E}, {0x1920, 0x192B}, {0x1930, 0x193B}, {0x1944, 0x196D}, + {0x1970, 0x1974}, {0x1980, 0x19AB}, {0x19B0, 0x19C9}, {0x19D0, 0x19DA}, + {0x19DE, 0x1A1B}, {0x1A1E, 0x1A5E}, {0x1A60, 0x1A7C}, {0x1A7F, 0x1A89}, + {0x1A90, 0x1A99}, {0x1AA0, 0x1AAD}, {0x1AB0, 0x1ACE}, {0x1B00, 0x1B4C}, + {0x1B50, 0x1B7E}, {0x1B80, 0x1BF3}, {0x1BFC, 0x1C37}, {0x1C3B, 0x1C49}, + {0x1C4D, 0x1C88}, {0x1C90, 0x1CBA}, {0x1CBD, 0x1CC7}, {0x1CD0, 0x1CFA}, + {0x1D00, 0x1F15}, {0x1F18, 0x1F1D}, {0x1F20, 0x1F45}, {0x1F48, 0x1F4D}, + {0x1F50, 0x1F57}, {0x1F5F, 0x1F7D}, {0x1F80, 0x1FB4}, {0x1FB6, 0x1FC4}, + {0x1FC6, 0x1FD3}, {0x1FD6, 0x1FDB}, {0x1FDD, 0x1FEF}, {0x1FF2, 0x1FF4}, + {0x1FF6, 0x1FFE}, {0x2010, 0x2027}, {0x2030, 0x205E}, {0x2074, 0x208E}, + {0x2090, 0x209C}, {0x20A0, 0x20C0}, {0x20D0, 0x20F0}, {0x2100, 0x218B}, + {0x2190, 0x2426}, {0x2440, 0x244A}, {0x2460, 0x2B73}, {0x2B76, 0x2B95}, + {0x2B97, 0x2CF3}, {0x2CF9, 0x2D25}, {0x2D30, 0x2D67}, {0x2D7F, 0x2D96}, {0x2DA0, 0x2DA6}, {0x2DA8, 0x2DAE}, {0x2DB0, 0x2DB6}, {0x2DB8, 0x2DBE}, {0x2DC0, 0x2DC6}, {0x2DC8, 0x2DCE}, {0x2DD0, 0x2DD6}, {0x2DD8, 0x2DDE}, - {0x2DE0, 0x2E52}, {0x2E80, 0x2E99}, {0x2E9B, 0x2EF3}, {0x2F00, 0x2FD5}, + {0x2DE0, 0x2E5D}, {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} + {0x3220, 0xA48C}, {0xA490, 0xA4C6}, {0xA4D0, 0xA62B}, {0xA640, 0xA6F7}, + {0xA700, 0xA7CA}, {0xA7D5, 0xA7D9}, {0xA7F2, 0xA82C}, {0xA830, 0xA839}, + {0xA840, 0xA877}, {0xA880, 0xA8C5}, {0xA8CE, 0xA8D9}, {0xA8E0, 0xA953}, + {0xA95F, 0xA97C}, {0xA980, 0xA9CD}, {0xA9CF, 0xA9D9}, {0xA9DE, 0xA9FE}, + {0xAA00, 0xAA36}, {0xAA40, 0xAA4D}, {0xAA50, 0xAA59}, {0xAA5C, 0xAAC2}, + {0xAADB, 0xAAF6}, {0xAB01, 0xAB06}, {0xAB09, 0xAB0E}, {0xAB11, 0xAB16}, + {0xAB20, 0xAB26}, {0xAB28, 0xAB2E}, {0xAB30, 0xAB6B}, {0xAB70, 0xABED}, + {0xABF0, 0xABF9}, {0xAC00, 0xD7A3}, {0xD7B0, 0xD7C6}, {0xD7CB, 0xD7FB}, + {0xF900, 0xFA6D}, {0xFA70, 0xFAD9}, {0xFB00, 0xFB06}, {0xFB13, 0xFB17}, + {0xFB1D, 0xFB36}, {0xFB38, 0xFB3C}, {0xFB46, 0xFBC2}, {0xFBD3, 0xFD8F}, + {0xFD92, 0xFDC7}, {0xFDF0, 0xFE19}, {0xFE20, 0xFE52}, {0xFE54, 0xFE66}, + {0xFE68, 0xFE6B}, {0xFE70, 0xFE74}, {0xFE76, 0xFEFC}, {0xFF01, 0xFFBE}, + {0xFFC2, 0xFFC7}, {0xFFCA, 0xFFCF}, {0xFFD2, 0xFFD7}, {0xFFDA, 0xFFDC}, + {0xFFE0, 0xFFE6}, {0xFFE8, 0xFFEE} #if CHRBITS > 16 ,{0x10000, 0x1000B}, {0x1000D, 0x10026}, {0x10028, 0x1003A}, {0x1003F, 0x1004D}, {0x10050, 0x1005D}, {0x10080, 0x100FA}, {0x10100, 0x10102}, {0x10107, 0x10133}, {0x10137, 0x1018E}, {0x10190, 0x1019C}, {0x101D0, 0x101FD}, {0x10280, 0x1029C}, {0x102A0, 0x102D0}, {0x102E0, 0x102FB}, {0x10300, 0x10323}, {0x1032D, 0x1034A}, {0x10350, 0x1037A}, {0x10380, 0x1039D}, {0x1039F, 0x103C3}, {0x103C8, 0x103D5}, {0x10400, 0x1049D}, {0x104A0, 0x104A9}, {0x104B0, 0x104D3}, {0x104D8, 0x104FB}, - {0x10500, 0x10527}, {0x10530, 0x10563}, {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}, + {0x10500, 0x10527}, {0x10530, 0x10563}, {0x1056F, 0x1057A}, {0x1057C, 0x1058A}, + {0x1058C, 0x10592}, {0x10597, 0x105A1}, {0x105A3, 0x105B1}, {0x105B3, 0x105B9}, + {0x10600, 0x10736}, {0x10740, 0x10755}, {0x10760, 0x10767}, {0x10780, 0x10785}, + {0x10787, 0x107B0}, {0x107B2, 0x107BA}, {0x10800, 0x10805}, {0x1080A, 0x10835}, + {0x1083F, 0x10855}, {0x10857, 0x1089E}, {0x108A7, 0x108AF}, {0x108E0, 0x108F2}, + {0x108FB, 0x1091B}, {0x1091F, 0x10939}, {0x10980, 0x109B7}, {0x109BC, 0x109CF}, + {0x109D2, 0x10A03}, {0x10A0C, 0x10A13}, {0x10A15, 0x10A17}, {0x10A19, 0x10A35}, + {0x10A38, 0x10A3A}, {0x10A3F, 0x10A48}, {0x10A50, 0x10A58}, {0x10A60, 0x10A9F}, + {0x10AC0, 0x10AE6}, {0x10AEB, 0x10AF6}, {0x10B00, 0x10B35}, {0x10B39, 0x10B55}, + {0x10B58, 0x10B72}, {0x10B78, 0x10B91}, {0x10B99, 0x10B9C}, {0x10BA9, 0x10BAF}, + {0x10C00, 0x10C48}, {0x10C80, 0x10CB2}, {0x10CC0, 0x10CF2}, {0x10CFA, 0x10D27}, + {0x10D30, 0x10D39}, {0x10E60, 0x10E7E}, {0x10E80, 0x10EA9}, {0x10EAB, 0x10EAD}, + {0x10EFD, 0x10F27}, {0x10F30, 0x10F59}, {0x10F70, 0x10F89}, {0x10FB0, 0x10FCB}, + {0x10FE0, 0x10FF6}, {0x11000, 0x1104D}, {0x11052, 0x11075}, {0x1107F, 0x110BC}, + {0x110BE, 0x110C2}, {0x110D0, 0x110E8}, {0x110F0, 0x110F9}, {0x11100, 0x11134}, + {0x11136, 0x11147}, {0x11150, 0x11176}, {0x11180, 0x111DF}, {0x111E1, 0x111F4}, + {0x11200, 0x11211}, {0x11213, 0x11241}, {0x11280, 0x11286}, {0x1128A, 0x1128D}, + {0x1128F, 0x1129D}, {0x1129F, 0x112A9}, {0x112B0, 0x112EA}, {0x112F0, 0x112F9}, + {0x11300, 0x11303}, {0x11305, 0x1130C}, {0x11313, 0x11328}, {0x1132A, 0x11330}, + {0x11335, 0x11339}, {0x1133B, 0x11344}, {0x1134B, 0x1134D}, {0x1135D, 0x11363}, + {0x11366, 0x1136C}, {0x11370, 0x11374}, {0x11400, 0x1145B}, {0x1145D, 0x11461}, + {0x11480, 0x114C7}, {0x114D0, 0x114D9}, {0x11580, 0x115B5}, {0x115B8, 0x115DD}, + {0x11600, 0x11644}, {0x11650, 0x11659}, {0x11660, 0x1166C}, {0x11680, 0x116B9}, + {0x116C0, 0x116C9}, {0x11700, 0x1171A}, {0x1171D, 0x1172B}, {0x11730, 0x11746}, + {0x11800, 0x1183B}, {0x118A0, 0x118F2}, {0x118FF, 0x11906}, {0x1190C, 0x11913}, + {0x11918, 0x11935}, {0x1193B, 0x11946}, {0x11950, 0x11959}, {0x119A0, 0x119A7}, + {0x119AA, 0x119D7}, {0x119DA, 0x119E4}, {0x11A00, 0x11A47}, {0x11A50, 0x11AA2}, + {0x11AB0, 0x11AF8}, {0x11B00, 0x11B09}, {0x11C00, 0x11C08}, {0x11C0A, 0x11C36}, + {0x11C38, 0x11C45}, {0x11C50, 0x11C6C}, {0x11C70, 0x11C8F}, {0x11C92, 0x11CA7}, + {0x11CA9, 0x11CB6}, {0x11D00, 0x11D06}, {0x11D0B, 0x11D36}, {0x11D3F, 0x11D47}, + {0x11D50, 0x11D59}, {0x11D60, 0x11D65}, {0x11D6A, 0x11D8E}, {0x11D93, 0x11D98}, + {0x11DA0, 0x11DA9}, {0x11EE0, 0x11EF8}, {0x11F00, 0x11F10}, {0x11F12, 0x11F3A}, + {0x11F3E, 0x11F59}, {0x11FC0, 0x11FF1}, {0x11FFF, 0x12399}, {0x12400, 0x1246E}, + {0x12470, 0x12474}, {0x12480, 0x12543}, {0x12F90, 0x12FF2}, {0x13000, 0x1342F}, + {0x13440, 0x13455}, {0x14400, 0x14646}, {0x16800, 0x16A38}, {0x16A40, 0x16A5E}, + {0x16A60, 0x16A69}, {0x16A6E, 0x16ABE}, {0x16AC0, 0x16AC9}, {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}, {0x1AFF0, 0x1AFF3}, {0x1AFF5, 0x1AFFB}, + {0x1B000, 0x1B122}, {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}, + {0x1BC9C, 0x1BC9F}, {0x1CF00, 0x1CF2D}, {0x1CF30, 0x1CF46}, {0x1CF50, 0x1CFC3}, + {0x1D000, 0x1D0F5}, {0x1D100, 0x1D126}, {0x1D129, 0x1D172}, {0x1D17B, 0x1D1EA}, + {0x1D200, 0x1D245}, {0x1D2C0, 0x1D2D3}, {0x1D2E0, 0x1D2F3}, {0x1D300, 0x1D356}, {0x1D360, 0x1D378}, {0x1D400, 0x1D454}, {0x1D456, 0x1D49C}, {0x1D4A9, 0x1D4AC}, {0x1D4AE, 0x1D4B9}, {0x1D4BD, 0x1D4C3}, {0x1D4C5, 0x1D505}, {0x1D507, 0x1D50A}, {0x1D50D, 0x1D514}, {0x1D516, 0x1D51C}, {0x1D51E, 0x1D539}, {0x1D53B, 0x1D53E}, {0x1D540, 0x1D544}, {0x1D54A, 0x1D550}, {0x1D552, 0x1D6A5}, {0x1D6A8, 0x1D7CB}, - {0x1D7CE, 0x1DA8B}, {0x1DA9B, 0x1DA9F}, {0x1DAA1, 0x1DAAF}, {0x1E000, 0x1E006}, - {0x1E008, 0x1E018}, {0x1E01B, 0x1E021}, {0x1E026, 0x1E02A}, {0x1E100, 0x1E12C}, - {0x1E130, 0x1E13D}, {0x1E140, 0x1E149}, {0x1E2C0, 0x1E2F9}, {0x1E800, 0x1E8C4}, + {0x1D7CE, 0x1DA8B}, {0x1DA9B, 0x1DA9F}, {0x1DAA1, 0x1DAAF}, {0x1DF00, 0x1DF1E}, + {0x1DF25, 0x1DF2A}, {0x1E000, 0x1E006}, {0x1E008, 0x1E018}, {0x1E01B, 0x1E021}, + {0x1E026, 0x1E02A}, {0x1E030, 0x1E06D}, {0x1E100, 0x1E12C}, {0x1E130, 0x1E13D}, + {0x1E140, 0x1E149}, {0x1E290, 0x1E2AE}, {0x1E2C0, 0x1E2F9}, {0x1E4D0, 0x1E4F9}, + {0x1E7E0, 0x1E7E6}, {0x1E7E8, 0x1E7EB}, {0x1E7F0, 0x1E7FE}, {0x1E800, 0x1E8C4}, {0x1E8C7, 0x1E8D6}, {0x1E900, 0x1E94B}, {0x1E950, 0x1E959}, {0x1EC71, 0x1ECB4}, {0x1ED01, 0x1ED3D}, {0x1EE00, 0x1EE03}, {0x1EE05, 0x1EE1F}, {0x1EE29, 0x1EE32}, {0x1EE34, 0x1EE37}, {0x1EE4D, 0x1EE4F}, {0x1EE67, 0x1EE6A}, {0x1EE6C, 0x1EE72}, {0x1EE74, 0x1EE77}, {0x1EE79, 0x1EE7C}, {0x1EE80, 0x1EE89}, {0x1EE8B, 0x1EE9B}, {0x1EEA1, 0x1EEA3}, {0x1EEA5, 0x1EEA9}, {0x1EEAB, 0x1EEBB}, {0x1F000, 0x1F02B}, {0x1F030, 0x1F093}, {0x1F0A0, 0x1F0AE}, {0x1F0B1, 0x1F0BF}, {0x1F0C1, 0x1F0CF}, {0x1F0D1, 0x1F0F5}, {0x1F100, 0x1F1AD}, {0x1F1E6, 0x1F202}, {0x1F210, 0x1F23B}, - {0x1F240, 0x1F248}, {0x1F260, 0x1F265}, {0x1F300, 0x1F6D7}, {0x1F6E0, 0x1F6EC}, - {0x1F6F0, 0x1F6FC}, {0x1F700, 0x1F773}, {0x1F780, 0x1F7D8}, {0x1F7E0, 0x1F7EB}, + {0x1F240, 0x1F248}, {0x1F260, 0x1F265}, {0x1F300, 0x1F6D7}, {0x1F6DC, 0x1F6EC}, + {0x1F6F0, 0x1F6FC}, {0x1F700, 0x1F776}, {0x1F77B, 0x1F7D9}, {0x1F7E0, 0x1F7EB}, {0x1F800, 0x1F80B}, {0x1F810, 0x1F847}, {0x1F850, 0x1F859}, {0x1F860, 0x1F887}, - {0x1F890, 0x1F8AD}, {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} + {0x1F890, 0x1F8AD}, {0x1F900, 0x1FA53}, {0x1FA60, 0x1FA6D}, {0x1FA70, 0x1FA7C}, + {0x1FA80, 0x1FA88}, {0x1FA90, 0x1FABD}, {0x1FABF, 0x1FAC5}, {0x1FACE, 0x1FADB}, + {0x1FAE0, 0x1FAE8}, {0x1FAF0, 0x1FAF8}, {0x1FB00, 0x1FB92}, {0x1FB94, 0x1FBCA}, + {0x1FBF0, 0x1FBF9}, {0x20000, 0x2A6DF}, {0x2A700, 0x2B739}, {0x2B740, 0x2B81D}, + {0x2B820, 0x2CEA1}, {0x2CEB0, 0x2EBE0}, {0x2F800, 0x2FA1D}, {0x30000, 0x3134A}, + {0x31350, 0x323AF}, {0xE0100, 0xE01EF} #endif }; #define NUM_GRAPH_RANGE (sizeof(graphRangeTable)/sizeof(crange)) @@ -779,34 +799,37 @@ 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, + 0xC55, 0xC56, 0xC5D, 0xCD5, 0xCD6, 0xCDD, 0xCDE, 0xDBD, 0xDCA, 0xDD6, 0xE81, 0xE82, 0xE84, 0xEA5, 0xEC6, 0x10C7, 0x10CD, 0x1258, 0x12C0, 0x1772, 0x1773, 0x1940, 0x1F59, 0x1F5B, 0x1F5D, 0x2070, 0x2071, - 0x2D27, 0x2D2D, 0x2D6F, 0x2D70, 0xFB3E, 0xFB40, 0xFB41, 0xFB43, 0xFB44, - 0xFFFC, 0xFFFD + 0x2D27, 0x2D2D, 0x2D6F, 0x2D70, 0xA7D0, 0xA7D1, 0xA7D3, 0xFB3E, 0xFB40, + 0xFB41, 0xFB43, 0xFB44, 0xFDCF, 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 + ,0x1003C, 0x1003D, 0x101A0, 0x10594, 0x10595, 0x105BB, 0x105BC, 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, 0x16FF0, 0x16FF1, 0x1AFFD, + 0x1AFFE, 0x1B132, 0x1B155, 0x1D49E, 0x1D49F, 0x1D4A2, 0x1D4A5, 0x1D4A6, 0x1D4BB, + 0x1D546, 0x1E023, 0x1E024, 0x1E08F, 0x1E14E, 0x1E14F, 0x1E2FF, 0x1E7ED, 0x1E7EE, + 0x1E95E, 0x1E95F, 0x1EE21, 0x1EE22, 0x1EE24, 0x1EE27, 0x1EE39, 0x1EE3B, 0x1EE42, + 0x1EE47, 0x1EE49, 0x1EE4B, 0x1EE51, 0x1EE52, 0x1EE54, 0x1EE57, 0x1EE59, 0x1EE5B, + 0x1EE5D, 0x1EE5F, 0x1EE61, 0x1EE62, 0x1EE64, 0x1EE7E, 0x1EEF0, 0x1EEF1, 0x1F250, + 0x1F251, 0x1F7F0, 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 *); */ @@ -836,11 +859,11 @@ /* * Search table. */ Tcl_DStringInit(&ds); - np = Tcl_UniCharToUtfDString(startp, len, &ds); + np = Tcl_UniCharToUtfDString(startp, (int)len, &ds); for (cn=cnames; cn->name!=NULL; cn++) { if (strlen(cn->name)==len && strncmp(cn->name, np, len)==0) { break; /* NOTE BREAK OUT */ } } @@ -895,13 +918,13 @@ cv = getcvec(v, nchrs, 0); NOERRN(); for (c=a; c<=b; c++) { addchr(cv, c); - lc = Tcl_UniCharToLower(c); - uc = Tcl_UniCharToUpper(c); - tc = Tcl_UniCharToTitle(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); @@ -946,15 +969,15 @@ * Crude fake equivalence class for testing. */ if ((v->cflags®_FAKE) && c == 'x') { cv = getcvec(v, 4, 0); - addchr(cv, 'x'); - addchr(cv, 'y'); + addchr(cv, (chr)'x'); + addchr(cv, (chr)'y'); if (cases) { - addchr(cv, 'X'); - addchr(cv, 'Y'); + addchr(cv, (chr)'X'); + addchr(cv, (chr)'Y'); } return cv; } /* @@ -964,11 +987,11 @@ if (cases) { return allcases(v, c); } cv = getcvec(v, 1, 0); assert(cv != NULL); - addchr(cv, c); + addchr(cv, (chr)c); return cv; } /* - cclass - supply cvec for a character class @@ -985,12 +1008,11 @@ size_t len; struct cvec *cv = NULL; Tcl_DString ds; const char *np; const char *const *namePtr; - size_t i; - int index; + int i, index; /* * The following arrays define the valid character class names. */ @@ -1009,11 +1031,11 @@ * Extract the class name */ len = endp - startp; Tcl_DStringInit(&ds); - np = Tcl_UniCharToUtfDString(startp, len, &ds); + np = Tcl_UniCharToUtfDString(startp, (int)len, &ds); /* * Map the name to the corresponding enumerated value. */ @@ -1044,31 +1066,31 @@ switch((enum classes) index) { case CC_ALNUM: cv = getcvec(v, NUM_ALPHA_CHAR, NUM_DIGIT_RANGE + NUM_ALPHA_RANGE); if (cv) { - for (i=0 ; islast = NULL; nfa->free = NULL; nfa->nstates = 0; nfa->cm = cm; nfa->v = v; + nfa->size = 0; nfa->bos[0] = nfa->bos[1] = COLORLESS; nfa->eos[0] = nfa->eos[1] = COLORLESS; nfa->parent = parent; /* Precedes newfstate so parent is valid. */ nfa->post = newfstate(nfa, '@'); /* number 0 */ nfa->pre = newfstate(nfa, '>'); /* number 1 */ @@ -85,14 +86,69 @@ freenfa(nfa); return NULL; } return nfa; } + +/* + - TooManyStates - checks if the max states exceeds the compile-time value + ^ static int TooManyStates(struct nfa *); + */ +static int +TooManyStates( + struct nfa *nfa) +{ + struct nfa *parent = nfa->parent; + size_t sz = nfa->size; + + while (parent != NULL) { + sz = parent->size; + parent = parent->parent; + } + if (sz > REG_MAX_STATES) { + return 1; + } + return 0; +} + +/* + - IncrementSize - increases the tracked size of the NFA and its parents. + ^ static void IncrementSize(struct nfa *); + */ +static void +IncrementSize( + struct nfa *nfa) +{ + struct nfa *parent = nfa->parent; + + nfa->size++; + while (parent != NULL) { + parent->size++; + parent = parent->parent; + } +} + +/* + - DecrementSize - increases the tracked size of the NFA and its parents. + ^ static void DecrementSize(struct nfa *); + */ +static void +DecrementSize( + struct nfa *nfa) +{ + struct nfa *parent = nfa->parent; + + nfa->size--; + while (parent != NULL) { + parent->size--; + parent = parent->parent; + } +} /* - freenfa - free an entire NFA - ^ static void freenfa(struct nfa *); + ^ static VOID freenfa(struct nfa *); */ static void freenfa( struct nfa *nfa) { @@ -122,24 +178,24 @@ newstate( struct nfa *nfa) { struct state *s; + if (TooManyStates(nfa)) { + /* XXX: add specific error for this */ + NERR(REG_ETOOBIG); + return NULL; + } if (nfa->free != NULL) { s = nfa->free; nfa->free = s->next; } else { - if (nfa->v->spaceused >= REG_MAX_COMPILE_SPACE) { - NERR(REG_ETOOBIG); - return NULL; - } s = (struct state *) MALLOC(sizeof(struct state)); if (s == NULL) { NERR(REG_ESPACE); return NULL; } - nfa->v->spaceused += sizeof(struct state); s->oas.next = NULL; s->free = NULL; s->noas = 0; } @@ -159,10 +215,16 @@ assert(nfa->slast->next == NULL); nfa->slast->next = s; } s->prev = nfa->slast; nfa->slast = s; + + /* + * Track the current size and the parent size. + */ + + IncrementSize(nfa); return s; } /* - newfstate - allocate an NFA state with a specified flag value @@ -182,11 +244,11 @@ return s; } /* - dropstate - delete a state's inarcs and outarcs and free it - ^ static void dropstate(struct nfa *, struct state *); + ^ static VOID dropstate(struct nfa *, struct state *); */ static void dropstate( struct nfa *nfa, struct state *s) @@ -202,11 +264,11 @@ freestate(nfa, s); } /* - freestate - free a state, which has no in-arcs or out-arcs - ^ static void freestate(struct nfa *, struct state *); + ^ static VOID freestate(struct nfa *, struct state *); */ static void freestate( struct nfa *nfa, struct state *s) @@ -229,15 +291,16 @@ nfa->states = s->next; } s->prev = NULL; s->next = nfa->free; /* don't delete it, put it on the free list */ nfa->free = s; + DecrementSize(nfa); } /* - destroystate - really get rid of an already-freed state - ^ static void destroystate(struct nfa *, struct state *); + ^ static VOID destroystate(struct nfa *, struct state *); */ static void destroystate( struct nfa *nfa, struct state *s) @@ -247,22 +310,20 @@ assert(s->no == FREESTATE); for (ab=s->oas.next ; ab!=NULL ; ab=abnext) { abnext = ab->next; FREE(ab); - nfa->v->spaceused -= sizeof(struct arcbatch); } s->ins = NULL; s->outs = NULL; s->next = NULL; FREE(s); - nfa->v->spaceused -= sizeof(struct state); } /* - newarc - set up a new arc within an NFA - ^ static void newarc(struct nfa *, int, pcolor, struct state *, + ^ static VOID newarc(struct nfa *, int, pcolor, struct state *, ^ struct state *); */ /* * This function checks to make sure that no duplicate arcs are created. * In general we never want duplicates. @@ -291,11 +352,11 @@ if (a->from == from && a->co == co && a->type == t) { return; } } } - + /* no dup, so create the arc */ createarc(nfa, t, co, from, to); } /* @@ -376,23 +437,18 @@ /* * if none at hand, get more */ if (s->free == NULL) { - struct arcbatch *newAb; + struct arcbatch *newAb = (struct arcbatch *) + MALLOC(sizeof(struct arcbatch)); int i; - if (nfa->v->spaceused >= REG_MAX_COMPILE_SPACE) { - NERR(REG_ETOOBIG); - return NULL; - } - newAb = (struct arcbatch *) MALLOC(sizeof(struct arcbatch)); if (newAb == NULL) { NERR(REG_ESPACE); return NULL; } - nfa->v->spaceused += sizeof(struct arcbatch); newAb->next = s->oas.next; s->oas.next = newAb; for (i=0 ; ia[i].type = 0; @@ -408,11 +464,11 @@ return a; } /* - freearc - free an arc - ^ static void freearc(struct nfa *, struct arc *); + ^ static VOID freearc(struct nfa *, struct arc *); */ static void freearc( struct nfa *nfa, struct arc *victim) @@ -567,11 +623,11 @@ return NULL; } /* - cparc - allocate a new arc within an NFA, copying details from old one - ^ static void cparc(struct nfa *, struct arc *, struct state *, + ^ static VOID cparc(struct nfa *, struct arc *, struct state *, ^ struct state *); */ static void cparc( struct nfa *nfa, @@ -655,11 +711,11 @@ if (aa->type > bb->type) { return 1; } return 0; } - + /* * sortouts - sort the out arcs of a state by to/color/type */ static void sortouts( @@ -754,11 +810,11 @@ * * However, if we have a whole lot of arcs to deal with, retail duplicate * checks become too slow. In that case we proceed by sorting and merging * the arc lists, and then we can indeed just update the arcs in-place. * - ^ static void moveins(struct nfa *, struct state *, struct state *); + ^ static VOID moveins(struct nfa *, struct state *, struct state *); */ static void moveins( struct nfa *nfa, struct state *oldState, @@ -841,11 +897,11 @@ assert(oldState->ins == NULL); } /* - copyins - copy in arcs of a state to another state - ^ static void copyins(struct nfa *, struct state *, struct state *, int); + ^ static VOID copyins(struct nfa *, struct state *, struct state *, int); */ static void copyins( struct nfa *nfa, struct state *oldState, @@ -1014,11 +1070,11 @@ } } /* - moveouts - move all out arcs of a state to another state - ^ static void moveouts(struct nfa *, struct state *, struct state *); + ^ static VOID moveouts(struct nfa *, struct state *, struct state *); */ static void moveouts( struct nfa *nfa, struct state *oldState, @@ -1098,11 +1154,11 @@ assert(oldState->outs == NULL); } /* - copyouts - copy out arcs of a state to another state - ^ static void copyouts(struct nfa *, struct state *, struct state *, int); + ^ static VOID copyouts(struct nfa *, struct state *, struct state *, int); */ static void copyouts( struct nfa *nfa, struct state *oldState, @@ -1174,11 +1230,11 @@ } } /* - cloneouts - copy out arcs of a state to another state pair, modifying type - ^ static void cloneouts(struct nfa *, struct state *, struct state *, + ^ static VOID cloneouts(struct nfa *, struct state *, struct state *, ^ struct state *, int); */ static void cloneouts( struct nfa *nfa, @@ -1198,11 +1254,11 @@ /* - delsub - delete a sub-NFA, updating subre pointers if necessary * This uses a recursive traversal of the sub-NFA, marking already-seen * states using their tmp pointer. - ^ static void delsub(struct nfa *, struct state *, struct state *); + ^ static VOID delsub(struct nfa *, struct state *, struct state *); */ static void delsub( struct nfa *nfa, struct state *lp, /* the sub-NFA goes from here... */ @@ -1221,11 +1277,11 @@ } /* - deltraverse - the recursive heart of delsub * This routine's basic job is to destroy all out-arcs of the state. - ^ static void deltraverse(struct nfa *, struct state *, struct state *); + ^ static VOID deltraverse(struct nfa *, struct state *, struct state *); */ static void deltraverse( struct nfa *nfa, struct state *leftend, @@ -1264,11 +1320,11 @@ /* - dupnfa - duplicate sub-NFA * Another recursive traversal, this time using tmp to point to duplicates as * well as mark already-seen states. (You knew there was a reason why it's a * state pointer, didn't you? :-)) - ^ static void dupnfa(struct nfa *, struct state *, struct state *, + ^ static VOID dupnfa(struct nfa *, struct state *, struct state *, ^ struct state *, struct state *); */ static void dupnfa( struct nfa *nfa, @@ -1281,27 +1337,26 @@ newarc(nfa, EMPTY, 0, from, to); return; } stop->tmp = to; - duptraverse(nfa, start, from, 0); + duptraverse(nfa, start, from); /* done, except for clearing out the tmp pointers */ stop->tmp = NULL; cleartraverse(nfa, start); } /* - duptraverse - recursive heart of dupnfa - ^ static void duptraverse(struct nfa *, struct state *, struct state *); + ^ static VOID duptraverse(struct nfa *, struct state *, struct state *); */ static void duptraverse( struct nfa *nfa, struct state *s, - struct state *stmp, /* s's duplicate, or NULL */ - int depth) + struct state *stmp) /* s's duplicate, or NULL */ { struct arc *a; if (s->tmp != NULL) { return; /* already done */ @@ -1311,24 +1366,12 @@ if (s->tmp == NULL) { assert(NISERR()); return; } - /* - * Arbitrary depth limit. Needs tuning, but this value is sufficient to - * make all normal tests (not reg-33.14) pass. - */ -#ifndef DUPTRAVERSE_MAX_DEPTH -#define DUPTRAVERSE_MAX_DEPTH 15000 -#endif - - if (depth++ > DUPTRAVERSE_MAX_DEPTH) { - NERR(REG_ESPACE); - } - for (a=s->outs ; a!=NULL && !NISERR() ; a=a->outchain) { - duptraverse(nfa, a->to, NULL, depth); + duptraverse(nfa, a->to, NULL); if (NISERR()) { break; } assert(a->to->tmp != NULL); cparc(nfa, a, s->tmp, a->to->tmp); @@ -1335,11 +1378,11 @@ } } /* - cleartraverse - recursive cleanup for algorithms that leave tmp ptrs set - ^ static void cleartraverse(struct nfa *, struct state *); + ^ static VOID cleartraverse(struct nfa *, struct state *); */ static void cleartraverse( struct nfa *nfa, struct state *s) @@ -1356,11 +1399,11 @@ } } /* - specialcolors - fill in special colors for an NFA - ^ static void specialcolors(struct nfa *); + ^ static VOID specialcolors(struct nfa *); */ static void specialcolors( struct nfa *nfa) { @@ -1439,11 +1482,11 @@ return analyze(nfa); /* and analysis */ } /* - pullback - pull back constraints backward to eliminate them - ^ static void pullback(struct nfa *, FILE *); + ^ static VOID pullback(struct nfa *, FILE *); */ static void pullback( struct nfa *nfa, FILE *f) /* for debug output; NULL none */ @@ -1619,11 +1662,11 @@ return 1; } /* - pushfwd - push forward constraints forward to eliminate them - ^ static void pushfwd(struct nfa *, FILE *); + ^ static VOID pushfwd(struct nfa *, FILE *); */ static void pushfwd( struct nfa *nfa, FILE *f) /* for debug output; NULL none */ @@ -1858,11 +1901,11 @@ return INCOMPATIBLE; /* for benefit of blind compilers */ } /* - fixempties - get rid of EMPTY arcs - ^ static void fixempties(struct nfa *, FILE *); + ^ static VOID fixempties(struct nfa *, FILE *); */ static void fixempties( struct nfa *nfa, FILE *f) /* for debug output; NULL none */ @@ -2018,11 +2061,11 @@ for (a = inarcsorig[s2->no]; a != NULL; a = a->inchain) { if (a->type != EMPTY) { arcarray[arccount++] = a; } } - + /* Reset the tmp fields as we walk back */ nexts = s2->tmp; s2->tmp = NULL; } s->tmp = NULL; @@ -2040,11 +2083,11 @@ while (nskip-- > 0) { a = a->inchain; } inarcsorig[s->no] = a; } - + FREE(arcarray); FREE(inarcsorig); if (NISERR()) { return; @@ -2191,11 +2234,11 @@ /* If we removed all the outarcs, the state is useless. */ if (s->nouts == 0 && !s->flag) { dropstate(nfa, s); } } - + /* Nothing to do if no remaining constraint arcs */ if (NISERR() || !hasconstraints) { return; } @@ -2681,11 +2724,11 @@ } } /* - cleanup - clean up NFA after optimizations - ^ static void cleanup(struct nfa *); + ^ static VOID cleanup(struct nfa *); */ static void cleanup( struct nfa *nfa) { @@ -2722,11 +2765,11 @@ nfa->nstates = n; } /* - markreachable - recursive marking of reachable states - ^ static void markreachable(struct nfa *, struct state *, struct state *, + ^ static VOID markreachable(struct nfa *, struct state *, struct state *, ^ struct state *); */ static void markreachable( struct nfa *nfa, @@ -2746,11 +2789,11 @@ } } /* - markcanreach - recursive marking of states which can reach here - ^ static void markcanreach(struct nfa *, struct state *, struct state *, + ^ static VOID markcanreach(struct nfa *, struct state *, struct state *, ^ struct state *); */ static void markcanreach( struct nfa *nfa, @@ -2794,11 +2837,11 @@ return 0; } /* - compact - construct the compact representation of an NFA - ^ static void compact(struct nfa *, struct cnfa *); + ^ static VOID compact(struct nfa *, struct cnfa *); */ static void compact( struct nfa *nfa, struct cnfa *cnfa) @@ -2814,20 +2857,17 @@ nstates = 0; narcs = 0; for (s = nfa->states; s != NULL; s = s->next) { nstates++; - narcs += s->nouts + 1; /* need one extra for endmarker */ + narcs += 1 + s->nouts + 1; + /* 1 as a fake for flags, nouts for arcs, 1 as endmarker */ } - cnfa->stflags = (char *) MALLOC(nstates * sizeof(char)); cnfa->states = (struct carc **) MALLOC(nstates * sizeof(struct carc *)); cnfa->arcs = (struct carc *) MALLOC(narcs * sizeof(struct carc)); - if (cnfa->stflags == NULL || cnfa->states == NULL || cnfa->arcs == NULL) { - if (cnfa->stflags != NULL) { - FREE(cnfa->stflags); - } + if (cnfa->states == NULL || cnfa->arcs == NULL) { if (cnfa->states != NULL) { FREE(cnfa->states); } if (cnfa->arcs != NULL) { FREE(cnfa->arcs); @@ -2846,12 +2886,13 @@ cnfa->flags = 0; ca = cnfa->arcs; for (s = nfa->states; s != NULL; s = s->next) { assert((size_t) s->no < nstates); - cnfa->stflags[s->no] = 0; cnfa->states[s->no] = ca; + ca->co = 0; /* clear and skip flags "arc" */ + ca++; first = ca; for (a = s->outs; a != NULL; a = a->outchain) { switch (a->type) { case PLAIN: ca->co = a->co; @@ -2881,18 +2922,18 @@ /* * Mark no-progress states. */ for (a = nfa->pre->outs; a != NULL; a = a->outchain) { - cnfa->stflags[a->to->no] = CNFA_NOPROGRESS; + cnfa->states[a->to->no]->co = 1; } - cnfa->stflags[nfa->pre->no] = CNFA_NOPROGRESS; + cnfa->states[nfa->pre->no]->co = 1; } /* - carcsort - sort compacted-NFA arcs by color - ^ static void carcsort(struct carc *, struct carc *); + ^ static VOID carcsort(struct carc *, struct carc *); */ static void carcsort( struct carc *first, size_t n) @@ -2907,11 +2948,11 @@ const void *a, const void *b) { const struct carc *aa = (const struct carc *) a; const struct carc *bb = (const struct carc *) b; - + if (aa->co < bb->co) { return -1; } if (aa->co > bb->co) { return +1; @@ -2925,26 +2966,25 @@ return 0; } /* - freecnfa - free a compacted NFA - ^ static void freecnfa(struct cnfa *); + ^ static VOID freecnfa(struct cnfa *); */ static void freecnfa( struct cnfa *cnfa) { assert(cnfa->nstates != 0); /* not empty already */ cnfa->nstates = 0; - FREE(cnfa->stflags); FREE(cnfa->states); FREE(cnfa->arcs); } /* - dumpnfa - dump an NFA in human-readable form - ^ static void dumpnfa(struct nfa *, FILE *); + ^ static VOID dumpnfa(struct nfa *, FILE *); */ static void dumpnfa( struct nfa *nfa, FILE *f) @@ -2976,13 +3016,10 @@ 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 */ /* @@ -2989,11 +3026,11 @@ ^ #ifdef REG_DEBUG */ /* - dumpstate - dump an NFA state in human-readable form - ^ static void dumpstate(struct state *, FILE *); + ^ static VOID dumpstate(struct state *, FILE *); */ static void dumpstate( struct state *s, FILE *f) @@ -3019,11 +3056,11 @@ } } /* - dumparcs - dump out-arcs in human-readable form - ^ static void dumparcs(struct state *, FILE *); + ^ static VOID dumparcs(struct state *, FILE *); */ static void dumparcs( struct state *s, FILE *f) @@ -3053,11 +3090,11 @@ } } /* - dumparc - dump one outarc in readable form, including prefixing tab - ^ static void dumparc(struct arc *, struct state *, FILE *); + ^ static VOID dumparc(struct arc *, struct state *, FILE *); */ static void dumparc( struct arc *a, struct state *s, @@ -3127,11 +3164,11 @@ */ #endif /* ifdef REG_DEBUG */ /* - dumpcnfa - dump a compacted NFA in human-readable form - ^ static void dumpcnfa(struct cnfa *, FILE *); + ^ static VOID dumpcnfa(struct cnfa *, FILE *); */ static void dumpcnfa( struct cnfa *cnfa, FILE *f) @@ -3155,16 +3192,13 @@ if (cnfa->flags&HASLACONS) { fprintf(f, ", haslacons"); } fprintf(f, "\n"); for (st = 0; st < cnfa->nstates; st++) { - dumpcstate(st, cnfa, f); + dumpcstate(st, cnfa->states[st], cnfa, f); } fflush(f); -#else - (void)cnfa; - (void)f; #endif } #ifdef REG_DEBUG /* subordinates of dumpcnfa */ /* @@ -3171,37 +3205,38 @@ ^ #ifdef REG_DEBUG */ /* - dumpcstate - dump a compacted-NFA state in human-readable form - ^ static void dumpcstate(int, struct cnfa *, FILE *); + ^ static VOID dumpcstate(int, struct carc *, struct cnfa *, FILE *); */ static void dumpcstate( int st, + struct carc *ca, struct cnfa *cnfa, FILE *f) { - struct carc *ca; + int i; int pos; - fprintf(f, "%d%s", st, (cnfa->stflags[st] & CNFA_NOPROGRESS) ? ":" : "."); + fprintf(f, "%d%s", st, (ca[0].co) ? ":" : "."); pos = 1; - for (ca = cnfa->states[st]; ca->co != COLORLESS; ca++) { - if (ca->co < cnfa->ncolors) { - fprintf(f, "\t[%ld]->%d", (long) ca->co, ca->to); + for (i = 1; ca[i].co != COLORLESS; i++) { + if (ca[i].co < cnfa->ncolors) { + fprintf(f, "\t[%ld]->%d", (long) ca[i].co, ca[i].to); } else { - fprintf(f, "\t:%ld:->%d", (long) (ca->co - cnfa->ncolors), ca->to); + fprintf(f, "\t:%ld:->%d", (long) ca[i].co-cnfa->ncolors,ca[i].to); } if (pos == 5) { fprintf(f, "\n"); pos = 1; } else { pos++; } } - if (ca == cnfa->states[st] || pos != 1) { + if (i == 1 || pos != 1) { fprintf(f, "\n"); } fflush(f); } Index: generic/regcomp.c ================================================================== --- generic/regcomp.c +++ generic/regcomp.c @@ -37,11 +37,11 @@ */ /* =====^!^===== 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 *, size_t); +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 *); @@ -54,13 +54,14 @@ static void brackpart(struct vars *, struct state *, struct state *); static const chr *scanplain(struct vars *); static void onechr(struct vars *, pchr, struct state *, struct state *); static void dovec(struct vars *, struct cvec *, struct state *, struct state *); static void wordchrs(struct vars *); -static struct subre *sub_re(struct vars *, int, int, struct state *, struct state *); +static 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 void optst(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 *); @@ -76,14 +77,17 @@ static void prefixes(struct vars *); static void lexnest(struct vars *, const chr *, const chr *); static void lexword(struct vars *); static int next(struct vars *); static int lexescape(struct vars *); -static int lexdigits(struct vars *, int, int, int); +static chr lexdigits(struct vars *, int, int, int); static int brenext(struct vars *, pchr); static void skip(struct vars *); -static chr newline(void); +static chr newline(NOPARMS); +#ifdef REG_DEBUG +static const chr *ch(NOPARMS); +#endif static chr chrnamed(struct vars *, const chr *, const chr *, pchr); /* === regc_color.c === */ static void initcm(struct vars *, struct colormap *); static void freecm(struct colormap *); static void cmtreefree(struct colormap *, union tree *, int); @@ -133,11 +137,11 @@ static void copyouts(struct nfa *, struct state *, struct state *); static void cloneouts(struct nfa *, struct state *, struct state *, struct state *, int); static void delsub(struct nfa *, struct state *, struct state *); static void deltraverse(struct nfa *, struct state *, struct state *); static void dupnfa(struct nfa *, struct state *, struct state *, struct state *, struct state *); -static void duptraverse(struct nfa *, struct state *, struct state *, int); +static void duptraverse(struct nfa *, struct state *, struct state *); static void cleartraverse(struct nfa *, struct state *); static void specialcolors(struct nfa *); static long optimize(struct nfa *, FILE *); static void pullback(struct nfa *, FILE *); static int pull(struct nfa *, struct arc *, struct state **); @@ -171,11 +175,11 @@ static void dumparcs(struct state *, FILE *); static void dumparc(struct arc *, struct state *, FILE *); #endif static void dumpcnfa(struct cnfa *, FILE *); #ifdef REG_DEBUG -static void dumpcstate(int, struct cnfa *, FILE *); +static void dumpcstate(int, struct carc *, struct cnfa *, FILE *); #endif /* === regc_cvec.c === */ static struct cvec *clearcvec(struct cvec *); static void addchr(struct cvec *, pchr); static void addrange(struct cvec *, pchr, pchr); @@ -203,13 +207,13 @@ const chr *savestop; int err; /* error code (0 if none) */ int cflags; /* copy of compile flags */ int lasttype; /* type of previous token */ int nexttype; /* type of next token */ - size_t nextvalue; /* value (if any) of next token */ + chr nextvalue; /* value (if any) of next token */ int lexcon; /* lexical context type (see lex.c) */ - size_t nsubexp; /* subexpression count */ + int nsubexp; /* subexpression count */ struct subre **subs; /* subRE pointer vector */ size_t nsubs; /* length of vector */ struct subre *sub10[10]; /* initial vector, enough for most */ struct nfa *nfa; /* the NFA */ struct colormap *cm; /* character color map */ @@ -216,36 +220,34 @@ color nlcolor; /* color of newline */ struct state *wordchrs; /* state in nfa holding word-char outarcs */ struct subre *tree; /* subexpression tree */ struct subre *treechain; /* all tree nodes allocated */ struct subre *treefree; /* any free tree nodes */ - int ntree; /* number of tree nodes, plus one */ + int ntree; /* number of tree nodes */ struct cvec *cv; /* interface cvec */ struct cvec *cv2; /* utility cvec */ struct subre *lacons; /* lookahead-constraint vector */ - size_t nlacons; /* size of lacons */ - size_t spaceused; /* approx. space used for compilation */ + int nlacons; /* size of lacons */ }; /* parsing macros; most know that `v' is the struct vars pointer */ #define NEXT() (next(v)) /* advance by one token */ #define SEE(t) (v->nexttype == (t)) /* is next token this? */ #define EAT(t) (SEE(t) && next(v)) /* if next is this, swallow it */ #define VISERR(vv) ((vv)->err != 0)/* have we seen an error yet? */ #define ISERR() VISERR(v) -#define VERR(vv,e) ((vv)->nexttype = EOS, \ - (vv)->err = ((vv)->err ? (vv)->err : (e))) +#define VERR(vv,e) \ + ((vv)->nexttype = EOS, ((vv)->err) ? (vv)->err : ((vv)->err = (e))) #define ERR(e) VERR(v, e) /* record an error */ #define NOERR() {if (ISERR()) return;} /* if error seen, return */ #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 INSIST(c, e) ((c) ? 0 : ERR(e)) /* if condition false, error */ #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 */ @@ -266,18 +268,16 @@ /* is an arc colored, and hence on a color chain? */ #define COLORED(a) \ ((a)->type == PLAIN || (a)->type == AHEAD || (a)->type == BEHIND) /* static function list */ -static const struct fns functions = { +static struct fns functions = { rfree, /* regfree insides */ }; /* - compile - compile regular expression - * Note: on failure, no resources remain allocated, so regfree() - * need not be applied to re. ^ int compile(regex_t *, const chr *, size_t, int); */ int compile( regex_t *re, @@ -285,11 +285,12 @@ size_t len, int flags) { AllocVars(v); struct guts *g; - size_t i, j; + int i; + size_t j; FILE *debug = (flags®_PROGRESS) ? stdout : NULL; #define CNOERR() { if (ISERR()) return freev(v, v->err); } /* * Sanity checks. @@ -333,21 +334,21 @@ v->treefree = NULL; 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); + re->re_fns = VS(&functions); /* * More complex setup, malloced things. */ - re->re_guts = (void*)(MALLOC(sizeof(struct guts))); + re->re_guts = VS(MALLOC(sizeof(struct guts))); if (re->re_guts == NULL) { return freev(v, REG_ESPACE); } g = (struct guts *) re->re_guts; g->tree = NULL; @@ -391,10 +392,11 @@ if (debug != NULL) { fprintf(debug, "\n\n\n========= RAW ==========\n"); dumpnfa(v->nfa, debug); dumpst(v->tree, debug, 1); } + optst(v, v->tree); v->ntree = numst(v->tree, 1); markst(v->tree); cleanst(v); if (debug != NULL) { fprintf(debug, "\n\n\n========= TREE FIXED ==========\n"); @@ -408,11 +410,11 @@ re->re_info |= nfatree(v, v->tree, debug); CNOERR(); assert(v->nlacons == 0 || v->lacons != NULL); for (i = 1; i < v->nlacons; i++) { if (debug != NULL) { - fprintf(debug, "\n\n\n========= LA%" TCL_Z_MODIFIER "d ==========\n", i); + fprintf(debug, "\n\n\n========= LA%d ==========\n", i); } nfanode(v, &v->lacons[i], debug); } CNOERR(); if (v->tree->flags&SHORTER) { @@ -429,11 +431,11 @@ /* * Can sacrifice main NFA now, so use it as work area. */ - (void) optimize(v->nfa, debug); + (DISCARD) optimize(v->nfa, debug); CNOERR(); makesearch(v, v->nfa); CNOERR(); compact(v->nfa, &g->search); CNOERR(); @@ -464,22 +466,22 @@ return freev(v, 0); } /* - moresubs - enlarge subRE vector - ^ static void moresubs(struct vars *, size_t); + ^ static void moresubs(struct vars *, int); */ static void moresubs( struct vars *v, - size_t wanted) /* want enough room for this one */ + int wanted) /* want enough room for this one */ { struct subre **p; size_t n; - assert(wanted > 0 && wanted >= v->nsubs); - n = wanted * 3 / 2 + 1; + assert(wanted > 0 && (size_t)wanted >= v->nsubs); + n = (size_t)wanted * 3 / 2 + 1; if (v->subs == v->sub10) { p = (struct subre **) MALLOC(n * sizeof(struct subre *)); if (p != NULL) { memcpy(p, v->subs, v->nsubs * sizeof(struct subre *)); } @@ -494,11 +496,11 @@ v->subs = p; for (p = &v->subs[v->nsubs]; v->nsubs < n; p++, v->nsubs++) { *p = NULL; } assert(v->nsubs == n); - assert(wanted < v->nsubs); + assert((size_t)wanted < v->nsubs); } /* - freev - free vars struct's substructures where necessary * Optionally does error-number setting, and always returns error code (if @@ -508,11 +510,11 @@ static int freev( struct vars *v, int err) { - int ret; + register int ret; if (v->re != NULL) { rfree(v->re); } if (v->subs != v->sub10) { @@ -660,21 +662,21 @@ struct subre *t; /* temporary */ int firstbranch; /* is this the first branch? */ assert(stopper == ')' || stopper == EOS); - branches = sub_re(v, '|', LONGER, init, final); + branches = subre(v, '|', LONGER, init, final); NOERRN(); branch = branches; firstbranch = 1; do { /* a branch */ if (!firstbranch) { /* * Need a place to hang the branch. */ - branch->right = sub_re(v, '|', LONGER, init, final); + branch->right = subre(v, '|', LONGER, init, final); NOERRN(); branch = branch->right; } firstbranch = 0; left = newstate(v->nfa); @@ -741,11 +743,11 @@ int seencontent; /* is there anything in this branch yet? */ struct subre *t; lp = left; seencontent = 0; - t = sub_re(v, '=', 0, left, right); /* op '=' is tentative */ + t = subre(v, '=', 0, left, right); /* op '=' is tentative */ NOERRN(); while (!SEE('|') && !SEE(stopper) && !SEE(EOS)) { if (seencontent) { /* implicit concat operator */ lp = newstate(v->nfa); NOERRN(); @@ -792,11 +794,11 @@ int m, n; struct subre *atom; /* atom's subtree */ struct subre *t; int cap; /* capturing parens? */ int pos; /* positive lookahead? */ - size_t subno; /* capturing-parens or backref number */ + int subno; /* capturing-parens or backref number */ int atomtype; int qprefer; /* quantifier short/long preference */ int f; struct subre **atomp; /* where the pointer to atom is */ @@ -805,11 +807,11 @@ */ atom = NULL; assert(lp->nouts == 0); /* must string new code */ assert(rp->nins == 0); /* between lp and rp */ - subno = 0; + subno = 0; /* just to shut lint up */ /* * An atom or constraint... */ @@ -949,14 +951,14 @@ case '(': /* value flags as capturing or non */ cap = (type == LACON) ? 0 : v->nextvalue; if (cap) { v->nsubexp++; subno = v->nsubexp; - if (subno >= v->nsubs) { + if ((size_t)subno >= v->nsubs) { moresubs(v, subno); } - assert(subno < v->nsubs); + assert((size_t)subno < v->nsubs); } else { atomtype = PLAIN; /* something that's not '(' */ } NEXT(); @@ -974,11 +976,11 @@ assert(SEE(')') || ISERR()); NEXT(); NOERR(); if (cap) { v->subs[subno] = atom; - t = sub_re(v, '(', atom->flags|CAP, lp, rp); + t = subre(v, '(', atom->flags|CAP, lp, rp); NOERR(); t->subno = subno; t->left = atom; atom = t; } @@ -992,11 +994,11 @@ INSIST(type != LACON, REG_ESUBREG); INSIST(v->nextvalue < v->nsubs, REG_ESUBREG); INSIST(v->subs[v->nextvalue] != NULL, REG_ESUBREG); NOERR(); assert(v->nextvalue > 0); - atom = sub_re(v, 'b', BACKR, lp, rp); + atom = subre(v, 'b', BACKR, lp, rp); NOERR(); subno = v->nextvalue; atom->subno = subno; EMPTYARC(lp, rp); /* temporarily, so there's something */ NEXT(); @@ -1107,28 +1109,22 @@ /* * Now we'll need a subre for the contents even if they're boring. */ if (atom == NULL) { - atom = sub_re(v, '=', 0, lp, rp); + atom = subre(v, '=', 0, lp, rp); NOERR(); } /* * Prepare a general-purpose state skeleton. * - * In the no-backrefs case, we want this: - * - * [lp] ---> [s] ---prefix---> [begin] ---atom---> [end] ---rest---> [rp] - * - * where prefix is some repetitions of atom. In the general case we need - * - * [lp] ---> [s] ---iterator---> [s2] ---rest---> [rp] - * - * where the iterator wraps around [begin] ---atom---> [end] - * - * We make the s state here for both cases; s2 is made below if needed + * ---> [s] ---prefix---> [begin] ---atom---> [end] ----rest---> [rp] + * / / + * [lp] ----> [s2] ----bypass--------------------- + * + * where bypass is an empty, and prefix is some repetitions of atom */ s = newstate(v->nfa); /* first, new endpoints for the atom */ s2 = newstate(v->nfa); NOERR(); @@ -1135,20 +1131,22 @@ moveouts(v->nfa, lp, s); moveins(v->nfa, rp, s2); NOERR(); atom->begin = s; atom->end = s2; - s = newstate(v->nfa); /* set up starting state */ + s = newstate(v->nfa); /* and spots for prefix and bypass */ + s2 = newstate(v->nfa); NOERR(); EMPTYARC(lp, s); + EMPTYARC(lp, s2); NOERR(); /* * Break remaining subRE into x{...} and what follows. */ - t = sub_re(v, '.', COMBINE(qprefer, atom->flags), lp, rp); + t = subre(v, '.', COMBINE(qprefer, atom->flags), lp, rp); NOERR(); t->left = atom; atomp = &t->left; /* @@ -1158,11 +1156,11 @@ /* * Split top into prefix and remaining. */ assert(top->op == '=' && top->left == NULL && top->right == NULL); - top->left = sub_re(v, '=', top->flags, top->begin, lp); + top->left = subre(v, '=', top->flags, top->begin, lp); NOERR(); top->op = '.'; top->right = t; /* @@ -1184,12 +1182,31 @@ atom->begin, atom->end); NOERR(); } /* - * It's quantifier time. If the atom is just a backref, we'll let it deal - * with quantifiers internally. + * It's quantifier time; first, turn x{0,...} into x{1,...}|empty + */ + + if (m == 0) { + EMPTYARC(s2, atom->end);/* the bypass */ + assert(PREF(qprefer) != 0); + f = COMBINE(qprefer, atom->flags); + t = subre(v, '|', f, lp, atom->end); + NOERR(); + t->left = atom; + t->right = subre(v, '|', PREF(f), s2, atom->end); + NOERR(); + t->right->left = subre(v, '=', 0, s2, atom->end); + NOERR(); + *atomp = t; + atomp = &t->left; + m = 1; + } + + /* + * Deal with the rest of the quantifier. */ if (atomtype == BACKREF) { /* * Special case: backrefs have internal quantifiers. @@ -1203,70 +1220,44 @@ repeat(v, atom->begin, atom->end, m, n); atom->min = (short) m; atom->max = (short) n; atom->flags |= COMBINE(qprefer, atom->flags); - /* rest of branch can be strung starting from atom->end */ - s2 = atom->end; } else if (m == 1 && n == 1) { /* * No/vacuous quantifier: done. */ EMPTYARC(s, atom->begin); /* empty prefix */ - /* rest of branch can be strung starting from atom->end */ - s2 = atom->end; - } else if (m > 0 && !(atom->flags & BACKR)) { + } else { /* - * If there's no backrefs involved, we can turn x{m,n} into - * x{m-1,n-1}x, with capturing parens in only the second x. This - * is valid because we only care about capturing matches from the - * final iteration of the quantifier. It's a win because we can - * implement the backref-free left side as a plain DFA node, since - * we don't really care where its submatches are. + * Turn x{m,n} into x{m-1,n-1}x, with capturing parens in only second + * x */ dupnfa(v->nfa, atom->begin, atom->end, s, atom->begin); assert(m >= 1 && m != DUPINF && n >= 1); repeat(v, s, atom->begin, m-1, (n == DUPINF) ? n : n-1); f = COMBINE(qprefer, atom->flags); - t = sub_re(v, '.', f, s, atom->end); /* prefix and atom */ + t = subre(v, '.', f, s, atom->end); /* prefix and atom */ NOERR(); - t->left = sub_re(v, '=', PREF(f), s, atom->begin); + t->left = subre(v, '=', PREF(f), s, atom->begin); NOERR(); t->right = atom; *atomp = t; - /* rest of branch can be strung starting from atom->end */ - s2 = atom->end; - } else { - /* general case: need an iteration node */ - s2 = newstate(v->nfa); - NOERR(); - moveouts(v->nfa, atom->end, s2); - NOERR(); - dupnfa(v->nfa, atom->begin, atom->end, s, s2); - repeat(v, s, s2, m, n); - f = COMBINE(qprefer, atom->flags); - t = sub_re(v, '*', f, s, s2); - NOERR(); - t->min = (short) m; - t->max = (short) n; - t->left = atom; - *atomp = t; - /* rest of branch is to be strung from iteration's end state */ } /* * And finally, look after that postponed recursion. */ t = top->right; if (!(SEE('|') || SEE(stopper) || SEE(EOS))) { - t->right = parsebranch(v, stopper, type, s2, rp, 1); + t->right = parsebranch(v, stopper, type, atom->end, rp, 1); } else { - EMPTYARC(s2, rp); - t->right = sub_re(v, '=', 0, s2, rp); + EMPTYARC(atom->end, rp); + t->right = subre(v, '=', 0, atom->end, rp); } NOERR(); assert(SEE('|') || SEE(stopper) || SEE(EOS)); t->flags |= COMBINE(t->flags, t->right->flags); top->flags |= COMBINE(top->flags, t->flags); @@ -1329,12 +1320,10 @@ return n; } /* - repeat - replicate subNFA for quantifiers - * The sub-NFA strung from lp to rp is modified to represent m to n - * repetitions of its initial contents. * The duplication sequences used here are chosen carefully so that any * pointers starting out pointing into the subexpression end up pointing into * the last occurrence. (Note that it may not be strung between the same left * and right end states, however!) This used to be important for the subRE * tree, although the important bits are now handled by the in-line code in @@ -1491,11 +1480,11 @@ struct state *rp) { celt startc, endc; struct cvec *cv; const chr *startp, *endp; - chr c; + chr c[1]; /* * Parse something, get rid of special cases, take shortcuts. */ @@ -1503,22 +1492,22 @@ case RANGE: /* a-b-c or other botch */ ERR(REG_ERANGE); return; break; case PLAIN: - c = v->nextvalue; + c[0] = v->nextvalue; NEXT(); /* * Shortcut for ordinary chr (not range). */ if (!SEE(RANGE)) { - onechr(v, c, lp, rp); + onechr(v, c[0], lp, rp); return; } - startc = element(v, &c, &c+1); + startc = element(v, c, c+1); NOERR(); break; case COLLEL: startp = v->now; endp = scanplain(v); @@ -1558,13 +1547,13 @@ if (SEE(RANGE)) { NEXT(); switch (v->nexttype) { case PLAIN: case RANGE: - c = v->nextvalue; + c[0] = v->nextvalue; NEXT(); - endc = element(v, &c, &c+1); + endc = element(v, c, c+1); NOERR(); break; case COLLEL: startp = v->now; endp = scanplain(v); @@ -1714,16 +1703,16 @@ NOERR(); v->wordchrs = left; } /* - - sub_re - allocate a subre - ^ static struct subre *sub_re(struct vars *, int, int, struct state *, + - subre - allocate a subre + ^ static struct subre *subre(struct vars *, int, int, struct state *, ^ struct state *); */ static struct subre * -sub_re( +subre( struct vars *v, int op, int flags, struct state *begin, struct state *end) @@ -1740,15 +1729,15 @@ } ret->chain = v->treechain; v->treechain = ret; } - assert(strchr("=b|.*(", op) != NULL); + assert(strchr("|.b(=", op) != NULL); ret->op = op; ret->flags = flags; - ret->id = 0; /* will be assigned later */ + ret->retry = 0; ret->subno = 0; ret->min = ret->max = 1; ret->left = NULL; ret->right = NULL; ret->begin = begin; @@ -1797,21 +1786,39 @@ if (!NULLCNFA(sr->cnfa)) { freecnfa(&sr->cnfa); } sr->flags = 0; - if (v != NULL && v->treechain != NULL) { - /* we're still parsing, maybe we can reuse the subre */ + if (v != NULL) { sr->left = v->treefree; v->treefree = sr; } else { FREE(sr); } } /* - - numst - number tree nodes (assigning "id" indexes) + - optst - optimize a subRE subtree + ^ static void optst(struct vars *, struct subre *); + */ +static void +optst( + struct vars *v, + struct subre *t) +{ + /* + * DGP (2007-11-13): I assume it was the programmer's intent to eventually + * come back and add code to optimize subRE trees, but the routine coded + * just spends effort traversing the tree and doing nothing. We can do + * nothing with less effort. + */ + + return; +} + +/* + - numst - number tree nodes (assigning retry indexes) ^ static int numst(struct subre *, int); */ static int /* next number */ numst( struct subre *t, @@ -1820,11 +1827,11 @@ int i; assert(t != NULL); i = start; - t->id = (short) i++; + t->retry = (short) i++; if (t->left != NULL) { i = numst(t->left, i); } if (t->right != NULL) { i = numst(t->right, i); @@ -1832,23 +1839,10 @@ return i; } /* - markst - mark tree nodes as INUSE - * Note: this is a great deal more subtle than it looks. During initial - * parsing of a regex, all subres are linked into the treechain list; - * discarded ones are also linked into the treefree list for possible reuse. - * After we are done creating all subres required for a regex, we run markst() - * then cleanst(), which results in discarding all subres not reachable from - * v->tree. We then clear v->treechain, indicating that subres must be found - * by descending from v->tree. This changes the behavior of freesubre(): it - * will henceforth FREE() unwanted subres rather than sticking them into the - * treefree list. (Doing that any earlier would result in dangling links in - * the treechain list.) This all means that freev() will clean up correctly - * if invoked before or after markst()+cleanst(); but it would not work if - * called partway through this state conversion, so we mustn't error out - * in or between these two functions. ^ static void markst(struct subre *); */ static void markst( struct subre *t) @@ -1896,14 +1890,14 @@ FILE *f) /* for debug output */ { assert(t != NULL && t->begin != NULL); if (t->left != NULL) { - (void) nfatree(v, t->left, f); + (DISCARD) nfatree(v, t->left, f); } if (t->right != NULL) { - (void) nfatree(v, t->right, f); + (DISCARD) nfatree(v, t->right, f); } return nfanode(v, t, f); } @@ -1951,30 +1945,28 @@ struct vars *v, struct state *begin, struct state *end, int pos) { - int n; - struct subre *newlacons; struct subre *sub; + int n; if (v->nlacons == 0) { + v->lacons = (struct subre *) MALLOC(2 * sizeof(struct subre)); n = 1; /* skip 0th */ - newlacons = (struct subre *) MALLOC(2 * sizeof(struct subre)); + v->nlacons = 2; } else { - n = v->nlacons; - newlacons = (struct subre *) REALLOC(v->lacons, - (n + 1) * sizeof(struct subre)); + v->lacons = (struct subre *) REALLOC(v->lacons, + (v->nlacons+1)*sizeof(struct subre)); + n = v->nlacons++; } - if (newlacons == NULL) { + if (v->lacons == NULL) { ERR(REG_ESPACE); return 0; } - v->lacons = newlacons; - v->nlacons = n + 1; sub = &v->lacons[n]; sub->begin = begin; sub->end = end; sub->subno = pos; ZAPCNFA(sub->cnfa); @@ -2018,24 +2010,22 @@ re->re_magic = 0; /* invalidate RE */ g = (struct guts *) re->re_guts; re->re_guts = NULL; re->re_fns = NULL; - if (g != NULL) { - g->magic = 0; - freecm(&g->cmap); - if (g->tree != NULL) { - freesubre(NULL, g->tree); - } - if (g->lacons != NULL) { - freelacons(g->lacons, g->nlacons); - } - if (!NULLCNFA(g->search)) { - freecnfa(&g->search); - } - FREE(g); - } + g->magic = 0; + freecm(&g->cmap); + if (g->tree != NULL) { + freesubre(NULL, g->tree); + } + if (g->lacons != NULL) { + freelacons(g->lacons, g->nlacons); + } + if (!NULLCNFA(g->search)) { + freecnfa(&g->search); + } + FREE(g); } /* - dump - dump an RE in human-readable form ^ static void dump(regex_t *, FILE *); @@ -2062,12 +2052,12 @@ 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 %" TCL_Z_MODIFIER "d, info 0%lo, ntree %d\n", - re->re_nsub, re->re_info, g->ntree); + fprintf(f, "nsub %d, info 0%lo, csize %d, ntree %d\n", + 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); @@ -2077,13 +2067,10 @@ (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 @@ -2175,18 +2162,18 @@ struct subre *t, char *buf, size_t bufsize) { /* - * Big enough for hex int or decimal t->id? + * Big enough for hex int or decimal t->retry? */ - if (bufsize < sizeof(void*)*2 + 3 || bufsize < sizeof(t->id)*3 + 1) { + if (bufsize < sizeof(void*)*2 + 3 || bufsize < sizeof(t->retry)*3 + 1) { return "unable"; } - if (t->id != 0) { - sprintf(buf, "%d", t->id); + if (t->retry != 0) { + sprintf(buf, "%d", t->retry); } else { sprintf(buf, "%p", t); } return buf; } Index: generic/regcustom.h ================================================================== --- generic/regcustom.h +++ generic/regcustom.h @@ -28,19 +28,20 @@ /* * Headers if any. */ -#include "regex.h" +#include "tclInt.h" /* * Overrides for regguts.h definitions, if any. */ -#define MALLOC(n) Tcl_AttemptAlloc(n) -#define FREE(p) Tcl_Free(p) -#define REALLOC(p,n) Tcl_AttemptRealloc(p,n) +#define FUNCPTR(name, args) (*name)args +#define MALLOC(n) ckalloc(n) +#define FREE(p) ckfree(VS(p)) +#define REALLOC(p,n) ckrealloc(VS(p),n) /* * Do not insert extras between the "begin" and "end" lines - this chunk is * automatically extracted to be fitted into regex.h. */ @@ -53,19 +54,31 @@ #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_VOID_T +#undef __REG_VOID_T +#endif +#ifdef __REG_CONST +#undef __REG_CONST #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... */ +#define __REG_VOID_T void +#define __REG_CONST const /* 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 */ @@ -85,15 +98,15 @@ #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 */ +#define CHR_MAX 0xffffffff /* 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 */ +#define CHR_MAX 0xffff /* CHR_MAX-CHR_MIN+1 should fit in uchr */ #endif /* * Functions operating on chr. */ @@ -125,26 +138,24 @@ */ #if 1 #define AllocVars(vPtr) \ static Tcl_ThreadDataKey varsKey; \ - struct vars *vPtr = (struct vars *) \ + register 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)) + register 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: + * And pick up the standard header. */ + +#include "regex.h" Index: generic/rege_dfa.c ================================================================== --- generic/rege_dfa.c +++ generic/rege_dfa.c @@ -34,20 +34,21 @@ - longest - longest-preferred matching engine ^ static chr *longest(struct vars *, struct dfa *, chr *, chr *, int *); */ static chr * /* endpoint, or NULL */ longest( - struct vars *const v, /* used only for debug and exec flags */ - struct dfa *const d, - chr *const start, /* where the match should start */ - chr *const stop, /* match must end at or before here */ - int *const hitstopp) /* record whether hit v->stop, if non-NULL */ + struct vars *v, /* used only for debug and exec flags */ + struct dfa *d, + chr *start, /* where the match should start */ + chr *stop, /* match must end at or before here */ + int *hitstopp) /* record whether hit v->stop, if non-NULL */ { chr *cp; chr *realstop = (stop == v->stop) ? stop : stop + 1; color co; - struct sset *css, *ss; + struct sset *css; + struct sset *ss; chr *post; int i; struct colormap *cm = d->cm; /* @@ -82,11 +83,11 @@ * Main loop. */ if (v->eflags®_FTRACE) { while (cp < realstop) { - FDEBUG(("+++ at c%d +++\n", (int) (css - d->ssets))); + FDEBUG(("+++ at c%d +++\n", css - d->ssets)); co = GETCOLOR(cm, *cp); FDEBUG(("char %c, color %ld\n", (char)*cp, (long)co)); ss = css->outs[co]; if (ss == NULL) { ss = miss(v, d, css, co, cp+1, start); @@ -116,11 +117,11 @@ /* * Shutdown. */ - FDEBUG(("+++ shutdown at c%d +++\n", (int) (css - d->ssets))); + FDEBUG(("+++ shutdown at c%d +++\n", css - d->ssets)); if (cp == v->stop && stop == v->stop) { if (hitstopp != NULL) { *hitstopp = 1; } co = d->cnfa->eos[(v->eflags®_NOTEOL) ? 0 : 1]; @@ -161,23 +162,24 @@ ^ static chr *shortest(struct vars *, struct dfa *, chr *, chr *, chr *, ^ chr **, int *); */ static chr * /* endpoint, or NULL */ shortest( - struct vars *const v, - struct dfa *const d, - chr *const start, /* where the match should start */ - chr *const min, /* match must end at or after here */ - chr *const max, /* match must end at or before here */ - chr **const coldp, /* store coldstart pointer here, if nonNULL */ - int *const hitstopp) /* record whether hit v->stop, if non-NULL */ + struct vars *v, + struct dfa *d, + chr *start, /* where the match should start */ + chr *min, /* match must end at or after here */ + chr *max, /* match must end at or before here */ + chr **coldp, /* store coldstart pointer here, if nonNULL */ + int *hitstopp) /* record whether hit v->stop, if non-NULL */ { chr *cp; chr *realmin = (min == v->stop) ? min : min + 1; chr *realmax = (max == v->stop) ? max : max + 1; color co; - struct sset *css, *ss; + struct sset *css; + struct sset *ss; struct colormap *cm = d->cm; /* * Initialize. */ @@ -211,11 +213,11 @@ * Main loop. */ if (v->eflags®_FTRACE) { while (cp < realmax) { - FDEBUG(("--- at c%d ---\n", (int) (css - d->ssets))); + FDEBUG(("--- at c%d ---\n", css - d->ssets)); co = GETCOLOR(cm, *cp); FDEBUG(("char %c, color %ld\n", (char)*cp, (long)co)); ss = css->outs[co]; if (ss == NULL) { ss = miss(v, d, css, co, cp+1, start); @@ -252,11 +254,11 @@ if (ss == NULL) { return NULL; } if (coldp != NULL) { /* report last no-progress state set, if any */ - *coldp = lastCold(v, d); + *coldp = lastcold(v, d); } if ((ss->flags&POSTSTATE) && cp > min) { assert(cp >= realmin); cp--; @@ -280,22 +282,23 @@ return cp; } /* - - lastCold - determine last point at which no progress had been made - ^ static chr *lastCold(struct vars *, struct dfa *); + - lastcold - determine last point at which no progress had been made + ^ static chr *lastcold(struct vars *, struct dfa *); */ static chr * /* endpoint, or NULL */ -lastCold( - struct vars *const v, - struct dfa *const d) +lastcold( + struct vars *v, + struct dfa *d) { struct sset *ss; - chr *nopr = d->lastnopr; + chr *nopr; int i; + nopr = d->lastnopr; if (nopr == NULL) { nopr = v->start; } for (ss = d->ssets, i = d->nssused; i > 0; ss++, i--) { if ((ss->flags&NOPROGRESS) && nopr < ss->lastseen) { @@ -304,19 +307,19 @@ } return nopr; } /* - - newDFA - set up a fresh DFA - ^ static struct dfa *newDFA(struct vars *, struct cnfa *, + - newdfa - set up a fresh DFA + ^ static struct dfa *newdfa(struct vars *, struct cnfa *, ^ struct colormap *, struct smalldfa *); */ static struct dfa * -newDFA( - struct vars *const v, - struct cnfa *const cnfa, - struct colormap *const cm, +newdfa( + struct vars *v, + struct cnfa *cnfa, + struct colormap *cm, struct smalldfa *sml) /* preallocated space, may be NULL */ { struct dfa *d; size_t nss = cnfa->nstates * 2; int wordsper = (cnfa->nstates + UBITS - 1) / UBITS; @@ -340,16 +343,16 @@ d->outsarea = sml->outsarea; d->incarea = sml->incarea; d->cptsmalloced = 0; d->mallocarea = (smallwas == NULL) ? (char *)sml : NULL; } else { - d = (struct dfa *) MALLOC(sizeof(struct dfa)); + d = (struct dfa *)MALLOC(sizeof(struct dfa)); if (d == NULL) { ERR(REG_ESPACE); return NULL; } - d->ssets = (struct sset *) MALLOC(nss * sizeof(struct sset)); + d->ssets = (struct sset *)MALLOC(nss * sizeof(struct sset)); d->statesarea = (unsigned *) MALLOC((nss+WORK) * wordsper * sizeof(unsigned)); d->work = &d->statesarea[nss * wordsper]; d->outsarea = (struct sset **) MALLOC(nss * cnfa->ncolors * sizeof(struct sset *)); @@ -357,11 +360,11 @@ MALLOC(nss * cnfa->ncolors * sizeof(struct arcp)); d->cptsmalloced = 1; d->mallocarea = (char *)d; if (d->ssets == NULL || d->statesarea == NULL || d->outsarea == NULL || d->incarea == NULL) { - freeDFA(d); + freedfa(d); ERR(REG_ESPACE); return NULL; } } @@ -382,16 +385,16 @@ return d; } /* - - freeDFA - free a DFA - ^ static void freeDFA(struct dfa *); + - freedfa - free a DFA + ^ static void freedfa(struct dfa *); */ static void -freeDFA( - struct dfa *const d) +freedfa( + struct dfa *d) { if (d->cptsmalloced) { if (d->ssets != NULL) { FREE(d->ssets); } @@ -416,12 +419,12 @@ * There are probably better ways, but they're more expensive. ^ static unsigned hash(unsigned *, int); */ static unsigned hash( - unsigned *const uv, - const int n) + unsigned *uv, + int n) { int i; unsigned h; h = 0; @@ -435,13 +438,13 @@ - initialize - hand-craft a cache entry for startup, otherwise get ready ^ static struct sset *initialize(struct vars *, struct dfa *, chr *); */ static struct sset * initialize( - struct vars *const v, /* used only for debug flags */ - struct dfa *const d, - chr *const start) + struct vars *v, /* used only for debug flags */ + struct dfa *d, + chr *start) { struct sset *ss; int i; /* @@ -449,11 +452,11 @@ */ if (d->nssused > 0 && (d->ssets[0].flags&STARTER)) { ss = &d->ssets[0]; } else { /* no, must (re)build it */ - ss = getVacantSS(v, d, start, start); + ss = getvacant(v, d, start, start); for (i = 0; i < d->wordsper; i++) { ss->states[i] = 0; } BSET(ss->states, d->cnfa->pre); ss->hash = HASH(ss->states, d->wordsper); @@ -479,22 +482,27 @@ ^ static struct sset *miss(struct vars *, struct dfa *, struct sset *, ^ pcolor, chr *, chr *); */ static struct sset * /* NULL if goes to empty set */ miss( - struct vars *const v, /* used only for debug flags */ - struct dfa *const d, - struct sset *const css, - const pcolor co, - chr *const cp, /* next chr */ - chr *const start) /* where the attempt got started */ + struct vars *v, /* used only for debug flags */ + struct dfa *d, + struct sset *css, + pcolor co, + chr *cp, /* next chr */ + chr *start) /* where the attempt got started */ { struct cnfa *cnfa = d->cnfa; + int i; unsigned h; struct carc *ca; struct sset *p; - int i, isPost, noProgress, gotState, doLAConstraints, sawLAConstraints; + int ispost; + int noprogress; + int gotstate; + int dolacons; + int sawlacons; /* * For convenience, we can be called even if it might not be a miss. */ @@ -509,61 +517,61 @@ */ for (i = 0; i < d->wordsper; i++) { d->work[i] = 0; } - isPost = 0; - noProgress = 1; - gotState = 0; + ispost = 0; + noprogress = 1; + gotstate = 0; for (i = 0; i < d->nstates; i++) { if (ISBSET(css->states, i)) { - for (ca = cnfa->states[i]; ca->co != COLORLESS; ca++) { + for (ca = cnfa->states[i]+1; ca->co != COLORLESS; ca++) { if (ca->co == co) { BSET(d->work, ca->to); - gotState = 1; + gotstate = 1; if (ca->to == cnfa->post) { - isPost = 1; + ispost = 1; } - if (!(cnfa->stflags[ca->to] & CNFA_NOPROGRESS)) { - noProgress = 0; + if (!cnfa->states[ca->to]->co) { + noprogress = 0; } FDEBUG(("%d -> %d\n", i, ca->to)); } } } } - doLAConstraints = (gotState ? (cnfa->flags&HASLACONS) : 0); - sawLAConstraints = 0; - while (doLAConstraints) { /* transitive closure */ - doLAConstraints = 0; + dolacons = (gotstate) ? (cnfa->flags&HASLACONS) : 0; + sawlacons = 0; + while (dolacons) { /* transitive closure */ + dolacons = 0; for (i = 0; i < d->nstates; i++) { if (ISBSET(d->work, i)) { - for (ca = cnfa->states[i]; ca->co != COLORLESS; ca++) { - if (ca->co < cnfa->ncolors) { - continue; /* NOTE CONTINUE */ + for (ca = cnfa->states[i]+1; ca->co != COLORLESS; ca++) { + if (ca->co <= cnfa->ncolors) { + continue; /* NOTE CONTINUE */ } - sawLAConstraints = 1; + sawlacons = 1; if (ISBSET(d->work, ca->to)) { - continue; /* NOTE CONTINUE */ + continue; /* NOTE CONTINUE */ } - if (!checkLAConstraint(v, cnfa, cp, ca->co)) { - continue; /* NOTE CONTINUE */ + if (!lacon(v, cnfa, cp, ca->co)) { + continue; /* NOTE CONTINUE */ } BSET(d->work, ca->to); - doLAConstraints = 1; + dolacons = 1; if (ca->to == cnfa->post) { - isPost = 1; + ispost = 1; } - if (!(cnfa->stflags[ca->to] & CNFA_NOPROGRESS)) { - noProgress = 0; + if (!cnfa->states[ca->to]->co) { + noprogress = 0; } FDEBUG(("%d :> %d\n", i, ca->to)); } } } } - if (!gotState) { + if (!gotstate) { return NULL; } h = HASH(d->work, d->wordsper); /* @@ -570,52 +578,51 @@ * Next, is that in the cache? */ for (p = d->ssets, i = d->nssused; i > 0; p++, i--) { if (HIT(h, d->work, p, d->wordsper)) { - FDEBUG(("cached c%d\n", (int) (p - d->ssets))); + FDEBUG(("cached c%d\n", p - d->ssets)); break; /* NOTE BREAK OUT */ } } if (i == 0) { /* nope, need a new cache entry */ - p = getVacantSS(v, d, cp, start); + p = getvacant(v, d, cp, start); assert(p != css); for (i = 0; i < d->wordsper; i++) { p->states[i] = d->work[i]; } p->hash = h; - p->flags = (isPost ? POSTSTATE : 0); - if (noProgress) { + p->flags = (ispost) ? POSTSTATE : 0; + if (noprogress) { p->flags |= NOPROGRESS; } /* * lastseen to be dealt with by caller */ } - if (!sawLAConstraints) { /* lookahead conds. always cache miss */ - FDEBUG(("c%d[%d]->c%d\n", - (int) (css - d->ssets), co, (int) (p - d->ssets))); + if (!sawlacons) { /* lookahead conds. always cache miss */ + FDEBUG(("c%d[%d]->c%d\n", css - d->ssets, co, p - d->ssets)); css->outs[co] = p; css->inchain[co] = p->ins; p->ins.ss = css; - p->ins.co = (color) co; + p->ins.co = (color)co; } return p; } /* - - checkLAConstraint - lookahead-constraint checker for miss() - ^ static int checkLAConstraint(struct vars *, struct cnfa *, chr *, pcolor); + - lacon - lookahead-constraint checker for miss() + ^ static int lacon(struct vars *, struct cnfa *, chr *, pcolor); */ static int /* predicate: constraint satisfied? */ -checkLAConstraint( - struct vars *const v, - struct cnfa *const pcnfa, /* parent cnfa */ - chr *const cp, - const pcolor co) /* "color" of the lookahead constraint */ +lacon( + struct vars *v, + struct cnfa *pcnfa, /* parent cnfa */ + chr *cp, + pcolor co) /* "color" of the lookahead constraint */ { int n; struct subre *sub; struct dfa *d; struct smalldfa sd; @@ -623,50 +630,52 @@ n = co - pcnfa->ncolors; assert(n < v->g->nlacons && v->g->lacons != NULL); FDEBUG(("=== testing lacon %d\n", n)); sub = &v->g->lacons[n]; - d = newDFA(v, &sub->cnfa, &v->g->cmap, &sd); + d = newdfa(v, &sub->cnfa, &v->g->cmap, &sd); if (d == NULL) { ERR(REG_ESPACE); return 0; } - end = longest(v, d, cp, v->stop, NULL); - freeDFA(d); + end = longest(v, d, cp, v->stop, (int *)NULL); + freedfa(d); FDEBUG(("=== lacon %d match %d\n", n, (end != NULL))); return (sub->subno) ? (end != NULL) : (end == NULL); } /* - - getVacantSS - get a vacant state set + - getvacant - get a vacant state set * This routine clears out the inarcs and outarcs, but does not otherwise * clear the innards of the state set -- that's up to the caller. - ^ static struct sset *getVacantSS(struct vars *, struct dfa *, chr *, chr *); + ^ static struct sset *getvacant(struct vars *, struct dfa *, chr *, chr *); */ static struct sset * -getVacantSS( - struct vars *const v, /* used only for debug flags */ - struct dfa *const d, - chr *const cp, - chr *const start) +getvacant( + struct vars *v, /* used only for debug flags */ + struct dfa *d, + chr *cp, + chr *start) { int i; - struct sset *ss, *p; - struct arcp ap, lastap = {NULL, 0}; /* silence gcc 4 warning */ + struct sset *ss; + struct sset *p; + struct arcp ap; + struct arcp lastap = {NULL, 0}; /* silence gcc 4 warning */ color co; - ss = pickNextSS(v, d, cp, start); + ss = pickss(v, d, cp, start); assert(!(ss->flags&LOCKED)); /* * Clear out its inarcs, including self-referential ones. */ ap = ss->ins; while ((p = ap.ss) != NULL) { co = ap.co; - FDEBUG(("zapping c%d's %ld outarc\n", (int) (p - d->ssets), (long)co)); + FDEBUG(("zapping c%d's %ld outarc\n", p - d->ssets, (long)co)); p->outs[co] = NULL; ap = p->inchain[co]; p->inchain[co].ss = NULL; /* paranoia */ } ss->ins.ss = NULL; @@ -679,16 +688,17 @@ p = ss->outs[i]; assert(p != ss); /* not self-referential */ if (p == NULL) { continue; /* NOTE CONTINUE */ } - FDEBUG(("del outarc %d from c%d's in chn\n", i, (int) (p - d->ssets))); + FDEBUG(("del outarc %d from c%d's in chn\n", i, p - d->ssets)); if (p->ins.ss == ss && p->ins.co == i) { p->ins = ss->inchain[i]; } else { assert(p->ins.ss != NULL); - for (ap = p->ins; ap.ss != NULL && !(ap.ss == ss && ap.co == i); + for (ap = p->ins; ap.ss != NULL && + !(ap.ss == ss && ap.co == i); ap = ap.ss->inchain[ap.co]) { lastap = ap; } assert(ap.ss != NULL); lastap.ss->inchain[lastap.co] = ss->inchain[i]; @@ -717,22 +727,23 @@ return ss; } /* - - pickNextSS - pick the next stateset to be used - ^ static struct sset *pickNextSS(struct vars *, struct dfa *, chr *, chr *); + - pickss - pick the next stateset to be used + ^ static struct sset *pickss(struct vars *, struct dfa *, chr *, chr *); */ static struct sset * -pickNextSS( - struct vars *const v, /* used only for debug flags */ - struct dfa *const d, - chr *const cp, - chr *const start) +pickss( + struct vars *v, /* used only for debug flags */ + struct dfa *d, + chr *cp, + chr *start) { int i; - struct sset *ss, *end; + struct sset *ss; + struct sset *end; chr *ancient; /* * Shortcut for cases where cache isn't full. */ @@ -771,19 +782,19 @@ } for (ss = d->search, end = &d->ssets[d->nssets]; ss < end; ss++) { if ((ss->lastseen == NULL || ss->lastseen < ancient) && !(ss->flags&LOCKED)) { d->search = ss + 1; - FDEBUG(("replacing c%d\n", (int) (ss - d->ssets))); + FDEBUG(("replacing c%d\n", ss - d->ssets)); return ss; } } for (ss = d->ssets, end = d->search; ss < end; ss++) { if ((ss->lastseen == NULL || ss->lastseen < ancient) && !(ss->flags&LOCKED)) { d->search = ss + 1; - FDEBUG(("replacing c%d\n", (int) (ss - d->ssets))); + FDEBUG(("replacing c%d\n", ss - d->ssets)); return ss; } } /* Index: generic/regerror.c ================================================================== --- generic/regerror.c +++ generic/regerror.c @@ -39,11 +39,11 @@ /* * Struct to map among codes, code names, and explanations. */ -static const struct rerr { +static struct rerr { int code; const char *name; const char *explain; } rerrs[] = { /* The actual table is built from regex.h */ @@ -52,17 +52,19 @@ }; /* - regerror - the interface to error numbers */ +/* ARGSUSED */ size_t /* Actual space needed (including NUL) */ regerror( int code, /* Error code, or REG_ATOI or REG_ITOA */ + const regex_t *preg, /* Associated regex_t (unused at present) */ char *errbuf, /* Result buffer (unless errbuf_size==0) */ size_t errbuf_size) /* Available space in errbuf, can be 0 */ { - const struct rerr *r; + struct rerr *r; const char *msg; char convbuf[sizeof(unk)+50]; /* 50 = plenty for int */ size_t len; int icode; @@ -84,11 +86,11 @@ } } if (r->code >= 0) { msg = r->name; } else { /* Unknown; tell him the number */ - sprintf(convbuf, "REG_%u", icode); + sprintf(convbuf, "REG_%u", (unsigned)icode); msg = convbuf; } break; default: /* A real, normal error code */ for (r = rerrs; r->code >= 0; r++) { Index: generic/regerrs.h ================================================================== --- generic/regerrs.h +++ generic/regerrs.h @@ -14,7 +14,7 @@ { REG_BADRPT, "REG_BADRPT", "quantifier operand invalid" }, { REG_ASSERT, "REG_ASSERT", "\"can't happen\" -- you found a bug" }, { REG_INVARG, "REG_INVARG", "invalid argument to regex function" }, { REG_MIXED, "REG_MIXED", "character widths of regex and string differ" }, { REG_BADOPT, "REG_BADOPT", "invalid embedded option" }, -{ REG_ETOOBIG, "REG_ETOOBIG", "regular expression is too complex" }, +{ REG_ETOOBIG, "REG_ETOOBIG", "nfa has too many states" }, { REG_ECOLORS, "REG_ECOLORS", "too many colors" }, Index: generic/regex.h ================================================================== --- generic/regex.h +++ generic/regex.h @@ -1,10 +1,7 @@ #ifndef _REGEX_H_ #define _REGEX_H_ /* never again */ - -#include "tclInt.h" - /* * regular expressions * * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved. * @@ -86,19 +83,31 @@ #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_VOID_T +#undef __REG_VOID_T +#endif +#ifdef __REG_CONST +#undef __REG_CONST #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... */ +#define __REG_VOID_T VOID +#define __REG_CONST CONST /* 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 */ @@ -107,20 +116,51 @@ /* --- 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 + * an override. + */ +#ifdef __REG_REGOFF_T +typedef __REG_REGOFF_T regoff_t; +#else +typedef long regoff_t; +#endif + +/* + * For benefit of old compilers, we offer the option of + * overriding the `void' type used to declare nonexistent return types. + */ +#ifdef __REG_VOID_T +typedef __REG_VOID_T re_void; +#else +typedef void re_void; +#endif + +/* + * Also for benefit of old compilers, can supply a macro which + * expands to a substitute for `const'. + */ +#ifndef __REG_CONST +#define __REG_CONST const +#endif + + /* * other interface types */ /* the biggie, a compiled RE (or rather, a front end to same) */ typedef struct { int re_magic; /* magic number */ - long re_info; /* information about RE */ 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 @@ -131,20 +171,21 @@ #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; + char *re_guts; /* `char *' is more portable than `void *' */ + char *re_fns; } regex_t; /* result reporting (may acquire more fields later) */ typedef struct { - size_t rm_so; /* start of substring */ - size_t rm_eo; /* end of substring */ + 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 */ @@ -151,17 +192,17 @@ } rm_detail_t; /* * compilation ^ #ifndef __REG_NOCHAR - ^ int re_comp(regex_t *, const char *, size_t, int); + ^ int re_comp(regex_t *, __REG_CONST char *, size_t, int); ^ #endif ^ #ifndef __REG_NOFRONT - ^ int regcomp(regex_t *, const char *, int); + ^ int regcomp(regex_t *, __REG_CONST char *, int); ^ #endif ^ #ifdef __REG_WIDE_T - ^ int __REG_WIDE_COMPILE(regex_t *, const __REG_WIDE_T *, size_t, int); + ^ int __REG_WIDE_COMPILE(regex_t *, __REG_CONST __REG_WIDE_T *, size_t, int); ^ #endif */ #define REG_BASIC 000000 /* BREs (convenience) */ #define REG_EXTENDED 000001 /* EREs */ #define REG_ADVF 000002 /* advanced features in EREs */ @@ -182,18 +223,18 @@ #define REG_PROGRESS 020000 /* none of your business :-) */ /* * execution ^ #ifndef __REG_NOCHAR - ^ int re_exec(regex_t *, const char *, size_t, + ^ int re_exec(regex_t *, __REG_CONST char *, size_t, ^ rm_detail_t *, size_t, regmatch_t [], int); ^ #endif ^ #ifndef __REG_NOFRONT - ^ int regexec(regex_t *, const char *, size_t, regmatch_t [], int); + ^ int regexec(regex_t *, __REG_CONST char *, size_t, regmatch_t [], int); ^ #endif ^ #ifdef __REG_WIDE_T - ^ int __REG_WIDE_EXEC(regex_t *, const __REG_WIDE_T *, size_t, + ^ int __REG_WIDE_EXEC(regex_t *, __REG_CONST __REG_WIDE_T *, size_t, ^ rm_detail_t *, size_t, regmatch_t [], int); ^ #endif */ #define REG_NOTBOL 0001 /* BOS is not BOL */ #define REG_NOTEOL 0002 /* EOS is not EOL */ @@ -202,11 +243,11 @@ #define REG_MTRACE 0020 /* none of your business */ #define REG_SMALL 0040 /* none of your business */ /* * misc generics (may be more functions here eventually) - ^ void regfree(regex_t *); + ^ re_void regfree(regex_t *); */ /* * error reporting * Be careful if modifying the list of error codes -- the table used by @@ -214,11 +255,11 @@ * * 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); + ^ extern size_t regerror(int, __REG_CONST regex_t *, 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 */ @@ -234,11 +275,11 @@ #define REG_BADRPT 13 /* quantifier operand invalid */ #define REG_ASSERT 15 /* "can't happen" -- you found a bug */ #define REG_INVARG 16 /* invalid argument to regex function */ #define REG_MIXED 17 /* character widths of regex and string differ */ #define REG_BADOPT 18 /* invalid embedded option */ -#define REG_ETOOBIG 19 /* regular expression is too complex */ +#define REG_ETOOBIG 19 /* nfa has too many states */ #define REG_ECOLORS 20 /* too many colors */ /* two specials for debugging and testing */ #define REG_ATOI 101 /* convert error-code name to number */ #define REG_ITOA 102 /* convert error-code number to name */ @@ -247,29 +288,29 @@ */ /* =====^!^===== begin forwards =====^!^===== */ /* automatically gathered by fwd; do not hand-edit */ /* === regproto.h === */ #ifndef __REG_NOCHAR -int re_comp(regex_t *, const char *, size_t, int); +int re_comp(regex_t *, __REG_CONST char *, size_t, int); #endif #ifndef __REG_NOFRONT -int regcomp(regex_t *, const char *, int); +int regcomp(regex_t *, __REG_CONST char *, int); #endif #ifdef __REG_WIDE_T -MODULE_SCOPE int __REG_WIDE_COMPILE(regex_t *, const __REG_WIDE_T *, size_t, int); +MODULE_SCOPE int __REG_WIDE_COMPILE(regex_t *, __REG_CONST __REG_WIDE_T *, size_t, int); #endif #ifndef __REG_NOCHAR -int re_exec(regex_t *, const char *, size_t, rm_detail_t *, size_t, regmatch_t [], int); +int re_exec(regex_t *, __REG_CONST char *, size_t, rm_detail_t *, size_t, regmatch_t [], int); #endif #ifndef __REG_NOFRONT -int regexec(regex_t *, const char *, size_t, regmatch_t [], int); +int regexec(regex_t *, __REG_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); +MODULE_SCOPE int __REG_WIDE_EXEC(regex_t *, __REG_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); +MODULE_SCOPE re_void regfree(regex_t *); +MODULE_SCOPE size_t regerror(int, __REG_CONST regex_t *, char *, size_t); /* automatically gathered by fwd; do not hand-edit */ /* =====^!^===== end forwards =====^!^===== */ /* * more C++ voodoo @@ -277,13 +318,5 @@ #ifdef __cplusplus } #endif #endif - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ Index: generic/regexec.c ================================================================== --- generic/regexec.c +++ generic/regexec.c @@ -42,11 +42,11 @@ struct sset { /* state set */ unsigned *states; /* pointer to bitvector */ unsigned hash; /* hash of bitvector */ #define HASH(bv, nw) (((nw) == 1) ? *(bv) : hash(bv, nw)) #define HIT(h,bv,ss,nw) ((ss)->hash == (h) && ((nw) == 1 || \ - memcmp((void*)(bv), (void*)((ss)->states), (nw)*sizeof(unsigned)) == 0)) + memcmp(VS(bv), VS((ss)->states), (nw)*sizeof(unsigned)) == 0)) int flags; #define STARTER 01 /* the initial state set */ #define POSTSTATE 02 /* includes the goal state */ #define LOCKED 04 /* locked in cache */ #define NOPROGRESS 010 /* zero-progress state set */ @@ -71,11 +71,11 @@ struct colormap *cm; chr *lastpost; /* location of last cache-flushed success */ chr *lastnopr; /* location of last cache-flushed NOPROGRESS */ struct sset *search; /* replacement-search-pointer memory */ int cptsmalloced; /* were the areas individually malloced? */ - char *mallocarea; /* self, or malloced area, or NULL */ + char *mallocarea; /* self, or master malloced area, or NULL */ }; #define WORK 1 /* number of work bitvectors needed */ /* @@ -89,10 +89,11 @@ struct sset ssets[FEWSTATES*2]; unsigned statesarea[FEWSTATES*2 + WORK]; struct sset *outsarea[FEWSTATES*2 * FEWCOLORS]; struct arcp incarea[FEWSTATES*2 * FEWCOLORS]; }; +#define DOMALLOC ((struct smalldfa *)NULL) /* force malloc */ /* * Internal variables, bundled for easy passing around. */ @@ -104,17 +105,17 @@ regmatch_t *pmatch; rm_detail_t *details; chr *start; /* start of string */ chr *stop; /* just past end of string */ int err; /* error code if any (0 none) */ - struct dfa **subdfas; /* per-subre DFAs */ + regoff_t *mem; /* memory vector for backtracking */ struct smalldfa dfa1; struct smalldfa dfa2; }; #define VISERR(vv) ((vv)->err != 0) /* have we seen an error yet? */ #define ISERR() VISERR(v) -#define VERR(vv,e) ((vv)->err = ((vv)->err ? (vv)->err : (e))) +#define VERR(vv,e) (((vv)->err) ? (vv)->err : ((vv)->err = (e))) #define ERR(e) VERR(v, e) /* record an error */ #define NOERR() {if (ISERR()) return v->err;} /* if error seen, return it */ #define OFF(p) ((p) - v->start) #define LOFF(p) ((long)OFF(p)) @@ -122,71 +123,75 @@ * forward declarations */ /* =====^!^===== 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); +int exec(regex_t *, CONST chr *, size_t, rm_detail_t *, size_t, regmatch_t [], int); +static int find(struct vars *, struct cnfa *, struct colormap *); +static int cfind(struct vars *, struct cnfa *, struct colormap *); +static int cfindloop(struct vars *, struct cnfa *, struct colormap *, struct dfa *, struct dfa *, chr **); +static VOID zapsubs(regmatch_t *, size_t); +static VOID zapmem(struct vars *, struct subre *); +static VOID subset(struct vars *, struct subre *, chr *, chr *); +static int dissect(struct vars *, struct subre *, chr *, chr *); +static int condissect(struct vars *, struct subre *, chr *, chr *); +static int altdissect(struct vars *, struct subre *, chr *, chr *); 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 crevdissect(struct vars *, struct subre *, chr *, chr *); static int cbrdissect(struct vars *, struct subre *, chr *, chr *); static int caltdissect(struct vars *, struct subre *, chr *, chr *); -static int citerdissect(struct vars *, struct subre *, chr *, chr *); -static int creviterdissect(struct vars *, struct subre *, chr *, chr *); /* === rege_dfa.c === */ -static chr *longest(struct vars *const, struct dfa *const, chr *const, chr *const, int *const); -static chr *shortest(struct vars *const, struct dfa *const, chr *const, chr *const, chr *const, chr **const, int *const); -static chr *lastCold(struct vars *const, struct dfa *const); -static struct dfa *newDFA(struct vars *const, struct cnfa *const, struct colormap *const, struct smalldfa *); -static void freeDFA(struct dfa *const); -static unsigned hash(unsigned *const, const int); -static struct sset *initialize(struct vars *const, struct dfa *const, chr *const); -static struct sset *miss(struct vars *const, struct dfa *const, struct sset *const, const pcolor, chr *const, chr *const); -static int checkLAConstraint(struct vars *const, struct cnfa *const, chr *const, const pcolor); -static struct sset *getVacantSS(struct vars *const, struct dfa *const, chr *const, chr *const); -static struct sset *pickNextSS(struct vars *const, struct dfa *const, chr *const, chr *const); +static chr *longest(struct vars *, struct dfa *, chr *, chr *, int *); +static chr *shortest(struct vars *, struct dfa *, chr *, chr *, chr *, chr **, int *); +static chr *lastcold(struct vars *, struct dfa *); +static struct dfa *newdfa(struct vars *, struct cnfa *, struct colormap *, struct smalldfa *); +static VOID freedfa(struct dfa *); +static unsigned hash(unsigned *, int); +static struct sset *initialize(struct vars *, struct dfa *, chr *); +static struct sset *miss(struct vars *, struct dfa *, struct sset *, pcolor, chr *, chr *); +static int lacon(struct vars *, struct cnfa *, chr *, pcolor); +static struct sset *getvacant(struct vars *, struct dfa *, chr *, chr *); +static struct sset *pickss(struct vars *, struct dfa *, chr *, chr *); /* automatically gathered by fwd; do not hand-edit */ /* =====^!^===== end forwards =====^!^===== */ /* - exec - match regular expression - ^ int exec(regex_t *, const chr *, size_t, rm_detail_t *, + ^ int exec(regex_t *, CONST chr *, size_t, rm_detail_t *, ^ size_t, regmatch_t [], int); */ int exec( regex_t *re, - const chr *string, + CONST chr *string, size_t len, rm_detail_t *details, size_t nmatch, regmatch_t pmatch[], int flags) { AllocVars(v); - int st, backref; - int n; - int i; + int st; + size_t n; + int backref; #define LOCALMAT 20 regmatch_t mat[LOCALMAT]; -#define LOCALDFAS 40 - struct dfa *subdfas[LOCALDFAS]; +#define LOCALMEM 40 + regoff_t mem[LOCALMEM]; /* * 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. */ @@ -228,110 +233,100 @@ } v->details = details; v->start = (chr *)string; v->stop = (chr *)string + len; v->err = 0; - assert(v->g->ntree >= 0); - n = v->g->ntree; - if (n <= LOCALDFAS) - v->subdfas = subdfas; - else - v->subdfas = (struct dfa **) MALLOC(n * sizeof(struct dfa *)); - if (v->subdfas == NULL) { - if (v->pmatch != pmatch && v->pmatch != mat) - FREE(v->pmatch); - FreeVars(v); - return REG_ESPACE; - } - for (i = 0; i < n; i++) - v->subdfas[i] = NULL; + if (backref) { + /* + * Need retry memory. + */ + + assert(v->g->ntree >= 0); + n = (size_t)v->g->ntree; + if (n <= LOCALMEM) { + v->mem = mem; + } else { + v->mem = (regoff_t *) MALLOC(n*sizeof(regoff_t)); + } + if (v->mem == NULL) { + if (v->pmatch != pmatch && v->pmatch != mat) { + FREE(v->pmatch); + } + FreeVars(v); + return REG_ESPACE; + } + } else { + v->mem = NULL; + } /* * Do it. */ assert(v->g->tree != NULL); if (backref) { - st = complicatedFind(v, &v->g->tree->cnfa, &v->g->cmap); + st = cfind(v, &v->g->tree->cnfa, &v->g->cmap); } else { - st = simpleFind(v, &v->g->tree->cnfa, &v->g->cmap); + st = find(v, &v->g->tree->cnfa, &v->g->cmap); } /* * Copy (portion of) match vector over if necessary. */ if (st == REG_OKAY && v->pmatch != pmatch && nmatch > 0) { - zapallsubs(pmatch, nmatch); + zapsubs(pmatch, nmatch); n = (nmatch < v->nmatch) ? nmatch : v->nmatch; - memcpy((void*)(pmatch), (void*)(v->pmatch), n*sizeof(regmatch_t)); + memcpy(VS(pmatch), VS(v->pmatch), n*sizeof(regmatch_t)); } /* * Clean up. */ if (v->pmatch != pmatch && v->pmatch != mat) { FREE(v->pmatch); } - n = v->g->ntree; - for (i = 0; i < n; i++) { - if (v->subdfas[i] != NULL) - freeDFA(v->subdfas[i]); + if (v->mem != NULL && v->mem != mem) { + FREE(v->mem); } - if (v->subdfas != subdfas) - FREE(v->subdfas); FreeVars(v); return st; } /* - - getsubdfa - create or re-fetch the DFA for a subre node - * We only need to create the DFA once per overall regex execution. - * 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]; -} - -/* - - simpleFind - find a match for the main NFA (no-complications case) - ^ static int simpleFind(struct vars *, struct cnfa *, struct colormap *); + - find - find a match for the main NFA (no-complications case) + ^ static int find(struct vars *, struct cnfa *, struct colormap *); */ static int -simpleFind( - struct vars *const v, - struct cnfa *const cnfa, - struct colormap *const cm) +find( + struct vars *v, + struct cnfa *cnfa, + struct colormap *cm) { - struct dfa *s, *d; - chr *begin, *end = NULL; + struct dfa *s; + struct dfa *d; + chr *begin; + chr *end = NULL; chr *cold; - chr *open, *close; /* Open and close of range of possible + chr *open; /* Open and close of range of possible * starts */ + chr *close; int hitend; int shorter = (v->g->tree->flags&SHORTER) ? 1 : 0; /* * First, a shot with the search RE. */ - s = newDFA(v, &v->g->search, cm, &v->dfa1); + s = newdfa(v, &v->g->search, cm, &v->dfa1); assert(!(ISERR() && s != NULL)); NOERR(); MDEBUG(("\nsearch at %ld\n", LOFF(v->start))); cold = NULL; close = shortest(v, s, v->start, v->start, v->stop, &cold, NULL); - freeDFA(s); + freedfa(s); NOERR(); if (v->g->cflags®_EXPECT) { assert(v->details != NULL); if (cold != NULL) { v->details->rm_extend.rm_so = OFF(cold); @@ -353,33 +348,30 @@ assert(cold != NULL); open = cold; cold = NULL; MDEBUG(("between %ld and %ld\n", LOFF(open), LOFF(close))); - d = newDFA(v, cnfa, cm, &v->dfa1); + d = newdfa(v, cnfa, cm, &v->dfa1); assert(!(ISERR() && d != NULL)); NOERR(); for (begin = open; begin <= close; begin++) { MDEBUG(("\nfind trying at %ld\n", LOFF(begin))); if (shorter) { end = shortest(v, d, begin, begin, v->stop, NULL, &hitend); } else { end = longest(v, d, begin, v->stop, &hitend); } - if (ISERR()) { - freeDFA(d); - return v->err; - } + NOERR(); if (hitend && cold == NULL) { cold = begin; } if (end != NULL) { break; /* NOTE BREAK OUT */ } } assert(end != NULL); /* search RE succeeded so loop should */ - freeDFA(d); + freedfa(d); /* * And pin down details. */ @@ -397,44 +389,45 @@ if (v->nmatch == 1) { /* no need for submatches */ return REG_OKAY; } /* - * Find submatches. + * Submatches. */ - zapallsubs(v->pmatch, v->nmatch); - return cdissect(v, v->g->tree, begin, end); + zapsubs(v->pmatch, v->nmatch); + return dissect(v, v->g->tree, begin, end); } /* - - complicatedFind - find a match for the main NFA (with complications) - ^ static int complicatedFind(struct vars *, struct cnfa *, struct colormap *); + - cfind - find a match for the main NFA (with complications) + ^ static int cfind(struct vars *, struct cnfa *, struct colormap *); */ static int -complicatedFind( - struct vars *const v, - struct cnfa *const cnfa, - struct colormap *const cm) +cfind( + struct vars *v, + struct cnfa *cnfa, + struct colormap *cm) { - struct dfa *s, *d; + struct dfa *s; + struct dfa *d; chr *cold = NULL; /* silence gcc 4 warning */ int ret; - s = newDFA(v, &v->g->search, cm, &v->dfa1); + s = newdfa(v, &v->g->search, cm, &v->dfa1); NOERR(); - d = newDFA(v, cnfa, cm, &v->dfa2); + d = newdfa(v, cnfa, cm, &v->dfa2); if (ISERR()) { assert(d == NULL); - freeDFA(s); + freedfa(s); return v->err; } - ret = complicatedFindLoop(v, d, s, &cold); + ret = cfindloop(v, cnfa, cm, d, s, &cold); - freeDFA(d); - freeDFA(s); + 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); @@ -445,28 +438,34 @@ } return ret; } /* - - complicatedFindLoop - the heart of complicatedFind - ^ static int complicatedFindLoop(struct vars *, + - cfindloop - the heart of cfind + ^ static int cfindloop(struct vars *, struct cnfa *, struct colormap *, ^ 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 */ +cfindloop( + struct vars *v, + struct cnfa *cnfa, + struct colormap *cm, + struct dfa *d, + struct dfa *s, + chr **coldp) /* where to put coldstart pointer */ { - chr *begin, *end; + chr *begin; + chr *end; chr *cold; - chr *open, *close; /* Open and close of range of possible + chr *open; /* Open and close of range of possible * starts */ - chr *estart, *estop; - int er, hitend; + chr *close; + chr *estart; + chr *estop; + int er; int shorter = v->g->tree->flags&SHORTER; + int hitend; assert(d != NULL && s != NULL); cold = NULL; close = v->start; do { @@ -478,11 +477,11 @@ assert(cold != NULL); open = cold; cold = NULL; MDEBUG(("cbetween %ld and %ld\n", LOFF(open), LOFF(close))); for (begin = open; begin <= close; begin++) { - MDEBUG(("\ncomplicatedFind trying at %ld\n", LOFF(begin))); + MDEBUG(("\ncfind trying at %ld\n", LOFF(begin))); estart = begin; estop = v->stop; for (;;) { if (shorter) { end = shortest(v, d, begin, estart, estop, NULL, &hitend); @@ -495,11 +494,12 @@ if (end == NULL) { break; /* NOTE BREAK OUT */ } MDEBUG(("tentative end %ld\n", LOFF(end))); - zapallsubs(v->pmatch, v->nmatch); + zapsubs(v->pmatch, v->nmatch); + zapmem(v, v->g->tree); er = cdissect(v, v->g->tree, begin, end); if (er == REG_OKAY) { if (v->nmatch > 0) { v->pmatch[0].rm_so = OFF(begin); v->pmatch[0].rm_eo = OFF(end); @@ -507,11 +507,10 @@ *coldp = cold; return REG_OKAY; } if (er != REG_NOMATCH) { ERR(er); - *coldp = cold; return er; } if ((shorter) ? end == estop : end == begin) { break; } @@ -532,17 +531,17 @@ *coldp = cold; return REG_NOMATCH; } /* - - zapallsubs - initialize all subexpression matches to "no match" - ^ static void zapallsubs(regmatch_t *, size_t); + - zapsubs - initialize the subexpression matches to "no match" + ^ static VOID zapsubs(regmatch_t *, size_t); */ static void -zapallsubs( - regmatch_t *const p, - const size_t n) +zapsubs( + regmatch_t *p, + size_t n) { size_t i; for (i = n-1; i > 0; i--) { p[i].rm_so = -1; @@ -549,45 +548,48 @@ p[i].rm_eo = -1; } } /* - - zaptreesubs - initialize subexpressions within subtree to "no match" - ^ static void zaptreesubs(struct vars *, struct subre *); + - zapmem - initialize the retry memory of a subtree to zeros + ^ static VOID zapmem(struct vars *, struct subre *); */ static void -zaptreesubs( - struct vars *const v, - struct subre *const t) +zapmem( + struct vars *v, + struct subre *t) { + if (t == NULL) { + return; + } + + assert(v->mem != NULL); + v->mem[t->retry] = 0; if (t->op == '(') { - int n = t->subno; - assert(n > 0); - if ((size_t) n < v->nmatch) { - v->pmatch[n].rm_so = -1; - v->pmatch[n].rm_eo = -1; - } + assert(t->subno > 0); + v->pmatch[t->subno].rm_so = -1; + v->pmatch[t->subno].rm_eo = -1; } if (t->left != NULL) { - zaptreesubs(v, t->left); + zapmem(v, t->left); } if (t->right != NULL) { - zaptreesubs(v, t->right); + zapmem(v, t->right); } } /* - - subset - set subexpression match data for a successful subre - ^ static void subset(struct vars *, struct subre *, chr *, chr *); + - subset - set any subexpression relevant to a successful subre + ^ static VOID subset(struct vars *, struct subre *, chr *, chr *); */ static void subset( - struct vars *const v, - struct subre *const sub, - chr *const begin, - chr *const end) + struct vars *v, + struct subre *sub, + chr *begin, + chr *end) { int n = sub->subno; assert(n > 0); if ((size_t)n >= v->nmatch) { @@ -598,119 +600,274 @@ v->pmatch[n].rm_so = OFF(begin); v->pmatch[n].rm_eo = OFF(end); } /* - - cdissect - check backrefs and determine subexpression matches - * cdissect recursively processes a subre tree to check matching of backrefs - * and/or identify submatch boundaries for capture nodes. The proposed match - * runs from "begin" to "end" (not including "end"), and we are basically - * "dissecting" it to see where the submatches are. - * Before calling any level of cdissect, the caller must have run the node's - * DFA and found that the proposed substring satisfies the DFA. (We make - * the caller do that because in concatenation and iteration nodes, it's - * much faster to check all the substrings against the child DFAs before we - * recurse.) Also, caller must have cleared subexpression match data via - * zaptreesubs (or zapallsubs at the top level). + - dissect - determine subexpression matches (uncomplicated case) + ^ static int dissect(struct vars *, struct subre *, chr *, chr *); + */ +static int /* regexec return code */ +dissect( + struct vars *v, + struct subre *t, + chr *begin, /* beginning of relevant substring */ + chr *end) /* end of same */ +{ + assert(t != NULL); + MDEBUG(("dissect %ld-%ld\n", LOFF(begin), LOFF(end))); + + switch (t->op) { + case '=': /* terminal node */ + assert(t->left == NULL && t->right == NULL); + return REG_OKAY; /* no action, parent did the work */ + case '|': /* alternation */ + assert(t->left != NULL); + return altdissect(v, t, begin, end); + case 'b': /* back ref -- shouldn't be calling us! */ + return REG_ASSERT; + case '.': /* concatenation */ + assert(t->left != NULL && t->right != NULL); + return condissect(v, t, begin, end); + case '(': /* capturing */ + assert(t->left != NULL && t->right == NULL); + assert(t->subno > 0); + subset(v, t, begin, end); + return dissect(v, t->left, begin, end); + default: + return REG_ASSERT; + } +} + +/* + - condissect - determine concatenation subexpression matches (uncomplicated) + ^ static int condissect(struct vars *, struct subre *, chr *, chr *); + */ +static int /* regexec return code */ +condissect( + struct vars *v, + struct subre *t, + chr *begin, /* beginning of relevant substring */ + chr *end) /* end of same */ +{ + struct dfa *d; + struct dfa *d2; + chr *mid; + int i; + int shorter = (t->left->flags&SHORTER) ? 1 : 0; + chr *stop = (shorter) ? end : begin; + + assert(t->op == '.'); + assert(t->left != NULL && t->left->cnfa.nstates > 0); + assert(t->right != NULL && t->right->cnfa.nstates > 0); + + d = newdfa(v, &t->left->cnfa, &v->g->cmap, &v->dfa1); + NOERR(); + d2 = newdfa(v, &t->right->cnfa, &v->g->cmap, &v->dfa2); + if (ISERR()) { + assert(d2 == NULL); + freedfa(d); + return v->err; + } + + /* + * Pick a tentative midpoint. + */ + + if (shorter) { + mid = shortest(v, d, begin, begin, end, NULL, NULL); + } else { + mid = longest(v, d, begin, end, NULL); + } + if (mid == NULL) { + freedfa(d); + freedfa(d2); + return REG_ASSERT; + } + MDEBUG(("tentative midpoint %ld\n", LOFF(mid))); + + /* + * Iterate until satisfaction or failure. + */ + + while (longest(v, d2, mid, end, NULL) != end) { + /* + * That midpoint didn't work, find a new one. + */ + + if (mid == stop) { + /* + * All possibilities exhausted! + */ + + MDEBUG(("no midpoint!\n")); + freedfa(d); + freedfa(d2); + return REG_ASSERT; + } + if (shorter) { + mid = shortest(v, d, begin, mid+1, end, NULL, NULL); + } else { + mid = longest(v, d, begin, mid-1, NULL); + } + if (mid == NULL) { + /* + * Failed to find a new one! + */ + + MDEBUG(("failed midpoint!\n")); + freedfa(d); + freedfa(d2); + return REG_ASSERT; + } + MDEBUG(("new midpoint %ld\n", LOFF(mid))); + } + + /* + * Satisfaction. + */ + + MDEBUG(("successful\n")); + freedfa(d); + freedfa(d2); + i = dissect(v, t->left, begin, mid); + if (i != REG_OKAY) { + return i; + } + return dissect(v, t->right, mid, end); +} + +/* + - altdissect - determine alternative subexpression matches (uncomplicated) + ^ static int altdissect(struct vars *, struct subre *, chr *, chr *); + */ +static int /* regexec return code */ +altdissect( + struct vars *v, + struct subre *t, + chr *begin, /* beginning of relevant substring */ + chr *end) /* end of same */ +{ + struct dfa *d; + int i; + + assert(t != NULL); + assert(t->op == '|'); + + for (i = 0; t != NULL; t = t->right, i++) { + MDEBUG(("trying %dth\n", i)); + assert(t->left != NULL && t->left->cnfa.nstates > 0); + d = newdfa(v, &t->left->cnfa, &v->g->cmap, &v->dfa1); + if (ISERR()) { + return v->err; + } + if (longest(v, d, begin, end, NULL) == end) { + MDEBUG(("success\n")); + freedfa(d); + return dissect(v, t->left, begin, end); + } + freedfa(d); + } + return REG_ASSERT; /* none of them matched?!? */ +} + +/* + - cdissect - determine subexpression matches (with complications) + * The retry memory stores the offset of the trial midpoint from begin, plus 1 + * so that 0 uniquely means "clean slate". ^ static int cdissect(struct vars *, struct subre *, chr *, chr *); */ static int /* regexec return code */ cdissect( struct vars *v, struct subre *t, - chr *begin, /* beginning of relevant substring */ - chr *end) /* end of same */ + chr *begin, /* beginning of relevant substring */ + chr *end) /* end of same */ { int er; assert(t != NULL); MDEBUG(("cdissect %ld-%ld %c\n", LOFF(begin), LOFF(end), t->op)); switch (t->op) { case '=': /* terminal node */ assert(t->left == NULL && t->right == NULL); - er = REG_OKAY; /* no action, parent did the work */ - break; - case 'b': /* back reference */ + return REG_OKAY; /* no action, parent did the work */ + case '|': /* alternation */ + assert(t->left != NULL); + return caltdissect(v, t, begin, end); + case 'b': /* back ref -- shouldn't be calling us! */ assert(t->left == NULL && t->right == NULL); - er = cbrdissect(v, t, begin, end); - break; + return cbrdissect(v, t, begin, end); case '.': /* concatenation */ assert(t->left != NULL && t->right != NULL); - if (t->left->flags & SHORTER) /* reverse scan */ - er = crevcondissect(v, t, begin, end); - else - er = ccondissect(v, t, begin, end); - break; - case '|': /* alternation */ - assert(t->left != NULL); - er = caltdissect(v, t, begin, end); - break; - case '*': /* iteration */ - assert(t->left != NULL); - if (t->left->flags & SHORTER) /* reverse scan */ - er = creviterdissect(v, t, begin, end); - else - er = citerdissect(v, t, begin, end); - break; + return ccondissect(v, t, begin, end); case '(': /* capturing */ assert(t->left != NULL && t->right == NULL); assert(t->subno > 0); er = cdissect(v, t->left, begin, end); if (er == REG_OKAY) { subset(v, t, begin, end); } - break; + return er; default: - er = REG_ASSERT; - break; - } - - /* - * We should never have a match failure unless backrefs lurk below; - * otherwise, either caller failed to check the DFA, or there's some - * inconsistency between the DFA and the node's innards. - */ - assert(er != REG_NOMATCH || (t->flags & BACKR)); - - return er; + return REG_ASSERT; + } } /* - - ccondissect - dissect match for concatenation node + - ccondissect - concatenation subexpression matches (with complications) + * The retry memory stores the offset of the trial midpoint from begin, plus 1 + * so that 0 uniquely means "clean slate". ^ static int ccondissect(struct vars *, struct subre *, chr *, chr *); */ static int /* regexec return code */ ccondissect( struct vars *v, struct subre *t, - chr *begin, /* beginning of relevant substring */ - chr *end) /* end of same */ + chr *begin, /* beginning of relevant substring */ + chr *end) /* end of same */ { struct dfa *d, *d2; chr *mid; + int er; assert(t->op == '.'); assert(t->left != NULL && t->left->cnfa.nstates > 0); assert(t->right != NULL && t->right->cnfa.nstates > 0); - assert(!(t->left->flags & SHORTER)); - - d = getsubdfa(v, t->left); - NOERR(); - d2 = getsubdfa(v, t->right); - NOERR(); - - MDEBUG(("cConcat %d\n", t->id)); + + if (t->left->flags&SHORTER) { /* reverse scan */ + return crevdissect(v, t, begin, end); + } + + d = newdfa(v, &t->left->cnfa, &v->g->cmap, DOMALLOC); + if (ISERR()) { + return v->err; + } + d2 = newdfa(v, &t->right->cnfa, &v->g->cmap, DOMALLOC); + if (ISERR()) { + freedfa(d); + return v->err; + } + MDEBUG(("cconcat %d\n", t->retry)); /* * Pick a tentative midpoint. */ - mid = longest(v, d, begin, end, (int *) NULL); - if (mid == NULL) { - return REG_NOMATCH; + + if (v->mem[t->retry] == 0) { + mid = longest(v, d, begin, end, NULL); + if (mid == NULL) { + freedfa(d); + freedfa(d2); + return REG_NOMATCH; + } + MDEBUG(("tentative midpoint %ld\n", LOFF(mid))); + v->mem[t->retry] = (mid - begin) + 1; + } else { + mid = begin + (v->mem[t->retry] - 1); + MDEBUG(("working midpoint %ld\n", LOFF(mid))); } - MDEBUG(("tentative midpoint %ld\n", LOFF(mid))); /* * Iterate until satisfaction or failure. */ @@ -718,24 +875,27 @@ /* * Try this midpoint on for size. */ if (longest(v, d2, mid, end, NULL) == end) { - int er = cdissect(v, t->left, begin, mid); - + er = cdissect(v, t->left, begin, mid); if (er == REG_OKAY) { er = cdissect(v, t->right, mid, end); if (er == REG_OKAY) { /* * Satisfaction. */ - + MDEBUG(("successful\n")); + freedfa(d); + freedfa(d2); return REG_OKAY; } } - if (er != REG_NOMATCH) { + if ((er != REG_OKAY) && (er != REG_NOMATCH)) { + freedfa(d); + freedfa(d2); return er; } } /* @@ -745,63 +905,88 @@ if (mid == begin) { /* * All possibilities exhausted. */ - MDEBUG(("%d no midpoint\n", t->id)); + MDEBUG(("%d no midpoint\n", t->retry)); + freedfa(d); + freedfa(d2); return REG_NOMATCH; } mid = longest(v, d, begin, mid-1, NULL); if (mid == NULL) { /* * Failed to find a new one. */ - MDEBUG(("%d failed midpoint\n", t->id)); + MDEBUG(("%d failed midpoint\n", t->retry)); + freedfa(d); + freedfa(d2); return REG_NOMATCH; } - MDEBUG(("%d: new midpoint %ld\n", t->id, LOFF(mid))); - zaptreesubs(v, t->left); - zaptreesubs(v, t->right); + MDEBUG(("%d: new midpoint %ld\n", t->retry, LOFF(mid))); + v->mem[t->retry] = (mid - begin) + 1; + zapmem(v, t->left); + zapmem(v, t->right); } } /* - - crevcondissect - dissect match for concatenation node, shortest-first - ^ static int crevcondissect(struct vars *, struct subre *, chr *, chr *); + - crevdissect - determine backref shortest-first subexpression matches + * The retry memory stores the offset of the trial midpoint from begin, plus 1 + * so that 0 uniquely means "clean slate". + ^ static int crevdissect(struct vars *, struct subre *, chr *, chr *); */ static int /* regexec return code */ -crevcondissect( +crevdissect( struct vars *v, struct subre *t, - chr *begin, /* beginning of relevant substring */ - chr *end) /* end of same */ + chr *begin, /* beginning of relevant substring */ + chr *end) /* end of same */ { - struct dfa *d, *d2; + struct dfa *d; + struct dfa *d2; chr *mid; + int er; assert(t->op == '.'); assert(t->left != NULL && t->left->cnfa.nstates > 0); assert(t->right != NULL && t->right->cnfa.nstates > 0); assert(t->left->flags&SHORTER); - d = getsubdfa(v, t->left); - NOERR(); - d2 = getsubdfa(v, t->right); - NOERR(); + /* + * Concatenation -- need to split the substring between parts. + */ - MDEBUG(("crevcon %d\n", t->id)); + d = newdfa(v, &t->left->cnfa, &v->g->cmap, DOMALLOC); + if (ISERR()) { + return v->err; + } + d2 = newdfa(v, &t->right->cnfa, &v->g->cmap, DOMALLOC); + if (ISERR()) { + freedfa(d); + return v->err; + } + MDEBUG(("crev %d\n", t->retry)); /* * Pick a tentative midpoint. */ - mid = shortest(v, d, begin, begin, end, (chr **) NULL, (int *) NULL); - if (mid == NULL) { - return REG_NOMATCH; + if (v->mem[t->retry] == 0) { + mid = shortest(v, d, begin, begin, end, NULL, NULL); + if (mid == NULL) { + freedfa(d); + freedfa(d2); + return REG_NOMATCH; + } + MDEBUG(("tentative midpoint %ld\n", LOFF(mid))); + v->mem[t->retry] = (mid - begin) + 1; + } else { + mid = begin + (v->mem[t->retry] - 1); + MDEBUG(("working midpoint %ld\n", LOFF(mid))); } - MDEBUG(("tentative midpoint %ld\n", LOFF(mid))); /* * Iterate until satisfaction or failure. */ @@ -809,24 +994,27 @@ /* * Try this midpoint on for size. */ if (longest(v, d2, mid, end, NULL) == end) { - int er = cdissect(v, t->left, begin, mid); - + er = cdissect(v, t->left, begin, mid); if (er == REG_OKAY) { er = cdissect(v, t->right, mid, end); if (er == REG_OKAY) { /* * Satisfaction. */ MDEBUG(("successful\n")); + freedfa(d); + freedfa(d2); return REG_OKAY; } } - if (er != REG_NOMATCH) { + if (er != REG_OKAY && er != REG_NOMATCH) { + freedfa(d); + freedfa(d2); return er; } } /* @@ -836,487 +1024,172 @@ if (mid == end) { /* * All possibilities exhausted. */ - MDEBUG(("%d no midpoint\n", t->id)); + MDEBUG(("%d no midpoint\n", t->retry)); + freedfa(d); + freedfa(d2); return REG_NOMATCH; } mid = shortest(v, d, begin, mid+1, end, NULL, NULL); if (mid == NULL) { /* * Failed to find a new one. */ - MDEBUG(("%d failed midpoint\n", t->id)); + MDEBUG(("%d failed midpoint\n", t->retry)); + freedfa(d); + freedfa(d2); return REG_NOMATCH; } - MDEBUG(("%d: new midpoint %ld\n", t->id, LOFF(mid))); - zaptreesubs(v, t->left); - zaptreesubs(v, t->right); + MDEBUG(("%d: new midpoint %ld\n", t->retry, LOFF(mid))); + v->mem[t->retry] = (mid - begin) + 1; + zapmem(v, t->left); + zapmem(v, t->right); } } /* - - cbrdissect - dissect match for backref node + - cbrdissect - determine backref subexpression matches ^ static int cbrdissect(struct vars *, struct subre *, chr *, chr *); */ static int /* regexec return code */ cbrdissect( struct vars *v, struct subre *t, - chr *begin, /* beginning of relevant substring */ - chr *end) /* end of same */ -{ - int n = t->subno, min = t->min, max = t->max; - size_t numreps; - size_t tlen; - size_t brlen; - chr *brstring; - chr *p; + chr *begin, /* beginning of relevant substring */ + chr *end) /* end of same */ +{ + int i; + int n = t->subno; + size_t len; + chr *paren; + chr *p; + chr *stop; + int min = t->min; + int max = t->max; assert(t != NULL); assert(t->op == 'b'); assert(n >= 0); assert((size_t)n < v->nmatch); - MDEBUG(("cbackref n%d %d{%d-%d}\n", t->id, n, min, max)); - - /* get the backreferenced string */ - if (v->pmatch[n].rm_so == TCL_INDEX_NONE) { - return REG_NOMATCH; - } - brstring = v->start + v->pmatch[n].rm_so; - brlen = v->pmatch[n].rm_eo - v->pmatch[n].rm_so; - - /* special cases for zero-length strings */ - if (brlen == 0) { - /* - * matches only if target is zero length, but any number of - * repetitions can be considered to be present - */ - if (begin == end && min <= max) { - MDEBUG(("cbackref matched trivially\n")); - return REG_OKAY; - } - return REG_NOMATCH; - } - if (begin == end) { - /* matches only if zero repetitions are okay */ - if (min == 0) { - MDEBUG(("cbackref matched trivially\n")); + MDEBUG(("cbackref n%d %d{%d-%d}\n", t->retry, n, min, max)); + + if (v->pmatch[n].rm_so == -1) { + return REG_NOMATCH; + } + paren = v->start + v->pmatch[n].rm_so; + len = v->pmatch[n].rm_eo - v->pmatch[n].rm_so; + + /* + * No room to maneuver -- retries are pointless. + */ + + if (v->mem[t->retry]) { + return REG_NOMATCH; + } + v->mem[t->retry] = 1; + + /* + * Special-case zero-length string. + */ + + if (len == 0) { + if (begin == end) { return REG_OKAY; } return REG_NOMATCH; } /* - * check target length to see if it could possibly be an allowed number of - * repetitions of brstring + * And too-short string. + */ + + assert(end >= begin); + if ((size_t)(end - begin) < len) { + return REG_NOMATCH; + } + stop = end - len; + + /* + * Count occurrences. + */ + + i = 0; + for (p = begin; p <= stop && (i < max || max == DUPINF); p += len) { + if ((*v->g->compare)(paren, p, len) != 0) { + break; + } + i++; + } + MDEBUG(("cbackref found %d\n", i)); + + /* + * And sort it out. */ - assert(end > begin); - tlen = end - begin; - if (tlen % brlen != 0) - return REG_NOMATCH; - numreps = tlen / brlen; - if (numreps < (size_t)min || (numreps > (size_t)max && max != DUPINF)) - return REG_NOMATCH; - - /* okay, compare the actual string contents */ - p = begin; - while (numreps-- > 0) { - if ((*v->g->compare) (brstring, p, brlen) != 0) - return REG_NOMATCH; - p += brlen; - } - - MDEBUG(("cbackref matched\n")); - return REG_OKAY; + if (p != end) { /* didn't consume all of it */ + return REG_NOMATCH; + } + if (min <= i && (i <= max || max == DUPINF)) { + return REG_OKAY; + } + return REG_NOMATCH; /* out of range */ } /* - - caltdissect - dissect match for alternation node + - caltdissect - determine alternative subexpression matches (w. complications) ^ static int caltdissect(struct vars *, struct subre *, chr *, chr *); */ static int /* regexec return code */ caltdissect( struct vars *v, struct subre *t, - chr *begin, /* beginning of relevant substring */ - chr *end) /* end of same */ + chr *begin, /* beginning of relevant substring */ + chr *end) /* end of same */ { struct dfa *d; int er; - - /* We loop, rather than tail-recurse, to handle a chain of alternatives */ - while (t != NULL) { - assert(t->op == '|'); - assert(t->left != NULL && t->left->cnfa.nstates > 0); - - MDEBUG(("calt n%d\n", t->id)); - - d = getsubdfa(v, t->left); - NOERR(); - if (longest(v, d, begin, end, (int *) NULL) == end) { - MDEBUG(("calt matched\n")); - er = cdissect(v, t->left, begin, end); - if (er != REG_NOMATCH) { - return er; - } - } - - t = t->right; - } - - return REG_NOMATCH; -} - -/* - - citerdissect - dissect match for iteration node - ^ static int citerdissect(struct vars *, struct subre *, chr *, chr *); - */ -static int /* regexec return code */ -citerdissect(struct vars * v, - struct subre * t, - chr *begin, /* beginning of relevant substring */ - chr *end) /* end of same */ -{ - struct dfa *d; - chr **endpts; - chr *limit; - int min_matches; - size_t max_matches; - int nverified; - int k; - int i; - int er; - - assert(t->op == '*'); - assert(t->left != NULL && t->left->cnfa.nstates > 0); - assert(!(t->left->flags & SHORTER)); - assert(begin <= end); - - /* - * If zero matches are allowed, and target string is empty, just declare - * victory. OTOH, if target string isn't empty, zero matches can't work - * so we pretend the min is 1. - */ - min_matches = t->min; - if (min_matches <= 0) { - if (begin == end) - return REG_OKAY; - min_matches = 1; - } - - /* - * We need workspace to track the endpoints of each sub-match. Normally - * we consider only nonzero-length sub-matches, so there can be at most - * end-begin of them. However, if min is larger than that, we will also - * consider zero-length sub-matches in order to find enough matches. - * - * For convenience, endpts[0] contains the "begin" pointer and we store - * sub-match endpoints in endpts[1..max_matches]. - */ - max_matches = end - begin; - if (max_matches > (size_t)t->max && t->max != DUPINF) - max_matches = t->max; - if (max_matches < (size_t)min_matches) - max_matches = min_matches; - endpts = (chr **) MALLOC((max_matches + 1) * sizeof(chr *)); - if (endpts == NULL) - return REG_ESPACE; - endpts[0] = begin; - - d = getsubdfa(v, t->left); - if (ISERR()) { - FREE(endpts); - return v->err; - } - MDEBUG(("citer %d\n", t->id)); - - /* - * Our strategy is to first find a set of sub-match endpoints that are - * valid according to the child node's DFA, and then recursively dissect - * each sub-match to confirm validity. If any validity check fails, - * backtrack the last sub-match and try again. And, when we next try for - * a validity check, we need not recheck any successfully verified - * sub-matches that we didn't move the endpoints of. nverified remembers - * how many sub-matches are currently known okay. - */ - - /* initialize to consider first sub-match */ - nverified = 0; - k = 1; - limit = end; - - /* iterate until satisfaction or failure */ - while (k > 0) { - /* try to find an endpoint for the k'th sub-match */ - endpts[k] = longest(v, d, endpts[k - 1], limit, (int *) NULL); - if (endpts[k] == NULL) { - /* no match possible, so see if we can shorten previous one */ - k--; - goto backtrack; - } - MDEBUG(("%d: working endpoint %d: %ld\n", - t->id, k, LOFF(endpts[k]))); - - /* k'th sub-match can no longer be considered verified */ - if (nverified >= k) - nverified = k - 1; - - if (endpts[k] != end) { - /* haven't reached end yet, try another iteration if allowed */ - if ((size_t)k >= max_matches) { - /* must try to shorten some previous match */ - k--; - goto backtrack; - } - - /* reject zero-length match unless necessary to achieve min */ - if (endpts[k] == endpts[k - 1] && - (k >= min_matches || min_matches - k < end - endpts[k])) - goto backtrack; - - k++; - limit = end; - continue; - } - - /* - * We've identified a way to divide the string into k sub-matches - * that works so far as the child DFA can tell. If k is an allowed - * number of matches, start the slow part: recurse to verify each - * sub-match. We always have k <= max_matches, needn't check that. - */ - if (k < min_matches) - goto backtrack; - - MDEBUG(("%d: verifying %d..%d\n", t->id, nverified + 1, k)); - - for (i = nverified + 1; i <= k; i++) { - zaptreesubs(v, t->left); - er = cdissect(v, t->left, endpts[i - 1], endpts[i]); - if (er == REG_OKAY) { - nverified = i; - continue; - } - if (er == REG_NOMATCH) - break; - /* oops, something failed */ - FREE(endpts); - return er; - } - - if (i > k) { - /* satisfaction */ - MDEBUG(("%d successful\n", t->id)); - FREE(endpts); - return REG_OKAY; - } - - /* match failed to verify, so backtrack */ - - backtrack: - /* - * Must consider shorter versions of the current sub-match. However, - * we'll only ask for a zero-length match if necessary. - */ - while (k > 0) { - chr *prev_end = endpts[k - 1]; - - if (endpts[k] > prev_end) { - limit = endpts[k] - 1; - if (limit > prev_end || - (k < min_matches && min_matches - k >= end - prev_end)) { - /* break out of backtrack loop, continue the outer one */ - break; - } - } - /* can't shorten k'th sub-match any more, consider previous one */ - k--; - } - } - - /* all possibilities exhausted */ - MDEBUG(("%d failed\n", t->id)); - FREE(endpts); - return REG_NOMATCH; -} - -/* - - creviterdissect - dissect match for iteration node, shortest-first - ^ static int creviterdissect(struct vars *, struct subre *, chr *, chr *); - */ -static int /* regexec return code */ -creviterdissect(struct vars * v, - struct subre * t, - chr *begin, /* beginning of relevant substring */ - chr *end) /* end of same */ -{ - struct dfa *d; - chr **endpts; - chr *limit; - int min_matches; - size_t max_matches; - int nverified; - int k; - int i; - int er; - - assert(t->op == '*'); - assert(t->left != NULL && t->left->cnfa.nstates > 0); - assert(t->left->flags & SHORTER); - assert(begin <= end); - - /* - * If zero matches are allowed, and target string is empty, just declare - * victory. OTOH, if target string isn't empty, zero matches can't work - * so we pretend the min is 1. - */ - min_matches = t->min; - if (min_matches <= 0) { - if (begin == end) - return REG_OKAY; - min_matches = 1; - } - - /* - * We need workspace to track the endpoints of each sub-match. Normally - * we consider only nonzero-length sub-matches, so there can be at most - * end-begin of them. However, if min is larger than that, we will also - * consider zero-length sub-matches in order to find enough matches. - * - * For convenience, endpts[0] contains the "begin" pointer and we store - * sub-match endpoints in endpts[1..max_matches]. - */ - max_matches = end - begin; - if (max_matches > (size_t)t->max && t->max != DUPINF) - max_matches = t->max; - if (max_matches < (size_t)min_matches) - max_matches = min_matches; - endpts = (chr **) MALLOC((max_matches + 1) * sizeof(chr *)); - if (endpts == NULL) - return REG_ESPACE; - endpts[0] = begin; - - d = getsubdfa(v, t->left); - if (ISERR()) { - FREE(endpts); - return v->err; - } - MDEBUG(("creviter %d\n", t->id)); - - /* - * Our strategy is to first find a set of sub-match endpoints that are - * valid according to the child node's DFA, and then recursively dissect - * each sub-match to confirm validity. If any validity check fails, - * backtrack the last sub-match and try again. And, when we next try for - * a validity check, we need not recheck any successfully verified - * sub-matches that we didn't move the endpoints of. nverified remembers - * how many sub-matches are currently known okay. - */ - - /* initialize to consider first sub-match */ - nverified = 0; - k = 1; - limit = begin; - - /* iterate until satisfaction or failure */ - while (k > 0) { - /* disallow zero-length match unless necessary to achieve min */ - if (limit == endpts[k - 1] && - limit != end && - (k >= min_matches || min_matches - k < end - limit)) - limit++; - - /* if this is the last allowed sub-match, it must reach to the end */ - if ((size_t)k >= max_matches) - limit = end; - - /* try to find an endpoint for the k'th sub-match */ - endpts[k] = shortest(v, d, endpts[k - 1], limit, end, - (chr **) NULL, (int *) NULL); - if (endpts[k] == NULL) { - /* no match possible, so see if we can lengthen previous one */ - k--; - goto backtrack; - } - MDEBUG(("%d: working endpoint %d: %ld\n", - t->id, k, LOFF(endpts[k]))); - - /* k'th sub-match can no longer be considered verified */ - if (nverified >= k) - nverified = k - 1; - - if (endpts[k] != end) { - /* haven't reached end yet, try another iteration if allowed */ - if ((size_t)k >= max_matches) { - /* must try to lengthen some previous match */ - k--; - goto backtrack; - } - - k++; - limit = endpts[k - 1]; - continue; - } - - /* - * We've identified a way to divide the string into k sub-matches - * that works so far as the child DFA can tell. If k is an allowed - * number of matches, start the slow part: recurse to verify each - * sub-match. We always have k <= max_matches, needn't check that. - */ - if (k < min_matches) - goto backtrack; - - MDEBUG(("%d: verifying %d..%d\n", t->id, nverified + 1, k)); - - for (i = nverified + 1; i <= k; i++) { - zaptreesubs(v, t->left); - er = cdissect(v, t->left, endpts[i - 1], endpts[i]); - if (er == REG_OKAY) { - nverified = i; - continue; - } - if (er == REG_NOMATCH) - break; - /* oops, something failed */ - FREE(endpts); - return er; - } - - if (i > k) { - /* satisfaction */ - MDEBUG(("%d successful\n", t->id)); - FREE(endpts); - return REG_OKAY; - } - - /* match failed to verify, so backtrack */ - - backtrack: - /* - * Must consider longer versions of the current sub-match. - */ - while (k > 0) { - if (endpts[k] < end) { - limit = endpts[k] + 1; - /* break out of backtrack loop, continue the outer one */ - break; - } - /* can't lengthen k'th sub-match any more, consider previous one */ - k--; - } - } - - /* all possibilities exhausted */ - MDEBUG(("%d failed\n", t->id)); - FREE(endpts); - return REG_NOMATCH; +#define UNTRIED 0 /* not yet tried at all */ +#define TRYING 1 /* top matched, trying submatches */ +#define TRIED 2 /* top didn't match or submatches exhausted */ + + if (t == NULL) { + return REG_NOMATCH; + } + assert(t->op == '|'); + if (v->mem[t->retry] == TRIED) { + return caltdissect(v, t->right, begin, end); + } + + MDEBUG(("calt n%d\n", t->retry)); + assert(t->left != NULL); + + if (v->mem[t->retry] == UNTRIED) { + d = newdfa(v, &t->left->cnfa, &v->g->cmap, DOMALLOC); + if (ISERR()) { + return v->err; + } + if (longest(v, d, begin, end, NULL) != end) { + freedfa(d); + v->mem[t->retry] = TRIED; + return caltdissect(v, t->right, begin, end); + } + freedfa(d); + MDEBUG(("calt matched\n")); + v->mem[t->retry] = TRYING; + } + + er = cdissect(v, t->left, begin, end); + if (er != REG_NOMATCH) { + return er; + } + + v->mem[t->retry] = TRIED; + return caltdissect(v, t->right, begin, end); } #include "rege_dfa.c" /* Index: generic/regfronts.c ================================================================== --- generic/regfronts.c +++ generic/regfronts.c @@ -37,11 +37,11 @@ - regcomp - compile regular expression */ int regcomp( regex_t *re, - const char *str, + CONST char *str, int flags) { size_t len; int f = flags; @@ -59,16 +59,16 @@ - regexec - execute regular expression */ int regexec( regex_t *re, - const char *str, + CONST char *str, size_t nmatch, regmatch_t pmatch[], int flags) { - const char *start; + CONST char *start; size_t len; int f = flags; if (f & REG_STARTEND) { start = str + pmatch[0].rm_so; Index: generic/regguts.h ================================================================== --- generic/regguts.h +++ generic/regguts.h @@ -36,10 +36,19 @@ #include "regcustom.h" /* * Things that regcustom.h might override. */ + +/* standard header files (NULL is a reasonable indicator for them) */ +#ifndef NULL +#include +#include +#include +#include +#include +#endif /* assertions */ #ifndef assert #ifndef REG_DEBUG #ifndef NDEBUG @@ -46,37 +55,72 @@ #define NDEBUG /* no assertions */ #endif #endif /* !REG_DEBUG */ #include #endif + +/* voids */ +#ifndef VOID +#define VOID void /* for function return values */ +#endif +#ifndef DISCARD +#define DISCARD void /* for throwing values away */ +#endif +#ifndef PVOID +#define PVOID void * /* generic pointer */ +#endif +#ifndef VS +#define VS(x) ((void*)(x)) /* cast something to generic ptr */ +#endif +#ifndef NOPARMS +#define NOPARMS void /* for empty parm lists */ +#endif + +/* const */ +#ifndef CONST +#define CONST const /* for old compilers, might be empty */ +#endif + +/* function-pointer declarator */ +#ifndef FUNCPTR +#if __STDC__ >= 1 +#define FUNCPTR(name, args) (*name)args +#else +#define FUNCPTR(name, args) (*name)() +#endif +#endif /* memory allocation */ #ifndef MALLOC #define MALLOC(n) malloc(n) #endif #ifndef REALLOC -#define REALLOC(p, n) realloc(p, n) +#define REALLOC(p, n) realloc(VS(p), n) #endif #ifndef FREE -#define FREE(p) free(p) +#define FREE(p) free(VS(p)) #endif /* want size of a char in bits, and max value in bounded quantifiers */ +#ifndef CHAR_BIT +#include +#endif #ifndef _POSIX2_RE_DUP_MAX #define _POSIX2_RE_DUP_MAX 255 /* normally from */ #endif /* * misc */ #define NOTREACHED 0 +#define xxx 1 #define DUPMAX _POSIX2_RE_DUP_MAX #define DUPINF (DUPMAX+1) -#define REMAGIC 0xFED7 /* magic number for main struct */ +#define REMAGIC 0xfed7 /* magic number for main struct */ /* * debugging facilities */ #ifdef REG_DEBUG @@ -157,18 +201,11 @@ #define PSEUDO 02 /* pseudocolor, no real chars */ #define UNUSEDCOLOR(cd) ((cd)->flags&FREECOL) union tree *block; /* block of solid color, if any */ }; -/* - * The color map itself - * - * Much of the data in the colormap struct is only used at compile time. - * However, the bulk of the space usage is in the "tree" structure, so it's - * not clear that there's much point in converting the rest to a more compact - * form when compilation is finished. - */ +/* the color map itself */ struct colormap { int magic; #define CMMAGIC 0x876 struct vars *v; /* for compile error reporting */ size_t ncds; /* number of colordescs */ @@ -220,15 +257,16 @@ */ struct state; struct arc { - int type; /* 0 if free, else an NFA arc type code */ + int type; +#define ARCFREE '\0' color co; struct state *from; /* where it's from (and contained within) */ struct state *to; /* where it's to */ - struct arc *outchain; /* link in *from's outs chain or free chain */ + struct arc *outchain; /* *from's outs chain or free chain */ struct arc *outchainRev; /* back-link in *from's outs chain */ #define freechain outchain /* we do not maintain "freechainRev" */ struct arc *inchain; /* *to's ins chain */ struct arc *inchainRev; /* back-link in *to's ins chain */ struct arc *colorchain; /* color's arc chain */ @@ -267,32 +305,24 @@ struct state *slast; /* tail of the chain */ struct state *free; /* free list */ struct colormap *cm; /* the color map */ color bos[2]; /* colors, if any, assigned to BOS and BOL */ color eos[2]; /* colors, if any, assigned to EOS and EOL */ + size_t size; /* Current NFA size; differs from nstates as + * it also counts the number of states created + * by children of this state. */ struct vars *v; /* simplifies compile error reporting */ struct nfa *parent; /* parent NFA, if any */ }; /* * definitions for compacted NFA - * - * The main space savings in a compacted NFA is from making the arcs as small - * as possible. We store only the transition color and next-state number for - * each arc. The list of out arcs for each state is an array beginning at - * cnfa.states[statenumber], and terminated by a dummy carc struct with - * co == COLORLESS. - * - * The non-dummy carc structs are of two types: plain arcs and LACON arcs. - * Plain arcs just store the transition color number as "co". LACON arcs - * store the lookahead constraint number plus cnfa.ncolors as "co". LACON - * arcs can be distinguished from plain by testing for co >= cnfa.ncolors. */ struct carc { color co; /* COLORLESS is list terminator */ - int to; /* next-state number */ + int to; /* state number */ }; struct cnfa { int nstates; /* number of states */ int ncolors; /* number of colors */ @@ -300,56 +330,31 @@ #define HASLACONS 01 /* uses lookahead constraints */ int pre; /* setup state number */ int post; /* teardown state number */ color bos[2]; /* colors, if any, assigned to BOS and BOL */ color eos[2]; /* colors, if any, assigned to EOS and EOL */ - char *stflags; /* vector of per-state flags bytes */ -#define CNFA_NOPROGRESS 01 /* flag bit for a no-progress state */ struct carc **states; /* vector of pointers to outarc lists */ - /* states[n] are pointers into a single malloc'd array of arcs */ struct carc *arcs; /* the area for the lists */ }; #define ZAPCNFA(cnfa) ((cnfa).nstates = 0) #define NULLCNFA(cnfa) ((cnfa).nstates == 0) /* - * This symbol limits the transient heap space used by the regex compiler, - * and thereby also the maximum complexity of NFAs that we'll deal with. - * Currently we only count NFA states and arcs against this; the other - * transient data is generally not large enough to notice compared to those. - * Note that we do not charge anything for the final output data structures - * (the compacted NFA and the colormap). + * Used to limit the maximum NFA size to something sane. [Bug 1810264] */ -#ifndef REG_MAX_COMPILE_SPACE -#define REG_MAX_COMPILE_SPACE \ - (100000 * sizeof(struct state) + 100000 * sizeof(struct arcbatch)) + +#ifndef REG_MAX_STATES +# define REG_MAX_STATES 100000 #endif /* * subexpression tree - * - * "op" is one of: - * '=' plain regex without interesting substructure (implemented as DFA) - * 'b' back-reference (has no substructure either) - * '(' capture node: captures the match of its single child - * '.' concatenation: matches a match for left, then a match for right - * '|' alternation: matches a match for left or a match for right - * '*' iteration: matches some number of matches of its single child - * - * Note: the right child of an alternation must be another alternation or - * NULL; hence, an N-way branch requires N alternation nodes, not N-1 as you - * might expect. This could stand to be changed. Actually I'd rather see - * a single alternation node with N children, but that will take revising - * the representation of struct subre. - * - * Note: when a backref is directly quantified, we stick the min/max counts - * into the backref rather than plastering an iteration node on top. This is - * for efficiency: there is no need to search for possible division points. */ struct subre { - char op; /* see type codes above */ + char op; /* '|', '.' (concat), 'b' (backref), '(', + * '=' */ char flags; #define LONGER 01 /* prefers longer match */ #define SHORTER 02 /* prefers shorter match */ #define MIXED 04 /* mixed preference below */ #define CAP 010 /* capturing parens below */ @@ -361,14 +366,14 @@ #define UP(f) (((f)&~NOPROP) | (LMIX(f) & SMIX(f) & MIXED)) #define MESSY(f) ((f)&(MIXED|CAP|BACKR)) #define PREF(f) ((f)&NOPROP) #define PREF2(f1, f2) ((PREF(f1) != 0) ? PREF(f1) : PREF(f2)) #define COMBINE(f1, f2) (UP((f1)|(f2)) | PREF2(f1, f2)) - short id; /* ID of subre (1..ntree-1) */ + short retry; /* index into retry memory */ int subno; /* subexpression number (for 'b' and '(') */ - short min; /* min repetitions for iteration or backref */ - short max; /* max repetitions for iteration or backref */ + short min; /* min repetitions, for backref only */ + short max; /* max repetitions, for backref only */ struct subre *left; /* left child, if any (also freelist chain) */ struct subre *right; /* right child, if any */ struct state *begin; /* outarcs from here... */ struct state *end; /* ...ending in inarcs here */ struct cnfa cnfa; /* compacted NFA, if any */ @@ -379,28 +384,28 @@ * table of function pointers for generic manipulation functions. A regex_t's * re_fns points to one of these. */ struct fns { - void (*free) (regex_t *); + VOID FUNCPTR(free, (regex_t *)); }; /* * the insides of a regex_t, hidden behind a void * */ struct guts { int magic; -#define GUTSMAGIC 0xFED9 +#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 */ + int ntree; struct colormap cmap; - int (*compare) (const chr *, const chr *, size_t); + int FUNCPTR(compare, (CONST chr *, CONST chr *, size_t)); struct subre *lacons; /* lookahead-constraint vector */ int nlacons; /* size of lacons */ }; /* @@ -409,11 +414,11 @@ */ #ifndef AllocVars #define AllocVars(vPtr) \ struct vars var; \ - struct vars *vPtr = &var + register struct vars *vPtr = &var #endif #ifndef FreeVars #define FreeVars(vPtr) ((void) 0) #endif Index: generic/tcl.decls ================================================================== --- generic/tcl.decls +++ generic/tcl.decls @@ -3,12 +3,12 @@ # This file contains the declarations for all supported public # functions that are exported by the Tcl library via the stubs table. # This file is used to generate the tclDecls.h, tclPlatDecls.h # and tclStubInit.c files. # -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. +# Copyright (c) 1998-1999 Scriptics Corporation. +# Copyright (c) 2001, 2002 Kevin B. Kenny. All rights reserved. # Copyright (c) 2007 Daniel A. Steffen # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -27,75 +27,75 @@ # the an index should never be reused for a different function in order # to preserve backwards compatibility. declare 0 { int Tcl_PkgProvideEx(Tcl_Interp *interp, const char *name, - const char *version, const void *clientData) + const char *version, ClientData clientData) } declare 1 { - const char *Tcl_PkgRequireEx(Tcl_Interp *interp, + CONST84_RETURN char *Tcl_PkgRequireEx(Tcl_Interp *interp, const char *name, const char *version, int exact, - void *clientDataPtr) + ClientData *clientDataPtr) } declare 2 { - TCL_NORETURN void Tcl_Panic(const char *format, ...) + void Tcl_Panic(const char *format, ...) } declare 3 { - void *Tcl_Alloc(size_t size) + char *Tcl_Alloc(unsigned int size) } declare 4 { - void Tcl_Free(void *ptr) + void Tcl_Free(char *ptr) } declare 5 { - void *Tcl_Realloc(void *ptr, size_t size) + char *Tcl_Realloc(char *ptr, unsigned int size) } declare 6 { - void *Tcl_DbCkalloc(size_t size, const char *file, int line) + char *Tcl_DbCkalloc(unsigned int size, const char *file, int line) } declare 7 { - void Tcl_DbCkfree(void *ptr, const char *file, int line) + void Tcl_DbCkfree(char *ptr, const char *file, int line) } declare 8 { - void *Tcl_DbCkrealloc(void *ptr, size_t size, + 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, - void *clientData) + ClientData clientData) } declare 10 unix { void Tcl_DeleteFileHandler(int fd) } declare 11 { - void Tcl_SetTimer(const Tcl_Time *timePtr) + void Tcl_SetTimer(Tcl_Time *timePtr) } declare 12 { void Tcl_Sleep(int ms) } declare 13 { - int Tcl_WaitForEvent(const Tcl_Time *timePtr) + int Tcl_WaitForEvent(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, size_t length) + 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) + Tcl_ObjType *typePtr) } declare 19 { void Tcl_DbDecrRefCount(Tcl_Obj *objPtr, const char *file, int line) } declare 20 { @@ -102,16 +102,15 @@ void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file, int line) } declare 21 { int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line) } -# Removed in 9.0 (changed to macro): -#declare 22 { -# Tcl_Obj *Tcl_DbNewBooleanObj(int boolValue, const char *file, int line) -#} +declare 22 { + Tcl_Obj *Tcl_DbNewBooleanObj(int boolValue, const char *file, int line) +} declare 23 { - Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes, size_t length, + 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) @@ -118,33 +117,32 @@ } declare 25 { Tcl_Obj *Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv, const char *file, int line) } -# Removed in 9.0 (changed to macro): -#declare 26 { -# Tcl_Obj *Tcl_DbNewLongObj(long longValue, const char *file, int line) -#} +declare 26 { + 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, size_t length, + 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) + int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, int *intPtr) } declare 32 { int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - int *boolPtr) + int *intPtr) } declare 33 { unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *lengthPtr) } declare 34 { @@ -152,15 +150,14 @@ } declare 35 { int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr) } -# Removed in 9.0, replaced by macro. -#declare 36 { -# int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, -# const char *const *tablePtr, const char *msg, int flags, int *indexPtr) -#} +declare 36 { + int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + CONST84 char **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) @@ -167,11 +164,11 @@ } declare 39 { int Tcl_GetLongFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr) } declare 40 { - const Tcl_ObjType *Tcl_GetObjType(const char *typeName) + Tcl_ObjType *Tcl_GetObjType(const char *typeName) } declare 41 { char *Tcl_GetStringFromObj(Tcl_Obj *objPtr, int *lengthPtr) } declare 42 { @@ -199,77 +196,69 @@ } declare 48 { int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]) } -# Removed in 9.0 (changed to macro): -#declare 49 { -# Tcl_Obj *Tcl_NewBooleanObj(int boolValue) -#} +declare 49 { + Tcl_Obj *Tcl_NewBooleanObj(int intValue) +} declare 50 { - Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, size_t length) + Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, int length) } declare 51 { Tcl_Obj *Tcl_NewDoubleObj(double doubleValue) } -# Removed in 9.0 (changed to macro): -#declare 52 { -# Tcl_Obj *Tcl_NewIntObj(int intValue) -#} +declare 52 { + Tcl_Obj *Tcl_NewIntObj(int intValue) +} declare 53 { Tcl_Obj *Tcl_NewListObj(int objc, Tcl_Obj *const objv[]) } -# Removed in 9.0 (changed to macro): -#declare 54 { -# Tcl_Obj *Tcl_NewLongObj(long longValue) -#} +declare 54 { + Tcl_Obj *Tcl_NewLongObj(long longValue) +} declare 55 { Tcl_Obj *Tcl_NewObj(void) } declare 56 { - Tcl_Obj *Tcl_NewStringObj(const char *bytes, size_t length) + Tcl_Obj *Tcl_NewStringObj(const char *bytes, int length) } -# Removed in 9.0 (changed to macro): -#declare 57 { -# void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue) -#} +declare 57 { + void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int intValue) +} declare 58 { - unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, size_t length) + unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int numBytes) } declare 59 { void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, const unsigned char *bytes, - size_t length) + int numBytes) } declare 60 { void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue) } -# Removed in 9.0 (changed to macro): -#declare 61 { -# void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue) -#} +declare 61 { + void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue) +} declare 62 { void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]) } -# Removed in 9.0 (changed to macro): -#declare 63 { -# void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue) -#} +declare 63 { + void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue) +} declare 64 { - void Tcl_SetObjLength(Tcl_Obj *objPtr, size_t length) + void Tcl_SetObjLength(Tcl_Obj *objPtr, int length) } declare 65 { - void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, size_t length) -} -# Removed in 9.0, replaced by macro. -#declare 66 { -# void Tcl_AddErrorInfo(Tcl_Interp *interp, const char *message) -#} -# Removed in 9.0, replaced by macro. -#declare 67 { -# void Tcl_AddObjErrorInfo(Tcl_Interp *interp, const char *message, -# int length) -#} + void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, int length) +} +declare 66 { + void Tcl_AddErrorInfo(Tcl_Interp *interp, const char *message) +} +declare 67 { + 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) @@ -277,11 +266,11 @@ declare 70 { void Tcl_AppendResult(Tcl_Interp *interp, ...) } declare 71 { Tcl_AsyncHandler Tcl_AsyncCreate(Tcl_AsyncProc *proc, - void *clientData) + ClientData clientData) } declare 72 { void Tcl_AsyncDelete(Tcl_AsyncHandler async) } declare 73 { @@ -291,133 +280,129 @@ void Tcl_AsyncMark(Tcl_AsyncHandler async) } declare 75 { int Tcl_AsyncReady(void) } -# Removed in 9.0 -#declare 76 { -# void Tcl_BackgroundError(Tcl_Interp *interp) -#} -# Removed in 9.0: -#declare 77 { -# char Tcl_Backslash(const char *src, int *readPtr) -#} +declare 76 { + void Tcl_BackgroundError(Tcl_Interp *interp) +} +declare 77 { + 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, - void *clientData) + ClientData clientData) } declare 80 { - void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, void *clientData) + void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, ClientData clientData) } -# Removed in 9.0: -#declare 81 { -# int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan) -#} +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) + char *Tcl_Concat(int argc, CONST84 char *const *argv) } declare 84 { - size_t Tcl_ConvertElement(const char *src, char *dst, int flags) + int Tcl_ConvertElement(const char *src, char *dst, int flags) } declare 85 { - size_t Tcl_ConvertCountedElement(const char *src, size_t length, char *dst, + int Tcl_ConvertCountedElement(const char *src, int length, char *dst, int flags) } declare 86 { int Tcl_CreateAlias(Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int argc, - const char *const *argv) + CONST84 char *const *argv) } declare 87 { int Tcl_CreateAliasObj(Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]) } declare 88 { - Tcl_Channel Tcl_CreateChannel(const Tcl_ChannelType *typePtr, - const char *chanName, void *instanceData, int mask) + Tcl_Channel Tcl_CreateChannel(Tcl_ChannelType *typePtr, + const char *chanName, ClientData instanceData, int mask) } declare 89 { void Tcl_CreateChannelHandler(Tcl_Channel chan, int mask, - Tcl_ChannelProc *proc, void *clientData) + Tcl_ChannelProc *proc, ClientData clientData) } declare 90 { void Tcl_CreateCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc, - void *clientData) + ClientData clientData) } declare 91 { Tcl_Command Tcl_CreateCommand(Tcl_Interp *interp, const char *cmdName, - Tcl_CmdProc *proc, void *clientData, + Tcl_CmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc) } declare 92 { void Tcl_CreateEventSource(Tcl_EventSetupProc *setupProc, - Tcl_EventCheckProc *checkProc, void *clientData) + Tcl_EventCheckProc *checkProc, ClientData clientData) } declare 93 { - void Tcl_CreateExitHandler(Tcl_ExitProc *proc, void *clientData) + void Tcl_CreateExitHandler(Tcl_ExitProc *proc, ClientData clientData) } declare 94 { Tcl_Interp *Tcl_CreateInterp(void) } -# Removed in 9.0: -#declare 95 { -# void Tcl_CreateMathFunc(Tcl_Interp *interp, const char *name, -# int numArgs, Tcl_ValueType *argTypes, -# Tcl_MathProc *proc, void *clientData) -#} +declare 95 { + 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, void *clientData, + Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc) } declare 97 { - Tcl_Interp *Tcl_CreateChild(Tcl_Interp *interp, const char *name, + Tcl_Interp *Tcl_CreateSlave(Tcl_Interp *interp, const char *name, int isSafe) } declare 98 { Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds, - Tcl_TimerProc *proc, void *clientData) + Tcl_TimerProc *proc, ClientData clientData) } declare 99 { Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level, - Tcl_CmdTraceProc *proc, void *clientData) + 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, - void *clientData) + ClientData clientData) } declare 102 { void Tcl_DeleteCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc, - void *clientData) + 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, void *clientData) + void Tcl_DeleteEvents(Tcl_EventDeleteProc *proc, ClientData clientData) } declare 106 { void Tcl_DeleteEventSource(Tcl_EventSetupProc *setupProc, - Tcl_EventCheckProc *checkProc, void *clientData) + Tcl_EventCheckProc *checkProc, ClientData clientData) } declare 107 { - void Tcl_DeleteExitHandler(Tcl_ExitProc *proc, void *clientData) + void Tcl_DeleteExitHandler(Tcl_ExitProc *proc, ClientData clientData) } declare 108 { void Tcl_DeleteHashEntry(Tcl_HashEntry *entryPtr) } declare 109 { @@ -435,20 +420,20 @@ declare 113 { void Tcl_DeleteTrace(Tcl_Interp *interp, Tcl_Trace trace) } declare 114 { void Tcl_DontCallWhenDeleted(Tcl_Interp *interp, - Tcl_InterpDeleteProc *proc, void *clientData) + Tcl_InterpDeleteProc *proc, ClientData clientData) } declare 115 { int Tcl_DoOneEvent(int flags) } declare 116 { - void Tcl_DoWhenIdle(Tcl_IdleProc *proc, void *clientData) + void Tcl_DoWhenIdle(Tcl_IdleProc *proc, ClientData clientData) } declare 117 { - char *Tcl_DStringAppend(Tcl_DString *dsPtr, const char *bytes, size_t length) + char *Tcl_DStringAppend(Tcl_DString *dsPtr, const char *bytes, int length) } declare 118 { char *Tcl_DStringAppendElement(Tcl_DString *dsPtr, const char *element) } declare 119 { @@ -465,40 +450,38 @@ } declare 123 { void Tcl_DStringResult(Tcl_Interp *interp, Tcl_DString *dsPtr) } declare 124 { - void Tcl_DStringSetLength(Tcl_DString *dsPtr, size_t length) + 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) + CONST84_RETURN char *Tcl_ErrnoId(void) } declare 128 { - const char *Tcl_ErrnoMsg(int err) + CONST84_RETURN char *Tcl_ErrnoMsg(int err) } -# Removed in 9.0, replaced by macro. -#declare 129 { -# int Tcl_Eval(Tcl_Interp *interp, const char *script) -#} +declare 129 { + int Tcl_Eval(Tcl_Interp *interp, const char *script) +} declare 130 { int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName) } -# Removed in 9.0, replaced by macro. -#declare 131 { -# int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) -#} +declare 131 { + int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) +} declare 132 { - void Tcl_EventuallyFree(void *clientData, Tcl_FreeProc *freeProc) + void Tcl_EventuallyFree(ClientData clientData, Tcl_FreeProc *freeProc) } declare 133 { - TCL_NORETURN void Tcl_Exit(int status) + void Tcl_Exit(int status) } declare 134 { int Tcl_ExposeCommand(Tcl_Interp *interp, const char *hiddenCmdToken, const char *cmdName) } @@ -528,37 +511,35 @@ int Tcl_ExprString(Tcl_Interp *interp, const char *expr) } declare 143 { void Tcl_Finalize(void) } -# Removed in 9.0 (stub entry only) -#declare 144 { -# void Tcl_FindExecutable(const char *argv0) -#} +declare 144 { + 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) } -# Removed in 9.0, TIP 559 -#declare 147 { -# void Tcl_FreeResult(Tcl_Interp *interp) -#} +declare 147 { + void Tcl_FreeResult(Tcl_Interp *interp) +} declare 148 { - int Tcl_GetAlias(Tcl_Interp *interp, const char *childCmd, - Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, - int *argcPtr, const char ***argvPtr) + int Tcl_GetAlias(Tcl_Interp *interp, const char *slaveCmd, + Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, + int *argcPtr, CONST84 char ***argvPtr) } declare 149 { - int Tcl_GetAliasObj(Tcl_Interp *interp, const char *childCmd, - Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, + int Tcl_GetAliasObj(Tcl_Interp *interp, const char *slaveCmd, + Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv) } declare 150 { - void *Tcl_GetAssocData(Tcl_Interp *interp, const char *name, + 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) @@ -566,103 +547,99 @@ declare 152 { int Tcl_GetChannelBufferSize(Tcl_Channel chan) } declare 153 { int Tcl_GetChannelHandle(Tcl_Channel chan, int direction, - void **handlePtr) + ClientData *handlePtr) } declare 154 { - void *Tcl_GetChannelInstanceData(Tcl_Channel chan) + ClientData Tcl_GetChannelInstanceData(Tcl_Channel chan) } declare 155 { int Tcl_GetChannelMode(Tcl_Channel chan) } declare 156 { - const char *Tcl_GetChannelName(Tcl_Channel chan) + CONST84_RETURN 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 { - const Tcl_ChannelType *Tcl_GetChannelType(Tcl_Channel chan) + 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, + CONST84_RETURN char *Tcl_GetCommandName(Tcl_Interp *interp, Tcl_Command command) } declare 161 { int Tcl_GetErrno(void) } declare 162 { - const char *Tcl_GetHostName(void) + CONST84_RETURN char *Tcl_GetHostName(void) } declare 163 { int Tcl_GetInterpPath(Tcl_Interp *interp, Tcl_Interp *childInterp) } declare 164 { - Tcl_Interp *Tcl_GetParent(Tcl_Interp *interp) + Tcl_Interp *Tcl_GetMaster(Tcl_Interp *interp) } declare 165 { const char *Tcl_GetNameOfExecutable(void) } declare 166 { Tcl_Obj *Tcl_GetObjResult(Tcl_Interp *interp) } # Tcl_GetOpenFile is only available on unix, but it is a part of the old -# generic interface, so we include it here for compatibility reasons. +# generic interface, so we inlcude it here for compatibility reasons. declare 167 unix { int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, int forWriting, - int checkUsage, void **filePtr) + 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 { - size_t Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr) + int Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr) } declare 170 { - size_t Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr) + int Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr) } declare 171 { int Tcl_GetServiceMode(void) } declare 172 { - Tcl_Interp *Tcl_GetChild(Tcl_Interp *interp, const char *name) + Tcl_Interp *Tcl_GetSlave(Tcl_Interp *interp, const char *slaveName) } declare 173 { Tcl_Channel Tcl_GetStdChannel(int type) } -# Removed in 9.0, replaced by macro. -#declare 174 { -# const char *Tcl_GetStringResult(Tcl_Interp *interp) -#} -# Removed in 9.0, replaced by macro. -#declare 175 { -# const char *Tcl_GetVar(Tcl_Interp *interp, const char *varName, -# int flags) -#} +declare 174 { + CONST84_RETURN char *Tcl_GetStringResult(Tcl_Interp *interp) +} +declare 175 { + CONST84_RETURN char *Tcl_GetVar(Tcl_Interp *interp, const char *varName, + int flags) +} declare 176 { - const char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1, + CONST84_RETURN char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags) } -# Removed in 9.0, replaced by macro. -#declare 177 { -# int Tcl_GlobalEval(Tcl_Interp *interp, const char *command) -#} -# Removed in 9.0, replaced by macro. -#declare 178 { -# int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) -#} +declare 177 { + int Tcl_GlobalEval(Tcl_Interp *interp, const char *command) +} +declare 178 { + 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 { @@ -683,34 +660,34 @@ declare 185 { int Tcl_IsSafe(Tcl_Interp *interp) } # Obsolete, use Tcl_FSJoinPath declare 186 { - char *Tcl_JoinPath(int argc, const char *const *argv, + char *Tcl_JoinPath(int argc, CONST84 char *const *argv, Tcl_DString *resultPtr) } declare 187 { - int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, void *addr, + int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, char *addr, int type) } # This slot is reserved for use by the plus patch: # declare 188 { # Tcl_MainLoop # } declare 189 { - Tcl_Channel Tcl_MakeFileChannel(void *handle, int mode) + Tcl_Channel Tcl_MakeFileChannel(ClientData handle, int mode) } declare 190 { int Tcl_MakeSafe(Tcl_Interp *interp) } declare 191 { - Tcl_Channel Tcl_MakeTcpClientChannel(void *tcpSocket) + Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket) } declare 192 { - char *Tcl_Merge(int argc, const char *const *argv) + char *Tcl_Merge(int argc, CONST84 char *const *argv) } declare 193 { Tcl_HashEntry *Tcl_NextHashEntry(Tcl_HashSearch *searchPtr) } declare 194 { @@ -724,43 +701,43 @@ Tcl_Obj *Tcl_ObjSetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags) } declare 197 { Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc, - const char **argv, int flags) + CONST84 char **argv, int flags) } # This is obsolete, use Tcl_FSOpenFileChannel declare 198 { Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp, const char *fileName, const char *modeString, int permissions) } declare 199 { Tcl_Channel Tcl_OpenTcpClient(Tcl_Interp *interp, int port, - const char *address, const char *myaddr, int myport, int async) + const char *address, const char *myaddr, int myport, int flags) } declare 200 { Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port, const char *host, Tcl_TcpAcceptProc *acceptProc, - void *callbackData) + ClientData callbackData) } declare 201 { - void Tcl_Preserve(void *data) + 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) + CONST84_RETURN char *Tcl_PosixError(Tcl_Interp *interp) } declare 205 { void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position) } declare 206 { - size_t Tcl_Read(Tcl_Channel chan, char *bufPtr, size_t toRead) + int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead) } declare 207 { void Tcl_ReapDetachedProcs(void) } declare 208 { @@ -771,11 +748,11 @@ } declare 210 { void Tcl_RegisterChannel(Tcl_Interp *interp, Tcl_Channel chan) } declare 211 { - void Tcl_RegisterObjType(const Tcl_ObjType *typePtr) + void Tcl_RegisterObjType(Tcl_ObjType *typePtr) } declare 212 { Tcl_RegExp Tcl_RegExpCompile(Tcl_Interp *interp, const char *pattern) } declare 213 { @@ -785,38 +762,38 @@ declare 214 { int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text, const char *pattern) } declare 215 { - void Tcl_RegExpRange(Tcl_RegExp regexp, size_t index, - const char **startPtr, const char **endPtr) + void Tcl_RegExpRange(Tcl_RegExp regexp, int index, + CONST84 char **startPtr, CONST84 char **endPtr) } declare 216 { - void Tcl_Release(void *clientData) + void Tcl_Release(ClientData clientData) } declare 217 { void Tcl_ResetResult(Tcl_Interp *interp) } declare 218 { - size_t Tcl_ScanElement(const char *src, int *flagPtr) + int Tcl_ScanElement(const char *src, int *flagPtr) } declare 219 { - size_t Tcl_ScanCountedElement(const char *src, size_t length, int *flagPtr) + int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr) } -# Removed in 9.0: -#declare 220 { -# int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode) -#} +# Obsolete +declare 220 { + 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, void *clientData) + Tcl_InterpDeleteProc *proc, ClientData clientData) } declare 224 { void Tcl_SetChannelBufferSize(Tcl_Channel chan, int sz) } declare 225 { @@ -832,24 +809,22 @@ } declare 228 { void Tcl_SetErrorCode(Tcl_Interp *interp, ...) } declare 229 { - void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr) + void Tcl_SetMaxBlockTime(Tcl_Time *timePtr) } -# Removed in 9.0 (stub entry only) -#declare 230 { -# void Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc) -#} +declare 230 { + void Tcl_SetPanicProc(Tcl_PanicProc *panicProc) +} declare 231 { int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth) } -# Removed in 9.0, replaced by macro. -#declare 232 { -# void Tcl_SetResult(Tcl_Interp *interp, char *result, -# Tcl_FreeProc *freeProc) -#} +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) @@ -858,116 +833,108 @@ void Tcl_SetObjResult(Tcl_Interp *interp, Tcl_Obj *resultObjPtr) } declare 236 { void Tcl_SetStdChannel(Tcl_Channel channel, int type) } -# Removed in 9.0, replaced by macro. -#declare 237 { -# const char *Tcl_SetVar(Tcl_Interp *interp, const char *varName, -# const char *newValue, int flags) -#} +declare 237 { + CONST84_RETURN 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, + CONST84_RETURN 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) + CONST84_RETURN char *Tcl_SignalId(int sig) } declare 240 { - const char *Tcl_SignalMsg(int sig) + CONST84_RETURN char *Tcl_SignalMsg(int sig) } declare 241 { void Tcl_SourceRCFile(Tcl_Interp *interp) } declare 242 { int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr, - const char ***argvPtr) + CONST84 char ***argvPtr) } # Obsolete, use Tcl_FSSplitPath declare 243 { - void Tcl_SplitPath(const char *path, int *argcPtr, const char ***argvPtr) -} -# Removed in 9.0 (stub entry only) -#declare 244 { -# void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName, -# Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) -#} -# Removed in 9.0 (stub entry only) -#declare 245 { -# int Tcl_StringMatch(const char *str, const char *pattern) -#} -# Removed in 9.0: -#declare 246 { -# int Tcl_TellOld(Tcl_Channel chan) -#} -# Removed in 9.0, replaced by macro. -#declare 247 { -# int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags, -# Tcl_VarTraceProc *proc, ClientData clientData) -#} + void Tcl_SplitPath(const char *path, int *argcPtr, CONST84 char ***argvPtr) +} +declare 244 { + void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName, + Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) +} +declare 245 { + int Tcl_StringMatch(const char *str, const char *pattern) +} +# Obsolete +declare 246 { + int Tcl_TellOld(Tcl_Channel chan) +} +declare 247 { + 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, void *clientData) + int flags, Tcl_VarTraceProc *proc, ClientData clientData) } declare 249 { char *Tcl_TranslateFileName(Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr) } declare 250 { - size_t Tcl_Ungets(Tcl_Channel chan, const char *str, size_t len, int atHead) + 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) } -# Removed in 9.0, replaced by macro. -#declare 253 { -# int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, int flags) -#} +declare 253 { + 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) } -# Removed in 9.0, replaced by macro. -#declare 255 { -# void Tcl_UntraceVar(Tcl_Interp *interp, const char *varName, int flags, -# Tcl_VarTraceProc *proc, ClientData clientData) -#} +declare 255 { + 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, - void *clientData) + ClientData clientData) } declare 257 { void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName) } -# Removed in 9.0, replaced by macro. -#declare 258 { -# int Tcl_UpVar(Tcl_Interp *interp, const char *frameName, -# const char *varName, const char *localName, int flags) -#} +declare 258 { + 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, ...) } -# Removed in 9.0, replaced by macro. -#declare 261 { -# ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName, -# int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData) -#} +declare 261 { + ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName, + int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData) +} declare 262 { - void *Tcl_VarTraceInfo2(Tcl_Interp *interp, const char *part1, + ClientData Tcl_VarTraceInfo2(Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, - void *prevClientData) + ClientData prevClientData) } declare 263 { - size_t Tcl_Write(Tcl_Channel chan, const char *s, size_t slen) + 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) } @@ -975,61 +942,53 @@ int Tcl_DumpActiveMemory(const char *fileName) } declare 266 { void Tcl_ValidateAllMemory(const char *file, int line) } -# Removed in 9.0: -#declare 267 { -# void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList) -#} -# Removed in 9.0: -#declare 268 { -# void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList) -#} +declare 267 { + void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList) +} +declare 268 { + 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) -} -# Removed in 9.0, replaced by macro. -#declare 271 { -# const char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name, -# const char *version, int exact) -#} + CONST84_RETURN char *Tcl_ParseVar(Tcl_Interp *interp, const char *start, + CONST84 char **termPtr) +} +declare 271 { + CONST84_RETURN char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name, + const char *version, int exact) +} declare 272 { - const char *Tcl_PkgPresentEx(Tcl_Interp *interp, + CONST84_RETURN char *Tcl_PkgPresentEx(Tcl_Interp *interp, const char *name, const char *version, int exact, - void *clientDataPtr) + ClientData *clientDataPtr) } -# Removed in 9.0, replaced by macro. -#declare 273 { -# int Tcl_PkgProvide(Tcl_Interp *interp, const char *name, -# const char *version) -#} +declare 273 { + int Tcl_PkgProvide(Tcl_Interp *interp, const char *name, + const char *version) +} # TIP #268: The internally used new Require function is in slot 573. -# Removed in 9.0, replaced by macro. -#declare 274 { -# const char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name, -# const char *version, int exact) -#} -# Removed in 9.0: -#declare 275 { -# void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList) -#} -# Removed in 9.0: -#declare 276 { -# int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList) -#} +declare 274 { + CONST84_RETURN char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name, + const char *version, int exact) +} +declare 275 { + void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList) +} +declare 276 { + int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList) +} declare 277 { Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options) } -# Removed in 9.0: -#declare 278 { -# TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList) -#} +declare 278 { + 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) @@ -1049,11 +1008,11 @@ # (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, void *instanceData, + Tcl_ChannelType *typePtr, ClientData instanceData, int mask, Tcl_Channel prevChan) } declare 282 { int Tcl_UnstackChannel(Tcl_Interp *interp, Tcl_Channel chan) } @@ -1077,21 +1036,20 @@ } declare 287 { Tcl_Encoding Tcl_CreateEncoding(const Tcl_EncodingType *typePtr) } declare 288 { - void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc, void *clientData) + void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc, ClientData clientData) } declare 289 { - void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, void *clientData) + void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, ClientData clientData) } -# Removed in 9.0, replaced by macro. -#declare 290 { -# void Tcl_DiscardResult(Tcl_SavedResult *statePtr) -#} +declare 290 { + void Tcl_DiscardResult(Tcl_SavedResult *statePtr) +} declare 291 { - int Tcl_EvalEx(Tcl_Interp *interp, const char *script, size_t numBytes, + 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) @@ -1098,27 +1056,27 @@ } declare 293 { int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags) } declare 294 { - TCL_NORETURN void Tcl_ExitThread(int status) + void Tcl_ExitThread(int status) } declare 295 { int Tcl_ExternalToUtf(Tcl_Interp *interp, Tcl_Encoding encoding, - const char *src, size_t srcLen, int flags, - Tcl_EncodingState *statePtr, char *dst, size_t dstLen, + 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, size_t srcLen, Tcl_DString *dsPtr) + const char *src, int srcLen, Tcl_DString *dsPtr) } declare 297 { void Tcl_FinalizeThread(void) } declare 298 { - void Tcl_FinalizeNotifier(void *clientData) + void Tcl_FinalizeNotifier(ClientData clientData) } declare 299 { void Tcl_FreeEncoding(Tcl_Encoding encoding) } declare 300 { @@ -1126,29 +1084,29 @@ } declare 301 { Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name) } declare 302 { - const char *Tcl_GetEncodingName(Tcl_Encoding encoding) + CONST84_RETURN 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, size_t offset, const char *msg, int flags, + const void *tablePtr, int offset, const char *msg, int flags, int *indexPtr) } declare 305 { - void *Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, size_t size) + 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 { - void *Tcl_InitNotifier(void) + ClientData Tcl_InitNotifier(void) } declare 308 { void Tcl_MutexLock(Tcl_Mutex *mutexPtr) } declare 309 { @@ -1157,27 +1115,25 @@ declare 310 { void Tcl_ConditionNotify(Tcl_Condition *condPtr) } declare 311 { void Tcl_ConditionWait(Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, - const Tcl_Time *timePtr) + Tcl_Time *timePtr) } declare 312 { - size_t Tcl_NumUtfChars(const char *src, size_t length) + int Tcl_NumUtfChars(const char *src, int length) } declare 313 { - size_t Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, - size_t charsToRead, int appendFlag) -} -# Removed in 9.0, replaced by macro. -#declare 314 { -# void Tcl_RestoreResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr) -#} -# Removed in 9.0, replaced by macro. -#declare 315 { -# void Tcl_SaveResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr) -#} + 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, @@ -1189,86 +1145,84 @@ declare 319 { void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event *evPtr, Tcl_QueuePosition position) } declare 320 { - int Tcl_UniCharAtIndex(const char *src, size_t index) + Tcl_UniChar Tcl_UniCharAtIndex(const char *src, int index) } declare 321 { - int Tcl_UniCharToLower(int ch) + Tcl_UniChar Tcl_UniCharToLower(int ch) } declare 322 { - int Tcl_UniCharToTitle(int ch) + Tcl_UniChar Tcl_UniCharToTitle(int ch) } declare 323 { - int Tcl_UniCharToUpper(int ch) + Tcl_UniChar Tcl_UniCharToUpper(int ch) } declare 324 { int Tcl_UniCharToUtf(int ch, char *buf) } declare 325 { - const char *Tcl_UtfAtIndex(const char *src, size_t index) + CONST84_RETURN char *Tcl_UtfAtIndex(const char *src, int index) } declare 326 { - int Tcl_UtfCharComplete(const char *src, size_t length) + int Tcl_UtfCharComplete(const char *src, int length) } declare 327 { - size_t Tcl_UtfBackslash(const char *src, int *readPtr, char *dst) + int Tcl_UtfBackslash(const char *src, int *readPtr, char *dst) } declare 328 { - const char *Tcl_UtfFindFirst(const char *src, int ch) + CONST84_RETURN char *Tcl_UtfFindFirst(const char *src, int ch) } declare 329 { - const char *Tcl_UtfFindLast(const char *src, int ch) + CONST84_RETURN char *Tcl_UtfFindLast(const char *src, int ch) } declare 330 { - const char *Tcl_UtfNext(const char *src) + CONST84_RETURN char *Tcl_UtfNext(const char *src) } declare 331 { - const char *Tcl_UtfPrev(const char *src, const char *start) + CONST84_RETURN char *Tcl_UtfPrev(const char *src, const char *start) } declare 332 { int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding, - const char *src, size_t srcLen, int flags, - Tcl_EncodingState *statePtr, char *dst, size_t dstLen, + 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, size_t srcLen, Tcl_DString *dsPtr) + 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) + int Tcl_UtfToUniChar(const char *src, Tcl_UniChar *chPtr) } declare 337 { int Tcl_UtfToUpper(char *src) } declare 338 { - size_t Tcl_WriteChars(Tcl_Channel chan, const char *src, size_t srcLen) + int Tcl_WriteChars(Tcl_Channel chan, const char *src, int srcLen) } declare 339 { - size_t Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr) + int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr) } declare 340 { char *Tcl_GetString(Tcl_Obj *objPtr) } -# Removed in 9.0: -#declare 341 { -# const char *Tcl_GetDefaultEncodingDir(void) -#} -# Removed in 9.0: -#declare 342 { -# void Tcl_SetDefaultEncodingDir(const char *path) -#} +declare 341 { + CONST84_RETURN char *Tcl_GetDefaultEncodingDir(void) +} +declare 342 { + void Tcl_SetDefaultEncodingDir(const char *path) +} declare 343 { - void Tcl_AlertNotifier(void *clientData) + void Tcl_AlertNotifier(ClientData clientData) } declare 344 { void Tcl_ServiceModeHook(int mode) } declare 345 { @@ -1290,64 +1244,61 @@ int Tcl_UniCharIsUpper(int ch) } declare 351 { int Tcl_UniCharIsWordChar(int ch) } -# Removed in 9.0: -#declare 352 { -# size_t Tcl_UniCharLen(const Tcl_UniChar *uniStr) -#} -# Removed in 9.0: -#declare 353 { -# int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, -# size_t numChars) -#} +declare 352 { + int Tcl_UniCharLen(const Tcl_UniChar *uniStr) +} +declare 353 { + int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, + unsigned long numChars) +} declare 354 { - char *Tcl_Char16ToUtfDString(const unsigned short *uniStr, - size_t uniLength, Tcl_DString *dsPtr) + char *Tcl_UniCharToUtfDString(const Tcl_UniChar *uniStr, + int uniLength, Tcl_DString *dsPtr) } declare 355 { - unsigned short *Tcl_UtfToChar16DString(const char *src, - size_t length, Tcl_DString *dsPtr) + Tcl_UniChar *Tcl_UtfToUniCharDString(const char *src, + int length, Tcl_DString *dsPtr) } declare 356 { Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags) } -# Removed in 9.0: -#declare 357 { -# Tcl_Obj *Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, -# int count) -#} +declare 357 { + 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, size_t length) + const char *command, int length) } declare 360 { int Tcl_ParseBraces(Tcl_Interp *interp, const char *start, - size_t numBytes, Tcl_Parse *parsePtr, int append, - const char **termPtr) + int numBytes, Tcl_Parse *parsePtr, int append, + CONST84 char **termPtr) } declare 361 { int Tcl_ParseCommand(Tcl_Interp *interp, const char *start, - size_t numBytes, int nested, Tcl_Parse *parsePtr) + int numBytes, int nested, Tcl_Parse *parsePtr) } declare 362 { - int Tcl_ParseExpr(Tcl_Interp *interp, const char *start, size_t numBytes, - Tcl_Parse *parsePtr) + 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, - size_t numBytes, Tcl_Parse *parsePtr, int append, - const char **termPtr) + int numBytes, Tcl_Parse *parsePtr, int append, + CONST84 char **termPtr) } declare 364 { int Tcl_ParseVarName(Tcl_Interp *interp, const char *start, - size_t numBytes, Tcl_Parse *parsePtr, int append) + 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) @@ -1360,14 +1311,14 @@ } declare 368 { int Tcl_Stat(const char *path, struct stat *bufPtr) } declare 369 { - int Tcl_UtfNcmp(const char *s1, const char *s2, size_t n) + int Tcl_UtfNcmp(const char *s1, const char *s2, unsigned long n) } declare 370 { - int Tcl_UtfNcasecmp(const char *s1, const char *s2, size_t n) + 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 { @@ -1382,40 +1333,38 @@ declare 375 { int Tcl_UniCharIsPunct(int ch) } declare 376 { int Tcl_RegExpExecObj(Tcl_Interp *interp, Tcl_RegExp regexp, - Tcl_Obj *textObj, size_t offset, size_t nmatches, int flags) + 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, size_t numChars) + Tcl_Obj *Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, int numChars) } declare 379 { void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, - size_t numChars) + int numChars) } declare 380 { - size_t Tcl_GetCharLength(Tcl_Obj *objPtr) + int Tcl_GetCharLength(Tcl_Obj *objPtr) } declare 381 { - int Tcl_GetUniChar(Tcl_Obj *objPtr, size_t index) + Tcl_UniChar Tcl_GetUniChar(Tcl_Obj *objPtr, int index) } -# Removed in 9.0, replaced by macro. -#declare 382 { -# Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr) -#} +declare 382 { + Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr) +} declare 383 { - Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, size_t first, size_t last) + Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, int first, int last) } -# Removed in 9.0 -#declare 384 { -# void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, -# size_t length) -#} +declare 384 { + 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 { @@ -1429,53 +1378,52 @@ } declare 389 { int Tcl_GetChannelNamesEx(Tcl_Interp *interp, const char *pattern) } declare 390 { - int Tcl_ProcObjCmd(void *clientData, Tcl_Interp *interp, + 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, - void *clientData, size_t stackSize, int flags) + int Tcl_CreateThread(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc proc, + ClientData clientData, int stackSize, int flags) } # Introduced in 8.3.2 declare 394 { - size_t Tcl_ReadRaw(Tcl_Channel chan, char *dst, size_t bytesToRead) + int Tcl_ReadRaw(Tcl_Channel chan, char *dst, int bytesToRead) } declare 395 { - size_t Tcl_WriteRaw(Tcl_Channel chan, const char *src, size_t srcLen) + 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) + CONST84_RETURN 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) } -# Removed in 9.0 -#declare 401 { -# Tcl_DriverCloseProc *Tcl_ChannelCloseProc( -# const Tcl_ChannelType *chanTypePtr) -#} +declare 401 { + Tcl_DriverCloseProc *Tcl_ChannelCloseProc( + const Tcl_ChannelType *chanTypePtr) +} declare 402 { Tcl_DriverClose2Proc *Tcl_ChannelClose2Proc( const Tcl_ChannelType *chanTypePtr) } declare 403 { @@ -1484,15 +1432,14 @@ } declare 404 { Tcl_DriverOutputProc *Tcl_ChannelOutputProc( const Tcl_ChannelType *chanTypePtr) } -# Removed in 9.0 -#declare 405 { -# Tcl_DriverSeekProc *Tcl_ChannelSeekProc( -# const Tcl_ChannelType *chanTypePtr) -#} +declare 405 { + Tcl_DriverSeekProc *Tcl_ChannelSeekProc( + const Tcl_ChannelType *chanTypePtr) +} declare 406 { Tcl_DriverSetOptionProc *Tcl_ChannelSetOptionProc( const Tcl_ChannelType *chanTypePtr) } declare 407 { @@ -1536,64 +1483,60 @@ void Tcl_ClearChannelHandlers(Tcl_Channel channel) } declare 418 { int Tcl_IsChannelExisting(const char *channelName) } -# Removed in 9.0: -#declare 419 { -# int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, -# size_t numChars) -#} -# Removed in 9.0: -#declare 420 { -# int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr, -# const Tcl_UniChar *uniPattern, int nocase) -#} -# Removed in 9.0, as it is actually a macro: -#declare 421 { -# Tcl_HashEntry *Tcl_FindHashEntry(Tcl_HashTable *tablePtr, const void *key) -#} -# Removed in 9.0, as it is actually a macro: -#declare 422 { -# Tcl_HashEntry *Tcl_CreateHashEntry(Tcl_HashTable *tablePtr, -# const void *key, int *newPtr) -#} +declare 419 { + int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, + unsigned long numChars) +} +declare 420 { + int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr, + const Tcl_UniChar *uniPattern, int nocase) +} +declare 421 { + Tcl_HashEntry *Tcl_FindHashEntry(Tcl_HashTable *tablePtr, const char *key) +} +declare 422 { + Tcl_HashEntry *Tcl_CreateHashEntry(Tcl_HashTable *tablePtr, + const char *key, int *newPtr) +} declare 423 { void Tcl_InitCustomHashTable(Tcl_HashTable *tablePtr, int keyType, - const Tcl_HashKeyType *typePtr) + Tcl_HashKeyType *typePtr) } declare 424 { void Tcl_InitObjHashTable(Tcl_HashTable *tablePtr) } declare 425 { - void *Tcl_CommandTraceInfo(Tcl_Interp *interp, const char *varName, + ClientData Tcl_CommandTraceInfo(Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *procPtr, - void *prevClientData) + ClientData prevClientData) } declare 426 { int Tcl_TraceCommand(Tcl_Interp *interp, const char *varName, int flags, - Tcl_CommandTraceProc *proc, void *clientData) + Tcl_CommandTraceProc *proc, ClientData clientData) } declare 427 { void Tcl_UntraceCommand(Tcl_Interp *interp, const char *varName, - int flags, Tcl_CommandTraceProc *proc, void *clientData) + int flags, Tcl_CommandTraceProc *proc, ClientData clientData) } declare 428 { - void *Tcl_AttemptAlloc(size_t size) + char *Tcl_AttemptAlloc(unsigned int size) } declare 429 { - void *Tcl_AttemptDbCkalloc(size_t size, const char *file, int line) + char *Tcl_AttemptDbCkalloc(unsigned int size, const char *file, int line) } declare 430 { - void *Tcl_AttemptRealloc(void *ptr, size_t size) + char *Tcl_AttemptRealloc(char *ptr, unsigned int size) } declare 431 { - void *Tcl_AttemptDbCkrealloc(void *ptr, size_t size, + char *Tcl_AttemptDbCkrealloc(char *ptr, unsigned int size, const char *file, int line) } declare 432 { - int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, size_t length) + int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, int length) } # TIP#10 (thread-aware channels) akupries declare 433 { Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel) @@ -1603,20 +1546,18 @@ declare 434 { Tcl_UniChar *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr) } # TIP#15 (math function introspection) dkf -# Removed in 9.0: -#declare 435 { -# int Tcl_GetMathFuncInfo(Tcl_Interp *interp, const char *name, -# int *numArgsPtr, Tcl_ValueType **argTypesPtr, -# Tcl_MathProc **procPtr, void **clientDataPtr) -#} -# Removed in 9.0: -#declare 436 { -# Tcl_Obj *Tcl_ListMathFuncs(Tcl_Interp *interp, const char *pattern) -#} +declare 435 { + int Tcl_GetMathFuncInfo(Tcl_Interp *interp, const char *name, + int *numArgsPtr, Tcl_ValueType **argTypesPtr, + Tcl_MathProc **procPtr, ClientData *clientDataPtr) +} +declare 436 { + 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) } @@ -1674,11 +1615,11 @@ declare 452 { int Tcl_FSFileAttrsSet(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr) } declare 453 { - const char *const *Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr, + const char **Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef) } declare 454 { int Tcl_FSStat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf) } @@ -1713,25 +1654,25 @@ declare 464 { Tcl_Obj *Tcl_FSJoinToPath(Tcl_Obj *pathPtr, int objc, Tcl_Obj *const objv[]) } declare 465 { - void *Tcl_FSGetInternalRep(Tcl_Obj *pathPtr, - const Tcl_Filesystem *fsPtr) + ClientData Tcl_FSGetInternalRep(Tcl_Obj *pathPtr, + 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, - void *clientData) + Tcl_Obj *Tcl_FSNewNativePath(Tcl_Filesystem *fromFilesystem, + ClientData clientData) } declare 469 { - const void *Tcl_FSGetNativePath(Tcl_Obj *pathPtr) + const char *Tcl_FSGetNativePath(Tcl_Obj *pathPtr) } declare 470 { Tcl_Obj *Tcl_FSFileSystemInfo(Tcl_Obj *pathPtr) } declare 471 { @@ -1739,24 +1680,24 @@ } declare 472 { Tcl_Obj *Tcl_FSListVolumes(void) } declare 473 { - int Tcl_FSRegister(void *clientData, const Tcl_Filesystem *fsPtr) + int Tcl_FSRegister(ClientData clientData, Tcl_Filesystem *fsPtr) } declare 474 { - int Tcl_FSUnregister(const Tcl_Filesystem *fsPtr) + int Tcl_FSUnregister(Tcl_Filesystem *fsPtr) } declare 475 { - void *Tcl_FSData(const Tcl_Filesystem *fsPtr) + ClientData Tcl_FSData(Tcl_Filesystem *fsPtr) } declare 476 { const char *Tcl_FSGetTranslatedStringPath(Tcl_Interp *interp, Tcl_Obj *pathPtr) } declare 477 { - const Tcl_Filesystem *Tcl_FSGetFileSystemForPath(Tcl_Obj *pathPtr) + Tcl_Filesystem *Tcl_FSGetFileSystemForPath(Tcl_Obj *pathPtr) } declare 478 { Tcl_PathType Tcl_FSGetPathType(Tcl_Obj *pathPtr) } @@ -1763,17 +1704,17 @@ # TIP#49 (detection of output buffering) akupries declare 479 { int Tcl_OutputBuffered(Tcl_Channel chan) } declare 480 { - void Tcl_FSMountsChanged(const Tcl_Filesystem *fsPtr) + void Tcl_FSMountsChanged(Tcl_Filesystem *fsPtr) } # TIP#56 (evaluate a parsed script) msofer declare 481 { int Tcl_EvalTokensStandard(Tcl_Interp *interp, Tcl_Token *tokenPtr, - size_t count) + int count) } # TIP#73 (access to current time) kbk declare 482 { void Tcl_GetTime(Tcl_Time *timeBuf) @@ -1780,11 +1721,11 @@ } # TIP#32 (object-enabled traces) kbk declare 483 { Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, int level, int flags, - Tcl_CmdObjTraceProc *objProc, void *clientData, + Tcl_CmdObjTraceProc *objProc, ClientData clientData, Tcl_CmdObjTraceDeleteProc *delProc) } declare 484 { int Tcl_GetCommandInfoFromToken(Tcl_Command token, Tcl_CmdInfo *infoPtr) } @@ -1871,18 +1812,18 @@ } # TIP#59 (configuration reporting) akupries declare 505 { void Tcl_RegisterConfig(Tcl_Interp *interp, const char *pkgName, - const Tcl_Config *configuration, const char *valEncoding) + 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, - void *clientData, Tcl_NamespaceDeleteProc *deleteProc) + ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc) } declare 507 { void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr) } declare 508 { @@ -1927,24 +1868,24 @@ declare 518 { int Tcl_FSEvalFileEx(Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName) } -# Removed in 9.0 (stub entry only) -#declare 519 {nostub {Don't use this function in a stub-enabled extension}} { -# Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc) -#} +# TIP#121 (exit handler) dkf for Joe Mistachkin +declare 519 { + Tcl_ExitProc *Tcl_SetExitProc(Tcl_ExitProc *proc) +} # TIP#143 (resource limits) dkf declare 520 { void Tcl_LimitAddHandler(Tcl_Interp *interp, int type, - Tcl_LimitHandlerProc *handlerProc, void *clientData, + Tcl_LimitHandlerProc *handlerProc, ClientData clientData, Tcl_LimitHandlerDeleteProc *deleteProc) } declare 521 { void Tcl_LimitRemoveHandler(Tcl_Interp *interp, int type, - Tcl_LimitHandlerProc *handlerProc, void *clientData) + Tcl_LimitHandlerProc *handlerProc, ClientData clientData) } declare 522 { int Tcl_LimitReady(Tcl_Interp *interp) } declare 523 { @@ -2053,16 +1994,16 @@ # TIP#233 (virtualized time) akupries declare 552 { void Tcl_SetTimeProc(Tcl_GetTimeProc *getProc, Tcl_ScaleTimeProc *scaleProc, - void *clientData) + ClientData clientData) } declare 553 { void Tcl_QueryTimeProc(Tcl_GetTimeProc **getProc, Tcl_ScaleTimeProc **scaleProc, - void **clientData) + ClientData *clientData) } # TIP#218 (driver thread actions) davygrvy/akupries ChannelType ver 4 declare 554 { Tcl_DriverThreadActionProc *Tcl_ChannelThreadActionProc( @@ -2069,23 +2010,23 @@ const Tcl_ChannelType *chanTypePtr) } # TIP#237 (arbitrary-precision integers) kbk declare 555 { - Tcl_Obj *Tcl_NewBignumObj(void *value) + Tcl_Obj *Tcl_NewBignumObj(mp_int *value) } declare 556 { - Tcl_Obj *Tcl_DbNewBignumObj(void *value, const char *file, int line) + Tcl_Obj *Tcl_DbNewBignumObj(mp_int *value, const char *file, int line) } declare 557 { - void Tcl_SetBignumObj(Tcl_Obj *obj, void *value) + void Tcl_SetBignumObj(Tcl_Obj *obj, mp_int *value) } declare 558 { - int Tcl_GetBignumFromObj(Tcl_Interp *interp, Tcl_Obj *obj, void *value) + int Tcl_GetBignumFromObj(Tcl_Interp *interp, Tcl_Obj *obj, mp_int *value) } declare 559 { - int Tcl_TakeBignumFromObj(Tcl_Interp *interp, Tcl_Obj *obj, void *value) + int Tcl_TakeBignumFromObj(Tcl_Interp *interp, Tcl_Obj *obj, mp_int *value) } # TIP #208 ('chan' command) jeffh declare 560 { int Tcl_TruncateChannel(Tcl_Channel chan, Tcl_WideInt length) @@ -2110,11 +2051,11 @@ } # TIP #237 (additional conversion functions for bignum support) kbk/dgp declare 566 { int Tcl_InitBignumFromDouble(Tcl_Interp *interp, double initval, - void *toInit) + mp_int *toInit) } # TIP#181 (namespace unknown command) dgp for Neil Madden declare 567 { Tcl_Obj *Tcl_GetNamespaceUnknownHandler(Tcl_Interp *interp, @@ -2141,20 +2082,20 @@ } # TIP#268 (extended version numbers and requirements) akupries declare 573 { int Tcl_PkgRequireProc(Tcl_Interp *interp, const char *name, - int objc, Tcl_Obj *const objv[], void *clientDataPtr) + int objc, Tcl_Obj *const objv[], ClientData *clientDataPtr) } # 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, - size_t length, size_t limit, const char *ellipsis) + 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[]) } @@ -2169,305 +2110,15 @@ void Tcl_AppendPrintfToObj(Tcl_Obj *objPtr, const char *format, ...) } # ----- BASELINE -- FOR -- 8.5.0 ----- # -# TIP #285 (script cancellation support) jmistachkin -declare 580 { - int Tcl_CancelEval(Tcl_Interp *interp, Tcl_Obj *resultObjPtr, - void *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, void *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, - void *data0, void *data1, void *data2, - void *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, - void *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 { - unsigned Tcl_GetFSInodeFromStat(const Tcl_StatBuf *statPtr) -} -declare 591 { - unsigned Tcl_GetModeFromStat(const Tcl_StatBuf *statPtr) -} -declare 592 { - int Tcl_GetLinkCountFromStat(const Tcl_StatBuf *statPtr) -} -declare 593 { - int Tcl_GetUserIdFromStat(const Tcl_StatBuf *statPtr) -} -declare 594 { - int Tcl_GetGroupIdFromStat(const Tcl_StatBuf *statPtr) -} -declare 595 { - int Tcl_GetDeviceTypeFromStat(const Tcl_StatBuf *statPtr) -} -declare 596 { - Tcl_WideInt Tcl_GetAccessTimeFromStat(const Tcl_StatBuf *statPtr) -} -declare 597 { - Tcl_WideInt Tcl_GetModificationTimeFromStat(const Tcl_StatBuf *statPtr) -} -declare 598 { - Tcl_WideInt Tcl_GetChangeTimeFromStat(const Tcl_StatBuf *statPtr) -} -declare 599 { - Tcl_WideUInt Tcl_GetSizeFromStat(const Tcl_StatBuf *statPtr) -} -declare 600 { - Tcl_WideUInt Tcl_GetBlocksFromStat(const Tcl_StatBuf *statPtr) -} -declare 601 { - unsigned Tcl_GetBlockSizeFromStat(const Tcl_StatBuf *statPtr) -} - -# TIP#314 (ensembles with parameters) dkf for Lars Hellstr"om -declare 602 { - int Tcl_SetEnsembleParameterList(Tcl_Interp *interp, Tcl_Command token, - Tcl_Obj *paramList) -} -declare 603 { - int Tcl_GetEnsembleParameterList(Tcl_Interp *interp, Tcl_Command token, - Tcl_Obj **paramListPtr) -} - -# TIP#265 (option parser) dkf for Sam Bromley -declare 604 { - int Tcl_ParseArgsObjv(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, - int *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv) -} - -# TIP#336 (manipulate the error line) dgp -declare 605 { - int Tcl_GetErrorLine(Tcl_Interp *interp) -} -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, - size_t buffersize, Tcl_Obj *gzipHeaderDictObj) -} -declare 612 { - unsigned int Tcl_ZlibCRC32(unsigned int crc, const unsigned char *buf, - size_t len) -} -declare 613 { - unsigned int Tcl_ZlibAdler32(unsigned int adler, const unsigned char *buf, - size_t 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, - size_t count) -} -declare 620 { - int Tcl_ZlibStreamClose(Tcl_ZlibStream zshandle) -} -declare 621 { - int Tcl_ZlibStreamReset(Tcl_ZlibStream zshandle) -} - -# TIP 338 (control over startup script) dgp -declare 622 { - void Tcl_SetStartupScript(Tcl_Obj *path, const char *encoding) -} -declare 623 { - Tcl_Obj *Tcl_GetStartupScript(const char **encodingPtr) -} - -# TIP#332 (half-close made public) aferrieux -declare 624 { - int Tcl_CloseEx(Tcl_Interp *interp, Tcl_Channel chan, int flags) -} - -# TIP #353 (NR-enabled expressions) dgp -declare 625 { - int Tcl_NRExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj *resultPtr) -} - -# TIP #356 (NR-enabled substitution) dgp -declare 626 { - int Tcl_NRSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags) -} - -# TIP #357 (Export TclLoadFile and TclpFindSymbol) kbk -declare 627 { - int Tcl_LoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, - const char *const symv[], int flags, void *procPtrs, - Tcl_LoadHandle *handlePtr) -} -declare 628 { - void *Tcl_FindSymbol(Tcl_Interp *interp, Tcl_LoadHandle handle, - const char *symbol) -} -declare 629 { - int Tcl_FSUnloadFile(Tcl_Interp *interp, Tcl_LoadHandle handlePtr) -} - -# TIP #400 -declare 630 { - void Tcl_ZlibStreamSetCompressionDictionary(Tcl_ZlibStream zhandle, - Tcl_Obj *compressionDictionaryObj) -} - -# ----- 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, - void *callbackData) -} - -# TIP #430 -declare 632 { - int TclZipfs_Mount(Tcl_Interp *interp, const char *mountPoint, - const char *zipname, const char *passwd) -} -declare 633 { - int TclZipfs_Unmount(Tcl_Interp *interp, const char *mountPoint) -} -declare 634 { - Tcl_Obj *TclZipfs_TclLibrary(void) -} -declare 635 { - int TclZipfs_MountBuffer(Tcl_Interp *interp, const char *mountPoint, - unsigned char *data, size_t datalen, int copy) -} - -# TIP #445 -declare 636 { - void Tcl_FreeIntRep(Tcl_Obj *objPtr) -} -declare 637 { - char *Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, - size_t 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) -} -declare 640 { - int Tcl_HasStringRep(Tcl_Obj *objPtr) -} - -# TIP #506 -declare 641 { - void Tcl_IncrRefCount(Tcl_Obj *objPtr) -} - -declare 642 { - void Tcl_DecrRefCount(Tcl_Obj *objPtr) -} - -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, size_t size) -} - -declare 645 { - int Tcl_GetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, - size_t endValue, size_t *indexPtr) -} - -# TIP #548 -declare 646 { - int Tcl_UtfToUniChar(const char *src, int *chPtr) -} -declare 647 { - char *Tcl_UniCharToUtfDString(const int *uniStr, - size_t uniLength, Tcl_DString *dsPtr) -} -declare 648 { - int *Tcl_UtfToUniCharDString(const char *src, - size_t length, Tcl_DString *dsPtr) -} - -# ----- BASELINE -- FOR -- 8.7.0 ----- # +declare 687 { + void TclUnusedStubEntry(void) +} + +# ----- BASELINE -- FOR -- 8.7.0 / 9.0.0 ----- # ############################################################################## # Define the platform specific public Tcl interface. These functions are only # available on the designated platform. @@ -2479,54 +2130,45 @@ # (none) ################################ # Windows specific functions -# Added in Tcl 8.1, Removed in Tcl 9.0 (converted to macro) - -#declare 0 win { -# TCHAR *Tcl_WinUtfToTChar(const char *str, size_t len, Tcl_DString *dsPtr) -#} -#declare 1 win { -# char *Tcl_WinTCharToUtf(const TCHAR *str, size_t len, Tcl_DString *dsPtr) -#} +# 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) +} +declare 3 win { + void TclUnusedStubEntry(void) +} ################################ # Mac OS X specific functions -# Removed in 9.0 -#declare 0 macosx { -# int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp, -# const char *bundleName, int hasResourceFile, -# size_t maxPathLen, char *libraryPath) -#} +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, size_t maxPathLen, char *libraryPath) + int hasResourceFile, int maxPathLen, char *libraryPath) +} +declare 2 macosx { + void TclUnusedStubEntry(void) } ############################################################################## # Public functions that are not accessible via the stubs table. 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) -} -export { - void Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc) -} -export { - Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc) -} -export { - void Tcl_FindExecutable(const char *argv0) + void Tcl_Main(int argc, char **argv, Tcl_AppInitProc *appInitProc) } export { const char *Tcl_InitStubs(Tcl_Interp *interp, const char *version, int exact) } @@ -2539,12 +2181,27 @@ int exact) } export { void Tcl_GetMemoryInfo(Tcl_DString *dsPtr) } + +# Global variables that need to be exported from the tcl shared library. + +export { + TclStubs *tclStubsPtr (fool checkstubs) +} +export { + TclPlatStubs *tclPlatStubsPtr (fool checkstubs) +} +export { + TclIntStubs *tclIntStubsPtr (fool checkstubs) +} +export { + TclIntPlatStubs *tclIntPlatStubsPtr (fool checkstubs) +} export { - void Tcl_InitSubsystems(void) + TclTomMathStubs *tclTomMathStubsPtr (fool checkstubs) } # Local Variables: # mode: tcl # End: Index: generic/tcl.h ================================================================== --- generic/tcl.h +++ generic/tcl.h @@ -36,29 +36,62 @@ /* * When version numbers change here, must also go into the following files and * update the version numbers: * * library/init.tcl (1 LOC patch) - * unix/configure.ac (2 LOC Major, 2 LOC minor, 1 LOC patch) - * win/configure.ac (as above) + * unix/configure.in (2 LOC Major, 2 LOC minor, 1 LOC patch) + * win/configure.in (as above) * win/tcl.m4 (not patchlevel) + * win/makefile.bc (not patchlevel) 2 LOC * README (sections 0 and 2, with and without separator) + * macosx/Tcl.pbproj/project.pbxproj (not patchlevel) 1 LOC + * macosx/Tcl.pbproj/default.pbxuser (not patchlevel) 1 LOC + * macosx/Tcl.xcode/project.pbxproj (not patchlevel) 2 LOC + * macosx/Tcl.xcode/default.pbxuser (not patchlevel) 1 LOC * 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) + * tools/tcl.wse.in (for windows installer) + * tools/tclSplash.bmp (not patchlevel) */ -#define TCL_MAJOR_VERSION 9 -#define TCL_MINOR_VERSION 0 -#define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE -#define TCL_RELEASE_SERIAL 2 - -#define TCL_VERSION "9.0" -#define TCL_PATCH_LEVEL "9.0a2" - -#if defined(RC_INVOKED) +#define TCL_MAJOR_VERSION 8 +#define TCL_MINOR_VERSION 5 +#define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE +#define TCL_RELEASE_SERIAL 19 + +#define TCL_VERSION "8.5" +#define TCL_PATCH_LEVEL "8.5.19" + +/* + * The following definitions set up the proper options for Windows compilers. + * We use this method because there is no autoconf equivalent. + */ + +#ifndef __WIN32__ +# if defined(_WIN32) || defined(WIN32) || defined(__MSVCRT__) || defined(__BORLANDC__) || (defined(__WATCOMC__) && defined(__WINDOWS_386__)) +# define __WIN32__ +# ifndef WIN32 +# define WIN32 +# endif +# ifndef _WIN32 +# define _WIN32 +# endif +# endif +#endif + +/* + * STRICT: See MSDN Article Q83456 + */ + +#ifdef __WIN32__ +# ifndef STRICT +# define STRICT +# endif +#endif /* __WIN32__ */ + /* * Utility macros: STRINGIFY takes an argument and wraps it in "" (double * quotation marks), JOIN joins two arguments. */ @@ -68,11 +101,10 @@ #endif #ifndef JOIN # define JOIN(a,b) JOIN1(a,b) # define JOIN1(a,b) a##b #endif -#endif /* RC_INVOKED */ /* * 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. @@ -82,14 +114,19 @@ */ #ifndef RC_INVOKED /* - * Special macro to define mutexes. + * Special macro to define mutexes, that doesn't do anything if we are not + * using threads. */ +#ifdef TCL_THREADS #define TCL_DECLARE_MUTEX(name) static Tcl_Mutex name; +#else +#define TCL_DECLARE_MUTEX(name) +#endif /* * Tcl's public routine Tcl_FSSeek() uses the values SEEK_SET, SEEK_CUR, and * SEEK_END, all #define'd by stdio.h . * @@ -99,46 +136,28 @@ * prior Tcl releases. */ #include -#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)) -# define TCL_NORETURN1 __attribute__ ((noreturn)) -#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 */ -# define TCL_NOINLINE /* nothing */ -# endif -# define TCL_NORETURN1 /* nothing */ -#endif - -/* - * Allow a part of Tcl's API to be explicitly marked as deprecated. - * - * Used to make TIP 330/336 generate moans even if people use the - * compatibility macros. Change your code, guys! We won't support you forever. - */ - -#if defined(__GNUC__) && ((__GNUC__ >= 4) || ((__GNUC__ == 3) && (__GNUC_MINOR__ >= 1))) -# if (__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ >= 5)) -# define TCL_DEPRECATED_API(msg) __attribute__ ((__deprecated__ (msg))) -# else -# define TCL_DEPRECATED_API(msg) __attribute__ ((__deprecated__)) -# endif -#else -# define TCL_DEPRECATED_API(msg) /* nothing portable */ -#endif - -/* - *---------------------------------------------------------------------------- +/* + * 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 +#ifndef TCL_NO_DEPRECATED +# 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 + +/* * Macros used to declare a function to be exported by a DLL. Used by Windows, * maps to no-op declarations on non-Windows systems. The default build on * windows is for a DLL, which causes the DLLIMPORT and DLLEXPORT macros to be * nonempty. To build a static library, the macro STATIC_BUILD should be * defined. @@ -147,11 +166,11 @@ * correctly decorate the C library imported function. Use CRTIMPORT * for this purpose. _DLL is defined by the compiler when linking to * MSVCRT. */ -#if (defined(_WIN32) && (defined(_MSC_VER) || (defined(__BORLANDC__) && (__BORLANDC__ >= 0x0550)) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec)))) +#if (defined(__WIN32__) && (defined(_MSC_VER) || (defined(__BORLANDC__) && (__BORLANDC__ >= 0x0550)) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec)))) # define HAVE_DECLSPEC 1 # ifdef STATIC_BUILD # define DLLIMPORT # define DLLEXPORT # ifdef _DLL @@ -178,11 +197,11 @@ * These macros are used to control whether functions are being declared for * import or export. If a function is being declared while it is being built * to be included in a shared library, then it should have the DLLEXPORT * storage class. If is being declared for use by a module that is going to * link against the shared library, then it should have the DLLIMPORT storage - * class. If the symbol is being declared for a static build or for use from a + * class. If the symbol is beind declared for a static build or for use from a * stub library, then the storage class should be empty. * * The convention is that a macro called BUILD_xxxx, where xxxx is the name of * a library we are building, is set on the compile line for sources that are * to be placed in the library. When this macro is set, the storage class will @@ -199,12 +218,47 @@ # else # define TCL_STORAGE_CLASS DLLIMPORT # endif #endif -#if !defined(CONST86) && !defined(TCL_NO_DEPRECATED) -# define CONST86 const +/* + * Definitions that allow this header file to be used either with or without + * ANSI C features like function prototypes. + */ + +#undef _ANSI_ARGS_ +#undef CONST +#ifndef INLINE +# define INLINE +#endif + +#ifndef NO_CONST +# define CONST const +#else +# define CONST +#endif + +#ifndef NO_PROTOTYPES +# define _ANSI_ARGS_(x) x +#else +# define _ANSI_ARGS_(x) () +#endif + +#ifdef USE_NON_CONST +# ifdef USE_COMPAT_CONST +# error define at most one of USE_NON_CONST and USE_COMPAT_CONST +# endif +# define CONST84 +# define CONST84_RETURN +#else +# ifdef USE_COMPAT_CONST +# define CONST84 +# define CONST84_RETURN CONST +# else +# define CONST84 CONST +# define CONST84_RETURN CONST +# endif #endif /* * Make sure EXTERN isn't defined elsewhere. */ @@ -217,15 +271,50 @@ # 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 can't be included after tcl.h, since tcl.h also defines + * VOID. This block is skipped under Cygwin and Mingw. + */ + +#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__ +# ifndef NO_VOID +# define VOID void +# else +# define VOID char +# endif +#endif + /* * Miscellaneous declarations. */ -typedef void *ClientData; +#ifndef _CLIENTDATA +# ifndef NO_VOID + typedef void *ClientData; +# else + typedef int *ClientData; +# endif +# define _CLIENTDATA +#endif /* * Darwin specific configure overrides (to support fat compiles, where * configure runs only once for multiple architectures): */ @@ -241,18 +330,27 @@ # undef TCL_CFG_DO64BIT # endif /* __LP64__ */ # undef HAVE_STRUCT_STAT64 #endif /* __APPLE__ */ +/* Cross-compiling 32-bit on a 64-bit platform? Then our + * configure script does the wrong thing. Correct that here. + */ +#if defined(__GNUC__) && !defined(_WIN32) && !defined(__LP64__) +# undef TCL_WIDE_INT_IS_LONG +# undef TCL_WIDE_INT_TYPE +# define TCL_WIDE_INT_TYPE long long +#endif + /* * Define Tcl_WideInt to be a type that is (at least) 64-bits wide, and define * Tcl_WideUInt to be the unsigned variant of that type (assuming that where * we have one, we can have the other.) * * Also defines the following macros: - * TCL_WIDE_INT_IS_LONG - if wide ints are really longs (i.e. we're on a - * LP64 system such as modern Solaris or Linux ... not including Win64) + * TCL_WIDE_INT_IS_LONG - if wide ints are really longs (i.e. we're on a real + * 64-bit system.) * Tcl_WideAsLong - forgetful converter from wideInt to long. * Tcl_LongAsWide - sign-extending converter from long to wideInt. * Tcl_WideAsDouble - converter from wideInt to double. * Tcl_DoubleAsWide - converter from double to wideInt. * @@ -263,54 +361,77 @@ * tclObj.c) depends on the function * sprintf(...,"%" TCL_LL_MODIFIER "d",...). */ #if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG) -# if defined(_WIN32) && (!defined(__USE_MINGW_ANSI_STDIO) || !__USE_MINGW_ANSI_STDIO) +# if defined(__WIN32__) && (!defined(__USE_MINGW_ANSI_STDIO) || !__USE_MINGW_ANSI_STDIO) # define TCL_WIDE_INT_TYPE __int64 -# define TCL_LL_MODIFIER "I64" -# if defined(_WIN64) -# define TCL_Z_MODIFIER "I" -# endif +# ifdef __BORLANDC__ +# define TCL_LL_MODIFIER "L" +# else /* __BORLANDC__ */ +# define TCL_LL_MODIFIER "I64" +# endif /* __BORLANDC__ */ # elif defined(__GNUC__) -# define TCL_Z_MODIFIER "z" -# else /* ! _WIN32 && ! __GNUC__ */ +# define TCL_WIDE_INT_TYPE long long +# define TCL_LL_MODIFIER "ll" +# else /* ! __WIN32__ && ! __GNUC__ */ /* * Don't know what platform it is and configure hasn't discovered what is * going on for us. Try to guess... */ -# include -# if defined(LLONG_MAX) && (LLONG_MAX == LONG_MAX) -# define TCL_WIDE_INT_IS_LONG 1 -# endif -# endif /* _WIN32 */ +# ifdef NO_LIMITS_H +# error please define either TCL_WIDE_INT_TYPE or TCL_WIDE_INT_IS_LONG +# else /* !NO_LIMITS_H */ +# include +# if (INT_MAX < LONG_MAX) +# define TCL_WIDE_INT_IS_LONG 1 +# else +# define TCL_WIDE_INT_TYPE long long +# endif +# endif /* NO_LIMITS_H */ +# endif /* __WIN32__ */ #endif /* !TCL_WIDE_INT_TYPE & !TCL_WIDE_INT_IS_LONG */ - -#ifndef TCL_WIDE_INT_TYPE -# define TCL_WIDE_INT_TYPE long long -#endif /* !TCL_WIDE_INT_TYPE */ +#ifdef TCL_WIDE_INT_IS_LONG +# undef TCL_WIDE_INT_TYPE +# define TCL_WIDE_INT_TYPE long +#endif /* TCL_WIDE_INT_IS_LONG */ typedef TCL_WIDE_INT_TYPE Tcl_WideInt; typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; -#ifndef TCL_LL_MODIFIER -# define TCL_LL_MODIFIER "ll" -#endif /* !TCL_LL_MODIFIER */ -#ifndef TCL_Z_MODIFIER -# if defined(__GNUC__) && !defined(_WIN32) -# define TCL_Z_MODIFIER "z" +#ifdef TCL_WIDE_INT_IS_LONG +# define Tcl_WideAsLong(val) ((long)(val)) +# define Tcl_LongAsWide(val) ((long)(val)) +# define Tcl_WideAsDouble(val) ((double)((long)(val))) +# define Tcl_DoubleAsWide(val) ((long)((double)(val))) +# ifndef TCL_LL_MODIFIER +# define TCL_LL_MODIFIER "l" +# endif /* !TCL_LL_MODIFIER */ +#else /* TCL_WIDE_INT_IS_LONG */ +/* + * The next short section of defines are only done when not running on Windows + * or some other strange platform. + */ +# ifndef TCL_LL_MODIFIER +# define TCL_LL_MODIFIER "ll" +# endif /* !TCL_LL_MODIFIER */ +# define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val))) +# define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val))) +# define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val))) +# define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val))) +#endif /* TCL_WIDE_INT_IS_LONG */ + +#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 -# define TCL_Z_MODIFIER "" -# endif -#endif /* !TCL_Z_MODIFIER */ -#define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val))) -#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) - typedef struct __stat64 Tcl_StatBuf; + typedef struct _stat32i64 Tcl_StatBuf; +# endif /* _MSC_VER < 1400 */ #elif defined(__CYGWIN__) typedef struct { dev_t st_dev; unsigned short st_ino; unsigned short st_mode; @@ -319,22 +440,22 @@ short st_gid; /* Here is a 2-byte gap */ dev_t st_rdev; /* Here is a 4-byte gap */ long long st_size; - struct {long long tv_sec;} st_atim; - struct {long long tv_sec;} st_mtim; - struct {long long tv_sec;} st_ctim; + struct {long tv_sec;} st_atim; + struct {long tv_sec;} st_mtim; + struct {long tv_sec;} st_ctim; + /* Here is a 4-byte gap */ } Tcl_StatBuf; #elif defined(HAVE_STRUCT_STAT64) && !defined(__APPLE__) typedef struct stat64 Tcl_StatBuf; #else typedef struct stat Tcl_StatBuf; #endif /* - *---------------------------------------------------------------------------- * Data structures defined opaquely in this module. The definitions below just * provide dummy types. A few fields are made visible in Tcl_Interp * structures, namely those used for returning a string result from commands. * Direct access to the result field is discouraged in Tcl 8.0. The * interpreter result is either an object or a string, and the two values are @@ -349,11 +470,25 @@ * 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 Tcl_Interp; +typedef struct Tcl_Interp { + char *result; /* If the last command returned a string + * result, this points to it. */ + void (*freeProc) _ANSI_ARGS_((char *blockPtr)); + /* Zero means the string result is statically + * allocated. TCL_DYNAMIC means it was + * allocated with ckalloc and should be freed + * with ckfree. Other values give the address + * of function to invoke to free the result. + * Tcl_Eval must free it before executing next + * command. */ + int errorLine; /* When TCL_ERROR is returned, this gives the + * line number within the command where the + * error occurred (1 if first line). */ +} 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; @@ -370,32 +505,30 @@ typedef struct Tcl_ThreadDataKey_ *Tcl_ThreadDataKey; typedef struct Tcl_ThreadId_ *Tcl_ThreadId; typedef struct Tcl_TimerToken_ *Tcl_TimerToken; typedef struct Tcl_Trace_ *Tcl_Trace; typedef struct Tcl_Var_ *Tcl_Var; -typedef struct Tcl_ZLibStream_ *Tcl_ZlibStream; /* - *---------------------------------------------------------------------------- * 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) (void *clientData); +#if defined __WIN32__ +typedef unsigned (__stdcall Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData)); #else -typedef void (Tcl_ThreadCreateProc) (void *clientData); +typedef void (Tcl_ThreadCreateProc) _ANSI_ARGS_((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. */ -#if defined _WIN32 +#if defined __WIN32__ # define Tcl_ThreadCreateType unsigned __stdcall # define TCL_THREAD_CREATE_RETURN return 0 #else # define Tcl_ThreadCreateType void # define TCL_THREAD_CREATE_RETURN @@ -448,22 +581,23 @@ * relative to the start of the match string, not the beginning of the entire * string. */ typedef struct Tcl_RegExpIndices { - size_t start; /* Character offset of first character in + long start; /* Character offset of first character in * match. */ - size_t end; /* Character offset of first character after + long end; /* Character offset of first character after * the match. */ } Tcl_RegExpIndices; typedef struct Tcl_RegExpInfo { - size_t nsubs; /* Number of subexpressions in the compiled + int nsubs; /* Number of subexpressions in the compiled * expression. */ Tcl_RegExpIndices *matches; /* Array of nsubs match offset pairs. */ - size_t extendStart; /* The offset at which a subsequent match + 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. @@ -471,11 +605,10 @@ typedef Tcl_StatBuf *Tcl_Stat_; typedef struct stat *Tcl_OldStat_; /* - *---------------------------------------------------------------------------- * When a TCL command returns, the interpreter contains a result from the * command. Programmers are strongly encouraged to use one of the functions * Tcl_GetObjResult() or Tcl_GetStringResult() to read the interpreter's * result. See the SetResult man page for details. Besides this result, the * command function returns an integer code, which is one of the following: @@ -497,98 +630,123 @@ #define TCL_ERROR 1 #define TCL_RETURN 2 #define TCL_BREAK 3 #define TCL_CONTINUE 4 +#define TCL_RESULT_SIZE 200 + /* - *---------------------------------------------------------------------------- * 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: + */ + +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; + /* * 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) (void *clientData, Tcl_Interp *interp, - int code); -typedef void (Tcl_ChannelProc) (void *clientData, int mask); -typedef void (Tcl_CloseProc) (void *data); -typedef void (Tcl_CmdDeleteProc) (void *clientData); -typedef int (Tcl_CmdProc) (void *clientData, Tcl_Interp *interp, - int argc, const char *argv[]); -typedef void (Tcl_CmdTraceProc) (void *clientData, Tcl_Interp *interp, - int level, char *command, Tcl_CmdProc *proc, - void *cmdClientData, int argc, const char *argv[]); -typedef int (Tcl_CmdObjTraceProc) (void *clientData, Tcl_Interp *interp, - int level, const char *command, Tcl_Command commandInfo, int objc, - struct Tcl_Obj *const *objv); -typedef void (Tcl_CmdObjTraceDeleteProc) (void *clientData); -typedef void (Tcl_DupInternalRepProc) (struct Tcl_Obj *srcPtr, - struct Tcl_Obj *dupPtr); -typedef int (Tcl_EncodingConvertProc) (void *clientData, const char *src, - int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, - int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); -#define Tcl_EncodingFreeProc Tcl_FreeProc -typedef int (Tcl_EventProc) (Tcl_Event *evPtr, int flags); -typedef void (Tcl_EventCheckProc) (void *clientData, int flags); -typedef int (Tcl_EventDeleteProc) (Tcl_Event *evPtr, void *clientData); -typedef void (Tcl_EventSetupProc) (void *clientData, int flags); -#define Tcl_ExitProc Tcl_FreeProc -typedef void (Tcl_FileProc) (void *clientData, int mask); -#define Tcl_FileFreeProc Tcl_FreeProc -typedef void (Tcl_FreeInternalRepProc) (struct Tcl_Obj *objPtr); -typedef void (Tcl_FreeProc) (void *blockPtr); -typedef void (Tcl_IdleProc) (void *clientData); -typedef void (Tcl_InterpDeleteProc) (void *clientData, - Tcl_Interp *interp); -typedef void (Tcl_NamespaceDeleteProc) (void *clientData); -typedef int (Tcl_ObjCmdProc) (void *clientData, Tcl_Interp *interp, - int objc, struct Tcl_Obj *const *objv); -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) (void *callbackData, Tcl_Channel chan, - char *address, int port); -typedef void (Tcl_TimerProc) (void *clientData); -typedef int (Tcl_SetFromAnyProc) (Tcl_Interp *interp, struct Tcl_Obj *objPtr); -typedef void (Tcl_UpdateStringProc) (struct Tcl_Obj *objPtr); -typedef char * (Tcl_VarTraceProc) (void *clientData, Tcl_Interp *interp, - const char *part1, const char *part2, int flags); -typedef void (Tcl_CommandTraceProc) (void *clientData, Tcl_Interp *interp, - const char *oldName, const char *newName, int flags); -typedef void (Tcl_CreateFileHandlerProc) (int fd, int mask, Tcl_FileProc *proc, - void *clientData); -typedef void (Tcl_DeleteFileHandlerProc) (int fd); -typedef void (Tcl_AlertNotifierProc) (void *clientData); -typedef void (Tcl_ServiceModeHookProc) (int mode); -typedef void *(Tcl_InitNotifierProc) (void); -typedef void (Tcl_FinalizeNotifierProc) (void *clientData); -typedef void (Tcl_MainLoopProc) (void); - -/* - *---------------------------------------------------------------------------- +typedef int (Tcl_AppInitProc) _ANSI_ARGS_((Tcl_Interp *interp)); +typedef int (Tcl_AsyncProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int code)); +typedef void (Tcl_ChannelProc) _ANSI_ARGS_((ClientData clientData, int mask)); +typedef void (Tcl_CloseProc) _ANSI_ARGS_((ClientData data)); +typedef void (Tcl_CmdDeleteProc) _ANSI_ARGS_((ClientData clientData)); +typedef int (Tcl_CmdProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, CONST84 char *argv[])); +typedef void (Tcl_CmdTraceProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc, + ClientData cmdClientData, int argc, CONST84 char *argv[])); +typedef int (Tcl_CmdObjTraceProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int level, CONST char *command, + Tcl_Command commandInfo, int objc, struct Tcl_Obj * CONST * objv)); +typedef void (Tcl_CmdObjTraceDeleteProc) _ANSI_ARGS_((ClientData clientData)); +typedef void (Tcl_DupInternalRepProc) _ANSI_ARGS_((struct Tcl_Obj *srcPtr, + struct Tcl_Obj *dupPtr)); +typedef int (Tcl_EncodingConvertProc)_ANSI_ARGS_((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)_ANSI_ARGS_((ClientData clientData)); +typedef int (Tcl_EventProc) _ANSI_ARGS_((Tcl_Event *evPtr, int flags)); +typedef void (Tcl_EventCheckProc) _ANSI_ARGS_((ClientData clientData, + int flags)); +typedef int (Tcl_EventDeleteProc) _ANSI_ARGS_((Tcl_Event *evPtr, + ClientData clientData)); +typedef void (Tcl_EventSetupProc) _ANSI_ARGS_((ClientData clientData, + int flags)); +typedef void (Tcl_ExitProc) _ANSI_ARGS_((ClientData clientData)); +typedef void (Tcl_FileProc) _ANSI_ARGS_((ClientData clientData, int mask)); +typedef void (Tcl_FileFreeProc) _ANSI_ARGS_((ClientData clientData)); +typedef void (Tcl_FreeInternalRepProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr)); +typedef void (Tcl_FreeProc) _ANSI_ARGS_((char *blockPtr)); +typedef void (Tcl_IdleProc) _ANSI_ARGS_((ClientData clientData)); +typedef void (Tcl_InterpDeleteProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp)); +typedef int (Tcl_MathProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr)); +typedef void (Tcl_NamespaceDeleteProc) _ANSI_ARGS_((ClientData clientData)); +typedef int (Tcl_ObjCmdProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST * objv)); +typedef int (Tcl_PackageInitProc) _ANSI_ARGS_((Tcl_Interp *interp)); +typedef int (Tcl_PackageUnloadProc) _ANSI_ARGS_((Tcl_Interp *interp, + int flags)); +typedef void (Tcl_PanicProc) _ANSI_ARGS_((CONST char *format, ...)); +typedef void (Tcl_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData, + Tcl_Channel chan, char *address, int port)); +typedef void (Tcl_TimerProc) _ANSI_ARGS_((ClientData clientData)); +typedef int (Tcl_SetFromAnyProc) _ANSI_ARGS_((Tcl_Interp *interp, + struct Tcl_Obj *objPtr)); +typedef void (Tcl_UpdateStringProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr)); +typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, CONST84 char *part1, CONST84 char *part2, + int flags)); +typedef void (Tcl_CommandTraceProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, CONST char *oldName, CONST char *newName, + int flags)); +typedef void (Tcl_CreateFileHandlerProc) _ANSI_ARGS_((int fd, int mask, + Tcl_FileProc *proc, ClientData clientData)); +typedef void (Tcl_DeleteFileHandlerProc) _ANSI_ARGS_((int fd)); +typedef void (Tcl_AlertNotifierProc) _ANSI_ARGS_((ClientData clientData)); +typedef void (Tcl_ServiceModeHookProc) _ANSI_ARGS_((int mode)); +typedef ClientData (Tcl_InitNotifierProc) _ANSI_ARGS_((VOID)); +typedef void (Tcl_FinalizeNotifierProc) _ANSI_ARGS_((ClientData clientData)); +typedef void (Tcl_MainLoopProc) _ANSI_ARGS_((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. */ typedef struct Tcl_ObjType { - const char *name; /* Name of the type, e.g. "int". */ + char *name; /* Name of the type, e.g. "int". */ Tcl_FreeInternalRepProc *freeIntRepProc; /* Called to free any storage for the type's * internal rep. NULL if the internal rep does * not need freeing. */ Tcl_DupInternalRepProc *dupIntRepProc; @@ -601,72 +759,82 @@ /* Called to convert the object's internal rep * to this type. Frees the internal rep of the * old type. Returns TCL_ERROR on failure. */ } Tcl_ObjType; -/* - * The following structure stores an internal representation (intrep) for - * a Tcl value. An intrep is associated with an Tcl_ObjType when both - * are stored in the same Tcl_Obj. The routines of the Tcl_ObjType govern - * the handling of the intrep. - */ - -typedef union Tcl_ObjIntRep { /* The internal representation: */ - long longValue; /* - an long integer value. */ - double doubleValue; /* - a double-precision floating value. */ - void *otherValuePtr; /* - another, type-specific value, */ - /* not used internally any more. */ - Tcl_WideInt wideValue; /* - an integer value >= 64bits */ - struct { /* - internal rep as two pointers. */ - void *ptr1; - void *ptr2; - } twoPtrValue; - struct { /* - internal rep as a pointer and a long, */ - void *ptr; /* not used internally any more. */ - unsigned long value; - } ptrAndLongRep; -} Tcl_ObjIntRep; - /* * 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 { - size_t refCount; /* When 0 the object will be freed. */ + 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 Tcl_Alloc. NULL means + * 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. */ - size_t length; /* The number of bytes at *bytes, not + int length; /* The number of bytes at *bytes, not * including the terminating null. */ - const Tcl_ObjType *typePtr; /* Denotes the object's type. Always + 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: */ + union { /* The internal representation: */ + long longValue; /* - an long integer value. */ + double doubleValue; /* - a double-precision floating value. */ + VOID *otherValuePtr; /* - another, type-specific value. */ + Tcl_WideInt wideValue; /* - a long long value. */ + struct { /* - internal rep as two pointers. */ + VOID *ptr1; + VOID *ptr2; + } twoPtrValue; + struct { /* - internal rep as a wide int, tightly + * packed fields. */ + VOID *ptr; /* Pointer to digits. */ + unsigned long value;/* Alloc, used, and signum packed into a + * single word. */ + } ptrAndLongRep; + } internalRep; } Tcl_Obj; - /* - *---------------------------------------------------------------------------- - * The following type contains the state needed by Tcl_SaveResult. It - * is typically allocated on the stack. + * Macros to increment and decrement a Tcl_Obj's reference count, and to test + * whether an object is shared (i.e. has reference count > 1). Note: clients + * should use Tcl_DecrRefCount() when they are finished using an object, and + * should never call TclFreeObj() directly. TclFreeObj() is only defined and + * made public in tcl.h to support Tcl_DecrRefCount's macro definition. */ -typedef Tcl_Obj *Tcl_SavedResult; +void Tcl_IncrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr)); +void Tcl_DecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr)); +int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr)); /* - *---------------------------------------------------------------------------- + * 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[TCL_RESULT_SIZE+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). */ @@ -675,11 +843,11 @@ * namespace. This contains no ::'s. The name * of the global namespace is "" although "::" * is an synonym. */ char *fullName; /* The namespace's fully qualified name. This * starts with ::. */ - void *clientData; /* Arbitrary value associated with this + 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; @@ -687,11 +855,10 @@ * one. NULL if this is the global * namespace. */ } Tcl_Namespace; /* - *---------------------------------------------------------------------------- * The following structure represents a call frame, or activation record. A * call frame defines a naming context for a procedure call: its local scope * (for local variables) and its namespace scope (used for non-local * variables; often the global :: namespace). A call frame can also define the * naming context for a namespace eval or namespace inscope command: the @@ -713,25 +880,24 @@ typedef struct Tcl_CallFrame { Tcl_Namespace *nsPtr; int dummy1; int dummy2; - void *dummy3; - void *dummy4; - void *dummy5; + VOID *dummy3; + VOID *dummy4; + VOID *dummy5; int dummy6; - void *dummy7; - void *dummy8; + VOID *dummy7; + VOID *dummy8; int dummy9; - void *dummy10; - void *dummy11; - void *dummy12; - void *dummy13; + VOID *dummy10; + VOID *dummy11; + VOID *dummy12; + VOID *dummy13; } Tcl_CallFrame; /* - *---------------------------------------------------------------------------- * Information about commands that is returned by Tcl_GetCommandInfo and * passed to Tcl_SetCommandInfo. objProc is an objc/objv object-based command * function while proc is a traditional Tcl argc/argv string-based function. * Tcl_CreateObjCommand and Tcl_CreateCommand ensure that both objProc and * proc are non-NULL and can be called to execute the command. However, it may @@ -747,52 +913,52 @@ 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. */ - void *objClientData; /* ClientData for object proc. */ + ClientData objClientData; /* ClientData for object proc. */ Tcl_CmdProc *proc; /* Command's string-based function. */ - void *clientData; /* ClientData for string proc. */ + ClientData clientData; /* ClientData for string proc. */ Tcl_CmdDeleteProc *deleteProc; /* Function to call when command is * deleted. */ - void *deleteData; /* Value to pass to deleteProc (usually the + 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. */ - size_t length; /* Number of non-NULL characters in the + int length; /* Number of non-NULL characters in the * string. */ - size_t spaceAvl; /* Total number of bytes available for the + 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) +#define Tcl_DStringTrunc Tcl_DStringSetLength /* * Definitions for the maximum number of digits of precision that may be - * produced by Tcl_PrintDouble, and the number of bytes of buffer space - * required by Tcl_PrintDouble. + * 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) @@ -816,21 +982,17 @@ #define TCL_DONT_USE_BRACES 1 #define TCL_DONT_QUOTE_HASH 8 /* - * Flags that may be passed to Tcl_GetIndexFromObj. - * TCL_EXACT disallows abbreviated strings. - * TCL_INDEX_TEMP_TABLE disallows caching of lookups. A possible use case is - * a table that will not live long enough to make it worthwhile. + * Flag that may be passed to Tcl_GetIndexFromObj to force it to disallow + * abbreviated strings. */ -#define TCL_EXACT 1 -#define TCL_INDEX_TEMP_TABLE 2 +#define TCL_EXACT 1 /* - *---------------------------------------------------------------------------- * Flag values passed to Tcl_RecordAndEval, Tcl_EvalObj, Tcl_EvalObjv. * WARNING: these bit choices must not conflict with the bit choices for * evalFlag bits in tclInt.h! * * Meanings: @@ -840,23 +1002,15 @@ * TCL_EVAL_INVOKE: Magical Tcl_EvalObjv mode for aliases/ensembles * o Run in iPtr->lookupNsPtr or global namespace * o Cut out of error traces * o Don't reset the flags controlling ensemble * error message rewriting. - * TCL_CANCEL_UNWIND: Magical Tcl_CancelEval mode that causes the - * stack for the script in progress to be - * completely unwound. - * TCL_EVAL_NOERR: Do no exception reporting at all, just return - * as the caller will report. */ - -#define TCL_NO_EVAL 0x010000 -#define TCL_EVAL_GLOBAL 0x020000 -#define TCL_EVAL_DIRECT 0x040000 -#define TCL_EVAL_INVOKE 0x080000 -#define TCL_CANCEL_UNWIND 0x100000 -#define TCL_EVAL_NOERR 0x200000 +#define TCL_NO_EVAL 0x10000 +#define TCL_EVAL_GLOBAL 0x20000 +#define TCL_EVAL_DIRECT 0x40000 +#define TCL_EVAL_INVOKE 0x80000 /* * Special freeProc values that may be passed to Tcl_SetResult (see the man * page for details): */ @@ -865,12 +1019,10 @@ #define TCL_STATIC ((Tcl_FreeProc *) 0) #define TCL_DYNAMIC ((Tcl_FreeProc *) 3) /* * Flag values passed to variable-related functions. - * WARNING: these bit choices must not conflict with the bit choice for - * TCL_CANCEL_UNWIND, above. */ #define TCL_GLOBAL_ONLY 1 #define TCL_NAMESPACE_ONLY 2 #define TCL_APPEND_VALUE 4 @@ -877,18 +1029,18 @@ #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. */ +/* Required to support old variable/vdelete/vinfo traces */ #define TCL_TRACE_OLD_STYLE 0x1000 #endif -/* Indicate the semantics of the result of a trace. */ +/* Indicate the semantics of the result of a trace */ #define TCL_TRACE_RESULT_DYNAMIC 0x8000 #define TCL_TRACE_RESULT_OBJECT 0x10000 /* * Flag values for ensemble commands. @@ -900,15 +1052,26 @@ /* * Flag values passed to command-related functions. */ -#define TCL_TRACE_RENAME 0x2000 -#define TCL_TRACE_DELETE 0x4000 +#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) + */ + +#ifndef TCL_NO_DEPRECATED +# define TCL_PARSE_PART1 0x400 +#endif + /* * Types for linked variables: */ #define TCL_LINK_INT 1 @@ -919,41 +1082,43 @@ #define TCL_LINK_CHAR 6 #define TCL_LINK_UCHAR 7 #define TCL_LINK_SHORT 8 #define TCL_LINK_USHORT 9 #define TCL_LINK_UINT 10 -#if defined(TCL_WIDE_INT_IS_LONG) || defined(_WIN32) || defined(__CYGWIN__) -#define TCL_LINK_LONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_INT : TCL_LINK_INT) -#define TCL_LINK_ULONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_UINT : TCL_LINK_UINT) -#else #define TCL_LINK_LONG 11 #define TCL_LINK_ULONG 12 -#endif #define TCL_LINK_FLOAT 13 #define TCL_LINK_WIDE_UINT 14 -#define TCL_LINK_CHARS 15 -#define TCL_LINK_BINARY 16 #define TCL_LINK_READ_ONLY 0x80 - + /* - *---------------------------------------------------------------------------- * Forward declarations of Tcl_HashTable and related types. */ -#ifndef TCL_HASH_TYPE -# define TCL_HASH_TYPE size_t -#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); -typedef int (Tcl_CompareHashKeysProc) (void *keyPtr, Tcl_HashEntry *hPtr); -typedef Tcl_HashEntry * (Tcl_AllocHashEntryProc) (Tcl_HashTable *tablePtr, - void *keyPtr); -typedef void (Tcl_FreeHashEntryProc) (Tcl_HashEntry *hPtr); +typedef unsigned int (Tcl_HashKeyProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr, + VOID *keyPtr)); +typedef int (Tcl_CompareHashKeysProc) _ANSI_ARGS_((VOID *keyPtr, + Tcl_HashEntry *hPtr)); +typedef Tcl_HashEntry *(Tcl_AllocHashEntryProc) _ANSI_ARGS_(( + Tcl_HashTable *tablePtr, VOID *keyPtr)); +typedef void (Tcl_FreeHashEntryProc) _ANSI_ARGS_((Tcl_HashEntry *hPtr)); + +/* + * This flag controls whether the hash table stores the hash of a key, or + * recalculates it. There should be no reason for turning this flag off as it + * is completely binary and source compatible unless you directly access the + * bucketPtr member of the Tcl_HashTableEntry structure. This member has been + * removed and the space used to store the hash value. + */ + +#ifndef TCL_HASH_KEY_STORE_HASH +# define TCL_HASH_KEY_STORE_HASH 1 +#endif /* * Structure definition for an entry in a hash table. No-one outside Tcl * should access any of these fields directly; use the macros defined below. */ @@ -960,20 +1125,28 @@ struct Tcl_HashEntry { Tcl_HashEntry *nextPtr; /* Pointer to next entry in this hash bucket, * or NULL for end of chain. */ Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */ - size_t hash; /* Hash value. */ - void *clientData; /* Application stores something here with +#if TCL_HASH_KEY_STORE_HASH + VOID *hash; /* Hash value, stored as pointer to ensure + * that the offsets of the fields in this + * structure are not changed. */ +#else + Tcl_HashEntry **bucketPtr; /* Pointer to bucket that points to first + * entry in this entry's chain: used for + * deleting the entry. */ +#endif + 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. */ - char string[1]; /* String for key. The actual size will be as + char string[4]; /* String for key. The actual size will be as * large as needed to hold the key. */ } key; /* MUST BE LAST FIELD IN RECORD!! */ }; /* @@ -987,14 +1160,22 @@ * randomising the bits and then using the upper * N bits as the index into the table. * TCL_HASH_KEY_SYSTEM_HASH - If this flag is set then all memory internally * allocated for the hash table that is not for an * entry will use the system heap. + * TCL_HASH_KEY_DIRECT_COMPARE - + * Allows fast comparison for hash keys directly + * by compare of their key.oneWordValue values, + * before call of compareKeysProc (much slower + * than a direct compare, so it is speed-up only + * flag). Don't use it if keys contain values rather + * than pointers. */ #define TCL_HASH_KEY_RANDOMIZE_HASH 0x1 #define TCL_HASH_KEY_SYSTEM_HASH 0x2 +#define TCL_HASH_KEY_DIRECT_COMPARE 0x4 /* * Structure definition for the methods associated with a hash table key type. */ @@ -1049,30 +1230,30 @@ * 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). */ - size_t numBuckets; /* Total number of buckets allocated at + int numBuckets; /* Total number of buckets allocated at * **bucketPtr. */ - size_t numEntries; /* Total number of entries present in + int numEntries; /* Total number of entries present in * table. */ - size_t rebuildSize; /* Enlarge table when numEntries gets to be + int rebuildSize; /* Enlarge table when numEntries gets to be * this large. */ - size_t mask; /* Mask value used in hashing function. */ 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_HashEntry *(*findProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr, + CONST char *key)); + Tcl_HashEntry *(*createProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr, + CONST char *key, int *newPtr)); + Tcl_HashKeyType *typePtr; /* Type of the keys used in the * Tcl_HashTable. */ }; /* * Structure definition for information used to keep track of searches through @@ -1079,11 +1260,11 @@ * hash tables: */ typedef struct Tcl_HashSearch { Tcl_HashTable *tablePtr; /* Table being searched. */ - size_t nextIndex; /* Index of next bucket to be enumerated after + 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; @@ -1106,14 +1287,14 @@ * can be the same as TCL_CUSTOM_TYPE_KEYS, and TCL_ONE_WORD_KEYS can be the * same as TCL_CUSTOM_PTR_KEYS because they simply determine how the key is * accessed from the entry and not the behaviour. */ -#define TCL_STRING_KEYS (0) -#define TCL_ONE_WORD_KEYS (1) -#define TCL_CUSTOM_TYPE_KEYS (-2) -#define TCL_CUSTOM_PTR_KEYS (-1) +#define TCL_STRING_KEYS 0 +#define TCL_ONE_WORD_KEYS 1 +#define TCL_CUSTOM_TYPE_KEYS -2 +#define TCL_CUSTOM_PTR_KEYS -1 /* * Structure definition for information used to keep track of searches through * dictionaries. These fields should not be accessed by code outside * tclDictObj.c @@ -1120,17 +1301,16 @@ */ typedef struct { void *next; /* Search position for underlying hash * table. */ - size_t epoch; /* Epoch marker for dictionary being searched, - * or 0 if search has terminated. */ + int epoch; /* Epoch marker for dictionary being searched, + * or -1 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 * events: */ #define TCL_DONT_WAIT (1<<1) @@ -1179,22 +1359,23 @@ typedef struct Tcl_Time { long sec; /* Seconds. */ long usec; /* Microseconds. */ } Tcl_Time; -typedef void (Tcl_SetTimerProc) (const Tcl_Time *timePtr); -typedef int (Tcl_WaitForEventProc) (const Tcl_Time *timePtr); +typedef void (Tcl_SetTimerProc) _ANSI_ARGS_((Tcl_Time *timePtr)); +typedef int (Tcl_WaitForEventProc) _ANSI_ARGS_((Tcl_Time *timePtr)); /* * TIP #233 (Virtualized Time) */ -typedef void (Tcl_GetTimeProc) (Tcl_Time *timebuf, void *clientData); -typedef void (Tcl_ScaleTimeProc) (Tcl_Time *timebuf, void *clientData); +typedef void (Tcl_GetTimeProc) _ANSI_ARGS_((Tcl_Time *timebuf, + ClientData clientData)); +typedef void (Tcl_ScaleTimeProc) _ANSI_ARGS_((Tcl_Time *timebuf, + ClientData clientData)); /* - *---------------------------------------------------------------------------- * Bits to pass to Tcl_CreateFileHandler and Tcl_CreateChannelHandler to * indicate what sorts of events are of interest: */ #define TCL_READABLE (1<<1) @@ -1223,16 +1404,20 @@ /* * Value to use as the closeProc for a channel that supports the close2Proc * interface. */ -#define TCL_CLOSE2PROC NULL +#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. */ @@ -1242,43 +1427,49 @@ /* * Typedefs for the various operations in a channel type: */ -typedef int (Tcl_DriverBlockModeProc) (void *instanceData, int mode); -typedef void Tcl_DriverCloseProc; -typedef int (Tcl_DriverClose2Proc) (void *instanceData, - Tcl_Interp *interp, int flags); -typedef int (Tcl_DriverInputProc) (void *instanceData, char *buf, - int toRead, int *errorCodePtr); -typedef int (Tcl_DriverOutputProc) (void *instanceData, - const char *buf, int toWrite, int *errorCodePtr); -typedef void Tcl_DriverSeekProc; -typedef int (Tcl_DriverSetOptionProc) (void *instanceData, - Tcl_Interp *interp, const char *optionName, - const char *value); -typedef int (Tcl_DriverGetOptionProc) (void *instanceData, - Tcl_Interp *interp, const char *optionName, - Tcl_DString *dsPtr); -typedef void (Tcl_DriverWatchProc) (void *instanceData, int mask); -typedef int (Tcl_DriverGetHandleProc) (void *instanceData, - int direction, void **handlePtr); -typedef int (Tcl_DriverFlushProc) (void *instanceData); -typedef int (Tcl_DriverHandlerProc) (void *instanceData, - int interestMask); -typedef Tcl_WideInt (Tcl_DriverWideSeekProc) (void *instanceData, - Tcl_WideInt offset, int mode, int *errorCodePtr); +typedef int (Tcl_DriverBlockModeProc) _ANSI_ARGS_(( + ClientData instanceData, int mode)); +typedef int (Tcl_DriverCloseProc) _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp)); +typedef int (Tcl_DriverClose2Proc) _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp, int flags)); +typedef int (Tcl_DriverInputProc) _ANSI_ARGS_((ClientData instanceData, + char *buf, int toRead, int *errorCodePtr)); +typedef int (Tcl_DriverOutputProc) _ANSI_ARGS_((ClientData instanceData, + CONST84 char *buf, int toWrite, int *errorCodePtr)); +typedef int (Tcl_DriverSeekProc) _ANSI_ARGS_((ClientData instanceData, + long offset, int mode, int *errorCodePtr)); +typedef int (Tcl_DriverSetOptionProc) _ANSI_ARGS_(( + ClientData instanceData, Tcl_Interp *interp, + CONST char *optionName, CONST char *value)); +typedef int (Tcl_DriverGetOptionProc) _ANSI_ARGS_(( + ClientData instanceData, Tcl_Interp *interp, + CONST84 char *optionName, Tcl_DString *dsPtr)); +typedef void (Tcl_DriverWatchProc) _ANSI_ARGS_(( + ClientData instanceData, int mask)); +typedef int (Tcl_DriverGetHandleProc) _ANSI_ARGS_(( + ClientData instanceData, int direction, + ClientData *handlePtr)); +typedef int (Tcl_DriverFlushProc) _ANSI_ARGS_((ClientData instanceData)); +typedef int (Tcl_DriverHandlerProc) _ANSI_ARGS_(( + ClientData instanceData, int interestMask)); +typedef Tcl_WideInt (Tcl_DriverWideSeekProc) _ANSI_ARGS_(( + ClientData instanceData, Tcl_WideInt offset, + int mode, int *errorCodePtr)); /* * TIP #218, Channel Thread Actions */ -typedef void (Tcl_DriverThreadActionProc) (void *instanceData, - int action); +typedef void (Tcl_DriverThreadActionProc) _ANSI_ARGS_ (( + ClientData instanceData, int action)); /* * TIP #208, File Truncation (etc.) */ -typedef int (Tcl_DriverTruncateProc) (void *instanceData, - Tcl_WideInt length); +typedef int (Tcl_DriverTruncateProc) _ANSI_ARGS_(( + ClientData instanceData, Tcl_WideInt length)); /* * struct Tcl_ChannelType: * * One such structure exists for each type (kind) of channel. It collects @@ -1288,23 +1479,26 @@ * It is recommend that the Tcl_Channel* functions are used to access elements * of this structure, instead of direct accessing. */ typedef struct Tcl_ChannelType { - const char *typeName; /* The name of the channel type in Tcl + char *typeName; /* The name of the channel type in Tcl * commands. This storage is owned by channel * type. */ Tcl_ChannelTypeVersion version; /* Version of the channel type. */ - void *closeProc; - /* Not used any more. */ + Tcl_DriverCloseProc *closeProc; + /* Function to call to close the channel, 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. */ - void *seekProc; - /* Not used any more. */ + Tcl_DriverSeekProc *seekProc; + /* Function to call to seek on the channel. + * May be NULL. */ Tcl_DriverSetOptionProc *setOptionProc; /* Set an option on a channel. */ Tcl_DriverGetOptionProc *getOptionProc; /* Get an option from a channel. */ Tcl_DriverWatchProc *watchProc; @@ -1318,26 +1512,41 @@ * the device supports closing the read & * write sides independently. */ Tcl_DriverBlockModeProc *blockModeProc; /* Set blocking mode for the raw channel. May * be NULL. */ + /* + * Only valid in TCL_CHANNEL_VERSION_2 channels or later. + */ Tcl_DriverFlushProc *flushProc; /* Function to call to flush a channel. May be * NULL. */ Tcl_DriverHandlerProc *handlerProc; /* Function to call to handle a channel event. * This will be passed up the stacked channel * chain. */ + /* + * Only valid in TCL_CHANNEL_VERSION_3 channels or later. + */ Tcl_DriverWideSeekProc *wideSeekProc; /* Function to call to seek on the channel * which can handle 64-bit offsets. May be * NULL, and must be NULL if seekProc is * NULL. */ + /* + * Only valid in TCL_CHANNEL_VERSION_4 channels or later. + * TIP #218, Channel Thread Actions. + */ Tcl_DriverThreadActionProc *threadActionProc; /* Function to call to notify the driver of * thread specific activity for a channel. May * be NULL. */ + + /* + * Only valid in TCL_CHANNEL_VERSION_5 channels or later. + * TIP #208, File Truncation. + */ Tcl_DriverTruncateProc *truncateProc; /* Function to call to truncate the underlying * file to a particular length. May be NULL if * the channel does not support truncation. */ } Tcl_ChannelType; @@ -1351,11 +1560,10 @@ #define TCL_MODE_BLOCKING 0 /* Put channel into blocking mode. */ #define TCL_MODE_NONBLOCKING 1 /* Put channel into nonblocking * mode. */ /* - *---------------------------------------------------------------------------- * Enum for different types of file paths. */ typedef enum Tcl_PathType { TCL_PATH_ABSOLUTE, @@ -1403,198 +1611,237 @@ /* * Typedefs for the various filesystem operations: */ -typedef int (Tcl_FSStatProc) (Tcl_Obj *pathPtr, Tcl_StatBuf *buf); -typedef int (Tcl_FSAccessProc) (Tcl_Obj *pathPtr, int mode); -typedef Tcl_Channel (Tcl_FSOpenFileChannelProc) (Tcl_Interp *interp, - Tcl_Obj *pathPtr, int mode, int permissions); -typedef int (Tcl_FSMatchInDirectoryProc) (Tcl_Interp *interp, Tcl_Obj *result, - Tcl_Obj *pathPtr, const char *pattern, Tcl_GlobTypeData *types); -typedef Tcl_Obj * (Tcl_FSGetCwdProc) (Tcl_Interp *interp); -typedef int (Tcl_FSChdirProc) (Tcl_Obj *pathPtr); -typedef int (Tcl_FSLstatProc) (Tcl_Obj *pathPtr, Tcl_StatBuf *buf); -typedef int (Tcl_FSCreateDirectoryProc) (Tcl_Obj *pathPtr); -typedef int (Tcl_FSDeleteFileProc) (Tcl_Obj *pathPtr); -typedef int (Tcl_FSCopyDirectoryProc) (Tcl_Obj *srcPathPtr, - Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr); -typedef int (Tcl_FSCopyFileProc) (Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr); -typedef int (Tcl_FSRemoveDirectoryProc) (Tcl_Obj *pathPtr, int recursive, - Tcl_Obj **errorPtr); -typedef int (Tcl_FSRenameFileProc) (Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr); -typedef void (Tcl_FSUnloadFileProc) (Tcl_LoadHandle loadHandle); -typedef Tcl_Obj * (Tcl_FSListVolumesProc) (void); +typedef int (Tcl_FSStatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *buf)); +typedef int (Tcl_FSAccessProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, int mode)); +typedef Tcl_Channel (Tcl_FSOpenFileChannelProc) _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode, int permissions)); +typedef int (Tcl_FSMatchInDirectoryProc) _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *result, Tcl_Obj *pathPtr, CONST char *pattern, + Tcl_GlobTypeData * types)); +typedef Tcl_Obj * (Tcl_FSGetCwdProc) _ANSI_ARGS_((Tcl_Interp *interp)); +typedef int (Tcl_FSChdirProc) _ANSI_ARGS_((Tcl_Obj *pathPtr)); +typedef int (Tcl_FSLstatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, + Tcl_StatBuf *buf)); +typedef int (Tcl_FSCreateDirectoryProc) _ANSI_ARGS_((Tcl_Obj *pathPtr)); +typedef int (Tcl_FSDeleteFileProc) _ANSI_ARGS_((Tcl_Obj *pathPtr)); +typedef int (Tcl_FSCopyDirectoryProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr)); +typedef int (Tcl_FSCopyFileProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr)); +typedef int (Tcl_FSRemoveDirectoryProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, + int recursive, Tcl_Obj **errorPtr)); +typedef int (Tcl_FSRenameFileProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr)); +typedef void (Tcl_FSUnloadFileProc) _ANSI_ARGS_((Tcl_LoadHandle loadHandle)); +typedef Tcl_Obj * (Tcl_FSListVolumesProc) _ANSI_ARGS_((void)); /* 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 *const * (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, - void **clientDataPtr); -typedef Tcl_Obj * (Tcl_FSFilesystemPathTypeProc) (Tcl_Obj *pathPtr); -typedef Tcl_Obj * (Tcl_FSFilesystemSeparatorProc) (Tcl_Obj *pathPtr); -#define Tcl_FSFreeInternalRepProc Tcl_FreeProc -typedef void *(Tcl_FSDupInternalRepProc) (void *clientData); -typedef Tcl_Obj * (Tcl_FSInternalToNormalizedProc) (void *clientData); -typedef void *(Tcl_FSCreateInternalRepProc) (Tcl_Obj *pathPtr); +typedef int (Tcl_FSUtimeProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, + struct utimbuf *tval)); +typedef int (Tcl_FSNormalizePathProc) _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *pathPtr, int nextCheckpoint)); +typedef int (Tcl_FSFileAttrsGetProc) _ANSI_ARGS_((Tcl_Interp *interp, + int index, Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef)); +typedef CONST char ** (Tcl_FSFileAttrStringsProc) _ANSI_ARGS_(( + Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef)); +typedef int (Tcl_FSFileAttrsSetProc) _ANSI_ARGS_((Tcl_Interp *interp, + int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr)); +typedef Tcl_Obj * (Tcl_FSLinkProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, + Tcl_Obj *toPtr, int linkType)); +typedef int (Tcl_FSLoadFileProc) _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_Obj *pathPtr, Tcl_LoadHandle *handlePtr, + Tcl_FSUnloadFileProc **unloadProcPtr)); +typedef int (Tcl_FSPathInFilesystemProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, + ClientData *clientDataPtr)); +typedef Tcl_Obj * (Tcl_FSFilesystemPathTypeProc) _ANSI_ARGS_(( + Tcl_Obj *pathPtr)); +typedef Tcl_Obj * (Tcl_FSFilesystemSeparatorProc) _ANSI_ARGS_(( + Tcl_Obj *pathPtr)); +typedef void (Tcl_FSFreeInternalRepProc) _ANSI_ARGS_((ClientData clientData)); +typedef ClientData (Tcl_FSDupInternalRepProc) _ANSI_ARGS_(( + ClientData clientData)); +typedef Tcl_Obj * (Tcl_FSInternalToNormalizedProc) _ANSI_ARGS_(( + ClientData clientData)); +typedef ClientData (Tcl_FSCreateInternalRepProc) _ANSI_ARGS_(( + 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 + * together in one place all the functions that are part of the specific * 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. */ - size_t structureLength; /* Length of this structure, so future binary + 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 + /* Function to check whether a path 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. */ + /* Function to duplicate internal fs rep. May + * be NULL (but then fs is less efficient). */ + Tcl_FSFreeInternalRepProc *freeInternalRepProc; + /* Function to free internal fs rep. Must be + * implemented if internal representations + * need freeing, otherwise it can be NULL. */ + Tcl_FSInternalToNormalizedProc *internalToNormalizedProc; + /* Function to convert internal representation + * to a normalized path. Only required if the + * fs creates pure path objects with no + * string/path representation. */ + Tcl_FSCreateInternalRepProc *createInternalRepProc; + /* Function to create a filesystem-specific + * internal representation. May be NULL if + * paths have no internal representation, or + * if the Tcl_FSPathInFilesystemProc for this + * filesystem always immediately creates an + * internal representation for paths it + * accepts. */ + Tcl_FSNormalizePathProc *normalizePathProc; + /* Function to normalize a path. Should be + * implemented for all filesystems which can + * have multiple string representations for + * the same path object. */ + Tcl_FSFilesystemPathTypeProc *filesystemPathTypeProc; + /* Function to determine the type of a path in + * this filesystem. May be NULL. */ + Tcl_FSFilesystemSeparatorProc *filesystemSeparatorProc; + /* Function to return the separator + * character(s) for this filesystem. Must be + * implemented. */ + Tcl_FSStatProc *statProc; /* Function to process a 'Tcl_FSStat()' call. + * Must be implemented for any reasonable + * filesystem. */ + Tcl_FSAccessProc *accessProc; + /* Function to process a 'Tcl_FSAccess()' + * call. Must be implemented for any + * reasonable filesystem. */ + Tcl_FSOpenFileChannelProc *openFileChannelProc; + /* Function to process a + * 'Tcl_FSOpenFileChannel()' call. Must be + * implemented for any reasonable + * filesystem. */ + Tcl_FSMatchInDirectoryProc *matchInDirectoryProc; + /* Function to process a + * 'Tcl_FSMatchInDirectory()'. If not + * implemented, then glob and recursive copy + * functionality will be lacking in the + * filesystem. */ + Tcl_FSUtimeProc *utimeProc; /* Function to process a 'Tcl_FSUtime()' call. + * Required to allow setting (not reading) of + * times with 'file mtime', 'file atime' and + * the open-r/open-w/fcopy implementation of + * 'file copy'. */ + Tcl_FSLinkProc *linkProc; /* Function to process a 'Tcl_FSLink()' call. + * Should be implemented only if the + * filesystem supports links (reading or + * creating). */ + Tcl_FSListVolumesProc *listVolumesProc; + /* Function to list any filesystem volumes + * added by this filesystem. Should be + * implemented only if the filesystem adds + * volumes at the head of the filesystem. */ + Tcl_FSFileAttrStringsProc *fileAttrStringsProc; + /* Function to list all attributes strings + * which are valid for this filesystem. If not + * implemented the filesystem will not support + * the 'file attributes' command. This allows + * arbitrary additional information to be + * attached to files in the filesystem. */ + Tcl_FSFileAttrsGetProc *fileAttrsGetProc; + /* Function to process a + * 'Tcl_FSFileAttrsGet()' call, used by 'file + * attributes'. */ + Tcl_FSFileAttrsSetProc *fileAttrsSetProc; + /* Function to process a + * 'Tcl_FSFileAttrsSet()' call, used by 'file + * attributes'. */ + Tcl_FSCreateDirectoryProc *createDirectoryProc; + /* Function to process a + * 'Tcl_FSCreateDirectory()' call. Should be + * implemented unless the FS is read-only. */ + Tcl_FSRemoveDirectoryProc *removeDirectoryProc; + /* Function to process a + * 'Tcl_FSRemoveDirectory()' call. Should be + * implemented unless the FS is read-only. */ + Tcl_FSDeleteFileProc *deleteFileProc; + /* Function to process a 'Tcl_FSDeleteFile()' + * call. Should be implemented unless the FS + * is read-only. */ + Tcl_FSCopyFileProc *copyFileProc; + /* Function to process a 'Tcl_FSCopyFile()' + * call. If not implemented Tcl will fall back + * on open-r, open-w and fcopy as a copying + * mechanism, for copying actions initiated in + * Tcl (not C). */ + Tcl_FSRenameFileProc *renameFileProc; + /* Function to process a 'Tcl_FSRenameFile()' + * call. If not implemented, Tcl will fall + * back on a copy and delete mechanism, for + * rename actions initiated in Tcl (not C). */ + Tcl_FSCopyDirectoryProc *copyDirectoryProc; + /* Function to process a + * 'Tcl_FSCopyDirectory()' call. If not + * implemented, Tcl will fall back on a + * recursive create-dir, file copy mechanism, + * for copying actions initiated in Tcl (not + * C). */ + Tcl_FSLstatProc *lstatProc; /* Function to process a 'Tcl_FSLstat()' call. + * If not implemented, Tcl will attempt to use + * the 'statProc' defined above instead. */ + Tcl_FSLoadFileProc *loadFileProc; + /* Function to process a 'Tcl_FSLoadFile()' + * call. If not implemented, Tcl will fall + * back on a copy to native-temp followed by a + * Tcl_FSLoadFile on that temporary copy. */ + Tcl_FSGetCwdProc *getCwdProc; + /* Function to process a 'Tcl_FSGetCwd()' + * call. Most filesystems need not implement + * this. It will usually only be called once, + * if 'getcwd' is called before 'chdir'. May + * be NULL. */ + Tcl_FSChdirProc *chdirProc; /* Function to process a 'Tcl_FSChdir()' call. + * If filesystems do not implement this, it + * will be emulated by a series of directory + * access checks. Otherwise, virtual + * filesystems which do implement it need only + * respond with a positive return result if + * the dirName is a valid directory in their + * filesystem. They need not remember the + * result, since that will be automatically + * remembered for use by GetCwd. Real + * filesystems should carry out the correct + * action (i.e. call the correct system + * 'chdir' api). If not implemented, then 'cd' + * and 'pwd' will fail inside the + * filesystem. */ } 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 @@ -1607,11 +1854,10 @@ #define TCL_CREATE_SYMBOLIC_LINK 0x01 #define TCL_CREATE_HARD_LINK 0x02 /* - *---------------------------------------------------------------------------- * The following structure represents the Notifier functions that you can * override with the Tcl_SetNotifier call. */ typedef struct Tcl_NotifierProcs { @@ -1622,26 +1868,88 @@ Tcl_InitNotifierProc *initNotifierProc; Tcl_FinalizeNotifierProc *finalizeNotifierProc; Tcl_AlertNotifierProc *alertNotifierProc; Tcl_ServiceModeHookProc *serviceModeHookProc; } Tcl_NotifierProcs; - + +/* + * The following structure represents a user-defined encoding. It collects + * together all the functions that are used by the specific encoding. + */ + +typedef struct Tcl_EncodingType { + CONST char *encodingName; /* The name of the encoding, e.g. "euc-jp". + * This name is the unique key for this + * 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; + /* - *---------------------------------------------------------------------------- - * The following data structures and declarations are for the new Tcl parser. + * The following definitions are used as values for the conversion control + * flags argument when converting text from one character set to another: * + * TCL_ENCODING_START - Signifies that the source buffer is the first + * block in a (potentially multi-block) input + * stream. Tells the conversion function to reset + * to an initial state and perform any + * initialization that needs to occur before the + * first byte is converted. If the source buffer + * contains the entire input stream to be + * converted, this flag should be set. + * TCL_ENCODING_END - Signifies that the source buffer is the last + * 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, then the converter will return + * immediately upon encountering an invalid byte + * sequence or a source character that has no + * mapping in the target encoding. If clear, then + * the converter will skip the problem, + * substituting one or more "close" characters in + * the destination buffer and then continue to + * convert the source. + */ + +#define TCL_ENCODING_START 0x01 +#define TCL_ENCODING_END 0x02 +#define TCL_ENCODING_STOPONERROR 0x04 + +/* + * The following data structures and declarations are for the new Tcl parser. + */ + +/* * For each word of a command, and for each piece of a word such as a variable * reference, one of the following structures is created to describe the * 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. */ - size_t size; /* Number of bytes in token. */ - size_t numComponents; /* If this token is composed of other tokens, + 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; @@ -1749,17 +2057,17 @@ */ #define NUM_STATIC_TOKENS 20 typedef struct Tcl_Parse { - const char *commentStart; /* Pointer to # that begins the first of one + CONST char *commentStart; /* Pointer to # that begins the first of one * or more comments preceding the command. */ - size_t commentSize; /* Number of bytes in comments (up through + 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 + 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 * terminating newline, close bracket, or * semicolon. */ @@ -1779,17 +2087,17 @@ /* * The fields below are intended only for the private use of the parser. * They should not be used by functions that invoke Tcl_ParseCommand. */ - const char *string; /* The original command string passed to + CONST char *string; /* The original command string passed to * Tcl_ParseCommand. */ - const char *end; /* Points to the character just after the last + CONST char *end; /* Points to the character just after the last * one in the command string. */ Tcl_Interp *interp; /* Interpreter to use for error reporting, or * NULL. */ - const char *term; /* Points to character in string that + CONST char *term; /* Points to character in string that * terminated most recent token. Filled in by * ParseTokens. If an error occurs, points to * beginning of region where the error * occurred (e.g. the open brace if the close * brace is missing). */ @@ -1802,88 +2110,10 @@ * space should be large enough to accommodate * most commands; dynamic space is allocated * for very large commands that don't fit * here. */ } Tcl_Parse; - -/* - *---------------------------------------------------------------------------- - * The following structure represents a user-defined encoding. It collects - * together all the functions that are used by the specific encoding. - */ - -typedef struct Tcl_EncodingType { - const char *encodingName; /* The name of the encoding, e.g. "euc-jp". - * This name is the unique key for this - * encoding type. */ - Tcl_EncodingConvertProc *toUtfProc; - /* Function to convert from external encoding - * into UTF-8. */ - Tcl_EncodingConvertProc *fromUtfProc; - /* Function to convert from UTF-8 into - * external encoding. */ - Tcl_FreeProc *freeProc; - /* If non-NULL, function to call when this - * encoding is deleted. */ - void *clientData; /* Arbitrary value associated with encoding - * type. Passed to conversion functions. */ - 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; - -/* - * The following definitions are used as values for the conversion control - * flags argument when converting text from one character set to another: - * - * TCL_ENCODING_START - Signifies that the source buffer is the first - * block in a (potentially multi-block) input - * stream. Tells the conversion function to reset - * to an initial state and perform any - * initialization that needs to occur before the - * first byte is converted. If the source buffer - * contains the entire input stream to be - * converted, this flag should be set. - * TCL_ENCODING_END - Signifies that the source buffer is the last - * 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 /* * The following definitions are the error codes returned by the conversion * routines: * @@ -1909,59 +2139,60 @@ * could not be represented in the target * encoding. This error is reported only if * TCL_ENCODING_STOPONERROR was specified. */ -#define TCL_CONVERT_MULTIBYTE (-1) -#define TCL_CONVERT_SYNTAX (-2) -#define TCL_CONVERT_UNKNOWN (-3) -#define TCL_CONVERT_NOSPACE (-4) +#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 4-bytes in size (UCS-4) (the default). If == 3, - * then Tcl_UniChar must be 2-bytes in size (UTF-16). Since Tcl 9.0, UCS-4 - * mode is the default and recommended mode. + * Unicode character in UTF-8. The valid values should be 3 or 6 (or perhaps 1 + * if we want to support a non-unicode enabled core). If 3, then Tcl_UniChar + * must be 2-bytes in size (UCS-2) (the default). If 6, then Tcl_UniChar must + * be 4-bytes in size (UCS-4). At this time UCS-2 mode is the default and + * recommended mode. UCS-4 is experimental and not recommended. It works for + * the core, but most extensions expect UCS-2. */ #ifndef TCL_UTF_MAX -#define TCL_UTF_MAX 4 +#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. + * unsigned int isn't 100% accurate as it should be a strict 4-byte value. + * The size of this value must be reflected correctly in regcustom.h. + * XXX: Tcl is currently UCS-2 and planning UTF-16 for the Unicode + * XXX: string rep that Tcl_UniChar represents. Changing the size + * XXX: of Tcl_UniChar is /not/ supported. */ -typedef int Tcl_UniChar; +typedef unsigned int Tcl_UniChar; #else typedef unsigned short Tcl_UniChar; #endif - + /* - *---------------------------------------------------------------------------- * TIP #59: The following structure is used in calls 'Tcl_RegisterConfig' to * provide the system with the embedded configuration data. */ typedef struct Tcl_Config { - const char *key; /* Configuration key to register. ASCII + CONST char *key; /* Configuration key to register. ASCII * encoded, thus UTF-8. */ - const char *value; /* The value associated with the key. System + CONST char *value; /* The value associated with the key. System * encoding. */ } Tcl_Config; /* - *---------------------------------------------------------------------------- * Flags for TIP#143 limits, detailing which limits are active in an * interpreter. Used for Tcl_{Add,Remove}LimitHandler type argument. */ #define TCL_LIMIT_COMMANDS 0x01 @@ -1970,288 +2201,112 @@ /* * 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) (void *clientData, Tcl_Interp *interp); -typedef void (Tcl_LimitHandlerDeleteProc) (void *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 or including here. But the libtommath project - * didn't honor our request. See: - * - * 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 +typedef void (Tcl_LimitHandlerProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp)); +typedef void (Tcl_LimitHandlerDeleteProc) _ANSI_ARGS_((ClientData clientData)); + +typedef struct mp_int mp_int; #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. */ - void *clientData; /* Word to pass to function callbacks. */ -} Tcl_ArgvInfo; - -/* - * Legal values for the type field of a Tcl_ArgInfo: see the user - * documentation for details. - */ - -#define TCL_ARGV_CONSTANT 15 -#define TCL_ARGV_INT 16 -#define TCL_ARGV_STRING 17 -#define TCL_ARGV_REST 18 -#define TCL_ARGV_FLOAT 19 -#define TCL_ARGV_FUNC 20 -#define TCL_ARGV_GENFUNC 21 -#define TCL_ARGV_HELP 22 -#define TCL_ARGV_END 23 - -/* - * Types of callback functions for the TCL_ARGV_FUNC and TCL_ARGV_GENFUNC - * argument types: - */ - -typedef int (Tcl_ArgvFuncProc)(void *clientData, Tcl_Obj *objPtr, - void *dstPtr); -typedef int (Tcl_ArgvGenFuncProc)(void *clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const *objv, void *dstPtr); - -/* - * Shorthand for commonly used argTable entries. - */ - -#define TCL_ARGV_AUTO_HELP \ - {TCL_ARGV_HELP, "-help", NULL, NULL, \ - "Print summary of command-line options and abort", NULL} -#define TCL_ARGV_AUTO_REST \ - {TCL_ARGV_REST, "--", NULL, NULL, \ - "Marks the end of the options", NULL} -#define TCL_ARGV_TABLE_END \ - {TCL_ARGV_END, NULL, NULL, NULL, NULL, NULL} - -/* - *---------------------------------------------------------------------------- - * Definitions needed for Tcl_Zlib routines. [TIP #234] - * - * Constants for the format flags describing what sort of data format is - * desired/expected for the Tcl_ZlibDeflate, Tcl_ZlibInflate and - * Tcl_ZlibStreamInit functions. - */ - -#define TCL_ZLIB_FORMAT_RAW 1 -#define TCL_ZLIB_FORMAT_ZLIB 2 -#define TCL_ZLIB_FORMAT_GZIP 4 -#define TCL_ZLIB_FORMAT_AUTO 8 - -/* - * Constants that describe whether the stream is to operate in compressing or - * decompressing mode. - */ - -#define TCL_ZLIB_STREAM_DEFLATE 16 -#define TCL_ZLIB_STREAM_INFLATE 32 - -/* - * Constants giving compression levels. Use of TCL_ZLIB_COMPRESS_DEFAULT is - * recommended. - */ - -#define TCL_ZLIB_COMPRESS_NONE 0 -#define TCL_ZLIB_COMPRESS_FAST 1 -#define TCL_ZLIB_COMPRESS_BEST 9 -#define TCL_ZLIB_COMPRESS_DEFAULT (-1) - -/* - * Constants for types of flushing, used with Tcl_ZlibFlush. - */ - -#define TCL_ZLIB_NO_FLUSH 0 -#define TCL_ZLIB_FLUSH 2 -#define TCL_ZLIB_FULLFLUSH 3 -#define TCL_ZLIB_FINALIZE 4 - -/* - *---------------------------------------------------------------------------- - * Definitions needed for the Tcl_LoadFile function. [TIP #416] - */ - -#define TCL_LOAD_GLOBAL 1 -#define TCL_LOAD_LAZY 2 - -/* - *---------------------------------------------------------------------------- - * Definitions needed for the Tcl_OpenTcpServerEx function. [TIP #456] - */ -#define TCL_TCPSERVER_REUSEADDR (1<<0) -#define TCL_TCPSERVER_REUSEPORT (1<<1) - -/* - * Constants for special size_t-typed values, see TIP #494 - */ - -#define TCL_IO_FAILURE ((size_t)-1) -#define TCL_AUTO_LENGTH ((size_t)-1) -#define TCL_INDEX_NONE ((size_t)-1) - -/* - *---------------------------------------------------------------------------- - * Single public declaration for NRE. - */ - -typedef int (Tcl_NRPostProc) (void *data[], Tcl_Interp *interp, - int result); - -/* - *---------------------------------------------------------------------------- +typedef unsigned int mp_digit; +#define MP_DIGIT_DECLARED + +/* * The following constant is used to test for older versions of Tcl in the * stubs tables. + * + * Jan Nijtman's plus patch uses 0xFCA1BACF, so we need to pick a different + * value since the stubs tables don't match. */ -#define TCL_STUB_MAGIC ((int) 0xFCA3BACB + (int) sizeof(void *)) +#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_NORETURN1 void Tcl_ConsolePanic(const char *format, ...); -#else -# define Tcl_ConsolePanic NULL -#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), \ - TCL_STUB_MAGIC) -#else -# define Tcl_InitStubs(interp, version, exact) \ - (Tcl_InitStubs)(interp, TCL_PATCH_LEVEL, \ - 1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ - TCL_STUB_MAGIC) -#endif -#else -#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE -# define Tcl_InitStubs(interp, version, exact) \ - Tcl_PkgInitStubsCheck(interp, version, \ - (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) -#else -# define Tcl_InitStubs(interp, version, exact) \ - Tcl_PkgInitStubsCheck(interp, TCL_PATCH_LEVEL, \ - 1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) -#endif -#endif +EXTERN CONST char * Tcl_InitStubs _ANSI_ARGS_((Tcl_Interp *interp, + CONST char *version, int exact)); +EXTERN CONST char * TclTomMathInitializeStubs _ANSI_ARGS_(( + Tcl_Interp *interp, CONST char *version, + int epoch, int revision)); + +#ifndef USE_TCL_STUBS + +/* + * When not using stubs, make it a macro. + */ + +#define Tcl_InitStubs(interp, version, exact) \ + Tcl_PkgInitStubsCheck(interp, version, exact) + +#endif + + /* + * TODO - tommath stubs export goes here! + */ + /* * Public functions that are not accessible via the stubs table. * Tcl_GetMemoryInfo is needed for AOLserver. [Bug 1868171] */ -#define Tcl_Main(argc, argv, proc) Tcl_MainEx(argc, argv, proc, \ - ((Tcl_SetPanicProc(Tcl_ConsolePanic), Tcl_CreateInterp)())) -EXTERN TCL_NORETURN void Tcl_MainEx(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); -EXTERN void Tcl_FindExecutable(const char *argv0); -EXTERN void Tcl_SetPanicProc( - TCL_NORETURN1 Tcl_PanicProc *panicProc); -EXTERN void Tcl_StaticPackage(Tcl_Interp *interp, - const char *pkgName, - Tcl_PackageInitProc *initProc, - Tcl_PackageInitProc *safeInitProc); -EXTERN Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc); -#ifdef _WIN32 -EXTERN int TclZipfs_AppHook(int *argc, wchar_t ***argv); -#else -EXTERN int TclZipfs_AppHook(int *argc, char ***argv); +EXTERN void Tcl_Main _ANSI_ARGS_((int argc, char **argv, + Tcl_AppInitProc *appInitProc)); +EXTERN CONST char * Tcl_PkgInitStubsCheck _ANSI_ARGS_((Tcl_Interp *interp, + CONST char *version, int exact)); +#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) +EXTERN void Tcl_GetMemoryInfo _ANSI_ARGS_((Tcl_DString *dsPtr)); #endif - + /* - *---------------------------------------------------------------------------- * Include the public function declarations that are accessible via the stubs * table. */ #include "tclDecls.h" /* * Include platform specific public function declarations that are accessible - * via the stubs table. Make all TclOO symbols MODULE_SCOPE (which only - * has effect on building it as a shared library). See ticket [3010352]. + * via the stubs table. */ -#if defined(BUILD_tcl) -# undef TCLAPI -# define TCLAPI MODULE_SCOPE -#endif - #include "tclPlatDecls.h" /* - *---------------------------------------------------------------------------- - * The following declarations map ckalloc and ckfree to Tcl_Alloc and - * Tcl_Free for use in Tcl-8.x-compatible extensions. + * 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. */ -#ifndef BUILD_tcl -# define ckalloc Tcl_Alloc -# define attemptckalloc Tcl_AttemptAlloc -# ifdef _MSC_VER - /* Silence invalid C4090 warnings */ -# define ckfree(a) Tcl_Free((char *)(a)) -# define ckrealloc(a,b) Tcl_Realloc((char *)(a),(b)) -# define attemptckrealloc(a,b) Tcl_AttemptRealloc((char *)(a),(b)) -# else -# define ckfree Tcl_Free -# define ckrealloc Tcl_Realloc -# define attemptckrealloc Tcl_AttemptRealloc -# endif -#endif - -#ifndef TCL_MEM_DEBUG +#ifdef TCL_MEM_DEBUG + +# define ckalloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__) +# define ckfree(x) Tcl_DbCkfree(x, __FILE__, __LINE__) +# define ckrealloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__) +# define attemptckalloc(x) Tcl_AttemptDbCkalloc(x, __FILE__, __LINE__) +# define attemptckrealloc(x,y) Tcl_AttemptDbCkrealloc((x), (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) Tcl_Alloc(x) +# define ckfree(x) Tcl_Free(x) +# define ckrealloc(x,y) Tcl_Realloc(x,y) +# define attemptckalloc(x) Tcl_AttemptAlloc(x) +# define attemptckrealloc(x,y) Tcl_AttemptRealloc(x,y) # undef Tcl_InitMemory # define Tcl_InitMemory(x) # undef Tcl_DumpActiveMemory # define Tcl_DumpActiveMemory(x) # undef Tcl_ValidateAllMemory @@ -2258,36 +2313,30 @@ # 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) { \ + if (--(_objPtr)->refCount <= 0) { \ TclFreeObj(_objPtr); \ } \ } while(0) -# undef Tcl_IsShared # define Tcl_IsShared(objPtr) \ ((objPtr)->refCount > 1) #endif /* @@ -2300,20 +2349,26 @@ # undef Tcl_NewBignumObj # define Tcl_NewBignumObj(val) \ Tcl_DbNewBignumObj(val, __FILE__, __LINE__) # undef Tcl_NewBooleanObj # define Tcl_NewBooleanObj(val) \ - Tcl_DbNewWideIntObj((val)!=0, __FILE__, __LINE__) + Tcl_DbNewBooleanObj(val, __FILE__, __LINE__) # undef Tcl_NewByteArrayObj # define Tcl_NewByteArrayObj(bytes, len) \ Tcl_DbNewByteArrayObj(bytes, len, __FILE__, __LINE__) # undef Tcl_NewDoubleObj # define Tcl_NewDoubleObj(val) \ Tcl_DbNewDoubleObj(val, __FILE__, __LINE__) +# undef Tcl_NewIntObj +# define Tcl_NewIntObj(val) \ + Tcl_DbNewLongObj(val, __FILE__, __LINE__) # undef Tcl_NewListObj # define Tcl_NewListObj(objc, objv) \ Tcl_DbNewListObj(objc, objv, __FILE__, __LINE__) +# undef Tcl_NewLongObj +# define Tcl_NewLongObj(val) \ + Tcl_DbNewLongObj(val, __FILE__, __LINE__) # undef Tcl_NewObj # define Tcl_NewObj() \ Tcl_DbNewObj(__FILE__, __LINE__) # undef Tcl_NewStringObj # define Tcl_NewStringObj(bytes, len) \ @@ -2322,31 +2377,83 @@ # define Tcl_NewWideIntObj(val) \ Tcl_DbNewWideIntObj(val, __FILE__, __LINE__) #endif /* TCL_MEM_DEBUG */ /* - *---------------------------------------------------------------------------- * Macros for clients to use to access fields of hash entries: */ #define Tcl_GetHashValue(h) ((h)->clientData) -#define Tcl_SetHashValue(h, value) ((h)->clientData = (void *) (value)) +#define Tcl_SetHashValue(h, value) ((h)->clientData = (ClientData) (value)) #define Tcl_GetHashKey(tablePtr, h) \ - ((void *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS || \ + ((char *) (((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)) + (*((tablePtr)->findProc))(tablePtr, key) +#undef Tcl_CreateHashEntry #define Tcl_CreateHashEntry(tablePtr, key, newPtr) \ - (*((tablePtr)->createProc))(tablePtr, (const char *)(key), newPtr) + (*((tablePtr)->createProc))(tablePtr, key, newPtr) + +/* + * Macros that eliminate the overhead of the thread synchronization functions + * when compiling without thread support. + */ + +#ifndef TCL_THREADS +#undef Tcl_MutexLock +#define Tcl_MutexLock(mutexPtr) +#undef Tcl_MutexUnlock +#define Tcl_MutexUnlock(mutexPtr) +#undef Tcl_MutexFinalize +#define Tcl_MutexFinalize(mutexPtr) +#undef Tcl_ConditionNotify +#define Tcl_ConditionNotify(condPtr) +#undef Tcl_ConditionWait +#define Tcl_ConditionWait(condPtr, mutexPtr, timePtr) +#undef Tcl_ConditionFinalize +#define Tcl_ConditionFinalize(condPtr) +#endif /* TCL_THREADS */ + +#ifndef TCL_NO_DEPRECATED + /* + * These function have been renamed. The old names are deprecated, but we + * define these macros for backwards compatibilty. + */ + +# 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 +#endif + +/* + * 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. + */ + +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS + +EXTERN int Tcl_AppInit _ANSI_ARGS_((Tcl_Interp *interp)); + +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLIMPORT #endif /* RC_INVOKED */ /* * end block for C++ Index: generic/tclAlloc.c ================================================================== --- generic/tclAlloc.c +++ generic/tclAlloc.c @@ -20,21 +20,21 @@ * Windows and Unix use an alternative allocator when building with threads * that has significantly reduced lock contention. */ #include "tclInt.h" -#if !TCL_THREADS || !defined(USE_THREAD_ALLOC) +#if !defined(TCL_THREADS) || !defined(USE_THREAD_ALLOC) -#if defined(USE_TCLALLOC) && USE_TCLALLOC +#if USE_TCLALLOC /* * We should really make use of AC_CHECK_TYPE(caddr_t) here, but it can wait * until Tcl uses config.h properly. */ #if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__) -typedef size_t caddr_t; +typedef unsigned long caddr_t; #endif /* * The overhead on a block is at least 8 bytes. When free, this space contains * a pointer to the next free block, and the bottom two bits must be zero. @@ -54,11 +54,11 @@ unsigned char index; /* bucket # */ unsigned char unused; /* unused */ unsigned char magic1; /* other magic number */ #ifndef NDEBUG unsigned short rmagic; /* range magic number */ - size_t size; /* actual block size */ + unsigned long size; /* actual block size */ unsigned short unused2; /* padding to 8-byte align */ #endif } ovu; #define overMagic0 ovu.magic0 #define overMagic1 ovu.magic1 @@ -66,15 +66,15 @@ #define rangeCheckMagic ovu.rmagic #define realBlockSize ovu.size }; -#define MAGIC 0xEF /* magic # on accounting info */ +#define MAGIC 0xef /* magic # on accounting info */ #define RMAGIC 0x5555 /* magic # on range info */ #ifndef NDEBUG -#define RSLOP sizeof(unsigned short) +#define RSLOP sizeof (unsigned short) #else #define RSLOP 0 #endif #define OVERHEAD (sizeof(union overhead) + RSLOP) @@ -119,11 +119,11 @@ * initialized. Futhermore, because Tcl_Alloc may be used before anything else * in Tcl, we make this module self-initializing after all with the allocInit * variable. */ -#if TCL_THREADS +#ifdef TCL_THREADS static Tcl_Mutex *allocMutexPtr; #endif static int allocInit = 0; #ifdef MSTATS @@ -131,11 +131,12 @@ /* * numMallocs[i] is the difference between the number of mallocs and frees for * a given block size. */ -static size_t numMallocs[NBUCKETS+1]; +static unsigned int numMallocs[NBUCKETS+1]; +#include #endif #if !defined(NDEBUG) #define ASSERT(p) if (!(p)) Tcl_Panic(# p) #define RANGE_ASSERT(p) if (!(p)) Tcl_Panic(# p) @@ -146,11 +147,11 @@ /* * Prototypes for functions used only in this file. */ -static void MoreCore(size_t bucket); +static void MoreCore(int bucket); /* *------------------------------------------------------------------------- * * TclInitAlloc -- @@ -169,11 +170,11 @@ void TclInitAlloc(void) { if (!allocInit) { allocInit = 1; -#if TCL_THREADS +#ifdef TCL_THREADS allocMutexPtr = Tcl_GetAllocMutex(); #endif } } @@ -247,17 +248,17 @@ * None. * *---------------------------------------------------------------------- */ -void * +char * TclpAlloc( - size_t numBytes) /* Number of bytes to allocate. */ + unsigned int numBytes) /* Number of bytes to allocate. */ { - union overhead *overPtr; - size_t bucket; - size_t amount; + register union overhead *overPtr; + register long bucket; + register unsigned amount; struct block *bigBlockPtr = NULL; if (!allocInit) { /* * We have to make the "self initializing" because Tcl_Alloc may be @@ -272,12 +273,12 @@ * First the simple case: we simple allocate big blocks directly. */ if (numBytes >= MAXMALLOC - OVERHEAD) { if (numBytes <= UINT_MAX - OVERHEAD -sizeof(struct block)) { - bigBlockPtr = TclpSysAlloc( - sizeof(struct block) + OVERHEAD + numBytes); + bigBlockPtr = (struct block *) TclpSysAlloc((unsigned) + (sizeof(struct block) + OVERHEAD + numBytes), 0); } if (bigBlockPtr == NULL) { Tcl_MutexUnlock(allocMutexPtr); return NULL; } @@ -286,11 +287,11 @@ bigBlockPtr->prevPtr = &bigBlocks; bigBlockPtr->nextPtr->prevPtr = bigBlockPtr; overPtr = (union overhead *) (bigBlockPtr + 1); overPtr->overMagic0 = overPtr->overMagic1 = MAGIC; - overPtr->bucketIndex = 0xFF; + overPtr->bucketIndex = 0xff; #ifdef MSTATS numMallocs[NBUCKETS]++; #endif #ifndef NDEBUG @@ -343,11 +344,11 @@ * Remove from linked list */ nextf[bucket] = overPtr->next; overPtr->overMagic0 = overPtr->overMagic1 = MAGIC; - overPtr->bucketIndex = UCHAR(bucket); + overPtr->bucketIndex = (unsigned char) bucket; #ifdef MSTATS numMallocs[bucket]++; #endif @@ -383,31 +384,32 @@ *---------------------------------------------------------------------- */ static void MoreCore( - size_t bucket) /* What bucket to allocate to. */ + int bucket) /* What bucket to allocat 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 */ + register union overhead *overPtr; + register long size; /* size of desired block */ + long amount; /* amount to allocate */ + int 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); + size = 1 << (bucket + 3); ASSERT(size > 0); amount = MAXMALLOC; numBlocks = amount / size; ASSERT(numBlocks*size == amount); - blockPtr = TclpSysAlloc(sizeof(struct block) + amount); + blockPtr = (struct block *) TclpSysAlloc((unsigned) + (sizeof(struct block) + amount), 1); /* no more room! */ if (blockPtr == NULL) { return; } blockPtr->nextPtr = blockList; @@ -443,22 +445,22 @@ *---------------------------------------------------------------------- */ void TclpFree( - void *oldPtr) /* Pointer to memory to free. */ + char *oldPtr) /* Pointer to memory to free. */ { - size_t size; - union overhead *overPtr; + register long size; + register union overhead *overPtr; struct block *bigBlockPtr; if (oldPtr == NULL) { return; } Tcl_MutexLock(allocMutexPtr); - overPtr = (union overhead *)((caddr_t)oldPtr - sizeof(union overhead)); + 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); @@ -466,11 +468,11 @@ } RANGE_ASSERT(overPtr->rangeCheckMagic == RMAGIC); RANGE_ASSERT(BLOCK_END(overPtr) == RMAGIC); size = overPtr->bucketIndex; - if (size == 0xFF) { + if (size == 0xff) { #ifdef MSTATS numMallocs[NBUCKETS]--; #endif bigBlockPtr = (struct block *) overPtr - 1; @@ -506,28 +508,28 @@ * None. * *---------------------------------------------------------------------- */ -void * +char * TclpRealloc( - void *oldPtr, /* Pointer to alloced block. */ - size_t numBytes) /* New size of memory. */ + char *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; + unsigned long maxSize; if (oldPtr == NULL) { return TclpAlloc(numBytes); } Tcl_MutexLock(allocMutexPtr); - overPtr = (union overhead *)((caddr_t)oldPtr - sizeof(union overhead)); + 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); @@ -540,11 +542,11 @@ /* * If the block isn't in a bin, just realloc it. */ - if (i == 0xFF) { + if (i == 0xff) { struct block *prevPtr, *nextPtr; bigBlockPtr = (struct block *) overPtr - 1; prevPtr = bigBlockPtr->prevPtr; nextPtr = bigBlockPtr->nextPtr; bigBlockPtr = (struct block *) TclpSysRealloc(bigBlockPtr, @@ -578,11 +580,11 @@ overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); BLOCK_END(overPtr) = RMAGIC; #endif Tcl_MutexUnlock(allocMutexPtr); - return (void *)(overPtr+1); + return (char *)(overPtr+1); } maxSize = 1 << (i+3); expensive = 0; if (numBytes+OVERHEAD > maxSize) { expensive = 1; @@ -601,11 +603,11 @@ } maxSize -= OVERHEAD; if (maxSize < numBytes) { numBytes = maxSize; } - memcpy(newPtr, oldPtr, numBytes); + memcpy(newPtr, oldPtr, (size_t) numBytes); TclpFree(oldPtr); return newPtr; } /* @@ -642,33 +644,33 @@ #ifdef MSTATS void mstats( char *s) /* Where to write info. */ { - unsigned int i, j; - union overhead *overPtr; - size_t totalFree = 0, totalUsed = 0; + register int i, j; + register union overhead *overPtr; + int 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++) { - fprintf(stderr, " %u", j); + fprintf(stderr, " %d", j); } - totalFree += ((size_t)j) * (1 << (i + 3)); + totalFree += j * (1 << (i + 3)); } fprintf(stderr, "\nused:\t"); for (i = 0; i < NBUCKETS; i++) { - fprintf(stderr, " %" TCL_Z_MODIFIER "u", numMallocs[i]); + fprintf(stderr, " %d", numMallocs[i]); totalUsed += numMallocs[i] * (1 << (i + 3)); } - fprintf(stderr, "\n\tTotal small in use: %" TCL_Z_MODIFIER "u, total free: %" TCL_Z_MODIFIER "u\n", - totalUsed, totalFree); - fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %" TCL_Z_MODIFIER "u\n", + fprintf(stderr, "\n\tTotal small in use: %d, total free: %d\n", + totalUsed, totalFree); + fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n", MAXMALLOC, numMallocs[NBUCKETS]); Tcl_MutexUnlock(allocMutexPtr); } #endif @@ -689,16 +691,15 @@ * None. * *---------------------------------------------------------------------- */ -#undef TclpAlloc -void * +char * TclpAlloc( - size_t numBytes) /* Number of bytes to allocate. */ + unsigned int numBytes) /* Number of bytes to allocate. */ { - return malloc(numBytes); + return (char*) malloc(numBytes); } /* *---------------------------------------------------------------------- * @@ -713,14 +714,13 @@ * None. * *---------------------------------------------------------------------- */ -#undef TclpFree void TclpFree( - void *oldPtr) /* Pointer to memory to free. */ + char *oldPtr) /* Pointer to memory to free. */ { free(oldPtr); return; } @@ -738,16 +738,16 @@ * None. * *---------------------------------------------------------------------- */ -void * +char * TclpRealloc( - void *oldPtr, /* Pointer to alloced block. */ - size_t numBytes) /* New size of memory. */ + char *oldPtr, /* Pointer to alloced block. */ + unsigned int numBytes) /* New size of memory. */ { - return realloc(oldPtr, numBytes); + return (char*) realloc(oldPtr, numBytes); } #endif /* !USE_TCLALLOC */ #endif /* !TCL_THREADS */ DELETED generic/tclAssembly.c Index: generic/tclAssembly.c ================================================================== --- generic/tclAssembly.c +++ /dev/null @@ -1,4355 +0,0 @@ -/* - * tclAssembly.c -- - * - * Assembler for Tcl bytecodes. - * - * This file contains the procedures that convert Tcl Assembly Language (TAL) - * to a sequence of bytecode instructions for the Tcl execution engine. - * - * Copyright (c) 2010 by Ozgur Dogan Ugurlu. - * Copyright (c) 2010 by Kevin B. Kenny. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -/*- - *- THINGS TO DO: - *- More instructions: - *- done - alternate exit point (affects stack and exception range checking) - *- break and continue - if exception ranges can be sorted out. - *- foreach_start4, foreach_step4 - *- returnImm, returnStk - *- expandStart, expandStkTop, invokeExpanded, expandDrop - *- dictFirst, dictNext, dictDone - *- dictUpdateStart, dictUpdateEnd - *- jumpTable testing - *- syntax (?) - *- returnCodeBranch - *- tclooNext, tclooNextClass - */ - -#include "tclInt.h" -#include "tclCompile.h" -#include "tclOOInt.h" -#include - -/* - * Structure that represents a range of instructions in the bytecode. - */ - -typedef struct CodeRange { - int startOffset; /* Start offset in the bytecode array */ - int endOffset; /* End offset in the bytecode array */ -} CodeRange; - -/* - * State identified for a basic block's catch context. - */ - -typedef enum BasicBlockCatchState { - BBCS_UNKNOWN = 0, /* Catch context has not yet been identified */ - BBCS_NONE, /* Block is outside of any catch */ - BBCS_INCATCH, /* Block is within a catch context */ - BBCS_CAUGHT /* Block is within a catch context and - * may be executed after an exception fires */ -} BasicBlockCatchState; - -/* - * Structure that defines a basic block - a linear sequence of bytecode - * instructions with no jumps in or out (including not changing the - * state of any exception range). - */ - -typedef struct BasicBlock { - int originalStartOffset; /* Instruction offset before JUMP1s were - * substituted with JUMP4's */ - int startOffset; /* Instruction offset of the start of the - * block */ - int startLine; /* Line number in the input script of the - * instruction at the start of the block */ - int jumpOffset; /* Bytecode offset of the 'jump' instruction - * that ends the block, or -1 if there is no - * jump. */ - int jumpLine; /* Line number in the input script of the - * 'jump' instruction that ends the block, or - * -1 if there is no jump */ - struct BasicBlock* prevPtr; /* Immediate predecessor of this block */ - struct BasicBlock* predecessor; - /* Predecessor of this block in the spanning - * tree */ - struct BasicBlock* successor1; - /* BasicBlock structure of the following - * block: NULL at the end of the bytecode - * sequence. */ - Tcl_Obj* jumpTarget; /* Jump target label if the jump target is - * unresolved */ - int initialStackDepth; /* Absolute stack depth on entry */ - int minStackDepth; /* Low-water relative stack depth */ - int maxStackDepth; /* High-water relative stack depth */ - int finalStackDepth; /* Relative stack depth on exit */ - enum BasicBlockCatchState catchState; - /* State of the block for 'catch' analysis */ - int catchDepth; /* Number of nested catches in which the basic - * block appears */ - struct BasicBlock* enclosingCatch; - /* BasicBlock structure of the last startCatch - * executed on a path to this block, or NULL - * if there is no enclosing catch */ - int foreignExceptionBase; /* Base index of foreign exceptions */ - int foreignExceptionCount; /* Count of foreign exceptions */ - ExceptionRange* foreignExceptions; - /* ExceptionRange structures for exception - * ranges belonging to embedded scripts and - * expressions in this block */ - JumptableInfo* jtPtr; /* Jump table at the end of this basic block */ - int flags; /* Boolean flags */ -} BasicBlock; - -/* - * Flags that pertain to a basic block. - */ - -enum BasicBlockFlags { - BB_VISITED = (1 << 0), /* Block has been visited in the current - * traversal */ - BB_FALLTHRU = (1 << 1), /* Control may pass from this block to a - * successor */ - BB_JUMP1 = (1 << 2), /* Basic block ends with a 1-byte-offset jump - * and may need expansion */ - BB_JUMPTABLE = (1 << 3), /* Basic block ends with a jump table */ - BB_BEGINCATCH = (1 << 4), /* Block ends with a 'beginCatch' instruction, - * marking it as the start of a 'catch' - * sequence. The 'jumpTarget' is the exception - * exit from the catch block. */ - BB_ENDCATCH = (1 << 5) /* Block ends with an 'endCatch' instruction, - * unwinding the catch from the exception - * stack. */ -}; - -/* - * Source instruction type recognized by the assembler. - */ - -typedef enum { - ASSEM_1BYTE, /* Fixed arity, 1-byte instruction */ - ASSEM_BEGIN_CATCH, /* Begin catch: one 4-byte jump offset to be - * converted to appropriate exception - * ranges */ - ASSEM_BOOL, /* One Boolean operand */ - ASSEM_BOOL_LVT4, /* One Boolean, one 4-byte LVT ref. */ - ASSEM_CLOCK_READ, /* 1-byte unsigned-integer case number, in the - * range 0-3 */ - ASSEM_CONCAT1, /* 1-byte unsigned-integer operand count, must - * be strictly positive, consumes N, produces - * 1 */ - ASSEM_DICT_GET, /* 'dict get' and related - consumes N+1 - * operands, produces 1, N > 0 */ - ASSEM_DICT_SET, /* specifies key count and LVT index, consumes - * N+1 operands, produces 1, N > 0 */ - ASSEM_DICT_UNSET, /* specifies key count and LVT index, consumes - * N operands, produces 1, N > 0 */ - ASSEM_END_CATCH, /* End catch. No args. Exception range popped - * from stack and stack pointer restored. */ - ASSEM_EVAL, /* 'eval' - evaluate a constant script (by - * compiling it in line with the assembly - * code! I love Tcl!) */ - ASSEM_INDEX, /* 4 byte operand, integer or end-integer */ - ASSEM_INVOKE, /* 1- or 4-byte operand count, must be - * strictly positive, consumes N, produces - * 1. */ - ASSEM_JUMP, /* Jump instructions */ - ASSEM_JUMP4, /* Jump instructions forcing a 4-byte offset */ - ASSEM_JUMPTABLE, /* Jumptable (switch -exact) */ - ASSEM_LABEL, /* The assembly directive that defines a - * label */ - ASSEM_LINDEX_MULTI, /* 4-byte operand count, must be strictly - * positive, consumes N, produces 1 */ - ASSEM_LIST, /* 4-byte operand count, must be nonnegative, - * consumses N, produces 1 */ - ASSEM_LSET_FLAT, /* 4-byte operand count, must be >= 3, - * consumes N, produces 1 */ - ASSEM_LVT, /* One operand that references a local - * variable */ - ASSEM_LVT1, /* One 1-byte operand that references a local - * variable */ - ASSEM_LVT1_SINT1, /* One 1-byte operand that references a local - * variable, one signed-integer 1-byte - * operand */ - ASSEM_LVT4, /* One 4-byte operand that references a local - * variable */ - ASSEM_OVER, /* OVER: 4-byte operand count, consumes N+1, - * produces N+2 */ - ASSEM_PUSH, /* one literal operand */ - ASSEM_REGEXP, /* One Boolean operand, but weird mapping to - * call flags */ - ASSEM_REVERSE, /* REVERSE: 4-byte operand count, consumes N, - * produces N */ - ASSEM_SINT1, /* One 1-byte signed-integer operand - * (INCR_STK_IMM) */ - ASSEM_SINT4_LVT4, /* Signed 4-byte integer operand followed by - * LVT entry. Fixed arity */ - ASSEM_DICT_GET_DEF /* 'dict getwithdefault' - consumes N+2 - * operands, produces 1, N > 0 */ -} TalInstType; - -/* - * Description of an instruction recognized by the assembler. - */ - -typedef struct TalInstDesc { - const char *name; /* Name of instruction. */ - TalInstType instType; /* The type of instruction */ - int tclInstCode; /* Instruction code. For instructions having - * 1- and 4-byte variables, tclInstCode is - * ((1byte)<<8) || (4byte) */ - int operandsConsumed; /* Number of operands consumed by the - * operation, or INT_MIN if the operation is - * variadic */ - int operandsProduced; /* Number of operands produced by the - * operation. If negative, the operation has a - * net stack effect of -1-operandsProduced */ -} TalInstDesc; - -/* - * Structure that holds the state of the assembler while generating code. - */ - -typedef struct AssemblyEnv { - CompileEnv* envPtr; /* Compilation environment being used for code - * generation */ - Tcl_Parse* parsePtr; /* Parse of the current line of source */ - Tcl_HashTable labelHash; /* Hash table whose keys are labels and whose - * values are 'label' objects storing the code - * offsets of the labels. */ - int cmdLine; /* Current line number within the assembly - * code */ - int* clNext; /* Invisible continuation line for - * [info frame] */ - BasicBlock* head_bb; /* First basic block in the code */ - BasicBlock* curr_bb; /* Current basic block */ - int maxDepth; /* Maximum stack depth encountered */ - int curCatchDepth; /* Current depth of catches */ - int maxCatchDepth; /* Maximum depth of catches encountered */ - int flags; /* Compilation flags (TCL_EVAL_DIRECT) */ -} AssemblyEnv; - -/* - * Static functions defined in this file. - */ - -static void AddBasicBlockRangeToErrorInfo(AssemblyEnv*, - BasicBlock*); -static BasicBlock * AllocBB(AssemblyEnv*); -static int AssembleOneLine(AssemblyEnv* envPtr); -static void BBAdjustStackDepth(BasicBlock* bbPtr, int consumed, - int produced); -static void BBUpdateStackReqs(BasicBlock* bbPtr, int tblIdx, - int count); -static void BBEmitInstInt1(AssemblyEnv* assemEnvPtr, int tblIdx, - int opnd, int count); -static void BBEmitInstInt4(AssemblyEnv* assemEnvPtr, int tblIdx, - int opnd, int count); -static void BBEmitInst1or4(AssemblyEnv* assemEnvPtr, int tblIdx, - int param, int count); -static void BBEmitOpcode(AssemblyEnv* assemEnvPtr, int tblIdx, - int count); -static int BuildExceptionRanges(AssemblyEnv* assemEnvPtr); -static int CalculateJumpRelocations(AssemblyEnv*, int*); -static int CheckForUnclosedCatches(AssemblyEnv*); -static int CheckForThrowInWrongContext(AssemblyEnv*); -static int CheckNonThrowingBlock(AssemblyEnv*, BasicBlock*); -static int BytecodeMightThrow(unsigned char); -static int CheckJumpTableLabels(AssemblyEnv*, BasicBlock*); -static int CheckNamespaceQualifiers(Tcl_Interp*, const char*, - int); -static int CheckNonNegative(Tcl_Interp*, int); -static int CheckOneByte(Tcl_Interp*, int); -static int CheckSignedOneByte(Tcl_Interp*, int); -static int CheckStack(AssemblyEnv*); -static int CheckStrictlyPositive(Tcl_Interp*, int); -static ByteCode * CompileAssembleObj(Tcl_Interp *interp, - Tcl_Obj *objPtr); -static void CompileEmbeddedScript(AssemblyEnv*, Tcl_Token*, - const TalInstDesc*); -static int DefineLabel(AssemblyEnv* envPtr, const char* label); -static void DeleteMirrorJumpTable(JumptableInfo* jtPtr); -static void FillInJumpOffsets(AssemblyEnv*); -static int CreateMirrorJumpTable(AssemblyEnv* assemEnvPtr, - Tcl_Obj* jumpTable); -static int FindLocalVar(AssemblyEnv* envPtr, - Tcl_Token** tokenPtrPtr); -static int FinishAssembly(AssemblyEnv*); -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*, - Tcl_Obj*); -static void RestoreEmbeddedExceptionRanges(AssemblyEnv*); -static int StackCheckBasicBlock(AssemblyEnv*, BasicBlock *, - BasicBlock *, int); -static BasicBlock* StartBasicBlock(AssemblyEnv*, int fallthrough, - Tcl_Obj* jumpLabel); -/* static int AdvanceIp(const unsigned char *pc); */ -static int StackCheckBasicBlock(AssemblyEnv*, BasicBlock *, - BasicBlock *, int); -static int StackCheckExit(AssemblyEnv*); -static void StackFreshCatches(AssemblyEnv*, BasicBlock*, int, - BasicBlock**, int*); -static void SyncStackDepth(AssemblyEnv*); -static int TclAssembleCode(CompileEnv* envPtr, const char* code, - int codeLen, int flags); -static void UnstackExpiredCatches(CompileEnv*, BasicBlock*, int, - BasicBlock**, int*); - -/* - * Tcl_ObjType that describes bytecode emitted by the assembler. - */ - -static Tcl_FreeInternalRepProc FreeAssembleCodeInternalRep; -static Tcl_DupInternalRepProc DupAssembleCodeInternalRep; - -static const Tcl_ObjType assembleCodeType = { - "assemblecode", - FreeAssembleCodeInternalRep, /* freeIntRepProc */ - DupAssembleCodeInternalRep, /* dupIntRepProc */ - NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ -}; - -/* - * Source instructions recognized in the Tcl Assembly Language (TAL) - */ - -static const TalInstDesc TalInstructionTable[] = { - /* PUSH must be first, see the code near the end of TclAssembleCode */ - {"push", ASSEM_PUSH, (INST_PUSH1<<8 - | INST_PUSH4), 0, 1}, - - {"add", ASSEM_1BYTE, INST_ADD, 2, 1}, - {"append", ASSEM_LVT, (INST_APPEND_SCALAR1<<8 - | INST_APPEND_SCALAR4),1, 1}, - {"appendArray", ASSEM_LVT, (INST_APPEND_ARRAY1<<8 - | INST_APPEND_ARRAY4), 2, 1}, - {"appendArrayStk", ASSEM_1BYTE, INST_APPEND_ARRAY_STK, 3, 1}, - {"appendStk", ASSEM_1BYTE, INST_APPEND_STK, 2, 1}, - {"arrayExistsImm", ASSEM_LVT4, INST_ARRAY_EXISTS_IMM, 0, 1}, - {"arrayExistsStk", ASSEM_1BYTE, INST_ARRAY_EXISTS_STK, 1, 1}, - {"arrayMakeImm", ASSEM_LVT4, INST_ARRAY_MAKE_IMM, 0, 0}, - {"arrayMakeStk", ASSEM_1BYTE, INST_ARRAY_MAKE_STK, 1, 0}, - {"beginCatch", ASSEM_BEGIN_CATCH, - INST_BEGIN_CATCH4, 0, 0}, - {"bitand", ASSEM_1BYTE, INST_BITAND, 2, 1}, - {"bitnot", ASSEM_1BYTE, INST_BITNOT, 1, 1}, - {"bitor", ASSEM_1BYTE, INST_BITOR, 2, 1}, - {"bitxor", ASSEM_1BYTE, INST_BITXOR, 2, 1}, - {"clockRead", ASSEM_CLOCK_READ, INST_CLOCK_READ, 0, 1}, - {"concat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1}, - {"concatStk", ASSEM_LIST, INST_CONCAT_STK, INT_MIN,1}, - {"coroName", ASSEM_1BYTE, INST_COROUTINE_NAME, 0, 1}, - {"currentNamespace",ASSEM_1BYTE, INST_NS_CURRENT, 0, 1}, - {"dictAppend", ASSEM_LVT4, INST_DICT_APPEND, 2, 1}, - {"dictExists", ASSEM_DICT_GET, INST_DICT_EXISTS, INT_MIN,1}, - {"dictExpand", ASSEM_1BYTE, INST_DICT_EXPAND, 3, 1}, - {"dictGet", ASSEM_DICT_GET, INST_DICT_GET, INT_MIN,1}, - {"dictGetDef", ASSEM_DICT_GET_DEF, INST_DICT_GET_DEF, INT_MIN,1}, - {"dictIncrImm", ASSEM_SINT4_LVT4, - INST_DICT_INCR_IMM, 1, 1}, - {"dictLappend", ASSEM_LVT4, INST_DICT_LAPPEND, 2, 1}, - {"dictRecombineStk",ASSEM_1BYTE, INST_DICT_RECOMBINE_STK,3, 0}, - {"dictRecombineImm",ASSEM_LVT4, INST_DICT_RECOMBINE_IMM,2, 0}, - {"dictSet", ASSEM_DICT_SET, INST_DICT_SET, INT_MIN,1}, - {"dictUnset", ASSEM_DICT_UNSET, - INST_DICT_UNSET, INT_MIN,1}, - {"div", ASSEM_1BYTE, INST_DIV, 2, 1}, - {"dup", ASSEM_1BYTE, INST_DUP, 1, 2}, - {"endCatch", ASSEM_END_CATCH,INST_END_CATCH, 0, 0}, - {"eq", ASSEM_1BYTE, INST_EQ, 2, 1}, - {"eval", ASSEM_EVAL, INST_EVAL_STK, 1, 1}, - {"evalStk", ASSEM_1BYTE, INST_EVAL_STK, 1, 1}, - {"exist", ASSEM_LVT4, INST_EXIST_SCALAR, 0, 1}, - {"existArray", ASSEM_LVT4, INST_EXIST_ARRAY, 1, 1}, - {"existArrayStk", ASSEM_1BYTE, INST_EXIST_ARRAY_STK, 2, 1}, - {"existStk", ASSEM_1BYTE, INST_EXIST_STK, 1, 1}, - {"expon", ASSEM_1BYTE, INST_EXPON, 2, 1}, - {"expr", ASSEM_EVAL, INST_EXPR_STK, 1, 1}, - {"exprStk", ASSEM_1BYTE, INST_EXPR_STK, 1, 1}, - {"ge", ASSEM_1BYTE, INST_GE, 2, 1}, - {"gt", ASSEM_1BYTE, INST_GT, 2, 1}, - {"incr", ASSEM_LVT1, INST_INCR_SCALAR1, 1, 1}, - {"incrArray", ASSEM_LVT1, INST_INCR_ARRAY1, 2, 1}, - {"incrArrayImm", ASSEM_LVT1_SINT1, - INST_INCR_ARRAY1_IMM, 1, 1}, - {"incrArrayStk", ASSEM_1BYTE, INST_INCR_ARRAY_STK, 3, 1}, - {"incrArrayStkImm", ASSEM_SINT1, INST_INCR_ARRAY_STK_IMM,2, 1}, - {"incrImm", ASSEM_LVT1_SINT1, - INST_INCR_SCALAR1_IMM, 0, 1}, - {"incrStk", ASSEM_1BYTE, INST_INCR_STK, 2, 1}, - {"incrStkImm", ASSEM_SINT1, INST_INCR_STK_IMM, 1, 1}, - {"infoLevelArgs", ASSEM_1BYTE, INST_INFO_LEVEL_ARGS, 1, 1}, - {"infoLevelNumber", ASSEM_1BYTE, INST_INFO_LEVEL_NUM, 0, 1}, - {"invokeStk", ASSEM_INVOKE, (INST_INVOKE_STK1 << 8 - | INST_INVOKE_STK4), INT_MIN,1}, - {"jump", ASSEM_JUMP, INST_JUMP1, 0, 0}, - {"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}, - {"lappendListArray",ASSEM_LVT4, INST_LAPPEND_LIST_ARRAY,2, 1}, - {"lappendListArrayStk", ASSEM_1BYTE,INST_LAPPEND_LIST_ARRAY_STK, 3, 1}, - {"lappendListStk", ASSEM_1BYTE, INST_LAPPEND_LIST_STK, 2, 1}, - {"lappendStk", ASSEM_1BYTE, INST_LAPPEND_STK, 2, 1}, - {"le", ASSEM_1BYTE, INST_LE, 2, 1}, - {"lindexMulti", ASSEM_LINDEX_MULTI, - INST_LIST_INDEX_MULTI, INT_MIN,1}, - {"list", ASSEM_LIST, INST_LIST, INT_MIN,1}, - {"listConcat", ASSEM_1BYTE, INST_LIST_CONCAT, 2, 1}, - {"listIn", ASSEM_1BYTE, INST_LIST_IN, 2, 1}, - {"listIndex", ASSEM_1BYTE, INST_LIST_INDEX, 2, 1}, - {"listIndexImm", ASSEM_INDEX, INST_LIST_INDEX_IMM, 1, 1}, - {"listLength", ASSEM_1BYTE, INST_LIST_LENGTH, 1, 1}, - {"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}, - {"nop", ASSEM_1BYTE, INST_NOP, 0, 0}, - {"not", ASSEM_1BYTE, INST_LNOT, 1, 1}, - {"nsupvar", ASSEM_LVT4, INST_NSUPVAR, 2, 1}, - {"numericType", ASSEM_1BYTE, INST_NUM_TYPE, 1, 1}, - {"originCmd", ASSEM_1BYTE, INST_ORIGIN_COMMAND, 1, 1}, - {"over", ASSEM_OVER, INST_OVER, INT_MIN,-1-1}, - {"pop", ASSEM_1BYTE, INST_POP, 1, 0}, - {"pushReturnCode", ASSEM_1BYTE, INST_PUSH_RETURN_CODE, 0, 1}, - {"pushReturnOpts", ASSEM_1BYTE, INST_PUSH_RETURN_OPTIONS, - 0, 1}, - {"pushResult", ASSEM_1BYTE, INST_PUSH_RESULT, 0, 1}, - {"regexp", ASSEM_REGEXP, INST_REGEXP, 2, 1}, - {"resolveCmd", ASSEM_1BYTE, INST_RESOLVE_COMMAND, 1, 1}, - {"reverse", ASSEM_REVERSE, INST_REVERSE, INT_MIN,-1-0}, - {"rshift", ASSEM_1BYTE, INST_RSHIFT, 2, 1}, - {"store", ASSEM_LVT, (INST_STORE_SCALAR1<<8 - | INST_STORE_SCALAR4), 1, 1}, - {"storeArray", ASSEM_LVT, (INST_STORE_ARRAY1<<8 - | INST_STORE_ARRAY4), 2, 1}, - {"storeArrayStk", ASSEM_1BYTE, INST_STORE_ARRAY_STK, 3, 1}, - {"storeStk", ASSEM_1BYTE, INST_STORE_STK, 2, 1}, - {"strcaseLower", ASSEM_1BYTE, INST_STR_LOWER, 1, 1}, - {"strcaseTitle", ASSEM_1BYTE, INST_STR_TITLE, 1, 1}, - {"strcaseUpper", ASSEM_1BYTE, INST_STR_UPPER, 1, 1}, - {"strcmp", ASSEM_1BYTE, INST_STR_CMP, 2, 1}, - {"strcat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1}, - {"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1}, - {"strfind", ASSEM_1BYTE, INST_STR_FIND, 2, 1}, - {"strge", ASSEM_1BYTE, INST_STR_GE, 2, 1}, - {"strgt", ASSEM_1BYTE, INST_STR_GT, 2, 1}, - {"strindex", ASSEM_1BYTE, INST_STR_INDEX, 2, 1}, - {"strle", ASSEM_1BYTE, INST_STR_LE, 2, 1}, - {"strlen", ASSEM_1BYTE, INST_STR_LEN, 1, 1}, - {"strlt", ASSEM_1BYTE, INST_STR_LT, 2, 1}, - {"strmap", ASSEM_1BYTE, INST_STR_MAP, 3, 1}, - {"strmatch", ASSEM_BOOL, INST_STR_MATCH, 2, 1}, - {"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1}, - {"strrange", ASSEM_1BYTE, INST_STR_RANGE, 3, 1}, - {"strreplace", ASSEM_1BYTE, INST_STR_REPLACE, 4, 1}, - {"strrfind", ASSEM_1BYTE, INST_STR_FIND_LAST, 2, 1}, - {"strtrim", ASSEM_1BYTE, INST_STR_TRIM, 2, 1}, - {"strtrimLeft", ASSEM_1BYTE, INST_STR_TRIM_LEFT, 2, 1}, - {"strtrimRight", ASSEM_1BYTE, INST_STR_TRIM_RIGHT, 2, 1}, - {"sub", ASSEM_1BYTE, INST_SUB, 2, 1}, - {"tclooClass", ASSEM_1BYTE, INST_TCLOO_CLASS, 1, 1}, - {"tclooIsObject", ASSEM_1BYTE, INST_TCLOO_IS_OBJECT, 1, 1}, - {"tclooNamespace", ASSEM_1BYTE, INST_TCLOO_NS, 1, 1}, - {"tclooSelf", ASSEM_1BYTE, INST_TCLOO_SELF, 0, 1}, - {"tryCvtToBoolean", ASSEM_1BYTE, INST_TRY_CVT_TO_BOOLEAN,1, 2}, - {"tryCvtToNumeric", ASSEM_1BYTE, INST_TRY_CVT_TO_NUMERIC,1, 1}, - {"uminus", ASSEM_1BYTE, INST_UMINUS, 1, 1}, - {"unset", ASSEM_BOOL_LVT4,INST_UNSET_SCALAR, 0, 0}, - {"unsetArray", ASSEM_BOOL_LVT4,INST_UNSET_ARRAY, 1, 0}, - {"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. - * The instructions must be in ascending order by numeric operation code. - */ - -static const unsigned char NonThrowingByteCodes[] = { - INST_PUSH1, INST_PUSH4, INST_POP, INST_DUP, /* 1-4 */ - INST_JUMP1, INST_JUMP4, /* 34-35 */ - INST_END_CATCH, INST_PUSH_RESULT, INST_PUSH_RETURN_CODE, /* 70-72 */ - INST_STR_EQ, INST_STR_NEQ, INST_STR_CMP, INST_STR_LEN, /* 73-76 */ - INST_LIST, /* 79 */ - INST_OVER, /* 95 */ - INST_PUSH_RETURN_OPTIONS, /* 108 */ - INST_REVERSE, /* 126 */ - INST_NOP, /* 132 */ - INST_STR_MAP, /* 143 */ - INST_STR_FIND, /* 144 */ - INST_COROUTINE_NAME, /* 149 */ - INST_NS_CURRENT, /* 151 */ - INST_INFO_LEVEL_NUM, /* 152 */ - INST_RESOLVE_COMMAND, /* 154 */ - INST_STR_TRIM, INST_STR_TRIM_LEFT, INST_STR_TRIM_RIGHT, /* 166-168 */ - INST_CONCAT_STK, /* 169 */ - INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE, /* 170-172 */ - INST_NUM_TYPE, /* 180 */ - INST_STR_LT, INST_STR_GT, INST_STR_LE, INST_STR_GE /* 191-194 */ -}; - -/* - * Helper macros. - */ - -#if defined(TCL_DEBUG_ASSEMBLY) && defined(__GNUC__) && __GNUC__ > 2 -#define DEBUG_PRINT(...) fprintf(stderr, ##__VA_ARGS__);fflush(stderr) -#elif defined(__GNUC__) && __GNUC__ > 2 -#define DEBUG_PRINT(...) /* nothing */ -#else -#define DEBUG_PRINT /* nothing */ -#endif - -/* - *----------------------------------------------------------------------------- - * - * BBAdjustStackDepth -- - * - * When an opcode is emitted, adjusts the stack information in the basic - * block to reflect the number of operands produced and consumed. - * - * Results: - * None. - * - * Side effects: - * Updates minimum, maximum and final stack requirements in the basic - * block. - * - *----------------------------------------------------------------------------- - */ - -static void -BBAdjustStackDepth( - BasicBlock *bbPtr, /* Structure describing the basic block */ - int consumed, /* Count of operands consumed by the - * operation */ - int produced) /* Count of operands produced by the - * operation */ -{ - int depth = bbPtr->finalStackDepth; - - depth -= consumed; - if (depth < bbPtr->minStackDepth) { - bbPtr->minStackDepth = depth; - } - depth += produced; - if (depth > bbPtr->maxStackDepth) { - bbPtr->maxStackDepth = depth; - } - bbPtr->finalStackDepth = depth; -} - -/* - *----------------------------------------------------------------------------- - * - * BBUpdateStackReqs -- - * - * Updates the stack requirements of a basic block, given the opcode - * being emitted and an operand count. - * - * Results: - * None. - * - * Side effects: - * Updates min, max and final stack requirements in the basic block. - * - * Notes: - * This function must not be called for instructions such as REVERSE and - * OVER that are variadic but do not consume all their operands. Instead, - * BBAdjustStackDepth should be called directly. - * - * count should be provided only for variadic operations. For operations - * with known arity, count should be 0. - * - *----------------------------------------------------------------------------- - */ - -static void -BBUpdateStackReqs( - BasicBlock* bbPtr, /* Structure describing the basic block */ - int tblIdx, /* Index in TalInstructionTable of the - * operation being assembled */ - int count) /* Count of operands for variadic insts */ -{ - int consumed = TalInstructionTable[tblIdx].operandsConsumed; - int produced = TalInstructionTable[tblIdx].operandsProduced; - - if (consumed == INT_MIN) { - /* - * The instruction is variadic; it consumes 'count' operands, or - * 'count+1' for ASSEM_DICT_GET_DEF. - */ - - consumed = count; - if (TalInstructionTable[tblIdx].instType == ASSEM_DICT_GET_DEF) { - consumed++; - } - } - if (produced < 0) { - /* - * The instruction leaves some of its variadic operands on the stack, - * with net stack effect of '-1-produced' - */ - - produced = consumed - produced - 1; - } - BBAdjustStackDepth(bbPtr, consumed, produced); -} - -/* - *----------------------------------------------------------------------------- - * - * BBEmitOpcode, BBEmitInstInt1, BBEmitInstInt4 -- - * - * Emit the opcode part of an instruction, or the entirety of an - * instruction with a 1- or 4-byte operand, and adjust stack - * requirements. - * - * Results: - * None. - * - * Side effects: - * Stores instruction and operand in the operand stream, and adjusts the - * stack. - * - *----------------------------------------------------------------------------- - */ - -static void -BBEmitOpcode( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - 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) { - bbPtr->startLine = assemEnvPtr->cmdLine; - } - - TclEmitInt1(op, envPtr); - TclUpdateAtCmdStart(op, envPtr); - BBUpdateStackReqs(bbPtr, tblIdx, count); -} - -static void -BBEmitInstInt1( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - int tblIdx, /* Index in TalInstructionTable of op */ - int opnd, /* 1-byte operand */ - int count) /* Operand count for variadic ops */ -{ - BBEmitOpcode(assemEnvPtr, tblIdx, count); - TclEmitInt1(opnd, assemEnvPtr->envPtr); -} - -static void -BBEmitInstInt4( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - int tblIdx, /* Index in TalInstructionTable of op */ - int opnd, /* 4-byte operand */ - int count) /* Operand count for variadic ops */ -{ - BBEmitOpcode(assemEnvPtr, tblIdx, count); - TclEmitInt4(opnd, assemEnvPtr->envPtr); -} - -/* - *----------------------------------------------------------------------------- - * - * BBEmitInst1or4 -- - * - * Emits a 1- or 4-byte operation according to the magnitude of the - * operand. - * - *----------------------------------------------------------------------------- - */ - -static void -BBEmitInst1or4( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - int tblIdx, /* Index in TalInstructionTable of op */ - int param, /* Variable-length parameter */ - int count) /* Arity if variadic */ -{ - 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); -} - -/* - *----------------------------------------------------------------------------- - * - * Tcl_AssembleObjCmd, TclNRAssembleObjCmd -- - * - * Direct evaluation path for tcl::unsupported::assemble - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Assembles the code in objv[1], and executes it, so side effects - * include whatever the code does. - * - *----------------------------------------------------------------------------- - */ - -int -Tcl_AssembleObjCmd( - ClientData clientData, /* clientData */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - /* - * Boilerplate - make sure that there is an NRE trampoline on the C stack - * because there needs to be one in place to execute bytecode. - */ - - return Tcl_NRCallObjProc(interp, TclNRAssembleObjCmd, clientData, objc, objv); -} - -int -TclNRAssembleObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - ByteCode *codePtr; /* Pointer to the bytecode to execute */ - Tcl_Obj* backtrace; /* Object where extra error information is - * constructed. */ - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "bytecodeList"); - return TCL_ERROR; - } - - /* - * Assemble the source to bytecode. - */ - - codePtr = CompileAssembleObj(interp, objv[1]); - - /* - * On failure, report error line. - */ - - if (codePtr == NULL) { - Tcl_AddErrorInfo(interp, "\n (\""); - Tcl_AppendObjToErrorInfo(interp, objv[0]); - Tcl_AddErrorInfo(interp, "\" body, line "); - TclNewIntObj(backtrace, Tcl_GetErrorLine(interp)); - Tcl_AppendObjToErrorInfo(interp, backtrace); - Tcl_AddErrorInfo(interp, ")"); - return TCL_ERROR; - } - - /* - * Use NRE to evaluate the bytecode from the trampoline. - */ - - return TclNRExecuteByteCode(interp, codePtr); -} - -/* - *----------------------------------------------------------------------------- - * - * CompileAssembleObj -- - * - * Sets up and assembles Tcl bytecode for the direct-execution path in - * the Tcl bytecode assembler. - * - * Results: - * Returns a pointer to the assembled code. Returns NULL if the assembly - * fails for any reason, with an appropriate error message in the - * interpreter. - * - *----------------------------------------------------------------------------- - */ - -static ByteCode * -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 */ - size_t 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); - - if (codePtr) { - namespacePtr = iPtr->varFramePtr->nsPtr; - if (((Interp *) *codePtr->interpHandle == iPtr) - && (codePtr->compileEpoch == iPtr->compileEpoch) - && (codePtr->nsPtr == namespacePtr) - && (codePtr->nsEpoch == namespacePtr->resolverEpoch) - && (codePtr->localCachePtr - == iPtr->varFramePtr->localCachePtr)) { - return codePtr; - } - - /* - * Not valid, so free it and regenerate. - */ - - Tcl_StoreIntRep(objPtr, &assembleCodeType, NULL); - } - - /* - * Set up the compilation environment, and assemble the code. - */ - - source = TclGetStringFromObj(objPtr, &sourceLen); - TclInitCompileEnv(interp, &compEnv, source, sourceLen, NULL, 0); - status = TclAssembleCode(&compEnv, source, sourceLen, TCL_EVAL_DIRECT); - if (status != TCL_OK) { - /* - * Assembly failed. Clean up and report the error. - */ - TclFreeCompileEnv(&compEnv); - return NULL; - } - - /* - * Add a "done" instruction as the last instruction and change the object - * into a ByteCode object. Ownership of the literal objects and aux data - * items is given to the ByteCode object. - */ - - TclEmitOpcode(INST_DONE, &compEnv); - codePtr = TclInitByteCodeObj(objPtr, &assembleCodeType, &compEnv); - TclFreeCompileEnv(&compEnv); - - /* - * Record the local variable context to which the bytecode pertains - */ - - if (iPtr->varFramePtr->localCachePtr) { - codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; - codePtr->localCachePtr->refCount++; - } - - /* - * Report on what the assembler did. - */ - -#ifdef TCL_COMPILE_DEBUG - if (tclTraceCompile >= 2) { - TclPrintByteCodeObj(interp, objPtr); - fflush(stdout); - } -#endif /* TCL_COMPILE_DEBUG */ - - return codePtr; -} - -/* - *----------------------------------------------------------------------------- - * - * TclCompileAssembleCmd -- - * - * Compilation procedure for the '::tcl::unsupported::assemble' command. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Puts the result of assembling the code into the bytecode stream in - * 'compileEnv'. - * - * This procedure makes sure that the command has a single arg, which is - * constant. If that condition is met, the procedure calls TclAssembleCode to - * produce bytecode for the given assembly code, and returns any error - * resulting from the assembly. - * - *----------------------------------------------------------------------------- - */ - -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; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - - /* - * Compile the code and convert any error from the compilation into - * bytecode reporting the error; - */ - - if (TCL_ERROR == TclAssembleCode(envPtr, tokenPtr[1].start, - tokenPtr[1].size, TCL_EVAL_DIRECT)) { - - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"%.*s\" body, line %d)", - (int)parsePtr->tokenPtr->size, parsePtr->tokenPtr->start, - Tcl_GetErrorLine(interp))); - envPtr->numCommands = numCommands; - envPtr->codeNext = envPtr->codeStart + offset; - envPtr->currStackDepth = depth; - TclCompileSyntaxError(interp, envPtr); - } - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * TclAssembleCode -- - * - * Take a list of instructions in a Tcl_Obj, and assemble them to Tcl - * bytecodes - * - * Results: - * Returns TCL_OK on success, TCL_ERROR on failure. If 'flags' includes - * TCL_EVAL_DIRECT, places an error message in the interpreter result. - * - * Side effects: - * Adds byte codes to the compile environment, and updates the - * environment's stack depth. - * - *----------------------------------------------------------------------------- - */ - -static int -TclAssembleCode( - CompileEnv *envPtr, /* Compilation environment that is to receive - * the generated bytecode */ - const char* codePtr, /* Assembly-language code to be processed */ - int codeLen, /* Length of the code */ - int flags) /* OR'ed combination of flags */ -{ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - /* - * Walk through the assembly script using the Tcl parser. Each 'command' - * will be an instruction or assembly directive. - */ - - const char* instPtr = codePtr; - /* Where to start looking for a line of code */ - const char* nextPtr; /* Pointer to the end of the line of code */ - int bytesLeft = codeLen; /* Number of bytes of source code remaining to - * be parsed */ - int status; /* Tcl status return */ - AssemblyEnv* assemEnvPtr = NewAssemblyEnv(envPtr, flags); - Tcl_Parse* parsePtr = assemEnvPtr->parsePtr; - - do { - /* - * Parse out one command line from the assembly script. - */ - - status = Tcl_ParseCommand(interp, instPtr, bytesLeft, 0, parsePtr); - - /* - * Report errors in the parse. - */ - - if (status != TCL_OK) { - if (flags & TCL_EVAL_DIRECT) { - Tcl_LogCommandInfo(interp, codePtr, parsePtr->commandStart, - parsePtr->term + 1 - parsePtr->commandStart); - } - FreeAssemblyEnv(assemEnvPtr); - return TCL_ERROR; - } - - /* - * Advance the pointers around any leading commentary. - */ - - TclAdvanceLines(&assemEnvPtr->cmdLine, instPtr, - parsePtr->commandStart); - TclAdvanceContinuations(&assemEnvPtr->cmdLine, &assemEnvPtr->clNext, - parsePtr->commandStart - envPtr->source); - - /* - * Process the line of code. - */ - - if (parsePtr->numWords > 0) { - size_t 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(" %4" TCL_Z_MODIFIER "d Assembling: ", - envPtr->codeNext - envPtr->codeStart); - TclPrintSource(stdout, parsePtr->commandStart, - TclMin(instLen, 55)); - printf("\n"); - } -#endif - if (AssembleOneLine(assemEnvPtr) != TCL_OK) { - if (flags & TCL_EVAL_DIRECT) { - Tcl_LogCommandInfo(interp, codePtr, - parsePtr->commandStart, instLen); - } - Tcl_FreeParse(parsePtr); - FreeAssemblyEnv(assemEnvPtr); - return TCL_ERROR; - } - } - - /* - * Advance to the next line of code. - */ - - nextPtr = parsePtr->commandStart + parsePtr->commandSize; - bytesLeft -= (nextPtr - instPtr); - instPtr = nextPtr; - TclAdvanceLines(&assemEnvPtr->cmdLine, parsePtr->commandStart, - instPtr); - TclAdvanceContinuations(&assemEnvPtr->cmdLine, &assemEnvPtr->clNext, - instPtr - envPtr->source); - Tcl_FreeParse(parsePtr); - } while (bytesLeft > 0); - - /* - * Done with parsing the code. - */ - - status = FinishAssembly(assemEnvPtr); - FreeAssemblyEnv(assemEnvPtr); - return status; -} - -/* - *----------------------------------------------------------------------------- - * - * NewAssemblyEnv -- - * - * Creates an environment for the assembler to run in. - * - * Results: - * Allocates, initialises and returns an assembler environment - * - *----------------------------------------------------------------------------- - */ - -static AssemblyEnv* -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; - - /* - * Make the hashtables that store symbol resolution. - */ - - Tcl_InitHashTable(&assemEnvPtr->labelHash, TCL_STRING_KEYS); - - /* - * Start the first basic block. - */ - - assemEnvPtr->curr_bb = NULL; - assemEnvPtr->head_bb = AllocBB(assemEnvPtr); - assemEnvPtr->curr_bb = assemEnvPtr->head_bb; - assemEnvPtr->head_bb->startLine = 1; - - /* - * Stash compilation flags. - */ - - assemEnvPtr->flags = flags; - return assemEnvPtr; -} - -/* - *----------------------------------------------------------------------------- - * - * FreeAssemblyEnv -- - * - * Cleans up the assembler environment when assembly is complete. - * - *----------------------------------------------------------------------------- - */ - -static void -FreeAssemblyEnv( - AssemblyEnv* assemEnvPtr) /* Environment to free */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment being used for code - * generation */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - BasicBlock* thisBB; /* Pointer to a basic block being deleted */ - BasicBlock* nextBB; /* Pointer to a deleted basic block's - * successor */ - - /* - * Free all the basic block structures. - */ - - for (thisBB = assemEnvPtr->head_bb; thisBB != NULL; thisBB = nextBB) { - if (thisBB->jumpTarget != NULL) { - Tcl_DecrRefCount(thisBB->jumpTarget); - } - if (thisBB->foreignExceptions != NULL) { - Tcl_Free(thisBB->foreignExceptions); - } - nextBB = thisBB->successor1; - if (thisBB->jtPtr != NULL) { - DeleteMirrorJumpTable(thisBB->jtPtr); - thisBB->jtPtr = NULL; - } - Tcl_Free(thisBB); - } - - /* - * Dispose what's left. - */ - - Tcl_DeleteHashTable(&assemEnvPtr->labelHash); - TclStackFree(interp, assemEnvPtr->parsePtr); - TclStackFree(interp, assemEnvPtr); -} - -/* - *----------------------------------------------------------------------------- - * - * AssembleOneLine -- - * - * Assembles a single command from an assembly language source. - * - * Results: - * Returns TCL_ERROR with an appropriate error message if the assembly - * fails. Returns TCL_OK if the assembly succeeds. Updates the assembly - * environment with the state of the assembly. - * - *----------------------------------------------------------------------------- - */ - -static int -AssembleOneLine( - AssemblyEnv* assemEnvPtr) /* State of the assembly */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment being used for code - * gen */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - Tcl_Parse* parsePtr = assemEnvPtr->parsePtr; - /* Parse of the line of code */ - Tcl_Token* tokenPtr; /* Current token within the line of code */ - Tcl_Obj* instNameObj; /* Name of the instruction */ - int tblIdx; /* Index in TalInstructionTable of the - * instruction */ - TalInstType instType; /* Type of the instruction */ - Tcl_Obj* operand1Obj = NULL; - /* First operand to the instruction */ - const char* operand1; /* String rep of the operand */ - size_t 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 */ - - /* - * Make sure that the instruction name is known at compile time. - */ - - tokenPtr = parsePtr->tokenPtr; - if (GetNextOperand(assemEnvPtr, &tokenPtr, &instNameObj) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Look up the instruction name. - */ - - if (Tcl_GetIndexFromObjStruct(interp, instNameObj, - &TalInstructionTable[0].name, sizeof(TalInstDesc), "instruction", - TCL_EXACT, &tblIdx) != TCL_OK) { - goto cleanup; - } - - /* - * Vector on the type of instruction being processed. - */ - - instType = TalInstructionTable[tblIdx].instType; - switch (instType) { - - case ASSEM_PUSH: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "value"); - goto cleanup; - } - if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { - goto cleanup; - } - operand1 = TclGetStringFromObj(operand1Obj, &operand1Len); - litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0); - BBEmitInst1or4(assemEnvPtr, tblIdx, litIndex, 0); - break; - - case ASSEM_1BYTE: - if (parsePtr->numWords != 1) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, ""); - goto cleanup; - } - BBEmitOpcode(assemEnvPtr, tblIdx, 0); - break; - - case ASSEM_BEGIN_CATCH: - /* - * Emit the BEGIN_CATCH instruction with the code offset of the - * exception branch target instead of the exception range index. The - * correct index will be generated and inserted later, when catches - * are being resolved. - */ - - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "label"); - goto cleanup; - } - if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { - goto cleanup; - } - assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine; - assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext-envPtr->codeStart; - BBEmitInstInt4(assemEnvPtr, tblIdx, 0, 0); - assemEnvPtr->curr_bb->flags |= BB_BEGINCATCH; - StartBasicBlock(assemEnvPtr, BB_FALLTHRU, operand1Obj); - break; - - case ASSEM_BOOL: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean"); - goto cleanup; - } - if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0); - break; - - case ASSEM_BOOL_LVT4: - if (parsePtr->numWords != 3) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean varName"); - goto cleanup; - } - if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { - goto cleanup; - } - localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0) { - goto cleanup; - } - BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0); - TclEmitInt4(localVar, envPtr); - break; - - case ASSEM_CLOCK_READ: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { - goto cleanup; - } - if (opnd < 0 || opnd > 3) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("operand must be [0..3]", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND<0,>3", NULL); - goto cleanup; - } - BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, opnd); - break; - - case ASSEM_CONCAT1: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckOneByte(interp, opnd) != TCL_OK - || CheckStrictlyPositive(interp, opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, opnd); - break; - - case ASSEM_DICT_GET: - case ASSEM_DICT_GET_DEF: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckStrictlyPositive(interp, opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd+1); - break; - - case ASSEM_DICT_SET: - if (parsePtr->numWords != 3) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckStrictlyPositive(interp, opnd) != TCL_OK) { - goto cleanup; - } - localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd+1); - TclEmitInt4(localVar, envPtr); - break; - - case ASSEM_DICT_UNSET: - if (parsePtr->numWords != 3) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckStrictlyPositive(interp, opnd) != TCL_OK) { - goto cleanup; - } - localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); - TclEmitInt4(localVar, envPtr); - break; - - case ASSEM_END_CATCH: - if (parsePtr->numWords != 1) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, ""); - goto cleanup; - } - assemEnvPtr->curr_bb->flags |= BB_ENDCATCH; - BBEmitOpcode(assemEnvPtr, tblIdx, 0); - StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL); - break; - - case ASSEM_EVAL: - /* TODO - Refactor this stuff into a subroutine that takes the inst - * code, the message ("script" or "expression") and an evaluator - * callback that calls TclCompileScript or TclCompileExpr. */ - - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, - ((TalInstructionTable[tblIdx].tclInstCode - == INST_EVAL_STK) ? "script" : "expression")); - goto cleanup; - } - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - CompileEmbeddedScript(assemEnvPtr, tokenPtr+1, - TalInstructionTable+tblIdx); - } else if (GetNextOperand(assemEnvPtr, &tokenPtr, - &operand1Obj) != TCL_OK) { - goto cleanup; - } else { - operand1 = TclGetStringFromObj(operand1Obj, &operand1Len); - litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0); - - /* - * Assumes that PUSH is the first slot! - */ - - BBEmitInst1or4(assemEnvPtr, 0, litIndex, 0); - BBEmitOpcode(assemEnvPtr, tblIdx, 0); - } - break; - - case ASSEM_INVOKE: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckStrictlyPositive(interp, opnd) != TCL_OK) { - goto cleanup; - } - - BBEmitInst1or4(assemEnvPtr, tblIdx, opnd, opnd); - break; - - case ASSEM_JUMP: - case ASSEM_JUMP4: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "label"); - goto cleanup; - } - if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { - goto cleanup; - } - assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext-envPtr->codeStart; - if (instType == ASSEM_JUMP) { - flags = BB_JUMP1; - BBEmitInstInt1(assemEnvPtr, tblIdx, 0, 0); - } else { - flags = 0; - BBEmitInstInt4(assemEnvPtr, tblIdx, 0, 0); - } - - /* - * Start a new basic block at the instruction following the jump. - */ - - assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine; - if (TalInstructionTable[tblIdx].operandsConsumed != 0) { - flags |= BB_FALLTHRU; - } - StartBasicBlock(assemEnvPtr, flags, operand1Obj); - break; - - case ASSEM_JUMPTABLE: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "table"); - goto cleanup; - } - if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { - goto cleanup; - } - - jtPtr = (JumptableInfo*)Tcl_Alloc(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); - - infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr); - DEBUG_PRINT("auxdata index=%d\n", infoIndex); - - BBEmitInstInt4(assemEnvPtr, tblIdx, infoIndex, 0); - if (CreateMirrorJumpTable(assemEnvPtr, operand1Obj) != TCL_OK) { - goto cleanup; - } - StartBasicBlock(assemEnvPtr, BB_JUMPTABLE|BB_FALLTHRU, NULL); - break; - - case ASSEM_LABEL: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "name"); - goto cleanup; - } - if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { - goto cleanup; - } - - /* - * Add the (label_name, address) pair to the hash table. - */ - - if (DefineLabel(assemEnvPtr, TclGetString(operand1Obj)) != TCL_OK) { - goto cleanup; - } - break; - - case ASSEM_LINDEX_MULTI: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckStrictlyPositive(interp, opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); - break; - - case ASSEM_LIST: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckNonNegative(interp, opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); - break; - - case ASSEM_INDEX: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); - goto cleanup; - } - if (GetListIndexOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); - break; - - case ASSEM_LSET_FLAT: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { - goto cleanup; - } - if (opnd < 2) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("operand must be >=2", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND>=2", NULL); - } - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); - break; - - case ASSEM_LVT: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); - goto cleanup; - } - localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0) { - goto cleanup; - } - BBEmitInst1or4(assemEnvPtr, tblIdx, localVar, 0); - break; - - case ASSEM_LVT1: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); - goto cleanup; - } - localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0 || CheckOneByte(interp, localVar)) { - goto cleanup; - } - BBEmitInstInt1(assemEnvPtr, tblIdx, localVar, 0); - break; - - case ASSEM_LVT1_SINT1: - if (parsePtr->numWords != 3) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "varName imm8"); - goto cleanup; - } - localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0 || CheckOneByte(interp, localVar) - || GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckSignedOneByte(interp, opnd)) { - goto cleanup; - } - BBEmitInstInt1(assemEnvPtr, tblIdx, localVar, 0); - TclEmitInt1(opnd, envPtr); - break; - - case ASSEM_LVT4: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); - goto cleanup; - } - localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, localVar, 0); - break; - - case ASSEM_OVER: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckNonNegative(interp, opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd+1); - break; - - case ASSEM_REGEXP: - if (parsePtr->numWords != 2) { - 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; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckNonNegative(interp, opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); - break; - - case ASSEM_SINT1: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckSignedOneByte(interp, opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0); - break; - - case ASSEM_SINT4_LVT4: - if (parsePtr->numWords != 3) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { - goto cleanup; - } - localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, 0); - TclEmitInt4(localVar, envPtr); - break; - - default: - Tcl_Panic("Instruction \"%s\" could not be found, can't happen\n", - TclGetString(instNameObj)); - } - - status = TCL_OK; - cleanup: - Tcl_DecrRefCount(instNameObj); - if (operand1Obj) { - Tcl_DecrRefCount(operand1Obj); - } - return status; -} - -/* - *----------------------------------------------------------------------------- - * - * CompileEmbeddedScript -- - * - * Compile an embedded 'eval' or 'expr' that appears in assembly code. - * - * This procedure is called when the 'eval' or 'expr' assembly directive is - * encountered, and the argument to the directive is a simple word that - * requires no substitution. The appropriate compiler (TclCompileScript or - * TclCompileExpr) is invoked recursively, and emits bytecode. - * - * Before the compiler is invoked, the compilation environment's stack - * consumption is reset to zero. Upon return from the compilation, the net - * stack effect of the compilation is in the compiler env, and this stack - * effect is posted to the assembler environment. The compile environment's - * stack consumption is then restored to what it was before (which is actually - * the state of the stack on entry to the block of assembly code). - * - * Any exception ranges pushed by the compilation are copied to the basic - * block and removed from the compiler environment. They will be rebuilt at - * the end of assembly, when the exception stack depth is actually known. - * - *----------------------------------------------------------------------------- - */ - -static void -CompileEmbeddedScript( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - Tcl_Token* tokenPtr, /* Tcl_Token containing the script */ - const TalInstDesc* instPtr) /* Instruction that determines whether - * the script is 'expr' or 'eval' */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - - /* - * The expression or script is not only known at compile time, but - * actually a "simple word". It can be compiled inline by invoking the - * compiler recursively. - * - * Save away the stack depth and reset it before compiling the script. - * 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) { - case INST_EVAL_STK: - TclCompileScript(interp, tokenPtr->start, tokenPtr->size, envPtr); - break; - case INST_EXPR_STK: - TclCompileExpr(interp, tokenPtr->start, tokenPtr->size, envPtr, 1); - break; - default: - Tcl_Panic("no ASSEM_EVAL case for %s (%d), can't happen", - instPtr->name, instPtr->tclInstCode); - } - - /* - * Roll up the stack usage of the embedded block into the assembler - * environment. - */ - - SyncStackDepth(assemEnvPtr); - envPtr->currStackDepth = savedStackDepth; - 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); -} - -/* - *----------------------------------------------------------------------------- - * - * SyncStackDepth -- - * - * Copies the stack depth from the compile environment to a basic block. - * - * Side effects: - * Current and max stack depth in the current basic block are adjusted. - * - * This procedure is called on return from invoking the compiler for the - * 'eval' and 'expr' operations. It adjusts the stack depth of the current - * basic block to reflect the stack required by the just-compiled code. - * - *----------------------------------------------------------------------------- - */ - -static void -SyncStackDepth( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* curr_bb = assemEnvPtr->curr_bb; - /* Current basic block */ - int maxStackDepth = curr_bb->finalStackDepth + envPtr->maxStackDepth; - /* Max stack depth in the basic block */ - - if (maxStackDepth > curr_bb->maxStackDepth) { - curr_bb->maxStackDepth = maxStackDepth; - } - curr_bb->finalStackDepth += envPtr->currStackDepth; -} - -/* - *----------------------------------------------------------------------------- - * - * MoveExceptionRangesToBasicBlock -- - * - * Removes exception ranges that were created by compiling an embedded - * script from the CompileEnv, and stores them in the BasicBlock. They - * will be reinstalled, at the correct stack depth, after control flow - * analysis is complete on the assembly code. - * - *----------------------------------------------------------------------------- - */ - -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 */ - int exceptionCount = envPtr->exceptArrayNext - savedExceptArrayNext; - /* Number of ranges that must be moved */ - int i; - - if (exceptionCount == 0) { - /* Nothing to do */ - return; - } - - /* - * Save the exception ranges in the basic block. They will be re-added at - * the conclusion of assembly; at this time, the INST_BEGIN_CATCH - * instructions in the block will be adjusted from whatever range indices - * they have [savedExceptArrayNext .. envPtr->exceptArrayNext) to the - * indices that the exceptions acquire. The saved exception ranges are - * converted to a relative nesting depth. The depth will be recomputed - * once flow analysis has determined the actual stack depth of the block. - */ - - DEBUG_PRINT("basic block %p has %d exceptions starting at %d\n", - curr_bb, exceptionCount, savedExceptArrayNext); - curr_bb->foreignExceptionBase = savedExceptArrayNext; - curr_bb->foreignExceptionCount = exceptionCount; - curr_bb->foreignExceptions = - (ExceptionRange*)Tcl_Alloc(exceptionCount * sizeof(ExceptionRange)); - memcpy(curr_bb->foreignExceptions, - envPtr->exceptArrayPtr + savedExceptArrayNext, - exceptionCount * sizeof(ExceptionRange)); - for (i = 0; i < exceptionCount; ++i) { - curr_bb->foreignExceptions[i].nestingLevel -= envPtr->exceptDepth; - } - envPtr->exceptArrayNext = savedExceptArrayNext; -} - -/* - *----------------------------------------------------------------------------- - * - * CreateMirrorJumpTable -- - * - * Makes a jump table with comparison values and assembly code labels. - * - * Results: - * Returns a standard Tcl status, with an error message in the - * interpreter on error. - * - * Side effects: - * Initializes the jump table pointer in the current basic block to a - * JumptableInfo. The keys in the JumptableInfo are the comparison - * strings. The values, instead of being jump displacements, are - * Tcl_Obj's with the code labels. - */ - -static int -CreateMirrorJumpTable( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - Tcl_Obj* jumps) /* List of alternating keywords and labels */ -{ - int objc; /* Number of elements in the 'jumps' list */ - Tcl_Obj** objv; /* Pointers to the elements in the list */ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - BasicBlock* bbPtr = assemEnvPtr->curr_bb; - /* Current basic block */ - JumptableInfo* jtPtr; - Tcl_HashTable* jtHashPtr; /* Hashtable in the JumptableInfo */ - Tcl_HashEntry* hashEntry; /* Entry for a key in the hashtable */ - int isNew; /* Flag==1 if the key is not yet in the - * table. */ - int i; - - if (Tcl_ListObjGetElements(interp, jumps, &objc, &objv) != TCL_OK) { - return TCL_ERROR; - } - if (objc % 2 != 0) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "jump table must have an even number of list elements", - -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADJUMPTABLE", NULL); - } - return TCL_ERROR; - } - - /* - * Allocate the jumptable. - */ - - jtPtr = (JumptableInfo*)Tcl_Alloc(sizeof(JumptableInfo)); - jtHashPtr = &jtPtr->hashTable; - Tcl_InitHashTable(jtHashPtr, TCL_STRING_KEYS); - - /* - * Fill the keys and labels into the table. - */ - - DEBUG_PRINT("jump table {\n"); - for (i = 0; i < objc; i+=2) { - DEBUG_PRINT(" %s -> %s\n", TclGetString(objv[i]), - TclGetString(objv[i+1])); - hashEntry = Tcl_CreateHashEntry(jtHashPtr, TclGetString(objv[i]), - &isNew); - if (!isNew) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "duplicate entry in jump table for \"%s\"", - TclGetString(objv[i]))); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY"); - DeleteMirrorJumpTable(jtPtr); - return TCL_ERROR; - } - } - Tcl_SetHashValue(hashEntry, objv[i+1]); - Tcl_IncrRefCount(objv[i+1]); - } - DEBUG_PRINT("}\n"); - - /* - * Put the mirror jumptable in the basic block struct. - */ - - bbPtr->jtPtr = jtPtr; - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * DeleteMirrorJumpTable -- - * - * Cleans up a jump table when the basic block is deleted. - * - *----------------------------------------------------------------------------- - */ - -static void -DeleteMirrorJumpTable( - JumptableInfo* jtPtr) -{ - Tcl_HashTable* jtHashPtr = &jtPtr->hashTable; - /* Hash table pointer */ - 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); - Tcl_Free(jtPtr); -} - -/* - *----------------------------------------------------------------------------- - * - * GetNextOperand -- - * - * Retrieves the next operand in sequence from an assembly instruction, - * and makes sure that its value is known at compile time. - * - * Results: - * If successful, returns TCL_OK and leaves a Tcl_Obj with the operand - * text in *operandObjPtr. In case of failure, returns TCL_ERROR and - * leaves *operandObjPtr untouched. - * - * Side effects: - * Advances *tokenPtrPtr around the token just processed. - * - *----------------------------------------------------------------------------- - */ - -static int -GetNextOperand( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - Tcl_Token** tokenPtrPtr, /* INPUT/OUTPUT: Pointer to the token holding - * the operand */ - Tcl_Obj** operandObjPtr) /* OUTPUT: Tcl object holding the operand text - * with \-substitutions done. */ -{ - Tcl_Interp* interp = (Tcl_Interp*) assemEnvPtr->envPtr->iPtr; - Tcl_Obj* operandObj; - - TclNewObj(operandObj); - if (!TclWordKnownAtCompileTime(*tokenPtrPtr, operandObj)) { - Tcl_DecrRefCount(operandObj); - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "assembly code may not contain substitutions", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOSUBST", NULL); - } - return TCL_ERROR; - } - *tokenPtrPtr = TokenAfter(*tokenPtrPtr); - Tcl_IncrRefCount(operandObj); - *operandObjPtr = operandObj; - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * GetBooleanOperand -- - * - * Retrieves a Boolean operand from the input stream and advances - * the token pointer. - * - * Results: - * Returns a standard Tcl result (with an error message in the - * interpreter on failure). - * - * Side effects: - * Stores the Boolean value in (*result) and advances (*tokenPtrPtr) - * to the next token. - * - *----------------------------------------------------------------------------- - */ - -static int -GetBooleanOperand( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - Tcl_Token** tokenPtrPtr, /* Current token from the parser */ - int* result) /* OUTPUT: Integer extracted from the token */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - 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* intObj; /* Integer from the source code */ - int status; /* Tcl status return */ - - /* - * Extract the next token as a string. - */ - - if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Convert to an integer, advance to the next token and return. - */ - - status = Tcl_GetBooleanFromObj(interp, intObj, result); - Tcl_DecrRefCount(intObj); - *tokenPtrPtr = TokenAfter(tokenPtr); - return status; -} - -/* - *----------------------------------------------------------------------------- - * - * GetIntegerOperand -- - * - * Retrieves an integer operand from the input stream and advances the - * token pointer. - * - * Results: - * Returns a standard Tcl result (with an error message in the - * interpreter on failure). - * - * Side effects: - * Stores the integer value in (*result) and advances (*tokenPtrPtr) to - * the next token. - * - *----------------------------------------------------------------------------- - */ - -static int -GetIntegerOperand( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - Tcl_Token** tokenPtrPtr, /* Current token from the parser */ - int* result) /* OUTPUT: Integer extracted from the token */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - 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* intObj; /* Integer from the source code */ - int status; /* Tcl status return */ - - /* - * Extract the next token as a string. - */ - - if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Convert to an integer, advance to the next token and return. - */ - - status = Tcl_GetIntFromObj(interp, intObj, result); - Tcl_DecrRefCount(intObj); - *tokenPtrPtr = TokenAfter(tokenPtr); - return status; -} - -/* - *----------------------------------------------------------------------------- - * - * GetListIndexOperand -- - * - * 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 -GetListIndexOperand( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - Tcl_Token** tokenPtrPtr, /* Current token from the parser */ - int* result) /* OUTPUT: Integer extracted from the token */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - 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 *value; - int status; - - /* General operand validity check */ - if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &value) != TCL_OK) { - return TCL_ERROR; - } - - /* Convert to an integer, advance to the next token and return. */ - /* - * NOTE: Indexing a list with an index before it yields the - * same result as indexing after it, and might be more easily portable - * when list size limits grow. - */ - status = TclIndexEncode(interp, value, - TCL_INDEX_NONE,TCL_INDEX_NONE, result); - - Tcl_DecrRefCount(value); - *tokenPtrPtr = TokenAfter(tokenPtr); - return status; -} - -/* - *----------------------------------------------------------------------------- - * - * FindLocalVar -- - * - * Gets the name of a local variable from the input stream and advances - * the token pointer. - * - * Results: - * Returns the LVT index of the local variable. Returns -1 if the - * variable is non-local, not known at compile time, or cannot be - * installed in the LVT (leaving an error message in the interpreter - * result if necessary). - * - * Side effects: - * Advances the token pointer. May define a new LVT slot if the variable - * has not yet been seen and the execution context allows for it. - * - *----------------------------------------------------------------------------- - */ - -static int -FindLocalVar( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - Tcl_Token** tokenPtrPtr) -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - 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; - size_t 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)) { - Tcl_DecrRefCount(varNameObj); - return -1; - } - localVar = TclFindCompiledLocal(varNameStr, varNameLen, 1, envPtr); - Tcl_DecrRefCount(varNameObj); - if (localVar == -1) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot use this instruction to create a variable" - " in a non-proc context", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL); - } - return -1; - } - *tokenPtrPtr = TokenAfter(tokenPtr); - return localVar; -} - -/* - *----------------------------------------------------------------------------- - * - * CheckNamespaceQualifiers -- - * - * Verify that a variable name has no namespace qualifiers before - * attempting to install it in the LVT. - * - * Results: - * On success, returns TCL_OK. On failure, returns TCL_ERROR and stores - * an error message in the interpreter result. - * - *----------------------------------------------------------------------------- - */ - -static int -CheckNamespaceQualifiers( - Tcl_Interp* interp, /* Tcl interpreter for error reporting */ - const char* name, /* Variable name to check */ - int nameLen) /* Length of the variable */ -{ - const char* p; - - for (p = name; p+2 < name+nameLen; p++) { - if ((*p == ':') && (p[1] == ':')) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "variable \"%s\" is not local", name)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONLOCAL", name, NULL); - return TCL_ERROR; - } - } - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * CheckOneByte -- - * - * Verify that a constant fits in a single byte in the instruction - * stream. - * - * Results: - * On success, returns TCL_OK. On failure, returns TCL_ERROR and stores - * an error message in the interpreter result. - * - * This code is here primarily to verify that instructions like INCR_SCALAR1 - * are possible on a given local variable. The fact that there is no - * INCR_SCALAR4 is puzzling. - * - *----------------------------------------------------------------------------- - */ - -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; -} - -/* - *----------------------------------------------------------------------------- - * - * CheckSignedOneByte -- - * - * Verify that a constant fits in a single signed byte in the instruction - * stream. - * - * Results: - * On success, returns TCL_OK. On failure, returns TCL_ERROR and stores - * an error message in the interpreter result. - * - * This code is here primarily to verify that instructions like INCR_SCALAR1 - * are possible on a given local variable. The fact that there is no - * INCR_SCALAR4 is puzzling. - * - *----------------------------------------------------------------------------- - */ - -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; -} - -/* - *----------------------------------------------------------------------------- - * - * CheckNonNegative -- - * - * Verify that a constant is nonnegative - * - * Results: - * On success, returns TCL_OK. On failure, returns TCL_ERROR and stores - * an error message in the interpreter result. - * - * This code is here primarily to verify that instructions like INCR_INVOKE - * are consuming a positive number of operands - * - *----------------------------------------------------------------------------- - */ - -static int -CheckNonNegative( - Tcl_Interp* interp, /* Tcl interpreter for error reporting */ - int value) /* Value to check */ -{ - Tcl_Obj* result; /* Error message */ - - if (value < 0) { - result = Tcl_NewStringObj("operand must be nonnegative", -1); - Tcl_SetObjResult(interp, result); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONNEGATIVE", NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * CheckStrictlyPositive -- - * - * Verify that a constant is positive - * - * Results: - * On success, returns TCL_OK. On failure, returns TCL_ERROR and - * stores an error message in the interpreter result. - * - * This code is here primarily to verify that instructions like INCR_INVOKE - * are consuming a positive number of operands - * - *----------------------------------------------------------------------------- - */ - -static int -CheckStrictlyPositive( - Tcl_Interp* interp, /* Tcl interpreter for error reporting */ - int value) /* Value to check */ -{ - Tcl_Obj* result; /* Error message */ - - if (value <= 0) { - result = Tcl_NewStringObj("operand must be positive", -1); - Tcl_SetObjResult(interp, result); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "POSITIVE", NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * DefineLabel -- - * - * Defines a label appearing in the assembly sequence. - * - * Results: - * Returns a standard Tcl result. Returns TCL_OK and an empty result if - * the definition succeeds; returns TCL_ERROR and an appropriate message - * if a duplicate definition is found. - * - *----------------------------------------------------------------------------- - */ - -static int -DefineLabel( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - const char* labelName) /* Label being defined */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - Tcl_HashEntry* entry; /* Label's entry in the symbol table */ - int isNew; /* Flag == 1 iff the label was previously - * undefined */ - - /* TODO - This can now be simplified! */ - - StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL); - - /* - * Look up the newly-defined label in the symbol table. - */ - - entry = Tcl_CreateHashEntry(&assemEnvPtr->labelHash, labelName, &isNew); - if (!isNew) { - /* - * This is a duplicate label. - */ - - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "duplicate definition of label \"%s\"", labelName)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPLABEL", labelName, - NULL); - } - return TCL_ERROR; - } - - /* - * This is the first appearance of the label in the code. - */ - - Tcl_SetHashValue(entry, assemEnvPtr->curr_bb); - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * StartBasicBlock -- - * - * Starts a new basic block when a label or jump is encountered. - * - * Results: - * Returns a pointer to the BasicBlock structure of the new - * basic block. - * - *----------------------------------------------------------------------------- - */ - -static BasicBlock* -StartBasicBlock( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - int flags, /* Flags to apply to the basic block being - * closed, if there is one. */ - Tcl_Obj* jumpLabel) /* Label of the location that the block jumps - * to, or NULL if the block does not jump */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* newBB; /* BasicBlock structure for the new block */ - BasicBlock* currBB = assemEnvPtr->curr_bb; - - /* - * Coalesce zero-length blocks. - */ - - if (currBB->startOffset == envPtr->codeNext - envPtr->codeStart) { - currBB->startLine = assemEnvPtr->cmdLine; - return currBB; - } - - /* - * Make the new basic block. - */ - - newBB = AllocBB(assemEnvPtr); - - /* - * Record the jump target if there is one. - */ - - currBB->jumpTarget = jumpLabel; - if (jumpLabel != NULL) { - Tcl_IncrRefCount(currBB->jumpTarget); - } - - /* - * Record the fallthrough if there is one. - */ - - currBB->flags |= flags; - - /* - * Record the successor block. - */ - - currBB->successor1 = newBB; - assemEnvPtr->curr_bb = newBB; - return newBB; -} - -/* - *----------------------------------------------------------------------------- - * - * AllocBB -- - * - * Allocates a new basic block - * - * Results: - * Returns a pointer to the newly allocated block, which is initialized - * to contain no code and begin at the current instruction pointer. - * - *----------------------------------------------------------------------------- - */ - -static BasicBlock * -AllocBB( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - BasicBlock *bb = (BasicBlock*)Tcl_Alloc(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; - bb->predecessor = NULL; - bb->successor1 = NULL; - bb->jumpTarget = NULL; - bb->initialStackDepth = 0; - bb->minStackDepth = 0; - bb->maxStackDepth = 0; - bb->finalStackDepth = 0; - bb->catchDepth = 0; - bb->enclosingCatch = NULL; - bb->foreignExceptionBase = -1; - bb->foreignExceptionCount = 0; - bb->foreignExceptions = NULL; - bb->jtPtr = NULL; - bb->flags = 0; - - return bb; -} - -/* - *----------------------------------------------------------------------------- - * - * FinishAssembly -- - * - * Postprocessing after all bytecode has been generated for a block of - * assembly code. - * - * Results: - * Returns a standard Tcl result, with an error message left in the - * interpreter if appropriate. - * - * Side effects: - * The program is checked to see if any undefined labels remain. The - * initial stack depth of all the basic blocks in the flow graph is - * calculated and saved. The stack balance on exit is computed, checked - * and saved. - * - *----------------------------------------------------------------------------- - */ - -static int -FinishAssembly( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - int mustMove; /* Amount by which the code needs to be grown - * because of expanding jumps */ - - /* - * Resolve the targets of all jumps and determine whether code needs to be - * moved around. - */ - - if (CalculateJumpRelocations(assemEnvPtr, &mustMove)) { - return TCL_ERROR; - } - - /* - * Move the code if necessary. - */ - - if (mustMove) { - MoveCodeForJumps(assemEnvPtr, mustMove); - } - - /* - * Resolve jump target labels to bytecode offsets. - */ - - FillInJumpOffsets(assemEnvPtr); - - /* - * Label each basic block with its catch context. Quit on inconsistency. - */ - - if (ProcessCatches(assemEnvPtr) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Make sure that no block accessible from a catch's error exit that hasn't - * popped the exception stack can throw an exception. - */ - - if (CheckForThrowInWrongContext(assemEnvPtr) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Compute stack balance throughout the program. - */ - - if (CheckStack(assemEnvPtr) != TCL_OK) { - return TCL_ERROR; - } - - /* - * TODO - Check for unreachable code. Or maybe not; unreachable code is - * Mostly Harmless. - */ - - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * CalculateJumpRelocations -- - * - * Calculate any movement that has to be done in the assembly code to - * expand JUMP1 instructions to JUMP4 (because they jump more than a - * 1-byte range). - * - * Results: - * Returns a standard Tcl result, with an appropriate error message if - * anything fails. - * - * Side effects: - * Sets the 'startOffset' pointer in every basic block to the new origin - * of the block, and turns off JUMP1 flags on instructions that must be - * expanded (and adjusts them to the corresponding JUMP4's). Does *not* - * store the jump offsets at this point. - * - * Sets *mustMove to 1 if and only if at least one instruction changed - * size so the code must be moved. - * - * As a side effect, also checks for undefined labels and reports them. - * - *----------------------------------------------------------------------------- - */ - -static int -CalculateJumpRelocations( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - int* mustMove) /* OUTPUT: Number of bytes that have been - * added to the code */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* bbPtr; /* Pointer to a basic block being checked */ - Tcl_HashEntry* entry; /* Exit label's entry in the symbol table */ - BasicBlock* jumpTarget; /* Basic block where the jump goes */ - int motion; /* Amount by which the code has expanded */ - int offset; /* Offset in the bytecode from a jump - * instruction to its target */ - unsigned opcode; /* Opcode in the bytecode being adjusted */ - - /* - * Iterate through basic blocks as long as a change results in code - * expansion. - */ - - *mustMove = 0; - do { - motion = 0; - for (bbPtr = assemEnvPtr->head_bb; - bbPtr != NULL; - bbPtr = bbPtr->successor1) { - /* - * Advance the basic block start offset by however many bytes we - * have inserted in the code up to this point - */ - - bbPtr->startOffset += motion; - - /* - * If the basic block references a label (and hence performs a - * jump), find the location of the label. Report an error if the - * label is missing. - */ - - if (bbPtr->jumpTarget != NULL) { - entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - TclGetString(bbPtr->jumpTarget)); - if (entry == NULL) { - ReportUndefinedLabel(assemEnvPtr, bbPtr, - bbPtr->jumpTarget); - return TCL_ERROR; - } - - /* - * 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; - } - } - } - - /* - * If the basic block references a jump table, that doesn't affect - * the code locations, but resolve the labels now, and store basic - * block pointers in the jumptable hash. - */ - - if (bbPtr->flags & BB_JUMPTABLE) { - if (CheckJumpTableLabels(assemEnvPtr, bbPtr) != TCL_OK) { - return TCL_ERROR; - } - } - } - *mustMove += motion; - } while (motion != 0); - - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * CheckJumpTableLabels -- - * - * Make sure that all the labels in a jump table are defined. - * - * Results: - * Returns TCL_OK if they are, TCL_ERROR if they aren't. - * - *----------------------------------------------------------------------------- - */ - -static int -CheckJumpTableLabels( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - BasicBlock* bbPtr) /* Basic block that ends in a jump table */ -{ - Tcl_HashTable* symHash = &bbPtr->jtPtr->hashTable; - /* Hash table with the symbols */ - Tcl_HashSearch search; /* Hash table iterator */ - Tcl_HashEntry* symEntryPtr; /* Hash entry for the symbols */ - Tcl_Obj* symbolObj; /* Jump target */ - Tcl_HashEntry* valEntryPtr; /* Hash entry for the resolutions */ - - /* - * 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); - return TCL_ERROR; - } - } - DEBUG_PRINT("}\n"); - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * ReportUndefinedLabel -- - * - * Report that a basic block refers to an undefined jump label - * - * Side effects: - * Stores an error message, error code, and line number information in - * the assembler's Tcl interpreter. - * - *----------------------------------------------------------------------------- - */ - -static void -ReportUndefinedLabel( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - BasicBlock* bbPtr, /* Basic block that contains the undefined - * label */ - Tcl_Obj* jumpTarget) /* Label of a jump target */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "undefined label \"%s\"", TclGetString(jumpTarget))); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOLABEL", - TclGetString(jumpTarget), NULL); - Tcl_SetErrorLine(interp, bbPtr->jumpLine); - } -} - -/* - *----------------------------------------------------------------------------- - * - * MoveCodeForJumps -- - * - * Move bytecodes in memory to accommodate JUMP1 instructions that have - * expanded to become JUMP4's. - * - *----------------------------------------------------------------------------- - */ - -static void -MoveCodeForJumps( - AssemblyEnv* assemEnvPtr, /* Assembler environment */ - int mustMove) /* Number of bytes of added code */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* bbPtr; /* Pointer to a basic block being checked */ - int topOffset; /* Bytecode offset of the following basic - * block before code motion */ - - /* - * Make sure that there is enough space in the bytecode array to - * accommodate the expanded code. - */ - - while (envPtr->codeEnd < envPtr->codeNext + mustMove) { - TclExpandCodeArray(envPtr); - } - - /* - * Iterate through the bytecodes in reverse order, and move them upward to - * their new homes. - */ - - topOffset = envPtr->codeNext - envPtr->codeStart; - for (bbPtr = assemEnvPtr->curr_bb; bbPtr != NULL; bbPtr = bbPtr->prevPtr) { - DEBUG_PRINT("move code from %d to %d\n", - bbPtr->originalStartOffset, bbPtr->startOffset); - memmove(envPtr->codeStart + bbPtr->startOffset, - envPtr->codeStart + bbPtr->originalStartOffset, - topOffset - bbPtr->originalStartOffset); - topOffset = bbPtr->originalStartOffset; - bbPtr->jumpOffset += (bbPtr->startOffset - bbPtr->originalStartOffset); - } - envPtr->codeNext += mustMove; -} - -/* - *----------------------------------------------------------------------------- - * - * FillInJumpOffsets -- - * - * Fill in the final offsets of all jump instructions once bytecode - * locations have been completely determined. - * - *----------------------------------------------------------------------------- - */ - -static void -FillInJumpOffsets( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* bbPtr; /* Pointer to a basic block being checked */ - Tcl_HashEntry* entry; /* Hashtable entry for a jump target label */ - BasicBlock* jumpTarget; /* Basic block where a jump goes */ - int fromOffset; /* Bytecode location of a jump instruction */ - int targetOffset; /* Bytecode location of a jump instruction's - * target */ - - 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, - envPtr->codeStart + fromOffset + 1); - } - } - if (bbPtr->flags & BB_JUMPTABLE) { - ResolveJumpTableTargets(assemEnvPtr, bbPtr); - } - } -} - -/* - *----------------------------------------------------------------------------- - * - * ResolveJumpTableTargets -- - * - * Puts bytecode addresses for the targets of a jumptable into the - * table - * - * Results: - * Returns TCL_OK if they are, TCL_ERROR if they aren't. - * - *----------------------------------------------------------------------------- - */ - -static void -ResolveJumpTableTargets( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - BasicBlock* bbPtr) /* Basic block that ends in a jump table */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_HashTable* symHash = &bbPtr->jtPtr->hashTable; - /* Hash table with the symbols */ - Tcl_HashSearch search; /* Hash table iterator */ - Tcl_HashEntry* symEntryPtr; /* Hash entry for the symbols */ - Tcl_Obj* symbolObj; /* Jump target */ - Tcl_HashEntry* valEntryPtr; /* Hash entry for the resolutions */ - int auxDataIndex; /* Index of the auxdata */ - JumptableInfo* realJumpTablePtr; - /* Jump table in the actual code */ - Tcl_HashTable* realJumpHashPtr; - /* Jump table hash in the actual code */ - Tcl_HashEntry* realJumpEntryPtr; - /* Entry in the jump table hash in - * the actual code */ - 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); - - Tcl_SetHashValue(realJumpEntryPtr, - INT2PTR(jumpTargetBBPtr->startOffset - bbPtr->jumpOffset)); - } - DEBUG_PRINT("}\n"); -} - -/* - *----------------------------------------------------------------------------- - * - * CheckForThrowInWrongContext -- - * - * Verify that no beginCatch/endCatch sequence can throw an exception - * after an original exception is caught and before its exception context - * is removed from the stack. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Stores an appropriate error message in the interpreter as needed. - * - *----------------------------------------------------------------------------- - */ - -static int -CheckForThrowInWrongContext( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - BasicBlock* blockPtr; /* Current basic block */ - - /* - * Walk through the basic blocks in turn, checking all the ones that have - * caught an exception and not disposed of it properly. - */ - - for (blockPtr = assemEnvPtr->head_bb; - blockPtr != NULL; - blockPtr = blockPtr->successor1) { - if (blockPtr->catchState == BBCS_CAUGHT) { - /* - * Walk through the instructions in the basic block. - */ - - if (CheckNonThrowingBlock(assemEnvPtr, blockPtr) != TCL_OK) { - return TCL_ERROR; - } - } - } - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * CheckNonThrowingBlock -- - * - * Check that a basic block cannot throw an exception. - * - * Results: - * Returns TCL_ERROR if the block cannot be proven to be nonthrowing. - * - * Side effects: - * Stashes an error message in the interpreter result. - * - *----------------------------------------------------------------------------- - */ - -static int -CheckNonThrowingBlock( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - BasicBlock* blockPtr) /* Basic block where exceptions are not - * allowed */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - BasicBlock* nextPtr; /* Pointer to the succeeding basic block */ - int offset; /* Bytecode offset of the current - * instruction */ - int bound; /* Bytecode offset following the last - * instruction of the block. */ - unsigned char opcode; /* Current bytecode instruction */ - - /* - * Determine where in the code array the basic block ends. - */ - - nextPtr = blockPtr->successor1; - if (nextPtr == NULL) { - bound = envPtr->codeNext - envPtr->codeStart; - } else { - bound = nextPtr->startOffset; - } - - /* - * Walk through the instructions of the block. - */ - - offset = blockPtr->startOffset; - while (offset < bound) { - /* - * Determine whether an instruction is nonthrowing. - */ - - opcode = (envPtr->codeStart)[offset]; - if (BytecodeMightThrow(opcode)) { - /* - * Report an error for a throw in the wrong context. - */ - - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" instruction may not appear in " - "a context where an exception has been " - "caught and not disposed of.", - tclInstructionTable[opcode].name)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADTHROW", NULL); - AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr); - } - return TCL_ERROR; - } - offset += tclInstructionTable[opcode].numBytes; - } - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * BytecodeMightThrow -- - * - * Tests if a given bytecode instruction might throw an exception. - * - * Results: - * Returns 1 if the bytecode might throw an exception, 0 if the - * instruction is known never to throw. - * - *----------------------------------------------------------------------------- - */ - -static int -BytecodeMightThrow( - unsigned char opcode) -{ - /* - * Binary search on the non-throwing bytecode list. - */ - - int min = 0; - int max = sizeof(NonThrowingByteCodes) - 1; - int mid; - unsigned char c; - - while (max >= min) { - mid = (min + max) / 2; - c = NonThrowingByteCodes[mid]; - if (opcode < c) { - max = mid-1; - } else if (opcode > c) { - min = mid+1; - } else { - /* - * Opcode is nonthrowing. - */ - - return 0; - } - } - - return 1; -} - -/* - *----------------------------------------------------------------------------- - * - * CheckStack -- - * - * Audit stack usage in a block of assembly code. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Updates stack depth on entry for all basic blocks in the flowgraph. - * Calculates the max stack depth used in the program, and updates the - * compilation environment to reflect it. - * - *----------------------------------------------------------------------------- - */ - -static int -CheckStack( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - int maxDepth; /* Maximum stack depth overall */ - - /* - * Checking the head block will check all the other blocks recursively. - */ - - assemEnvPtr->maxDepth = 0; - if (StackCheckBasicBlock(assemEnvPtr, assemEnvPtr->head_bb, NULL, - 0) == TCL_ERROR) { - return TCL_ERROR; - } - - /* - * Post the max stack depth back to the compilation environment. - */ - - maxDepth = assemEnvPtr->maxDepth + envPtr->currStackDepth; - if (maxDepth > envPtr->maxStackDepth) { - envPtr->maxStackDepth = maxDepth; - } - - /* - * If the exit is reachable, make sure that the program exits with 1 - * operand on the stack. - */ - - if (StackCheckExit(assemEnvPtr) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Reset the visited state on all basic blocks. - */ - - ResetVisitedBasicBlocks(assemEnvPtr); - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * StackCheckBasicBlock -- - * - * Checks stack consumption for a basic block (and recursively for its - * successors). - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Updates initial stack depth for the basic block and its successors. - * (Final and maximum stack depth are relative to initial, and are not - * touched). - * - * This procedure eventually checks, for the entire flow graph, whether stack - * balance is consistent. It is an error for a given basic block to be - * reachable along multiple flow paths with different stack depths. - * - *----------------------------------------------------------------------------- - */ - -static int -StackCheckBasicBlock( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - BasicBlock* blockPtr, /* Pointer to the basic block being checked */ - BasicBlock* predecessor, /* Pointer to the block that passed control to - * this one. */ - int initialStackDepth) /* Stack depth on entry to the block */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - BasicBlock* jumpTarget; /* Basic block where a jump goes */ - int stackDepth; /* Current stack depth */ - int maxDepth; /* Maximum stack depth so far */ - int result; /* Tcl status return */ - Tcl_HashSearch jtSearch; /* Search structure for the jump table */ - Tcl_HashEntry* jtEntry; /* Hash entry in the jump table */ - Tcl_Obj* targetLabel; /* Target label from the jump table */ - Tcl_HashEntry* entry; /* Hash entry in the label table */ - - if (blockPtr->flags & BB_VISITED) { - /* - * If the block is already visited, check stack depth for consistency - * among the paths that reach it. - */ - - if (blockPtr->initialStackDepth == initialStackDepth) { - return TCL_OK; - } - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "inconsistent stack depths on two execution paths", -1)); - - /* - * TODO - add execution trace of both paths - */ - - Tcl_SetErrorLine(interp, blockPtr->startLine); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL); - } - return TCL_ERROR; - } - - /* - * If the block is not already visited, set the 'predecessor' link to - * indicate how control got to it. Set the initial stack depth to the - * current stack depth in the flow of control. - */ - - blockPtr->flags |= BB_VISITED; - blockPtr->predecessor = predecessor; - blockPtr->initialStackDepth = initialStackDepth; - - /* - * Calculate minimum stack depth, and flag an error if the block - * underflows the stack. - */ - - if (initialStackDepth + blockPtr->minStackDepth < 0) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("stack underflow", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL); - AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr); - Tcl_SetErrorLine(interp, blockPtr->startLine); - } - return TCL_ERROR; - } - - /* - * Make sure that the block doesn't try to pop below the stack level of an - * enclosing catch. - */ - - if (blockPtr->enclosingCatch != 0 && - initialStackDepth + blockPtr->minStackDepth - < (blockPtr->enclosingCatch->initialStackDepth - + blockPtr->enclosingCatch->finalStackDepth)) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "code pops stack below level of enclosing catch", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACKINCATCH", -1); - AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr); - Tcl_SetErrorLine(interp, blockPtr->startLine); - } - return TCL_ERROR; - } - - /* - * Update maximum stgack depth. - */ - - maxDepth = initialStackDepth + blockPtr->maxStackDepth; - if (maxDepth > assemEnvPtr->maxDepth) { - assemEnvPtr->maxDepth = maxDepth; - } - - /* - * Calculate stack depth on exit from the block, and invoke this procedure - * recursively to check successor blocks. - */ - - stackDepth = initialStackDepth + blockPtr->finalStackDepth; - result = TCL_OK; - if (blockPtr->flags & BB_FALLTHRU) { - 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; -} - -/* - *----------------------------------------------------------------------------- - * - * StackCheckExit -- - * - * Makes sure that the net stack effect of an entire assembly language - * script is to push 1 result. - * - * Results: - * Returns a standard Tcl result, with an error message in the - * interpreter result if the stack is wrong. - * - * Side effects: - * If the assembly code had a net stack effect of zero, emits code to the - * concluding block to push a null result. In any case, updates the stack - * depth in the compile environment to reflect the net effect of the - * assembly code. - * - *----------------------------------------------------------------------------- - */ - -static int -StackCheckExit( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - int depth; /* Net stack effect */ - int litIndex; /* Index in the literal pool of the empty - * string */ - BasicBlock* curr_bb = assemEnvPtr->curr_bb; - /* Final basic block in the assembly */ - - /* - * Don't perform these checks if execution doesn't reach the exit (either - * because of an infinite loop or because the only return is from the - * middle. - */ - - if (curr_bb->flags & BB_VISITED) { - /* - * Exit with no operands; push an empty one. - */ - - depth = curr_bb->finalStackDepth + curr_bb->initialStackDepth; - if (depth == 0) { - /* - * Emit a 'push' of the empty literal. - */ - - litIndex = TclRegisterLiteral(envPtr, "", 0, 0); - - /* - * Assumes that 'push' is at slot 0 in TalInstructionTable. - */ - - BBEmitInst1or4(assemEnvPtr, 0, litIndex, 0); - ++depth; - } - - /* - * Exit with unbalanced stack. - */ - - if (depth != 1) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "stack is unbalanced on exit from the code (depth=%d)", - depth)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL); - } - return TCL_ERROR; - } - - /* - * Record stack usage. - */ - - envPtr->currStackDepth += depth; - } - - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * ProcessCatches -- - * - * First pass of 'catch' processing. - * - * Results: - * Returns a standard Tcl result, with an appropriate error message if - * the result is TCL_ERROR. - * - * Side effects: - * Labels all basic blocks with their enclosing catches. - * - *----------------------------------------------------------------------------- - */ - -static int -ProcessCatches( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - BasicBlock* blockPtr; /* Pointer to a basic block */ - - /* - * Clear the catch state of all basic blocks. - */ - - for (blockPtr = assemEnvPtr->head_bb; - blockPtr != NULL; - blockPtr = blockPtr->successor1) { - blockPtr->catchState = BBCS_UNKNOWN; - blockPtr->enclosingCatch = NULL; - } - - /* - * Start the check recursively from the first basic block, which is - * outside any exception context - */ - - if (ProcessCatchesInBasicBlock(assemEnvPtr, assemEnvPtr->head_bb, - NULL, BBCS_NONE, 0) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Check for unclosed catch on exit. - */ - - if (CheckForUnclosedCatches(assemEnvPtr) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Now there's enough information to build the exception ranges. - */ - - if (BuildExceptionRanges(assemEnvPtr) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Finally, restore any exception ranges from embedded scripts. - */ - - RestoreEmbeddedExceptionRanges(assemEnvPtr); - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * ProcessCatchesInBasicBlock -- - * - * First-pass catch processing for one basic block. - * - * Results: - * Returns a standard Tcl result, with error message in the interpreter - * result if an error occurs. - * - * This procedure checks consistency of the exception context through the - * assembler program, and records the enclosing 'catch' for every basic block. - * - *----------------------------------------------------------------------------- - */ - -static int -ProcessCatchesInBasicBlock( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - BasicBlock* bbPtr, /* Basic block being processed */ - BasicBlock* enclosing, /* Start basic block of the enclosing catch */ - enum BasicBlockCatchState state, - /* BBCS_NONE, BBCS_INCATCH, or BBCS_CAUGHT */ - int catchDepth) /* Depth of nesting of catches */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - int result; /* Return value from this procedure */ - BasicBlock* fallThruEnclosing; - /* Enclosing catch if execution falls thru */ - enum BasicBlockCatchState fallThruState; - /* Catch state of the successor block */ - BasicBlock* jumpEnclosing; /* Enclosing catch if execution goes to jump - * target */ - enum BasicBlockCatchState jumpState; - /* Catch state of the jump target */ - int changed = 0; /* Flag == 1 iff successor blocks need to be - * checked because the state of this block has - * changed. */ - BasicBlock* jumpTarget; /* Basic block where a jump goes */ - Tcl_HashSearch jtSearch; /* Hash search control for a jumptable */ - Tcl_HashEntry* jtEntry; /* Entry in a jumptable */ - Tcl_Obj* targetLabel; /* Target label from a jumptable */ - Tcl_HashEntry* entry; /* Entry from the label table */ - - /* - * Update the state of the current block, checking for consistency. Set - * 'changed' to 1 if the state changes and successor blocks need to be - * rechecked. - */ - - if (bbPtr->catchState == BBCS_UNKNOWN) { - bbPtr->enclosingCatch = enclosing; - } else if (bbPtr->enclosingCatch != enclosing) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "execution reaches an instruction in inconsistent " - "exception contexts", -1)); - Tcl_SetErrorLine(interp, bbPtr->startLine); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADCATCH", NULL); - } - return TCL_ERROR; - } - if (state > bbPtr->catchState) { - bbPtr->catchState = state; - changed = 1; - } - - /* - * If this block has been visited before, and its state hasn't changed, - * we're done with it for now. - */ - - if (!changed) { - return TCL_OK; - } - bbPtr->catchDepth = catchDepth; - - /* - * Determine enclosing catch and 'caught' state for the fallthrough and - * the jump target. Default for both is the state of the current block. - */ - - fallThruEnclosing = enclosing; - fallThruState = state; - jumpEnclosing = enclosing; - jumpState = state; - - /* - * TODO: Make sure that the test cases include validating that a natural - * loop can't include 'beginCatch' or 'endCatch' - */ - - if (bbPtr->flags & BB_BEGINCATCH) { - /* - * If the block begins a catch, the state for the successor is 'in - * catch'. The jump target is the exception exit, and the state of the - * jump target is 'caught.' - */ - - fallThruEnclosing = bbPtr; - fallThruState = BBCS_INCATCH; - jumpEnclosing = bbPtr; - jumpState = BBCS_CAUGHT; - ++catchDepth; - } - - if (bbPtr->flags & BB_ENDCATCH) { - /* - * If the block ends a catch, the state for the successor is whatever - * the state was on entry to the catch. - */ - - if (enclosing == NULL) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "endCatch without a corresponding beginCatch", -1)); - Tcl_SetErrorLine(interp, bbPtr->startLine); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADENDCATCH", NULL); - } - return TCL_ERROR; - } - fallThruEnclosing = enclosing->enclosingCatch; - fallThruState = enclosing->catchState; - --catchDepth; - } - - /* - * Visit any successor blocks with the appropriate exception context - */ - - result = TCL_OK; - 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; -} - -/* - *----------------------------------------------------------------------------- - * - * CheckForUnclosedCatches -- - * - * Checks that a sequence of assembly code has no unclosed catches on - * exit. - * - * Results: - * Returns a standard Tcl result, with an error message for unclosed - * catches. - * - *----------------------------------------------------------------------------- - */ - -static int -CheckForUnclosedCatches( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - - if (assemEnvPtr->curr_bb->catchState >= BBCS_INCATCH) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "catch still active on exit from assembly code", -1)); - Tcl_SetErrorLine(interp, - assemEnvPtr->curr_bb->enclosingCatch->startLine); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "UNCLOSEDCATCH", NULL); - } - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * BuildExceptionRanges -- - * - * Walks through the assembly code and builds exception ranges for the - * catches embedded therein. - * - * Results: - * Returns a standard Tcl result with an error message in the interpreter - * if anything is unsuccessful. - * - * Side effects: - * Each contiguous block of code with a given catch exit is assigned an - * exception range at the appropriate level. - * Exception ranges in embedded blocks have their levels corrected and - * collated into the table. - * Blocks that end with 'beginCatch' are associated with the innermost - * exception range of the following block. - * - *----------------------------------------------------------------------------- - */ - -static int -BuildExceptionRanges( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* bbPtr; /* Current basic block */ - BasicBlock* prevPtr = NULL; /* Previous basic block */ - int catchDepth = 0; /* Current catch depth */ - int maxCatchDepth = 0; /* Maximum catch depth in the program */ - BasicBlock** catches; /* Stack of catches in progress */ - int* catchIndices; /* Indices of the exception ranges of catches - * in progress */ - int i; - - /* - * Determine the max catch depth for the entire assembly script - * (excluding embedded eval's and expr's, which will be handled later). - */ - - for (bbPtr=assemEnvPtr->head_bb; bbPtr != NULL; bbPtr=bbPtr->successor1) { - if (bbPtr->catchDepth > maxCatchDepth) { - maxCatchDepth = bbPtr->catchDepth; - } - } - - /* - * Allocate memory for a stack of active catches. - */ - - catches = (BasicBlock**)Tcl_Alloc(maxCatchDepth * sizeof(BasicBlock*)); - catchIndices = (int *)Tcl_Alloc(maxCatchDepth * sizeof(int)); - for (i = 0; i < maxCatchDepth; ++i) { - catches[i] = NULL; - catchIndices[i] = -1; - } - - /* - * Walk through the basic blocks and manage exception ranges. - */ - - for (bbPtr=assemEnvPtr->head_bb; bbPtr != NULL; bbPtr=bbPtr->successor1) { - UnstackExpiredCatches(envPtr, bbPtr, catchDepth, catches, - catchIndices); - LookForFreshCatches(bbPtr, catches); - StackFreshCatches(assemEnvPtr, bbPtr, catchDepth, catches, - catchIndices); - - /* - * If the last block was a 'begin catch', fill in the exception range. - */ - - catchDepth = bbPtr->catchDepth; - if (prevPtr != NULL && (prevPtr->flags & BB_BEGINCATCH)) { - TclStoreInt4AtPtr(catchIndices[catchDepth-1], - envPtr->codeStart + bbPtr->startOffset - 4); - } - - prevPtr = bbPtr; - } - - /* Make sure that all catches are closed */ - - if (catchDepth != 0) { - Tcl_Panic("unclosed catch at end of code in " - "tclAssembly.c:BuildExceptionRanges, can't happen"); - } - - /* Free temp storage */ - - Tcl_Free(catchIndices); - Tcl_Free(catches); - - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * UnstackExpiredCatches -- - * - * Unstacks and closes the exception ranges for any catch contexts that - * were active in the previous basic block but are inactive in the - * current one. - * - *----------------------------------------------------------------------------- - */ - -static void -UnstackExpiredCatches( - CompileEnv* envPtr, /* Compilation environment */ - BasicBlock* bbPtr, /* Basic block being processed */ - 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 - * block being entered. - */ - - while (catchDepth > bbPtr->catchDepth) { - --catchDepth; - if (catches[catchDepth] != NULL) { - range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; - range->numCodeBytes = bbPtr->startOffset - range->codeOffset; - catches[catchDepth] = NULL; - catchIndices[catchDepth] = -1; - } - } - - /* - * 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; - } - } -} - -/* - *----------------------------------------------------------------------------- - * - * LookForFreshCatches -- - * - * Determines whether a basic block being entered needs any exception - * ranges that are not already stacked. - * - * Does not create the ranges: this procedure iterates from the innermost - * catch outward, but exception ranges must be created from the outermost - * catch inward. - * - *----------------------------------------------------------------------------- - */ - -static void -LookForFreshCatches( - 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 -- - * - * Make ExceptionRange records for any catches that are in the basic - * block being entered and were not in the previous basic block. - * - *----------------------------------------------------------------------------- - */ - -static void -StackFreshCatches( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - BasicBlock* bbPtr, /* Basic block being processed */ - 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 */ -{ - 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; - } - } -} - -/* - *----------------------------------------------------------------------------- - * - * RestoreEmbeddedExceptionRanges -- - * - * Processes an assembly script, replacing any exception ranges that - * were present in embedded code. - * - *----------------------------------------------------------------------------- - */ - -static void -RestoreEmbeddedExceptionRanges( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* bbPtr; /* Current basic block */ - int rangeBase; /* Base of the foreign exception ranges when - * they are reinstalled */ - int rangeIndex; /* Index of the current foreign exception - * range as reinstalled */ - ExceptionRange* range; /* Current foreign exception range */ - unsigned char opcode; /* Current instruction's opcode */ - int catchIndex; /* Index of the exception range to which the - * current instruction refers */ - int i; - - /* - * Walk the basic blocks looking for exceptions in embedded scripts. - */ - - for (bbPtr = assemEnvPtr->head_bb; - bbPtr != NULL; - bbPtr = bbPtr->successor1) { - if (bbPtr->foreignExceptionCount != 0) { - /* - * Reinstall the embedded exceptions and track their nesting level - */ - - rangeBase = envPtr->exceptArrayNext; - for (i = 0; i < bbPtr->foreignExceptionCount; ++i) { - range = bbPtr->foreignExceptions + i; - rangeIndex = TclCreateExceptRange(range->type, envPtr); - range->nestingLevel += envPtr->exceptDepth + bbPtr->catchDepth; - memcpy(envPtr->exceptArrayPtr + rangeIndex, range, - sizeof(ExceptionRange)); - if (range->nestingLevel >= envPtr->maxExceptDepth) { - envPtr->maxExceptDepth = range->nestingLevel + 1; - } - } - - /* - * Walk through the bytecode of the basic block, and relocate - * INST_BEGIN_CATCH4 instructions to the new locations - */ - - i = bbPtr->startOffset; - while (i < bbPtr->successor1->startOffset) { - opcode = envPtr->codeStart[i]; - if (opcode == INST_BEGIN_CATCH4) { - catchIndex = TclGetUInt4AtPtr(envPtr->codeStart + i + 1); - if (catchIndex >= bbPtr->foreignExceptionBase - && catchIndex < (bbPtr->foreignExceptionBase + - bbPtr->foreignExceptionCount)) { - catchIndex -= bbPtr->foreignExceptionBase; - catchIndex += rangeBase; - TclStoreInt4AtPtr(catchIndex, envPtr->codeStart+i+1); - } - } - i += tclInstructionTable[opcode].numBytes; - } - } - } -} - -/* - *----------------------------------------------------------------------------- - * - * ResetVisitedBasicBlocks -- - * - * Turns off the 'visited' flag in all basic blocks at the conclusion - * of a pass. - * - *----------------------------------------------------------------------------- - */ - -static void -ResetVisitedBasicBlocks( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - BasicBlock* block; - - for (block = assemEnvPtr->head_bb; block != NULL; - block = block->successor1) { - block->flags &= ~BB_VISITED; - } -} - -/* - *----------------------------------------------------------------------------- - * - * AddBasicBlockRangeToErrorInfo -- - * - * Updates the error info of the Tcl interpreter to show a given basic - * block in the code. - * - * This procedure is used to label the callstack with source location - * information when reporting an error in stack checking. - * - *----------------------------------------------------------------------------- - */ - -static void -AddBasicBlockRangeToErrorInfo( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - BasicBlock* bbPtr) /* Basic block in which the error is found */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - Tcl_Obj* lineNo; /* Line number in the source */ - - Tcl_AddErrorInfo(interp, "\n in assembly code between lines "); - TclNewIntObj(lineNo, bbPtr->startLine); - Tcl_IncrRefCount(lineNo); - Tcl_AppendObjToErrorInfo(interp, lineNo); - Tcl_AddErrorInfo(interp, " and "); - if (bbPtr->successor1 != NULL) { - TclSetIntObj(lineNo, bbPtr->successor1->startLine); - Tcl_AppendObjToErrorInfo(interp, lineNo); - } else { - Tcl_AddErrorInfo(interp, "end of assembly code"); - } - Tcl_DecrRefCount(lineNo); -} - -/* - *----------------------------------------------------------------------------- - * - * DupAssembleCodeInternalRep -- - * - * Part of the Tcl object type implementation for Tcl assembly language - * bytecode. We do not copy the bytecode intrep. Instead, we return - * without setting copyPtr->typePtr, so the copy is a plain string copy - * of the assembly source, and if it is to be used as a compiled - * expression, it will need to be reprocessed. - * - * This makes sense, because with Tcl's copy-on-write practices, the - * usual (only?) time Tcl_DuplicateObj() will be called is when the copy - * is about to be modified, which would invalidate any copied bytecode - * anyway. The only reason it might make sense to copy the bytecode is if - * we had some modifying routines that operated directly on the intrep, - * as we do for lists and dicts. - * - * Results: - * None. - * - * Side effects: - * None. - * - *----------------------------------------------------------------------------- - */ - -static void -DupAssembleCodeInternalRep( - TCL_UNUSED(Tcl_Obj *), - TCL_UNUSED(Tcl_Obj *)) -{ - return; -} - -/* - *----------------------------------------------------------------------------- - * - * FreeAssembleCodeInternalRep -- - * - * Part of the Tcl object type implementation for Tcl expression - * bytecode. Frees the storage allocated to hold the internal rep, unless - * ref counts indicate bytecode execution is still in progress. - * - * Results: - * None. - * - * Side effects: - * May free allocated memory. Leaves objPtr untyped. - * - *----------------------------------------------------------------------------- - */ - -static void -FreeAssembleCodeInternalRep( - Tcl_Obj *objPtr) -{ - ByteCode *codePtr; - - ByteCodeGetIntRep(objPtr, &assembleCodeType, codePtr); - assert(codePtr != NULL); - - TclReleaseByteCode(codePtr); -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ Index: generic/tclAsync.c ================================================================== --- generic/tclAsync.c +++ generic/tclAsync.c @@ -116,11 +116,11 @@ ClientData clientData) /* Argument to pass to handler. */ { AsyncHandler *asyncPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - asyncPtr = (AsyncHandler*)Tcl_Alloc(sizeof(AsyncHandler)); + asyncPtr = (AsyncHandler *) ckalloc(sizeof(AsyncHandler)); asyncPtr->ready = 0; asyncPtr->nextPtr = NULL; asyncPtr->proc = proc; asyncPtr->clientData = clientData; asyncPtr->originTsd = tsdPtr; @@ -233,11 +233,11 @@ if (asyncPtr == NULL) { break; } asyncPtr->ready = 0; Tcl_MutexUnlock(&tsdPtr->asyncMutex); - code = asyncPtr->proc(asyncPtr->clientData, interp, code); + code = (*asyncPtr->proc)(asyncPtr->clientData, interp, code); Tcl_MutexLock(&tsdPtr->asyncMutex); } tsdPtr->asyncActive = 0; Tcl_MutexUnlock(&tsdPtr->asyncMutex); return code; @@ -258,11 +258,11 @@ * The state associated with the handler is deleted. * * Failure to locate the handler in current thread private list * of async handlers will result in panic; exception: the list * is already empty (potential trouble?). - * Consequently, threads should create and delete handlers + * Consequently, threads should create and delete handlers * themselves. I.e. a handler created by one should not be * deleted by some other thread. * *---------------------------------------------------------------------- */ @@ -308,11 +308,11 @@ if (asyncPtr == tsdPtr->lastHandler) { tsdPtr->lastHandler = prevPtr; } } Tcl_MutexUnlock(&tsdPtr->asyncMutex); - Tcl_Free(asyncPtr); + ckfree((char *) asyncPtr); } /* *---------------------------------------------------------------------- * Index: generic/tclBasic.c ================================================================== --- generic/tclBasic.c +++ generic/tclBasic.c @@ -8,66 +8,21 @@ * Copyright (c) 1987-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2007 Daniel A. Steffen - * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. - * Copyright (c) 2008 Miguel Sofer * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" -#include "tclOOInt.h" #include "tclCompile.h" -#include "tclTomMath.h" +#include +#include #include -#include - -/* - * 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 -#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 +#include "tommath.h" /* * Determine whether we're using IEEE floating point */ @@ -76,406 +31,229 @@ /* Largest odd integer that can be represented exactly in a double */ # define MAX_EXACT 9007199254740991.0 #endif /* - * 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. */ - size_t 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); - -/* - * Table used to map command implementation functions to a human-readable type - * name, for [info type]. The keys in the table are function addresses, and - * the values in the table are static char* containing strings in Tcl's - * internal encoding (almost UTF-8). - */ - -static Tcl_HashTable commandTypeTable; -static int commandTypeInit = 0; -TCL_DECLARE_MUTEX(commandTypeLock); - -/* - * Declarations for managing contexts for non-recursive coroutines. Contexts - * are used to save the evaluation state between NR calls to each coro. - */ - -#define SAVE_CONTEXT(context) \ - (context).framePtr = iPtr->framePtr; \ - (context).varFramePtr = iPtr->varFramePtr; \ - (context).cmdFramePtr = iPtr->cmdFramePtr; \ - (context).lineLABCPtr = iPtr->lineLABCPtr - -#define RESTORE_CONTEXT(context) \ - iPtr->framePtr = (context).framePtr; \ - iPtr->varFramePtr = (context).varFramePtr; \ - iPtr->cmdFramePtr = (context).cmdFramePtr; \ - iPtr->lineLABCPtr = (context).lineLABCPtr - + * 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; + /* * Static functions in this file: */ -static Tcl_ObjCmdProc BadEnsembleSubcommand; -static char * CallCommandTraces(Interp *iPtr, Command *cmdPtr, - const char *oldName, const char *newName, - int flags); -static int CancelEvalProc(ClientData clientData, - Tcl_Interp *interp, int code); -static int CheckDoubleResult(Tcl_Interp *interp, double dResult); -static void DeleteCoroutine(ClientData clientData); -static void DeleteInterpProc(Tcl_Interp *interp); -static void DeleteOpCmdClientData(ClientData clientData); +static char * CallCommandTraces(Interp *iPtr, Command *cmdPtr, + const char *oldName, const char *newName, int flags); +static int CheckDoubleResult(Tcl_Interp *interp, double dResult); +static void DeleteInterpProc(Tcl_Interp *interp); +static void DeleteOpCmdClientData(ClientData clientData); +static Tcl_Obj *GetCommandSource(Interp *iPtr, const char *command, + int numChars, int objc, Tcl_Obj *const objv[]); +static void ProcessUnexpectedResult(Tcl_Interp *interp, int returnCode); +static int OldMathFuncProc(ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *const *objv); +static void OldMathFuncDeleteProc(ClientData clientData); +static int ExprAbsFunc(ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *const *objv); +static int ExprBinaryFunc(ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *const *objv); +static int ExprBoolFunc(ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *const *objv); +static int ExprCeilFunc(ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *const *objv); +static int ExprDoubleFunc(ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *const *objv); +static int ExprEntierFunc(ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *const *objv); +static int ExprFloorFunc(ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *const *objv); +static int ExprIntFunc(ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *const *objv); +static int ExprIsqrtFunc(ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *const *objv); +static int ExprRandFunc(ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *const *objv); +static int ExprRoundFunc(ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *const *objv); +static int ExprSqrtFunc(ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *const *objv); +static int ExprSrandFunc(ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *const *objv); +static int ExprUnaryFunc(ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *const *objv); +static int ExprWideFunc(ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *const *objv); +static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, + int actual, Tcl_Obj *const *objv); #ifdef USE_DTRACE -static Tcl_ObjCmdProc DTraceObjCmd; -static Tcl_NRPostProc DTraceCmdReturn; -#else -# define DTraceCmdReturn NULL -#endif /* USE_DTRACE */ -static Tcl_ObjCmdProc ExprAbsFunc; -static Tcl_ObjCmdProc ExprBinaryFunc; -static Tcl_ObjCmdProc ExprBoolFunc; -static Tcl_ObjCmdProc ExprCeilFunc; -static Tcl_ObjCmdProc ExprDoubleFunc; -static Tcl_ObjCmdProc ExprFloorFunc; -static Tcl_ObjCmdProc ExprIntFunc; -static Tcl_ObjCmdProc ExprIsqrtFunc; -static Tcl_ObjCmdProc ExprIsFiniteFunc; -static Tcl_ObjCmdProc ExprIsInfinityFunc; -static Tcl_ObjCmdProc ExprIsNaNFunc; -static Tcl_ObjCmdProc ExprIsNormalFunc; -static Tcl_ObjCmdProc ExprIsSubnormalFunc; -static Tcl_ObjCmdProc ExprIsUnorderedFunc; -static Tcl_ObjCmdProc ExprMaxFunc; -static Tcl_ObjCmdProc ExprMinFunc; -static Tcl_ObjCmdProc ExprRandFunc; -static Tcl_ObjCmdProc ExprRoundFunc; -static Tcl_ObjCmdProc ExprSqrtFunc; -static Tcl_ObjCmdProc ExprSrandFunc; -static Tcl_ObjCmdProc ExprUnaryFunc; -static Tcl_ObjCmdProc ExprWideFunc; -static Tcl_ObjCmdProc FloatClassifyObjCmd; -static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, - int actual, Tcl_Obj *const *objv); -static Tcl_NRPostProc NRCoroutineCallerCallback; -static Tcl_NRPostProc NRCoroutineExitCallback; -static Tcl_NRPostProc NRCommand; - -static void ProcessUnexpectedResult(Tcl_Interp *interp, - int returnCode); -static int RewindCoroutine(CoroutineData *corPtr, int result); -static void TEOV_SwitchVarFrame(Tcl_Interp *interp); -static void TEOV_PushExceptionHandlers(Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[], int flags); -static inline Command * TEOV_LookupCmdFromObj(Tcl_Interp *interp, - Tcl_Obj *namePtr, Namespace *lookupNsPtr); -static int TEOV_NotFound(Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[], Namespace *lookupNsPtr); -static int TEOV_RunEnterTraces(Tcl_Interp *interp, - Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc, - Tcl_Obj *const objv[]); -static Tcl_NRPostProc RewindCoroutineCallback; -static Tcl_NRPostProc TEOEx_ByteCodeCallback; -static Tcl_NRPostProc TEOEx_ListCallback; -static Tcl_NRPostProc TEOV_Error; -static Tcl_NRPostProc TEOV_Exception; -static Tcl_NRPostProc TEOV_NotFoundCallback; -static Tcl_NRPostProc TEOV_RestoreVarFrame; -static Tcl_NRPostProc TEOV_RunLeaveTraces; -static Tcl_NRPostProc EvalObjvCore; -static Tcl_NRPostProc Dispatch; - -static Tcl_ObjCmdProc NRInjectObjCmd; -static Tcl_NRPostProc NRPostInvoke; -static Tcl_ObjCmdProc CoroTypeObjCmd; -static Tcl_ObjCmdProc TclNRCoroInjectObjCmd; -static Tcl_ObjCmdProc TclNRCoroProbeObjCmd; -static Tcl_NRPostProc InjectHandler; -static Tcl_NRPostProc InjectHandlerPostCall; - -MODULE_SCOPE const TclStubs tclStubs; - -/* - * Magical counts for the number of arguments accepted by a coroutine command - * after particular kinds of [yield]. - */ - -#define CORO_ACTIVATE_YIELD PTR2INT(NULL) -#define CORO_ACTIVATE_YIELDM PTR2INT(NULL)+1 - -#define COROUTINE_ARGUMENTS_SINGLE_OPTIONAL (-1) -#define COROUTINE_ARGUMENTS_ARBITRARY (-2) - +static int DTraceObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +#endif + +extern TclStubs tclStubs; + /* * The following structure define the commands in the Tcl core. */ typedef struct { const char *name; /* Name of object-based command. */ Tcl_ObjCmdProc *objProc; /* Object-based function for command. */ CompileProc *compileProc; /* Function called to compile command. */ - Tcl_ObjCmdProc *nreProc; /* NR-based function for command */ - int flags; /* Various flag bits, as defined below. */ + int isSafe; /* If non-zero, command will be present in + * safe interpreter. Otherwise it will be + * hidden. */ } CmdInfo; -#define CMD_IS_SAFE 1 /* Whether this command is part of the set of - * commands present by default in a safe - * interpreter. */ -/* CMD_COMPILES_EXPANDED - Whether the compiler for this command can handle - * expansion for itself rather than needing the generic layer to take care of - * it for it. Defined in tclInt.h. */ - -/* - * The following struct states that the command it talks about (a subcommand - * of one of Tcl's built-in ensembles) is unsafe and must be hidden when an - * interpreter is made safe. (TclHideUnsafeCommands accesses an array of these - * structs.) Alas, we can't sensibly just store the information directly in - * the commands. - */ - -typedef struct { - const char *ensembleNsName; /* The ensemble's name within ::tcl. NULL for - * the end of the list of commands to hide. */ - const char *commandName; /* The name of the command within the - * ensemble. If this is NULL, we want to also - * make the overall command be hidden, an ugly - * hack because it is expected by security - * policies in the wild. */ -} UnsafeEnsembleInfo; - /* * The built-in commands, and the functions that implement them: */ static const CmdInfo builtInCmds[] = { /* * Commands in the generic core. */ - {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE}, - {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, CMD_IS_SAFE}, - {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, CMD_IS_SAFE}, - {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE}, - {"concat", Tcl_ConcatObjCmd, TclCompileConcatCmd, NULL, CMD_IS_SAFE}, - {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, CMD_IS_SAFE}, - {"coroinject", NULL, NULL, TclNRCoroInjectObjCmd, CMD_IS_SAFE}, - {"coroprobe", NULL, NULL, TclNRCoroProbeObjCmd, CMD_IS_SAFE}, - {"coroutine", NULL, NULL, TclNRCoroutineObjCmd, CMD_IS_SAFE}, - {"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, CMD_IS_SAFE}, - {"eval", Tcl_EvalObjCmd, NULL, TclNREvalObjCmd, CMD_IS_SAFE}, - {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, TclNRExprObjCmd, CMD_IS_SAFE}, - {"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, CMD_IS_SAFE}, - {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, CMD_IS_SAFE}, - {"format", Tcl_FormatObjCmd, TclCompileFormatCmd, NULL, CMD_IS_SAFE}, - {"fpclassify", FloatClassifyObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, CMD_IS_SAFE}, - {"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, CMD_IS_SAFE}, - {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, CMD_IS_SAFE}, - {"join", Tcl_JoinObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, CMD_IS_SAFE}, - {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, CMD_IS_SAFE}, - {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, CMD_IS_SAFE}, - {"linsert", Tcl_LinsertObjCmd, TclCompileLinsertCmd, NULL, CMD_IS_SAFE}, - {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED}, - {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, CMD_IS_SAFE}, - {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, CMD_IS_SAFE}, - {"lpop", Tcl_LpopObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, CMD_IS_SAFE}, - {"lremove", Tcl_LremoveObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE}, - {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE}, - {"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"package", Tcl_PackageObjCmd, NULL, TclNRPackageObjCmd, CMD_IS_SAFE}, - {"proc", Tcl_ProcObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, CMD_IS_SAFE}, - {"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, CMD_IS_SAFE}, - {"rename", Tcl_RenameObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, NULL, CMD_IS_SAFE}, - {"scan", Tcl_ScanObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"set", Tcl_SetObjCmd, TclCompileSetCmd, NULL, CMD_IS_SAFE}, - {"split", Tcl_SplitObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"subst", Tcl_SubstObjCmd, TclCompileSubstCmd, TclNRSubstObjCmd, CMD_IS_SAFE}, - {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, TclNRSwitchObjCmd, CMD_IS_SAFE}, - {"tailcall", NULL, TclCompileTailcallCmd, TclNRTailcallObjCmd, CMD_IS_SAFE}, - {"throw", Tcl_ThrowObjCmd, TclCompileThrowCmd, NULL, CMD_IS_SAFE}, - {"trace", Tcl_TraceObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"try", Tcl_TryObjCmd, TclCompileTryCmd, TclNRTryObjCmd, CMD_IS_SAFE}, - {"unset", Tcl_UnsetObjCmd, TclCompileUnsetCmd, NULL, CMD_IS_SAFE}, - {"uplevel", Tcl_UplevelObjCmd, NULL, TclNRUplevelObjCmd, CMD_IS_SAFE}, - {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, CMD_IS_SAFE}, - {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, CMD_IS_SAFE}, - {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, CMD_IS_SAFE}, - {"yield", NULL, TclCompileYieldCmd, TclNRYieldObjCmd, CMD_IS_SAFE}, - {"yieldto", NULL, TclCompileYieldToCmd, TclNRYieldToObjCmd, CMD_IS_SAFE}, + {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, 1}, + {"apply", Tcl_ApplyObjCmd, NULL, 1}, + {"array", Tcl_ArrayObjCmd, NULL, 1}, + {"binary", Tcl_BinaryObjCmd, NULL, 1}, + {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, 1}, +#ifndef EXCLUDE_OBSOLETE_COMMANDS + {"case", Tcl_CaseObjCmd, NULL, 1}, +#endif + {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, 1}, + {"concat", Tcl_ConcatObjCmd, NULL, 1}, + {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, 1}, + {"error", Tcl_ErrorObjCmd, NULL, 1}, + {"eval", Tcl_EvalObjCmd, NULL, 1}, + {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, 1}, + {"for", Tcl_ForObjCmd, TclCompileForCmd, 1}, + {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, 1}, + {"format", Tcl_FormatObjCmd, NULL, 1}, + {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, 1}, + {"if", Tcl_IfObjCmd, TclCompileIfCmd, 1}, + {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, 1}, + {"join", Tcl_JoinObjCmd, NULL, 1}, + {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, 1}, + {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, 1}, + {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, 1}, + {"linsert", Tcl_LinsertObjCmd, NULL, 1}, + {"list", Tcl_ListObjCmd, TclCompileListCmd, 1}, + {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, 1}, + {"lrange", Tcl_LrangeObjCmd, NULL, 1}, + {"lrepeat", Tcl_LrepeatObjCmd, NULL, 1}, + {"lreplace", Tcl_LreplaceObjCmd, NULL, 1}, + {"lreverse", Tcl_LreverseObjCmd, NULL, 1}, + {"lsearch", Tcl_LsearchObjCmd, NULL, 1}, + {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, 1}, + {"lsort", Tcl_LsortObjCmd, NULL, 1}, + {"namespace", Tcl_NamespaceObjCmd, TclCompileNamespaceCmd, 1}, + {"package", Tcl_PackageObjCmd, NULL, 1}, + {"proc", Tcl_ProcObjCmd, NULL, 1}, + {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, 1}, + {"regsub", Tcl_RegsubObjCmd, NULL, 1}, + {"rename", Tcl_RenameObjCmd, NULL, 1}, + {"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, 1}, + {"scan", Tcl_ScanObjCmd, NULL, 1}, + {"set", Tcl_SetObjCmd, TclCompileSetCmd, 1}, + {"split", Tcl_SplitObjCmd, NULL, 1}, + {"subst", Tcl_SubstObjCmd, NULL, 1}, + {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, 1}, + {"trace", Tcl_TraceObjCmd, NULL, 1}, + {"unset", Tcl_UnsetObjCmd, NULL, 1}, + {"uplevel", Tcl_UplevelObjCmd, NULL, 1}, + {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, 1}, + {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, 1}, + {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, 1}, /* * Commands in the OS-interface. Note that many of these are unsafe. */ - {"after", Tcl_AfterObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"cd", Tcl_CdObjCmd, NULL, NULL, 0}, - {"close", Tcl_CloseObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"eof", Tcl_EofObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"exec", Tcl_ExecObjCmd, NULL, NULL, 0}, - {"exit", Tcl_ExitObjCmd, NULL, NULL, 0}, - {"fblocked", Tcl_FblockedObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"fconfigure", Tcl_FconfigureObjCmd, NULL, NULL, 0}, - {"fcopy", Tcl_FcopyObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"fileevent", Tcl_FileEventObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"flush", Tcl_FlushObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"gets", Tcl_GetsObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"glob", Tcl_GlobObjCmd, NULL, NULL, 0}, - {"load", Tcl_LoadObjCmd, NULL, NULL, 0}, - {"open", Tcl_OpenObjCmd, NULL, NULL, 0}, - {"pid", Tcl_PidObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"puts", Tcl_PutsObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"pwd", Tcl_PwdObjCmd, NULL, NULL, 0}, - {"read", Tcl_ReadObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"seek", Tcl_SeekObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"socket", Tcl_SocketObjCmd, NULL, NULL, 0}, - {"source", Tcl_SourceObjCmd, NULL, TclNRSourceObjCmd, 0}, - {"tell", Tcl_TellObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"time", Tcl_TimeObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"timerate", Tcl_TimeRateObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"unload", Tcl_UnloadObjCmd, NULL, NULL, 0}, - {"update", Tcl_UpdateObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"vwait", Tcl_VwaitObjCmd, NULL, NULL, CMD_IS_SAFE}, - {NULL, NULL, NULL, NULL, 0} -}; - -/* - * Information about which pieces of ensembles to hide when making an - * interpreter safe: - */ - -static const UnsafeEnsembleInfo unsafeEnsembleCommands[] = { - /* [encoding] has two unsafe commands. Assumed by older security policies - * to be overall unsafe; it isn't but... */ - {"encoding", NULL}, - {"encoding", "dirs"}, - {"encoding", "system"}, - /* [file] has MANY unsafe commands! Assumed by older security policies to - * be overall unsafe; it isn't but... */ - {"file", NULL}, - {"file", "atime"}, - {"file", "attributes"}, - {"file", "copy"}, - {"file", "delete"}, - {"file", "dirname"}, - {"file", "executable"}, - {"file", "exists"}, - {"file", "extension"}, - {"file", "isdirectory"}, - {"file", "isfile"}, - {"file", "link"}, - {"file", "lstat"}, - {"file", "mtime"}, - {"file", "mkdir"}, - {"file", "nativename"}, - {"file", "normalize"}, - {"file", "owned"}, - {"file", "readable"}, - {"file", "readlink"}, - {"file", "rename"}, - {"file", "rootname"}, - {"file", "size"}, - {"file", "stat"}, - {"file", "tail"}, - {"file", "tempdir"}, - {"file", "tempfile"}, - {"file", "type"}, - {"file", "volumes"}, - {"file", "writable"}, - /* [info] has two unsafe commands */ - {"info", "cmdtype"}, - {"info", "nameofexecutable"}, - /* [tcl::process] has ONLY unsafe commands! */ - {"process", "list"}, - {"process", "status"}, - {"process", "purge"}, - {"process", "autopurge"}, - /* [zipfs] has MANY unsafe commands! */ - {"zipfs", "lmkimg"}, - {"zipfs", "lmkzip"}, - {"zipfs", "mkimg"}, - {"zipfs", "mkkey"}, - {"zipfs", "mkzip"}, - {"zipfs", "mount"}, - {"zipfs", "mount_data"}, - {"zipfs", "unmount"}, - {NULL, NULL} + {"after", Tcl_AfterObjCmd, NULL, 1}, + {"cd", Tcl_CdObjCmd, NULL, 0}, + {"close", Tcl_CloseObjCmd, NULL, 1}, + {"eof", Tcl_EofObjCmd, NULL, 1}, + {"encoding", Tcl_EncodingObjCmd, NULL, 0}, + {"exec", Tcl_ExecObjCmd, NULL, 0}, + {"exit", Tcl_ExitObjCmd, NULL, 0}, + {"fblocked", Tcl_FblockedObjCmd, NULL, 1}, + {"fconfigure", Tcl_FconfigureObjCmd, NULL, 0}, + {"fcopy", Tcl_FcopyObjCmd, NULL, 1}, + {"file", Tcl_FileObjCmd, NULL, 0}, + {"fileevent", Tcl_FileEventObjCmd, NULL, 1}, + {"flush", Tcl_FlushObjCmd, NULL, 1}, + {"gets", Tcl_GetsObjCmd, NULL, 1}, + {"glob", Tcl_GlobObjCmd, NULL, 0}, + {"load", Tcl_LoadObjCmd, NULL, 0}, + {"open", Tcl_OpenObjCmd, NULL, 0}, + {"pid", Tcl_PidObjCmd, NULL, 1}, + {"puts", Tcl_PutsObjCmd, NULL, 1}, + {"pwd", Tcl_PwdObjCmd, NULL, 0}, + {"read", Tcl_ReadObjCmd, NULL, 1}, + {"seek", Tcl_SeekObjCmd, NULL, 1}, + {"socket", Tcl_SocketObjCmd, NULL, 0}, + {"source", Tcl_SourceObjCmd, NULL, 0}, + {"tell", Tcl_TellObjCmd, NULL, 1}, + {"time", Tcl_TimeObjCmd, NULL, 1}, +#ifdef TCL_TIMERATE + {"timerate", Tcl_TimeRateObjCmd, NULL, 1}, +#endif + {"unload", Tcl_UnloadObjCmd, NULL, 0}, + {"update", Tcl_UpdateObjCmd, NULL, 1}, + {"vwait", Tcl_VwaitObjCmd, NULL, 1}, + {NULL, NULL, NULL, 0} }; /* * Math functions. All are safe. */ typedef struct { const char *name; /* Name of the function. The full name is - * "::tcl::mathfunc::". */ + * "::tcl::mathfunc::". */ Tcl_ObjCmdProc *objCmdProc; /* Function that evaluates the function */ - double (*fn)(double x); /* Real function pointer */ + ClientData clientData; /* Client data for the function */ } 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}, + { "abs", ExprAbsFunc, NULL }, + { "acos", ExprUnaryFunc, (ClientData) acos }, + { "asin", ExprUnaryFunc, (ClientData) asin }, + { "atan", ExprUnaryFunc, (ClientData) atan }, + { "atan2", ExprBinaryFunc, (ClientData) atan2 }, { "bool", ExprBoolFunc, NULL }, - { "ceil", ExprCeilFunc, NULL }, - { "cos", ExprUnaryFunc, cos }, - { "cosh", ExprUnaryFunc, cosh }, + { "ceil", ExprCeilFunc, NULL }, + { "cos", ExprUnaryFunc, (ClientData) cos }, + { "cosh", ExprUnaryFunc, (ClientData) 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}, + { "entier", ExprEntierFunc, NULL }, + { "exp", ExprUnaryFunc, (ClientData) exp }, + { "floor", ExprFloorFunc, NULL }, + { "fmod", ExprBinaryFunc, (ClientData) fmod }, + { "hypot", ExprBinaryFunc, (ClientData) 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}, + { "log", ExprUnaryFunc, (ClientData) log }, + { "log10", ExprUnaryFunc, (ClientData) log10 }, + { "pow", ExprBinaryFunc, (ClientData) pow }, { "rand", ExprRandFunc, NULL }, { "round", ExprRoundFunc, NULL }, - { "sin", ExprUnaryFunc, sin }, - { "sinh", ExprUnaryFunc, sinh }, - { "sqrt", ExprSqrtFunc, NULL }, + { "sin", ExprUnaryFunc, (ClientData) sin }, + { "sinh", ExprUnaryFunc, (ClientData) sinh }, + { "sqrt", ExprSqrtFunc, NULL }, { "srand", ExprSrandFunc, NULL }, - { "tan", ExprUnaryFunc, tan }, - { "tanh", ExprUnaryFunc, tanh }, - { "wide", ExprWideFunc, NULL }, + { "tan", ExprUnaryFunc, (ClientData) tan }, + { "tanh", ExprUnaryFunc, (ClientData) tanh }, + { "wide", ExprWideFunc, NULL }, { NULL, NULL, NULL } }; /* * TIP#174's math operators. All are safe. @@ -537,55 +315,54 @@ /* unused */ {0}, NULL}, { "==", TclSortingOpCmd, TclCompileEqOpCmd, /* unused */ {0}, NULL}, { "eq", TclSortingOpCmd, TclCompileStreqOpCmd, /* unused */ {0}, NULL}, - { "lt", TclSortingOpCmd, TclCompileStrLtOpCmd, - /* unused */ {0}, NULL}, - { "le", TclSortingOpCmd, TclCompileStrLeOpCmd, - /* unused */ {0}, NULL}, - { "gt", TclSortingOpCmd, TclCompileStrGtOpCmd, - /* unused */ {0}, NULL}, - { "ge", TclSortingOpCmd, TclCompileStrGeOpCmd, - /* unused */ {0}, NULL}, { NULL, NULL, NULL, {0}, NULL} }; - + /* - *---------------------------------------------------------------------- - * - * TclFinalizeEvaluation -- - * - * Finalizes the script cancellation hash table. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- + * Macros for stack checks. The goal of these macros is to allow the size of + * the stack to be checked (so preventing overflow) in a *cheap* way. Note + * that the check needs to be (amortized) cheap since it is on the critical + * path for recursion. */ -void -TclFinalizeEvaluation(void) -{ - Tcl_MutexLock(&cancelLock); - if (cancelTableInitialized == 1) { - Tcl_DeleteHashTable(&cancelTable); - cancelTableInitialized = 0; - } - Tcl_MutexUnlock(&cancelLock); - - Tcl_MutexLock(&commandTypeLock); - if (commandTypeInit) { - Tcl_DeleteHashTable(&commandTypeTable); - commandTypeInit = 0; - } - Tcl_MutexUnlock(&commandTypeLock); -} +#if defined(TCL_NO_STACK_CHECK) +/* + * Stack check disabled: make them noops. + */ + +# define CheckCStack(interp, localIntPtr) 1 +# define GetCStackParams(iPtr) /* do nothing */ +#elif defined(TCL_CROSS_COMPILE) + +/* + * This variable is static and only set *once*, during library initialization. + * It therefore needs no thread guards. + */ + +static int stackGrowsDown = 1; +# define GetCStackParams(iPtr) \ + stackGrowsDown = TclpGetCStackParams(&((iPtr)->stackBound)) +# define CheckCStack(iPtr, localIntPtr) \ + (stackGrowsDown \ + ? ((localIntPtr) > (iPtr)->stackBound) \ + : ((localIntPtr) < (iPtr)->stackBound) \ + ) +#else /* !TCL_NO_STACK_CHECK && !TCL_CROSS_COMPILE */ +# define GetCStackParams(iPtr) \ + TclpGetCStackParams(&((iPtr)->stackBound)) +# ifdef TCL_STACK_GROWS_UP +# define CheckCStack(iPtr, localIntPtr) \ + (!(iPtr)->stackBound || (localIntPtr) < (iPtr)->stackBound) +# else /* TCL_STACK_GROWS_UP */ +# define CheckCStack(iPtr, localIntPtr) \ + ((localIntPtr) > (iPtr)->stackBound) +# endif /* TCL_STACK_GROWS_UP */ +#endif /* TCL_NO_STACK_CHECK/TCL_CROSS_COMPILE */ /* *---------------------------------------------------------------------- * * Tcl_CreateInterp -- @@ -611,106 +388,81 @@ Command *cmdPtr; const BuiltinFuncDef *builtinFuncPtr; const OpCmdInfo *opcmdInfoPtr; const CmdInfo *cmdInfoPtr; Tcl_Namespace *nsPtr; - Tcl_HashEntry *hPtr; - int isNew; - CancelInfo *cancelInfo; union { char c[sizeof(short)]; short s; } order; #ifdef TCL_COMPILE_STATS ByteCodeStats *statsPtr; #endif /* TCL_COMPILE_STATS */ char mathFuncName[32]; CallFrame *framePtr; + int result; - Tcl_InitSubsystems(); + TclInitSubsystems(); /* * Panic if someone updated the CallFrame structure without also updating * the Tcl_CallFrame structure (or vice versa). */ if (sizeof(Tcl_CallFrame) < sizeof(CallFrame)) { + /*NOTREACHED*/ Tcl_Panic("Tcl_CallFrame must not be smaller than CallFrame"); } -#if defined(_WIN32) && !defined(_WIN64) - if (sizeof(time_t) != 8) { - Tcl_Panic(" is not compatible with VS2005+"); - } - if ((offsetof(Tcl_StatBuf,st_atime) != 32) - || (offsetof(Tcl_StatBuf,st_ctime) != 48)) { - Tcl_Panic(" is not compatible with VS2005+"); +#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 ((TclOffset(Tcl_StatBuf,st_atime) != 32) + || (TclOffset(Tcl_StatBuf,st_ctime) != 40)) { + /*NOTREACHED*/ + Tcl_Panic(" is not compatible with MSVC"); } #endif - if (cancelTableInitialized == 0) { - Tcl_MutexLock(&cancelLock); - if (cancelTableInitialized == 0) { - Tcl_InitHashTable(&cancelTable, TCL_ONE_WORD_KEYS); - cancelTableInitialized = 1; - } - - Tcl_MutexUnlock(&cancelLock); - } - - if (commandTypeInit == 0) { - TclRegisterCommandTypeName(TclObjInterpProc, "proc"); - TclRegisterCommandTypeName(TclEnsembleImplementationCmd, "ensemble"); - TclRegisterCommandTypeName(TclAliasObjCmd, "alias"); - TclRegisterCommandTypeName(TclLocalAliasObjCmd, "alias"); - TclRegisterCommandTypeName(TclChildObjCmd, "interp"); - TclRegisterCommandTypeName(TclInvokeImportedCmd, "import"); - TclRegisterCommandTypeName(TclOOPublicObjectCmd, "object"); - TclRegisterCommandTypeName(TclOOPrivateObjectCmd, "privateObject"); - TclRegisterCommandTypeName(TclOOMyClassObjCmd, "privateClass"); - TclRegisterCommandTypeName(TclNRInterpCoroutine, "coroutine"); - } - /* * Initialize support for namespaces and create the global namespace * (whose name is ""; an alias is "::"). This also initializes the Tcl * object type table and other object management code. */ - iPtr = (Interp *)Tcl_Alloc(sizeof(Interp)); + iPtr = (Interp *) ckalloc(sizeof(Interp)); interp = (Tcl_Interp *) iPtr; - iPtr->legacyResult = NULL; - /* Special invalid value: Any attempt to free the legacy result - * will cause a crash. */ - iPtr->legacyFreeProc = (void (*) (void))-1; + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = NULL; iPtr->errorLine = 0; - iPtr->stubTable = &tclStubs; iPtr->objResultPtr = Tcl_NewObj(); Tcl_IncrRefCount(iPtr->objResultPtr); iPtr->handle = TclHandleCreate(iPtr); iPtr->globalNsPtr = NULL; iPtr->hiddenCmdTablePtr = NULL; iPtr->interpInfo = NULL; - iPtr->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. + * TIP #280 - Initialize the arrays used to extend the ByteCode and + * Proc structures. */ iPtr->cmdFramePtr = NULL; - iPtr->linePBodyPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); - iPtr->lineBCPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); - iPtr->lineLAPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); - iPtr->lineLABCPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); + 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; @@ -719,44 +471,36 @@ iPtr->returnOpts = NULL; iPtr->errorInfo = NULL; TclNewLiteralStringObj(iPtr->eiVar, "::errorInfo"); Tcl_IncrRefCount(iPtr->eiVar); - iPtr->errorStack = Tcl_NewListObj(0, NULL); - Tcl_IncrRefCount(iPtr->errorStack); - iPtr->resetErrorStack = 1; - TclNewLiteralStringObj(iPtr->upLiteral,"UP"); - Tcl_IncrRefCount(iPtr->upLiteral); - TclNewLiteralStringObj(iPtr->callLiteral,"CALL"); - Tcl_IncrRefCount(iPtr->callLiteral); - TclNewLiteralStringObj(iPtr->innerLiteral,"INNER"); - Tcl_IncrRefCount(iPtr->innerLiteral); - iPtr->innerContext = Tcl_NewListObj(0, NULL); - Tcl_IncrRefCount(iPtr->innerContext); iPtr->errorCode = NULL; 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; + + iPtr->appendResult = NULL; + iPtr->appendAvl = 0; + iPtr->appendUsed = 0; 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) { iPtr->packagePrefer = PKG_PREFER_STABLE; - } else -#endif + } else { iPtr->packagePrefer = PKG_PREFER_LATEST; + } iPtr->cmdCount = 0; - TclInitLiteralTable(&iPtr->literalTable); - iPtr->compileEpoch = 1; + TclInitLiteralTable(&(iPtr->literalTable)); + iPtr->compileEpoch = 0; iPtr->compiledProcPtr = NULL; iPtr->resolverPtr = NULL; iPtr->evalFlags = 0; iPtr->scriptFile = NULL; iPtr->flags = 0; @@ -767,10 +511,11 @@ iPtr->assocData = NULL; iPtr->execEnvPtr = NULL; /* Set after namespaces initialized. */ iPtr->emptyObjPtr = Tcl_NewObj(); /* Another empty object. */ Tcl_IncrRefCount(iPtr->emptyObjPtr); + iPtr->resultSpace[0] = 0; iPtr->threadId = Tcl_GetCurrentThread(); /* TIP #378 */ #ifdef TCL_INTERP_DEBUG_FRAME iPtr->flags |= INTERP_DEBUG_FRAME; @@ -800,13 +545,16 @@ * 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 *)Tcl_Alloc(sizeof(CallFrame)); - (void) Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, + framePtr = (CallFrame *) ckalloc(sizeof(CallFrame)); + result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, (Tcl_Namespace *) iPtr->globalNsPtr, /*isProcCallFrame*/ 0); + if (result != TCL_OK) { + Tcl_Panic("Tcl_CreateInterp: failed to push the root stack frame"); + } framePtr->objc = 0; iPtr->framePtr = framePtr; iPtr->varFramePtr = framePtr; iPtr->rootFramePtr = framePtr; @@ -816,57 +564,38 @@ * TclCreateExecEnv after initializing namespaces since it tries to * reference a Tcl variable (it links to the Tcl "tcl_traceExec" * variable). */ - iPtr->execEnvPtr = TclCreateExecEnv(interp, INTERP_STACK_INITIAL_SIZE); + iPtr->execEnvPtr = TclCreateExecEnv(interp); /* * TIP #219, Tcl Channel Reflection API support. */ iPtr->chanMsg = NULL; - /* - * TIP #285, Script cancellation support. - */ - - iPtr->asyncCancelMsg = Tcl_NewObj(); - - cancelInfo = (CancelInfo *)Tcl_Alloc(sizeof(CancelInfo)); - cancelInfo->interp = interp; - - iPtr->asyncCancel = Tcl_AsyncCreate(CancelEvalProc, cancelInfo); - cancelInfo->async = iPtr->asyncCancel; - cancelInfo->result = NULL; - cancelInfo->length = 0; - - Tcl_MutexLock(&cancelLock); - hPtr = Tcl_CreateHashEntry(&cancelTable, iPtr, &isNew); - Tcl_SetHashValue(hPtr, cancelInfo); - Tcl_MutexUnlock(&cancelLock); - /* * Initialize the compilation and execution statistics kept for this * interpreter. */ #ifdef TCL_COMPILE_STATS - statsPtr = &iPtr->stats; + statsPtr = &(iPtr->stats); statsPtr->numExecutions = 0; statsPtr->numCompilations = 0; statsPtr->numByteCodesFreed = 0; - memset(statsPtr->instructionCount, 0, + (void) memset(statsPtr->instructionCount, 0, sizeof(statsPtr->instructionCount)); statsPtr->totalSrcBytes = 0.0; statsPtr->totalByteCodeBytes = 0.0; statsPtr->currentSrcBytes = 0.0; statsPtr->currentByteCodeBytes = 0.0; - memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount)); - memset(statsPtr->byteCodeCount, 0, sizeof(statsPtr->byteCodeCount)); - memset(statsPtr->lifetimeCount, 0, sizeof(statsPtr->lifetimeCount)); + (void) memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount)); + (void) memset(statsPtr->byteCodeCount, 0, sizeof(statsPtr->byteCodeCount)); + (void) memset(statsPtr->lifetimeCount, 0, sizeof(statsPtr->lifetimeCount)); statsPtr->currentInstBytes = 0.0; statsPtr->currentLitBytes = 0.0; statsPtr->currentExceptBytes = 0.0; statsPtr->currentAuxBytes = 0.0; @@ -873,38 +602,51 @@ statsPtr->currentCmdMapBytes = 0.0; statsPtr->numLiteralsCreated = 0; statsPtr->totalLitStringBytes = 0.0; statsPtr->currentLitStringBytes = 0.0; - memset(statsPtr->literalCount, 0, sizeof(statsPtr->literalCount)); + (void) 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); + iPtr->ensembleRewrite.sourceObjs = NULL; + iPtr->ensembleRewrite.numRemovedObjs = 0; + iPtr->ensembleRewrite.numInsertedObjs = 0; /* * 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. + * Initialise the thread-specific data ekeko. */ -#if TCL_THREADS && defined(USE_THREAD_ALLOC) - iPtr->allocCache = (AllocCache *)TclpGetAllocCache(); +#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) + iPtr->allocCache = TclpGetAllocCache(); #else iPtr->allocCache = NULL; #endif iPtr->pendingObjDataPtr = NULL; iPtr->asyncReadyPtr = TclGetAsyncReadyPtr(); - iPtr->deferredCallbacks = NULL; + + /* + * Insure that the stack checking mechanism for this interp is + * initialized. + */ + + GetCStackParams(iPtr); /* * Create the core commands. Do it here, rather than calling * Tcl_CreateCommand, because it's faster (there's no need to check for a * pre-existing command by the same name). If a command has a Tcl_CmdProc @@ -913,21 +655,23 @@ * extracts strings, calls the string function, and creates an object for * the result. Similarly, if a command has a Tcl_ObjCmdProc but no * Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand. */ - for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { + for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { + int isNew; + Tcl_HashEntry *hPtr; + if ((cmdInfoPtr->objProc == NULL) - && (cmdInfoPtr->compileProc == NULL) - && (cmdInfoPtr->nreProc == NULL)) { + && (cmdInfoPtr->compileProc == 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 *)Tcl_Alloc(sizeof(Command)); + cmdPtr = (Command *) ckalloc(sizeof(Command)); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = iPtr->globalNsPtr; cmdPtr->refCount = 1; cmdPtr->cmdEpoch = 0; cmdPtr->compileProc = cmdInfoPtr->compileProc; @@ -936,38 +680,26 @@ cmdPtr->objProc = cmdInfoPtr->objProc; cmdPtr->objClientData = NULL; cmdPtr->deleteProc = NULL; cmdPtr->deleteData = NULL; cmdPtr->flags = 0; - if (cmdInfoPtr->flags & CMD_COMPILES_EXPANDED) { - cmdPtr->flags |= CMD_COMPILES_EXPANDED; - } cmdPtr->importRefPtr = NULL; cmdPtr->tracePtr = NULL; - cmdPtr->nreProc = cmdInfoPtr->nreProc; Tcl_SetHashValue(hPtr, cmdPtr); } } /* - * Create the "array", "binary", "chan", "clock", "dict", "encoding", - * "file", "info", "namespace" and "string" ensembles. Note that all these - * commands (and their subcommands that are not present in the global - * namespace) are wholly safe *except* for "clock", "encoding" and "file". + * Create the "chan", "dict", "info" and "string" ensembles. Note that all + * these commands (and their subcommands that are not present in the + * global namespace) are wholly safe. */ - TclInitArrayCmd(interp); - TclInitBinaryCmd(interp); TclInitChanCmd(interp); TclInitDictCmd(interp); - TclInitEncodingCmd(interp); - TclInitFileCmd(interp); TclInitInfoCmd(interp); - TclInitNamespaceCmd(interp); TclInitStringCmd(interp); - TclInitPrefixCmd(interp); - TclInitProcessCmd(interp); /* * Register "clock" subcommands. These *do* go through * Tcl_CreateObjCommand, since they aren't in the global namespace and * involve ensembles. @@ -986,31 +718,19 @@ Tcl_CreateObjCommand(interp, "::tcl::Bgerror", TclDefaultBgErrorHandlerObjCmd, NULL, NULL); /* - * Create unsupported commands for debugging bytecode and objects. + * Create an unsupported command for debugging bytecode. */ Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble", - Tcl_DisassembleObjCmd, INT2PTR(0), NULL); - Tcl_CreateObjCommand(interp, "::tcl::unsupported::getbytecode", - Tcl_DisassembleObjCmd, INT2PTR(1), NULL); - Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation", - Tcl_RepresentationCmd, NULL, NULL); - - /* Adding the bytecode assembler command */ - cmdPtr = (Command *) Tcl_NRCreateCommand(interp, - "::tcl::unsupported::assemble", Tcl_AssembleObjCmd, - TclNRAssembleObjCmd, NULL, NULL); - cmdPtr->compileProc = &TclCompileAssembleCmd; - - /* Coroutine monkeybusiness */ - Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL, - NRInjectObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "::tcl::unsupported::corotype", - CoroTypeObjCmd, NULL, NULL); + Tcl_DisassembleObjCmd, NULL, NULL); + + /* Create an unsupported command for timerate */ + Tcl_CreateObjCommand(interp, "::tcl::unsupported::timerate", + Tcl_TimeRateObjCmd, NULL, NULL); /* Export unsupported commands */ nsPtr = Tcl_FindNamespace(interp, "::tcl::unsupported", NULL, 0); if (nsPtr) { Tcl_Export(interp, nsPtr, "*", 1); @@ -1031,33 +751,34 @@ nsPtr = Tcl_CreateNamespace(interp, "::tcl::mathfunc", NULL,NULL); if (nsPtr == NULL) { Tcl_Panic("Can't create math function namespace"); } + strcpy(mathFuncName, "::tcl::mathfunc::"); #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); + builtinFuncPtr->objCmdProc, builtinFuncPtr->clientData, NULL); Tcl_Export(interp, nsPtr, builtinFuncPtr->name, 0); } /* * Register the mathematical "operator" commands. [TIP #174] */ nsPtr = Tcl_CreateNamespace(interp, "::tcl::mathop", NULL, NULL); +#define MATH_OP_PREFIX_LEN 15 /* == strlen("::tcl::mathop::") */ 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); + (void) Tcl_Export(interp, nsPtr, "*", 1); + strcpy(mathFuncName, "::tcl::mathop::"); for (opcmdInfoPtr=mathOpCmds ; opcmdInfoPtr->name!=NULL ; opcmdInfoPtr++){ - TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)Tcl_Alloc(sizeof(TclOpCmdClientData)); + 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); @@ -1099,25 +820,28 @@ Tcl_SetVar2(interp, "tcl_platform", "byteOrder", ((order.c[0] == 1) ? "littleEndian" : "bigEndian"), TCL_GLOBAL_ONLY); Tcl_SetVar2Ex(interp, "tcl_platform", "wordSize", - Tcl_NewWideIntObj(sizeof(long)), TCL_GLOBAL_ONLY); + Tcl_NewLongObj((long) sizeof(long)), TCL_GLOBAL_ONLY); /* TIP #291 */ Tcl_SetVar2Ex(interp, "tcl_platform", "pointerSize", - Tcl_NewWideIntObj(sizeof(void *)), TCL_GLOBAL_ONLY); + Tcl_NewLongObj((long) sizeof(void *)), TCL_GLOBAL_ONLY); /* * 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); + Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY); + Tcl_TraceVar2(interp, "tcl_precision", NULL, + TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + TclPrecTraceProc, NULL); TclpSetVariables(interp); -#if TCL_THREADS +#ifdef 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 * introspect on the interpreter level of thread safety. @@ -1131,108 +855,29 @@ * TIP #268: Full patchlevel instead of just major.minor */ Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs); +#ifdef Tcl_InitStubs +#undef Tcl_InitStubs +#endif + Tcl_InitStubs(interp, TCL_VERSION, 1); + if (TclTommath_Init(interp) != TCL_OK) { - Tcl_Panic("%s", Tcl_GetStringResult(interp)); - } - - if (TclOOInit(interp) != TCL_OK) { - Tcl_Panic("%s", Tcl_GetStringResult(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", Tcl_GetStringResult(interp)); - } - if (TclZipfs_Init(interp) != TCL_OK) { - Tcl_Panic("%s", Tcl_GetStringResult(interp)); - } -#endif - - TOP_CB(iPtr) = NULL; + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); + } + return interp; } static void DeleteOpCmdClientData( ClientData clientData) { - TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData; - - Tcl_Free(occdPtr); -} - -/* - * --------------------------------------------------------------------- - * - * TclRegisterCommandTypeName, TclGetCommandTypeName -- - * - * Command type registration and lookup mechanism. Everything is keyed by - * the Tcl_ObjCmdProc for the command, and that is used as the *key* into - * the hash table that maps to constant strings that are names. (It is - * recommended that those names be ASCII.) - * - * --------------------------------------------------------------------- - */ - -void -TclRegisterCommandTypeName( - Tcl_ObjCmdProc *implementationProc, - const char *nameStr) -{ - Tcl_HashEntry *hPtr; - - Tcl_MutexLock(&commandTypeLock); - if (commandTypeInit == 0) { - Tcl_InitHashTable(&commandTypeTable, TCL_ONE_WORD_KEYS); - commandTypeInit = 1; - } - if (nameStr != NULL) { - int isNew; - - hPtr = Tcl_CreateHashEntry(&commandTypeTable, - (void *) implementationProc, &isNew); - Tcl_SetHashValue(hPtr, (void *) nameStr); - } else { - hPtr = Tcl_FindHashEntry(&commandTypeTable, - (void *) implementationProc); - if (hPtr != NULL) { - Tcl_DeleteHashEntry(hPtr); - } - } - Tcl_MutexUnlock(&commandTypeLock); -} - -const char * -TclGetCommandTypeName( - Tcl_Command command) -{ - Command *cmdPtr = (Command *) command; - Tcl_ObjCmdProc *procPtr = cmdPtr->objProc; - const char *name = "native"; - - if (procPtr == NULL) { - procPtr = cmdPtr->nreProc; - } - Tcl_MutexLock(&commandTypeLock); - if (commandTypeInit) { - Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&commandTypeTable, procPtr); - - if (hPtr && Tcl_GetHashValue(hPtr)) { - name = (const char *) Tcl_GetHashValue(hPtr); - } - } - Tcl_MutexUnlock(&commandTypeLock); - - return name; + TclOpCmdClientData *occdPtr = clientData; + + ckfree((char *) occdPtr); } /* *---------------------------------------------------------------------- * @@ -1251,96 +896,22 @@ int TclHideUnsafeCommands( Tcl_Interp *interp) /* Hide commands in this interpreter. */ { - const CmdInfo *cmdInfoPtr; - const UnsafeEnsembleInfo *unsafePtr; + register const CmdInfo *cmdInfoPtr; if (interp == NULL) { return TCL_ERROR; } for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { - if (!(cmdInfoPtr->flags & CMD_IS_SAFE)) { + if (!cmdInfoPtr->isSafe) { Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name); } } - - for (unsafePtr = unsafeEnsembleCommands; - unsafePtr->ensembleNsName; unsafePtr++) { - if (unsafePtr->commandName) { - /* - * Hide an ensemble subcommand. - */ - - Tcl_Obj *cmdName = Tcl_ObjPrintf("::tcl::%s::%s", - unsafePtr->ensembleNsName, unsafePtr->commandName); - Tcl_Obj *hideName = Tcl_ObjPrintf("tcl:%s:%s", - unsafePtr->ensembleNsName, unsafePtr->commandName); - - 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_GetStringResult(interp)); - } - Tcl_CreateObjCommand(interp, TclGetString(cmdName), - BadEnsembleSubcommand, (void *)unsafePtr, NULL); - TclDecrRefCount(cmdName); - TclDecrRefCount(hideName); - } else { - /* - * Hide an ensemble main command (for compatibility). - */ - - if (Tcl_HideCommand(interp, unsafePtr->ensembleNsName, - unsafePtr->ensembleNsName) != TCL_OK) { - Tcl_Panic("problem making '%s' safe: %s", - unsafePtr->ensembleNsName, - Tcl_GetStringResult(interp)); - } - } - } - return TCL_OK; } - -/* - *---------------------------------------------------------------------- - * - * BadEnsembleSubcommand -- - * - * Command used to act as a backstop implementation when subcommands of - * ensembles are unsafe (the real implementations of the subcommands are - * hidden). The clientData is description of what was hidden. - * - * Results: - * A standard Tcl result (always a TCL_ERROR). - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -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; -} /* *-------------------------------------------------------------- * * Tcl_CallWhenDeleted -- @@ -1369,21 +940,21 @@ 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)); + Tcl_GetThreadData(&assocDataCounterKey, (int)sizeof(int)); int isNew; char buffer[32 + TCL_INTEGER_SPACE]; - AssocData *dPtr = (AssocData *)Tcl_Alloc(sizeof(AssocData)); + 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 *)Tcl_Alloc(sizeof(Tcl_HashTable)); + 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; @@ -1426,13 +997,13 @@ if (hTablePtr == NULL) { return; } for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - dPtr = (AssocData *)Tcl_GetHashValue(hPtr); + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) { - Tcl_Free(dPtr); + ckfree((char *) dPtr); Tcl_DeleteHashEntry(hPtr); return; } } } @@ -1468,18 +1039,18 @@ AssocData *dPtr; Tcl_HashEntry *hPtr; int isNew; if (iPtr->assocData == NULL) { - iPtr->assocData = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); + 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); + dPtr = Tcl_GetHashValue(hPtr); } else { - dPtr = (AssocData *)Tcl_Alloc(sizeof(AssocData)); + dPtr = (AssocData *) ckalloc(sizeof(AssocData)); } dPtr->proc = proc; dPtr->clientData = clientData; Tcl_SetHashValue(hPtr, dPtr); @@ -1516,15 +1087,15 @@ } hPtr = Tcl_FindHashEntry(iPtr->assocData, name); if (hPtr == NULL) { return; } - dPtr = (AssocData *)Tcl_GetHashValue(hPtr); + dPtr = Tcl_GetHashValue(hPtr); if (dPtr->proc != NULL) { dPtr->proc(dPtr->clientData, interp); } - Tcl_Free(dPtr); + ckfree((char *) dPtr); Tcl_DeleteHashEntry(hPtr); } /* *---------------------------------------------------------------------- @@ -1561,11 +1132,11 @@ } hPtr = Tcl_FindHashEntry(iPtr->assocData, name); if (hPtr == NULL) { return NULL; } - dPtr = (AssocData *)Tcl_GetHashValue(hPtr); + dPtr = Tcl_GetHashValue(hPtr); if (procPtr != NULL) { *procPtr = dPtr->proc; } return dPtr->clientData; } @@ -1675,18 +1246,16 @@ Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_HashTable *hTablePtr; ResolverScheme *resPtr, *nextResPtr; - int i; /* - * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup, - * unless we are exiting. + * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup. */ - if ((iPtr->numLevels > 0) && !TclInExit()) { + if (iPtr->numLevels > 0) { Tcl_Panic("DeleteInterpProc called with active evals"); } /* * The interpreter should already be marked deleted; otherwise how did we @@ -1704,41 +1273,10 @@ if (iPtr->chanMsg != NULL) { Tcl_DecrRefCount(iPtr->chanMsg); iPtr->chanMsg = NULL; } - /* - * 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) { - Tcl_Free(cancelInfo->result); - } - Tcl_Free(cancelInfo); - } - - Tcl_DeleteHashEntry(hPtr); - } - - if (iPtr->asyncCancel != NULL) { - Tcl_AsyncDelete(iPtr->asyncCancel); - iPtr->asyncCancel = NULL; - } - - if (iPtr->asyncCancelMsg != NULL) { - Tcl_DecrRefCount(iPtr->asyncCancelMsg); - iPtr->asyncCancelMsg = NULL; - } - Tcl_MutexUnlock(&cancelLock); - /* * Shut down all limit handler callback scripts that call back into this * interpreter. Then eliminate all limit handlers for this interpreter. */ @@ -1764,20 +1302,21 @@ hTablePtr = iPtr->hiddenCmdTablePtr; if (hTablePtr != NULL) { /* * Non-pernicious deletion. The deletion callbacks will not be allowed * to create any new hidden or non-hidden commands. - * Tcl_DeleteCommandFromToken will remove the entry from the + * 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_DeleteCommandFromToken(interp, + (Tcl_Command) Tcl_GetHashValue(hPtr)); } Tcl_DeleteHashTable(hTablePtr); - Tcl_Free(hTablePtr); + ckfree((char *) hTablePtr); } /* * Invoke deletion callbacks; note that a callback can create new * callbacks, so we iterate. @@ -1789,39 +1328,41 @@ hTablePtr = iPtr->assocData; iPtr->assocData = NULL; for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search); hPtr != NULL; hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) { - dPtr = (AssocData *)Tcl_GetHashValue(hPtr); + dPtr = Tcl_GetHashValue(hPtr); Tcl_DeleteHashEntry(hPtr); if (dPtr->proc != NULL) { dPtr->proc(dPtr->clientData, interp); } - Tcl_Free(dPtr); + ckfree((char *) dPtr); } Tcl_DeleteHashTable(hTablePtr); - Tcl_Free(hTablePtr); + ckfree((char *) hTablePtr); } /* * Pop the root frame pointer and finish deleting the global * namespace. The order is important [Bug 1658572]. */ - if ((iPtr->framePtr != iPtr->rootFramePtr) && !TclInExit()) { + if (iPtr->framePtr != iPtr->rootFramePtr) { Tcl_Panic("DeleteInterpProc: popping rootCallFrame with other frames on top"); } Tcl_PopCallFrame(interp); - Tcl_Free(iPtr->rootFramePtr); + ckfree((char *) 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. */ + Tcl_FreeResult(interp); + interp->result = NULL; Tcl_DecrRefCount(iPtr->objResultPtr); iPtr->objResultPtr = NULL; Tcl_DecrRefCount(iPtr->ecVar); if (iPtr->errorCode) { Tcl_DecrRefCount(iPtr->errorCode); @@ -1830,18 +1371,16 @@ Tcl_DecrRefCount(iPtr->eiVar); if (iPtr->errorInfo) { Tcl_DecrRefCount(iPtr->errorInfo); iPtr->errorInfo = NULL; } - Tcl_DecrRefCount(iPtr->errorStack); - iPtr->errorStack = NULL; - Tcl_DecrRefCount(iPtr->upLiteral); - Tcl_DecrRefCount(iPtr->callLiteral); - Tcl_DecrRefCount(iPtr->innerLiteral); - Tcl_DecrRefCount(iPtr->innerContext); if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); + } + if (iPtr->appendResult != NULL) { + ckfree(iPtr->appendResult); + iPtr->appendResult = NULL; } TclFreePackageInfo(iPtr); while (iPtr->tracePtr != NULL) { Tcl_DeleteTrace((Tcl_Interp *) iPtr, (Tcl_Trace) iPtr->tracePtr); } @@ -1856,115 +1395,118 @@ iPtr->emptyObjPtr = NULL; resPtr = iPtr->resolverPtr; while (resPtr) { nextResPtr = resPtr->nextPtr; - Tcl_Free(resPtr->name); - Tcl_Free(resPtr); + ckfree(resPtr->name); + ckfree((char *) resPtr); resPtr = nextResPtr; } /* * Free up literal objects created for scripts compiled by the * interpreter. */ - TclDeleteLiteralTable(interp, &iPtr->literalTable); + 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); - } - Tcl_Free(cfPtr->line); - Tcl_Free(cfPtr); - } - Tcl_DeleteHashEntry(hPtr); - } - Tcl_DeleteHashTable(iPtr->linePBodyPtr); - Tcl_Free(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++) { - Tcl_Free(eclPtr->loc[i].line); - } - - if (eclPtr->loc != NULL) { - Tcl_Free(eclPtr->loc); - } - - Tcl_Free(eclPtr); - Tcl_DeleteHashEntry(hPtr); - } - Tcl_DeleteHashTable(iPtr->lineBCPtr); - Tcl_Free(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); - Tcl_Free(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); - Tcl_Free(iPtr->lineLABCPtr); - iPtr->lineLABCPtr = NULL; - - /* - * Squelch the tables of traces on variables and searches over arrays in - * the in the interpreter. - */ + { + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + int i; + + for (hPtr = Tcl_FirstHashEntry(iPtr->linePBodyPtr, &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + CmdFrame *cfPtr = 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((char *) cfPtr->line); + ckfree((char *) cfPtr); + } + Tcl_DeleteHashEntry(hPtr); + } + Tcl_DeleteHashTable(iPtr->linePBodyPtr); + ckfree((char *) iPtr->linePBodyPtr); + iPtr->linePBodyPtr = NULL; + + /* + * See also tclCompile.c, TclCleanupByteCode + */ + + for (hPtr = Tcl_FirstHashEntry(iPtr->lineBCPtr, &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + ExtCmdLoc *eclPtr = (ExtCmdLoc *) Tcl_GetHashValue(hPtr); + + if (eclPtr->type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount(eclPtr->path); + } + for (i=0; i< eclPtr->nuloc; i++) { + ckfree((char *) eclPtr->loc[i].line); + } + + if (eclPtr->loc != NULL) { + ckfree((char *) eclPtr->loc); + } + + Tcl_DeleteHashTable (&eclPtr->litInfo); + + ckfree((char *) eclPtr); + Tcl_DeleteHashEntry(hPtr); + } + Tcl_DeleteHashTable(iPtr->lineBCPtr); + ckfree((char *) iPtr->lineBCPtr); + iPtr->lineBCPtr = NULL; + + /* + * Location stack for uplevel/eval/... scripts which were passed + * through proc arguments. Actually we track all arguments as we + * don't, cannot know which arguments will be used as scripts and + * which won't. + */ + + if (iPtr->lineLAPtr->numEntries) { + /* + * 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((char*) iPtr->lineLAPtr); + iPtr->lineLAPtr = NULL; + + if (iPtr->lineLABCPtr->numEntries) { + /* + * 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((char*) iPtr->lineLABCPtr); + iPtr->lineLABCPtr = NULL; + } Tcl_DeleteHashTable(&iPtr->varTraces); Tcl_DeleteHashTable(&iPtr->varSearches); - Tcl_Free(iPtr); + ckfree((char *) iPtr); } /* *--------------------------------------------------------------------------- * @@ -2026,14 +1568,13 @@ * the source, in order to avoid potential confusion, lets prevent "::" in * the token too. - dl */ if (strstr(hiddenCmdToken, "::") != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( + Tcl_AppendResult(interp, "cannot use namespace qualifiers in hidden command" - " token (rename)", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "HIDDENTOKEN", NULL); + " token (rename)", NULL); return TCL_ERROR; } /* * Find the command to hide. An error is returned if cmdName can't be @@ -2051,24 +1592,23 @@ /* * Check that the command is really in global namespace */ if (cmdPtr->nsPtr != iPtr->globalNsPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can only hide global namespace commands (use rename then hide)", - -1)); - Tcl_SetErrorCode(interp, "TCL", "HIDE", "NON_GLOBAL", NULL); + Tcl_AppendResult(interp, "can only hide global namespace commands" + " (use rename then hide)", NULL); return TCL_ERROR; } /* * Initialize the hidden command table if necessary. */ hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; if (hiddenCmdTablePtr == NULL) { - hiddenCmdTablePtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); + hiddenCmdTablePtr = (Tcl_HashTable *) + ckalloc((unsigned) sizeof(Tcl_HashTable)); Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS); iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr; } /* @@ -2077,14 +1617,12 @@ * exists. */ hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &isNew); if (!isNew) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "hidden command named \"%s\" already exists", - hiddenCmdToken)); - Tcl_SetErrorCode(interp, "TCL", "HIDE", "ALREADY_HIDDEN", NULL); + Tcl_AppendResult(interp, "hidden command named \"", hiddenCmdToken, + "\" already exists", NULL); return TCL_ERROR; } /* * NB: This code is currently 'like' a rename to a specialy set apart name @@ -2181,14 +1719,12 @@ * trying to do an expose and a rename (to another namespace) at the same * time). */ if (strstr(cmdName, "::") != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot expose to a namespace (use expose to toplevel, then rename)", - -1)); - Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "NON_GLOBAL", NULL); + Tcl_AppendResult(interp, "cannot expose to a namespace " + "(use expose to toplevel, then rename)", NULL); return TCL_ERROR; } /* * Get the command from the hidden command table: @@ -2198,33 +1734,31 @@ hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; if (hiddenCmdTablePtr != NULL) { hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken); } if (hPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown hidden command \"%s\"", hiddenCmdToken)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", - hiddenCmdToken, NULL); + Tcl_AppendResult(interp, "unknown hidden command \"", hiddenCmdToken, + "\"", NULL); return TCL_ERROR; } - cmdPtr = (Command *)Tcl_GetHashValue(hPtr); + cmdPtr = 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 + * Tcl_HideCommand() but let's double check. (If it was not, we would not * really know how to handle it). */ if (cmdPtr->nsPtr != iPtr->globalNsPtr) { /* - * This case is theoritically impossible, we might rather Tcl_Panic + * This case is theoritically impossible, we might rather Tcl_Panic() * than 'nicely' erroring out ? */ - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "trying to expose a non-global command namespace command", - -1)); + Tcl_AppendResult(interp, + "trying to expose a non global command name space command", + NULL); return TCL_ERROR; } /* * This is the global table. @@ -2237,27 +1771,15 @@ * exposing a previously hidden command. */ hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew); if (!isNew) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "exposed command \"%s\" already exists", cmdName)); - Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "COMMAND_EXISTS", NULL); + Tcl_AppendResult(interp, "exposed command \"", cmdName, + "\" already exists", NULL); return TCL_ERROR; } - /* - * Command resolvers (per-interp, per-namespace) might have resolved to a - * command for the given namespace scope with this command not being - * registered with the namespace's command table. During BC compilation, - * the so-resolved command turns into a CmdName literal. Without - * invalidating a possible CmdName literal here explicitly, such literals - * keep being reused while pointing to overhauled commands. - */ - - TclInvalidateCmdLiteral(interp, cmdName, nsPtr); - /* * The list of command exported from the namespace might have changed. * However, we do not need to recompute this just yet; next time we need * the info will be soon enough. */ @@ -2388,28 +1910,26 @@ tail = cmdName; } hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); - if (isNew || deleted) { + if (isNew || deleted) { /* * isNew - No conflict with existing command. * deleted - We've already deleted a conflicting command */ break; - } + } - /* - * An existing command conflicts. Try to delete it... - */ - - cmdPtr = (Command *)Tcl_GetHashValue(hPtr); + /* An existing command conflicts. Try to delete it.. */ + cmdPtr = 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. + * Be careful to preserve + * any existing import links so we can restore them down below. That + * way, you can redefine a command and its import status will remain + * intact. */ cmdPtr->refCount++; if (cmdPtr->importRefPtr) { cmdPtr->flags |= CMD_REDEF_IN_PROGRESS; @@ -2425,30 +1945,19 @@ deleted = 1; } 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). - */ - - Tcl_Free(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 - * compilation, the so-resolved command turns into a CmdName literal. - * Without invalidating a possible CmdName literal here explicitly, - * such literals keep being reused while pointing to overhauled - * commands. - */ - - TclInvalidateCmdLiteral(interp, tail, nsPtr); + * 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((char *) Tcl_GetHashValue(hPtr)); + } + + if (!deleted) { /* * The list of command exported from the namespace might have changed. * However, we do not need to recompute this just yet; next time we * need the info will be soon enough. @@ -2455,11 +1964,11 @@ */ TclInvalidateNsCmdLookup(nsPtr); TclInvalidateNsPath(nsPtr); } - cmdPtr = (Command *)Tcl_Alloc(sizeof(Command)); + cmdPtr = (Command *) ckalloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = nsPtr; cmdPtr->refCount = 1; cmdPtr->cmdEpoch = 0; @@ -2471,11 +1980,10 @@ cmdPtr->deleteProc = deleteProc; cmdPtr->deleteData = clientData; cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; cmdPtr->tracePtr = NULL; - cmdPtr->nreProc = NULL; /* * Plug in any existing import references found above. Be sure to update * all of these references to point to the new command. */ @@ -2482,11 +1990,11 @@ if (oldRefPtr != NULL) { cmdPtr->importRefPtr = oldRefPtr; while (oldRefPtr != NULL) { Command *refCmdPtr = oldRefPtr->importedCmdPtr; - dataPtr = (ImportedCmdData *)refCmdPtr->objClientData; + dataPtr = refCmdPtr->objClientData; dataPtr->realCmdPtr = cmdPtr; oldRefPtr = oldRefPtr->nextPtr; } } @@ -2513,10 +2021,11 @@ * 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 @@ -2534,98 +2043,92 @@ * specified namespace; otherwise it is put in * the global namespace. */ Tcl_ObjCmdProc *proc, /* Object-based function to associate with * name. */ ClientData clientData, /* Arbitrary value to pass to object - * function. */ - Tcl_CmdDeleteProc *deleteProc + * function. */ + Tcl_CmdDeleteProc *deleteProc) /* If not NULL, gives a function to call when * this command is deleted. */ -) { Interp *iPtr = (Interp *) interp; + ImportRef *oldRefPtr = NULL; Namespace *nsPtr; + Command *cmdPtr; + Tcl_HashEntry *hPtr; const char *tail; + int isNew = 0, deleted = 0; + ImportedCmdData *dataPtr; if (iPtr->flags & DELETED) { /* * The interpreter is being deleted. Don't create any new commands; * it's not safe to muck with the interpreter anymore. */ - return (Tcl_Command) NULL; - } - - /* - * Determine where the command should reside. If its name contains - * namespace qualifiers, we put it in the specified namespace; - * otherwise, we always put it in the global namespace. - */ - - if (strstr(cmdName, "::") != NULL) { - Namespace *dummy1, *dummy2; - - TclGetNamespaceForQualName(interp, cmdName, NULL, - TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); - if ((nsPtr == NULL) || (tail == NULL)) { - return (Tcl_Command) NULL; - } - } else { - nsPtr = iPtr->globalNsPtr; - tail = cmdName; - } - - return TclCreateObjCommandInNs(interp, tail, (Tcl_Namespace *) nsPtr, - proc, clientData, deleteProc); -} - -Tcl_Command -TclCreateObjCommandInNs( - Tcl_Interp *interp, - const char *cmdName, /* Name of command, without any namespace - * components. */ - Tcl_Namespace *namesp, /* The namespace to create the command in */ - Tcl_ObjCmdProc *proc, /* Object-based function to associate with - * name. */ - 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. - */ - - while (1) { - hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew); - - if (isNew || deleted) { + + return (Tcl_Command) NULL; + } + + /* + * If the command name we seek to create already exists, we need to + * delete that first. That can be tricky in the presence of traces. + * Loop until we no longer find an existing command in the way, or + * until we've deleted one command and that didn't finish the job. + */ + + while (1) { + /* + * Determine where the command should reside. If its name contains + * namespace qualifiers, we put it in the specified namespace; + * otherwise, we always put it in the global namespace. + */ + + if (strstr(cmdName, "::") != NULL) { + Namespace *dummy1, *dummy2; + + TclGetNamespaceForQualName(interp, cmdName, NULL, + TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); + if ((nsPtr == NULL) || (tail == NULL)) { + return (Tcl_Command) NULL; + } + } else { + nsPtr = iPtr->globalNsPtr; + tail = cmdName; + } + + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); + + if (isNew || deleted) { /* * isNew - No conflict with existing command. * deleted - We've already deleted a conflicting command */ break; + } + + /* An existing command conflicts. Try to delete it.. */ + cmdPtr = 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; } /* - * An existing command conflicts. Try to delete it... - */ - - cmdPtr = (Command *)Tcl_GetHashValue(hPtr); - - /* - * Command already exists; delete it. Be careful to preserve any + * 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. */ @@ -2632,61 +2135,41 @@ cmdPtr->refCount++; if (cmdPtr->importRefPtr) { cmdPtr->flags |= CMD_REDEF_IN_PROGRESS; } - /* - * Make sure namespace doesn't get deallocated. - */ - - cmdPtr->nsPtr->refCount++; - Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); - nsPtr = (Namespace *) TclEnsureNamespace(interp, - (Tcl_Namespace *) cmdPtr->nsPtr); - TclNsDecrRefCount(cmdPtr->nsPtr); if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) { oldRefPtr = cmdPtr->importRefPtr; cmdPtr->importRefPtr = NULL; } TclCleanupCommandMacro(cmdPtr); deleted = 1; } + 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). - */ - - Tcl_Free(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 - * compilation, the so-resolved command turns into a CmdName literal. - * Without invalidating a possible CmdName literal here explicitly, - * such literals keep being reused while pointing to overhauled - * commands. - */ - - TclInvalidateCmdLiteral(interp, cmdName, nsPtr); - + * 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) { /* * The list of command exported from the namespace might have changed. * However, we do not need to recompute this just yet; next time we * need the info will be soon enough. */ TclInvalidateNsCmdLookup(nsPtr); TclInvalidateNsPath(nsPtr); } - cmdPtr = (Command *)Tcl_Alloc(sizeof(Command)); + cmdPtr = (Command *) ckalloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = nsPtr; cmdPtr->refCount = 1; cmdPtr->cmdEpoch = 0; @@ -2698,11 +2181,10 @@ cmdPtr->deleteProc = deleteProc; cmdPtr->deleteData = clientData; cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; cmdPtr->tracePtr = NULL; - cmdPtr->nreProc = NULL; /* * Plug in any existing import references found above. Be sure to update * all of these references to point to the new command. */ @@ -2709,14 +2191,11 @@ if (oldRefPtr != NULL) { cmdPtr->importRefPtr = oldRefPtr; while (oldRefPtr != NULL) { Command *refCmdPtr = oldRefPtr->importedCmdPtr; - - dataPtr = (ImportedCmdData*)refCmdPtr->objClientData; - cmdPtr->refCount++; - TclCleanupCommandMacro(dataPtr->realCmdPtr); + dataPtr = refCmdPtr->objClientData; dataPtr->realCmdPtr = cmdPtr; oldRefPtr = oldRefPtr->nextPtr; } } @@ -2754,28 +2233,28 @@ int TclInvokeStringCommand( ClientData clientData, /* Points to command's Command structure. */ Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + register int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Command *cmdPtr = (Command *)clientData; + Command *cmdPtr = clientData; int i, result; const char **argv = (const char **) - TclStackAlloc(interp, (objc + 1) * sizeof(char *)); + TclStackAlloc(interp, (unsigned)(objc + 1) * sizeof(char *)); - for (i = 0; i < objc; i++) { - argv[i] = TclGetString(objv[i]); + for (i = 0; i < objc; i++) { + argv[i] = Tcl_GetString(objv[i]); } argv[objc] = 0; /* * Invoke the command's string-based Tcl_CmdProc. */ - result = cmdPtr->proc(cmdPtr->clientData, interp, objc, argv); + result = (*cmdPtr->proc)(cmdPtr->clientData, interp, objc, argv); TclStackFree(interp, (void *) argv); return result; } @@ -2789,11 +2268,11 @@ * pointer to this function is stored as the Tcl_CmdProc in a Command * structure. It simply turns around and calls the object Tcl_ObjCmdProc * in the Command structure. * * Results: - * A standard Tcl result value. + * A standard Tcl string result value. * * Side effects: * Besides those side effects of the called Tcl_ObjCmdProc, * TclInvokeObjectCommand allocates and frees storage. * @@ -2803,19 +2282,19 @@ 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. */ + register const char **argv) /* Argument strings. */ { - Command *cmdPtr = ( Command *) clientData; + Command *cmdPtr = (Command *) clientData; Tcl_Obj *objPtr; int i, length, result; Tcl_Obj **objv = (Tcl_Obj **) - TclStackAlloc(interp, (argc * sizeof(Tcl_Obj *))); + TclStackAlloc(interp, (unsigned)(argc * sizeof(Tcl_Obj *))); - for (i = 0; i < argc; i++) { + for (i = 0; i < argc; i++) { length = strlen(argv[i]); TclNewStringObj(objPtr, argv[i], length); Tcl_IncrRefCount(objPtr); objv[i] = objPtr; } @@ -2822,23 +2301,25 @@ /* * 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); - } + result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, 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++) { + for (i = 0; i < argc; i++) { objPtr = objv[i]; Tcl_DecrRefCount(objPtr); } TclStackFree(interp, objv); return result; @@ -2890,33 +2371,31 @@ */ cmd = Tcl_FindCommand(interp, oldName, NULL, /*flags*/ 0); cmdPtr = (Command *) cmd; if (cmdPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't %s \"%s\": command doesn't exist", + Tcl_AppendResult(interp, "can't ", ((newName == NULL)||(*newName == '\0'))? "delete":"rename", - oldName)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, NULL); + " \"", oldName, "\": command doesn't exist", NULL); return TCL_ERROR; } + cmdNsPtr = cmdPtr->nsPtr; + oldFullName = Tcl_NewObj(); + Tcl_IncrRefCount(oldFullName); + Tcl_GetCommandFullName(interp, cmd, oldFullName); /* * If the new command name is NULL or empty, delete the command. Do this * with Tcl_DeleteCommandFromToken, since we already have the command. */ if ((newName == NULL) || (*newName == '\0')) { Tcl_DeleteCommandFromToken(interp, cmd); - return TCL_OK; + result = TCL_OK; + goto done; } - cmdNsPtr = cmdPtr->nsPtr; - oldFullName = Tcl_NewObj(); - Tcl_IncrRefCount(oldFullName); - Tcl_GetCommandFullName(interp, cmd, oldFullName); - /* * Make sure that the destination command does not already exist. The * rename operation is like creating a command, so we should automatically * create the containing namespaces just like Tcl_CreateCommand would. */ @@ -2923,28 +2402,25 @@ TclGetNamespaceForQualName(interp, newName, NULL, TCL_CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail); if ((newNsPtr == NULL) || (newTail == NULL)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't rename to \"%s\": bad command name", newName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); + Tcl_AppendResult(interp, "can't rename to \"", newName, + "\": bad command name", NULL); result = TCL_ERROR; goto done; } if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't rename to \"%s\": command already exists", newName)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RENAME", - "TARGET_EXISTS", NULL); + Tcl_AppendResult(interp, "can't rename to \"", newName, + "\": command already exists", NULL); result = TCL_ERROR; goto done; } /* * Warning: any changes done in the code here are likely to be needed in - * Tcl_HideCommand code too (until the common parts are extracted out). + * Tcl_HideCommand() code too (until the common parts are extracted out). * - dl */ /* * Put the command in the new namespace so we can check for an alias loop. @@ -2980,21 +2456,10 @@ */ TclInvalidateNsCmdLookup(cmdNsPtr); TclInvalidateNsCmdLookup(cmdPtr->nsPtr); - /* - * Command resolvers (per-interp, per-namespace) might have resolved to a - * command for the given namespace scope with this command not being - * registered with the namespace's command table. During BC compilation, - * the so-resolved command turns into a CmdName literal. Without - * invalidating a possible CmdName literal here explicitly, such literals - * keep being reused while pointing to overhauled commands. - */ - - TclInvalidateCmdLiteral(interp, newTail, cmdPtr->nsPtr); - /* * Script for rename traces can delete the command "oldName". Therefore * increment the reference count for cmdPtr so that it's Command structure * is freed only towards the end of this function by calling * TclCleanupCommand. @@ -3006,15 +2471,15 @@ */ Tcl_DStringInit(&newFullName); Tcl_DStringAppend(&newFullName, newNsPtr->fullName, -1); if (newNsPtr != iPtr->globalNsPtr) { - TclDStringAppendLiteral(&newFullName, "::"); + Tcl_DStringAppend(&newFullName, "::", 2); } Tcl_DStringAppend(&newFullName, newTail, -1); cmdPtr->refCount++; - CallCommandTraces(iPtr, cmdPtr, TclGetString(oldFullName), + CallCommandTraces(iPtr, cmdPtr, Tcl_GetString(oldFullName), Tcl_DStringValue(&newFullName), TCL_TRACE_RENAME); Tcl_DStringFree(&newFullName); /* * The new command name is okay, so remove the command from its current @@ -3110,11 +2575,11 @@ Tcl_Command cmd, const Tcl_CmdInfo *infoPtr) { Command *cmdPtr; /* Internal representation of the command */ - if (cmd == NULL) { + if (cmd == (Tcl_Command) NULL) { return 0; } /* * The isNativeObjectProc and nsPtr members of *infoPtr are ignored. @@ -3124,16 +2589,12 @@ cmdPtr->proc = infoPtr->proc; cmdPtr->clientData = infoPtr->clientData; if (infoPtr->objProc == NULL) { cmdPtr->objProc = TclInvokeStringCommand; cmdPtr->objClientData = cmdPtr; - cmdPtr->nreProc = NULL; } else { - if (infoPtr->objProc != cmdPtr->objProc) { - cmdPtr->nreProc = NULL; - cmdPtr->objProc = infoPtr->objProc; - } + cmdPtr->objProc = infoPtr->objProc; cmdPtr->objClientData = infoPtr->objClientData; } cmdPtr->deleteProc = infoPtr->deleteProc; cmdPtr->deleteData = infoPtr->deleteData; return 1; @@ -3194,11 +2655,11 @@ Tcl_Command cmd, Tcl_CmdInfo *infoPtr) { Command *cmdPtr; /* Internal representation of the command */ - if (cmd == NULL) { + if (cmd == (Tcl_Command) NULL) { return 0; } /* * Set isNativeObjectProc 1 if objProc was registered by a call to @@ -3236,11 +2697,11 @@ *---------------------------------------------------------------------- */ const char * Tcl_GetCommandName( - TCL_UNUSED(Tcl_Interp *), + Tcl_Interp *interp, /* Interpreter containing the command. */ 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; @@ -3253,11 +2714,11 @@ */ return ""; } - return (const char *)Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); + return Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); } /* *---------------------------------------------------------------------- * @@ -3287,27 +2748,27 @@ Tcl_Obj *objPtr) /* Points to the object onto which the * command's full name is appended. */ { Interp *iPtr = (Interp *) interp; - Command *cmdPtr = (Command *) command; + register 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) && TclRoutineHasName(cmdPtr)) { + 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); + name = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); Tcl_AppendToObj(objPtr, name, -1); } } } @@ -3339,11 +2800,11 @@ /* * Find the desired command and delete it. */ cmd = Tcl_FindCommand(interp, cmdName, NULL, /*flags*/ 0); - if (cmd == NULL) { + if (cmd == (Tcl_Command) NULL) { return -1; } return Tcl_DeleteCommandFromToken(interp, cmd); } @@ -3376,20 +2837,27 @@ Interp *iPtr = (Interp *) interp; Command *cmdPtr = (Command *) cmd; ImportRef *refPtr, *nextRefPtr; Tcl_Command importCmd; + /* + * Bump the command epoch counter. This will invalidate all cached + * references that point to this command. + */ + + cmdPtr->cmdEpoch++; + /* * The code here is tricky. We can't delete the hash table entry before * invoking the deletion callback because there are cases where the * deletion callback needs to invoke the command (e.g. object systems such * as OTcl). However, this means that the callback could try to delete or * rename the command. The deleted flag allows us to detect these cases * and skip nested deletes. */ - if (cmdPtr->flags & CMD_DYING) { + if (cmdPtr->flags & CMD_IS_DELETED) { /* * Another deletion is already in progress. Remove the hash table * entry now, but don't invoke a callback or free the command * structure. Take care to only remove the hash entry if it has not * already been removed; otherwise if we manage to hit this function @@ -3398,38 +2866,28 @@ if (cmdPtr->hPtr != NULL) { Tcl_DeleteHashEntry(cmdPtr->hPtr); cmdPtr->hPtr = NULL; } - - /* - * Bump the command epoch counter. This will invalidate all cached - * references that point to this command. - */ - - cmdPtr->cmdEpoch++; - return 0; } /* * We must delete this command, even though both traces and delete procs * may try to avoid this (renaming the command etc). Also traces and - * delete procs may try to delete the command themselves. This flag + * delete procs may try to delete the command themsevles. This flag * declares that a delete is in progress and that recursive deletes should * be ignored. */ - cmdPtr->flags |= CMD_DYING; + cmdPtr->flags |= CMD_IS_DELETED; /* * Call trace functions for the command being deleted. Then delete its * traces. */ - cmdPtr->nsPtr->refCount++; - if (cmdPtr->tracePtr != NULL) { CommandTrace *tracePtr; CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE); /* @@ -3437,27 +2895,25 @@ */ tracePtr = cmdPtr->tracePtr; while (tracePtr != NULL) { CommandTrace *nextPtr = tracePtr->nextPtr; - - if (tracePtr->refCount-- <= 1) { - Tcl_Free(tracePtr); + if ((--tracePtr->refCount) <= 0) { + ckfree((char *) tracePtr); } tracePtr = nextPtr; } cmdPtr->tracePtr = NULL; } /* - * The list of commands exported from the namespace might have changed. + * The list of command exported from the namespace might have changed. * However, we do not need to recompute this just yet; next time we need * the info will be soon enough. */ TclInvalidateNsCmdLookup(cmdPtr->nsPtr); - TclNsDecrRefCount(cmdPtr->nsPtr); /* * If the command being deleted has a compile function, increment the * interpreter's compileEpoch to invalidate its compiled code. This makes * sure that we don't later try to execute old code compiled with @@ -3468,40 +2924,43 @@ if (cmdPtr->compileProc != NULL) { iPtr->compileEpoch++; } - if (!(cmdPtr->flags & CMD_REDEF_IN_PROGRESS)) { - /* - * Delete any imports of this routine before deleting this routine itself. - * See issue 688fcc7082fa. - */ - for (refPtr = cmdPtr->importRefPtr; refPtr != NULL; - refPtr = nextRefPtr) { - nextRefPtr = refPtr->nextPtr; - importCmd = (Tcl_Command) refPtr->importedCmdPtr; - Tcl_DeleteCommandFromToken(interp, importCmd); - } - } - if (cmdPtr->deleteProc != NULL) { /* * Delete the command's client data. If this was an imported command * created when a command was imported into a namespace, this client * data will be a pointer to a ImportedCmdData structure describing * the "real" command that this imported command refers to. - * + */ + + /* * If you are getting a crash during the call to deleteProc and * cmdPtr->deleteProc is a pointer to the function free(), the most * likely cause is that your extension allocated memory for the - * clientData argument to Tcl_CreateObjCommand with the Tcl_Alloc() + * clientData argument to Tcl_CreateObjCommand() with the ckalloc() * macro and you are now trying to deallocate this memory with free() - * instead of Tcl_Free(). You should pass a pointer to your own method - * that calls Tcl_Free(). + * instead of ckfree(). You should pass a pointer to your own method + * that calls ckfree(). */ - cmdPtr->deleteProc(cmdPtr->deleteData); + (*cmdPtr->deleteProc)(cmdPtr->deleteData); + } + + /* + * If this command was imported into other namespaces, then imported + * commands were created that refer back to this command. Delete these + * imported commands now. + */ + if (!(cmdPtr->flags & CMD_REDEF_IN_PROGRESS)) { + for (refPtr = cmdPtr->importRefPtr; refPtr != NULL; + refPtr = nextRefPtr) { + nextRefPtr = refPtr->nextPtr; + importCmd = (Tcl_Command) refPtr->importedCmdPtr; + Tcl_DeleteCommandFromToken(interp, importCmd); + } } /* * Don't use hPtr to delete the hash entry here, because it's possible * that the deletion callback renamed the command. Instead, use @@ -3510,59 +2969,35 @@ */ if (cmdPtr->hPtr != NULL) { Tcl_DeleteHashEntry(cmdPtr->hPtr); cmdPtr->hPtr = NULL; - - /* - * Bump the command epoch counter. This will invalidate all cached - * references that point to this command. - */ - - cmdPtr->cmdEpoch++; } /* - * A number of tests for particular kinds of commands are done by checking - * whether the objProc field holds a known value. Set the field to NULL so - * that such tests won't have false positives when applied to deleted - * commands. + * Mark the Command structure as no longer valid. This allows + * TclExecuteByteCode to recognize when a Command has logically been + * deleted and a pointer to this Command structure cached in a CmdName + * object is invalid. TclExecuteByteCode will look up the command again in + * the interpreter's command hashtable. */ cmdPtr->objProc = NULL; /* * Now free the Command structure, unless there is another reference to it * from a CmdName Tcl object in some ByteCode code sequence. In that case, * delay the cleanup until all references are either discarded (when a * ByteCode is freed) or replaced by a new reference (when a cached - * CmdName Command reference is found to be invalid and - * TclNRExecuteByteCode looks up the command in the command hashtable). + * CmdName Command reference is found to be invalid and TclExecuteByteCode + * looks up the command in the command hashtable). */ - cmdPtr->flags |= CMD_DEAD; TclCleanupCommandMacro(cmdPtr); return 0; } -/* - *---------------------------------------------------------------------- - * - * CallCommandTraces -- - * - * Abstraction of the code to call traces on a command. - * - * Results: - * Currently always NULL. - * - * Side effects: - * Anything; this may recursively evaluate scripts and code exists to do - * just that. - * - *---------------------------------------------------------------------- - */ - static char * CallCommandTraces( Interp *iPtr, /* Interpreter containing command. */ Command *cmdPtr, /* Command whose traces are to be invoked. */ const char *oldName, /* Command's old name, or NULL if we must get @@ -3571,11 +3006,11 @@ * is not being renamed */ int flags) /* Flags indicating the type of traces to * trigger, either TCL_TRACE_DELETE or * TCL_TRACE_RENAME. */ { - CommandTrace *tracePtr; + register CommandTrace *tracePtr; ActiveCommandTrace active; char *result; Tcl_Obj *oldNamePtr = NULL; Tcl_InterpState state = NULL; @@ -3582,11 +3017,11 @@ if (cmdPtr->flags & CMD_TRACE_ACTIVE) { /* * While a rename trace is active, we will not process any more rename * traces; while a delete trace is active we will never reach here - * because Tcl_DeleteCommandFromToken checks for the condition - * (cmdPtr->flags & CMD_DYING) and returns immediately when a + * (cmdPtr->flags & CMD_IS_DELETED) and returns immediately when a * command deletion is in progress. For all other traces, delete * traces will not be invoked but a call to TraceCommandProc will * ensure that tracePtr->clientData is freed whenever the command * "oldName" is deleted. */ @@ -3629,15 +3064,15 @@ } tracePtr->refCount++; if (state == NULL) { state = Tcl_SaveInterpState((Tcl_Interp *) iPtr, TCL_OK); } - tracePtr->traceProc(tracePtr->clientData, (Tcl_Interp *) iPtr, - oldName, newName, flags); + (*tracePtr->traceProc)(tracePtr->clientData, + (Tcl_Interp *) iPtr, oldName, newName, flags); cmdPtr->flags &= ~tracePtr->flags; - if (tracePtr->refCount-- <= 1) { - Tcl_Free(tracePtr); + if ((--tracePtr->refCount) <= 0) { + ckfree((char *) tracePtr); } } if (state) { Tcl_RestoreInterpState((Tcl_Interp *) iPtr, state); @@ -3660,86 +3095,38 @@ cmdPtr->refCount--; iPtr->activeCmdTracePtr = active.nextPtr; Tcl_Release(iPtr); return result; } - -/* - *---------------------------------------------------------------------- - * - * CancelEvalProc -- - * - * Marks this interpreter as being canceled. This causes current - * executions to be unwound as the interpreter enters a state where it - * refuses to execute more commands or handle [catch] or [try], yet the - * interpreter is still able to execute further commands after the - * cancelation is cleared (unlike if it is deleted). - * - * Results: - * The value given for the code argument. - * - * Side effects: - * Transfers a message from the cancelation message to the interpreter. - * - *---------------------------------------------------------------------- - */ - -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) { - /* - * Setting the CANCELED flag will cause the script in progress to - * be canceled as soon as possible. The core honors this flag at - * all the necessary places to ensure script cancellation is - * responsive. Extensions can check for this flag by calling - * Tcl_Canceled and checking if TCL_ERROR is returned or they can - * choose to ignore the script cancellation flag and the - * associated functionality altogether. Currently, the only other - * flag we care about here is the TCL_CANCEL_UNWIND flag (from - * Tcl_CancelEval). We do not want to simply combine all the flags - * from original Tcl_CancelEval call with the interp flags here - * just in case the caller passed flags that might cause behaviour - * unrelated to script cancellation. - */ - - TclSetCancelFlags(iPtr, cancelInfo->flags | CANCELED); - - /* - * Now, we must set the script cancellation flags on all the child - * interpreters belonging to this one. - */ - - TclSetChildCancelFlags((Tcl_Interp *) iPtr, - cancelInfo->flags | CANCELED, 0); - - /* - * Create the result object now so that Tcl_Canceled can avoid - * locking the cancelLock mutex. - */ - - if (cancelInfo->result != NULL) { - Tcl_SetStringObj(iPtr->asyncCancelMsg, cancelInfo->result, - cancelInfo->length); - } else { - Tcl_SetObjLength(iPtr->asyncCancelMsg, 0); - } - } - Tcl_MutexUnlock(&cancelLock); - } - - return code; + +/* + *---------------------------------------------------------------------- + * + * GetCommandSource -- + * + * This function returns a Tcl_Obj with the full source string for the + * command. This insures that traces get a correct NUL-terminated command + * string. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Obj * +GetCommandSource( + Interp *iPtr, + const char *command, + int numChars, + int objc, + Tcl_Obj *const objv[]) +{ + if (!command) { + return Tcl_NewListObj(objc, objv); + } + if (command == (char *) -1) { + command = TclGetSrcInfoForCmd(iPtr, &numChars); + } + return Tcl_NewStringObj(command, numChars); } /* *---------------------------------------------------------------------- * @@ -3761,17 +3148,377 @@ *---------------------------------------------------------------------- */ void TclCleanupCommand( - Command *cmdPtr) /* Points to the Command structure to + register Command *cmdPtr) /* Points to the Command structure to * be freed. */ { - if (cmdPtr->refCount-- <= 1) { - Tcl_Free(cmdPtr); + cmdPtr->refCount--; + if (cmdPtr->refCount <= 0) { + ckfree((char *) 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. + * + *---------------------------------------------------------------------- + */ + +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); + Tcl_DStringAppend(&bigName, "::tcl::mathfunc::", -1); + 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, /* Ponter 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 = 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) && (valuePtr->typePtr == &tclDoubleType)) { + d = valuePtr->internalRep.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, Tcl_GetString(valuePtr)); + ckfree((char *)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 (Tcl_GetWideIntFromObj(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((char *)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((char *)args); + return TCL_ERROR; + } + valuePtr = Tcl_GetObjResult(interp); + Tcl_GetWideIntFromObj(NULL, valuePtr, &(args[k].wideValue)); + Tcl_ResetResult(interp); + break; + } + } + + /* + * Call the function. + */ + + errno = 0; + result = (*dataPtr->proc)(dataPtr->clientData, interp, args, &funcResult); + ckfree((char *)args); + if (result != TCL_OK) { + return result; + } + + /* + * Return the result of the call. + */ + + if (funcResult.type == TCL_INT) { + TclNewLongObj(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 = clientData; + + ckfree((void *) dataPtr->argTypes); + ckfree((void *) 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_Obj *message; + + TclNewLiteralStringObj(message, "unknown math function \""); + Tcl_AppendToObj(message, name, -1); + Tcl_AppendToObj(message, "\"", 1); + Tcl_SetObjResult(interp, message); + *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 = 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; +} /* *---------------------------------------------------------------------- * * TclInterpReady -- @@ -3782,319 +3529,429 @@ * Results: * The return value is TCL_OK if it the interpreter is ready, TCL_ERROR * otherwise. * * Side effects: - * The interpreter's result is cleared. + * The interpreters object and string results are cleared. * *---------------------------------------------------------------------- */ int TclInterpReady( Tcl_Interp *interp) { - Interp *iPtr = (Interp *) interp; +#if !defined(TCL_NO_STACK_CHECK) + int localInt; /* used for checking the stack */ +#endif + register Interp *iPtr = (Interp *) interp; /* - * Reset the interpreter's result and clear out any previous error - * information. + * 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. */ if (iPtr->flags & DELETED) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to call eval in deleted interpreter", -1)); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, + "attempt to call eval in deleted interpreter", NULL); Tcl_SetErrorCode(interp, "TCL", "IDELETE", "attempt to call eval in deleted interpreter", NULL); return TCL_ERROR; } - if (iPtr->execEnvPtr->rewind) { - return TCL_ERROR; - } - - /* - * Make sure the script being evaluated (if any) has not been canceled. - */ - - if (TclCanceled(iPtr) && - (TCL_OK != Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG))) { - return TCL_ERROR; - } - /* * Check depth of nested calls to Tcl_Eval: if this gets too large, it's * probably because of an infinite loop somewhere. */ - if (((iPtr->numLevels) <= iPtr->maxNestingDepth)) { + if (((iPtr->numLevels) <= iPtr->maxNestingDepth) + && CheckCStack(iPtr, &localInt)) { return TCL_OK; } - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "too many nested evaluations (infinite loop?)", -1)); - Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", NULL); + if (!CheckCStack(iPtr, &localInt)) { + Tcl_AppendResult(interp, + "out of stack space (infinite loop?)", NULL); + } else { + Tcl_AppendResult(interp, + "too many nested evaluations (infinite loop?)", NULL); + } return TCL_ERROR; } /* *---------------------------------------------------------------------- * - * TclResetCancellation -- - * - * Reset the script cancellation flags if the nesting level - * (iPtr->numLevels) for the interp is zero or argument force is - * non-zero. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * The script cancellation flags for the interp may be reset. - * - *---------------------------------------------------------------------- - */ - -int -TclResetCancellation( - Tcl_Interp *interp, - int force) -{ - Interp *iPtr = (Interp *) interp; - - if (iPtr == NULL) { - return TCL_ERROR; - } - - if (force || (iPtr->numLevels == 0)) { - TclUnsetCancelFlags(iPtr); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_Canceled -- - * - * Check if the script in progress has been canceled, i.e., - * Tcl_CancelEval was called for this interpreter or any of its parent - * interpreters. - * - * Results: - * The return value is TCL_OK if the script evaluation has not been - * canceled, TCL_ERROR otherwise. - * - * If "flags" contains TCL_LEAVE_ERR_MSG, an error message is returned in - * the interpreter's result object. Otherwise, the interpreter's result - * object is left unchanged. If "flags" contains TCL_CANCEL_UNWIND, - * TCL_ERROR will only be returned if the script evaluation is being - * completely unwound. - * - * Side effects: - * The CANCELED flag for the interp will be reset if it is set. - * - *---------------------------------------------------------------------- - */ - -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)) { - return TCL_OK; - } - - /* - * The CANCELED flag is a one-shot flag that is reset immediately upon - * being detected; however, if the TCL_CANCEL_UNWIND flag is set we will - * continue to report that the script in progress has been canceled - * thereby allowing the evaluation stack for the interp to be fully - * unwound. - */ - - iPtr->flags &= ~CANCELED; - - /* - * The CANCELED flag was detected and reset; however, if the caller - * specified the TCL_CANCEL_UNWIND flag, we only return TCL_ERROR - * (indicating that the script in progress has been canceled) if the - * evaluation stack for the interp is being fully unwound. - */ - - if ((flags & TCL_CANCEL_UNWIND) && !(iPtr->flags & TCL_CANCEL_UNWIND)) { - return TCL_OK; - } - - /* - * If the TCL_LEAVE_ERR_MSG flags bit is set, place an error in the - * interp's result; otherwise, we leave it alone. - */ - - if (flags & TCL_LEAVE_ERR_MSG) { - const char *id, *message = NULL; - size_t length; - - /* - * Setup errorCode variables so that we can differentiate between - * being canceled and unwound. - */ - - if (iPtr->asyncCancelMsg != NULL) { - message = TclGetStringFromObj(iPtr->asyncCancelMsg, &length); - } else { - length = 0; - } - - if (iPtr->flags & TCL_CANCEL_UNWIND) { - id = "IUNWIND"; - if (length == 0) { - message = "eval unwound"; - } - } else { - id = "ICANCEL"; - if (length == 0) { - message = "eval canceled"; - } - } - - Tcl_SetObjResult(interp, Tcl_NewStringObj(message, -1)); - Tcl_SetErrorCode(interp, "TCL", "CANCEL", id, message, NULL); - } - - /* - * Return TCL_ERROR to the caller (not necessarily just the Tcl core - * itself) that indicates further processing of the script or command in - * progress should halt gracefully and as soon as possible. - */ - - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CancelEval -- - * - * This function schedules the cancellation of the current script in the - * given interpreter. + * TclEvalObjvInternal + * + * This function evaluates a Tcl command that has already been parsed + * into words, with one Tcl_Obj holding each word. The caller is + * responsible for managing the iPtr->numLevels. + * + * TclEvalObjvInternal is the backend for Tcl_EvalObjv, the bytecode + * engine also calls it directly. * * Results: * The return value is a standard Tcl completion code such as TCL_OK or - * TCL_ERROR. Since the interp may belong to a different thread, no error - * message can be left in the interp's result. + * TCL_ERROR. A result or error message is left in interp's result. If an + * error occurs, this function does NOT add any information to the + * errorInfo variable. * * Side effects: - * The script in progress in the specified interpreter will be canceled - * with TCL_ERROR after asynchronous handlers are invoked at the next - * Tcl_Canceled check. + * Depends on the command. * *---------------------------------------------------------------------- */ int -Tcl_CancelEval( - Tcl_Interp *interp, /* Interpreter in which to cancel the - * script. */ - Tcl_Obj *resultObjPtr, /* The script cancellation error message or - * NULL for a default error message. */ - ClientData clientData, /* Passed to CancelEvalProc. */ - int flags) /* Collection of OR-ed bits that control - * the cancellation of the script. Only - * TCL_CANCEL_UNWIND is currently - * supported. */ -{ - Tcl_HashEntry *hPtr; - CancelInfo *cancelInfo; - int code = TCL_ERROR; - const char *result; - - if (interp == NULL) { +TclEvalObjvInternal( + Tcl_Interp *interp, /* Interpreter in which to evaluate the + * command. Also used for error reporting. */ + int objc, /* Number of words in command. */ + Tcl_Obj *const objv[], /* An array of pointers to objects that are + * the words that make up the command. */ + const char *command, /* Points to the beginning of the string + * representation of the command; this is used + * for traces. NULL if the string + * representation of the command is unknown is + * to be generated from (objc,objv), -1 if it + * is to be generated from bytecode + * source. This is only needed the traces. */ + int length, /* Number of bytes in command; if -1, all + * characters up to the first null byte are + * used. */ + int flags) /* Collection of OR-ed bits that control the + * evaluation of the script. Only + * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are + * currently supported. */ +{ + Command *cmdPtr; + Interp *iPtr = (Interp *) interp; + Tcl_Obj **newObjv; + int i; + CallFrame *savedVarFramePtr = NULL; + CallFrame *varFramePtr = iPtr->varFramePtr; + int code = TCL_OK; + int traceCode = TCL_OK; + int checkTraces = 1, traced; + Namespace *savedNsPtr = NULL; + Namespace *lookupNsPtr = iPtr->lookupNsPtr; + Tcl_Obj *commandPtr = NULL; + + if (TclInterpReady(interp) == TCL_ERROR) { return TCL_ERROR; } - Tcl_MutexLock(&cancelLock); - if (cancelTableInitialized != 1) { - /* - * No CancelInfo hash table (Tcl_CreateInterp has never been called?) - */ - - goto done; - } - hPtr = Tcl_FindHashEntry(&cancelTable, (char *) interp); - 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 *)Tcl_Realloc(cancelInfo->result,cancelInfo->length); - memcpy(cancelInfo->result, result, cancelInfo->length); - TclDecrRefCount(resultObjPtr); /* Discard their result object. */ - } else { - cancelInfo->result = NULL; - cancelInfo->length = 0; - } - cancelInfo->clientData = clientData; - cancelInfo->flags = flags; - Tcl_AsyncMark(cancelInfo->async); - code = TCL_OK; + if (objc == 0) { + return TCL_OK; + } + + /* + * If any execution traces rename or delete the current command, we may + * need (at most) two passes here. + */ + + reparseBecauseOfTraces: + + /* + * Configure evaluation context to match the requested flags. + */ + + if (flags) { + if (flags & TCL_EVAL_INVOKE) { + savedNsPtr = varFramePtr->nsPtr; + if (lookupNsPtr) { + varFramePtr->nsPtr = lookupNsPtr; + iPtr->lookupNsPtr = NULL; + } else { + varFramePtr->nsPtr = iPtr->globalNsPtr; + } + } else if ((flags & TCL_EVAL_GLOBAL) + && (varFramePtr != iPtr->rootFramePtr) && !savedVarFramePtr) { + varFramePtr = iPtr->rootFramePtr; + savedVarFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = varFramePtr; + } + } + + /* + * Find the function to execute this command. If there isn't one, then see + * if there is an unknown command handler registered for this namespace. + * If so, create a new word array with the handler as the first words and + * the original command words as arguments. Then call ourselves + * recursively to execute it. + */ + + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); + if (!cmdPtr) { + goto notFound; + } + + if (savedNsPtr) { + varFramePtr->nsPtr = savedNsPtr; + } else if (iPtr->ensembleRewrite.sourceObjs) { + /* + * TCL_EVAL_INVOKE was not set: clear rewrite rules + */ + + iPtr->ensembleRewrite.sourceObjs = NULL; + } + + /* + * Call trace functions if needed. + */ + + traced = (iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)); + if (traced && checkTraces) { + int cmdEpoch = cmdPtr->cmdEpoch; + int newEpoch; + + /* + * Insure that we have a correct nul-terminated command string for the + * trace code. + */ + + commandPtr = GetCommandSource(iPtr, command, length, objc, objv); + command = TclGetStringFromObj(commandPtr, &length); + + /* + * 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. + */ + + cmdPtr->refCount++; + if (iPtr->tracePtr && (traceCode == TCL_OK)) { + traceCode = TclCheckInterpTraces(interp, command, length, + cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); + } + if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { + traceCode = TclCheckExecutionTraces(interp, command, length, + cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); + } + newEpoch = cmdPtr->cmdEpoch; + TclCleanupCommandMacro(cmdPtr); + + /* + * If the traces modified/deleted the command or any existing traces, + * they will update the command's epoch. When that happens, set + * checkTraces is set to 0 to prevent the re-calling of traces (and + * any possible infinite loop) and we go back to re-find the command + * implementation. + */ + + if (traceCode == TCL_OK && cmdEpoch != newEpoch) { + checkTraces = 0; + if (commandPtr) { + Tcl_DecrRefCount(commandPtr); + commandPtr = NULL; + } + goto reparseBecauseOfTraces; + } + } + +#ifdef USE_DTRACE + if (TCL_DTRACE_CMD_ARGS_ENABLED()) { + char *a[10]; + int i = 0; + + while (i < 10) { + a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++; + } + TCL_DTRACE_CMD_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], + a[8], a[9]); + } + if (TCL_DTRACE_CMD_INFO_ENABLED() && iPtr->cmdFramePtr) { + Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr); + char *a[4]; int i[2]; + + TclDTraceInfo(info, a, i); + TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1]); + TclDecrRefCount(info); + } +#endif /* USE_DTRACE */ + + /* + * Finally, invoke the command's Tcl_ObjCmdProc. + */ + + cmdPtr->refCount++; + iPtr->cmdCount++; + if (code == TCL_OK && traceCode == TCL_OK + && !TclLimitExceeded(iPtr->limit)) { + if (TCL_DTRACE_CMD_ENTRY_ENABLED()) { + TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1, + (Tcl_Obj **)(objv + 1)); + } + code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); + if (TCL_DTRACE_CMD_RETURN_ENABLED()) { + TCL_DTRACE_CMD_RETURN(TclGetString(objv[0]), code); + } + } + + if (TclAsyncReady(iPtr)) { + code = Tcl_AsyncInvoke(interp, code); + } + if (code == TCL_OK && TclLimitReady(iPtr->limit)) { + code = Tcl_LimitCheck(interp); + } + + /* + * Call 'leave' command traces + */ + + if (traced) { + if (!(cmdPtr->flags & CMD_IS_DELETED)) { + if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && traceCode == TCL_OK){ + traceCode = TclCheckExecutionTraces(interp, command, length, + cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); + } + if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { + traceCode = TclCheckInterpTraces(interp, command, length, + cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); + } + } + + /* + * If one of the trace invocation resulted in error, then change the + * result code accordingly. Note, that the interp->result should + * already be set correctly by the call to TraceExecutionProc. + */ + + if (traceCode != TCL_OK) { + code = traceCode; + } + if (commandPtr) { + Tcl_DecrRefCount(commandPtr); + } + } + + /* + * Decrement the reference count of cmdPtr and deallocate it if it has + * dropped to zero. + */ + + TclCleanupCommandMacro(cmdPtr); + + /* + * 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. + */ + + if (*(iPtr->result) != 0) { + (void) Tcl_GetObjResult(interp); + } + +#ifdef USE_DTRACE + if (TCL_DTRACE_CMD_RESULT_ENABLED()) { + Tcl_Obj *r; + + r = Tcl_GetObjResult(interp); + TCL_DTRACE_CMD_RESULT(TclGetString(objv[0]), code, TclGetString(r),r); + } +#endif /* USE_DTRACE */ done: - Tcl_MutexUnlock(&cancelLock); + if (savedVarFramePtr) { + iPtr->varFramePtr = savedVarFramePtr; + } return code; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_InterpActive -- - * - * Returns non-zero if the specified interpreter is in use, i.e. if there - * is an evaluation currently active in the interpreter. - * - * Results: - * See above. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_InterpActive( - Tcl_Interp *interp) -{ - return ((Interp *) interp)->numLevels > 0; + + notFound: + { + Namespace *currNsPtr = NULL; /* Used to check for and invoke any + * registered unknown command handler + * for the current namespace (TIP + * 181). */ + int newObjc, handlerObjc; + Tcl_Obj **handlerObjv; + + currNsPtr = varFramePtr->nsPtr; + if ((currNsPtr == NULL) || (currNsPtr->unknownHandlerPtr == NULL)) { + currNsPtr = iPtr->globalNsPtr; + if (currNsPtr == NULL) { + Tcl_Panic("TclEvalObjvInternal: NULL global namespace pointer"); + } + } + + /* + * Check to see if the resolution namespace has lost its unknown + * handler. If so, reset it to "::unknown". + */ + + if (currNsPtr->unknownHandlerPtr == NULL) { + TclNewLiteralStringObj(currNsPtr->unknownHandlerPtr, "::unknown"); + Tcl_IncrRefCount(currNsPtr->unknownHandlerPtr); + } + + /* + * Get the list of words for the unknown handler and allocate enough + * space to hold both the handler prefix and all words of the command + * invokation itself. + */ + + Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr, + &handlerObjc, &handlerObjv); + newObjc = objc + handlerObjc; + newObjv = (Tcl_Obj **) TclStackAlloc(interp, + (int) sizeof(Tcl_Obj *) * newObjc); + + /* + * Copy command prefix from unknown handler and add on the real + * command's full argument list. Note that we only use memcpy() once + * because we have to increment the reference count of all the handler + * arguments anyway. + */ + + for (i = 0; i < handlerObjc; ++i) { + newObjv[i] = handlerObjv[i]; + Tcl_IncrRefCount(newObjv[i]); + } + memcpy(newObjv+handlerObjc, objv, sizeof(Tcl_Obj *) * (unsigned)objc); + + /* + * Look up and invoke the handler (by recursive call to this + * function). If there is no handler at all, instead of doing the + * recursive call we just generate a generic error message; it would + * be an infinite-recursion nightmare otherwise. + */ + + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]); + if (cmdPtr == NULL) { + Tcl_AppendResult(interp, "invalid command name \"", + TclGetString(objv[0]), "\"", NULL); + code = TCL_ERROR; + } else { + iPtr->numLevels++; + code = TclEvalObjvInternal(interp, newObjc, newObjv, command, + length, 0); + iPtr->numLevels--; + } + + /* + * Release any resources we locked and allocated during the handler + * call. + */ + + for (i = 0; i < handlerObjc; ++i) { + Tcl_DecrRefCount(newObjv[i]); + } + TclStackFree(interp, newObjv); + if (savedNsPtr) { + varFramePtr->nsPtr = savedNsPtr; + } + goto done; + } } /* *---------------------------------------------------------------------- * @@ -4106,11 +3963,11 @@ * Results: * The return value is a standard Tcl completion code such as TCL_OK or * TCL_ERROR. A result or error message is left in interp's result. * * Side effects: - * Always pushes a callback. Other side effects depend on the command. + * Depends on the command. * *---------------------------------------------------------------------- */ int @@ -4120,691 +3977,59 @@ int objc, /* Number of words in command. */ Tcl_Obj *const objv[], /* An array of pointers to objects that are * the words that make up the command. */ int flags) /* Collection of OR-ed bits that control the * evaluation of the script. Only - * TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and - * TCL_EVAL_NOERR are currently supported. */ -{ - int result; - NRE_callback *rootPtr = TOP_CB(interp); - - result = TclNREvalObjv(interp, objc, objv, flags, NULL); - return TclNRRunCallbacks(interp, result, rootPtr); -} - -int -TclNREvalObjv( - Tcl_Interp *interp, /* Interpreter in which to evaluate the - * command. Also used for error reporting. */ - int objc, /* Number of words in command. */ - Tcl_Obj *const objv[], /* An array of pointers to objects that are - * the words that make up the command. */ - int flags, /* Collection of OR-ed bits that control the - * evaluation of the script. Only - * TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and - * TCL_EVAL_NOERR are currently supported. */ - Command *cmdPtr) /* NULL if the Command is to be looked up - * here, otherwise the pointer to the - * requested Command struct to be invoked. */ + * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are + * currently supported. */ { Interp *iPtr = (Interp *) interp; - - /* - * data[1] stores a marker for use by tailcalls; it will be set to 1 by - * command redirectors (imports, alias, ensembles) so that tailcall skips - * this callback (that marks the end of the target command) and goes back - * to the end of the source command. - */ - - if (iPtr->deferredCallbacks) { - iPtr->deferredCallbacks = NULL; - } else { - TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); - } + int code = TCL_OK; + int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); iPtr->numLevels++; - TclNRAddCallback(interp, EvalObjvCore, cmdPtr, INT2PTR(flags), - INT2PTR(objc), objv); - 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). - */ - - if (!(flags & TCL_EVAL_NOERR)) { - TEOV_PushExceptionHandlers(interp, objc, objv, flags); - } - - if (TCL_OK != TclInterpReady(interp)) { - return TCL_ERROR; - } - - if (objc == 0) { - return TCL_OK; - } - - if (TclLimitExceeded(iPtr->limit)) { - return TCL_ERROR; - } - - /* - * Configure evaluation context to match the requested flags. - */ - - if (iPtr->lookupNsPtr) { - - /* - * Capture the namespace we should do command name resolution in, as - * instructed by our caller sneaking it in to us in a private interp - * field. Clear that field right away so we cannot possibly have its - * use leak where it should not. The sneaky message pass is done. - * - * Use of this mechanism overrides the TCL_EVAL_GLOBAL flag. - * TODO: Is that a bug? - */ - - lookupNsPtr = iPtr->lookupNsPtr; - iPtr->lookupNsPtr = NULL; - } else if (flags & TCL_EVAL_INVOKE) { - lookupNsPtr = iPtr->globalNsPtr; - } else { - - /* - * TCL_EVAL_INVOKE was not set: clear rewrite rules - */ - - TclResetRewriteEnsemble(interp, 1); - - if (flags & TCL_EVAL_GLOBAL) { - TEOV_SwitchVarFrame(interp); - lookupNsPtr = iPtr->globalNsPtr; - } - } - - /* - * Lookup the Command to dispatch. - */ - - reresolve: - assert(cmdPtr == NULL); - if (preCmdPtr) { - /* - * Caller gave it to us. - */ - - if (!(preCmdPtr->flags & CMD_DEAD)) { - /* - * So long as it exists, use it. - */ - - cmdPtr = preCmdPtr; - } else if (flags & TCL_EVAL_NORESOLVE) { - /* - * When it's been deleted, and we're told not to attempt resolving - * it ourselves, all we can do is raise an error. - */ - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "attempt to invoke a deleted command")); - Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL); - return TCL_ERROR; - } - } - if (cmdPtr == NULL) { - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); - if (!cmdPtr) { - return TEOV_NotFound(interp, objc, objv, lookupNsPtr); - } - } - - if (enterTracesDone || iPtr->tracePtr - || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { - Tcl_Obj *commandPtr = TclGetSourceFromFrame( - flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, - objc, objv); - - Tcl_IncrRefCount(commandPtr); - if (!enterTracesDone) { - int code = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr, - objc, objv); - - /* - * Send any exception from enter traces back as an exception - * raised by the traced command. - * TODO: Is this a bug? Letting an execution trace BREAK or - * CONTINUE or RETURN in the place of the traced command? Would - * either converting all exceptions to TCL_ERROR, or just - * swallowing them be better? (Swallowing them has the problem of - * permanently hiding program errors.) - */ - - if (code != TCL_OK) { - Tcl_DecrRefCount(commandPtr); - return code; - } - - /* - * If the enter traces made the resolved cmdPtr unusable, go back - * and resolve again, but next time don't run enter traces again. - */ - - if (cmdPtr == NULL) { - enterTracesDone = 1; - Tcl_DecrRefCount(commandPtr); - goto reresolve; - } - } - - /* - * Schedule leave traces. Raise the refCount on the resolved cmdPtr, - * so that when it passes to the leave traces we know it's still - * valid. - */ - - cmdPtr->refCount++; - TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), - commandPtr, cmdPtr, objv); - } - - TclNRAddCallback(interp, Dispatch, - cmdPtr->nreProc ? cmdPtr->nreProc : cmdPtr->objProc, - cmdPtr->objClientData, INT2PTR(objc), objv); - return TCL_OK; -} - -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; - - while (i < 10) { - a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++; - } - TCL_DTRACE_CMD_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], - a[8], a[9]); - } - if (TCL_DTRACE_CMD_INFO_ENABLED() && iPtr->cmdFramePtr) { - Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr); - const char *a[6]; int i[2]; - - TclDTraceInfo(info, a, i); - TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); - TclDecrRefCount(info); - } - if ((TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED()) - && objc) { - TclNRAddCallback(interp, DTraceCmdReturn, objv[0], NULL, NULL, NULL); - } - if (TCL_DTRACE_CMD_ENTRY_ENABLED() && objc) { - TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1, - (Tcl_Obj **)(objv + 1)); - } -#endif /* USE_DTRACE */ - - iPtr->cmdCount++; - return objProc(clientData, interp, objc, objv); -} - -int -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); - } - return result; -} - -static int -NRCommand( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - Interp *iPtr = (Interp *) interp; - + code = TclEvalObjvInternal(interp, objc, objv, NULL, 0, flags); iPtr->numLevels--; - /* - * If there is a tailcall, schedule it next - */ - - if (data[1] && (data[1] != INT2PTR(1))) { - TclNRAddCallback(interp, TclNRTailcallEval, data[1], NULL, NULL, NULL); - } - - /* OPT ?? - * Do not interrupt a series of cleanups with async or limit checks: - * just check at the end? - */ - - if (TclAsyncReady(iPtr)) { - result = Tcl_AsyncInvoke(interp, result); - } - if ((result == TCL_OK) && TclCanceled(iPtr)) { - result = Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG); - } - if (result == TCL_OK && TclLimitReady(iPtr->limit)) { - result = Tcl_LimitCheck(interp); - } - - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TEOV_Exception - - * TEOV_LookupCmdFromObj - - * TEOV_RunEnterTraces - - * TEOV_RunLeaveTraces - - * TEOV_NotFound - - * - * These are helper functions for Tcl_EvalObjv. - * - *---------------------------------------------------------------------- - */ - -static void -TEOV_PushExceptionHandlers( - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[], - int flags) -{ - Interp *iPtr = (Interp *) interp; - - /* - * If any error processing is necessary, push the appropriate records. - * Note that we have to push them in the inverse order: first the one that - * has to run last. - */ - - if (!(flags & TCL_EVAL_INVOKE)) { - /* - * Error messages - */ - - TclNRAddCallback(interp, TEOV_Error, INT2PTR(objc), - (ClientData) objv, NULL, NULL); - } - - if (iPtr->numLevels == 1) { - /* - * No CONTINUE or BREAK at level 0, manage RETURN - */ - - TclNRAddCallback(interp, TEOV_Exception, INT2PTR(iPtr->evalFlags), - NULL, NULL, NULL); - } -} - -static void -TEOV_SwitchVarFrame( - Tcl_Interp *interp) -{ - Interp *iPtr = (Interp *) interp; - - /* - * Change the varFrame to be the rootVarFrame, and push a record to - * restore things at the end. - */ - - TclNRAddCallback(interp, TEOV_RestoreVarFrame, iPtr->varFramePtr, NULL, - NULL, NULL); - iPtr->varFramePtr = iPtr->rootFramePtr; -} - -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, - int result) -{ - Interp *iPtr = (Interp *) interp; - int allowExceptions = (PTR2INT(data[0]) & TCL_ALLOW_EXCEPTIONS); - - if (result != TCL_OK) { - if (result == TCL_RETURN) { - result = TclUpdateReturnInfo(iPtr); - } - if ((result != TCL_OK) && (result != TCL_ERROR) && !allowExceptions) { - ProcessUnexpectedResult(interp, result); - result = TCL_ERROR; - } - } - - /* - * We are returning to level 0, so should process TclResetCancellation. As - * numLevels has not *yet* been decreased, do not call it: do the thing - * here directly. - */ - - TclUnsetCancelFlags(iPtr); - return result; -} - -static int -TEOV_Error( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - Interp *iPtr = (Interp *) interp; - Tcl_Obj *listPtr; - const char *cmdString; - size_t 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. - */ - - listPtr = Tcl_NewListObj(objc, objv); - cmdString = TclGetStringFromObj(listPtr, &cmdLen); - Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); - Tcl_DecrRefCount(listPtr); - } - iPtr->flags &= ~ERR_ALREADY_LOGGED; - return result; -} - -static int -TEOV_NotFound( - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[], - Namespace *lookupNsPtr) -{ - Command * cmdPtr; - Interp *iPtr = (Interp *) interp; - int i, newObjc, handlerObjc; - Tcl_Obj **newObjv, **handlerObjv; - CallFrame *varFramePtr = iPtr->varFramePtr; - Namespace *currNsPtr = NULL;/* Used to check for and invoke any registered - * unknown command handler for the current - * namespace (TIP 181). */ - Namespace *savedNsPtr = NULL; - - currNsPtr = varFramePtr->nsPtr; - if ((currNsPtr == NULL) || (currNsPtr->unknownHandlerPtr == NULL)) { - currNsPtr = iPtr->globalNsPtr; - if (currNsPtr == NULL) { - Tcl_Panic("Tcl_EvalObjv: NULL global namespace pointer"); - } - } - - /* - * Check to see if the resolution namespace has lost its unknown handler. - * If so, reset it to "::unknown". - */ - - if (currNsPtr->unknownHandlerPtr == NULL) { - TclNewLiteralStringObj(currNsPtr->unknownHandlerPtr, "::unknown"); - Tcl_IncrRefCount(currNsPtr->unknownHandlerPtr); - } - - /* - * Get the list of words for the unknown handler and allocate enough space - * to hold both the handler prefix and all words of the command 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. - */ - - for (i = 0; i < handlerObjc; ++i) { - newObjv[i] = handlerObjv[i]; - Tcl_IncrRefCount(newObjv[i]); - } - memcpy(newObjv+handlerObjc, objv, sizeof(Tcl_Obj *) * objc); - - /* - * Look up and invoke the handler (by recursive call to this function). If - * there is no handler at all, instead of doing the recursive call we just - * generate a generic error message; it would be an infinite-recursion - * nightmare otherwise. - * - * In this case we worry a bit less about recursion for now, and call the - * "blocking" interface. - */ - - cmdPtr = TEOV_LookupCmdFromObj(interp, newObjv[0], lookupNsPtr); - if (cmdPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid command name \"%s\"", TclGetString(objv[0]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", - TclGetString(objv[0]), NULL); - - /* - * Release any resources we locked and allocated during the handler - * call. - */ - - for (i = 0; i < handlerObjc; ++i) { - Tcl_DecrRefCount(newObjv[i]); - } - TclStackFree(interp, newObjv); - return TCL_ERROR; - } - - if (lookupNsPtr) { - savedNsPtr = varFramePtr->nsPtr; - varFramePtr->nsPtr = lookupNsPtr; - } - TclSkipTailcall(interp); - TclNRAddCallback(interp, TEOV_NotFoundCallback, INT2PTR(handlerObjc), - newObjv, savedNsPtr, NULL); - return TclNREvalObjv(interp, newObjc, newObjv, TCL_EVAL_NOERR, NULL); -} - -static int -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; - } - - /* - * Release any resources we locked and allocated during the handler call. - */ - - for (i = 0; i < objc; ++i) { - Tcl_DecrRefCount(objv[i]); - } - TclStackFree(interp, objv); - - return result; -} - -static int -TEOV_RunEnterTraces( - Tcl_Interp *interp, - Command **cmdPtrPtr, - Tcl_Obj *commandPtr, - int objc, - Tcl_Obj *const objv[]) -{ - Interp *iPtr = (Interp *) interp; - Command *cmdPtr = *cmdPtrPtr; - size_t length, newEpoch, cmdEpoch = cmdPtr->cmdEpoch; - int traceCode = TCL_OK; - const char *command = TclGetStringFromObj(commandPtr, &length); - - /* - * Call trace functions. - * Execute any command or execution traces. Note that we bump up the - * command's reference count for the duration of the calling of the - * traces so that the structure doesn't go away underneath our feet. - */ - - cmdPtr->refCount++; - if (iPtr->tracePtr) { - traceCode = TclCheckInterpTraces(interp, command, length, - cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); - } - if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { - traceCode = TclCheckExecutionTraces(interp, command, length, - cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); - } - newEpoch = cmdPtr->cmdEpoch; - TclCleanupCommandMacro(cmdPtr); - - if (traceCode != TCL_OK) { - if (traceCode == TCL_ERROR) { - Tcl_Obj *info; - - TclNewLiteralStringObj(info, "\n (enter trace on \""); - Tcl_AppendLimitedToObj(info, command, length, 55, "..."); - Tcl_AppendToObj(info, "\")", 2); - Tcl_AppendObjToErrorInfo(interp, info); - iPtr->flags |= ERR_ALREADY_LOGGED; - } - return traceCode; - } - if (cmdEpoch != newEpoch) { - *cmdPtrPtr = NULL; - } - return TCL_OK; -} - -static int -TEOV_RunLeaveTraces( - 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]; - size_t length; - const char *command = TclGetStringFromObj(commandPtr, &length); - - if (!(cmdPtr->flags & CMD_DYING)) { - if (cmdPtr->flags & CMD_HAS_EXEC_TRACES) { - traceCode = TclCheckExecutionTraces(interp, command, length, - cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); - } - if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { - traceCode = TclCheckInterpTraces(interp, command, length, - cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); - } - } - - /* - * As cmdPtr is set, TclNRRunCallbacks is about to reduce the numlevels. - * Prevent that by resetting the cmdPtr field and dealing right here with - * cmdPtr->refCount. - */ - - TclCleanupCommandMacro(cmdPtr); - - if (traceCode != TCL_OK) { - if (traceCode == TCL_ERROR) { - Tcl_Obj *info; - - TclNewLiteralStringObj(info, "\n (leave trace on \""); - Tcl_AppendLimitedToObj(info, command, length, 55, "..."); - Tcl_AppendToObj(info, "\")", 2); - Tcl_AppendObjToErrorInfo(interp, info); - iPtr->flags |= ERR_ALREADY_LOGGED; - } - result = traceCode; - } - Tcl_DecrRefCount(commandPtr); - return result; -} - -static inline Command * -TEOV_LookupCmdFromObj( - Tcl_Interp *interp, - Tcl_Obj *namePtr, - Namespace *lookupNsPtr) -{ - Interp *iPtr = (Interp *) interp; - Command *cmdPtr; - Namespace *savedNsPtr = iPtr->varFramePtr->nsPtr; - - if (lookupNsPtr) { - iPtr->varFramePtr->nsPtr = lookupNsPtr; - } - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, namePtr); - iPtr->varFramePtr->nsPtr = savedNsPtr; - return cmdPtr; + if (code == TCL_OK) { + return code; + } else { + + /* + * If we are again at the top level, process any unusual return code + * returned by the evaluated code. + */ + + if (iPtr->numLevels == 0) { + if (code == TCL_RETURN) { + code = TclUpdateReturnInfo(iPtr); + } + if ((code != TCL_ERROR) && !allowExceptions) { + ProcessUnexpectedResult(interp, code); + code = TCL_ERROR; + } + } + + if ((code == TCL_ERROR) && !(flags & TCL_EVAL_INVOKE)) { + /* + * If there was an error, a command string will be needed for the + * error log: generate it now. Do not worry too much about doing + * it expensively. + */ + + Tcl_Obj *listPtr; + char *cmdString; + int cmdLen; + + listPtr = Tcl_NewListObj(objc, objv); + cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen); + Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); + Tcl_DecrRefCount(listPtr); + } + + return code; + } } /* *---------------------------------------------------------------------- * @@ -4830,15 +4055,63 @@ 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. */ - size_t count) /* Number of tokens to consider at tokenPtr. + int count) /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ { return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL, 1, - NULL, NULL); + NULL, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * 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; } /* *---------------------------------------------------------------------- * @@ -4863,92 +4136,95 @@ 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. */ - size_t numBytes, /* Number of bytes in script. If -1, the + 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); + 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. */ - size_t numBytes, /* Number of bytes in script. If -1, the + 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 */ - const char *outerScript) /* continuation line data. This is set only in - * TclSubstTokens(), to properly handle - * [...]-nested commands. The 'outerScript' - * refers to the most-outer script containing - * the embedded command, which is refered to - * by 'script'. The 'clNextOuter' refers to - * the current entry in the table of - * continuation lines in this "main script", - * and the character offsets are relative to - * the 'outerScript' as well. - * - * If outerScript == script, then this call is - * for the outer-most script/command. See - * Tcl_EvalEx() and TclEvalObjEx() for places - * generating arguments for which this is - * true. */ + int* clNextOuter, /* Information about an outer context for */ + CONST char* outerScript) /* continuation line data. This is set only in + * TclSubstTokens(), to properly handle + * [...]-nested commands. The 'outerScript' + * refers to the most-outer script containing the + * embedded command, which is refered to by + * 'script'. The 'clNextOuter' refers to the + * current entry in the table of continuation + * lines in this "master script", and the + * character offsets are relative to the + * 'outerScript' as well. + * + * If outerScript == script, then this call is + * for the outer-most script/command. See + * Tcl_EvalEx() and TclEvalObjEx() for places + * generating arguments for which this is true. + */ { 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 bytesLeft, expandRequested, code = TCL_OK; - size_t commandLength; + 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_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)); + 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. */ + /* + * 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. + */ + + int* clNext = NULL; if (iPtr->scriptCLLocPtr) { if (clNextOuter) { clNext = clNextOuter; } else { clNext = &iPtr->scriptCLLocPtr->loc[0]; } } - if (numBytes == TCL_INDEX_NONE) { + if (numBytes < 0) { numBytes = strlen(script); } Tcl_ResetResult(interp); savedVarFramePtr = iPtr->varFramePtr; @@ -4968,26 +4244,27 @@ bytesLeft = numBytes; /* * TIP #280 Initialize tracking. Do not push on the frame stack yet. * - * We open a new context, either for a sourced script, or 'eval'. - * For sourced files we always have a path object, even if nothing was - * specified in the interp itself. That makes code using it simpler as - * NULL checks can be left out. Sourced file without path in the - * 'scriptFile' is possible during Tcl initialization. + * We may continue counting based on a specific context (CTX), or open a + * new context, either for a sourced script, or 'eval'. For sourced files + * we always have a path object, even if nothing was specified in the + * interp itself. That makes code using it simpler as NULL checks can be + * left out. Sourced file without path in the 'scriptFile' is possible + * during Tcl initialization. */ - eeFramePtr->level = iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level + 1 : 1; - eeFramePtr->framePtr = iPtr->framePtr; - eeFramePtr->nextPtr = iPtr->cmdFramePtr; - eeFramePtr->nline = 0; - eeFramePtr->line = NULL; - eeFramePtr->cmdObj = NULL; - - iPtr->cmdFramePtr = eeFramePtr; - if (iPtr->evalFlags & TCL_EVAL_FILE) { + if (iPtr->evalFlags & TCL_EVAL_CTX) { + /* + * Path information comes out of the context. + */ + + eeFramePtr->type = TCL_LOCATION_SOURCE; + eeFramePtr->data.eval.path = iPtr->invokeCmdFramePtr->data.eval.path; + Tcl_IncrRefCount(eeFramePtr->data.eval.path); + } else if (iPtr->evalFlags & TCL_EVAL_FILE) { /* * Set up for a sourced file. */ eeFramePtr->type = TCL_LOCATION_SOURCE; @@ -5004,11 +4281,10 @@ if (norm == NULL) { /* * Error message in the interp result. */ - code = TCL_ERROR; goto error; } eeFramePtr->data.eval.path = norm; } else { @@ -5022,28 +4298,32 @@ eeFramePtr->type = TCL_LOCATION_EVAL; eeFramePtr->data.eval.path = NULL; } + eeFramePtr->level = iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level + 1 : 1; + eeFramePtr->framePtr = iPtr->framePtr; + eeFramePtr->nextPtr = iPtr->cmdFramePtr; + eeFramePtr->nline = 0; + eeFramePtr->line = NULL; + iPtr->evalFlags = 0; do { if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) { code = TCL_ERROR; - Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, - parsePtr->term + 1 - parsePtr->commandStart); - goto posterror; + goto error; } /* * TIP #280 Track lines. The parser may have skipped text till it * found the command we are now at. We have to count the lines in this * block, and do not forget invisible continuation lines. */ TclAdvanceLines(&line, p, parsePtr->commandStart); - TclAdvanceContinuations(&line, &clNext, - parsePtr->commandStart - outerScript); + TclAdvanceContinuations (&line, &clNext, + parsePtr->commandStart - outerScript); gotParse = 1; if (parsePtr->numWords > 0) { /* * TIP #280. Track lines within the words of the current @@ -5050,30 +4330,31 @@ * command. We use a separate pointer into the table of * continuation line locations to not lose our position for the * per-command parsing. */ - int wordLine = line; + int wordLine = line; const char *wordStart = parsePtr->commandStart; - int *wordCLNext = clNext; - unsigned int objectsNeeded = 0; - unsigned int numWords = parsePtr->numWords; + int* wordCLNext = clNext; /* * Generate an array of objects for the words of the command. */ + unsigned int objectsNeeded = 0; + unsigned int numWords = parsePtr->numWords; + if (numWords > minObjs) { - expand = (int *)Tcl_Alloc(numWords * sizeof(int)); - objvSpace = (Tcl_Obj **)Tcl_Alloc(numWords * sizeof(Tcl_Obj *)); - lineSpace = (int *)Tcl_Alloc(numWords * sizeof(int)); + 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; objectsUsed < numWords; objectsUsed++, tokenPtr += tokenPtr->numComponents+1) { /* * TIP #280. Track lines to current word. Save the information @@ -5082,12 +4363,12 @@ * evaluator as well, including the type of context (source * vs. eval). */ TclAdvanceLines(&wordLine, wordStart, tokenPtr->start); - TclAdvanceContinuations(&wordLine, &wordCLNext, - tokenPtr->start - outerScript); + TclAdvanceContinuations (&wordLine, &wordCLNext, + tokenPtr->start - outerScript); wordStart = tokenPtr->start; lines[objectsUsed] = TclWordKnownAtCompileTime(tokenPtr, NULL) ? wordLine : -1; @@ -5095,16 +4376,16 @@ iPtr->evalFlags |= TCL_EVAL_FILE; } code = TclSubstTokens(interp, tokenPtr+1, tokenPtr->numComponents, NULL, wordLine, - wordCLNext, outerScript); + wordCLNext, outerScript); iPtr->evalFlags = 0; if (code != TCL_OK) { - break; + goto error; } objv[objectsUsed] = Tcl_GetObjResult(interp); Tcl_IncrRefCount(objv[objectsUsed]); if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { int numElements; @@ -5117,11 +4398,11 @@ */ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (expanding word %d)", objectsUsed)); Tcl_DecrRefCount(objv[objectsUsed]); - break; + goto error; } expandRequested = 1; expand[objectsUsed] = 1; objectsNeeded += (numElements ? numElements : 1); @@ -5129,18 +4410,14 @@ expand[objectsUsed] = 0; objectsNeeded++; } if (wordCLNext) { - TclContinuationsEnterDerived(objv[objectsUsed], - wordStart - outerScript, wordCLNext); + TclContinuationsEnterDerived (objv[objectsUsed], + wordStart - outerScript, wordCLNext); } } /* for loop */ - iPtr->cmdFramePtr = eeFramePtr; - if (code != TCL_OK) { - goto error; - } if (expandRequested) { /* * Some word expansion was requested. Check for objv resize. */ @@ -5147,14 +4424,15 @@ Tcl_Obj **copy = objvSpace; int *lcopy = lineSpace; int wordIdx = numWords; int objIdx = objectsNeeded - 1; - if ((numWords > minObjs) || (objectsNeeded > minObjs)) { - objv = objvSpace = - (Tcl_Obj **)Tcl_Alloc(objectsNeeded * sizeof(Tcl_Obj *)); - lines = lineSpace = (int *)Tcl_Alloc(objectsNeeded * sizeof(int)); + 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]) { @@ -5177,14 +4455,14 @@ } } objv += objIdx+1; if (copy != stackObjArray) { - Tcl_Free(copy); + ckfree((char *) copy); } if (lcopy != linesStack) { - Tcl_Free(lcopy); + ckfree((char *) lcopy); } } /* * Execute the command and free the objects for its words. @@ -5194,54 +4472,54 @@ * termination character, if necessary. Here is where we put our * frame on the stack of frames too. _After_ the nested commands * have been executed. */ - eeFramePtr->cmd = parsePtr->commandStart; - eeFramePtr->len = parsePtr->commandSize; + eeFramePtr->cmd.str.cmd = parsePtr->commandStart; + eeFramePtr->cmd.str.len = parsePtr->commandSize; if (parsePtr->term == parsePtr->commandStart + parsePtr->commandSize - 1) { - eeFramePtr->len--; + eeFramePtr->cmd.str.len--; } eeFramePtr->nline = objectsUsed; eeFramePtr->line = lines; - TclArgumentEnter(interp, objv, objectsUsed, eeFramePtr); - code = Tcl_EvalObjv(interp, objectsUsed, objv, - TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME); - TclArgumentRelease(interp, objv, objectsUsed); + TclArgumentEnter (interp, objv, objectsUsed, eeFramePtr); + iPtr->cmdFramePtr = eeFramePtr; + iPtr->numLevels++; + code = TclEvalObjvInternal(interp, objectsUsed, objv, + parsePtr->commandStart, parsePtr->commandSize, 0); + iPtr->numLevels--; + iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; + TclArgumentRelease (interp, objv, objectsUsed); eeFramePtr->line = NULL; eeFramePtr->nline = 0; - if (eeFramePtr->cmdObj) { - Tcl_DecrRefCount(eeFramePtr->cmdObj); - eeFramePtr->cmdObj = NULL; - } if (code != TCL_OK) { goto error; } for (i = 0; i < objectsUsed; i++) { Tcl_DecrRefCount(objv[i]); } objectsUsed = 0; if (objvSpace != stackObjArray) { - Tcl_Free(objvSpace); + ckfree((char *) objvSpace); objvSpace = stackObjArray; - Tcl_Free(lineSpace); + ckfree((char *) lineSpace); lineSpace = linesStack; } /* * Free expand separately since objvSpace could have been * reallocated above. */ if (expand != expandStack) { - Tcl_Free(expand); + ckfree((char *) expand); expand = expandStack; } } /* @@ -5289,11 +4567,10 @@ commandLength -= 1; } Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, commandLength); } - posterror: iPtr->flags &= ~ERR_ALREADY_LOGGED; /* * Then free resources that had been allocated to the command. */ @@ -5303,24 +4580,23 @@ } if (gotParse) { Tcl_FreeParse(parsePtr); } if (objvSpace != stackObjArray) { - Tcl_Free(objvSpace); - Tcl_Free(lineSpace); + ckfree((char *) objvSpace); + ckfree((char *) lineSpace); } if (expand != expandStack) { - Tcl_Free(expand); + ckfree((char *) expand); } iPtr->varFramePtr = savedVarFramePtr; cleanup_return: /* * TIP #280. Release the local CmdFrame, and its contents. */ - iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; if (eeFramePtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(eeFramePtr->data.eval.path); } TclStackFree(interp, linesStack); TclStackFree(interp, expandStack); @@ -5353,11 +4629,11 @@ TclAdvanceLines( int *line, const char *start, const char *end) { - const char *p; + register const char *p; for (p = start; p < end; p++) { if (*p == '\n') { (*line)++; } @@ -5383,35 +4659,33 @@ * TIP #280 *---------------------------------------------------------------------- */ void -TclAdvanceContinuations( - int *line, - int **clNextPtrPtr, - int loc) +TclAdvanceContinuations (line,clNextPtrPtr,loc) + int* line; + int** clNextPtrPtr; + int loc; { /* - * Track the invisible continuation lines embedded in a script, if any. - * Here they are just spaces (already). They were removed by - * TclSubstTokens via TclParseBackslash. + * Track the invisible continuation lines embedded in a script, if + * any. Here they are just spaces (already). They were removed by + * TclSubstTokens() via TclParseBackslash(). * * *clNextPtrPtr <=> We have continuation lines to track. * **clNextPtrPtr >= 0 <=> We are not beyond the last possible location. * loc >= **clNextPtrPtr <=> We stepped beyond the current cont. line. */ - while (*clNextPtrPtr && (**clNextPtrPtr >= 0) - && (loc >= **clNextPtrPtr)) { + while (*clNextPtrPtr && (**clNextPtrPtr >= 0) && (loc >= **clNextPtrPtr)) { /* * We just stepped over an invisible continuation line. Adjust the * line counter and step to the table entry holding the location of * the next continuation line to track. */ - - (*line)++; - (*clNextPtrPtr)++; + (*line) ++; + (*clNextPtrPtr) ++; } } /* *---------------------------------------------------------------------- @@ -5425,12 +4699,12 @@ /* *---------------------------------------------------------------------- * * TclArgumentEnter -- * - * This procedure is a helper for the TIP #280 uplevel extension. It - * enters location references for the arguments of a command to be + * This procedure is a helper for the TIP #280 uplevel extension. + * It enters location references for the arguments of a command to be * invoked. Only the first entry has the actual data, further entries * simply count the usage up. * * Results: * None. @@ -5441,66 +4715,62 @@ * TIP #280 *---------------------------------------------------------------------- */ void -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 +TclArgumentEnter(interp,objv,objc,cfPtr) + Tcl_Interp* interp; + Tcl_Obj** objv; + int objc; + CmdFrame* cfPtr; +{ + Interp* iPtr = (Interp*) interp; + int new, 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 *)Tcl_Alloc(sizeof(CFWord)); - cfwPtr->framePtr = cfPtr; - cfwPtr->word = i; - cfwPtr->refCount = 1; - Tcl_SetHashValue(hPtr, cfwPtr); + if (cfPtr->line [i] < 0) continue; + hPtr = Tcl_CreateHashEntry (iPtr->lineLAPtr, (char*) objv[i], &new); + if (new) { + /* + * 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++; + /* + * 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 ++; } } } /* *---------------------------------------------------------------------- * * TclArgumentRelease -- * - * This procedure is a helper for the TIP #280 uplevel extension. It - * removes the location references for the arguments of a command just - * done. Usage is counted down, the data is removed only when no user is - * left over. + * This procedure is a helper for the TIP #280 uplevel extension. + * It removes the location references for the arguments of a command + * just done. Usage is counted down, the data is removed only when + * no user is left over. * * Results: * None. * * Side effects: @@ -5509,45 +4779,42 @@ * TIP #280 *---------------------------------------------------------------------- */ void -TclArgumentRelease( - Tcl_Interp *interp, - Tcl_Obj **objv, - int objc) +TclArgumentRelease(interp,objv,objc) + Tcl_Interp* interp; + Tcl_Obj** objv; + int objc; { - Interp *iPtr = (Interp *) interp; + Interp* iPtr = (Interp*) interp; + Tcl_HashEntry* hPtr; + CFWord* cfwPtr; int i; - for (i = 1; i < objc; i++) { - 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; - } - - Tcl_Free(cfwPtr); - Tcl_DeleteHashEntry(hPtr); + for (i=1; i < objc; i++) { + hPtr = Tcl_FindHashEntry (iPtr->lineLAPtr, (char *) objv[i]); + + if (!hPtr) { continue; } + cfwPtr = (CFWord*) Tcl_GetHashValue (hPtr); + + cfwPtr->refCount --; + if (cfwPtr->refCount > 0) { continue; } + + ckfree ((char*) cfwPtr); + Tcl_DeleteHashEntry (hPtr); } } /* *---------------------------------------------------------------------- * * TclArgumentBCEnter -- * - * This procedure is a helper for the TIP #280 uplevel extension. It - * enters location references for the literal arguments of commands in - * bytecode about to be invoked. Only the first entry has the actual + * This procedure is a helper for the TIP #280 uplevel extension. + * It enters location references for the literal arguments of commands + * in bytecode about to be invoked. Only the first entry has the actual * data, further entries simply count the usage up. * * Results: * None. * @@ -5557,109 +4824,88 @@ * TIP #280 *---------------------------------------------------------------------- */ void -TclArgumentBCEnter( - Tcl_Interp *interp, - Tcl_Obj *objv[], - int objc, - void *codePtr, - CmdFrame *cfPtr, - int cmd, - size_t 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. - * - * If they are not the same, we arrived here by compiling an - * ensemble dispatch. Ensemble subcommands that lead to script - * evaluation are not supposed to get compiled, because a command - * such as [info level] in the script can expose some of the dispatch - * shenanigans. This means that we don't have to tend to the - * housekeeping, and can escape now. - */ - - if (ePtr->nline != objc) { - return; - } - - /* - * Having disposed of the ensemble cases, we can state... - * A few truths ... - * (1) ePtr->nline == objc - * (2) (ePtr->line[word] < 0) => !literal, for all words - * (3) (word == 0) => !literal - * - * Item (2) is why we can use objv to get the literals, and do not - * have to save them at compile time. - */ - - for (word = 1; word < objc; word++) { - if (ePtr->line[word] >= 0) { - int isNew; - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr, - objv[word], &isNew); - CFWordBC *cfwPtr = (CFWordBC *)Tcl_Alloc(sizeof(CFWordBC)); - - cfwPtr->framePtr = cfPtr; - cfwPtr->obj = objv[word]; - cfwPtr->pc = pc; - cfwPtr->word = word; - cfwPtr->nextPtr = lastPtr; - 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; +TclArgumentBCEnter(interp,objv,objc,codePtr,cfPtr,pc) + Tcl_Interp* interp; + Tcl_Obj* objv[]; + int objc; + void* codePtr; + CmdFrame* cfPtr; + int pc; +{ + Interp* iPtr = (Interp*) interp; + Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr); + + if (hePtr) { + ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr); + hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, INT2PTR(pc)); + + if (hePtr) { + int cmd = PTR2INT(Tcl_GetHashValue(hePtr)); + ECL* ePtr = &eclPtr->loc[cmd]; + int word; + + /* + * A few truths ... + * (1) ePtr->nline == objc + * (2) (ePtr->line[word] < 0) => !literal, for all words + * (3) (word == 0) => !literal + * + * Item (2) is why we can use objv to get the literals, and do not + * have to save them at compile time. + */ + + if (ePtr->nline != objc) { + Tcl_Panic ("TIP 280 data structure inconsistency"); + } + + for (word = 1; word < objc; word++) { + if (ePtr->line[word] >= 0) { + int isnew; + Tcl_HashEntry* hPtr = + Tcl_CreateHashEntry (iPtr->lineLABCPtr, + (char*) objv[word], &isnew); + CFWordBC* cfwPtr = (CFWordBC*) ckalloc (sizeof (CFWordBC)); + + cfwPtr->framePtr = cfPtr; + cfwPtr->pc = pc; + cfwPtr->word = word; + + 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 */ + } /* if */ + } /* if */ } /* *---------------------------------------------------------------------- * * TclArgumentBCRelease -- * - * This procedure is a helper for the TIP #280 uplevel extension. It - * removes the location references for the literal arguments of commands - * in bytecode just done. Usage is counted down, the data is removed only - * when no user is left over. + * This procedure is a helper for the TIP #280 uplevel extension. + * It removes the location references for the literal arguments of + * commands in bytecode just done. Usage is counted down, the data + * is removed only when no user is left over. * * Results: * None. * * Side effects: @@ -5668,47 +4914,61 @@ * TIP #280 *---------------------------------------------------------------------- */ void -TclArgumentBCRelease( - Tcl_Interp *interp, - CmdFrame *cfPtr) -{ - 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); - } - - Tcl_Free(cfwPtr); - cfwPtr = nextPtr; - } - - cfPtr->litarg = NULL; +TclArgumentBCRelease(interp,objv,objc,codePtr,pc) + Tcl_Interp* interp; + Tcl_Obj* objv[]; + int objc; + void* codePtr; + int pc; +{ + Interp* iPtr = (Interp*) interp; + Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr); + + if (hePtr) { + ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr); + hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, INT2PTR(pc)); + + if (hePtr) { + int cmd = PTR2INT(Tcl_GetHashValue(hePtr)); + ECL* ePtr = &eclPtr->loc[cmd]; + int word; + + /* + * Iterate in reverse order, to properly match our pop to the push + * in TclArgumentBCEnter(). + */ + for (word = objc-1; word >= 1; word--) { + if (ePtr->line[word] >= 0) { + Tcl_HashEntry* hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, + (char *) objv[word]); + if (hPtr) { + CFWordBC* cfwPtr = (CFWordBC*) Tcl_GetHashValue (hPtr); + + if (cfwPtr->prevPtr) { + Tcl_SetHashValue(hPtr, cfwPtr->prevPtr); + } else { + Tcl_DeleteHashEntry(hPtr); + } + + ckfree((char *) cfwPtr); + } + } + } + } + } } /* *---------------------------------------------------------------------- * * TclArgumentGet -- * - * This procedure is a helper for the TIP #280 uplevel extension. It - * finds the location references for a Tcl_Obj, if any. + * This procedure is a helper for the TIP #280 uplevel extension. + * It find the location references for a Tcl_Obj, if any. * * Results: * None. * * Side effects: @@ -5717,62 +4977,137 @@ * TIP #280 *---------------------------------------------------------------------- */ void -TclArgumentGet( - Tcl_Interp *interp, - Tcl_Obj *obj, - CmdFrame **cfPtrPtr, - int *wordPtr) -{ - Interp *iPtr = (Interp *) interp; - Tcl_HashEntry *hPtr; - CmdFrame *framePtr; +TclArgumentGet(interp,obj,cfPtrPtr,wordPtr) + Tcl_Interp* interp; + Tcl_Obj* obj; + CmdFrame** cfPtrPtr; + int* wordPtr; +{ + Interp* iPtr = (Interp*) interp; + Tcl_HashEntry* hPtr; + CmdFrame* framePtr; /* * An object which either has no string rep or else is a canonical list is * guaranteed to have been generated dynamically: bail out, this cannot * have a usable absolute location. _Do not touch_ the information the set * up by the caller. It knows better than us. */ - if (!TclHasStringRep(obj) || TclListObjIsCanonical(obj)) { + if ((obj->bytes == NULL) || TclListObjIsCanonical(obj)) { return; } /* * First look for location information recorded in the argument * stack. That is nearest. */ - hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) obj); + hPtr = Tcl_FindHashEntry (iPtr->lineLAPtr, (char *) obj); if (hPtr) { - CFWord *cfwPtr = (CFWord *)Tcl_GetHashValue(hPtr); - - *wordPtr = cfwPtr->word; + 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); + hPtr = Tcl_FindHashEntry (iPtr->lineLABCPtr, (char *) obj); + if (hPtr) { - CFWordBC *cfwPtr = (CFWordBC *)Tcl_GetHashValue(hPtr); + CFWordBC* cfwPtr = (CFWordBC*) Tcl_GetHashValue (hPtr); framePtr = cfwPtr->framePtr; - framePtr->data.tebc.pc = (char *) (((ByteCode *) + framePtr->data.tebc.pc = (char *) (((ByteCode*) framePtr->data.tebc.codePtr)->codeStart + cfwPtr->pc); *cfPtrPtr = cfwPtr->framePtr; - *wordPtr = cfwPtr->word; + *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. + * + *---------------------------------------------------------------------- + */ + +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); +} /* *---------------------------------------------------------------------- * * Tcl_EvalObjEx, TclEvalObjEx -- @@ -5779,15 +5114,10 @@ * * Execute Tcl commands stored in a Tcl object. These commands are * compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT is * specified. * - * If the flag TCL_EVAL_DIRECT is passed in, the value of invoker - * must be NULL. Support for non-NULL invokers in that mode has - * been removed since it was unused and untested. Failure to - * follow this limitation will lead to an assertion panic. - * * Results: * The return value is one of the return codes defined in tcl.h (such as * TCL_OK), and the interpreter's result contains a value to supplement * the return code. * @@ -5802,11 +5132,11 @@ 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 + register 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. */ { @@ -5815,159 +5145,100 @@ 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 + register 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. */ -{ - Interp *iPtr = (Interp *) interp; + register Interp *iPtr = (Interp *) interp; + char *script; + int numSrcBytes; int result; + CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case + * TCL_EVAL_GLOBAL was set. */ - /* - * This function consists of three independent blocks for: direct - * evaluation of canonical lists, compilation and bytecode execution and - * finally direct evaluation. Precisely one of these blocks will be run. + Tcl_IncrRefCount(objPtr); + + /* Pure List Optimization (no string representation). In this case, we can + * safely use Tcl_EvalObjv instead and get an appreciable improvement in + * execution speed. This is because it allows us to avoid a setFromAny + * step that would just pack everything into a string and back out again. + * + * This also preserves any associations between list elements and location + * information for such elements. + * + * This restriction has been relaxed a bit by storing in lists whether + * they are "canonical" or not (a canonical list being one that is either + * pure or that has its string rep derived by UpdateStringOfList from the + * internal rep). */ if (TclListObjIsCanonical(objPtr)) { - CmdFrame *eoFramePtr = NULL; - int objc; - Tcl_Obj *listPtr, **objv; - - /* - * Canonical List Optimization: In this case, we - * can safely use Tcl_EvalObjv instead and get an appreciable - * improvement in execution speed. This is because it allows us to - * avoid a setFromAny step that would just pack everything into a - * string and back out again. - * - * This also preserves any associations between list elements and - * location information for such elements. - */ - - /* - * Shimmer protection! Always pass an unshared obj. The caller could - * incr the refCount of objPtr AFTER calling us! To be completely safe - * we always make a copy. The callback takes care of the refCounts for - * both listPtr and objPtr. - * - * TODO: Create a test to demo this need, or eliminate it. - * FIXME OPT: preserve just the internal rep? - */ - - Tcl_IncrRefCount(objPtr); - listPtr = TclListObjCopy(interp, objPtr); - Tcl_IncrRefCount(listPtr); - - if (word != INT_MIN) { - /* - * TIP #280 Structures for tracking lines. As we know that this is - * dynamic execution we ignore the invoker, even if known. - * - * TIP #280. We do _not_ compute all the line numbers for the - * words in the command. For the eval of a pure list the most - * sensible choice is to put all words on line 1. Given that we - * neither need memory for them nor compute anything. 'line' is - * left NULL. The two places using this information (TclInfoFrame, - * 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; - eoFramePtr->nextPtr = iPtr->cmdFramePtr; - - eoFramePtr->cmdObj = objPtr; - eoFramePtr->cmd = NULL; - eoFramePtr->len = 0; - eoFramePtr->data.eval.path = NULL; - - iPtr->cmdFramePtr = eoFramePtr; - - flags |= TCL_EVAL_SOURCE_IN_FRAME; - } - - TclMarkTailcall(interp); - TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr, - objPtr, NULL); - - TclListObjGetElements(NULL, listPtr, &objc, &objv); - return TclNREvalObjv(interp, objc, objv, flags, NULL); - } - - if (!(flags & TCL_EVAL_DIRECT)) { - /* - * Let the compiler/engine subsystem do the evaluation. - * - * TIP #280 The invoker provides us with the context for the script. - * We transfer this to the byte code compiler. - */ - - int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); - ByteCode *codePtr; - CallFrame *savedVarFramePtr = NULL; /* Saves old copy of - * iPtr->varFramePtr in case - * TCL_EVAL_GLOBAL was set. */ - - if (TclInterpReady(interp) != TCL_OK) { - return TCL_ERROR; - } - if (flags & TCL_EVAL_GLOBAL) { - savedVarFramePtr = iPtr->varFramePtr; - iPtr->varFramePtr = iPtr->rootFramePtr; - } - Tcl_IncrRefCount(objPtr); - codePtr = TclCompileObj(interp, objPtr, invoker, word); - - TclNRAddCallback(interp, TEOEx_ByteCodeCallback, savedVarFramePtr, - objPtr, INT2PTR(allowExceptions), NULL); - return TclNRExecuteByteCode(interp, codePtr); - } - - { - /* - * We're not supposed to use the compiler or byte-code - * interpreter. Let Tcl_EvalEx evaluate the command directly (and - * probably more slowly). - */ - - const char *script; - size_t numSrcBytes; + /* + * TIP #280 Structures for tracking lines. As we know that this is + * dynamic execution we ignore the invoker, even if known. + */ + + int nelements; + Tcl_Obj **elements, *copyPtr = TclListObjCopy(NULL, objPtr); + CmdFrame *eoFramePtr = (CmdFrame *) + TclStackAlloc(interp, sizeof(CmdFrame)); + + eoFramePtr->type = TCL_LOCATION_EVAL_LIST; + eoFramePtr->level = (iPtr->cmdFramePtr == NULL? 1 + : iPtr->cmdFramePtr->level + 1); + eoFramePtr->framePtr = iPtr->framePtr; + eoFramePtr->nextPtr = iPtr->cmdFramePtr; + + eoFramePtr->nline = 0; + eoFramePtr->line = NULL; + + eoFramePtr->cmd.listPtr = objPtr; + Tcl_IncrRefCount(eoFramePtr->cmd.listPtr); + eoFramePtr->data.eval.path = NULL; + + /* + * TIP #280 We do _not_ compute all the line numbers for the words + * in the command. For the eval of a pure list the most sensible + * choice is to put all words on line 1. Given that we neither + * need memory for them nor compute anything. 'line' is left + * NULL. The two places using this information (TclInfoFrame, and + * TclInitCompileEnv), are special-cased to use the proper line + * number directly instead of accessing the 'line' array. + */ + + Tcl_ListObjGetElements(NULL, copyPtr, &nelements, &elements); + + iPtr->cmdFramePtr = eoFramePtr; + result = Tcl_EvalObjv(interp, nelements, elements, flags); + + Tcl_DecrRefCount(copyPtr); + iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; + Tcl_DecrRefCount(eoFramePtr->cmd.listPtr); + TclStackFree(interp, eoFramePtr); + } else if (flags & TCL_EVAL_DIRECT) { + /* + * We're not supposed to use the compiler or byte-code interpreter. + * Let Tcl_EvalEx evaluate the command directly (and probably more + * slowly). + */ + + /* + * TIP #280. Propagate context as much as we can. Especially if the + * script to evaluate is a single literal it makes sense to look if + * our context is one with absolute line numbers we can then track + * into the literal itself too. + * + * See also tclCompile.c, TclInitCompileEnv, for the equivalent code + * in the bytecode compiler. + */ /* * 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. @@ -5974,104 +5245,145 @@ * * It may be possible that the script Tcl_Obj* can be free'd while the * evaluator is using it, leading to the release of the associated * ContLineLoc structure as well. To ensure that the latter doesn't * happen we set a lock on it. We release this lock later in this - * function, after the evaluator is done. The relevant "lineCLPtr" + * function, after the evaluator is done. The relevant "lineCLPtr" * hashtable is managed in the file "tclObj.c". * * Another important action is to save (and later restore) the * continuation line information of the caller, in case we are * executing nested commands in the eval/direct path. */ - ContLineLoc *saveCLLocPtr = iPtr->scriptCLLocPtr; - - assert(invoker == NULL); - - iPtr->scriptCLLocPtr = TclContinuationsGet(objPtr); - - Tcl_IncrRefCount(objPtr); - - script = TclGetStringFromObj(objPtr, &numSrcBytes); - result = Tcl_EvalEx(interp, script, numSrcBytes, flags); - - TclDecrRefCount(objPtr); - + ContLineLoc* saveCLLocPtr = iPtr->scriptCLLocPtr; + ContLineLoc* clLocPtr = TclContinuationsGet (objPtr); + + if (clLocPtr) { + iPtr->scriptCLLocPtr = clLocPtr; + Tcl_Preserve (iPtr->scriptCLLocPtr); + } else { + iPtr->scriptCLLocPtr = NULL; + } + + if (invoker == NULL) { + /* + * No context, force opening of our own. + */ + + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + result = Tcl_EvalEx(interp, script, numSrcBytes, flags); + } else { + /* + * We have an invoker, describing the command asking for the + * evaluation of a subordinate script. This script may originate + * in a literal word, or from a variable, etc. Using the line + * array we now check if we have good line information for the + * relevant word. The type of context is relevant as well. In a + * non-'source' context we don't have to try tracking lines. + * + * First see if the word exists and is a literal. If not we go + * through the easy dynamic branch. No need to perform more + * complex invokations. + */ + + int pc = 0; + CmdFrame *ctxPtr = (CmdFrame *) + TclStackAlloc(interp, sizeof(CmdFrame)); + + *ctxPtr = *invoker; + if (invoker->type == TCL_LOCATION_BC) { + /* + * Note: Type BC => ctxPtr->data.eval.path is not used. + * ctxPtr->data.tebc.codePtr is used instead. + */ + + TclGetSrcInfoForPc(ctxPtr); + pc = 1; + } + + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + + if ((ctxPtr->nline <= word) || + (ctxPtr->line[word] < 0) || + (ctxPtr->type != TCL_LOCATION_SOURCE)) { + /* + * Dynamic script, or dynamic context, force our own + * context. + */ + + result = Tcl_EvalEx(interp, script, numSrcBytes, flags); + + } else { + /* + * Absolute context to reuse. + */ + + iPtr->invokeCmdFramePtr = ctxPtr; + iPtr->evalFlags |= TCL_EVAL_CTX; + + result = TclEvalEx(interp, script, numSrcBytes, flags, + ctxPtr->line[word], NULL, script); + } + + if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) { + /* + * Death of SrcInfo reference. + */ + + Tcl_DecrRefCount(ctxPtr->data.eval.path); + } + TclStackFree(interp, ctxPtr); + } + + /* + * Now release the lock on the continuation line information, if + * any, and restore the caller's settings. + */ + + if (iPtr->scriptCLLocPtr) { + Tcl_Release (iPtr->scriptCLLocPtr); + } iPtr->scriptCLLocPtr = saveCLLocPtr; - return result; - } -} - -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; - size_t numSrcBytes; - - ProcessUnexpectedResult(interp, result); - result = TCL_ERROR; - script = TclGetStringFromObj(objPtr, &numSrcBytes); - Tcl_LogCommandInfo(interp, script, script, numSrcBytes); - } - - /* - * We are returning to level 0, so should call TclResetCancellation. - * Let us just unset the flags inline. - */ - - TclUnsetCancelFlags(iPtr); - } - iPtr->evalFlags = 0; - - /* - * Restore the callFrame if this was a TCL_EVAL_GLOBAL. - */ - - if (savedVarFramePtr) { + } else { + /* + * Let the compiler/engine subsystem do the evaluation. + * + * TIP #280 The invoker provides us with the context for the script. + * We transfer this to the byte code compiler. + */ + int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); + + savedVarFramePtr = iPtr->varFramePtr; + if (flags & TCL_EVAL_GLOBAL) { + iPtr->varFramePtr = iPtr->rootFramePtr; + } + + result = TclCompEvalObj(interp, objPtr, invoker, word); + + /* + * If we are again at the top level, process any unusual return code + * returned by the evaluated code. + */ + + if (iPtr->numLevels == 0) { + if (result == TCL_RETURN) { + result = TclUpdateReturnInfo(iPtr); + } + if ((result != TCL_OK) && (result != TCL_ERROR) + && !allowExceptions) { + ProcessUnexpectedResult(interp, result); + result = TCL_ERROR; + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + Tcl_LogCommandInfo(interp, script, script, numSrcBytes); + } + } + iPtr->evalFlags = 0; iPtr->varFramePtr = savedVarFramePtr; } TclDecrRefCount(objPtr); - return result; -} - -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; - TclStackFree(interp, eoFramePtr); - } - TclDecrRefCount(objPtr); - TclDecrRefCount(listPtr); - return result; } /* *---------------------------------------------------------------------- @@ -6097,25 +5409,21 @@ ProcessUnexpectedResult( Tcl_Interp *interp, /* The interpreter in which the unexpected * result code was returned. */ int returnCode) /* The unexpected result code. */ { - char buf[TCL_INTEGER_SPACE]; - Tcl_ResetResult(interp); if (returnCode == TCL_BREAK) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "invoked \"break\" outside of a loop", -1)); + Tcl_AppendResult(interp, + "invoked \"break\" outside of a loop", NULL); } else if (returnCode == TCL_CONTINUE) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "invoked \"continue\" outside of a loop", -1)); + Tcl_AppendResult(interp, + "invoked \"continue\" outside of a loop", NULL); } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "command returned bad code: %d", returnCode)); } - sprintf(buf, "%d", returnCode); - Tcl_SetErrorCode(interp, "TCL", "UNEXPECTED_RESULT_CODE", buf, NULL); } /* *--------------------------------------------------------------------------- * @@ -6142,11 +5450,11 @@ 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; + register Tcl_Obj *exprPtr; int result = TCL_OK; if (*exprstring == '\0') { /* * Legacy compatibility - return 0 for the zero-length string. */ @@ -6155,10 +5463,13 @@ } 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 @@ -6166,11 +5477,11 @@ 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; + register Tcl_Obj *exprPtr; int result = TCL_OK; if (*exprstring == '\0') { /* * Legacy compatibility - return 0 for the zero-length string. @@ -6181,10 +5492,13 @@ 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 @@ -6206,10 +5520,18 @@ 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; } } /* @@ -6235,11 +5557,11 @@ int Tcl_ExprLongObj( Tcl_Interp *interp, /* Context in which to evaluate the * expression. */ - Tcl_Obj *objPtr, /* Expression to evaluate. */ + register Tcl_Obj *objPtr, /* Expression to evaluate. */ long *ptr) /* Where to store long result. */ { Tcl_Obj *resultPtr; int result, type; double d; @@ -6248,11 +5570,11 @@ result = Tcl_ExprObj(interp, objPtr, &resultPtr); if (result != TCL_OK) { return TCL_ERROR; } - if (TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type)!=TCL_OK) { + if (TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type) != TCL_OK){ return TCL_ERROR; } switch (type) { case TCL_NUMBER_DOUBLE: { @@ -6264,11 +5586,12 @@ return TCL_ERROR; } resultPtr = Tcl_NewBignumObj(&big); } /* FALLTHRU */ - case TCL_NUMBER_INT: + case TCL_NUMBER_LONG: + case TCL_NUMBER_WIDE: case TCL_NUMBER_BIG: result = TclGetLongFromObj(interp, resultPtr, ptr); break; case TCL_NUMBER_NAN: @@ -6282,11 +5605,11 @@ int Tcl_ExprDoubleObj( Tcl_Interp *interp, /* Context in which to evaluate the * expression. */ - Tcl_Obj *objPtr, /* Expression to evaluate. */ + register Tcl_Obj *objPtr, /* Expression to evaluate. */ double *ptr) /* Where to store double result. */ { Tcl_Obj *resultPtr; int result, type; ClientData internalPtr; @@ -6318,11 +5641,11 @@ int Tcl_ExprBooleanObj( Tcl_Interp *interp, /* Context in which to evaluate the * expression. */ - Tcl_Obj *objPtr, /* Expression to evaluate. */ + register Tcl_Obj *objPtr, /* Expression to evaluate. */ int *ptr) /* Where to store 0/1 result. */ { Tcl_Obj *resultPtr; int result; @@ -6340,11 +5663,10 @@ * * TclObjInvokeNamespace -- * * Object version: Invokes a Tcl command, given an objv/objc, from either * the exposed or hidden set of commands in the given interpreter. - * * NOTE: The command is invoked in the global stack frame of the * interpreter or namespace, thus it cannot see any current state on the * stack of that interpreter. * * Results: @@ -6374,11 +5696,15 @@ /* * Make the specified namespace the current namespace and invoke the * command. */ - (void) TclPushStackFrame(interp, &framePtr, nsPtr, /*isProcFrame*/0); + result = TclPushStackFrame(interp, &framePtr, nsPtr, /*isProcFrame*/0); + if (result != TCL_OK) { + return TCL_ERROR; + } + result = TclObjInvoke(interp, objc, objv, flags); TclPopStackFrame(interp); return result; } @@ -6409,76 +5735,71 @@ * name of the command to invoke. */ int flags) /* Combination of flags controlling the call: * TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN, * or TCL_INVOKE_NO_TRACEBACK. */ { + register Interp *iPtr = (Interp *) interp; + Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ + char *cmdName; /* Name of the command from objv[0]. */ + Tcl_HashEntry *hPtr = NULL; + Command *cmdPtr; + int result; + if (interp == NULL) { return TCL_ERROR; } + if ((objc < 1) || (objv == NULL)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "illegal argument vector", -1)); + Tcl_AppendResult(interp, "illegal argument vector", NULL); return TCL_ERROR; } + if ((flags & TCL_INVOKE_HIDDEN) == 0) { Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN"); } - return Tcl_NRCallObjProc(interp, TclNRInvoke, NULL, objc, objv); -} - -int -TclNRInvoke( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Interp *iPtr = (Interp *) interp; - Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ - const char *cmdName; /* Name of the command from objv[0]. */ - Tcl_HashEntry *hPtr = NULL; - Command *cmdPtr; + + if (TclInterpReady(interp) == TCL_ERROR) { + return TCL_ERROR; + } 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--; + Tcl_AppendResult(interp, "invalid hidden command name \"", + cmdName, "\"", NULL); + return TCL_ERROR; + } + cmdPtr = Tcl_GetHashValue(hPtr); + + /* + * Invoke the command function. + */ + + iPtr->cmdCount++; + result = cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); + + /* + * If an error occurred, record information about what was being executed + * when the error occurred. + */ + + if ((result == TCL_ERROR) + && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0) + && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) { + int length; + Tcl_Obj *command = Tcl_NewListObj(objc, objv); + const char *cmdString; + + Tcl_IncrRefCount(command); + cmdString = Tcl_GetStringFromObj(command, &length); + Tcl_LogCommandInfo(interp, cmdString, cmdString, length); + Tcl_DecrRefCount(command); + iPtr->flags &= ~ERR_ALREADY_LOGGED; + } return result; } /* *--------------------------------------------------------------------------- @@ -6511,11 +5832,11 @@ if (expr[0] == '\0') { /* * An empty string. Just set the interpreter's result to 0. */ - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0)); + Tcl_SetResult(interp, "0", TCL_VOLATILE); } else { Tcl_Obj *resultPtr, *exprObj = Tcl_NewStringObj(expr, -1); Tcl_IncrRefCount(exprObj); code = Tcl_ExprObj(interp, exprObj, &resultPtr); @@ -6522,10 +5843,16 @@ 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; } /* @@ -6551,24 +5878,98 @@ Tcl_AppendObjToErrorInfo( Tcl_Interp *interp, /* Interpreter to which error information * pertains. */ Tcl_Obj *objPtr) /* Message to record. */ { - size_t length; + int length; const char *message = TclGetStringFromObj(objPtr, &length); - Interp *iPtr = (Interp *) interp; Tcl_IncrRefCount(objPtr); + Tcl_AddObjErrorInfo(interp, message, 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. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AddErrorInfo( + Tcl_Interp *interp, /* Interpreter to which error information + * pertains. */ + const char *message) /* Message to record. */ +{ + Tcl_AddObjErrorInfo(interp, message, -1); +} + +/* + *---------------------------------------------------------------------- + * + * 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. */ +{ + register 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) { - iPtr->errorInfo = iPtr->objResultPtr; + if (iPtr->result[0] != 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(interp->result, -1); + } else { + iPtr->errorInfo = iPtr->objResultPtr; + } Tcl_IncrRefCount(iPtr->errorInfo); if (!iPtr->errorCode) { Tcl_SetErrorCode(interp, "NONE", NULL); } } @@ -6583,11 +5984,57 @@ iPtr->errorInfo = Tcl_DuplicateObj(iPtr->errorInfo); Tcl_IncrRefCount(iPtr->errorInfo); } Tcl_AppendToObj(iPtr->errorInfo, message, length); } - Tcl_DecrRefCount(objPtr); +} + +/* + *--------------------------------------------------------------------------- + * + * 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_Eval(interp, Tcl_DStringValue(&buf)); + Tcl_DStringFree(&buf); + return result; } /* *---------------------------------------------------------------------- * @@ -6596,46 +6043,65 @@ * 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. + * left in interp->result. * * Side effects: * Depends on what was done by the command. * *---------------------------------------------------------------------- */ - + /* ARGSUSED */ int Tcl_VarEval( Tcl_Interp *interp, ...) { va_list argList; int result; - Tcl_DString buf; - char *string; va_start(argList, interp); - /* - * 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 Tcl_Alloc 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); + 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. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GlobalEval( + Tcl_Interp *interp, /* Interpreter in which to evaluate command. */ + const char *command) /* Command to evaluate. */ +{ + register Interp *iPtr = (Interp *) interp; + int result; + CallFrame *savedVarFramePtr; + + savedVarFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = iPtr->rootFramePtr; + result = Tcl_Eval(interp, command); + iPtr->varFramePtr = savedVarFramePtr; return result; } /* *---------------------------------------------------------------------- @@ -6755,11 +6221,11 @@ *---------------------------------------------------------------------- */ static int ExprCeilFunc( - TCL_UNUSED(void *), + ClientData clientData, /* Ignored */ Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Actual parameter list. */ { @@ -6771,23 +6237,18 @@ MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN - if (code != TCL_OK) { - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType); - - if (irPtr) { - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; - } + if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; } #endif if (code != TCL_OK) { return TCL_ERROR; } - if (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclCeil(&big))); mp_clear(&big); } else { Tcl_SetObjResult(interp, Tcl_NewDoubleObj(ceil(d))); @@ -6795,11 +6256,11 @@ return TCL_OK; } static int ExprFloorFunc( - TCL_UNUSED(void *), + ClientData clientData, /* Ignored */ Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Actual parameter list. */ { @@ -6811,23 +6272,18 @@ MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN - if (code != TCL_OK) { - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType); - - if (irPtr) { - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; - } + if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; } #endif if (code != TCL_OK) { return TCL_ERROR; } - if (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclFloor(&big))); mp_clear(&big); } else { Tcl_SetObjResult(interp, Tcl_NewDoubleObj(floor(d))); @@ -6835,22 +6291,23 @@ return TCL_OK; } static int ExprIsqrtFunc( - TCL_UNUSED(void *), + ClientData clientData, /* Ignored */ 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; Tcl_WideInt w; mp_int big; - int exact = 0; /* Flag ==1 if the argument can be represented - * in a double as an exact integer. */ + int exact = 0; /* Flag == 1 if the argument can be + * represented in a double as an exact + * integer. */ /* * Check syntax. */ @@ -6895,11 +6352,11 @@ mp_clear(&big); goto negarg; } break; default: - if (TclGetWideIntFromObj(interp, objv[1], &w) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[1], &w) != TCL_OK) { return TCL_ERROR; } if (w < 0) { goto negarg; } @@ -6917,35 +6374,28 @@ 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; - } + + mp_init(&root); + mp_sqrt(&big, &root); + mp_clear(&big); 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); + Tcl_SetObjResult(interp, + Tcl_NewStringObj("square root of negative argument", -1)); return TCL_ERROR; } static int ExprSqrtFunc( - TCL_UNUSED(void *), + ClientData clientData, /* Ignored */ Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Actual parameter list. */ { @@ -6957,36 +6407,25 @@ MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN - if (code != TCL_OK) { - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType); - - if (irPtr) { - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; - } + if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; } #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; - } + + mp_init(&root); + mp_sqrt(&big, &root); + mp_clear(&big); Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclBignumToDouble(&root))); mp_clear(&root); } else { Tcl_SetObjResult(interp, Tcl_NewDoubleObj(sqrt(d))); } @@ -7011,25 +6450,21 @@ MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN - if (code != TCL_OK) { - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType); - - if (irPtr) { - d = irPtr->doubleValue; - Tcl_ResetResult(interp); - code = TCL_OK; - } + if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { + d = objv[1]->internalRep.doubleValue; + Tcl_ResetResult(interp); + code = TCL_OK; } #endif if (code != TCL_OK) { return TCL_ERROR; } errno = 0; - return CheckDoubleResult(interp, func(d)); + return CheckDoubleResult(interp, (*func)(d)); } static int CheckDoubleResult( Tcl_Interp *interp, @@ -7075,45 +6510,37 @@ MathFuncWrongNumArgs(interp, 3, objc, objv); return TCL_ERROR; } code = Tcl_GetDoubleFromObj(interp, objv[1], &d1); #ifdef ACCEPT_NAN - if (code != TCL_OK) { - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType); - - if (irPtr) { - d1 = irPtr->doubleValue; - Tcl_ResetResult(interp); - code = TCL_OK; - } + if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { + d1 = objv[1]->internalRep.doubleValue; + Tcl_ResetResult(interp); + code = TCL_OK; } #endif if (code != TCL_OK) { return TCL_ERROR; } code = Tcl_GetDoubleFromObj(interp, objv[2], &d2); #ifdef ACCEPT_NAN - if (code != TCL_OK) { - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType); - - if (irPtr) { - d2 = irPtr->doubleValue; - Tcl_ResetResult(interp); - code = TCL_OK; - } + if ((code != TCL_OK) && (objv[2]->typePtr == &tclDoubleType)) { + d2 = objv[2]->internalRep.doubleValue; + Tcl_ResetResult(interp); + code = TCL_OK; } #endif if (code != TCL_OK) { return TCL_ERROR; } errno = 0; - return CheckDoubleResult(interp, func(d1, d2)); + return CheckDoubleResult(interp, (*func)(d1, d2)); } static int ExprAbsFunc( - TCL_UNUSED(void *), + ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Parameter vector. */ { @@ -7128,66 +6555,76 @@ if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { return TCL_ERROR; } - 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])) { - size_t 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)); + if (type == TCL_NUMBER_LONG) { + long l = *((const long *) ptr); + + if (l > (long)0) { + goto unChanged; + } else if (l == (long)0) { + const char *string = objv[1]->bytes; + if (string) { + while (*string != '0') { + if (*string == '-') { + Tcl_SetObjResult(interp, Tcl_NewLongObj(0)); + return TCL_OK; + } + string++; + } + } + goto unChanged; + } else if (l == LONG_MIN) { + TclBNInitBignumFromLong(&big, l); + goto tooLarge; + } + Tcl_SetObjResult(interp, Tcl_NewLongObj(-l)); return TCL_OK; } if (type == TCL_NUMBER_DOUBLE) { double d = *((const double *) ptr); static const double poszero = 0.0; - /* - * We need to distinguish here between positive 0.0 and negative -0.0. - * [Bug 2954959] + /* We need to distinguish here between positive 0.0 and + * negative -0.0, see Bug ID #2954959. */ - if (d == -0.0) { - if (!memcmp(&d, &poszero, sizeof(double))) { + if (!memcmp(&d, &poszero, sizeof(double))) { + goto unChanged; + } + } else { + if (d > -0.0) { goto unChanged; } - } else if (d > -0.0) { - goto unChanged; } Tcl_SetObjResult(interp, Tcl_NewDoubleObj(-d)); return TCL_OK; } + +#ifndef NO_WIDE_TYPE + if (type == TCL_NUMBER_WIDE) { + Tcl_WideInt w = *((const Tcl_WideInt *) ptr); + + if (w >= (Tcl_WideInt)0) { + goto unChanged; + } + if (w == LLONG_MIN) { + TclBNInitBignumFromWideInt(&big, w); + goto tooLarge; + } + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-w)); + return TCL_OK; + } +#endif if (type == TCL_NUMBER_BIG) { - if (mp_isneg((const mp_int *) ptr)) { + if (mp_cmp_d(ptr, 0) == MP_LT) { Tcl_GetBignumFromObj(NULL, objv[1], &big); tooLarge: - if (mp_neg(&big, &big) != MP_OKAY) { - return TCL_ERROR; - } + mp_neg(&big, &big); Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); } else { unChanged: Tcl_SetObjResult(interp, objv[1]); } @@ -7198,21 +6635,20 @@ #ifdef ACCEPT_NAN Tcl_SetObjResult(interp, objv[1]); return TCL_OK; #else double d; - Tcl_GetDoubleFromObj(interp, objv[1], &d); return TCL_ERROR; #endif } return TCL_OK; } static int ExprBoolFunc( - TCL_UNUSED(void *), + ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Actual parameter vector. */ { @@ -7229,25 +6665,24 @@ return TCL_OK; } static int ExprDoubleFunc( - TCL_UNUSED(void *), + ClientData clientData, /* Ignored. */ 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; - if (objc != 2) { MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) { #ifdef ACCEPT_NAN - if (TclHasIntRep(objv[1], &tclDoubleType)) { + if (objv[1]->typePtr == &tclDoubleType) { Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } #endif return TCL_ERROR; @@ -7255,12 +6690,12 @@ Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult)); return TCL_OK; } static int -ExprIntFunc( - TCL_UNUSED(void *), +ExprEntierFunc( + ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Actual parameter vector. */ { @@ -7276,23 +6711,23 @@ return TCL_ERROR; } if (type == TCL_NUMBER_DOUBLE) { d = *((const double *) ptr); - if ((d >= (double)WIDE_MAX) || (d <= (double)WIDE_MIN)) { + if ((d >= (double)LONG_MAX) || (d <= (double)LONG_MIN)) { mp_int big; if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) { /* Infinity */ return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); return TCL_OK; } else { - Tcl_WideInt result = (Tcl_WideInt) d; + long result = (long) d; - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(result)); return TCL_OK; } } if (type != TCL_NUMBER_NAN) { @@ -7309,97 +6744,78 @@ */ Tcl_GetDoubleFromObj(interp, objv[1], &d); return TCL_ERROR; } + +static int +ExprIntFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + long iResult; + Tcl_Obj *objPtr; + if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) { + return TCL_ERROR; + } + objPtr = Tcl_GetObjResult(interp); + if (TclGetLongFromObj(NULL, objPtr, &iResult) != TCL_OK) { + /* + * Truncate the bignum; keep only bits in long range. + */ + + mp_int big; + + Tcl_GetBignumFromObj(NULL, objPtr, &big); + mp_mod_2d(&big, CHAR_BIT * sizeof(long), &big); + objPtr = Tcl_NewBignumObj(&big); + Tcl_IncrRefCount(objPtr); + TclGetLongFromObj(NULL, objPtr, &iResult); + Tcl_DecrRefCount(objPtr); + } + Tcl_SetObjResult(interp, Tcl_NewLongObj(iResult)); + return TCL_OK; +} static int ExprWideFunc( - TCL_UNUSED(void *), + ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Actual parameter vector. */ { Tcl_WideInt wResult; - - if (ExprIntFunc(NULL, interp, objc, objv) != TCL_OK) { - return TCL_ERROR; - } - TclGetWideBitsFromObj(NULL, Tcl_GetObjResult(interp), &wResult); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult)); - return TCL_OK; -} - -/* - * Common implmentation of max() and min(). - */ -static int -ExprMaxMinFunc( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* The interpreter in which to execute the - * function. */ - int objc, /* Actual parameter count. */ - Tcl_Obj *const *objv, /* Actual parameter vector. */ - int op) /* Comparison direction */ -{ - Tcl_Obj *res; - double d; - int type, i; - ClientData ptr; - - if (objc < 2) { - MathFuncWrongNumArgs(interp, 2, objc, objv); - return TCL_ERROR; - } - res = objv[1]; - for (i = 1; i < objc; i++) { - if (TclGetNumberFromObj(interp, objv[i], &ptr, &type) != TCL_OK) { - return TCL_ERROR; - } - if (type == TCL_NUMBER_NAN) { - /* - * Get the error message for NaN. - */ - - Tcl_GetDoubleFromObj(interp, objv[i], &d); - return TCL_ERROR; - } - if (TclCompareTwoNumbers(objv[i], res) == op) { - res = objv[i]; - } - } - - Tcl_SetObjResult(interp, res); - return TCL_OK; -} - -static int -ExprMaxFunc( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* The interpreter in which to execute the - * function. */ - int objc, /* Actual parameter count. */ - Tcl_Obj *const *objv) /* Actual parameter vector. */ -{ - return ExprMaxMinFunc(NULL, interp, objc, objv, MP_GT); -} - -static int -ExprMinFunc( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* The interpreter in which to execute the - * function. */ - int objc, /* Actual parameter count. */ - Tcl_Obj *const *objv) /* Actual parameter vector. */ -{ - return ExprMaxMinFunc(NULL, interp, objc, objv, MP_LT); -} - -static int -ExprRandFunc( - TCL_UNUSED(void *), + Tcl_Obj *objPtr; + if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) { + return TCL_ERROR; + } + objPtr = Tcl_GetObjResult(interp); + if (Tcl_GetWideIntFromObj(NULL, objPtr, &wResult) != TCL_OK) { + /* + * Truncate the bignum; keep only bits in wide int range. + */ + + mp_int big; + + Tcl_GetBignumFromObj(NULL, objPtr, &big); + mp_mod_2d(&big, CHAR_BIT * sizeof(Tcl_WideInt), &big); + objPtr = Tcl_NewBignumObj(&big); + Tcl_IncrRefCount(objPtr); + Tcl_GetWideIntFromObj(NULL, objPtr, &wResult); + Tcl_DecrRefCount(objPtr); + } + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult)); + return TCL_OK; +} + +static int +ExprRandFunc( + ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Actual parameter vector. */ { @@ -7416,22 +6832,22 @@ if (!(iPtr->flags & RAND_SEED_INITIALIZED)) { iPtr->flags |= RAND_SEED_INITIALIZED; /* - * To ensure different seeds in different threads (bug #416643), - * take into consideration the thread this interp is running in. + * Take into consideration the thread this interp is running in order + * to insure different seeds in different threads (bug #416643) */ 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 &= (unsigned long) 0x7fffffff; + if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { iPtr->randSeed ^= 123459876; } } /* @@ -7488,11 +6904,11 @@ return TCL_OK; } static int ExprRoundFunc( - TCL_UNUSED(void *), + ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Parameter vector. */ { @@ -7509,45 +6925,41 @@ return TCL_ERROR; } if (type == TCL_NUMBER_DOUBLE) { double fractPart, intPart; - Tcl_WideInt max = WIDE_MAX, min = WIDE_MIN; + long max = LONG_MAX, min = LONG_MIN; fractPart = modf(*((const double *) ptr), &intPart); 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); + 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; + mp_add_d(&big, 1, &big); } Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); return TCL_OK; } else { - Tcl_WideInt result = (Tcl_WideInt)intPart; + long result = (long)intPart; if (fractPart <= -0.5) { result--; } else if (fractPart >= 0.5) { result++; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(result)); return TCL_OK; } } if (type != TCL_NUMBER_NAN) { @@ -7567,18 +6979,18 @@ return TCL_ERROR; } static int ExprSrandFunc( - TCL_UNUSED(void *), + ClientData clientData, /* Ignored. */ 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. */ + long i = 0; /* Initialized to avoid compiler warning. */ /* * Convert argument and use it to reset the seed. */ @@ -7585,421 +6997,45 @@ if (objc != 2) { MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } - if (TclGetWideBitsFromObj(NULL, objv[1], &w) != TCL_OK) { - return TCL_ERROR; + if (TclGetLongFromObj(NULL, objv[1], &i) != TCL_OK) { + Tcl_Obj *objPtr; + mp_int big; + + if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) { + /* TODO: more ::errorInfo here? or in caller? */ + return TCL_ERROR; + } + + mp_mod_2d(&big, CHAR_BIT * sizeof(long), &big); + objPtr = Tcl_NewBignumObj(&big); + Tcl_IncrRefCount(objPtr); + TclGetLongFromObj(NULL, objPtr, &i); + Tcl_DecrRefCount(objPtr); } /* * Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2. See comments in - * ExprRandFunc for more details. + * ExprRandFunc() for more details. */ iPtr->flags |= RAND_SEED_INITIALIZED; - iPtr->randSeed = (long) w & 0x7FFFFFFF; - if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7FFFFFFF)) { + iPtr->randSeed = i; + iPtr->randSeed &= (unsigned long) 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 -- - * - * This page contains the functions that implement all of the built-in - * math functions for classifying IEEE doubles. - * - * These have to be a little bit careful while Tcl_GetDoubleFromObj() - * rejects NaN values, which these functions *explicitly* accept. - * - * Results: - * Each function returns TCL_OK if it succeeds and pushes an Tcl object - * holding the result. If it fails it returns TCL_ERROR and leaves an - * error message in the interpreter's result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - * - * Older MSVC is supported by Tcl, but doesn't have fpclassify(). Of course. - * But it does sometimes have _fpclass() which does almost the same job; if - * even that is absent, we grobble around directly in the platform's binary - * representation of double. - * - * The ClassifyDouble() function makes all that conform to a common API - * (effectively the C99 standard API renamed), and just delegates to the - * standard macro on platforms that do it correctly. - */ - -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. - */ - - union { - double d; /* Interpret as double */ - struct { - unsigned int low; /* Lower 32 bits */ - unsigned int high; /* Upper 32 bits */ - } w; /* Interpret as unsigned integer words */ - } doubleMeaning; /* So we can look at the representation of a - * double directly. Platform (i.e., processor) - * specific; this is for x86 (and most other - * little-endian processors, but those are - * untested). */ - unsigned int exponent, mantissaLow, mantissaHigh; - /* The pieces extracted from the double. */ - int zeroMantissa; /* Was the mantissa zero? That's special. */ - - /* - * Shifts and masks to use with the doubleMeaning variable above. - */ - -#define EXPONENT_MASK 0x7FF /* 11 bits (after shifting) */ -#define EXPONENT_SHIFT 20 /* Moves exponent to bottom of word */ -#define MANTISSA_MASK 0xFFFFF /* 20 bits (plus 32 from other word) */ - - /* - * Extract the exponent (11 bits) and mantissa (52 bits). Note that we - * totally ignore the sign bit. - */ - - doubleMeaning.d = d; - exponent = (doubleMeaning.w.high >> EXPONENT_SHIFT) & EXPONENT_MASK; - mantissaLow = doubleMeaning.w.low; - mantissaHigh = doubleMeaning.w.high & MANTISSA_MASK; - zeroMantissa = (mantissaHigh == 0 && mantissaLow == 0); - - /* - * Look for the special cases of exponent. - */ - - switch (exponent) { - case 0: - /* - * When the exponent is all zeros, it's a ZERO or a SUBNORMAL. - */ - - return zeroMantissa ? FP_ZERO : FP_SUBNORMAL; - case EXPONENT_MASK: - /* - * When the exponent is all ones, it's an INF or a NAN. - */ - - return zeroMantissa ? FP_INFINITE : FP_NAN; - default: - /* - * Everything else is a NORMAL double precision float. - */ - - return FP_NORMAL; - } -#elif TCL_FPCLASSIFY_MODE == 1 - switch (_fpclass(d)) { - case _FPCLASS_NZ: - case _FPCLASS_PZ: - return FP_ZERO; - case _FPCLASS_NN: - case _FPCLASS_PN: - return FP_NORMAL; - case _FPCLASS_ND: - case _FPCLASS_PD: - return FP_SUBNORMAL; - case _FPCLASS_NINF: - case _FPCLASS_PINF: - return FP_INFINITE; - default: - Tcl_Panic("result of _fpclass() outside documented range!"); - case _FPCLASS_QNAN: - case _FPCLASS_SNAN: - return FP_NAN; - } -#else /* TCL_FPCLASSIFY_MODE not in (0..3) */ -#error "unknown or unexpected TCL_FPCLASSIFY_MODE" -#endif /* TCL_FPCLASSIFY_MODE */ -#endif /* !fpclassify */ -} - -static int -ExprIsFiniteFunc( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* The interpreter in which to execute the - * function. */ - int objc, /* Actual parameter count */ - Tcl_Obj *const *objv) /* Actual parameter list */ -{ - double d; - ClientData ptr; - int type, result = 0; - - if (objc != 2) { - MathFuncWrongNumArgs(interp, 2, objc, objv); - return TCL_ERROR; - } - - if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { - return TCL_ERROR; - } - if (type != TCL_NUMBER_NAN) { - if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { - return TCL_ERROR; - } - type = ClassifyDouble(d); - result = (type != FP_INFINITE && type != FP_NAN); - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); - return TCL_OK; -} - -static int -ExprIsInfinityFunc( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* The interpreter in which to execute the - * function. */ - int objc, /* Actual parameter count */ - Tcl_Obj *const *objv) /* Actual parameter list */ -{ - double d; - ClientData ptr; - int type, result = 0; - - if (objc != 2) { - MathFuncWrongNumArgs(interp, 2, objc, objv); - return TCL_ERROR; - } - - if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { - return TCL_ERROR; - } - if (type != TCL_NUMBER_NAN) { - if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { - return TCL_ERROR; - } - result = (ClassifyDouble(d) == FP_INFINITE); - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); - return TCL_OK; -} - -static int -ExprIsNaNFunc( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* The interpreter in which to execute the - * function. */ - int objc, /* Actual parameter count */ - Tcl_Obj *const *objv) /* Actual parameter list */ -{ - double d; - ClientData ptr; - int type, result = 1; - - if (objc != 2) { - MathFuncWrongNumArgs(interp, 2, objc, objv); - return TCL_ERROR; - } - - if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { - return TCL_ERROR; - } - if (type != TCL_NUMBER_NAN) { - if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { - return TCL_ERROR; - } - result = (ClassifyDouble(d) == FP_NAN); - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); - return TCL_OK; -} - -static int -ExprIsNormalFunc( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* The interpreter in which to execute the - * function. */ - int objc, /* Actual parameter count */ - Tcl_Obj *const *objv) /* Actual parameter list */ -{ - double d; - ClientData ptr; - int type, result = 0; - - if (objc != 2) { - MathFuncWrongNumArgs(interp, 2, objc, objv); - return TCL_ERROR; - } - - if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { - return TCL_ERROR; - } - if (type != TCL_NUMBER_NAN) { - if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { - return TCL_ERROR; - } - result = (ClassifyDouble(d) == FP_NORMAL); - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); - return TCL_OK; -} - -static int -ExprIsSubnormalFunc( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* The interpreter in which to execute the - * function. */ - int objc, /* Actual parameter count */ - Tcl_Obj *const *objv) /* Actual parameter list */ -{ - double d; - ClientData ptr; - int type, result = 0; - - if (objc != 2) { - MathFuncWrongNumArgs(interp, 2, objc, objv); - return TCL_ERROR; - } - - if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { - return TCL_ERROR; - } - if (type != TCL_NUMBER_NAN) { - if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { - return TCL_ERROR; - } - result = (ClassifyDouble(d) == FP_SUBNORMAL); - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); - return TCL_OK; -} - -static int -ExprIsUnorderedFunc( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* The interpreter in which to execute the - * function. */ - int objc, /* Actual parameter count */ - Tcl_Obj *const *objv) /* Actual parameter list */ -{ - double d; - ClientData ptr; - int type, result = 0; - - if (objc != 3) { - MathFuncWrongNumArgs(interp, 3, objc, objv); - return TCL_ERROR; - } - - if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { - return TCL_ERROR; - } - if (type == TCL_NUMBER_NAN) { - result = 1; - } else { - d = *((const double *) ptr); - result = (ClassifyDouble(d) == FP_NAN); - } - - if (TclGetNumberFromObj(interp, objv[2], &ptr, &type) != TCL_OK) { - return TCL_ERROR; - } - if (type == TCL_NUMBER_NAN) { - result |= 1; - } else { - d = *((const double *) ptr); - result |= (ClassifyDouble(d) == FP_NAN); - } - - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); - return TCL_OK; -} - -static int -FloatClassifyObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* The interpreter in which to execute the - * function. */ - int objc, /* Actual parameter count */ - Tcl_Obj *const *objv) /* Actual parameter list */ -{ - double d; - Tcl_Obj *objPtr; - ClientData ptr; - int type; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "floatValue"); - return TCL_ERROR; - } - - if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { - return TCL_ERROR; - } - if (type == TCL_NUMBER_NAN) { - goto gotNaN; - } else if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { - return TCL_ERROR; - } - switch (ClassifyDouble(d)) { - case FP_INFINITE: - TclNewLiteralStringObj(objPtr, "infinite"); - break; - case FP_NAN: - gotNaN: - TclNewLiteralStringObj(objPtr, "nan"); - break; - case FP_NORMAL: - TclNewLiteralStringObj(objPtr, "normal"); - break; - case FP_SUBNORMAL: - TclNewLiteralStringObj(objPtr, "subnormal"); - break; - case FP_ZERO: - TclNewLiteralStringObj(objPtr, "zero"); - break; - default: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unable to classify number: %f", d)); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, objPtr); - return TCL_OK; + return ExprRandFunc(clientData, interp, 1, objv); } /* *---------------------------------------------------------------------- * @@ -8022,27 +7058,26 @@ Tcl_Interp *interp, /* Tcl interpreter */ int expected, /* Formal parameter count. */ int found, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Actual parameter vector. */ { - const char *name = TclGetString(objv[0]); + const char *name = Tcl_GetString(objv[0]); const char *tail = name + strlen(name); while (tail > name+1) { - tail--; + --tail; if (*tail == ':' && tail[-1] == ':') { name = tail+1; break; } } Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s arguments for math function \"%s\"", - (found < expected ? "not enough" : "too many"), name)); - Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); + "too %s arguments for math function \"%s\"", + (found < expected ? "few" : "many"), name)); } - #ifdef USE_DTRACE + /* *---------------------------------------------------------------------- * * DTraceObjCmd -- * @@ -8057,12 +7092,12 @@ *---------------------------------------------------------------------- */ static int DTraceObjCmd( - TCL_UNUSED(void *), - TCL_UNUSED(Tcl_Interp *), + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { if (TCL_DTRACE_TCL_PROBE_ENABLED()) { char *a[10]; @@ -8094,1458 +7129,51 @@ */ void TclDTraceInfo( Tcl_Obj *info, - const char **args, + char **args, int *argsi) { - static Tcl_Obj *keys[10] = { NULL }; + static Tcl_Obj *keys[7] = { NULL }; Tcl_Obj **k = keys, *val; - int i = 0; + int i; if (!*k) { -#define kini(s) TclNewLiteralStringObj(keys[i], s); i++ - kini("cmd"); kini("type"); kini("proc"); kini("file"); - kini("method"); kini("class"); kini("lambda"); kini("object"); - kini("line"); kini("level"); -#undef kini + TclNewLiteralStringObj(keys[0], "cmd"); + TclNewLiteralStringObj(keys[1], "type"); + TclNewLiteralStringObj(keys[2], "proc"); + TclNewLiteralStringObj(keys[3], "file"); + TclNewLiteralStringObj(keys[4], "lambda"); + TclNewLiteralStringObj(keys[5], "line"); + TclNewLiteralStringObj(keys[6], "level"); } - for (i = 0; i < 6; i++) { + for (i = 0; i < 4; i++) { Tcl_DictObjGet(NULL, info, *k++, &val); args[i] = val ? TclGetString(val) : NULL; } - - /* - * no "proc" -> use "lambda" - */ - if (!args[2]) { Tcl_DictObjGet(NULL, info, *k, &val); args[2] = val ? TclGetString(val) : NULL; } - k++; - - /* - * no "class" -> use "object" - */ - - if (!args[5]) { - Tcl_DictObjGet(NULL, info, *k, &val); - args[5] = val ? TclGetString(val) : NULL; - } k++; for (i = 0; i < 2; i++) { Tcl_DictObjGet(NULL, info, *k++, &val); if (val) { - TclGetIntFromObj(NULL, val, &argsi[i]); + TclGetIntFromObj(NULL, val, &(argsi[i])); } else { argsi[i] = 0; } } } - -/* - *---------------------------------------------------------------------- - * - * DTraceCmdReturn -- - * - * NR callback for DTrace command return probes. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -DTraceCmdReturn( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - char *cmdName = TclGetString((Tcl_Obj *) data[0]); - - if (TCL_DTRACE_CMD_RETURN_ENABLED()) { - TCL_DTRACE_CMD_RETURN(cmdName, result); - } - if (TCL_DTRACE_CMD_RESULT_ENABLED()) { - Tcl_Obj *r = Tcl_GetObjResult(interp); - - TCL_DTRACE_CMD_RESULT(cmdName, result, TclGetString(r), r); - } - return result; -} TCL_DTRACE_DEBUG_LOG() #endif /* USE_DTRACE */ -/* - *---------------------------------------------------------------------- - * - * Tcl_NRCallObjProc -- - * - * This function calls an objProc directly while managing things properly - * if it happens to be an NR objProc. It is meant to be used by extenders - * that provide an NR implementation of a command, as this function - * permits a trivial coding of the non-NR objProc. - * - * Results: - * The return value is a standard Tcl completion code such as TCL_OK or - * TCL_ERROR. A result or error message is left in interp's result. - * - * Side effects: - * Depends on the objProc. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_NRCallObjProc( - Tcl_Interp *interp, - Tcl_ObjCmdProc *objProc, - ClientData clientData, - int objc, - Tcl_Obj *const objv[]) -{ - NRE_callback *rootPtr = TOP_CB(interp); - - TclNRAddCallback(interp, Dispatch, objProc, clientData, - INT2PTR(objc), objv); - return TclNRRunCallbacks(interp, TCL_OK, rootPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_NRCreateCommand -- - * - * Define a new NRE-enabled object-based command in a command table. - * - * Results: - * The return value is a token for the command, which can be used in - * future calls to Tcl_GetCommandName. - * - * Side effects: - * If no command named "cmdName" already exists for interp, one is - * created. Otherwise, if a command does exist, then if the object-based - * Tcl_ObjCmdProc is TclInvokeStringCommand, we assume Tcl_CreateCommand - * was called previously for the same command and just set its - * Tcl_ObjCmdProc to the argument "proc"; otherwise, we delete the old - * command. - * - * 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. - * - *---------------------------------------------------------------------- - */ - -Tcl_Command -Tcl_NRCreateCommand( - Tcl_Interp *interp, /* Token for command interpreter (returned by - * previous call to Tcl_CreateInterp). */ - const char *cmdName, /* Name of command. If it contains namespace - * qualifiers, the new command is put in the - * specified namespace; otherwise it is put in - * the global namespace. */ - Tcl_ObjCmdProc *proc, /* Object-based function to associate with - * name, provides direct access for direct - * calls. */ - Tcl_ObjCmdProc *nreProc, /* Object-based function to associate with - * name, provides NR implementation */ - 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. */ -{ - Command *cmdPtr = (Command *) - Tcl_CreateObjCommand(interp, cmdName, proc, clientData, - deleteProc); - - cmdPtr->nreProc = nreProc; - return (Tcl_Command) cmdPtr; -} - -Tcl_Command -TclNRCreateCommandInNs( - Tcl_Interp *interp, - const char *cmdName, - Tcl_Namespace *nsPtr, - Tcl_ObjCmdProc *proc, - Tcl_ObjCmdProc *nreProc, - ClientData clientData, - Tcl_CmdDeleteProc *deleteProc) -{ - Command *cmdPtr = (Command *) - TclCreateObjCommandInNs(interp, cmdName, nsPtr, proc, clientData, - deleteProc); - - cmdPtr->nreProc = nreProc; - return (Tcl_Command) cmdPtr; -} - -/**************************************************************************** - * Stuff for the public api - ****************************************************************************/ - -int -Tcl_NREvalObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - int flags) -{ - return TclNREvalObjEx(interp, objPtr, flags, NULL, INT_MIN); -} - -int -Tcl_NREvalObjv( - Tcl_Interp *interp, /* Interpreter in which to evaluate the - * command. Also used for error reporting. */ - int objc, /* Number of words in command. */ - Tcl_Obj *const objv[], /* An array of pointers to objects that are - * the words that make up the command. */ - int flags) /* Collection of OR-ed bits that control the - * evaluation of the script. Only - * TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and - * TCL_EVAL_NOERR are currently supported. */ -{ - return TclNREvalObjv(interp, objc, objv, flags, NULL); -} - -int -Tcl_NRCmdSwap( - Tcl_Interp *interp, - Tcl_Command cmd, - int objc, - Tcl_Obj *const objv[], - int flags) -{ - return TclNREvalObjv(interp, objc, objv, flags|TCL_EVAL_NOERR, - (Command *) cmd); -} - -/***************************************************************************** - * Tailcall related code - ***************************************************************************** - * - * The steps of the tailcall dance are as follows: - * - * 1. when [tailcall] is invoked, it stores the corresponding callback in - * the current CallFrame and returns TCL_RETURN - * 2. when the CallFrame is popped, it calls TclSetTailcall to store the - * callback in the proper NRCommand callback - the spot where the command - * that pushed the CallFrame is completely cleaned up - * 3. when the NRCommand callback runs, it schedules the tailcall callback - * to run immediately after it returns - * - * One delicate point is to properly define the NRCommand where the tailcall - * will execute. There are functions whose purpose is to help define the - * precise spot: - * TclMarkTailcall: if the NEXT command to be pushed tailcalls, execution - * should continue right here - * TclSkipTailcall: if the NEXT command to be pushed tailcalls, execution - * should continue after the CURRENT command is fully returned ("skip - * the next command: we are redirecting to it, tailcalls should run - * after WE return") - * TclPushTailcallPoint: the search for a tailcalling spot cannot traverse - * this point. This is special for OO, as some of the oo constructs - * that behave like commands may not push an NRCommand callback. - */ - -void -TclMarkTailcall( - Tcl_Interp *interp) -{ - Interp *iPtr = (Interp *) interp; - - if (iPtr->deferredCallbacks == NULL) { - TclNRAddCallback(interp, NRCommand, NULL, NULL, - NULL, NULL); - iPtr->deferredCallbacks = TOP_CB(interp); - } -} - -void -TclSkipTailcall( - Tcl_Interp *interp) -{ - Interp *iPtr = (Interp *) interp; - - TclMarkTailcall(interp); - iPtr->deferredCallbacks->data[1] = INT2PTR(1); -} - -void -TclPushTailcallPoint( - Tcl_Interp *interp) -{ - TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); - ((Interp *) interp)->numLevels++; -} - -/* - *---------------------------------------------------------------------- - * - * TclSetTailcall -- - * - * Splice a tailcall command in the proper spot of the NRE callback - * stack, so that it runs at the right time. - * - *---------------------------------------------------------------------- - */ - -void -TclSetTailcall( - Tcl_Interp *interp, - Tcl_Obj *listPtr) -{ - /* - * Find the splicing spot: right before the NRCommand of the thing - * being tailcalled. Note that we skip NRCommands marked by a 1 in data[1] - * (used by command redirectors). - */ - - NRE_callback *runPtr; - - for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) { - if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) { - break; - } - } - if (!runPtr) { - Tcl_Panic("tailcall cannot find the right splicing spot: should not happen!"); - } - runPtr->data[1] = listPtr; -} - -/* - *---------------------------------------------------------------------- - * - * TclNRTailcallObjCmd -- - * - * Prepare the tailcall as a list and store it in the current - * varFrame. When the frame is later popped the tailcall will be spliced - * at the proper place. - * - * Results: - * The first NRCommand callback that is not marked to be skipped is - * updated so that its data[1] field contains the tailcall list. - * - *---------------------------------------------------------------------- - */ - -int -TclNRTailcallObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Interp *iPtr = (Interp *) interp; - - if (objc < 1) { - Tcl_WrongNumArgs(interp, 1, objv, "?command? ?arg ...?"); - return TCL_ERROR; - } - - if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "tailcall can only be called from a proc, lambda or method", -1)); - Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL); - return TCL_ERROR; - } - - /* - * Invocation without args just clears a scheduled tailcall; invocation - * with an argument replaces any previously scheduled tailcall. - */ - - if (iPtr->varFramePtr->tailcallPtr) { - Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr); - iPtr->varFramePtr->tailcallPtr = NULL; - } - - /* - * Create the callback to actually evaluate the tailcalled - * command, then set it in the varFrame so that PopCallFrame can use it - * at the proper time. - */ - - if (objc > 1) { - Tcl_Obj *listPtr, *nsObjPtr; - Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; - - /* - * The tailcall data is in a Tcl list: the first element is the - * namespace, the rest the command to be tailcalled. - */ - - nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); - listPtr = Tcl_NewListObj(objc, objv); - TclListObjSetElement(interp, listPtr, 0, nsObjPtr); - - iPtr->varFramePtr->tailcallPtr = listPtr; - } - return TCL_RETURN; -} - -/* - *---------------------------------------------------------------------- - * - * TclNRTailcallEval -- - * - * This NREcallback actually causes the tailcall to be evaluated. - * - *---------------------------------------------------------------------- - */ - -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]; - - if (result == TCL_OK) { - result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); - } - - if (result != TCL_OK) { - /* - * Tailcall execution was preempted, eg by an intervening catch or by - * a now-gone namespace: cleanup and return. - */ - - Tcl_DecrRefCount(listPtr); - return result; - } - - /* - * Perform the tailcall - */ - - TclMarkTailcall(interp); - TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL); - iPtr->lookupNsPtr = (Namespace *) nsPtr; - return TclNREvalObjv(interp, objc-1, objv+1, 0, NULL); -} - -int -TclNRReleaseValues( - 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++; - } - return result; -} - -void -Tcl_NRAddCallback( - Tcl_Interp *interp, - Tcl_NRPostProc *postProcPtr, - ClientData data0, - ClientData data1, - ClientData data2, - ClientData data3) -{ - if (!(postProcPtr)) { - Tcl_Panic("Adding a callback without an objProc?!"); - } - TclNRAddCallback(interp, postProcPtr, data0, data1, data2, data3); -} - -/* - *---------------------------------------------------------------------- - * - * TclNRCoroutineObjCmd -- (and friends) - * - * This object-based function is invoked to process the "coroutine" Tcl - * command. It is heavily based on "apply". - * - * Results: - * A standard Tcl object result value. - * - * Side effects: - * A new procedure gets created. - * - * ** FIRST EXPERIMENTAL IMPLEMENTATION ** - * - * It is fairly amateurish and not up to our standards - mainly in terms of - * error messages and [info] interaction. Just to test the infrastructure in - * teov and tebc. - *---------------------------------------------------------------------- - */ - -#define iPtr ((Interp *) interp) - -int -TclNRYieldObjCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - - if (objc > 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?returnValue?"); - return TCL_ERROR; - } - - if (!corPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "yield can only be called in a coroutine", -1)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL); - return TCL_ERROR; - } - - if (objc == 2) { - Tcl_SetObjResult(interp, objv[1]); - } - - NRE_ASSERT(!COR_IS_SUSPENDED(corPtr)); - TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, - clientData, NULL, NULL); - return TCL_OK; -} - -int -TclNRYieldToObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - Tcl_Obj *listPtr, *nsObjPtr; - Tcl_Namespace *nsPtr = TclGetCurrentNamespace(interp); - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?"); - return TCL_ERROR; - } - - if (!corPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "yieldto can only be called in a coroutine", -1)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL); - return TCL_ERROR; - } - - if (((Namespace *) nsPtr)->flags & NS_DYING) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "yieldto called in deleted namespace", -1)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED", - NULL); - return TCL_ERROR; - } - - /* - * Add the tailcall in the caller env, then just yield. - * - * This is essentially code from TclNRTailcallObjCmd - */ - - listPtr = Tcl_NewListObj(objc, objv); - nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); - TclListObjSetElement(interp, listPtr, 0, nsObjPtr); - - /* - * Add the callback in the caller's env, then instruct TEBC to yield. - */ - - iPtr->execEnvPtr = corPtr->callerEEPtr; - TclSetTailcall(interp, listPtr); - iPtr->execEnvPtr = corPtr->eePtr; - - 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) -{ - Tcl_Interp *interp = corPtr->eePtr->interp; - Tcl_InterpState state = Tcl_SaveInterpState(interp, result); - - NRE_ASSERT(COR_IS_SUSPENDED(corPtr)); - NRE_ASSERT(corPtr->eePtr != NULL); - NRE_ASSERT(corPtr->eePtr != iPtr->execEnvPtr); - - corPtr->eePtr->rewind = 1; - TclNRAddCallback(interp, RewindCoroutineCallback, state, - NULL, NULL, NULL); - 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); - Tcl_Free(corPtr); - return result; - } - - NRE_ASSERT(COR_IS_SUSPENDED(corPtr)); - SAVE_CONTEXT(corPtr->running); - RESTORE_CONTEXT(corPtr->caller); - - if (cmdPtr->flags & CMD_DYING) { - /* - * The command was deleted while it was running: wind down the - * execEnv, this will do the complete cleanup. RewindCoroutine will - * restore both the caller's context and interp state. - */ - - return RewindCoroutine(corPtr, result); - } - - return result; -} - -static int -NRCoroutineExitCallback( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - CoroutineData *corPtr = (CoroutineData *)data[0]; - Command *cmdPtr = corPtr->cmdPtr; - - /* - * This runs at the bottom of the Coroutine's execEnv: it will be executed - * when the coroutine returns or is wound down, but not when it yields. It - * deletes the coroutine and restores the caller's environment. - */ - - NRE_ASSERT(interp == corPtr->eePtr->interp); - NRE_ASSERT(TOP_CB(interp) == NULL); - NRE_ASSERT(iPtr->execEnvPtr == corPtr->eePtr); - NRE_ASSERT(!COR_IS_SUSPENDED(corPtr)); - NRE_ASSERT((corPtr->callerEEPtr->callbackPtr->procPtr == NRCoroutineCallerCallback)); - - cmdPtr->deleteProc = NULL; - Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); - TclCleanupCommandMacro(cmdPtr); - - corPtr->eePtr->corPtr = NULL; - TclDeleteExecEnv(corPtr->eePtr); - corPtr->eePtr = NULL; - - corPtr->stackLevel = NULL; - - /* - * #280. - * Drop the coroutine-owned copy of the lineLABCPtr hashtable for literal - * command arguments in bytecode. - */ - - Tcl_DeleteHashTable(corPtr->lineLABCPtr); - Tcl_Free(corPtr->lineLABCPtr); - corPtr->lineLABCPtr = NULL; - - RESTORE_CONTEXT(corPtr->caller); - iPtr->execEnvPtr = corPtr->callerEEPtr; - iPtr->numLevels++; - - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclNRCoroutineActivateCallback -- - * - * This is the workhorse for coroutines: it implements both yield and - * resume. - * - * It is important that both be implemented in the same callback: the - * detection of the impossibility to suspend due to a busy C-stack relies - * on the precise position of a local variable in the stack. We do not - * want the compiler to play tricks on us, either by moving things around - * or inlining. - * - *---------------------------------------------------------------------- - */ - -int -TclNRCoroutineActivateCallback( - 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 -- - * Push the callback to restore the caller's context on yield or - * return. - */ - - TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr, - NULL, NULL, NULL); - - /* - * Record the stackLevel at which the resume is happening, then swap - * the interp's environment to make it suitable to run this coroutine. - */ - - corPtr->stackLevel = stackLevel; - numLevels = corPtr->auxNumLevels; - corPtr->auxNumLevels = iPtr->numLevels; - - SAVE_CONTEXT(corPtr->caller); - corPtr->callerEEPtr = iPtr->execEnvPtr; - RESTORE_CONTEXT(corPtr->running); - iPtr->execEnvPtr = corPtr->eePtr; - iPtr->numLevels += numLevels; - } else { - /* - * Coroutine is active: yield - */ - - if (corPtr->stackLevel != stackLevel) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot yield: C stack busy", -1)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD", - NULL); - return TCL_ERROR; - } - - if (type == CORO_ACTIVATE_YIELD) { - corPtr->nargs = COROUTINE_ARGUMENTS_SINGLE_OPTIONAL; - } else if (type == CORO_ACTIVATE_YIELDM) { - corPtr->nargs = COROUTINE_ARGUMENTS_ARBITRARY; - } else { - Tcl_Panic("Yield received an option which is not implemented"); - } - - corPtr->stackLevel = NULL; - - numLevels = iPtr->numLevels; - iPtr->numLevels = corPtr->auxNumLevels; - corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels; - - iPtr->execEnvPtr = corPtr->callerEEPtr; - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclNREvalList -- - * - * Callback to invoke command as list, used in order to delayed - * processing of canonical list command in sane environment. - * - *---------------------------------------------------------------------- - */ - -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); -} - -/* - *---------------------------------------------------------------------- - * - * CoroTypeObjCmd -- - * - * Implementation of [::tcl::unsupported::corotype] command. - * - *---------------------------------------------------------------------- - */ - -static int -CoroTypeObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Command *cmdPtr; - CoroutineData *corPtr; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "coroName"); - return TCL_ERROR; - } - - /* - * Look up the coroutine. - */ - - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]); - if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can only get coroutine type of a coroutine", -1)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", - TclGetString(objv[1]), NULL); - return TCL_ERROR; - } - - /* - * An active coroutine is "active". Can't tell what it might do in the - * future. - */ - - corPtr = (CoroutineData *)cmdPtr->objClientData; - if (!COR_IS_SUSPENDED(corPtr)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("active", -1)); - return TCL_OK; - } - - /* - * Inactive coroutines are classified by the (effective) command used to - * suspend them, which matters when you're injecting a probe. - */ - - switch (corPtr->nargs) { - case COROUTINE_ARGUMENTS_SINGLE_OPTIONAL: - Tcl_SetObjResult(interp, Tcl_NewStringObj("yield", -1)); - return TCL_OK; - case COROUTINE_ARGUMENTS_ARBITRARY: - Tcl_SetObjResult(interp, Tcl_NewStringObj("yieldto", -1)); - return TCL_OK; - default: - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unknown coroutine type", -1)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BAD_TYPE", NULL); - return TCL_ERROR; - } -} - -/* - *---------------------------------------------------------------------- - * - * TclNRCoroInjectObjCmd, TclNRCoroProbeObjCmd -- - * - * Implementation of [coroinject] and [coroprobe] commands. - * - *---------------------------------------------------------------------- - */ - -static inline CoroutineData * -GetCoroutineFromObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - const char *errMsg) -{ - /* - * How to get a coroutine from its handle. - */ - - Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr); - - if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", - TclGetString(objPtr), NULL); - return NULL; - } - return (CoroutineData *)cmdPtr->objClientData; -} - -static int -TclNRCoroInjectObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - CoroutineData *corPtr; - ExecEnv *savedEEPtr = iPtr->execEnvPtr; - - /* - * Usage more or less like tailcall: - * coroinject coroName cmd ?arg1 arg2 ...? - */ - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?"); - return TCL_ERROR; - } - - corPtr = GetCoroutineFromObj(interp, objv[1], - "can only inject a command into a coroutine"); - if (!corPtr) { - return TCL_ERROR; - } - if (!COR_IS_SUSPENDED(corPtr)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can only inject a command into a suspended coroutine", -1)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL); - return TCL_ERROR; - } - - /* - * Add the callback to the coro's execEnv, so that it is the first thing - * to happen when the coro is resumed. - */ - - iPtr->execEnvPtr = corPtr->eePtr; - TclNRAddCallback(interp, InjectHandler, corPtr, - Tcl_NewListObj(objc - 2, objv + 2), INT2PTR(corPtr->nargs), NULL); - iPtr->execEnvPtr = savedEEPtr; - - return TCL_OK; -} - -static int -TclNRCoroProbeObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - CoroutineData *corPtr; - ExecEnv *savedEEPtr = iPtr->execEnvPtr; - int numLevels, unused; - int *stackLevel = &unused; - - /* - * Usage more or less like tailcall: - * coroprobe coroName cmd ?arg1 arg2 ...? - */ - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?"); - return TCL_ERROR; - } - - corPtr = GetCoroutineFromObj(interp, objv[1], - "can only inject a probe command into a coroutine"); - if (!corPtr) { - return TCL_ERROR; - } - if (!COR_IS_SUSPENDED(corPtr)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can only inject a probe command into a suspended coroutine", - -1)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL); - return TCL_ERROR; - } - - /* - * Add the callback to the coro's execEnv, so that it is the first thing - * to happen when the coro is resumed. - */ - - iPtr->execEnvPtr = corPtr->eePtr; - TclNRAddCallback(interp, InjectHandler, corPtr, - Tcl_NewListObj(objc - 2, objv + 2), INT2PTR(corPtr->nargs), corPtr); - iPtr->execEnvPtr = savedEEPtr; - - /* - * Now we immediately transfer control to the coroutine to run our probe. - * TRICKY STUFF copied from the [yield] implementation. - * - * Push the callback to restore the caller's context on yield back. - */ - - TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr, - NULL, NULL, NULL); - - /* - * Record the stackLevel at which the resume is happening, then swap - * the interp's environment to make it suitable to run this coroutine. - */ - - corPtr->stackLevel = stackLevel; - numLevels = corPtr->auxNumLevels; - corPtr->auxNumLevels = iPtr->numLevels; - - /* - * Do the actual stack swap. - */ - - SAVE_CONTEXT(corPtr->caller); - corPtr->callerEEPtr = iPtr->execEnvPtr; - RESTORE_CONTEXT(corPtr->running); - iPtr->execEnvPtr = corPtr->eePtr; - iPtr->numLevels += numLevels; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * InjectHandler, InjectHandlerPostProc -- - * - * Part of the implementation of [coroinject] and [coroprobe]. These are - * run inside the context of the coroutine being injected/probed into. - * - * InjectHandler runs a script (possibly adding arguments) in the context - * of the coroutine. The script is specified as a one-shot list (with - * reference count equal to 1) in data[1]. This function also arranges - * for InjectHandlerPostProc to be the part that runs after the script - * completes. - * - * InjectHandlerPostProc cleans up after InjectHandler (deleting the - * list) and, for the [coroprobe] command *only*, yields back to the - * caller context (i.e., where [coroprobe] was run). - *s - *---------------------------------------------------------------------- - */ - -static int -InjectHandler( - 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) { - /* - * If this is [coroinject], add the extra arguments now. - */ - - if (nargs == COROUTINE_ARGUMENTS_SINGLE_OPTIONAL) { - Tcl_ListObjAppendElement(NULL, listPtr, - Tcl_NewStringObj("yield", -1)); - } else if (nargs == COROUTINE_ARGUMENTS_ARBITRARY) { - Tcl_ListObjAppendElement(NULL, listPtr, - Tcl_NewStringObj("yieldto", -1)); - } else { - /* - * I don't think this is reachable... - */ - - Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewIntObj(nargs)); - } - Tcl_ListObjAppendElement(NULL, listPtr, Tcl_GetObjResult(interp)); - } - - /* - * Call the user's script; we're in the right place. - */ - - Tcl_IncrRefCount(listPtr); - TclMarkTailcall(interp); - TclNRAddCallback(interp, InjectHandlerPostCall, corPtr, listPtr, - INT2PTR(nargs), isProbe); - TclListObjGetElements(NULL, listPtr, &objc, &objv); - return TclNREvalObjv(interp, objc, objv, 0, NULL); -} - -static int -InjectHandlerPostCall( - 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. - */ - - Tcl_DecrRefCount(listPtr); - - /* - * If we were doing a probe, splice ourselves back out of the stack - * cleanly here. General injection should instead just look after itself. - * - * Code from guts of [yield] implementation. - */ - - if (isProbe) { - if (result == TCL_ERROR) { - Tcl_AddErrorInfo(interp, - "\n (injected coroutine probe command)"); - } - corPtr->nargs = nargs; - corPtr->stackLevel = NULL; - numLevels = iPtr->numLevels; - iPtr->numLevels = corPtr->auxNumLevels; - corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels; - iPtr->execEnvPtr = corPtr->callerEEPtr; - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * NRInjectObjCmd -- - * - * Implementation of [::tcl::unsupported::inject] command. - * - *---------------------------------------------------------------------- - */ - -static int -NRInjectObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - CoroutineData *corPtr; - ExecEnv *savedEEPtr = iPtr->execEnvPtr; - - /* - * Usage more or less like tailcall: - * inject coroName cmd ?arg1 arg2 ...? - */ - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?"); - return TCL_ERROR; - } - - corPtr = GetCoroutineFromObj(interp, objv[1], - "can only inject a command into a coroutine"); - if (!corPtr) { - return TCL_ERROR; - } - if (!COR_IS_SUSPENDED(corPtr)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can only inject a command into a suspended coroutine", -1)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL); - return TCL_ERROR; - } - - /* - * Add the callback to the coro's execEnv, so that it is the first thing - * to happen when the coro is resumed. - */ - - iPtr->execEnvPtr = corPtr->eePtr; - TclNRAddCallback(interp, TclNREvalList, Tcl_NewListObj(objc-2, objv+2), - NULL, NULL, NULL); - iPtr->execEnvPtr = savedEEPtr; - - return TCL_OK; -} - -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; - } - - /* - * Parse all the arguments to work out what to feed as the result of the - * [yield]. TRICKY POINT: objc==0 happens here! It occurs when a coroutine - * is deleted! - */ - - switch (corPtr->nargs) { - case COROUTINE_ARGUMENTS_SINGLE_OPTIONAL: - if (objc == 2) { - Tcl_SetObjResult(interp, objv[1]); - } else if (objc > 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?arg?"); - return TCL_ERROR; - } - break; - default: - if (corPtr->nargs != objc-1) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("wrong coro nargs; how did we get here? " - "not implemented!", -1)); - Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); - return TCL_ERROR; - } - /* fallthrough */ - case COROUTINE_ARGUMENTS_ARBITRARY: - if (objc > 1) { - Tcl_SetObjResult(interp, Tcl_NewListObj(objc-1, objv+1)); - } - break; - } - - TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, - NULL, NULL, NULL); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclNRCoroutineObjCmd -- - * - * Implementation of [coroutine] command; see documentation for - * description of what this does. - * - *---------------------------------------------------------------------- - */ - -int -TclNRCoroutineObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Command *cmdPtr; - CoroutineData *corPtr; - const char *procName, *simpleName; - Namespace *nsPtr, *altNsPtr, *cxtNsPtr, - *inNsPtr = (Namespace *)TclGetCurrentNamespace(interp); - Namespace *lookupNsPtr = iPtr->varFramePtr->nsPtr; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "name cmd ?arg ...?"); - return TCL_ERROR; - } - - procName = TclGetString(objv[1]); - TclGetNamespaceForQualName(interp, procName, inNsPtr, 0, - &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName); - - if (nsPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create procedure \"%s\": unknown namespace", - procName)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", NULL); - return TCL_ERROR; - } - if (simpleName == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create procedure \"%s\": bad procedure name", - procName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, NULL); - return TCL_ERROR; - } - - /* - * We ARE creating the coroutine command: allocate the corresponding - * struct and create the corresponding command. - */ - - corPtr = (CoroutineData *)Tcl_Alloc(sizeof(CoroutineData)); - - cmdPtr = (Command *) TclNRCreateCommandInNs(interp, simpleName, - (Tcl_Namespace *)nsPtr, /*objProc*/ NULL, TclNRInterpCoroutine, - corPtr, DeleteCoroutine); - - corPtr->cmdPtr = cmdPtr; - cmdPtr->refCount++; - - /* - * #280. - * Provide the new coroutine with its own copy of the lineLABCPtr - * hashtable for literal command arguments in bytecode. Note that that - * CFWordBC chains are not duplicated, only the entrypoints to them. This - * means that in the presence of coroutines each chain is potentially a - * tree. Like the chain -> tree conversion of the CmdFrame stack. - */ - - { - Tcl_HashSearch hSearch; - Tcl_HashEntry *hePtr; - - corPtr->lineLABCPtr = (Tcl_HashTable *)Tcl_Alloc(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, - Tcl_GetHashKey(iPtr->lineLABCPtr, hePtr), - &isNew); - - Tcl_SetHashValue(newPtr, Tcl_GetHashValue(hePtr)); - } - } - - /* - * Create the base context. - */ - - corPtr->running.framePtr = iPtr->rootFramePtr; - corPtr->running.varFramePtr = iPtr->rootFramePtr; - corPtr->running.cmdFramePtr = NULL; - corPtr->running.lineLABCPtr = corPtr->lineLABCPtr; - corPtr->stackLevel = NULL; - corPtr->auxNumLevels = 0; - - /* - * Create the coro's execEnv, switch to it to push the exit and coro - * command callbacks, then switch back. - */ - - corPtr->eePtr = TclCreateExecEnv(interp, CORO_STACK_INITIAL_SIZE); - corPtr->callerEEPtr = iPtr->execEnvPtr; - corPtr->eePtr->corPtr = corPtr; - - SAVE_CONTEXT(corPtr->caller); - corPtr->callerEEPtr = iPtr->execEnvPtr; - RESTORE_CONTEXT(corPtr->running); - iPtr->execEnvPtr = corPtr->eePtr; - - TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, - NULL, NULL, NULL); - - /* - * Ensure that the command is looked up in the correct namespace. - */ - - iPtr->lookupNsPtr = lookupNsPtr; - Tcl_NREvalObj(interp, Tcl_NewListObj(objc - 2, objv + 2), 0); - iPtr->numLevels--; - - SAVE_CONTEXT(corPtr->running); - RESTORE_CONTEXT(corPtr->caller); - iPtr->execEnvPtr = corPtr->callerEEPtr; - - /* - * Now just resume the coroutine. - */ - - TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, - NULL, NULL, NULL); - return TCL_OK; -} - -/* - * This is used in the [info] ensemble - */ - -int -TclInfoCoroutineCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - - if (objc != 1) { - Tcl_WrongNumArgs(interp, 1, objv, NULL); - return TCL_ERROR; - } - - if (corPtr && !(corPtr->cmdPtr->flags & CMD_DYING)) { - Tcl_Obj *namePtr; - - TclNewObj(namePtr); - Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr, namePtr); - Tcl_SetObjResult(interp, namePtr); - } - return TCL_OK; -} - -#undef iPtr - /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 - * tab-width: 8 - * indent-tabs-mode: nil * End: */ Index: generic/tclBinary.c ================================================================== --- generic/tclBinary.c +++ generic/tclBinary.c @@ -10,22 +10,21 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" -#include "tclTomMath.h" +#include "tommath.h" #include -#include /* * The following constants are used by GetFormatSpec to indicate various * special conditions in the parsing of a format specifier. */ -#define BINARY_ALL ((size_t)-1) /* Use all elements in the argument. */ -#define BINARY_NOCOUNT ((size_t)-2) /* No count was specified in format. */ +#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 */ @@ -55,209 +54,55 @@ * Prototypes for local procedures defined in this file: */ static void DupByteArrayInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); -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, - size_t *countPtr, int *flagsPtr); +static int GetFormatSpec(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, - size_t 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[]); -/* Binary encoding sub-ensemble commands */ -static int BinaryEncodeHex(ClientData clientData, - Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int BinaryDecodeHex(ClientData clientData, - Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int BinaryEncode64(ClientData clientData, - Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int BinaryDecode64(ClientData clientData, - Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int BinaryEncodeUu(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int BinaryDecodeUu(ClientData clientData, - Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); - -/* - * The following tables are used by the binary encoders - */ - -static const char HexDigits[16] = { - '0', '1', '2', '3', '4', '5', '6', '7', - '8', '9', 'a', 'b', 'c', 'd', 'e', 'f' -}; - -static const char UueDigits[65] = { - '`', '!', '"', '#', '$', '%', '&', '\'', - '(', ')', '*', '+', ',', '-', '.', '/', - '0', '1', '2', '3', '4', '5', '6', '7', - '8', '9', ':', ';', '<', '=', '>', '?', - '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G', - 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', - 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', - 'X', 'Y', 'Z', '[', '\\',']', '^', '_', - '`' -}; - -static const char B64Digits[65] = { - 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', - 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', - 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', - 'Y', 'Z', 'a', 'b', 'c', 'd', 'e', 'f', - 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', - 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', - 'w', 'x', 'y', 'z', '0', '1', '2', '3', - '4', '5', '6', '7', '8', '9', '+', '/', - '=' -}; - -/* - * How to construct the ensembles. - */ - -static const EnsembleImplMap binaryMap[] = { - { "format", BinaryFormatCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0 }, - { "scan", BinaryScanCmd, TclCompileBasicMin2ArgCmd, NULL, NULL, 0 }, - { "encode", NULL, NULL, NULL, NULL, 0 }, - { "decode", NULL, NULL, NULL, NULL, 0 }, - { NULL, NULL, NULL, NULL, NULL, 0 } -}; -static const EnsembleImplMap encodeMap[] = { - { "hex", BinaryEncodeHex, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, - { "uuencode", BinaryEncodeUu, NULL, NULL, NULL, 0 }, - { "base64", BinaryEncode64, NULL, NULL, NULL, 0 }, - { NULL, NULL, NULL, NULL, NULL, 0 } -}; -static const EnsembleImplMap decodeMap[] = { - { "hex", BinaryDecodeHex, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, - { "uuencode", BinaryDecodeUu, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, - { "base64", BinaryDecode64, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, - { NULL, NULL, NULL, NULL, NULL, 0 } -}; - -/* - * The following object types represent an array of bytes. The intent is to - * allow arbitrary binary data to pass through Tcl as a Tcl value without loss - * or damage. Such values are useful for things like encoded strings or Tk - * images to name just two. - * - * It's strange to have two Tcl_ObjTypes in place for this task when one would - * do, so a bit of detail and history how we got to this point and where we - * might go from here. - * - * A bytearray is an ordered sequence of bytes. Each byte is an integer value - * in the range [0-255]. To be a Tcl value type, we need a way to encode each - * value in the value set as a Tcl string. The simplest encoding is to - * represent each byte value as the same codepoint value. A bytearray of N - * bytes is encoded into a Tcl string of N characters where the codepoint of - * each character is the value of corresponding byte. This approach creates a - * one-to-one map between all bytearray values and a subset of Tcl string - * values. - * - * When converting a Tcl string value to the bytearray internal rep, the - * question arises what to do with strings outside that subset? That is, - * those Tcl strings containing at least one codepoint greater than 255? The - * obviously correct answer is to raise an error! That string value does not - * represent any valid bytearray value. Full Stop. The setFromAnyProc - * signature has a completion code return value for just this reason, to - * reject invalid inputs. - * - * Unfortunately this was not the path taken by the authors of the original - * tclByteArrayType. They chose to accept all Tcl string values as acceptable - * string encodings of the bytearray values that result from masking away the - * high bits of any codepoint value at all. This meant that every bytearray - * value had multiple accepted string representations. - * - * The implications of this choice are truly ugly. When a Tcl value has a - * string representation, we are required to accept that as the true value. - * Bytearray values that possess a string representation cannot be processed - * as bytearrays because we cannot know which true value that bytearray - * represents. The consequence is that we drag around an internal rep that we - * cannot make any use of. This painful price is extracted at any point after - * a string rep happens to be generated for the value. This happens even when - * the troublesome codepoints outside the byte range never show up. This - * happens rather routinely in normal Tcl operations unless we burden the - * script writer with the cognitive burden of avoiding it. The price is also - * paid by callers of the C interface. The routine - * - * unsigned char *Tcl_GetByteArrayFromObj(objPtr, lenPtr) - * - * has a guarantee to always return a non-NULL value, but that value points to - * a byte sequence that cannot be used by the caller to process the Tcl value - * absent some sideband testing that objPtr is "pure". Tcl offers no public - * interface to perform this test, so callers either break encapsulation or - * are unavoidably buggy. Tcl has defined a public interface that cannot be - * used correctly. The Tcl source code itself suffers the same problem, and - * has been buggy, but progressively less so as more and more portions of the - * code have been retrofitted with the required "purity testing". The set of - * values able to pass the purity test can be increased via the introduction - * of a "canonical" flag marker, but the only way the broken interface itself - * can be discarded is to start over and define the Tcl_ObjType properly. - * Bytearrays should simply be usable as bytearrays without a kabuki dance of - * testing. - * - * The Tcl_ObjType "properByteArrayType" is (nearly) a correct implementation - * of bytearrays. Any Tcl value with the type properByteArrayType can have - * its bytearray value fetched and used with confidence that acting on that - * value is equivalent to acting on the true Tcl string value. This still - * implies a side testing burden -- past mistakes will not let us avoid that - * immediately, but it is at least a conventional test of type, and can be - * implemented entirely by examining the objPtr fields, with no need to query - * the intrep, as a canonical flag would require. - * - * Until Tcl_GetByteArrayFromObj() and Tcl_SetByteArrayLength() can be revised - * to admit the possibility of returning NULL when the true value is not a - * valid bytearray, we need a mechanism to retain compatibility with the - * deployed callers of the broken interface. That's what the retained - * "tclByteArrayType" provides. In those unusual circumstances where we - * convert an invalid bytearray value to a bytearray type, it is to this - * legacy type. Essentially any time this legacy type gets used, it's a - * signal of a bug being ignored. A TIP should be drafted to remove this - * connection to the broken past so that Tcl 9 will no longer have any trace - * of it. Prescribing a migration path will be the key element of that work. - * The internal changes now in place are the limit of what can be done short - * of interface repair. They provide a great expansion of the histories over - * which bytearray values can be useful in the meanwhile. - */ - -static const Tcl_ObjType properByteArrayType = { - "bytearray", - FreeProperByteArrayInternalRep, - DupProperByteArrayInternalRep, - UpdateStringOfByteArray, - NULL -}; - -const Tcl_ObjType tclByteArrayType = { + unsigned int length, int type); + +/* + * The following object type represents an array of bytes. An array of bytes + * is not equivalent to an internationalized string. Conceptually, a string is + * an array of 16-bit quantities organized as a sequence of properly formed + * UTF-8 characters, while a ByteArray is an array of 8-bit quantities. + * Accessor functions are provided to convert a ByteArray to a String or a + * String to a ByteArray. Two or more consecutive bytes in an array of bytes + * may look like a single UTF-8 character if the array is casually treated as + * a string. But obtaining the String from a ByteArray is guaranteed to + * produced properly formed UTF-8 sequences so that there is a one-to-one map + * between bytes and characters. + * + * Converting a ByteArray to a String proceeds by casting each byte in the + * array to a 16-bit quantity, treating that number as a Unicode character, + * and storing the UTF-8 version of that Unicode character in the String. For + * ByteArrays consisting entirely of values 1..127, the corresponding String + * representation is the same as the ByteArray representation. + * + * Converting a String to a ByteArray proceeds by getting the Unicode + * representation of each character in the String, casting it to a byte by + * truncating the upper 8 bits, and then storing the byte in the ByteArray. + * Converting from ByteArray to String and back to ByteArray is not lossy, but + * converting an arbitrary String to a ByteArray may be. + */ + +Tcl_ObjType tclByteArrayType = { "bytearray", FreeByteArrayInternalRep, DupByteArrayInternalRep, - NULL, + UpdateStringOfByteArray, SetByteArrayFromAny }; /* * The following structure is the internal rep for a ByteArray object. Keeps @@ -264,35 +109,27 @@ * 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 { - size_t bad; /* Index of the character that is a nonbyte. - * If all characters are bytes, bad = used, - * though then we should never read it. */ - size_t used; /* The number of bytes used in the byte +typedef struct ByteArray { + int used; /* The number of bytes used in the byte * array. */ - size_t allocated; /* The amount of space actually allocated + int allocated; /* The amount of space actually allocated * minus 1 byte. */ - unsigned char bytes[TCLFLEXARRAY]; /* The array of bytes. The actual size of this + unsigned char bytes[4]; /* 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 = (baPtr) - -int -TclIsPureByteArray( - Tcl_Obj * objPtr) -{ - return TclHasIntRep(objPtr, &properByteArrayType); -} + ((unsigned) (sizeof(ByteArray) - 4 + (len))) +#define GET_BYTEARRAY(objPtr) \ + ((ByteArray *) (objPtr)->internalRep.twoPtrValue.ptr1) +#define SET_BYTEARRAY(objPtr, baPtr) \ + (objPtr)->internalRep.twoPtrValue.ptr1 = (VOID *) (baPtr) + /* *---------------------------------------------------------------------- * * Tcl_NewByteArrayObj -- @@ -308,28 +145,39 @@ * Memory allocated for new object and copy of byte array argument. * *---------------------------------------------------------------------- */ +#ifdef TCL_MEM_DEBUG #undef Tcl_NewByteArrayObj Tcl_Obj * Tcl_NewByteArrayObj( const unsigned char *bytes, /* The array of bytes used to initialize the * new object. */ - size_t length) /* Length of the array of bytes */ + 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 * +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. */ +{ Tcl_Obj *objPtr; TclNewObj(objPtr); Tcl_SetByteArrayObj(objPtr, bytes, length); return objPtr; -#endif /* TCL_MEM_DEBUG */ } +#endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_DbNewByteArrayObj -- @@ -353,15 +201,17 @@ * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG + Tcl_Obj * Tcl_DbNewByteArrayObj( const unsigned char *bytes, /* The array of bytes used to initialize the * new object. */ - size_t length, /* Length of the array of bytes. */ + 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. */ { @@ -369,24 +219,28 @@ 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. */ - size_t length, /* Length of the array of bytes, which must be + int length, /* Length of the array of bytes, which must be * >= 0. */ - TCL_UNUSED(const char *) /*file*/, - TCL_UNUSED(int) /*line*/) + 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. */ { return Tcl_NewByteArrayObj(bytes, length); } #endif /* TCL_MEM_DEBUG */ - + /* *--------------------------------------------------------------------------- * * Tcl_SetByteArrayObj -- * @@ -404,90 +258,35 @@ */ 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. */ - size_t length) /* Length of the array of bytes, which must - * be >= 0. */ + const unsigned char *bytes, /* The array of bytes to use as the new + * value. */ + 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"); } + TclFreeIntRep(objPtr); TclInvalidateStringRep(objPtr); - byteArrayPtr = (ByteArray *)Tcl_Alloc(BYTEARRAY_SIZE(length)); - byteArrayPtr->bad = length; + if (length < 0) { + length = 0; + } + byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(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 */ - size_t *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 %" TCL_Z_MODIFIER "u " - "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; + memcpy(byteArrayPtr->bytes, bytes, (size_t) length); + } + objPtr->typePtr = &tclByteArrayType; + SET_BYTEARRAY(objPtr, byteArrayPtr); } /* *---------------------------------------------------------------------- * @@ -510,39 +309,21 @@ 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. */ { - size_t numBytes = 0; - unsigned char *bytes = TclGetBytesFromObj(NULL, objPtr, &numBytes); - - if (bytes == NULL) { - ByteArray *baPtr; - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &tclByteArrayType); - - assert(irPtr != NULL); - - baPtr = GET_BYTEARRAY(irPtr); - bytes = baPtr->bytes; - numBytes = baPtr->used; - } - - /* Macro TclGetByteArrayFromObj passes NULL for lengthPtr as - * a trick to get around changing size. */ - if (lengthPtr) { - if (numBytes > INT_MAX) { - /* Caller asked for an int length, but true length is outside - * the int range. This case will be developed out of existence - * in Tcl 9. As interim measure, fail. */ - - *lengthPtr = 0; - return NULL; - } else { - *lengthPtr = (int) numBytes; - } - } - return bytes; + ByteArray *baPtr; + + if (objPtr->typePtr != &tclByteArrayType) { + SetByteArrayFromAny(NULL, objPtr); + } + baPtr = GET_BYTEARRAY(objPtr); + + if (lengthPtr != NULL) { + *lengthPtr = baPtr->used; + } + return (unsigned char *) baPtr->bytes; } /* *---------------------------------------------------------------------- * @@ -566,40 +347,29 @@ */ unsigned char * Tcl_SetByteArrayLength( Tcl_Obj *objPtr, /* The ByteArray object. */ - size_t length) /* New length for internal byte array. */ + int length) /* New length for internal byte array. */ { ByteArray *byteArrayPtr; - Tcl_ObjIntRep *irPtr; 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); - } - } + if (objPtr->typePtr != &tclByteArrayType) { + SetByteArrayFromAny(NULL, objPtr); } - byteArrayPtr = GET_BYTEARRAY(irPtr); + byteArrayPtr = GET_BYTEARRAY(objPtr); if (length > byteArrayPtr->allocated) { - byteArrayPtr = (ByteArray *)Tcl_Realloc(byteArrayPtr, BYTEARRAY_SIZE(length)); + byteArrayPtr = (ByteArray *) ckrealloc( + (char *) byteArrayPtr, BYTEARRAY_SIZE(length)); byteArrayPtr->allocated = length; - SET_BYTEARRAY(irPtr, byteArrayPtr); + SET_BYTEARRAY(objPtr, byteArrayPtr); } TclInvalidateStringRep(objPtr); - objPtr->typePtr = &properByteArrayType; - byteArrayPtr->bad = length; byteArrayPtr->used = length; return byteArrayPtr->bytes; } /* @@ -618,52 +388,36 @@ *---------------------------------------------------------------------- */ static int SetByteArrayFromAny( - TCL_UNUSED(Tcl_Interp *), + Tcl_Interp *interp, /* Not used. */ Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */ { - size_t length, bad; - const char *src, *srcEnd; + int length; + 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 = TclGetStringFromObj(objPtr, &length); - bad = length; - srcEnd = src + length; - - byteArrayPtr = (ByteArray *)Tcl_Alloc(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); - } - + Tcl_UniChar ch; + + if (objPtr->typePtr != &tclByteArrayType) { + src = TclGetStringFromObj(objPtr, &length); + srcEnd = src + length; + + byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length)); + for (dst = byteArrayPtr->bytes; src < srcEnd; ) { + src += Tcl_UtfToUniChar(src, &ch); + *dst++ = (unsigned char) ch; + } + + byteArrayPtr->used = dst - byteArrayPtr->bytes; + byteArrayPtr->allocated = length; + + TclFreeIntRep(objPtr); + objPtr->typePtr = &tclByteArrayType; + SET_BYTEARRAY(objPtr, byteArrayPtr); + } return TCL_OK; } /* *---------------------------------------------------------------------- @@ -684,18 +438,12 @@ static void FreeByteArrayInternalRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { - Tcl_Free(GET_BYTEARRAY(TclFetchIntRep(objPtr, &tclByteArrayType))); -} - -static void -FreeProperByteArrayInternalRep( - Tcl_Obj *objPtr) /* Object with internal rep to free. */ -{ - Tcl_Free(GET_BYTEARRAY(TclFetchIntRep(objPtr, &properByteArrayType))); + ckfree((char *) GET_BYTEARRAY(objPtr)); + objPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * @@ -716,99 +464,87 @@ static void DupByteArrayInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - size_t length; - ByteArray *srcArrayPtr, *copyArrayPtr; - Tcl_ObjIntRep ir; - - srcArrayPtr = GET_BYTEARRAY(TclFetchIntRep(srcPtr, &tclByteArrayType)); - length = srcArrayPtr->used; - - copyArrayPtr = (ByteArray *)Tcl_Alloc(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 *)Tcl_Alloc(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); + int length; + ByteArray *srcArrayPtr, *copyArrayPtr; + + srcArrayPtr = GET_BYTEARRAY(srcPtr); + length = srcArrayPtr->used; + + copyArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length)); + copyArrayPtr->used = length; + copyArrayPtr->allocated = length; + memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, (size_t) length); + SET_BYTEARRAY(copyPtr, copyArrayPtr); + + copyPtr->typePtr = &tclByteArrayType; } /* *---------------------------------------------------------------------- * * UpdateStringOfByteArray -- * - * Update the string representation for a ByteArray data object. + * Update the string representation for a ByteArray data object. Note: + * This procedure 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 * ByteArray-to-string conversion. + * + * The object becomes a string object -- the internal rep is discarded + * and the typePtr becomes NULL. * *---------------------------------------------------------------------- */ static void 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; - size_t i, length = byteArrayPtr->used; - size_t size = length; + int i, length, size; + unsigned char *src; + char *dst; + ByteArray *byteArrayPtr; + + byteArrayPtr = GET_BYTEARRAY(objPtr); + src = byteArrayPtr->bytes; + length = byteArrayPtr->used; /* * How much space will string rep need? */ - for (i = 0; i < length; i++) { + size = length; + for (i = 0; i < length && size >= 0; i++) { if ((src[i] == 0) || (src[i] > 127)) { size++; } } + if (size < 0) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + + dst = (char *) ckalloc((unsigned) (size + 1)); + objPtr->bytes = dst; + objPtr->length = size; if (size == length) { - char *dst = Tcl_InitStringRep(objPtr, (char *)src, size); - - TclOOM(dst, size); + memcpy(dst, src, (size_t) size); + dst[size] = '\0'; } else { - char *dst = Tcl_InitStringRep(objPtr, NULL, size); - - TclOOM(dst, size); for (i = 0; i < length; i++) { dst += Tcl_UniCharToUtf(src[i], dst); } - (void) Tcl_InitStringRep(objPtr, NULL, size); + *dst = '\0'; } } /* *---------------------------------------------------------------------- @@ -827,643 +563,89 @@ * size, or possibly larger. [Bug 2992970] * *---------------------------------------------------------------------- */ +#define TCL_MIN_GROWTH 1024 void TclAppendBytesToByteArray( Tcl_Obj *objPtr, const unsigned char *bytes, - size_t len) + int len) { ByteArray *byteArrayPtr; - size_t needed; - Tcl_ObjIntRep *irPtr; + int needed; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray"); } - if (len == TCL_INDEX_NONE) { + 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. - */ - + /* Append zero bytes is a no-op. */ return; } - - 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 (len > UINT_MAX - byteArrayPtr->used) { - Tcl_Panic("max size for a Tcl value (%u bytes) exceeded", UINT_MAX); + if (objPtr->typePtr != &tclByteArrayType) { + SetByteArrayFromAny(NULL, objPtr); + } + byteArrayPtr = GET_BYTEARRAY(objPtr); + + if (len > INT_MAX - byteArrayPtr->used) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } needed = byteArrayPtr->used + len; /* * If we need to, resize the allocated space in the byte array. */ if (needed > byteArrayPtr->allocated) { ByteArray *ptr = NULL; - size_t attempt; + int attempt; if (needed <= INT_MAX/2) { - /* - * Try to allocate double the total space that is needed. - */ - + /* Try to allocate double the total space that is needed. */ attempt = 2 * needed; - ptr = (ByteArray *)Tcl_AttemptRealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); + ptr = (ByteArray *) attemptckrealloc((void *) byteArrayPtr, + BYTEARRAY_SIZE(attempt)); } if (ptr == NULL) { - /* - * Try to allocate double the increment that is needed (plus). - */ - - size_t limit = UINT_MAX - needed; - size_t extra = len + TCL_MIN_GROWTH; - size_t growth = (extra > limit) ? limit : extra; + /* Try to allocate double the increment that is needed (plus). */ + unsigned int limit = INT_MAX - needed; + unsigned int extra = len + TCL_MIN_GROWTH; + int growth = (int) ((extra > limit) ? limit : extra); attempt = needed + growth; - ptr = (ByteArray *)Tcl_AttemptRealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); + ptr = (ByteArray *) attemptckrealloc((void *) byteArrayPtr, + BYTEARRAY_SIZE(attempt)); } if (ptr == NULL) { - /* - * Last chance: Try to allocate exactly what is needed. - */ - + /* Last chance: Try to allocate exactly what is needed. */ attempt = needed; - ptr = (ByteArray *)Tcl_Realloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); + ptr = (ByteArray *) ckrealloc((void *)byteArrayPtr, + BYTEARRAY_SIZE(attempt)); } byteArrayPtr = ptr; byteArrayPtr->allocated = attempt; - SET_BYTEARRAY(irPtr, byteArrayPtr); + SET_BYTEARRAY(objPtr, byteArrayPtr); } if (bytes) { memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, len); } byteArrayPtr->used += len; TclInvalidateStringRep(objPtr); - objPtr->typePtr = &properByteArrayType; -} - -/* - *---------------------------------------------------------------------- - * - * TclInitBinaryCmd -- - * - * This function is called to create the "binary" Tcl command. See the - * user documentation for details on what it does. - * - * Results: - * A command token for the new command. - * - * Side effects: - * Creates a new binary command as a mapped ensemble. - * - *---------------------------------------------------------------------- - */ - -Tcl_Command -TclInitBinaryCmd( - Tcl_Interp *interp) -{ - Tcl_Command binaryEnsemble; - - binaryEnsemble = TclMakeEnsemble(interp, "binary", binaryMap); - TclMakeEnsemble(interp, "binary encode", encodeMap); - TclMakeEnsemble(interp, "binary decode", decodeMap); - return binaryEnsemble; -} - -/* - *---------------------------------------------------------------------- - * - * BinaryFormatCmd -- - * - * This procedure implements the "binary format" Tcl command. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * 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. */ - size_t 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; - size_t length; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg ...?"); - return TCL_ERROR; - } - - /* - * To avoid copying the data, we format the string in two passes. The - * first pass computes the size of the output buffer. The second pass - * places the formatted data into the buffer. - */ - - format = TclGetString(objv[1]); - arg = 2; - offset = 0; - length = 0; - while (*format != '\0') { - str = format; - flags = 0; - if (!GetFormatSpec(&format, &cmd, &count, &flags)) { - break; - } - switch (cmd) { - case 'a': - case 'A': - case 'b': - case 'B': - case 'h': - case 'H': - /* - * For string-type specifiers, the count corresponds to the number - * of bytes in a single argument. - */ - - if (arg >= objc) { - goto badIndex; - } - if (count == BINARY_ALL) { - (void)TclGetByteArrayFromObj(objv[arg], &count); - } else if (count == BINARY_NOCOUNT) { - count = 1; - } - arg++; - if (cmd == 'a' || cmd == 'A') { - offset += count; - } else if (cmd == 'b' || cmd == 'B') { - offset += (count + 7) / 8; - } else { - offset += (count + 1) / 2; - } - break; - case 'c': - size = 1; - goto doNumbers; - case 't': - case 's': - case 'S': - size = 2; - goto doNumbers; - case 'n': - case 'i': - case 'I': - size = 4; - goto doNumbers; - case 'm': - case 'w': - case 'W': - size = 8; - goto doNumbers; - case 'r': - case 'R': - case 'f': - size = sizeof(float); - goto doNumbers; - case 'q': - case 'Q': - case 'd': - size = sizeof(double); - - doNumbers: - if (arg >= objc) { - goto badIndex; - } - - /* - * For number-type specifiers, the count corresponds to the number - * of elements in the list stored in a single argument. If no - * count is specified, then the argument is taken as a single - * non-list value. - */ - - if (count == BINARY_NOCOUNT) { - arg++; - count = 1; - } else { - int listc; - Tcl_Obj **listv; - - /* - * The macro evals its args more than once: avoid arg++ - */ - - if (TclListObjGetElements(interp, objv[arg], &listc, - &listv) != TCL_OK) { - return TCL_ERROR; - } - arg++; - - if (count == BINARY_ALL) { - count = listc; - } else if (count > (size_t)listc) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "number of elements in list does not match count", - -1)); - return TCL_ERROR; - } - } - offset += count*size; - break; - - case 'x': - if (count == BINARY_ALL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot use \"*\" in format string with \"x\"", -1)); - return TCL_ERROR; - } else if (count == BINARY_NOCOUNT) { - count = 1; - } - offset += count; - break; - case 'X': - if (count == BINARY_NOCOUNT) { - count = 1; - } - if ((count > (size_t)offset) || (count == BINARY_ALL)) { - count = offset; - } - if (offset > (int)length) { - length = offset; - } - offset -= count; - break; - case '@': - if (offset > (int)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 > (int)length) { - length = offset; - } - if (length == 0) { - return TCL_OK; - } - - /* - * Prepare the result object by preallocating the caclulated number of - * bytes and filling with nulls. - */ - - TclNewObj(resultPtr); - buffer = Tcl_SetByteArrayLength(resultPtr, length); - memset(buffer, 0, length); - - /* - * Pack the data into the result object. Note that we can skip the error - * checking during this pass, since we have already parsed the string - * once. - */ - - arg = 2; - format = TclGetString(objv[1]); - cursor = buffer; - maxPos = cursor; - while (*format != 0) { - flags = 0; - if (!GetFormatSpec(&format, &cmd, &count, &flags)) { - break; - } - if ((count == 0) && (cmd != '@')) { - if (cmd != 'x') { - arg++; - } - continue; - } - switch (cmd) { - case 'a': - case 'A': { - char pad = (char) (cmd == 'a' ? '\0' : ' '); - unsigned char *bytes; - - bytes = TclGetByteArrayFromObj(objv[arg], &length); - arg++; - if (count == BINARY_ALL) { - count = length; - } else if (count == BINARY_NOCOUNT) { - count = 1; - } - if (length >= count) { - memcpy(cursor, bytes, count); - } else { - memcpy(cursor, bytes, length); - memset(cursor + length, pad, count - length); - } - cursor += count; - break; - } - case 'b': - case 'B': { - unsigned char *last; - - str = TclGetStringFromObj(objv[arg], &length); - arg++; - if (count == BINARY_ALL) { - count = length; - } else if (count == BINARY_NOCOUNT) { - count = 1; - } - last = cursor + ((count + 7) / 8); - if (count > length) { - count = length; - } - value = 0; - errorString = "binary"; - if (cmd == 'B') { - for (offset = 0; (size_t)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; (size_t)offset < count; offset++) { - value >>= 1; - if (str[offset] == '1') { - value |= 128; - } else if (str[offset] != '0') { - errorValue = str; - Tcl_DecrRefCount(resultPtr); - goto badValue; - } - if (!((offset + 1) % 8)) { - *cursor++ = UCHAR(value); - value = 0; - } - } - } - if ((offset % 8) != 0) { - if (cmd == 'B') { - value <<= 8 - (offset % 8); - } else { - value >>= 8 - (offset % 8); - } - *cursor++ = UCHAR(value); - } - while (cursor < last) { - *cursor++ = '\0'; - } - break; - } - case 'h': - case 'H': { - unsigned char *last; - int c; - - str = TclGetStringFromObj(objv[arg], &length); - arg++; - if (count == BINARY_ALL) { - count = length; - } else if (count == BINARY_NOCOUNT) { - count = 1; - } - last = cursor + ((count + 1) / 2); - if (count > length) { - count = length; - } - value = 0; - errorString = "hexadecimal"; - if (cmd == 'H') { - for (offset = 0; (size_t)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; (size_t)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; - } else { - value >>= 4; - } - *cursor++ = UCHAR(value); - } - - while (cursor < last) { - *cursor++ = '\0'; - } - break; - } - case 'c': - case 't': - case 's': - case 'S': - case 'n': - case 'i': - case 'I': - case 'm': - case 'w': - case 'W': - case 'r': - case 'R': - case 'd': - case 'q': - case 'Q': - case 'f': { - int listc, i; - Tcl_Obj **listv; - - if (count == BINARY_NOCOUNT) { - /* - * Note that we are casting away the const-ness of objv, but - * this is safe since we aren't going to modify the array. - */ - - listv = (Tcl_Obj **) (objv + arg); - listc = 1; - count = 1; - } else { - TclListObjGetElements(interp, objv[arg], &listc, &listv); - if (count == BINARY_ALL) { - count = listc; - } - } - arg++; - for (i = 0; (size_t)i < count; i++) { - if (FormatNumber(interp, cmd, listv[i], &cursor) != TCL_OK) { - Tcl_DecrRefCount(resultPtr); - return TCL_ERROR; - } - } - break; - } - case 'x': - if (count == BINARY_NOCOUNT) { - count = 1; - } - memset(cursor, 0, count); - cursor += count; - break; - case 'X': - if (cursor > maxPos) { - maxPos = cursor; - } - if (count == BINARY_NOCOUNT) { - count = 1; - } - if ((count == BINARY_ALL) || (count > (size_t)(cursor - buffer))) { - cursor = buffer; - } else { - cursor -= count; - } - break; - case '@': - if (cursor > maxPos) { - maxPos = cursor; - } - if (count == BINARY_ALL) { - cursor = maxPos; - } else { - cursor = buffer + count; - } - break; - } - } - Tcl_SetObjResult(interp, resultPtr); - return TCL_OK; - - badValue: - Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "expected %s string but got \"%s\" instead", - errorString, errorValue)); - return TCL_ERROR; - - badCount: - errorString = "missing count for \"@\" field specifier"; - goto error; - - 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; - } - - error: - Tcl_SetObjResult(interp, Tcl_NewStringObj(errorString, -1)); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * BinaryScanCmd -- - * - * This procedure implements the "binary scan" Tcl command. +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_BinaryObjCmd -- + * + * This procedure implements the "binary" Tcl command. * * Results: * A standard Tcl result. * * Side effects: @@ -1471,360 +653,822 @@ * *---------------------------------------------------------------------- */ int -BinaryScanCmd( - TCL_UNUSED(ClientData), +Tcl_BinaryObjCmd( + ClientData dummy, /* Not used. */ 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. */ - size_t count; /* Count associated with current format + int count; /* Count associated with current format * character. */ int flags; /* Format field flags */ - const char *format; /* Pointer to current position in format + 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, i; - size_t length = 0; - - 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 = TclGetByteArrayFromObj(objv[1], &length); - format = TclGetString(objv[2]); - arg = 3; - offset = 0; - while (*format != '\0') { - str = format; - flags = 0; - if (!GetFormatSpec(&format, &cmd, &count, &flags)) { - goto done; - } - switch (cmd) { - case 'a': - case 'A': { - unsigned char *src; - - if (arg >= objc) { - DeleteScanNumberCache(numberCachePtr); - goto badIndex; - } - 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; - - /* - * Trim trailing nulls and spaces, if necessary. - */ - - if (cmd == 'A') { - while (size > 0) { - if (src[size - 1] != '\0' && src[size - 1] != ' ') { - break; - } - size--; - } - } - - /* - * Have to do this #ifdef-fery because (as part of defining - * Tcl_NewByteArrayObj) we removed the #def that hides this stuff - * normally. If this code ever gets copied to another file, it - * should be changed back to the simpler version. - */ - -#ifdef TCL_MEM_DEBUG - valuePtr = Tcl_DbNewByteArrayObj(src, size, __FILE__, __LINE__); -#else - valuePtr = Tcl_NewByteArrayObj(src, size); -#endif /* TCL_MEM_DEBUG */ - - resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, - TCL_LEAVE_ERR_MSG); - arg++; - if (resultPtr == NULL) { - DeleteScanNumberCache(numberCachePtr); - return TCL_ERROR; - } - offset += count; - break; - } - case 'b': - case 'B': { - unsigned char *src; - char *dest; - - if (arg >= objc) { - DeleteScanNumberCache(numberCachePtr); - goto badIndex; - } - if (count == BINARY_ALL) { - count = (length - offset) * 8; - } else { - if (count == BINARY_NOCOUNT) { - count = 1; - } - if (count > (size_t)(length - offset) * 8) { - goto done; - } - } - src = buffer + offset; - TclNewObj(valuePtr); - Tcl_SetObjLength(valuePtr, count); - dest = TclGetString(valuePtr); - - if (cmd == 'b') { - for (i = 0; (size_t)i < count; i++) { - if (i % 8) { - value >>= 1; - } else { - value = *src++; - } - *dest++ = (char) ((value & 1) ? '1' : '0'); - } - } else { - for (i = 0; (size_t)i < count; i++) { - if (i % 8) { - value <<= 1; - } else { - value = *src++; - } - *dest++ = (char) ((value & 0x80) ? '1' : '0'); - } - } - - resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, - TCL_LEAVE_ERR_MSG); - arg++; - if (resultPtr == NULL) { - DeleteScanNumberCache(numberCachePtr); - return TCL_ERROR; - } - offset += (count + 7) / 8; - break; - } - case 'h': - case 'H': { - char *dest; - unsigned char *src; - static const char hexdigit[] = "0123456789abcdef"; - - if (arg >= objc) { - DeleteScanNumberCache(numberCachePtr); - goto badIndex; - } - if (count == BINARY_ALL) { - count = (length - offset)*2; - } else { - if (count == BINARY_NOCOUNT) { - count = 1; - } - if (count > (length - offset)*2) { - goto done; - } - } - src = buffer + offset; - TclNewObj(valuePtr); - Tcl_SetObjLength(valuePtr, count); - dest = TclGetString(valuePtr); - - if (cmd == 'h') { - for (i = 0; (size_t)i < count; i++) { - if (i % 2) { - value >>= 4; - } else { - value = *src++; - } - *dest++ = hexdigit[value & 0xF]; - } - } else { - for (i = 0; (size_t)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) { - DeleteScanNumberCache(numberCachePtr); - return TCL_ERROR; - } - offset += (count + 1) / 2; - break; - } - case 'c': - size = 1; - goto scanNumber; - case 't': - case 's': - case 'S': - size = 2; - goto scanNumber; - case 'n': - case 'i': - case 'I': - size = 4; - goto scanNumber; - case 'm': - case 'w': - case 'W': - size = 8; - goto scanNumber; - case 'r': - case 'R': - case 'f': - size = sizeof(float); - goto scanNumber; - case 'q': - case 'Q': - case 'd': { - unsigned char *src; - - size = sizeof(double); - /* fall through */ - - scanNumber: - if (arg >= objc) { - DeleteScanNumberCache(numberCachePtr); - goto badIndex; - } - if (count == BINARY_NOCOUNT) { - if ((length - offset) < (size_t)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; - } - TclNewObj(valuePtr); - src = buffer + offset; - for (i = 0; (size_t)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 > (size_t)offset)) { - offset = 0; - } else { - offset -= count; - } - break; - case '@': - if (count == BINARY_NOCOUNT) { - DeleteScanNumberCache(numberCachePtr); - goto badCount; - } - if ((count == BINARY_ALL) || (count > length)) { - offset = length; - } else { - offset = count; - } - break; - default: - DeleteScanNumberCache(numberCachePtr); - errorString = str; - goto badField; - } - } - - /* - * Set the result to the last position of the cursor. - */ - - done: - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(arg - 3)); - DeleteScanNumberCache(numberCachePtr); - - return TCL_OK; - - badCount: - errorString = "missing count for \"@\" field specifier"; - goto error; - - 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; - } - - error: - Tcl_SetObjResult(interp, Tcl_NewStringObj(errorString, -1)); + unsigned char *cursor; /* Current position within result buffer. */ + unsigned char *maxPos; /* Greatest position within result buffer that + * cursor has visited.*/ + const char *errorString; + char *errorValue, *str; + int offset, size, length, index; + static const char *options[] = { + "format", "scan", NULL + }; + enum options { + BINARY_FORMAT, BINARY_SCAN + }; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); + return TCL_ERROR; + } + + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + switch ((enum options) index) { + case BINARY_FORMAT: + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "formatString ?arg arg ...?"); + return TCL_ERROR; + } + + /* + * To avoid copying the data, we format the string in two passes. The + * first pass computes the size of the output buffer. The second pass + * places the formatted data into the buffer. + */ + + format = TclGetString(objv[2]); + arg = 3; + offset = 0; + length = 0; + while (*format != '\0') { + str = format; + flags = 0; + if (!GetFormatSpec(&format, &cmd, &count, &flags)) { + break; + } + switch (cmd) { + case 'a': + case 'A': + case 'b': + case 'B': + case 'h': + case 'H': + /* + * For string-type specifiers, the count corresponds to the + * number 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') { + offset += (count + 7) / 8; + } else { + offset += (count + 1) / 2; + } + break; + case 'c': + size = 1; + goto doNumbers; + case 't': + case 's': + case 'S': + size = 2; + goto doNumbers; + case 'n': + case 'i': + case 'I': + size = 4; + goto doNumbers; + case 'm': + case 'w': + case 'W': + size = 8; + goto doNumbers; + case 'r': + case 'R': + case 'f': + size = sizeof(float); + goto doNumbers; + case 'q': + case 'Q': + case 'd': + size = sizeof(double); + + doNumbers: + if (arg >= objc) { + goto badIndex; + } + + /* + * For number-type specifiers, the count corresponds to the + * number of elements in the list stored in a single argument. + * If no count is specified, then the argument is taken as a + * single non-list value. + */ + + if (count == BINARY_NOCOUNT) { + arg++; + count = 1; + } else { + int listc; + Tcl_Obj **listv; + + /* The macro evals its args more than once: avoid arg++ */ + if (TclListObjGetElements(interp, objv[arg], &listc, + &listv) != TCL_OK) { + return TCL_ERROR; + } + arg++; + + if (count == BINARY_ALL) { + count = listc; + } else if (count > listc) { + Tcl_AppendResult(interp, + "number of elements in list does not match count", + NULL); + return TCL_ERROR; + } + } + offset += count*size; + break; + + case 'x': + if (count == BINARY_ALL) { + Tcl_AppendResult(interp, + "cannot use \"*\" in format string with \"x\"", + NULL); + return TCL_ERROR; + } else if (count == BINARY_NOCOUNT) { + count = 1; + } + 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; + } + + /* + * Prepare the result object by preallocating the caclulated number of + * bytes and filling with nulls. + */ + + resultPtr = Tcl_NewObj(); + buffer = Tcl_SetByteArrayLength(resultPtr, length); + memset(buffer, 0, (size_t) length); + + /* + * Pack the data into the result object. Note that we can skip the + * error checking during this pass, since we have already parsed the + * string once. + */ + + arg = 3; + format = TclGetString(objv[2]); + cursor = buffer; + maxPos = cursor; + while (*format != 0) { + flags = 0; + if (!GetFormatSpec(&format, &cmd, &count, &flags)) { + break; + } + if ((count == 0) && (cmd != '@')) { + if (cmd != 'x') { + arg++; + } + continue; + } + 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, (size_t) count); + } else { + memcpy(cursor, bytes, (size_t) length); + memset(cursor + length, pad, (size_t) (count - length)); + } + cursor += count; + break; + } + case 'b': + case 'B': { + unsigned char *last; + + str = TclGetStringFromObj(objv[arg], &length); + arg++; + if (count == BINARY_ALL) { + count = length; + } else if (count == BINARY_NOCOUNT) { + count = 1; + } + last = cursor + ((count + 7) / 8); + 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++ = (unsigned char) 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; + } + if (!((offset + 1) % 8)) { + *cursor++ = (unsigned char) value; + value = 0; + } + } + } + if ((offset % 8) != 0) { + if (cmd == 'B') { + value <<= 8 - (offset % 8); + } else { + value >>= 8 - (offset % 8); + } + *cursor++ = (unsigned char) value; + } + while (cursor < last) { + *cursor++ = '\0'; + } + break; + } + case 'h': + case 'H': { + unsigned char *last; + int c; + + str = TclGetStringFromObj(objv[arg], &length); + arg++; + if (count == BINARY_ALL) { + count = length; + } else if (count == BINARY_NOCOUNT) { + count = 1; + } + last = cursor + ((count + 1) / 2); + 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++ = (unsigned char)(value & 0xff); + value = 0; + } + } + } + if (offset % 2) { + if (cmd == 'H') { + value <<= 4; + } else { + value >>= 4; + } + *cursor++ = (unsigned char) value; + } + + while (cursor < last) { + *cursor++ = '\0'; + } + break; + } + case 'c': + case 't': + case 's': + case 'S': + case 'n': + case 'i': + case 'I': + case 'm': + case 'w': + case 'W': + case 'r': + case 'R': + case 'd': + case 'q': + case 'Q': + case 'f': { + int listc, i; + Tcl_Obj **listv; + + if (count == BINARY_NOCOUNT) { + /* + * Note that we are casting away the const-ness of objv, + * but this is safe since we aren't going to modify the + * array. + */ + + listv = (Tcl_Obj**)(objv + arg); + listc = 1; + count = 1; + } else { + TclListObjGetElements(interp, objv[arg], &listc, &listv); + if (count == BINARY_ALL) { + count = listc; + } + } + arg++; + for (i = 0; i < count; i++) { + if (FormatNumber(interp, cmd, listv[i], &cursor)!=TCL_OK) { + Tcl_DecrRefCount(resultPtr); + return TCL_ERROR; + } + } + break; + } + case 'x': + if (count == BINARY_NOCOUNT) { + count = 1; + } + memset(cursor, 0, (size_t) count); + cursor += count; + break; + 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) { + maxPos = cursor; + } + if (count == BINARY_ALL) { + cursor = maxPos; + } else { + cursor = buffer + count; + } + break; + } + } + Tcl_SetObjResult(interp, resultPtr); + break; + case BINARY_SCAN: { + int i; + Tcl_Obj *valuePtr, *elementPtr; + Tcl_HashTable numberCacheHash; + Tcl_HashTable *numberCachePtr; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, + "value formatString ?varName varName ...?"); + return TCL_ERROR; + } + numberCachePtr = &numberCacheHash; + Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS); + buffer = Tcl_GetByteArrayFromObj(objv[2], &length); + format = TclGetString(objv[3]); + cursor = buffer; + arg = 4; + offset = 0; + while (*format != '\0') { + str = format; + flags = 0; + if (!GetFormatSpec(&format, &cmd, &count, &flags)) { + goto done; + } + switch (cmd) { + case 'a': + case 'A': { + unsigned char *src; + + if (arg >= objc) { + DeleteScanNumberCache(numberCachePtr); + goto badIndex; + } + 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; + + /* + * Trim trailing nulls and spaces, if necessary. + */ + + if (cmd == 'A') { + while (size > 0) { + if (src[size-1] != '\0' && src[size-1] != ' ') { + break; + } + size--; + } + } + + /* + * Have to do this #ifdef-fery because (as part of defining + * Tcl_NewByteArrayObj) we removed the #def that hides this + * stuff normally. If this code ever gets copied to another + * file, it should be changed back to the simpler version. + */ + +#ifdef TCL_MEM_DEBUG + valuePtr = Tcl_DbNewByteArrayObj(src, size, __FILE__,__LINE__); +#else + valuePtr = Tcl_NewByteArrayObj(src, size); +#endif /* TCL_MEM_DEBUG */ + + resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, + TCL_LEAVE_ERR_MSG); + arg++; + if (resultPtr == NULL) { + DeleteScanNumberCache(numberCachePtr); + return TCL_ERROR; + } + offset += count; + break; + } + case 'b': + case 'B': { + unsigned char *src; + char *dest; + + if (arg >= objc) { + DeleteScanNumberCache(numberCachePtr); + goto badIndex; + } + 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'); + } + } + + resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, + TCL_LEAVE_ERR_MSG); + arg++; + if (resultPtr == NULL) { + DeleteScanNumberCache(numberCachePtr); + return TCL_ERROR; + } + offset += (count + 7) / 8; + break; + } + case 'h': + case 'H': { + char *dest; + unsigned char *src; + int i; + static const char hexdigit[] = "0123456789abcdef"; + + if (arg >= objc) { + DeleteScanNumberCache(numberCachePtr); + goto badIndex; + } + if (count == BINARY_ALL) { + count = (length - offset)*2; + } else { + if (count == BINARY_NOCOUNT) { + count = 1; + } + if (count > (length - offset)*2) { + goto done; + } + } + 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) { + DeleteScanNumberCache(numberCachePtr); + return TCL_ERROR; + } + offset += (count + 1) / 2; + break; + } + case 'c': + size = 1; + goto scanNumber; + case 't': + case 's': + case 'S': + size = 2; + goto scanNumber; + case 'n': + case 'i': + case 'I': + size = 4; + goto scanNumber; + case 'm': + case 'w': + case 'W': + size = 8; + goto scanNumber; + case 'r': + case 'R': + case 'f': + size = sizeof(float); + goto scanNumber; + case 'q': + case 'Q': + case 'd': { + unsigned char *src; + + size = sizeof(double); + /* fall through */ + + 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) { + DeleteScanNumberCache(numberCachePtr); + goto badCount; + } + if ((count == BINARY_ALL) || (count > length)) { + offset = length; + } else { + offset = count; + } + break; + default: + DeleteScanNumberCache(numberCachePtr); + errorString = str; + goto badField; + } + } + + /* + * Set the result to the last position of the cursor. + */ + + done: + Tcl_SetObjResult(interp, Tcl_NewLongObj(arg - 4)); + DeleteScanNumberCache(numberCachePtr); + break; + } + } + return TCL_OK; + + badValue: + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "expected ", errorString, + " string but got \"", errorValue, "\" instead", NULL); + return TCL_ERROR; + + badCount: + errorString = "missing count for \"@\" field specifier"; + goto error; + + badIndex: + errorString = "not enough arguments for all format specifiers"; + goto error; + + badField: + { + Tcl_UniChar ch; + char buf[TCL_UTF_MAX + 1]; + + Tcl_UtfToUniChar(errorString, &ch); + buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; + Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL); + return TCL_ERROR; + } + + error: + Tcl_AppendResult(interp, errorString, NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- @@ -1847,13 +1491,13 @@ *---------------------------------------------------------------------- */ static int GetFormatSpec( - const char **formatPtr, /* Pointer to format string. */ + char **formatPtr, /* Pointer to format string. */ char *cmdPtr, /* Pointer to location of command char. */ - size_t *countPtr, /* Pointer to repeat count value. */ + int *countPtr, /* Pointer to repeat count value. */ int *flagsPtr) /* Pointer to field flags */ { /* * Skip any leading blanks. */ @@ -1876,27 +1520,27 @@ *cmdPtr = **formatPtr; (*formatPtr)++; if (**formatPtr == 'u') { (*formatPtr)++; - *flagsPtr |= BINARY_UNSIGNED; + (*flagsPtr) |= BINARY_UNSIGNED; } if (**formatPtr == '*') { (*formatPtr)++; - *countPtr = BINARY_ALL; + (*countPtr) = BINARY_ALL; } else if (isdigit(UCHAR(**formatPtr))) { /* INTL: digit */ unsigned long int count; errno = 0; - count = strtoul(*formatPtr, (char **) formatPtr, 10); + count = strtoul(*formatPtr, formatPtr, 10); if (errno || (count > (unsigned long) INT_MAX)) { - *countPtr = INT_MAX; + (*countPtr) = INT_MAX; } else { - *countPtr = (int) count; + (*countPtr) = (int) count; } } else { - *countPtr = BINARY_NOCOUNT; + (*countPtr) = BINARY_NOCOUNT; } return 1; } /* @@ -2015,20 +1659,20 @@ static void CopyNumber( const void *from, /* source */ void *to, /* destination */ - size_t length, /* Number of bytes to copy */ + unsigned int length, /* Number of bytes to copy */ int type) /* What type of thing are we copying? */ { switch (NeedReversing(type)) { - case 0: + case 0: memcpy(to, from, length); break; case 1: { - const unsigned char *fromPtr = (const unsigned char *)from; - unsigned char *toPtr = (unsigned char *)to; + const unsigned char *fromPtr = from; + unsigned char *toPtr = to; switch (length) { case 4: toPtr[0] = fromPtr[3]; toPtr[1] = fromPtr[2]; @@ -2047,12 +1691,12 @@ break; } break; } case 2: { - const unsigned char *fromPtr = (const unsigned char *)from; - unsigned char *toPtr = (unsigned char *)to; + const unsigned char *fromPtr = from; + unsigned char *toPtr = to; toPtr[0] = fromPtr[4]; toPtr[1] = fromPtr[5]; toPtr[2] = fromPtr[6]; toPtr[3] = fromPtr[7]; @@ -2061,12 +1705,12 @@ 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; + const unsigned char *fromPtr = from; + unsigned char *toPtr = to; toPtr[0] = fromPtr[3]; toPtr[1] = fromPtr[2]; toPtr[2] = fromPtr[1]; toPtr[3] = fromPtr[0]; @@ -2102,10 +1746,11 @@ * errors. */ int type, /* Type of number to format. */ Tcl_Obj *src, /* Number to format. */ unsigned char **cursorPtr) /* Pointer to index into destination buffer. */ { + long value; double dvalue; Tcl_WideInt wvalue; float fvalue; switch (type) { @@ -2117,15 +1762,14 @@ * returns TCL_ERROR for NaN, but we can check by comparing the * object's type pointer. */ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(src, &tclDoubleType); - if (irPtr == NULL) { + if (src->typePtr != &tclDoubleType) { return TCL_ERROR; } - dvalue = irPtr->doubleValue; + dvalue = src->internalRep.doubleValue; } CopyNumber(&dvalue, *cursorPtr, sizeof(double), type); *cursorPtr += sizeof(double); return TCL_OK; @@ -2137,25 +1781,23 @@ * returns TCL_ERROR for NaN, but we can check by comparing the * object's type pointer. */ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(src, &tclDoubleType); - - if (irPtr == NULL) { + if (src->typePtr != &tclDoubleType) { return TCL_ERROR; } - dvalue = irPtr->doubleValue; + dvalue = src->internalRep.doubleValue; } /* * Because some compilers will generate floating point exceptions on * an overflow cast (e.g. Borland), we restrict the values to the * valid range for float. */ - if (fabs(dvalue) > (double) FLT_MAX) { + if (fabs(dvalue) > (double)FLT_MAX) { fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX; } else { fvalue = (float) dvalue; } CopyNumber(&fvalue, *cursorPtr, sizeof(float), type); @@ -2166,82 +1808,82 @@ * 64-bit integer values. */ case 'w': case 'W': case 'm': - if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, src, &wvalue) != TCL_OK) { return TCL_ERROR; } if (NeedReversing(type)) { - *(*cursorPtr)++ = UCHAR(wvalue); - *(*cursorPtr)++ = UCHAR(wvalue >> 8); - *(*cursorPtr)++ = UCHAR(wvalue >> 16); - *(*cursorPtr)++ = UCHAR(wvalue >> 24); - *(*cursorPtr)++ = UCHAR(wvalue >> 32); - *(*cursorPtr)++ = UCHAR(wvalue >> 40); - *(*cursorPtr)++ = UCHAR(wvalue >> 48); - *(*cursorPtr)++ = UCHAR(wvalue >> 56); + *(*cursorPtr)++ = (unsigned char) wvalue; + *(*cursorPtr)++ = (unsigned char) (wvalue >> 8); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 16); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 24); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 32); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 40); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 48); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 56); } else { - *(*cursorPtr)++ = UCHAR(wvalue >> 56); - *(*cursorPtr)++ = UCHAR(wvalue >> 48); - *(*cursorPtr)++ = UCHAR(wvalue >> 40); - *(*cursorPtr)++ = UCHAR(wvalue >> 32); - *(*cursorPtr)++ = UCHAR(wvalue >> 24); - *(*cursorPtr)++ = UCHAR(wvalue >> 16); - *(*cursorPtr)++ = UCHAR(wvalue >> 8); - *(*cursorPtr)++ = UCHAR(wvalue); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 56); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 48); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 40); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 32); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 24); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 16); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 8); + *(*cursorPtr)++ = (unsigned char) wvalue; } return TCL_OK; /* * 32-bit integer values. */ case 'i': case 'I': case 'n': - if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) { + if (TclGetLongFromObj(interp, src, &value) != TCL_OK) { return TCL_ERROR; } if (NeedReversing(type)) { - *(*cursorPtr)++ = UCHAR(wvalue); - *(*cursorPtr)++ = UCHAR(wvalue >> 8); - *(*cursorPtr)++ = UCHAR(wvalue >> 16); - *(*cursorPtr)++ = UCHAR(wvalue >> 24); + *(*cursorPtr)++ = (unsigned char) value; + *(*cursorPtr)++ = (unsigned char) (value >> 8); + *(*cursorPtr)++ = (unsigned char) (value >> 16); + *(*cursorPtr)++ = (unsigned char) (value >> 24); } else { - *(*cursorPtr)++ = UCHAR(wvalue >> 24); - *(*cursorPtr)++ = UCHAR(wvalue >> 16); - *(*cursorPtr)++ = UCHAR(wvalue >> 8); - *(*cursorPtr)++ = UCHAR(wvalue); + *(*cursorPtr)++ = (unsigned char) (value >> 24); + *(*cursorPtr)++ = (unsigned char) (value >> 16); + *(*cursorPtr)++ = (unsigned char) (value >> 8); + *(*cursorPtr)++ = (unsigned char) value; } return TCL_OK; /* * 16-bit integer values. */ case 's': case 'S': case 't': - if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) { + if (TclGetLongFromObj(interp, src, &value) != TCL_OK) { return TCL_ERROR; } if (NeedReversing(type)) { - *(*cursorPtr)++ = UCHAR(wvalue); - *(*cursorPtr)++ = UCHAR(wvalue >> 8); + *(*cursorPtr)++ = (unsigned char) value; + *(*cursorPtr)++ = (unsigned char) (value >> 8); } else { - *(*cursorPtr)++ = UCHAR(wvalue >> 8); - *(*cursorPtr)++ = UCHAR(wvalue); + *(*cursorPtr)++ = (unsigned char) (value >> 8); + *(*cursorPtr)++ = (unsigned char) value; } return TCL_OK; /* * 8-bit integer values. */ case 'c': - if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) { + if (TclGetLongFromObj(interp, src, &value) != TCL_OK) { return TCL_ERROR; } - *(*cursorPtr)++ = UCHAR(wvalue); + *(*cursorPtr)++ = (unsigned char) value; return TCL_OK; default: Tcl_Panic("unexpected fallthrough"); return TCL_ERROR; @@ -2272,13 +1914,13 @@ ScanNumber( unsigned char *buffer, /* Buffer to scan number from. */ int type, /* Format character from "binary scan" */ int flags, /* Format field flags */ Tcl_HashTable **numberCachePtrPtr) - /* Place to look for cache of scanned value - * objects, or NULL if too many different - * numbers have been scanned. */ + /* Place to look for cache of scanned + * value objects, or NULL if too many + * different numbers have been scanned. */ { long value; float fvalue; double dvalue; Tcl_WideUInt uwvalue; @@ -2342,47 +1984,45 @@ + (((long)buffer[3]) << 24)); } else { value = (long) (buffer[3] + (buffer[2] << 8) + (buffer[1] << 16) - + (((long) buffer[0]) << 24)); + + (((long)buffer[0]) << 24)); } /* * Check to see if the value was sign extended properly on systems * where an int is more than 32-bits. - * * We avoid caching unsigned integers as we cannot distinguish between * 32bit signed and unsigned in the hash (short and char are ok). */ if (flags & BINARY_UNSIGNED) { return Tcl_NewWideIntObj((Tcl_WideInt)(unsigned long)value); } - if ((value & (((unsigned) 1) << 31)) && (value > 0)) { - value -= (((unsigned) 1) << 31); - value -= (((unsigned) 1) << 31); + if ((value & (((unsigned int)1)<<31)) && (value > 0)) { + value -= (((unsigned int)1)<<31); + value -= (((unsigned int)1)<<31); } returnNumericObject: if (*numberCachePtrPtr == NULL) { - return Tcl_NewWideIntObj(value); + return Tcl_NewLongObj(value); } else { - Tcl_HashTable *tablePtr = *numberCachePtrPtr; - Tcl_HashEntry *hPtr; + register Tcl_HashTable *tablePtr = *numberCachePtrPtr; + register Tcl_HashEntry *hPtr; int isNew; hPtr = Tcl_CreateHashEntry(tablePtr, INT2PTR(value), &isNew); if (!isNew) { - return (Tcl_Obj *)Tcl_GetHashValue(hPtr); + return (Tcl_Obj *) Tcl_GetHashValue(hPtr); } if (tablePtr->numEntries <= BINARY_SCAN_MAX_CACHE) { - Tcl_Obj *objPtr; + register Tcl_Obj *objPtr = Tcl_NewLongObj(value); - TclNewIntObj(objPtr, value); Tcl_IncrRefCount(objPtr); - Tcl_SetHashValue(hPtr, objPtr); + Tcl_SetHashValue(hPtr, (ClientData) objPtr); return objPtr; } /* * We've overflowed the cache! Someone's parsing a LOT of varied @@ -2393,11 +2033,11 @@ * cannot trigger this. */ DeleteScanNumberCache(tablePtr); *numberCachePtrPtr = NULL; - return Tcl_NewWideIntObj(value); + return Tcl_NewLongObj(value); } /* * Do not cache wide (64-bit) values; they are already too large to * use as keys. @@ -2427,13 +2067,12 @@ } if (flags & BINARY_UNSIGNED) { Tcl_Obj *bigObj = NULL; mp_int big; - if (mp_init_u64(&big, uwvalue) == MP_OKAY) { - bigObj = Tcl_NewBignumObj(&big); - } + TclBNInitBignumFromWideUInt(&big, uwvalue); + bigObj = Tcl_NewBignumObj(&big); return bigObj; } return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue); /* @@ -2495,830 +2134,22 @@ return; } hEntry = Tcl_FirstHashEntry(numberCachePtr, &search); while (hEntry != NULL) { - Tcl_Obj *value = (Tcl_Obj *)Tcl_GetHashValue(hEntry); + register Tcl_Obj *value = Tcl_GetHashValue(hEntry); if (value != NULL) { Tcl_DecrRefCount(value); } hEntry = Tcl_NextHashEntry(&search); } Tcl_DeleteHashTable(numberCachePtr); } - -/* - * ---------------------------------------------------------------------- - * - * NOTES -- - * - * Some measurements show that it is faster to use a table to to perform - * uuencode and base64 value encoding than to calculate the output (at - * least on intel P4 arch). - * - * Conversely using a lookup table for the decoding is slower than just - * calculating the values. We therefore use the fastest of each method. - * - * Presumably this has to do with the size of the tables. The base64 - * decode table is 255 bytes while the encode table is only 65 bytes. The - * choice likely depends on CPU memory cache sizes. - */ - -/* - *---------------------------------------------------------------------- - * - * BinaryEncodeHex -- - * - * Implement the [binary encode hex] binary encoding. clientData must be - * a table to convert values to hexadecimal digits. - * - * Results: - * Interp result set to an encoded byte array object - * - * Side effects: - * 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; - size_t offset = 0, count = 0; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "data"); - return TCL_ERROR; - } - - TclNewObj(resultObj); - data = TclGetByteArrayFromObj(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; -} - -/* - *---------------------------------------------------------------------- - * - * BinaryDecodeHex -- - * - * Implement the [binary decode hex] binary encoding. - * - * Results: - * Interp result set to an decoded byte array object - * - * Side effects: - * 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, pure = 1, strict = 0; - size_t 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 + 1) / 2; - begin = cursor = Tcl_SetByteArrayLength(resultObj, size); - while (data < dataend) { - value = 0; - for (i = 0 ; i < 2 ; i++) { - if (data >= dataend) { - value <<= 4; - break; - } - - c = *data++; - if (!isxdigit(UCHAR(c))) { - if (strict || !TclIsSpaceProc(c)) { - goto badChar; - } - i--; - continue; - } - - value <<= 4; - 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 %" - TCL_Z_MODIFIER "u", ucs4, ucs4, 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); \ - outindex++; \ - if (maxlen > 0 && cursor != limit) { \ - if (outindex == maxlen) { \ - memcpy(cursor, wrapchar, wrapcharlen); \ - cursor += wrapcharlen; \ - outindex = 0; \ - } \ - } \ - 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"; - size_t wrapcharlen = 1; - int i, index, size, outindex = 0, purewrap = 1; - size_t offset, count = 0; - enum { OPT_MAXLEN, OPT_WRAPCHAR }; - static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL }; - - if (objc < 2 || objc % 2 != 0) { - Tcl_WrongNumArgs(interp, 1, objv, - "?-maxlen len? ?-wrapchar char? data"); - return TCL_ERROR; - } - for (i = 1; i < objc - 1; i += 2) { - if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option", - TCL_EXACT, &index) != TCL_OK) { - return TCL_ERROR; - } - switch (index) { - case OPT_MAXLEN: - if (Tcl_GetIntFromObj(interp, objv[i + 1], &maxlen) != TCL_OK) { - return TCL_ERROR; - } - if (maxlen < 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "line length out of range", -1)); - Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", - "LINE_LENGTH", NULL); - return TCL_ERROR; - } - break; - case OPT_WRAPCHAR: - wrapchar = (const char *)TclGetBytesFromObj(NULL, - objv[i + 1], &wrapcharlen); - if (wrapchar == NULL) { - purewrap = 0; - wrapchar = TclGetStringFromObj(objv[i + 1], &wrapcharlen); - } - break; - } - } - if (wrapcharlen == 0) { - maxlen = 0; - } - - TclNewObj(resultObj); - data = TclGetByteArrayFromObj(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; -} -#undef OUTPUT - -/* - *---------------------------------------------------------------------- - * - * BinaryEncodeUu -- - * - * This implements the uuencode binary encoding. Input is broken into 6 - * bit chunks and a lookup table is used to turn these values into output - * characters. This differs from the generic code above in that line - * lengths are also encoded. - * - * Results: - * Interp result set to an encoded byte array object - * - * Side effects: - * 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 rawLength, n, i, bits, index; - int lineLength = 61; - const unsigned char SingleNewline[] = { UCHAR('\n') }; - const unsigned char *wrapchar = SingleNewline; - size_t j, offset, count = 0, 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; - size_t numBytes = wrapcharlen; - - while (numBytes) { - switch (*p) { - case '\t': - case '\v': - case '\f': - case '\r': - p++; numBytes--; - continue; - case '\n': - numBytes--; - break; - default: - badwrap: - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "invalid wrapchar; will defeat decoding", - -1)); - Tcl_SetErrorCode(interp, "TCL", "BINARY", - "ENCODE", "WRAPCHAR", NULL); - return TCL_ERROR; - } - } - if (numBytes) { - goto badwrap; - } - } - break; - } - } - - /* - * Allocate the buffer. This is a little bit too long, but is "good - * enough". - */ - - TclNewObj(resultObj); - offset = 0; - data = TclGetByteArrayFromObj(objv[objc - 1], &count); - rawLength = (lineLength - 1) * 3 / 4; - start = cursor = Tcl_SetByteArrayLength(resultObj, - (lineLength + wrapcharlen) * - ((count + (rawLength - 1)) / rawLength)); - n = bits = 0; - - /* - * Encode the data. Each output line first has the length of raw data - * encoded by the output line described in it by one encoded byte, then - * the encoded data follows (encoding each 6 bits as one character). - * Encoded lines are always terminated by a newline. - */ - - while (offset < count) { - int lineLen = count - offset; - - if (lineLen > rawLength) { - 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]; - } - } - - /* - * Fix the length of the output bytearray. - */ - - Tcl_SetByteArrayLength(resultObj, cursor - start); - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * BinaryDecodeUu -- - * - * Decode a uuencoded string. - * - * Results: - * Interp result set to an byte array object - * - * Side effects: - * 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, pure = 1, strict = 0, lineLen; - size_t size, count = 0; - 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 - * number of data bytes we expect to generate from the line) we're - * processing this time round if it is not already known (i.e., when the - * lineLen variable is set to the magic value, -1). - */ - - while (data < dataend) { - char d[4] = {0, 0, 0, 0}; - - if (lineLen < 0) { - c = *data++; - 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++) { - if (data < dataend) { - d[i] = c = *data++; - if (c < 32 || c > 96) { - if (strict) { - if (!TclIsSpaceProc(c)) { - goto badUu; - } else if (c == '\n') { - goto shortUu; - } - } - i--; - continue; - } - } - } - - /* - * 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 - * newline. - */ - - if (lineLen == 0 && data < dataend) { - lineLen = -1; - do { - c = *data++; - if (c == '\n') { - break; - } else if (c >= 32 && c <= 96) { - data--; - break; - } else if (strict || !TclIsSpaceProc(c)) { - goto badUu; - } - } while (data < dataend); - } - } - - /* - * Sanity check, clean up and finish. - */ - - if (lineLen > 0 && strict) { - goto shortUu; - } - Tcl_SetByteArrayLength(resultObj, cursor - begin); - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; - - shortUu: - Tcl_SetObjResult(interp, Tcl_ObjPrintf("short uuencode data")); - Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "SHORT", 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 %" - TCL_Z_MODIFIER "u", ucs4, ucs4, data - datastart - 1)); - Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL); - TclDecrRefCount(resultObj); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * BinaryDecode64 -- - * - * Decode a base64 encoded string. - * - * Results: - * Interp result set to an byte array object - * - * Side effects: - * 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, cut = 0; - size_t size, 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; - - /* - * Decode the current block. Each base64 block consists of four input - * characters A-Z, a-z, 0-9, +, or /. Each character supplies six bits - * of output data, so each block's output is 24 bits (three bytes) in - * length. The final block can be shorter by one or two bytes, denoted - * by the input ending with one or two ='s, respectively. - */ - - for (i = 0; i < 4; i++) { - /* - * Get the next input character. At end of input, pad with at most - * two ='s. If more than two ='s would be needed, instead discard - * the block read thus far. - */ - - if (data < dataend) { - c = *data++; - } else if (i > 1) { - c = '='; - } else { - if (strict && i <= 1) { - /* - * Single resp. unfulfilled char (each 4th next single - * char) is rather bad64 error case in strict mode. - */ - - goto bad64; - } - cut += 3; - break; - } - - /* - * Load the character into the block value. Handle ='s specially - * because they're only valid as the last character or two of the - * final block of input. Unless strict mode is enabled, skip any - * 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 %" - TCL_Z_MODIFIER "u", ucs4, ucs4, 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: */ Index: generic/tclCkalloc.c ================================================================== --- generic/tclCkalloc.c +++ generic/tclCkalloc.c @@ -18,32 +18,26 @@ #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 { - size_t refCount; /* Number of mem_headers referencing this +typedef struct MemTag { + int refCount; /* Number of mem_headers referencing this * tag. */ - char string[1]; /* Actual size of string will be as large as + char string[4]; /* Actual size of string will be as large as * needed for actual tag. This must be the * last field in the structure. */ } MemTag; -#define TAG_SIZE(bytesInString) ((offsetof(MemTag, string) + 1) + bytesInString) +#define TAG_SIZE(bytesInString) ((unsigned) sizeof(MemTag) + bytesInString - 3) static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set * by "memory tag" command). */ /* @@ -50,18 +44,18 @@ * One of the following structures is allocated just before each dynamically * allocated chunk of memory, both to record information about the chunk and * to help detect chunk under-runs. */ -#define LOW_GUARD_SIZE (8 + (32 - (sizeof(size_t) + sizeof(int)))%8) +#define LOW_GUARD_SIZE (8 + (32 - (sizeof(long) + sizeof(int)))%8) struct mem_header { struct mem_header *flink; struct mem_header *blink; MemTag *tagPtr; /* Tag from "memory tag" command; may be * NULL. */ - const char *file; - size_t length; + CONST char *file; + long length; int line; unsigned char low_guard[LOW_GUARD_SIZE]; /* Aligns body on 8-byte boundary, plus * provides at least 8 additional guard bytes * to detect underruns. */ @@ -87,18 +81,18 @@ */ #define BODY_OFFSET \ ((size_t) (&((struct mem_header *) 0)->body)) -static unsigned int total_mallocs = 0; -static unsigned int total_frees = 0; +static int total_mallocs = 0; +static int total_frees = 0; static size_t current_bytes_malloced = 0; static size_t maximum_bytes_malloced = 0; -static unsigned int current_malloc_packets = 0; -static unsigned int maximum_malloc_packets = 0; -static unsigned int break_on_malloc = 0; -static unsigned int trace_on_at_malloc = 0; +static int current_malloc_packets = 0; +static int maximum_malloc_packets = 0; +static int break_on_malloc = 0; +static int trace_on_at_malloc = 0; static int alloc_tracing = FALSE; static int init_malloced_bodies = TRUE; #ifdef MEM_VALIDATE static int validate_memory = TRUE; #else @@ -119,37 +113,35 @@ * 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 Tcl_Alloc... + * 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 int CheckmemCmd(ClientData clientData, Tcl_Interp *interp, + int argc, CONST char *argv[]); +static int MemoryCmd(ClientData clientData, Tcl_Interp *interp, + int argc, CONST char *argv[]); static void ValidateMemory(struct mem_header *memHeaderP, - const char *file, int line, int nukeGuards); + 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. + * TclInitSubsystems. * *---------------------------------------------------------------------- */ void @@ -156,11 +148,11 @@ TclInitDbCkalloc(void) { if (!ckallocInit) { ckallocInit = 1; ckallocMutexPtr = Tcl_GetAllocMutex(); -#if !TCL_THREADS +#ifndef TCL_THREADS /* Silence compiler warning */ (void)ckallocMutexPtr; #endif } } @@ -174,32 +166,28 @@ * *---------------------------------------------------------------------- */ int -TclDumpMemoryInfo( - ClientData clientData, - int flags) +TclDumpMemoryInfo(ClientData clientData, int flags) { char buf[1024]; - if (clientData == NULL) { - return 0; - } + if (clientData == NULL) { return 0; } sprintf(buf, - "total mallocs %10u\n" - "total frees %10u\n" - "current packets allocated %10u\n" - "current bytes allocated %10" TCL_Z_MODIFIER "u\n" - "maximum packets allocated %10u\n" - "maximum bytes allocated %10" TCL_Z_MODIFIER "u\n", + "total mallocs %10d\n" + "total frees %10d\n" + "current packets allocated %10d\n" + "current bytes allocated %10lu\n" + "maximum packets allocated %10d\n" + "maximum bytes allocated %10lu\n", total_mallocs, total_frees, current_malloc_packets, - current_bytes_malloced, + (unsigned long)current_bytes_malloced, maximum_malloc_packets, - maximum_bytes_malloced); + (unsigned long)maximum_bytes_malloced); if (flags == 0) { fprintf((FILE *)clientData, "%s", buf); } else { /* Assume objPtr to append to */ Tcl_AppendToObj((Tcl_Obj *) clientData, buf, -1); @@ -226,11 +214,11 @@ static void ValidateMemory( struct mem_header *memHeaderP, /* Memory chunk to validate */ - const char *file, /* File containing the call to + CONST char *file, /* File containing the call to * Tcl_ValidateAllMemory */ int line, /* Line number of call to * Tcl_ValidateAllMemory */ int nukeGuards) /* If non-zero, indicates that the memory * guards are to be reset to 0 after they have @@ -244,21 +232,21 @@ 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 %" TCL_Z_MODIFIER "u is 0x%x \t%c\n", idx, byte, + 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(stderr, 0); - fprintf(stderr, "low guard failed at %p, %s %d\n", - memHeaderP->body, file, line); + TclDumpMemoryInfo((ClientData) stderr, 0); + fprintf(stderr, "low guard failed at %lx, %s %d\n", + (long unsigned int) 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, + fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length, memHeaderP->file, memHeaderP->line); Tcl_Panic("Memory validation failure"); } hiPtr = (unsigned char *)memHeaderP->body + memHeaderP->length; @@ -265,22 +253,22 @@ for (idx = 0; idx < HIGH_GUARD_SIZE; idx++) { byte = *(hiPtr + idx); if (byte != GUARD_VALUE) { guard_failed = TRUE; fflush(stdout); - byte &= 0xFF; - fprintf(stderr, "hi guard byte %" TCL_Z_MODIFIER "u is 0x%x \t%c\n", idx, byte, + 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(stderr, 0); - fprintf(stderr, "high guard failed at %p, %s %d\n", - memHeaderP->body, file, line); + TclDumpMemoryInfo((ClientData) stderr, 0); + fprintf(stderr, "high guard failed at %lx, %s %d\n", + (long unsigned int) memHeaderP->body, file, line); fflush(stderr); /* In case name pointer is bad. */ - fprintf(stderr, "%" TCL_Z_MODIFIER "u bytes allocated at (%s %d)\n", + fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length, memHeaderP->file, memHeaderP->line); Tcl_Panic("Memory validation failure"); } @@ -307,11 +295,11 @@ *---------------------------------------------------------------------- */ void Tcl_ValidateAllMemory( - const char *file, /* File from which Tcl_ValidateAllMemory was + CONST char *file, /* File from which Tcl_ValidateAllMemory was * called. */ int line) /* Line number of call to * Tcl_ValidateAllMemory */ { struct mem_header *memScanP; @@ -341,11 +329,11 @@ *---------------------------------------------------------------------- */ int Tcl_DumpActiveMemory( - const char *fileName) /* Name of the file to write info to */ + CONST char *fileName) /* Name of the file to write info to */ { FILE *fileP; struct mem_header *memScanP; char *address; @@ -358,13 +346,14 @@ } } Tcl_MutexLock(ckallocMutexPtr); for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) { - address = &memScanP->body[0]; - fprintf(fileP, "%p - %p %" TCL_Z_MODIFIER "u @ %s %d %s", - address, address + memScanP->length - 1, + address = &memScanP->body [0]; + fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s", + (long unsigned int) address, + (long unsigned int) address + memScanP->length - 1, memScanP->length, memScanP->file, memScanP->line, (memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string); (void) fputc('\n', fileP); } Tcl_MutexUnlock(ckallocMutexPtr); @@ -376,29 +365,29 @@ } /* *---------------------------------------------------------------------- * - * Tcl_DbCkalloc - debugging Tcl_Alloc + * 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 Tcl_Alloc macro; it uses the preprocessor autodefines __FILE__ + * by the ckalloc macro; it uses the preprocessor autodefines __FILE__ * and __LINE__. * *---------------------------------------------------------------------- */ -void * +char * Tcl_DbCkalloc( - size_t size, - const char *file, + unsigned int size, + CONST char *file, int line) { struct mem_header *result = NULL; if (validate_memory) { @@ -405,17 +394,17 @@ 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 + + result = (struct mem_header *) TclpAlloc((unsigned)size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); } if (result == NULL) { fflush(stdout); - TclDumpMemoryInfo(stderr, 0); - Tcl_Panic("unable to alloc %" TCL_Z_MODIFIER "u bytes, %s line %d", size, file, line); + 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 @@ -449,26 +438,30 @@ allocHead = result; total_mallocs++; if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) { (void) fflush(stdout); - fprintf(stderr, "reached malloc trace enable point (%u)\n", + fprintf(stderr, "reached malloc trace enable point (%d)\n", total_mallocs); fflush(stderr); alloc_tracing = TRUE; trace_on_at_malloc = 0; } if (alloc_tracing) { - fprintf(stderr,"Tcl_Alloc %p %" TCL_Z_MODIFIER "u %s %d\n", - result->body, size, file, line); + fprintf(stderr,"ckalloc %lx %u %s %d\n", + (long unsigned int) 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); + fprintf(stderr,"reached malloc break limit (%d)\n", + total_mallocs); + fprintf(stderr, "program will now enter C debugger\n"); + (void) fflush(stderr); + abort(); } current_malloc_packets++; if (current_malloc_packets > maximum_malloc_packets) { maximum_malloc_packets = current_malloc_packets; @@ -481,14 +474,14 @@ Tcl_MutexUnlock(ckallocMutexPtr); return result->body; } -void * +char * Tcl_AttemptDbCkalloc( - size_t size, - const char *file, + unsigned int size, + CONST char *file, int line) { struct mem_header *result = NULL; if (validate_memory) { @@ -495,16 +488,16 @@ 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 + + result = (struct mem_header *) TclpAlloc((unsigned)size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); } if (result == NULL) { fflush(stdout); - TclDumpMemoryInfo(stderr, 0); + TclDumpMemoryInfo((ClientData) stderr, 0); return NULL; } /* * Fill in guard zones and size. Also initialize the contents of the block @@ -546,18 +539,22 @@ alloc_tracing = TRUE; trace_on_at_malloc = 0; } if (alloc_tracing) { - fprintf(stderr,"Tcl_Alloc %p %" TCL_Z_MODIFIER "u %s %d\n", - result->body, size, file, line); + fprintf(stderr,"ckalloc %lx %u %s %d\n", + (long unsigned int) 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); + fprintf(stderr,"reached malloc break limit (%d)\n", + total_mallocs); + fprintf(stderr, "program will now enter C debugger\n"); + (void) fflush(stderr); + abort(); } current_malloc_packets++; if (current_malloc_packets > maximum_malloc_packets) { maximum_malloc_packets = current_malloc_packets; @@ -573,29 +570,29 @@ } /* *---------------------------------------------------------------------- * - * Tcl_DbCkfree - debugging Tcl_Free + * 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 Tcl_Free macro; it uses the preprocessor autodefines __FILE__ and + * by the ckfree macro; it uses the preprocessor autodefines __FILE__ and * __LINE__. * *---------------------------------------------------------------------- */ void Tcl_DbCkfree( - void *ptr, - const char *file, + char *ptr, + CONST char *file, int line) { struct mem_header *memp; if (ptr == NULL) { @@ -611,31 +608,32 @@ */ memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); if (alloc_tracing) { - fprintf(stderr, "Tcl_Free %p %" TCL_Z_MODIFIER "u %s %d\n", - memp->body, memp->length, file, line); + fprintf(stderr, "ckfree %lx %ld %s %d\n", + (long unsigned int) 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); + memset(ptr, GUARD_VALUE, (size_t) 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); + memp->tagPtr->refCount--; + if ((memp->tagPtr->refCount == 0) && (curTagPtr != memp->tagPtr)) { + TclpFree((char *) memp->tagPtr); } } /* * Delink from allocated list @@ -648,36 +646,36 @@ memp->blink->flink = memp->flink; } if (allocHead == memp) { allocHead = memp->flink; } - TclpFree(memp); + TclpFree((char *) memp); Tcl_MutexUnlock(ckallocMutexPtr); } /* *-------------------------------------------------------------------- * - * Tcl_DbCkrealloc - debugging Tcl_Realloc + * 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. * *-------------------------------------------------------------------- */ -void * +char * Tcl_DbCkrealloc( - void *ptr, - size_t size, - const char *file, + char *ptr, + unsigned int size, + CONST char *file, int line) { char *newPtr; - size_t copySize; + unsigned int copySize; struct mem_header *memp; if (ptr == NULL) { return Tcl_DbCkalloc(size, file, line); } @@ -687,28 +685,28 @@ */ memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); copySize = size; - if (copySize > memp->length) { + if (copySize > (unsigned int) memp->length) { copySize = memp->length; } - newPtr = (char *)Tcl_DbCkalloc(size, file, line); - memcpy(newPtr, ptr, copySize); + newPtr = Tcl_DbCkalloc(size, file, line); + memcpy(newPtr, ptr, (size_t) copySize); Tcl_DbCkfree(ptr, file, line); return newPtr; } -void * +char * Tcl_AttemptDbCkrealloc( - void *ptr, - size_t size, - const char *file, + char *ptr, + unsigned int size, + CONST char *file, int line) { char *newPtr; - size_t copySize; + unsigned int copySize; struct mem_header *memp; if (ptr == NULL) { return Tcl_AttemptDbCkalloc(size, file, line); } @@ -718,18 +716,18 @@ */ memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); copySize = size; - if (copySize > memp->length) { + if (copySize > (unsigned int) memp->length) { copySize = memp->length; } - newPtr = (char *)Tcl_AttemptDbCkalloc(size, file, line); + newPtr = Tcl_AttemptDbCkalloc(size, file, line); if (newPtr == NULL) { return NULL; } - memcpy(newPtr, ptr, copySize); + memcpy(newPtr, ptr, (size_t) copySize); Tcl_DbCkfree(ptr, file, line); return newPtr; } @@ -748,42 +746,48 @@ * Same as the debug versions. * *---------------------------------------------------------------------- */ -void * +#undef Tcl_Alloc +#undef Tcl_Free +#undef Tcl_Realloc +#undef Tcl_AttemptAlloc +#undef Tcl_AttemptRealloc + +char * Tcl_Alloc( - size_t size) + unsigned int size) { return Tcl_DbCkalloc(size, "unknown", 0); } -void * +char * Tcl_AttemptAlloc( - size_t size) + unsigned int size) { return Tcl_AttemptDbCkalloc(size, "unknown", 0); } void Tcl_Free( - void *ptr) + char *ptr) { Tcl_DbCkfree(ptr, "unknown", 0); } -void * +char * Tcl_Realloc( - void *ptr, - size_t size) + char *ptr, + unsigned int size) { return Tcl_DbCkrealloc(ptr, size, "unknown", 0); } -void * +char * Tcl_AttemptRealloc( - void *ptr, - size_t size) + char *ptr, + unsigned int size) { return Tcl_AttemptDbCkrealloc(ptr, size, "unknown", 0); } /* @@ -806,162 +810,162 @@ * Results: * Standard TCL results. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ static int MemoryCmd( - TCL_UNUSED(ClientData), + ClientData clientData, Tcl_Interp *interp, - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Obj values of arguments. */ + int argc, + CONST char *argv[]) { - const char *fileName; + CONST char *fileName; FILE *fileP; Tcl_DString buffer; int result; size_t len; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option [args..]"); + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option [args..]\"", NULL); 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"); + if ((strcmp(argv[1],"active") == 0) || (strcmp(argv[1],"display") == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " file\"", NULL); return TCL_ERROR; } - fileName = Tcl_TranslateFileName(interp, TclGetString(objv[2]), &buffer); + fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); if (fileName == NULL) { return TCL_ERROR; } - result = Tcl_DumpActiveMemory(fileName); + 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))); + Tcl_AppendResult(interp, "error accessing ", argv[2], NULL); return TCL_ERROR; } return TCL_OK; } - if (strcmp(TclGetString(objv[1]),"break_on_malloc") == 0) { - int value; - if (objc != 3) { + if (strcmp(argv[1],"break_on_malloc") == 0) { + if (argc != 3) { goto argError; } - if (Tcl_GetIntFromObj(interp, objv[2], &value) != TCL_OK) { + if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) { return TCL_ERROR; } - break_on_malloc = (unsigned int) value; return TCL_OK; } - if (strcmp(TclGetString(objv[1]),"info") == 0) { + if (strcmp(argv[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", + "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10lu\n%-25s %10d\n%-25s %10lu\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) { + if (strcmp(argv[1],"init") == 0) { + if (argc != 3) { goto bad_suboption; } - init_malloced_bodies = (strcmp(TclGetString(objv[2]),"on") == 0); + init_malloced_bodies = (strcmp(argv[2],"on") == 0); return TCL_OK; } - if (strcmp(TclGetString(objv[1]), "objs") == 0) { - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "file"); + if (strcmp(argv[1],"objs") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " objs file\"", NULL); return TCL_ERROR; } - fileName = Tcl_TranslateFileName(interp, TclGetString(objv[2]), &buffer); + fileName = Tcl_TranslateFileName(interp, argv[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))); + Tcl_AppendResult(interp, "cannot open output file", NULL); 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"); + if (strcmp(argv[1],"onexit") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " onexit file\"", NULL); return TCL_ERROR; } - fileName = Tcl_TranslateFileName(interp, TclGetString(objv[2]), &buffer); + fileName = Tcl_TranslateFileName(interp, argv[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"); + if (strcmp(argv[1],"tag") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " tag string\"", NULL); + return TCL_ERROR; + } + if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) { + TclpFree((char *) curTagPtr); + } + len = strlen(argv[2]); + curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(len)); + curTagPtr->refCount = 0; + memcpy(curTagPtr->string, argv[2], len + 1); + return TCL_OK; + } + if (strcmp(argv[1],"trace") == 0) { + if (argc != 3) { + goto bad_suboption; + } + alloc_tracing = (strcmp(argv[2],"on") == 0); + return TCL_OK; + } + + if (strcmp(argv[1],"trace_on_at_malloc") == 0) { + if (argc != 3) { + goto argError; + } + if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) { + return TCL_ERROR; + } + return TCL_OK; + } + if (strcmp(argv[1],"validate") == 0) { + if (argc != 3) { + goto bad_suboption; + } + validate_memory = (strcmp(argv[2],"on") == 0); + return TCL_OK; + } + + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be active, break_on_malloc, info, init, onexit, " + "tag, trace, trace_on_at_malloc, or validate", NULL); + return TCL_ERROR; + + argError: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " count\"", NULL); + return TCL_ERROR; + + bad_suboption: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " on|off\"", NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- @@ -978,27 +982,25 @@ * Side effects: * None. * *---------------------------------------------------------------------- */ -static int CheckmemCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); static int CheckmemCmd( - TCL_UNUSED(ClientData), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Interpreter for evaluation. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Obj values of arguments. */ + int argc, /* Number of arguments. */ + CONST char *argv[]) /* String values of arguments. */ { - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "fileName"); + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileName\"", NULL); return TCL_ERROR; } tclMemDumpFileName = dumpFile; - strcpy(tclMemDumpFileName, TclGetString(objv[1])); + strcpy(tclMemDumpFileName, argv[1]); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -1020,12 +1022,12 @@ 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); + Tcl_CreateCommand(interp, "memory", MemoryCmd, (ClientData) NULL, NULL); + Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0, NULL); } #else /* TCL_MEM_DEBUG */ @@ -1045,15 +1047,17 @@ * that memory was actually allocated. * *---------------------------------------------------------------------- */ -void * +char * Tcl_Alloc( - size_t size) + unsigned int size) { - void *result = TclpAlloc(size); + char *result; + + result = 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 @@ -1062,27 +1066,28 @@ * 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 %" TCL_Z_MODIFIER "u bytes", size); + Tcl_Panic("unable to alloc %u bytes", size); } return result; } -void * +char * Tcl_DbCkalloc( - size_t size, - const char *file, + unsigned int size, + CONST char *file, int line) { - void *result = TclpAlloc(size); + char *result; + + result = (char *) TclpAlloc(size); if ((result == NULL) && size) { fflush(stdout); - Tcl_Panic("unable to alloc %" TCL_Z_MODIFIER "u bytes, %s line %d", - size, file, line); + Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line); } return result; } /* @@ -1094,24 +1099,30 @@ * check that memory was actually allocated. * *---------------------------------------------------------------------- */ -void * +char * Tcl_AttemptAlloc( - size_t size) + unsigned int size) { - return (char *)TclpAlloc(size); + char *result; + + result = TclpAlloc(size); + return result; } -void * +char * Tcl_AttemptDbCkalloc( - size_t size, - TCL_UNUSED(const char *) /*file*/, - TCL_UNUSED(int) /*line*/) + unsigned int size, + CONST char *file, + int line) { - return (char *)TclpAlloc(size); + char *result; + + result = (char *) TclpAlloc(size); + return result; } /* *---------------------------------------------------------------------- * @@ -1121,36 +1132,39 @@ * that memory was actually allocated. * *---------------------------------------------------------------------- */ -void * +char * Tcl_Realloc( - void *ptr, - size_t size) + char *ptr, + unsigned int size) { - void *result = TclpRealloc(ptr, size); + char *result; + + result = TclpRealloc(ptr, size); if ((result == NULL) && size) { - Tcl_Panic("unable to realloc %" TCL_Z_MODIFIER "u bytes", size); + Tcl_Panic("unable to realloc %u bytes", size); } return result; } -void * +char * Tcl_DbCkrealloc( - void *ptr, - size_t size, - const char *file, + char *ptr, + unsigned int size, + CONST char *file, int line) { - void *result = TclpRealloc(ptr, size); + char *result; + + result = (char *) TclpRealloc(ptr, size); if ((result == NULL) && size) { fflush(stdout); - Tcl_Panic("unable to realloc %" TCL_Z_MODIFIER "u bytes, %s line %d", - size, file, line); + Tcl_Panic("unable to realloc %u bytes, %s line %d", size, file, line); } return result; } /* @@ -1162,26 +1176,32 @@ * check that memory was actually allocated. * *---------------------------------------------------------------------- */ -void * +char * Tcl_AttemptRealloc( - void *ptr, - size_t size) + char *ptr, + unsigned int size) { - return (char *)TclpRealloc(ptr, size); + char *result; + + result = TclpRealloc(ptr, size); + return result; } -void * +char * Tcl_AttemptDbCkrealloc( - void *ptr, - size_t size, - TCL_UNUSED(const char *) /*file*/, - TCL_UNUSED(int) /*line*/) + char *ptr, + unsigned int size, + CONST char *file, + int line) { - return (char *)TclpRealloc(ptr, size); + char *result; + + result = (char *) TclpRealloc(ptr, size); + return result; } /* *---------------------------------------------------------------------- * @@ -1194,20 +1214,20 @@ *---------------------------------------------------------------------- */ void Tcl_Free( - void *ptr) + char *ptr) { TclpFree(ptr); } void Tcl_DbCkfree( - void *ptr, - TCL_UNUSED(const char *) /*file*/, - TCL_UNUSED(int) /*line*/) + char *ptr, + CONST char *file, + int line) { TclpFree(ptr); } /* @@ -1218,34 +1238,33 @@ * Dummy initialization for memory command, which is only available if * TCL_MEM_DEBUG is on. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ void Tcl_InitMemory( - TCL_UNUSED(Tcl_Interp *) /*interp*/) + Tcl_Interp *interp) { } int Tcl_DumpActiveMemory( - TCL_UNUSED(const char *) /*fileName*/) + CONST char *fileName) { return TCL_OK; } void Tcl_ValidateAllMemory( - TCL_UNUSED(const char *) /*file*/, - TCL_UNUSED(int) /*line*/) + CONST char *file, + int line) { } int -TclDumpMemoryInfo( - TCL_UNUSED(ClientData), - TCL_UNUSED(int) /*flags*/) +TclDumpMemoryInfo(ClientData clientData, int flags) { return 1; } #endif /* TCL_MEM_DEBUG */ @@ -1280,27 +1299,25 @@ } Tcl_MutexLock(ckallocMutexPtr); if (curTagPtr != NULL) { - TclpFree(curTagPtr); + TclpFree((char *) curTagPtr); curTagPtr = NULL; } allocHead = NULL; Tcl_MutexUnlock(ckallocMutexPtr); #endif -#if defined(USE_TCLALLOC) && USE_TCLALLOC +#if USE_TCLALLOC TclFinalizeAllocSubsystem(); #endif } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 - * tab-width: 8 - * indent-tabs-mode: nil * End: */ Index: generic/tclClock.c ================================================================== --- generic/tclClock.c +++ generic/tclClock.c @@ -5,11 +5,11 @@ * the time and date facilities of TclX, by Mark Diekhans and Karl * Lehenbauer. * * Copyright 1991-1995 Karl Lehenbauer and Mark Diekhans. * Copyright (c) 1995 Sun Microsystems, Inc. - * Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. + * Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ @@ -17,11 +17,11 @@ /* * Windows has mktime. The configurators do not check. */ -#ifdef _WIN32 +#ifdef __WIN32__ #define HAVE_MKTIME 1 #endif /* * Constants @@ -29,16 +29,16 @@ #define JULIAN_DAY_POSIX_EPOCH 2440588 #define SECONDS_PER_DAY 86400 #define JULIAN_SEC_POSIX_EPOCH (((Tcl_WideInt) JULIAN_DAY_POSIX_EPOCH) \ * SECONDS_PER_DAY) -#define FOUR_CENTURIES 146097 /* days */ +#define FOUR_CENTURIES 146097 /* days */ #define JDAY_1_JAN_1_CE_JULIAN 1721424 #define JDAY_1_JAN_1_CE_GREGORIAN 1721426 -#define ONE_CENTURY_GREGORIAN 36524 /* days */ -#define FOUR_YEARS 1461 /* days */ -#define ONE_YEAR 365 /* days */ +#define ONE_CENTURY_GREGORIAN 36524 /* days */ +#define FOUR_YEARS 1461 /* days */ +#define ONE_YEAR 365 /* days */ /* * Table of the days in each month, leap and common years */ @@ -56,11 +56,11 @@ */ typedef enum ClockLiteral { LIT__NIL, LIT__DEFAULT_FORMAT, - LIT_BCE, LIT_C, + LIT_BCE, LIT_C, LIT_CANNOT_USE_GMT_AND_TIMEZONE, LIT_CE, LIT_DAYOFMONTH, LIT_DAYOFWEEK, LIT_DAYOFYEAR, LIT_ERA, LIT_GMT, LIT_GREGORIAN, LIT_INTEGER_VALUE_TOO_LARGE, @@ -72,11 +72,11 @@ LIT__END } ClockLiteral; static const char *const literals[] = { "", "%a %b %d %H:%M:%S %Z %Y", - "BCE", "C", + "BCE", "C", "cannot use -gmt and -timezone in same call", "CE", "dayOfMonth", "dayOfWeek", "dayOfYear", "era", ":GMT", "gregorian", "integer value too large to represent", @@ -89,39 +89,39 @@ /* * Structure containing the client data for [clock] */ -typedef struct { - size_t refCount; /* Number of live references. */ - Tcl_Obj **literals; /* Pool of object literals. */ +typedef struct ClockClientData { + int refCount; /* Number of live references */ + Tcl_Obj** literals; /* Pool of object literals */ } ClockClientData; /* * Structure containing the fields used in [clock format] and [clock scan] */ -typedef struct { +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 */ + Tcl_Obj* tzName; /* Time zone name */ int julianDay; /* Julian Day Number in local time zone */ - int isBce; /* 1 if BCE */ + enum {BCE=1, CE=0} era; /* Era */ int gregorian; /* Flag == 1 if the date is Gregorian */ int year; /* Year of the era */ int dayOfYear; /* Day of the year (1 January == 1) */ int month; /* Month number */ int dayOfMonth; /* Day of the month */ int iso8601Year; /* ISO8601 week-based year */ int iso8601Week; /* ISO8601 week number */ int dayOfWeek; /* Day of the week */ } TclDateFields; -static const char *const eras[] = { "CE", "BCE", NULL }; +static const char* eras[] = { "CE", "BCE", NULL }; /* * Thread specific data block holding a 'struct tm' for the 'gmtime' and * 'localtime' library calls. */ @@ -137,30 +137,30 @@ /* * Function prototypes for local procedures in this file: */ -static int ConvertUTCToLocal(Tcl_Interp *, - TclDateFields *, Tcl_Obj *, int); -static int ConvertUTCToLocalUsingTable(Tcl_Interp *, - TclDateFields *, int, Tcl_Obj *const[]); -static int ConvertUTCToLocalUsingC(Tcl_Interp *, - TclDateFields *, int); -static int ConvertLocalToUTC(Tcl_Interp *, - TclDateFields *, Tcl_Obj *, int); -static int ConvertLocalToUTCUsingTable(Tcl_Interp *, - TclDateFields *, int, Tcl_Obj *const[]); -static int ConvertLocalToUTCUsingC(Tcl_Interp *, - TclDateFields *, int); -static Tcl_Obj * LookupLastTransition(Tcl_Interp *, Tcl_WideInt, +static int ConvertUTCToLocal(Tcl_Interp*, + TclDateFields*, Tcl_Obj*, int); +static int ConvertUTCToLocalUsingTable(Tcl_Interp*, + TclDateFields*, int, Tcl_Obj *const[]); +static int ConvertUTCToLocalUsingC(Tcl_Interp*, + TclDateFields*, int); +static int ConvertLocalToUTC(Tcl_Interp*, + TclDateFields*, Tcl_Obj*, int); +static int ConvertLocalToUTCUsingTable(Tcl_Interp*, + TclDateFields*, int, Tcl_Obj *const[]); +static int ConvertLocalToUTCUsingC(Tcl_Interp*, + TclDateFields*, int); +static Tcl_Obj* LookupLastTransition(Tcl_Interp*, Tcl_WideInt, int, Tcl_Obj *const *); -static void GetYearWeekDay(TclDateFields *, int); -static void GetGregorianEraYearDay(TclDateFields *, int); -static void GetMonthDay(TclDateFields *); -static void GetJulianDayFromEraYearWeekDay(TclDateFields *, int); -static void GetJulianDayFromEraYearMonthDay(TclDateFields *, int); -static int IsGregorianLeapYear(TclDateFields *); +static void GetYearWeekDay(TclDateFields*, int); +static void GetGregorianEraYearDay(TclDateFields*, int); +static void GetMonthDay(TclDateFields*); +static void GetJulianDayFromEraYearWeekDay(TclDateFields*, int); +static void GetJulianDayFromEraYearMonthDay(TclDateFields*, int); +static int IsGregorianLeapYear(TclDateFields*); static int WeekdayOnOrBefore(int, int); static int ClockClicksObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int ClockConvertlocaltoutcObjCmd( @@ -183,11 +183,11 @@ int objc, Tcl_Obj *const objv[]); static int ClockMillisecondsObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int ClockParseformatargsObjCmd( - ClientData clientData, Tcl_Interp *interp, + ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj *const objv[]); static int ClockSecondsObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static struct tm * ThreadSafeLocalTime(const time_t *); @@ -206,18 +206,22 @@ * will always have the ClockClientData sent * to it, but may well ignore this data. */ }; static const struct ClockCommand clockCommands[] = { + { "clicks", ClockClicksObjCmd }, { "getenv", ClockGetenvObjCmd }, + { "microseconds", ClockMicrosecondsObjCmd }, + { "milliseconds", ClockMillisecondsObjCmd }, + { "seconds", ClockSecondsObjCmd }, { "Oldscan", TclClockOldscanObjCmd }, { "ConvertLocalToUTC", ClockConvertlocaltoutcObjCmd }, { "GetDateFields", ClockGetdatefieldsObjCmd }, { "GetJulianDayFromEraYearMonthDay", ClockGetjuliandayfromerayearmonthdayObjCmd }, { "GetJulianDayFromEraYearWeekDay", - ClockGetjuliandayfromerayearweekdayObjCmd }, + ClockGetjuliandayfromerayearweekdayObjCmd }, { "ParseFormatArgs", ClockParseformatargsObjCmd }, { NULL, NULL } }; /* @@ -243,29 +247,16 @@ Tcl_Interp *interp) /* Tcl interpreter */ { const struct ClockCommand *clockCmdPtr; char cmdName[50]; /* Buffer large enough to hold the string *::tcl::clock::GetJulianDayFromEraYearMonthDay - * plus a terminating NUL. */ + * plus a terminating NULL. */ ClockClientData *data; int i; - /* Structure of the 'clock' ensemble */ - - static const EnsembleImplMap clockImplMap[] = { - {"add", NULL, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, - {"clicks", ClockClicksObjCmd, TclCompileClockClicksCmd, NULL, NULL, 0}, - {"format", NULL, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, - {"microseconds", ClockMicrosecondsObjCmd, TclCompileClockReadingCmd, NULL, INT2PTR(1), 0}, - {"milliseconds", ClockMillisecondsObjCmd, TclCompileClockReadingCmd, NULL, INT2PTR(2), 0}, - {"scan", NULL, TclCompileBasicMin1ArgCmd, NULL, NULL , 0}, - {"seconds", ClockSecondsObjCmd, TclCompileClockReadingCmd, NULL, INT2PTR(3), 0}, - {NULL, NULL, NULL, NULL, NULL, 0} - }; - /* - * Safe interps get [::clock] as alias to a parent, so do not need their + * Safe interps get [::clock] as alias to a master, so do not need their * own copies of the support routines. */ if (Tcl_IsSafe(interp)) { return; @@ -273,35 +264,30 @@ /* * Create the client data, which is a refcounted literal pool. */ - data = (ClockClientData *)Tcl_Alloc(sizeof(ClockClientData)); + data = (ClockClientData *) ckalloc(sizeof(ClockClientData)); data->refCount = 0; - data->literals = (Tcl_Obj **)Tcl_Alloc(LIT__END * sizeof(Tcl_Obj*)); + 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. - * TODO - Let Tcl_MakeEnsemble do this? */ + strcpy(cmdName, "::tcl::clock::"); #define TCL_CLOCK_PREFIX_LEN 14 /* == strlen("::tcl::clock::") */ - memcpy(cmdName, "::tcl::clock::", TCL_CLOCK_PREFIX_LEN); for (clockCmdPtr=clockCommands ; clockCmdPtr->name!=NULL ; clockCmdPtr++) { strcpy(cmdName + TCL_CLOCK_PREFIX_LEN, clockCmdPtr->name); data->refCount++; Tcl_CreateObjCommand(interp, cmdName, clockCmdPtr->objCmdProc, data, ClockDeleteCmdProc); } - - /* Make the clock ensemble */ - - TclMakeEnsemble(interp, "clock", clockImplMap); } /* *---------------------------------------------------------------------- * @@ -329,19 +315,19 @@ *---------------------------------------------------------------------- */ static int ClockConvertlocaltoutcObjCmd( - ClientData clientData, /* Client data */ - Tcl_Interp *interp, /* Tcl interpreter */ + 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; + ClockClientData* data = (ClockClientData*) clientData; + Tcl_Obj* const * literals = data->literals; + Tcl_Obj* secondsObj; + Tcl_Obj* dict; int changeover; TclDateFields fields; int created = 0; int status; @@ -352,21 +338,21 @@ 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) { + if (Tcl_DictObjGet(interp, dict, literals[LIT_LOCALSECONDS], + &secondsObj)!= TCL_OK) { return TCL_ERROR; } if (secondsObj == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("key \"localseconds\" not " - "found in dictionary", -1)); + "found in dictionary", -1)); return TCL_ERROR; } - if ((TclGetWideIntFromObj(interp, secondsObj, - &fields.localSeconds) != TCL_OK) + if ((Tcl_GetWideIntFromObj(interp, secondsObj, + &(fields.localSeconds)) != TCL_OK) || (TclGetIntFromObj(interp, objv[3], &changeover) != TCL_OK) || ConvertLocalToUTC(interp, &fields, objv[2], changeover)) { return TCL_ERROR; } @@ -378,11 +364,11 @@ if (Tcl_IsShared(dict)) { dict = Tcl_DuplicateObj(dict); created = 1; Tcl_IncrRefCount(dict); } - status = Tcl_DictObjPut(interp, dict, lit[LIT_SECONDS], + status = Tcl_DictObjPut(interp, dict, literals[LIT_SECONDS], Tcl_NewWideIntObj(fields.seconds)); if (status == TCL_OK) { Tcl_SetObjResult(interp, dict); } if (created) { @@ -402,20 +388,20 @@ * Usage: * ::tcl::clock::GetDateFields seconds tzdata changeover * * Parameters: * seconds - Time expressed in seconds from the Posix epoch. - * tzdata - Time zone data of the time zone in which time is to be - * expressed. + * tzdata - Time zone data of the time zone in which time is to + * be expressed. * changeover - Julian Day Number at which the current locale adopted * the Gregorian calendar * * Results: * Returns a dictonary populated with the fields: * seconds - Seconds from the Posix epoch - * localSeconds - Nominal seconds from the Posix epoch in the - * local time zone. + * localSeconds - Nominal seconds from the Posix epoch in + * the local time zone. * tzOffset - Time zone offset in seconds east of Greenwich * tzName - Time zone name * julianDay - Julian Day Number in the local time zone * *---------------------------------------------------------------------- @@ -422,18 +408,18 @@ */ int ClockGetdatefieldsObjCmd( ClientData clientData, /* Opaque pointer to literal pool, etc. */ - Tcl_Interp *interp, /* Tcl interpreter */ + 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; + Tcl_Obj* dict; + ClockClientData* data = (ClockClientData*) clientData; + Tcl_Obj* const * literals = data->literals; int changeover; /* * Check params. */ @@ -440,22 +426,22 @@ if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "seconds tzdata changeover"); return TCL_ERROR; } - if (TclGetWideIntFromObj(interp, objv[1], &fields.seconds) != TCL_OK + if (Tcl_GetWideIntFromObj(interp, objv[1], &(fields.seconds)) != TCL_OK || TclGetIntFromObj(interp, objv[3], &changeover) != TCL_OK) { return TCL_ERROR; } - /* - * fields.seconds could be an unsigned number that overflowed. Make sure - * that it isn't. + /* + * 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]); + if (objv[1]->typePtr == &tclBignumType) { + Tcl_SetObjResult(interp, literals[LIT_INTEGER_VALUE_TOO_LARGE]); return TCL_ERROR; } /* * Convert UTC time to local. @@ -479,38 +465,38 @@ GetGregorianEraYearDay(&fields, changeover); GetMonthDay(&fields); GetYearWeekDay(&fields, changeover); dict = Tcl_NewDictObj(); - Tcl_DictObjPut(NULL, dict, lit[LIT_LOCALSECONDS], + Tcl_DictObjPut(NULL, dict, literals[LIT_LOCALSECONDS], Tcl_NewWideIntObj(fields.localSeconds)); - Tcl_DictObjPut(NULL, dict, lit[LIT_SECONDS], + Tcl_DictObjPut(NULL, dict, literals[LIT_SECONDS], Tcl_NewWideIntObj(fields.seconds)); - Tcl_DictObjPut(NULL, dict, lit[LIT_TZNAME], fields.tzName); + Tcl_DictObjPut(NULL, dict, literals[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_DictObjPut(NULL, dict, literals[LIT_TZOFFSET], + Tcl_NewIntObj(fields.tzOffset)); + Tcl_DictObjPut(NULL, dict, literals[LIT_JULIANDAY], + Tcl_NewIntObj(fields.julianDay)); + Tcl_DictObjPut(NULL, dict, literals[LIT_GREGORIAN], + Tcl_NewIntObj(fields.gregorian)); + Tcl_DictObjPut(NULL, dict, literals[LIT_ERA], + literals[fields.era ? LIT_BCE : LIT_CE]); + Tcl_DictObjPut(NULL, dict, literals[LIT_YEAR], + Tcl_NewIntObj(fields.year)); + Tcl_DictObjPut(NULL, dict, literals[LIT_DAYOFYEAR], + Tcl_NewIntObj(fields.dayOfYear)); + Tcl_DictObjPut(NULL, dict, literals[LIT_MONTH], + Tcl_NewIntObj(fields.month)); + Tcl_DictObjPut(NULL, dict, literals[LIT_DAYOFMONTH], + Tcl_NewIntObj(fields.dayOfMonth)); + Tcl_DictObjPut(NULL, dict, literals[LIT_ISO8601YEAR], + Tcl_NewIntObj(fields.iso8601Year)); + Tcl_DictObjPut(NULL, dict, literals[LIT_ISO8601WEEK], + Tcl_NewIntObj(fields.iso8601Week)); + Tcl_DictObjPut(NULL, dict, literals[LIT_DAYOFWEEK], + Tcl_NewIntObj(fields.dayOfWeek)); Tcl_SetObjResult(interp, dict); return TCL_OK; } @@ -534,64 +520,25 @@ * *---------------------------------------------------------------------- */ static int -FetchEraField( - Tcl_Interp *interp, - Tcl_Obj *dict, - Tcl_Obj *key, - int *storePtr) -{ - Tcl_Obj *value = NULL; - - if (Tcl_DictObjGet(interp, dict, key, &value) != TCL_OK) { - return TCL_ERROR; - } - if (value == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "expected key(s) not found in dictionary", -1)); - return TCL_ERROR; - } - return Tcl_GetIndexFromObj(interp, value, eras, "era", TCL_EXACT, storePtr); -} - -static int -FetchIntField( - Tcl_Interp *interp, - Tcl_Obj *dict, - Tcl_Obj *key, - int *storePtr) -{ - Tcl_Obj *value = NULL; - - if (Tcl_DictObjGet(interp, dict, key, &value) != TCL_OK) { - return TCL_ERROR; - } - if (value == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "expected key(s) not found in dictionary", -1)); - return TCL_ERROR; - } - return TclGetIntFromObj(interp, value, storePtr); -} - -static int -ClockGetjuliandayfromerayearmonthdayObjCmd( +ClockGetjuliandayfromerayearmonthdayObjCmd ( ClientData clientData, /* Opaque pointer to literal pool, etc. */ - Tcl_Interp *interp, /* Tcl interpreter */ + 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; + Tcl_Obj* dict; + ClockClientData* data = (ClockClientData*) clientData; + Tcl_Obj* const * literals = data->literals; + Tcl_Obj* fieldPtr; int changeover; int copied = 0; int status; - int isBce = 0; + int era = 0; /* * Check params. */ @@ -598,21 +545,31 @@ 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 + if (Tcl_DictObjGet(interp, dict, literals[LIT_ERA], &fieldPtr) != TCL_OK + || fieldPtr == NULL + || Tcl_GetIndexFromObj(interp, fieldPtr, eras, "era", TCL_EXACT, + &era) != TCL_OK + || Tcl_DictObjGet(interp, dict, literals[LIT_YEAR], &fieldPtr) != TCL_OK + || fieldPtr == NULL + || TclGetIntFromObj(interp, fieldPtr, &(fields.year)) != TCL_OK + || Tcl_DictObjGet(interp, dict, literals[LIT_MONTH], &fieldPtr) != TCL_OK + || fieldPtr == NULL + || TclGetIntFromObj(interp, fieldPtr, &(fields.month)) != TCL_OK + || Tcl_DictObjGet(interp, dict, literals[LIT_DAYOFMONTH], &fieldPtr) != TCL_OK + || fieldPtr == NULL + || TclGetIntFromObj(interp, fieldPtr, + &(fields.dayOfMonth)) != TCL_OK || TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) { + if (fieldPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("expected key(s) not found in dictionary", -1)); + } return TCL_ERROR; } - fields.isBce = isBce; + fields.era = era; /* * Get Julian day. */ @@ -625,12 +582,12 @@ 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)); + status = Tcl_DictObjPut(interp, dict, literals[LIT_JULIANDAY], + Tcl_NewIntObj(fields.julianDay)); if (status == TCL_OK) { Tcl_SetObjResult(interp, dict); } if (copied) { Tcl_DecrRefCount(dict); @@ -658,24 +615,25 @@ * *---------------------------------------------------------------------- */ static int -ClockGetjuliandayfromerayearweekdayObjCmd( +ClockGetjuliandayfromerayearweekdayObjCmd ( ClientData clientData, /* Opaque pointer to literal pool, etc. */ - Tcl_Interp *interp, /* Tcl interpreter */ + 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; + Tcl_Obj* dict; + ClockClientData* data = (ClockClientData*) clientData; + Tcl_Obj* const * literals = data->literals; + Tcl_Obj* fieldPtr; int changeover; int copied = 0; int status; - int isBce = 0; + int era = 0; /* * Check params. */ @@ -682,21 +640,30 @@ 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 + if (Tcl_DictObjGet(interp, dict, literals[LIT_ERA], &fieldPtr) != TCL_OK + || fieldPtr == NULL + || Tcl_GetIndexFromObj(interp, fieldPtr, eras, "era", TCL_EXACT, + &era) != TCL_OK + || Tcl_DictObjGet(interp, dict, literals[LIT_ISO8601YEAR], &fieldPtr) != TCL_OK + || fieldPtr == NULL + || TclGetIntFromObj(interp, fieldPtr, &(fields.iso8601Year)) != TCL_OK + || Tcl_DictObjGet(interp, dict, literals[LIT_ISO8601WEEK], &fieldPtr) != TCL_OK + || fieldPtr == NULL + || TclGetIntFromObj(interp, fieldPtr, &(fields.iso8601Week)) != TCL_OK + || Tcl_DictObjGet(interp, dict, literals[LIT_DAYOFWEEK], &fieldPtr) != TCL_OK + || fieldPtr == NULL + || TclGetIntFromObj(interp, fieldPtr, &(fields.dayOfWeek)) != TCL_OK || TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) { + if (fieldPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("expected key(s) not found in dictionary", -1)); + } return TCL_ERROR; } - fields.isBce = isBce; + fields.era = era; /* * Get Julian day. */ @@ -709,12 +676,12 @@ 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)); + status = Tcl_DictObjPut(interp, dict, literals[LIT_JULIANDAY], + Tcl_NewIntObj(fields.julianDay)); if (status == TCL_OK) { Tcl_SetObjResult(interp, dict); } if (copied) { Tcl_DecrRefCount(dict); @@ -740,17 +707,17 @@ *---------------------------------------------------------------------- */ static int ConvertLocalToUTC( - Tcl_Interp *interp, /* Tcl interpreter */ - TclDateFields *fields, /* Fields of the time */ - Tcl_Obj *tzdata, /* Time zone data */ + Tcl_Interp* interp, /* Tcl interpreter */ + TclDateFields* fields, /* Fields of the time */ + Tcl_Obj* tzdata, /* Time zone data */ int changeover) /* Julian Day of the Gregorian transition */ { int rowc; /* Number of rows in tzdata */ - Tcl_Obj **rowv; /* Pointers to the rows */ + Tcl_Obj** rowv; /* Pointers to the rows */ /* * Unpack the tz data. */ @@ -788,18 +755,18 @@ *---------------------------------------------------------------------- */ static int ConvertLocalToUTCUsingTable( - Tcl_Interp *interp, /* Tcl interpreter */ - TclDateFields *fields, /* Time to convert, with 'seconds' filled in */ + Tcl_Interp* interp, /* Tcl interpreter */ + TclDateFields* fields, /* Time to convert, with 'seconds' filled in */ int rowc, /* Number of points at which time changes */ Tcl_Obj *const rowv[]) /* Points at which time changes */ { - Tcl_Obj *row; + Tcl_Obj* row; int cellc; - Tcl_Obj **cellv; + Tcl_Obj** cellv; int have[8]; int nHave = 0; int i; int found; @@ -820,11 +787,11 @@ row = LookupLastTransition(interp, fields->seconds, rowc, rowv); if ((row == NULL) || TclListObjGetElements(interp, row, &cellc, &cellv) != TCL_OK || TclGetIntFromObj(interp, cellv[1], - &fields->tzOffset) != TCL_OK) { + &(fields->tzOffset)) != TCL_OK) { return TCL_ERROR; } found = 0; for (i = 0; !found && i < nHave; ++i) { if (have[i] == fields->tzOffset) { @@ -834,11 +801,12 @@ } if (!found) { if (nHave == 8) { Tcl_Panic("loop in ConvertLocalToUTCUsingTable"); } - have[nHave++] = fields->tzOffset; + have[nHave] = fields->tzOffset; + ++nHave; } fields->seconds = fields->localSeconds - fields->tzOffset; } fields->tzOffset = have[i]; fields->seconds = fields->localSeconds - fields->tzOffset; @@ -863,12 +831,12 @@ *---------------------------------------------------------------------- */ static int ConvertLocalToUTCUsingC( - Tcl_Interp *interp, /* Tcl interpreter */ - TclDateFields *fields, /* Time to convert, with 'seconds' filled in */ + Tcl_Interp* interp, /* Tcl interpreter */ + TclDateFields* fields, /* Time to convert, with 'seconds' filled in */ int changeover) /* Julian Day of the Gregorian transition */ { struct tm timeVal; int localErrno; int secondOfDay; @@ -881,11 +849,11 @@ jsec = fields->localSeconds + JULIAN_SEC_POSIX_EPOCH; fields->julianDay = (int) (jsec / SECONDS_PER_DAY); secondOfDay = (int)(jsec % SECONDS_PER_DAY); if (secondOfDay < 0) { secondOfDay += SECONDS_PER_DAY; - fields->julianDay--; + --fields->julianDay; } GetGregorianEraYearDay(fields, changeover); GetMonthDay(fields); /* @@ -918,12 +886,12 @@ * If conversion fails, report an error. */ if (localErrno != 0 || (fields->seconds == -1 && timeVal.tm_yday == -1)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "time value too large/small to represent", -1)); + Tcl_SetResult(interp, "time value too large/small to represent", + TCL_STATIC); return TCL_ERROR; } return TCL_OK; } @@ -943,17 +911,17 @@ *---------------------------------------------------------------------- */ static int ConvertUTCToLocal( - Tcl_Interp *interp, /* Tcl interpreter */ - TclDateFields *fields, /* Fields of the time */ - Tcl_Obj *tzdata, /* Time zone data */ + Tcl_Interp* interp, /* Tcl interpreter */ + TclDateFields* fields, /* Fields of the time */ + Tcl_Obj* tzdata, /* Time zone data */ int changeover) /* Julian Day of the Gregorian transition */ { int rowc; /* Number of rows in tzdata */ - Tcl_Obj **rowv; /* Pointers to the rows */ + Tcl_Obj** rowv; /* Pointers to the rows */ /* * Unpack the tz data. */ @@ -991,28 +959,28 @@ *---------------------------------------------------------------------- */ static int ConvertUTCToLocalUsingTable( - Tcl_Interp *interp, /* Tcl interpreter */ - TclDateFields *fields, /* Fields of the date */ + Tcl_Interp* interp, /* Tcl interpreter */ + TclDateFields* fields, /* Fields of the date */ int rowc, /* Number of rows in the conversion table * (>= 1) */ Tcl_Obj *const rowv[]) /* Rows of the conversion table */ { - Tcl_Obj *row; /* Row containing the current information */ + Tcl_Obj* row; /* Row containing the current information */ int cellc; /* Count of cells in the row (must be 4) */ - Tcl_Obj **cellv; /* Pointers to the cells */ + Tcl_Obj** cellv; /* Pointers to the cells */ /* * Look up the nearest transition time. */ row = LookupLastTransition(interp, fields->seconds, rowc, rowv); if (row == NULL || TclListObjGetElements(interp, row, &cellc, &cellv) != TCL_OK || - TclGetIntFromObj(interp, cellv[1], &fields->tzOffset) != TCL_OK) { + TclGetIntFromObj(interp,cellv[1],&(fields->tzOffset)) != TCL_OK) { return TCL_ERROR; } /* * Convert the time. @@ -1043,45 +1011,45 @@ *---------------------------------------------------------------------- */ static int ConvertUTCToLocalUsingC( - Tcl_Interp *interp, /* Tcl interpreter */ - TclDateFields *fields, /* Time to convert, with 'seconds' filled in */ + 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 */ + 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) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "number too large to represent as a Posix time", -1)); + Tcl_AppendResult(interp, + "number too large to represent as a Posix time", NULL); Tcl_SetErrorCode(interp, "CLOCK", "argTooLarge", NULL); return TCL_ERROR; } TzsetIfNecessary(); timeVal = ThreadSafeLocalTime(&tock); if (timeVal == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( + Tcl_AppendResult(interp, "localtime failed (clock value may be too " - "large/small to represent)", -1)); + "large/small to represent)", NULL); Tcl_SetErrorCode(interp, "CLOCK", "localtimeFailed", NULL); return TCL_ERROR; } /* * Fill in the date in 'fields' and use it to derive Julian Day. */ - fields->isBce = 0; + fields->era = CE; fields->year = timeVal->tm_year + 1900; fields->month = timeVal->tm_mon + 1; fields->dayOfMonth = timeVal->tm_mday; GetJulianDayFromEraYearMonthDay(fields, changeover); @@ -1129,28 +1097,28 @@ * Returns a pointer to the row, or NULL if an error occurs. * *---------------------------------------------------------------------- */ -static Tcl_Obj * +static Tcl_Obj* LookupLastTransition( - Tcl_Interp *interp, /* Interpreter for error messages */ + Tcl_Interp* interp, /* Interpreter for error messages */ Tcl_WideInt tick, /* Time from the epoch */ int rowc, /* Number of rows of tzdata */ Tcl_Obj *const *rowv) /* Rows in tzdata */ { int l; int u; - Tcl_Obj *compObj; + Tcl_Obj* compObj; Tcl_WideInt compVal; /* * Examine the first row to make sure we're in bounds. */ if (Tcl_ListObjIndex(interp, rowv[0], 0, &compObj) != TCL_OK - || TclGetWideIntFromObj(interp, compObj, &compVal) != TCL_OK) { + || Tcl_GetWideIntFromObj(interp, compObj, &compVal) != TCL_OK) { return NULL; } /* * Bizarre case - first row doesn't begin at MIN_WIDE_INT. Return it @@ -1169,11 +1137,11 @@ u = rowc-1; while (l < u) { int m = (l + u + 1) / 2; if (Tcl_ListObjIndex(interp, rowv[m], 0, &compObj) != TCL_OK || - TclGetWideIntFromObj(interp, compObj, &compVal) != TCL_OK) { + Tcl_GetWideIntFromObj(interp, compObj, &compVal) != TCL_OK) { return NULL; } if (tick >= compVal) { l = m; } else { @@ -1201,11 +1169,11 @@ *---------------------------------------------------------------------- */ static void GetYearWeekDay( - TclDateFields *fields, /* Date to convert, must have 'julianDay' */ + TclDateFields* fields, /* Date to convert, must have 'julianDay' */ int changeover) /* Julian Day Number of the Gregorian * transition */ { TclDateFields temp; int dayOfFiscalYear; @@ -1215,11 +1183,11 @@ * 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) { + if (temp.era == BCE) { temp.iso8601Year = temp.year - 1; } else { temp.iso8601Year = temp.year + 1; } temp.iso8601Week = 1; @@ -1231,11 +1199,11 @@ * 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) { + if (temp.era == BCE) { temp.iso8601Year += 1; } else { temp.iso8601Year -= 1; } GetJulianDayFromEraYearWeekDay(&temp, changeover); @@ -1268,11 +1236,11 @@ *---------------------------------------------------------------------- */ static void GetGregorianEraYearDay( - TclDateFields *fields, /* Date fields containing 'julianDay' */ + TclDateFields* fields, /* Date fields containing 'julianDay' */ int changeover) /* Gregorian transition date */ { int jday = fields->julianDay; int day; int year; @@ -1294,11 +1262,11 @@ day = jday - JDAY_1_JAN_1_CE_GREGORIAN; n = day / FOUR_CENTURIES; day %= FOUR_CENTURIES; if (day < 0) { day += FOUR_CENTURIES; - n--; + --n; } year += 400 * n; /* * n = number of centuries since the start of (year); @@ -1314,18 +1282,20 @@ n = 3; day += ONE_CENTURY_GREGORIAN; } year += 100 * n; + } else { /* * Julian calendar. */ fields->gregorian = 0; year = 1; day = jday - JDAY_1_JAN_1_CE_JULIAN; + } /* * n = number of 4-year cycles; days = remaining days. */ @@ -1332,11 +1302,11 @@ n = day / FOUR_YEARS; day %= FOUR_YEARS; if (day < 0) { day += FOUR_YEARS; - n--; + --n; } year += 4 * n; /* * n = number of years; days = remaining days. @@ -1357,14 +1327,14 @@ /* * store era/year/day back into fields. */ if (year <= 0) { - fields->isBce = 1; + fields->era = BCE; fields->year = 1 - year; } else { - fields->isBce = 0; + fields->era = CE; fields->year = year; } fields->dayOfYear = day + 1; } @@ -1384,15 +1354,15 @@ *---------------------------------------------------------------------- */ static void GetMonthDay( - TclDateFields *fields) /* Date to convert */ + TclDateFields* fields) /* Date to convert */ { int day = fields->dayOfYear; int month; - const int *h = hath[IsGregorianLeapYear(fields)]; + const int* h = hath[IsGregorianLeapYear(fields)]; for (month = 0; month < 12 && day > h[month]; ++month) { day -= h[month]; } fields->month = month+1; @@ -1416,23 +1386,23 @@ *---------------------------------------------------------------------- */ static void GetJulianDayFromEraYearWeekDay( - TclDateFields *fields, /* Date to convert */ + TclDateFields* fields, /* Date to convert */ int changeover) /* Julian Day Number of the Gregorian * transition */ { int firstMonday; /* Julian day number of week 1, day 1 in the * given year */ - TclDateFields firstWeek; /* * Find January 4 in the ISO8601 year, which will always be in week 1. */ - firstWeek.isBce = fields->isBce; + TclDateFields firstWeek; + firstWeek.era = fields->era; firstWeek.year = fields->iso8601Year; firstWeek.month = 1; firstWeek.dayOfMonth = 4; GetJulianDayFromEraYearMonthDay(&firstWeek, changeover); @@ -1467,16 +1437,19 @@ *---------------------------------------------------------------------- */ static void GetJulianDayFromEraYearMonthDay( - TclDateFields *fields, /* Date to convert */ + TclDateFields* fields, /* Date to convert */ int changeover) /* Gregorian transition date as a Julian Day */ { - int year, ym1, month, mm1, q, r, ym1o4, ym1o100, ym1o400; + int year; int ym1; + int month; int mm1; + int q; int r; + int ym1o4; int ym1o100; int ym1o400; - if (fields->isBce) { + if (fields->era == BCE) { year = 1 - fields->year; } else { year = fields->year; } @@ -1500,44 +1473,32 @@ * Adjust the year after reducing the month. */ fields->gregorian = 1; if (year < 1) { - fields->isBce = 1; + fields->era = BCE; fields->year = 1-year; } else { - fields->isBce = 0; + fields->era = CE; 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) - ym1o4 = ym1 / 4; - else { - ym1o4 = - (int) (((unsigned int) -ym1) / 4); - } -#endif - if (ym1 % 4 < 0) { - ym1o4--; + ym1o4 = ym1 / 4; + if (ym1 % 4 < 0) { + --ym1o4; } ym1o100 = ym1 / 100; if (ym1 % 100 < 0) { - ym1o100--; + --ym1o100; } ym1o400 = ym1 / 400; if (ym1 % 400 < 0) { - ym1o400--; + --ym1o400; } fields->julianDay = JDAY_1_JAN_1_CE_GREGORIAN - 1 + fields->dayOfMonth + daysInPriorMonths[IsGregorianLeapYear(fields)][month - 1] + (ONE_YEAR * ym1) @@ -1553,12 +1514,12 @@ if (fields->julianDay < changeover) { fields->gregorian = 0; fields->julianDay = JDAY_1_JAN_1_CE_JULIAN - 1 + fields->dayOfMonth + daysInPriorMonths[year%4 == 0][month - 1] - + (365 * ym1) - + ym1o4; + + (ONE_YEAR * ym1) + + ym1o4; } } /* *---------------------------------------------------------------------- @@ -1574,16 +1535,18 @@ *---------------------------------------------------------------------- */ static int IsGregorianLeapYear( - TclDateFields *fields) /* Date to test */ + TclDateFields* fields) /* Date to test */ { - int year = fields->year; + int year; - if (fields->isBce) { - year = 1 - year; + if (fields->era == BCE) { + year = 1 - fields->year; + } else { + year = fields->year; } if (year%4 != 0) { return 0; } else if (!(fields->gregorian)) { return 1; @@ -1643,17 +1606,17 @@ *---------------------------------------------------------------------- */ int ClockGetenvObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, + ClientData clientData, + Tcl_Interp* interp, int objc, Tcl_Obj *const objv[]) { - const char *varName; - const char *varValue; + const char* varName; + const char* varValue; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "name"); return TCL_ERROR; } @@ -1690,11 +1653,12 @@ { /* * Get a thread-local buffer to hold the returned time. */ - struct tm *tmPtr = (struct tm *)Tcl_GetThreadData(&tmKey, sizeof(struct tm)); + struct tm *tmPtr = (struct tm *) + Tcl_GetThreadData(&tmKey, (int) sizeof(struct tm)); #ifdef HAVE_LOCALTIME_R localtime_r(timePtr, tmPtr); #else struct tm *sysTmPtr; @@ -1701,13 +1665,14 @@ Tcl_MutexLock(&clockMutex); sysTmPtr = localtime(timePtr); if (sysTmPtr == NULL) { Tcl_MutexUnlock(&clockMutex); return NULL; + } else { + memcpy((void *) tmPtr, (void *) localtime(timePtr), sizeof(struct tm)); + Tcl_MutexUnlock(&clockMutex); } - memcpy(tmPtr, localtime(timePtr), sizeof(struct tm)); - Tcl_MutexUnlock(&clockMutex); #endif return tmPtr; } /*---------------------------------------------------------------------- @@ -1728,24 +1693,23 @@ *---------------------------------------------------------------------- */ int ClockClicksObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, /* Tcl interpreter */ + ClientData clientData, /* Client data is unused */ + Tcl_Interp* interp, /* Tcl interpreter */ int objc, /* Parameter count */ - Tcl_Obj *const *objv) /* Parameter values */ + Tcl_Obj* const* objv) /* Parameter values */ { - static const char *const clicksSwitches[] = { + static const char *clicksSwitches[] = { "-milliseconds", "-microseconds", NULL }; enum ClicksSwitch { - CLICKS_MILLIS, CLICKS_MICROS, CLICKS_NATIVE + CLICKS_MILLIS, CLICKS_MICROS, CLICKS_NATIVE }; int index = CLICKS_NATIVE; Tcl_Time now; - Tcl_WideInt clicks = 0; switch (objc) { case 1: break; case 2: @@ -1753,32 +1717,34 @@ &index) != TCL_OK) { return TCL_ERROR; } break; default: - Tcl_WrongNumArgs(interp, 1, objv, "?-switch?"); + Tcl_WrongNumArgs(interp, 1, objv, "?option?"); return TCL_ERROR; } switch (index) { case CLICKS_MILLIS: Tcl_GetTime(&now); - clicks = (Tcl_WideInt) now.sec * 1000 + now.usec / 1000; + Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) + now.sec * 1000 + now.usec / 1000)); break; - case CLICKS_NATIVE: -#ifdef TCL_WIDE_CLICKS - clicks = TclpGetWideClicks(); + case CLICKS_NATIVE: { +#ifndef TCL_WIDE_CLICKS + unsigned long clicks = TclpGetClicks(); #else - clicks = (Tcl_WideInt) TclpGetClicks(); + Tcl_WideInt clicks = TclpGetWideClicks(); #endif + Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) clicks)); break; + } case CLICKS_MICROS: - clicks = TclpGetMicroseconds(); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(TclpGetMicroseconds())); break; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(clicks)); return TCL_OK; } /*---------------------------------------------------------------------- * @@ -1798,23 +1764,23 @@ *---------------------------------------------------------------------- */ int ClockMillisecondsObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, /* Tcl interpreter */ + ClientData clientData, /* Client data is unused */ + Tcl_Interp* interp, /* Tcl interpreter */ int objc, /* Parameter count */ - Tcl_Obj *const *objv) /* Parameter values */ + Tcl_Obj* const* objv) /* Parameter values */ { Tcl_Time now; if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } Tcl_GetTime(&now); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) + Tcl_SetObjResult(interp, Tcl_NewWideIntObj( (Tcl_WideInt) now.sec * 1000 + now.usec / 1000)); return TCL_OK; } /*---------------------------------------------------------------------- @@ -1835,14 +1801,14 @@ *---------------------------------------------------------------------- */ int ClockMicrosecondsObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, /* Tcl interpreter */ + ClientData clientData, /* Client data is unused */ + Tcl_Interp* interp, /* Tcl interpreter */ int objc, /* Parameter count */ - Tcl_Obj *const *objv) /* Parameter values */ + Tcl_Obj* const* objv) /* Parameter values */ { if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } @@ -1856,78 +1822,81 @@ * ClockParseformatargsObjCmd -- * * Parses the arguments for [clock format]. * * Results: - * Returns a standard Tcl result, whose value is a four-element list - * comprising the time format, the locale, and the timezone. + * Returns a standard Tcl result, whose value is a four-element + * list comprising the time format, the locale, and the timezone. * * This function exists because the loop that parses the [clock format] - * options is a known performance "hot spot", and is implemented in an effort - * to speed that particular code up. + * options is a known performance "hot spot", and is implemented in an + * effort to speed that particular code up. * *----------------------------------------------------------------------------- */ static int ClockParseformatargsObjCmd( ClientData clientData, /* Client data containing literal pool */ - Tcl_Interp *interp, /* Tcl interpreter */ + 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 */ + Tcl_Obj *const objv[] /* Parameter vector */ +) { + + ClockClientData* dataPtr = (ClockClientData*) clientData; + Tcl_Obj** litPtr = dataPtr->literals; + + /* Format, locale and timezone */ + + Tcl_Obj* results[3]; #define formatObj results[0] #define localeObj results[1] #define timezoneObj results[2] int gmtFlag = 0; - static const char *const options[] = { /* Command line options expected */ - "-format", "-gmt", "-locale", - "-timezone", NULL }; + + /* Command line options expected */ + + static const char* options[] = { + "-format", "-gmt", "-locale", + "-timezone", NULL }; enum optionInd { CLOCK_FORMAT_FORMAT, CLOCK_FORMAT_GMT, CLOCK_FORMAT_LOCALE, - CLOCK_FORMAT_TIMEZONE + CLOCK_FORMAT_TIMEZONE }; - int optionIndex; /* Index of an option. */ - int saw = 0; /* Flag == 1 if option was seen already. */ - Tcl_WideInt clockVal; /* Clock value - just used to parse. */ + int optionIndex; /* Index of an option */ + int saw = 0; /* Flag == 1 if option was seen already */ + Tcl_WideInt clockVal; /* Clock value - just used to parse */ int i; - /* - * Args consist of a time followed by keyword-value pairs. - */ + /* Args consist of a time followed by keyword-value pairs */ if (objc < 2 || (objc % 2) != 0) { Tcl_WrongNumArgs(interp, 0, objv, - "clock format clockval ?-format string? " - "?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?"); + "clock format clockval ?-format string? " + "?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?"); Tcl_SetErrorCode(interp, "CLOCK", "wrongNumArgs", NULL); return TCL_ERROR; } - /* - * Extract values for the keywords. - */ + /* Extract values for the keywords */ 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", - TclGetString(objv[i]), NULL); + if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", 0, + &optionIndex) != TCL_OK) { + Tcl_SetErrorCode(interp, "CLOCK", "badSwitch", + Tcl_GetString(objv[i]), NULL); return TCL_ERROR; } switch (optionIndex) { case CLOCK_FORMAT_FORMAT: formatObj = objv[i+1]; break; case CLOCK_FORMAT_GMT: - if (Tcl_GetBooleanFromObj(interp, objv[i+1], &gmtFlag) != TCL_OK){ + if (Tcl_GetBooleanFromObj(interp, objv[i+1], &gmtFlag) != TCL_OK) { return TCL_ERROR; } break; case CLOCK_FORMAT_LOCALE: localeObj = objv[i+1]; @@ -1934,40 +1903,37 @@ break; case CLOCK_FORMAT_TIMEZONE: timezoneObj = objv[i+1]; break; } - saw |= 1 << optionIndex; + saw |= (1 << optionIndex); } - /* - * Check options. - */ + /* Check options */ - if (TclGetWideIntFromObj(interp, objv[1], &clockVal) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[1], &clockVal) != TCL_OK) { return TCL_ERROR; } if ((saw & (1 << CLOCK_FORMAT_GMT)) - && (saw & (1 << CLOCK_FORMAT_TIMEZONE))) { + && (saw & (1 << CLOCK_FORMAT_TIMEZONE))) { Tcl_SetObjResult(interp, litPtr[LIT_CANNOT_USE_GMT_AND_TIMEZONE]); Tcl_SetErrorCode(interp, "CLOCK", "gmtWithTimezone", NULL); return TCL_ERROR; } if (gmtFlag) { timezoneObj = litPtr[LIT_GMT]; } - /* - * Return options as a list. - */ + /* Return options as a list */ Tcl_SetObjResult(interp, Tcl_NewListObj(3, results)); return TCL_OK; #undef timezoneObj #undef localeObj #undef formatObj + } /*---------------------------------------------------------------------- * * ClockSecondsObjCmd - @@ -1986,14 +1952,14 @@ *---------------------------------------------------------------------- */ int ClockSecondsObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, /* Tcl interpreter */ + ClientData clientData, /* Client data is unused */ + Tcl_Interp* interp, /* Tcl interpreter */ int objc, /* Parameter count */ - Tcl_Obj *const *objv) /* Parameter values */ + Tcl_Obj* const* objv) /* Parameter values */ { Tcl_Time now; if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); @@ -2022,27 +1988,27 @@ */ static void TzsetIfNecessary(void) { - static char* tzWas = (char *)INT2PTR(-1); /* Previous value of TZ, protected by + static char* tzWas = INT2PTR(-1); /* Previous value of TZ, protected by * clockMutex. */ - const char *tzIsNow; /* Current value of TZ */ + 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)) { - Tcl_Free(tzWas); + ckfree(tzWas); } - tzWas = (char *)Tcl_Alloc(strlen(tzIsNow) + 1); + tzWas = ckalloc(strlen(tzIsNow) + 1); strcpy(tzWas, tzIsNow); } else if (tzIsNow == NULL && tzWas != NULL) { tzset(); - if (tzWas != INT2PTR(-1)) Tcl_Free(tzWas); + if (tzWas != INT2PTR(-1)) ckfree(tzWas); tzWas = NULL; } Tcl_MutexUnlock(&clockMutex); } @@ -2062,19 +2028,20 @@ static void ClockDeleteCmdProc( ClientData clientData) /* Opaque pointer to the client data */ { - ClockClientData *data = (ClockClientData *)clientData; + ClockClientData *data = (ClockClientData*) clientData; int i; - if (data->refCount-- <= 1) { + --(data->refCount); + if (data->refCount == 0) { for (i = 0; i < LIT__END; ++i) { Tcl_DecrRefCount(data->literals[i]); } - Tcl_Free(data->literals); - Tcl_Free(data); + ckfree((char*) (data->literals)); + ckfree((char*) data); } } /* * Local Variables: Index: generic/tclCmdAH.c ================================================================== --- generic/tclCmdAH.c +++ generic/tclCmdAH.c @@ -10,93 +10,26 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" -#ifdef _WIN32 -# include "tclWinInt.h" -#endif - -/* - * 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. - */ - -struct ForeachState { - Tcl_Obj *bodyPtr; /* The script body of the command. */ - int bodyIdx; /* The argument index of the body. */ - int j, maxj; /* Number of loop iterations. */ - int numLists; /* Count of value lists. */ - int *index; /* Array of value list indices. */ - int *varcList; /* # loop variables per list. */ - Tcl_Obj ***varvList; /* Array of var name lists. */ - Tcl_Obj **vCopyList; /* Copies of var name list arguments. */ - int *argcList; /* Array of value list sizes. */ - Tcl_Obj ***argvList; /* Array of value lists. */ - Tcl_Obj **aCopyList; /* Copies of value list arguments. */ - Tcl_Obj *resultList; /* List of result values from the loop body, - * or NULL if we're not collecting them - * ([lmap] vs [foreach]). */ -}; +#include /* * 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 EncodingDirsObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_FSStatProc *statProc, Tcl_StatBuf *statPtr); -static const char * GetTypeFromMode(int mode); +static const char * GetTypeFromMode(int mode); static int StoreStatData(Tcl_Interp *interp, Tcl_Obj *varName, Tcl_StatBuf *statPtr); -static int EachloopCmd(Tcl_Interp *interp, int collect, - int objc, Tcl_Obj *const objv[]); -static Tcl_NRPostProc CatchObjCmdCallback; -static Tcl_NRPostProc ExprCallback; -static Tcl_NRPostProc ForSetupCallback; -static Tcl_NRPostProc ForCondCallback; -static Tcl_NRPostProc ForNextCallback; -static Tcl_NRPostProc ForPostNextCallback; -static Tcl_NRPostProc ForeachLoopStep; -static Tcl_NRPostProc EvalCmdErrMsg; - -static Tcl_ObjCmdProc FileAttrAccessTimeCmd; -static Tcl_ObjCmdProc FileAttrIsDirectoryCmd; -static Tcl_ObjCmdProc FileAttrIsExecutableCmd; -static Tcl_ObjCmdProc FileAttrIsExistingCmd; -static Tcl_ObjCmdProc FileAttrIsFileCmd; -static Tcl_ObjCmdProc FileAttrIsOwnedCmd; -static Tcl_ObjCmdProc FileAttrIsReadableCmd; -static Tcl_ObjCmdProc FileAttrIsWritableCmd; -static Tcl_ObjCmdProc FileAttrLinkStatCmd; -static Tcl_ObjCmdProc FileAttrModifyTimeCmd; -static Tcl_ObjCmdProc FileAttrSizeCmd; -static Tcl_ObjCmdProc FileAttrStatCmd; -static Tcl_ObjCmdProc FileAttrTypeCmd; -static Tcl_ObjCmdProc FilesystemSeparatorCmd; -static Tcl_ObjCmdProc FilesystemVolumesCmd; -static Tcl_ObjCmdProc PathDirNameCmd; -static Tcl_ObjCmdProc PathExtensionCmd; -static Tcl_ObjCmdProc PathFilesystemCmd; -static Tcl_ObjCmdProc PathJoinCmd; -static Tcl_ObjCmdProc PathNativeNameCmd; -static Tcl_ObjCmdProc PathNormalizeCmd; -static Tcl_ObjCmdProc PathRootNameCmd; -static Tcl_ObjCmdProc PathSplitCmd; -static Tcl_ObjCmdProc PathTailCmd; -static Tcl_ObjCmdProc PathTypeCmd; /* *---------------------------------------------------------------------- * * Tcl_BreakObjCmd -- @@ -115,13 +48,14 @@ * See the user documentation. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_BreakObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { if (objc != 1) { @@ -128,10 +62,145 @@ 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. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_CaseObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + register int i; + int body, result, caseObjc; + char *stringPtr, *arg; + Tcl_Obj *const *caseObjv; + Tcl_Obj *armPtr; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, + "string ?in? patList 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; + char *pat, *p; + + if (i == (caseObjc - 1)) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "extra case pattern with no body", NULL); + 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((char *) 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), interp->errorLine)); + } + return result; + } + + /* + * Nothing matched: return nothing. + */ + + return TCL_OK; +} /* *---------------------------------------------------------------------- * * Tcl_CatchObjCmd -- @@ -146,29 +215,21 @@ * See the user documentation. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ 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), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *varNamePtr = NULL; Tcl_Obj *optionVarNamePtr = NULL; + int result; Interp *iPtr = (Interp *) interp; if ((objc < 2) || (objc > 4)) { Tcl_WrongNumArgs(interp, 1, objv, "script ?resultVarName? ?optionVarName?"); @@ -180,61 +241,48 @@ } if (objc == 4) { optionVarNamePtr = objv[3]; } - TclNRAddCallback(interp, CatchObjCmdCallback, INT2PTR(objc), - varNamePtr, optionVarNamePtr, NULL); - /* * TIP #280. Make invoking context available to caught script. */ - return TclNREvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1); -} - -static int -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; + result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1); /* * We disable catch in interpreters where the limit has been exceeded. */ - if (rewind || Tcl_LimitExceeded(interp)) { + if (Tcl_LimitExceeded(interp)) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"catch\" body line %d)", Tcl_GetErrorLine(interp))); + "\n (\"catch\" body line %d)", interp->errorLine)); return TCL_ERROR; } if (objc >= 3) { if (NULL == Tcl_ObjSetVar2(interp, varNamePtr, NULL, - Tcl_GetObjResult(interp), TCL_LEAVE_ERR_MSG)) { + Tcl_GetObjResult(interp), 0)) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, + "couldn't save command result in variable", NULL); return TCL_ERROR; } } if (objc == 4) { Tcl_Obj *options = Tcl_GetReturnOptions(interp, result); - if (NULL == Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL, - options, TCL_LEAVE_ERR_MSG)) { - /* Do not decrRefCount 'options', it was already done by - * Tcl_ObjSetVar2 */ + options, 0)) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, + "couldn't save return options in variable", NULL); return TCL_ERROR; } } Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(result)); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -251,13 +299,14 @@ * See the user documentation. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_CdObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *dir; @@ -277,13 +326,12 @@ if (Tcl_FSConvertToPathType(interp, dir) != TCL_OK) { result = TCL_ERROR; } else { result = Tcl_FSChdir(dir); if (result != TCL_OK) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't change working directory to \"%s\": %s", - TclGetString(dir), Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "couldn't change working directory to \"", + TclGetString(dir), "\": ", Tcl_PosixError(interp), NULL); result = TCL_ERROR; } } if (objc != 2) { Tcl_DecrRefCount(dir); @@ -306,13 +354,14 @@ * See the user documentation. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_ConcatObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { if (objc >= 2) { @@ -340,13 +389,14 @@ * See the user documentation. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_ContinueObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { if (objc != 1) { @@ -355,163 +405,128 @@ } return TCL_CONTINUE; } /* - *----------------------------------------------------------------------------- - * - * TclInitEncodingCmd -- - * - * This function creates the 'encoding' ensemble. - * - * Results: - * Returns the Tcl_Command so created. - * - * Side effects: - * The ensemble is initialized. - * - * This command is hidden in a safe interpreter. - */ - -Tcl_Command -TclInitEncodingCmd( - Tcl_Interp* interp) /* Tcl interpreter */ -{ - static const EnsembleImplMap encodingImplMap[] = { - {"convertfrom", EncodingConvertfromObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"convertto", EncodingConverttoObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"dirs", EncodingDirsObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, - {"names", EncodingNamesObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, - {"system", EncodingSystemObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, - {NULL, NULL, NULL, NULL, NULL, 0} - }; - - return TclMakeEnsemble(interp, "encoding", encodingImplMap); -} - -/* - *---------------------------------------------------------------------- - * - * EncodingConvertfromObjCmd -- - * - * This command converts a byte array in an external encoding into a - * Tcl string - * - * Results: - * 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 */ - size_t length = 0; /* 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 *) TclGetByteArrayFromObj(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. - */ - - Tcl_SetObjResult(interp, TclDStringToObj(&ds)); - - /* - * We're done with the encoding - */ - - Tcl_FreeEncoding(encoding); - return TCL_OK; - -} - -/* - *---------------------------------------------------------------------- - * - * EncodingConverttoObjCmd -- - * - * This command converts a Tcl string into a byte array that - * encodes the string according to some encoding. - * - * Results: - * 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 */ - size_t 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]; - } 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 to a byte array in 'ds' - */ - - stringPtr = TclGetStringFromObj(data, &length); - Tcl_UtfToExternalDString(encoding, stringPtr, length, &ds); - Tcl_SetObjResult(interp, - Tcl_NewByteArrayObj((unsigned char*) Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds))); - Tcl_DStringFree(&ds); - - /* - * We're done with the encoding - */ - - Tcl_FreeEncoding(encoding); - return TCL_OK; - + *---------------------------------------------------------------------- + * + * Tcl_EncodingObjCmd -- + * + * This command manipulates encodings. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_EncodingObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int index; + + static const char *optionStrings[] = { + "convertfrom", "convertto", "dirs", "names", "system", + NULL + }; + enum options { + ENC_CONVERTFROM, ENC_CONVERTTO, ENC_DIRS, ENC_NAMES, ENC_SYSTEM + }; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + switch ((enum options) index) { + case ENC_CONVERTTO: + case ENC_CONVERTFROM: { + Tcl_Obj *data; + Tcl_DString ds; + Tcl_Encoding encoding; + int length; + char *stringPtr; + + if (objc == 3) { + encoding = Tcl_GetEncoding(interp, NULL); + data = objv[2]; + } else if (objc == 4) { + if (Tcl_GetEncodingFromObj(interp, objv[2], &encoding) != TCL_OK) { + return TCL_ERROR; + } + data = objv[3]; + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?encoding? data"); + return TCL_ERROR; + } + + if ((enum options) index == ENC_CONVERTFROM) { + /* + * Treat the string as binary data. + */ + + stringPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); + Tcl_ExternalToUtfDString(encoding, stringPtr, length, &ds); + + /* + * Note that we cannot use Tcl_DStringResult here because it will + * truncate the string at the first null byte. + */ + + Tcl_SetObjResult(interp, Tcl_NewStringObj( + Tcl_DStringValue(&ds), Tcl_DStringLength(&ds))); + Tcl_DStringFree(&ds); + } else { + /* + * Store the result as binary data. + */ + + stringPtr = TclGetStringFromObj(data, &length); + Tcl_UtfToExternalDString(encoding, stringPtr, length, &ds); + Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( + (unsigned char *) Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds))); + Tcl_DStringFree(&ds); + } + + Tcl_FreeEncoding(encoding); + break; + } + case ENC_DIRS: + return EncodingDirsObjCmd(dummy, interp, objc, objv); + case ENC_NAMES: + if (objc > 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + Tcl_GetEncodingNames(interp); + break; + case ENC_SYSTEM: + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?encoding?"); + return TCL_ERROR; + } + if (objc == 2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + Tcl_GetEncodingName(NULL), -1)); + } else { + return Tcl_SetSystemEncoding(interp, TclGetString(objv[2])); + } + break; + } + return TCL_OK; } /* *---------------------------------------------------------------------- * @@ -528,100 +543,33 @@ *---------------------------------------------------------------------- */ int EncodingDirsObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *dirListObj; - if (objc > 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?dirList?"); + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?dirList?"); return TCL_ERROR; } - if (objc == 1) { + if (objc == 2) { Tcl_SetObjResult(interp, Tcl_GetEncodingSearchPath()); return TCL_OK; } - dirListObj = objv[1]; + dirListObj = objv[2]; if (Tcl_SetEncodingSearchPath(dirListObj) == TCL_ERROR) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "expected directory list but got \"%s\"", - TclGetString(dirListObj))); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "ENCODING", "BADPATH", - NULL); + Tcl_AppendResult(interp, "expected directory list but got \"", + TclGetString(dirListObj), "\"", NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, dirListObj); - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * EncodingNamesObjCmd -- - * - * This command returns a list of the available encoding names - * - * 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; -} - -/* - *----------------------------------------------------------------------------- - * - * EncodingSystemObjCmd -- - * - * This command retrieves or changes the system encoding - * - * Results: - * Returns a standard Tcl result - * - * 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, - Tcl_NewStringObj(Tcl_GetEncodingName(NULL), -1)); - } else { - return Tcl_SetSystemEncoding(interp, TclGetString(objv[1])); - } return TCL_OK; } /* *---------------------------------------------------------------------- @@ -638,13 +586,14 @@ * See the user documentation. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_ErrorObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *options, *optName; @@ -687,44 +636,21 @@ * 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; -} - + /* ARGSUSED */ int Tcl_EvalObjCmd( - ClientData clientData, + ClientData dummy, /* Not used. */ 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; + int result; + register 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; } @@ -732,28 +658,36 @@ if (objc == 2) { /* * TIP #280. Make argument location available to eval'd script. */ - invoker = iPtr->cmdFramePtr; - word = 1; - objPtr = objv[1]; - TclArgumentGet(interp, objPtr, &invoker, &word); + CmdFrame* invoker = iPtr->cmdFramePtr; + int word = 1; + TclArgumentGet (interp, objv[1], &invoker, &word); + + result = TclEvalObjEx(interp, objv[1], TCL_EVAL_DIRECT, + invoker, word); } else { /* * More than one argument: concatenate them together with spaces * between, then evaluate the result. Tcl_EvalObjEx will delete the * object when it decrements its refcount after eval'ing it. - * - * TIP #280. Make invoking context available to eval'd script, done - * with the default values. */ objPtr = Tcl_ConcatObj(objc-1, objv+1); + + /* + * TIP #280. Make invoking context available to eval'd script. + */ + + result = TclEvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, 0); + } + if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"eval\" body line %d)", interp->errorLine)); } - TclNRAddCallback(interp, EvalCmdErrMsg, NULL, NULL, NULL, NULL); - return TclNREvalObjEx(interp, objPtr, 0, invoker, word); + return result; } /* *---------------------------------------------------------------------- * @@ -769,30 +703,32 @@ * See the user documentation. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_ExitObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_WideInt value; + int 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) { + } else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) { return TCL_ERROR; } - Tcl_Exit((int)value); + Tcl_Exit(value); + /*NOTREACHED*/ return TCL_OK; /* Better not ever reach this! */ } /* *---------------------------------------------------------------------- @@ -816,78 +752,53 @@ * See the user documentation. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_ExprObjCmd( - ClientData clientData, + ClientData dummy, /* Not used. */ 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; + Tcl_Obj *resultPtr; + int result; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?"); return TCL_ERROR; } - TclNewObj(resultPtr); - Tcl_IncrRefCount(resultPtr); if (objc == 2) { - objPtr = objv[1]; - TclNRAddCallback(interp, ExprCallback, resultPtr, NULL, NULL, NULL); + result = Tcl_ExprObj(interp, objv[1], &resultPtr); } else { - objPtr = Tcl_ConcatObj(objc-1, objv+1); - TclNRAddCallback(interp, ExprCallback, resultPtr, objPtr, NULL, NULL); - } - - return Tcl_NRExprObj(interp, objPtr, resultPtr); -} - -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_Obj *objPtr = Tcl_ConcatObj(objc-1, objv+1); + Tcl_IncrRefCount(objPtr); + result = Tcl_ExprObj(interp, objPtr, &resultPtr); Tcl_DecrRefCount(objPtr); } if (result == TCL_OK) { Tcl_SetObjResult(interp, resultPtr); + Tcl_DecrRefCount(resultPtr); /* Done with the result object */ } - Tcl_DecrRefCount(resultPtr); + return result; } /* *---------------------------------------------------------------------- * - * TclInitFileCmd -- - * - * This function builds the "file" Tcl command ensemble. See the user - * documentation for details on what that ensemble does. - * - * PLEASE NOTE THAT THIS FAILS WITH FILENAMES AND PATHS WITH EMBEDDED - * NULLS. With the object-based Tcl_FS APIs, the above NOTE may no longer - * be true. In any case this assertion should be tested. + * Tcl_FileObjCmd -- + * + * This procedure is invoked to process the "file" Tcl command. See the + * user documentation for details on what it does. PLEASE NOTE THAT THIS + * FAILS WITH FILENAMES AND PATHS WITH EMBEDDED NULLS. With the + * object-based Tcl_FS APIs, the above NOTE may no longer be true. In any + * case this assertion should be tested. * * Results: * A standard Tcl result. * * Side effects: @@ -894,1096 +805,573 @@ * See the user documentation. * *---------------------------------------------------------------------- */ -Tcl_Command -TclInitFileCmd( - Tcl_Interp *interp) -{ - /* - * Note that most subcommands are unsafe because either they manipulate - * the native filesystem or because they reveal information about the - * native filesystem. - */ - - static const EnsembleImplMap initMap[] = { - {"atime", FileAttrAccessTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 1}, - {"attributes", TclFileAttrsCmd, NULL, NULL, NULL, 1}, - {"channels", TclChannelNamesCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"copy", TclFileCopyCmd, NULL, NULL, NULL, 1}, - {"delete", TclFileDeleteCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1}, - {"dirname", PathDirNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {"executable", FileAttrIsExecutableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {"exists", FileAttrIsExistingCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {"extension", PathExtensionCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {"isdirectory", FileAttrIsDirectoryCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {"isfile", FileAttrIsFileCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {"join", PathJoinCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, - {"link", TclFileLinkCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 1}, - {"lstat", FileAttrLinkStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 1}, - {"mtime", FileAttrModifyTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 1}, - {"mkdir", TclFileMakeDirsCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1}, - {"nativename", PathNativeNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {"normalize", PathNormalizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {"owned", FileAttrIsOwnedCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {"pathtype", PathTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"readable", FileAttrIsReadableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {"readlink", TclFileReadLinkCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {"rename", TclFileRenameCmd, NULL, NULL, NULL, 1}, - {"rootname", PathRootNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {"separator", FilesystemSeparatorCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"size", FileAttrSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {"split", PathSplitCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"stat", FileAttrStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 1}, - {"system", PathFilesystemCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"tail", PathTailCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {"tempdir", TclFileTempDirCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, - {"tempfile", TclFileTemporaryCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 1}, - {"type", FileAttrTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {"volumes", FilesystemVolumesCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1}, - {"writable", FileAttrIsWritableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {NULL, NULL, NULL, NULL, NULL, 0} - }; - return TclMakeEnsemble(interp, "file", initMap); -} - -/* - *---------------------------------------------------------------------- - * - * FileAttrAccessTimeCmd -- - * - * This function is invoked to process the "file atime" Tcl command. See - * the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * 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 -- - * - * This function is invoked to process the "file mtime" Tcl command. See - * the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * May update the modification time on the file, if requested by the - * 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 -- - * - * This function is invoked to process the "file lstat" Tcl command. See - * the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * 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) { - Tcl_WrongNumArgs(interp, 1, objv, "name varName"); - return TCL_ERROR; - } - if (GetStatBuf(interp, objv[1], Tcl_FSLstat, &buf) != TCL_OK) { - return TCL_ERROR; - } - return StoreStatData(interp, objv[2], &buf); -} - -/* - *---------------------------------------------------------------------- - * - * FileAttrStatCmd -- - * - * This function is invoked to process the "file stat" Tcl command. See - * the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * 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) { - Tcl_WrongNumArgs(interp, 1, objv, "name varName"); - return TCL_ERROR; - } - if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { - return TCL_ERROR; - } - return StoreStatData(interp, objv[2], &buf); -} - -/* - *---------------------------------------------------------------------- - * - * FileAttrTypeCmd -- - * - * This function is invoked to process the "file type" Tcl command. See - * the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -FileAttrTypeCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_StatBuf buf; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "name"); - return TCL_ERROR; - } - if (GetStatBuf(interp, objv[1], Tcl_FSLstat, &buf) != TCL_OK) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewStringObj( - GetTypeFromMode((unsigned short) buf.st_mode), -1)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * FileAttrSizeCmd -- - * - * This function is invoked to process the "file size" Tcl command. See - * the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -FileAttrSizeCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_StatBuf buf; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "name"); - return TCL_ERROR; - } - if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) buf.st_size)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * FileAttrIsDirectoryCmd -- - * - * This function is invoked to process the "file isdirectory" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -FileAttrIsDirectoryCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_StatBuf buf; - int value = 0; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "name"); - return TCL_ERROR; - } - if (GetStatBuf(NULL, objv[1], Tcl_FSStat, &buf) == TCL_OK) { - value = S_ISDIR(buf.st_mode); - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * FileAttrIsExecutableCmd -- - * - * This function is invoked to process the "file executable" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * 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; - } - return CheckAccess(interp, objv[1], X_OK); -} - -/* - *---------------------------------------------------------------------- - * - * FileAttrIsExistingCmd -- - * - * This function is invoked to process the "file exists" Tcl command. See - * the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * 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; - } - return CheckAccess(interp, objv[1], F_OK); -} - -/* - *---------------------------------------------------------------------- - * - * FileAttrIsFileCmd -- - * - * This function is invoked to process the "file isfile" Tcl command. See - * the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -FileAttrIsFileCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_StatBuf buf; - int value = 0; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "name"); - return TCL_ERROR; - } - if (GetStatBuf(NULL, objv[1], Tcl_FSStat, &buf) == TCL_OK) { - value = S_ISREG(buf.st_mode); - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * FileAttrIsOwnedCmd -- - * - * This function is invoked to process the "file owned" Tcl command. See - * the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -FileAttrIsOwnedCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ -#ifdef __CYGWIN__ -#define geteuid() (short)(geteuid)() -#endif -#if !defined(_WIN32) - Tcl_StatBuf buf; -#endif - int value = 0; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "name"); - return TCL_ERROR; - } -#if defined(_WIN32) - value = TclWinFileOwned(objv[1]); -#else - if (GetStatBuf(NULL, objv[1], Tcl_FSStat, &buf) == TCL_OK) { - value = (geteuid() == buf.st_uid); - } -#endif - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * FileAttrIsReadableCmd -- - * - * This function is invoked to process the "file readable" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * 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; - } - return CheckAccess(interp, objv[1], R_OK); -} - -/* - *---------------------------------------------------------------------- - * - * FileAttrIsWritableCmd -- - * - * This function is invoked to process the "file writable" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * 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; - } - return CheckAccess(interp, objv[1], W_OK); -} - -/* - *---------------------------------------------------------------------- - * - * PathDirNameCmd -- - * - * This function is invoked to process the "file dirname" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -PathDirNameCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Obj *dirPtr; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "name"); - return TCL_ERROR; - } - dirPtr = TclPathPart(interp, objv[1], TCL_PATH_DIRNAME); - if (dirPtr == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, dirPtr); - Tcl_DecrRefCount(dirPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * PathExtensionCmd -- - * - * This function is invoked to process the "file extension" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -PathExtensionCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Obj *dirPtr; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "name"); - return TCL_ERROR; - } - dirPtr = TclPathPart(interp, objv[1], TCL_PATH_EXTENSION); - if (dirPtr == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, dirPtr); - Tcl_DecrRefCount(dirPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * PathRootNameCmd -- - * - * This function is invoked to process the "file root" Tcl command. See - * the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -PathRootNameCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Obj *dirPtr; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "name"); - return TCL_ERROR; - } - dirPtr = TclPathPart(interp, objv[1], TCL_PATH_ROOT); - if (dirPtr == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, dirPtr); - Tcl_DecrRefCount(dirPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * PathTailCmd -- - * - * This function is invoked to process the "file tail" Tcl command. See - * the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -PathTailCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Obj *dirPtr; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "name"); - return TCL_ERROR; - } - dirPtr = TclPathPart(interp, objv[1], TCL_PATH_TAIL); - if (dirPtr == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, dirPtr); - Tcl_DecrRefCount(dirPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * PathFilesystemCmd -- - * - * This function is invoked to process the "file system" Tcl command. See - * the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * 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", - TclGetString(objv[1]), NULL); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, fsInfo); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * PathJoinCmd -- - * - * This function is invoked to process the "file join" Tcl command. See - * the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * 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; - } - Tcl_SetObjResult(interp, TclJoinPath(objc - 1, objv + 1, 0)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * PathNativeNameCmd -- - * - * This function is invoked to process the "file nativename" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -PathNativeNameCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_DString ds; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "name"); - return TCL_ERROR; - } - if (Tcl_TranslateFileName(interp, TclGetString(objv[1]), &ds) == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, TclDStringToObj(&ds)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * PathNormalizeCmd -- - * - * This function is invoked to process the "file normalize" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -PathNormalizeCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Obj *fileName; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "name"); - return TCL_ERROR; - } - fileName = Tcl_FSGetNormalizedPath(interp, objv[1]); - if (fileName == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, fileName); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * PathSplitCmd -- - * - * This function is invoked to process the "file split" Tcl command. See - * the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -PathSplitCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Obj *res; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "name"); - return TCL_ERROR; - } - res = Tcl_FSSplitPath(objv[1], NULL); - if (res == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not read \"%s\": no such file or directory", - TclGetString(objv[1]))); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PATHSPLIT", "NONESUCH", - NULL); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, res); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * PathTypeCmd -- - * - * This function is invoked to process the "file pathtype" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -PathTypeCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Obj *typeName; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "name"); - return TCL_ERROR; - } - switch (Tcl_FSGetPathType(objv[1])) { - case TCL_PATH_ABSOLUTE: - TclNewLiteralStringObj(typeName, "absolute"); - break; - case TCL_PATH_RELATIVE: - TclNewLiteralStringObj(typeName, "relative"); - break; - case TCL_PATH_VOLUME_RELATIVE: - TclNewLiteralStringObj(typeName, "volumerelative"); - break; - default: - /* Should be unreachable */ - return TCL_OK; - } - Tcl_SetObjResult(interp, typeName); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * FilesystemSeparatorCmd -- - * - * This function is invoked to process the "file separator" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * 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", - TclGetString(objv[1]), NULL); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, separatorObj); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * FilesystemVolumesCmd -- - * - * This function is invoked to process the "file volumes" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * 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; - } - Tcl_SetObjResult(interp, Tcl_FSListVolumes()); - return TCL_OK; + /* ARGSUSED */ +int +Tcl_FileObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int index, value; + Tcl_StatBuf buf; + struct utimbuf tval; + + /* + * This list of constants should match the fileOption string array below. + */ + + static const char *fileOptions[] = { + "atime", "attributes", "channels", "copy", + "delete", + "dirname", "executable", "exists", "extension", + "isdirectory", "isfile", "join", "link", + "lstat", "mtime", "mkdir", "nativename", + "normalize", "owned", + "pathtype", "readable", "readlink", "rename", + "rootname", "separator", "size", "split", + "stat", "system", + "tail", "type", "volumes", "writable", + NULL + }; + enum options { + FCMD_ATIME, FCMD_ATTRIBUTES, FCMD_CHANNELS, FCMD_COPY, + FCMD_DELETE, + FCMD_DIRNAME, FCMD_EXECUTABLE, FCMD_EXISTS, FCMD_EXTENSION, + FCMD_ISDIRECTORY, FCMD_ISFILE, FCMD_JOIN, FCMD_LINK, + FCMD_LSTAT, FCMD_MTIME, FCMD_MKDIR, FCMD_NATIVENAME, + FCMD_NORMALIZE, FCMD_OWNED, + FCMD_PATHTYPE, FCMD_READABLE, FCMD_READLINK, FCMD_RENAME, + FCMD_ROOTNAME, FCMD_SEPARATOR, FCMD_SIZE, FCMD_SPLIT, + FCMD_STAT, FCMD_SYSTEM, + FCMD_TAIL, FCMD_TYPE, FCMD_VOLUMES, FCMD_WRITABLE + }; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + switch ((enum options) index) { + + case FCMD_ATIME: + case FCMD_MTIME: + if ((objc < 3) || (objc > 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "name ?time?"); + return TCL_ERROR; + } + if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { + return TCL_ERROR; + } + if (objc == 4) { + Tcl_WideInt newTime; + + + if (Tcl_GetWideIntFromObj(interp, objv[3], &newTime) != TCL_OK) { + return TCL_ERROR; + } + + if (index == FCMD_ATIME) { + tval.actime = newTime; + tval.modtime = buf.st_mtime; + } else { /* index == FCMD_MTIME */ + tval.actime = buf.st_atime; + tval.modtime = newTime; + } + + if (Tcl_FSUtime(objv[2], &tval) != 0) { + Tcl_AppendResult(interp, "could not set ", + (index == FCMD_ATIME ? "access" : "modification"), + " time for file \"", TclGetString(objv[2]), "\": ", + Tcl_PosixError(interp), NULL); + 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[2], Tcl_FSStat, &buf) != TCL_OK) { + return TCL_ERROR; + } + } + + Tcl_SetObjResult(interp, Tcl_NewWideIntObj( + (index == FCMD_ATIME ? buf.st_atime : buf.st_mtime))); + return TCL_OK; + case FCMD_ATTRIBUTES: + return TclFileAttrsCmd(interp, objc, objv); + case FCMD_CHANNELS: + if ((objc < 2) || (objc > 3)) { + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + return TCL_ERROR; + } + return Tcl_GetChannelNamesEx(interp, + ((objc == 2) ? NULL : TclGetString(objv[2]))); + case FCMD_COPY: + return TclFileCopyCmd(interp, objc, objv); + case FCMD_DELETE: + return TclFileDeleteCmd(interp, objc, objv); + case FCMD_DIRNAME: { + Tcl_Obj *dirPtr; + + if (objc != 3) { + goto only3Args; + } + dirPtr = TclPathPart(interp, objv[2], TCL_PATH_DIRNAME); + if (dirPtr == NULL) { + return TCL_ERROR; + } else { + Tcl_SetObjResult(interp, dirPtr); + Tcl_DecrRefCount(dirPtr); + return TCL_OK; + } + } + case FCMD_EXECUTABLE: + if (objc != 3) { + goto only3Args; + } + return CheckAccess(interp, objv[2], X_OK); + case FCMD_EXISTS: + if (objc != 3) { + goto only3Args; + } + return CheckAccess(interp, objv[2], F_OK); + case FCMD_EXTENSION: { + Tcl_Obj *ext; + + if (objc != 3) { + goto only3Args; + } + ext = TclPathPart(interp, objv[2], TCL_PATH_EXTENSION); + if (ext != NULL) { + Tcl_SetObjResult(interp, ext); + Tcl_DecrRefCount(ext); + return TCL_OK; + } else { + return TCL_ERROR; + } + } + case FCMD_ISDIRECTORY: + if (objc != 3) { + goto only3Args; + } + value = 0; + if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { + value = S_ISDIR(buf.st_mode); + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); + return TCL_OK; + case FCMD_ISFILE: + if (objc != 3) { + goto only3Args; + } + value = 0; + if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { + value = S_ISREG(buf.st_mode); + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); + return TCL_OK; + case FCMD_OWNED: + if (objc != 3) { + goto only3Args; + } + value = 0; + if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { + /* + * For Windows, there are no user ids associated with a file, so + * we always return 1. + */ + +#if defined(__WIN32__) || defined(__CYGWIN__) + value = 1; +#else + value = (geteuid() == buf.st_uid); +#endif + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); + return TCL_OK; + case FCMD_JOIN: { + Tcl_Obj *resObj; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); + return TCL_ERROR; + } + resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2); + Tcl_SetObjResult(interp, resObj); + return TCL_OK; + } + case FCMD_LINK: { + Tcl_Obj *contents; + int index; + + if (objc < 3 || objc > 5) { + Tcl_WrongNumArgs(interp, 2, objv, "?-linktype? linkname ?target?"); + return TCL_ERROR; + } + + /* + * Index of the 'source' argument. + */ + + if (objc == 5) { + index = 3; + } else { + index = 2; + } + + if (objc > 3) { + int linkAction; + if (objc == 5) { + /* + * We have a '-linktype' argument. + */ + + static const char *linkTypes[] = { + "-symbolic", "-hard", NULL + }; + if (Tcl_GetIndexFromObj(interp, objv[2], linkTypes, "switch", + 0, &linkAction) != TCL_OK) { + return TCL_ERROR; + } + if (linkAction == 0) { + linkAction = TCL_CREATE_SYMBOLIC_LINK; + } else { + linkAction = TCL_CREATE_HARD_LINK; + } + } else { + linkAction = TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK; + } + if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Create link from source to target. + */ + + contents = Tcl_FSLink(objv[index], objv[index+1], linkAction); + if (contents == NULL) { + /* + * We handle three common error cases specially, and for all + * other errors, we use the standard posix error message. + */ + + if (errno == EEXIST) { + Tcl_AppendResult(interp, "could not create new link \"", + TclGetString(objv[index]), + "\": that path already exists", NULL); + } else if (errno == ENOENT) { + /* + * There are two cases here: either the target doesn't + * exist, or the directory of the src doesn't exist. + */ + + int access; + Tcl_Obj *dirPtr = TclPathPart(interp, objv[index], + TCL_PATH_DIRNAME); + + if (dirPtr == NULL) { + return TCL_ERROR; + } + access = Tcl_FSAccess(dirPtr, F_OK); + Tcl_DecrRefCount(dirPtr); + if (access != 0) { + Tcl_AppendResult(interp, + "could not create new link \"", + TclGetString(objv[index]), + "\": no such file or directory", NULL); + } else { + Tcl_AppendResult(interp, + "could not create new link \"", + TclGetString(objv[index]), "\": target \"", + TclGetString(objv[index+1]), + "\" doesn't exist", NULL); + } + } else { + Tcl_AppendResult(interp, + "could not create new link \"", + TclGetString(objv[index]), "\" pointing to \"", + TclGetString(objv[index+1]), "\": ", + Tcl_PosixError(interp), NULL); + } + return TCL_ERROR; + } + } else { + if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Read link + */ + + contents = Tcl_FSLink(objv[index], NULL, 0); + if (contents == NULL) { + Tcl_AppendResult(interp, "could not read link \"", + TclGetString(objv[index]), "\": ", + Tcl_PosixError(interp), NULL); + return TCL_ERROR; + } + } + Tcl_SetObjResult(interp, contents); + if (objc == 3) { + /* + * If we are reading a link, we need to free this result refCount. + * If we are creating a link, this will just be objv[index+1], and + * so we don't own it. + */ + + Tcl_DecrRefCount(contents); + } + return TCL_OK; + } + case FCMD_LSTAT: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "name varName"); + return TCL_ERROR; + } + if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) { + return TCL_ERROR; + } + return StoreStatData(interp, objv[3], &buf); + case FCMD_STAT: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "name varName"); + return TCL_ERROR; + } + if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { + return TCL_ERROR; + } + return StoreStatData(interp, objv[3], &buf); + case FCMD_SIZE: + if (objc != 3) { + goto only3Args; + } + if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, + Tcl_NewWideIntObj((Tcl_WideInt) buf.st_size)); + return TCL_OK; + case FCMD_TYPE: + if (objc != 3) { + goto only3Args; + } + if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj( + GetTypeFromMode((unsigned short) buf.st_mode), -1)); + return TCL_OK; + case FCMD_MKDIR: + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); + return TCL_ERROR; + } + return TclFileMakeDirsCmd(interp, objc, objv); + case FCMD_NATIVENAME: { + const char *fileName; + Tcl_DString ds; + + if (objc != 3) { + goto only3Args; + } + fileName = TclGetString(objv[2]); + fileName = Tcl_TranslateFileName(interp, fileName, &ds); + if (fileName == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(fileName, + Tcl_DStringLength(&ds))); + Tcl_DStringFree(&ds); + return TCL_OK; + } + case FCMD_NORMALIZE: { + Tcl_Obj *fileName; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "filename"); + return TCL_ERROR; + } + + fileName = Tcl_FSGetNormalizedPath(interp, objv[2]); + if (fileName == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, fileName); + return TCL_OK; + } + case FCMD_PATHTYPE: { + Tcl_Obj *typeName; + + if (objc != 3) { + goto only3Args; + } + + switch (Tcl_FSGetPathType(objv[2])) { + case TCL_PATH_ABSOLUTE: + TclNewLiteralStringObj(typeName, "absolute"); + break; + case TCL_PATH_RELATIVE: + TclNewLiteralStringObj(typeName, "relative"); + break; + case TCL_PATH_VOLUME_RELATIVE: + TclNewLiteralStringObj(typeName, "volumerelative"); + break; + default: + return TCL_OK; + } + Tcl_SetObjResult(interp, typeName); + return TCL_OK; + } + case FCMD_READABLE: + if (objc != 3) { + goto only3Args; + } + return CheckAccess(interp, objv[2], R_OK); + case FCMD_READLINK: { + Tcl_Obj *contents; + + if (objc != 3) { + goto only3Args; + } + + if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) { + return TCL_ERROR; + } + + contents = Tcl_FSLink(objv[2], NULL, 0); + + if (contents == NULL) { + Tcl_AppendResult(interp, "could not readlink \"", + TclGetString(objv[2]), "\": ", Tcl_PosixError(interp), + NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, contents); + Tcl_DecrRefCount(contents); + return TCL_OK; + } + case FCMD_RENAME: + return TclFileRenameCmd(interp, objc, objv); + case FCMD_ROOTNAME: { + Tcl_Obj *root; + + if (objc != 3) { + goto only3Args; + } + root = TclPathPart(interp, objv[2], TCL_PATH_ROOT); + if (root != NULL) { + Tcl_SetObjResult(interp, root); + Tcl_DecrRefCount(root); + return TCL_OK; + } else { + return TCL_ERROR; + } + } + case FCMD_SEPARATOR: + if ((objc < 2) || (objc > 3)) { + Tcl_WrongNumArgs(interp, 2, objv, "?name?"); + return TCL_ERROR; + } + if (objc == 2) { + const char *separator = NULL; /* lint */ + + 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[2]); + + if (separatorObj == NULL) { + Tcl_SetResult(interp, "Unrecognised path", TCL_STATIC); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, separatorObj); + } + return TCL_OK; + case FCMD_SPLIT: { + Tcl_Obj *res; + + if (objc != 3) { + goto only3Args; + } + res = Tcl_FSSplitPath(objv[2], NULL); + if (res == NULL) { + /* How can the interp be NULL here?! DKF */ + if (interp != NULL) { + Tcl_AppendResult(interp, "could not read \"", + TclGetString(objv[2]), + "\": no such file or directory", NULL); + } + return TCL_ERROR; + } + Tcl_SetObjResult(interp, res); + return TCL_OK; + } + case FCMD_SYSTEM: { + Tcl_Obj *fsInfo; + + if (objc != 3) { + goto only3Args; + } + fsInfo = Tcl_FSFileSystemInfo(objv[2]); + if (fsInfo == NULL) { + Tcl_SetResult(interp, "Unrecognised path", TCL_STATIC); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, fsInfo); + return TCL_OK; + } + case FCMD_TAIL: { + Tcl_Obj *dirPtr; + + if (objc != 3) { + goto only3Args; + } + dirPtr = TclPathPart(interp, objv[2], TCL_PATH_TAIL); + if (dirPtr == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, dirPtr); + Tcl_DecrRefCount(dirPtr); + return TCL_OK; + } + case FCMD_VOLUMES: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_FSListVolumes()); + return TCL_OK; + case FCMD_WRITABLE: + if (objc != 3) { + goto only3Args; + } + return CheckAccess(interp, objv[2], W_OK); + } + + only3Args: + Tcl_WrongNumArgs(interp, 2, objv, "name"); + return TCL_ERROR; } /* *--------------------------------------------------------------------------- * @@ -2055,17 +1443,17 @@ if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { return TCL_ERROR; } - status = statProc(pathPtr, statPtr); + status = (*statProc)(pathPtr, statPtr); if (status < 0) { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not read \"%s\": %s", - TclGetString(pathPtr), Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "could not read \"", + TclGetString(pathPtr), "\": ", + Tcl_PosixError(interp), NULL); } return TCL_ERROR; } return TCL_OK; } @@ -2096,11 +1484,11 @@ * to store stat results. */ Tcl_StatBuf *statPtr) /* Pointer to buffer containing stat data to * store in varName. */ { Tcl_Obj *field, *value; - unsigned short mode; + register 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 @@ -2118,30 +1506,30 @@ } \ TclDecrRefCount(field); /* * Watch out porters; the inode is meant to be an *unsigned* value, so the - * cast might fail when there isn't a real arithmetic 'long long' type... + * cast might fail when there isn't a real arithmentic 'long long' type... */ - STORE_ARY("dev", Tcl_NewWideIntObj((long)statPtr->st_dev)); + STORE_ARY("dev", Tcl_NewLongObj((long)statPtr->st_dev)); STORE_ARY("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino)); - STORE_ARY("nlink", Tcl_NewWideIntObj((long)statPtr->st_nlink)); - STORE_ARY("uid", Tcl_NewWideIntObj((long)statPtr->st_uid)); - STORE_ARY("gid", Tcl_NewWideIntObj((long)statPtr->st_gid)); + STORE_ARY("nlink", Tcl_NewLongObj((long)statPtr->st_nlink)); + STORE_ARY("uid", Tcl_NewLongObj((long)statPtr->st_uid)); + STORE_ARY("gid", Tcl_NewLongObj((long)statPtr->st_gid)); 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)); + STORE_ARY("blksize", Tcl_NewLongObj((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))); + STORE_ARY("atime", Tcl_NewWideIntObj(statPtr->st_atime)); + STORE_ARY("mtime", Tcl_NewWideIntObj(statPtr->st_mtime)); + STORE_ARY("ctime", Tcl_NewWideIntObj(statPtr->st_ctime)); mode = (unsigned short) statPtr->st_mode; - STORE_ARY("mode", Tcl_NewWideIntObj(mode)); + STORE_ARY("mode", Tcl_NewIntObj(mode)); STORE_ARY("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1)); #undef STORE_ARY return TCL_OK; } @@ -2205,213 +1593,96 @@ * A standard Tcl result. * * Side effects: * See the user documentation. * - * Notes: - * This command is split into a lot of pieces so that it can avoid doing - * reentrant TEBC calls. This makes things rather hard to follow, but - * here's the plan: - * - * NR: ---------------_\ - * Direct: Tcl_ForObjCmd -> TclNRForObjCmd - * | - * ForSetupCallback - * | - * [while] ------------> TclNRForIterCallback <---------. - * | | - * ForCondCallback | - * | | - * ForNextCallback ------------| - * | | - * 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; + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ForObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int result, value; + Interp *iPtr = (Interp *) interp; if (objc != 5) { Tcl_WrongNumArgs(interp, 1, objv, "start test next command"); return TCL_ERROR; } - TclSmallAllocEx(interp, sizeof(ForIterData), iterPtr); - iterPtr->cond = objv[2]; - iterPtr->body = objv[4]; - iterPtr->next = objv[3]; - iterPtr->msg = "\n (\"for\" body line %d)"; - iterPtr->word = 4; - - TclNRAddCallback(interp, ForSetupCallback, iterPtr, NULL, NULL, NULL); - /* * TIP #280. Make invoking context available to initial script. */ - return TclNREvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1); -} - -static int -ForSetupCallback( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - ForIterData *iterPtr = (ForIterData *)data[0]; - + result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1); 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: + while (1) { /* - * We need to reset the result before evaluating the expression. - * Otherwise, any error message will be appended to the result of the - * last evaluation. + * We need to reset the result before passing it off to + * Tcl_ExprBooleanObj. Otherwise, any error message will be appended + * to the result of the last evaluation. */ Tcl_ResetResult(interp); - TclNewObj(boolObj); - TclNRAddCallback(interp, ForCondCallback, iterPtr, boolObj, NULL, - NULL); - return Tcl_NRExprObj(interp, iterPtr->cond, boolObj); - case TCL_BREAK: - result = TCL_OK; - Tcl_ResetResult(interp); - break; - case TCL_ERROR: - Tcl_AppendObjToErrorInfo(interp, - Tcl_ObjPrintf(iterPtr->msg, Tcl_GetErrorLine(interp))); - } - TclSmallFreeEx(interp, iterPtr); - return result; -} - -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) { - Tcl_DecrRefCount(boolObj); - TclSmallFreeEx(interp, iterPtr); - return TCL_ERROR; - } - Tcl_DecrRefCount(boolObj); - - if (value) { - /* TIP #280. */ - if (iterPtr->next) { - TclNRAddCallback(interp, ForNextCallback, iterPtr, NULL, NULL, - NULL); - } else { - TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, - NULL, NULL); - } - return TclNREvalObjEx(interp, iterPtr->body, 0, iPtr->cmdFramePtr, - iterPtr->word); - } - TclSmallFreeEx(interp, iterPtr); - return result; -} - -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); + result = Tcl_ExprBooleanObj(interp, objv[2], &value); + if (result != TCL_OK) { + return result; + } + if (!value) { + break; + } + + /* + * TIP #280. Make invoking context available to loop body. + */ + + result = TclEvalObjEx(interp, objv[4], 0, iPtr->cmdFramePtr, 4); + if ((result != TCL_OK) && (result != TCL_CONTINUE)) { + if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"for\" body line %d)", interp->errorLine)); + } + break; + } /* * TIP #280. Make invoking context available to next script. */ - return TclNREvalObjEx(interp, next, 0, iPtr->cmdFramePtr, 3); - } - - TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, NULL, NULL); - return result; -} - -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; - } - TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, NULL, NULL); + result = TclEvalObjEx(interp, objv[3], 0, iPtr->cmdFramePtr, 3); + if (result == TCL_BREAK) { + break; + } else if (result != TCL_OK) { + if (result == TCL_ERROR) { + Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)"); + } + return result; + } + } + if (result == TCL_BREAK) { + result = TCL_OK; + } + if (result == TCL_OK) { + Tcl_ResetResult(interp); + } return result; } /* *---------------------------------------------------------------------- * - * Tcl_ForeachObjCmd, TclNRForeachCmd, EachloopCmd -- + * Tcl_ForeachObjCmd -- * * This object-based procedure is invoked to process the "foreach" Tcl * command. See the user documentation for details on what it does. * * Results: @@ -2421,308 +1692,165 @@ * See the user documentation. * *---------------------------------------------------------------------- */ -int -Tcl_ForeachObjCmd( - ClientData clientData, - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - return Tcl_NRCallObjProc(interp, TclNRForeachCmd, clientData, objc, objv); -} - -int -TclNRForeachCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - return EachloopCmd(interp, TCL_EACH_KEEP_NONE, objc, objv); -} - -int -Tcl_LmapObjCmd( - ClientData clientData, - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - return Tcl_NRCallObjProc(interp, TclNRLmapCmd, clientData, objc, objv); -} - -int -TclNRLmapCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - return EachloopCmd(interp, TCL_EACH_COLLECT, objc, objv); -} - -static int -EachloopCmd( - Tcl_Interp *interp, /* Our context for variables and script - * evaluation. */ - int collect, /* Select collecting or accumulating mode - * (TCL_EACH_*) */ - int objc, /* The arguments being passed in... */ - Tcl_Obj *const objv[]) -{ - int numLists = (objc-2) / 2; - struct ForeachState *statePtr; - int i, j, result; + /* ARGSUSED */ +int +Tcl_ForeachObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int result = TCL_OK; + int i; /* i selects a value list */ + int j, maxj; /* Number of loop iterations */ + int v; /* v selects a loop variable */ + int numLists = (objc-2)/2; /* Count of value lists */ + Tcl_Obj *bodyPtr; + Interp *iPtr = (Interp *) interp; + + int *index; /* Array of value list indices */ + int *varcList; /* # loop variables per list */ + Tcl_Obj ***varvList; /* Array of var name lists */ + Tcl_Obj **vCopyList; /* Copies of var name list arguments */ + int *argcList; /* Array of value list sizes */ + Tcl_Obj ***argvList; /* Array of value lists */ + Tcl_Obj **aCopyList; /* Copies of value list arguments */ if (objc < 4 || (objc%2 != 0)) { Tcl_WrongNumArgs(interp, 1, objv, "varList list ?varList list ...? command"); return TCL_ERROR; } /* * Manage numList parallel value lists. - * statePtr->argvList[i] is a value list counted by statePtr->argcList[i]; - * statePtr->varvList[i] is the list of variables associated with the - * value list; - * statePtr->varcList[i] is the number of variables associated with the - * value list; - * statePtr->index[i] is the current pointer into the value list - * 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. + * argvList[i] is a value list counted by argcList[i]l; + * varvList[i] is the list of variables associated with the value list; + * varcList[i] is the number of variables associated with the value list; + * index[i] is the current pointer into the value list argvList[i]. */ - 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; - statePtr->vCopyList = (Tcl_Obj **) (statePtr->argvList + numLists); - statePtr->aCopyList = statePtr->vCopyList + numLists; - statePtr->index = (int *) (statePtr->aCopyList + numLists); - statePtr->varcList = statePtr->index + numLists; - statePtr->argcList = statePtr->varcList + numLists; - - statePtr->numLists = numLists; - statePtr->bodyPtr = objv[objc - 1]; - statePtr->bodyIdx = objc - 1; - - if (collect == TCL_EACH_COLLECT) { - statePtr->resultList = Tcl_NewListObj(0, NULL); - } else { - statePtr->resultList = NULL; - } + index = (int *) TclStackAlloc(interp, 3 * numLists * sizeof(int)); + varcList = index + numLists; + argcList = varcList + numLists; + memset(index, 0, 3 * numLists * sizeof(int)); + + varvList = (Tcl_Obj ***) + TclStackAlloc(interp, 2 * numLists * sizeof(Tcl_Obj **)); + argvList = varvList + numLists; + memset(varvList, 0, 2 * numLists * sizeof(Tcl_Obj **)); + + vCopyList = (Tcl_Obj **) + TclStackAlloc(interp, 2 * numLists * sizeof(Tcl_Obj *)); + aCopyList = vCopyList + numLists; + memset(vCopyList, 0, 2 * numLists * sizeof(Tcl_Obj *)); /* * Break up the value lists and variable lists into elements. */ - for (i=0 ; ivCopyList[i] = TclListObjCopy(interp, objv[1+i*2]); - if (statePtr->vCopyList[i] == NULL) { - result = TCL_ERROR; - goto done; - } - TclListObjGetElements(NULL, statePtr->vCopyList[i], - &statePtr->varcList[i], &statePtr->varvList[i]); - if (statePtr->varcList[i] < 1) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s varlist is empty", - (statePtr->resultList != NULL ? "lmap" : "foreach"))); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", - (statePtr->resultList != NULL ? "LMAP" : "FOREACH"), - "NEEDVARS", NULL); - result = TCL_ERROR; - goto done; - } - - statePtr->aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]); - if (statePtr->aCopyList[i] == NULL) { - result = TCL_ERROR; - goto done; - } - TclListObjGetElements(NULL, statePtr->aCopyList[i], - &statePtr->argcList[i], &statePtr->argvList[i]); - - j = statePtr->argcList[i] / statePtr->varcList[i]; - if ((statePtr->argcList[i] % statePtr->varcList[i]) != 0) { - j++; - } - if (j > statePtr->maxj) { - statePtr->maxj = j; - } - } - - /* - * If there is any work to do, assign the variables and set things going - * non-recursively. - */ - - if (statePtr->maxj > 0) { - result = ForeachAssignments(interp, statePtr); - if (result == TCL_ERROR) { - goto done; - } - - TclNRAddCallback(interp, ForeachLoopStep, statePtr, NULL, NULL, NULL); - return TclNREvalObjEx(interp, objv[objc-1], 0, - ((Interp *) interp)->cmdFramePtr, objc-1); - } - - /* - * This cleanup stage is only used when an error occurs during setup or if - * there is no work to do. - */ - - result = TCL_OK; - done: - ForeachCleanup(interp, statePtr); - return result; -} - -/* - * Post-body processing handler. - */ - -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) { - case TCL_CONTINUE: - result = TCL_OK; - break; - case TCL_OK: - if (statePtr->resultList != NULL) { - Tcl_ListObjAppendElement(interp, statePtr->resultList, - Tcl_GetObjResult(interp)); - } - break; - case TCL_BREAK: - result = TCL_OK; - goto finish; - case TCL_ERROR: - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"%s\" body line %d)", - (statePtr->resultList != NULL ? "lmap" : "foreach"), - Tcl_GetErrorLine(interp))); - default: - goto done; - } - - /* - * Test if there is work still to be done. If so, do the next round of - * variable assignments, reschedule ourselves and run the body again. - */ - - if (statePtr->maxj > ++statePtr->j) { - result = ForeachAssignments(interp, statePtr); - if (result == TCL_ERROR) { - goto done; - } - - TclNRAddCallback(interp, ForeachLoopStep, statePtr, NULL, NULL, NULL); - return TclNREvalObjEx(interp, statePtr->bodyPtr, 0, - ((Interp *) interp)->cmdFramePtr, statePtr->bodyIdx); - } - - /* - * We're done. Tidy up our work space and finish off. - */ - - finish: - if (statePtr->resultList == NULL) { - Tcl_ResetResult(interp); - } else { - Tcl_SetObjResult(interp, statePtr->resultList); - statePtr->resultList = NULL; /* Don't clean it up */ - } - - done: - ForeachCleanup(interp, statePtr); - return result; -} - -/* - * Factored out code to do the assignments in [foreach]. - */ - -static inline int -ForeachAssignments( - Tcl_Interp *interp, - struct ForeachState *statePtr) -{ - int i, v, k; - Tcl_Obj *valuePtr, *varValuePtr; - - for (i=0 ; inumLists ; i++) { - for (v=0 ; vvarcList[i] ; v++) { - k = statePtr->index[i]++; - - if (k < statePtr->argcList[i]) { - valuePtr = statePtr->argvList[i][k]; - } else { - TclNewObj(valuePtr); /* Empty string */ - } - - varValuePtr = Tcl_ObjSetVar2(interp, statePtr->varvList[i][v], - NULL, valuePtr, TCL_LEAVE_ERR_MSG); - - if (varValuePtr == NULL) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (setting %s loop variable \"%s\")", - (statePtr->resultList != NULL ? "lmap" : "foreach"), - TclGetString(statePtr->varvList[i][v]))); - return TCL_ERROR; - } - } - } - - return TCL_OK; -} - -/* - * Factored out code for cleaning up the state of the foreach. - */ - -static inline void -ForeachCleanup( - Tcl_Interp *interp, - struct ForeachState *statePtr) -{ - int i; - - for (i=0 ; inumLists ; i++) { - if (statePtr->vCopyList[i]) { - TclDecrRefCount(statePtr->vCopyList[i]); - } - if (statePtr->aCopyList[i]) { - TclDecrRefCount(statePtr->aCopyList[i]); - } - } - if (statePtr->resultList != NULL) { - TclDecrRefCount(statePtr->resultList); - } - TclStackFree(interp, statePtr); + maxj = 0; + for (i=0 ; i maxj) { + maxj = j; + } + } + + /* + * Iterate maxj times through the lists in parallel. If some value lists + * run out of values, set loop vars to "" + */ + + bodyPtr = objv[objc-1]; + for (j=0 ; jcmdFramePtr, objc-1); + if (result != TCL_OK) { + if (result == TCL_CONTINUE) { + result = TCL_OK; + } else if (result == TCL_BREAK) { + result = TCL_OK; + break; + } else if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"foreach\" body line %d)", + interp->errorLine)); + break; + } else { + break; + } + } + } + if (result == TCL_OK) { + Tcl_ResetResult(interp); + } + + done: + for (i=0 ; i= objc) { + clause = TclGetString(objv[i-1]); + Tcl_AppendResult(interp, "wrong # args: ", + "no expression after \"", clause, "\" argument", NULL); + return TCL_ERROR; + } + if (!thenScriptIndex) { + result = Tcl_ExprBooleanObj(interp, objv[i], &value); + if (result != TCL_OK) { + return result; + } + } i++; if (i >= objc) { - goto missingScript; + missingScript: + clause = TclGetString(objv[i-1]); + Tcl_AppendResult(interp, "wrong # args: ", + "no script following \"", clause, "\" argument", NULL); + return TCL_ERROR; } clause = TclGetString(objv[i]); if ((i < objc) && (strcmp(clause, "then") == 0)) { i++; } @@ -273,41 +263,21 @@ if (thenScriptIndex) { /* * TIP #280. Make invoking context available to branch. */ - return TclNREvalObjEx(interp, objv[thenScriptIndex], 0, + return TclEvalObjEx(interp, objv[thenScriptIndex], 0, iPtr->cmdFramePtr, thenScriptIndex); } return TCL_OK; } clause = TclGetString(objv[i]); - if ((clause[0] != 'e') || (strcmp(clause, "elseif") != 0)) { - break; - } - i++; - - /* - * At this point in the loop, objv and objc refer to an expression to - * test, either for the main expression or an expression following an - * "elseif". The arguments after the expression must be "then" - * (optional) and a script to execute if the expression is true. - */ - - if (i >= objc) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "wrong # args: no expression after \"%s\" argument", - clause)); - Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); - return TCL_ERROR; - } - if (!thenScriptIndex) { - TclNewObj(boolObj); - Tcl_NRAddCallback(interp, IfConditionCallback, data[0], data[1], - INT2PTR(i), boolObj); - return Tcl_NRExprObj(interp, objv[i], boolObj); - } + if ((clause[0] == 'e') && (strcmp(clause, "elseif") == 0)) { + i++; + continue; + } + break; } /* * Couldn't find a "then" or "elseif" clause to execute. Check now for an * "else" clause. We know that there's at least one more argument when we @@ -315,36 +285,29 @@ */ if (strcmp(clause, "else") == 0) { i++; if (i >= objc) { - goto missingScript; + Tcl_AppendResult(interp, "wrong # args: ", + "no script following \"else\" argument", NULL); + return TCL_ERROR; } } if (i < objc - 1) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "wrong # args: extra words after \"else\" clause in \"if\" command", - -1)); - Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); + Tcl_AppendResult(interp, "wrong # args: ", + "extra words after \"else\" clause in \"if\" command", NULL); return TCL_ERROR; } if (thenScriptIndex) { /* * TIP #280. Make invoking context available to branch/else. */ - return TclNREvalObjEx(interp, objv[thenScriptIndex], 0, + return TclEvalObjEx(interp, objv[thenScriptIndex], 0, iPtr->cmdFramePtr, thenScriptIndex); } - return TclNREvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr, i); - - missingScript: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "wrong # args: no script following \"%s\" argument", - TclGetString(objv[i-1]))); - Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); - return TCL_ERROR; + return TclEvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr, i); } /* *---------------------------------------------------------------------- * @@ -366,11 +329,11 @@ *---------------------------------------------------------------------- */ int Tcl_IncrObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *newValuePtr, *incrPtr; @@ -381,11 +344,11 @@ } if (objc == 3) { incrPtr = objv[2]; } else { - TclNewIntObj(incrPtr, 1); + incrPtr = Tcl_NewIntObj(1); } Tcl_IncrRefCount(incrPtr); newValuePtr = TclIncrObjVar2(interp, objv[1], NULL, incrPtr, TCL_LEAVE_ERR_MSG); Tcl_DecrRefCount(incrPtr); @@ -410,11 +373,11 @@ * * This function is called to create the "info" Tcl command. See the user * documentation for details on what it does. * * Results: - * Handle for the info command, or NULL on failure. + * FIXME * * Side effects: * none * *---------------------------------------------------------------------- @@ -447,17 +410,17 @@ *---------------------------------------------------------------------- */ static int InfoArgsCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Interp *iPtr = (Interp *) interp; - const char *name; + register Interp *iPtr = (Interp *) interp; + char *name; Proc *procPtr; CompiledLocal *localPtr; Tcl_Obj *listObjPtr; if (objc != 2) { @@ -466,13 +429,11 @@ } name = TclGetString(objv[1]); procPtr = TclFindProc(iPtr, name); if (procPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't a procedure", name)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL); + Tcl_AppendResult(interp, "\"", name, "\" isn't a procedure", NULL); return TCL_ERROR; } /* * Build a return list containing the arguments. @@ -510,31 +471,29 @@ *---------------------------------------------------------------------- */ static int InfoBodyCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Interp *iPtr = (Interp *) interp; - const char *name, *bytes; + register Interp *iPtr = (Interp *) interp; + char *name; Proc *procPtr; - size_t numBytes; + Tcl_Obj *bodyPtr, *resultPtr; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "procname"); return TCL_ERROR; } name = TclGetString(objv[1]); procPtr = TclFindProc(iPtr, name); if (procPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't a procedure", name)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL); + Tcl_AppendResult(interp, "\"", name, "\" isn't a procedure", NULL); return TCL_ERROR; } /* * Here we used to return procPtr->bodyPtr, except when the body was @@ -543,12 +502,22 @@ * compiler/engine subsystem, we now always return a copy of the string * rep. It is important to return a copy so that later manipulations of * the object do not invalidate the internal rep. */ - bytes = TclGetStringFromObj(procPtr->bodyPtr, &numBytes); - Tcl_SetObjResult(interp, Tcl_NewStringObj(bytes, numBytes)); + bodyPtr = procPtr->bodyPtr; + if (bodyPtr->bytes == NULL) { + /* + * The string rep might not be valid if the procedure has never been + * run before. [Bug #545644] + */ + + (void) TclGetString(bodyPtr); + } + resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length); + + Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -571,11 +540,11 @@ *---------------------------------------------------------------------- */ static int InfoCmdCountCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; @@ -583,11 +552,11 @@ if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(iPtr->cmdCount)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(iPtr->cmdCount)); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -613,26 +582,26 @@ *---------------------------------------------------------------------- */ static int InfoCommandsCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *cmdName, *pattern; + char *cmdName, *pattern; const char *simplePattern; - Tcl_HashEntry *entryPtr; + register 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; - size_t i; + int i; /* * Get the pattern and find the "effective namespace" in which to list * commands. */ @@ -651,12 +620,12 @@ */ Namespace *dummy1NsPtr, *dummy2NsPtr; pattern = TclGetString(objv[1]); - TclGetNamespaceForQualName(interp, pattern, NULL, 0, &nsPtr, - &dummy1NsPtr, &dummy2NsPtr, &simplePattern); + TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, 0, + &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); if (nsPtr != NULL) { /* We successfully found the pattern's ns. */ specificNsInPattern = (strcmp(simplePattern, pattern) != 0); } } else { @@ -688,15 +657,15 @@ */ entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); if (entryPtr != NULL) { if (specificNsInPattern) { - cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr); + cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); elemObjPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, cmd, elemObjPtr); } else { - cmdName = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); + cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); elemObjPtr = Tcl_NewStringObj(cmdName, -1); } Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); Tcl_SetObjResult(interp, listPtr); return TCL_OK; @@ -719,11 +688,11 @@ if (entryPtr == NULL) { tablePtr = &globalNsPtr->cmdTable; entryPtr = Tcl_FindHashEntry(tablePtr, simplePattern); } if (entryPtr != NULL) { - cmdName = (const char *)Tcl_GetHashKey(tablePtr, entryPtr); + cmdName = Tcl_GetHashKey(tablePtr, entryPtr); Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(cmdName, -1)); Tcl_SetObjResult(interp, listPtr); return TCL_OK; } @@ -735,15 +704,15 @@ * old matching scheme is perfect. */ entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); while (entryPtr != NULL) { - cmdName = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); + cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) || Tcl_StringMatch(cmdName, simplePattern)) { if (specificNsInPattern) { - cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr); + cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); elemObjPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, cmd, elemObjPtr); } else { elemObjPtr = Tcl_NewStringObj(cmdName, -1); } @@ -761,11 +730,11 @@ */ if ((nsPtr != globalNsPtr) && !specificNsInPattern) { entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search); while (entryPtr != NULL) { - cmdName = (const char *)Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); + cmdName = 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)); @@ -792,17 +761,17 @@ Tcl_InitObjHashTable(&addedCommandsTable); entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); while (entryPtr != NULL) { - cmdName = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); + cmdName = 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); + (char *)elemObjPtr, &isNew); } entryPtr = Tcl_NextHashEntry(&search); } /* @@ -818,16 +787,16 @@ if (pathNsPtr == globalNsPtr) { foundGlobal = 1; } entryPtr = Tcl_FirstHashEntry(&pathNsPtr->cmdTable, &search); while (entryPtr != NULL) { - cmdName = (const char *)Tcl_GetHashKey(&pathNsPtr->cmdTable, entryPtr); + cmdName = Tcl_GetHashKey(&pathNsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) || Tcl_StringMatch(cmdName, simplePattern)) { elemObjPtr = Tcl_NewStringObj(cmdName, -1); (void) Tcl_CreateHashEntry(&addedCommandsTable, - elemObjPtr, &isNew); + (char *) elemObjPtr, &isNew); if (isNew) { Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); } else { TclDecrRefCount(elemObjPtr); } @@ -845,11 +814,11 @@ */ if (!foundGlobal) { entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search); while (entryPtr != NULL) { - cmdName = (const char *)Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); + cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) || Tcl_StringMatch(cmdName, simplePattern)) { elemObjPtr = Tcl_NewStringObj(cmdName, -1); if (Tcl_FindHashEntry(&addedCommandsTable, (char *) elemObjPtr) == NULL) { @@ -890,11 +859,11 @@ *---------------------------------------------------------------------- */ static int InfoCompleteCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { if (objc != 2) { @@ -927,17 +896,17 @@ *---------------------------------------------------------------------- */ static int InfoDefaultCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - const char *procName, *argName; + char *procName, *argName, *varName; Proc *procPtr; CompiledLocal *localPtr; Tcl_Obj *valueObjPtr; if (objc != 4) { @@ -948,96 +917,47 @@ procName = TclGetString(objv[1]); argName = TclGetString(objv[2]); procPtr = TclFindProc(iPtr, procName); if (procPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't a procedure", procName)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", procName, - NULL); + Tcl_AppendResult(interp, "\"", procName, "\" isn't a procedure",NULL); return TCL_ERROR; } for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; localPtr = localPtr->nextPtr) { if (TclIsVarArgument(localPtr) && (strcmp(argName, localPtr->name) == 0)) { if (localPtr->defValuePtr != NULL) { valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL, - localPtr->defValuePtr, TCL_LEAVE_ERR_MSG); - if (valueObjPtr == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1)); - } else { - Tcl_Obj *nullObjPtr = Tcl_NewObj(); - - valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL, - nullObjPtr, TCL_LEAVE_ERR_MSG); - if (valueObjPtr == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0)); - } - return TCL_OK; - } - } - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "procedure \"%s\" doesn't have an argument \"%s\"", - procName, argName)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARGUMENT", argName, NULL); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * InfoErrorStackCmd -- - * - * Called to implement the "info errorstack" command that returns information - * about the last error's call stack. Handles the following syntax: - * - * info errorstack ?interp? - * - * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. - * - * Side effects: - * Returns a result in the interpreter's result object. If there is an - * error, the result is an error message. - * - *---------------------------------------------------------------------- - */ - -static int -InfoErrorStackCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Interp *target; - Interp *iPtr; - - if ((objc != 1) && (objc != 2)) { - Tcl_WrongNumArgs(interp, 1, objv, "?interp?"); - return TCL_ERROR; - } - - target = interp; - if (objc == 2) { - target = Tcl_GetChild(interp, TclGetString(objv[1])); - if (target == NULL) { - return TCL_ERROR; - } - } - - iPtr = (Interp *) target; - Tcl_SetObjResult(interp, iPtr->errorStack); - - return TCL_OK; + localPtr->defValuePtr, 0); + if (valueObjPtr == NULL) { + goto defStoreError; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); + } else { + Tcl_Obj *nullObjPtr = Tcl_NewObj(); + valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL, + nullObjPtr, 0); + if (valueObjPtr == NULL) { + goto defStoreError; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + } + return TCL_OK; + } + } + + Tcl_AppendResult(interp, "procedure \"", procName, + "\" doesn't have an argument \"", argName, "\"", NULL); + return TCL_ERROR; + + defStoreError: + varName = TclGetString(objv[3]); + Tcl_AppendResult(interp, "couldn't store default value in variable \"", + varName, "\"", NULL); + return TCL_ERROR; } /* *---------------------------------------------------------------------- * @@ -1058,16 +978,16 @@ *---------------------------------------------------------------------- */ int TclInfoExistsCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *varName; + char *varName; Var *varPtr; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "varName"); return TCL_ERROR; @@ -1103,120 +1023,73 @@ *---------------------------------------------------------------------- */ static int InfoFrameCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ 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; - CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - int topLevel = 0; - - if (objc > 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?number?"); - return TCL_ERROR; - } - - while (corPtr) { - while (*cmdFramePtrPtr) { - topLevel++; - cmdFramePtrPtr = &((*cmdFramePtrPtr)->nextPtr); - } - if (corPtr->caller.cmdFramePtr) { - *cmdFramePtrPtr = corPtr->caller.cmdFramePtr; - } - corPtr = corPtr->callerEEPtr->corPtr; - } - topLevel += (*cmdFramePtrPtr)->level; - - if (topLevel != iPtr->cmdFramePtr->level) { - framePtr = iPtr->cmdFramePtr; - while (framePtr) { - framePtr->level = topLevel--; - framePtr = framePtr->nextPtr; - } - if (topLevel) { - Tcl_Panic("Broken frame level calculation"); - } - topLevel = iPtr->cmdFramePtr->level; - } + int level; + CmdFrame *framePtr; if (objc == 1) { /* * Just "info frame". */ - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(topLevel)); - goto done; + int levels = + (iPtr->cmdFramePtr == NULL ? 0 : iPtr->cmdFramePtr->level); + + Tcl_SetObjResult(interp, Tcl_NewIntObj (levels)); + return TCL_OK; + } else if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?number?"); + return TCL_ERROR; } /* * We've got "info frame level" and must parse the level first. */ if (TclGetIntFromObj(interp, objv[1], &level) != TCL_OK) { - code = TCL_ERROR; - goto done; - } - - if ((level > topLevel) || (level <= - topLevel)) { - levelError: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad level \"%s\"", TclGetString(objv[1]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", - TclGetString(objv[1]), NULL); - code = TCL_ERROR; - goto done; - } - - /* - * Let us convert to relative so that we know how many levels to go back - */ - - if (level > 0) { - level -= topLevel; - } - - framePtr = iPtr->cmdFramePtr; - while (++level <= 0) { - framePtr = framePtr->nextPtr; - if (!framePtr) { - goto levelError; - } + return TCL_ERROR; + } + if (level <= 0) { + /* + * Negative levels are adressing relative to the current frame's + * depth. + */ + + if (iPtr->cmdFramePtr == NULL) { + levelError: + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad level \"", + TclGetString(objv[1]), "\"", NULL); + return TCL_ERROR; + } + + /* + * Convert to absolute. + */ + + level += iPtr->cmdFramePtr->level; + } + + for (framePtr = iPtr->cmdFramePtr; framePtr != NULL; + framePtr = framePtr->nextPtr) { + if (framePtr->level == level) { + break; + } + } + if (framePtr == NULL) { + goto levelError; } Tcl_SetObjResult(interp, TclInfoFrame(interp, framePtr)); - - done: - cmdFramePtrPtr = &iPtr->cmdFramePtr; - corPtr = iPtr->execEnvPtr->corPtr; - while (corPtr) { - CmdFrame *endPtr = corPtr->caller.cmdFramePtr; - - if (endPtr) { - if (*cmdFramePtrPtr == endPtr) { - *cmdFramePtrPtr = NULL; - } else { - CmdFrame *runPtr = *cmdFramePtrPtr; - - while (runPtr->nextPtr != endPtr) { - runPtr->level -= endPtr->level; - runPtr = runPtr->nextPtr; - } - runPtr->level = 1; - runPtr->nextPtr = NULL; - } - cmdFramePtrPtr = &corPtr->caller.cmdFramePtr; - } - corPtr = corPtr->callerEEPtr->corPtr; - } - return code; + return TCL_OK; } /* *---------------------------------------------------------------------- * @@ -1237,25 +1110,25 @@ TclInfoFrame( Tcl_Interp *interp, /* Current interpreter. */ CmdFrame *framePtr) /* Frame to get info for. */ { Interp *iPtr = (Interp *) interp; - Tcl_Obj *tmpObj; Tcl_Obj *lv[20]; /* Keep uptodate when more keys are added to * the dict. */ int lc = 0; /* * This array is indexed by the TCL_LOCATION_... values, except * for _LAST. */ - static const char *const typeString[TCL_LOCATION_LAST] = { + static const char *typeString[TCL_LOCATION_LAST] = { "eval", "eval", "eval", "precompiled", "source", "proc" }; - Proc *procPtr = framePtr->framePtr ? framePtr->framePtr->procPtr : NULL; - int needsFree = -1; + Tcl_Obj *tmpObj; + Proc *procPtr = + framePtr->framePtr ? framePtr->framePtr->procPtr : NULL; - /* + /* * Pull the information and construct the dictionary to return, as list. * Regarding use of the CmdFrame fields see tclInt.h, and its definition. */ #define ADD_PAIR(name, value) \ @@ -1269,16 +1142,32 @@ * Evaluation, dynamic script. Type, line, cmd, the latter through * str. */ ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1)); - if (framePtr->line) { - ADD_PAIR("line", Tcl_NewWideIntObj(framePtr->line[0])); - } else { - ADD_PAIR("line", Tcl_NewWideIntObj(1)); - } - ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL)); + ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0])); + ADD_PAIR("cmd", Tcl_NewStringObj(framePtr->cmd.str.cmd, + framePtr->cmd.str.len)); + break; + + case TCL_LOCATION_EVAL_LIST: + /* + * List optimized evaluation. Type, line, cmd, the latter through + * listPtr, possibly a frame. + */ + + ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1)); + ADD_PAIR("line", Tcl_NewIntObj(1)); + + /* + * We put a duplicate of the command list obj into the result to + * ensure that the 'pure List'-property of the command itself is not + * destroyed. Otherwise the query here would disable the list + * optimization path in Tcl_EvalObjEx. + */ + + ADD_PAIR("cmd", Tcl_DuplicateObj(framePtr->cmd.listPtr)); break; case TCL_LOCATION_PREBC: /* * Precompiled. Result contains the type as signal, nothing else. @@ -1290,12 +1179,13 @@ case TCL_LOCATION_BC: { /* * Execution of bytecode. Talk to the BC engine to fill out the frame. */ - CmdFrame *fPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame)); + CmdFrame *fPtr; + fPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); *fPtr = *framePtr; /* * Note: * Type BC => f.data.eval.path is not used. @@ -1309,11 +1199,11 @@ * Possibly modified: type, path! */ ADD_PAIR("type", Tcl_NewStringObj(typeString[fPtr->type], -1)); if (fPtr->line) { - ADD_PAIR("line", Tcl_NewWideIntObj(fPtr->line[0])); + ADD_PAIR("line", Tcl_NewIntObj(fPtr->line[0])); } if (fPtr->type == TCL_LOCATION_SOURCE) { ADD_PAIR("file", fPtr->data.eval.path); @@ -1322,14 +1212,12 @@ */ Tcl_DecrRefCount(fPtr->data.eval.path); } - ADD_PAIR("cmd", TclGetSourceFromFrame(fPtr, 0, NULL)); - if (fPtr->cmdObj && framePtr->cmdObj == NULL) { - needsFree = lc - 1; - } + ADD_PAIR("cmd", + Tcl_NewStringObj(fPtr->cmd.str.cmd, fPtr->cmd.str.len)); TclStackFree(interp, fPtr); break; } case TCL_LOCATION_SOURCE: @@ -1336,19 +1224,20 @@ /* * Evaluation of a script file. */ ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1)); - ADD_PAIR("line", Tcl_NewWideIntObj(framePtr->line[0])); + ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0])); ADD_PAIR("file", framePtr->data.eval.path); /* * Refcount framePtr->data.eval.path goes up when lv is converted into * the result list object. */ - ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL)); + ADD_PAIR("cmd", Tcl_NewStringObj(framePtr->cmd.str.cmd, + framePtr->cmd.str.len)); break; case TCL_LOCATION_PROC: Tcl_Panic("TCL_LOCATION_PROC found in standard frame"); break; @@ -1361,23 +1250,26 @@ if (procPtr != NULL) { Tcl_HashEntry *namePtr = procPtr->cmdPtr->hPtr; if (namePtr) { - Tcl_Obj *procNameObj; - /* * This is a regular command. */ - TclNewObj(procNameObj); - Tcl_GetCommandFullName(interp, (Tcl_Command) procPtr->cmdPtr, - procNameObj); - ADD_PAIR("proc", procNameObj); + char *procName = Tcl_GetHashKey(namePtr->tablePtr, namePtr); + char *nsName = procPtr->cmdPtr->nsPtr->fullName; + + ADD_PAIR("proc", Tcl_NewStringObj(nsName, -1)); + + if (strcmp(nsName, "::") != 0) { + Tcl_AppendToObj(lv[lc-1], "::", -1); + } + Tcl_AppendToObj(lv[lc-1], procName, -1); } else if (procPtr->cmdPtr->clientData) { - ExtraFrameInfo *efiPtr = (ExtraFrameInfo *)procPtr->cmdPtr->clientData; - size_t i; + ExtraFrameInfo *efiPtr = procPtr->cmdPtr->clientData; + int i; /* * This is a non-standard command. Luckily, it's told us how to * render extra information about its frame. */ @@ -1386,11 +1278,11 @@ 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; + lv[lc++] = efiPtr->fields[i].clientData; } } } } @@ -1407,21 +1299,17 @@ for (idx=top ; idx!=NULL ; idx=idx->callerVarPtr) { if (idx == current) { int c = framePtr->framePtr->level; int t = iPtr->varFramePtr->level; - ADD_PAIR("level", Tcl_NewWideIntObj(t - c)); + ADD_PAIR("level", Tcl_NewIntObj(t - c)); break; } } } - tmpObj = Tcl_NewListObj(lc, lv); - if (needsFree >= 0) { - Tcl_DecrRefCount(lv[needsFree]); - } - return tmpObj; + return Tcl_NewListObj(lc, lv); } /* *---------------------------------------------------------------------- * @@ -1443,11 +1331,11 @@ *---------------------------------------------------------------------- */ static int InfoFunctionsCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *script; @@ -1508,11 +1396,11 @@ *---------------------------------------------------------------------- */ static int InfoHostnameCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *name; @@ -1525,14 +1413,11 @@ name = Tcl_GetHostName(); if (name) { Tcl_SetObjResult(interp, Tcl_NewStringObj(name, -1)); return TCL_OK; } - - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unable to determine name of host", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "HOSTNAME", "UNKNOWN", NULL); + Tcl_SetResult(interp, "unable to determine name of host", TCL_STATIC); return TCL_ERROR; } /* *---------------------------------------------------------------------- @@ -1554,19 +1439,19 @@ *---------------------------------------------------------------------- */ static int InfoLevelCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ 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" */ - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(iPtr->varFramePtr->level)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(iPtr->varFramePtr->level)); return TCL_OK; } if (objc == 2) { int level; @@ -1598,14 +1483,12 @@ Tcl_WrongNumArgs(interp, 1, objv, "?number?"); return TCL_ERROR; levelError: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad level \"%s\"", TclGetString(objv[1]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", - TclGetString(objv[1]), NULL); + Tcl_AppendResult(interp, "bad level \"", TclGetString(objv[1]), "\"", + NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- @@ -1628,11 +1511,11 @@ *---------------------------------------------------------------------- */ static int InfoLibraryCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *libDirName; @@ -1640,19 +1523,16 @@ if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } - libDirName = Tcl_GetVar2(interp, "tcl_library", NULL, TCL_GLOBAL_ONLY); + libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); if (libDirName != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj(libDirName, -1)); return TCL_OK; } - - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "no library has been specified for Tcl", -1)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", "tcl_library",NULL); + Tcl_SetResult(interp, "no library has been specified for Tcl",TCL_STATIC); return TCL_ERROR; } /* *---------------------------------------------------------------------- @@ -1675,33 +1555,28 @@ *---------------------------------------------------------------------- */ static int InfoLoadedCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *interpName, *packageName; + char *interpName; - if (objc > 3) { - Tcl_WrongNumArgs(interp, 1, objv, "?interp? ?packageName?"); + if ((objc != 1) && (objc != 2)) { + Tcl_WrongNumArgs(interp, 1, objv, "?interp?"); return TCL_ERROR; } - if (objc < 2) { /* Get loaded pkgs in all interpreters. */ + if (objc == 1) { /* Get loaded pkgs in all interpreters. */ interpName = NULL; } else { /* Get pkgs just in specified interp. */ interpName = TclGetString(objv[1]); } - if (objc < 3) { /* Get loaded files in all packages. */ - packageName = NULL; - } else { /* Get pkgs just in specified interp. */ - packageName = TclGetString(objv[2]); - } - return TclGetLoadedPackagesEx(interp, interpName, packageName); + return TclGetLoadedPackages(interp, interpName); } /* *---------------------------------------------------------------------- * @@ -1723,11 +1598,11 @@ *---------------------------------------------------------------------- */ static int InfoNameOfExecutableCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { if (objc != 1) { @@ -1759,11 +1634,11 @@ *---------------------------------------------------------------------- */ static int InfoPatchLevelCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *patchlevel; @@ -1771,11 +1646,11 @@ if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } - patchlevel = Tcl_GetVar2(interp, "tcl_patchLevel", NULL, + patchlevel = Tcl_GetVar(interp, "tcl_patchLevel", (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); if (patchlevel != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj(patchlevel, -1)); return TCL_OK; } @@ -1806,25 +1681,25 @@ *---------------------------------------------------------------------- */ static int InfoProcsCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *cmdName, *pattern; + 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; + register Tcl_HashEntry *entryPtr; Tcl_HashSearch search; Command *cmdPtr, *realCmdPtr; /* * Get the pattern and find the "effective namespace" in which to list @@ -1845,12 +1720,13 @@ */ Namespace *dummy1NsPtr, *dummy2NsPtr; pattern = TclGetString(objv[1]); - TclGetNamespaceForQualName(interp, pattern, NULL, /*flags*/ 0, &nsPtr, - &dummy1NsPtr, &dummy2NsPtr, &simplePattern); + TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, + /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, + &simplePattern); if (nsPtr != NULL) { /* We successfully found the pattern's ns. */ specificNsInPattern = (strcmp(simplePattern, pattern) != 0); } } else { @@ -1872,11 +1748,11 @@ 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); + cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); if (!TclIsProc(cmdPtr)) { realCmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) { @@ -1897,14 +1773,14 @@ } else #endif /* !INFO_PROCS_SEARCH_GLOBAL_NS */ { entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); while (entryPtr != NULL) { - cmdName = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); + cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) || Tcl_StringMatch(cmdName, simplePattern)) { - cmdPtr = (Command *)Tcl_GetHashValue(entryPtr); + cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); if (!TclIsProc(cmdPtr)) { realCmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) { @@ -1935,23 +1811,23 @@ #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 + * code. As this could break backwards compatibilty 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); + cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); if ((simplePattern == NULL) || Tcl_StringMatch(cmdName, simplePattern)) { if (Tcl_FindHashEntry(&nsPtr->cmdTable,cmdName) == NULL) { - cmdPtr = (Command *)Tcl_GetHashValue(entryPtr); + cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); realCmdPtr = (Command *) TclGetOriginalCommand( (Tcl_Command) cmdPtr); if (TclIsProc(cmdPtr) || ((realCmdPtr != NULL) && TclIsProc(realCmdPtr))) { @@ -1993,17 +1869,16 @@ *---------------------------------------------------------------------- */ static int InfoScriptCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ 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; } @@ -2041,11 +1916,11 @@ *---------------------------------------------------------------------- */ static int InfoSharedlibCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { if (objc != 1) { @@ -2079,11 +1954,11 @@ *---------------------------------------------------------------------- */ static int InfoTclVersionCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *version; @@ -2103,64 +1978,10 @@ } /* *---------------------------------------------------------------------- * - * InfoCmdTypeCmd -- - * - * Called to implement the "info cmdtype" command that returns the type - * of a given command. Handles the following syntax: - * - * info cmdtype cmdName - * - * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. - * - * Side effects: - * Returns a type name. If there is an error, the result is an error - * message. - * - *---------------------------------------------------------------------- - */ - -static int -InfoCmdTypeCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Command command; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "commandName"); - return TCL_ERROR; - } - command = Tcl_FindCommand(interp, TclGetString(objv[1]), NULL, - TCL_LEAVE_ERR_MSG); - if (command == NULL) { - return TCL_ERROR; - } - - /* - * There's one special case: safe child interpreters can't see aliases as - * aliases as they're part of the security mechanisms. - */ - - if (Tcl_IsSafe(interp) - && (((Command *) command)->objProc == TclAliasObjCmd)) { - Tcl_AppendResult(interp, "native", NULL); - } else { - Tcl_SetObjResult(interp, - Tcl_NewStringObj(TclGetCommandTypeName(command), -1)); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_JoinObjCmd -- * * This procedure is invoked to process the "join" Tcl command. See the * user documentation for details on what it does. * @@ -2173,18 +1994,17 @@ *---------------------------------------------------------------------- */ int Tcl_JoinObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { - size_t length; - int listLen; - Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs; + int listLen, i; + Tcl_Obj *resObjPtr, *joinObjPtr, **elemPtrs; if ((objc < 2) || (objc > 3)) { Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?"); return TCL_ERROR; } @@ -2197,51 +2017,31 @@ if (TclListObjGetElements(interp, objv[1], &listLen, &elemPtrs) != TCL_OK) { return TCL_ERROR; } - if (listLen == 0) { - /* No elements to join; default empty result is correct. */ - return TCL_OK; - } - if (listLen == 1) { - /* One element; return it */ - Tcl_SetObjResult(interp, elemPtrs[0]); - return TCL_OK; - } - joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2]; Tcl_IncrRefCount(joinObjPtr); - (void) TclGetStringFromObj(joinObjPtr, &length); - if (length == 0) { - resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0); - } else { - int i; - - resObjPtr = Tcl_NewObj(); - for (i = 0; i < listLen; i++) { - if (i > 0) { - - /* - * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT** - * to shimmer joinObjPtr. If it did, then the case where - * objv[1] and objv[2] are the same value would not be safe. - * Accessing elemPtrs would crash. - */ - - Tcl_AppendObjToObj(resObjPtr, joinObjPtr); - } - Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); - } + resObjPtr = Tcl_NewObj(); + for (i = 0; i < listLen; i++) { + if (i > 0) { + + /* + * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT** + * to shimmer joinObjPtr. If it did, then the case where + * objv[1] and objv[2] are the same value would not be safe. + * Accessing elemPtrs would crash. + */ + + Tcl_AppendObjToObj(resObjPtr, joinObjPtr); + } + Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); } Tcl_DecrRefCount(joinObjPtr); - if (resObjPtr) { - Tcl_SetObjResult(interp, resObjPtr); - return TCL_OK; - } - return TCL_ERROR; + Tcl_SetObjResult(interp, resObjPtr); + return TCL_OK; } /* *---------------------------------------------------------------------- * @@ -2259,22 +2059,22 @@ *---------------------------------------------------------------------- */ int Tcl_LassignObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ 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. */ int code = TCL_OK; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "list ?varName ...?"); + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "list varName ?varName ...?"); return TCL_ERROR; } listCopyPtr = TclListObjCopy(interp, objv[1]); if (listCopyPtr == NULL) { @@ -2284,26 +2084,24 @@ TclListObjGetElements(NULL, listCopyPtr, &listObjc, &listObjv); objc -= 2; objv += 2; while (code == TCL_OK && objc > 0 && listObjc > 0) { - if (Tcl_ObjSetVar2(interp, *objv++, NULL, *listObjv++, - TCL_LEAVE_ERR_MSG) == NULL) { + if (NULL == Tcl_ObjSetVar2(interp, *objv++, NULL, + *listObjv++, TCL_LEAVE_ERR_MSG)) { code = TCL_ERROR; } - objc--; - listObjc--; + objc--; listObjc--; } if (code == TCL_OK && objc > 0) { Tcl_Obj *emptyObj; - TclNewObj(emptyObj); Tcl_IncrRefCount(emptyObj); while (code == TCL_OK && objc-- > 0) { - if (Tcl_ObjSetVar2(interp, *objv++, NULL, emptyObj, - TCL_LEAVE_ERR_MSG) == NULL) { + if (NULL == Tcl_ObjSetVar2(interp, *objv++, NULL, + emptyObj, TCL_LEAVE_ERR_MSG)) { code = TCL_ERROR; } } Tcl_DecrRefCount(emptyObj); } @@ -2333,19 +2131,20 @@ *---------------------------------------------------------------------- */ int Tcl_LindexObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ 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 ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "list ?index...?"); return TCL_ERROR; } /* * If objc==3, then objv[2] may be either a single index or a list of @@ -2364,15 +2163,15 @@ * Set the interpreter's object result to the last element extracted. */ if (elemPtr == NULL) { return TCL_ERROR; + } else { + Tcl_SetObjResult(interp, elemPtr); + Tcl_DecrRefCount(elemPtr); + return TCL_OK; } - - Tcl_SetObjResult(interp, elemPtr); - Tcl_DecrRefCount(elemPtr); - return TCL_OK; } /* *---------------------------------------------------------------------- * @@ -2391,21 +2190,20 @@ *---------------------------------------------------------------------- */ int Tcl_LinsertObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + register int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *listPtr; - size_t index; - int len, result; + int index, len, result; - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "list index ?element ...?"); + if (objc < 4) { + Tcl_WrongNumArgs(interp, 1, objv, "list index element ?element ...?"); return TCL_ERROR; } result = TclListObjLength(interp, objv[1], &len); if (result != TCL_OK) { @@ -2420,11 +2218,11 @@ result = TclGetIntForIndexM(interp, objv[2], /*end*/ len, &index); if (result != TCL_OK) { return result; } - if (index + 1 > (size_t)len + 1) { + if (index > len) { index = len; } /* * If the list object is unshared we can modify it directly. Otherwise we @@ -2434,11 +2232,11 @@ listPtr = objv[1]; if (Tcl_IsShared(listPtr)) { listPtr = TclListObjCopy(NULL, listPtr); } - if ((objc == 4) && (index == (size_t)len)) { + if ((objc == 4) && (index == len)) { /* * Special case: insert one element at the end of the list. */ Tcl_ListObjAppendElement(NULL, listPtr, objv[3]); @@ -2474,23 +2272,23 @@ *---------------------------------------------------------------------- */ int Tcl_ListObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) + register int objc, /* Number of arguments. */ + register 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. */ if (objc > 1) { - Tcl_SetObjResult(interp, Tcl_NewListObj(objc-1, &objv[1])); + Tcl_SetObjResult(interp, Tcl_NewListObj((objc-1), &(objv[1]))); } return TCL_OK; } /* @@ -2510,14 +2308,14 @@ *---------------------------------------------------------------------- */ int Tcl_LlengthObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) + register Tcl_Obj *const objv[]) /* Argument objects. */ { int listLen, result; if (objc != 2) { @@ -2533,112 +2331,11 @@ /* * Set the interpreter's object result to an integer object holding the * length. */ - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(listLen)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_LpopObjCmd -- - * - * This procedure is invoked to process the "lpop" 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_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) { - Tcl_WrongNumArgs(interp, 1, objv, "listvar ?index?"); - return TCL_ERROR; - } - - listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); - if (listPtr == NULL) { - return TCL_ERROR; - } - - result = TclListObjGetElements(interp, listPtr, &listLen, &elemPtrs); - if (result != TCL_OK) { - return result; - } - - /* - * First, extract the element to be returned. - * TclLindexFlat adds a ref count which is handled. - */ - - if (objc == 2) { - if (!listLen) { - /* empty list, throw the same error as with index "end" */ - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "index \"end\" out of range", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" - "OUTOFRANGE", 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; - } - } - Tcl_SetObjResult(interp, elemPtr); - Tcl_DecrRefCount(elemPtr); - - /* - * Second, remove the element. - * TclLsetFlat adds a ref count which is handled. - */ - - if (objc == 2) { - if (Tcl_IsShared(listPtr)) { - listPtr = TclListObjCopy(NULL, listPtr); - } - result = Tcl_ListObjReplace(interp, listPtr, listLen - 1, 1, 0, NULL); - if (result != TCL_OK) { - return result; - } - Tcl_IncrRefCount(listPtr); - } else { - listPtr = TclLsetFlat(interp, listPtr, objc-2, objv+2, NULL); - - if (listPtr == NULL) { - return TCL_ERROR; - } - } - - stored = Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG); - Tcl_DecrRefCount(listPtr); - if (stored == NULL) { - return TCL_ERROR; - } - + Tcl_SetObjResult(interp, Tcl_NewIntObj(listLen)); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -2657,177 +2354,62 @@ *---------------------------------------------------------------------- */ int Tcl_LrangeObjCmd( - TCL_UNUSED(ClientData), + ClientData notUsed, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) + register Tcl_Obj *const objv[]) /* Argument objects. */ { - int listLen, result; - size_t first, last; + Tcl_Obj *listPtr, **elemPtrs; + int listLen, first, result; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "list first last"); return TCL_ERROR; } - result = TclListObjLength(interp, objv[1], &listLen); - if (result != TCL_OK) { - return result; + /* + * Make sure the list argument is a list object and get its length and a + * pointer to its array of element pointers. + */ + + listPtr = TclListObjCopy(interp, objv[1]); + if (listPtr == NULL) { + return TCL_ERROR; } + TclListObjGetElements(NULL, listPtr, &listLen, &elemPtrs); result = TclGetIntForIndexM(interp, objv[2], /*endValue*/ listLen - 1, &first); - if (result != TCL_OK) { - return result; - } - - result = TclGetIntForIndexM(interp, objv[3], /*endValue*/ listLen - 1, - &last); - if (result != TCL_OK) { - return result; - } - - Tcl_SetObjResult(interp, TclListObjRange(objv[1], first, last)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_LremoveObjCmd -- - * - * This procedure is invoked to process the "lremove" Tcl command. See the - * user documentation for details on what it does. - * - * Results: - * A standard Tcl object result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -static int -LremoveIndexCompare( - const void *el1Ptr, - const void *el2Ptr) -{ - size_t idx1 = *((const size_t *) el1Ptr); - size_t idx2 = *((const size_t *) 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, listLen, prevIdx, first, num; - size_t *idxv; - Tcl_Obj *listObj; - - /* - * Parse the arguments. - */ - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "list ?index ...?"); - return TCL_ERROR; - } - - listObj = objv[1]; - if (TclListObjLength(interp, listObj, &listLen) != TCL_OK) { - return TCL_ERROR; - } - - idxc = objc - 2; - if (idxc == 0) { - Tcl_SetObjResult(interp, listObj); - return TCL_OK; - } - idxv = (size_t *)Tcl_Alloc((objc - 2) * sizeof(size_t)); - for (i = 2; i < objc; i++) { - if (TclGetIntForIndexM(interp, objv[i], /*endValue*/ listLen - 1, - &idxv[i - 2]) != TCL_OK) { - Tcl_Free(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(size_t), LremoveIndexCompare); - } - - /* - * Make our working copy, then do the actual removes piecemeal. - */ - - if (Tcl_IsShared(listObj)) { - listObj = TclListObjCopy(NULL, listObj); - } - num = 0; - first = listLen; - for (i = 0, prevIdx = -1 ; i < idxc ; i++) { - int idx = idxv[i]; - - /* - * Repeated index and sanity check. - */ - - if (idx == prevIdx) { - continue; - } - prevIdx = idx; - if (idx < 0 || idx >= listLen) { - continue; - } - - /* - * Coalesce adjacent removes to reduce the number of copies. - */ - - if (num == 0) { - num = 1; - first = idx; - } else if (idx + 1 == first) { - num++; - first = idx; - } else { - /* - * Note that this operation can't fail now; we know we have a list - * and we're only ever contracting that list. - */ - - (void) Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL); - listLen -= num; - num = 1; - first = idx; - } - } - if (num != 0) { - (void) Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL); - } - Tcl_Free(idxv); - Tcl_SetObjResult(interp, listObj); - return TCL_OK; + if (result == TCL_OK) { + int last; + + if (first < 0) { + first = 0; + } + + result = TclGetIntForIndexM(interp, objv[3], /*endValue*/ listLen - 1, + &last); + if (result == TCL_OK) { + if (last >= listLen) { + last = (listLen - 1); + } + + if (first <= last) { + int numElems = (last - first + 1); + + Tcl_SetObjResult(interp, + Tcl_NewListObj(numElems, &(elemPtrs[first]))); + } + } + } + + Tcl_DecrRefCount(listPtr); + return result; } /* *---------------------------------------------------------------------- * @@ -2845,36 +2427,34 @@ *---------------------------------------------------------------------- */ int Tcl_LrepeatObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) + register int objc, /* Number of arguments. */ + register Tcl_Obj *const objv[]) /* The argument objects. */ { int elementCount, i, totalElems; - Tcl_Obj *listPtr, **dataArray = NULL; + Tcl_Obj *listPtr, **dataArray; + List *listRepPtr; /* * Check arguments for legality: - * lrepeat count ?value ...? - */ - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "count ?value ...?"); - return TCL_ERROR; - } - if (TCL_OK != TclGetIntFromObj(interp, objv[1], &elementCount)) { - return TCL_ERROR; - } - if (elementCount < 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad count \"%d\": must be integer >= 0", elementCount)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPEAT", "NEGARG", - NULL); + * lrepeat posInt value ?value ...? + */ + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "positiveCount value ?value ...?"); + return TCL_ERROR; + } + if (TCL_ERROR == TclGetIntFromObj(interp, objv[1], &elementCount)) { + return TCL_ERROR; + } + if (elementCount < 1) { + Tcl_AppendResult(interp, "must have a count of at least 1", NULL); return TCL_ERROR; } /* * Skip forward to the interesting arguments now we've finished parsing. @@ -2883,14 +2463,13 @@ objc -= 2; objv += 2; /* Final sanity check. Do not exceed limits on max list length. */ - if (elementCount && objc > LIST_MAX/elementCount) { + if (objc > LIST_MAX/elementCount) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "max length of a Tcl list (%d elements) exceeded", LIST_MAX)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } totalElems = objc * elementCount; /* @@ -2897,27 +2476,23 @@ * Get an empty list object that is allocated large enough to hold each * init value elementCount times. */ listPtr = Tcl_NewListObj(totalElems, NULL); - if (totalElems) { - List *listRepPtr = ListRepPtr(listPtr); - - listRepPtr->elemCount = elementCount*objc; - dataArray = &listRepPtr->elements; - } + listRepPtr = ListRepPtr(listPtr); + listRepPtr->elemCount = elementCount*objc; + dataArray = &listRepPtr->elements; /* * Set the elements. Note that we handle the common degenerate case of a * 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]; + register Tcl_Obj *tmpPtr = objv[0]; tmpPtr->refCount += elementCount; for (i=0 ; i (size_t)listLen) { - first = listLen; - } - - if (last + 1 > (size_t)listLen) { - last = listLen - 1; - } - if (first + 1 <= last + 1) { - numToDelete = last - first + 1; + if (first < 0) { + first = 0; + } + + /* + * Complain if the user asked for a start element that is greater than the + * list length. This won't ever trigger for the "end-*" case as that will + * be properly constrained by TclGetIntForIndex because we use listLen-1 + * (to allow for replacing the last elem). + */ + + if ((first >= listLen) && (listLen > 0)) { + Tcl_AppendResult(interp, "list doesn't contain element ", + TclGetString(objv[2]), NULL); + return TCL_ERROR; + } + if (last >= listLen) { + last = (listLen - 1); + } + if (first <= last) { + numToDelete = (last - first + 1); } else { numToDelete = 0; } /* @@ -3024,11 +2608,11 @@ * we end up with a list in canonical form. Resist any temptation to * optimize this case away. */ if (TCL_OK != Tcl_ListObjReplace(interp, listPtr, first, numToDelete, - objc-4, objv+4)) { + objc-4, &(objv[4]))) { return TCL_ERROR; } /* * Set the interpreter's object result. @@ -3055,11 +2639,11 @@ *---------------------------------------------------------------------- */ int Tcl_LreverseObjCmd( - TCL_UNUSED(ClientData), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument values. */ { Tcl_Obj **elemv; @@ -3072,11 +2656,11 @@ if (TclListObjGetElements(interp, objv[1], &elemc, &elemv) != TCL_OK) { return TCL_ERROR; } /* - * If the list is empty, just return it. [Bug 1876793] + * If the list is empty, just return it [Bug 1876793] */ if (!elemc) { Tcl_SetObjResult(interp, objv[1]); return TCL_OK; @@ -3134,62 +2718,55 @@ *---------------------------------------------------------------------- */ int Tcl_LsearchObjCmd( - TCL_UNUSED(ClientData), + ClientData clientData, /* Not used. */ 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, bisect; - size_t length = 0, elemLen, start, groupSize, groupOffset, lower, upper; - int allocatedIndexVector = 0; - int dataType, isIncreasing; - Tcl_WideInt patWide, objWide, wide; + char *bytes, *patternBytes; + int i, match, mode, index, result, listc, length, elemLen; + int dataType, isIncreasing, lower, upper, patInt, objInt, offset; int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase; double patDouble, objDouble; SortInfo sortInfo; Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr; - SortStrCmpFn_t strCmpFn = TclUtfCmp; + SortStrCmpFn_t strCmpFn = strcmp; Tcl_RegExp regexp = NULL; - static const char *const options[] = { - "-all", "-ascii", "-bisect", "-decreasing", "-dictionary", + static const char *options[] = { + "-all", "-ascii", "-decreasing", "-dictionary", "-exact", "-glob", "-increasing", "-index", "-inline", "-integer", "-nocase", "-not", - "-real", "-regexp", "-sorted", "-start", "-stride", + "-real", "-regexp", "-sorted", "-start", "-subindices", NULL }; - enum lsearchoptions { - LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_BISECT, LSEARCH_DECREASING, - LSEARCH_DICTIONARY, LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, - LSEARCH_INDEX, LSEARCH_INLINE, LSEARCH_INTEGER, LSEARCH_NOCASE, - LSEARCH_NOT, LSEARCH_REAL, LSEARCH_REGEXP, LSEARCH_SORTED, - LSEARCH_START, LSEARCH_STRIDE, LSEARCH_SUBINDICES + enum options { + LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_DECREASING, LSEARCH_DICTIONARY, + LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, LSEARCH_INDEX, + LSEARCH_INLINE, LSEARCH_INTEGER, LSEARCH_NOCASE, LSEARCH_NOT, + LSEARCH_REAL, LSEARCH_REGEXP, LSEARCH_SORTED, LSEARCH_START, + LSEARCH_SUBINDICES }; enum datatypes { ASCII, DICTIONARY, INTEGER, REAL }; enum modes { EXACT, GLOB, REGEXP, SORTED }; - enum modes mode; mode = GLOB; dataType = ASCII; isIncreasing = 1; allMatches = 0; inlineReturn = 0; returnSubindices = 0; negatedMatch = 0; - bisect = 0; listPtr = NULL; startPtr = NULL; - groupSize = 1; - groupOffset = 0; - start = 0; + offset = 0; noCase = 0; sortInfo.compareCmdPtr = NULL; sortInfo.isIncreasing = 1; sortInfo.sortMode = 0; sortInfo.interp = interp; @@ -3196,31 +2773,32 @@ sortInfo.resultCode = TCL_OK; sortInfo.indexv = NULL; sortInfo.indexc = 0; if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "?-option value ...? list pattern"); + Tcl_WrongNumArgs(interp, 1, objv, "?options? list pattern"); return TCL_ERROR; } for (i = 1; i < objc-2; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { - result = TCL_ERROR; - goto done; + if (startPtr != NULL) { + Tcl_DecrRefCount(startPtr); + } + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return TCL_ERROR; } - switch ((enum lsearchoptions) index) { + switch ((enum options) index) { case LSEARCH_ALL: /* -all */ allMatches = 1; break; case LSEARCH_ASCII: /* -ascii */ dataType = ASCII; break; - case LSEARCH_BISECT: /* -bisect */ - mode = SORTED; - bisect = 1; - break; case LSEARCH_DECREASING: /* -decreasing */ isIncreasing = 0; sortInfo.isIncreasing = 0; break; case LSEARCH_DICTIONARY: /* -dictionary */ @@ -3267,18 +2845,17 @@ * because it will either be replaced or there will be an error. */ if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); - startPtr = NULL; } if (i > objc-4) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "missing starting index", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); - result = TCL_ERROR; - goto done; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + Tcl_AppendResult(interp, "missing starting index", NULL); + return TCL_ERROR; } i++; if (objv[i] == objv[objc - 2]) { /* * Take copy to prevent shimmering problems. Note that it does @@ -3288,52 +2865,28 @@ */ startPtr = Tcl_DuplicateObj(objv[i]); } else { startPtr = objv[i]; - } - Tcl_IncrRefCount(startPtr); - break; - case LSEARCH_STRIDE: /* -stride */ - if (i > objc-4) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "\"-stride\" option must be " - "followed by stride length", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); - result = TCL_ERROR; - goto done; - } - if (Tcl_GetWideIntFromObj(interp, objv[i+1], &wide) != TCL_OK) { - result = TCL_ERROR; - goto done; - } - if (wide < 1) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "stride length must be at least 1", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", - "BADSTRIDE", NULL); - result = TCL_ERROR; - goto done; - } - groupSize = wide; - i++; + Tcl_IncrRefCount(startPtr); + } break; case LSEARCH_INDEX: { /* -index */ Tcl_Obj **indices; int j; - if (allocatedIndexVector) { - TclStackFree(interp, sortInfo.indexv); - allocatedIndexVector = 0; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); } if (i > objc-4) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( + if (startPtr != NULL) { + Tcl_DecrRefCount(startPtr); + } + Tcl_AppendResult(interp, "\"-index\" option must be followed by list index", - -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); - result = TCL_ERROR; - goto done; + NULL); + return TCL_ERROR; } /* * Store the extracted indices for processing by sublist * extraction. Note that we don't do this using objects because @@ -3341,12 +2894,14 @@ */ i++; if (TclListObjGetElements(interp, objv[i], &sortInfo.indexc, &indices) != TCL_OK) { - result = TCL_ERROR; - goto done; + if (startPtr != NULL) { + Tcl_DecrRefCount(startPtr); + } + return TCL_ERROR; } switch (sortInfo.indexc) { case 0: sortInfo.indexv = NULL; break; @@ -3353,41 +2908,29 @@ 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. */ + ckalloc(sizeof(int) * sortInfo.indexc); } /* * 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 1) { + ckfree((char *) sortInfo.indexv); + } Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (-index option item number %d)", j)); - goto done; + return TCL_ERROR; } - sortInfo.indexv[j] = encoded; } break; } } } @@ -3395,28 +2938,19 @@ /* * Subindices only make sense if asked for with -index option set. */ if (returnSubindices && sortInfo.indexc==0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "-subindices cannot be used without -index option", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", - "BAD_OPTION_MIX", NULL); - result = TCL_ERROR; - goto done; - } - - if (bisect && (allMatches || negatedMatch)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "-bisect is not compatible with -all or -not", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", - "BAD_OPTION_MIX", NULL); - result = TCL_ERROR; - goto done; - } - - if (mode == REGEXP) { + if (startPtr != NULL) { + Tcl_DecrRefCount(startPtr); + } + Tcl_AppendResult(interp, + "-subindices cannot be used without -index option", NULL); + return TCL_ERROR; + } + + if ((enum modes) mode == REGEXP) { /* * We can shimmer regexp/list if listv[i] == pattern, so get the * regexp rep before the list rep. First time round, omit the interp * and hope that the compilation will succeed. If it fails, we'll * recompile in "expensive" mode with a place to put error messages. @@ -3435,12 +2969,17 @@ regexp = Tcl_GetRegExpFromObj(interp, objv[objc - 1], TCL_REG_ADVANCED | (noCase ? TCL_REG_NOCASE : 0)); } if (regexp == NULL) { - result = TCL_ERROR; - goto done; + if (startPtr != NULL) { + Tcl_DecrRefCount(startPtr); + } + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return TCL_ERROR; } } /* * Make sure the list argument is a list object and get its length and a @@ -3447,106 +2986,69 @@ * pointer to its array of element pointers. */ result = TclListObjGetElements(interp, objv[objc - 2], &listc, &listv); if (result != TCL_OK) { - goto done; - } - - /* - * Check for sanity when grouping elements of the overall list together - * because of the -stride option. [TIP #351] - */ - - if (groupSize > 1) { - if (listc % groupSize) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "list size must be a multiple of the stride length", - -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", "BADSTRIDE", - NULL); - result = TCL_ERROR; - goto done; - } - if (sortInfo.indexc > 0) { - /* - * Use the first value in the list supplied to -index as the - * offset of the element within each group by which to sort. - */ - - groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1); - if (groupOffset >= 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; - } - if (sortInfo.indexc == 1) { - sortInfo.indexc = 0; - sortInfo.indexv = NULL; - } else { - sortInfo.indexc--; - - for (i = 0; i < sortInfo.indexc; i++) { - sortInfo.indexv[i] = sortInfo.indexv[i+1]; - } - } - } + if (startPtr != NULL) { + Tcl_DecrRefCount(startPtr); + } + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return result; } /* * Get the user-specified start offset. */ if (startPtr) { - result = TclGetIntForIndexM(interp, startPtr, listc-1, &start); + result = TclGetIntForIndexM(interp, startPtr, listc-1, &offset); + Tcl_DecrRefCount(startPtr); if (result != TCL_OK) { - goto done; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return result; } - if (start == TCL_INDEX_NONE) { - start = TCL_INDEX_START; + if (offset < 0) { + offset = 0; } /* * 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 >= (size_t)listc) { + if (offset > listc-1) { + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } if (allMatches || inlineReturn) { Tcl_ResetResult(interp); } else { - TclNewIndexObj(itemPtr, TCL_INDEX_NONE); - Tcl_SetObjResult(interp, itemPtr); - } - goto done; - } - - /* - * If start points within a group, it points to the start of the group. - */ - - if (groupSize > 1) { - start -= (start % groupSize); + Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); + } + return TCL_OK; } } patObj = objv[objc - 1]; patternBytes = NULL; - if (mode == EXACT || mode == SORTED) { + if ((enum modes) mode == EXACT || (enum modes) mode == SORTED) { switch ((enum datatypes) dataType) { case ASCII: case DICTIONARY: patternBytes = TclGetStringFromObj(patObj, &length); break; case INTEGER: - result = TclGetWideIntFromObj(interp, patObj, &patWide); + result = TclGetIntFromObj(interp, patObj, &patInt); if (result != TCL_OK) { - goto done; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return result; } /* * List representation might have been shimmered; restore it. [Bug * 1844789] @@ -3555,11 +3057,14 @@ TclListObjGetElements(NULL, objv[objc - 2], &listc, &listv); break; case REAL: result = Tcl_GetDoubleFromObj(interp, patObj, &patDouble); if (result != TCL_OK) { - goto done; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return result; } /* * List representation might have been shimmered; restore it. [Bug * 1844789] @@ -3578,35 +3083,32 @@ */ index = -1; match = 0; - if (mode == SORTED && !allMatches && !negatedMatch) { + if ((enum modes) mode == SORTED && !allMatches && !negatedMatch) { /* * If the data is sorted, we can do a more intelligent search. Note * that there is no point in being smart when -all was specified; in * that case, we have to look at all items anyway, and there is no * sense in doing this when the match sense is inverted. */ - /* - * With -stride, lower, upper and i are kept as multiples of groupSize. - */ - - lower = start - groupSize; + lower = offset - 1; upper = listc; - while (lower + groupSize != upper && sortInfo.resultCode == TCL_OK) { + while (lower + 1 != upper && sortInfo.resultCode == TCL_OK) { i = (lower + upper)/2; - i -= i % groupSize; if (sortInfo.indexc != 0) { - itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo); + itemPtr = SelectObjFromSublist(listv[i], &sortInfo); if (sortInfo.resultCode != TCL_OK) { - result = sortInfo.resultCode; - goto done; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return sortInfo.resultCode; } } else { - itemPtr = listv[i+groupOffset]; + itemPtr = listv[i]; } switch ((enum datatypes) dataType) { case ASCII: bytes = TclGetString(itemPtr); match = strCmpFn(patternBytes, bytes); @@ -3614,26 +3116,32 @@ case DICTIONARY: bytes = TclGetString(itemPtr); match = DictionaryCompare(patternBytes, bytes); break; case INTEGER: - result = TclGetWideIntFromObj(interp, itemPtr, &objWide); + result = TclGetIntFromObj(interp, itemPtr, &objInt); if (result != TCL_OK) { - goto done; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return result; } - if (patWide == objWide) { + if (patInt == objInt) { match = 0; - } else if (patWide < objWide) { + } else if (patInt < objInt) { match = -1; } else { match = 1; } break; case REAL: result = Tcl_GetDoubleFromObj(interp, itemPtr, &objDouble); if (result != TCL_OK) { - goto done; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return result; } if (patDouble == objDouble) { match = 0; } else if (patDouble < objDouble) { match = -1; @@ -3644,29 +3152,23 @@ } 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. + * our first match might not be the first occurance. * Consider: 0 0 0 1 1 1 2 2 2 * - * To maintain consistency with standard lsearch semantics, we - * must find the leftmost occurrence of the pattern in the + * To maintain consistancy with standard lsearch semantics, we + * must find the leftmost occurance 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. */ index = i; - if (bisect) { - lower = i; - } else { - upper = i; - } + upper = i; } else if (match > 0) { if (isIncreasing) { lower = i; } else { upper = i; @@ -3677,13 +3179,11 @@ } else { lower = i; } } } - if (bisect && index < 0) { - index = lower; - } + } else { /* * We need to do a linear search, because (at least one) of: * - our matcher can only tell equal vs. not equal * - our matching sense is negated @@ -3691,26 +3191,28 @@ */ if (allMatches) { listPtr = Tcl_NewListObj(0, NULL); } - for (i = start; i < listc; i += groupSize) { + for (i = offset; i < listc; i++) { match = 0; - if (sortInfo.indexc != 0) { - itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo); + if (sortInfo.indexc != 0) { + itemPtr = SelectObjFromSublist(listv[i], &sortInfo); if (sortInfo.resultCode != TCL_OK) { if (listPtr != NULL) { Tcl_DecrRefCount(listPtr); } - result = sortInfo.resultCode; - goto done; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return sortInfo.resultCode; } } else { - itemPtr = listv[i+groupOffset]; + itemPtr = listv[i]; } - - switch (mode) { + + switch ((enum modes) mode) { case SORTED: case EXACT: switch ((enum datatypes) dataType) { case ASCII: bytes = TclGetStringFromObj(itemPtr, &elemLen); @@ -3721,11 +3223,12 @@ */ if (noCase) { match = (TclUtfCasecmp(bytes, patternBytes) == 0); } else { - match = (memcmp(bytes, patternBytes, length) == 0); + match = (memcmp(bytes, patternBytes, + (size_t) length) == 0); } } break; case DICTIONARY: @@ -3732,27 +3235,33 @@ bytes = TclGetString(itemPtr); match = (DictionaryCompare(bytes, patternBytes) == 0); break; case INTEGER: - result = TclGetWideIntFromObj(interp, itemPtr, &objWide); + result = TclGetIntFromObj(interp, itemPtr, &objInt); if (result != TCL_OK) { if (listPtr != NULL) { Tcl_DecrRefCount(listPtr); } - goto done; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return result; } - match = (objWide == patWide); + match = (objInt == patInt); break; case REAL: result = Tcl_GetDoubleFromObj(interp,itemPtr, &objDouble); if (result != TCL_OK) { if (listPtr) { Tcl_DecrRefCount(listPtr); } - goto done; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return result; } match = (objDouble == patDouble); break; } break; @@ -3767,12 +3276,14 @@ if (match < 0) { Tcl_DecrRefCount(patObj); if (listPtr != NULL) { Tcl_DecrRefCount(listPtr); } - result = TCL_ERROR; - goto done; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return TCL_ERROR; } break; } /* @@ -3792,33 +3303,26 @@ /* * Note that these appends are not expected to fail. */ if (returnSubindices && (sortInfo.indexc != 0)) { - itemPtr = SelectObjFromSublist(listv[i+groupOffset], - &sortInfo); - Tcl_ListObjAppendElement(interp, listPtr, itemPtr); - } else if (groupSize > 1) { - Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0, - groupSize, &listv[i]); + itemPtr = SelectObjFromSublist(listv[i], &sortInfo); } else { itemPtr = listv[i]; - Tcl_ListObjAppendElement(interp, listPtr, itemPtr); } + Tcl_ListObjAppendElement(interp, listPtr, itemPtr); } else if (returnSubindices) { int j; - TclNewIndexObj(itemPtr, i+groupOffset); + itemPtr = Tcl_NewIntObj(i); for (j=0 ; j 1) { - Tcl_SetObjResult(interp, Tcl_NewListObj(groupSize, &listv[index])); - } else { - Tcl_SetObjResult(interp, listv[index]); - } - } - result = TCL_OK; + Tcl_SetObjResult(interp, listv[index]); + } /* * Cleanup the index list array. */ - done: - if (startPtr != NULL) { - Tcl_DecrRefCount(startPtr); - } - if (allocatedIndexVector) { - TclStackFree(interp, sortInfo.indexv); - } - return result; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return TCL_OK; } /* *---------------------------------------------------------------------- * @@ -3894,11 +3382,11 @@ *---------------------------------------------------------------------- */ int Tcl_LsetObjCmd( - TCL_UNUSED(ClientData), + ClientData clientData, /* Not used. */ 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. */ @@ -3907,20 +3395,20 @@ /* * Check parameter count. */ if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, - "listVar ?index? ?index ...? value"); + Tcl_WrongNumArgs(interp, 1, objv, "listVar ?index? ?index...? value"); return TCL_ERROR; } /* * Look up the list variable's value. */ - listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); + listPtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, + TCL_LEAVE_ERR_MSG); if (listPtr == NULL) { return TCL_ERROR; } /* @@ -3979,45 +3467,42 @@ *---------------------------------------------------------------------- */ int Tcl_LsortObjCmd( - TCL_UNUSED(ClientData), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument values. */ { - int i, index, indices, length, nocase = 0, indexc; + int i, j, index, indices, length, nocase = 0, indexc; int sortMode = SORTMODE_ASCII; - int group, allocatedIndexVector = 0; - size_t j, idx, groupSize, groupOffset; - Tcl_WideInt wide; Tcl_Obj *resultPtr, *cmdPtr, **listObjPtrs, *listObj, *indexPtr; size_t elmArrSize; - SortElement *elementArray = NULL, *elementPtr; + SortElement *elementArray, *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[] = { + static const char *switches[] = { "-ascii", "-command", "-decreasing", "-dictionary", "-increasing", - "-index", "-indices", "-integer", "-nocase", "-real", "-stride", - "-unique", NULL + "-index", "-indices", "-integer", "-nocase", "-real", "-unique", NULL }; enum Lsort_Switches { LSORT_ASCII, LSORT_COMMAND, LSORT_DECREASING, LSORT_DICTIONARY, LSORT_INCREASING, LSORT_INDEX, LSORT_INDICES, LSORT_INTEGER, - LSORT_NOCASE, LSORT_REAL, LSORT_STRIDE, LSORT_UNIQUE + LSORT_NOCASE, LSORT_REAL, LSORT_UNIQUE }; + /* + * The subList array below holds pointers to temporary lists built during + * the merge sort. Element i of the array holds a list of length 2**i. + */ +# define MAXCALLOC 1024000 +# define NUM_LISTS 30 + SortElement *subList[NUM_LISTS+1]; + if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?-option value ...? list"); + Tcl_WrongNumArgs(interp, 1, objv, "?options? list"); return TCL_ERROR; } /* * Parse arguments to set up the mode for the sort. @@ -4027,35 +3512,34 @@ sortInfo.sortMode = SORTMODE_ASCII; sortInfo.indexv = NULL; sortInfo.indexc = 0; sortInfo.unique = 0; sortInfo.interp = interp; - sortInfo.resultCode = TCL_OK; + sortInfo.resultCode = TCL_OK; cmdPtr = NULL; indices = 0; - group = 0; - groupSize = 1; - groupOffset = 0; - indexPtr = NULL; for (i = 1; i < objc-1; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index) != TCL_OK) { - sortInfo.resultCode = TCL_ERROR; - goto done; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return TCL_ERROR; } switch ((enum Lsort_Switches) index) { case LSORT_ASCII: sortInfo.sortMode = SORTMODE_ASCII; break; case LSORT_COMMAND: - if (i == objc-2) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( + if (i == (objc-2)) { + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + Tcl_AppendResult(interp, "\"-command\" option must be followed " - "by comparison command", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); - sortInfo.resultCode = TCL_ERROR; - goto done; + "by comparison command", NULL); + return TCL_ERROR; } sortInfo.sortMode = SORTMODE_COMMAND; cmdPtr = objv[i+1]; i++; break; @@ -4067,56 +3551,58 @@ 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; + Tcl_Obj **indices; + + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + if (i == (objc-2)) { + Tcl_AppendResult(interp, "\"-index\" option must be " + "followed by list index", NULL); + return TCL_ERROR; + } + + /* + * Take copy to prevent shimmering problems. + */ + + if (TclListObjGetElements(interp, objv[i+1], &sortInfo.indexc, + &indices) != TCL_OK) { + return TCL_ERROR; + } + switch (sortInfo.indexc) { + case 0: + sortInfo.indexv = NULL; + break; + case 1: + sortInfo.indexv = &sortInfo.singleIndex; + break; + default: + sortInfo.indexv = (int *) + ckalloc(sizeof(int) * sortInfo.indexc); } /* - * 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. + * 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<(size_t)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 %" TCL_Z_MODIFIER "d)", j)); - sortInfo.resultCode = TCL_ERROR; - goto done; - } - } - indexPtr = objv[i+1]; + for (j=0 ; j 1) { + ckfree((char *) sortInfo.indexv); + } + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (-index option item number %d)", j)); + return TCL_ERROR; + } + } i++; break; } case LSORT_INTEGER: sortInfo.sortMode = SORTMODE_INTEGER; @@ -4130,70 +3616,15 @@ case LSORT_UNIQUE: sortInfo.unique = 1; break; case LSORT_INDICES: indices = 1; - break; - case LSORT_STRIDE: - if (i == objc-2) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "\"-stride\" option must be " - "followed by stride length", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); - sortInfo.resultCode = TCL_ERROR; - goto done; - } - if (Tcl_GetWideIntFromObj(interp, objv[i+1], &wide) != TCL_OK) { - sortInfo.resultCode = TCL_ERROR; - goto done; - } - if (wide < 2) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "stride length must be at least 2", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", - "BADSTRIDE", NULL); - sortInfo.resultCode = TCL_ERROR; - goto done; - } - groupSize = wide; - group = 1; - i++; break; } } if (nocase && (sortInfo.sortMode == SORTMODE_ASCII)) { sortInfo.sortMode = SORTMODE_ASCII_NC; - } - - /* - * Now extract the -index list for real, if present. No failures are - * expected here; the values are all of the right type or convertible to - * it. - */ - - if (indexPtr) { - Tcl_Obj **indexv; - - TclListObjGetElements(interp, indexPtr, &sortInfo.indexc, &indexv); - switch (sortInfo.indexc) { - case 0: - sortInfo.indexv = NULL; - break; - case 1: - sortInfo.indexv = &sortInfo.singleIndex; - break; - 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<(size_t)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]; if (sortInfo.sortMode == SORTMODE_COMMAND) { @@ -4206,12 +3637,14 @@ * 1675116] */ listObj = TclListObjCopy(interp, listObj); if (listObj == NULL) { - sortInfo.resultCode = TCL_ERROR; - goto done; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return TCL_ERROR; } /* * The existing command is a list. We want to flatten it, append two * dummy arguments on the end, and replace these arguments later. @@ -4224,12 +3657,14 @@ != TCL_OK) { TclDecrRefCount(newCommandPtr); TclDecrRefCount(listObj); Tcl_IncrRefCount(newObjPtr); TclDecrRefCount(newObjPtr); - sortInfo.resultCode = TCL_ERROR; - goto done; + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return TCL_ERROR; } Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj()); sortInfo.compareCmdPtr = newCommandPtr; } @@ -4236,83 +3671,29 @@ sortInfo.resultCode = TclListObjGetElements(interp, listObj, &length, &listObjPtrs); if (sortInfo.resultCode != TCL_OK || length <= 0) { goto done; } - - /* - * Check for sanity when grouping elements of the overall list together - * because of the -stride option. [TIP #326] - */ - - if (group) { - if (length % groupSize) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "list size must be a multiple of the stride length", - -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", "BADSTRIDE", - NULL); - sortInfo.resultCode = TCL_ERROR; - goto done; - } - length = length / groupSize; - if (sortInfo.indexc > 0) { - /* - * Use the first value in the list supplied to -index as the - * offset of the element within each group by which to sort. - */ - - groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1); - if (groupOffset >= 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; - } - if (sortInfo.indexc == 1) { - sortInfo.indexc = 0; - sortInfo.indexv = NULL; - } else { - sortInfo.indexc--; - - /* - * Do not shrink the actual memory block used; that doesn't - * work with TclStackAlloc-allocated memory. [Bug 2918962] - * - * TODO: Consider a pointer increment to replace this - * array shift. - */ - - for (i = 0; i < sortInfo.indexc; i++) { - sortInfo.indexv[i] = sortInfo.indexv[i+1]; - } - } - } - } - sortInfo.numElements = length; - + indexc = sortInfo.indexc; sortMode = sortInfo.sortMode; if ((sortMode == SORTMODE_ASCII_NC) || (sortMode == SORTMODE_DICTIONARY)) { /* * For this function's purpose all string-based modes are equivalent */ - + sortMode = SORTMODE_ASCII; } /* * Initialize the sublists. After the following loop, subList[i] will * contain a sorted sublist of length 2**i. Use one extra subList at the * end, always at NULL, to indicate the end of the lists. */ - + for (j=0 ; j<=NUM_LISTS ; j++) { subList[j] = NULL; } /* @@ -4320,79 +3701,71 @@ * begins sorting it into the sublists as it appears. */ elmArrSize = length * sizeof(SortElement); if (elmArrSize <= MAXCALLOC) { - elementArray = (SortElement *)Tcl_Alloc(elmArrSize); + elementArray = (SortElement *) ckalloc(elmArrSize); } else { - elementArray = (SortElement *)malloc(elmArrSize); + 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; + for (i=0; i < length; i++){ if (indexc) { /* * If this is an indexed sort, retrieve the corresponding element */ - indexPtr = SelectObjFromSublist(listObjPtrs[idx], &sortInfo); + indexPtr = SelectObjFromSublist(listObjPtrs[i], &sortInfo); if (sortInfo.resultCode != TCL_OK) { - goto done; + goto done1; } } else { - indexPtr = listObjPtrs[idx]; + indexPtr = listObjPtrs[i]; } /* * Determine the "value" of this object for sorting purposes */ - + if (sortMode == SORTMODE_ASCII) { - elementArray[i].collationKey.strValuePtr = TclGetString(indexPtr); + elementArray[i].index.strValuePtr = TclGetString(indexPtr); } else if (sortMode == SORTMODE_INTEGER) { - Tcl_WideInt a; - - if (TclGetWideIntFromObj(sortInfo.interp, indexPtr, &a) != TCL_OK) { + long a; + if (TclGetLongFromObj(sortInfo.interp, indexPtr, &a) != TCL_OK) { sortInfo.resultCode = TCL_ERROR; - goto done; + goto done1; } - elementArray[i].collationKey.wideValue = a; + elementArray[i].index.intValue = a; } else if (sortMode == SORTMODE_REAL) { double a; - - if (Tcl_GetDoubleFromObj(sortInfo.interp, indexPtr, - &a) != TCL_OK) { + if (Tcl_GetDoubleFromObj(sortInfo.interp, indexPtr, &a) != TCL_OK) { sortInfo.resultCode = TCL_ERROR; - goto done; + goto done1; } - elementArray[i].collationKey.doubleValue = a; + elementArray[i].index.doubleValue = a; } else { - elementArray[i].collationKey.objValuePtr = indexPtr; + elementArray[i].index.objValuePtr = indexPtr; } /* * Determine the representation of this element in the result: either * the objPtr itself, or its index in the original list. */ - - if (indices || group) { - elementArray[i].payload.index = idx; - } else { - elementArray[i].payload.objPtr = listObjPtrs[idx]; - } + + elementArray[i].objPtr = (indices ? INT2PTR(i) : listObjPtrs[i]); /* * Merge this element in the pre-existing sublists (and merge together * sublists when we have two of the same size). */ - + elementArray[i].nextPtr = NULL; elementPtr = &elementArray[i]; for (j=0 ; subList[j] ; j++) { elementPtr = MergeLists(subList[j], elementPtr, &sortInfo); subList[j] = NULL; @@ -4404,74 +3777,61 @@ } /* * Merge all sublists */ - + elementPtr = subList[0]; for (j=1 ; jelements; - if (group) { - for (i=0; elementPtr!=NULL ; elementPtr=elementPtr->nextPtr) { - idx = elementPtr->payload.index; - for (j = 0; j < groupSize; j++) { - if (indices) { - TclNewIndexObj(objPtr, idx + j - groupOffset); - newArray[i++] = objPtr; - Tcl_IncrRefCount(objPtr); - } else { - objPtr = listObjPtrs[idx + j - groupOffset]; - newArray[i++] = objPtr; - Tcl_IncrRefCount(objPtr); - } - } - } - } else if (indices) { - for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) { - TclNewIndexObj(objPtr, elementPtr->payload.index); - newArray[i++] = objPtr; - Tcl_IncrRefCount(objPtr); - } - } else { - for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) { - objPtr = elementPtr->payload.objPtr; + + /* + * Now store the sorted elements in the result list. + */ + + if (sortInfo.resultCode == TCL_OK) { + List *listRepPtr; + Tcl_Obj **newArray, *objPtr; + int i; + + resultPtr = Tcl_NewListObj(sortInfo.numElements, NULL); + listRepPtr = ListRepPtr(resultPtr); + newArray = &listRepPtr->elements; + if (indices) { + for (i = 0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr){ + objPtr = Tcl_NewIntObj(PTR2INT(elementPtr->objPtr)); + newArray[i++] = objPtr; + Tcl_IncrRefCount(objPtr); + } + } else { + for (i = 0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr){ + objPtr = elementPtr->objPtr; newArray[i++] = objPtr; Tcl_IncrRefCount(objPtr); } } listRepPtr->elemCount = i; Tcl_SetObjResult(interp, resultPtr); } + + done1: + if (elmArrSize <= MAXCALLOC) { + ckfree((char *)elementArray); + } else { + free((char *)elementArray); + } done: if (sortMode == SORTMODE_COMMAND) { TclDecrRefCount(sortInfo.compareCmdPtr); TclDecrRefCount(listObj); sortInfo.compareCmdPtr = NULL; } - if (allocatedIndexVector) { - TclStackFree(interp, sortInfo.indexv); - } - if (elementArray) { - if (elmArrSize <= MAXCALLOC) { - Tcl_Free(elementArray); - } else { - free((char *)elementArray); - } + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); } return sortInfo.resultCode; } /* @@ -4484,27 +3844,25 @@ * * Results: * The unified list of SortElement structures. * * Side effects: - * If infoPtr->unique is set then infoPtr->numElements may be updated. + * If infoPtr->unique is set then infoPtr->numElements may be updated. * Possibly others, if a user-defined comparison command does something - * weird. + * weird. * * Note: - * If infoPtr->unique is set, the merge assumes that there are no + * If infoPtr->unique is set, the merge assumes that there are no * "repeated" elements in each of the left and right lists. In that case, * if any element of the left list is equivalent to one in the right list * it is omitted from the merged list. - * - * This simplified mechanism works because of the special way our - * MergeSort creates the sublists to be merged and will fail to eliminate - * all repeats in the general case where they are already present in - * either the left or right list. A general code would need to skip - * adjacent initial repeats in the left and right lists before comparing - * their initial elements, at each step. - * + * This simplified mechanism works because of the special way + * our MergeSort creates the sublists to be merged and will fail to + * eliminate all repeats in the general case where they are already + * present in either the left or right list. A general code would need to + * skip adjacent initial repeats in the left and right lists before + * comparing their initial elements, at each step. *---------------------------------------------------------------------- */ static SortElement * MergeLists( @@ -4602,29 +3960,29 @@ * "lsort" command. */ { int order = 0; if (infoPtr->sortMode == SORTMODE_ASCII) { - order = TclUtfCmp(elemPtr1->collationKey.strValuePtr, - elemPtr2->collationKey.strValuePtr); + order = strcmp(elemPtr1->index.strValuePtr, + elemPtr2->index.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_ASCII_NC) { - order = TclUtfCasecmp(elemPtr1->collationKey.strValuePtr, - elemPtr2->collationKey.strValuePtr); + order = TclUtfCasecmp(elemPtr1->index.strValuePtr, + elemPtr2->index.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) { - order = DictionaryCompare(elemPtr1->collationKey.strValuePtr, - elemPtr2->collationKey.strValuePtr); + order = DictionaryCompare(elemPtr1->index.strValuePtr, + elemPtr2->index.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_INTEGER) { - Tcl_WideInt a, b; + long a, b; - a = elemPtr1->collationKey.wideValue; - b = elemPtr2->collationKey.wideValue; + a = elemPtr1->index.intValue; + b = elemPtr2->index.intValue; order = ((a >= b) - (a <= b)); } else if (infoPtr->sortMode == SORTMODE_REAL) { double a, b; - a = elemPtr1->collationKey.doubleValue; - b = elemPtr2->collationKey.doubleValue; + a = elemPtr1->index.doubleValue; + b = elemPtr2->index.doubleValue; order = ((a >= b) - (a <= b)); } else { Tcl_Obj **objv, *paramObjv[2]; int objc; Tcl_Obj *objPtr1, *objPtr2; @@ -4632,18 +3990,18 @@ if (infoPtr->resultCode != TCL_OK) { /* * Once an error has occurred, skip any future comparisons so as * to preserve the error message in sortInterp->result. */ - + return 0; } - objPtr1 = elemPtr1->collationKey.objValuePtr; - objPtr2 = elemPtr2->collationKey.objValuePtr; - + objPtr1 = elemPtr1->index.objValuePtr; + objPtr2 = elemPtr2->index.objValuePtr; + paramObjv[0] = objPtr1; paramObjv[1] = objPtr2; /* * We made space in the command list for the two things to compare. @@ -4657,24 +4015,24 @@ &objc, &objv); infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0); if (infoPtr->resultCode != TCL_OK) { - Tcl_AddErrorInfo(infoPtr->interp, "\n (-compare command)"); + Tcl_AddErrorInfo(infoPtr->interp, + "\n (-compare command)"); return 0; } /* * Parse the result of the command. */ if (TclGetIntFromObj(infoPtr->interp, Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) { - Tcl_SetObjResult(infoPtr->interp, Tcl_NewStringObj( - "-compare command returned non-integer result", -1)); - Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT", - "COMPARISONFAILED", NULL); + Tcl_ResetResult(infoPtr->interp); + Tcl_AppendResult(infoPtr->interp, + "-compare command returned non-integer result", NULL); infoPtr->resultCode = TCL_ERROR; return 0; } } if (!infoPtr->isIncreasing) { @@ -4707,13 +4065,13 @@ *---------------------------------------------------------------------- */ static int DictionaryCompare( - const char *left, const char *right) /* The strings to compare. */ + char *left, char *right) /* The strings to compare. */ { - int uniLeft = 0, uniRight = 0, uniLeftLower, uniRightLower; + Tcl_UniChar uniLeft, uniRight, uniLeftLower, uniRightLower; int diff, zeros; int secondaryDiff = 0; while (1) { if (isdigit(UCHAR(*right)) /* INTL: digit */ @@ -4724,15 +4082,15 @@ * leading zeros than the other, the number with more leading * zeros sorts later, but only as a secondary choice. */ zeros = 0; - while ((*right == '0') && isdigit(UCHAR(right[1]))) { + while ((*right == '0') && (isdigit(UCHAR(right[1])))) { right++; zeros--; } - while ((*left == '0') && isdigit(UCHAR(left[1]))) { + while ((*left == '0') && (isdigit(UCHAR(left[1])))) { left++; zeros++; } if (secondaryDiff == 0) { secondaryDiff = zeros; @@ -4778,12 +4136,12 @@ * 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); + left += Tcl_UtfToUniChar(left, &uniLeft); + right += Tcl_UtfToUniChar(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 @@ -4865,31 +4223,32 @@ if (TclListObjLength(infoPtr->interp, objPtr, &listLen) != TCL_OK) { infoPtr->resultCode = TCL_ERROR; return NULL; } + index = infoPtr->indexv[i]; + + /* + * Adjust for end-based indexing. + */ - index = TclIndexDecode(infoPtr->indexv[i], listLen - 1); + if (index < SORTIDX_NONE) { + index += listLen + 1; + } if (Tcl_ListObjIndex(infoPtr->interp, objPtr, index, ¤tObj) != TCL_OK) { infoPtr->resultCode = TCL_ERROR; return NULL; } if (currentObj == NULL) { - if (index == (int)TCL_INDEX_NONE) { - index = TCL_INDEX_END - infoPtr->indexv[i]; - Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf( - "element end-%d missing from sublist \"%s\"", - index, TclGetString(objPtr))); - } else { - Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf( - "element %d missing from sublist \"%s\"", - index, TclGetString(objPtr))); - } - Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT", - "INDEXFAILED", NULL); + char buffer[TCL_INTEGER_SPACE]; + + TclFormatInt(buffer, index); + Tcl_AppendResult(infoPtr->interp, "element ", buffer, + " missing from sublist \"", TclGetString(objPtr), "\"", + NULL); infoPtr->resultCode = TCL_ERROR; return NULL; } objPtr = currentObj; } @@ -4899,8 +4258,7 @@ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 - * tab-width: 8 * End: */ Index: generic/tclCmdMZ.c ================================================================== --- generic/tclCmdMZ.c +++ generic/tclCmdMZ.c @@ -8,62 +8,22 @@ * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 Scriptics Corporation. * Copyright (c) 2002 ActiveState Corporation. - * Copyright (c) 2003-2009 Donal K. Fellows. + * Copyright (c) 2003 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclCompile.h" #include "tclRegexp.h" -#include "tclStringTrim.h" - -static inline Tcl_Obj * During(Tcl_Interp *interp, int resultCode, - Tcl_Obj *oldOptions, Tcl_Obj *errorInfo); -static Tcl_NRPostProc SwitchPostProc; -static Tcl_NRPostProc TryPostBody; -static Tcl_NRPostProc TryPostFinal; -static Tcl_NRPostProc TryPostHandler; + static int UniCharIsAscii(int character); static int UniCharIsHexDigit(int character); - -/* - * Default set of characters to trim in [string trim] and friends. This is a - * UTF-8 literal string containing all Unicode space characters [TIP #413] - */ - -const char tclDefaultTrimSet[] = - "\x09\x0a\x0b\x0c\x0d " /* ASCII */ - "\xc0\x80" /* nul (U+0000) */ - "\xc2\x85" /* next line (U+0085) */ - "\xc2\xa0" /* non-breaking space (U+00a0) */ - "\xe1\x9a\x80" /* ogham space mark (U+1680) */ - "\xe1\xa0\x8e" /* mongolian vowel separator (U+180e) */ - "\xe2\x80\x80" /* en quad (U+2000) */ - "\xe2\x80\x81" /* em quad (U+2001) */ - "\xe2\x80\x82" /* en space (U+2002) */ - "\xe2\x80\x83" /* em space (U+2003) */ - "\xe2\x80\x84" /* three-per-em space (U+2004) */ - "\xe2\x80\x85" /* four-per-em space (U+2005) */ - "\xe2\x80\x86" /* six-per-em space (U+2006) */ - "\xe2\x80\x87" /* figure space (U+2007) */ - "\xe2\x80\x88" /* punctuation space (U+2008) */ - "\xe2\x80\x89" /* thin space (U+2009) */ - "\xe2\x80\x8a" /* hair space (U+200a) */ - "\xe2\x80\x8b" /* zero width space (U+200b) */ - "\xe2\x80\xa8" /* line separator (U+2028) */ - "\xe2\x80\xa9" /* paragraph separator (U+2029) */ - "\xe2\x80\xaf" /* narrow no-break space (U+202f) */ - "\xe2\x81\x9f" /* medium mathematical space (U+205f) */ - "\xe2\x81\xa0" /* word joiner (U+2060) */ - "\xe3\x80\x80" /* ideographic space (U+3000) */ - "\xef\xbb\xbf" /* zero width no-break space (U+feff) */ -; /* *---------------------------------------------------------------------- * * Tcl_PwdObjCmd -- @@ -80,11 +40,11 @@ *---------------------------------------------------------------------- */ int Tcl_PwdObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *retVal; @@ -120,51 +80,52 @@ *---------------------------------------------------------------------- */ int Tcl_RegexpObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - size_t offset, stringLength, matchLength, cflags, eflags; - int i, indices, match, about, all, doinline, numMatchesSaved; + 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[] = { + static const char *options[] = { "-all", "-about", "-indices", "-inline", "-expanded", "-line", "-linestop", "-lineanchor", "-nocase", "-start", "--", NULL }; - enum regexpoptions { + 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 = TCL_INDEX_START; + eflags = 0; + offset = 0; all = 0; doinline = 0; for (i = 1; i < objc; i++) { - const char *name; + char *name; int index; name = TclGetString(objv[i]); if (name[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", TCL_EXACT, + if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, &index) != TCL_OK) { goto optionError; } - switch ((enum regexpoptions) index) { + switch ((enum options) index) { case REGEXP_ALL: all = 1; break; case REGEXP_INDICES: indices = 1; @@ -189,15 +150,15 @@ break; case REGEXP_LINEANCHOR: cflags |= TCL_REG_NLANCH; break; case REGEXP_START: { - size_t temp; + int temp; if (++i >= objc) { goto endOfForLoop; } - if (TclGetIntForIndexM(interp, objv[i], (size_t)WIDE_MAX - 1, &temp) != TCL_OK) { + if (TclGetIntForIndexM(interp, objv[i], 0, &temp) != TCL_OK) { goto optionError; } if (startIndex) { Tcl_DecrRefCount(startIndex); } @@ -212,11 +173,11 @@ } endOfForLoop: if ((objc - i) < (2 - about)) { Tcl_WrongNumArgs(interp, 1, objv, - "?-option ...? exp string ?matchVar? ?subMatchVar ...?"); + "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"); goto optionError; } objc -= i; objv += i; @@ -224,14 +185,12 @@ * Check if the user requested -inline, but specified match variables; a * no-no. */ if (doinline && ((objc - 2) != 0)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "regexp match variables not allowed when using -inline", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "REGEXP", - "MIX_VAR_INLINE", NULL); + Tcl_AppendResult(interp, "regexp match variables not allowed" + " when using -inline", NULL); goto optionError; } /* * Handle the odd about case separately. @@ -257,14 +216,14 @@ objPtr = objv[1]; stringLength = Tcl_GetCharLength(objPtr); if (startIndex) { - TclGetIntForIndexM(interp, startIndex, stringLength, &offset); + TclGetIntForIndexM(NULL, startIndex, stringLength, &offset); Tcl_DecrRefCount(startIndex); - if (offset == TCL_INDEX_NONE) { - offset = TCL_INDEX_START; + if (offset < 0) { + offset = 0; } } regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); if (regExpr == NULL) { @@ -304,15 +263,15 @@ * 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 == TCL_INDEX_START) { + if (offset == 0) { eflags = 0; - } else if (offset + 1 > stringLength + 1) { + } else if (offset > stringLength) { eflags = TCL_REG_NOTBOL; - } else if (Tcl_GetUniChar(objPtr, offset-1) == '\n') { + } else if (Tcl_GetUniChar(objPtr, offset-1) == (Tcl_UniChar)'\n') { eflags = 0; } else { eflags = TCL_REG_NOTBOL; } @@ -322,11 +281,11 @@ return TCL_ERROR; } if (match == 0) { /* - * We want to set the value of the interpreter result only when + * We want to set the value of the intepreter result only when * this is the first time through the loop. */ if (all <= 1) { /* @@ -334,11 +293,11 @@ * empty list, otherwise set it to an integer object w/ value * 0. */ if (!doinline) { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); } return TCL_OK; } break; } @@ -362,41 +321,41 @@ } for (i = 0; i < objc; i++) { Tcl_Obj *newPtr; if (indices) { - size_t start, end; + 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 <= (int)info.nsubs && info.matches[i].start != TCL_INDEX_NONE) { + 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 + 1 >= offset + 1) { + if (end >= offset) { end--; } } else { - start = TCL_INDEX_NONE; - end = TCL_INDEX_NONE; + start = -1; + end = -1; } - TclNewIndexObj(objs[0], start); - TclNewIndexObj(objs[1], end); + objs[0] = Tcl_NewLongObj(start); + objs[1] = Tcl_NewLongObj(end); newPtr = Tcl_NewListObj(2, objs); } else { - if (i <= (int)info.nsubs) { + if (i <= info.nsubs) { newPtr = Tcl_GetRange(objPtr, offset + info.matches[i].start, offset + info.matches[i].end - 1); } else { newPtr = Tcl_NewObj(); @@ -408,12 +367,15 @@ Tcl_DecrRefCount(newPtr); Tcl_DecrRefCount(resultPtr); return TCL_ERROR; } } else { - if (Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, - TCL_LEAVE_ERR_MSG) == NULL) { + Tcl_Obj *valuePtr; + valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0); + if (valuePtr == NULL) { + Tcl_AppendResult(interp, "couldn't set variable \"", + TclGetString(objv[i]), "\"", NULL); return TCL_ERROR; } } } @@ -429,12 +391,11 @@ * when we match the NULL string at the end of the input string, we * will loop indefinately (because the length of the match is 0, so * offset never changes). */ - matchLength = (info.matches[0].end - info.matches[0].start); - + matchLength = info.matches[0].end - info.matches[0].start; offset += info.matches[0].end; /* * A match of length zero could happen for {^} {$} or {.*} and in * these cases we always want to bump the index up one. @@ -442,11 +403,11 @@ if (matchLength == 0) { offset++; } all++; - if (offset + 1 >= stringLength + 1) { + if (offset >= stringLength) { break; } } /* @@ -456,11 +417,11 @@ */ if (doinline) { Tcl_SetObjResult(interp, resultPtr); } else { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(all ? all-1 : 1)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(all ? all-1 : 1)); } return TCL_OK; } /* @@ -480,62 +441,57 @@ *---------------------------------------------------------------------- */ int Tcl_RegsubObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int result, cflags, all, match, command, numParts; - size_t idx, wlen, wsublen = 0, offset, numMatches; - size_t start, end, subStart, subEnd; + int idx, result, cflags, all, wlen, wsublen, numMatches, offset; + int start, end, subStart, subEnd, match; Tcl_RegExp regExpr; Tcl_RegExpInfo info; Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL; - Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec = 0, *wend; + Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend; - static const char *const options[] = { - "-all", "-command", "-expanded", "-line", - "-linestop", "-lineanchor", "-nocase", "-start", + static const char *options[] = { + "-all", "-nocase", "-expanded", + "-line", "-linestop", "-lineanchor", "-start", "--", NULL }; - enum regsubobjoptions { - REGSUB_ALL, REGSUB_COMMAND, REGSUB_EXPANDED, REGSUB_LINE, - REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_NOCASE, REGSUB_START, + enum options { + REGSUB_ALL, REGSUB_NOCASE, REGSUB_EXPANDED, + REGSUB_LINE, REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_START, REGSUB_LAST }; cflags = TCL_REG_ADVANCED; all = 0; - offset = TCL_INDEX_START; - command = 0; + offset = 0; resultPtr = NULL; - for (idx = 1; idx < (size_t)objc; idx++) { - const char *name; + for (idx = 1; idx < objc; idx++) { + char *name; int index; name = TclGetString(objv[idx]); if (name[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, objv[idx], options, "option", + if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", TCL_EXACT, &index) != TCL_OK) { goto optionError; } - switch ((enum regsubobjoptions) index) { + switch ((enum options) index) { case REGSUB_ALL: all = 1; break; case REGSUB_NOCASE: cflags |= TCL_REG_NOCASE; break; - case REGSUB_COMMAND: - command = 1; - break; case REGSUB_EXPANDED: cflags |= TCL_REG_EXPANDED; break; case REGSUB_LINE: cflags |= TCL_REG_NEWLINE; @@ -545,15 +501,15 @@ break; case REGSUB_LINEANCHOR: cflags |= TCL_REG_NLANCH; break; case REGSUB_START: { - size_t temp; - if (++idx >= (size_t)objc) { + int temp; + if (++idx >= objc) { goto endOfForLoop; } - if (TclGetIntForIndexM(interp, objv[idx], (size_t)WIDE_MAX - 1, &temp) != TCL_OK) { + if (TclGetIntForIndexM(interp, objv[idx], 0, &temp) != TCL_OK) { goto optionError; } if (startIndex) { Tcl_DecrRefCount(startIndex); } @@ -566,13 +522,13 @@ goto endOfForLoop; } } endOfForLoop: - if ((size_t)objc < idx + 3 || (size_t)objc > idx + 4) { + if (objc-idx < 3 || objc-idx > 4) { Tcl_WrongNumArgs(interp, 1, objv, - "?-option ...? exp string subSpec ?varName?"); + "?switches? exp string subSpec ?varName?"); optionError: if (startIndex) { Tcl_DecrRefCount(startIndex); } return TCL_ERROR; @@ -580,39 +536,38 @@ objc -= idx; objv += idx; if (startIndex) { - size_t stringLength = Tcl_GetCharLength(objv[1]); + int stringLength = Tcl_GetCharLength(objv[1]); - TclGetIntForIndexM(interp, startIndex, stringLength, &offset); + TclGetIntForIndexM(NULL, startIndex, stringLength, &offset); Tcl_DecrRefCount(startIndex); - if (offset == TCL_INDEX_NONE) { - offset = TCL_INDEX_START; + if (offset < 0) { + offset = 0; } } - if (all && (offset == TCL_INDEX_START) && (command == 0) + if (all && (offset == 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. */ - size_t slen; - int nocase, wsrclc; - int (*strCmpFn)(const Tcl_UniChar*,const Tcl_UniChar*,size_t); - Tcl_UniChar *p; + int slen, nocase; + int (*strCmpFn)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long); + Tcl_UniChar *p, wsrclc; numMatches = 0; nocase = (cflags & TCL_REG_NOCASE); - strCmpFn = nocase ? TclUniCharNcasecmp : TclUniCharNcmp; + strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; - wsrc = TclGetUnicodeFromObj(objv[0], &slen); - wstring = TclGetUnicodeFromObj(objv[1], &wlen); - wsubspec = TclGetUnicodeFromObj(objv[2], &wsublen); + 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) { /* @@ -622,35 +577,36 @@ if (wstring < wend) { resultPtr = Tcl_NewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); for (; wstring < wend; wstring++) { - TclAppendUnicodeToObj(resultPtr, wsubspec, wsublen); - TclAppendUnicodeToObj(resultPtr, wstring, 1); + Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); + Tcl_AppendUnicodeToObj(resultPtr, wstring, 1); numMatches++; } 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, slen) == 0))) { + (slen==1 || (strCmpFn(wstring, wsrc, + (unsigned long) slen) == 0))) { if (numMatches == 0) { resultPtr = Tcl_NewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); } if (p != wstring) { - TclAppendUnicodeToObj(resultPtr, p, wstring - p); + Tcl_AppendUnicodeToObj(resultPtr, p, wstring - p); p = wstring + slen; } else { p += slen; } wstring = p - 1; - TclAppendUnicodeToObj(resultPtr, wsubspec, wsublen); + Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); numMatches++; } } if (numMatches) { wlen = wfirstChar + wlen - p; @@ -665,32 +621,10 @@ regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); if (regExpr == NULL) { return TCL_ERROR; } - if (command) { - /* - * In command-prefix mode, we require that the third non-option - * argument be a list, so we enforce that here. Afterwards, we fetch - * the RE compilation again in case objv[0] and objv[2] are the same - * object. (If they aren't, that's cheap to do.) - */ - - if (Tcl_ListObjLength(interp, objv[2], &numParts) != TCL_OK) { - return TCL_ERROR; - } - if (numParts < 1) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "command prefix must be a list of at least one element", - -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "REGSUB", - "CMDEMPTY", NULL); - return TCL_ERROR; - } - regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); - } - /* * Make sure to avoid problems where the objects are shared. This can * cause RegExpObj <> UnicodeObj shimmering that causes data corruption. * [Bug #461322] */ @@ -698,19 +632,17 @@ if (objv[1] == objv[0]) { objPtr = Tcl_DuplicateObj(objv[1]); } else { objPtr = objv[1]; } - wstring = TclGetUnicodeFromObj(objPtr, &wlen); + wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen); if (objv[2] == objv[0]) { subPtr = Tcl_DuplicateObj(objv[2]); } else { subPtr = objv[2]; } - if (!command) { - wsubspec = TclGetUnicodeFromObj(subPtr, &wsublen); - } + wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen); result = TCL_OK; /* * The following loop is to handle multiple matches within the same source @@ -743,17 +675,17 @@ break; } if (numMatches == 0) { resultPtr = Tcl_NewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); - if (offset > TCL_INDEX_START) { + if (offset > 0) { /* * Copy the initial portion of the string in if an offset was * specified. */ - TclAppendUnicodeToObj(resultPtr, wstring, offset); + Tcl_AppendUnicodeToObj(resultPtr, wstring, offset); } } numMatches++; /* @@ -762,95 +694,11 @@ */ Tcl_RegExpGetInfo(regExpr, &info); start = info.matches[0].start; end = info.matches[0].end; - TclAppendUnicodeToObj(resultPtr, wstring + offset, start); - - /* - * In command-prefix mode, the substitutions are added as quoted - * arguments to the subSpec to form a command, that is then executed - * and the result used as the string to substitute in. Actually, - * everything is passed through Tcl_EvalObjv, as that's much faster. - */ - - if (command) { - Tcl_Obj **args = NULL, **parts; - int numArgs; - - Tcl_ListObjGetElements(interp, subPtr, &numParts, &parts); - numArgs = numParts + info.nsubs + 1; - args = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj*) * numArgs); - memcpy(args, parts, sizeof(Tcl_Obj*) * numParts); - - for (idx = 0 ; idx <= info.nsubs ; idx++) { - subStart = info.matches[idx].start; - subEnd = info.matches[idx].end; - if ((subStart != TCL_INDEX_NONE) && (subEnd != TCL_INDEX_NONE)) { - args[idx + numParts] = Tcl_NewUnicodeObj( - wstring + offset + subStart, subEnd - subStart); - } else { - args[idx + numParts] = Tcl_NewObj(); - } - Tcl_IncrRefCount(args[idx + numParts]); - } - - /* - * At this point, we're locally holding the references to the - * argument words we added for this time round the loop, and the - * subPtr is holding the references to the words that the user - * supplied directly. None are zero-refcount, which is important - * because Tcl_EvalObjv is "hairy monster" in terms of refcount - * handling, being able to optionally add references to any of its - * argument words. We'll drop the local refs immediately - * 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]); - } - Tcl_Free(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 = TclGetUnicodeFromObj(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 - * again at the same spot. - */ - - if (offset < wlen) { - TclAppendUnicodeToObj(resultPtr, wstring + offset, 1); - } - offset++; - } - if (all) { - continue; - } else { - break; - } - } + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start); /* * Append the subSpec argument to the variable, making appropriate * substitutions. This code is a bit hairy because of the backslash * conventions and because the code saves up ranges of characters in @@ -866,11 +714,11 @@ ch = wsrc[1]; if ((ch >= '0') && (ch <= '9')) { idx = ch - '0'; } else if ((ch == '\\') || (ch == '&')) { *wsrc = ch; - TclAppendUnicodeToObj(resultPtr, wfirstChar, + Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar + 1); *wsrc = '\\'; wfirstChar = wsrc + 2; wsrc++; continue; @@ -880,19 +728,19 @@ } else { continue; } if (wfirstChar != wsrc) { - TclAppendUnicodeToObj(resultPtr, wfirstChar, + Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); } if (idx <= info.nsubs) { subStart = info.matches[idx].start; subEnd = info.matches[idx].end; - if ((subStart != TCL_INDEX_NONE) && (subEnd != TCL_INDEX_NONE)) { - TclAppendUnicodeToObj(resultPtr, + if ((subStart >= 0) && (subEnd >= 0)) { + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset + subStart, subEnd - subStart); } } if (*wsrc == '\\') { @@ -900,21 +748,21 @@ } wfirstChar = wsrc + 1; } if (wfirstChar != wsrc) { - TclAppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); + Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); } if (end == 0) { /* * Always consume at least one character of the input string in * order to prevent infinite loops. */ if (offset < wlen) { - TclAppendUnicodeToObj(resultPtr, wstring + offset, 1); + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); } offset++; } else { offset += end; if (start == end) { @@ -922,11 +770,11 @@ * We matched an empty string, which means we must go forward * one more step so we don't match again at the same spot. */ if (offset < wlen) { - TclAppendUnicodeToObj(resultPtr, wstring + offset, 1); + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); } offset++; } } if (!all) { @@ -947,23 +795,24 @@ */ resultPtr = objv[1]; Tcl_IncrRefCount(resultPtr); } else if (offset < wlen) { - TclAppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); } if (objc == 4) { - if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, - TCL_LEAVE_ERR_MSG) == NULL) { + if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, 0) == NULL) { + Tcl_AppendResult(interp, "couldn't set variable \"", + TclGetString(objv[3]), "\"", NULL); result = TCL_ERROR; } else { /* * Set the interpreter's object result to an integer object * holding the number of matches. */ - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(numMatches)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(numMatches)); } } else { /* * No varname supplied, so just return the modified string. */ @@ -1001,16 +850,16 @@ *---------------------------------------------------------------------- */ int Tcl_RenameObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Arbitrary value passed to the command. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *oldName, *newName; + char *oldName, *newName; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "oldName newName"); return TCL_ERROR; } @@ -1037,11 +886,11 @@ *---------------------------------------------------------------------- */ int Tcl_ReturnObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int code, level; @@ -1084,73 +933,39 @@ *---------------------------------------------------------------------- */ 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), + ClientData dummy, /* Not used. */ 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; - void **pkgFiles = NULL; - void *names = NULL; - if (objc < 2 || objc > 4) { + if (objc != 2 && objc !=4) { Tcl_WrongNumArgs(interp, 1, objv, "?-encoding name? fileName"); return TCL_ERROR; } fileName = objv[objc-1]; if (objc == 4) { - static const char *const options[] = { + static const char *options[] = { "-encoding", NULL }; int index; if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], options, "option", TCL_EXACT, &index)) { return TCL_ERROR; } encodingName = TclGetString(objv[2]); - } else if (objc == 3) { - /* Handle undocumented -nopkg option. This should only be - * used by the internal ::tcl::Pkg::source utility function. */ - static const char *const nopkgoptions[] = { - "-nopkg", NULL - }; - 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) { - /* restore "tclPkgFiles" assocdata to how it was. */ - *pkgFiles = names; - } - return result; + } + + return Tcl_FSEvalFileEx(interp, fileName, encodingName); } /* *---------------------------------------------------------------------- * @@ -1168,21 +983,20 @@ *---------------------------------------------------------------------- */ int Tcl_SplitObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int ch = 0; + Tcl_UniChar ch; int len; const char *splitChars; - const char *stringPtr; - const char *end; - size_t splitCharLen, stringLen; + char *stringPtr, *end; + int splitCharLen, stringLen; Tcl_Obj *listPtr, *objPtr; if (objc == 2) { splitChars = " \n\t\r"; splitCharLen = 4; @@ -1216,59 +1030,65 @@ */ Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS); for ( ; stringPtr < end; stringPtr += len) { - len = TclUtfToUCS4(stringPtr, &ch); - hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR(ch), &isNew); + len = TclUtfToUniChar(stringPtr, &ch); + + /* + * Assume Tcl_UniChar is an integral type... + */ + + hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0+ch, &isNew); if (isNew) { TclNewStringObj(objPtr, stringPtr, len); /* * Don't need to fiddle with refcount... */ - Tcl_SetHashValue(hPtr, objPtr); + Tcl_SetHashValue(hPtr, (ClientData) objPtr); } else { - objPtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr); + objPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); } Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } Tcl_DeleteHashTable(&charReuseTable); } else if (splitCharLen == 1) { - const char *p; + 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,*splitChars)) != NULL) { + 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; - size_t splitLen; - int splitChar; + char *element; + const char *p, *splitEnd; + int splitLen; + Tcl_UniChar 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); + len = TclUtfToUniChar(stringPtr, &ch); for (p = splitChars; p < splitEnd; p += splitLen) { - splitLen = TclUtfToUCS4(p, &splitChar); + splitLen = TclUtfToUniChar(p, &splitChar); if (ch == splitChar) { TclNewStringObj(objPtr, element, stringPtr - element); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); element = stringPtr + len; break; @@ -1287,12 +1107,11 @@ *---------------------------------------------------------------------- * * StringFirstCmd -- * * This procedure is invoked to process the "string first" Tcl command. - * See the user documentation for details on what it does. Note that this - * command only functions correctly on properly formed Tcl UTF strings. + * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -1301,42 +1120,109 @@ *---------------------------------------------------------------------- */ static int StringFirstCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - size_t start = TCL_INDEX_START; + Tcl_UniChar *ustring1, *ustring2; + int match, start, length1, length2; if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "needleString haystackString ?startIndex?"); return TCL_ERROR; } + /* + * We are searching string2 for the sequence string1. + */ + + match = -1; + start = 0; + length2 = -1; + + ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1); + ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2); + if (objc == 4) { - size_t end = Tcl_GetCharLength(objv[2]) - 1; + /* + * If a startIndex is specified, we will need to fast forward to that + * point in the string before we think about a match. + */ - if (TCL_OK != TclGetIntForIndexM(interp, objv[3], end, &start)) { + if (TclGetIntForIndexM(interp, objv[3], length2-1, &start) != TCL_OK){ return TCL_ERROR; } + + /* + * Reread to prevent shimmering problems. + */ + + ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1); + ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2); + + if (start >= length2) { + goto str_first_done; + } else if (start > 0) { + ustring2 += start; + length2 -= start; + } else if (start < 0) { + /* + * Invalid start index mapped to string start; Bug #423581 + */ + + start = 0; + } } - Tcl_SetObjResult(interp, TclStringFirst(objv[1], objv[2], start)); + + /* + * If the length of the needle is more than the length of the haystack, it + * cannot be contained in there so we can avoid searching. [Bug 2960021] + */ + + if (length1 > 0 && length1 <= length2) { + register Tcl_UniChar *p, *end; + + end = ustring2 + length2 - length1 + 1; + for (p = ustring2; p < end; p++) { + /* + * Scan forward to find the first character. + */ + + if ((*p == *ustring1) && (TclUniCharNcmp(ustring1, p, + (unsigned long) length1) == 0)) { + match = p - ustring2; + break; + } + } + } + + /* + * Compute the character index of the matching string by counting the + * number of characters before the match. + */ + + if ((match != -1) && (objc == 4)) { + match += start; + } + + str_first_done: + Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); return TCL_OK; } /* *---------------------------------------------------------------------- * * StringLastCmd -- * * This procedure is invoked to process the "string last" Tcl command. - * See the user documentation for details on what it does. Note that this - * command only functions correctly on properly formed Tcl UTF strings. + * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: @@ -1345,31 +1231,84 @@ *---------------------------------------------------------------------- */ static int StringLastCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - size_t last = TCL_INDEX_END; + Tcl_UniChar *ustring1, *ustring2, *p; + int match, start, length1, length2; if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, - "needleString haystackString ?lastIndex?"); + "needleString haystackString ?startIndex?"); return TCL_ERROR; } + /* + * We are searching string2 for the sequence string1. + */ + + match = -1; + start = 0; + length2 = -1; + + ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1); + ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2); + if (objc == 4) { - size_t end = Tcl_GetCharLength(objv[2]) - 1; + /* + * If a startIndex is specified, we will need to restrict the string + * range to that char index in the string + */ - if (TCL_OK != TclGetIntForIndexM(interp, objv[3], end, &last)) { + if (TclGetIntForIndexM(interp, objv[3], length2-1, &start) != TCL_OK){ return TCL_ERROR; } + + /* + * Reread to prevent shimmering problems. + */ + + ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1); + ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2); + + if (start < 0) { + goto str_last_done; + } else if (start < length2) { + p = ustring2 + start + 1 - length1; + } else { + p = ustring2 + length2 - length1; + } + } else { + p = ustring2 + length2 - length1; } - Tcl_SetObjResult(interp, TclStringLast(objv[1], objv[2], last)); + + /* + * If the length of the needle is more than the length of the haystack, it + * cannot be contained in there so we can avoid searching. [Bug 2960021] + */ + + if (length1 > 0 && length1 <= length2) { + for (; p >= ustring2; p--) { + /* + * Scan backwards to find the first character. + */ + + if ((*p == *ustring1) && !memcmp(ustring1, p, + sizeof(Tcl_UniChar) * (size_t)length1)) { + match = p - ustring2; + break; + } + } + } + + str_last_done: + Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -1389,115 +1328,59 @@ *---------------------------------------------------------------------- */ static int StringIndexCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - size_t index, end; + 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. - */ - - end = Tcl_GetCharLength(objv[1]) - 1; - if (TclGetIntForIndexM(interp, objv[2], end, &index) != TCL_OK) { - return TCL_ERROR; - } - - if ((index != TCL_INDEX_NONE) && (index + 1 <= end + 1)) { - 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] = ""; - - end = Tcl_UniCharToUtf(ch, buf); - if ((ch >= 0xD800) && (end < 3)) { - end += Tcl_UniCharToUtf(-1, buf + end); - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, end)); - } - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * StringInsertCmd -- - * - * This procedure is invoked to process the "string insert" Tcl command. - * See the user documentation for details on what it does. Note that this - * command only functions correctly on properly formed Tcl UTF strings. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * 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 */ -{ - size_t length; /* String length */ - size_t 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 == TCL_INDEX_NONE) { - index = TCL_INDEX_START; - } - if (index > length) { - index = length; - } - - outObj = TclStringReplace(interp, objv[1], index, 0, objv[3], - TCL_STRING_IN_PLACE); - - if (outObj != NULL) { - Tcl_SetObjResult(interp, outObj); - return TCL_OK; - } - - return TCL_ERROR; + * If we have a ByteArray object, avoid indexing in the Utf string since + * the byte array contains one byte per character. Otherwise, use the + * Unicode string rep to get the index'th char. + */ + + if (TclIsPureByteArray(objv[1])) { + const unsigned char *string = + Tcl_GetByteArrayFromObj(objv[1], &length); + + if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK){ + return TCL_ERROR; + } + string = Tcl_GetByteArrayFromObj(objv[1], &length); + if ((index >= 0) && (index < length)) { + Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(string + index, 1)); + } + } else { + /* + * Get Unicode char length to calulate 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)) { + char buf[TCL_UTF_MAX]; + Tcl_UniChar ch; + + ch = Tcl_GetUniChar(objv[1], index); + length = Tcl_UniCharToUtf(ch, buf); + Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length)); + } + } + return TCL_OK; } /* *---------------------------------------------------------------------- * @@ -1516,43 +1399,41 @@ *---------------------------------------------------------------------- */ static int StringIsCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *string1, *end, *stop; + Tcl_UniChar ch; int (*chcomp)(int) = NULL; /* The UniChar comparison function. */ - int i, result = 1, strict = 0, index, length3; - size_t failat = 0; - size_t length1, length2; + int i, failat = 0, result = 1, strict = 0, index, length1, length2; Tcl_Obj *objPtr, *failVarObj = NULL; Tcl_WideInt w; - static const char *const isClasses[] = { + static const char *isClasses[] = { "alnum", "alpha", "ascii", "control", - "boolean", "dict", "digit", "double", - "entier", "false", "graph", "integer", - "list", "lower", "print", "punct", - "space", "true", "upper", "wideinteger", - "wordchar", "xdigit", NULL - }; - enum isClassesEnum { - STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, - STR_IS_BOOL, STR_IS_DICT, STR_IS_DIGIT, STR_IS_DOUBLE, - STR_IS_ENTIER, STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, - STR_IS_LIST, STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, - STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, - STR_IS_WORD, STR_IS_XDIGIT - }; - static const char *const isOptions[] = { + "boolean", "digit", "double", "false", + "graph", "integer", "list", "lower", + "print", "punct", "space", "true", + "upper", "wideinteger", "wordchar", "xdigit", + NULL + }; + enum isClasses { + STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, + STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_FALSE, + STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST, STR_IS_LOWER, + STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, + STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT + }; + static const char *isOptions[] = { "-strict", "-failindex", NULL }; - enum isOptionsEnum { + enum isOptions { OPT_STRICT, OPT_FAILIDX }; if (objc < 3 || objc > 6) { Tcl_WrongNumArgs(interp, 1, objv, @@ -1570,11 +1451,11 @@ if (Tcl_GetIndexFromObj(interp, objv[i], isOptions, "option", 0, &idx2) != TCL_OK) { return TCL_ERROR; } - switch ((enum isOptionsEnum) idx2) { + switch ((enum isOptions) idx2) { case OPT_STRICT: strict = 1; break; case OPT_FAILIDX: if (i+1 >= objc-1) { @@ -1599,11 +1480,11 @@ /* * When entering here, result == 1 and failat == 0. */ - switch ((enum isClassesEnum) index) { + switch ((enum isClasses) index) { case STR_IS_ALNUM: chcomp = Tcl_UniCharIsAlnum; break; case STR_IS_ALPHA: chcomp = Tcl_UniCharIsAlpha; @@ -1612,82 +1493,37 @@ chcomp = UniCharIsAscii; break; case STR_IS_BOOL: case STR_IS_TRUE: case STR_IS_FALSE: - if (!TclHasIntRep(objPtr, &tclBooleanType) - && (TCL_OK != TclSetBooleanFromAny(NULL, objPtr))) { + if (TCL_OK != Tcl_ConvertToType(NULL, objPtr, &tclBooleanType)) { if (strict) { result = 0; } else { string1 = TclGetStringFromObj(objPtr, &length1); result = length1 == 0; } - } else if ((objPtr->internalRep.wideValue != 0) - ? (index == STR_IS_FALSE) : (index == STR_IS_TRUE)) { + } else if (((index == STR_IS_TRUE) && + objPtr->internalRep.longValue == 0) + || ((index == STR_IS_FALSE) && + objPtr->internalRep.longValue != 0)) { 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; - size_t 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 (TclIsSpaceProc(*p)) { - p++; - } - TclNewStringObj(tmpStr, string1, p-string1); - failat = Tcl_GetCharLength(tmpStr); - TclDecrRefCount(tmpStr); - break; - } - } - } - break; - } case STR_IS_DIGIT: chcomp = Tcl_UniCharIsDigit; break; case STR_IS_DOUBLE: { - if (TclHasIntRep(objPtr, &tclDoubleType) || - TclHasIntRep(objPtr, &tclIntType) || - TclHasIntRep(objPtr, &tclBignumType)) { + if ((objPtr->typePtr == &tclDoubleType) || + (objPtr->typePtr == &tclIntType) || +#ifndef NO_WIDE_TYPE + (objPtr->typePtr == &tclWideIntType) || +#endif + (objPtr->typePtr == &tclBignumType)) { break; } string1 = TclGetStringFromObj(objPtr, &length1); if (length1 == 0) { if (strict) { @@ -1703,65 +1539,29 @@ } else { failat = stop - string1; if (stop < end) { result = 0; TclFreeIntRep(objPtr); + objPtr->typePtr = NULL; } } break; } case STR_IS_GRAPH: chcomp = Tcl_UniCharIsGraph; break; case STR_IS_INT: - case STR_IS_ENTIER: - if (TclHasIntRep(objPtr, &tclIntType) || - TclHasIntRep(objPtr, &tclBignumType)) { - break; - } - string1 = TclGetStringFromObj(objPtr, &length1); - if (length1 == 0) { - if (strict) { - result = 0; - } - goto str_is_done; - } - end = string1 + length1; - if (TclParseNumber(NULL, objPtr, NULL, NULL, -1, - (const char **) &stop, TCL_PARSE_INTEGER_ONLY) == TCL_OK) { - if (stop == end) { - /* - * Entire string parses as an integer. - */ - - break; - } else { - /* - * Some prefix parsed as an integer, but not the whole string, - * so return failure index as the point where parsing stopped. - * Clear out the internal rep, since keeping it would leave - * *objPtr in an inconsistent state. - */ - - result = 0; - failat = stop - string1; - TclFreeIntRep(objPtr); - } - } else { - /* - * No prefix is a valid integer. Fail at beginning. - */ - - result = 0; - failat = 0; - } - break; + if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &i)) { + break; + } + goto failedIntParse; case STR_IS_WIDE: - if (TCL_OK == TclGetWideIntFromObj(NULL, objPtr, &w)) { + if (TCL_OK == Tcl_GetWideIntFromObj(NULL, objPtr, &w)) { break; } + failedIntParse: string1 = TclGetStringFromObj(objPtr, &length1); if (length1 == 0) { if (strict) { result = 0; } @@ -1796,10 +1596,11 @@ * *objPtr in an inconsistent state. */ failat = stop - string1; TclFreeIntRep(objPtr); + objPtr->typePtr = NULL; } } else { /* * No prefix is a valid integer. Fail at beginning. */ @@ -1811,11 +1612,11 @@ /* * We ignore the strictness here, since empty strings are always * well-formed lists. */ - if (TCL_OK == TclListObjLength(NULL, objPtr, &length3)) { + if (TCL_OK == TclListObjLength(NULL, objPtr, &length2)) { break; } if (failVarObj != NULL) { /* @@ -1823,13 +1624,12 @@ * fairly expensive. This is adapted from the core of * SetListFromAny(). */ const char *elemStart, *nextElem; - size_t lenRemain; - size_t elemSize; - const char *p; + int lenRemain, elemSize; + register const char *p; string1 = TclGetStringFromObj(objPtr, &length1); end = string1 + length1; failat = -1; for (p=string1, lenRemain=length1; lenRemain > 0; @@ -1891,14 +1691,12 @@ } goto str_is_done; } end = string1 + length1; for (; string1 < end; string1 += length2, failat++) { - int ucs4; - - length2 = TclUtfToUCS4(string1, &ucs4); - if (!chcomp(ucs4)) { + length2 = TclUtfToUniChar(string1, &ch); + if (!chcomp(ch)) { result = 0; break; } } } @@ -1907,15 +1705,14 @@ * 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)) { - TclNewIndexObj(objPtr, failat); - if (Tcl_ObjSetVar2(interp, failVarObj, NULL, objPtr, TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; - } + if ((result == 0) && (failVarObj != NULL) && + Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat), + TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); return TCL_OK; } @@ -1928,11 +1725,11 @@ static int UniCharIsHexDigit( int character) { - return (character >= 0) && (character < 0x80) && isxdigit(UCHAR(character)); + return (character >= 0) && (character < 0x80) && isxdigit(character); } /* *---------------------------------------------------------------------- * @@ -1951,20 +1748,20 @@ *---------------------------------------------------------------------- */ static int StringMapCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - size_t length1, length2, mapElemc, index; + 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*, size_t); + 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; } @@ -1971,68 +1768,64 @@ if (objc == 4) { const char *string = TclGetStringFromObj(objv[1], &length2); if ((length2 > 1) && - strncmp(string, "-nocase", length2) == 0) { + strncmp(string, "-nocase", (size_t) length2) == 0) { nocase = 1; } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad option \"%s\": must be -nocase", string)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", - string, NULL); + Tcl_AppendResult(interp, "bad option \"", string, + "\": must be -nocase", NULL); return TCL_ERROR; } } /* * This test is tricky, but has to be that way or you get other strange - * inconsistencies (see test string-10.20.1 for illustration why!) + * inconsistencies (see test string-10.20 for illustration why!) */ - if (!TclHasStringRep(objv[objc-2]) - && TclHasIntRep(objv[objc-2], &tclDictType)) { + if (objv[objc-2]->typePtr == &tclDictType && objv[objc-2]->bytes == NULL){ int i, done; 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], &i); - if (i == 0) { + 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 * i; + 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); + mapElemv = (Tcl_Obj **) + TclStackAlloc(interp, sizeof(Tcl_Obj *) * mapElemc); Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0, mapElemv+1, &done); - for (index=2 ; index30% faster on * larger strings. */ - size_t mapLen; - int u2lc; - Tcl_UniChar *mapString; + int mapLen; + Tcl_UniChar *mapString, u2lc; - ustring2 = TclGetUnicodeFromObj(mapElemv[0], &length2); + 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 = TclGetUnicodeFromObj(mapElemv[1], &mapLen); + 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, - length2) == 0)) { + (unsigned long) length2) == 0)) { if (p != ustring1) { - TclAppendUnicodeToObj(resultPtr, p, ustring1-p); + Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p); p = ustring1 + length2; } else { p += length2; } ustring1 = p - 1; - TclAppendUnicodeToObj(resultPtr, mapString, mapLen); + Tcl_AppendUnicodeToObj(resultPtr, mapString, mapLen); } } } } else { - Tcl_UniChar **mapStrings; - size_t *mapLens; - int *u2lc = 0; + Tcl_UniChar **mapStrings, *u2lc = NULL; + int *mapLens; /* * 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*sizeof(Tcl_UniChar *)*2); - mapLens = (size_t *)TclStackAlloc(interp, mapElemc * sizeof(size_t) * 2); + 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)); + u2lc = (Tcl_UniChar *) TclStackAlloc(interp, + mapElemc * sizeof(Tcl_UniChar)); } for (index = 0; index < mapElemc; index++) { - mapStrings[index] = TclGetUnicodeFromObj(mapElemv[index], + mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index], mapLens+index); if (nocase && ((index % 2) == 0)) { u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]); } } @@ -2153,18 +1944,18 @@ ustring2 = mapStrings[index]; length2 = mapLens[index]; if ((length2 > 0) && ((*ustring1 == *ustring2) || (nocase && (Tcl_UniCharToLower(*ustring1) == u2lc[index/2]))) && /* Restrict max compare length. */ - ((size_t)(end-ustring1) >= length2) && ((length2 == 1) || - !strCmpFn(ustring2, ustring1, length2))) { + (end-ustring1 >= length2) && ((length2 == 1) || + !strCmpFn(ustring2, ustring1, (unsigned) length2))) { if (p != ustring1) { /* * Put the skipped chars onto the result first. */ - TclAppendUnicodeToObj(resultPtr, p, ustring1-p); + Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p); p = ustring1 + length2; } else { p += length2; } @@ -2176,11 +1967,11 @@ /* * Append the map value to the unicode string. */ - TclAppendUnicodeToObj(resultPtr, + Tcl_AppendUnicodeToObj(resultPtr, mapStrings[index+1], mapLens[index+1]); break; } } } @@ -2193,11 +1984,11 @@ if (p != ustring1) { /* * Put the rest of the unmapped chars onto result. */ - TclAppendUnicodeToObj(resultPtr, p, ustring1 - p); + Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); } Tcl_SetObjResult(interp, resultPtr); done: if (mapWithDict) { TclStackFree(interp, mapElemv); @@ -2226,11 +2017,11 @@ *---------------------------------------------------------------------- */ static int StringMatchCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int nocase = 0; @@ -2239,21 +2030,19 @@ Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? pattern string"); return TCL_ERROR; } if (objc == 4) { - size_t length; + int length; const char *string = TclGetStringFromObj(objv[1], &length); if ((length > 1) && - strncmp(string, "-nocase", length) == 0) { + strncmp(string, "-nocase", (size_t) length) == 0) { nocase = TCL_MATCH_NOCASE; } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad option \"%s\": must be -nocase", string)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", - string, NULL); + Tcl_AppendResult(interp, "bad option \"", string, + "\": must be -nocase", NULL); return TCL_ERROR; } } Tcl_SetObjResult(interp, Tcl_NewBooleanObj( TclStringMatchObj(objv[objc-1], objv[objc-2], nocase))); @@ -2278,42 +2067,64 @@ *---------------------------------------------------------------------- */ static int StringRangeCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - size_t first, last, end; + const unsigned char *string; + 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. + * If we have a ByteArray object, avoid indexing in the Utf string since + * the byte array contains one byte per character. Otherwise, use the + * Unicode string rep to get the range. */ - end = Tcl_GetCharLength(objv[1]) - 1; + if (TclIsPureByteArray(objv[1])) { + string = Tcl_GetByteArrayFromObj(objv[1], &length); + length--; + } else { + /* + * Get the length in actual characters. + */ - if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK || - TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK) { + string = NULL; + 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 == TCL_INDEX_NONE) { - first = TCL_INDEX_START; - } - if (last + 1 >= end + 1) { - last = end; - } - if (last + 1 >= first + 1) { - Tcl_SetObjResult(interp, Tcl_GetRange(objv[1], first, last)); + if (first < 0) { + first = 0; + } + if (last >= length) { + last = length; + } + if (last >= first) { + if (string != NULL) { + /* + * Reread the string to prevent shimmering nasties. + */ + + string = Tcl_GetByteArrayFromObj(objv[1], &length); + Tcl_SetObjResult(interp, + Tcl_NewByteArrayObj(string+first, last - first + 1)); + } else { + Tcl_SetObjResult(interp, Tcl_GetRange(objv[1], first, last)); + } } return TCL_OK; } /* @@ -2334,16 +2145,18 @@ *---------------------------------------------------------------------- */ static int StringReptCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int count; + const char *string1; + char *string2; + int count, index, length1, length2; Tcl_Obj *resultPtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "string count"); return TCL_ERROR; @@ -2357,21 +2170,72 @@ * Check for cases that allow us to skip copying stuff. */ if (count == 1) { Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; + goto done; } else if (count < 1) { - return TCL_OK; + goto done; + } + string1 = TclGetStringFromObj(objv[1], &length1); + if (length1 <= 0) { + goto done; } - resultPtr = TclStringRepeat(interp, objv[1], count, TCL_STRING_IN_PLACE); - if (resultPtr) { - Tcl_SetObjResult(interp, resultPtr); - return TCL_OK; + /* + * Only build up a string that has data. Instead of building it up with + * repeated appends, we just allocate the necessary space once and copy + * the string value in. + * + * We have to worry about overflow [Bugs 714106, 2561746]. + * At this point we know 1 <= length1 <= INT_MAX and 2 <= count <= INT_MAX. + * We need to keep 2 <= length2 <= INT_MAX. + */ + + if (count > (INT_MAX / length1)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "result exceeds max size for a Tcl value (%d bytes)", INT_MAX)); + return TCL_ERROR; } - return TCL_ERROR; + length2 = length1 * count; + + /* + * Include space for the NUL. + */ + + string2 = attemptckalloc((unsigned) length2 + 1); + if (string2 == NULL) { + /* + * Alloc failed. Note that in this case we try to do an error message + * since this is a case that's most likely when the alloc is large and + * that's easy to do with this API. Note that if we fail allocating a + * short string, this will likely keel over too (and fatally). + */ + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "string size overflow, out of memory allocating %u bytes", + length2 + 1)); + return TCL_ERROR; + } + for (index = 0; index < count; index++) { + memcpy(string2 + (length1 * index), string1, (size_t) length1); + } + string2[length2] = '\0'; + + /* + * We have to directly assign this instead of using Tcl_SetStringObj (and + * indirectly TclInitStringRep) because that makes another copy of the + * data. + */ + + TclNewObj(resultPtr); + resultPtr->bytes = string2; + resultPtr->length = length2; + Tcl_SetObjResult(interp, resultPtr); + + done: + return TCL_OK; } /* *---------------------------------------------------------------------- * @@ -2390,59 +2254,64 @@ *---------------------------------------------------------------------- */ static int StringRplcCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - size_t first, last, end; + Tcl_UniChar *ustring; + int first, last, length, end; if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 1, objv, "string first last ?string?"); return TCL_ERROR; } - end = Tcl_GetCharLength(objv[1]) - 1; + ustring = Tcl_GetUnicodeFromObj(objv[1], &length); + end = length - 1; if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK || - TclGetIntForIndexM(interp, objv[3], end, &last) != 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. + * 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 */ - if ((last == TCL_INDEX_NONE) || /* Range ends before start of string */ - (first + 1 > end + 1) || /* Range begins after end of string */ - (last + 1 < first + 1)) { /* 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 == TCL_INDEX_NONE) { - first = TCL_INDEX_START; - } - if (last + 1 > end + 1) { - last = end; + ustring = Tcl_GetUnicodeFromObj(objv[1], &length); + end = length-1; + + if (first < 0) { + first = 0; } - resultPtr = TclStringReplace(interp, objv[1], first, - last + 1 - first, (objc == 5) ? objv[4] : NULL, - TCL_STRING_IN_PLACE); - + resultPtr = Tcl_NewUnicodeObj(ustring, first); + if (objc == 5) { + Tcl_AppendObjToObj(resultPtr, objv[4]); + } + if (last < end) { + Tcl_AppendUnicodeToObj(resultPtr, ustring + last + 1, + end - last); + } Tcl_SetObjResult(interp, resultPtr); } return TCL_OK; } @@ -2464,31 +2333,33 @@ *---------------------------------------------------------------------- */ static int StringRevCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ 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)); + Tcl_SetObjResult(interp, TclStringObjReverse(objv[1])); 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. + * command. See the user documentation for details on what it does. Note + * that this command only functions correctly on properly formed Tcl UTF + * strings. * * Results: * A standard Tcl result. * * Side effects: @@ -2497,40 +2368,39 @@ *---------------------------------------------------------------------- */ static int StringStartCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int ch; + Tcl_UniChar ch; const char *p, *string; - size_t numChars, length, cur, index; - Tcl_Obj *obj; + 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) - 1; - if (TclGetIntForIndexM(interp, objv[2], numChars, &index) != TCL_OK) { + numChars = Tcl_NumUtfChars(string, length); + if (TclGetIntForIndexM(interp, objv[2], numChars-1, &index) != TCL_OK) { return TCL_ERROR; } - string = TclGetString(objv[1]); - if (index + 1 > numChars + 1) { - index = numChars; + string = TclGetStringFromObj(objv[1], &length); + if (index >= numChars) { + index = numChars - 1; } cur = 0; - if (index + 1 > 1) { + if (index > 0) { p = Tcl_UtfAtIndex(string, index); - TclUtfToUCS4(p, &ch); - for (cur = index; cur != TCL_INDEX_NONE; cur--) { + TclUtfToUniChar(p, &ch); + for (cur = index; cur >= 0; cur--) { int delta = 0; const char *next; if (!Tcl_UniCharIsWordChar(ch)) { break; @@ -2537,30 +2407,30 @@ } next = TclUtfPrev(p, string); do { next += delta; - delta = TclUtfToUCS4(next, &ch); + delta = TclUtfToUniChar(next, &ch); } while (next + delta < p); p = next; } if (cur != index) { cur += 1; } } - TclNewIndexObj(obj, cur); - Tcl_SetObjResult(interp, obj); + Tcl_SetObjResult(interp, Tcl_NewIntObj(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. + * See the user documentation for details on what it does. Note that this + * command only functions correctly on properly formed Tcl UTF strings. * * Results: * A standard Tcl result. * * Side effects: @@ -2569,51 +2439,49 @@ *---------------------------------------------------------------------- */ static int StringEndCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int ch; + Tcl_UniChar ch; const char *p, *end, *string; - size_t length, numChars, cur, index; - Tcl_Obj *obj; + 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) - 1; - if (TclGetIntForIndexM(interp, objv[2], numChars, &index) != TCL_OK) { + 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 == TCL_INDEX_NONE) { - index = TCL_INDEX_START; + if (index < 0) { + index = 0; } - if (index + 1 <= numChars + 1) { + if (index < numChars) { p = Tcl_UtfAtIndex(string, index); end = string+length; for (cur = index; p < end; cur++) { - p += TclUtfToUCS4(p, &ch); + p += TclUtfToUniChar(p, &ch); if (!Tcl_UniCharIsWordChar(ch)) { break; } } if (cur == index) { cur++; } } else { - cur = numChars + 1; + cur = numChars; } - TclNewIndexObj(obj, cur); - Tcl_SetObjResult(interp, obj); + Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -2633,11 +2501,11 @@ *---------------------------------------------------------------------- */ static int StringEqualCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { /* @@ -2644,40 +2512,38 @@ * Remember to keep code here in some sync with the byte-compiled versions * in tclExecute.c (INST_STR_EQ, INST_STR_NEQ and INST_STR_CMP as well as * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...). */ - const char *string2; - int i, match, nocase = 0, reqlength = -1; - size_t length; + char *string1, *string2; + int length1, length2, i, match, length, nocase = 0, reqlength = -1; + typedef int (*strCmpFn_t)(const char *, const char *, unsigned int); + strCmpFn_t strCmpFn; if (objc < 3 || objc > 6) { str_cmp_args: Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? ?-length int? string1 string2"); return TCL_ERROR; } for (i = 1; i < objc-2; i++) { - string2 = TclGetStringFromObj(objv[i], &length); - if ((length > 1) && !strncmp(string2, "-nocase", length)) { + string2 = TclGetStringFromObj(objv[i], &length2); + if ((length2 > 1) && !strncmp(string2, "-nocase", (size_t)length2)) { nocase = 1; - } else if ((length > 1) - && !strncmp(string2, "-length", length)) { + } else if ((length2 > 1) + && !strncmp(string2, "-length", (size_t)length2)) { if (i+1 >= objc-2) { goto str_cmp_args; } - i++; + ++i; if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) { return TCL_ERROR; } } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad option \"%s\": must be -nocase or -length", - string2)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", - string2, NULL); + Tcl_AppendResult(interp, "bad option \"", string2, + "\": must be -nocase or -length", NULL); return TCL_ERROR; } } /* @@ -2684,11 +2550,84 @@ * From now on, we only access the two objects at the end of the argument * array. */ objv += objc-2; - match = TclStringCmp(objv[0], objv[1], 0, nocase, reqlength); + + if ((reqlength == 0) || (objv[0] == objv[1])) { + /* + * Always match at 0 chars of if it is the same obj. + */ + + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); + return TCL_OK; + } + + if (!nocase && TclIsPureByteArray(objv[0]) && + TclIsPureByteArray(objv[1])) { + /* + * 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... :^) + */ + + string1 = (char *) Tcl_GetByteArrayFromObj(objv[0], &length1); + string2 = (char *) Tcl_GetByteArrayFromObj(objv[1], &length2); + strCmpFn = (strCmpFn_t) memcmp; + } else if ((objv[0]->typePtr == &tclStringType) + && (objv[1]->typePtr == &tclStringType)) { + /* + * Do a unicode-specific comparison if both of the args are of String + * type. In benchmark testing this proved the most efficient check + * between the unicode and string comparison operations. + */ + + string1 = (char *) Tcl_GetUnicodeFromObj(objv[0], &length1); + string2 = (char *) Tcl_GetUnicodeFromObj(objv[1], &length2); + strCmpFn = (strCmpFn_t) + (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp); + } else { + /* + * 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. + */ + + string1 = (char *) TclGetStringFromObj(objv[0], &length1); + string2 = (char *) TclGetStringFromObj(objv[1], &length2); + if ((reqlength < 0) && !nocase) { + strCmpFn = (strCmpFn_t) TclpUtfNcmp2; + } else { + length1 = Tcl_NumUtfChars(string1, length1); + length2 = Tcl_NumUtfChars(string2, length2); + strCmpFn = (strCmpFn_t) (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); + } + } + + if ((reqlength < 0) && (length1 != length2)) { + match = 1; /* This will be reversed below. */ + } else { + length = (length1 < length2) ? length1 : length2; + 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; + } + + match = strCmpFn(string1, string2, (unsigned) length); + if ((match == 0) && (reqlength > length)) { + match = length1 - length2; + } + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(match ? 0 : 1)); return TCL_OK; } /* @@ -2709,11 +2648,11 @@ *---------------------------------------------------------------------- */ static int StringCmpCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { /* @@ -2720,111 +2659,121 @@ * 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/...). */ - int match, nocase, reqlength, status; - - status = TclStringCmpOpts(interp, objc, objv, &nocase, &reqlength); - if (status != TCL_OK) { - return status; - } - - objv += objc-2; - match = TclStringCmp(objv[0], objv[1], 0, nocase, reqlength); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(match)); - return TCL_OK; -} - -int -TclStringCmpOpts( - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[], /* Argument objects. */ - int *nocase, - int *reqlength) -{ - int i; - size_t length; - const char *string; - - *reqlength = -1; - *nocase = 0; + char *string1, *string2; + int length1, length2, i, match, length, nocase = 0, reqlength = -1; + typedef int (*strCmpFn_t)(const char *, const char *, unsigned int); + strCmpFn_t strCmpFn; + if (objc < 3 || objc > 6) { str_cmp_args: Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? ?-length int? string1 string2"); return TCL_ERROR; } for (i = 1; i < objc-2; i++) { - string = TclGetStringFromObj(objv[i], &length); - if ((length > 1) && !strncmp(string, "-nocase", length)) { - *nocase = 1; - } else if ((length > 1) - && !strncmp(string, "-length", length)) { + string2 = TclGetStringFromObj(objv[i], &length2); + if ((length2 > 1) && !strncmp(string2, "-nocase", (size_t)length2)) { + nocase = 1; + } else if ((length2 > 1) + && !strncmp(string2, "-length", (size_t)length2)) { if (i+1 >= objc-2) { goto str_cmp_args; } - i++; - if (TclGetIntFromObj(interp, objv[i], reqlength) != TCL_OK) { - return TCL_ERROR; - } - } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad option \"%s\": must be -nocase or -length", - string)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", - string, NULL); - return TCL_ERROR; - } - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * StringCatCmd -- - * - * This procedure is invoked to process the "string cat" 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 -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) { - /* - * If there are no args, the result is an empty object. - * Just leave the preset empty interp result. - */ - return TCL_OK; - } - - objResultPtr = TclStringCat(interp, objc-1, objv+1, TCL_STRING_IN_PLACE); - - if (objResultPtr) { - Tcl_SetObjResult(interp, objResultPtr); - return TCL_OK; - } - - return TCL_ERROR; + ++i; + if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) { + return TCL_ERROR; + } + } else { + Tcl_AppendResult(interp, "bad option \"", string2, + "\": must be -nocase or -length", NULL); + return TCL_ERROR; + } + } + + /* + * From now on, we only access the two objects at the end of the argument + * array. + */ + + objv += objc-2; + + if ((reqlength == 0) || (objv[0] == objv[1])) { + /* + * Always match at 0 chars of if it is the same obj. + */ + + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); + return TCL_OK; + } + + if (!nocase && TclIsPureByteArray(objv[0]) && + TclIsPureByteArray(objv[1])) { + /* + * 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... :^) + */ + + string1 = (char *) Tcl_GetByteArrayFromObj(objv[0], &length1); + string2 = (char *) Tcl_GetByteArrayFromObj(objv[1], &length2); + strCmpFn = (strCmpFn_t) memcmp; + } else if ((objv[0]->typePtr == &tclStringType) + && (objv[1]->typePtr == &tclStringType)) { + /* + * Do a unicode-specific comparison if both of the args are of String + * type. In benchmark testing this proved the most efficient check + * between the unicode and string comparison operations. + */ + + string1 = (char *) Tcl_GetUnicodeFromObj(objv[0], &length1); + string2 = (char *) Tcl_GetUnicodeFromObj(objv[1], &length2); + strCmpFn = (strCmpFn_t) + (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp); + } else { + /* + * 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. + */ + + string1 = (char *) TclGetStringFromObj(objv[0], &length1); + string2 = (char *) TclGetStringFromObj(objv[1], &length2); + if ((reqlength < 0) && !nocase) { + strCmpFn = (strCmpFn_t) TclpUtfNcmp2; + } else { + length1 = Tcl_NumUtfChars(string1, length1); + length2 = Tcl_NumUtfChars(string2, length2); + strCmpFn = (strCmpFn_t) (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); + } + } + + length = (length1 < length2) ? length1 : length2; + 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; + } + + match = strCmpFn(string1, string2, (unsigned) length); + if ((match == 0) && (reqlength > length)) { + match = length1 - length2; + } + + Tcl_SetObjResult(interp, + Tcl_NewIntObj((match > 0) ? 1 : (match < 0) ? -1 : 0)); + return TCL_OK; } /* *---------------------------------------------------------------------- * @@ -2844,24 +2793,24 @@ *---------------------------------------------------------------------- */ static int StringBytesCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - size_t length; + int length; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "string"); return TCL_ERROR; } (void) TclGetStringFromObj(objv[1], &length); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(length)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(length)); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -2881,21 +2830,34 @@ *---------------------------------------------------------------------- */ static int StringLenCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ 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; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_GetCharLength(objv[1]))); + /* + * If we have a ByteArray object, avoid recomputing the string since the + * byte array contains one byte per character. Otherwise, use the Unicode + * string rep to calculate the length. + */ + + if (objv[1]->typePtr == &tclByteArrayType) { + (void) Tcl_GetByteArrayFromObj(objv[1], &length); + } else { + length = Tcl_GetCharLength(objv[1]); + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(length)); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -2915,18 +2877,17 @@ *---------------------------------------------------------------------- */ static int StringLowerCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - size_t length1, length2; - const char *string1; - char *string2; + int length1, length2; + char *string1, *string2; if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?"); return TCL_ERROR; } @@ -2938,32 +2899,32 @@ length1 = Tcl_UtfToLower(TclGetString(resultPtr)); Tcl_SetObjLength(resultPtr, length1); Tcl_SetObjResult(interp, resultPtr); } else { - size_t first, last; + 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 == TCL_INDEX_NONE) { + if (first < 0) { first = 0; } last = first; if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1, &last) != TCL_OK)) { return TCL_ERROR; } - if (last + 1 >= length1 + 1) { + if (last >= length1) { last = length1; } - if (last + 1 < first + 1) { + if (last < first) { Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } string1 = TclGetStringFromObj(objv[1], &length1); @@ -3000,18 +2961,17 @@ *---------------------------------------------------------------------- */ static int StringUpperCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - size_t length1, length2; - const char *string1; - char *string2; + int length1, length2; + char *string1, *string2; if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?"); return TCL_ERROR; } @@ -3023,32 +2983,32 @@ length1 = Tcl_UtfToUpper(TclGetString(resultPtr)); Tcl_SetObjLength(resultPtr, length1); Tcl_SetObjResult(interp, resultPtr); } else { - size_t first, last; + 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 == TCL_INDEX_NONE) { - first = TCL_INDEX_START; + if (first < 0) { + first = 0; } last = first; if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1, &last) != TCL_OK)) { return TCL_ERROR; } - if (last + 1 >= length1 + 1) { + if (last >= length1) { last = length1; } - if (last + 1 < first + 1) { + if (last < first) { Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } string1 = TclGetStringFromObj(objv[1], &length1); @@ -3085,18 +3045,17 @@ *---------------------------------------------------------------------- */ static int StringTitleCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - size_t length1, length2; - const char *string1; - char *string2; + int length1, length2; + char *string1, *string2; if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?"); return TCL_ERROR; } @@ -3108,32 +3067,32 @@ length1 = Tcl_UtfToTitle(TclGetString(resultPtr)); Tcl_SetObjLength(resultPtr, length1); Tcl_SetObjResult(interp, resultPtr); } else { - size_t first, last; + 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 == TCL_INDEX_NONE) { - first = TCL_INDEX_START; + if (first < 0) { + first = 0; } last = first; if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1, &last) != TCL_OK)) { return TCL_ERROR; } - if (last + 1 >= length1 + 1) { + if (last >= length1) { last = length1; } - if (last + 1 < first + 1) { + if (last < first) { Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } string1 = TclGetStringFromObj(objv[1], &length1); @@ -3170,23 +3129,23 @@ *---------------------------------------------------------------------- */ static int StringTrimCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *string1, *string2; - size_t triml, trimr, length1, length2; + int triml, trimr, length1, length2; if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); } else if (objc == 2) { - string2 = tclDefaultTrimSet; - length2 = strlen(tclDefaultTrimSet); + string2 = " \t\n\r"; + length2 = strlen(string2); } else { Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); return TCL_ERROR; } string1 = TclGetStringFromObj(objv[1], &length1); @@ -3217,24 +3176,23 @@ *---------------------------------------------------------------------- */ static int StringTrimLCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *string1, *string2; - int trim; - size_t length1, length2; + int trim, length1, length2; if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); } else if (objc == 2) { - string2 = tclDefaultTrimSet; - length2 = strlen(tclDefaultTrimSet); + string2 = " \t\n\r"; + length2 = strlen(string2); } else { Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); return TCL_ERROR; } string1 = TclGetStringFromObj(objv[1], &length1); @@ -3264,24 +3222,23 @@ *---------------------------------------------------------------------- */ static int StringTrimRCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *string1, *string2; - int trim; - size_t length1, length2; + int trim, length1, length2; if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); } else if (objc == 2) { - string2 = tclDefaultTrimSet; - length2 = strlen(tclDefaultTrimSet); + string2 = " \t\n\r"; + length2 = strlen(string2); } else { Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); return TCL_ERROR; } string1 = TclGetStringFromObj(objv[1], &length1); @@ -3318,35 +3275,33 @@ Tcl_Command TclInitStringCmd( Tcl_Interp *interp) /* Current interpreter. */ { static const EnsembleImplMap stringImplMap[] = { - {"bytelength", StringBytesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"cat", StringCatCmd, TclCompileStringCatCmd, NULL, NULL, 0}, - {"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL, 0}, - {"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0}, - {"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0}, - {"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0}, - {"insert", StringInsertCmd, TclCompileStringInsertCmd, NULL, NULL, 0}, - {"is", StringIsCmd, TclCompileStringIsCmd, NULL, NULL, 0}, - {"last", StringLastCmd, TclCompileStringLastCmd, NULL, NULL, 0}, - {"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0}, - {"map", StringMapCmd, TclCompileStringMapCmd, NULL, NULL, 0}, - {"match", StringMatchCmd, TclCompileStringMatchCmd, NULL, NULL, 0}, - {"range", StringRangeCmd, TclCompileStringRangeCmd, NULL, NULL, 0}, - {"repeat", StringReptCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"replace", StringRplcCmd, TclCompileStringReplaceCmd, NULL, NULL, 0}, - {"reverse", StringRevCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"tolower", StringLowerCmd, TclCompileStringToLowerCmd, NULL, NULL, 0}, - {"toupper", StringUpperCmd, TclCompileStringToUpperCmd, NULL, NULL, 0}, - {"totitle", StringTitleCmd, TclCompileStringToTitleCmd, NULL, NULL, 0}, - {"trim", StringTrimCmd, TclCompileStringTrimCmd, NULL, NULL, 0}, - {"trimleft", StringTrimLCmd, TclCompileStringTrimLCmd, NULL, NULL, 0}, - {"trimright", StringTrimRCmd, TclCompileStringTrimRCmd, NULL, NULL, 0}, - {"wordend", StringEndCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"wordstart", StringStartCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {NULL, NULL, NULL, NULL, NULL, 0} + {"bytelength", StringBytesCmd, NULL}, + {"compare", StringCmpCmd, TclCompileStringCmpCmd}, + {"equal", StringEqualCmd, TclCompileStringEqualCmd}, + {"first", StringFirstCmd, NULL}, + {"index", StringIndexCmd, TclCompileStringIndexCmd}, + {"is", StringIsCmd, NULL}, + {"last", StringLastCmd, NULL}, + {"length", StringLenCmd, TclCompileStringLenCmd}, + {"map", StringMapCmd, NULL}, + {"match", StringMatchCmd, TclCompileStringMatchCmd}, + {"range", StringRangeCmd, NULL}, + {"repeat", StringReptCmd, NULL}, + {"replace", StringRplcCmd, NULL}, + {"reverse", StringRevCmd, NULL}, + {"tolower", StringLowerCmd, NULL}, + {"toupper", StringUpperCmd, NULL}, + {"totitle", StringTitleCmd, NULL}, + {"trim", StringTrimCmd, NULL}, + {"trimleft", StringTrimLCmd, NULL}, + {"trimright", StringTrimRCmd, NULL}, + {"wordend", StringEndCmd, NULL}, + {"wordstart", StringStartCmd, NULL}, + {NULL, NULL, NULL} }; return TclMakeEnsemble(interp, "string", stringImplMap); } @@ -3367,28 +3322,34 @@ * *---------------------------------------------------------------------- */ int -TclSubstOptions( - Tcl_Interp *interp, - int numOpts, - Tcl_Obj *const opts[], - int *flagPtr) +Tcl_SubstObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - static const char *const substOptions[] = { + static const char *substOptions[] = { "-nobackslashes", "-nocommands", "-novariables", NULL }; - enum { + enum substOptions { SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS }; - int i, flags = TCL_SUBST_ALL; + Tcl_Obj *resultPtr; + int flags, i; - for (i = 0; i < numOpts; i++) { + /* + * Parse command-line options. + */ + + flags = TCL_SUBST_ALL; + for (i = 1; i < (objc-1); i++) { int optionIndex; - if (Tcl_GetIndexFromObj(interp, opts[i], substOptions, "option", 0, + if (Tcl_GetIndexFromObj(interp, objv[i], substOptions, "switch", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } switch (optionIndex) { case SUBST_NOBACKSLASHES: @@ -3402,43 +3363,27 @@ break; default: Tcl_Panic("Tcl_SubstObjCmd: bad option index to SubstOptions"); } } - *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) { + if (i != objc-1) { Tcl_WrongNumArgs(interp, 1, objv, "?-nobackslashes? ?-nocommands? ?-novariables? string"); return TCL_ERROR; } - if (TclSubstOptions(interp, objc-2, objv+1, &flags) != TCL_OK) { + /* + * Perform the substitution. + */ + + resultPtr = Tcl_SubstObj(interp, objv[i], flags); + + if (resultPtr == NULL) { return TCL_ERROR; } - return Tcl_NRSubstObj(interp, objv[objc-1], flags); + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; } /* *---------------------------------------------------------------------- * @@ -3456,28 +3401,18 @@ *---------------------------------------------------------------------- */ int Tcl_SwitchObjCmd( - ClientData clientData, + ClientData dummy, /* Not used. */ 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, index, mode, foundmode, splitObjs, numMatchesSaved; - int noCase; - size_t patternLength, j; - const char *pattern; + int i,j, index, mode, foundmode, result, splitObjs, numMatchesSaved; + int noCase, patternLength; + char *pattern; Tcl_Obj *stringObj, *indexVarObj, *matchVarObj; Tcl_Obj *const *savedObjv = objv; Tcl_RegExp regExpr = NULL; Interp *iPtr = (Interp *) interp; int pc = 0; @@ -3489,20 +3424,20 @@ /* * If you add options that make -e and -g not unique prefixes of -exact or * -glob, you *must* fix TclCompileSwitchCmd's option parser as well. */ - static const char *const options[] = { + static const char *options[] = { "-exact", "-glob", "-indexvar", "-matchvar", "-nocase", "-regexp", "--", NULL }; - enum switchOptionsEnum { + enum options { OPT_EXACT, OPT_GLOB, OPT_INDEXV, OPT_MATCHV, OPT_NOCASE, OPT_REGEXP, OPT_LAST }; typedef int (*strCmpFn_t)(const char *, const char *); - strCmpFn_t strCmpFn = TclUtfCmp; + strCmpFn_t strCmpFn = strcmp; mode = OPT_EXACT; foundmode = 0; indexVarObj = NULL; matchVarObj = NULL; @@ -3514,11 +3449,11 @@ } if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } - switch ((enum switchOptionsEnum) index) { + switch ((enum options) index) { /* * General options. */ case OPT_LAST: @@ -3537,47 +3472,40 @@ if (foundmode) { /* * Mode already set via -exact, -glob, or -regexp. */ - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad option \"%s\": %s option already found", - TclGetString(objv[i]), options[mode])); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", - "DOUBLEOPT", NULL); + Tcl_AppendResult(interp, "bad option \"", + TclGetString(objv[i]), "\": ", options[mode], + " option already found", NULL); return TCL_ERROR; + } else { + foundmode = 1; + mode = index; + break; } - foundmode = 1; - mode = index; - break; /* * Check for TIP#75 options specifying the variables to write * regexp information into. */ case OPT_INDEXV: i++; if (i >= objc-2) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "missing variable name argument to %s option", - "-indexvar")); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", - "NOVAR", NULL); + Tcl_AppendResult(interp, "missing variable name argument to ", + "-indexvar", " option", NULL); return TCL_ERROR; } indexVarObj = objv[i]; numMatchesSaved = -1; break; case OPT_MATCHV: i++; if (i >= objc-2) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "missing variable name argument to %s option", - "-matchvar")); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", - "NOVAR", NULL); + Tcl_AppendResult(interp, "missing variable name argument to ", + "-matchvar", " option", NULL); return TCL_ERROR; } matchVarObj = objv[i]; numMatchesSaved = -1; break; @@ -3585,25 +3513,21 @@ } finishedOptions: if (objc - i < 2) { Tcl_WrongNumArgs(interp, 1, objv, - "?-option ...? string ?pattern body ...? ?default body?"); + "?switches? string pattern body ... ?default body?"); return TCL_ERROR; } if (indexVarObj != NULL && mode != OPT_REGEXP) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s option requires -regexp option", "-indexvar")); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", - "MODERESTRICTION", NULL); + Tcl_AppendResult(interp, + "-indexvar option requires -regexp option", NULL); return TCL_ERROR; } if (matchVarObj != NULL && mode != OPT_REGEXP) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s option requires -regexp option", "-matchvar")); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", - "MODERESTRICTION", NULL); + Tcl_AppendResult(interp, + "-matchvar option requires -regexp option", NULL); return TCL_ERROR; } stringObj = objv[i]; objc -= i + 1; @@ -3620,23 +3544,23 @@ */ splitObjs = 0; if (objc == 1) { Tcl_Obj **listv; - blist = objv[0]; - if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) { + + if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK){ return TCL_ERROR; } /* * Ensure that the list is non-empty. */ if (objc < 1) { Tcl_WrongNumArgs(interp, 1, savedObjv, - "?-option ...? string {?pattern body ...? ?default body?}"); + "?switches? string {pattern body ... ?default body?}"); return TCL_ERROR; } objv = listv; splitObjs = 1; } @@ -3646,14 +3570,11 @@ * bodies. */ if (objc % 2) { Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "extra switch pattern with no body", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM", - NULL); + Tcl_AppendResult(interp, "extra switch pattern with no body", NULL); /* * Check if this can be due to a badly placed comment in the switch * block. * @@ -3662,16 +3583,14 @@ */ if (splitObjs) { for (i=0 ; i 1) { - TclNewIndexObj(rangeObjAry[0], info.matches[j].start); - TclNewIndexObj(rangeObjAry[1], info.matches[j].end-1); + if (info.matches[j].end > 0) { + rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start); + rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end-1); } else { - TclNewIndexObj(rangeObjAry[1], TCL_INDEX_NONE); - rangeObjAry[0] = rangeObjAry[1]; + rangeObjAry[0] = rangeObjAry[1] = Tcl_NewIntObj(-1); } /* * Never fails; the object is always clean at this point. */ @@ -3850,11 +3767,11 @@ * We've got a match. Find a body to execute, skipping bodies that are * "-". */ matchFound: - ctxPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame)); + ctxPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); *ctxPtr = *iPtr->cmdFramePtr; if (splitObjs) { /* * We have to perform the GetSrc and other type dependent handling of @@ -3865,11 +3782,11 @@ */ if (ctxPtr->type == TCL_LOCATION_BC) { /* * Type BC => ctxPtr->data.eval.path is not used. - * ctxPtr->data.tebc.codePtr is used instead. + * ctxPtr->data.tebc.codePtr is used instead. */ TclGetSrcInfoForPc(ctxPtr); pc = 1; @@ -3880,11 +3797,11 @@ } if (ctxPtr->type == TCL_LOCATION_SOURCE && ctxPtr->line[bidx] >= 0) { int bline = ctxPtr->line[bidx]; - ctxPtr->line = (int *)Tcl_Alloc(objc * sizeof(int)); + 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 @@ -3894,20 +3811,20 @@ * which triggers reversion to the old behavior. */ int k; - ctxPtr->line = (int *)Tcl_Alloc(objc * sizeof(int)); + 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 >= (size_t)objc) { + if (j >= objc) { /* * This shouldn't happen since we've checked that the last body is * not a continuation... */ @@ -3920,35 +3837,13 @@ /* * TIP #280: Make invoking context available to switch branch. */ - Tcl_NRAddCallback(interp, SwitchPostProc, INT2PTR(splitObjs), ctxPtr, - INT2PTR(pc), (ClientData) pattern); - return TclNREvalObjEx(interp, objv[j], 0, ctxPtr, splitObjs ? j : bidx+j); -} - -static int -SwitchPostProc( - 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]; - size_t patternLength = strlen(pattern); - - /* - * Clean up TIP 280 context information - */ - + result = TclEvalObjEx(interp, objv[j], 0, ctxPtr, splitObjs ? j : bidx+j); if (splitObjs) { - Tcl_Free(ctxPtr->line); + ckfree((char *) ctxPtr->line); if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) { /* * Death of SrcInfo reference. */ @@ -3959,83 +3854,21 @@ /* * Generate an error message if necessary. */ if (result == TCL_ERROR) { - unsigned limit = 50; + int limit = 50; int overflow = (patternLength > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"%.*s%s\" arm line %d)", - (overflow ? limit : (unsigned)patternLength), pattern, - (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); + (overflow ? limit : patternLength), pattern, + (overflow ? "..." : ""), interp->errorLine)); } TclStackFree(interp, ctxPtr); return result; } - -/* - *---------------------------------------------------------------------- - * - * Tcl_ThrowObjCmd -- - * - * This procedure is invoked to process the "throw" 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_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; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "type message"); - return TCL_ERROR; - } - - /* - * The type must be a list of at least length 1. - */ - - if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { - return TCL_ERROR; - } else if (len < 1) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "type must be non-empty list", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "THROW", "BADEXCEPTION", - NULL); - return TCL_ERROR; - } - - /* - * Now prepare the result options dictionary. We use the list API as it is - * slightly more convenient. - */ - - TclNewLiteralStringObj(options, "-code error -level 0 -errorcode"); - Tcl_ListObjAppendElement(NULL, options, objv[1]); - - /* - * We're ready to go. Fire things into the low-level result machinery. - */ - - Tcl_SetObjResult(interp, objv[2]); - return Tcl_SetReturnOptions(interp, options); -} /* *---------------------------------------------------------------------- * * Tcl_TimeObjCmd -- @@ -4052,18 +3885,18 @@ *---------------------------------------------------------------------- */ int Tcl_TimeObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Obj *objPtr; + register Tcl_Obj *objPtr; Tcl_Obj *objs[4]; - int i, result; + register int i, result; int count; double totalMicroSec; #ifndef TCL_WIDE_CLICKS Tcl_Time start, stop; #else @@ -4088,11 +3921,11 @@ Tcl_GetTime(&start); #else start = TclpGetWideClicks(); #endif while (i-- > 0) { - result = TclEvalObjEx(interp, objPtr, 0, NULL, 0); + result = Tcl_EvalObjEx(interp, objPtr, 0); if (result != TCL_OK) { return result; } } #ifndef TCL_WIDE_CLICKS @@ -4150,44 +3983,43 @@ *---------------------------------------------------------------------- */ int Tcl_TimeRateObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ 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; + register Tcl_Obj *objPtr; + register int result, i; Tcl_Obj *calibrate = NULL, *direct = NULL; - Tcl_WideUInt count = 0; /* Holds repetition count */ + TclWideMUInt count = 0; /* Holds repetition count */ Tcl_WideInt maxms = WIDE_MIN; /* Maximal running time (in milliseconds) */ - Tcl_WideUInt maxcnt = WIDE_MAX; + TclWideMUInt maxcnt = WIDE_MAX; /* Maximal count of iterations. */ - Tcl_WideUInt threshold = 1; /* Current threshold for check time (faster + TclWideMUInt threshold = 1; /* Current threshold for check time (faster * repeat count without time check) */ - Tcl_WideUInt maxIterTm = 1; /* Max time of some iteration as max + 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; + register Tcl_WideInt start, middle, stop; #ifndef TCL_WIDE_CLICKS Tcl_Time now; #endif /* !TCL_WIDE_CLICKS */ static const char *const options[] = { "-direct", "-overhead", "-calibrate", "--", NULL }; - enum timeRateOptionsEnum { + 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; @@ -4197,11 +4029,11 @@ } if (index == TMRT_LAST) { i++; break; } - switch ((enum timeRateOptionsEnum)index) { + switch (index) { case TMRT_EV_DIRECT: direct = objv[i]; break; case TMRT_OVERHEAD: if (++i >= objc - 1) { @@ -4212,12 +4044,10 @@ } break; case TMRT_CALIBRATE: calibrate = objv[i]; break; - case TMRT_LAST: - break; } } if (i >= objc || i < objc - 3) { usage: @@ -4273,11 +4103,11 @@ /* * Self-call with 100 milliseconds to warm-up, before entering the * calibration cycle. */ - TclNewIntObj(clobjv[i], 100); + TclNewLongObj(clobjv[i], 100); Tcl_IncrRefCount(clobjv[i]); result = Tcl_TimeRateObjCmd(NULL, interp, i + 1, clobjv); Tcl_DecrRefCount(clobjv[i]); if (result != TCL_OK) { return result; @@ -4298,11 +4128,11 @@ */ maxms = -1000; do { lastMeasureOverhead = measureOverhead; - TclNewIntObj(clobjv[i], (int) maxms); + TclNewLongObj(clobjv[i], (int) maxms); Tcl_IncrRefCount(clobjv[i]); result = Tcl_TimeRateObjCmd(NULL, interp, i + 1, clobjv); Tcl_DecrRefCount(clobjv[i]); if (result != TCL_OK) { return result; @@ -4328,11 +4158,11 @@ /* * Reset last measurement overhead */ measureOverhead = 0; - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(0)); return TCL_OK; } /* * If time is negative, make current overhead more precise. @@ -4411,19 +4241,17 @@ * 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); + result = TclExecuteByteCode(interp, codePtr); } else { /* eval */ result = TclEvalObjEx(interp, objPtr, 0, NULL, 0); } /* * Allow break and continue from measurement cycle (used for @@ -4488,15 +4316,13 @@ */ threshold = (middle - start) / count; if (threshold > maxIterTm) { maxIterTm = threshold; - /* * Iterations seem to be longer. */ - if (threshold > maxIterTm * 2) { factor *= 2; if (factor > 50) { factor = 50; } @@ -4542,17 +4368,17 @@ } } { Tcl_Obj *objarr[8], **objs = objarr; - Tcl_WideUInt usec, val; + TclWideMUInt usec, val; int digits; /* * Absolute execution time in microseconds or in wide clicks. */ - usec = (Tcl_WideUInt)(middle - start); + usec = (TclWideMUInt)(middle - start); #ifdef TCL_WIDE_CLICKS /* * convert execution time (in wide clicks) to microsecs. */ @@ -4559,12 +4385,11 @@ usec *= TclpWideClickInMicrosec(); #endif /* TCL_WIDE_CLICKS */ if (!count) { /* no iterations - avoid divide by zero */ - TclNewIntObj(objs[4], 0); - objs[0] = objs[2] = objs[4]; + objs[0] = objs[2] = objs[4] = Tcl_NewWideIntObj(0); goto retRes; } /* * If not calibrating... @@ -4578,11 +4403,11 @@ if (overhead > 0) { /* * Estimate the time of overhead (microsecs). */ - Tcl_WideUInt curOverhead = overhead * count; + TclWideMUInt curOverhead = overhead * count; if (usec > curOverhead) { usec -= curOverhead; } else { usec = 0; @@ -4601,11 +4426,11 @@ objs += 2; } val = usec / count; /* microsecs per iteration */ if (val >= 1000000) { - TclNewIntObj(objs[0], val); + objs[0] = Tcl_NewWideIntObj(val); } else { if (val < 10) { digits = 6; } else if (val < 100) { digits = 4; @@ -4617,11 +4442,11 @@ digits = 1; } objs[0] = Tcl_ObjPrintf("%.*f", digits, ((double) usec)/count); } - TclNewIntObj(objs[2], count); /* iterations */ + objs[2] = Tcl_NewWideIntObj(count); /* iterations */ /* * Calculate speed as rate (count) per sec */ @@ -4639,11 +4464,11 @@ digits = 1; } objs[4] = Tcl_ObjPrintf("%.*f", digits, ((double) (count * 1000000)) / usec); } else { - TclNewIntObj(objs[4], val); + objs[4] = Tcl_NewWideIntObj(val); } } else { objs[4] = Tcl_NewWideIntObj((count / usec) * 1000000); } @@ -4654,11 +4479,11 @@ if (!calibrate) { if (usec >= 1) { objs[6] = Tcl_ObjPrintf("%.3f", (double)usec / 1000); } else { - TclNewIntObj(objs[6], 0); + objs[6] = Tcl_NewWideIntObj(0); } TclNewLiteralStringObj(objs[7], "net-ms"); } /* @@ -4674,583 +4499,10 @@ done: if (codePtr != NULL) { TclReleaseByteCode(codePtr); } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_TryObjCmd, TclNRTryObjCmd -- - * - * This procedure is invoked to process the "try" Tcl command. See the - * user documentation (or TIP #329) for details on what it does. - * - * Results: - * A standard Tcl object result. - * - * Side effects: - * 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[] = { - "finally", "on", "trap", NULL - }; - enum Handlers { - TryFinally, TryOn, TryTrap - }; - - /* - * Parse the arguments. The handlers are passed to subsequent callbacks as - * a Tcl_Obj list of the 5-tuples like (type, returnCode, errorCodePrefix, - * bindVariables, script), and the finally script is just passed as it is. - */ - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, - "body ?handler ...? ?finally script?"); - return TCL_ERROR; - } - bodyObj = objv[1]; - handlersObj = Tcl_NewObj(); - bodyShared = 0; - haveHandlers = 0; - for (i=2 ; i objc-4) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "wrong # args to on clause: must be \"... on code" - " variableList script\"", -1)); - Tcl_DecrRefCount(handlersObj); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "ON", - "ARGUMENT", NULL); - return TCL_ERROR; - } - if (TclGetCompletionCodeFromObj(interp, objv[i+1], - &code) != TCL_OK) { - Tcl_DecrRefCount(handlersObj); - return TCL_ERROR; - } - info[2] = NULL; - goto commonHandler; - - case TryTrap: /* trap pattern variableList script */ - if (i > objc-4) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "wrong # args to trap clause: " - "must be \"... trap pattern variableList script\"", - -1)); - Tcl_DecrRefCount(handlersObj); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP", - "ARGUMENT", 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", - TclGetString(objv[i+1]))); - Tcl_DecrRefCount(handlersObj); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP", - "EXNFORMAT", NULL); - return TCL_ERROR; - } - info[2] = objv[i+1]; - - commonHandler: - if (Tcl_ListObjLength(interp, objv[i+2], &dummy) != TCL_OK) { - Tcl_DecrRefCount(handlersObj); - return TCL_ERROR; - } - - info[0] = objv[i]; /* type */ - TclNewIntObj(info[1], code); /* returnCode */ - if (info[2] == NULL) { /* errorCodePrefix */ - TclNewObj(info[2]); - } - info[3] = objv[i+2]; /* bindVariables */ - info[4] = objv[i+3]; /* script */ - - bodyShared = !strcmp(TclGetString(objv[i+3]), "-"); - Tcl_ListObjAppendElement(NULL, handlersObj, - Tcl_NewListObj(5, info)); - haveHandlers = 1; - i += 3; - break; - } - } - if (bodyShared) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "last non-finally clause must not have a body of \"-\"", -1)); - Tcl_DecrRefCount(handlersObj); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "BADFALLTHROUGH", - NULL); - return TCL_ERROR; - } - if (!haveHandlers) { - Tcl_DecrRefCount(handlersObj); - handlersObj = NULL; - } - - /* - * Execute the body. - */ - - Tcl_NRAddCallback(interp, TryPostBody, handlersObj, finallyObj, - (ClientData)objv, INT2PTR(objc)); - return TclNREvalObjEx(interp, bodyObj, 0, - ((Interp *) interp)->cmdFramePtr, 1); -} - -/* - *---------------------------------------------------------------------- - * - * During -- - * - * This helper function patches together the updates to the interpreter's - * return options that are needed when things fail during the processing - * of a handler or finally script for the [try] command. - * - * Returns: - * The new option dictionary. - * - *---------------------------------------------------------------------- - */ - -static inline Tcl_Obj * -During( - Tcl_Interp *interp, - int resultCode, /* The result code from the just-evaluated - * script. */ - Tcl_Obj *oldOptions, /* The old option dictionary. */ - Tcl_Obj *errorInfo) /* An object to append to the errorinfo and - * release, or NULL if nothing is to be added. - * Designed to be used with Tcl_ObjPrintf. */ -{ - Tcl_Obj *during, *options; - - if (errorInfo != NULL) { - Tcl_AppendObjToErrorInfo(interp, errorInfo); - } - options = Tcl_GetReturnOptions(interp, resultCode); - TclNewLiteralStringObj(during, "-during"); - Tcl_IncrRefCount(during); - Tcl_DictObjPut(interp, options, during, oldOptions); - Tcl_DecrRefCount(during); - Tcl_IncrRefCount(options); - Tcl_DecrRefCount(oldOptions); - return options; -} - -/* - *---------------------------------------------------------------------- - * - * TryPostBody -- - * - * Callback to handle the outcome of the execution of the body of a 'try' - * command. - * - *---------------------------------------------------------------------- - */ - -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. - */ - - if (((Interp*) interp)->execEnvPtr->rewind || Tcl_LimitExceeded(interp)) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"%s\" body line %d)", TclGetString(cmdObj), - Tcl_GetErrorLine(interp))); - if (handlersObj != NULL) { - Tcl_DecrRefCount(handlersObj); - } - return TCL_ERROR; - } - - /* - * Basic processing of the outcome of the script, including adding of - * errorinfo trace. - */ - - if (result == TCL_ERROR) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"%s\" body line %d)", TclGetString(cmdObj), - Tcl_GetErrorLine(interp))); - } - resultObj = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(resultObj); - options = Tcl_GetReturnOptions(interp, result); - Tcl_IncrRefCount(options); - Tcl_ResetResult(interp); - - /* - * Handle the results. - */ - - if (handlersObj != NULL) { - int found = 0; - Tcl_Obj **handlers, **info; - - Tcl_ListObjGetElements(NULL, handlersObj, &numHandlers, &handlers); - for (i=0 ; i 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 { - /* - * Dispose of the result to prevent a memleak. [Bug 2910044] - */ - - Tcl_DecrRefCount(resultObj); - } - - /* - * Evaluate the handler body and process the outcome. Note that we - * need to keep the kind of handler for debugging purposes, and in - * any case anything we want from info[] must be extracted right - * now because the info[] array is about to become invalid. There - * is very little refcount handling here however, since we know - * that the objects that we still want to refer to now were input - * arguments to [try] and so are still on the Tcl value stack. - */ - - handlerBodyObj = info[4]; - Tcl_NRAddCallback(interp, TryPostHandler, objv, options, info[0], - INT2PTR((finallyObj == NULL) ? 0 : objc - 1)); - Tcl_DecrRefCount(handlersObj); - return TclNREvalObjEx(interp, handlerBodyObj, 0, - ((Interp *) interp)->cmdFramePtr, 4*i + 5); - - handlerFailed: - resultObj = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(resultObj); - options = During(interp, result, options, NULL); - break; - - didNotMatch: - continue; - } - - /* - * No handler matched; get rid of the list of handlers. - */ - - Tcl_DecrRefCount(handlersObj); - } - - /* - * Process the finally clause. - */ - - if (finallyObj != NULL) { - Tcl_NRAddCallback(interp, TryPostFinal, resultObj, options, cmdObj, - NULL); - return TclNREvalObjEx(interp, finallyObj, 0, - ((Interp *) interp)->cmdFramePtr, objc - 1); - } - - /* - * Install the correct result/options into the interpreter and clean up - * any temporary storage. - */ - - result = Tcl_SetReturnOptions(interp, options); - Tcl_DecrRefCount(options); - Tcl_SetObjResult(interp, resultObj); - Tcl_DecrRefCount(resultObj); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TryPostHandler -- - * - * Callback to handle the outcome of the execution of a handler of a - * 'try' command. - * - *---------------------------------------------------------------------- - */ - -static int -TryPostHandler( - ClientData data[], - 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. - */ - - if (((Interp*) interp)->execEnvPtr->rewind || Tcl_LimitExceeded(interp)) { - options = During(interp, result, options, Tcl_ObjPrintf( - "\n (\"%s ... %s\" handler line %d)", - TclGetString(cmdObj), TclGetString(handlerKindObj), - Tcl_GetErrorLine(interp))); - Tcl_DecrRefCount(options); - return TCL_ERROR; - } - - /* - * The handler result completely substitutes for the result of the body. - */ - - resultObj = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(resultObj); - if (result == TCL_ERROR) { - options = During(interp, result, options, Tcl_ObjPrintf( - "\n (\"%s ... %s\" handler line %d)", - TclGetString(cmdObj), TclGetString(handlerKindObj), - Tcl_GetErrorLine(interp))); - } else { - Tcl_DecrRefCount(options); - options = Tcl_GetReturnOptions(interp, result); - Tcl_IncrRefCount(options); - } - - /* - * Process the finally clause if it is present. - */ - - if (finallyObj != NULL) { - Interp *iPtr = (Interp *) interp; - - Tcl_NRAddCallback(interp, TryPostFinal, resultObj, options, cmdObj, - NULL); - - /* The 'finally' script is always the last argument word. */ - return TclNREvalObjEx(interp, finallyObj, 0, iPtr->cmdFramePtr, - finally); - } - - /* - * Install the correct result/options into the interpreter and clean up - * any temporary storage. - */ - - result = Tcl_SetReturnOptions(interp, options); - Tcl_DecrRefCount(options); - Tcl_SetObjResult(interp, resultObj); - Tcl_DecrRefCount(resultObj); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TryPostFinal -- - * - * Callback to handle the outcome of the execution of the finally script - * of a 'try' command. - * - *---------------------------------------------------------------------- - */ - -static int -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); - resultObj = NULL; - if (result == TCL_ERROR) { - options = During(interp, result, options, Tcl_ObjPrintf( - "\n (\"%s ... finally\" body line %d)", - TclGetString(cmdObj), Tcl_GetErrorLine(interp))); - } else { - Tcl_Obj *origOptions = options; - - options = Tcl_GetReturnOptions(interp, result); - Tcl_IncrRefCount(options); - Tcl_DecrRefCount(origOptions); - } - } - - /* - * Install the correct result/options into the interpreter and clean up - * any temporary storage. - */ - - result = Tcl_SetReturnOptions(interp, options); - Tcl_DecrRefCount(options); - if (resultObj != NULL) { - Tcl_SetObjResult(interp, resultObj); - Tcl_DecrRefCount(resultObj); - } return result; } /* *---------------------------------------------------------------------- @@ -5273,46 +4525,49 @@ *---------------------------------------------------------------------- */ int Tcl_WhileObjCmd( - ClientData clientData, + ClientData dummy, /* Not used. */ 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; + int result, value; + Interp *iPtr = (Interp *) interp; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "test command"); return TCL_ERROR; } - /* - * We reuse [for]'s callback, passing a NULL for the 'next' script. - */ - - TclSmallAllocEx(interp, sizeof(ForIterData), iterPtr); - iterPtr->cond = objv[1]; - iterPtr->body = objv[2]; - iterPtr->next = NULL; - iterPtr->msg = "\n (\"while\" body line %d)"; - iterPtr->word = 2; - - TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, - NULL, NULL); - return TCL_OK; + while (1) { + result = Tcl_ExprBooleanObj(interp, objv[1], &value); + if (result != TCL_OK) { + return result; + } + if (!value) { + break; + } + + /* TIP #280. */ + result = TclEvalObjEx(interp, objv[2], 0, iPtr->cmdFramePtr, 2); + if ((result != TCL_OK) && (result != TCL_CONTINUE)) { + if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"while\" body line %d)", interp->errorLine)); + } + break; + } + } + if (result == TCL_BREAK) { + result = TCL_OK; + } + if (result == TCL_OK) { + Tcl_ResetResult(interp); + } + return result; } /* *---------------------------------------------------------------------- * @@ -5329,34 +4584,36 @@ *---------------------------------------------------------------------- */ void TclListLines( - Tcl_Obj *listObj, /* Pointer to obj holding a string with list - * structure. Assumed to be valid. Assumed to - * contain n elements. */ + Tcl_Obj* listObj, /* Pointer to obj holding a string with list + * structure. Assumed to be valid. Assumed to + * 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 + Tcl_Obj* const* elems) /* The list elems as Tcl_Obj*, in need of * derived continuation data */ { - const char *listStr = TclGetString(listObj); - const char *listHead = listStr; + 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); + ContLineLoc* clLocPtr = TclContinuationsGet(listObj); + int* clNext = (clLocPtr ? &clLocPtr->loc[0] : NULL); for (i = 0; i < n; i++) { TclFindElement(NULL, listStr, length, &element, &next, NULL, NULL); TclAdvanceLines(&line, listStr, element); /* Leading whitespace */ - TclAdvanceContinuations(&line, &clNext, element - listHead); + TclAdvanceContinuations (&line, &clNext, element - listHead); if (elems && clNext) { - TclContinuationsEnterDerived(elems[i], element-listHead, clNext); + TclContinuationsEnterDerived (elems[i], element - listHead, + clNext); } lines[i] = line; length -= (next - listStr); TclAdvanceLines(&line, element, next); /* Element */ Index: generic/tclCompCmds.c ================================================================== --- generic/tclCompCmds.c +++ generic/tclCompCmds.c @@ -5,112 +5,227 @@ * commands into a sequence of instructions ("bytecodes"). * * Copyright (c) 1997-1998 Sun Microsystems, Inc. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2002 ActiveState Corporation. - * Copyright (c) 2004-2013 by Donal K. Fellows. + * Copyright (c) 2004-2006 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 "tclCompile.h" -#include + +/* + * Macro that encapsulates an efficiency trick that avoids a function call for + * the simplest of compiles. The ANSI C "prototype" for this macro is: + * + * static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr, + * Tcl_Interp *interp, int word); + */ + +#define CompileWord(envPtr, tokenPtr, interp, word) \ + if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \ + TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \ + (tokenPtr)[1].size), (envPtr)); \ + } else { \ + envPtr->line = mapPtr->loc[eclIndex].line[word]; \ + envPtr->clNext = mapPtr->loc[eclIndex].next[word]; \ + TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ + (envPtr)); \ + } + +/* + * TIP #280: Remember the per-word line information of the current command. An + * index is used instead of a pointer as recursive compilation may reallocate, + * i.e. move, the array. This is also the reason to save the nuloc now, it may + * change during the course of the function. + * + * Macro to encapsulate the variable definition and setup. + */ + +#define DefineLineInformation \ + ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ + int eclIndex = mapPtr->nuloc - 1 + +#define SetLineInformation(word) \ + envPtr->line = mapPtr->loc [eclIndex].line [(word)]; \ + envPtr->clNext = mapPtr->loc [eclIndex].next [(word)] + +/* + * Convenience macro for use when compiling bodies of commands. The ANSI C + * "prototype" for this macro is: + * + * static void CompileBody(CompileEnv *envPtr, Tcl_Token *tokenPtr, + * Tcl_Interp *interp); + */ + +#define CompileBody(envPtr, tokenPtr, interp) \ + TclCompileCmdWord((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ + (envPtr)) + +/* + * Convenience macro for use when compiling tokens to be pushed. The ANSI C + * "prototype" for this macro is: + * + * static void CompileTokens(CompileEnv *envPtr, Tcl_Token *tokenPtr, + * Tcl_Interp *interp); + */ + +#define CompileTokens(envPtr, tokenPtr, interp) \ + TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ + (envPtr)); +/* + * Convenience macro for use when pushing literals. The ANSI C "prototype" for + * this macro is: + * + * static void PushLiteral(CompileEnv *envPtr, + * const char *string, int length); + */ + +#define PushLiteral(envPtr, string, length) \ + TclEmitPush(TclRegisterNewLiteral((envPtr), (string), (length)), (envPtr)) + +/* + * 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 + * maximal depth of nested CATCH ranges in order to alloc runtime + * memory. These macros should compute precisely that? OTOH, the nesting depth + * of LOOP ranges is an interesting datum for debugging purposes, and that is + * what we compute now. + * + * static int DeclareExceptionRange(CompileEnv *envPtr, int type); + * static int ExceptionRangeStarts(CompileEnv *envPtr, int index); + * static void ExceptionRangeEnds(CompileEnv *envPtr, int index); + * static void ExceptionRangeTarget(CompileEnv *envPtr, int index, LABEL); + */ + +#define DeclareExceptionRange(envPtr, type) \ + (TclCreateExceptRange((type), (envPtr))) +#define ExceptionRangeStarts(envPtr, index) \ + (((envPtr)->exceptDepth++), \ + ((envPtr)->maxExceptDepth = \ + TclMax((envPtr)->exceptDepth, (envPtr)->maxExceptDepth)), \ + ((envPtr)->exceptArrayPtr[(index)].codeOffset = CurrentOffset(envPtr))) +#define ExceptionRangeEnds(envPtr, index) \ + (((envPtr)->exceptDepth--), \ + ((envPtr)->exceptArrayPtr[(index)].numCodeBytes = \ + CurrentOffset(envPtr) - (envPtr)->exceptArrayPtr[(index)].codeOffset)) +#define ExceptionRangeTarget(envPtr, index, targetType) \ + ((envPtr)->exceptArrayPtr[(index)].targetType = CurrentOffset(envPtr)) /* * 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); +static ClientData DupDictUpdateInfo(ClientData clientData); +static void FreeDictUpdateInfo(ClientData clientData); +static void PrintDictUpdateInfo(ClientData clientData, + Tcl_Obj *appendObj, ByteCode *codePtr, + unsigned int pcOffset); +static ClientData DupForeachInfo(ClientData clientData); +static void FreeForeachInfo(ClientData clientData); +static void PrintForeachInfo(ClientData clientData, + Tcl_Obj *appendObj, ByteCode *codePtr, + unsigned int pcOffset); +static ClientData DupJumptableInfo(ClientData clientData); +static void FreeJumptableInfo(ClientData clientData); +static void PrintJumptableInfo(ClientData clientData, + Tcl_Obj *appendObj, ByteCode *codePtr, + unsigned int pcOffset); +static int LocalScalarFromToken(Tcl_Token *tokenPtr, + CompileEnv *envPtr); +static int LocalScalar(const char *bytes, int numBytes, + CompileEnv *envPtr); +static int PushVarName(Tcl_Interp *interp, + Tcl_Token *varTokenPtr, CompileEnv *envPtr, + int flags, int *localIndexPtr, + int *simpleVarNamePtr, int *isScalarPtr, + int line, int* clNext); +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 CompileReturnInternal(CompileEnv *envPtr, + unsigned char op, int code, int level, + Tcl_Obj *returnOpts); + +#define PushVarNameWord(i,v,e,f,l,s,sc,word) \ + PushVarName (i,v,e,f,l,s,sc, \ + mapPtr->loc [eclIndex].line [(word)], \ + mapPtr->loc [eclIndex].next [(word)]) + +/* + * Flags bits used by PushVarName. + */ + +#define TCL_CREATE_VAR 1 /* Create a compiled local if none is found */ +#define TCL_NO_LARGE_INDEX 2 /* Do not return localIndex value > 255 */ /* * The structures below define the AuxData types defined in this file. */ -static const AuxDataType foreachInfoType = { +AuxDataType tclForeachInfoType = { "ForeachInfo", /* name */ DupForeachInfo, /* dupProc */ FreeForeachInfo, /* freeProc */ - PrintForeachInfo, /* printProc */ - DisassembleForeachInfo /* disassembleProc */ + PrintForeachInfo /* printProc */ }; -static const AuxDataType newForeachInfoType = { - "NewForeachInfo", /* name */ - DupForeachInfo, /* dupProc */ - FreeForeachInfo, /* freeProc */ - PrintNewForeachInfo, /* printProc */ - DisassembleNewForeachInfo /* disassembleProc */ +AuxDataType tclJumptableInfoType = { + "JumptableInfo", /* name */ + DupJumptableInfo, /* dupProc */ + FreeJumptableInfo, /* freeProc */ + PrintJumptableInfo /* printProc */ }; -static const AuxDataType dictUpdateInfoType = { +AuxDataType tclDictUpdateInfoType = { "DictUpdateInfo", /* name */ DupDictUpdateInfo, /* dupProc */ FreeDictUpdateInfo, /* freeProc */ - PrintDictUpdateInfo, /* printProc */ - DisassembleDictUpdateInfo /* disassembleProc */ + PrintDictUpdateInfo /* printProc */ }; - -/* - *---------------------------------------------------------------------- - * - * TclGetAuxDataType -- - * - * This procedure looks up an Auxdata type by name. - * - * Results: - * If an AuxData type with name matching "typeName" is found, a pointer - * to its AuxDataType structure is returned; otherwise, NULL is returned. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -const AuxDataType * -TclGetAuxDataType( - const char *typeName) /* Name of AuxData type to look up. */ -{ - if (!strcmp(typeName, foreachInfoType.name)) { - return &foreachInfoType; - } else if (!strcmp(typeName, newForeachInfoType.name)) { - return &newForeachInfoType; - } else if (!strcmp(typeName, dictUpdateInfoType.name)) { - return &dictUpdateInfoType; - } else if (!strcmp(typeName, tclJumptableInfoType.name)) { - return &tclJumptableInfoType; - } - return NULL; -} /* *---------------------------------------------------------------------- * * TclCompileAppendCmd -- * * Procedure called to compile the "append" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "append" command at * runtime. * @@ -124,15 +239,14 @@ * 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; + int simpleVarName, isScalar, localIndex, numWords; + DefineLineInformation; /* TIP #280 */ - /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; if (numWords == 1) { return TCL_ERROR; } else if (numWords == 2) { /* @@ -140,15 +254,14 @@ */ return TclCompileSetCmd(interp, parsePtr, cmdPtr, envPtr); } else if (numWords > 3) { /* - * APPEND instructions currently only handle one value, but we can - * handle some multi-value cases by stringing them together. + * APPEND instructions currently only handle one value. */ - goto appendMultiple; + return TCL_ERROR; } /* * Decide if we can use a frame slot for the var/array name or if we need * to emit code to compute and push the name at runtime. We use a frame @@ -157,337 +270,50 @@ * qualifiers. */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &isScalar, 1); + PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, + &localIndex, &simpleVarName, &isScalar, 1); /* * We are doing an assignment, otherwise TclCompileSetCmd was called, so * push the new value. This will need to be extended to push a value for * each argument. */ + if (numWords > 2) { valueTokenPtr = TokenAfter(varTokenPtr); CompileWord(envPtr, valueTokenPtr, interp, 2); + } /* * Emit instructions to set/get the variable. */ + if (simpleVarName) { if (isScalar) { if (localIndex < 0) { TclEmitOpcode(INST_APPEND_STK, envPtr); + } else if (localIndex <= 255) { + TclEmitInstInt1(INST_APPEND_SCALAR1, localIndex, envPtr); } else { - Emit14Inst(INST_APPEND_SCALAR, localIndex, envPtr); + TclEmitInstInt4(INST_APPEND_SCALAR4, localIndex, envPtr); } } else { if (localIndex < 0) { TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr); - } else { - Emit14Inst(INST_APPEND_ARRAY, localIndex, envPtr); - } - } - - return TCL_OK; - - appendMultiple: - /* - * Can only handle the case where we are appending to a local scalar when - * there are multiple values to append. Fortunately, this is common. - */ - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - - localIndex = LocalScalarFromToken(varTokenPtr, envPtr); - if (localIndex < 0) { - return TCL_ERROR; - } - - /* - * Definitely appending to a local scalar; generate the words and append - * them. - */ - - valueTokenPtr = TokenAfter(varTokenPtr); - for (i = 2 ; i < numWords ; i++) { - CompileWord(envPtr, valueTokenPtr, interp, i); - valueTokenPtr = TokenAfter(valueTokenPtr); - } - TclEmitInstInt4( INST_REVERSE, numWords-2, envPtr); - for (i = 2 ; i < numWords ;) { - Emit14Inst( INST_APPEND_SCALAR, localIndex, envPtr); - if (++i < numWords) { - TclEmitOpcode(INST_POP, envPtr); - } - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileArray*Cmd -- - * - * Functions called to compile "array" sucommands. - * - * Results: - * All return TCL_OK for a successful compile, and TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "array" subcommand at - * runtime. - * - *---------------------------------------------------------------------- - */ - -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) { - return TCL_ERROR; - } - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT, - &localIndex, &isScalar, 1); - if (!isScalar) { - return TCL_ERROR; - } - - if (localIndex >= 0) { - TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - } else { - TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); - } - return TCL_OK; -} - -int -TclCompileArraySetCmd( - 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 *varTokenPtr, *dataTokenPtr; - int isScalar, localIndex, code = TCL_OK; - int isDataLiteral, isDataValid, isDataEven, len; - int keyVar, valVar, infoIndex; - int fwd, offsetBack, offsetFwd; - Tcl_Obj *literalObj; - ForeachInfo *infoPtr; - - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - dataTokenPtr = TokenAfter(varTokenPtr); - TclNewObj(literalObj); - isDataLiteral = TclWordKnownAtCompileTime(dataTokenPtr, literalObj); - isDataValid = (isDataLiteral - && Tcl_ListObjLength(NULL, literalObj, &len) == TCL_OK); - isDataEven = (isDataValid && (len & 1) == 0); - - /* - * Special case: literal odd-length argument is always an error. - */ - - if (isDataValid && !isDataEven) { - /* Abandon custom compile and let invocation raise the error */ - code = TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); - goto done; - - /* - * We used to compile to the bytecode that would throw the error, - * but that was wrong because it would not invoke the array trace - * on the variable. - * - PushStringLiteral(envPtr, "list must have an even number of elements"); - PushStringLiteral(envPtr, "-errorcode {TCL ARGUMENT FORMAT}"); - TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr); - TclEmitInt4( 0, envPtr); - goto done; - * - */ - } - - /* - * Except for the special "ensure array" case below, when we're not in - * a proc, we cannot do a better compile than generic. - */ - - if ((varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) || - (envPtr->procPtr == NULL && !(isDataEven && len == 0))) { - code = TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); - goto done; - } - - PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT, - &localIndex, &isScalar, 1); - if (!isScalar) { - code = TCL_ERROR; - goto done; - } - - /* - * Special case: literal empty value argument is just an "ensure array" - * operation. - */ - - if (isDataEven && len == 0) { - if (localIndex >= 0) { - TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); - TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); - } else { - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); - TclEmitInstInt1(INST_JUMP_TRUE1, 5, envPtr); - TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr); - TclEmitInstInt1(INST_JUMP1, 3, envPtr); - /* Each branch decrements stack depth, but we only take one. */ - TclAdjustStackDepth(1, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - PushStringLiteral(envPtr, ""); - goto done; - } - - if (localIndex < 0) { - /* - * a non-local variable: upvar from a local one! This consumes the - * variable name that was left at stacktop. - */ - - localIndex = TclFindCompiledLocal(varTokenPtr->start, - varTokenPtr->size, 1, envPtr); - PushStringLiteral(envPtr, "0"); - TclEmitInstInt4(INST_REVERSE, 2, envPtr); - TclEmitInstInt4(INST_UPVAR, localIndex, envPtr); - TclEmitOpcode(INST_POP, envPtr); - } - - /* - * Prepare for the internal foreach. - */ - - keyVar = AnonymousLocal(envPtr); - valVar = AnonymousLocal(envPtr); - - infoPtr = (ForeachInfo *)Tcl_Alloc(offsetof(ForeachInfo, varLists) + sizeof(ForeachVarList *)); - infoPtr->numLists = 1; - infoPtr->varLists[0] = (ForeachVarList *)Tcl_Alloc(offsetof(ForeachVarList, varIndexes) + 2 * sizeof(int)); - infoPtr->varLists[0]->numVars = 2; - infoPtr->varLists[0]->varIndexes[0] = keyVar; - infoPtr->varLists[0]->varIndexes[1] = valVar; - infoIndex = TclCreateAuxData(infoPtr, &newForeachInfoType, envPtr); - - /* - * Start issuing instructions to write to the array. - */ - - TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); - TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); - - CompileWord(envPtr, dataTokenPtr, interp, 2); - if (!isDataLiteral || !isDataValid) { - /* - * Only need this safety check if we're handling a non-literal or list - * containing an invalid literal; with valid list literals, we've - * already checked (worth it because literals are a very common - * use-case with [array set]). - */ - - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_LIST_LENGTH, envPtr); - PushStringLiteral(envPtr, "1"); - TclEmitOpcode( INST_BITAND, envPtr); - offsetFwd = CurrentOffset(envPtr); - TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); - PushStringLiteral(envPtr, "list must have an even number of elements"); - PushStringLiteral(envPtr, "-errorcode {TCL ARGUMENT FORMAT}"); - TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr); - TclEmitInt4( 0, envPtr); - TclAdjustStackDepth(-1, envPtr); - fwd = CurrentOffset(envPtr) - offsetFwd; - TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); - } - - TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr); - offsetBack = CurrentOffset(envPtr); - Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr); - Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr); - Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - infoPtr->loopCtTemp = offsetBack - CurrentOffset(envPtr); /*misuse */ - TclEmitOpcode( INST_FOREACH_STEP, envPtr); - TclEmitOpcode( INST_FOREACH_END, envPtr); - TclAdjustStackDepth(-3, envPtr); - PushStringLiteral(envPtr, ""); - - done: - Tcl_DecrRefCount(literalObj); - return code; -} - -int -TclCompileArrayUnsetCmd( - 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 = TokenAfter(parsePtr->tokenPtr); - int isScalar, localIndex; - - if (parsePtr->numWords != 2) { - return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - - PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT, - &localIndex, &isScalar, 1); - if (!isScalar) { - return TCL_ERROR; - } - - if (localIndex >= 0) { - TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - TclEmitInstInt1(INST_JUMP_FALSE1, 8, envPtr); - TclEmitInstInt1(INST_UNSET_SCALAR, 1, envPtr); - TclEmitInt4( localIndex, envPtr); - } else { - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); - TclEmitInstInt1(INST_JUMP_FALSE1, 6, envPtr); - TclEmitInstInt1(INST_UNSET_STK, 1, envPtr); - TclEmitInstInt1(INST_JUMP1, 3, envPtr); - /* Each branch decrements stack depth, but we only take one. */ - TclAdjustStackDepth(1, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - PushStringLiteral(envPtr, ""); + } else if (localIndex <= 255) { + TclEmitInstInt1(INST_APPEND_ARRAY1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_APPEND_ARRAY4, localIndex, envPtr); + } + } + } else { + TclEmitOpcode(INST_APPEND_STK, envPtr); + } + return TCL_OK; } /* *---------------------------------------------------------------------- @@ -495,12 +321,12 @@ * TclCompileBreakCmd -- * * Procedure called to compile the "break" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "break" command at * runtime. * @@ -507,44 +333,26 @@ *---------------------------------------------------------------------- */ int TclCompileBreakCmd( - TCL_UNUSED(Tcl_Interp *), + 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 *), + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - ExceptionRange *rangePtr; - ExceptionAux *auxPtr; - if (parsePtr->numWords != 1) { return TCL_ERROR; } /* - * Find the innermost exception range that contains this command. - */ - - rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_BREAK, &auxPtr); - if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) { - /* - * Found the target! No need for a nasty INST_BREAK here. - */ - - TclCleanupStackForBreakContinue(envPtr, auxPtr); - TclAddLoopBreakFixup(envPtr, auxPtr); - } else { - /* - * Emit a real break. - */ - - TclEmitOpcode(INST_BREAK, envPtr); - } - TclAdjustStackDepth(1, envPtr); - + * Emit a break instruction. + */ + + TclEmitOpcode(INST_BREAK, envPtr); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -567,18 +375,20 @@ 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 *), + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ 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); + int resultIndex, optsIndex, range; + int initStackDepth = envPtr->currStackDepth; + int savedStackDepth; + DefineLineInformation; /* TIP #280 */ /* * If syntax does not match what we expect for [catch], do not compile. * Let runtime checks determine if syntax has changed. */ @@ -585,35 +395,24 @@ if ((parsePtr->numWords < 2) || (parsePtr->numWords > 4)) { return TCL_ERROR; } - /* - * If variables were specified and the catch command is at global level - * (not in a procedure), don't compile it inline: the payoff is too small. - */ - - if ((parsePtr->numWords >= 3) && !EnvHasLVT(envPtr)) { - return TCL_ERROR; - } - /* * Make sure the variable names, if any, have no substitutions and just * refer to local scalars. */ resultIndex = optsIndex = -1; cmdTokenPtr = TokenAfter(parsePtr->tokenPtr); if (parsePtr->numWords >= 3) { resultNameTokenPtr = TokenAfter(cmdTokenPtr); - /* DGP */ resultIndex = LocalScalarFromToken(resultNameTokenPtr, envPtr); if (resultIndex < 0) { return TCL_ERROR; } - /* DKF */ if (parsePtr->numWords == 4) { optsNameTokenPtr = TokenAfter(resultNameTokenPtr); optsIndex = LocalScalarFromToken(optsNameTokenPtr, envPtr); if (optsIndex < 0) { return TCL_ERROR; @@ -620,301 +419,152 @@ } } } /* - * We will compile the catch command. Declare the exception range that it - * uses. - * + * We will compile the catch command. Declare the exception range + * that it uses. + */ + + range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + + /* * If the body is a simple word, compile a BEGIN_CATCH instruction, * followed by the instructions to eval the body. * Otherwise, compile instructions to substitute the body text before - * starting the catch, then BEGIN_CATCH, and then EVAL_STK to evaluate the - * substituted body. - * Care has to be taken to make sure that substitution happens outside the - * catch range so that errors in the substitution are not caught. + * starting the catch, then BEGIN_CATCH, and then EVAL_STK to + * evaluate the substituted body. + * Care has to be taken to make sure that substitution happens outside + * the catch range so that errors in the substitution are not caught. * [Bug 219184] * The reason for duplicating the script is that EVAL_STK would otherwise * begin by undeflowing the stack below the mark set by BEGIN_CATCH4. */ - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); - ExceptionRangeStarts(envPtr, range); - BODY(cmdTokenPtr, 1); - } else { - SetLineInformation(1); - CompileTokens(envPtr, cmdTokenPtr, interp); - TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); - ExceptionRangeStarts(envPtr, range); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitInvoke(envPtr, INST_EVAL_STK); - /* drop the script */ - dropScript = 1; - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - ExceptionRangeEnds(envPtr, range); - - - /* - * Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch result, - * and jump around the "error case" code. - */ - - TclCheckStackDepth(depth+1, envPtr); - PushStringLiteral(envPtr, "0"); + SetLineInformation(1); + if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + savedStackDepth = envPtr->currStackDepth; + TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr); + ExceptionRangeStarts(envPtr, range); + CompileBody(envPtr, cmdTokenPtr, interp); + } else { + CompileTokens(envPtr, cmdTokenPtr, interp); + savedStackDepth = envPtr->currStackDepth; + TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr); + ExceptionRangeStarts(envPtr, range); + TclEmitOpcode(INST_DUP, envPtr); + TclEmitOpcode(INST_EVAL_STK, envPtr); + } + /* Stack at this point: + * nonsimple: script result + * simple: result + */ + + /* + * Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch + * result, and jump around the "error case" code. + */ + + PushLiteral(envPtr, "0", 1); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + /* Stack at this point: ?script? result TCL_OK */ /* - * Emit the "error case" epilogue. Push the interpreter result and the - * return code. + * Emit the "error case" epilogue. Push the interpreter result + * and the return code. */ + envPtr->currStackDepth = savedStackDepth; ExceptionRangeTarget(envPtr, range, catchOffset); - TclSetStackDepth(depth + dropScript, envPtr); - - if (dropScript) { - TclEmitOpcode( INST_POP, envPtr); - } - - - /* Stack at this point is empty */ - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); - - /* Stack at this point on both branches: result returnCode */ - + /* Stack at this point: ?script? */ + TclEmitOpcode(INST_PUSH_RESULT, envPtr); + TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr); + + /* + * Update the target of the jump after the "no errors" code. + */ + + /* Stack at this point: ?script? result returnCode */ if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { - Tcl_Panic("TclCompileCatchCmd: bad jump distance %" TCL_Z_MODIFIER "d", - (CurrentOffset(envPtr) - jumpFixup.codeOffset)); + 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 - */ + /* Push the return options if the caller wants them */ if (optsIndex != -1) { - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); + TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr); } /* * End the catch */ - TclEmitOpcode( INST_END_CATCH, envPtr); - - /* - * Save the result and return options if the caller wants them. This needs - * to happen after INST_END_CATCH (compile-3.6/7). - */ - - if (optsIndex != -1) { - Emit14Inst( INST_STORE_SCALAR, optsIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } + ExceptionRangeEnds(envPtr, range); + TclEmitOpcode(INST_END_CATCH, envPtr); /* * At this point, the top of the stack is inconveniently ordered: - * result returnCode - * Reverse the stack to store the result. + * ?script? result returnCode ?returnOptions? + * Reverse the stack to bring the result to the top. */ - TclEmitInstInt4( INST_REVERSE, 2, envPtr); + if (optsIndex != -1) { + TclEmitInstInt4(INST_REVERSE, 3, envPtr); + } else { + TclEmitInstInt4(INST_REVERSE, 2, envPtr); + } + + /* + * Store the result if requested, and remove it from the stack + */ + if (resultIndex != -1) { - Emit14Inst( INST_STORE_SCALAR, resultIndex, envPtr); - } - TclEmitOpcode( INST_POP, envPtr); - - TclCheckStackDepth(depth+1, envPtr); - return TCL_OK; -} - -/*---------------------------------------------------------------------- - * - * TclCompileClockClicksCmd -- - * - * Procedure called to compile the "tcl::clock::clicks" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to run time. - * - * Side effects: - * Instructions are added to envPtr to execute the "clock clicks" - * 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: - /* - * No args - */ - TclEmitInstInt1(INST_CLOCK_READ, 0, envPtr); - break; - case 2: - /* - * -milliseconds or -microseconds - */ - tokenPtr = TokenAfter(parsePtr->tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD - || tokenPtr[1].size < 4 - || tokenPtr[1].size > 13) { - return TCL_ERROR; - } else if (!strncmp(tokenPtr[1].start, "-microseconds", - tokenPtr[1].size)) { - TclEmitInstInt1(INST_CLOCK_READ, 1, envPtr); - break; - } else if (!strncmp(tokenPtr[1].start, "-milliseconds", - tokenPtr[1].size)) { - TclEmitInstInt1(INST_CLOCK_READ, 2, envPtr); - break; + if (resultIndex <= 255) { + TclEmitInstInt1(INST_STORE_SCALAR1, resultIndex, envPtr); + } else { + TclEmitInstInt4(INST_STORE_SCALAR4, resultIndex, envPtr); + } + } + TclEmitOpcode(INST_POP, envPtr); + + /* + * Stack is now ?script? ?returnOptions? returnCode. + * If the options dict has been requested, it is buried on the stack + * under the return code. Reverse the stack to bring it to the top, + * store it and remove it from the stack. + */ + + if (optsIndex != -1) { + TclEmitInstInt4(INST_REVERSE, 2, envPtr); + if (optsIndex <= 255) { + TclEmitInstInt1(INST_STORE_SCALAR1, optsIndex, envPtr); } else { - return TCL_ERROR; - } - default: - return TCL_ERROR; - } - return TCL_OK; -} - - -/*---------------------------------------------------------------------- - * - * TclCompileClockReadingCmd -- - * - * Procedure called to compile the "tcl::clock::microseconds", - * "tcl::clock::milliseconds" and "tcl::clock::seconds" commands. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to run time. - * - * Side effects: - * Instructions are added to envPtr to execute the "clock clicks" - * command at runtime. - * - * 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) { - return TCL_ERROR; - } - - TclEmitInstInt1(INST_CLOCK_READ, PTR2INT(cmdPtr->objClientData), envPtr); - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileConcatCmd -- - * - * Procedure called to compile the "concat" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "concat" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -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; - - /* TODO: Consider compiling expansion case. */ - if (parsePtr->numWords == 1) { - /* - * [concat] without arguments just pushes an empty object. - */ - - PushStringLiteral(envPtr, ""); - return TCL_OK; - } - - /* - * Test if all arguments are compile-time known. If they are, we can - * implement with a simple push. - */ - - TclNewObj(listObj); - for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) { - tokenPtr = TokenAfter(tokenPtr); - TclNewObj(objPtr); - if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(listObj); - listObj = NULL; - break; - } - (void) Tcl_ListObjAppendElement(NULL, listObj, objPtr); - } - if (listObj != NULL) { - Tcl_Obj **objs; - const char *bytes; - int len; - size_t slen; - - Tcl_ListObjGetElements(NULL, listObj, &len, &objs); - objPtr = Tcl_ConcatObj(len, objs); - Tcl_DecrRefCount(listObj); - bytes = TclGetStringFromObj(objPtr, &slen); - PushLiteral(envPtr, bytes, slen); - Tcl_DecrRefCount(objPtr); - return TCL_OK; - } - - /* - * General case: runtime concat. - */ - - for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, i); - } - - TclEmitInstInt4( INST_CONCAT_STK, i-1, envPtr); - + TclEmitInstInt4(INST_STORE_SCALAR4, optsIndex, envPtr); + } + TclEmitOpcode(INST_POP, envPtr); + } + + /* + * Stack is now ?script? result. Get rid of the subst'ed script + * if it's hanging arond. + */ + + if (cmdTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + TclEmitInstInt4(INST_REVERSE, 2, envPtr); + TclEmitOpcode(INST_POP, envPtr); + } + + /* + * Result of all this, on either branch, should have been to leave + * one operand -- the return code -- on the stack. + */ + + if (envPtr->currStackDepth != initStackDepth + 1) { + Tcl_Panic("in TclCompileCatchCmd, currStackDepth = %d should be %d", + envPtr->currStackDepth, initStackDepth+1); + } return TCL_OK; } /* *---------------------------------------------------------------------- @@ -922,12 +572,12 @@ * TclCompileContinueCmd -- * * Procedure called to compile the "continue" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "continue" command at * runtime. * @@ -934,49 +584,30 @@ *---------------------------------------------------------------------- */ int TclCompileContinueCmd( - TCL_UNUSED(Tcl_Interp *), + 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 *), + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - ExceptionRange *rangePtr; - ExceptionAux *auxPtr; - /* * There should be no argument after the "continue". */ if (parsePtr->numWords != 1) { return TCL_ERROR; } /* - * See if we can find a valid continueOffset (i.e., not -1) in the - * innermost containing exception range. - */ - - rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE, &auxPtr); - if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) { - /* - * Found the target! No need for a nasty INST_CONTINUE here. - */ - - TclCleanupStackForBreakContinue(envPtr, auxPtr); - TclAddLoopContinueFixup(envPtr, auxPtr); - } else { - /* - * Emit a real continue. - */ - - TclEmitOpcode(INST_CONTINUE, envPtr); - } - TclAdjustStackDepth(1, envPtr); - + * Emit a continue instruction. + */ + + TclEmitOpcode(INST_CONTINUE, envPtr); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -984,35 +615,54 @@ * TclCompileDict*Cmd -- * * Functions called to compile "dict" sucommands. * * Results: - * All return TCL_OK for a successful compile, and TCL_ERROR to defer - * evaluation to runtime. + * All return TCL_OK for a successful compile, and TCL_ERROR to defer + * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "dict" subcommand at * runtime. + * + * Notes: + * The following commands are in fairly common use and are possibly worth + * bytecoding: + * dict append + * dict create [*] + * dict exists [*] + * dict for + * dict get [*] + * dict incr + * dict keys [*] + * dict lappend + * dict set + * dict unset + * + * In practice, those that are pure-value operators (marked with [*]) can + * probably be left alone (except perhaps [dict get] which is very very + * common) and [dict update] should be considered instead (really big + * win!) * *---------------------------------------------------------------------- */ 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 *), + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr; + Tcl_Token *tokenPtr, *varTokenPtr; int i, dictVarIndex; - Tcl_Token *varTokenPtr; + DefineLineInformation; /* TIP #280 */ /* - * There must be at least one argument after the command. + * There must be at least three arguments after the (sub-)command. */ if (parsePtr->numWords < 4) { return TCL_ERROR; } @@ -1043,11 +693,10 @@ * Now emit the instruction to do the dict manipulation. */ TclEmitInstInt4( INST_DICT_SET, parsePtr->numWords-3, envPtr); TclEmitInt4( dictVarIndex, envPtr); - TclAdjustStackDepth(-1, envPtr); return TCL_OK; } int TclCompileDictIncrCmd( @@ -1056,64 +705,53 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *keyTokenPtr; int dictVarIndex, incrAmount; + DefineLineInformation; /* TIP #280 */ /* * There must be at least two arguments after the command. */ if (parsePtr->numWords < 3 || parsePtr->numWords > 4) { return TCL_ERROR; } + + /* + * The dictionary variable must be a local scalar that is knowable at + * compile time; anything else exceeds the complexity of the opcode. So + * discover what the index is. + */ + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr); + if (dictVarIndex < 0) { + return TCL_ERROR; + } + keyTokenPtr = TokenAfter(varTokenPtr); /* * Parse the increment amount, if present. */ if (parsePtr->numWords == 4) { - const char *word; - size_t numBytes; - int code; - Tcl_Token *incrTokenPtr; - Tcl_Obj *intObj; - - incrTokenPtr = TokenAfter(keyTokenPtr); - if (incrTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TclCompileBasic2Or3ArgCmd(interp, parsePtr,cmdPtr, envPtr); - } - word = incrTokenPtr[1].start; - numBytes = incrTokenPtr[1].size; - - intObj = Tcl_NewStringObj(word, numBytes); - Tcl_IncrRefCount(intObj); - code = TclGetIntFromObj(NULL, intObj, &incrAmount); - TclDecrRefCount(intObj); - if (code != TCL_OK) { - return TclCompileBasic2Or3ArgCmd(interp, parsePtr,cmdPtr, envPtr); + Tcl_Token *incrTokenPtr = TokenAfter(keyTokenPtr); + Tcl_Obj *intObj = Tcl_NewObj(); + int fail = (!TclWordKnownAtCompileTime(incrTokenPtr, intObj) + || TCL_ERROR == TclGetIntFromObj(NULL, intObj, &incrAmount)); + Tcl_DecrRefCount(intObj); + if (fail) { + return TCL_ERROR; } } else { incrAmount = 1; } - /* - * The dictionary variable must be a local scalar that is knowable at - * compile time; anything else exceeds the complexity of the opcode. So - * discover what the index is. - */ - - dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr); - if (dictVarIndex < 0) { - return TclCompileBasic2Or3ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - /* * Emit the key and the code to actually do the increment. */ CompileWord(envPtr, keyTokenPtr, interp, 2); @@ -1125,23 +763,23 @@ 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 *), + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; int i; + DefineLineInformation; /* TIP #280 */ /* * 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. */ if (parsePtr->numWords < 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1152,339 +790,10 @@ for (i=1 ; inumWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4(INST_DICT_GET, parsePtr->numWords-2, envPtr); - TclAdjustStackDepth(-1, envPtr); - return TCL_OK; -} - -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) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - - for (i=1 ; inumWords ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); - tokenPtr = TokenAfter(tokenPtr); - } - TclEmitInstInt4(INST_DICT_GET_DEF, parsePtr->numWords-3, envPtr); - TclAdjustStackDepth(-2, envPtr); - return TCL_OK; -} - -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. */ - if (parsePtr->numWords < 3) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - - /* - * Now we do the code generation. - */ - - for (i=1 ; inumWords ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); - tokenPtr = TokenAfter(tokenPtr); - } - TclEmitInstInt4(INST_DICT_EXISTS, parsePtr->numWords-2, envPtr); - TclAdjustStackDepth(-1, envPtr); - return TCL_OK; -} - -int -TclCompileDictUnsetCmd( - 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. - */ - - /* TODO: Consider support for compiling expanded args. */ - if (parsePtr->numWords < 3) { - return TCL_ERROR; - } - - /* - * The dictionary variable must be a local scalar that is knowable at - * compile time; anything else exceeds the complexity of the opcode. So - * discover what the index is. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - dictVarIndex = LocalScalarFromToken(tokenPtr, envPtr); - if (dictVarIndex < 0) { - return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - - /* - * Remaining words (the key path) can be handled normally. - */ - - for (i=2 ; inumWords ; i++) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, i); - } - - /* - * Now emit the instruction to do the dict manipulation. - */ - - TclEmitInstInt4( INST_DICT_UNSET, parsePtr->numWords-2, envPtr); - TclEmitInt4( dictVarIndex, envPtr); - return TCL_OK; -} - -int -TclCompileDictCreateCmd( - 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 */ - int worker; /* Temp var for building the value in. */ - Tcl_Token *tokenPtr; - Tcl_Obj *keyObj, *valueObj, *dictObj; - const char *bytes; - int i; - size_t len; - - if ((parsePtr->numWords & 1) == 0) { - return TCL_ERROR; - } - - /* - * See if we can build the value at compile time... - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - TclNewObj(dictObj); - Tcl_IncrRefCount(dictObj); - for (i=1 ; inumWords ; i+=2) { - TclNewObj(keyObj); - Tcl_IncrRefCount(keyObj); - if (!TclWordKnownAtCompileTime(tokenPtr, keyObj)) { - Tcl_DecrRefCount(keyObj); - Tcl_DecrRefCount(dictObj); - goto nonConstant; - } - tokenPtr = TokenAfter(tokenPtr); - TclNewObj(valueObj); - Tcl_IncrRefCount(valueObj); - if (!TclWordKnownAtCompileTime(tokenPtr, valueObj)) { - Tcl_DecrRefCount(keyObj); - Tcl_DecrRefCount(valueObj); - Tcl_DecrRefCount(dictObj); - goto nonConstant; - } - tokenPtr = TokenAfter(tokenPtr); - Tcl_DictObjPut(NULL, dictObj, keyObj, valueObj); - Tcl_DecrRefCount(keyObj); - Tcl_DecrRefCount(valueObj); - } - - /* - * We did! Excellent. The "verifyDict" is to do type forcing. - */ - - bytes = TclGetStringFromObj(dictObj, &len); - PushLiteral(envPtr, bytes, len); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_DICT_VERIFY, envPtr); - Tcl_DecrRefCount(dictObj); - return TCL_OK; - - /* - * Otherwise, we've got to issue runtime code to do the building, which we - * do by [dict set]ting into an unnamed local variable. This requires that - * we are in a context with an LVT. - */ - - nonConstant: - worker = AnonymousLocal(envPtr); - if (worker < 0) { - return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - - PushStringLiteral(envPtr, ""); - Emit14Inst( INST_STORE_SCALAR, worker, envPtr); - TclEmitOpcode( INST_POP, envPtr); - tokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i=1 ; inumWords ; i+=2) { - CompileWord(envPtr, tokenPtr, interp, i); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, i+1); - tokenPtr = TokenAfter(tokenPtr); - TclEmitInstInt4( INST_DICT_SET, 1, envPtr); - TclEmitInt4( worker, envPtr); - TclAdjustStackDepth(-1, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - Emit14Inst( INST_LOAD_SCALAR, worker, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( worker, envPtr); - return TCL_OK; -} - -int -TclCompileDictMergeCmd( - 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, workerIndex, infoIndex, outLoop; - - /* - * Deal with some special edge cases. Note that in the case with one - * argument, the only thing to do is to verify the dict-ness. - */ - - /* TODO: Consider support for compiling expanded args. (less likely) */ - if (parsePtr->numWords < 2) { - PushStringLiteral(envPtr, ""); - return TCL_OK; - } else if (parsePtr->numWords == 2) { - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_DICT_VERIFY, envPtr); - return TCL_OK; - } - - /* - * There's real merging work to do. - * - * Allocate some working space. This means we'll only ever compile this - * command when there's an LVT present. - */ - - workerIndex = AnonymousLocal(envPtr); - if (workerIndex < 0) { - return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - infoIndex = AnonymousLocal(envPtr); - - /* - * Get the first dictionary and verify that it is so. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_DICT_VERIFY, envPtr); - Emit14Inst( INST_STORE_SCALAR, workerIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - - /* - * For each of the remaining dictionaries... - */ - - outLoop = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - TclEmitInstInt4( INST_BEGIN_CATCH4, outLoop, envPtr); - ExceptionRangeStarts(envPtr, outLoop); - for (i=2 ; inumWords ; i++) { - /* - * Get the dictionary, and merge its pairs into the first dict (using - * a small loop). - */ - - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, i); - TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); - TclEmitInstInt1( INST_JUMP_TRUE1, 24, envPtr); - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitInstInt4( INST_DICT_SET, 1, envPtr); - TclEmitInt4( workerIndex, envPtr); - TclAdjustStackDepth(-1, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr); - TclEmitInstInt1( INST_JUMP_FALSE1, -20, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( infoIndex, envPtr); - } - ExceptionRangeEnds(envPtr, outLoop); - TclEmitOpcode( INST_END_CATCH, envPtr); - - /* - * Clean up any state left over. - */ - - Emit14Inst( INST_LOAD_SCALAR, workerIndex, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( workerIndex, envPtr); - TclEmitInstInt1( INST_JUMP1, 18, envPtr); - - /* - * If an exception happens when starting to iterate over the second (and - * subsequent) dicts. This is strictly not necessary, but it is nice. - */ - - TclAdjustStackDepth(-1, envPtr); - ExceptionRangeTarget(envPtr, outLoop, catchOffset); - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( workerIndex, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( infoIndex, envPtr); - TclEmitOpcode( INST_RETURN_STK, envPtr); - return TCL_OK; } int TclCompileDictForCmd( @@ -1493,181 +802,124 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - return CompileDictEachCmd(interp, parsePtr, cmdPtr, envPtr, - TCL_EACH_KEEP_NONE); -} - -int -TclCompileDictMapCmd( - 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. */ -{ - return CompileDictEachCmd(interp, parsePtr, cmdPtr, envPtr, - TCL_EACH_COLLECT); -} - -int -CompileDictEachCmd( - 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. */ - int collect) /* Flag == TCL_EACH_COLLECT to collect and - * construct a new dictionary with the loop - * body result. */ -{ - DefineLineInformation; /* TIP #280 */ + Proc *procPtr = envPtr->procPtr; Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr; - int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange; + int keyVarIndex, valueVarIndex, loopRange, catchRange; int infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset; - int numVars, endTargetOffset; - int collectVar = -1; /* Index of temp var holding the result - * dict. */ - const char **argv; - Tcl_DString buffer; + int numVars, endTargetOffset, numBytes; + const char *bytes; + int savedStackDepth = envPtr->currStackDepth; + /* Needed because jumps confuse the stack + * space calculator. */ + Tcl_Obj *varNameObj, *varListObj = NULL; + DefineLineInformation; /* TIP #280 */ /* - * There must be three arguments after the command. + * There must be exactly three arguments after the command. */ - if (parsePtr->numWords != 4) { - return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); + if (parsePtr->numWords != 4 || procPtr == NULL) { + return TCL_ERROR; } varsTokenPtr = TokenAfter(parsePtr->tokenPtr); dictTokenPtr = TokenAfter(varsTokenPtr); bodyTokenPtr = TokenAfter(dictTokenPtr); - if (varsTokenPtr->type != TCL_TOKEN_SIMPLE_WORD || - bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - - /* - * Create temporary variable to capture return values from loop body when - * we're collecting results. - */ - - if (collect == TCL_EACH_COLLECT) { - collectVar = AnonymousLocal(envPtr); - if (collectVar < 0) { - return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } + + if (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; } /* * Check we've got a pair of variables and that they are local variables. * Then extract their indices in the LVT. */ - Tcl_DStringInit(&buffer); - TclDStringAppendToken(&buffer, &varsTokenPtr[1]); - 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) { - Tcl_Free((void *)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); - Tcl_Free((void *)argv); - - if ((keyVarIndex < 0) || (valueVarIndex < 0)) { - return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } + varListObj = Tcl_NewObj(); + if (!TclWordKnownAtCompileTime(varsTokenPtr, varListObj) || + TCL_OK != Tcl_ListObjLength(NULL, varListObj, &numVars) || + numVars != 2) { + Tcl_DecrRefCount(varListObj); + return TCL_ERROR; + } + + Tcl_ListObjIndex(NULL, varListObj, 0, &varNameObj); + bytes = Tcl_GetStringFromObj(varNameObj, &numBytes); + keyVarIndex = LocalScalar(bytes, numBytes, envPtr); + if (keyVarIndex < 0) { + Tcl_DecrRefCount(varListObj); + return TCL_ERROR; + } + + Tcl_ListObjIndex(NULL, varListObj, 1, &varNameObj); + bytes = Tcl_GetStringFromObj(varNameObj, &numBytes); + valueVarIndex = LocalScalar(bytes, numBytes, envPtr); + if (valueVarIndex < 0) { + Tcl_DecrRefCount(varListObj); + return TCL_ERROR; + } + + Tcl_DecrRefCount(varListObj); /* * Allocate a temporary variable to store the iterator reference. The * variable will contain a Tcl_DictSearch reference which will be * allocated by INST_DICT_FIRST and disposed when the variable is unset * (at which point it should also have been finished with). */ - infoIndex = AnonymousLocal(envPtr); - if (infoIndex < 0) { - return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } + infoIndex = TclFindCompiledLocal(NULL, 0, 1, procPtr); /* * Preparation complete; issue instructions. Note that this code issues * fixed-sized jumps. That simplifies things a lot! * - * First up, initialize the accumulator dictionary if needed. - */ - - if (collect == TCL_EACH_COLLECT) { - PushStringLiteral(envPtr, ""); - Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - - /* - * Get the dictionary and start the iteration. No catching of errors at - * this point. + * First up, get the dictionary and start the iteration. No catching of + * errors at this point. */ CompileWord(envPtr, dictTokenPtr, interp, 2); + TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); + emptyTargetOffset = CurrentOffset(envPtr); + TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr); /* * Now we catch errors from here on so that we can finalize the search * started by Tcl_DictObjFirst above. */ - catchRange = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange, envPtr); + catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange, envPtr); ExceptionRangeStarts(envPtr, catchRange); - TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); - emptyTargetOffset = CurrentOffset(envPtr); - TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr); - /* * Inside the iteration, write the loop variables. */ bodyTargetOffset = CurrentOffset(envPtr); - Emit14Inst( INST_STORE_SCALAR, keyVarIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - Emit14Inst( INST_STORE_SCALAR, valueVarIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); + TclEmitInstInt4( INST_STORE_SCALAR4, keyVarIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + TclEmitInstInt4( INST_STORE_SCALAR4, valueVarIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); /* * Set up the loop exception targets. */ - loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + loopRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); ExceptionRangeStarts(envPtr, loopRange); /* * Compile the loop body itself. It should be stack-neutral. */ - BODY(bodyTokenPtr, 3); - if (collect == TCL_EACH_COLLECT) { - Emit14Inst( INST_LOAD_SCALAR, keyVarIndex, envPtr); - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitInstInt4(INST_DICT_SET, 1, envPtr); - TclEmitInt4( collectVar, envPtr); - TclAdjustStackDepth(-1, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - TclEmitOpcode( INST_POP, envPtr); + SetLineInformation(3); + CompileBody(envPtr, bodyTokenPtr, interp); + TclEmitOpcode( INST_POP, envPtr); /* * Both exception target ranges (error and loop) end here. */ @@ -1679,67 +931,66 @@ * from the dictionary and jumping back to the code to write them into * variables if there is another pair. */ ExceptionRangeTarget(envPtr, loopRange, continueOffset); - TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr); + TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr); jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr); - TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement, envPtr); + TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement, envPtr); + TclEmitOpcode( INST_POP, envPtr); + TclEmitOpcode( INST_POP, envPtr); + + /* + * Now do the final cleanup for the no-error case (this is where we break + * out of the loop to) by force-terminating the iteration (if not already + * terminated), ditching the exception info and jumping to the last + * instruction for this command. In theory, this could be done using the + * "finally" clause (next generated) but this is faster. + */ + + ExceptionRangeTarget(envPtr, loopRange, breakOffset); + TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr); + TclEmitOpcode( INST_END_CATCH, envPtr); endTargetOffset = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP1, 0, envPtr); + TclEmitInstInt4( INST_JUMP4, 0, envPtr); /* * Error handler "finally" clause, which force-terminates the iteration * and rethrows the error. */ - TclAdjustStackDepth(-1, envPtr); ExceptionRangeTarget(envPtr, catchRange, catchOffset); - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( infoIndex, envPtr); - if (collect == TCL_EACH_COLLECT) { - TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( collectVar, envPtr); - } - TclEmitOpcode( INST_RETURN_STK, envPtr); + TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); + TclEmitOpcode( INST_PUSH_RESULT, envPtr); + TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr); + TclEmitOpcode( INST_END_CATCH, envPtr); + TclEmitOpcode( INST_RETURN_STK, envPtr); /* * Otherwise we're done (the jump after the DICT_FIRST points here) and we * need to pop the bogus key/value pair (pushed to keep stack calculations * easy!) Note that we skip the END_CATCH. [Bug 1382528] */ + envPtr->currStackDepth = savedStackDepth+2; jumpDisplacement = CurrentOffset(envPtr) - emptyTargetOffset; TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement, envPtr->codeStart + emptyTargetOffset); - jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset; - TclUpdateInstInt1AtPc(INST_JUMP1, jumpDisplacement, - envPtr->codeStart + endTargetOffset); - TclEmitOpcode( INST_POP, envPtr); - TclEmitOpcode( INST_POP, envPtr); - ExceptionRangeTarget(envPtr, loopRange, breakOffset); - TclFinalizeLoopExceptionRange(envPtr, loopRange); - TclEmitOpcode( INST_END_CATCH, envPtr); + TclEmitOpcode( INST_POP, envPtr); + TclEmitOpcode( INST_POP, envPtr); + TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr); /* * Final stage of the command (normal case) is that we push an empty - * object (or push the accumulator as the result object). This is done - * last to promote peephole optimization when it's dropped immediately. + * object. This is done last to promote peephole optimization when it's + * dropped immediately. */ - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( infoIndex, envPtr); - if (collect == TCL_EACH_COLLECT) { - Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr); - TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( collectVar, envPtr); - } else { - PushStringLiteral(envPtr, ""); - } + jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset; + TclUpdateInstInt4AtPc(INST_JUMP4, jumpDisplacement, + envPtr->codeStart + endTargetOffset); + PushLiteral(envPtr, "", 0); return TCL_OK; } int TclCompileDictUpdateCmd( @@ -1748,23 +999,15 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - DefineLineInformation; /* TIP #280 */ int i, dictIndex, numVars, range, infoIndex; Tcl_Token **keyTokenPtrs, *dictVarTokenPtr, *bodyTokenPtr, *tokenPtr; DictUpdateInfo *duiPtr; JumpFixup jumpFixup; - - /* - * There must be at least one argument after the command. - */ - - if (parsePtr->numWords < 5) { - return TCL_ERROR; - } + DefineLineInformation; /* TIP #280 */ /* * Parse the command. Expect the following: * dict update ? ...? */ @@ -1771,10 +1014,13 @@ if ((parsePtr->numWords - 1) & 1) { return TCL_ERROR; } numVars = (parsePtr->numWords - 3) / 2; + if (numVars < 1) { + return TCL_ERROR; + } /* * The dictionary variable must be a local scalar that is knowable at * compile time; anything else exceeds the complexity of the opcode. So * discover what the index is. @@ -1781,78 +1027,92 @@ */ dictVarTokenPtr = TokenAfter(parsePtr->tokenPtr); dictIndex = LocalScalarFromToken(dictVarTokenPtr, envPtr); if (dictIndex < 0) { - goto issueFallback; + return TCL_ERROR; } /* * 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 *)Tcl_Alloc(offsetof(DictUpdateInfo, varIndices) + sizeof(int) * numVars); + duiPtr = (DictUpdateInfo *) + ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1)); duiPtr->length = numVars; - keyTokenPtrs = (Tcl_Token **)TclStackAlloc(interp, sizeof(Tcl_Token *) * numVars); + keyTokenPtrs = (Tcl_Token **) TclStackAlloc(interp, + sizeof(Tcl_Token *) * numVars); tokenPtr = TokenAfter(dictVarTokenPtr); for (i=0 ; ivarIndices[i] = LocalScalarFromToken(tokenPtr, envPtr); - if (duiPtr->varIndices[i] < 0) { - goto failedUpdateInfoAssembly; - } + duiPtr->varIndices[i] = index; tokenPtr = TokenAfter(tokenPtr); } if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - goto failedUpdateInfoAssembly; + ckfree((char *) duiPtr); + TclStackFree(interp, keyTokenPtrs); + return TCL_ERROR; } bodyTokenPtr = tokenPtr; /* * The list of variables to bind is stored in auxiliary data so that it * can't be snagged by literal sharing and forced to shimmer dangerously. */ - infoIndex = TclCreateAuxData(duiPtr, &dictUpdateInfoType, envPtr); + infoIndex = TclCreateAuxData(duiPtr, &tclDictUpdateInfoType, envPtr); for (i=0 ; inumWords - 1); + SetLineInformation(parsePtr->numWords - 1); + CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); /* * Normal termination code: the stack has the key list below the result of * the body evaluation: swap them and finish the update code. */ - TclEmitOpcode( INST_END_CATCH, envPtr); - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); - TclEmitInt4( infoIndex, envPtr); + TclEmitOpcode( INST_END_CATCH, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); + TclEmitInt4( infoIndex, envPtr); /* * Jump around the exceptional termination code. */ @@ -1863,35 +1123,25 @@ * options in the stack, bring up the key list, finish the update code, * and finally return with the catched return data */ ExceptionRangeTarget(envPtr, range, catchOffset); - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); - TclEmitInstInt4( INST_REVERSE, 3, envPtr); - - TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); - TclEmitInt4( infoIndex, envPtr); - TclEmitInvoke(envPtr,INST_RETURN_STK); + TclEmitOpcode( INST_PUSH_RESULT, envPtr); + TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); + TclEmitOpcode( INST_END_CATCH, envPtr); + TclEmitInstInt4( INST_REVERSE, 3, envPtr); + + TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); + TclEmitInt4( infoIndex, envPtr); + TclEmitOpcode( INST_RETURN_STK, envPtr); if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { - Tcl_Panic("TclCompileDictCmd(update): bad jump distance %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - jumpFixup.codeOffset); + 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: - Tcl_Free(duiPtr); - TclStackFree(interp, keyTokenPtrs); - issueFallback: - return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } int TclCompileDictAppendCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ @@ -1899,22 +1149,21 @@ * 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; + DefineLineInformation; /* TIP #280 */ /* - * There must be at least two argument after the command. And we impose an - * (arbirary) safe limit; anyone exceeding it should stop worrying about - * speed quite so much. ;-) + * There must be at least two argument after the command. Since we + * implement using INST_CONCAT1, make sure the number of arguments + * stays within its range. */ - /* TODO: Consider support for compiling expanded args. */ - if (parsePtr->numWords<4 || parsePtr->numWords>100) { + if (parsePtr->numWords<4 || parsePtr->numWords>258) { return TCL_ERROR; } /* * Get the index of the local variable that we will be working with. @@ -1921,11 +1170,11 @@ */ tokenPtr = TokenAfter(parsePtr->tokenPtr); dictVarIndex = LocalScalarFromToken(tokenPtr, envPtr); if (dictVarIndex < 0) { - return TclCompileBasicMin2ArgCmd(interp, parsePtr,cmdPtr, envPtr); + return TCL_ERROR; } /* * Produce the string to concatenate onto the dictionary entry. */ @@ -1934,11 +1183,11 @@ for (i=2 ; inumWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } if (parsePtr->numWords > 4) { - TclEmitInstInt1(INST_STR_CONCAT1, parsePtr->numWords-3, envPtr); + TclEmitInstInt1(INST_CONCAT1, parsePtr->numWords-3, envPtr); } /* * Do the concatenation. */ @@ -1954,294 +1203,32 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *keyTokenPtr, *valueTokenPtr; int dictVarIndex; + DefineLineInformation; /* TIP #280 */ /* * There must be three arguments after the command. */ - /* TODO: Consider support for compiling expanded args. */ - /* Probably not. Why is INST_DICT_LAPPEND limited to one value? */ if (parsePtr->numWords != 4) { return TCL_ERROR; } - /* - * Parse the arguments. - */ - varTokenPtr = TokenAfter(parsePtr->tokenPtr); keyTokenPtr = TokenAfter(varTokenPtr); valueTokenPtr = TokenAfter(keyTokenPtr); dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr); if (dictVarIndex < 0) { - return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); + return TCL_ERROR; } - - /* - * Issue the implementation. - */ - CompileWord(envPtr, keyTokenPtr, interp, 2); CompileWord(envPtr, valueTokenPtr, interp, 3); - TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr); - return TCL_OK; -} - -int -TclCompileDictWithCmd( - 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 */ - int i, range, varNameTmp = -1, pathTmp = -1, keysTmp, gotPath; - int dictVar, bodyIsEmpty = 1; - Tcl_Token *varTokenPtr, *tokenPtr; - JumpFixup jumpFixup; - const char *ptr, *end; - - /* - * There must be at least one argument after the command. - */ - - /* TODO: Consider support for compiling expanded args. */ - if (parsePtr->numWords < 3) { - return TCL_ERROR; - } - - /* - * Parse the command (trivially). Expect the following: - * dict with ? ...? - */ - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - tokenPtr = TokenAfter(varTokenPtr); - for (i=3 ; inumWords ; i++) { - tokenPtr = TokenAfter(tokenPtr); - } - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - - /* - * Test if the last word is an empty script; if so, we can compile it in - * all cases, but if it is non-empty we need local variable table entries - * to hold the temporary variables (used to keep stack usage simple). - */ - - for (ptr=tokenPtr[1].start,end=ptr+tokenPtr[1].size ; ptr!=end ; ptr++) { - if (*ptr!=' ' && *ptr!='\t' && *ptr!='\n' && *ptr!='\r') { - if (envPtr->procPtr == NULL) { - return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, - envPtr); - } - bodyIsEmpty = 0; - break; - } - } - - /* - * Determine if we're manipulating a dict in a simple local variable. - */ - - gotPath = (parsePtr->numWords > 3); - dictVar = LocalScalarFromToken(varTokenPtr, envPtr); - - /* - * Special case: an empty body means we definitely have no need to issue - * try-finally style code or to allocate local variable table entries for - * storing temporaries. Still need to do both INST_DICT_EXPAND and - * INST_DICT_RECOMBINE_* though, because we can't determine if we're free - * of traces. - */ - - if (bodyIsEmpty) { - if (dictVar >= 0) { - if (gotPath) { - /* - * Case: Path into dict in LVT with empty body. - */ - - tokenPtr = TokenAfter(varTokenPtr); - for (i=2 ; inumWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); - tokenPtr = TokenAfter(tokenPtr); - } - TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); - Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr); - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitOpcode( INST_DICT_EXPAND, envPtr); - TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr); - } else { - /* - * Case: Direct dict in LVT with empty body. - */ - - PushStringLiteral(envPtr, ""); - Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr); - PushStringLiteral(envPtr, ""); - TclEmitOpcode( INST_DICT_EXPAND, envPtr); - TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr); - } - } else { - if (gotPath) { - /* - * Case: Path into dict in non-simple var with empty body. - */ - - tokenPtr = varTokenPtr; - for (i=1 ; inumWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); - tokenPtr = TokenAfter(tokenPtr); - } - TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitOpcode( INST_LOAD_STK, envPtr); - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitOpcode( INST_DICT_EXPAND, envPtr); - TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); - } else { - /* - * Case: Direct dict in non-simple var with empty body. - */ - - CompileWord(envPtr, varTokenPtr, interp, 1); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_LOAD_STK, envPtr); - PushStringLiteral(envPtr, ""); - TclEmitOpcode( INST_DICT_EXPAND, envPtr); - PushStringLiteral(envPtr, ""); - TclEmitInstInt4(INST_REVERSE, 2, envPtr); - TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); - } - } - PushStringLiteral(envPtr, ""); - return TCL_OK; - } - - /* - * OK, we have a non-trivial body. This means that the focus is on - * generating a try-finally structure where the INST_DICT_RECOMBINE_* goes - * in the 'finally' clause. - * - * Start by allocating local (unnamed, untraced) working variables. - */ - - if (dictVar == -1) { - varNameTmp = AnonymousLocal(envPtr); - } - if (gotPath) { - pathTmp = AnonymousLocal(envPtr); - } - keysTmp = AnonymousLocal(envPtr); - - /* - * Issue instructions. First, the part to expand the dictionary. - */ - - if (dictVar == -1) { - CompileWord(envPtr, varTokenPtr, interp, 1); - Emit14Inst( INST_STORE_SCALAR, varNameTmp, envPtr); - } - tokenPtr = TokenAfter(varTokenPtr); - if (gotPath) { - for (i=2 ; inumWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); - tokenPtr = TokenAfter(tokenPtr); - } - TclEmitInstInt4( INST_LIST, parsePtr->numWords-3,envPtr); - Emit14Inst( INST_STORE_SCALAR, pathTmp, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - if (dictVar == -1) { - TclEmitOpcode( INST_LOAD_STK, envPtr); - } else { - Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr); - } - if (gotPath) { - Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); - } else { - PushStringLiteral(envPtr, ""); - } - TclEmitOpcode( INST_DICT_EXPAND, envPtr); - Emit14Inst( INST_STORE_SCALAR, keysTmp, envPtr); - TclEmitOpcode( INST_POP, envPtr); - - /* - * Now the body of the [dict with]. - */ - - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); - - ExceptionRangeStarts(envPtr, range); - BODY(tokenPtr, parsePtr->numWords - 1); - ExceptionRangeEnds(envPtr, range); - - /* - * Now fold the results back into the dictionary in the OK case. - */ - - TclEmitOpcode( INST_END_CATCH, envPtr); - if (dictVar == -1) { - Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr); - } - if (gotPath) { - Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); - } else { - PushStringLiteral(envPtr, ""); - } - Emit14Inst( INST_LOAD_SCALAR, keysTmp, envPtr); - if (dictVar == -1) { - TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); - } else { - TclEmitInstInt4( INST_DICT_RECOMBINE_IMM, dictVar, envPtr); - } - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); - - /* - * Now fold the results back into the dictionary in the exception case. - */ - - TclAdjustStackDepth(-1, envPtr); - ExceptionRangeTarget(envPtr, range, catchOffset); - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); - if (dictVar == -1) { - Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr); - } - if (parsePtr->numWords > 3) { - Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); - } else { - PushStringLiteral(envPtr, ""); - } - Emit14Inst( INST_LOAD_SCALAR, keysTmp, envPtr); - if (dictVar == -1) { - TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); - } else { - TclEmitInstInt4( INST_DICT_RECOMBINE_IMM, dictVar, envPtr); - } - 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 %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - jumpFixup.codeOffset); - } + TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -2253,163 +1240,68 @@ * * Results: * DupDictUpdateInfo: a copy of the auxiliary data * FreeDictUpdateInfo: none * PrintDictUpdateInfo: none - * DisassembleDictUpdateInfo: none * * Side effects: * DupDictUpdateInfo: allocates memory * FreeDictUpdateInfo: releases memory * PrintDictUpdateInfo: none - * DisassembleDictUpdateInfo: none * *---------------------------------------------------------------------- */ static ClientData DupDictUpdateInfo( ClientData clientData) { DictUpdateInfo *dui1Ptr, *dui2Ptr; - size_t len; + unsigned len; - dui1Ptr = (DictUpdateInfo *)clientData; - len = offsetof(DictUpdateInfo, varIndices) + sizeof(int) * dui1Ptr->length; - dui2Ptr = (DictUpdateInfo *)Tcl_Alloc(len); + dui1Ptr = clientData; + len = sizeof(DictUpdateInfo) + sizeof(int) * (dui1Ptr->length - 1); + dui2Ptr = (DictUpdateInfo *) ckalloc(len); memcpy(dui2Ptr, dui1Ptr, len); return dui2Ptr; } static void FreeDictUpdateInfo( ClientData clientData) { - Tcl_Free(clientData); + ckfree(clientData); } static void PrintDictUpdateInfo( ClientData clientData, Tcl_Obj *appendObj, - TCL_UNUSED(ByteCode *), - TCL_UNUSED(unsigned int)) + ByteCode *codePtr, + unsigned int pcOffset) { - DictUpdateInfo *duiPtr = (DictUpdateInfo *)clientData; - size_t i; + DictUpdateInfo *duiPtr = clientData; + int i; for (i=0 ; ilength ; 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; - size_t i; - Tcl_Obj *variables; - - TclNewObj(variables); - for (i=0 ; ilength ; i++) { - Tcl_ListObjAppendElement(NULL, variables, - Tcl_NewWideIntObj(duiPtr->varIndices[i])); - } - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("variables", -1), - variables); -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileErrorCmd -- - * - * Procedure called to compile the "error" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "error" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -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. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - - /* - * Construct the options. Note that -code and -level are not here. - */ - - if (parsePtr->numWords == 2) { - PushStringLiteral(envPtr, ""); - } else { - PushStringLiteral(envPtr, "-errorinfo"); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - if (parsePtr->numWords == 3) { - TclEmitInstInt4( INST_LIST, 2, envPtr); - } else { - PushStringLiteral(envPtr, "-errorcode"); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 3); - TclEmitInstInt4( INST_LIST, 4, envPtr); - } - } - - /* - * Issue the error via 'returnImm error 0'. - */ - - TclEmitInstInt4( INST_RETURN_IMM, TCL_ERROR, envPtr); - TclEmitInt4( 0, envPtr); - return TCL_OK; -} /* *---------------------------------------------------------------------- * * TclCompileExprCmd -- * * Procedure called to compile the "expr" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "expr" command at * runtime. * @@ -2419,11 +1311,12 @@ 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 *), + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *firstWordPtr; if (parsePtr->numWords == 1) { @@ -2448,12 +1341,12 @@ * TclCompileForCmd -- * * Procedure called to compile the "for" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "for" command at * runtime. * @@ -2463,18 +1356,20 @@ 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 *), + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - DefineLineInformation; /* TIP #280 */ Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr; JumpFixup jumpEvalCondFixup; - int bodyCodeOffset, nextCodeOffset, jumpDist; + int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist; int bodyRange, nextRange; + int savedStackDepth = envPtr->currStackDepth; + DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords != 5) { return TCL_ERROR; } @@ -2500,15 +1395,25 @@ if ((nextTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) { return TCL_ERROR; } + /* + * Create ExceptionRange records for the body and the "next" command. The + * "next" command's ExceptionRange supports break but not continue (and + * has a -1 continueOffset). + */ + + bodyRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); + nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + /* * Inline compile the initial command. */ - BODY(startTokenPtr, 1); + SetLineInformation (1); + CompileBody(envPtr, startTokenPtr, interp); TclEmitOpcode(INST_POP, envPtr); /* * Jump to the evaluation of the condition. This code uses the "loop * rotation" optimisation (which eliminates one branch from the loop). @@ -2525,41 +1430,48 @@ /* * Compile the loop body. */ - bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange); - BODY(bodyTokenPtr, 4); + SetLineInformation (4); + CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, bodyRange); + envPtr->currStackDepth = savedStackDepth + 1; TclEmitOpcode(INST_POP, envPtr); /* - * Compile the "next" subcommand. Note that this exception range will not - * have a continueOffset (other than -1) connected to it; it won't trap - * TCL_CONTINUE but rather just TCL_BREAK. + * Compile the "next" subcommand. */ - nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); - envPtr->exceptAuxArrayPtr[nextRange].supportsContinue = 0; + envPtr->currStackDepth = savedStackDepth; nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange); - BODY(nextTokenPtr, 3); + SetLineInformation (3); + CompileBody(envPtr, nextTokenPtr, interp); ExceptionRangeEnds(envPtr, nextRange); + envPtr->currStackDepth = savedStackDepth + 1; TclEmitOpcode(INST_POP, envPtr); + envPtr->currStackDepth = savedStackDepth; /* * Compile the test expression then emit the conditional jump that * terminates the for. */ - if (TclFixupForwardJumpToHere(envPtr, &jumpEvalCondFixup, 127)) { + testCodeOffset = CurrentOffset(envPtr); + + jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset; + if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) { bodyCodeOffset += 3; nextCodeOffset += 3; + testCodeOffset += 3; } - SetLineInformation(2); + SetLineInformation (2); + envPtr->currStackDepth = savedStackDepth; TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + envPtr->currStackDepth = savedStackDepth + 1; jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; if (jumpDist > 127) { TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); } else { @@ -2576,18 +1488,17 @@ envPtr->exceptArrayPtr[nextRange].codeOffset = nextCodeOffset; ExceptionRangeTarget(envPtr, bodyRange, breakOffset); ExceptionRangeTarget(envPtr, nextRange, breakOffset); - TclFinalizeLoopExceptionRange(envPtr, bodyRange); - TclFinalizeLoopExceptionRange(envPtr, nextRange); /* * The for command's result is an empty string. */ - PushStringLiteral(envPtr, ""); + envPtr->currStackDepth = savedStackDepth; + PushLiteral(envPtr, "", 0); return TCL_OK; } /* @@ -2596,12 +1507,12 @@ * TclCompileForeachCmd -- * * Procedure called to compile the "foreach" command. * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. * * Side effects: * Instructions are added to envPtr to execute the "foreach" command at * runtime. * @@ -2615,83 +1526,22 @@ * created by Tcl_ParseCommand. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, - TCL_EACH_KEEP_NONE); -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLmapCmd -- - * - * Procedure called to compile the "lmap" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "lmap" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileLmapCmd( - 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. */ -{ - return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, - TCL_EACH_COLLECT); -} - -/* - *---------------------------------------------------------------------- - * - * CompileEachloopCmd -- - * - * Procedure called to compile the "foreach" and "lmap" commands. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "foreach" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -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 + 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; + unsigned char *jumpPc; + JumpFixup jumpFalseFixup; + int jumpBackDist, jumpBackOffset, infoIndex, range; + int numWords, numLists, tempVar, i, j, code = TCL_OK; + int savedStackDepth = envPtr->currStackDepth; Tcl_Obj *varListObj = NULL; + DefineLineInformation; /* TIP #280 */ /* * If the foreach command isn't in a procedure, don't compile it inline: * the payoff is too small. */ @@ -2723,21 +1573,21 @@ * structures describing this command. Then create a AuxData record * pointing to the ForeachInfo structure. */ numLists = (numWords - 2)/2; - infoPtr = (ForeachInfo *)Tcl_Alloc(offsetof(ForeachInfo, varLists) - + numLists * sizeof(ForeachVarList *)); + infoPtr = (ForeachInfo *) ckalloc((unsigned) + sizeof(ForeachInfo) + numLists*sizeof(ForeachVarList *)); infoPtr->numLists = 0; /* Count this up as we go */ /* - * Parse each var list into sequence of var names. Don't + * Parse each var list into sequence of var names. Don't * compile the foreach inline if any var name needs substitutions or isn't * a scalar, or if any var list needs substitutions. */ - TclNewObj(varListObj); + varListObj = Tcl_NewObj(); for (i = 0, tokenPtr = parsePtr->tokenPtr; i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { ForeachVarList *varListPtr; int numVars; @@ -2746,125 +1596,177 @@ continue; } /* * If the variable list is empty, we can enter an infinite loop when - * the interpreted version would not. Take care to ensure this does - * not happen. [Bug 1671138] + * the interpreted version would not. Take care to ensure this does + * not happen. [Bug 1671138] */ if (!TclWordKnownAtCompileTime(tokenPtr, varListObj) || TCL_OK != Tcl_ListObjLength(NULL, varListObj, &numVars) || numVars == 0) { code = TCL_ERROR; goto done; } - varListPtr = (ForeachVarList *)Tcl_Alloc(offsetof(ForeachVarList, varIndexes) - + numVars * sizeof(int)); + varListPtr = (ForeachVarList *) ckalloc((unsigned) + sizeof(ForeachVarList) + numVars*sizeof(int)); varListPtr->numVars = numVars; infoPtr->varLists[i/2] = varListPtr; infoPtr->numLists++; for (j = 0; j < numVars; j++) { Tcl_Obj *varNameObj; + int numBytes; const char *bytes; - int varIndex; - size_t length; - Tcl_ListObjIndex(NULL, varListObj, j, &varNameObj); - bytes = TclGetStringFromObj(varNameObj, &length); - varIndex = LocalScalar(bytes, length, envPtr); - if (varIndex < 0) { + bytes = Tcl_GetStringFromObj(varNameObj, &numBytes); + varListPtr->varIndexes[j] = LocalScalar(bytes, numBytes, envPtr); + if (varListPtr->varIndexes[j] < 0) { code = TCL_ERROR; goto done; } - varListPtr->varIndexes[j] = varIndex; } Tcl_SetObjLength(varListObj, 0); } /* - * We will compile the foreach command. - */ - - infoIndex = TclCreateAuxData(infoPtr, &newForeachInfoType, envPtr); - - /* - * Create the collecting object, unshared. - */ - - if (collect == TCL_EACH_COLLECT) { - TclEmitInstInt4(INST_LIST, 0, envPtr); - } - - /* - * Evaluate each value list and leave it on stack. + * Reserve (numLists + 1) temporary variables: + * - numLists temps to hold each value list + * - 1 temp for the loop counter (index of next element in each list) + * + * At this time we don't try to reuse temporaries; if there are two + * nonoverlapping foreach loops, they don't share any temps. + */ + + tempVar = TclFindCompiledLocal(NULL, 0, 1, procPtr); + infoPtr->firstValueTemp = tempVar; + for (i= 1; i < numLists; i++) { + TclFindCompiledLocal(NULL, 0, 1, procPtr); + } + infoPtr->loopCtTemp = TclFindCompiledLocal(NULL, 0, 1, procPtr); + + infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr); + + /* + * Create an exception record to handle [break] and [continue]. + */ + + range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); + + /* + * Evaluate then store each value list in the associated temporary. */ for (i = 0, tokenPtr = parsePtr->tokenPtr; i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { if ((i%2 == 0) && (i > 0)) { - CompileWord(envPtr, tokenPtr, interp, i); + SetLineInformation (i); + CompileTokens(envPtr, tokenPtr, interp); + if (tempVar <= 255) { + TclEmitInstInt1(INST_STORE_SCALAR1, tempVar, envPtr); + } else { + TclEmitInstInt4(INST_STORE_SCALAR4, tempVar, envPtr); + } + TclEmitOpcode(INST_POP, envPtr); + tempVar++; } } - TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr); + /* + * Initialize the temporary var that holds the count of loop iterations. + */ + + TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr); + + /* + * Top of loop code: assign each loop variable and check whether + * to terminate the loop. + */ + + ExceptionRangeTarget(envPtr, range, continueOffset); + TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); /* * Inline compile the loop body. */ - range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); - + SetLineInformation (numWords - 1); ExceptionRangeStarts(envPtr, range); - BODY(bodyTokenPtr, numWords - 1); + CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); + envPtr->currStackDepth = savedStackDepth + 1; + TclEmitOpcode(INST_POP, envPtr); - if (collect == TCL_EACH_COLLECT) { - TclEmitOpcode(INST_LMAP_COLLECT, envPtr); + /* + * Jump back to the test at the top of the loop. Generate a 4 byte jump if + * the distance to the test is > 120 bytes. This is conservative and + * ensures that we won't have to replace this jump if we later need to + * replace the ifFalse jump with a 4 byte jump. + */ + + jumpBackOffset = CurrentOffset(envPtr); + jumpBackDist = jumpBackOffset-envPtr->exceptArrayPtr[range].continueOffset; + if (jumpBackDist > 120) { + TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr); } else { - TclEmitOpcode( INST_POP, envPtr); + TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr); } /* - * Bottom of loop code: assign each loop variable and check whether - * to terminate the loop. Set the loop's break target. + * Fix the target of the jump after the foreach_step test. */ - ExceptionRangeTarget(envPtr, range, continueOffset); - TclEmitOpcode(INST_FOREACH_STEP, envPtr); + if (TclFixupForwardJumpToHere(envPtr, &jumpFalseFixup, 127)) { + /* + * Update the loop body's starting PC offset since it moved down. + */ + + envPtr->exceptArrayPtr[range].codeOffset += 3; + + /* + * Update the jump back to the test at the top of the loop since it + * also moved down 3 bytes. + */ + + jumpBackOffset += 3; + jumpPc = (envPtr->codeStart + jumpBackOffset); + jumpBackDist += 3; + if (jumpBackDist > 120) { + TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc); + } else { + TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc); + } + } + + /* + * Set the loop's break target. + */ + ExceptionRangeTarget(envPtr, range, breakOffset); - TclFinalizeLoopExceptionRange(envPtr, range); - TclEmitOpcode(INST_FOREACH_END, envPtr); - TclAdjustStackDepth(-(numLists+2), envPtr); - - /* - * Set the jumpback distance from INST_FOREACH_STEP to the start of the - * body's code. Misuse loopCtTemp for storing the jump size. - */ - - jumpBackOffset = envPtr->exceptArrayPtr[range].continueOffset - - envPtr->exceptArrayPtr[range].codeOffset; - infoPtr->loopCtTemp = -jumpBackOffset; - - /* - * The command's result is an empty string if not collecting. If - * collecting, it is automatically left on stack after FOREACH_END. - */ - - if (collect != TCL_EACH_COLLECT) { - PushStringLiteral(envPtr, ""); - } - - done: + + /* + * The foreach command's result is an empty string. + */ + + envPtr->currStackDepth = savedStackDepth; + PushLiteral(envPtr, "", 0); + envPtr->currStackDepth = savedStackDepth + 1; + + done: if (code == TCL_ERROR) { - FreeForeachInfo(infoPtr); + if (infoPtr) { + FreeForeachInfo(infoPtr); + } } - Tcl_DecrRefCount(varListObj); + if (varListObj) { + Tcl_DecrRefCount(varListObj); + } return code; } /* *---------------------------------------------------------------------- @@ -2890,26 +1792,26 @@ static ClientData DupForeachInfo( ClientData clientData) /* The foreach command's compilation auxiliary * data to duplicate. */ { - ForeachInfo *srcPtr = (ForeachInfo *)clientData; + register ForeachInfo *srcPtr = clientData; ForeachInfo *dupPtr; - ForeachVarList *srcListPtr, *dupListPtr; + register ForeachVarList *srcListPtr, *dupListPtr; int numVars, i, j, numLists = srcPtr->numLists; - dupPtr = (ForeachInfo *)Tcl_Alloc(offsetof(ForeachInfo, varLists) - + numLists * sizeof(ForeachVarList *)); + dupPtr = (ForeachInfo *) ckalloc((unsigned) + 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 *)Tcl_Alloc(offsetof(ForeachVarList, varIndexes) - + numVars * sizeof(int)); + dupListPtr = (ForeachVarList *) ckalloc((unsigned) + sizeof(ForeachVarList) + numVars*sizeof(int)); dupListPtr->numVars = numVars; for (j = 0; j < numVars; j++) { dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j]; } dupPtr->varLists[i] = dupListPtr; @@ -2939,29 +1841,29 @@ static void FreeForeachInfo( ClientData clientData) /* The foreach command's compilation auxiliary * data to free. */ { - ForeachInfo *infoPtr = (ForeachInfo *)clientData; - ForeachVarList *listPtr; + register ForeachInfo *infoPtr = clientData; + register ForeachVarList *listPtr; int numLists = infoPtr->numLists; - int i; + register int i; for (i = 0; i < numLists; i++) { listPtr = infoPtr->varLists[i]; - Tcl_Free(listPtr); + ckfree((char *) listPtr); } - Tcl_Free(infoPtr); + ckfree((char *) infoPtr); } /* *---------------------------------------------------------------------- * - * PrintForeachInfo, DisassembleForeachInfo -- + * PrintForeachInfo -- * - * Functions to write a human-readable or script-readablerepresentation - * of a ForeachInfo structure to a Tcl_Obj for debugging. + * Function to write a human-readable representation of a ForeachInfo + * structure to stdout for debugging. * * Results: * None. * * Side effects: @@ -2972,15 +1874,15 @@ static void PrintForeachInfo( ClientData clientData, Tcl_Obj *appendObj, - TCL_UNUSED(ByteCode *), - TCL_UNUSED(unsigned int)) + ByteCode *codePtr, + unsigned int pcOffset) { - ForeachInfo *infoPtr = (ForeachInfo *)clientData; - ForeachVarList *varsPtr; + register ForeachInfo *infoPtr = clientData; + register ForeachVarList *varsPtr; int i, j; Tcl_AppendToObj(appendObj, "data=[", -1); for (i=0 ; inumLists ; i++) { @@ -3007,426 +1909,2886 @@ (unsigned) varsPtr->varIndexes[j]); } Tcl_AppendToObj(appendObj, "]", -1); } } - -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 ; inumLists ; i++) { - if (i) { - Tcl_AppendToObj(appendObj, ",", -1); - } - Tcl_AppendToObj(appendObj, "[", -1); - varsPtr = infoPtr->varLists[i]; - for (j=0 ; jnumVars ; j++) { - if (j) { - Tcl_AppendToObj(appendObj, ",", -1); - } - Tcl_AppendPrintfToObj(appendObj, "%%v%u", - (unsigned) varsPtr->varIndexes[j]); - } - Tcl_AppendToObj(appendObj, "]", -1); - } -} - -static void -DisassembleForeachInfo( - ClientData clientData, - Tcl_Obj *dictObj, - TCL_UNUSED(ByteCode *), - TCL_UNUSED(unsigned int)) -{ - ForeachInfo *infoPtr = (ForeachInfo *)clientData; - ForeachVarList *varsPtr; - int i, j; - Tcl_Obj *objPtr, *innerPtr; - - /* - * Data stores. - */ - - TclNewObj(objPtr); - for (i=0 ; inumLists ; i++) { - Tcl_ListObjAppendElement(NULL, objPtr, - Tcl_NewWideIntObj(infoPtr->firstValueTemp + i)); - } - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("data", -1), objPtr); - - /* - * Loop counter. - */ - - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("loop", -1), - Tcl_NewWideIntObj(infoPtr->loopCtTemp)); - - /* - * Assignment targets. - */ - - TclNewObj(objPtr); - for (i=0 ; inumLists ; i++) { - TclNewObj(innerPtr); - varsPtr = infoPtr->varLists[i]; - for (j=0 ; jnumVars ; j++) { - Tcl_ListObjAppendElement(NULL, innerPtr, - Tcl_NewWideIntObj(varsPtr->varIndexes[j])); - } - Tcl_ListObjAppendElement(NULL, objPtr, innerPtr); - } - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr); -} - -static void -DisassembleNewForeachInfo( - ClientData clientData, - Tcl_Obj *dictObj, - TCL_UNUSED(ByteCode *), - TCL_UNUSED(unsigned int)) -{ - ForeachInfo *infoPtr = (ForeachInfo *)clientData; - ForeachVarList *varsPtr; - int i, j; - Tcl_Obj *objPtr, *innerPtr; - - /* - * Jump offset. - */ - - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("jumpOffset", -1), - Tcl_NewWideIntObj(infoPtr->loopCtTemp)); - - /* - * Assignment targets. - */ - - TclNewObj(objPtr); - for (i=0 ; inumLists ; i++) { - TclNewObj(innerPtr); - varsPtr = infoPtr->varLists[i]; - for (j=0 ; jnumVars ; j++) { - Tcl_ListObjAppendElement(NULL, innerPtr, - Tcl_NewWideIntObj(varsPtr->varIndexes[j])); - } - Tcl_ListObjAppendElement(NULL, objPtr, innerPtr); - } - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr); -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileFormatCmd -- - * - * Procedure called to compile the "format" command. Handles cases that - * can be done as constants or simple string concatenation only. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "format" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -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; - size_t len; - - /* - * Don't handle any guaranteed-error cases. - */ - - if (parsePtr->numWords < 2) { - return TCL_ERROR; - } - - /* - * Check if the argument words are all compile-time-known literals; that's - * a case we can handle by compiling to a constant. - */ - - TclNewObj(formatObj); - Tcl_IncrRefCount(formatObj); - tokenPtr = TokenAfter(tokenPtr); - if (!TclWordKnownAtCompileTime(tokenPtr, formatObj)) { - Tcl_DecrRefCount(formatObj); - return TCL_ERROR; - } - - objv = (Tcl_Obj **)Tcl_Alloc((parsePtr->numWords-2) * sizeof(Tcl_Obj *)); - for (i=0 ; i+2 < parsePtr->numWords ; i++) { - tokenPtr = TokenAfter(tokenPtr); - TclNewObj(objv[i]); - Tcl_IncrRefCount(objv[i]); - if (!TclWordKnownAtCompileTime(tokenPtr, objv[i])) { - goto checkForStringConcatCase; - } - } - - /* - * 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, TclGetString(formatObj), - parsePtr->numWords-2, objv); - for (; --i>=0 ;) { - Tcl_DecrRefCount(objv[i]); - } - Tcl_Free(objv); - Tcl_DecrRefCount(formatObj); - if (tmpObj == NULL) { - TclCompileSyntaxError(interp, envPtr); - return TCL_OK; - } - - /* - * Not an error, always a constant result, so just push the result as a - * literal. Job done. - */ - - bytes = TclGetStringFromObj(tmpObj, &len); - PushLiteral(envPtr, bytes, len); - Tcl_DecrRefCount(tmpObj); - return TCL_OK; - - checkForStringConcatCase: - /* - * See if we can generate a sequence of things to concatenate. This - * requires that all the % sequences be %s or %%, as everything else is - * sufficiently complex that we don't bother. - * - * 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]); - } - Tcl_Free(objv); - tokenPtr = TokenAfter(parsePtr->tokenPtr); - tokenPtr = TokenAfter(tokenPtr); - i = 0; - - /* - * Now scan through and check for non-%s and non-%% substitutions. - */ - - for (bytes = TclGetString(formatObj) ; *bytes ; bytes++) { - if (*bytes == '%') { - bytes++; - if (*bytes == 's') { - i++; - continue; - } else if (*bytes == '%') { - continue; - } - Tcl_DecrRefCount(formatObj); - return TCL_ERROR; - } - } - - /* - * Check if the number of things to concatenate will fit in a byte. - */ - - if (i+2 != parsePtr->numWords || i > 125) { - Tcl_DecrRefCount(formatObj); - return TCL_ERROR; - } - - /* - * Generate the pushes of the things to concatenate, a sequence of - * literals and compiled tokens (of which at least one is non-literal or - * 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 = TclGetString(formatObj); - /* The start of the currently-scanned literal - * in the format string. */ - TclNewObj(tmpObj); /* The buffer used to accumulate the literal - * being built. */ - for (bytes = start ; *bytes ; bytes++) { - if (*bytes == '%') { - Tcl_AppendToObj(tmpObj, start, bytes - start); - if (*++bytes == '%') { - Tcl_AppendToObj(tmpObj, "%", 1); - } else { - const char *b = TclGetStringFromObj(tmpObj, &len); - - /* - * If there is a non-empty literal from the format string, - * push it and reset. - */ - - if (len > 0) { - PushLiteral(envPtr, b, len); - Tcl_DecrRefCount(tmpObj); - TclNewObj(tmpObj); - i++; - } - - /* - * Push the code to produce the string that would be - * substituted with %s, except we'll be concatenating - * directly. - */ - - CompileWord(envPtr, tokenPtr, interp, j); - tokenPtr = TokenAfter(tokenPtr); - j++; - i++; - } - start = bytes + 1; - } - } - - /* - * Handle the case of a trailing literal. - */ - - Tcl_AppendToObj(tmpObj, start, bytes - start); - bytes = TclGetStringFromObj(tmpObj, &len); - if (len > 0) { - PushLiteral(envPtr, bytes, len); - i++; - } - Tcl_DecrRefCount(tmpObj); - Tcl_DecrRefCount(formatObj); - - if (i > 1) { - /* - * Do the concatenation, which produces the result. - */ - - TclEmitInstInt1(INST_STR_CONCAT1, i, envPtr); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclLocalScalarFromToken -- + +/* + *---------------------------------------------------------------------- + * + * TclCompileIfCmd -- + * + * Procedure called to compile the "if" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "if" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileIfCmd( + 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. */ +{ + 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 savedStackDepth = envPtr->currStackDepth; + /* Saved stack depth at the start of the first + * test; the envPtr current depth is restored + * to this value at the start of each test. */ + int realCond = 1; /* Set to 0 for static conditions: + * "if 0 {..}" */ + int boolVal; /* Value of static condition. */ + int compileScripts = 1; + DefineLineInformation; /* TIP #280 */ + + /* + * Only compile the "if" command if all arguments are simple words, in + * order to insure correct substitution [Bug 219166] + */ + + tokenPtr = parsePtr->tokenPtr; + wordIdx = 0; + numWords = parsePtr->numWords; + + for (wordIdx = 0; wordIdx < numWords; wordIdx++) { + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(tokenPtr); + } + + TclInitJumpFixupArray(&jumpFalseFixupArray); + TclInitJumpFixupArray(&jumpEndFixupArray); + code = TCL_OK; + + /* + * Each iteration of this loop compiles one "if expr ?then? body" or + * "elseif expr ?then? body" clause. + */ + + tokenPtr = parsePtr->tokenPtr; + wordIdx = 0; + while (wordIdx < numWords) { + /* + * Stop looping if the token isn't "if" or "elseif". + */ + + word = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + if ((tokenPtr == parsePtr->tokenPtr) + || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) { + tokenPtr = TokenAfter(tokenPtr); + wordIdx++; + } else { + break; + } + if (wordIdx >= numWords) { + code = TCL_ERROR; + goto done; + } + + /* + * Compile the test expression then emit the conditional jump around + * the "then" part. + */ + + envPtr->currStackDepth = savedStackDepth; + testTokenPtr = tokenPtr; + + if (realCond) { + /* + * Find out if the condition is a constant. + */ + + Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start, + testTokenPtr[1].size); + Tcl_IncrRefCount(boolObj); + code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal); + TclDecrRefCount(boolObj); + if (code == TCL_OK) { + /* + * A static condition. + */ + + realCond = 0; + if (!boolVal) { + compileScripts = 0; + } + } else { + SetLineInformation (wordIdx); + Tcl_ResetResult(interp); + TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { + TclExpandJumpFixupArray(&jumpFalseFixupArray); + } + jumpIndex = jumpFalseFixupArray.next; + jumpFalseFixupArray.next++; + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, + jumpFalseFixupArray.fixup+jumpIndex); + } + code = TCL_OK; + } + + /* + * Skip over the optional "then" before the then clause. + */ + + tokenPtr = TokenAfter(testTokenPtr); + wordIdx++; + if (wordIdx >= numWords) { + code = TCL_ERROR; + goto done; + } + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + word = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) { + tokenPtr = TokenAfter(tokenPtr); + wordIdx++; + if (wordIdx >= numWords) { + code = TCL_ERROR; + goto done; + } + } + } + + /* + * Compile the "then" command body. + */ + + if (compileScripts) { + SetLineInformation (wordIdx); + envPtr->currStackDepth = savedStackDepth; + CompileBody(envPtr, tokenPtr, interp); + } + + if (realCond) { + /* + * Jump to the end of the "if" command. Both jumpFalseFixupArray + * and jumpEndFixupArray are indexed by "jumpIndex". + */ + + if (jumpEndFixupArray.next >= jumpEndFixupArray.end) { + TclExpandJumpFixupArray(&jumpEndFixupArray); + } + jumpEndFixupArray.next++; + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, + jumpEndFixupArray.fixup+jumpIndex); + + /* + * Fix the target of the jumpFalse after the test. Generate a 4 + * byte jump if the distance is > 120 bytes. This is conservative, + * and ensures that we won't have to replace this jump if we later + * also need to replace the proceeding jump to the end of the "if" + * with a 4 byte jump. + */ + + if (TclFixupForwardJumpToHere(envPtr, + jumpFalseFixupArray.fixup+jumpIndex, 120)) { + /* + * Adjust the code offset for the proceeding jump to the end + * of the "if" command. + */ + + jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3; + } + } else if (boolVal) { + /* + * We were processing an "if 1 {...}"; stop compiling scripts. + */ + + compileScripts = 0; + } else { + /* + * We were processing an "if 0 {...}"; reset so that the rest + * (elseif, else) is compiled correctly. + */ + + realCond = 1; + compileScripts = 1; + } + + tokenPtr = TokenAfter(tokenPtr); + wordIdx++; + } + + /* + * Restore the current stack depth in the environment; the "else" clause + * (or its default) will add 1 to this. + */ + + envPtr->currStackDepth = savedStackDepth; + + /* + * Check for the optional else clause. Do not compile anything if this was + * an "if 1 {...}" case. + */ + + if ((wordIdx < numWords) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { + /* + * There is an else clause. Skip over the optional "else" word. + */ + + word = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) { + tokenPtr = TokenAfter(tokenPtr); + wordIdx++; + if (wordIdx >= numWords) { + code = TCL_ERROR; + goto done; + } + } + + if (compileScripts) { + /* + * Compile the else command body. + */ + + SetLineInformation (wordIdx); + CompileBody(envPtr, tokenPtr, interp); + } + + /* + * Make sure there are no words after the else clause. + */ + + wordIdx++; + if (wordIdx < numWords) { + code = TCL_ERROR; + goto done; + } + } else { + /* + * No else clause: the "if" command's result is an empty string. + */ + + if (compileScripts) { + PushLiteral(envPtr, "", 0); + } + } + + /* + * Fix the unconditional jumps to the end of the "if" command. + */ + + for (j = jumpEndFixupArray.next; j > 0; j--) { + jumpIndex = (j - 1); /* i.e. process the closest jump first. */ + if (TclFixupForwardJumpToHere(envPtr, + jumpEndFixupArray.fixup+jumpIndex, 127)) { + /* + * Adjust the immediately preceeding "ifFalse" jump. We moved it's + * target (just after this jump) down three bytes. + */ + + unsigned char *ifFalsePc = envPtr->codeStart + + jumpFalseFixupArray.fixup[jumpIndex].codeOffset; + unsigned char opCode = *ifFalsePc; + + if (opCode == INST_JUMP_FALSE1) { + jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1); + jumpFalseDist += 3; + TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1)); + } else if (opCode == INST_JUMP_FALSE4) { + jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1); + jumpFalseDist += 3; + TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1)); + } else { + Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode); + } + } + } + + /* + * Free the jumpFixupArray array if malloc'ed storage was used. + */ + + done: + envPtr->currStackDepth = savedStackDepth + 1; + TclFreeJumpFixupArray(&jumpFalseFixupArray); + TclFreeJumpFixupArray(&jumpEndFixupArray); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileIncrCmd -- + * + * Procedure called to compile the "incr" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "incr" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileIncrCmd( + 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, *incrTokenPtr; + int simpleVarName, isScalar, localIndex, haveImmValue, immValue; + DefineLineInformation; /* TIP #280 */ + + if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { + return TCL_ERROR; + } + + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + + PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX|TCL_CREATE_VAR, + &localIndex, &simpleVarName, &isScalar, 1); + + /* + * If an increment is given, push it, but see first if it's a small + * integer. + */ + + 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)) { + haveImmValue = 1; + } + if (!haveImmValue) { + PushLiteral(envPtr, word, numBytes); + } + } else { + SetLineInformation (2); + CompileTokens(envPtr, incrTokenPtr, interp); + } + } else { /* No incr amount given so use 1. */ + haveImmValue = 1; + } + + /* + * Emit the instruction to increment the variable. + */ + + if (simpleVarName) { + if (isScalar) { + if (localIndex >= 0) { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr); + TclEmitInt1(immValue, envPtr); + } else { + TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr); + } + } else { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, envPtr); + } else { + TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr); + } + } + } else { + if (localIndex >= 0) { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr); + TclEmitInt1(immValue, envPtr); + } else { + TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr); + } + } else { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr); + } else { + TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr); + } + } + } + } else { /* Non-simple variable name. */ + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr); + } else { + TclEmitOpcode(INST_INCR_STK, envPtr); + } + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLappendCmd -- + * + * Procedure called to compile the "lappend" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "lappend" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLappendCmd( + 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; + int simpleVarName, isScalar, localIndex, numWords; + DefineLineInformation; /* TIP #280 */ + + /* + * If we're not in a procedure, don't compile. + */ + + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + + numWords = parsePtr->numWords; + if (numWords == 1) { + return TCL_ERROR; + } + if (numWords != 3) { + /* + * LAPPEND instructions currently only handle one value appends. + */ + + return TCL_ERROR; + } + + /* + * Decide if we can use a frame slot for the var/array name or if we + * need to emit code to compute and push the name at runtime. We use a + * frame slot (entry in the array of local vars) if we are compiling a + * procedure body and if the name is simple text that does not include + * namespace qualifiers. + */ + + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + + PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, + &localIndex, &simpleVarName, &isScalar, 1); + + /* + * If we are doing an assignment, push the new value. In the no values + * case, create an empty object. + */ + + if (numWords > 2) { + Tcl_Token *valueTokenPtr = TokenAfter(varTokenPtr); + CompileWord(envPtr, valueTokenPtr, interp, 2); + } + + /* + * Emit instructions to set/get the variable. + */ + + /* + * The *_STK opcodes should be refactored to make better use of existing + * LOAD/STORE instructions. + */ + + if (simpleVarName) { + if (isScalar) { + if (localIndex < 0) { + TclEmitOpcode(INST_LAPPEND_STK, envPtr); + } else if (localIndex <= 255) { + TclEmitInstInt1(INST_LAPPEND_SCALAR1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_LAPPEND_SCALAR4, localIndex, envPtr); + } + } else { + if (localIndex < 0) { + TclEmitOpcode(INST_LAPPEND_ARRAY_STK, envPtr); + } else if (localIndex <= 255) { + TclEmitInstInt1(INST_LAPPEND_ARRAY1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_LAPPEND_ARRAY4, localIndex, envPtr); + } + } + } else { + TclEmitOpcode(INST_LAPPEND_STK, envPtr); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLassignCmd -- + * + * Procedure called to compile the "lassign" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "lassign" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLassignCmd( + 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; + int simpleVarName, isScalar, localIndex, numWords, idx; + DefineLineInformation; /* TIP #280 */ + + numWords = parsePtr->numWords; + + /* + * Check for command syntax error, but we'll punt that to runtime. + */ + + if (numWords < 3) { + return TCL_ERROR; + } + + /* + * Generate code to push list being taken apart by [lassign]. + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + + /* + * Generate code to assign values from the list to variables. + */ + + for (idx=0 ; idx= 0) { + TclEmitOpcode(INST_DUP, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + if (localIndex <= 255) { + TclEmitInstInt1(INST_STORE_SCALAR1,localIndex,envPtr); + } else { + TclEmitInstInt4(INST_STORE_SCALAR4,localIndex,envPtr); + } + } else { + TclEmitInstInt4(INST_OVER, 1, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + TclEmitOpcode(INST_STORE_SCALAR_STK, envPtr); + } + } else { + if (localIndex >= 0) { + TclEmitInstInt4(INST_OVER, 1, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + if (localIndex <= 255) { + TclEmitInstInt1(INST_STORE_ARRAY1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_STORE_ARRAY4, localIndex, envPtr); + } + } else { + TclEmitInstInt4(INST_OVER, 2, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + TclEmitOpcode(INST_STORE_ARRAY_STK, envPtr); + } + } + } else { + TclEmitInstInt4(INST_OVER, 1, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + TclEmitOpcode(INST_STORE_STK, envPtr); + } + TclEmitOpcode(INST_POP, envPtr); + } + + /* + * Generate code to leave the rest of the list on the stack. + */ + + TclEmitInstInt4(INST_LIST_RANGE_IMM, idx, envPtr); + TclEmitInt4(-2, envPtr); /* -2 == "end" */ + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLindexCmd -- + * + * Procedure called to compile the "lindex" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "lindex" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLindexCmd( + 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 *idxTokenPtr, *valTokenPtr; + int i, numWords = parsePtr->numWords; + DefineLineInformation; /* TIP #280 */ + + /* + * Quit if too few args. + */ + + if (numWords <= 1) { + return TCL_ERROR; + } + + valTokenPtr = TokenAfter(parsePtr->tokenPtr); + if (numWords != 3) { + goto emitComplexLindex; + } + + idxTokenPtr = TokenAfter(valTokenPtr); + if (idxTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + Tcl_Obj *tmpObj; + int idx, result; + + tmpObj = Tcl_NewStringObj(idxTokenPtr[1].start, idxTokenPtr[1].size); + result = TclGetIntFromObj(NULL, tmpObj, &idx); + TclDecrRefCount(tmpObj); + + if (result == TCL_OK && idx >= 0) { + /* + * All checks have been completed, and we have exactly this + * construct: + * lindex + * This is best compiled as a push of the arbitrary value followed + * by an "immediate lindex" which is the most efficient variety. + */ + + CompileWord(envPtr, valTokenPtr, interp, 1); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + return TCL_OK; + } + + /* + * If the conversion failed or the value was negative, we just keep on + * going with the more complex compilation. + */ + } + + /* + * Push the operands onto the stack. + */ + + emitComplexLindex: + for (i=1 ; iprocPtr == NULL) { + return TCL_ERROR; + } + + if (parsePtr->numWords == 1) { + /* + * [list] without arguments just pushes an empty object. + */ + + PushLiteral(envPtr, "", 0); + } else { + /* + * Push the all values onto the stack. + */ + + Tcl_Token *valueTokenPtr; + int i, numWords; + + numWords = parsePtr->numWords; + + valueTokenPtr = TokenAfter(parsePtr->tokenPtr); + for (i = 1; i < numWords; i++) { + CompileWord(envPtr, valueTokenPtr, interp, i); + valueTokenPtr = TokenAfter(valueTokenPtr); + } + TclEmitInstInt4(INST_LIST, numWords - 1, envPtr); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLlengthCmd -- + * + * Procedure called to compile the "llength" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "llength" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLlengthCmd( + 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; + DefineLineInformation; /* TIP #280 */ + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + + CompileWord(envPtr, varTokenPtr, interp, 1); + TclEmitOpcode(INST_LIST_LENGTH, envPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLsetCmd -- + * + * Procedure called to compile the "lset" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "lset" command at + * runtime. + * + * The general template for execution of the "lset" command is: + * (1) Instructions to push the variable name, unless the variable is + * local to the stack frame. + * (2) If the variable is an array element, instructions to push the + * array element name. + * (3) Instructions to push each of zero or more "index" arguments to the + * stack, followed with the "newValue" element. + * (4) Instructions to duplicate the variable name and/or array element + * name onto the top of the stack, if either was pushed at steps (1) + * and (2). + * (5) The appropriate INST_LOAD_* instruction to place the original + * value of the list variable at top of stack. + * (6) At this point, the stack contains: + * varName? arrayElementName? index1 index2 ... newValue oldList + * The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST + * according as whether there is exactly one index element (LIST) or + * either zero or else two or more (FLAT). This instruction removes + * everything from the stack except for the two names and pushes the + * new value of the variable. + * (7) Finally, INST_STORE_* stores the new value in the variable and + * cleans up the stack. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLsetCmd( + Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the + * command. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds the resulting instructions. */ +{ + 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 simpleVarName; /* Flag == 1 if var name is simple. */ + int isScalar; /* Flag == 1 if scalar, 0 if array. */ + int i; + DefineLineInformation; /* TIP #280 */ + + /* + * Check argument count. + */ + + if (parsePtr->numWords < 3) { + /* + * Fail at run time, not in compilation. + */ + + return TCL_ERROR; + } + + /* + * Decide if we can use a frame slot for the var/array name or if we need + * to emit code to compute and push the name at runtime. We use a frame + * slot (entry in the array of local vars) if we are compiling a procedure + * body and if the name is simple text that does not include namespace + * qualifiers. + */ + + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, + &localIndex, &simpleVarName, &isScalar, 1); + + /* + * Push the "index" args and the new element value. + */ + + for (i=2 ; inumWords ; ++i) { + varTokenPtr = TokenAfter(varTokenPtr); + CompileWord(envPtr, varTokenPtr, interp, i); + } + + /* + * Duplicate the variable name if it's been pushed. + */ + + if (!simpleVarName || localIndex < 0) { + if (!simpleVarName || isScalar) { + tempDepth = parsePtr->numWords - 2; + } else { + tempDepth = parsePtr->numWords - 1; + } + TclEmitInstInt4(INST_OVER, tempDepth, envPtr); + } + + /* + * Duplicate an array index if one's been pushed. + */ + + if (simpleVarName && !isScalar) { + if (localIndex < 0) { + tempDepth = parsePtr->numWords - 1; + } else { + tempDepth = parsePtr->numWords - 2; + } + TclEmitInstInt4(INST_OVER, tempDepth, envPtr); + } + + /* + * Emit code to load the variable's value. + */ + + if (!simpleVarName) { + TclEmitOpcode(INST_LOAD_STK, envPtr); + } else if (isScalar) { + if (localIndex < 0) { + TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); + } else if (localIndex < 0x100) { + TclEmitInstInt1(INST_LOAD_SCALAR1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_LOAD_SCALAR4, localIndex, envPtr); + } + } else { + if (localIndex < 0) { + TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); + } else if (localIndex < 0x100) { + TclEmitInstInt1(INST_LOAD_ARRAY1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_LOAD_ARRAY4, localIndex, envPtr); + } + } + + /* + * Emit the correct variety of 'lset' instruction. + */ + + if (parsePtr->numWords == 4) { + TclEmitOpcode(INST_LSET_LIST, envPtr); + } else { + TclEmitInstInt4(INST_LSET_FLAT, parsePtr->numWords-1, envPtr); + } + + /* + * Emit code to put the value back in the variable. + */ + + if (!simpleVarName) { + TclEmitOpcode(INST_STORE_STK, envPtr); + } else if (isScalar) { + if (localIndex < 0) { + TclEmitOpcode(INST_STORE_SCALAR_STK, envPtr); + } else if (localIndex < 0x100) { + TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr); + } + } else { + if (localIndex < 0) { + TclEmitOpcode(INST_STORE_ARRAY_STK, envPtr); + } else if (localIndex < 0x100) { + TclEmitInstInt1(INST_STORE_ARRAY1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_STORE_ARRAY4, localIndex, envPtr); + } + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileRegexpCmd -- + * + * Procedure called to compile the "regexp" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "regexp" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileRegexpCmd( + Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the + * command. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds the resulting instructions. */ +{ + Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the + * parse of the RE or string. */ + int i, len, nocase, exact, sawLast, simple; + char *str; + DefineLineInformation; /* TIP #280 */ + + /* + * We are only interested in compiling simple regexp cases. Currently + * supported compile cases are: + * regexp ?-nocase? ?--? staticString $var + * regexp ?-nocase? ?--? {^staticString$} $var + */ + + if (parsePtr->numWords < 3) { + return TCL_ERROR; + } + + simple = 0; + nocase = 0; + sawLast = 0; + varTokenPtr = parsePtr->tokenPtr; + + /* + * We only look for -nocase and -- as options. Everything else gets pushed + * to runtime execution. This is different than regexp's runtime option + * handling, but satisfies our stricter needs. + */ + + for (i = 1; i < parsePtr->numWords - 2; i++) { + varTokenPtr = TokenAfter(varTokenPtr); + if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + /* + * Not a simple string, so punt to runtime. + */ + + return TCL_ERROR; + } + str = (char *) varTokenPtr[1].start; + len = varTokenPtr[1].size; + if ((len == 2) && (str[0] == '-') && (str[1] == '-')) { + sawLast++; + i++; + break; + } else if ((len > 1) && (strncmp(str,"-nocase",(unsigned)len) == 0)) { + nocase = 1; + } else { + /* + * Not an option we recognize. + */ + + return TCL_ERROR; + } + } + + if ((parsePtr->numWords - i) != 2) { + /* + * We don't support capturing to variables. + */ + + return TCL_ERROR; + } + + /* + * Get the regexp string. If it is not a simple string or can't be + * converted to a glob pattern, push the word for the INST_REGEXP. + * Keep changes here in sync with TclCompileSwitchCmd Switch_Regexp. + */ + + varTokenPtr = TokenAfter(varTokenPtr); + + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + Tcl_DString ds; + + str = (char *) varTokenPtr[1].start; + len = varTokenPtr[1].size; + /* + * If it has a '-', it could be an incorrectly formed regexp command. + */ + + if ((*str == '-') && !sawLast) { + return TCL_ERROR; + } + + if (len == 0) { + /* + * The semantics of regexp are always match on re == "". + */ + + PushLiteral(envPtr, "1", 1); + return TCL_OK; + } + + /* + * Attempt to convert pattern to glob. If successful, push the + * converted pattern as a literal. + */ + + if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact) + == TCL_OK) { + simple = 1; + PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + } + } + + if (!simple) { + CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-2); + } + + /* + * Push the string arg. + */ + + varTokenPtr = TokenAfter(varTokenPtr); + CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-1); + + if (simple) { + if (exact && !nocase) { + TclEmitOpcode(INST_STR_EQ, envPtr); + } else { + TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr); + } + } else { + /* + * Pass correct RE compile flags. We use only Int1 (8-bit), but + * that handles all the flags we want to pass. + * Don't use TCL_REG_NOSUB as we may have backrefs. + */ + int cflags = TCL_REG_ADVANCED | (nocase ? TCL_REG_NOCASE : 0); + TclEmitInstInt1(INST_REGEXP, cflags, envPtr); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileReturnCmd -- + * + * Procedure called to compile the "return" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "return" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileReturnCmd( + 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. */ +{ + /* + * 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); + DefineLineInformation; /* TIP #280 */ + + /* + * Check for special case which can always be compiled: + * return -options + * 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 + * ('finally' clause processing) this piece of code would not be present. + */ + + if ((numWords == 4) && (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) + && (wordTokenPtr[1].size == 8) + && (strncmp(wordTokenPtr[1].start, "-options", 8) == 0)) { + Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr); + Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr); + + CompileWord(envPtr, optsTokenPtr, interp, 2); + CompileWord(envPtr, msgTokenPtr, interp, 3); + TclEmitOpcode(INST_RETURN_STK, envPtr); + 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. + */ + + for (objc = 0; objc < numOptionWords; objc++) { + objv[objc] = Tcl_NewObj(); + Tcl_IncrRefCount(objv[objc]); + if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { + objc++; + status = TCL_ERROR; + goto cleanup; + } + wordTokenPtr = TokenAfter(wordTokenPtr); + } + status = TclMergeReturnOptions(interp, objc, objv, + &returnOpts, &code, &level); + cleanup: + while (--objc >= 0) { + TclDecrRefCount(objv[objc]); + } + TclStackFree(interp, objv); + if (TCL_ERROR == status) { + /* + * Something was bogus in the return options. Clear the error message, + * and report back to the compiler that this must be interpreted at + * runtime. + */ + + Tcl_ResetResult(interp); + return TCL_ERROR; + } + + /* + * All options are known at compile time, so we're going to bytecompile. + * Emit instructions to push the result on the stack. + */ + + if (explicitResult) { + CompileWord(envPtr, wordTokenPtr, interp, numWords-1); + } else { + /* + * No explict result argument, so default result is empty string. + */ + + PushLiteral(envPtr, "", 0); + } + + /* + * Check for optimization: When [return] is in a proc, and there's no + * enclosing [catch], and there are no return options, then the INST_DONE + * instruction is equivalent, and may be more efficient. + */ + + if (numOptionWords == 0 && envPtr->procPtr != NULL) { + /* + * We have default return options and we're in a proc ... + */ + + int index = envPtr->exceptArrayNext - 1; + int enclosingCatch = 0; + + while (index >= 0) { + ExceptionRange range = envPtr->exceptArrayPtr[index]; + if ((range.type == CATCH_EXCEPTION_RANGE) + && (range.catchOffset == -1)) { + enclosingCatch = 1; + break; + } + index--; + } + if (!enclosingCatch) { + /* + * ... and there is no enclosing catch. Issue the maximally + * efficient exit instruction. + */ + + Tcl_DecrRefCount(returnOpts); + TclEmitOpcode(INST_DONE, envPtr); + return TCL_OK; + } + } + + /* Optimize [return -level 0 $x]. */ + Tcl_DictObjSize(NULL, returnOpts, &size); + if (size == 0 && level == 0 && code == TCL_OK) { + Tcl_DecrRefCount(returnOpts); + return TCL_OK; + } + + /* + * Could not use the optimization, so we push the return options dict, and + * emit the INST_RETURN_IMM instruction with code and level as operands. + */ + + CompileReturnInternal(envPtr, INST_RETURN_IMM, code, level, returnOpts); + return TCL_OK; +} + +static void +CompileReturnInternal( + CompileEnv *envPtr, + unsigned char op, + int code, + int level, + Tcl_Obj *returnOpts) +{ + TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr); + TclEmitInstInt4(op, code, envPtr); + TclEmitInt4(level, envPtr); +} + +void +TclCompileSyntaxError( + Tcl_Interp *interp, + CompileEnv *envPtr) +{ + Tcl_Obj *msg = Tcl_GetObjResult(interp); + int numBytes; + const char *bytes = TclGetStringFromObj(msg, &numBytes); + + TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr); + CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0, + Tcl_GetReturnOptions(interp, TCL_ERROR)); +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileSetCmd -- + * + * Procedure called to compile the "set" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "set" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileSetCmd( + 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 isAssignment, isScalar, simpleVarName, localIndex, numWords; + DefineLineInformation; /* TIP #280 */ + + numWords = parsePtr->numWords; + if ((numWords != 2) && (numWords != 3)) { + return TCL_ERROR; + } + isAssignment = (numWords == 3); + + /* + * Decide if we can use a frame slot for the var/array name or if we need + * to emit code to compute and push the name at runtime. We use a frame + * slot (entry in the array of local vars) if we are compiling a procedure + * body and if the name is simple text that does not include namespace + * qualifiers. + */ + + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, + &localIndex, &simpleVarName, &isScalar, 1); + + /* + * If we are doing an assignment, push the new value. + */ + + if (isAssignment) { + valueTokenPtr = TokenAfter(varTokenPtr); + CompileWord(envPtr, valueTokenPtr, interp, 2); + } + + /* + * Emit instructions to set/get the variable. + */ + + if (simpleVarName) { + if (isScalar) { + if (localIndex < 0) { + TclEmitOpcode((isAssignment? + INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), envPtr); + } else if (localIndex <= 255) { + TclEmitInstInt1((isAssignment? + INST_STORE_SCALAR1 : INST_LOAD_SCALAR1), + localIndex, envPtr); + } else { + TclEmitInstInt4((isAssignment? + INST_STORE_SCALAR4 : INST_LOAD_SCALAR4), + localIndex, envPtr); + } + } else { + if (localIndex < 0) { + TclEmitOpcode((isAssignment? + INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr); + } else if (localIndex <= 255) { + TclEmitInstInt1((isAssignment? + INST_STORE_ARRAY1 : INST_LOAD_ARRAY1), + localIndex, envPtr); + } else { + TclEmitInstInt4((isAssignment? + INST_STORE_ARRAY4 : INST_LOAD_ARRAY4), + localIndex, envPtr); + } + } + } else { + TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileStringCmpCmd -- + * + * Procedure called to compile the simplest and most common form of the + * "string compare" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "string compare" + * command at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileStringCmpCmd( + 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 *tokenPtr; + + /* + * We don't support any flags; the bytecode isn't that sophisticated. + */ + + if (parsePtr->numWords != 3) { + return TCL_ERROR; + } + + /* + * Push the two operands onto the stack and then the test. + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 2); + TclEmitOpcode(INST_STR_CMP, envPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileStringEqualCmd -- + * + * Procedure called to compile the simplest and most common form of the + * "string equal" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "string equal" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileStringEqualCmd( + 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 *tokenPtr; + + /* + * We don't support any flags; the bytecode isn't that sophisticated. + */ + + if (parsePtr->numWords != 3) { + return TCL_ERROR; + } + + /* + * Push the two operands onto the stack and then the test. + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 2); + TclEmitOpcode(INST_STR_EQ, envPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileStringIndexCmd -- + * + * Procedure called to compile the simplest and most common form of the + * "string index" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "string index" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileStringIndexCmd( + 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 *tokenPtr; + + if (parsePtr->numWords != 3) { + return TCL_ERROR; + } + + /* + * Push the two operands onto the stack and then the index operation. + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 2); + TclEmitOpcode(INST_STR_INDEX, envPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileStringMatchCmd -- + * + * Procedure called to compile the simplest and most common form of the + * "string match" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "string match" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileStringMatchCmd( + 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 *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); + + /* + * Check if we have a -nocase flag. + */ + + if (parsePtr->numWords == 4) { + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + str = tokenPtr[1].start; + length = tokenPtr[1].size; + if ((length <= 1) || strncmp(str, "-nocase", (size_t) length)) { + /* + * Fail at run time, not in compilation. + */ + + return TCL_ERROR; + } + nocase = 1; + tokenPtr = TokenAfter(tokenPtr); + } + + /* + * Push the strings to match against each other. + */ + + for (i = 0; i < 2; i++) { + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + str = tokenPtr[1].start; + length = tokenPtr[1].size; + if (!nocase && (i == 0)) { + /* + * Trivial matches can be done by 'string equal'. If -nocase + * was specified, we can't do this because INST_STR_EQ has no + * support for nocase. + */ + + Tcl_Obj *copy = Tcl_NewStringObj(str, length); + + Tcl_IncrRefCount(copy); + exactMatch = TclMatchIsTrivial(TclGetString(copy)); + TclDecrRefCount(copy); + } + PushLiteral(envPtr, str, length); + } else { + SetLineInformation (i+1+nocase); + CompileTokens(envPtr, tokenPtr, interp); + } + tokenPtr = TokenAfter(tokenPtr); + } + + /* + * Push the matcher. + */ + + if (exactMatch) { + TclEmitOpcode(INST_STR_EQ, envPtr); + } else { + TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileStringLenCmd -- + * + * Procedure called to compile the simplest and most common form of the + * "string length" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "string length" + * command at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileStringLenCmd( + 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 *tokenPtr; + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + /* + * Here someone is asking for the length of a static string. Just push + * the actual character (not byte) length. + */ + + char buf[TCL_INTEGER_SPACE]; + int len = Tcl_NumUtfChars(tokenPtr[1].start, tokenPtr[1].size); + + len = sprintf(buf, "%d", len); + PushLiteral(envPtr, buf, len); + } else { + SetLineInformation (1); + CompileTokens(envPtr, tokenPtr, interp); + TclEmitOpcode(INST_STR_LEN, envPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileSwitchCmd -- + * + * Procedure called to compile the "switch" command. + * + * Results: + * Returns TCL_OK for successful compile, or TCL_ERROR to defer + * evaluation to runtime (either when it is too complex to get the + * semantics right, or when we know for sure that it is an error but need + * the error to happen at the right time). + * + * Side effects: + * Instructions are added to envPtr to execute the "switch" command at + * runtime. + * + * FIXME: + * Stack depths are probably not calculated correctly. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileSwitchCmd( + 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; /* 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** bodyNext; + int foundDefault; /* Flag to indicate whether a "default" clause + * is present. */ + + JumpFixup *fixupArray; /* Array of forward-jump fixup records. */ + int *fixupTargetArray; /* Array of places for fixups to point at. */ + int fixupCount; /* Number of places to fix up. */ + int contFixIndex; /* Where the first of the jumps due to a group + * of continuation bodies starts, or -1 if + * there aren't any. */ + int contFixCount; /* Number of continuation bodies pointing to + * the current (or next) real body. */ + + int savedStackDepth = envPtr->currStackDepth; + int noCase; /* Has the -nocase flag been given? */ + int foundMode = 0; /* Have we seen a mode flag yet? */ + int i, valueIndex; + DefineLineInformation; /* TIP #280 */ + int* clNext = envPtr->clNext; + + /* + * Only handle the following versions: + * switch ?--? word {pattern body ...} + * switch -exact ?--? word {pattern body ...} + * switch -glob ?--? word {pattern body ...} + * switch -regexp ?--? word {pattern body ...} + * switch -- word simpleWordPattern simpleWordBody ... + * switch -exact -- word simpleWordPattern simpleWordBody ... + * switch -glob -- word simpleWordPattern simpleWordBody ... + * switch -regexp -- word simpleWordPattern simpleWordBody ... + * When the mode is -glob, can also handle a -nocase flag. + * + * First off, we don't care how the command's word was generated; we're + * compiling it anyway! So skip it... + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + valueIndex = 1; + numWords = parsePtr->numWords-1; + + /* + * Check for options. + */ + + noCase = 0; + mode = Switch_Exact; + if (numWords == 2) { + /* + * There's just the switch value and the bodies list. In that case, we + * can skip all option parsing and move on to consider switch values + * and the body list. + */ + + goto finishedOptionParse; + } + + /* + * There must be at least one option, --, because without that there is no + * 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--) { + register unsigned size = tokenPtr[1].size; + register 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). + */ + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || size < 2) { + return TCL_ERROR; + } + + if ((size <= 6) && !memcmp(chrs, "-exact", size)) { + if (foundMode) { + return TCL_ERROR; + } + mode = Switch_Exact; + foundMode = 1; + valueIndex++; + continue; + } else if ((size <= 5) && !memcmp(chrs, "-glob", size)) { + if (foundMode) { + return TCL_ERROR; + } + mode = Switch_Glob; + foundMode = 1; + valueIndex++; + continue; + } else if ((size <= 7) && !memcmp(chrs, "-regexp", size)) { + if (foundMode) { + return TCL_ERROR; + } + mode = Switch_Regexp; + foundMode = 1; + valueIndex++; + continue; + } else if ((size <= 7) && !memcmp(chrs, "-nocase", size)) { + noCase = 1; + valueIndex++; + continue; + } else if ((size == 2) && !memcmp(chrs, "--", 2)) { + valueIndex++; + break; + } + + /* + * The switch command has many flags we cannot compile at all (e.g. + * all the RE-related ones) which we must have encountered. Either + * that or we have run off the end. The action here is the same: punt + * to interpreted version. + */ + + return TCL_ERROR; + } + if (numWords < 3) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(tokenPtr); + numWords--; + if (noCase && (mode == Switch_Exact)) { + /* + * Can't compile this case; no opcode for case-insensitive equality! + */ + + return TCL_ERROR; + } + + /* + * The value to test against is going to always get pushed on the stack. + * But not yet; we need to verify that the rest of the command is + * compilable too. + */ + + finishedOptionParse: + valueTokenPtr = tokenPtr; + /* For valueIndex, see previous loop. */ + tokenPtr = TokenAfter(tokenPtr); + numWords--; + + /* + * Build an array of tokens for the matcher terms and script bodies. Note + * that in the case of the quoted bodies, this is tricky as we cannot use + * 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); + bodyNext = (int **) ckalloc(sizeof(int*) * maxLen); + + bline = mapPtr->loc[eclIndex].line[valueIndex+1]; + numWords = 0; + + while (numBytes > 0) { + CONST char *prevBytes = bytes; + int literal; + + if (TCL_OK != TclFindElement(NULL, bytes, numBytes, + &(bodyTokenArray[numWords].start), &bytes, + &(bodyTokenArray[numWords].size), &literal) || !literal) { + goto abort; + } + + bodyTokenArray[numWords].type = TCL_TOKEN_TEXT; + bodyTokenArray[numWords].numComponents = 0; + bodyToken[numWords] = bodyTokenArray + numWords; + + /* + * TIP #280: Now determine the line the list element starts on + * (there is no need to do it earlier, due to the possibility of + * aborting, see above). + */ + + TclAdvanceLines(&bline, prevBytes, bodyTokenArray[numWords].start); + TclAdvanceContinuations (&bline, &clNext, + bodyTokenArray[numWords].start - envPtr->source); + bodyLines[numWords] = bline; + bodyNext[numWords] = clNext; + TclAdvanceLines(&bline, bodyTokenArray[numWords].start, bytes); + TclAdvanceContinuations (&bline, &clNext, bytes - envPtr->source); + + numBytes -= (bytes - prevBytes); + numWords++; + } + if (numWords % 2) { + abort: + ckfree((char *) bodyToken); + ckfree((char *) bodyTokenArray); + ckfree((char *) bodyLines); + ckfree((char *) bodyNext); + 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); + bodyNext = (int **) ckalloc(sizeof(int*) * numWords); + bodyTokenArray = NULL; + for (i=0 ; itype != TCL_TOKEN_SIMPLE_WORD) { + ckfree((char *) bodyToken); + ckfree((char *) bodyLines); + ckfree((char *) bodyNext); + return TCL_ERROR; + } + bodyToken[i] = tokenPtr+1; + + /* + * TIP #280: Copy line information from regular cmd info. + */ + + bodyLines[i] = mapPtr->loc[eclIndex].line[valueIndex+1+i]; + bodyNext[i] = mapPtr->loc[eclIndex].next[valueIndex+1+i]; + tokenPtr = TokenAfter(tokenPtr); + } + } + + /* + * Fall back to interpreted if the last body is a continuation (it's + * illegal, but this makes the error happen at the right time). + */ + + if (bodyToken[numWords-1]->size == 1 && + bodyToken[numWords-1]->start[0] == '-') { + ckfree((char *) bodyToken); + ckfree((char *) bodyLines); + ckfree((char *) bodyNext); + if (bodyTokenArray != NULL) { + ckfree((char *) bodyTokenArray); + } + return TCL_ERROR; + } + + /* + * Now we commit to generating code; the parsing stage per se is done. + * First, we push the value we're matching against on the stack. + */ + + SetLineInformation (valueIndex); + CompileTokens(envPtr, valueTokenPtr, interp); + + /* + * Check if we can generate a jump table, since if so that's faster than + * doing an explicit compare with each body. Note that we're definitely + * over-conservative with determining whether we can do the jump table, + * but it handles the most common case well enough. + */ + + if (mode == Switch_Exact) { + JumptableInfo *jtPtr; + int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation; + int mustGenerate, jumpToDefault; + Tcl_DString buffer; + Tcl_HashEntry *hPtr; + + /* + * Compile the switch by using a jump table, which is basically a + * hashtable that maps from literal values to match against to the + * offset (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 *) ckalloc(sizeof(int) * (numWords/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 we will come back and rewrite the jump's offset + * parameter when we know what it should be, and that all jumps we + * issue are of the wide kind because that makes the code much easier + * to debug! + */ + + jumpLocation = CurrentOffset(envPtr); + TclEmitInstInt4(INST_JUMP_TABLE, infoIndex, envPtr); + jumpToDefault = CurrentOffset(envPtr); + TclEmitInstInt4(INST_JUMP4, 0, envPtr); + + for (i=0 ; isize != 7 || + memcmp(bodyToken[numWords-2]->start, "default", 7)) { + /* + * This is not a default clause, so insert the current + * location as a target in the jump table (assuming it isn't + * already there, which would indicate that this clause is + * probably masked by an earlier one). Note that we use a + * Tcl_DString here simply because the hash API does not let + * us specify the string length. + */ + + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, bodyToken[i]->start, + bodyToken[i]->size); + hPtr = Tcl_CreateHashEntry(&jtPtr->hashTable, + Tcl_DStringValue(&buffer), &isNew); + if (isNew) { + /* + * First time we've encountered this match clause, so it + * must point to here. + */ + + Tcl_SetHashValue(hPtr, (ClientData) + (CurrentOffset(envPtr) - jumpLocation)); + } + Tcl_DStringFree(&buffer); + } else { + /* + * This is a default clause, so patch up the fallthrough from + * the INST_JUMP_TABLE instruction to here. + */ + + foundDefault = 1; + isNew = 1; + TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault, + envPtr->codeStart+jumpToDefault+1); + } + + /* + * Now, for each arm we must deal with the body of the clause. + * + * If this is a continuation body (never true of a final clause, + * whether default or not) we're done because the next jump target + * will also point here, so we advance to the next clause. + */ + + if (bodyToken[i+1]->size == 1 && bodyToken[i+1]->start[0] == '-') { + mustGenerate = 1; + continue; + } + + /* + * Also skip this arm if its only match clause is masked. (We + * could probably be more aggressive about this, but that would be + * much more difficult to get right.) + */ + + if (!isNew && !mustGenerate) { + continue; + } + mustGenerate = 0; + + /* + * Compile the body of the arm. + */ + + envPtr->line = bodyLines[i+1]; /* TIP #280 */ + envPtr->clNext = bodyNext[i+1]; /* TIP #280 */ + TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); + + /* + * Compile a jump in to the end of the command if this body is + * anything other than a user-supplied default arm (to either skip + * over the remaining bodies or the code that generates an empty + * result). + */ + + if (i+2 < numWords || !foundDefault) { + finalFixups[numRealBodies++] = CurrentOffset(envPtr); + + /* + * Easier by far to issue this jump as a fixed-width jump. + * Otherwise we'd need to do a lot more (and more awkward) + * rewriting when we fixed this all up. + */ + + TclEmitInstInt4(INST_JUMP4, 0, envPtr); + } + } + + /* + * We're at the end. If we've not already done so through the + * processing of a user-supplied default clause, add in a "default" + * default clause now. + */ + + if (!foundDefault) { + TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault, + envPtr->codeStart+jumpToDefault+1); + PushLiteral(envPtr, "", 0); + } + + /* + * No more instructions to be issued; everything that needs to jump to + * the end of the command is fixed up at this point. + */ + + for (i=0 ; icodeStart+finalFixups[i]+1); + } + + /* + * Clean up all our temporary space and return. + */ + + ckfree((char *) finalFixups); + ckfree((char *) bodyToken); + ckfree((char *) bodyLines); + ckfree((char *) bodyNext); + if (bodyTokenArray != NULL) { + ckfree((char *) bodyTokenArray); + } + return TCL_OK; + } + + /* + * Generate a test for each arm. + */ + + contFixIndex = -1; + contFixCount = 0; + fixupArray = (JumpFixup *) ckalloc(sizeof(JumpFixup) * numWords); + fixupTargetArray = (int *) ckalloc(sizeof(int) * numWords); + memset(fixupTargetArray, 0, numWords * sizeof(int)); + fixupCount = 0; + foundDefault = 0; + for (i=0 ; icurrStackDepth = savedStackDepth + 1; + if (i!=numWords-2 || bodyToken[numWords-2]->size != 7 || + memcmp(bodyToken[numWords-2]->start, "default", 7)) { + /* + * Generate the test for the arm. + */ + + switch (mode) { + case Switch_Exact: + TclEmitOpcode(INST_DUP, envPtr); + TclCompileTokens(interp, bodyToken[i], 1, envPtr); + TclEmitOpcode(INST_STR_EQ, envPtr); + break; + case Switch_Glob: + TclCompileTokens(interp, bodyToken[i], 1, envPtr); + TclEmitInstInt4(INST_OVER, 1, envPtr); + TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr); + break; + case Switch_Regexp: { + int simple = 0, exact = 0; + + /* + * Keep in sync with TclCompileRegexpCmd. + */ + + if (bodyToken[i]->type == TCL_TOKEN_TEXT) { + Tcl_DString ds; + + if (bodyToken[i]->size == 0) { + /* + * The semantics of regexps are that they always match + * when the RE == "". + */ + + PushLiteral(envPtr, "1", 1); + break; + } + + /* + * Attempt to convert pattern to glob. If successful, push + * the converted pattern. + */ + + if (TclReToGlob(NULL, bodyToken[i]->start, + bodyToken[i]->size, &ds, &exact) == TCL_OK) { + simple = 1; + PushLiteral(envPtr, Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + } + } + if (!simple) { + TclCompileTokens(interp, bodyToken[i], 1, envPtr); + } + + TclEmitInstInt4(INST_OVER, 1, envPtr); + if (simple) { + if (exact && !noCase) { + TclEmitOpcode(INST_STR_EQ, envPtr); + } else { + TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr); + } + } else { + /* + * Pass correct RE compile flags. We use only Int1 + * (8-bit), but that handles all the flags we want to + * pass. Don't use TCL_REG_NOSUB as we may have backrefs + * or capture vars. + */ + + int cflags = TCL_REG_ADVANCED + | (noCase ? TCL_REG_NOCASE : 0); + + TclEmitInstInt1(INST_REGEXP, cflags, envPtr); + } + break; + } + default: + Tcl_Panic("unknown switch mode: %d", mode); + } + + /* + * In a fall-through case, we will jump on _true_ to the place + * where the body starts (generated later, with guarantee of this + * ensured earlier; the final body is never a fall-through). + */ + + if (bodyToken[i+1]->size==1 && bodyToken[i+1]->start[0]=='-') { + if (contFixIndex == -1) { + contFixIndex = fixupCount; + contFixCount = 0; + } + TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, + fixupArray+contFixIndex+contFixCount); + fixupCount++; + contFixCount++; + continue; + } + + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, fixupArray+fixupCount); + nextArmFixupIndex = fixupCount; + fixupCount++; + } else { + /* + * Got a default clause; set a flag to inhibit the generation of + * the jump after the body and the cleanup of the intermediate + * value that we are switching against. + * + * Note that default clauses (which are always terminal clauses) + * cannot be fall-through clauses as well, since the last clause + * is never a fall-through clause (which we have already + * verified). + */ + + foundDefault = 1; + } + + /* + * Generate the body for the arm. This is guaranteed not to be a + * fall-through case, but it might have preceding fall-through cases, + * so we must process those first. + */ + + if (contFixIndex != -1) { + int j; + + for (j=0 ; jcurrStackDepth = savedStackDepth + 1; + envPtr->line = bodyLines[i+1]; /* TIP #280 */ + envPtr->clNext = bodyNext[i+1]; /* TIP #280 */ + TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); + + if (!foundDefault) { + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, + fixupArray+fixupCount); + fixupCount++; + fixupTargetArray[nextArmFixupIndex] = CurrentOffset(envPtr); + } + } + + /* + * Clean up all our temporary space and return. + */ + + ckfree((char *) bodyToken); + ckfree((char *) bodyLines); + ckfree((char *) bodyNext); + if (bodyTokenArray != NULL) { + ckfree((char *) bodyTokenArray); + } + + /* + * Discard the value we are matching against unless we've had a default + * clause (in which case it will already be gone due to the code at the + * start of processing an arm, guaranteed) and make the result of the + * command an empty string. + */ + + if (!foundDefault) { + TclEmitOpcode(INST_POP, envPtr); + PushLiteral(envPtr, "", 0); + } + + /* + * Do jump fixups for arms that were executed. First, fill in the jumps of + * all jumps that don't point elsewhere to point to here. + */ + + for (i=0 ; icodeNext-envPtr->codeStart; + } + } + + /* + * Now scan backwards over all the jumps (all of which are forward jumps) + * doing each one. When we do one and there is a size changes, we must + * scan back over all the previous ones and see if they need adjusting + * before proceeding with further jump fixups (the interleaved nature of + * all the jumps makes this impossible to do without nested loops). + */ + + for (i=fixupCount-1 ; i>=0 ; i--) { + if (TclFixupForwardJump(envPtr, &fixupArray[i], + fixupTargetArray[i] - fixupArray[i].codeOffset, 127)) { + int j; + + for (j=i-1 ; j>=0 ; j--) { + if (fixupTargetArray[j] > fixupArray[i].codeOffset) { + fixupTargetArray[j] += 3; + } + } + } + } + ckfree((char *) fixupArray); + ckfree((char *) fixupTargetArray); + + envPtr->currStackDepth = savedStackDepth + 1; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DupJumptableInfo, FreeJumptableInfo -- + * + * Functions to duplicate, release and print a jump-table created for use + * with the INST_JUMP_TABLE instruction. + * + * Results: + * DupJumptableInfo: a copy of the jump-table + * FreeJumptableInfo: none + * PrintJumptableInfo: none + * + * Side effects: + * DupJumptableInfo: allocates memory + * FreeJumptableInfo: releases memory + * PrintJumptableInfo: none + * + *---------------------------------------------------------------------- + */ + +static ClientData +DupJumptableInfo( + ClientData clientData) +{ + JumptableInfo *jtPtr = 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 = clientData; + + Tcl_DeleteHashTable(&jtPtr->hashTable); + ckfree((char *) jtPtr); +} + +static void +PrintJumptableInfo( + ClientData clientData, + Tcl_Obj *appendObj, + ByteCode *codePtr, + unsigned int pcOffset) +{ + register JumptableInfo *jtPtr = 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 = 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); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileWhileCmd -- + * + * Procedure called to compile the "while" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "while" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileWhileCmd( + 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 *testTokenPtr, *bodyTokenPtr; + JumpFixup jumpEvalCondFixup; + int testCodeOffset, bodyCodeOffset, jumpDist, range, code, boolVal; + int savedStackDepth = envPtr->currStackDepth; + int loopMayEnd = 1; /* This is set to 0 if it is recognized as an + * infinite loop. */ + Tcl_Obj *boolObj; + DefineLineInformation; /* TIP #280 */ + + if (parsePtr->numWords != 3) { + return TCL_ERROR; + } + + /* + * If the test expression requires substitutions, don't compile the while + * command inline. E.g., the expression might cause the loop to never + * execute or execute forever, as in "while "$x < 5" {}". + * + * Bail out also if the body expression requires substitutions in order to + * insure correct behaviour [Bug 219166] + */ + + testTokenPtr = TokenAfter(parsePtr->tokenPtr); + bodyTokenPtr = TokenAfter(testTokenPtr); + + if ((testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) + || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) { + return TCL_ERROR; + } + + /* + * Find out if the condition is a constant. + */ + + boolObj = Tcl_NewStringObj(testTokenPtr[1].start, testTokenPtr[1].size); + Tcl_IncrRefCount(boolObj); + code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal); + TclDecrRefCount(boolObj); + if (code == TCL_OK) { + if (boolVal) { + /* + * It is an infinite loop; flag it so that we generate a more + * efficient body. + */ + + loopMayEnd = 0; + } else { + /* + * This is an empty loop: "while 0 {...}" or such. Compile no + * bytecodes. + */ + + goto pushResult; + } + } + + /* + * Create a ExceptionRange record for the loop body. This is used to + * implement break and continue. + */ + + range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); + + /* + * Jump to the evaluation of the condition. This code uses the "loop + * rotation" optimisation (which eliminates one branch from the loop). + * "while cond body" produces then: + * goto A + * B: body : bodyCodeOffset + * A: cond -> result : testCodeOffset, continueOffset + * if (result) goto B + * + * The infinite loop "while 1 body" produces: + * B: body : all three offsets here + * goto B + */ + + if (loopMayEnd) { + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup); + testCodeOffset = 0; /* Avoid compiler warning. */ + } else { + /* + * Make sure that the first command in the body is preceded by an + * INST_START_CMD, and hence counted properly. [Bug 1752146] + */ + + envPtr->atCmdStart = 0; + testCodeOffset = CurrentOffset(envPtr); + } + + /* + * Compile the loop body. + */ + + SetLineInformation (2); + bodyCodeOffset = ExceptionRangeStarts(envPtr, range); + CompileBody(envPtr, bodyTokenPtr, interp); + ExceptionRangeEnds(envPtr, range); + envPtr->currStackDepth = savedStackDepth + 1; + TclEmitOpcode(INST_POP, envPtr); + + /* + * Compile the test expression then emit the conditional jump that + * terminates the while. We already know it's a simple word. + */ + + if (loopMayEnd) { + testCodeOffset = CurrentOffset(envPtr); + jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset; + if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) { + bodyCodeOffset += 3; + testCodeOffset += 3; + } + envPtr->currStackDepth = savedStackDepth; + SetLineInformation (1); + TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + envPtr->currStackDepth = savedStackDepth + 1; + + jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; + if (jumpDist > 127) { + TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); + } else { + TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr); + } + } else { + jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; + if (jumpDist > 127) { + TclEmitInstInt4(INST_JUMP4, -jumpDist, envPtr); + } else { + TclEmitInstInt1(INST_JUMP1, -jumpDist, envPtr); + } + } + + /* + * Set the loop's body, continue and break offsets. + */ + + envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset; + envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset; + ExceptionRangeTarget(envPtr, range, breakOffset); + + /* + * The while command's result is an empty string. + */ + + pushResult: + envPtr->currStackDepth = savedStackDepth; + PushLiteral(envPtr, "", 0); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * LocalScalar(FromToken) -- * * Get the index into the table of compiled locals that corresponds * to a local scalar variable name. * * Results: * Returns the non-negative integer index value into the table of - * compiled locals corresponding to a local scalar variable name. - * If the arguments passed in do not identify a local scalar variable - * then return -1. + * compiled locals corresponding to a local scalar variable name. + * If the arguments passed in do not identify a local scalar variable + * then return -1. * * Side effects: - * May add an entery into the table of compiled locals. + * May add an entry into the table of compiled locals. * *---------------------------------------------------------------------- */ -int -TclLocalScalarFromToken( +static int +LocalScalarFromToken( Tcl_Token *tokenPtr, CompileEnv *envPtr) { - int isScalar, index; + int isSimple, isScalar, index; - TclPushVarName(NULL, tokenPtr, envPtr, TCL_NO_ELEMENT, &index, &isScalar); + PushVarName(NULL, tokenPtr, envPtr, TCL_CREATE_VAR, &index, + &isSimple, &isScalar, 0 /* ignored */, NULL /* ignored */); if (!isScalar) { index = -1; } return index; } -int -TclLocalScalar( +static int +LocalScalar( const char *bytes, - size_t numBytes, + int numBytes, CompileEnv *envPtr) { - Tcl_Token token[2] = {{TCL_TOKEN_SIMPLE_WORD, NULL, 0, 1}, - {TCL_TOKEN_TEXT, NULL, 0, 0}}; + Tcl_Token token[2] = {{TCL_TOKEN_SIMPLE_WORD, NULL, 0, 1}, + {TCL_TOKEN_TEXT, NULL, 0, 0}}; token[1].start = bytes; token[1].size = numBytes; - return TclLocalScalarFromToken(token, envPtr); + return LocalScalarFromToken(token, envPtr); } /* *---------------------------------------------------------------------- * - * TclPushVarName -- + * PushVarName -- * * Procedure used in the compiling where pushing a variable name is * necessary (append, lappend, set). * * Results: - * The values written to *localIndexPtr and *isScalarPtr signal to - * the caller what the instructions emitted by this routine will do: - * - * *isScalarPtr (*localIndexPtr < 0) - * 1 1 Push the varname on the stack. (Stack +1) - * 1 0 *localIndexPtr is the index of the compiled - * local for this varname. No instructions - * emitted. (Stack +0) - * 0 1 Push part1 and part2 names of array element - * on the stack. (Stack +2) - * 0 0 *localIndexPtr is the index of the compiled - * local for this array. Element name is pushed - * on the stack. (Stack +1) + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr. + * Instructions are added to envPtr to execute the "set" command at + * runtime. * *---------------------------------------------------------------------- */ -void -TclPushVarName( +static int +PushVarName( 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 flags, /* TCL_CREATE_VAR or TCL_NO_LARGE_INDEX. */ int *localIndexPtr, /* Must not be NULL. */ - int *isScalarPtr) /* Must not be NULL. */ + int *simpleVarNamePtr, /* Must not be NULL. */ + int *isScalarPtr, /* Must not be NULL. */ + int line, /* Line the token starts on. */ + int* clNext) /* Reference to offset of next hidden cont. line */ { - const char *p; - const char *last, *name, *elName; - size_t n; + register const char *p; + const char *name, *elName; + register int i, n; Tcl_Token *elemTokenPtr = NULL; - size_t nameLen, elNameLen; - int simpleVarName, localIndex; + int nameChars, elNameChars, 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 @@ -3435,11 +4797,11 @@ * qualifiers. */ simpleVarName = 0; name = elName = NULL; - nameLen = elNameLen = 0; + nameChars = elNameChars = 0; localIndex = -1; if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { /* * A simple variable name. Divide it up into "name" and "elName" @@ -3447,110 +4809,108 @@ */ simpleVarName = 1; name = varTokenPtr[1].start; - nameLen = varTokenPtr[1].size; - if (name[nameLen-1] == ')') { + nameChars = varTokenPtr[1].size; + if (name[nameChars-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; - } + + for (i=0,p=name ; itype = TCL_TOKEN_TEXT; elemTokenPtr->start = elName; - elemTokenPtr->size = elNameLen; + elemTokenPtr->size = elNameChars; 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) == ')')) { + && (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++) { + for (i = 0, p = varTokenPtr[1].start; + i < varTokenPtr[1].size; i++, p++) { if (*p == '(') { simpleVarName = 1; break; } } if (simpleVarName) { - size_t remainingLen; + int remainingChars; /* * 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. */ if (varTokenPtr[n].size == 1) { - n--; + --n; } else { - varTokenPtr[n].size--; + --varTokenPtr[n].size; removedParen = n; } name = varTokenPtr[1].start; - nameLen = p - varTokenPtr[1].start; + nameChars = p - varTokenPtr[1].start; elName = p + 1; - remainingLen = (varTokenPtr[2].start - p) - 1; - elNameLen = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 1; + remainingChars = (varTokenPtr[2].start - p) - 1; + elNameChars = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 1; - if (!(flags & TCL_NO_ELEMENT)) { - if (remainingLen) { + if (remainingChars) { /* * Make a first token with the extra characters in the first * token. */ - elemTokenPtr = (Tcl_Token *)TclStackAlloc(interp, n * sizeof(Tcl_Token)); + elemTokenPtr = (Tcl_Token *) TclStackAlloc(interp, + n * sizeof(Tcl_Token)); allocedTokens = 1; elemTokenPtr->type = TCL_TOKEN_TEXT; elemTokenPtr->start = elName; - elemTokenPtr->size = remainingLen; + elemTokenPtr->size = remainingChars; elemTokenPtr->numComponents = 0; elemTokenCount = n; /* * Copy the remaining tokens. */ memcpy(elemTokenPtr+1, varTokenPtr+2, (n-1) * sizeof(Tcl_Token)); - } else { + } else { /* * Use the already available tokens. */ elemTokenPtr = &varTokenPtr[2]; elemTokenCount = n - 1; - } } } } if (simpleVarName) { @@ -3557,13 +4917,12 @@ /* * 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) == ':')) { + for (i = 0, p = name; i < nameChars; i++, p++) { + if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) { hasNsQualifiers = 1; break; } } @@ -3571,57 +4930,1457 @@ * Look up the var name's index in the array of local vars in the proc * frame. If retrieving the var's value and it doesn't already exist, * push its name and look it up at runtime. */ - if (!hasNsQualifiers) { - localIndex = TclFindCompiledLocal(name, nameLen, 1, envPtr); + if ((envPtr->procPtr != NULL) && !hasNsQualifiers) { + localIndex = TclFindCompiledLocal(name, nameChars, + /*create*/ flags & TCL_CREATE_VAR, + envPtr->procPtr); if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) { /* * We'll push the name. */ localIndex = -1; } } if (interp && localIndex < 0) { - PushLiteral(envPtr, name, nameLen); + PushLiteral(envPtr, name, nameChars); } /* - * Compile the element script, if any, and only if not inhibited. [Bug - * 3600328] + * Compile the element script, if any. */ - if (elName != NULL && !(flags & TCL_NO_ELEMENT)) { - if (elNameLen) { - TclCompileTokens(interp, elemTokenPtr, elemTokenCount, - envPtr); + if (interp && elName != NULL) { + if (elNameChars) { + envPtr->line = line; + envPtr->clNext = clNext; + TclCompileTokens(interp, elemTokenPtr, elemTokenCount, envPtr); } else { - PushStringLiteral(envPtr, ""); + PushLiteral(envPtr, "", 0); } } } else if (interp) { /* * The var name isn't simple: compile and push it. */ + envPtr->line = line; + envPtr->clNext = clNext; CompileTokens(envPtr, varTokenPtr, interp); } if (removedParen) { - varTokenPtr[removedParen].size++; + ++varTokenPtr[removedParen].size; } if (allocedTokens) { TclStackFree(interp, elemTokenPtr); } *localIndexPtr = localIndex; + *simpleVarNamePtr = simpleVarName; *isScalarPtr = (elName == NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * CompileUnaryOpCmd -- + * + * Utility routine to compile the unary operator commands. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the compiled command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +static int +CompileUnaryOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + int instruction, + CompileEnv *envPtr) +{ + Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + TclEmitOpcode(instruction, envPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * CompileAssociativeBinaryOpCmd -- + * + * Utility routine to compile the binary operator commands that accept an + * arbitrary number of arguments, and that are associative operations. + * Because of the associativity, we may combine operations from right to + * left, saving us any effort of re-ordering the arguments on the stack + * after substitutions are completed. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the compiled command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +static int +CompileAssociativeBinaryOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + const char *identity, + int instruction, + CompileEnv *envPtr) +{ + Tcl_Token *tokenPtr = parsePtr->tokenPtr; + DefineLineInformation; /* TIP #280 */ + int words; + + for (words=1 ; wordsnumWords ; words++) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, words); + } + if (parsePtr->numWords <= 2) { + PushLiteral(envPtr, identity, -1); + words++; + } + if (words > 3) { + /* + * Reverse order of arguments to get precise agreement with + * [expr] in calcuations, including roundoff errors. + */ + TclEmitInstInt4(INST_REVERSE, words-1, envPtr); + } + while (--words > 1) { + TclEmitOpcode(instruction, envPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * CompileStrictlyBinaryOpCmd -- + * + * Utility routine to compile the binary operator commands, that strictly + * accept exactly two arguments. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the compiled command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +static int +CompileStrictlyBinaryOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + int instruction, + CompileEnv *envPtr) +{ + if (parsePtr->numWords != 3) { + return TCL_ERROR; + } + return CompileAssociativeBinaryOpCmd(interp, parsePtr, + NULL, instruction, envPtr); +} + +/* + *---------------------------------------------------------------------- + * + * CompileComparisonOpCmd -- + * + * Utility routine to compile the n-ary comparison operator commands. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the compiled command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +static int +CompileComparisonOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + int instruction, + CompileEnv *envPtr) +{ + Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ + + if (parsePtr->numWords < 3) { + PushLiteral(envPtr, "1", 1); + } else if (parsePtr->numWords == 3) { + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 2); + TclEmitOpcode(instruction, envPtr); + } else if (envPtr->procPtr == NULL) { + /* + * No local variable space! + */ + + return TCL_ERROR; + } else { + int tmpIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr->procPtr); + int words; + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 2); + if (tmpIndex <= 255) { + TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr); + } else { + TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); + } + TclEmitOpcode(instruction, envPtr); + for (words=3 ; wordsnumWords ;) { + if (tmpIndex <= 255) { + TclEmitInstInt1(INST_LOAD_SCALAR1, tmpIndex, envPtr); + } else { + TclEmitInstInt4(INST_LOAD_SCALAR4, tmpIndex, envPtr); + } + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, words); + if (++words < parsePtr->numWords) { + if (tmpIndex <= 255) { + TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr); + } else { + TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); + } + } + TclEmitOpcode(instruction, envPtr); + } + for (; words>3 ; words--) { + TclEmitOpcode(INST_BITAND, envPtr); + } + + /* + * Drop the value from the temp variable; retaining that reference + * might be expensive elsewhere. + */ + + PushLiteral(envPtr, "", 0); + if (tmpIndex <= 255) { + TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr); + } else { + TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); + } + TclEmitOpcode(INST_POP, envPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompile*OpCmd -- + * + * Procedures called to compile the corresponding "::tcl::mathop::*" + * commands. These are all wrappers around the utility operator command + * compiler functions, except for the compilers for subtraction and + * division, which are special. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the compiled command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileInvertOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + return CompileUnaryOpCmd(interp, parsePtr, INST_BITNOT, envPtr); +} + +int +TclCompileNotOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + return CompileUnaryOpCmd(interp, parsePtr, INST_LNOT, envPtr); +} + +int +TclCompileAddOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_ADD, + envPtr); +} + +int +TclCompileMulOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + return CompileAssociativeBinaryOpCmd(interp, parsePtr, "1", INST_MULT, + envPtr); +} + +int +TclCompileAndOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + return CompileAssociativeBinaryOpCmd(interp, parsePtr, "-1", INST_BITAND, + envPtr); +} + +int +TclCompileOrOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITOR, + envPtr); +} + +int +TclCompileXorOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITXOR, + envPtr); +} + +int +TclCompilePowOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + /* + * This one has its own implementation because the ** operator is + * the only one with right associativity. + */ + Tcl_Token *tokenPtr = parsePtr->tokenPtr; + DefineLineInformation; /* TIP #280 */ + int words; + + for (words=1 ; wordsnumWords ; words++) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, words); + } + if (parsePtr->numWords <= 2) { + PushLiteral(envPtr, "1", 1); + words++; + } + while (--words > 1) { + TclEmitOpcode(INST_EXPON, envPtr); + } + return TCL_OK; +} + +int +TclCompileLshiftOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LSHIFT, envPtr); +} + +int +TclCompileRshiftOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_RSHIFT, envPtr); +} + +int +TclCompileModOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_MOD, envPtr); +} + +int +TclCompileNeqOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_NEQ, envPtr); +} + +int +TclCompileStrneqOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_STR_NEQ, envPtr); +} + +int +TclCompileInOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_IN, envPtr); +} + +int +TclCompileNiOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_NOT_IN, + envPtr); +} + +int +TclCompileLessOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + return CompileComparisonOpCmd(interp, parsePtr, INST_LT, envPtr); +} + +int +TclCompileLeqOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + return CompileComparisonOpCmd(interp, parsePtr, INST_LE, envPtr); +} + +int +TclCompileGreaterOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + return CompileComparisonOpCmd(interp, parsePtr, INST_GT, envPtr); +} + +int +TclCompileGeqOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + return CompileComparisonOpCmd(interp, parsePtr, INST_GE, envPtr); +} + +int +TclCompileEqOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + return CompileComparisonOpCmd(interp, parsePtr, INST_EQ, envPtr); +} + +int +TclCompileStreqOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + return CompileComparisonOpCmd(interp, parsePtr, INST_STR_EQ, envPtr); +} + +int +TclCompileMinusOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + Tcl_Token *tokenPtr = parsePtr->tokenPtr; + DefineLineInformation; /* TIP #280 */ + int words; + + if (parsePtr->numWords == 1) { + /* Fallback to direct eval to report syntax error */ + return TCL_ERROR; + } + for (words=1 ; wordsnumWords ; words++) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, words); + } + if (words == 2) { + TclEmitOpcode(INST_UMINUS, envPtr); + return TCL_OK; + } + if (words == 3) { + TclEmitOpcode(INST_SUB, envPtr); + return TCL_OK; + } + /* + * Reverse order of arguments to get precise agreement with + * [expr] in calcuations, including roundoff errors. + */ + TclEmitInstInt4(INST_REVERSE, words-1, envPtr); + while (--words > 1) { + TclEmitInstInt4(INST_REVERSE, 2, envPtr); + TclEmitOpcode(INST_SUB, envPtr); + } + return TCL_OK; +} + +int +TclCompileDivOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + Tcl_Token *tokenPtr = parsePtr->tokenPtr; + DefineLineInformation; /* TIP #280 */ + int words; + + if (parsePtr->numWords == 1) { + /* Fallback to direct eval to report syntax error */ + return TCL_ERROR; + } + if (parsePtr->numWords == 2) { + PushLiteral(envPtr, "1.0", 3); + } + for (words=1 ; wordsnumWords ; words++) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, words); + } + if (words <= 3) { + TclEmitOpcode(INST_DIV, envPtr); + return TCL_OK; + } + /* + * Reverse order of arguments to get precise agreement with + * [expr] in calcuations, including roundoff errors. + */ + TclEmitInstInt4(INST_REVERSE, words-1, envPtr); + while (--words > 1) { + TclEmitInstInt4(INST_REVERSE, 2, envPtr); + TclEmitOpcode(INST_DIV, envPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * IndexTailVarIfKnown -- + * + * Procedure used in compiling [global] and [variable] commands. It + * inspects the variable name described by varTokenPtr and, if the tail + * is known at compile time, defines a corresponding local variable. + * + * Results: + * Returns the variable's index in the table of compiled locals if the + * tail is known at compile time, or -1 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +IndexTailVarIfKnown( + Tcl_Interp *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. + * In order for the tail to be known at compile time, the last token + * in the word has to be constant and contain "::" if it is not the + * only one. + */ + + if (envPtr->procPtr == NULL) { + return -1; + } + + TclNewObj(tailPtr); + if (TclWordKnownAtCompileTime(varTokenPtr, tailPtr)) { + full = 1; + lastTokenPtr = varTokenPtr; + } else { + full = 0; + lastTokenPtr = varTokenPtr + n; + if (!TclWordKnownAtCompileTime(lastTokenPtr, tailPtr)) { + Tcl_DecrRefCount(tailPtr); + return -1; + } + } + + tailName = TclGetStringFromObj(tailPtr, &len); + + if (len) { + if (*(tailName+len-1) == ')') { + /* + * Possible array: bail out + */ + + Tcl_DecrRefCount(tailPtr); + return -1; + } + + /* + * Get the tail: immediately after the last '::' + */ + + for(p = tailName + len -1; p > tailName; p--) { + if ((*p == ':') && (*(p-1) == ':')) { + p++; + break; + } + } + if (!full && (p == tailName)) { + /* + * No :: in the last component + */ + Tcl_DecrRefCount(tailPtr); + return -1; + } + len -= p - tailName; + tailName = p; + } + + localIndex = TclFindCompiledLocal(tailName, len, + /*create*/ TCL_CREATE_VAR, + envPtr->procPtr); + Tcl_DecrRefCount(tailPtr); + return localIndex; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileUpvarCmd -- + * + * Procedure called to compile the "upvar" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "upvar" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileUpvarCmd( + 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, *otherTokenPtr, *localTokenPtr; + int localIndex, numWords, i; + DefineLineInformation; /* TIP #280 */ + Tcl_Obj *objPtr; + + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + + numWords = parsePtr->numWords; + if (numWords < 3) { + return TCL_ERROR; + } + + /* + * Push the frame index if it is known at compile time + */ + + objPtr = Tcl_NewObj(); + tokenPtr = TokenAfter(parsePtr->tokenPtr); + if(TclWordKnownAtCompileTime(tokenPtr, objPtr)) { + CallFrame *framePtr; + Tcl_ObjType *newTypePtr, *typePtr = objPtr->typePtr; + + /* + * Attempt to convert to a level reference. Note that TclObjGetFrame + * only changes the obj type when a conversion was successful. + */ + + TclObjGetFrame(interp, objPtr, &framePtr); + newTypePtr = objPtr->typePtr; + Tcl_DecrRefCount(objPtr); + + if (newTypePtr != typePtr) { + if(numWords%2) { + return TCL_ERROR; + } + /* TODO: Push the known value instead? */ + CompileWord(envPtr, tokenPtr, interp, 1); + otherTokenPtr = TokenAfter(tokenPtr); + i = 2; + } else { + if(!(numWords%2)) { + return TCL_ERROR; + } + PushLiteral(envPtr, "1", 1); + otherTokenPtr = tokenPtr; + i = 1; + } + } else { + Tcl_DecrRefCount(objPtr); + return TCL_ERROR; + } + + /* + * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a + * local variable, return an error so that the non-compiled command will + * be called at runtime. + */ + + for(; iprocPtr == NULL) { + return TCL_ERROR; + } + + /* + * Only compile [namespace upvar ...]: needs an odd number of args, >=5 + */ + + numWords = parsePtr->numWords; + if (!(numWords%2) || (numWords < 5)) { + return TCL_ERROR; + } + + /* + * Check if the second argument is "upvar" + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + if ((tokenPtr->size != 5) /* 5 == strlen("upvar") */ + || strncmp(tokenPtr->start, "upvar", 5)) { + return TCL_ERROR; + } + + /* + * Push the namespace + */ + + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 2); + + /* + * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a + * local variable, return an error so that the non-compiled command will + * be called at runtime. + */ + + localTokenPtr = tokenPtr; + for(i=3; inumWords; + if (numWords < 2) { + return TCL_ERROR; + } + + /* + * 'global' has no effect outside of proc bodies; handle that at runtime + */ + + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + + /* + * Push the namespace + */ + + PushLiteral(envPtr, "::", 2); + + /* + * Loop over the variables. + */ + + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + for(i=1; inumWords; + if (numWords < 2) { + return TCL_ERROR; + } + + /* + * Bail out if not compiling a proc body + */ + + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + + /* + * Loop over the (var, value) pairs. + */ + + valueTokenPtr = parsePtr->tokenPtr; + for(i=1; inumWords < 2) { + return TCL_ERROR; + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + /* + * Too hard. + */ + + return TCL_ERROR; + } + + word = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + + /* + * There's a sporting chance we'll be able to compile this. But now we + * must check properly. To do that, check that we're compiling an ensemble + * that has a compilable command as its appropriate subcommand. + */ + + if (Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj) != TCL_OK + || mapObj == NULL) { + /* + * Either not an ensemble or a mapping isn't installed. Crud. Too hard + * to proceed. + */ + + return TCL_ERROR; + } + + /* + * Next, get the flags. We need them on several code paths. + */ + + (void) Tcl_GetEnsembleFlags(NULL, ensemble, &flags); + + /* + * 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) { + return TCL_ERROR; + } + for (i=0 ; i 1 && Tcl_IsSafe(interp)) { + return TCL_ERROR; + } + targetCmdObj = elems[0]; + + Tcl_IncrRefCount(targetCmdObj); + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj); + TclDecrRefCount(targetCmdObj); + if (cmdPtr == NULL || cmdPtr->compileProc == NULL + || cmdPtr->flags & CMD_HAS_EXEC_TRACES + || ((Interp *)interp)->flags & DONT_COMPILE_CMDS_INLINE) { + /* + * Maps to an undefined command or a command without a compiler. + * Cannot compile. + */ + + return TCL_ERROR; + } + + /* + * Now we've done the mapping process, can now actually try to compile. + * We do this by handing off to the subcommand's actual compiler. But to + * do that, we have to perform some trickery to rewrite the arguments. + */ + + TclParseInit(interp, NULL, 0, &synthetic); + synthetic.numWords = parsePtr->numWords - 2 + len; + TclGrowParseTokenArray(&synthetic, 2*len); + synthetic.numTokens = 2*len; + + /* + * Now we have the space to work in, install something rewritten. Note + * that we are here praying for all our might that none of these words are + * a script; the error detection code will crash if that happens and there + * is nothing we can do to avoid it! + */ + + for (i=0 ; inumComponents + 1; + TclGrowParseTokenArray(&synthetic, toCopy); + memcpy(synthetic.tokenPtr + synthetic.numTokens, tokenPtr, + sizeof(Tcl_Token) * toCopy); + synthetic.numTokens += toCopy; + } + + /* + * Hand off compilation to the subcommand compiler. At last! + */ + + mapPtr->loc[eclIndex].line++; + mapPtr->loc[eclIndex].next++; + + result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr); + + mapPtr->loc[eclIndex].line--; + mapPtr->loc[eclIndex].next--; + + /* + * Clean up if necessary. + */ + + Tcl_FreeParse(&synthetic); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileInfoExistsCmd -- + * + * Procedure called to compile the "info exists" subcommand. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "info exists" + * subcommand at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileInfoExistsCmd( + 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; + int isScalar, simpleVarName, localIndex; + DefineLineInformation; /* TIP #280 */ + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + + /* + * Decide if we can use a frame slot for the var/array name or if we need + * to emit code to compute and push the name at runtime. We use a frame + * slot (entry in the array of local vars) if we are compiling a procedure + * body and if the name is simple text that does not include namespace + * qualifiers. + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + PushVarNameWord(interp, tokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, + &simpleVarName, &isScalar, 1); + + /* + * Emit instruction to check the variable for existence. + */ + + if (simpleVarName) { + if (isScalar) { + if (localIndex < 0) { + TclEmitOpcode(INST_EXIST_STK, envPtr); + } else { + TclEmitInstInt4(INST_EXIST_SCALAR, localIndex, envPtr); + } + } else { + if (localIndex < 0) { + TclEmitOpcode(INST_EXIST_ARRAY_STK, envPtr); + } else { + TclEmitInstInt4(INST_EXIST_ARRAY, localIndex, envPtr); + } + } + } else { + TclEmitOpcode(INST_EXIST_STK, envPtr); + } + + return TCL_OK; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ DELETED generic/tclCompCmdsGR.c Index: generic/tclCompCmdsGR.c ================================================================== --- generic/tclCompCmdsGR.c +++ /dev/null @@ -1,3036 +0,0 @@ -/* - * tclCompCmdsGR.c -- - * - * This file contains compilation procedures that compile various Tcl - * commands (beginning with the letters 'g' through 'r') into a sequence - * of instructions ("bytecodes"). - * - * Copyright (c) 1997-1998 Sun Microsystems, Inc. - * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. - * Copyright (c) 2002 ActiveState Corporation. - * Copyright (c) 2004-2013 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 "tclCompile.h" -#include - -/* - * Prototypes for procedures defined later in this file: - */ - -static void CompileReturnInternal(CompileEnv *envPtr, - unsigned char op, int code, int level, - Tcl_Obj *returnOpts); -static int IndexTailVarIfKnown(Tcl_Interp *interp, - Tcl_Token *varTokenPtr, CompileEnv *envPtr); - -/* - *---------------------------------------------------------------------- - * - * TclGetIndexFromToken -- - * - * Parse a token to determine if an index value is known at - * compile time. - * - * 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 *index. - * - *---------------------------------------------------------------------- - */ - -int -TclGetIndexFromToken( - Tcl_Token *tokenPtr, - size_t before, - size_t after, - int *indexPtr) -{ - Tcl_Obj *tmpObj; - int result = TCL_ERROR; - - TclNewObj(tmpObj); - if (TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { - result = TclIndexEncode(NULL, tmpObj, before, after, indexPtr); - } - Tcl_DecrRefCount(tmpObj); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileGlobalCmd -- - * - * Procedure called to compile the "global" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "global" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -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; - } - - /* - * 'global' has no effect outside of proc bodies; handle that at runtime - */ - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } - - /* - * Push the namespace - */ - - PushStringLiteral(envPtr, "::"); - - /* - * Loop over the variables. - */ - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i=1; itokenPtr; - wordIdx = 0; - numWords = parsePtr->numWords; - - for (wordIdx = 0; wordIdx < numWords; wordIdx++) { - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(tokenPtr); - } - - TclInitJumpFixupArray(&jumpFalseFixupArray); - TclInitJumpFixupArray(&jumpEndFixupArray); - code = TCL_OK; - - /* - * Each iteration of this loop compiles one "if expr ?then? body" or - * "elseif expr ?then? body" clause. - */ - - tokenPtr = parsePtr->tokenPtr; - wordIdx = 0; - while (wordIdx < numWords) { - /* - * Stop looping if the token isn't "if" or "elseif". - */ - - word = tokenPtr[1].start; - numBytes = tokenPtr[1].size; - if ((tokenPtr == parsePtr->tokenPtr) - || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) { - tokenPtr = TokenAfter(tokenPtr); - wordIdx++; - } else { - break; - } - if (wordIdx >= numWords) { - code = TCL_ERROR; - goto done; - } - - /* - * Compile the test expression then emit the conditional jump around - * the "then" part. - */ - - testTokenPtr = tokenPtr; - - if (realCond) { - /* - * Find out if the condition is a constant. - */ - - Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start, - testTokenPtr[1].size); - - Tcl_IncrRefCount(boolObj); - code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal); - TclDecrRefCount(boolObj); - if (code == TCL_OK) { - /* - * A static condition. - */ - - realCond = 0; - if (!boolVal) { - compileScripts = 0; - } - } else { - SetLineInformation(wordIdx); - Tcl_ResetResult(interp); - TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { - TclExpandJumpFixupArray(&jumpFalseFixupArray); - } - jumpIndex = jumpFalseFixupArray.next; - jumpFalseFixupArray.next++; - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, - jumpFalseFixupArray.fixup + jumpIndex); - } - code = TCL_OK; - } - - /* - * Skip over the optional "then" before the then clause. - */ - - tokenPtr = TokenAfter(testTokenPtr); - wordIdx++; - if (wordIdx >= numWords) { - code = TCL_ERROR; - goto done; - } - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - word = tokenPtr[1].start; - numBytes = tokenPtr[1].size; - if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) { - tokenPtr = TokenAfter(tokenPtr); - wordIdx++; - if (wordIdx >= numWords) { - code = TCL_ERROR; - goto done; - } - } - } - - /* - * Compile the "then" command body. - */ - - if (compileScripts) { - BODY(tokenPtr, wordIdx); - } - - if (realCond) { - /* - * Jump to the end of the "if" command. Both jumpFalseFixupArray - * and jumpEndFixupArray are indexed by "jumpIndex". - */ - - if (jumpEndFixupArray.next >= jumpEndFixupArray.end) { - TclExpandJumpFixupArray(&jumpEndFixupArray); - } - jumpEndFixupArray.next++; - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - jumpEndFixupArray.fixup + jumpIndex); - - /* - * Fix the target of the jumpFalse after the test. Generate a 4 - * byte jump if the distance is > 120 bytes. This is conservative, - * and ensures that we won't have to replace this jump if we later - * also need to replace the proceeding jump to the end of the "if" - * with a 4 byte jump. - */ - - TclAdjustStackDepth(-1, envPtr); - if (TclFixupForwardJumpToHere(envPtr, - jumpFalseFixupArray.fixup + jumpIndex, 120)) { - /* - * Adjust the code offset for the proceeding jump to the end - * of the "if" command. - */ - - jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3; - } - } else if (boolVal) { - /* - * We were processing an "if 1 {...}"; stop compiling scripts. - */ - - compileScripts = 0; - } else { - /* - * We were processing an "if 0 {...}"; reset so that the rest - * (elseif, else) is compiled correctly. - */ - - realCond = 1; - compileScripts = 1; - } - - tokenPtr = TokenAfter(tokenPtr); - wordIdx++; - } - - /* - * Check for the optional else clause. Do not compile anything if this was - * an "if 1 {...}" case. - */ - - if ((wordIdx < numWords) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { - /* - * There is an else clause. Skip over the optional "else" word. - */ - - word = tokenPtr[1].start; - numBytes = tokenPtr[1].size; - if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) { - tokenPtr = TokenAfter(tokenPtr); - wordIdx++; - if (wordIdx >= numWords) { - code = TCL_ERROR; - goto done; - } - } - - if (compileScripts) { - /* - * Compile the else command body. - */ - - BODY(tokenPtr, wordIdx); - } - - /* - * Make sure there are no words after the else clause. - */ - - wordIdx++; - if (wordIdx < numWords) { - code = TCL_ERROR; - goto done; - } - } else { - /* - * No else clause: the "if" command's result is an empty string. - */ - - if (compileScripts) { - PushStringLiteral(envPtr, ""); - } - } - - /* - * Fix the unconditional jumps to the end of the "if" command. - */ - - for (j = jumpEndFixupArray.next; j > 0; j--) { - jumpIndex = (j - 1); /* i.e. process the closest jump first. */ - if (TclFixupForwardJumpToHere(envPtr, - jumpEndFixupArray.fixup + jumpIndex, 127)) { - /* - * Adjust the immediately preceeding "ifFalse" jump. We moved it's - * target (just after this jump) down three bytes. - */ - - unsigned char *ifFalsePc = envPtr->codeStart - + jumpFalseFixupArray.fixup[jumpIndex].codeOffset; - unsigned char opCode = *ifFalsePc; - - if (opCode == INST_JUMP_FALSE1) { - jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1); - jumpFalseDist += 3; - TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1)); - } else if (opCode == INST_JUMP_FALSE4) { - jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1); - jumpFalseDist += 3; - TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1)); - } else { - Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", opCode); - } - } - } - - /* - * Free the jumpFixupArray array if malloc'ed storage was used. - */ - - done: - TclFreeJumpFixupArray(&jumpFalseFixupArray); - TclFreeJumpFixupArray(&jumpEndFixupArray); - return code; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileIncrCmd -- - * - * Procedure called to compile the "incr" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "incr" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -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); - - PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX, - &localIndex, &isScalar, 1); - - /* - * If an increment is given, push it, but see first if it's a small - * integer. - */ - - haveImmValue = 0; - immValue = 1; - if (parsePtr->numWords == 3) { - incrTokenPtr = TokenAfter(varTokenPtr); - if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - const char *word = incrTokenPtr[1].start; - size_t numBytes = incrTokenPtr[1].size; - int code; - Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes); - - Tcl_IncrRefCount(intObj); - code = TclGetIntFromObj(NULL, intObj, &immValue); - TclDecrRefCount(intObj); - if ((code == TCL_OK) && (-127 <= immValue) && (immValue <= 127)) { - haveImmValue = 1; - } - if (!haveImmValue) { - PushLiteral(envPtr, word, numBytes); - } - } else { - SetLineInformation(2); - CompileTokens(envPtr, incrTokenPtr, interp); - } - } else { /* No incr amount given so use 1. */ - haveImmValue = 1; - } - - /* - * Emit the instruction to increment the variable. - */ - - if (isScalar) { /* Simple scalar variable. */ - if (localIndex >= 0) { - if (haveImmValue) { - TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr); - TclEmitInt1(immValue, envPtr); - } else { - TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr); - } - } else { - if (haveImmValue) { - TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr); - } else { - TclEmitOpcode( INST_INCR_STK, envPtr); - } - } - } else { /* Simple array variable. */ - if (localIndex >= 0) { - if (haveImmValue) { - TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr); - TclEmitInt1(immValue, envPtr); - } else { - TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr); - } - } else { - if (haveImmValue) { - TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr); - } else { - TclEmitOpcode( INST_INCR_ARRAY_STK, envPtr); - } - } - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileInfo*Cmd -- - * - * Procedures called to compile "info" subcommands. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "info" subcommand at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileInfoCommandsCmd( - 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) -{ - 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); - } else if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { - goto notCompilable; - } - bytes = TclGetString(objPtr); - - /* - * We require that the argument start with "::" and not have any of "*\[?" - * in it. (Theoretically, we should look in only the final component, but - * the difference is so slight given current naming practices.) - */ - - if (bytes[0] != ':' || bytes[1] != ':' || !TclMatchIsTrivial(bytes)) { - goto notCompilable; - } - Tcl_DecrRefCount(objPtr); - - /* - * Confirmed as a literal that will not frighten the horses. Compile. Note - * that the result needs to be list-ified. - */ - - /* TODO: Just push the known value */ - CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_STR_LEN, envPtr); - TclEmitInstInt1( INST_JUMP_FALSE1, 7, envPtr); - TclEmitInstInt4( INST_LIST, 1, envPtr); - return TCL_OK; - - 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) { - return TCL_ERROR; - } - - /* - * Not much to do; we compile to a single instruction... - */ - - TclEmitOpcode( INST_COROUTINE_NAME, envPtr); - return TCL_OK; -} - -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 - * to emit code to compute and push the name at runtime. We use a frame - * slot (entry in the array of local vars) if we are compiling a procedure - * body and if the name is simple text that does not include namespace - * qualifiers. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex, &isScalar, 1); - - /* - * Emit instruction to check the variable for existence. - */ - - if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode( INST_EXIST_STK, envPtr); - } else { - TclEmitInstInt4( INST_EXIST_SCALAR, localIndex, envPtr); - } - } else { - if (localIndex < 0) { - TclEmitOpcode( INST_EXIST_ARRAY_STK, envPtr); - } else { - TclEmitInstInt4( INST_EXIST_ARRAY, localIndex, envPtr); - } - } - - return TCL_OK; -} - -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) { - /* - * Not much to do; we compile to a single instruction... - */ - - TclEmitOpcode( INST_INFO_LEVEL_NUM, envPtr); - } else if (parsePtr->numWords != 2) { - return TCL_ERROR; - } else { - DefineLineInformation; /* TIP #280 */ - - /* - * Compile the argument, then add the instruction to convert it into a - * list of arguments. - */ - - CompileWord(envPtr, TokenAfter(parsePtr->tokenPtr), interp, 1); - TclEmitOpcode( INST_INFO_LEVEL_ARGS, envPtr); - } - return TCL_OK; -} - -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 ]. The first three - * words are compressed to a single token by the ensemble compilation - * engine. - */ - - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size < 1 - || strncmp(tokenPtr[1].start, "object", tokenPtr[1].size)) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(tokenPtr); - - /* - * Issue the code. - */ - - CompileWord(envPtr, tokenPtr, interp, 2); - TclEmitOpcode( INST_TCLOO_IS_OBJECT, envPtr); - return TCL_OK; -} - -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; - } - CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitOpcode( INST_TCLOO_NS, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLappendCmd -- - * - * Procedure called to compile the "lappend" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "lappend" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -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; - } - - if (numWords != 3 || envPtr->procPtr == NULL) { - goto lappendMultiple; - } - - /* - * Decide if we can use a frame slot for the var/array name or if we - * need to emit code to compute and push the name at runtime. We use a - * frame slot (entry in the array of local vars) if we are compiling a - * procedure body and if the name is simple text that does not include - * namespace qualifiers. - */ - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - - PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &isScalar, 1); - - /* - * If we are doing an assignment, push the new value. In the no values - * case, create an empty object. - */ - - if (numWords > 2) { - valueTokenPtr = TokenAfter(varTokenPtr); - - CompileWord(envPtr, valueTokenPtr, interp, 2); - } - - /* - * Emit instructions to set/get the variable. - */ - - /* - * The *_STK opcodes should be refactored to make better use of existing - * LOAD/STORE instructions. - */ - - if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode( INST_LAPPEND_STK, envPtr); - } else { - Emit14Inst( INST_LAPPEND_SCALAR, localIndex, envPtr); - } - } else { - if (localIndex < 0) { - TclEmitOpcode( INST_LAPPEND_ARRAY_STK, envPtr); - } else { - Emit14Inst( INST_LAPPEND_ARRAY, localIndex, envPtr); - } - } - - return TCL_OK; - - lappendMultiple: - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &isScalar, 1); - valueTokenPtr = TokenAfter(varTokenPtr); - for (i = 2 ; i < numWords ; i++) { - CompileWord(envPtr, valueTokenPtr, interp, i); - valueTokenPtr = TokenAfter(valueTokenPtr); - } - TclEmitInstInt4( INST_LIST, numWords - 2, envPtr); - if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode( INST_LAPPEND_LIST_STK, envPtr); - } else { - TclEmitInstInt4(INST_LAPPEND_LIST, localIndex, envPtr); - } - } else { - if (localIndex < 0) { - TclEmitOpcode( INST_LAPPEND_LIST_ARRAY_STK, envPtr); - } else { - TclEmitInstInt4(INST_LAPPEND_LIST_ARRAY, localIndex,envPtr); - } - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLassignCmd -- - * - * Procedure called to compile the "lassign" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "lassign" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -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. - */ - - if (numWords < 3) { - return TCL_ERROR; - } - - /* - * Generate code to push list being taken apart by [lassign]. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - - /* - * Generate code to assign values from the list to variables. - */ - - for (idx=0 ; idx= 0) { - TclEmitOpcode( INST_DUP, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } else { - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - TclEmitOpcode( INST_STORE_STK, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - } else { - if (localIndex >= 0) { - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } else { - TclEmitInstInt4(INST_OVER, 2, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - } - } - - /* - * Generate code to leave the rest of the list on the stack. - */ - - TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); - TclEmitInt4( (int)TCL_INDEX_END, envPtr); - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLindexCmd -- - * - * Procedure called to compile the "lindex" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "lindex" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileLindexCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - TCL_UNUSED(Command *), - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - DefineLineInformation; /* TIP #280 */ - Tcl_Token *idxTokenPtr, *valTokenPtr; - int i, idx, numWords = parsePtr->numWords; - - /* - * Quit if not enough args. - */ - - /* TODO: Consider support for compiling expanded args. */ - if (numWords <= 1) { - return TCL_ERROR; - } - - valTokenPtr = TokenAfter(parsePtr->tokenPtr); - if (numWords != 3) { - goto emitComplexLindex; - } - - idxTokenPtr = TokenAfter(valTokenPtr); - if (TclGetIndexFromToken(idxTokenPtr, TCL_INDEX_NONE, - TCL_INDEX_NONE, &idx) == TCL_OK) { - /* - * The idxTokenPtr parsed as a valid index value and was - * encoded as expected by INST_LIST_INDEX_IMM. - * - * NOTE: that we rely on indexing before a list producing the - * same result as indexing after a list. - */ - - CompileWord(envPtr, valTokenPtr, interp, 1); - TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr); - return TCL_OK; - } - - /* - * If the value was not known at compile time, the conversion failed or - * the value was negative, we just keep on going with the more complex - * compilation. - */ - - /* - * Push the operands onto the stack. - */ - - emitComplexLindex: - for (i=1 ; inumWords == 1) { - /* - * [list] without arguments just pushes an empty object. - */ - - PushStringLiteral(envPtr, ""); - return TCL_OK; - } - - /* - * Test if all arguments are compile-time known. If they are, we can - * implement with a simple push. - */ - - numWords = parsePtr->numWords; - valueTokenPtr = TokenAfter(parsePtr->tokenPtr); - TclNewObj(listObj); - for (i = 1; i < numWords && listObj != NULL; i++) { - TclNewObj(objPtr); - if (TclWordKnownAtCompileTime(valueTokenPtr, objPtr)) { - (void) Tcl_ListObjAppendElement(NULL, listObj, objPtr); - } else { - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(listObj); - listObj = NULL; - } - valueTokenPtr = TokenAfter(valueTokenPtr); - } - if (listObj != NULL) { - TclEmitPush(TclAddLiteralObj(envPtr, listObj, NULL), envPtr); - return TCL_OK; - } - - /* - * Push the all values onto the stack. - */ - - numWords = parsePtr->numWords; - valueTokenPtr = TokenAfter(parsePtr->tokenPtr); - concat = build = 0; - for (i = 1; i < numWords; i++) { - if (valueTokenPtr->type == TCL_TOKEN_EXPAND_WORD && build > 0) { - TclEmitInstInt4( INST_LIST, build, envPtr); - if (concat) { - TclEmitOpcode( INST_LIST_CONCAT, envPtr); - } - build = 0; - concat = 1; - } - CompileWord(envPtr, valueTokenPtr, interp, i); - if (valueTokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - if (concat) { - TclEmitOpcode( INST_LIST_CONCAT, envPtr); - } else { - concat = 1; - } - } else { - build++; - } - valueTokenPtr = TokenAfter(valueTokenPtr); - } - if (build > 0) { - TclEmitInstInt4( INST_LIST, build, envPtr); - if (concat) { - TclEmitOpcode( INST_LIST_CONCAT, envPtr); - } - } - - /* - * If there was just one expanded word, we must ensure that it is a list - * at this point. We use an [lrange ... 0 end] for this (instead of - * [llength], as with literals) as we must drop any string representation - * that might be hanging around. - */ - - if (concat && numWords == 2) { - TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( (int)TCL_INDEX_END, envPtr); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLlengthCmd -- - * - * Procedure called to compile the "llength" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "llength" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -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); - TclEmitOpcode( INST_LIST_LENGTH, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLrangeCmd -- - * - * How to compile the "lrange" command. We only bother because we needed - * the opcode anyway for "lassign". - * - *---------------------------------------------------------------------- - */ - -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); - - tokenPtr = TokenAfter(listTokenPtr); - if ((TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_NONE, - &idx1) != TCL_OK) || (idx1 == (int)TCL_INDEX_NONE)) { - return TCL_ERROR; - } - /* - * Token was an index value, and we treat all "first" indices - * before the list same as the start of the list. - */ - - tokenPtr = TokenAfter(tokenPtr); - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_NONE, TCL_INDEX_END, - &idx2) != TCL_OK) { - return TCL_ERROR; - } - /* - * Token was an index value, and we treat all "last" indices - * after the list same as the end of the list. - */ - - /* - * Issue instructions. It's not safe to skip doing the LIST_RANGE, as - * we've not proved that the 'list' argument is really a list. Not that it - * is worth trying to do that given current knowledge. - */ - - CompileWord(envPtr, listTokenPtr, interp, 1); - TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); - TclEmitInt4( idx2, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLinsertCmd -- - * - * How to compile the "linsert" command. We only bother with the case - * where the index is constant. - * - *---------------------------------------------------------------------- - */ - -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); - - /* - * Parse the index. Will only compile if it is constant and not an - * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing) or an end-based index greater than 'end' itself. - */ - - tokenPtr = TokenAfter(listTokenPtr); - - /* - * NOTE: This command treats all inserts at indices before the list - * the same as inserts at the start of the list, and all inserts - * after the list the same as inserts at the end of the list. We - * make that transformation here so we can use the optimized bytecode - * as much as possible. - */ - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_END, - &idx) != TCL_OK) { - return TCL_ERROR; - } - - /* - * There are four main cases. If there are no values to insert, this is - * just a confirm-listiness check. If the index is '0', this is a prepend. - * If the index is 'end' (== TCL_INDEX_END), this is an append. Otherwise, - * this is a splice (== split, insert values as list, concat-3). - */ - - CompileWord(envPtr, listTokenPtr, interp, 1); - if (parsePtr->numWords == 3) { - TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( (int)TCL_INDEX_END, envPtr); - return TCL_OK; - } - - for (i=3 ; inumWords ; i++) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, i); - } - TclEmitInstInt4( INST_LIST, i - 3, envPtr); - - if (idx == (int)TCL_INDEX_START) { - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitOpcode( INST_LIST_CONCAT, envPtr); - } else if (idx == (int)TCL_INDEX_END) { - TclEmitOpcode( INST_LIST_CONCAT, envPtr); - } else { - /* - * Here we handle two ranges for idx. First when idx > 0, we - * want the first half of the split to end at index idx-1 and - * the second half to start at index idx. - * Second when idx < TCL_INDEX_END, indicating "end-N" indexing, - * we want the first half of the split to end at index end-N and - * the second half to start at index end-N+1. We accomplish this - * with a pre-adjustment of the end-N value. - * The root of this is that the commands [lrange] and [linsert] - * differ in their interpretation of the "end" index. - */ - - if (idx < (int)TCL_INDEX_END) { - idx++; - } - TclEmitInstInt4( INST_OVER, 1, envPtr); - TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( idx - 1, envPtr); - TclEmitInstInt4( INST_REVERSE, 3, envPtr); - TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); - TclEmitInt4( (int)TCL_INDEX_END, envPtr); - TclEmitOpcode( INST_LIST_CONCAT, envPtr); - TclEmitOpcode( INST_LIST_CONCAT, envPtr); - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLreplaceCmd -- - * - * How to compile the "lreplace" command. We only bother with the case - * where the indices are constant. - * - *---------------------------------------------------------------------- - */ - -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); - - tokenPtr = TokenAfter(listTokenPtr); - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_NONE, - &idx1) != TCL_OK) { - return TCL_ERROR; - } - - tokenPtr = TokenAfter(tokenPtr); - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_NONE, TCL_INDEX_END, - &idx2) != TCL_OK) { - return TCL_ERROR; - } - - /* - * General structure of the [lreplace] result is - * prefix replacement suffix - * In a few cases we can predict various parts will be empty and - * take advantage. - * - * The proper suffix begins with the greater of indices idx1 or - * idx2 + 1. If we cannot tell at compile time which is greater, - * we must defer to direct evaluation. - */ - - if (idx1 == (int)TCL_INDEX_NONE) { - suffixStart = (int)TCL_INDEX_NONE; - } else if (idx2 == (int)TCL_INDEX_NONE) { - suffixStart = idx1; - } else if (idx2 == (int)TCL_INDEX_END) { - suffixStart = (int)TCL_INDEX_NONE; - } else if (((idx2 < (int)TCL_INDEX_END) && (idx1 <= (int)TCL_INDEX_END)) - || ((idx2 >= (int)TCL_INDEX_START) && (idx1 >= (int)TCL_INDEX_START))) { - suffixStart = (idx1 > idx2 + 1) ? idx1 : idx2 + 1; - } else { - return TCL_ERROR; - } - - /* All paths start with computing/pushing the original value. */ - CompileWord(envPtr, listTokenPtr, interp, 1); - - /* - * Push all the replacement values next so any errors raised in - * creating them get raised first. - */ - if (parsePtr->numWords > 4) { - /* Push the replacement arguments */ - tokenPtr = TokenAfter(tokenPtr); - for (i=4 ; inumWords ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); - tokenPtr = TokenAfter(tokenPtr); - } - - /* Make a list of them... */ - TclEmitInstInt4( INST_LIST, i - 4, envPtr); - - emptyPrefix = 0; - } - - if ((idx1 == suffixStart) && (parsePtr->numWords == 4)) { - /* - * This is a "no-op". Example: [lreplace {a b c} 2 0] - * We still do a list operation to get list-verification - * and canonicalization side effects. - */ - TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( (int)TCL_INDEX_END, envPtr); - return TCL_OK; - } - - if (idx1 != (int)TCL_INDEX_START) { - /* Prefix may not be empty; generate bytecode to push it */ - if (emptyPrefix) { - TclEmitOpcode( INST_DUP, envPtr); - } else { - TclEmitInstInt4( INST_OVER, 1, envPtr); - } - TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( idx1 - 1, envPtr); - if (!emptyPrefix) { - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitOpcode( INST_LIST_CONCAT, envPtr); - } - emptyPrefix = 0; - } - - if (!emptyPrefix) { - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - } - - if (suffixStart == (int)TCL_INDEX_NONE) { - TclEmitOpcode( INST_POP, envPtr); - if (emptyPrefix) { - PushStringLiteral(envPtr, ""); - } - } else { - /* Suffix may not be empty; generate bytecode to push it */ - TclEmitInstInt4( INST_LIST_RANGE_IMM, suffixStart, envPtr); - TclEmitInt4( (int)TCL_INDEX_END, envPtr); - if (!emptyPrefix) { - TclEmitOpcode( INST_LIST_CONCAT, envPtr); - } - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLsetCmd -- - * - * Procedure called to compile the "lset" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "lset" command at - * runtime. - * - * The general template for execution of the "lset" command is: - * (1) Instructions to push the variable name, unless the variable is - * local to the stack frame. - * (2) If the variable is an array element, instructions to push the - * array element name. - * (3) Instructions to push each of zero or more "index" arguments to the - * stack, followed with the "newValue" element. - * (4) Instructions to duplicate the variable name and/or array element - * name onto the top of the stack, if either was pushed at steps (1) - * and (2). - * (5) The appropriate INST_LOAD_* instruction to place the original - * value of the list variable at top of stack. - * (6) At this point, the stack contains: - * varName? arrayElementName? index1 index2 ... newValue oldList - * The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST - * according as whether there is exactly one index element (LIST) or - * either zero or else two or more (FLAT). This instruction removes - * everything from the stack except for the two names and pushes the - * new value of the variable. - * (7) Finally, INST_STORE_* stores the new value in the variable and - * cleans up the stack. - * - *---------------------------------------------------------------------- - */ - -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) { - /* - * Fail at run time, not in compilation. - */ - - return TCL_ERROR; - } - - /* - * Decide if we can use a frame slot for the var/array name or if we need - * to emit code to compute and push the name at runtime. We use a frame - * slot (entry in the array of local vars) if we are compiling a procedure - * body and if the name is simple text that does not include namespace - * qualifiers. - */ - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &isScalar, 1); - - /* - * Push the "index" args and the new element value. - */ - - for (i=2 ; inumWords ; ++i) { - varTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, varTokenPtr, interp, i); - } - - /* - * Duplicate the variable name if it's been pushed. - */ - - if (localIndex < 0) { - if (isScalar) { - tempDepth = parsePtr->numWords - 2; - } else { - tempDepth = parsePtr->numWords - 1; - } - TclEmitInstInt4( INST_OVER, tempDepth, envPtr); - } - - /* - * Duplicate an array index if one's been pushed. - */ - - if (!isScalar) { - if (localIndex < 0) { - tempDepth = parsePtr->numWords - 1; - } else { - tempDepth = parsePtr->numWords - 2; - } - TclEmitInstInt4( INST_OVER, tempDepth, envPtr); - } - - /* - * Emit code to load the variable's value. - */ - - if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode( INST_LOAD_STK, envPtr); - } else { - Emit14Inst( INST_LOAD_SCALAR, localIndex, envPtr); - } - } else { - if (localIndex < 0) { - TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr); - } else { - Emit14Inst( INST_LOAD_ARRAY, localIndex, envPtr); - } - } - - /* - * Emit the correct variety of 'lset' instruction. - */ - - if (parsePtr->numWords == 4) { - TclEmitOpcode( INST_LSET_LIST, envPtr); - } else { - TclEmitInstInt4( INST_LSET_FLAT, parsePtr->numWords-1, envPtr); - } - - /* - * Emit code to put the value back in the variable. - */ - - if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode( INST_STORE_STK, envPtr); - } else { - Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); - } - } else { - if (localIndex < 0) { - TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); - } else { - Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); - } - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileNamespace*Cmd -- - * - * Procedures called to compile the "namespace" command; currently, only - * the subcommands "namespace current" and "namespace upvar" are compiled - * to bytecodes, and the latter only inside a procedure(-like) context. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "namespace upvar" - * 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) { - return TCL_ERROR; - } - - /* - * Not much to do; we compile to a single instruction... - */ - - TclEmitOpcode( INST_NS_CURRENT, envPtr); - return TCL_OK; -} - -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); - - /* - * The specification of [namespace code] is rather shocking, in that it is - * supposed to check if the argument is itself the result of [namespace - * code] and not apply itself in that case. Which is excessively cautious, - * but what the test suite checks for. - */ - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || (tokenPtr[1].size > 20 - && strncmp(tokenPtr[1].start, "::namespace inscope ", 20) == 0)) { - /* - * Technically, we could just pass a literal '::namespace inscope ' - * term through, but that's something which really shouldn't be - * occurring as something that the user writes so we'll just punt it. - */ - - return TCL_ERROR; - } - - /* - * Now we can compile using the same strategy as [namespace code]'s normal - * implementation does internally. Note that we can't bind the namespace - * name directly here, because TclOO plays complex games with namespaces; - * the value needs to be determined at runtime for safety. - */ - - PushStringLiteral(envPtr, "::namespace"); - PushStringLiteral(envPtr, "inscope"); - TclEmitOpcode( INST_NS_CURRENT, envPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitInstInt4( INST_LIST, 4, envPtr); - return TCL_OK; -} - -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); - PushStringLiteral(envPtr, "0"); - PushStringLiteral(envPtr, "::"); - TclEmitInstInt4( INST_OVER, 2, envPtr); - TclEmitOpcode( INST_STR_FIND_LAST, envPtr); - off = CurrentOffset(envPtr); - PushStringLiteral(envPtr, "1"); - TclEmitOpcode( INST_SUB, envPtr); - TclEmitInstInt4( INST_OVER, 2, envPtr); - TclEmitInstInt4( INST_OVER, 1, envPtr); - TclEmitOpcode( INST_STR_INDEX, envPtr); - PushStringLiteral(envPtr, ":"); - TclEmitOpcode( INST_STR_EQ, envPtr); - off = off - CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_TRUE1, off, envPtr); - TclEmitOpcode( INST_STR_RANGE, envPtr); - return TCL_OK; -} - -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; - } - - /* - * Take care; only add 2 to found index if the string was actually found. - */ - - CompileWord(envPtr, tokenPtr, interp, 1); - PushStringLiteral(envPtr, "::"); - TclEmitInstInt4( INST_OVER, 1, envPtr); - TclEmitOpcode( INST_STR_FIND_LAST, envPtr); - TclEmitOpcode( INST_DUP, envPtr); - PushStringLiteral(envPtr, "0"); - TclEmitOpcode( INST_GE, envPtr); - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFixup); - PushStringLiteral(envPtr, "2"); - TclEmitOpcode( INST_ADD, envPtr); - TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127); - PushStringLiteral(envPtr, "end"); - TclEmitOpcode( INST_STR_RANGE, envPtr); - return TCL_OK; -} - -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 - */ - - numWords = parsePtr->numWords; - if ((numWords % 2) || (numWords < 4)) { - return TCL_ERROR; - } - - /* - * Push the namespace - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - - /* - * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a - * local variable, return an error so that the non-compiled command will - * be called at runtime. - */ - - localTokenPtr = tokenPtr; - for (i=2; inumWords < 2 || parsePtr->numWords > 3) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - idx = 1; - - /* - * If there's an option, check that it's "-command". We don't handle - * "-variable" (currently) and anything else is an error. - */ - - if (parsePtr->numWords == 3) { - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - opt = tokenPtr + 1; - if (opt->size < 2 || opt->size > 8 - || strncmp(opt->start, "-command", opt->size) != 0) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(tokenPtr); - idx++; - } - - /* - * Issue the bytecode. - */ - - CompileWord(envPtr, tokenPtr, interp, idx); - TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileRegexpCmd -- - * - * Procedure called to compile the "regexp" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "regexp" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -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. */ - size_t len; - int i, 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 - */ - - if (parsePtr->numWords < 3) { - return TCL_ERROR; - } - - simple = 0; - nocase = 0; - sawLast = 0; - varTokenPtr = parsePtr->tokenPtr; - - /* - * We only look for -nocase and -- as options. Everything else gets pushed - * to runtime execution. This is different than regexp's runtime option - * handling, but satisfies our stricter needs. - */ - - for (i = 1; i < parsePtr->numWords - 2; i++) { - varTokenPtr = TokenAfter(varTokenPtr); - if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - /* - * Not a simple string, so punt to runtime. - */ - - return TCL_ERROR; - } - 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; - } - } - - if ((parsePtr->numWords - i) != 2) { - /* - * We don't support capturing to variables. - */ - - return TCL_ERROR; - } - - /* - * Get the regexp string. If it is not a simple string or can't be - * converted to a glob pattern, push the word for the INST_REGEXP. - * Keep changes here in sync with TclCompileSwitchCmd Switch_Regexp. - */ - - varTokenPtr = TokenAfter(varTokenPtr); - - if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - Tcl_DString ds; - - str = varTokenPtr[1].start; - len = varTokenPtr[1].size; - - /* - * If it has a '-', it could be an incorrectly formed regexp command. - */ - - if ((*str == '-') && !sawLast) { - return TCL_ERROR; - } - - if (len == 0) { - /* - * The semantics of regexp are always match on re == "". - */ - - PushStringLiteral(envPtr, "1"); - return TCL_OK; - } - - /* - * Attempt to convert pattern to glob. If successful, push the - * converted pattern as a literal. - */ - - if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact, NULL) - == TCL_OK) { - simple = 1; - PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds)); - Tcl_DStringFree(&ds); - } - } - - if (!simple) { - CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords - 2); - } - - /* - * Push the string arg. - */ - - varTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords - 1); - - if (simple) { - if (exact && !nocase) { - TclEmitOpcode( INST_STR_EQ, envPtr); - } else { - TclEmitInstInt1( INST_STR_MATCH, nocase, envPtr); - } - } else { - /* - * Pass correct RE compile flags. We use only Int1 (8-bit), but - * that handles all the flags we want to pass. - * Don't use TCL_REG_NOSUB as we may have backrefs. - */ - - int cflags = TCL_REG_ADVANCED | (nocase ? TCL_REG_NOCASE : 0); - - TclEmitInstInt1( INST_REGEXP, cflags, envPtr); - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileRegsubCmd -- - * - * Procedure called to compile the "regsub" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "regsub" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -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. - * The substitution string must also be known at compile time and free of - * metacharacters ("\digit" and "&"). Finally, there must not be a - * variable mentioned in the [regsub] to write the result back to (because - * we can't get the count of substitutions that would be the result in - * that case). The key is that these are the conditions under which a - * [string map] could be used instead, in particular a [string map] of the - * form we can compile to bytecode. - * - * In short, we look for: - * - * regsub -all [--] simpleRE string simpleReplacement - * - * The only optional part is the "--", and no other options are handled. - */ - - DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr, *stringTokenPtr; - Tcl_Obj *patternObj = NULL, *replacementObj = NULL; - Tcl_DString pattern; - const char *bytes; - int exact, quantified, result = TCL_ERROR; - size_t len; - - if (parsePtr->numWords < 5 || parsePtr->numWords > 6) { - return TCL_ERROR; - } - - /* - * Parse the "-all", which must be the first argument (other options not - * supported, non-"-all" substitution we can't compile). - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size != 4 - || strncmp(tokenPtr[1].start, "-all", 4)) { - return TCL_ERROR; - } - - /* - * Get the pattern into patternObj, checking for "--" in the process. - */ - - Tcl_DStringInit(&pattern); - tokenPtr = TokenAfter(tokenPtr); - TclNewObj(patternObj); - if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { - goto done; - } - if (TclGetString(patternObj)[0] == '-') { - if (strcmp(TclGetString(patternObj), "--") != 0 - || parsePtr->numWords == 5) { - goto done; - } - tokenPtr = TokenAfter(tokenPtr); - Tcl_DecrRefCount(patternObj); - TclNewObj(patternObj); - if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { - goto done; - } - } else if (parsePtr->numWords == 6) { - goto done; - } - - /* - * Identify the code which produces the string to apply the substitution - * to (stringTokenPtr), and the replacement string (into replacementObj). - */ - - stringTokenPtr = TokenAfter(tokenPtr); - tokenPtr = TokenAfter(stringTokenPtr); - TclNewObj(replacementObj); - if (!TclWordKnownAtCompileTime(tokenPtr, replacementObj)) { - goto done; - } - - /* - * Next, higher-level checks. Is the RE a very simple glob? Is the - * replacement "simple"? - */ - - bytes = TclGetStringFromObj(patternObj, &len); - if (TclReToGlob(NULL, bytes, len, &pattern, &exact, &quantified) - != TCL_OK || exact || quantified) { - goto done; - } - bytes = Tcl_DStringValue(&pattern); - if (*bytes++ != '*') { - goto done; - } - while (1) { - switch (*bytes) { - case '*': - 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 + 2 > 2) { - goto isSimpleGlob; - } - - /* - * The pattern is "**"! I believe that should be impossible, - * but we definitely can't handle that at all. - */ - } - case '\0': case '?': case '[': case '\\': - goto done; - } - bytes++; - } - isSimpleGlob: - for (bytes = TclGetString(replacementObj); *bytes; bytes++) { - switch (*bytes) { - case '\\': case '&': - goto done; - } - } - - /* - * Proved the simplicity constraints! Time to issue the code. - */ - - result = TCL_OK; - bytes = Tcl_DStringValue(&pattern) + 1; - PushLiteral(envPtr, bytes, len); - bytes = TclGetStringFromObj(replacementObj, &len); - PushLiteral(envPtr, bytes, len); - CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords - 2); - TclEmitOpcode( INST_STR_MAP, envPtr); - - done: - Tcl_DStringFree(&pattern); - if (patternObj) { - Tcl_DecrRefCount(patternObj); - } - if (replacementObj) { - Tcl_DecrRefCount(replacementObj); - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileReturnCmd -- - * - * Procedure called to compile the "return" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "return" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -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 - * 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 - * ('finally' clause processing) this piece of code would not be present. - */ - - if ((numWords == 4) && (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) - && (wordTokenPtr[1].size == 8) - && (strncmp(wordTokenPtr[1].start, "-options", 8) == 0)) { - Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr); - Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr); - - CompileWord(envPtr, optsTokenPtr, interp, 2); - CompileWord(envPtr, msgTokenPtr, interp, 3); - TclEmitInvoke(envPtr, INST_RETURN_STK); - return TCL_OK; - } - - /* - * Allocate some working space. - */ - - objv = (Tcl_Obj **)TclStackAlloc(interp, numOptionWords * sizeof(Tcl_Obj *)); - - /* - * Scan through the return options. If any are unknown at compile time, - * there is no value in bytecompiling. Save the option values known in an - * objv array for merging into a return options dictionary. - * - * TODO: There is potential for improvement if all option keys are known - * at compile time and all option values relating to '-code' and '-level' - * are known at compile time. - */ - - for (objc = 0; objc < numOptionWords; objc++) { - TclNewObj(objv[objc]); - Tcl_IncrRefCount(objv[objc]); - if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { - /* - * Non-literal, so punt to run-time assembly of the dictionary. - */ - - for (; objc>=0 ; objc--) { - TclDecrRefCount(objv[objc]); - } - TclStackFree(interp, objv); - goto issueRuntimeReturn; - } - wordTokenPtr = TokenAfter(wordTokenPtr); - } - status = TclMergeReturnOptions(interp, objc, objv, - &returnOpts, &code, &level); - while (--objc >= 0) { - TclDecrRefCount(objv[objc]); - } - TclStackFree(interp, objv); - if (TCL_ERROR == status) { - /* - * Something was bogus in the return options. Clear the error message, - * and report back to the compiler that this must be interpreted at - * runtime. - */ - - Tcl_ResetResult(interp); - return TCL_ERROR; - } - - /* - * All options are known at compile time, so we're going to bytecompile. - * Emit instructions to push the result on the stack. - */ - - if (explicitResult) { - CompileWord(envPtr, wordTokenPtr, interp, numWords - 1); - } else { - /* - * No explict result argument, so default result is empty string. - */ - - PushStringLiteral(envPtr, ""); - } - - /* - * Check for optimization: When [return] is in a proc, and there's no - * enclosing [catch], and there are no return options, then the INST_DONE - * instruction is equivalent, and may be more efficient. - */ - - if (numOptionWords == 0 && envPtr->procPtr != NULL) { - /* - * We have default return options and we're in a proc ... - */ - - int index = envPtr->exceptArrayNext - 1; - int enclosingCatch = 0; - - while (index >= 0) { - ExceptionRange range = envPtr->exceptArrayPtr[index]; - - if ((range.type == CATCH_EXCEPTION_RANGE) - && (range.catchOffset == -1)) { - enclosingCatch = 1; - break; - } - index--; - } - if (!enclosingCatch) { - /* - * ... and there is no enclosing catch. Issue the maximally - * efficient exit instruction. - */ - - Tcl_DecrRefCount(returnOpts); - TclEmitOpcode(INST_DONE, envPtr); - TclAdjustStackDepth(1, envPtr); - return TCL_OK; - } - } - - /* Optimize [return -level 0 $x]. */ - Tcl_DictObjSize(NULL, returnOpts, &size); - if (size == 0 && level == 0 && code == TCL_OK) { - Tcl_DecrRefCount(returnOpts); - return TCL_OK; - } - - /* - * Could not use the optimization, so we push the return options dict, and - * emit the INST_RETURN_IMM instruction with code and level as operands. - */ - - CompileReturnInternal(envPtr, INST_RETURN_IMM, code, level, returnOpts); - return TCL_OK; - - issueRuntimeReturn: - /* - * Assemble the option dictionary (as a list as that's good enough). - */ - - wordTokenPtr = TokenAfter(parsePtr->tokenPtr); - for (objc=1 ; objc<=numOptionWords ; objc++) { - CompileWord(envPtr, wordTokenPtr, interp, objc); - wordTokenPtr = TokenAfter(wordTokenPtr); - } - TclEmitInstInt4(INST_LIST, numOptionWords, envPtr); - - /* - * Push the result. - */ - - if (explicitResult) { - CompileWord(envPtr, wordTokenPtr, interp, numWords - 1); - } else { - PushStringLiteral(envPtr, ""); - } - - /* - * Issue the RETURN itself. - */ - - TclEmitInvoke(envPtr, INST_RETURN_STK); - return TCL_OK; -} - -static void -CompileReturnInternal( - CompileEnv *envPtr, - unsigned char op, - int code, - int level, - Tcl_Obj *returnOpts) -{ - if (level == 0 && (code == TCL_BREAK || code == TCL_CONTINUE)) { - ExceptionRange *rangePtr; - ExceptionAux *exceptAux; - - rangePtr = TclGetInnermostExceptionRange(envPtr, code, &exceptAux); - if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) { - TclCleanupStackForBreakContinue(envPtr, exceptAux); - if (code == TCL_BREAK) { - TclAddLoopBreakFixup(envPtr, exceptAux); - } else { - TclAddLoopContinueFixup(envPtr, exceptAux); - } - Tcl_DecrRefCount(returnOpts); - return; - } - } - - TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr); - TclEmitInstInt4(op, code, envPtr); - TclEmitInt4(level, envPtr); -} - -void -TclCompileSyntaxError( - Tcl_Interp *interp, - CompileEnv *envPtr) -{ - Tcl_Obj *msg = Tcl_GetObjResult(interp); - size_t 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); -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileUpvarCmd -- - * - * Procedure called to compile the "upvar" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "upvar" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileUpvarCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - TCL_UNUSED(Command *), - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; - int localIndex, numWords, i; - Tcl_Obj *objPtr; - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } - - numWords = parsePtr->numWords; - if (numWords < 3) { - return TCL_ERROR; - } - - /* - * Push the frame index if it is known at compile time - */ - - TclNewObj(objPtr); - tokenPtr = TokenAfter(parsePtr->tokenPtr); - if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) { - CallFrame *framePtr; - const Tcl_ObjType *newTypePtr, *typePtr = objPtr->typePtr; - - /* - * Attempt to convert to a level reference. Note that TclObjGetFrame - * only changes the obj type when a conversion was successful. - */ - - TclObjGetFrame(interp, objPtr, &framePtr); - newTypePtr = objPtr->typePtr; - Tcl_DecrRefCount(objPtr); - - if (newTypePtr != typePtr) { - if (numWords%2) { - return TCL_ERROR; - } - /* TODO: Push the known value instead? */ - CompileWord(envPtr, tokenPtr, interp, 1); - otherTokenPtr = TokenAfter(tokenPtr); - i = 2; - } else { - if (!(numWords%2)) { - return TCL_ERROR; - } - PushStringLiteral(envPtr, "1"); - otherTokenPtr = tokenPtr; - i = 1; - } - } else { - Tcl_DecrRefCount(objPtr); - return TCL_ERROR; - } - - /* - * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a - * local variable, return an error so that the non-compiled command will - * be called at runtime. - */ - - for (; inumWords; - if (numWords < 2) { - return TCL_ERROR; - } - - /* - * Bail out if not compiling a proc body - */ - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } - - /* - * Loop over the (var, value) pairs. - */ - - valueTokenPtr = parsePtr->tokenPtr; - for (i=1; inumComponents; - size_t len; - 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. - * - * In order for the tail to be known at compile time, the last token in - * the word has to be constant and contain "::" if it is not the only one. - */ - - if (!EnvHasLVT(envPtr)) { - return -1; - } - - TclNewObj(tailPtr); - if (TclWordKnownAtCompileTime(varTokenPtr, tailPtr)) { - full = 1; - lastTokenPtr = varTokenPtr; - } else { - full = 0; - lastTokenPtr = varTokenPtr + n; - - if (lastTokenPtr->type != TCL_TOKEN_TEXT) { - Tcl_DecrRefCount(tailPtr); - return -1; - } - Tcl_SetStringObj(tailPtr, lastTokenPtr->start, lastTokenPtr->size); - } - - tailName = TclGetStringFromObj(tailPtr, &len); - - if (len) { - if (*(tailName + len - 1) == ')') { - /* - * Possible array: bail out - */ - - Tcl_DecrRefCount(tailPtr); - return -1; - } - - /* - * Get the tail: immediately after the last '::' - */ - - for (p = tailName + len -1; p > tailName; p--) { - if ((*p == ':') && (*(p - 1) == ':')) { - p++; - break; - } - } - if (!full && (p == tailName)) { - /* - * No :: in the last component. - */ - - Tcl_DecrRefCount(tailPtr); - return -1; - } - len -= p - tailName; - tailName = p; - } - - localIndex = TclFindCompiledLocal(tailName, len, 1, envPtr); - Tcl_DecrRefCount(tailPtr); - return localIndex; -} - -/* - * ---------------------------------------------------------------------- - * - * TclCompileObjectNextCmd, TclCompileObjectSelfCmd -- - * - * Compilations of the TclOO utility commands [next] and [self]. - * - * ---------------------------------------------------------------------- - */ - -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) { - return TCL_ERROR; - } - - for (i=0 ; inumWords ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); - tokenPtr = TokenAfter(tokenPtr); - } - TclEmitInstInt1( INST_TCLOO_NEXT, i, envPtr); - return TCL_OK; -} - -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 ; inumWords ; 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. - */ - - if (parsePtr->numWords == 1) { - goto compileSelfObject; - } else if (parsePtr->numWords == 2) { - Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr), *subcmd; - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size==0) { - return TCL_ERROR; - } - - subcmd = tokenPtr + 1; - if (strncmp(subcmd->start, "object", subcmd->size) == 0) { - goto compileSelfObject; - } else if (strncmp(subcmd->start, "namespace", subcmd->size) == 0) { - goto compileSelfNamespace; - } - } - - /* - * Can't compile; handle with runtime call. - */ - - return TCL_ERROR; - - compileSelfObject: - - /* - * This delegates the entire problem to a single opcode. - */ - - TclEmitOpcode( INST_TCLOO_SELF, envPtr); - return TCL_OK; - - compileSelfNamespace: - - /* - * This is formally only correct with TclOO methods as they are currently - * implemented; it assumes that the current namespace is invariably when a - * TclOO context is present is the object's namespace, and that's - * technically only something that's a matter of current policy. But it - * avoids creating another opcode, so that's all good! - */ - - TclEmitOpcode( INST_TCLOO_SELF, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitOpcode( INST_NS_CURRENT, envPtr); - return TCL_OK; -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ DELETED generic/tclCompCmdsSZ.c Index: generic/tclCompCmdsSZ.c ================================================================== --- generic/tclCompCmdsSZ.c +++ /dev/null @@ -1,4590 +0,0 @@ -/* - * tclCompCmdsSZ.c -- - * - * This file contains compilation procedures that compile various Tcl - * commands (beginning with the letters 's' through 'z', except for - * [upvar] and [variable]) into a sequence of instructions ("bytecodes"). - * Also includes the operator command compilers. - * - * Copyright (c) 1997-1998 Sun Microsystems, Inc. - * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. - * Copyright (c) 2002 ActiveState Corporation. - * Copyright (c) 2004-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 "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, - int numHandlers, int *matchCodes, - Tcl_Obj **matchClauses, int *resultVarIndices, - int *optionVarIndices, Tcl_Token **handlerTokens, - Tcl_Token *finallyToken); -static int IssueTryFinallyInstructions(Tcl_Interp *interp, - CompileEnv *envPtr, Tcl_Token *bodyToken, - Tcl_Token *finallyToken); - -/* - * The structures below define the AuxData types defined in this file. - */ - -const AuxDataType tclJumptableInfoType = { - "JumptableInfo", /* name */ - DupJumptableInfo, /* dupProc */ - FreeJumptableInfo, /* freeProc */ - PrintJumptableInfo, /* printProc */ - DisassembleJumptableInfo /* disassembleProc */ -}; - -/* - * Shorthand macros for instruction issuing. - */ - -#define OP(name) TclEmitOpcode(INST_##name, envPtr) -#define OP1(name,val) TclEmitInstInt1(INST_##name,(val),envPtr) -#define OP4(name,val) TclEmitInstInt4(INST_##name,(val),envPtr) -#define OP14(name,val1,val2) \ - TclEmitInstInt1(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr) -#define OP44(name,val1,val2) \ - TclEmitInstInt4(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr) -#define PUSH(str) \ - PushStringLiteral(envPtr, str) -#define JUMP4(name,var) \ - (var) = CurrentOffset(envPtr);TclEmitInstInt4(INST_##name##4,0,envPtr) -#define FIXJUMP4(var) \ - TclStoreInt4AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1) -#define JUMP1(name,var) \ - (var) = CurrentOffset(envPtr);TclEmitInstInt1(INST_##name##1,0,envPtr) -#define FIXJUMP1(var) \ - TclStoreInt1AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1) -#define LOAD(idx) \ - if ((idx)<256) {OP1(LOAD_SCALAR1,(idx));} else {OP4(LOAD_SCALAR4,(idx));} -#define STORE(idx) \ - if ((idx)<256) {OP1(STORE_SCALAR1,(idx));} else {OP4(STORE_SCALAR4,(idx));} -#define INVOKE(name) \ - TclEmitInvoke(envPtr,INST_##name) - - -/* - *---------------------------------------------------------------------- - * - * TclCompileSetCmd -- - * - * Procedure called to compile the "set" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "set" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -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); - - /* - * Decide if we can use a frame slot for the var/array name or if we need - * to emit code to compute and push the name at runtime. We use a frame - * slot (entry in the array of local vars) if we are compiling a procedure - * body and if the name is simple text that does not include namespace - * qualifiers. - */ - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &isScalar, 1); - - /* - * If we are doing an assignment, push the new value. - */ - - if (isAssignment) { - valueTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, valueTokenPtr, interp, 2); - } - - /* - * Emit instructions to set/get the variable. - */ - - if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode((isAssignment? - INST_STORE_STK : INST_LOAD_STK), envPtr); - } else if (localIndex <= 255) { - TclEmitInstInt1((isAssignment? - INST_STORE_SCALAR1 : INST_LOAD_SCALAR1), - localIndex, envPtr); - } else { - TclEmitInstInt4((isAssignment? - INST_STORE_SCALAR4 : INST_LOAD_SCALAR4), - localIndex, envPtr); - } - } else { - if (localIndex < 0) { - TclEmitOpcode((isAssignment? - INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr); - } else if (localIndex <= 255) { - TclEmitInstInt1((isAssignment? - INST_STORE_ARRAY1 : INST_LOAD_ARRAY1), - localIndex, envPtr); - } else { - TclEmitInstInt4((isAssignment? - INST_STORE_ARRAY4 : INST_LOAD_ARRAY4), - localIndex, envPtr); - } - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileString*Cmd -- - * - * Procedures called to compile various subcommands of the "string" - * command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "string" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileStringCatCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - TCL_UNUSED(Command *), - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - DefineLineInformation; /* TIP #280 */ - int i, numWords = parsePtr->numWords, numArgs; - Tcl_Token *wordTokenPtr; - Tcl_Obj *obj, *folded; - - /* Trivial case, no arg */ - - if (numWords<2) { - PushStringLiteral(envPtr, ""); - return TCL_OK; - } - - /* General case: issue CONCAT1's (by chunks of 254 if needed), folding - contiguous constants along the way */ - - numArgs = 0; - folded = NULL; - wordTokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i = 1; i < numWords; i++) { - TclNewObj(obj); - if (TclWordKnownAtCompileTime(wordTokenPtr, obj)) { - if (folded) { - Tcl_AppendObjToObj(folded, obj); - Tcl_DecrRefCount(obj); - } else { - folded = obj; - } - } else { - Tcl_DecrRefCount(obj); - if (folded) { - size_t 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) { - size_t 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. - */ - - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - - /* - * Push the two operands onto the stack and then the test. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - TclEmitOpcode(INST_STR_CMP, envPtr); - return TCL_OK; -} - -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. - */ - - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - - /* - * Push the two operands onto the stack and then the test. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - TclEmitOpcode(INST_STR_EQ, envPtr); - return TCL_OK; -} - -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. - */ - - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - - /* - * Push the two operands onto the stack and then the test. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - OP(STR_FIND); - return TCL_OK; -} - -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. - */ - - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - - /* - * Push the two operands onto the stack and then the test. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - OP(STR_FIND_LAST); - return TCL_OK; -} - -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; - } - - /* - * Push the two operands onto the stack and then the index operation. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - TclEmitOpcode(INST_STR_INDEX, envPtr); - return TCL_OK; -} - -int -TclCompileStringInsertCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - TCL_UNUSED(Command *), - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr; - int idx; - - if (parsePtr->numWords != 4) { - return TCL_ERROR; - } - - /* Compute and push the string in which to insert */ - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - - /* See what can be discovered about index at compile time */ - tokenPtr = TokenAfter(tokenPtr); - if (TCL_OK != TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, - TCL_INDEX_END, &idx)) { - - /* Nothing useful knowable - cease compile; let it direct eval */ - return TCL_ERROR; - } - - /* Compute and push the string to be inserted */ - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 3); - - if (idx == (int)TCL_INDEX_START) { - /* Prepend the insertion string */ - OP4( REVERSE, 2); - OP1( STR_CONCAT1, 2); - } else if (idx == (int)TCL_INDEX_END) { - /* Append the insertion string */ - OP1( STR_CONCAT1, 2); - } else { - /* Prefix + insertion + suffix */ - if (idx < (int)TCL_INDEX_END) { - /* See comments in compiler for [linsert]. */ - idx++; - } - OP4( OVER, 1); - OP44( STR_RANGE_IMM, 0, idx-1); - OP4( REVERSE, 3); - OP44( STR_RANGE_IMM, idx, TCL_INDEX_END); - OP1( STR_CONCAT1, 3); - } - - return TCL_OK; -} - -int -TclCompileStringIsCmd( - 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 *tokenPtr = TokenAfter(parsePtr->tokenPtr); - static const char *const isClasses[] = { - "alnum", "alpha", "ascii", "control", - "boolean", "dict", "digit", "double", "entier", - "false", "graph", "integer", "list", - "lower", "print", "punct", "space", - "true", "upper", "wideinteger", "wordchar", - "xdigit", NULL - }; - enum isClassesEnum { - STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, - STR_IS_BOOL, STR_IS_DICT, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER, - STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST, - STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, - STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD, - STR_IS_XDIGIT - }; - int t, range, allowEmpty = 0, end; - InstStringClassType strClassType; - Tcl_Obj *isClass; - - if (parsePtr->numWords < 3 || parsePtr->numWords > 6) { - return TCL_ERROR; - } - TclNewObj(isClass); - if (!TclWordKnownAtCompileTime(tokenPtr, isClass)) { - Tcl_DecrRefCount(isClass); - return TCL_ERROR; - } else if (Tcl_GetIndexFromObj(interp, isClass, isClasses, "class", 0, - &t) != TCL_OK) { - Tcl_DecrRefCount(isClass); - TclCompileSyntaxError(interp, envPtr); - return TCL_OK; - } - Tcl_DecrRefCount(isClass); - -#define GotLiteral(tokenPtr, word) \ - ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD && \ - (tokenPtr)[1].size > 1 && \ - (tokenPtr)[1].start[0] == word[0] && \ - strncmp((tokenPtr)[1].start, (word), (tokenPtr)[1].size) == 0) - - /* - * Cannot handle the -failindex option at all, and that's the only legal - * way to have more than 4 arguments. - */ - - if (parsePtr->numWords != 3 && parsePtr->numWords != 4) { - return TCL_ERROR; - } - - tokenPtr = TokenAfter(tokenPtr); - if (parsePtr->numWords == 3) { - allowEmpty = 1; - } else { - if (!GotLiteral(tokenPtr, "-strict")) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(tokenPtr); - } -#undef GotLiteral - - /* - * Compile the code. There are several main classes of check here. - * 1. Character classes - * 2. Booleans - * 3. Integers - * 4. Floats - * 5. Lists - */ - - CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); - - switch ((enum isClassesEnum) t) { - case STR_IS_ALNUM: - strClassType = STR_CLASS_ALNUM; - goto compileStrClass; - case STR_IS_ALPHA: - strClassType = STR_CLASS_ALPHA; - goto compileStrClass; - case STR_IS_ASCII: - strClassType = STR_CLASS_ASCII; - goto compileStrClass; - case STR_IS_CONTROL: - strClassType = STR_CLASS_CONTROL; - goto compileStrClass; - case STR_IS_DIGIT: - strClassType = STR_CLASS_DIGIT; - goto compileStrClass; - case STR_IS_GRAPH: - strClassType = STR_CLASS_GRAPH; - goto compileStrClass; - case STR_IS_LOWER: - strClassType = STR_CLASS_LOWER; - goto compileStrClass; - case STR_IS_PRINT: - strClassType = STR_CLASS_PRINT; - goto compileStrClass; - case STR_IS_PUNCT: - strClassType = STR_CLASS_PUNCT; - goto compileStrClass; - case STR_IS_SPACE: - strClassType = STR_CLASS_SPACE; - goto compileStrClass; - case STR_IS_UPPER: - strClassType = STR_CLASS_UPPER; - goto compileStrClass; - case STR_IS_WORD: - strClassType = STR_CLASS_WORD; - goto compileStrClass; - case STR_IS_XDIGIT: - strClassType = STR_CLASS_XDIGIT; - compileStrClass: - if (allowEmpty) { - OP1( STR_CLASS, strClassType); - } else { - int over, over2; - - OP( DUP); - OP1( STR_CLASS, strClassType); - JUMP1( JUMP_TRUE, over); - OP( POP); - PUSH( "0"); - JUMP1( JUMP, over2); - FIXJUMP1(over); - PUSH( ""); - OP( STR_NEQ); - FIXJUMP1(over2); - } - return TCL_OK; - - case STR_IS_BOOL: - case STR_IS_FALSE: - case STR_IS_TRUE: - OP( TRY_CVT_TO_BOOLEAN); - switch (t) { - int over, over2; - - case STR_IS_BOOL: - if (allowEmpty) { - JUMP1( JUMP_TRUE, over); - PUSH( ""); - OP( STR_EQ); - JUMP1( JUMP, over2); - FIXJUMP1(over); - OP( POP); - PUSH( "1"); - FIXJUMP1(over2); - } else { - OP4( REVERSE, 2); - OP( POP); - } - return TCL_OK; - case STR_IS_TRUE: - JUMP1( JUMP_TRUE, over); - if (allowEmpty) { - PUSH( ""); - OP( STR_EQ); - } else { - OP( POP); - PUSH( "0"); - } - FIXJUMP1( over); - OP( LNOT); - OP( LNOT); - return TCL_OK; - case STR_IS_FALSE: - JUMP1( JUMP_TRUE, over); - if (allowEmpty) { - PUSH( ""); - OP( STR_NEQ); - } else { - OP( POP); - PUSH( "1"); - } - FIXJUMP1( over); - OP( LNOT); - return TCL_OK; - } - break; - - case STR_IS_DOUBLE: { - int satisfied, isEmpty; - - if (allowEmpty) { - OP( DUP); - PUSH( ""); - OP( STR_EQ); - JUMP1( JUMP_TRUE, isEmpty); - OP( NUM_TYPE); - JUMP1( JUMP_TRUE, satisfied); - PUSH( "0"); - JUMP1( JUMP, end); - FIXJUMP1( isEmpty); - OP( POP); - FIXJUMP1( satisfied); - } else { - OP( NUM_TYPE); - JUMP1( JUMP_TRUE, satisfied); - PUSH( "0"); - JUMP1( JUMP, end); - TclAdjustStackDepth(-1, envPtr); - FIXJUMP1( satisfied); - } - PUSH( "1"); - FIXJUMP1( end); - return TCL_OK; - } - - case STR_IS_INT: - case STR_IS_WIDE: - case STR_IS_ENTIER: - if (allowEmpty) { - int testNumType; - - OP( DUP); - OP( NUM_TYPE); - OP( DUP); - JUMP1( JUMP_TRUE, testNumType); - OP( POP); - PUSH( ""); - OP( STR_EQ); - JUMP1( JUMP, end); - TclAdjustStackDepth(1, envPtr); - FIXJUMP1( testNumType); - OP4( REVERSE, 2); - OP( POP); - } else { - OP( NUM_TYPE); - OP( DUP); - JUMP1( JUMP_FALSE, end); - } - - switch (t) { - case STR_IS_WIDE: - PUSH( "2"); - OP( LE); - break; - case STR_IS_INT: - case STR_IS_ENTIER: - PUSH( "3"); - OP( LE); - break; - } - FIXJUMP1( end); - return TCL_OK; - case STR_IS_DICT: - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - OP4( BEGIN_CATCH4, range); - ExceptionRangeStarts(envPtr, range); - OP( DUP); - OP( DICT_VERIFY); - ExceptionRangeEnds(envPtr, range); - ExceptionRangeTarget(envPtr, range, catchOffset); - OP( POP); - OP( PUSH_RETURN_CODE); - OP( END_CATCH); - OP( LNOT); - return TCL_OK; - case STR_IS_LIST: - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - OP4( BEGIN_CATCH4, range); - ExceptionRangeStarts(envPtr, range); - OP( DUP); - OP( LIST_LENGTH); - OP( POP); - ExceptionRangeEnds(envPtr, range); - ExceptionRangeTarget(envPtr, range, catchOffset); - OP( POP); - OP( PUSH_RETURN_CODE); - OP( END_CATCH); - OP( LNOT); - return TCL_OK; - } - - return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileStringMatchCmd( - 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 *tokenPtr; - size_t length; - int i, exactMatch = 0, nocase = 0; - const char *str; - - if (parsePtr->numWords < 3 || parsePtr->numWords > 4) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - - /* - * Check if we have a -nocase flag. - */ - - if (parsePtr->numWords == 4) { - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - str = tokenPtr[1].start; - length = tokenPtr[1].size; - if ((length <= 1) || strncmp(str, "-nocase", length)) { - /* - * Fail at run time, not in compilation. - */ - - return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - nocase = 1; - tokenPtr = TokenAfter(tokenPtr); - } - - /* - * Push the strings to match against each other. - */ - - for (i = 0; i < 2; i++) { - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - str = tokenPtr[1].start; - length = tokenPtr[1].size; - if (!nocase && (i == 0)) { - /* - * Trivial matches can be done by 'string equal'. If -nocase - * was specified, we can't do this because INST_STR_EQ has no - * support for nocase. - */ - - Tcl_Obj *copy = Tcl_NewStringObj(str, length); - - Tcl_IncrRefCount(copy); - exactMatch = TclMatchIsTrivial(TclGetString(copy)); - TclDecrRefCount(copy); - } - PushLiteral(envPtr, str, length); - } else { - SetLineInformation(i+1+nocase); - CompileTokens(envPtr, tokenPtr, interp); - } - tokenPtr = TokenAfter(tokenPtr); - } - - /* - * Push the matcher. - */ - - if (exactMatch) { - TclEmitOpcode(INST_STR_EQ, envPtr); - } else { - TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr); - } - return TCL_OK; -} - -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]; - size_t len = Tcl_GetCharLength(objPtr); - - len = sprintf(buf, "%" TCL_Z_MODIFIER "d", len); - PushLiteral(envPtr, buf, len); - } else { - SetLineInformation(1); - CompileTokens(envPtr, tokenPtr, interp); - TclEmitOpcode(INST_STR_LEN, envPtr); - } - TclDecrRefCount(objPtr); - return TCL_OK; -} - -int -TclCompileStringMapCmd( - 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 *mapTokenPtr, *stringTokenPtr; - Tcl_Obj *mapObj, **objv; - const char *bytes; - int len; - size_t slen; - - /* - * We only handle the case: - * - * string map {foo bar} $thing - * - * That is, a literal two-element list (doesn't need to be brace-quoted, - * but does need to be compile-time knowable) and any old argument (the - * thing to map). - */ - - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - mapTokenPtr = TokenAfter(parsePtr->tokenPtr); - stringTokenPtr = TokenAfter(mapTokenPtr); - TclNewObj(mapObj); - Tcl_IncrRefCount(mapObj); - if (!TclWordKnownAtCompileTime(mapTokenPtr, mapObj)) { - Tcl_DecrRefCount(mapObj); - return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } else if (Tcl_ListObjGetElements(NULL, mapObj, &len, &objv) != TCL_OK) { - Tcl_DecrRefCount(mapObj); - return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } else if (len != 2) { - Tcl_DecrRefCount(mapObj); - return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - - /* - * Now issue the opcodes. Note that in the case that we know that the - * first word is an empty word, we don't issue the map at all. That is the - * correct semantics for mapping. - */ - - bytes = TclGetStringFromObj(objv[0], &slen); - if (slen == 0) { - CompileWord(envPtr, stringTokenPtr, interp, 2); - } else { - PushLiteral(envPtr, bytes, slen); - bytes = TclGetStringFromObj(objv[1], &slen); - PushLiteral(envPtr, bytes, slen); - CompileWord(envPtr, stringTokenPtr, interp, 2); - OP(STR_MAP); - } - Tcl_DecrRefCount(mapObj); - return TCL_OK; -} - -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) { - return TCL_ERROR; - } - stringTokenPtr = TokenAfter(parsePtr->tokenPtr); - fromTokenPtr = TokenAfter(stringTokenPtr); - toTokenPtr = TokenAfter(fromTokenPtr); - - /* Every path must push the string argument */ - CompileWord(envPtr, stringTokenPtr, interp, 1); - - /* - * Parse the two indices. - */ - - if (TclGetIndexFromToken(fromTokenPtr, TCL_INDEX_START, TCL_INDEX_NONE, - &idx1) != TCL_OK) { - goto nonConstantIndices; - } - /* - * Token parsed as an index expression. We treat all indices before - * the string the same as the start of the string. - */ - - if (idx1 == (int)TCL_INDEX_NONE) { - /* [string range $s end+1 $last] must be empty string */ - OP( POP); - PUSH( ""); - return TCL_OK; - } - - if (TclGetIndexFromToken(toTokenPtr, TCL_INDEX_NONE, TCL_INDEX_END, - &idx2) != TCL_OK) { - goto nonConstantIndices; - } - /* - * Token parsed as an index expression. We treat all indices after - * the string the same as the end of the string. - */ - if (idx2 == (int)TCL_INDEX_NONE) { - /* [string range $s $first -1] must be empty string */ - OP( POP); - PUSH( ""); - return TCL_OK; - } - - /* - * Push the operand onto the stack and then the substring operation. - */ - - OP44( STR_RANGE_IMM, idx1, idx2); - return TCL_OK; - - /* - * Push the operands onto the stack and then the substring operation. - */ - - nonConstantIndices: - CompileWord(envPtr, fromTokenPtr, interp, 2); - CompileWord(envPtr, toTokenPtr, interp, 3); - OP( STR_RANGE); - return TCL_OK; -} - -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 */ - valueTokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, valueTokenPtr, interp, 1); - - /* - * Check for first index known and useful at compile time. - */ - tokenPtr = TokenAfter(valueTokenPtr); - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_NONE, - &first) != TCL_OK) { - goto genericReplace; - } - - /* - * Check for last index known and useful at compile time. - */ - tokenPtr = TokenAfter(tokenPtr); - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_NONE, TCL_INDEX_END, - &last) != TCL_OK) { - goto genericReplace; - } - - /* - * [string replace] is an odd bird. For many arguments it is - * a conventional substring replacer. However it also goes out - * of its way to become a no-op for many cases where it would be - * replacing an empty substring. Precisely, it is a no-op when - * - * (last < first) OR - * (last < 0) OR - * (end < first) - * - * For some compile-time values we can detect these cases, and - * compile direct to bytecode implementing the no-op. - */ - - if ((last == (int)TCL_INDEX_NONE) /* Know (last < 0) */ - || (first == (int)TCL_INDEX_NONE) /* Know (first > end) */ - - /* - * Tricky to determine when runtime (last < first) can be - * certainly known based on the encoded values. Consider the - * cases... - * - * (first <= TCL_INDEX_END) && - * (last <= TCL_INDEX END) && (last < first) => ACCEPT - * else => cannot tell REJECT - */ - || ((first <= (int)TCL_INDEX_END) && (last <= (int)TCL_INDEX_END) - && (last < first)) /* Know (last < first) */ - /* - * (first == TCL_INDEX_NONE) && - * (last <= TCL_INDEX_END) => cannot tell REJECT - * else => (first < last) REJECT - * - * else [[first >= TCL_INDEX_START]] && - * (last <= TCL_INDEX_END) => cannot tell REJECT - * else [[last >= TCL_INDEX START]] && (last < first) => ACCEPT - */ - || ((first >= (int)TCL_INDEX_START) && (last >= (int)TCL_INDEX_START) - && (last < first))) { /* Know (last < first) */ - if (parsePtr->numWords == 5) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 4); - OP( POP); /* Pop newString */ - } - /* Original string argument now on TOS as result */ - return TCL_OK; - } - - if (parsePtr->numWords == 5) { - /* - * When we have a string replacement, we have to take care about - * not replacing empty substrings that [string replace] promises - * not to replace - * - * The remaining index values might be suitable for conventional - * string replacement, but only if they cannot possibly meet the - * conditions described above at runtime. If there's a chance they - * might, we would have to emit bytecode to check and at that point - * we're paying more in bytecode execution time than would make - * things worthwhile. Trouble is we are very limited in - * how much we can detect that at compile time. After decoding, - * we need, first: - * - * (first <= end) - * - * The encoded indices (first <= TCL_INDEX END) and - * (first == TCL_INDEX_NONE) always meets this condition, but - * any other encoded first index has some list for which it fails. - * - * We also need, second: - * - * (last >= 0) - * - * The encoded index (last >= TCL_INDEX_START) always meet this - * condition but any other encoded last index has some list for - * which it fails. - * - * Finally we need, third: - * - * (first <= last) - * - * Considered in combination with the constraints we already have, - * we see that we can proceed when (first == TCL_INDEX_NONE). - * These also permit simplification of the prefix|replace|suffix - * construction. The other constraints, though, interfere with - * getting a guarantee that first <= last. - */ - - if ((first == (int)TCL_INDEX_START) && (last >= (int)TCL_INDEX_START)) { - /* empty prefix */ - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 4); - OP4( REVERSE, 2); - if (last == INT_MAX) { - OP( POP); /* Pop original */ - } else { - OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END); - OP1( STR_CONCAT1, 2); - } - return TCL_OK; - } - - if ((last == (int)TCL_INDEX_NONE) && (first <= (int)TCL_INDEX_END)) { - OP44( STR_RANGE_IMM, 0, first-1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 4); - OP1( STR_CONCAT1, 2); - return TCL_OK; - } - - /* FLOW THROUGH TO genericReplace */ - - } else { - /* - * When we have no replacement string to worry about, we may - * have more luck, because the forbidden empty string replacements - * are harmless when they are replaced by another empty string. - */ - - if (first == (int)TCL_INDEX_START) { - /* empty prefix - build suffix only */ - - if (last == (int)TCL_INDEX_END) { - /* empty suffix too => empty result */ - OP( POP); /* Pop original */ - PUSH ( ""); - return TCL_OK; - } - OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END); - return TCL_OK; - } else { - if (last == (int)TCL_INDEX_END) { - /* empty suffix - build prefix only */ - OP44( STR_RANGE_IMM, 0, first-1); - return TCL_OK; - } - OP( DUP); - OP44( STR_RANGE_IMM, 0, first-1); - OP4( REVERSE, 2); - OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END); - OP1( STR_CONCAT1, 2); - return TCL_OK; - } - } - - genericReplace: - tokenPtr = TokenAfter(valueTokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 3); - if (parsePtr->numWords == 5) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 4); - } else { - PUSH( ""); - } - OP( STR_REPLACE); - return TCL_OK; -} - -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; - } - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - if (parsePtr->numWords == 3) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - } else { - PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet)); - } - OP( STR_TRIM_LEFT); - return TCL_OK; -} - -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; - } - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - if (parsePtr->numWords == 3) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - } else { - PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet)); - } - OP( STR_TRIM_RIGHT); - return TCL_OK; -} - -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; - } - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - if (parsePtr->numWords == 3) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - } else { - PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet)); - } - OP( STR_TRIM); - return TCL_OK; -} - -int -TclCompileStringToUpperCmd( - 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 *tokenPtr; - - if (parsePtr->numWords != 2) { - return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - OP( STR_UPPER); - return TCL_OK; -} - -int -TclCompileStringToLowerCmd( - 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 *tokenPtr; - - if (parsePtr->numWords != 2) { - return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - OP( STR_LOWER); - return TCL_OK; -} - -int -TclCompileStringToTitleCmd( - 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 *tokenPtr; - - if (parsePtr->numWords != 2) { - return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - OP( STR_TITLE); - return TCL_OK; -} - -/* - * Support definitions for the [string is] compilation. - */ - -static int -UniCharIsAscii( - int character) -{ - return (character >= 0) && (character < 0x80); -} - -static int -UniCharIsHexDigit( - int character) -{ - return (character >= 0) && (character < 0x80) && isxdigit(UCHAR(character)); -} - -StringClassDesc const tclStringClassTable[] = { - {"alnum", Tcl_UniCharIsAlnum}, - {"alpha", Tcl_UniCharIsAlpha}, - {"ascii", UniCharIsAscii}, - {"control", Tcl_UniCharIsControl}, - {"digit", Tcl_UniCharIsDigit}, - {"graph", Tcl_UniCharIsGraph}, - {"lower", Tcl_UniCharIsLower}, - {"print", Tcl_UniCharIsPrint}, - {"punct", Tcl_UniCharIsPunct}, - {"space", Tcl_UniCharIsSpace}, - {"upper", Tcl_UniCharIsUpper}, - {"word", Tcl_UniCharIsWordChar}, - {"xdigit", UniCharIsHexDigit}, - {"", NULL} -}; - -/* - *---------------------------------------------------------------------- - * - * TclCompileSubstCmd -- - * - * Procedure called to compile the "subst" command. - * - * Results: - * Returns TCL_OK for successful compile, or TCL_ERROR to defer - * evaluation to runtime (either when it is too complex to get the - * semantics right, or when we know for sure that it is an error but need - * the error to happen at the right time). - * - * Side effects: - * Instructions are added to envPtr to execute the "subst" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileSubstCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - TCL_UNUSED(Command *), - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - DefineLineInformation; /* TIP #280 */ - int numArgs = parsePtr->numWords - 1; - int numOpts = numArgs - 1; - int objc, flags = TCL_SUBST_ALL; - Tcl_Obj **objv/*, *toSubst = NULL*/; - Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); - int code = TCL_ERROR; - - if (numArgs == 0) { - return TCL_ERROR; - } - - objv = (Tcl_Obj **)TclStackAlloc(interp, /*numArgs*/ numOpts * sizeof(Tcl_Obj *)); - - for (objc = 0; objc < /*numArgs*/ numOpts; objc++) { - TclNewObj(objv[objc]); - Tcl_IncrRefCount(objv[objc]); - if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { - objc++; - goto cleanup; - } - wordTokenPtr = TokenAfter(wordTokenPtr); - } - -/* - if (TclSubstOptions(NULL, numOpts, objv, &flags) == TCL_OK) { - toSubst = objv[numOpts]; - Tcl_IncrRefCount(toSubst); - } -*/ - - /* TODO: Figure out expansion to cover WordKnownAtCompileTime - * The difficulty is that WKACT makes a copy, and if TclSubstParse - * below parses the copy of the original source string, some deep - * parts of the compile machinery get upset. They want all pointers - * stored in Tcl_Tokens to point back to the same original string. - */ - if (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - code = TclSubstOptions(NULL, numOpts, objv, &flags); - } - - cleanup: - while (--objc >= 0) { - TclDecrRefCount(objv[objc]); - } - TclStackFree(interp, objv); - if (/*toSubst == NULL*/ code != TCL_OK) { - return TCL_ERROR; - } - - SetLineInformation(numArgs); - TclSubstCompile(interp, wordTokenPtr[1].start, wordTokenPtr[1].size, - flags, mapPtr->loc[eclIndex].line[numArgs], envPtr); - -/* TclDecrRefCount(toSubst);*/ - return TCL_OK; -} - -void -TclSubstCompile( - Tcl_Interp *interp, - const char *bytes, - size_t numBytes, - int flags, - int line, - CompileEnv *envPtr) -{ - Tcl_Token *endTokenPtr, *tokenPtr; - int breakOffset = 0, count = 0, bline = line; - Tcl_Parse parse; - Tcl_InterpState state = NULL; - - TclSubstParse(interp, bytes, numBytes, flags, &parse, &state); - if (state != NULL) { - Tcl_ResetResult(interp); - } - - /* - * Tricky point! If the first token does not result in a *guaranteed* push - * of a Tcl_Obj on the stack, we must push an empty object. Otherwise it - * is possible to get to an INST_STR_CONCAT1 or INST_DONE without enough - * values on the stack, resulting in a crash. Thanks to Joe Mistachkin for - * identifying a script that could trigger this case. - */ - - tokenPtr = parse.tokenPtr; - if (tokenPtr->type != TCL_TOKEN_TEXT && tokenPtr->type != TCL_TOKEN_BS) { - PUSH(""); - count++; - } - - for (endTokenPtr = tokenPtr + parse.numTokens; - tokenPtr < endTokenPtr; tokenPtr = TokenAfter(tokenPtr)) { - size_t length; - int 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, - tokenPtr->start, tokenPtr->size, 0); - TclEmitPush(literal, envPtr); - TclAdvanceLines(&bline, tokenPtr->start, - tokenPtr->start + tokenPtr->size); - count++; - continue; - case TCL_TOKEN_BS: - length = TclParseBackslash(tokenPtr->start, tokenPtr->size, - NULL, buf); - literal = TclRegisterLiteral(envPtr, buf, length, 0); - TclEmitPush(literal, envPtr); - count++; - continue; - case TCL_TOKEN_VARIABLE: - /* - * Check for simple variable access; see if we can only generate - * 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) { - size_t i; - int foundCommand = 0; - - for (i=2 ; i<=tokenPtr->numComponents ; i++) { - if (tokenPtr[i].type == TCL_TOKEN_COMMAND) { - foundCommand = 1; - break; - } - } - if (foundCommand) { - break; - } - } - - envPtr->line = bline; - TclCompileVarSubst(interp, tokenPtr, envPtr); - bline = envPtr->line; - count++; - continue; - } - - while (count > 255) { - OP1( STR_CONCAT1, 255); - count -= 254; - } - if (count > 1) { - OP1( STR_CONCAT1, count); - count = 1; - } - - if (breakOffset == 0) { - /* Jump to the start (jump over the jump to end) */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &startFixup); - - /* 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 %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - startFixup.codeOffset); - } - } - - envPtr->line = bline; - catchRange = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - OP4( BEGIN_CATCH4, catchRange); - ExceptionRangeStarts(envPtr, catchRange); - - switch (tokenPtr->type) { - case TCL_TOKEN_COMMAND: - TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2, - envPtr); - count++; - break; - case TCL_TOKEN_VARIABLE: - TclCompileVarSubst(interp, tokenPtr, envPtr); - count++; - break; - default: - Tcl_Panic("unexpected token type in TclCompileSubstCmd: %d", - tokenPtr->type); - } - - ExceptionRangeEnds(envPtr, catchRange); - - /* Substitution produced TCL_OK */ - OP( END_CATCH); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &okFixup); - TclAdjustStackDepth(-1, envPtr); - - /* Exceptional return codes processed here */ - ExceptionRangeTarget(envPtr, catchRange, catchOffset); - OP( PUSH_RETURN_OPTIONS); - OP( PUSH_RESULT); - OP( PUSH_RETURN_CODE); - OP( END_CATCH); - OP( RETURN_CODE_BRANCH); - - /* ERROR -> reraise it; NB: can't require BREAK/CONTINUE handling */ - OP( RETURN_STK); - OP( NOP); - - /* RETURN */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &returnFixup); - - /* BREAK */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &breakFixup); - - /* CONTINUE */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &continueFixup); - - /* OTHER */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &otherFixup); - - TclAdjustStackDepth(1, envPtr); - /* BREAK destination */ - if (TclFixupForwardJumpToHere(envPtr, &breakFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad break jump distance %" TCL_Z_MODIFIER "d", - 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 %" TCL_Z_MODIFIER "d", - 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 %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - returnFixup.codeOffset); - } - if (TclFixupForwardJumpToHere(envPtr, &otherFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad other jump distance %" TCL_Z_MODIFIER "d", - 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 %" TCL_Z_MODIFIER "d", - 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 %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - endFixup.codeOffset); - } - bline = envPtr->line; - } - - while (count > 255) { - OP1( STR_CONCAT1, 255); - count -= 254; - } - if (count > 1) { - OP1( STR_CONCAT1, count); - } - - Tcl_FreeParse(&parse); - - if (state != NULL) { - Tcl_RestoreInterpState(interp, state); - TclCompileSyntaxError(interp, envPtr); - TclAdjustStackDepth(-1, envPtr); - } - - /* Final target of the multi-jump from all BREAKs */ - if (breakOffset > 0) { - TclUpdateInstInt4AtPc(INST_JUMP4, CurrentOffset(envPtr) - breakOffset, - envPtr->codeStart + breakOffset); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileSwitchCmd -- - * - * Procedure called to compile the "switch" command. - * - * Results: - * Returns TCL_OK for successful compile, or TCL_ERROR to defer - * evaluation to runtime (either when it is too complex to get the - * semantics right, or when we know for sure that it is an error but need - * the error to happen at the right time). - * - * Side effects: - * Instructions are added to envPtr to execute the "switch" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -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 ...} - * switch -regexp ?--? word {pattern body ...} - * switch -- word simpleWordPattern simpleWordBody ... - * switch -exact -- word simpleWordPattern simpleWordBody ... - * switch -glob -- word simpleWordPattern simpleWordBody ... - * switch -regexp -- word simpleWordPattern simpleWordBody ... - * When the mode is -glob, can also handle a -nocase flag. - * - * First off, we don't care how the command's word was generated; we're - * compiling it anyway! So skip it... - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - valueIndex = 1; - numWords = parsePtr->numWords-1; - - /* - * Check for options. - */ - - noCase = 0; - mode = Switch_Exact; - if (numWords == 2) { - /* - * There's just the switch value and the bodies list. In that case, we - * can skip all option parsing and move on to consider switch values - * and the body list. - */ - - goto finishedOptionParse; - } - - /* - * There must be at least one option, --, because without that there is no - * 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--) { - size_t 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). - */ - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || size < 2) { - return TCL_ERROR; - } - - if ((size <= 6) && !memcmp(chrs, "-exact", size)) { - if (foundMode) { - return TCL_ERROR; - } - mode = Switch_Exact; - foundMode = 1; - valueIndex++; - continue; - } else if ((size <= 5) && !memcmp(chrs, "-glob", size)) { - if (foundMode) { - return TCL_ERROR; - } - mode = Switch_Glob; - foundMode = 1; - valueIndex++; - continue; - } else if ((size <= 7) && !memcmp(chrs, "-regexp", size)) { - if (foundMode) { - return TCL_ERROR; - } - mode = Switch_Regexp; - foundMode = 1; - valueIndex++; - continue; - } else if ((size <= 7) && !memcmp(chrs, "-nocase", size)) { - noCase = 1; - valueIndex++; - continue; - } else if ((size == 2) && !memcmp(chrs, "--", 2)) { - valueIndex++; - break; - } - - /* - * The switch command has many flags we cannot compile at all (e.g. - * all the RE-related ones) which we must have encountered. Either - * that or we have run off the end. The action here is the same: punt - * to interpreted version. - */ - - return TCL_ERROR; - } - if (numWords < 3) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(tokenPtr); - numWords--; - if (noCase && (mode == Switch_Exact)) { - /* - * Can't compile this case; no opcode for case-insensitive equality! - */ - - return TCL_ERROR; - } - - /* - * The value to test against is going to always get pushed on the stack. - * But not yet; we need to verify that the rest of the command is - * compilable too. - */ - - finishedOptionParse: - valueTokenPtr = tokenPtr; - /* For valueIndex, see previous loop. */ - tokenPtr = TokenAfter(tokenPtr); - numWords--; - - /* - * Build an array of tokens for the matcher terms and script bodies. Note - * that in the case of the quoted bodies, this is tricky as we cannot use - * 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; - size_t 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 *)Tcl_Alloc(sizeof(Tcl_Token) * maxLen); - bodyToken = (Tcl_Token **)Tcl_Alloc(sizeof(Tcl_Token *) * maxLen); - bodyLines = (int *)Tcl_Alloc(sizeof(int) * maxLen); - bodyContLines = (int **)Tcl_Alloc(sizeof(int*) * maxLen); - - bline = mapPtr->loc[eclIndex].line[valueIndex+1]; - numWords = 0; - - while (numBytes > 0) { - const char *prevBytes = bytes; - int literal; - - if (TCL_OK != TclFindElement(NULL, bytes, numBytes, - &(bodyTokenArray[numWords].start), &bytes, - &(bodyTokenArray[numWords].size), &literal) || !literal) { - goto abort; - } - - bodyTokenArray[numWords].type = TCL_TOKEN_TEXT; - bodyTokenArray[numWords].numComponents = 0; - bodyToken[numWords] = bodyTokenArray + numWords; - - /* - * TIP #280: Now determine the line the list element starts on - * (there is no need to do it earlier, due to the possibility of - * aborting, see above). - */ - - TclAdvanceLines(&bline, prevBytes, bodyTokenArray[numWords].start); - TclAdvanceContinuations(&bline, &clNext, - bodyTokenArray[numWords].start - envPtr->source); - bodyLines[numWords] = bline; - bodyContLines[numWords] = clNext; - TclAdvanceLines(&bline, bodyTokenArray[numWords].start, bytes); - TclAdvanceContinuations(&bline, &clNext, bytes - envPtr->source); - - numBytes -= (bytes - prevBytes); - numWords++; - } - if (numWords % 2) { - abort: - Tcl_Free(bodyToken); - Tcl_Free(bodyTokenArray); - Tcl_Free(bodyLines); - Tcl_Free(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 **)Tcl_Alloc(sizeof(Tcl_Token *) * numWords); - bodyLines = (int *)Tcl_Alloc(sizeof(int) * numWords); - bodyContLines = (int **)Tcl_Alloc(sizeof(int*) * numWords); - bodyTokenArray = NULL; - for (i=0 ; itype != TCL_TOKEN_SIMPLE_WORD) { - goto freeTemporaries; - } - bodyToken[i] = tokenPtr+1; - - /* - * TIP #280: Copy line information from regular cmd info. - */ - - bodyLines[i] = mapPtr->loc[eclIndex].line[valueIndex+1+i]; - bodyContLines[i] = mapPtr->loc[eclIndex].next[valueIndex+1+i]; - tokenPtr = TokenAfter(tokenPtr); - } - } - - /* - * Fall back to interpreted if the last body is a continuation (it's - * illegal, but this makes the error happen at the right time). - */ - - if (bodyToken[numWords-1]->size == 1 && - bodyToken[numWords-1]->start[0] == '-') { - goto freeTemporaries; - } - - /* - * Now we commit to generating code; the parsing stage per se is done. - * Check if we can generate a jump table, since if so that's faster than - * doing an explicit compare with each body. Note that we're definitely - * over-conservative with determining whether we can do the jump table, - * 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: - Tcl_Free(bodyToken); - Tcl_Free(bodyLines); - Tcl_Free(bodyContLines); - if (bodyTokenArray != NULL) { - Tcl_Free(bodyTokenArray); - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * IssueSwitchChainedTests -- - * - * Generate instructions for a [switch] command that is to be compiled - * into a sequence of tests. This is the generic handle-everything mode - * that inherently has performance that is (on average) linear in the - * number of tests. It is the only mode that can handle -glob and -regexp - * matches, or anything that is case-insensitive. It does not handle the - * wild-and-wooly end of regexp matching (i.e., capture of match results) - * so that's when we spill to the interpreted version. - * - *---------------------------------------------------------------------- - */ - -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. */ -{ - enum {Switch_Exact, Switch_Glob, Switch_Regexp}; - int foundDefault; /* Flag to indicate whether a "default" clause - * is present. */ - JumpFixup *fixupArray; /* Array of forward-jump fixup records. */ - unsigned int *fixupTargetArray; /* Array of places for fixups to point at. */ - int fixupCount; /* Number of places to fix up. */ - int contFixIndex; /* Where the first of the jumps due to a group - * of continuation bodies starts, or -1 if - * there aren't any. */ - int contFixCount; /* Number of continuation bodies pointing to - * the current (or next) real body. */ - int nextArmFixupIndex; - int simple, exact; /* For extracting the type of regexp. */ - int i; - - /* - * 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 ; isize != 7 || - memcmp(bodyToken[numBodyTokens-2]->start, "default", 7)) { - /* - * Generate the test for the arm. - */ - - switch (mode) { - case Switch_Exact: - OP( DUP); - TclCompileTokens(interp, bodyToken[i], 1, envPtr); - OP( STR_EQ); - break; - case Switch_Glob: - TclCompileTokens(interp, bodyToken[i], 1, envPtr); - OP4( OVER, 1); - OP1( STR_MATCH, noCase); - break; - case Switch_Regexp: - simple = exact = 0; - - /* - * Keep in sync with TclCompileRegexpCmd. - */ - - if (bodyToken[i]->type == TCL_TOKEN_TEXT) { - Tcl_DString ds; - - if (bodyToken[i]->size == 0) { - /* - * The semantics of regexps are that they always match - * when the RE == "". - */ - - PUSH("1"); - break; - } - - /* - * Attempt to convert pattern to glob. If successful, push - * the converted pattern. - */ - - if (TclReToGlob(NULL, bodyToken[i]->start, - bodyToken[i]->size, &ds, &exact, NULL) == TCL_OK){ - simple = 1; - PushLiteral(envPtr, Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds)); - Tcl_DStringFree(&ds); - } - } - if (!simple) { - TclCompileTokens(interp, bodyToken[i], 1, envPtr); - } - - OP4( OVER, 1); - if (!simple) { - /* - * Pass correct RE compile flags. We use only Int1 - * (8-bit), but that handles all the flags we want to - * pass. Don't use TCL_REG_NOSUB as we may have backrefs - * or capture vars. - */ - - int cflags = TCL_REG_ADVANCED - | (noCase ? TCL_REG_NOCASE : 0); - - OP1(REGEXP, cflags); - } else if (exact && !noCase) { - OP( STR_EQ); - } else { - OP1(STR_MATCH, noCase); - } - break; - default: - Tcl_Panic("unknown switch mode: %d", mode); - } - - /* - * In a fall-through case, we will jump on _true_ to the place - * where the body starts (generated later, with guarantee of this - * ensured earlier; the final body is never a fall-through). - */ - - if (bodyToken[i+1]->size==1 && bodyToken[i+1]->start[0]=='-') { - if (contFixIndex == -1) { - contFixIndex = fixupCount; - contFixCount = 0; - } - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, - &fixupArray[contFixIndex+contFixCount]); - fixupCount++; - contFixCount++; - continue; - } - - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, - &fixupArray[fixupCount]); - nextArmFixupIndex = fixupCount; - fixupCount++; - } else { - /* - * Got a default clause; set a flag to inhibit the generation of - * the jump after the body and the cleanup of the intermediate - * value that we are switching against. - * - * Note that default clauses (which are always terminal clauses) - * cannot be fall-through clauses as well, since the last clause - * is never a fall-through clause (which we have already - * verified). - */ - - foundDefault = 1; - } - - /* - * Generate the body for the arm. This is guaranteed not to be a - * fall-through case, but it might have preceding fall-through cases, - * so we must process those first. - */ - - if (contFixIndex != -1) { - int j; - - for (j=0 ; jline = bodyLines[i+1]; /* TIP #280 */ - envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */ - TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); - - if (!foundDefault) { - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &fixupArray[fixupCount]); - fixupCount++; - fixupTargetArray[nextArmFixupIndex] = CurrentOffset(envPtr); - } - } - - /* - * Discard the value we are matching against unless we've had a default - * clause (in which case it will already be gone due to the code at the - * start of processing an arm, guaranteed) and make the result of the - * command an empty string. - */ - - if (!foundDefault) { - OP( POP); - PUSH(""); - } - - /* - * Do jump fixups for arms that were executed. First, fill in the jumps of - * all jumps that don't point elsewhere to point to here. - */ - - for (i=0 ; icodeNext-envPtr->codeStart; - } - } - - /* - * Now scan backwards over all the jumps (all of which are forward jumps) - * doing each one. When we do one and there is a size changes, we must - * scan back over all the previous ones and see if they need adjusting - * before proceeding with further jump fixups (the interleaved nature of - * all the jumps makes this impossible to do without nested loops). - */ - - for (i=fixupCount-1 ; i>=0 ; i--) { - if (TclFixupForwardJump(envPtr, &fixupArray[i], - fixupTargetArray[i] - fixupArray[i].codeOffset, 127)) { - int j; - - for (j=i-1 ; j>=0 ; j--) { - if (fixupTargetArray[j] > fixupArray[i].codeOffset) { - fixupTargetArray[j] += 3; - } - } - } - } - TclStackFree(interp, fixupTargetArray); - TclStackFree(interp, fixupArray); -} - -/* - *---------------------------------------------------------------------- - * - * IssueSwitchJumpTable -- - * - * Generate instructions for a [switch] command that is to be compiled - * into a jump table. This only handles the case where case-sensitive, - * exact matching is used, but this is actually the most common case in - * real code. - * - *---------------------------------------------------------------------- - */ - -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. */ -{ - JumptableInfo *jtPtr; - int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation; - int mustGenerate, foundDefault, jumpToDefault, i; - Tcl_DString buffer; - Tcl_HashEntry *hPtr; - - /* - * Compile the switch by using a jump table, which is basically a - * hashtable that maps from literal values to match against to the offset - * (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 *)Tcl_Alloc(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 - * we will come back and rewrite the jump's offset parameter when we know - * what it should be, and that all jumps we issue are of the wide kind - * because that makes the code much easier to debug! - */ - - jumpLocation = CurrentOffset(envPtr); - OP4( JUMP_TABLE, infoIndex); - jumpToDefault = CurrentOffset(envPtr); - OP4( JUMP4, 0); - - for (i=0 ; isize != 7 || - memcmp(bodyToken[numBodyTokens-2]->start, "default", 7)) { - /* - * This is not a default clause, so insert the current location as - * a target in the jump table (assuming it isn't already there, - * which would indicate that this clause is probably masked by an - * earlier one). Note that we use a Tcl_DString here simply - * because the hash API does not let us specify the string length. - */ - - Tcl_DStringInit(&buffer); - TclDStringAppendToken(&buffer, bodyToken[i]); - hPtr = Tcl_CreateHashEntry(&jtPtr->hashTable, - Tcl_DStringValue(&buffer), &isNew); - if (isNew) { - /* - * First time we've encountered this match clause, so it must - * point to here. - */ - - Tcl_SetHashValue(hPtr, CurrentOffset(envPtr) - jumpLocation); - } - Tcl_DStringFree(&buffer); - } else { - /* - * This is a default clause, so patch up the fallthrough from the - * INST_JUMP_TABLE instruction to here. - */ - - foundDefault = 1; - isNew = 1; - TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault, - envPtr->codeStart+jumpToDefault+1); - } - - /* - * Now, for each arm we must deal with the body of the clause. - * - * If this is a continuation body (never true of a final clause, - * whether default or not) we're done because the next jump target - * will also point here, so we advance to the next clause. - */ - - if (bodyToken[i+1]->size == 1 && bodyToken[i+1]->start[0] == '-') { - mustGenerate = 1; - continue; - } - - /* - * Also skip this arm if its only match clause is masked. (We could - * probably be more aggressive about this, but that would be much more - * difficult to get right.) - */ - - if (!isNew && !mustGenerate) { - continue; - } - mustGenerate = 0; - - /* - * Compile the body of the arm. - */ - - envPtr->line = bodyLines[i+1]; /* TIP #280 */ - envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */ - TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); - - /* - * Compile a jump in to the end of the command if this body is - * anything other than a user-supplied default arm (to either skip - * over the remaining bodies or the code that generates an empty - * result). - */ - - if (i+2 < numBodyTokens || !foundDefault) { - finalFixups[numRealBodies++] = CurrentOffset(envPtr); - - /* - * Easier by far to issue this jump as a fixed-width jump, since - * otherwise we'd need to do a lot more (and more awkward) - * rewriting when we fixed this all up. - */ - - OP4( JUMP4, 0); - TclAdjustStackDepth(-1, envPtr); - } - } - - /* - * We're at the end. If we've not already done so through the processing - * of a user-supplied default clause, add in a "default" default clause - * now. - */ - - if (!foundDefault) { - TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault, - envPtr->codeStart+jumpToDefault+1); - PUSH(""); - } - - /* - * No more instructions to be issued; everything that needs to jump to the - * end of the command is fixed up at this point. - */ - - for (i=0 ; icodeStart+finalFixups[i]+1); - } - - /* - * Clean up all our temporary space and return. - */ - - TclStackFree(interp, finalFixups); -} - -/* - *---------------------------------------------------------------------- - * - * DupJumptableInfo, FreeJumptableInfo -- - * - * Functions to duplicate, release and print a jump-table created for use - * with the INST_JUMP_TABLE instruction. - * - * Results: - * DupJumptableInfo: a copy of the jump-table - * FreeJumptableInfo: none - * PrintJumptableInfo: none - * DisassembleJumptableInfo: none - * - * Side effects: - * DupJumptableInfo: allocates memory - * FreeJumptableInfo: releases memory - * PrintJumptableInfo: none - * DisassembleJumptableInfo: none - * - *---------------------------------------------------------------------- - */ - -static ClientData -DupJumptableInfo( - ClientData clientData) -{ - JumptableInfo *jtPtr = (JumptableInfo *)clientData; - JumptableInfo *newJtPtr = (JumptableInfo *)Tcl_Alloc(sizeof(JumptableInfo)); - Tcl_HashEntry *hPtr, *newHPtr; - Tcl_HashSearch search; - int isNew; - - Tcl_InitHashTable(&newJtPtr->hashTable, TCL_STRING_KEYS); - hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search); - 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); - Tcl_Free(jtPtr); -} - -static void -PrintJumptableInfo( - ClientData clientData, - Tcl_Obj *appendObj, - TCL_UNUSED(ByteCode *), - unsigned int pcOffset) -{ - JumptableInfo *jtPtr = (JumptableInfo *)clientData; - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - const char *keyPtr; - int offset, i = 0; - - hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search); - for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) { - keyPtr = (const char *)Tcl_GetHashKey(&jtPtr->hashTable, hPtr); - offset = PTR2INT(Tcl_GetHashValue(hPtr)); - - if (i++) { - Tcl_AppendToObj(appendObj, ", ", -1); - if (i%4==0) { - Tcl_AppendToObj(appendObj, "\n\t\t", -1); - } - } - Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %d", - keyPtr, pcOffset + offset); - } -} - -static void -DisassembleJumptableInfo( - ClientData clientData, - Tcl_Obj *dictObj, - TCL_UNUSED(ByteCode *), - TCL_UNUSED(unsigned int)) -{ - JumptableInfo *jtPtr = (JumptableInfo *)clientData; - Tcl_Obj *mapping; - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - const char *keyPtr; - size_t offset; - - TclNewObj(mapping); - hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search); - for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) { - keyPtr = (const char *)Tcl_GetHashKey(&jtPtr->hashTable, hPtr); - offset = PTR2INT(Tcl_GetHashValue(hPtr)); - Tcl_DictObjPut(NULL, mapping, Tcl_NewStringObj(keyPtr, -1), - Tcl_NewWideIntObj(offset)); - } - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("mapping", -1), mapping); -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileTailcallCmd -- - * - * Procedure called to compile the "tailcall" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "tailcall" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -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 - || envPtr->procPtr == NULL) { - return TCL_ERROR; - } - - /* make room for the nsObjPtr */ - /* TODO: Doesn't this have to be a known value? */ - CompileWord(envPtr, tokenPtr, interp, 0); - for (i=1 ; inumWords ; i++) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, i); - } - TclEmitInstInt1( INST_TAILCALL, parsePtr->numWords, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileThrowCmd -- - * - * Procedure called to compile the "throw" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "throw" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -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; - - if (numWords != 3) { - return TCL_ERROR; - } - codeToken = TokenAfter(parsePtr->tokenPtr); - msgToken = TokenAfter(codeToken); - - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - - codeKnown = TclWordKnownAtCompileTime(codeToken, objPtr); - - /* - * First we must emit the code to substitute the arguments. This - * must come first in case substitution raises errors. - */ - if (!codeKnown) { - CompileWord(envPtr, codeToken, interp, 1); - PUSH( "-errorcode"); - } - CompileWord(envPtr, msgToken, interp, 2); - - codeIsList = codeKnown && (TCL_OK == - Tcl_ListObjLength(interp, objPtr, &len)); - codeIsValid = codeIsList && (len != 0); - - if (codeIsValid) { - Tcl_Obj *errPtr, *dictPtr; - - TclNewLiteralStringObj(errPtr, "-errorcode"); - TclNewObj(dictPtr); - Tcl_DictObjPut(NULL, dictPtr, errPtr, objPtr); - TclEmitPush(TclAddLiteralObj(envPtr, dictPtr, NULL), envPtr); - } - TclDecrRefCount(objPtr); - - /* - * Simpler bytecodes when we detect invalid arguments at compile time. - */ - if (codeKnown && !codeIsValid) { - OP( POP); - if (codeIsList) { - /* Must be an empty list */ - goto issueErrorForEmptyCode; - } - TclCompileSyntaxError(interp, envPtr); - return TCL_OK; - } - - if (!codeKnown) { - /* - * Argument validity checking has to be done by bytecode at - * run time. - */ - OP4( REVERSE, 3); - OP( DUP); - OP( LIST_LENGTH); - OP1( JUMP_FALSE1, 16); - OP4( LIST, 2); - OP44( RETURN_IMM, TCL_ERROR, 0); - TclAdjustStackDepth(2, envPtr); - OP( POP); - OP( POP); - OP( POP); - issueErrorForEmptyCode: - PUSH( "type must be non-empty list"); - PUSH( "-errorcode {TCL OPERATION THROW BADEXCEPTION}"); - } - OP44( RETURN_IMM, TCL_ERROR, 0); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileTryCmd -- - * - * Procedure called to compile the "try" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "try" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -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; - int i; - - if (numWords < 2) { - return TCL_ERROR; - } - - bodyToken = TokenAfter(parsePtr->tokenPtr); - - if (numWords == 2) { - /* - * No handlers or finally; do nothing beyond evaluating the body. - */ - - DefineLineInformation; /* TIP #280 */ - BODY(bodyToken, 1); - return TCL_OK; - } - - numWords -= 2; - tokenPtr = TokenAfter(bodyToken); - - /* - * 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 ; itype != TCL_TOKEN_SIMPLE_WORD) { - goto failedToCompile; - } - if (tokenPtr[1].size == 4 - && !strncmp(tokenPtr[1].start, "trap", 4)) { - /* - * Parse the list of errorCode words to match against. - */ - - matchCodes[i] = TCL_ERROR; - tokenPtr = TokenAfter(tokenPtr); - TclNewObj(tmpObj); - Tcl_IncrRefCount(tmpObj); - if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj) - || Tcl_ListObjLength(NULL, tmpObj, &objc) != TCL_OK - || (objc == 0)) { - TclDecrRefCount(tmpObj); - goto failedToCompile; - } - Tcl_ListObjReplace(NULL, tmpObj, 0, 0, 0, NULL); - matchClauses[i] = tmpObj; - } else if (tokenPtr[1].size == 2 - && !strncmp(tokenPtr[1].start, "on", 2)) { - int code; - - /* - * Parse the result code to look for. - */ - - tokenPtr = TokenAfter(tokenPtr); - TclNewObj(tmpObj); - Tcl_IncrRefCount(tmpObj); - if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { - TclDecrRefCount(tmpObj); - goto failedToCompile; - } - if (TCL_ERROR == TclGetCompletionCodeFromObj(NULL, tmpObj, &code)) { - TclDecrRefCount(tmpObj); - goto failedToCompile; - } - matchCodes[i] = code; - TclDecrRefCount(tmpObj); - } else { - goto failedToCompile; - } - - /* - * Parse the variable binding. - */ - - tokenPtr = TokenAfter(tokenPtr); - TclNewObj(tmpObj); - Tcl_IncrRefCount(tmpObj); - if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { - TclDecrRefCount(tmpObj); - goto failedToCompile; - } - if (Tcl_ListObjGetElements(NULL, tmpObj, &objc, &objv) != TCL_OK - || (objc > 2)) { - TclDecrRefCount(tmpObj); - goto failedToCompile; - } - if (objc > 0) { - size_t 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) { - size_t len; - const char *varname = TclGetStringFromObj(objv[1], &len); - - optionVarIndices[i] = LocalScalar(varname, len, envPtr); - if (optionVarIndices[i] < 0) { - TclDecrRefCount(tmpObj); - goto failedToCompile; - } - } else { - optionVarIndices[i] = -1; - } - TclDecrRefCount(tmpObj); - - /* - * Extract the body for this handler. - */ - - tokenPtr = TokenAfter(tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - goto failedToCompile; - } - if (tokenPtr[1].size == 1 && tokenPtr[1].start[0] == '-') { - handlerTokens[i] = NULL; - } else { - handlerTokens[i] = tokenPtr; - } - - tokenPtr = TokenAfter(tokenPtr); - } - - if (handlerTokens[numHandlers-1] == NULL) { - goto failedToCompile; - } - } - - /* - * Parse the finally clause - */ - - if (numWords == 0) { - finallyToken = NULL; - } else if (numWords == 2) { - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size != 7 - || strncmp(tokenPtr[1].start, "finally", 7)) { - goto failedToCompile; - } - finallyToken = TokenAfter(tokenPtr); - } else { - goto failedToCompile; - } - - /* - * Issue the bytecode. - */ - - if (!finallyToken) { - result = IssueTryClausesInstructions(interp, envPtr, bodyToken, - numHandlers, matchCodes, matchClauses, resultVarIndices, - optionVarIndices, handlerTokens); - } else if (numHandlers == 0) { - result = IssueTryFinallyInstructions(interp, envPtr, bodyToken, - finallyToken); - } else { - result = IssueTryClausesFinallyInstructions(interp, envPtr, bodyToken, - numHandlers, matchCodes, matchClauses, resultVarIndices, - optionVarIndices, handlerTokens, finallyToken); - } - - /* - * Delete any temporary state and finish off. - */ - - failedToCompile: - if (numHandlers > 0) { - for (i=0 ; i= 0) { - LOAD( resultVar); - STORE( resultVars[i]); - OP( POP); - if (optionVars[i] >= 0) { - LOAD( optionsVar); - STORE( optionVars[i]); - OP( POP); - } - } - if (!handlerTokens[i]) { - forwardsNeedFixing = 1; - JUMP4( JUMP, forwardsToFix[i]); - TclAdjustStackDepth(1, envPtr); - } else { - int dontChangeOptions; - - forwardsToFix[i] = -1; - if (forwardsNeedFixing) { - forwardsNeedFixing = 0; - for (j=0 ; j= 0 || handlerTokens[i]) { - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - OP4( BEGIN_CATCH4, range); - ExceptionRangeStarts(envPtr, range); - } - if (resultVars[i] >= 0) { - LOAD( resultVar); - STORE( resultVars[i]); - OP( POP); - if (optionVars[i] >= 0) { - LOAD( optionsVar); - STORE( optionVars[i]); - OP( POP); - } - - if (!handlerTokens[i]) { - /* - * No handler. Will not be the last handler (that is a - * condition that is checked by the caller). Chain to the next - * one. - */ - - ExceptionRangeEnds(envPtr, range); - OP( END_CATCH); - forwardsNeedFixing = 1; - JUMP4( JUMP, forwardsToFix[i]); - goto finishTrapCatchHandling; - } - } else if (!handlerTokens[i]) { - /* - * No handler. Will not be the last handler (that condition is - * checked by the caller). Chain to the next one. - */ - - forwardsNeedFixing = 1; - JUMP4( JUMP, forwardsToFix[i]); - goto endOfThisArm; - } - - /* - * Got a handler. Make sure that any pending patch-up actions from - * previous unprocessed handlers are dealt with now that we know where - * they are to jump to. - */ - - if (forwardsNeedFixing) { - forwardsNeedFixing = 0; - OP1( JUMP1, 7); - for (j=0 ; jtokenPtr ; inumWords ; i++) { - Tcl_Obj *leadingWord; - - TclNewObj(leadingWord); - varTokenPtr = TokenAfter(varTokenPtr); - if (!TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { - TclDecrRefCount(leadingWord); - - /* - * We can tolerate non-trivial substitutions in the first variable - * to be unset. If a '--' or '-nocomplain' was present, anything - * goes in that one place! (All subsequent variable names must be - * constants since we don't want to have to push them all first.) - */ - - if (varCount == 0) { - if (haveFlags) { - continue; - } - - /* - * In fact, we're OK as long as we're the first argument *and* - * we provably don't start with a '-'. If that is true, then - * even if everything else is varying, we still can't be a - * flag. Otherwise we'll spill to runtime to place a limit on - * the trickiness. - */ - - if (varTokenPtr->type == TCL_TOKEN_WORD - && varTokenPtr[1].type == TCL_TOKEN_TEXT - && varTokenPtr[1].size > 0 - && varTokenPtr[1].start[0] != '-') { - continue; - } - } - return TCL_ERROR; - } - if (varCount == 0) { - const char *bytes; - size_t len; - - bytes = TclGetStringFromObj(leadingWord, &len); - if (i == 1 && len == 11 && !strncmp("-nocomplain", bytes, 11)) { - flags = 0; - haveFlags++; - } else if (i == (2 - flags) && len == 2 && !strncmp("--", bytes, 2)) { - haveFlags++; - } else { - varCount++; - } - } else { - varCount++; - } - TclDecrRefCount(leadingWord); - } - - /* - * Issue instructions to unset each of the named variables. - */ - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i=0; inumWords ; i++) { - /* - * Decide if we can use a frame slot for the var/array name or if we - * need to emit code to compute and push the name at runtime. We use a - * frame slot (entry in the array of local vars) if we are compiling a - * procedure body and if the name is simple text that does not include - * namespace qualifiers. - */ - - PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &isScalar, i); - - /* - * Emit instructions to unset the variable. - */ - - if (isScalar) { - if (localIndex < 0) { - OP1( UNSET_STK, flags); - } else { - OP14( UNSET_SCALAR, flags, localIndex); - } - } else { - if (localIndex < 0) { - OP1( UNSET_ARRAY_STK, flags); - } else { - OP14( UNSET_ARRAY, flags, localIndex); - } - } - - varTokenPtr = TokenAfter(varTokenPtr); - } - PUSH(""); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileWhileCmd -- - * - * Procedure called to compile the "while" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "while" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -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 - * command inline. E.g., the expression might cause the loop to never - * execute or execute forever, as in "while "$x < 5" {}". - * - * Bail out also if the body expression requires substitutions in order to - * insure correct behaviour [Bug 219166] - */ - - testTokenPtr = TokenAfter(parsePtr->tokenPtr); - bodyTokenPtr = TokenAfter(testTokenPtr); - - if ((testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) - || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) { - return TCL_ERROR; - } - - /* - * Find out if the condition is a constant. - */ - - boolObj = Tcl_NewStringObj(testTokenPtr[1].start, testTokenPtr[1].size); - Tcl_IncrRefCount(boolObj); - code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal); - TclDecrRefCount(boolObj); - if (code == TCL_OK) { - if (boolVal) { - /* - * It is an infinite loop; flag it so that we generate a more - * efficient body. - */ - - loopMayEnd = 0; - } else { - /* - * This is an empty loop: "while 0 {...}" or such. Compile no - * bytecodes. - */ - - goto pushResult; - } - } - - /* - * Create a ExceptionRange record for the loop body. This is used to - * implement break and continue. - */ - - range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); - - /* - * Jump to the evaluation of the condition. This code uses the "loop - * rotation" optimisation (which eliminates one branch from the loop). - * "while cond body" produces then: - * goto A - * B: body : bodyCodeOffset - * A: cond -> result : testCodeOffset, continueOffset - * if (result) goto B - * - * The infinite loop "while 1 body" produces: - * B: body : all three offsets here - * goto B - */ - - if (loopMayEnd) { - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &jumpEvalCondFixup); - testCodeOffset = 0; /* Avoid compiler warning. */ - } else { - /* - * Make sure that the first command in the body is preceded by an - * INST_START_CMD, and hence counted properly. [Bug 1752146] - */ - - envPtr->atCmdStart &= ~1; - testCodeOffset = CurrentOffset(envPtr); - } - - /* - * Compile the loop body. - */ - - bodyCodeOffset = ExceptionRangeStarts(envPtr, range); - if (!loopMayEnd) { - envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset; - envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset; - } - BODY(bodyTokenPtr, 2); - ExceptionRangeEnds(envPtr, range); - OP( POP); - - /* - * Compile the test expression then emit the conditional jump that - * terminates the while. We already know it's a simple word. - */ - - if (loopMayEnd) { - testCodeOffset = CurrentOffset(envPtr); - jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset; - if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) { - bodyCodeOffset += 3; - testCodeOffset += 3; - } - SetLineInformation(1); - TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - - jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; - if (jumpDist > 127) { - TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); - } else { - TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr); - } - } else { - jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; - if (jumpDist > 127) { - TclEmitInstInt4(INST_JUMP4, -jumpDist, envPtr); - } else { - TclEmitInstInt1(INST_JUMP1, -jumpDist, envPtr); - } - } - - /* - * Set the loop's body, continue and break offsets. - */ - - envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset; - envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset; - ExceptionRangeTarget(envPtr, range, breakOffset); - TclFinalizeLoopExceptionRange(envPtr, range); - - /* - * The while command's result is an empty string. - */ - - pushResult: - PUSH(""); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileYieldCmd -- - * - * Procedure called to compile the "yield" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "yield" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -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) { - PUSH(""); - } else { - DefineLineInformation; /* TIP #280 */ - Tcl_Token *valueTokenPtr = TokenAfter(parsePtr->tokenPtr); - - CompileWord(envPtr, valueTokenPtr, interp, 1); - } - OP( YIELD); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileYieldToCmd -- - * - * Procedure called to compile the "yieldto" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "yieldto" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -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) { - return TCL_ERROR; - } - - OP( NS_CURRENT); - for (i = 1 ; i < parsePtr->numWords ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); - tokenPtr = TokenAfter(tokenPtr); - } - OP4( LIST, i); - OP( YIELD_TO_INVOKE); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * CompileUnaryOpCmd -- - * - * Utility routine to compile the unary operator commands. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the compiled command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -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); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * CompileAssociativeBinaryOpCmd -- - * - * Utility routine to compile the binary operator commands that accept an - * arbitrary number of arguments, and that are associative operations. - * Because of the associativity, we may combine operations from right to - * left, saving us any effort of re-ordering the arguments on the stack - * after substitutions are completed. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the compiled command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -static int -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 ; wordsnumWords ; words++) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, words); - } - if (parsePtr->numWords <= 2) { - PushLiteral(envPtr, identity, -1); - words++; - } - if (words > 3) { - /* - * Reverse order of arguments to get precise agreement with [expr] in - * calcuations, including roundoff errors. - */ - - OP4( REVERSE, words-1); - } - while (--words > 1) { - TclEmitOpcode(instruction, envPtr); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * CompileStrictlyBinaryOpCmd -- - * - * Utility routine to compile the binary operator commands, that strictly - * accept exactly two arguments. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the compiled command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileStrictlyBinaryOpCmd( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - int instruction, - CompileEnv *envPtr) -{ - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - return CompileAssociativeBinaryOpCmd(interp, parsePtr, - NULL, instruction, envPtr); -} - -/* - *---------------------------------------------------------------------- - * - * CompileComparisonOpCmd -- - * - * Utility routine to compile the n-ary comparison operator commands. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the compiled command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -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); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - TclEmitOpcode(instruction, envPtr); - } else if (envPtr->procPtr == NULL) { - /* - * No local variable space! - */ - - return TCL_ERROR; - } else { - int tmpIndex = AnonymousLocal(envPtr); - int words; - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - STORE(tmpIndex); - TclEmitOpcode(instruction, envPtr); - for (words=3 ; wordsnumWords ;) { - LOAD(tmpIndex); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, words); - if (++words < parsePtr->numWords) { - STORE(tmpIndex); - } - TclEmitOpcode(instruction, envPtr); - } - for (; words>3 ; words--) { - OP( BITAND); - } - - /* - * Drop the value from the temp variable; retaining that reference - * might be expensive elsewhere. - */ - - OP14( UNSET_SCALAR, 0, tmpIndex); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompile*OpCmd -- - * - * Procedures called to compile the corresponding "::tcl::mathop::*" - * commands. These are all wrappers around the utility operator command - * compiler functions, except for the compilers for subtraction and - * division, which are special. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the compiled command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -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 ; wordsnumWords ; 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. - */ - - return TCL_ERROR; - } - for (words=1 ; wordsnumWords ; words++) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, words); - } - if (words == 2) { - TclEmitOpcode(INST_UMINUS, envPtr); - return TCL_OK; - } - if (words == 3) { - TclEmitOpcode(INST_SUB, envPtr); - return TCL_OK; - } - - /* - * Reverse order of arguments to get precise agreement with [expr] in - * calcuations, including roundoff errors. - */ - - TclEmitInstInt4(INST_REVERSE, words-1, envPtr); - while (--words > 1) { - TclEmitInstInt4(INST_REVERSE, 2, envPtr); - TclEmitOpcode(INST_SUB, envPtr); - } - 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. - */ - - return TCL_ERROR; - } - if (parsePtr->numWords == 2) { - PUSH("1.0"); - } - for (words=1 ; wordsnumWords ; words++) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, words); - } - if (words <= 3) { - TclEmitOpcode(INST_DIV, envPtr); - return TCL_OK; - } - - /* - * Reverse order of arguments to get precise agreement with [expr] in - * calcuations, including roundoff errors. - */ - - TclEmitInstInt4(INST_REVERSE, words-1, envPtr); - while (--words > 1) { - TclEmitInstInt4(INST_REVERSE, 2, envPtr); - TclEmitOpcode(INST_DIV, envPtr); - } - return TCL_OK; -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ Index: generic/tclCompExpr.c ================================================================== --- generic/tclCompExpr.c +++ generic/tclCompExpr.c @@ -1,10 +1,10 @@ /* * tclCompExpr.c -- * - * This file contains the code to parse and compile Tcl expressions and - * implementations of the Tcl commands corresponding to expression + * This file contains the code to parse and compile Tcl expressions + * and implementations of the Tcl commands corresponding to expression * operators, such as the command ::tcl::mathop::+ . * * Contributions from Don Porter, NIST, 2006-2007. (not subject to US copyright) * * See the file "license.terms" for information on usage and redistribution of @@ -13,18 +13,18 @@ #include "tclInt.h" #include "tclCompile.h" /* CompileEnv */ /* - * 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. + * 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 { +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 */ @@ -34,40 +34,40 @@ unsigned char mark; /* Mark used to control traversal. */ unsigned char constant; /* Flag marking constant subexpressions. */ } OpNode; /* - * The storage for the tree is dynamically allocated array of OpNodes. The + * The storage for the tree is dynamically allocated array of OpNodes. The * array is grown as parsing needs dictate according to a scheme similar to * Tcl's string growth algorithm, so that the resizing costs are O(N) and so * that we use at least half the memory allocated as expressions get large. * * Each OpNode in the tree represents an operator in the expression, either - * unary or binary. When parsing is completed successfully, a binary operator + * unary or binary. When parsing is completed successfully, a binary operator * OpNode will have its left and right fields filled with "pointers" to its - * left and right operands. A unary operator OpNode will have its right field - * filled with a pointer to its single operand. When an operand is a + * left and right operands. A unary operator OpNode will have its right field + * filled with a pointer to its single operand. When an operand is a * subexpression the "pointer" takes the form of the index -- a non-negative * integer -- into the OpNode storage array where the root of that * subexpression parse tree is found. * * Non-operator elements of the expression do not get stored in the OpNode - * tree. They are stored in the other structures according to their type. - * Literal values get appended to the literal list. Elements that denote forms - * of quoting or substitution known to the Tcl parser get stored as - * Tcl_Tokens. These non-operator elements of the expression are the leaves of - * the completed parse tree. When an operand of an OpNode is one of these leaf - * elements, the following negative integer codes are used to indicate which - * kind of elements it is. + * tree. They are stored in the other structures according to their type. + * Literal values get appended to the literal list. Elements that denote + * forms of quoting or substitution known to the Tcl parser get stored as + * Tcl_Tokens. These non-operator elements of the expression are the + * leaves of the completed parse tree. When an operand of an OpNode is + * one of these leaf elements, the following negative integer codes are used + * to indicate which kind of elements it is. */ enum OperandTypes { OT_LITERAL = -3, /* Operand is a literal in the literal list */ OT_TOKENS = -2, /* Operand is sequence of Tcl_Tokens */ - OT_EMPTY = -1 /* "Operand" is an empty string. This is a special - * case used only to represent the EMPTY lexeme. See - * below. */ + OT_EMPTY = -1 /* "Operand" is an empty string. This is a + * special case used only to represent the + * EMPTY lexeme. See below. */ }; /* * Readable macros to test whether a "pointer" value points to an operator. * They operate on the "non-negative integer -> operator; negative integer -> @@ -77,34 +77,35 @@ #define IsOperator(l) ((l) >= 0) #define NotOperator(l) ((l) < 0) /* * Note that it is sufficient to store in the tree just the type of leaf - * operand, without any explicit pointer to which leaf. This is true because - * the traversals of the completed tree we perform are known to visit the - * leaves in the same order as the original parse. + * operand, without any explicit pointer to which leaf. This is true because + * the traversals of the completed tree we perform are known to visit + * the leaves in the same order as the original parse. * * In a completed parse tree, those OpNodes that are themselves (roots of * subexpression trees that are) operands of some operator store in their - * p.parent field a "pointer" to the OpNode of that operator. The p.parent - * field permits a traversal of the tree within a non-recursive routine - * (ConvertTreeToTokens() and CompileExprTree()). This means that even + * p.parent field a "pointer" to the OpNode of that operator. The p.parent + * field permits a traversal of the tree within a * non-recursive routine + * (ConvertTreeToTokens() and CompileExprTree()). This means that even * expression trees of great depth pose no risk of blowing the C stack. * - * While the parse tree is being constructed, the same memory space is used to - * hold the p.prev field which chains together a stack of incomplete trees - * awaiting their right operands. + * While the parse tree is being constructed, the same memory space is used + * to hold the p.prev field which chains together a stack of incomplete + * trees awaiting their right operands. * * The lexeme field is filled in with the lexeme of the operator that is - * returned by the ParseLexeme() routine. Only lexemes for unary and binary - * operators get stored in an OpNode. Other lexmes get different treatement. + * returned by the ParseLexeme() routine. Only lexemes for unary and + * binary operators get stored in an OpNode. Other lexmes get different + * treatement. * * The precedence field provides a place to store the precedence of the * operator, so it need not be looked up again and again. * - * The mark field is use to control the traversal of the tree, so that it can - * be done non-recursively. The mark values are: + * The mark field is use to control the traversal of the tree, so + * that it can be done non-recursively. The mark values are: */ enum Marks { MARK_LEFT, /* Next step of traversal is to visit left subtree */ MARK_RIGHT, /* Next step of traversal is to visit right subtree */ @@ -116,192 +117,189 @@ * completely known at compile time, and are eligible for computing then * rather than waiting until run time. */ /* - * Each lexeme belongs to one of four categories, which determine its place in - * the parse tree. We use the two high bits of the (unsigned char) value to - * store a NODE_TYPE code. + * Each lexeme belongs to one of four categories, which determine + * its place in the parse tree. We use the two high bits of the + * (unsigned char) value to store a NODE_TYPE code. */ #define NODE_TYPE 0xC0 /* - * The four category values are LEAF, UNARY, and BINARY, explained below, and - * "uncategorized", which is used either temporarily, until context determines - * which of the other three categories is correct, or for lexemes like - * INVALID, which aren't really lexemes at all, but indicators of a parsing - * error. Note that the codes must be distinct to distinguish categories, but - * need not take the form of a bit array. + * The four category values are LEAF, UNARY, and BINARY, explained below, + * and "uncategorized", which is used either temporarily, until context + * determines which of the other three categories is correct, or for + * lexemes like INVALID, which aren't really lexemes at all, but indicators + * of a parsing error. Note that the codes must be distinct to distinguish + * categories, but need not take the form of a bit array. */ -#define BINARY 0x40 /* This lexeme is a binary operator. An OpNode - * representing it should go into the parse - * tree, and two operands should be parsed for - * it in the expression. */ -#define UNARY 0x80 /* This lexeme is a unary operator. An OpNode +#define BINARY 0x40 /* This lexeme is a binary operator. An + * OpNode representing it should go into the + * parse tree, and two operands should be + * parsed for it in the expression. */ +#define UNARY 0x80 /* This lexeme is a unary operator. An OpNode * representing it should go into the parse * tree, and one operand should be parsed for * it in the expression. */ #define LEAF 0xC0 /* This lexeme is a leaf operand in the parse - * tree. No OpNode will be placed in the tree - * for it. Either a literal value will be + * tree. No OpNode will be placed in the tree + * for it. Either a literal value will be * appended to the list of literals in this * expression, or appropriate Tcl_Tokens will * be appended in a Tcl_Parse struct to * represent those leaves that require some - * form of substitution. */ + * form of substitution. + */ /* Uncategorized lexemes */ -#define PLUS 1 /* Ambiguous. Resolves to UNARY_PLUS or +#define PLUS 1 /* Ambiguous. Resolves to UNARY_PLUS or * BINARY_PLUS according to context. */ -#define MINUS 2 /* Ambiguous. Resolves to UNARY_MINUS or +#define MINUS 2 /* Ambiguous. Resolves to UNARY_MINUS or * BINARY_MINUS according to context. */ -#define BAREWORD 3 /* Ambigous. Resolves to BOOLEAN or to +#define BAREWORD 3 /* Ambigous. Resolves to BOOLEAN or to * FUNCTION or a parse error according to * context and value. */ -#define INCOMPLETE 4 /* A parse error. Used only when the single +#define INCOMPLETE 4 /* A parse error. Used only when the single * "=" is encountered. */ -#define INVALID 5 /* A parse error. Used when any punctuation +#define INVALID 5 /* A parse error. Used when any punctuation * appears that's not a supported operator. */ /* Leaf lexemes */ -#define NUMBER (LEAF | 1) - /* For literal numbers */ -#define SCRIPT (LEAF | 2) - /* Script substitution; [foo] */ -#define BOOLEAN (LEAF | BAREWORD) - /* For literal booleans */ -#define BRACED (LEAF | 4) - /* Braced string; {foo bar} */ -#define VARIABLE (LEAF | 5) - /* Variable substitution; $x */ -#define QUOTED (LEAF | 6) - /* Quoted string; "foo $bar [soom]" */ -#define EMPTY (LEAF | 7) - /* Used only for an empty argument list to a - * function. Represents the empty string - * within parens in the expression: rand() */ +#define NUMBER ( LEAF | 1) /* For literal numbers */ +#define SCRIPT ( LEAF | 2) /* Script substitution; [foo] */ +#define BOOLEAN ( LEAF | BAREWORD) /* For literal booleans */ +#define BRACED ( LEAF | 4) /* Braced string; {foo bar} */ +#define VARIABLE ( LEAF | 5) /* Variable substitution; $x */ +#define QUOTED ( LEAF | 6) /* Quoted string; "foo $bar [soom]" */ +#define EMPTY ( LEAF | 7) /* Used only for an empty argument + * list to a function. Represents + * the empty string within parens in + * the expression: rand() */ /* Unary operator lexemes */ -#define UNARY_PLUS (UNARY | PLUS) -#define UNARY_MINUS (UNARY | MINUS) -#define FUNCTION (UNARY | BAREWORD) - /* This is a bit of "creative interpretation" - * on the part of the parser. A function call - * is parsed into the parse tree according to - * the perspective that the function name is a - * unary operator and its argument list, - * enclosed in parens, is its operand. The - * additional requirements not implied - * generally by treatment as a unary operator - * -- for example, the requirement that the - * operand be enclosed in parens -- are hard - * coded in the relevant portions of - * ParseExpr(). We trade off the need to - * include such exceptional handling in the - * code against the need we would otherwise - * have for more lexeme categories. */ -#define START (UNARY | 4) - /* This lexeme isn't parsed from the - * expression text at all. It represents the - * start of the expression and sits at the - * root of the parse tree where it serves as - * the start/end point of traversals. */ -#define OPEN_PAREN (UNARY | 5) - /* Another bit of creative interpretation, - * where we treat "(" as a unary operator with - * the sub-expression between it and its - * matching ")" as its operand. See - * CLOSE_PAREN below. */ -#define NOT (UNARY | 6) -#define BIT_NOT (UNARY | 7) +#define UNARY_PLUS ( UNARY | PLUS) +#define UNARY_MINUS ( UNARY | MINUS) +#define FUNCTION ( UNARY | BAREWORD) /* This is a bit of "creative + * interpretation" on the part of the + * parser. A function call is parsed + * into the parse tree according to + * the perspective that the function + * name is a unary operator and its + * argument list, enclosed in parens, + * is its operand. The additional + * requirements not implied generally + * by treatment as a unary operator -- + * for example, the requirement that + * the operand be enclosed in parens -- + * are hard coded in the relevant + * portions of ParseExpr(). We trade + * off the need to include such + * exceptional handling in the code + * against the need we would otherwise + * have for more lexeme categories. */ +#define START ( UNARY | 4) /* This lexeme isn't parsed from the + * expression text at all. It + * represents the start of the + * expression and sits at the root of + * the parse tree where it serves as + * the start/end point of traversals. */ +#define OPEN_PAREN ( UNARY | 5) /* Another bit of creative + * interpretation, where we treat "(" + * as a unary operator with the + * sub-expression between it and its + * matching ")" as its operand. See + * CLOSE_PAREN below. */ +#define NOT ( UNARY | 6) +#define BIT_NOT ( UNARY | 7) /* Binary operator lexemes */ -#define BINARY_PLUS (BINARY | PLUS) -#define BINARY_MINUS (BINARY | MINUS) -#define COMMA (BINARY | 3) - /* The "," operator is a low precedence binary - * operator that separates the arguments in a - * function call. The additional constraint - * that this operator can only legally appear - * at the right places within a function call - * argument list are hard coded within - * ParseExpr(). */ -#define MULT (BINARY | 4) -#define DIVIDE (BINARY | 5) -#define MOD (BINARY | 6) -#define LESS (BINARY | 7) -#define GREATER (BINARY | 8) -#define BIT_AND (BINARY | 9) -#define BIT_XOR (BINARY | 10) -#define BIT_OR (BINARY | 11) -#define QUESTION (BINARY | 12) - /* These two lexemes make up the */ -#define COLON (BINARY | 13) - /* ternary conditional operator, $x ? $y : $z. - * We treat them as two binary operators to - * avoid another lexeme category, and code the - * additional constraints directly in - * ParseExpr(). For instance, the right - * operand of a "?" operator must be a ":" - * operator. */ -#define LEFT_SHIFT (BINARY | 14) -#define RIGHT_SHIFT (BINARY | 15) -#define LEQ (BINARY | 16) -#define GEQ (BINARY | 17) -#define EQUAL (BINARY | 18) -#define NEQ (BINARY | 19) -#define AND (BINARY | 20) -#define OR (BINARY | 21) -#define STREQ (BINARY | 22) -#define STRNEQ (BINARY | 23) -#define EXPON (BINARY | 24) - /* Unlike the other binary operators, EXPON is - * right associative and this distinction is - * coded directly in ParseExpr(). */ -#define IN_LIST (BINARY | 25) -#define NOT_IN_LIST (BINARY | 26) -#define CLOSE_PAREN (BINARY | 27) - /* By categorizing the CLOSE_PAREN lexeme as a - * BINARY operator, the normal parsing rules - * for binary operators assure that a close - * paren will not directly follow another - * operator, and the machinery already in - * place to connect operands to operators - * according to precedence performs most of - * the work of matching open and close parens - * for us. In the end though, a close paren is - * not really a binary operator, and some - * special coding in ParseExpr() make sure we - * never put an actual CLOSE_PAREN node in the - * parse tree. The sub-expression between - * parens becomes the single argument of the - * matching OPEN_PAREN unary operator. */ -#define STR_LT (BINARY | 28) -#define STR_GT (BINARY | 29) -#define STR_LEQ (BINARY | 30) -#define STR_GEQ (BINARY | 31) -#define END (BINARY | 32) - /* This lexeme represents the end of the - * string being parsed. Treating it as a - * binary operator follows the same logic as - * the CLOSE_PAREN lexeme and END pairs with - * START, in the same way that CLOSE_PAREN - * pairs with OPEN_PAREN. */ - +#define BINARY_PLUS ( BINARY | PLUS) +#define BINARY_MINUS ( BINARY | MINUS) +#define COMMA ( BINARY | 3) /* The "," operator is a low precedence + * binary operator that separates the + * arguments in a function call. The + * additional constraint that this + * operator can only legally appear + * at the right places within a + * function call argument list are + * hard coded within ParseExpr(). */ +#define MULT ( BINARY | 4) +#define DIVIDE ( BINARY | 5) +#define MOD ( BINARY | 6) +#define LESS ( BINARY | 7) +#define GREATER ( BINARY | 8) +#define BIT_AND ( BINARY | 9) +#define BIT_XOR ( BINARY | 10) +#define BIT_OR ( BINARY | 11) +#define QUESTION ( BINARY | 12) /* These two lexemes make up the */ +#define COLON ( BINARY | 13) /* ternary conditional operator, + * $x ? $y : $z . We treat them as + * two binary operators to avoid + * another lexeme category, and + * code the additional constraints + * directly in ParseExpr(). For + * instance, the right operand of + * a "?" operator must be a ":" + * operator. */ +#define LEFT_SHIFT ( BINARY | 14) +#define RIGHT_SHIFT ( BINARY | 15) +#define LEQ ( BINARY | 16) +#define GEQ ( BINARY | 17) +#define EQUAL ( BINARY | 18) +#define NEQ ( BINARY | 19) +#define AND ( BINARY | 20) +#define OR ( BINARY | 21) +#define STREQ ( BINARY | 22) +#define STRNEQ ( BINARY | 23) +#define EXPON ( BINARY | 24) /* Unlike the other binary operators, + * EXPON is right associative and this + * distinction is coded directly in + * ParseExpr(). */ +#define IN_LIST ( BINARY | 25) +#define NOT_IN_LIST ( BINARY | 26) +#define CLOSE_PAREN ( BINARY | 27) /* By categorizing the CLOSE_PAREN + * lexeme as a BINARY operator, the + * normal parsing rules for binary + * operators assure that a close paren + * will not directly follow another + * operator, and the machinery already + * in place to connect operands to + * operators according to precedence + * performs most of the work of + * matching open and close parens for + * us. In the end though, a close + * paren is not really a binary + * operator, and some special coding + * in ParseExpr() make sure we never + * put an actual CLOSE_PAREN node + * in the parse tree. The + * sub-expression between parens + * becomes the single argument of + * the matching OPEN_PAREN unary + * operator. */ +#define END ( BINARY | 28) /* This lexeme represents the end of + * the string being parsed. Treating + * it as a binary operator follows the + * same logic as the CLOSE_PAREN lexeme + * and END pairs with START, in the + * same way that CLOSE_PAREN pairs with + * OPEN_PAREN. */ /* * When ParseExpr() builds the parse tree it must choose which operands to * connect to which operators. This is done according to operator precedence. - * The greater an operator's precedence the greater claim it has to link to an - * available operand. The Precedence enumeration lists the precedence values - * used by Tcl expression operators, from lowest to highest claim. Each - * precedence level is commented with the operators that hold that precedence. + * The greater an operator's precedence the greater claim it has to link to + * an available operand. The Precedence enumeration lists the precedence + * values used by Tcl expression operators, from lowest to highest claim. + * Each precedence level is commented with the operators that hold that + * precedence. */ enum Precedence { PREC_END = 1, /* END */ PREC_START, /* START */ @@ -322,13 +320,13 @@ PREC_EXPON, /* "**" */ PREC_UNARY /* "+", "-", FUNCTION, "!", "~" */ }; /* - * Here the same information contained in the comments above is stored in - * inverted form, so that given a lexeme, one can quickly look up its - * precedence value. + * Here the same information contained in the comments above is stored + * in inverted form, so that given a lexeme, one can quickly look up + * its precedence value. */ static const unsigned char prec[] = { /* Non-operator lexemes */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, @@ -362,18 +360,16 @@ PREC_EQUAL, /* STRNEQ */ PREC_EXPON, /* EXPON */ PREC_EQUAL, /* IN_LIST */ PREC_EQUAL, /* NOT_IN_LIST */ PREC_CLOSE_PAREN, /* CLOSE_PAREN */ - PREC_COMPARE, /* STR_LT */ - PREC_COMPARE, /* STR_GT */ - PREC_COMPARE, /* STR_LEQ */ - PREC_COMPARE, /* STR_GEQ */ PREC_END, /* END */ /* Expansion room for more binary operators */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, /* Unary operator lexemes */ PREC_UNARY, /* UNARY_PLUS */ PREC_UNARY, /* UNARY_MINUS */ PREC_UNARY, /* FUNCTION */ PREC_START, /* START */ @@ -419,18 +415,16 @@ INST_STR_NEQ, /* STRNEQ */ INST_EXPON, /* EXPON */ INST_LIST_IN, /* IN_LIST */ INST_LIST_NOT_IN, /* NOT_IN_LIST */ 0, /* CLOSE_PAREN */ - INST_STR_LT, /* STR_LT */ - INST_STR_GT, /* STR_GT */ - INST_STR_LE, /* STR_LEQ */ - INST_STR_GE, /* STR_GEQ */ 0, /* END */ /* Expansion room for more binary operators */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, /* Unary operator lexemes */ INST_UPLUS, /* UNARY_PLUS */ INST_UMINUS, /* UNARY_MINUS */ 0, /* FUNCTION */ 0, /* START */ @@ -459,11 +453,11 @@ INVALID /* SYN */, INVALID /* ETB */, INVALID /* CAN */, INVALID /* EM */, INVALID /* SUB */, INVALID /* ESC */, INVALID /* FS */, INVALID /* GS */, INVALID /* RS */, INVALID /* US */, - INVALID /* SPACE */, 0 /* ! or != */, + INVALID /* SPACE */, 0 /* ! or != */, QUOTED /* " */, INVALID /* # */, VARIABLE /* $ */, MOD /* % */, 0 /* & or && */, INVALID /* ' */, OPEN_PAREN /* ( */, CLOSE_PAREN /* ) */, 0 /* * or ** */, PLUS /* + */, @@ -496,10 +490,17 @@ typedef struct JumpList { JumpFixup jump; /* Pass this argument to matching calls of * TclEmitForwardJump() and * TclFixupForwardJump(). */ + int depth; /* Remember the currStackDepth of the + * CompileEnv here. */ + int offset; /* Data used to compute jump lengths to pass + * to TclFixupForwardJump() */ + int convert; /* Temporary storage used to compute whether + * numeric conversion will be needed following + * the operator we're compiling. */ struct JumpList *next; /* Point to next item on the stack */ } JumpList; /* * Declarations for local functions to this file: @@ -507,226 +508,204 @@ 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, size_t numBytes, +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, - size_t numBytes, OpNode **opTreePtr, + int numBytes, OpNode **opTreePtr, Tcl_Obj *litList, Tcl_Obj *funcList, Tcl_Parse *parsePtr, int parseOnly); -static size_t ParseLexeme(const char *start, size_t numBytes, +static int ParseLexeme(const char *start, int numBytes, unsigned char *lexemePtr, Tcl_Obj **literalPtr); + /* *---------------------------------------------------------------------- * * ParseExpr -- * * Given a string, the numBytes bytes starting at start, this function - * parses it as a Tcl expression and constructs a tree representing the - * structure of the expression. The caller must pass in empty lists as - * the funcList and litList arguments. The elements of the parsed - * expression are returned to the caller as that tree, a list of literal - * values, a list of function names, and in Tcl_Tokens added to a - * Tcl_Parse struct passed in by the caller. + * parses it as a Tcl expression and constructs a tree representing + * the structure of the expression. The caller must pass in empty + * lists as the funcList and litList arguments. The elements of the + * parsed expression are returned to the caller as that tree, a list of + * literal values, a list of function names, and in Tcl_Tokens + * added to a Tcl_Parse struct passed in by the caller. * * Results: * If the string is successfully parsed as a valid Tcl expression, TCL_OK - * is returned, and data about the expression structure is written to the - * 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. + * is returned, and data about the expression structure is written to + * the 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 Tcl_Free() 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. + * 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. */ - size_t numBytes, /* Number of bytes in string. */ + 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. */ int parseOnly) /* A boolean indicating whether the caller's * aim is just a parse, or whether it will go - * on to compile the expression. Different - * optimizations are appropriate for the two - * scenarios. */ + * on to compile the expression. Different + * optimizations are appropriate for the + * two scenarios. */ { OpNode *nodes = NULL; /* Pointer to the OpNode storage array where * we build the parse tree. */ - 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. */ - size_t scanned = 0; /* Capture number of byte scanned by parsing - * routines. */ + unsigned 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 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 + * 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 - * to know about it. */ - int incomplete; /* Index of the most recent incomplete tree in - * the OpNode array. Heads a stack of + * an OperandTypes value encoding what we + * need to know about it. */ + int incomplete; /* Index of the most recent incomplete tree + * in the OpNode array. Heads a stack of * incomplete trees linked by p.prev. */ int complete = OT_EMPTY; /* "Index" of the complete tree (that is, a * complete subexpression) determined at the - * moment. OT_EMPTY is a nonsense value used - * only to silence compiler warnings. During a - * parse, complete will always hold an index - * or an OperandTypes value pointing to an - * actual leaf at the time the complete tree - * is needed. */ - - /* - * These variables control generation of the error message. - */ - + * moment. OT_EMPTY is a nonsense value + * used only to silence compiler warnings. + * During a parse, complete will always hold + * an index or an OperandTypes value pointing + * to an actual leaf at the time the complete + * tree is needed. */ + + /* These variables control generation of the error message. */ Tcl_Obj *msg = NULL; /* The error message. */ Tcl_Obj *post = NULL; /* In a few cases, an additional postscript * for the error message, supplying more * information after the error msg and * location have been reported. */ - const char *errCode = NULL; /* The detail word of the errorCode list, or - * NULL to indicate that no changes to the - * errorCode are to be done. */ - const char *subErrCode = NULL; - /* Extra information for use in generating the - * errorCode. */ - const char *mark = "_@_"; /* In the portion of the complete error - * 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. */ + const char *mark = "_@_"; /* In the portion of the complete error 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 unsigned limit = 25; /* Portions of the error message are + 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. */ + * 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 *)Tcl_AttemptAlloc(nodesAvailable * sizeof(OpNode)); + nodes = (OpNode *) attemptckalloc(nodesAvailable * sizeof(OpNode)); if (nodes == NULL) { TclNewLiteralStringObj(msg, "not enough memory to parse expression"); - errCode = "NOMEM"; goto error; } - /* - * Initialize the parse tree with the special "START" node. - */ - + /* Initialize the parse tree with the special "START" node. */ nodes->lexeme = START; nodes->precedence = prec[START]; nodes->mark = MARK_RIGHT; nodes->constant = 1; incomplete = lastParsed = nodesUsed; nodesUsed++; /* - * Main parsing loop parses one lexeme per iteration. We exit the loop - * only when there's a syntax error with a "goto error" which takes us to - * the error handling code following the loop, or when we've successfully - * completed the parse and we return to the caller. + * Main parsing loop parses one lexeme per iteration. We exit the + * loop only when there's a syntax error with a "goto error" which + * takes us to the error handling code following the loop, or when + * we've successfully completed the parse and we return to the caller. */ while (1) { - OpNode *nodePtr; /* Points to the OpNode we may fill this pass - * through the loop. */ + OpNode *nodePtr; /* Points to the OpNode we may fill this + * pass through the loop. */ unsigned char lexeme; /* The lexeme we parse this iteration. */ - Tcl_Obj *literal; /* Filled by the ParseLexeme() call when a - * literal is parsed that has a Tcl_Obj rep - * worth preserving. */ + Tcl_Obj *literal; /* Filled by the ParseLexeme() call when + * a literal is parsed that has a Tcl_Obj + * rep worth preserving. */ /* * Each pass through this loop adds up to one more OpNode. Allocate * space for one if required. */ if (nodesUsed >= nodesAvailable) { - unsigned int size = nodesUsed * 2; + unsigned size = nodesUsed * 2; OpNode *newPtr = NULL; do { if (size <= UINT_MAX/sizeof(OpNode)) { - newPtr = (OpNode *)Tcl_AttemptRealloc(nodes, size * sizeof(OpNode)); + newPtr = (OpNode *) attemptckrealloc((char *) nodes, + (unsigned int) size * sizeof(OpNode)); } } while ((newPtr == NULL) && ((size -= (size - nodesUsed) / 2) > nodesUsed)); if (newPtr == NULL) { TclNewLiteralStringObj(msg, "not enough memory to parse expression"); - errCode = "NOMEM"; goto error; } nodesAvailable = size; nodes = newPtr; } nodePtr = nodes + nodesUsed; - /* - * Skip white space between lexemes. - */ - + /* Skip white space between lexemes. */ scanned = TclParseAllWhiteSpace(start, numBytes); start += scanned; numBytes -= scanned; scanned = ParseLexeme(start, numBytes, &lexeme, &literal); - /* - * Use context to categorize the lexemes that are ambiguous. - */ - + /* Use context to categorize the lexemes that are ambiguous. */ if ((NODE_TYPE & lexeme) == 0) { - int b; - switch (lexeme) { case INVALID: - msg = Tcl_ObjPrintf("invalid character \"%.*s\"", - (int)scanned, start); - errCode = "BADCHAR"; + msg = Tcl_ObjPrintf( + "invalid character \"%.*s\"", scanned, start); goto error; case INCOMPLETE: - msg = Tcl_ObjPrintf("incomplete operator \"%.*s\"", - (int)scanned, start); - errCode = "PARTOP"; + msg = Tcl_ObjPrintf( + "incomplete operator \"%.*s\"", scanned, start); 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 - * paren, it might be a function call, and when the bareword - * is a legal literal boolean value, we accept that as well. + * Most barewords in an expression are a syntax error. + * The exceptions are that when a bareword is followed by + * an open paren, it might be a function call, and when the + * bareword is a legal literal boolean value, we accept that + * as well. */ if (start[scanned+TclParseAllWhiteSpace( start+scanned, numBytes-scanned)] == '(') { lexeme = FUNCTION; @@ -737,91 +716,87 @@ * it, so we keep a separate list of all the function * names we've parsed in the order we found them. */ Tcl_ListObjAppendElement(NULL, funcList, literal); - } else if (Tcl_GetBooleanFromObj(NULL,literal,&b) == TCL_OK) { - lexeme = BOOLEAN; - } else { - Tcl_DecrRefCount(literal); - msg = Tcl_ObjPrintf("invalid bareword \"%.*s%s\"", - (scanned < limit) ? (int)scanned : (int)limit - 3, start, - (scanned < limit) ? "" : "..."); - post = Tcl_ObjPrintf( - "should be \"$%.*s%s\" or \"{%.*s%s}\"", - (scanned < limit) ? (int)scanned : (int)limit - 3, - start, (scanned < limit) ? "" : "...", - (scanned < limit) ? (int)scanned : (int)limit - 3, - start, (scanned < limit) ? "" : "..."); - Tcl_AppendPrintfToObj(post, " or \"%.*s%s(...)\" or ...", - (scanned < limit) ? (int)scanned : (int)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); - - if (isdigit(UCHAR(*stop)) || (stop == start + 1)) { - switch (start[1]) { - case 'b': - Tcl_AppendToObj(post, - " (invalid binary number?)", -1); - parsePtr->errorType = TCL_PARSE_BAD_NUMBER; - errCode = "BADNUMBER"; - subErrCode = "BINARY"; - break; - case 'o': - Tcl_AppendToObj(post, - " (invalid octal number?)", -1); - parsePtr->errorType = TCL_PARSE_BAD_NUMBER; - errCode = "BADNUMBER"; - subErrCode = "OCTAL"; - break; - default: - if (isdigit(UCHAR(start[1]))) { - Tcl_AppendToObj(post, - " (invalid octal number?)", -1); - parsePtr->errorType = TCL_PARSE_BAD_NUMBER; - errCode = "BADNUMBER"; - subErrCode = "OCTAL"; - } - break; - } - } - } - goto error; + } else { + int b; + 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) ? "" : "..."); + if (start[0] == '0') { + const char *stop; + TclParseNumber(NULL, NULL, NULL, start, scanned, + &stop, TCL_PARSE_NO_WHITESPACE); + + if (isdigit(UCHAR(*stop)) || (stop == start + 1)) { + parsePtr->errorType = TCL_PARSE_BAD_NUMBER; + + switch (start[1]) { + case 'b': + Tcl_AppendToObj(post, + " (invalid binary number?)", -1); + break; + case 'o': + Tcl_AppendToObj(post, + " (invalid octal number?)", -1); + break; + default: + if (isdigit(UCHAR(start[1]))) { + Tcl_AppendToObj(post, + " (invalid octal number?)", -1); + } + break; + } + } + } + goto error; + } } break; case PLUS: case MINUS: if (IsOperator(lastParsed)) { + /* - * A "+" or "-" coming just after another operator must be - * interpreted as a unary operator. + * A "+" or "-" coming just after another operator + * must be interpreted as a unary operator. */ lexeme |= UNARY; } else { lexeme |= BINARY; } } } /* Uncategorized lexemes */ + /* Handle lexeme based on its category. */ + switch (NODE_TYPE & lexeme) { + /* - * Handle lexeme based on its category. + * Each LEAF results in either a literal getting appended to the + * litList, or a sequence of Tcl_Tokens representing a Tcl word + * getting appended to the parsePtr->tokens. No OpNode is filled + * for this lexeme. */ - switch (NODE_TYPE & lexeme) { case LEAF: { - /* - * Each LEAF results in either a literal getting appended to the - * litList, or a sequence of Tcl_Tokens representing a Tcl word - * getting appended to the parsePtr->tokens. No OpNode is filled - * for this lexeme. - */ - Tcl_Token *tokenPtr; const char *end = start; int wordIndex; int code = TCL_OK; @@ -830,18 +805,14 @@ * operator is a syntax error. */ if (NotOperator(lastParsed)) { msg = Tcl_ObjPrintf("missing operator at %s", mark); - errCode = "MISSING"; scanned = 0; insertMark = 1; - /* - * Free any literal to avoid a memleak. - */ - + /* Free any literal to avoid a memleak. */ if ((lexeme == NUMBER) || (lexeme == BOOLEAN)) { Tcl_DecrRefCount(literal); } goto error; } @@ -854,20 +825,19 @@ * duplicate literals into a single representative value. * (Like what is done with [split $s {}]). * Pro: ~75% memory saving on expressions like * {1+1+1+1+1+.....+1} (Convert "pointer + Tcl_Obj" cost * to "pointer" cost only) - * Con: Cost of the dict store/retrieve on every literal in - * every expression when expressions like the above tend - * to be uncommon. + * Con: Cost of the dict store/retrieve on every literal + * in every expression when expressions like the above + * tend to be uncommon. * The memory savings is temporary; Compiling to bytecode * will collapse things as literals are registered - * anyway, so the savings applies only to the time - * between parsing and compiling. Possibly important due - * to high-water mark nature of memory allocation. + * anyway, so the savings applies only to the time + * between parsing and compiling. Possibly important + * due to high-water mark nature of memory allocation. */ - Tcl_ListObjAppendElement(NULL, litList, literal); complete = lastParsed = OT_LITERAL; start += scanned; numBytes -= scanned; continue; @@ -875,12 +845,12 @@ default: break; } /* - * Remaining LEAF cases may involve filling Tcl_Tokens, so make - * room for at least 2 more tokens. + * Remaining LEAF cases may involve filling Tcl_Tokens, so + * make room for at least 2 more tokens. */ TclGrowParseTokenArray(parsePtr, 2); wordIndex = parsePtr->numTokens; tokenPtr = parsePtr->tokenPtr + wordIndex; @@ -895,11 +865,11 @@ scanned = end - start; break; case BRACED: code = Tcl_ParseBraces(NULL, start, numBytes, - parsePtr, 1, &end); + parsePtr, 1, &end); scanned = end - start; break; case VARIABLE: code = Tcl_ParseVarName(NULL, start, numBytes, parsePtr, 1); @@ -910,50 +880,48 @@ */ tokenPtr = parsePtr->tokenPtr + wordIndex + 1; if (code == TCL_OK && tokenPtr->type != TCL_TOKEN_VARIABLE) { TclNewLiteralStringObj(msg, "invalid character \"$\""); - errCode = "BADCHAR"; goto error; } scanned = tokenPtr->size; break; case SCRIPT: { - Tcl_Parse *nestedPtr = (Tcl_Parse *) - TclStackAlloc(interp, sizeof(Tcl_Parse)); + 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; end = start + numBytes; start++; while (1) { - code = Tcl_ParseCommand(interp, start, end - start, 1, + code = Tcl_ParseCommand(interp, start, (end - start), 1, nestedPtr); if (code != TCL_OK) { parsePtr->term = nestedPtr->term; parsePtr->errorType = nestedPtr->errorType; parsePtr->incomplete = nestedPtr->incomplete; break; } - start = nestedPtr->commandStart + nestedPtr->commandSize; + start = (nestedPtr->commandStart + nestedPtr->commandSize); Tcl_FreeParse(nestedPtr); - if ((nestedPtr->term < end) && (nestedPtr->term[0] == ']') - && !nestedPtr->incomplete) { + if ((nestedPtr->term < end) && (*(nestedPtr->term) == ']') + && !(nestedPtr->incomplete)) { break; } if (start == end) { TclNewLiteralStringObj(msg, "missing close-bracket"); parsePtr->term = tokenPtr->start; parsePtr->errorType = TCL_PARSE_MISSING_BRACKET; parsePtr->incomplete = 1; code = TCL_ERROR; - errCode = "UNBALANCED"; break; } } TclStackFree(interp, nestedPtr); end = start; @@ -960,58 +928,58 @@ start = tokenPtr->start; scanned = end - start; tokenPtr->size = scanned; parsePtr->numTokens++; break; - } /* SCRIPT case */ + } } if (code != TCL_OK) { + /* - * Here we handle all the syntax errors generated by the - * Tcl_Token generating parsing routines called in the switch - * just above. If the value of parsePtr->incomplete is 1, then - * the error was an unbalanced '[', '(', '{', or '"' and - * parsePtr->term is pointing to that unbalanced character. If - * the value of parsePtr->incomplete is 0, then the error is - * one of lacking whitespace following a quoted word, for - * example: expr {[an error {foo}bar]}, and parsePtr->term - * points to where the whitespace is missing. We reset our - * values of start and scanned so that when our error message - * is constructed, the location of the syntax error is sure to - * appear in it, even if the quoted expression is truncated. + * Here we handle all the syntax errors generated by + * the Tcl_Token generating parsing routines called in the + * switch just above. If the value of parsePtr->incomplete + * is 1, then the error was an unbalanced '[', '(', '{', + * or '"' and parsePtr->term is pointing to that unbalanced + * character. If the value of parsePtr->incomplete is 0, + * then the error is one of lacking whitespace following a + * quoted word, for example: expr {[an error {foo}bar]}, + * and parsePtr->term points to where the whitespace is + * missing. We reset our values of start and scanned so that + * when our error message is constructed, the location of + * the syntax error is sure to appear in it, even if the + * quoted expression is truncated. */ start = parsePtr->term; scanned = parsePtr->incomplete; - if (parsePtr->incomplete) { - errCode = "UNBALANCED"; - } goto error; } tokenPtr = parsePtr->tokenPtr + wordIndex; tokenPtr->size = scanned; tokenPtr->numComponents = parsePtr->numTokens - wordIndex - 1; if (!parseOnly && ((lexeme == QUOTED) || (lexeme == BRACED))) { + /* * When this expression is destined to be compiled, and a * braced or quoted word within an expression is known at - * compile time (no runtime substitutions in it), we can store - * it as a literal rather than in its tokenized form. This is - * an advantage since the compiled bytecode is going to need - * the argument in Tcl_Obj form eventually, so it's just as - * well to get there now. Another advantage is that with this - * conversion, larger constant expressions might be grown and - * optimized. - * - * On the contrary, if the end goal of this parse is to fill a - * Tcl_Parse for a caller of Tcl_ParseExpr(), then it's + * compile time (no runtime substitutions in it), we can + * store it as a literal rather than in its tokenized form. + * This is an advantage since the compiled bytecode is going + * to need the argument in Tcl_Obj form eventually, so it's + * just as well to get there now. Another advantage is that + * with this conversion, larger constant expressions might + * be grown and optimized. + * + * On the contrary, if the end goal of this parse is to + * fill a Tcl_Parse for a caller of Tcl_ParseExpr(), then it's * wasteful to convert to a literal only to convert back again * later. */ - TclNewObj(literal); + literal = Tcl_NewObj(); if (TclWordKnownAtCompileTime(tokenPtr, literal)) { Tcl_ListObjAppendElement(NULL, litList, literal); complete = lastParsed = OT_LITERAL; parsePtr->numTokens = wordIndex; break; @@ -1032,35 +1000,31 @@ if (NotOperator(lastParsed)) { msg = Tcl_ObjPrintf("missing operator at %s", mark); scanned = 0; insertMark = 1; - errCode = "MISSING"; goto error; } - /* - * Create an OpNode for the unary operator. - */ - + /* Create an OpNode for the unary operator */ nodePtr->lexeme = lexeme; nodePtr->precedence = prec[lexeme]; nodePtr->mark = MARK_RIGHT; /* * A FUNCTION cannot be a constant expression, because Tcl allows * functions to return variable results with the same arguments; - * for example, rand(). Other unary operators can root a constant + * for example, rand(). Other unary operators can root a constant * expression, so long as the argument is a constant expression. */ nodePtr->constant = (lexeme != FUNCTION); /* - * This unary operator is a new incomplete tree, so push it onto - * our stack of incomplete trees. Also remember it as the last - * lexeme we parsed. + * This unary operator is a new incomplete tree, so push it + * onto our stack of incomplete trees. Also remember it as + * the last lexeme we parsed. */ nodePtr->p.prev = incomplete; incomplete = lastParsed = nodesUsed; nodesUsed++; @@ -1077,95 +1041,92 @@ if (IsOperator(lastParsed)) { if ((lexeme == CLOSE_PAREN) && (nodePtr[-1].lexeme == OPEN_PAREN)) { if (nodePtr[-2].lexeme == FUNCTION) { + /* * Normally, "()" is a syntax error, but as a special * case accept it as an argument list for a function. * Treat this as a special LEAF lexeme, and restart - * the parsing loop with zero characters scanned. We - * will parse the ")" again the next time through, but - * with the OT_EMPTY leaf as the subexpression between - * the parens. + * the parsing loop with zero characters scanned. + * We'll parse the ")" again the next time through, + * but with the OT_EMPTY leaf as the subexpression + * between the parens. */ scanned = 0; complete = lastParsed = OT_EMPTY; break; } msg = Tcl_ObjPrintf("empty subexpression at %s", mark); scanned = 0; insertMark = 1; - errCode = "EMPTY"; goto error; } if (nodePtr[-1].precedence > precedence) { if (nodePtr[-1].lexeme == OPEN_PAREN) { TclNewLiteralStringObj(msg, "unbalanced open paren"); parsePtr->errorType = TCL_PARSE_MISSING_PAREN; - errCode = "UNBALANCED"; } else if (nodePtr[-1].lexeme == COMMA) { msg = Tcl_ObjPrintf( "missing function argument at %s", mark); scanned = 0; insertMark = 1; - errCode = "MISSING"; } else if (nodePtr[-1].lexeme == START) { TclNewLiteralStringObj(msg, "empty expression"); - errCode = "EMPTY"; - } - } else if (lexeme == CLOSE_PAREN) { - TclNewLiteralStringObj(msg, "unbalanced close paren"); - errCode = "UNBALANCED"; - } else if ((lexeme == COMMA) - && (nodePtr[-1].lexeme == OPEN_PAREN) - && (nodePtr[-2].lexeme == FUNCTION)) { - msg = Tcl_ObjPrintf("missing function argument at %s", - mark); - scanned = 0; - insertMark = 1; - errCode = "UNBALANCED"; + } + } else { + if (lexeme == CLOSE_PAREN) { + TclNewLiteralStringObj(msg, "unbalanced close paren"); + } else if ((lexeme == COMMA) + && (nodePtr[-1].lexeme == OPEN_PAREN) + && (nodePtr[-2].lexeme == FUNCTION)) { + msg = Tcl_ObjPrintf( + "missing function argument at %s", mark); + scanned = 0; + insertMark = 1; + } } if (msg == NULL) { msg = Tcl_ObjPrintf("missing operand at %s", mark); scanned = 0; insertMark = 1; - errCode = "MISSING"; } goto error; } /* - * Here is where the tree comes together. At this point, we have a - * stack of incomplete trees corresponding to substrings that are - * incomplete expressions, followed by a complete tree - * corresponding to a substring that is itself a complete - * expression, followed by the binary operator we have just - * parsed. The incomplete trees can each be completed by adding a - * right operand. + * Here is where the tree comes together. At this point, we + * have a stack of incomplete trees corresponding to + * substrings that are incomplete expressions, followed by + * a complete tree corresponding to a substring that is itself + * a complete expression, followed by the binary operator we have + * just parsed. The incomplete trees can each be completed by + * adding a right operand. * * To illustrate with an example, when we parse the expression * "1+2*3-4" and we reach this point having just parsed the "-" * operator, we have these incomplete trees: START, "1+", and - * "2*". Next we have the complete subexpression "3". Last is the - * "-" we've just parsed. - * - * The next step is to join our complete tree to an operator. The - * choice is governed by the precedence and associativity of the - * competing operators. If we connect it as the right operand of - * our most recent incomplete tree, we get a new complete tree, - * and we can repeat the process. The while loop following repeats - * this until precedence indicates it is time to join the complete - * tree as the left operand of the just parsed binary operator. - * - * Continuing the example, the first pass through the loop will - * join "3" to "2*"; the next pass will join "2*3" to "1+". Then - * we'll exit the loop and join "1+2*3" to "-". When we return to - * parse another lexeme, our stack of incomplete trees is START - * and "1+2*3-". + * "2*". Next we have the complete subexpression "3". Last is + * the "-" we've just parsed. + * + * The next step is to join our complete tree to an operator. + * The choice is governed by the precedence and associativity + * of the competing operators. If we connect it as the right + * operand of our most recent incomplete tree, we get a new + * complete tree, and we can repeat the process. The while + * loop following repeats this until precedence indicates it + * is time to join the complete tree as the left operand of + * the just parsed binary operator. + * + * Continuing the example, the first pass through the loop + * will join "3" to "2*"; the next pass will join "2*3" to + * "1+". Then we'll exit the loop and join "1+2*3" to "-". + * When we return to parse another lexeme, our stack of + * incomplete trees is START and "1+2*3-". */ while (1) { incompletePtr = nodes + incomplete; @@ -1172,22 +1133,20 @@ if (incompletePtr->precedence < precedence) { break; } if (incompletePtr->precedence == precedence) { - /* - * Right association rules for exponentiation. - */ + /* Right association rules for exponentiation. */ if (lexeme == EXPON) { break; } /* - * Special association rules for the conditional - * operators. The "?" and ":" operators have equal - * precedence, but must be linked up in sensible pairs. + * Special association rules for the conditional operators. + * The "?" and ":" operators have equal precedence, but + * must be linked up in sensible pairs. */ if ((incompletePtr->lexeme == QUESTION) && (NotOperator(complete) || (nodes[complete].lexeme != COLON))) { @@ -1197,31 +1156,28 @@ && (lexeme == QUESTION)) { break; } } - /* - * Some special syntax checks... - */ + /* Some special syntax checks... */ /* Parens must balance */ if ((incompletePtr->lexeme == OPEN_PAREN) && (lexeme != CLOSE_PAREN)) { TclNewLiteralStringObj(msg, "unbalanced open paren"); parsePtr->errorType = TCL_PARSE_MISSING_PAREN; - errCode = "UNBALANCED"; goto error; } /* Right operand of "?" must be ":" */ if ((incompletePtr->lexeme == QUESTION) && (NotOperator(complete) || (nodes[complete].lexeme != COLON))) { - msg = Tcl_ObjPrintf("missing operator \":\" at %s", mark); + msg = Tcl_ObjPrintf( + "missing operator \":\" at %s", mark); scanned = 0; insertMark = 1; - errCode = "MISSING"; goto error; } /* Operator ":" may only be right operand of "?" */ if (IsOperator(complete) @@ -1228,11 +1184,10 @@ && (nodes[complete].lexeme == COLON) && (incompletePtr->lexeme != QUESTION)) { TclNewLiteralStringObj(msg, "unexpected operator \":\" " "without preceding \"?\""); - errCode = "SURPRISE"; goto error; } /* * Attach complete tree as right operand of most recent @@ -1248,21 +1203,22 @@ incompletePtr->constant = incompletePtr->constant && (complete == OT_LITERAL); } /* - * The QUESTION/COLON and FUNCTION/OPEN_PAREN combinations - * each make up a single operator. Force them to agree whether - * they have a constant expression. + * The QUESTION/COLON and FUNCTION/OPEN_PAREN combinations each + * make up a single operator. Force them to agree whether they + * have a constant expression. */ if ((incompletePtr->lexeme == QUESTION) || (incompletePtr->lexeme == FUNCTION)) { nodes[complete].constant = incompletePtr->constant; } if (incompletePtr->lexeme == START) { + /* * Completing the START tree indicates we're done. * Transfer the parse tree to the caller and return. */ @@ -1270,12 +1226,12 @@ return TCL_OK; } /* * With a right operand attached, last incomplete tree has - * become the complete tree. Pop it from the incomplete tree - * stack. + * become the complete tree. Pop it from the incomplete + * tree stack. */ complete = incomplete; incomplete = incompletePtr->p.prev; @@ -1283,19 +1239,16 @@ if (incompletePtr->lexeme == OPEN_PAREN) { break; } } - /* - * More syntax checks... - */ + /* More syntax checks... */ /* Parens must balance. */ if (lexeme == CLOSE_PAREN) { if (incompletePtr->lexeme != OPEN_PAREN) { TclNewLiteralStringObj(msg, "unbalanced close paren"); - errCode = "UNBALANCED"; goto error; } } /* Commas must appear only in function argument lists. */ @@ -1302,45 +1255,37 @@ if (lexeme == COMMA) { if ((incompletePtr->lexeme != OPEN_PAREN) || (incompletePtr[-1].lexeme != FUNCTION)) { TclNewLiteralStringObj(msg, "unexpected \",\" outside function argument list"); - errCode = "SURPRISE"; goto error; } } /* Operator ":" may only be right operand of "?" */ if (IsOperator(complete) && (nodes[complete].lexeme == COLON)) { TclNewLiteralStringObj(msg, "unexpected operator \":\" without preceding \"?\""); - errCode = "SURPRISE"; goto error; } - /* - * Create no node for a CLOSE_PAREN lexeme. - */ - + /* Create no node for a CLOSE_PAREN lexeme. */ if (lexeme == CLOSE_PAREN) { break; } - /* - * Link complete tree as left operand of new node. - */ - + /* Link complete tree as left operand of new node. */ nodePtr->lexeme = lexeme; nodePtr->precedence = precedence; nodePtr->mark = MARK_LEFT; nodePtr->left = complete; /* * The COMMA operator cannot be optimized, since the function - * needs all of its arguments, and optimization would reduce the - * number. Other binary operators root constant expressions when - * both arguments are constant expressions. + * needs all of its arguments, and optimization would reduce + * the number. Other binary operators root constant expressions + * when both arguments are constant expressions. */ nodePtr->constant = (lexeme != COMMA); if (IsOperator(complete)) { @@ -1351,13 +1296,13 @@ nodePtr->constant = nodePtr->constant && (complete == OT_LITERAL); } /* - * With a left operand attached and a right operand missing, the - * just-parsed binary operator is root of a new incomplete tree. - * Push it onto the stack of incomplete trees. + * With a left operand attached and a right operand missing, + * the just-parsed binary operator is root of a new incomplete + * tree. Push it onto the stack of incomplete trees. */ nodePtr->p.prev = incomplete; incomplete = lastParsed = nodesUsed; nodesUsed++; @@ -1368,40 +1313,38 @@ /* Advance past the just-parsed lexeme */ start += scanned; numBytes -= scanned; } /* main parsing loop */ + error: + /* - * We only get here if there's been an error. Any errors that didn't get a - * suitable parsePtr->errorType, get recorded as syntax errors. + * We only get here if there's been an error. + * Any errors that didn't get a suitable parsePtr->errorType, + * get recorded as syntax errors. */ - error: if (parsePtr->errorType == TCL_PARSE_SUCCESS) { parsePtr->errorType = TCL_PARSE_SYNTAX; } - /* - * Free any partial parse tree we've built. - */ - + /* Free any partial parse tree we've built. */ if (nodes != NULL) { - Tcl_Free(nodes); + ckfree((char*) nodes); } if (interp == NULL) { - /* - * Nowhere to report an error message, so just free it. - */ + /* Nowhere to report an error message, so just free it */ if (msg) { Tcl_DecrRefCount(msg); } } else { + /* - * Construct the complete error message. Start with the simple error - * message, pulled from the interp result if necessary... + * Construct the complete error message. Start with the simple + * error message, pulled from the interp result if necessary... */ if (msg == NULL) { msg = Tcl_GetObjResult(interp); } @@ -1412,44 +1355,34 @@ */ Tcl_AppendPrintfToObj(msg, "\nin expression \"%s%.*s%.*s%s%s%.*s%s\"", ((start - limit) < parsePtr->string) ? "" : "...", ((start - limit) < parsePtr->string) - ? (int) (start - parsePtr->string) : (int)limit - 3, + ? (int) (start - parsePtr->string) : limit - 3, ((start - limit) < parsePtr->string) ? parsePtr->string : start - limit + 3, - (scanned < limit) ? (int)scanned : (int)limit - 3, start, + (scanned < limit) ? scanned : limit - 3, start, (scanned < limit) ? "" : "...", insertMark ? mark : "", (start + scanned + limit > parsePtr->end) - ? (int) (parsePtr->end - start) - (int)scanned : (int)limit-3, + ? (int) (parsePtr->end - start) - scanned : limit-3, start + scanned, (start + scanned + limit > parsePtr->end) ? "" : "..."); - /* - * Next, append any postscript message. - */ - + /* Next, append any postscript message. */ if (post != NULL) { Tcl_AppendToObj(msg, ";\n", -1); Tcl_AppendObjToObj(msg, post); Tcl_DecrRefCount(post); } Tcl_SetObjResult(interp, msg); - /* - * Finally, place context information in the errorInfo. - */ - + /* Finally, place context information in the errorInfo. */ numBytes = parsePtr->end - parsePtr->string; Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (parsing expression \"%.*s%s\")", - (numBytes < limit) ? (int)numBytes : (int)limit - 3, + (numBytes < limit) ? numBytes : limit - 3, parsePtr->string, (numBytes < limit) ? "" : "...")); - if (errCode) { - Tcl_SetErrorCode(interp, "TCL", "PARSE", "EXPR", errCode, - subErrCode, NULL); - } } return TCL_ERROR; } @@ -1459,14 +1392,14 @@ * ConvertTreeToTokens -- * * Given a string, the numBytes bytes starting at start, and an OpNode * tree and Tcl_Token array created by passing that same string to * ParseExpr(), this function writes into *parsePtr the sequence of - * Tcl_Tokens needed so to satisfy the historical interface provided by - * Tcl_ParseExpr(). Note that this routine exists only for the sake of - * the public Tcl_ParseExpr() routine. It is not used by Tcl itself at - * all. + * Tcl_Tokens needed so to satisfy the historical interface provided + * by Tcl_ParseExpr(). Note that this routine exists only for the sake + * of the public Tcl_ParseExpr() routine. It is not used by Tcl itself + * at all. * * Results: * None. * * Side effects: @@ -1477,11 +1410,11 @@ */ static void ConvertTreeToTokens( const char *start, - size_t numBytes, + int numBytes, OpNode *nodes, Tcl_Token *tokenPtr, Tcl_Parse *parsePtr) { int subExprTokenIdx = 0; @@ -1498,34 +1431,25 @@ * steps over ground already covered. */ nodePtr->mark++; - /* - * Handle next child node or leaf. - */ - + /* Handle next child node or leaf */ switch (next) { case OT_EMPTY: /* No tokens and no characters for the OT_EMPTY leaf. */ break; case OT_LITERAL: - /* - * Skip any white space that comes before the literal. - */ - + /* Skip any white space that comes before the literal */ scanned = TclParseAllWhiteSpace(start, numBytes); - start += scanned; + start +=scanned; numBytes -= scanned; - /* - * Reparse the literal to get pointers into source string. - */ - + /* Reparse the literal to get pointers into source string */ scanned = ParseLexeme(start, numBytes, &lexeme, NULL); TclGrowParseTokenArray(parsePtr, 2); subExprTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens; subExprTokenPtr->type = TCL_TOKEN_SUB_EXPR; @@ -1536,88 +1460,82 @@ subExprTokenPtr[1].start = start; subExprTokenPtr[1].size = scanned; subExprTokenPtr[1].numComponents = 0; parsePtr->numTokens += 2; - start += scanned; + start +=scanned; numBytes -= scanned; break; case OT_TOKENS: { + /* - * tokenPtr points to a token sequence that came from parsing a - * Tcl word. A Tcl word is made up of a sequence of one or more - * elements. When the word is only a single element, it's been the - * historical practice to replace the TCL_TOKEN_WORD token - * directly with a TCL_TOKEN_SUB_EXPR token. However, when the - * word has multiple elements, a TCL_TOKEN_WORD token is kept as a - * grouping device so that TCL_TOKEN_SUB_EXPR always has only one - * element. Wise or not, these are the rules the Tcl expr parser - * has followed, and for the sake of those few callers of - * Tcl_ParseExpr() we do not change them now. Internally, we can - * do better. + * tokenPtr points to a token sequence that came from parsing + * a Tcl word. A Tcl word is made up of a sequence of one or + * more elements. When the word is only a single element, it's + * been the historical practice to replace the TCL_TOKEN_WORD + * token directly with a TCL_TOKEN_SUB_EXPR token. However, + * when the word has multiple elements, a TCL_TOKEN_WORD token + * is kept as a grouping device so that TCL_TOKEN_SUB_EXPR + * always has only one element. Wise or not, these are the + * rules the Tcl expr parser has followed, and for the sake + * of those few callers of Tcl_ParseExpr() we do not change + * them now. Internally, we can do better. */ int toCopy = tokenPtr->numComponents + 1; if (tokenPtr->numComponents == tokenPtr[1].numComponents + 1) { + /* - * Single element word. Copy tokens and convert the leading + * 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, - toCopy * sizeof(Tcl_Token)); + (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. + * 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, - toCopy * sizeof(Tcl_Token)); + (size_t) toCopy * sizeof(Tcl_Token)); parsePtr->numTokens += toCopy + 1; } scanned = tokenPtr->start + tokenPtr->size - start; - start += scanned; + start +=scanned; numBytes -= scanned; tokenPtr += toCopy; break; } default: - /* - * Advance to the child node, which is an operator. - */ - + /* Advance to the child node, which is an operator. */ nodePtr = nodes + next; - /* - * Skip any white space that comes before the subexpression. - */ - + /* Skip any white space that comes before the subexpression */ scanned = TclParseAllWhiteSpace(start, numBytes); - start += scanned; + start +=scanned; numBytes -= scanned; - /* - * Generate tokens for the operator / subexpression... - */ - + /* Generate tokens for the operator / subexpression... */ switch (nodePtr->lexeme) { case OPEN_PAREN: case COMMA: case COLON: @@ -1630,20 +1548,20 @@ default: { /* * Remember the index of the last subexpression we were - * working on -- that of our parent. We'll stack it later. + * working on -- that of our parent. We'll stack it later. */ parentIdx = subExprTokenIdx; /* * Verify space for the two leading Tcl_Tokens representing - * the subexpression rooted by this operator. The first - * Tcl_Token will be of type TCL_TOKEN_SUB_EXPR; the second of - * type TCL_TOKEN_OPERATOR. + * the subexpression rooted by this operator. The first + * Tcl_Token will be of type TCL_TOKEN_SUB_EXPR; the second + * of type TCL_TOKEN_OPERATOR. */ TclGrowParseTokenArray(parsePtr, 2); subExprTokenIdx = parsePtr->numTokens; subExprTokenPtr = parsePtr->tokenPtr + subExprTokenIdx; @@ -1658,11 +1576,11 @@ subExprTokenPtr->start = start; /* * Eventually, we know that the numComponents field of the - * Tcl_Token of type TCL_TOKEN_OPERATOR will be 0. This means + * Tcl_Token of type TCL_TOKEN_OPERATOR will be 0. This means * we can make other use of this field for now to track the * stack of subexpressions we have pending. */ subExprTokenPtr[1].numComponents = parentIdx; @@ -1680,16 +1598,13 @@ break; case MARK_RIGHT: next = nodePtr->right; - /* - * Skip any white space that comes before the operator. - */ - + /* Skip any white space that comes before the operator */ scanned = TclParseAllWhiteSpace(start, numBytes); - start += scanned; + start +=scanned; numBytes -= scanned; /* * Here we scan from the string the operator corresponding to * nodePtr->lexeme. @@ -1700,14 +1615,11 @@ switch(nodePtr->lexeme) { case OPEN_PAREN: case COMMA: case COLON: - /* - * No tokens for these lexemes -> nothing to do. - */ - + /* No tokens for these lexemes -> nothing to do. */ break; default: /* @@ -1719,11 +1631,11 @@ subExprTokenPtr[1].start = start; subExprTokenPtr[1].size = scanned; break; } - start += scanned; + start +=scanned; numBytes -= scanned; break; case MARK_PARENT: switch (nodePtr->lexeme) { @@ -1738,23 +1650,20 @@ /* No tokens for these lexemes -> nothing to do. */ break; case OPEN_PAREN: - /* - * Skip past matching close paren. - */ - + /* Skip past matching close paren. */ scanned = TclParseAllWhiteSpace(start, numBytes); - start += scanned; + start +=scanned; numBytes -= scanned; scanned = ParseLexeme(start, numBytes, &lexeme, NULL); - start += scanned; + start +=scanned; numBytes -= scanned; break; - default: + default: { /* * Before we leave this node/operator/subexpression for the * last time, finish up its tokens.... * @@ -1765,11 +1674,11 @@ subExprTokenPtr = parsePtr->tokenPtr + subExprTokenIdx; subExprTokenPtr->size = start - subExprTokenPtr->start; /* * All the Tcl_Tokens allocated and filled belong to - * this subexpression. The first token is the leading + * this subexpresion. The first token is the leading * TCL_TOKEN_SUB_EXPR token, and all the rest (one fewer) * are its components. */ subExprTokenPtr->numComponents = @@ -1784,15 +1693,13 @@ parentIdx = subExprTokenPtr[1].numComponents; subExprTokenPtr[1].numComponents = 0; subExprTokenIdx = parentIdx; break; } + } - /* - * Since we're returning to parent, skip child handling code. - */ - + /* Since we're returning to parent, skip child handling code. */ nodePtr = nodes + nodePtr->p.parent; goto router; } } } @@ -1825,32 +1732,31 @@ int Tcl_ParseExpr( Tcl_Interp *interp, /* Used for error reporting. */ const char *start, /* Start of source string to parse. */ - size_t numBytes, /* Number of bytes in string. If -1, the + 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; /* List to hold the literals. */ - Tcl_Obj *funcList; /* List to hold the functon names. */ - Tcl_Parse *exprParsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse)); - /* Holds the Tcl_Tokens of substitutions. */ - - TclNewObj(litList); - TclNewObj(funcList); - if (numBytes == TCL_INDEX_NONE) { + 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 */); + 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) { @@ -1861,11 +1767,11 @@ parsePtr->errorType = exprParsePtr->errorType; } Tcl_FreeParse(exprParsePtr); TclStackFree(interp, exprParsePtr); - Tcl_Free(opTree); + ckfree((char *) opTree); return code; } /* *---------------------------------------------------------------------- @@ -1882,29 +1788,30 @@ * Code identifying lexeme parsed is writen to *lexemePtr. * *---------------------------------------------------------------------- */ -static size_t +static int ParseLexeme( const char *start, /* Start of lexeme to parse. */ - size_t numBytes, /* Number of bytes in string. */ + 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; - Tcl_UniChar ch = 0; + int scanned; + Tcl_UniChar ch; Tcl_Obj *literal = NULL; unsigned char byte; if (numBytes == 0) { *lexemePtr = END; return 0; } - byte = UCHAR(*start); + byte = (unsigned char)(*start); if (byte < sizeof(Lexeme) && Lexeme[byte] != 0) { *lexemePtr = Lexeme[byte]; return 1; } switch (byte) { @@ -1977,14 +1884,15 @@ return 1; case 'i': if ((numBytes > 1) && (start[1] == 'n') && ((numBytes == 2) || start[2] & 0x80 || !isalpha(UCHAR(start[2])))) { + /* - * Must make this check so we can tell the difference between the - * "in" operator and the "int" function name and the "infinity" - * numeric value. + * Must make this check so we can tell the difference between + * the "in" operator and the "int" function name and the + * "infinity" numeric value. */ *lexemePtr = IN_LIST; return 2; } @@ -2008,46 +1916,17 @@ case 'i': *lexemePtr = NOT_IN_LIST; return 2; } } - break; - - case 'l': - if ((numBytes > 1) - && ((numBytes == 2) || start[2] & 0x80 || !isalpha(UCHAR(start[2])))) { - switch (start[1]) { - case 't': - *lexemePtr = STR_LT; - return 2; - case 'e': - *lexemePtr = STR_LEQ; - return 2; - } - } - break; - - case 'g': - if ((numBytes > 1) - && ((numBytes == 2) || start[2] & 0x80 || !isalpha(UCHAR(start[2])))) { - switch (start[1]) { - case 't': - *lexemePtr = STR_GT; - return 2; - case 'e': - *lexemePtr = STR_GEQ; - return 2; - } - } - break; - } - - TclNewObj(literal); + } + + literal = Tcl_NewObj(); if (TclParseNumber(NULL, literal, NULL, start, numBytes, &end, TCL_PARSE_NO_WHITESPACE) == TCL_OK) { if (end < start + numBytes && !TclIsBareword(*end)) { - + number: TclInitStringRep(literal, start, end-start); *lexemePtr = NUMBER; if (literalPtr) { *literalPtr = literal; @@ -2063,17 +1942,16 @@ * (alpha, digit, underscore). Is this a number followed by * bareword syntax error? Or should we join into one bareword? * Example: Inf + luence + () becomes a valid function call. * [Bug 3401704] */ - if (TclHasIntRep(literal, &tclDoubleType)) { + if (literal->typePtr == &tclDoubleType) { const char *p = start; - while (p < end) { if (!TclIsBareword(*p++)) { /* - * The number has non-bareword characters, so we + * The number has non-bareword characters, so we * must treat it as a number. */ goto number; } } @@ -2085,11 +1963,10 @@ * form of an operator (eq, ne, in, ni, ...) so we treat * as number + operator. */ goto number; } - /* * Otherwise, fall through and parse the whole as a bareword. */ } } @@ -2096,22 +1973,20 @@ /* * 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 == '_') { - size_t scanned; if (Tcl_UtfCharComplete(start, numBytes)) { - scanned = TclUtfToUniChar(start, &ch); + scanned = Tcl_UtfToUniChar(start, &ch); } else { - char utfBytes[4]; - - memcpy(utfBytes, start, numBytes); + char utfBytes[TCL_UTF_MAX]; + memcpy(utfBytes, start, (size_t) numBytes); utfBytes[numBytes] = '\0'; - scanned = TclUtfToUniChar(utfBytes, &ch); + scanned = Tcl_UtfToUniChar(utfBytes, &ch); } *lexemePtr = INVALID; Tcl_DecrRefCount(literal); return scanned; } @@ -2149,31 +2024,27 @@ void TclCompileExpr( Tcl_Interp *interp, /* Used for error reporting. */ const char *script, /* The source script to compile. */ - size_t numBytes, /* Number of bytes in script. */ + int numBytes, /* Number of bytes in script. */ CompileEnv *envPtr, /* Holds resulting instructions. */ - int optimize) /* 0 for one-off expressions. */ + int optimize) /* 0 for one-off expressions */ { OpNode *opTree = NULL; /* Will point to the tree of operators */ - Tcl_Obj *litList; /* List to hold the literals */ - Tcl_Obj *funcList; /* List to hold the functon names*/ - Tcl_Parse *parsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse)); + 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; - TclNewObj(litList); - TclNewObj(funcList); - code = ParseExpr(interp, script, numBytes, &opTree, litList, + int code = ParseExpr(interp, script, numBytes, &opTree, litList, funcList, parsePtr, 0 /* parseOnly */); if (code == TCL_OK) { - /* - * Valid parse; compile the tree. - */ + /* Valid parse; compile the tree. */ int objc; Tcl_Obj *const *litObjv; Tcl_Obj **funcObjv; /* TIP #280 : Track Lines within the expression */ @@ -2190,11 +2061,11 @@ Tcl_FreeParse(parsePtr); TclStackFree(interp, parsePtr); Tcl_DecrRefCount(funcList); Tcl_DecrRefCount(litList); - Tcl_Free(opTree); + ckfree((char *) opTree); } /* *---------------------------------------------------------------------- * @@ -2221,50 +2092,51 @@ Tcl_Obj *const **litObjvPtr) { CompileEnv *envPtr; ByteCode *byteCodePtr; int code; - NRE_callback *rootPtr = TOP_CB(interp); + Tcl_Obj *byteCodeObj = Tcl_NewObj(); /* * 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)); + 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); + Tcl_IncrRefCount(byteCodeObj); + TclInitByteCodeObj(byteCodeObj, envPtr); TclFreeCompileEnv(envPtr); TclStackFree(interp, envPtr); - TclNRExecuteByteCode(interp, byteCodePtr); - code = TclNRRunCallbacks(interp, TCL_OK, rootPtr); - TclReleaseByteCode(byteCodePtr); + byteCodePtr = (ByteCode *) byteCodeObj->internalRep.twoPtrValue.ptr1; + code = TclExecuteByteCode(interp, byteCodePtr); + Tcl_DecrRefCount(byteCodeObj); return code; } /* *---------------------------------------------------------------------- * * CompileExprTree -- - * - * Compiles and writes to envPtr instructions for the subexpression tree - * at index in the nodes array. (*litObjvPtr) must point to the proper - * location in a corresponding literals list. Likewise, when non-NULL, - * funcObjv and tokenPtr must point into matching arrays of function - * names and Tcl_Token's derived from earlier call to ParseExpr(). When - * optimize is true, any constant subexpressions will be precomputed. + * Compiles and writes to envPtr instructions for the subexpression + * tree at index in the nodes array. (*litObjvPtr) must point to the + * proper location in a corresponding literals list. Likewise, when + * non-NULL, funcObjv and tokenPtr must point into matching arrays of + * function names and Tcl_Token's derived from earlier call to + * ParseExpr(). When optimize is true, any constant subexpressions + * will be precomputed. * * Results: * None. * * Side effects: * Adds instructions to envPtr to evaluate the expression at runtime. - * Consumes subtree of nodes rooted at index. Advances the pointer + * Consumes subtree of nodes rooted at index. Advances the pointer * *litObjvPtr. * *---------------------------------------------------------------------- */ @@ -2290,73 +2162,84 @@ JumpList *freePtr, *newJump; if (nodePtr->mark == MARK_LEFT) { next = nodePtr->left; - if (nodePtr->lexeme == QUESTION) { + switch (nodePtr->lexeme) { + case QUESTION: + newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; + newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; + jumpPtr->depth = envPtr->currStackDepth; convert = 1; + break; + case AND: + case OR: + newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; + newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; + newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; + jumpPtr->depth = envPtr->currStackDepth; + break; } } else if (nodePtr->mark == MARK_RIGHT) { next = nodePtr->right; switch (nodePtr->lexeme) { case FUNCTION: { Tcl_DString cmdName; const char *p; - size_t length; + int length; Tcl_DStringInit(&cmdName); - TclDStringAppendLiteral(&cmdName, "tcl::mathfunc::"); + Tcl_DStringAppend(&cmdName, "tcl::mathfunc::", -1); p = TclGetStringFromObj(*funcObjv, &length); funcObjv++; Tcl_DStringAppend(&cmdName, p, length); - TclEmitPush(TclRegisterLiteral(envPtr, + TclEmitPush(TclRegisterNewNSLiteral(envPtr, Tcl_DStringValue(&cmdName), - Tcl_DStringLength(&cmdName), LITERAL_CMD_NAME), envPtr); + Tcl_DStringLength(&cmdName)), envPtr); Tcl_DStringFree(&cmdName); /* * Start a count of the number of words in this function - * command invocation. In case there's already a count in - * progress (nested functions), save it in our unused "left" - * field for restoring later. + * command invocation. In case there's already a count + * in progress (nested functions), save it in our unused + * "left" field for restoring later. */ 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); + 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; - } + &(jumpPtr->next->jump)); + envPtr->currStackDepth = jumpPtr->depth; + jumpPtr->offset = (envPtr->codeNext - envPtr->codeStart); + jumpPtr->convert = convert; convert = 1; break; case AND: + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &(jumpPtr->jump)); + break; 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); + TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &(jumpPtr->jump)); break; } } else { - int pc1, pc2, target; - switch (nodePtr->lexeme) { case START: case QUESTION: if (convert && (nodePtr == rootPtr)) { TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); @@ -2365,76 +2248,73 @@ case OPEN_PAREN: /* do nothing */ break; case FUNCTION: + /* - * Use the numWords count we've kept to invoke the function - * command with the correct number of arguments. + * Use the numWords count we've kept to invoke the + * function command with the correct number of arguments. */ if (numWords < 255) { - TclEmitInvoke(envPtr, INST_INVOKE_STK1, numWords); + TclEmitInstInt1(INST_INVOKE_STK1, numWords, envPtr); } else { - TclEmitInvoke(envPtr, INST_INVOKE_STK4, numWords); + TclEmitInstInt4(INST_INVOKE_STK4, numWords, envPtr); } - /* - * Restore any saved numWords value. - */ - + /* Restore any saved numWords value. */ numWords = nodePtr->left; convert = 1; break; case COMMA: - /* - * Each comma implies another function argument. - */ + /* Each comma implies another function argument. */ numWords++; break; case COLON: - CLANG_ASSERT(jumpPtr); - if (jumpPtr->jump.jumpType == TCL_TRUE_JUMP) { - jumpPtr->jump.jumpType = TCL_UNCONDITIONAL_JUMP; - convert = 1; - } - target = jumpPtr->jump.codeOffset + 2; - if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { - target += 3; - } + if (TclFixupForwardJump(envPtr, &(jumpPtr->next->jump), + (envPtr->codeNext - envPtr->codeStart) + - jumpPtr->next->jump.codeOffset, 127)) { + jumpPtr->offset += 3; + } + TclFixupForwardJump(envPtr, &(jumpPtr->jump), + jumpPtr->offset - jumpPtr->jump.codeOffset, 127); + convert |= jumpPtr->convert; + envPtr->currStackDepth = jumpPtr->depth + 1; freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); - TclFixupForwardJump(envPtr, &jumpPtr->jump, - target - jumpPtr->jump.codeOffset, 127); - freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); break; case AND: case OR: - CLANG_ASSERT(jumpPtr); - pc1 = CurrentOffset(envPtr); - TclEmitInstInt1((nodePtr->lexeme == AND) ? INST_JUMP_FALSE1 - : INST_JUMP_TRUE1, 0, envPtr); - TclEmitPush(TclRegisterLiteral(envPtr, - (nodePtr->lexeme == AND) ? "1" : "0", 1, 0), envPtr); - pc2 = CurrentOffset(envPtr); - TclEmitInstInt1(INST_JUMP1, 0, envPtr); - TclAdjustStackDepth(-1, envPtr); - TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc1, - envPtr->codeStart + pc1 + 1); - if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { - pc2 += 3; - } - TclEmitPush(TclRegisterLiteral(envPtr, - (nodePtr->lexeme == AND) ? "0" : "1", 1, 0), envPtr); - TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc2, - envPtr->codeStart + pc2 + 1); - convert = 0; + TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND) + ? TCL_FALSE_JUMP : TCL_TRUE_JUMP, + &(jumpPtr->next->jump)); + TclEmitPush(TclRegisterNewLiteral(envPtr, + (nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, + &(jumpPtr->next->next->jump)); + TclFixupForwardJumpToHere(envPtr, &(jumpPtr->next->jump), 127); + if (TclFixupForwardJumpToHere(envPtr, &(jumpPtr->jump), 127)) { + jumpPtr->next->next->jump.codeOffset += 3; + } + TclEmitPush(TclRegisterNewLiteral(envPtr, + (nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr); + TclFixupForwardJumpToHere(envPtr, &(jumpPtr->next->next->jump), + 127); + convert = 0; + envPtr->currStackDepth = jumpPtr->depth + 1; + freePtr = jumpPtr; + jumpPtr = jumpPtr->next; + TclStackFree(interp, freePtr); + freePtr = jumpPtr; + jumpPtr = jumpPtr->next; + TclStackFree(interp, freePtr); freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); break; default: @@ -2441,12 +2321,12 @@ TclEmitOpcode(instruction[nodePtr->lexeme], envPtr); convert = 0; break; } if (nodePtr == rootPtr) { - /* We're done */ + /* We're done */ return; } nodePtr = nodes + nodePtr->p.parent; continue; } @@ -2459,15 +2339,18 @@ case OT_LITERAL: { Tcl_Obj *const *litObjv = *litObjvPtr; Tcl_Obj *literal = *litObjv; if (optimize) { - size_t length; + int length, index; const char *bytes = TclGetStringFromObj(literal, &length); - int idx = TclRegisterLiteral(envPtr, bytes, length, 0); - Tcl_Obj *objPtr = TclFetchLiteral(envPtr, idx); + LiteralEntry *lePtr; + Tcl_Obj *objPtr; + index = TclRegisterNewLiteral(envPtr, bytes, length); + lePtr = envPtr->literalArrayPtr + index; + objPtr = lePtr->objPtr; if ((objPtr->typePtr == NULL) && (literal->typePtr != NULL)) { /* * Would like to do this: * * lePtr->objPtr = literal; @@ -2474,74 +2357,45 @@ * Tcl_IncrRefCount(literal); * Tcl_DecrRefCount(objPtr); * * However, the design of the "global" and "local" * LiteralTable does not permit the value of lePtr->objPtr - * to change. So rather than replace lePtr->objPtr, we do - * surgery to transfer our desired intrep into it. + * to change. So rather than replace lePtr->objPtr, we + * do surgery to transfer our desired intrep into it. + * */ - objPtr->typePtr = literal->typePtr; objPtr->internalRep = literal->internalRep; literal->typePtr = NULL; } - TclEmitPush(idx, envPtr); + TclEmitPush(index, envPtr); } else { /* - * When optimize==0, we know the expression is a one-off and - * there's nothing to be gained from sharing literals when - * they won't live long, and the copies we have already have - * an appropriate intrep. In this case, skip literal + * When optimize==0, we know the expression is a one-off + * and there's nothing to be gained from sharing literals + * when they won't live long, and the copies we have already + * have an appropriate intrep. In this case, skip literal * registration that would enable sharing, and use the routine * that preserves intreps. */ - TclEmitPush(TclAddLiteralObj(envPtr, literal, NULL), envPtr); } (*litObjvPtr)++; break; } case OT_TOKENS: - CompileTokens(envPtr, tokenPtr, interp); + TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, + envPtr); tokenPtr += tokenPtr->numComponents + 1; break; default: if (optimize && nodes[next].constant) { Tcl_InterpState save = Tcl_SaveInterpState(interp, TCL_OK); - if (ExecConstantExprTree(interp, nodes, next, litObjvPtr) == TCL_OK) { - int idx; - Tcl_Obj *objPtr = Tcl_GetObjResult(interp); - - /* - * Don't generate a string rep, but if we have one - * already, then use it to share via the literal table. - */ - - if (TclHasStringRep(objPtr)) { - Tcl_Obj *tableValue; - size_t numBytes; - const char *bytes - = TclGetStringFromObj(objPtr, &numBytes); - - idx = TclRegisterLiteral(envPtr, bytes, numBytes, 0); - tableValue = TclFetchLiteral(envPtr, idx); - if ((tableValue->typePtr == NULL) && - (objPtr->typePtr != NULL)) { - /* - * Same intrep surgery as for OT_LITERAL. - */ - - tableValue->typePtr = objPtr->typePtr; - tableValue->internalRep = objPtr->internalRep; - objPtr->typePtr = NULL; - } - } else { - idx = TclAddLiteralObj(envPtr, objPtr, NULL); - } - TclEmitPush(idx, envPtr); + TclEmitPush(TclAddLiteralObj(envPtr, + Tcl_GetObjResult(interp), NULL), envPtr); } else { TclCompileSyntaxError(interp, envPtr); } Tcl_RestoreInterpState(interp, save); convert = 0; @@ -2554,21 +2408,20 @@ /* *---------------------------------------------------------------------- * * TclSingleOpCmd -- - * * Implements the commands: ~, !, <<, >>, %, !=, ne, in, ni * in the ::tcl::mathop namespace. These commands have no * extension to arbitrary arguments; they accept only exactly one * or exactly two arguments as suitable for the operator. * * Results: * A standard Tcl return code and result left in interp. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ int @@ -2581,11 +2434,11 @@ TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData; unsigned char lexeme; OpNode nodes[2]; Tcl_Obj *const *litObjv = objv + 1; - if (objc != 1 + occdPtr->i.numArgs) { + if (objc != 1+occdPtr->i.numArgs) { Tcl_WrongNumArgs(interp, 1, objv, occdPtr->expected); return TCL_ERROR; } ParseLexeme(occdPtr->op, strlen(occdPtr->op), &lexeme, NULL); @@ -2607,21 +2460,20 @@ /* *---------------------------------------------------------------------- * * TclSortingOpCmd -- - * Implements the commands: - * <, <=, >, >=, ==, eq, lt, le, gt, ge - * in the ::tcl::mathop namespace. These commands are defined for + * Implements the commands: <, <=, >, >=, ==, eq + * in the ::tcl::mathop namespace. These commands are defined for * arbitrary number of arguments by computing the AND of the base - * operator applied to all neighbor argument pairs. + * operator applied to all neighbor argument pairs. * * Results: * A standard Tcl return code and result left in interp. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ int @@ -2635,13 +2487,14 @@ 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)); + 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); @@ -2688,20 +2541,20 @@ /* *---------------------------------------------------------------------- * * TclVariadicOpCmd -- * Implements the commands: +, *, &, |, ^, ** - * in the ::tcl::mathop namespace. These commands are defined for + * in the ::tcl::mathop namespace. These commands are defined for * arbitrary number of arguments by repeatedly applying the base - * operator with suitable associative rules. When fewer than two + * operator with suitable associative rules. When fewer than two * arguments are provided, suitable identity values are returned. * * Results: * A standard Tcl return code and result left in interp. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ int @@ -2714,11 +2567,11 @@ TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData; unsigned char lexeme; int code; if (objc < 2) { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(occdPtr->i.identity)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(occdPtr->i.identity)); return TCL_OK; } ParseLexeme(occdPtr->op, strlen(occdPtr->op), &lexeme, NULL); lexeme |= BINARY; @@ -2728,11 +2581,11 @@ OpNode nodes[2]; int decrMe = 0; Tcl_Obj *const *litObjPtrPtr = litObjv; if (lexeme == EXPON) { - TclNewIntObj(litObjv[1], occdPtr->i.identity); + litObjv[1] = Tcl_NewIntObj(occdPtr->i.identity); Tcl_IncrRefCount(litObjv[1]); decrMe = 1; litObjv[0] = objv[1]; nodes[0].lexeme = START; nodes[0].mark = MARK_RIGHT; @@ -2744,11 +2597,11 @@ nodes[1].p.parent = 0; } else { if (lexeme == DIVIDE) { litObjv[0] = Tcl_NewDoubleObj(1.0); } else { - TclNewIntObj(litObjv[0], occdPtr->i.identity); + litObjv[0] = Tcl_NewIntObj(occdPtr->i.identity); } Tcl_IncrRefCount(litObjv[0]); litObjv[1] = objv[1]; nodes[0].lexeme = START; nodes[0].mark = MARK_RIGHT; @@ -2764,17 +2617,18 @@ Tcl_DecrRefCount(litObjv[decrMe]); return code; } else { Tcl_Obj *const *litObjv = objv + 1; - OpNode *nodes = (OpNode *)TclStackAlloc(interp, (objc-1) * sizeof(OpNode)); + 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--) { + for (i=objc-2; i>0; i-- ) { nodes[i].lexeme = lexeme; nodes[i].mark = MARK_LEFT; nodes[i].left = OT_LITERAL; nodes[i].right = lastOp; if (lastOp >= 0) { @@ -2781,11 +2635,11 @@ nodes[lastOp].p.parent = i; } lastOp = i; } } else { - for (i=1; i= 0) { nodes[lastOp].p.parent = i; @@ -2798,29 +2652,30 @@ nodes[lastOp].p.parent = 0; code = ExecConstantExprTree(interp, nodes, 0, &litObjv); TclStackFree(interp, nodes); + return code; } } /* *---------------------------------------------------------------------- * * TclNoIdentOpCmd -- * Implements the commands: -, / - * in the ::tcl::mathop namespace. These commands are defined for - * arbitrary non-zero number of arguments by repeatedly applying the base - * operator with suitable associative rules. When no arguments are - * provided, an error is raised. + * in the ::tcl::mathop namespace. These commands are defined for + * arbitrary non-zero number of arguments by repeatedly applying + * the base operator with suitable associative rules. When no + * arguments are provided, an error is raised. * * Results: * A standard Tcl return code and result left in interp. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ int @@ -2829,11 +2684,10 @@ 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); Index: generic/tclCompile.c ================================================================== --- generic/tclCompile.c +++ generic/tclCompile.c @@ -12,11 +12,19 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclCompile.h" -#include + +/* + * Table of all AuxData types. + */ + +static Tcl_HashTable auxDataTypeTable; +static int auxDataTypeTableInitialized; /* 0 means not yet initialized. */ + +TCL_DECLARE_MUTEX(tableMutex) /* * Variable that controls whether compilation tracing is enabled and, if so, * what level of tracing is desired: * 0: no compilation tracing @@ -27,11 +35,11 @@ #ifdef TCL_COMPILE_DEBUG int tclTraceCompile = 0; static int traceInitialized = 0; #endif - + /* * A table describing the Tcl bytecode instructions. Entries in this table * must correspond to the instruction opcode definitions in tclCompile.h. The * names "op1" and "op4" refer to an instruction's one or four byte first * operand. Similarly, "stktop" and "stknext" refer to the topmost and next to @@ -40,23 +48,23 @@ * Note that the load, store, and incr instructions do not distinguish local * from global variables; the bytecode interpreter at runtime uses the * existence of a procedure call frame to distinguish these. */ -InstructionDesc const tclInstructionTable[] = { +InstructionDesc tclInstructionTable[] = { /* Name Bytes stackEffect #Opnds Operand types */ {"done", 1, -1, 0, {OPERAND_NONE}}, /* Finish ByteCode execution and return stktop (top stack item) */ - {"push1", 2, +1, 1, {OPERAND_LIT1}}, + {"push1", 2, +1, 1, {OPERAND_UINT1}}, /* Push object at ByteCode objArray[op1] */ - {"push4", 5, +1, 1, {OPERAND_LIT4}}, + {"push4", 5, +1, 1, {OPERAND_UINT4}}, /* Push object at ByteCode objArray[op4] */ {"pop", 1, -1, 0, {OPERAND_NONE}}, /* Pop the topmost stack object */ {"dup", 1, +1, 0, {OPERAND_NONE}}, /* Duplicate the topmost stack object and push the result */ - {"strcat", 2, INT_MIN, 1, {OPERAND_UINT1}}, + {"concat1", 2, INT_MIN, 1, {OPERAND_UINT1}}, /* Concatenate the top op1 items and push result */ {"invokeStk1", 2, INT_MIN, 1, {OPERAND_UINT1}}, /* Invoke command named objv[0]; = */ {"invokeStk4", 5, INT_MIN, 1, {OPERAND_UINT4}}, /* Invoke command named objv[0]; = */ @@ -114,23 +122,27 @@ {"incrArrayStkImm", 2, -1, 1, {OPERAND_INT1}}, /* Incr array element; elem is top then array name, amount is op1 */ {"incrStkImm", 2, 0, 1, {OPERAND_INT1}}, /* Incr general variable; unparsed name is top, amount is op1 */ - {"jump1", 2, 0, 1, {OPERAND_OFFSET1}}, + {"jump1", 2, 0, 1, {OPERAND_INT1}}, /* Jump relative to (pc + op1) */ - {"jump4", 5, 0, 1, {OPERAND_OFFSET4}}, + {"jump4", 5, 0, 1, {OPERAND_INT4}}, /* Jump relative to (pc + op4) */ - {"jumpTrue1", 2, -1, 1, {OPERAND_OFFSET1}}, + {"jumpTrue1", 2, -1, 1, {OPERAND_INT1}}, /* Jump relative to (pc + op1) if stktop expr object is true */ - {"jumpTrue4", 5, -1, 1, {OPERAND_OFFSET4}}, + {"jumpTrue4", 5, -1, 1, {OPERAND_INT4}}, /* Jump relative to (pc + op4) if stktop expr object is true */ - {"jumpFalse1", 2, -1, 1, {OPERAND_OFFSET1}}, + {"jumpFalse1", 2, -1, 1, {OPERAND_INT1}}, /* Jump relative to (pc + op1) if stktop expr object is false */ - {"jumpFalse4", 5, -1, 1, {OPERAND_OFFSET4}}, + {"jumpFalse4", 5, -1, 1, {OPERAND_INT4}}, /* 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}}, @@ -140,15 +152,15 @@ {"neq", 1, -1, 0, {OPERAND_NONE}}, /* Not equal: push (stknext != stktop) */ {"lt", 1, -1, 0, {OPERAND_NONE}}, /* Less: push (stknext < stktop) */ {"gt", 1, -1, 0, {OPERAND_NONE}}, - /* Greater: push (stknext > stktop) */ + /* Greater: push (stknext || stktop) */ {"le", 1, -1, 0, {OPERAND_NONE}}, - /* Less or equal: push (stknext <= stktop) */ + /* Less or equal: push (stknext || stktop) */ {"ge", 1, -1, 0, {OPERAND_NONE}}, - /* Greater or equal: push (stknext >= stktop) */ + /* Greater or equal: push (stknext || stktop) */ {"lshift", 1, -1, 0, {OPERAND_NONE}}, /* Left shift: push (stknext << stktop) */ {"rshift", 1, -1, 0, {OPERAND_NONE}}, /* Right shift: push (stknext >> stktop) */ {"add", 1, -1, 0, {OPERAND_NONE}}, @@ -167,18 +179,29 @@ /* 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]; = */ {"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}}, @@ -272,11 +295,11 @@ {"listIndexImm", 5, 0, 1, {OPERAND_IDX4}}, /* List Index: push (lindex stktop op4) */ {"listRangeImm", 9, 0, 2, {OPERAND_IDX4, OPERAND_IDX4}}, /* List Range: push (lrange stktop op4 op4) */ - {"startCommand", 9, 0, 2, {OPERAND_OFFSET4, OPERAND_UINT4}}, + {"startCommand", 9, 0, 2, {OPERAND_INT4,OPERAND_UINT4}}, /* Start of bytecoded command: op is the length of the cmd's code, op2 * is number of commands here */ {"listIn", 1, -1, 0, {OPERAND_NONE}}, /* List containment: push [lsearch stktop stknext]>=0) */ @@ -284,11 +307,11 @@ /* List negated containment: push [lsearch stktop stknext]<0) */ {"pushReturnOpts", 1, +1, 0, {OPERAND_NONE}}, /* Push the interpreter's return option dictionary as an object on the * stack. */ - {"returnStk", 1, -1, 0, {OPERAND_NONE}}, + {"returnStk", 1, -2, 0, {OPERAND_NONE}}, /* Compiled [return]; options and result are on the stack, code and * level are in the options. */ {"dictGet", 5, INT_MIN, 1, {OPERAND_UINT4}}, /* The top op4 words (min 1) are a key path into the dictionary just @@ -316,50 +339,50 @@ /* Update a dictionary value such that the value pointed to by key has * some value list-appended onto it. op4 = LVTindex * Stack: ... key valueToAppend => ... newDict */ {"dictFirst", 5, +2, 1, {OPERAND_LVT4}}, /* Begin iterating over the dictionary, using the local scalar - * 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. + * indicated by op4 to hold the iterator state. If doneBool is true, + * dictDone *must* be called later on. * 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. */ {"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 */ + * of keys (popped from the stack) must be the same length as the list + * of variables. + * Stack: ... keyList => ... */ {"dictUpdateEnd", 9, -1, 2, {OPERAND_LVT4, OPERAND_AUX4}}, /* Reflect the state of local variables (described in the aux data * referred to by the second immediate argument) back to the state of * the dictionary in the variable referred to by the first immediate * argument. The list of keys (popped from the stack) must be the same * length as the list of variables. * Stack: ... keyList => ... */ - {"jumpTable", 5, -1, 1, {OPERAND_AUX4}}, + {"jumpTable", 5, -1, 1, {OPERAND_AUX4}}, /* Jump according to the jump-table (in AuxData as indicated by the * operand) and the argument popped from the list. Always executes the * next instruction if no match against the table's entries was found. * Stack: ... value => ... * Note that the jump table contains offsets relative to the PC when * it points to this instruction; the code is relocatable. */ - {"upvar", 5, -1, 1, {OPERAND_LVT4}}, - /* finds level and otherName in stack, links to local variable at - * index op1. Leaves the level on stack. */ - {"nsupvar", 5, -1, 1, {OPERAND_LVT4}}, - /* finds namespace and otherName in stack, links to local variable at - * index op1. Leaves the namespace on stack. */ - {"variable", 5, -1, 1, {OPERAND_LVT4}}, - /* finds namespace and otherName in stack, links to local variable at - * index op1. Leaves the namespace on stack. */ - {"syntax", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}}, - /* Compiled bytecodes to signal syntax error. Equivalent to returnImm - * except for the ERR_ALREADY_LOGGED flag in the interpreter. */ + {"upvar", 5, 0, 1, {OPERAND_LVT4}}, + /* finds level and otherName in stack, links to local variable at + * index op1. Leaves the level on stack. */ + {"nsupvar", 5, 0, 1, {OPERAND_LVT4}}, + /* finds namespace and otherName in stack, links to local variable at + * index op1. Leaves the namespace on stack. */ + {"variable", 5, 0, 1, {OPERAND_LVT4}}, + /* finds namespace and otherName in stack, links to local variable at + * index op1. Leaves the namespace on stack. */ + {"syntax", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}}, + /* Compiled bytecodes to signal syntax error. */ {"reverse", 5, 0, 1, {OPERAND_UINT4}}, /* Reverse the order of the arg elements at the top of stack */ {"regexp", 2, -1, 1, {OPERAND_INT1}}, /* Regexp: push (regexp stknext stktop) opnd == nocase */ @@ -372,367 +395,59 @@ {"existArrayStk", 1, -1, 0, {OPERAND_NONE}}, /* Test if array element exists; element is stktop, array name is * stknext */ {"existStk", 1, 0, 0, {OPERAND_NONE}}, /* Test if general variable exists; unparsed variable name is stktop*/ - - {"nop", 1, 0, 0, {OPERAND_NONE}}, - /* Do nothing */ - {"returnCodeBranch", 1, -1, 0, {OPERAND_NONE}}, - /* Jump to next instruction based on the return code on top of stack - * ERROR: +1; RETURN: +3; BREAK: +5; CONTINUE: +7; - * Other non-OK: +9 - */ - - {"unsetScalar", 6, 0, 2, {OPERAND_UINT1, OPERAND_LVT4}}, - /* Make scalar variable at index op2 in call frame cease to exist; - * op1 is 1 for errors on problems, 0 otherwise */ - {"unsetArray", 6, -1, 2, {OPERAND_UINT1, OPERAND_LVT4}}, - /* Make array element cease to exist; array at slot op2, element is - * stktop; op1 is 1 for errors on problems, 0 otherwise */ - {"unsetArrayStk", 2, -2, 1, {OPERAND_UINT1}}, - /* Make array element cease to exist; element is stktop, array name is - * stknext; op1 is 1 for errors on problems, 0 otherwise */ - {"unsetStk", 2, -1, 1, {OPERAND_UINT1}}, - /* Make general variable cease to exist; unparsed variable name is - * stktop; op1 is 1 for errors on problems, 0 otherwise */ - - {"dictExpand", 1, -1, 0, {OPERAND_NONE}}, - /* Probe into a dict and extract it (or a subdict of it) into - * variables with matched names. Produces list of keys bound as - * result. Part of [dict with]. - * Stack: ... dict path => ... keyList */ - {"dictRecombineStk", 1, -3, 0, {OPERAND_NONE}}, - /* Map variable contents back into a dictionary in a variable. Part of - * [dict with]. - * Stack: ... dictVarName path keyList => ... */ - {"dictRecombineImm", 5, -2, 1, {OPERAND_LVT4}}, - /* Map variable contents back into a dictionary in the local variable - * indicated by the LVT index. Part of [dict with]. - * Stack: ... path keyList => ... */ - {"dictExists", 5, INT_MIN, 1, {OPERAND_UINT4}}, - /* The top op4 words (min 1) are a key path into the dictionary just - * below the keys on the stack, and all those values are replaced by a - * boolean indicating whether it is possible to read out a value from - * that key-path (like [dict exists]). - * Stack: ... dict key1 ... keyN => ... boolean */ - {"verifyDict", 1, -1, 0, {OPERAND_NONE}}, - /* Verifies that the word on the top of the stack is a dictionary, - * popping it if it is and throwing an error if it is not. - * Stack: ... value => ... */ - - {"strmap", 1, -2, 0, {OPERAND_NONE}}, - /* Simplified version of [string map] that only applies one change - * string, and only case-sensitively. - * Stack: ... from to string => ... changedString */ - {"strfind", 1, -1, 0, {OPERAND_NONE}}, - /* Find the first index of a needle string in a haystack string, - * producing the index (integer) or -1 if nothing found. - * Stack: ... needle haystack => ... index */ - {"strrfind", 1, -1, 0, {OPERAND_NONE}}, - /* Find the last index of a needle string in a haystack string, - * producing the index (integer) or -1 if nothing found. - * Stack: ... needle haystack => ... index */ - {"strrangeImm", 9, 0, 2, {OPERAND_IDX4, OPERAND_IDX4}}, - /* String Range: push (string range stktop op4 op4) */ - {"strrange", 1, -2, 0, {OPERAND_NONE}}, - /* String Range with non-constant arguments. - * Stack: ... string idxA idxB => ... substring */ - - {"yield", 1, 0, 0, {OPERAND_NONE}}, - /* Makes the current coroutine yield the value at the top of the - * stack, and places the response back on top of the stack when it - * resumes. - * Stack: ... valueToYield => ... resumeValue */ - {"coroName", 1, +1, 0, {OPERAND_NONE}}, - /* Push the name of the interpreter's current coroutine as an object - * on the stack. */ - {"tailcall", 2, INT_MIN, 1, {OPERAND_UINT1}}, - /* Do a tailcall with the opnd items on the stack as the thing to - * tailcall to; opnd must be greater than 0 for the semantics to work - * right. */ - - {"currentNamespace", 1, +1, 0, {OPERAND_NONE}}, - /* Push the name of the interpreter's current namespace as an object - * on the stack. */ - {"infoLevelNumber", 1, +1, 0, {OPERAND_NONE}}, - /* Push the stack depth (i.e., [info level]) of the interpreter as an - * object on the stack. */ - {"infoLevelArgs", 1, 0, 0, {OPERAND_NONE}}, - /* Push the argument words to a stack depth (i.e., [info level ]) - * of the interpreter as an object on the stack. - * Stack: ... depth => ... argList */ - {"resolveCmd", 1, 0, 0, {OPERAND_NONE}}, - /* Resolves the command named on the top of the stack to its fully - * qualified version, or produces the empty string if no such command - * exists. Never generates errors. - * Stack: ... cmdName => ... fullCmdName */ - - {"tclooSelf", 1, +1, 0, {OPERAND_NONE}}, - /* Push the identity of the current TclOO object (i.e., the name of - * its current public access command) on the stack. */ - {"tclooClass", 1, 0, 0, {OPERAND_NONE}}, - /* Push the class of the TclOO object named at the top of the stack - * onto the stack. - * Stack: ... object => ... class */ - {"tclooNamespace", 1, 0, 0, {OPERAND_NONE}}, - /* Push the namespace of the TclOO object named at the top of the - * stack onto the stack. - * Stack: ... object => ... namespace */ - {"tclooIsObject", 1, 0, 0, {OPERAND_NONE}}, - /* Push whether the value named at the top of the stack is a TclOO - * object (i.e., a boolean). Can corrupt the interpreter result - * despite not throwing, so not safe for use in a post-exception - * context. - * Stack: ... value => ... boolean */ - - {"arrayExistsStk", 1, 0, 0, {OPERAND_NONE}}, - /* Looks up the element on the top of the stack and tests whether it - * is an array. Pushes a boolean describing whether this is the - * case. Also runs the whole-array trace on the named variable, so can - * throw anything. - * Stack: ... varName => ... boolean */ - {"arrayExistsImm", 5, +1, 1, {OPERAND_LVT4}}, - /* Looks up the variable indexed by opnd and tests whether it is an - * array. Pushes a boolean describing whether this is the case. Also - * runs the whole-array trace on the named variable, so can throw - * anything. - * Stack: ... => ... boolean */ - {"arrayMakeStk", 1, -1, 0, {OPERAND_NONE}}, - /* Forces the element on the top of the stack to be the name of an - * array. - * Stack: ... varName => ... */ - {"arrayMakeImm", 5, 0, 1, {OPERAND_LVT4}}, - /* Forces the variable indexed by opnd to be an array. Does not touch - * the stack. */ - - {"invokeReplace", 6, INT_MIN, 2, {OPERAND_UINT4,OPERAND_UINT1}}, - /* Invoke command named objv[0], replacing the first two words with - * the word at the top of the stack; - * = */ - - {"listConcat", 1, -1, 0, {OPERAND_NONE}}, - /* Concatenates the two lists at the top of the stack into a single - * list and pushes that resulting list onto the stack. - * Stack: ... list1 list2 => ... [lconcat list1 list2] */ - - {"expandDrop", 1, 0, 0, {OPERAND_NONE}}, - /* Drops an element from the auxiliary stack, popping stack elements - * until the matching stack depth is reached. */ - - /* New foreach implementation */ - {"foreach_start", 5, +2, 1, {OPERAND_AUX4}}, - /* Initialize execution of a foreach loop. Operand is aux data index - * of the ForeachInfo structure for the foreach command. It pushes 2 - * elements which hold runtime params for foreach_step, they are later - * dropped by foreach_end together with the value lists. NOTE that the - * iterator-tracker and info reference must not be passed to bytecodes - * that handle normal Tcl values. NOTE that this instruction jumps to - * the foreach_step instruction paired with it; the stack info below - * is only nominal. - * Stack: ... listObjs... => ... listObjs... iterTracker info */ - {"foreach_step", 1, 0, 0, {OPERAND_NONE}}, - /* "Step" or begin next iteration of foreach loop. Assigns to foreach - * iteration variables. May jump to straight after the foreach_start - * that pushed the iterTracker and info values. MUST be followed - * immediately by a foreach_end. - * Stack: ... listObjs... iterTracker info => - * ... listObjs... iterTracker info */ - {"foreach_end", 1, 0, 0, {OPERAND_NONE}}, - /* Clean up a foreach loop by dropping the info value, the tracker - * value and the lists that were being iterated over. - * Stack: ... listObjs... iterTracker info => ... */ - {"lmap_collect", 1, -1, 0, {OPERAND_NONE}}, - /* Appends the value at the top of the stack to the list located on - * the stack the "other side" of the foreach-related values. - * Stack: ... collector listObjs... iterTracker info value => - * ... collector listObjs... iterTracker info */ - - {"strtrim", 1, -1, 0, {OPERAND_NONE}}, - /* [string trim] core: removes the characters (designated by the value - * at the top of the stack) from both ends of the string and pushes - * the resulting string. - * Stack: ... string charset => ... trimmedString */ - {"strtrimLeft", 1, -1, 0, {OPERAND_NONE}}, - /* [string trimleft] core: removes the characters (designated by the - * value at the top of the stack) from the left of the string and - * pushes the resulting string. - * Stack: ... string charset => ... trimmedString */ - {"strtrimRight", 1, -1, 0, {OPERAND_NONE}}, - /* [string trimright] core: removes the characters (designated by the - * value at the top of the stack) from the right of the string and - * pushes the resulting string. - * Stack: ... string charset => ... trimmedString */ - - {"concatStk", 5, INT_MIN, 1, {OPERAND_UINT4}}, - /* Wrapper round Tcl_ConcatObj(), used for [concat] and [eval]. opnd - * is number of values to concatenate. - * Operation: push concat(stk1 stk2 ... stktop) */ - - {"strcaseUpper", 1, 0, 0, {OPERAND_NONE}}, - /* [string toupper] core: converts whole string to upper case using - * the default (extended "C" locale) rules. - * Stack: ... string => ... newString */ - {"strcaseLower", 1, 0, 0, {OPERAND_NONE}}, - /* [string tolower] core: converts whole string to upper case using - * the default (extended "C" locale) rules. - * Stack: ... string => ... newString */ - {"strcaseTitle", 1, 0, 0, {OPERAND_NONE}}, - /* [string totitle] core: converts whole string to upper case using - * the default (extended "C" locale) rules. - * Stack: ... string => ... newString */ - {"strreplace", 1, -3, 0, {OPERAND_NONE}}, - /* [string replace] core: replaces a non-empty range of one string - * with the contents of another. - * Stack: ... string fromIdx toIdx replacement => ... newString */ - - {"originCmd", 1, 0, 0, {OPERAND_NONE}}, - /* Reports which command was the origin (via namespace import chain) - * of the command named on the top of the stack. - * Stack: ... cmdName => ... fullOriginalCmdName */ - - {"tclooNext", 2, INT_MIN, 1, {OPERAND_UINT1}}, - /* Call the next item on the TclOO call chain, passing opnd arguments - * (min 1, max 255, *includes* "next"). The result of the invoked - * method implementation will be pushed on the stack in place of the - * arguments (similar to invokeStk). - * Stack: ... "next" arg2 arg3 -- argN => ... result */ - {"tclooNextClass", 2, INT_MIN, 1, {OPERAND_UINT1}}, - /* Call the following item on the TclOO call chain defined by class - * className, passing opnd arguments (min 2, max 255, *includes* - * "nextto" and the class name). The result of the invoked method - * implementation will be pushed on the stack in place of the - * arguments (similar to invokeStk). - * Stack: ... "nextto" className arg3 arg4 -- argN => ... result */ - - {"yieldToInvoke", 1, 0, 0, {OPERAND_NONE}}, - /* Makes the current coroutine yield the value at the top of the - * stack, invoking the given command/args with resolution in the given - * namespace (all packed into a list), and places the list of values - * that are the response back on top of the stack when it resumes. - * Stack: ... [list ns cmd arg1 ... argN] => ... resumeList */ - - {"numericType", 1, 0, 0, {OPERAND_NONE}}, - /* Pushes the numeric type code of the word at the top of the stack. - * Stack: ... value => ... typeCode */ - {"tryCvtToBoolean", 1, +1, 0, {OPERAND_NONE}}, - /* Try converting stktop to boolean if possible. No errors. - * Stack: ... value => ... value isStrictBool */ - {"strclass", 2, 0, 1, {OPERAND_SCLS1}}, - /* See if all the characters of the given string are a member of the - * specified (by opnd) character class. Note that an empty string will - * satisfy the class check (standard definition of "all"). - * Stack: ... stringValue => ... boolean */ - - {"lappendList", 5, 0, 1, {OPERAND_LVT4}}, - /* Lappend list to scalar variable at op4 in frame. - * Stack: ... list => ... listVarContents */ - {"lappendListArray", 5, -1, 1, {OPERAND_LVT4}}, - /* Lappend list to array element; array at op4. - * Stack: ... elem list => ... listVarContents */ - {"lappendListArrayStk", 1, -2, 0, {OPERAND_NONE}}, - /* Lappend list to array element. - * Stack: ... arrayName elem list => ... listVarContents */ - {"lappendListStk", 1, -1, 0, {OPERAND_NONE}}, - /* Lappend list to general variable. - * Stack: ... varName list => ... listVarContents */ - - {"clockRead", 2, +1, 1, {OPERAND_UINT1}}, - /* Read clock out to the stack. Operand is which clock to read - * 0=clicks, 1=microseconds, 2=milliseconds, 3=seconds. - * Stack: ... => ... time */ - - {"dictGetDef", 5, INT_MIN, 1, {OPERAND_UINT4}}, - /* The top word is the default, the next op4 words (min 1) are a key - * path into the dictionary just below the keys on the stack, and all - * those values are replaced by the value read out of that key-path - * (like [dict get]) except if there is no such key, when instead the - * default is pushed instead. - * Stack: ... dict key1 ... keyN default => ... value */ - - {"strlt", 1, -1, 0, {OPERAND_NONE}}, - /* String Less: push (stknext < stktop) */ - {"strgt", 1, -1, 0, {OPERAND_NONE}}, - /* String Greater: push (stknext > stktop) */ - {"strle", 1, -1, 0, {OPERAND_NONE}}, - /* String Less or equal: push (stknext <= stktop) */ - {"strge", 1, -1, 0, {OPERAND_NONE}}, - /* String Greater or equal: push (stknext >= stktop) */ - - {NULL, 0, 0, 0, {OPERAND_NONE}} + {0, 0, 0, 0, {0}} }; - + /* * Prototypes for procedures defined later in this file: */ -static void CleanupByteCode(ByteCode *codePtr); -static ByteCode * CompileSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - int flags); static void DupByteCodeInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static unsigned char * EncodeCmdLocMap(CompileEnv *envPtr, ByteCode *codePtr, unsigned char *startPtr); 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 void RegisterAuxDataType(AuxDataType *typePtr); static int SetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); -static void StartExpanding(CompileEnv *envPtr); - +static int FormatInstruction(ByteCode *codePtr, + unsigned char *pc, Tcl_Obj *bufferObj); +static void PrintSourceToObj(Tcl_Obj *appendObj, + const char *stringPtr, int maxChars); /* * TIP #280: Helper for building the per-word line information of all compiled * commands. */ static void EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset, - Tcl_Token *tokenPtr, const char *cmd, - int numWords, int line, int *clNext, int **lines, - CompileEnv *envPtr); + Tcl_Token *tokenPtr, const char *cmd, int len, + int numWords, int line, int* clNext, int **lines, + CompileEnv* envPtr); static void ReleaseCmdWordData(ExtCmdLoc *eclPtr); /* * The structure below defines the bytecode Tcl object type by means of * procedures that can be invoked by generic object code. */ -const Tcl_ObjType tclByteCodeType = { +Tcl_ObjType tclByteCodeType = { "bytecode", /* name */ FreeByteCodeInternalRep, /* freeIntRepProc */ DupByteCodeInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ SetByteCodeFromAny /* setFromAnyProc */ }; - -/* - * The structure below defines a bytecode Tcl object type to hold the - * compiled bytecode for the [subst]itution of Tcl values. - */ - -static const Tcl_ObjType substCodeType = { - "substcode", /* name */ - FreeSubstCodeInternalRep, /* freeIntRepProc */ - DupByteCodeInternalRep, /* dupIntRepProc - shared with bytecode */ - NULL, /* updateStringProc */ - NULL, /* setFromAnyProc */ -}; -#define SubstFlags(objPtr) (objPtr)->internalRep.twoPtrValue.ptr2 - -/* - * Helper macros. - */ - -#define TclIncrUInt4AtPtr(ptr, delta) \ - TclStoreInt4AtPtr(TclGetUInt4AtPtr(ptr)+(delta), (ptr)) /* *---------------------------------------------------------------------- * * TclSetByteCodeFromAny -- @@ -767,20 +482,18 @@ ClientData clientData) /* Hook procedure private data. */ { Interp *iPtr = (Interp *) interp; CompileEnv compEnv; /* Compilation environment structure allocated * in frame. */ - size_t length; - int result = TCL_OK; + int length, result = TCL_OK; const char *stringPtr; - Proc *procPtr = iPtr->compiledProcPtr; - ContLineLoc *clLocPtr; + ContLineLoc* clLocPtr; #ifdef TCL_COMPILE_DEBUG if (!traceInitialized) { if (Tcl_LinkVar(interp, "tcl_traceCompile", - &tclTraceCompile, TCL_LINK_INT) != TCL_OK) { + (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) { Tcl_Panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable"); } traceInitialized = 1; } #endif @@ -793,26 +506,27 @@ * stored by TclCompEvalObj and ProcCompileProc. */ TclInitCompileEnv(interp, &compEnv, stringPtr, length, iPtr->invokeCmdFramePtr, iPtr->invokeWord); - /* * Now we check if we have data about invisible continuation lines for the * script, and make it available to the compile environment, if so. * * It is not clear if the script Tcl_Obj* can be free'd while the compiler * is using it, leading to the release of the associated ContLineLoc * structure as well. To ensure that the latter doesn't happen we set a - * lock on it. We release this lock in the function TclFreeCompileEnv(), + * lock on it. We release this lock in the function TclFreeCompileEnv (), * found in this file. The "lineCLPtr" hashtable is managed in the file * "tclObj.c". */ - clLocPtr = TclContinuationsGet(objPtr); + clLocPtr = TclContinuationsGet (objPtr); if (clLocPtr) { - compEnv.clNext = &clLocPtr->loc[0]; + compEnv.clLoc = clLocPtr; + compEnv.clNext = &compEnv.clLoc->loc[0]; + Tcl_Preserve (compEnv.clLoc); } TclCompileScript(interp, stringPtr, length, &compEnv); /* @@ -819,50 +533,16 @@ * Successful compilation. Add a "done" instruction at the end. */ TclEmitOpcode(INST_DONE, &compEnv); - /* - * Check for optimizations! - * - * Test if the generated code is free of most hazards; if so, recompile - * but with generation of INST_START_CMD disabled. This produces somewhat - * faster code in some cases, and more compact code in more. - */ - - if (Tcl_GetParent(interp) == NULL && - !Tcl_LimitTypeEnabled(interp, TCL_LIMIT_COMMANDS|TCL_LIMIT_TIME) - && IsCompactibleCompileEnv(&compEnv)) { - TclFreeCompileEnv(&compEnv); - iPtr->compiledProcPtr = procPtr; - TclInitCompileEnv(interp, &compEnv, stringPtr, length, - iPtr->invokeCmdFramePtr, iPtr->invokeWord); - if (clLocPtr) { - compEnv.clNext = &clLocPtr->loc[0]; - } - 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->optimizer) { - (iPtr->optimizer)(&compEnv); - } - /* * Invoke the compilation hook procedure if one exists. */ if (hookProc) { - result = hookProc(interp, &compEnv, clientData); + result = (*hookProc)(interp, &compEnv, clientData); } /* * Change the object into a ByteCode object. Ownership of the literal * objects and aux data items is given to the ByteCode object. @@ -871,11 +551,11 @@ #ifdef TCL_COMPILE_DEBUG TclVerifyLocalLiteralTable(&compEnv); #endif /*TCL_COMPILE_DEBUG*/ if (result == TCL_OK) { - (void) TclInitByteCodeObj(objPtr, &tclByteCodeType, &compEnv); + TclInitByteCodeObj(objPtr, &compEnv); #ifdef TCL_COMPILE_DEBUG if (tclTraceCompile >= 2) { TclPrintByteCodeObj(interp, objPtr); fflush(stdout); } @@ -916,11 +596,12 @@ Tcl_Obj *objPtr) /* The object to make a ByteCode object. */ { if (interp == NULL) { return TCL_ERROR; } - return TclSetByteCodeFromAny(interp, objPtr, NULL, NULL); + (void) TclSetByteCodeFromAny(interp, objPtr, NULL, (ClientData) NULL); + return TCL_OK; } /* *---------------------------------------------------------------------- * @@ -940,12 +621,12 @@ *---------------------------------------------------------------------- */ static void DupByteCodeInternalRep( - TCL_UNUSED(Tcl_Obj *) /*srcPtr*/, - TCL_UNUSED(Tcl_Obj *) /*copyPtr*/) + Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ + Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { return; } /* @@ -968,24 +649,26 @@ *---------------------------------------------------------------------- */ static void FreeByteCodeInternalRep( - Tcl_Obj *objPtr) /* Object whose internal rep to free. */ -{ - ByteCode *codePtr; - - ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); - assert(codePtr != NULL); - - TclReleaseByteCode(codePtr); + register Tcl_Obj *objPtr) /* Object whose internal rep to free. */ +{ + register ByteCode *codePtr = (ByteCode *) + objPtr->internalRep.twoPtrValue.ptr1; + + codePtr->refCount--; + if (codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } + objPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * - * TclReleaseByteCode -- + * TclCleanupByteCode -- * * This procedure does all the real work of freeing up a bytecode * object's ByteCode structure. It's called only when the structure's * reference count becomes zero. * @@ -998,47 +681,28 @@ * *---------------------------------------------------------------------- */ 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. */ +TclCleanupByteCode( + register 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; + register Tcl_Obj **objArrayPtr, *objPtr; + register AuxData *auxDataPtr; int i; #ifdef TCL_COMPILE_STATS if (interp != NULL) { ByteCodeStats *statsPtr; Tcl_Time destroyTime; int lifetimeSec, lifetimeMicroSec, log2; - statsPtr = &iPtr->stats; + statsPtr = &((Interp *) interp)->stats; statsPtr->numByteCodesFreed++; statsPtr->currentSrcBytes -= (double) codePtr->numSrcBytes; statsPtr->currentByteCodeBytes -= (double) codePtr->structureSize; @@ -1086,11 +750,11 @@ * Also, as the interp deletion will remove the global literal table * anyway, we avoid the extra cost of updating it for each literal being * released. */ - if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { + if ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) || (interp == NULL)) { objArrayPtr = codePtr->objArrayPtr; for (i = 0; i < numLitObjects; i++) { objPtr = *objArrayPtr; if (objPtr) { @@ -1099,20 +763,28 @@ objArrayPtr++; } codePtr->numLitObjects = 0; } else { objArrayPtr = codePtr->objArrayPtr; - while (numLitObjects--) { - /* TclReleaseLiteral calls Tcl_DecrRefCount() for us */ - TclReleaseLiteral(interp, *objArrayPtr++); + for (i = 0; i < numLitObjects; i++) { + /* + * TclReleaseLiteral sets a ByteCode's object array entry NULL to + * indicate that it has already freed the literal. + */ + + objPtr = *objArrayPtr; + if (objPtr != NULL) { + TclReleaseLiteral(interp, objPtr); + } + objArrayPtr++; } } auxDataPtr = codePtr->auxDataArrayPtr; for (i = 0; i < numAuxDataItems; i++) { if (auxDataPtr->type->freeProc != NULL) { - auxDataPtr->type->freeProc(auxDataPtr->clientData); + (auxDataPtr->type->freeProc)(auxDataPtr->clientData); } auxDataPtr++; } /* @@ -1124,263 +796,22 @@ */ if (iPtr) { Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr); - if (hePtr) { - ReleaseCmdWordData((ExtCmdLoc *)Tcl_GetHashValue(hePtr)); + ReleaseCmdWordData(Tcl_GetHashValue(hePtr)); Tcl_DeleteHashEntry(hePtr); } } - if (codePtr->localCachePtr && (codePtr->localCachePtr->refCount-- <= 1)) { + if (codePtr->localCachePtr && (--codePtr->localCachePtr->refCount == 0)) { TclFreeLocalCache(interp, codePtr->localCachePtr); } TclHandleRelease(codePtr->interpHandle); - Tcl_Free(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 - * considered to be well-behaved and so can have compaction applied even - * if it would otherwise be invalid. - */ - - if (envPtr->procPtr != NULL && envPtr->procPtr->cmdPtr != NULL - && envPtr->procPtr->cmdPtr->nsPtr != NULL) { - Namespace *nsPtr = envPtr->procPtr->cmdPtr->nsPtr; - - if (strcmp(nsPtr->fullName, "::tcl") == 0 - || strncmp(nsPtr->fullName, "::tcl::", 7) == 0) { - return 1; - } - } - - /* - * Go through and ensure that no operation involved can cause a desired - * change of bytecode sequence during running. This comes down to ensuring - * that there are no mapped variables (due to traces) or calls to external - * commands (traces, [uplevel] trickery). This is actually a very - * conservative check; it turns down a lot of code that is OK in practice. - */ - - for (pc = envPtr->codeStart ; pc < envPtr->codeNext ; pc += size) { - switch (*pc) { - /* Invokes */ - case INST_INVOKE_STK1: - case INST_INVOKE_STK4: - case INST_INVOKE_EXPANDED: - case INST_INVOKE_REPLACE: - return 0; - /* Runtime evals */ - case INST_EVAL_STK: - case INST_EXPR_STK: - case INST_YIELD: - return 0; - /* Upvars */ - case INST_UPVAR: - case INST_NSUPVAR: - case INST_VARIABLE: - return 0; - default: - size = tclInstructionTable[*pc].numBytes; - assert (size > 0); - break; - } - } - - return 1; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SubstObj -- - * - * This function performs the substitutions specified on the given string - * as described in the user documentation for the "subst" Tcl command. - * - * Results: - * A Tcl_Obj* containing the substituted string, or NULL to indicate that - * an error occurred. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -Tcl_SubstObj( - Tcl_Interp *interp, /* Interpreter in which substitution occurs */ - Tcl_Obj *objPtr, /* The value to be substituted. */ - int flags) /* What substitutions to do. */ -{ - NRE_callback *rootPtr = TOP_CB(interp); - - if (TclNRRunCallbacks(interp, Tcl_NRSubstObj(interp, objPtr, flags), - rootPtr) != TCL_OK) { - return NULL; - } - return Tcl_GetObjResult(interp); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_NRSubstObj -- - * - * Request substitution of a Tcl value by the NR stack. - * - * Results: - * Returns TCL_OK. - * - * Side effects: - * Compiles objPtr into bytecode that performs the substitutions as - * governed by flags and places callbacks on the NR stack to execute - * the bytecode and store the result in the interp. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_NRSubstObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - int flags) -{ - ByteCode *codePtr = CompileSubstObj(interp, objPtr, flags); - - /* TODO: Confirm we do not need this. */ - /* Tcl_ResetResult(interp); */ - return TclNRExecuteByteCode(interp, codePtr); -} - -/* - *---------------------------------------------------------------------- - * - * CompileSubstObj -- - * - * Compile a Tcl value into ByteCode implementing its substitution, as - * governed by flags. - * - * Results: - * A (ByteCode *) is returned pointing to the resulting ByteCode. - * - * Side effects: - * The Tcl_ObjType of objPtr is changed to the "substcode" type, and the - * ByteCode and governing flags value are kept in the internal rep for - * faster operations the next time CompileSubstObj is called on the same - * value. - * - *---------------------------------------------------------------------- - */ - -static ByteCode * -CompileSubstObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - int flags) -{ - Interp *iPtr = (Interp *) interp; - ByteCode *codePtr = NULL; - - ByteCodeGetIntRep(objPtr, &substCodeType, codePtr); - - if (codePtr != NULL) { - Namespace *nsPtr = iPtr->varFramePtr->nsPtr; - - if (flags != PTR2INT(SubstFlags(objPtr)) - || ((Interp *) *codePtr->interpHandle != iPtr) - || (codePtr->compileEpoch != iPtr->compileEpoch) - || (codePtr->nsPtr != nsPtr) - || (codePtr->nsEpoch != nsPtr->resolverEpoch) - || (codePtr->localCachePtr != - iPtr->varFramePtr->localCachePtr)) { - Tcl_StoreIntRep(objPtr, &substCodeType, NULL); - codePtr = NULL; - } - } - if (codePtr == NULL) { - CompileEnv compEnv; - size_t numBytes; - const char *bytes = TclGetStringFromObj(objPtr, &numBytes); - - /* TODO: Check for more TIP 280 */ - TclInitCompileEnv(interp, &compEnv, bytes, numBytes, NULL, 0); - - TclSubstCompile(interp, bytes, numBytes, flags, 1, &compEnv); - - TclEmitOpcode(INST_DONE, &compEnv); - codePtr = TclInitByteCodeObj(objPtr, &substCodeType, &compEnv); - TclFreeCompileEnv(&compEnv); - - SubstFlags(objPtr) = INT2PTR(flags); - if (iPtr->varFramePtr->localCachePtr) { - codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; - codePtr->localCachePtr->refCount++; - } -#ifdef TCL_COMPILE_DEBUG - if (tclTraceCompile >= 2) { - TclPrintByteCodeObj(interp, objPtr); - fflush(stdout); - } -#endif /* TCL_COMPILE_DEBUG */ - } - return codePtr; -} - -/* - *---------------------------------------------------------------------- - * - * FreeSubstCodeInternalRep -- - * - * Part of the substcode Tcl object type implementation. Frees the - * storage associated with a substcode object's internal representation - * unless its code is actively being executed. - * - * Results: - * None. - * - * Side effects: - * The substcode object's internal rep is marked invalid and its code - * gets freed unless the code is actively being executed. In that case - * 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); + ckfree((char *) codePtr); } static void ReleaseCmdWordData( ExtCmdLoc *eclPtr) @@ -1389,18 +820,20 @@ if (eclPtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(eclPtr->path); } for (i=0 ; inuloc ; i++) { - Tcl_Free(eclPtr->loc[i].line); + ckfree((char *) eclPtr->loc[i].line); } if (eclPtr->loc != NULL) { - Tcl_Free(eclPtr->loc); + ckfree((char *) eclPtr->loc); } - Tcl_Free(eclPtr); + Tcl_DeleteHashTable (&eclPtr->litInfo); + + ckfree((char *) eclPtr); } /* *---------------------------------------------------------------------- * @@ -1420,22 +853,20 @@ void TclInitCompileEnv( Tcl_Interp *interp, /* The interpreter for which a CompileEnv * structure is initialized. */ - CompileEnv *envPtr,/* Points to the CompileEnv structure to + register CompileEnv *envPtr,/* Points to the CompileEnv structure to * initialize. */ const char *stringPtr, /* The source string to be compiled. */ - size_t numBytes, /* Number of bytes in source string. */ + 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].name == NULL); - envPtr->iPtr = iPtr; envPtr->source = stringPtr; envPtr->numSrcBytes = numBytes; envPtr->procPtr = iPtr->compiledProcPtr; iPtr->compiledProcPtr = NULL; @@ -1442,33 +873,31 @@ envPtr->numCommands = 0; envPtr->exceptDepth = 0; envPtr->maxExceptDepth = 0; envPtr->maxStackDepth = 0; envPtr->currStackDepth = 0; - TclInitLiteralTable(&envPtr->localLitTable); + TclInitLiteralTable(&(envPtr->localLitTable)); envPtr->codeStart = envPtr->staticCodeSpace; envPtr->codeNext = envPtr->codeStart; - envPtr->codeEnd = envPtr->codeStart + COMPILEENV_INIT_CODE_BYTES; + envPtr->codeEnd = (envPtr->codeStart + COMPILEENV_INIT_CODE_BYTES); envPtr->mallocedCodeArray = 0; envPtr->literalArrayPtr = envPtr->staticLiteralSpace; envPtr->literalArrayNext = 0; envPtr->literalArrayEnd = COMPILEENV_INIT_NUM_OBJECTS; envPtr->mallocedLiteralArray = 0; envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace; - envPtr->exceptAuxArrayPtr = envPtr->staticExAuxArraySpace; envPtr->exceptArrayNext = 0; envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES; envPtr->mallocedExceptArray = 0; envPtr->cmdMapPtr = envPtr->staticCmdMapSpace; envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE; envPtr->mallocedCmdMap = 0; envPtr->atCmdStart = 1; - envPtr->expandCount = 0; /* * TIP #280: Set up the extended command location information, based on * the context invoking the byte code compiler. This structure is used to * keep the per-word line information for all compiled commands. @@ -1475,74 +904,44 @@ * * See also tclBasic.c, TclEvalObjEx, for the equivalent code in the * non-compiling evaluator */ - envPtr->extCmdMapPtr = (ExtCmdLoc *)Tcl_Alloc(sizeof(ExtCmdLoc)); + envPtr->extCmdMapPtr = (ExtCmdLoc *) ckalloc(sizeof(ExtCmdLoc)); envPtr->extCmdMapPtr->loc = NULL; envPtr->extCmdMapPtr->nloc = 0; envPtr->extCmdMapPtr->nuloc = 0; envPtr->extCmdMapPtr->path = NULL; + Tcl_InitHashTable(&envPtr->extCmdMapPtr->litInfo, TCL_ONE_WORD_KEYS); - if (invoker == NULL) { - /* + if (invoker == NULL || + (invoker->type == TCL_LOCATION_EVAL_LIST)) { + /* * Initialize the compiler for relative counting in case of a * dynamic context. */ envPtr->line = 1; - if (iPtr->evalFlags & TCL_EVAL_FILE) { - iPtr->evalFlags &= ~TCL_EVAL_FILE; - envPtr->extCmdMapPtr->type = TCL_LOCATION_SOURCE; - - if (iPtr->scriptFile) { - /* - * Normalization here, to have the correct pwd. Should have - * negligible impact on performance, as the norm should have - * been done already by the 'source' invoking us, and it - * caches the result. - */ - - Tcl_Obj *norm = - Tcl_FSGetNormalizedPath(interp, iPtr->scriptFile); - - if (norm == NULL) { - /* - * Error message in the interp result. No place to put it. - * And no place to serve the error itself to either. Fake - * a path, empty string. - */ - - TclNewLiteralStringObj(envPtr->extCmdMapPtr->path, ""); - } else { - envPtr->extCmdMapPtr->path = norm; - } - } else { - TclNewLiteralStringObj(envPtr->extCmdMapPtr->path, ""); - } - - Tcl_IncrRefCount(envPtr->extCmdMapPtr->path); - } else { - envPtr->extCmdMapPtr->type = + envPtr->extCmdMapPtr->type = (envPtr->procPtr ? TCL_LOCATION_PROC : TCL_LOCATION_BC); - } } else { - /* + /* * 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)); + 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. + * ctx.data.tebc.codePtr is used instead. */ TclGetSrcInfoForPc(ctxPtr); pc = 1; } @@ -1558,11 +957,10 @@ if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) { /* * The reference made by 'TclGetSrcInfoForPc' is dead. */ - Tcl_DecrRefCount(ctxPtr->data.eval.path); } } else { envPtr->line = ctxPtr->line[word]; envPtr->extCmdMapPtr->type = ctxPtr->type; @@ -1579,11 +977,11 @@ } else { /* * We have a new reference here. */ - Tcl_IncrRefCount(envPtr->extCmdMapPtr->path); + Tcl_IncrRefCount(ctxPtr->data.eval.path); } } } TclStackFree(interp, ctxPtr); @@ -1590,15 +988,16 @@ } envPtr->extCmdMapPtr->start = envPtr->line; /* - * Initialize the data about invisible continuation lines as empty, i.e. - * not used. The caller (TclSetByteCodeFromAny) will set this up, if such - * data is available. + * Initialize the data about invisible continuation lines as empty, + * i.e. not used. The caller (TclSetByteCodeFromAny) will set this up, if + * such data is available. */ + envPtr->clLoc = NULL; envPtr->clNext = NULL; envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace; envPtr->auxDataArrayNext = 0; envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE; @@ -1627,18 +1026,18 @@ *---------------------------------------------------------------------- */ void TclFreeCompileEnv( - CompileEnv *envPtr)/* Points to the CompileEnv structure. */ + register CompileEnv *envPtr)/* Points to the CompileEnv structure. */ { - if (envPtr->localLitTable.buckets != envPtr->localLitTable.staticBuckets){ - Tcl_Free(envPtr->localLitTable.buckets); + if (envPtr->localLitTable.buckets != envPtr->localLitTable.staticBuckets) { + ckfree((char *) 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. */ int i; @@ -1660,29 +1059,38 @@ } auxDataPtr++; } } if (envPtr->mallocedCodeArray) { - Tcl_Free(envPtr->codeStart); + ckfree((char *) envPtr->codeStart); } if (envPtr->mallocedLiteralArray) { - Tcl_Free(envPtr->literalArrayPtr); + ckfree((char *) envPtr->literalArrayPtr); } if (envPtr->mallocedExceptArray) { - Tcl_Free(envPtr->exceptArrayPtr); - Tcl_Free(envPtr->exceptAuxArrayPtr); + ckfree((char *) envPtr->exceptArrayPtr); } if (envPtr->mallocedCmdMap) { - Tcl_Free(envPtr->cmdMapPtr); + ckfree((char *) envPtr->cmdMapPtr); } if (envPtr->mallocedAuxDataArray) { - Tcl_Free(envPtr->auxDataArrayPtr); + ckfree((char *) envPtr->auxDataArrayPtr); } if (envPtr->extCmdMapPtr) { ReleaseCmdWordData(envPtr->extCmdMapPtr); envPtr->extCmdMapPtr = NULL; } + + /* + * If we used data about invisible continuation lines, then now is the + * time to release on our hold on it. The lock was set in function + * TclSetByteCodeFromAny(), found in this file. + */ + + if (envPtr->clLoc) { + Tcl_Release (envPtr->clLoc); + } } /* *---------------------------------------------------------------------- * @@ -1725,11 +1133,11 @@ if (tokenPtr->type != TCL_TOKEN_WORD) { return 0; } tokenPtr++; if (valuePtr != NULL) { - TclNewObj(tempPtr); + tempPtr = Tcl_NewObj(); Tcl_IncrRefCount(tempPtr); } while (numComponents--) { switch (tokenPtr->type) { case TCL_TOKEN_TEXT: @@ -1738,14 +1146,13 @@ } break; case TCL_TOKEN_BS: if (tempPtr != NULL) { - char utfBuf[4] = ""; - size_t length = TclParseBackslash(tokenPtr->start, + char utfBuf[TCL_UTF_MAX]; + int length = TclParseBackslash(tokenPtr->start, tokenPtr->size, NULL, utfBuf); - Tcl_AppendToObj(tempPtr, utfBuf, length); } break; default: @@ -1779,375 +1186,46 @@ * Adds instructions to envPtr to evaluate the script at runtime. * *---------------------------------------------------------------------- */ -static int -ExpandRequested( - Tcl_Token *tokenPtr, - size_t 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) -{ - const char *bytes; - Command *cmdPtr; - int cmdLitIdx, extraLiteralFlags = LITERAL_CMD_NAME; - size_t length; - - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); - if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) { - extraLiteralFlags |= LITERAL_UNSHARED; - } - - bytes = TclGetStringFromObj(cmdObj, &length); - cmdLitIdx = TclRegisterLiteral(envPtr, bytes, length, extraLiteralFlags); - - if (cmdPtr && TclRoutineHasName(cmdPtr)) { - TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); - } - TclEmitPush(cmdLitIdx, envPtr); -} - -void -TclCompileInvocation( - Tcl_Interp *interp, - Tcl_Token *tokenPtr, - Tcl_Obj *cmdObj, - size_t numWords, - CompileEnv *envPtr) -{ - DefineLineInformation; - size_t wordIdx = 0; - int depth = TclGetStackDepth(envPtr); - - if (cmdObj) { - CompileCmdLiteral(interp, cmdObj, envPtr); - wordIdx = 1; - tokenPtr = TokenAfter(tokenPtr); - } - - for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) { - int objIdx; - - SetLineInformation(wordIdx); - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - CompileTokens(envPtr, tokenPtr, interp); - continue; - } - - objIdx = TclRegisterLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size, 0); - if (envPtr->clNext) { - TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), - tokenPtr[1].start - envPtr->source, envPtr->clNext); - } - TclEmitPush(objIdx, envPtr); - } - - if (wordIdx <= 255) { - TclEmitInvoke(envPtr, INST_INVOKE_STK1, wordIdx); - } else { - TclEmitInvoke(envPtr, INST_INVOKE_STK4, wordIdx); - } - TclCheckStackDepth(depth+1, envPtr); -} - -static void -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); - } - - for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) { - int objIdx; - - SetLineInformation(wordIdx); - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - CompileTokens(envPtr, tokenPtr, interp); - if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - TclEmitInstInt4(INST_EXPAND_STKTOP, - envPtr->currStackDepth, envPtr); - } - continue; - } - - objIdx = TclRegisterLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size, 0); - if (envPtr->clNext) { - TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), - tokenPtr[1].start - envPtr->source, envPtr->clNext); - } - TclEmitPush(objIdx, envPtr); - } - - /* - * The stack depth during argument expansion can only be managed at - * runtime, as the number of elements in the expanded lists is not known - * at compile time. We adjust here the stack depth estimate so that it is - * correct after the command with expanded arguments returns. - * - * The end effect of this command's invocation is that all the words of - * the command are popped from the stack, and the result is pushed: the - * stack top changes by (1-wordIdx). - * - * Note that the estimates are not correct while the command is being - * prepared and run, INST_EXPAND_STKTOP is not stack-neutral in general. - */ - - TclEmitInvoke(envPtr, INST_INVOKE_EXPANDED, wordIdx); - TclCheckStackDepth(depth+1, envPtr); -} - -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. - * atCmdStart == 1 : INST_START_CMD was the last instruction emitted. - * : We do not need to emit another. Instead we - * : increment the number of cmds started at it (except - * : for the special case at the start of a script.) - * atCmdStart == 0 : The last instruction was something else. We need - * : to emit INST_START_CMD here. - */ - - switch (envPtr->atCmdStart) { - case 0: - unwind = tclInstructionTable[INST_START_CMD].numBytes; - TclEmitInstInt4(INST_START_CMD, 0, envPtr); - incrOffset = envPtr->codeNext - envPtr->codeStart; - TclEmitInt4(0, envPtr); - break; - case 1: - if (envPtr->codeNext > envPtr->codeStart) { - incrOffset = envPtr->codeNext - 4 - envPtr->codeStart; - } - break; - case 2: - /* Nothing to do */ - ; - } - - if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, 1, cmdPtr, envPtr)) { - if (incrOffset >= 0) { - /* - * We successfully compiled a command. Increment the number of - * commands that start at the currently active INST_START_CMD. - */ - - unsigned char *incrPtr = envPtr->codeStart + incrOffset; - unsigned char *startPtr = incrPtr - 5; - - TclIncrUInt4AtPtr(incrPtr, 1); - if (unwind) { - /* We started the INST_START_CMD. Record the code length. */ - TclStoreInt4AtPtr(envPtr->codeNext - startPtr, startPtr + 1); - } - } - TclCheckStackDepth(depth+1, envPtr); - return TCL_OK; - } - - envPtr->codeNext -= unwind; /* Unwind INST_START_CMD */ - - /* - * Throw out any line information generated by the failed compile attempt. - */ - - while (mapPtr->nuloc - 1 > eclIndex) { - mapPtr->nuloc--; - Tcl_Free(mapPtr->loc[mapPtr->nuloc].line); - mapPtr->loc[mapPtr->nuloc].line = NULL; - } - - /* - * Reset the index of next command. Toss out any from failed nested - * partial compiles. - */ - - envPtr->numCommands = mapPtr->nuloc; - return TCL_ERROR; -} - -static int -CompileCommandTokens( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - CompileEnv *envPtr) -{ - Interp *iPtr = (Interp *) interp; - Tcl_Token *tokenPtr = parsePtr->tokenPtr; - ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; - Tcl_Obj *cmdObj; - Command *cmdPtr = NULL; - int code = TCL_ERROR; - int cmdKnown, expand = -1; - int *wlines, wlineat; - int cmdLine = envPtr->line; - int *clNext = envPtr->clNext; - int cmdIdx = envPtr->numCommands; - int startCodeOffset = envPtr->codeNext - envPtr->codeStart; - int depth = TclGetStackDepth(envPtr); - - assert (parsePtr->numWords > 0); - - /* Pre-Compile */ - - TclNewObj(cmdObj); - envPtr->numCommands++; - EnterCmdStartData(envPtr, cmdIdx, - parsePtr->commandStart - envPtr->source, startCodeOffset); - - /* - * TIP #280. Scan the words and compute the extended location information. - * The map first contain full per-word line information for use by the - * compiler. This is later replaced by a reduced form which signals - * non-literal words, stored in 'wlines'. - */ - - EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, - parsePtr->tokenPtr, parsePtr->commandStart, - parsePtr->numWords, cmdLine, - clNext, &wlines, envPtr); - wlineat = eclPtr->nuloc - 1; - - envPtr->line = eclPtr->loc[wlineat].line[0]; - envPtr->clNext = eclPtr->loc[wlineat].next[0]; - - /* Do we know the command word? */ - Tcl_IncrRefCount(cmdObj); - tokenPtr = parsePtr->tokenPtr; - cmdKnown = TclWordKnownAtCompileTime(tokenPtr, cmdObj); - - /* Is this a command we should (try to) compile with a compileProc ? */ - if (cmdKnown && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); - if (cmdPtr) { - /* - * Found a command. Test the ways we can be told not to attempt - * to compile it. - */ - if ((cmdPtr->compileProc == NULL) - || (cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION) - || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { - cmdPtr = NULL; - } - } - if (cmdPtr && !(cmdPtr->flags & CMD_COMPILES_EXPANDED)) { - expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); - if (expand) { - /* We need to expand, but compileProc cannot. */ - cmdPtr = NULL; - } - } - } - - /* If cmdPtr != NULL, we will try to call cmdPtr->compileProc */ - if (cmdPtr) { - code = CompileCmdCompileProc(interp, parsePtr, cmdPtr, envPtr); - } - - if (code == TCL_ERROR) { - if (expand < 0) { - expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); - } - - if (expand) { - CompileExpanded(interp, parsePtr->tokenPtr, - cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); - } else { - TclCompileInvocation(interp, parsePtr->tokenPtr, - cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); - } - } - - Tcl_DecrRefCount(cmdObj); - - TclEmitOpcode(INST_POP, envPtr); - EnterCmdExtentData(envPtr, cmdIdx, - parsePtr->term - parsePtr->commandStart, - (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); - - /* - * TIP #280: Free full form of per-word line data and insert the reduced - * form now - */ - - envPtr->line = cmdLine; - envPtr->clNext = clNext; - Tcl_Free(eclPtr->loc[wlineat].line); - Tcl_Free(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. */ - size_t numBytes, /* Number of bytes in script. If -1, the + 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; + int lastTopLevelCmdIndex = -1; + /* Index of most recent toplevel command in + * the command location table. Initialized to + * avoid compiler warning. */ + int startCodeOffset = -1; /* Offset of first byte of current command's + * code. Init. to avoid compiler warning. */ + unsigned char *entryCodeNext = envPtr->codeNext; + const char *p, *next; + Namespace *cmdNsPtr; + Command *cmdPtr; + Tcl_Token *tokenPtr; + int bytesLeft, isFirstCmd, wordIdx, currCmdIndex; + int commandLength, objIndex; + Tcl_DString ds; + /* TIP #280 */ + ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + int *wlines, wlineat, cmdLine; + int* clNext; + Tcl_Parse *parsePtr; 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). @@ -2157,137 +1235,427 @@ "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 + 1 > 1) { - /* - * Don't use system stack (size of Tcl_Parse is ca. 400 bytes), so - * many nested compilations (body enclosed in body) can cause abnormal - * program termination with a stack overflow exception, bug [fec0c17d39]. - */ - Tcl_Parse *parsePtr = (Tcl_Parse *)Tcl_Alloc(sizeof(Tcl_Parse)); - - do { - const char *next; - - if (TCL_OK != Tcl_ParseCommand(interp, p, numBytes, 0, parsePtr)) { - /* - * Compile bytecodes to report the parsePtr error at runtime. + /* + * Avoid stack exhaustion by too many nested calls of TclCompileScript + * (considering interp recursionlimit). + */ + iPtr->numLevels++; + + parsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse)); + + Tcl_DStringInit(&ds); + + if (numBytes < 0) { + numBytes = strlen(script); + } + Tcl_ResetResult(interp); + isFirstCmd = 1; + + if (envPtr->procPtr != NULL) { + cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr; + } else { + cmdNsPtr = NULL; /* use current NS */ + } + + /* + * Each iteration through the following loop compiles the next command + * from the script. + */ + + p = script; + bytesLeft = numBytes; + cmdLine = envPtr->line; + clNext = envPtr->clNext; + do { + if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) { + /* + * Compile bytecodes to report the parse error at runtime. */ Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, - parsePtr->term + 1 - parsePtr->commandStart); + /* Drop the command terminator (";","]") if appropriate */ + (parsePtr->term == + parsePtr->commandStart + parsePtr->commandSize - 1)? + parsePtr->commandSize - 1 : parsePtr->commandSize); TclCompileSyntaxError(interp, envPtr); - Tcl_Free(parsePtr); - return; + break; } + if (parsePtr->numWords > 0) { + int expand = 0; /* Set if there are dynamic expansions to + * handle */ + + /* + * If not the first command, pop the previous command's result + * and, if we're compiling a top level command, update the last + * command's code size to account for the pop instruction. + */ + + if (!isFirstCmd) { + TclEmitOpcode(INST_POP, envPtr); + envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes = + (envPtr->codeNext - envPtr->codeStart) + - startCodeOffset; + } + + /* + * Determine the actual length of the command. + */ + + commandLength = parsePtr->commandSize; + if (parsePtr->term == parsePtr->commandStart + commandLength - 1) { + /* + * The command terminator character (such as ; or ]) is the + * last character in the parsed command. Reduce the length by + * one so that the trace message doesn't include the + * terminator character. + */ + + commandLength -= 1; + } #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"); - } + /* + * If tracing, print a line for each top level command compiled. + */ + + if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { + 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); + /* + * Check whether expansion has been requested for any of the + * words. + */ + + for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr; + wordIdx < parsePtr->numWords; + wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) { + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + expand = 1; + break; + } + } + + envPtr->numCommands++; + currCmdIndex = (envPtr->numCommands - 1); + lastTopLevelCmdIndex = currCmdIndex; + startCodeOffset = (envPtr->codeNext - envPtr->codeStart); + EnterCmdStartData(envPtr, currCmdIndex, + parsePtr->commandStart - envPtr->source, startCodeOffset); + + /* + * Should only start issuing instructions after the "command has + * started" so that the command range is correct in the bytecode. + */ + + if (expand) { + TclEmitOpcode(INST_EXPAND_START, envPtr); + } + + /* + * TIP #280. Scan the words and compute the extended location + * information. The map first contain full per-word line + * information for use by the compiler. This is later replaced by + * a reduced form which signals non-literal words, stored in + * 'wlines'. + */ + + TclAdvanceLines(&cmdLine, p, parsePtr->commandStart); + TclAdvanceContinuations (&cmdLine, &clNext, + parsePtr->commandStart - envPtr->source); + EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, + parsePtr->tokenPtr, parsePtr->commandStart, + parsePtr->commandSize, parsePtr->numWords, cmdLine, + clNext, &wlines, envPtr); + wlineat = eclPtr->nuloc - 1; + + /* + * Each iteration of the following loop compiles one word from the + * command. + */ + + for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr; + wordIdx < parsePtr->numWords; wordIdx++, + tokenPtr += (tokenPtr->numComponents + 1)) { + + envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; + envPtr->clNext = eclPtr->loc [wlineat].next [wordIdx]; + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + /* + * The word is not a simple string of characters. + */ + + TclCompileTokens(interp, tokenPtr+1, + tokenPtr->numComponents, envPtr); + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + TclEmitInstInt4(INST_EXPAND_STKTOP, + envPtr->currStackDepth, envPtr); + } + continue; + } + + /* + * This is a simple string of literal characters (i.e. we know + * it absolutely and can use it directly). If this is the + * first word and the command has a compile procedure, let it + * compile the command. + */ + + if ((wordIdx == 0) && !expand) { + /* + * We copy the string before trying to find the command by + * name. We used to modify the string in place, but this + * is not safe because the name resolution handlers could + * have side effects that rely on the unmodified string. + */ + + Tcl_DStringSetLength(&ds, 0); + Tcl_DStringAppend(&ds, tokenPtr[1].start,tokenPtr[1].size); + + cmdPtr = (Command *) Tcl_FindCommand(interp, + Tcl_DStringValue(&ds), + (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0); + + if ((cmdPtr != NULL) + && (cmdPtr->compileProc != NULL) + && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES) + && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { + int savedNumCmds = envPtr->numCommands; + unsigned savedCodeNext = + envPtr->codeNext - envPtr->codeStart; + int update = 0, code; + + /* + * Mark the start of the command; the proper bytecode + * length will be updated later. There is no need to + * do this for the first bytecode in the compile env, + * as the check is done before calling + * TclExecuteByteCode(). Do emit an INST_START_CMD in + * special cases where the first bytecode is in a + * loop, to insure that the corresponding command is + * counted properly. Compilers for commands able to + * produce such a beast (currently 'while 1' only) set + * envPtr->atCmdStart to 0 in order to signal this + * case. [Bug 1752146] + * + * Note that the environment is initialised with + * atCmdStart=1 to avoid emitting ISC for the first + * command. + */ + + if (envPtr->atCmdStart) { + if (savedCodeNext != 0) { + /* + * Increase the number of commands being + * started at the current point. Note that + * this depends on the exact layout of the + * INST_START_CMD's operands, so be careful! + */ + + unsigned char *fixPtr = envPtr->codeNext - 4; + + TclStoreInt4AtPtr(TclGetUInt4AtPtr(fixPtr)+1, + fixPtr); + } + } else { + TclEmitInstInt4(INST_START_CMD, 0, envPtr); + TclEmitInt4(1, envPtr); + update = 1; + } + + code = (cmdPtr->compileProc)(interp, parsePtr, + cmdPtr, envPtr); + + if (code == TCL_OK) { + if (update) { + /* + * Fix the bytecode length. + */ + + unsigned char *fixPtr = envPtr->codeStart + + savedCodeNext + 1; + unsigned fixLen = envPtr->codeNext + - envPtr->codeStart - savedCodeNext; + + TclStoreInt4AtPtr(fixLen, fixPtr); + } + goto finishCommand; + } else { + if (envPtr->atCmdStart && savedCodeNext != 0) { + /* + * Decrease the number of commands being + * started at the current point. Note that + * this depends on the exact layout of the + * INST_START_CMD's operands, so be careful! + */ + + unsigned char *fixPtr = envPtr->codeNext - 4; + + TclStoreInt4AtPtr(TclGetUInt4AtPtr(fixPtr)-1, + fixPtr); + } + + /* + * Restore numCommands and codeNext to their + * correct values, removing any commands compiled + * before the failure to produce bytecode got + * reported. [Bugs 705406 and 735055] + */ + + envPtr->numCommands = savedNumCmds; + envPtr->codeNext = envPtr->codeStart+savedCodeNext; + } + } + + /* + * No compile procedure so push the word. If the command + * was found, push a CmdName object to reduce runtime + * lookups. Avoid sharing this literal among different + * namespaces to reduce shimmering. + */ + + objIndex = TclRegisterNewNSLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); + if (cmdPtr != NULL) { + TclSetCmdNameObj(interp, + envPtr->literalArrayPtr[objIndex].objPtr,cmdPtr); + } + if ((wordIdx == 0) && (parsePtr->numWords == 1)) { + /* + * Single word script: unshare the command name to + * avoid shimmering between bytecode and cmdName + * representations [Bug 458361] + */ + + TclHideLiteral(interp, envPtr, objIndex); + } + } else { + /* + * Simple argument word of a command. We reach this if and + * only if the command word was not compiled for whatever + * reason. Register the literal's location for use by + * uplevel, etc. commands, should they encounter it + * unmodified. We care only if the we are in a context + * which already allows absolute counting. + */ + objIndex = TclRegisterNewLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); + + if (envPtr->clNext) { + TclContinuationsEnterDerived (envPtr->literalArrayPtr[objIndex].objPtr, + tokenPtr[1].start - envPtr->source, + eclPtr->loc [wlineat].next [wordIdx]); + } + } + TclEmitPush(objIndex, envPtr); + } /* for loop */ + + /* + * Emit an invoke instruction for the command. We skip this if a + * compile procedure was found for the command. + */ + + if (expand) { + /* + * The stack depth during argument expansion can only be + * managed at runtime, as the number of elements in the + * expanded lists is not known at compile time. We adjust here + * the stack depth estimate so that it is correct after the + * command with expanded arguments returns. + * + * The end effect of this command's invocation is that all the + * words of the command are popped from the stack, and the + * result is pushed: the stack top changes by (1-wordIdx). + * + * Note that the estimates are not correct while the command + * is being prepared and run, INST_EXPAND_STKTOP is not + * stack-neutral in general. + */ + + TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); + TclAdjustStackDepth((1-wordIdx), envPtr); + } else if (wordIdx > 0) { + /* + * Save PC -> command map for the TclArgumentBC* functions. + */ + + int isnew; + Tcl_HashEntry* hePtr = Tcl_CreateHashEntry(&eclPtr->litInfo, + (char*) (envPtr->codeNext - envPtr->codeStart), &isnew); + Tcl_SetHashValue(hePtr, INT2PTR(wlineat)); + + if (wordIdx <= 255) { + TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); + } else { + TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); + } + } + + /* + * Update the compilation environment structure and record the + * offsets of the source and code for the command. + */ + + finishCommand: + EnterCmdExtentData(envPtr, currCmdIndex, commandLength, + (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); + isFirstCmd = 0; + + /* + * TIP #280: Free full form of per-word line data and insert the + * reduced form now + */ + + ckfree((char *) eclPtr->loc[wlineat].line); + ckfree((char *) eclPtr->loc[wlineat].next); + eclPtr->loc[wlineat].line = wlines; + eclPtr->loc[wlineat].next = NULL; + } /* end if parsePtr->numWords > 0 */ /* - * Advance parser to the next command in the script. + * Advance to the next command in the script. */ next = parsePtr->commandStart + parsePtr->commandSize; - numBytes -= next - p; + bytesLeft -= 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); + TclAdvanceLines(&cmdLine, parsePtr->commandStart, p); + TclAdvanceContinuations (&cmdLine, &clNext, p - envPtr->source); Tcl_FreeParse(parsePtr); - } while (numBytes > 0); - - Tcl_Free(parsePtr); - } - - if (lastCmdIdx == -1) { - /* - * Compiling the script yielded no bytecode. The script must be all - * whitespace, comments, and empty commands. Such scripts are defined - * to successfully produce the empty string result, so we emit the - * simple bytecode that makes that happen. - */ - - PushStringLiteral(envPtr, ""); - } else { - /* - * We compiled at least one command to bytecode. The routine - * CompileCommandTokens() follows the bytecode of each compiled - * command with an INST_POP, so that stack balance is maintained when - * several commands are in sequence. (The result of each command is - * thrown away before moving on to the next command). For the last - * command compiled, we need to undo that INST_POP so that the result - * of the last command becomes the result of the script. The code - * here removes that trailing INST_POP. - */ - - envPtr->cmdMapPtr[lastCmdIdx].numCodeBytes--; - envPtr->codeNext--; - envPtr->currStackDepth++; - } - TclCheckStackDepth(depth+1, envPtr); + } while (bytesLeft > 0); + + /* + * If the source script yielded no instructions (e.g., if it was empty), + * push an empty string as the command's result. + * + * WARNING: push an unshared object! If the script being compiled is a + * shared empty string, it will otherwise be self-referential and cause + * difficulties with literal management [Bugs 467523, 983660]. We used to + * have special code in TclReleaseLiteral to handle this particular + * self-reference, but now opt for avoiding its creation altogether. + */ + + if (envPtr->codeNext == entryCodeNext) { + TclEmitPush(TclAddLiteralObj(envPtr, Tcl_NewObj(), NULL), envPtr); + } + + iPtr->numLevels--; + TclStackFree(interp, parsePtr); + Tcl_DStringFree(&ds); } /* *---------------------------------------------------------------------- * @@ -2307,80 +1675,10 @@ * runtime. * *---------------------------------------------------------------------- */ -void -TclCompileVarSubst( - Tcl_Interp *interp, - Tcl_Token *tokenPtr, - CompileEnv *envPtr) -{ - const char *p, *name = tokenPtr[1].start; - size_t i, nameBytes = tokenPtr[1].size; - int 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). - */ - - for (i = 0, p = name; i < nameBytes; i++, p++) { - if ((*p == ':') && (i < nameBytes-1) && (*(p+1) == ':')) { - localVarName = -1; - break; - } else if ((*p == '(') - && (tokenPtr->numComponents == 1) - && (*(name + nameBytes - 1) == ')')) { - localVarName = 0; - break; - } - } - - /* - * Either push the variable's name, or find its index in the array - * of local variables in a procedure frame. - */ - - localVar = -1; - if (localVarName != -1) { - localVar = TclFindCompiledLocal(name, nameBytes, localVarName, envPtr); - } - if (localVar < 0) { - PushLiteral(envPtr, name, nameBytes); - } - - /* - * Emit instructions to load the variable. - */ - - TclAdvanceLines(&envPtr->line, tokenPtr[1].start, - tokenPtr[1].start + tokenPtr[1].size); - - if (tokenPtr->numComponents == 1) { - if (localVar < 0) { - TclEmitOpcode(INST_LOAD_STK, envPtr); - } else if (localVar <= 255) { - TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, envPtr); - } else { - TclEmitInstInt4(INST_LOAD_SCALAR4, localVar, envPtr); - } - } else { - TclCompileTokens(interp, tokenPtr+2, tokenPtr->numComponents-1, envPtr); - if (localVar < 0) { - TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); - } else if (localVar <= 255) { - TclEmitInstInt1(INST_LOAD_ARRAY1, localVar, envPtr); - } else { - TclEmitInstInt4(INST_LOAD_ARRAY4, localVar, envPtr); - } - } -} - void TclCompileTokens( Tcl_Interp *interp, /* Used for error and status reporting. */ Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to * compile. */ @@ -2388,59 +1686,57 @@ * 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, adjust; - size_t length; + char buffer[TCL_UTF_MAX]; + const char *name, *p; + int numObjsToConcat, nameBytes, localVarName, localVar; + int length, i; unsigned char *entryCodeNext = envPtr->codeNext; #define NUM_STATIC_POS 20 int isLiteral, maxNumCL, numCL; - int *clPosition = NULL; - int depth = TclGetStackDepth(envPtr); + int* clPosition = NULL; /* * For the handling of continuation lines in literals we first check if * this is actually a literal. For if not we can forego the additional * processing. Otherwise we pre-allocate a small table to store the - * locations of all continuation lines we find in this literal, if any. - * The table is extended if needed. - * - * Note: Different to the equivalent code in function 'TclSubstTokens()' - * (see file "tclParse.c") we do not seem to need the 'adjust' variable. - * We also do not seem to need code which merges continuation line - * information of multiple words which concat'd at runtime. Either that or - * I have not managed to find a test case for these two possibilities yet. - * It might be a difference between compile- versus run-time processing. - */ - - numCL = 0; - maxNumCL = 0; + * locations of all continuation lines we find in this literal, if + * any. The table is extended if needed. + * + * Note: Different to the equivalent code in function + * 'TclSubstTokens()' (see file "tclParse.c") we do not seem to need + * the 'adjust' variable. We also do not seem to need code which merges + * continuation line information of multiple words which concat'd at + * runtime. Either that or I have not managed to find a test case for + * these two possibilities yet. It might be a difference between compile- + * versus runtime processing. + */ + + numCL = 0; + maxNumCL = 0; isLiteral = 1; for (i=0 ; i < count; i++) { - if ((tokenPtr[i].type != TCL_TOKEN_TEXT) - && (tokenPtr[i].type != TCL_TOKEN_BS)) { + if ((tokenPtr[i].type != TCL_TOKEN_TEXT) && + (tokenPtr[i].type != TCL_TOKEN_BS)) { isLiteral = 0; break; } } if (isLiteral) { - maxNumCL = NUM_STATIC_POS; - clPosition = (int *)Tcl_Alloc(maxNumCL * sizeof(int)); + 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) { case TCL_TOKEN_TEXT: - TclDStringAppendToken(&textBuffer, tokenPtr); - TclAdvanceLines(&envPtr->line, tokenPtr->start, - tokenPtr->start + tokenPtr->size); + Tcl_DStringAppend(&textBuffer, tokenPtr->start, tokenPtr->size); break; case TCL_TOKEN_BS: length = TclParseBackslash(tokenPtr->start, tokenPtr->size, NULL, buffer); @@ -2462,47 +1758,46 @@ */ if ((length == 1) && (buffer[0] == ' ') && (tokenPtr->start[1] == '\n')) { if (isLiteral) { - int clPos = Tcl_DStringLength(&textBuffer); + int clPos = Tcl_DStringLength (&textBuffer); if (numCL >= maxNumCL) { maxNumCL *= 2; - clPosition = (int *)Tcl_Realloc(clPosition, - maxNumCL * sizeof(int)); + clPosition = (int*) ckrealloc ((char*)clPosition, + maxNumCL*sizeof(int)); } clPosition[numCL] = clPos; numCL ++; } - adjust++; } break; case TCL_TOKEN_COMMAND: /* * Push any accumulated chars appearing before the command. */ if (Tcl_DStringLength(&textBuffer) > 0) { - int literal = TclRegisterDStringLiteral(envPtr, &textBuffer); + int literal = TclRegisterNewLiteral(envPtr, + Tcl_DStringValue(&textBuffer), + Tcl_DStringLength(&textBuffer)); TclEmitPush(literal, envPtr); numObjsToConcat++; Tcl_DStringFree(&textBuffer); if (numCL) { - TclContinuationsEnter(TclFetchLiteral(envPtr, literal), - numCL, clPosition); + TclContinuationsEnter(envPtr->literalArrayPtr[literal].objPtr, + numCL, clPosition); } numCL = 0; } - envPtr->line += adjust; TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2, envPtr); - envPtr->line -= adjust; numObjsToConcat++; break; case TCL_TOKEN_VARIABLE: /* @@ -2510,74 +1805,142 @@ */ if (Tcl_DStringLength(&textBuffer) > 0) { int literal; - literal = TclRegisterDStringLiteral(envPtr, &textBuffer); + literal = TclRegisterNewLiteral(envPtr, + Tcl_DStringValue(&textBuffer), + Tcl_DStringLength(&textBuffer)); TclEmitPush(literal, envPtr); numObjsToConcat++; Tcl_DStringFree(&textBuffer); } - TclCompileVarSubst(interp, tokenPtr, envPtr); + /* + * 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). + */ + + name = tokenPtr[1].start; + nameBytes = tokenPtr[1].size; + localVarName = -1; + if (envPtr->procPtr != NULL) { + localVarName = 1; + for (i = 0, p = name; i < nameBytes; i++, p++) { + if ((*p == ':') && (i < nameBytes-1) && (*(p+1) == ':')) { + localVarName = -1; + break; + } else if ((*p == '(') + && (tokenPtr->numComponents == 1) + && (*(name + nameBytes - 1) == ')')) { + localVarName = 0; + break; + } + } + } + + /* + * Either push the variable's name, or find its index in the array + * of local variables in a procedure frame. + */ + + localVar = -1; + if (localVarName != -1) { + localVar = TclFindCompiledLocal(name, nameBytes, localVarName, + envPtr->procPtr); + } + if (localVar < 0) { + TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes), + envPtr); + } + + /* + * Emit instructions to load the variable. + */ + + if (tokenPtr->numComponents == 1) { + if (localVar < 0) { + TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); + } else if (localVar <= 255) { + TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, envPtr); + } else { + TclEmitInstInt4(INST_LOAD_SCALAR4, localVar, envPtr); + } + } else { + TclCompileTokens(interp, tokenPtr+2, + tokenPtr->numComponents-1, envPtr); + if (localVar < 0) { + TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); + } else if (localVar <= 255) { + TclEmitInstInt1(INST_LOAD_ARRAY1, localVar, envPtr); + } else { + TclEmitInstInt4(INST_LOAD_ARRAY4, localVar, envPtr); + } + } numObjsToConcat++; count -= tokenPtr->numComponents; tokenPtr += tokenPtr->numComponents; break; default: Tcl_Panic("Unexpected token type in TclCompileTokens: %d; %.*s", - tokenPtr->type, (int)tokenPtr->size, tokenPtr->start); + tokenPtr->type, tokenPtr->size, tokenPtr->start); } } /* * Push any accumulated characters appearing at the end. */ if (Tcl_DStringLength(&textBuffer) > 0) { - int literal = TclRegisterDStringLiteral(envPtr, &textBuffer); + int literal; + literal = TclRegisterNewLiteral(envPtr, Tcl_DStringValue(&textBuffer), + Tcl_DStringLength(&textBuffer)); TclEmitPush(literal, envPtr); numObjsToConcat++; + if (numCL) { - TclContinuationsEnter(TclFetchLiteral(envPtr, literal), - numCL, clPosition); + TclContinuationsEnter(envPtr->literalArrayPtr[literal].objPtr, + numCL, clPosition); } numCL = 0; } /* * If necessary, concatenate the parts of the word. */ while (numObjsToConcat > 255) { - TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr); + TclEmitInstInt1(INST_CONCAT1, 255, envPtr); numObjsToConcat -= 254; /* concat pushes 1 obj, the result */ } if (numObjsToConcat > 1) { - TclEmitInstInt1(INST_STR_CONCAT1, numObjsToConcat, envPtr); + TclEmitInstInt1(INST_CONCAT1, numObjsToConcat, envPtr); } /* * If the tokens yielded no instructions, push an empty string. */ if (envPtr->codeNext == entryCodeNext) { - PushStringLiteral(envPtr, ""); + TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); } Tcl_DStringFree(&textBuffer); /* - * Release the temp table we used to collect the locations of continuation - * lines, if any. + * Release the temp table we used to collect the locations of + * continuation lines, if any. */ if (maxNumCL) { - Tcl_Free(clPosition); + ckfree ((char*) clPosition); } - TclCheckStackDepth(depth+1, envPtr); } /* *---------------------------------------------------------------------- * @@ -2621,11 +1984,11 @@ * instructions to invoke the eval command procedure at runtime on the * result of evaluating the tokens. */ TclCompileTokens(interp, tokenPtr, count, envPtr); - TclEmitInvoke(envPtr, INST_EVAL_STK); + TclEmitOpcode(INST_EVAL_STK, envPtr); } } /* *---------------------------------------------------------------------- @@ -2666,11 +2029,11 @@ * If the expression is a single word that doesn't require substitutions, * just compile its string into inline instructions. */ if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { - TclCompileExpr(interp, tokenPtr[1].start,tokenPtr[1].size, envPtr, 1); + TclCompileExpr(interp, tokenPtr[1].start, tokenPtr[1].size, envPtr, 1); return; } /* * Emit code to call the expr command proc at runtime. Concatenate the @@ -2677,23 +2040,23 @@ * (already substituted once) expr tokens with a space between each. */ wordPtr = tokenPtr; for (i = 0; i < numWords; i++) { - CompileTokens(envPtr, wordPtr, interp); + TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents, envPtr); if (i < (numWords - 1)) { - PushStringLiteral(envPtr, " "); + TclEmitPush(TclRegisterNewLiteral(envPtr, " ", 1), envPtr); } - wordPtr += wordPtr->numComponents + 1; + wordPtr += (wordPtr->numComponents + 1); } concatItems = 2*numWords - 1; while (concatItems > 255) { - TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr); + TclEmitInstInt1(INST_CONCAT1, 255, envPtr); concatItems -= 254; } if (concatItems > 1) { - TclEmitInstInt1(INST_STR_CONCAT1, concatItems, envPtr); + TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr); } TclEmitOpcode(INST_EXPR_STK, envPtr); } /* @@ -2706,37 +2069,42 @@ * Results: * The return value is TCL_OK, indicating successful compilation. * * Side effects: * Instructions are added to envPtr to execute a no-op at runtime. No - * result is pushed onto the stack: the compiler has to take care of this - * itself if the last compiled command is a NoOp. + * result is pushed onto the stack: the compiler has to take care of this + * itself if the last compiled command is a NoOp. * *---------------------------------------------------------------------- */ 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 *), + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; int i; + int savedStackDepth = envPtr->currStackDepth; tokenPtr = parsePtr->tokenPtr; - for (i = 1; i < parsePtr->numWords; i++) { + for(i = 1; i < parsePtr->numWords; i++) { tokenPtr = tokenPtr + tokenPtr->numComponents + 1; + envPtr->currStackDepth = savedStackDepth; if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - CompileTokens(envPtr, tokenPtr, interp); + TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, + envPtr); TclEmitOpcode(INST_POP, envPtr); } } - PushStringLiteral(envPtr, ""); + envPtr->currStackDepth = savedStackDepth; + TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -2761,51 +2129,22 @@ * structure. * *---------------------------------------------------------------------- */ -static void -PreventCycle( - Tcl_Obj *objPtr, - CompileEnv *envPtr) -{ - int i; - - for (i = 0; i < envPtr->literalArrayNext; i++) { - if (objPtr == TclFetchLiteral(envPtr, i)) { - /* - * Prevent circular reference where the bytecode intrep of - * a value contains a literal which is that same value. - * If this is allowed to happen, refcount decrements may not - * reach zero, and memory may leak. Bugs 467523, 3357771 - * - * NOTE: [Bugs 3392070, 3389764] We make a copy based completely - * on the string value, and do not call Tcl_DuplicateObj() so we - * can be sure we do not have any lingering cycles hiding in - * the intrep. - */ - size_t 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 +void +TclInitByteCodeObj( + Tcl_Obj *objPtr, /* Points object that should be initialized, + * and whose string rep contains the source + * code. */ + register CompileEnv *envPtr)/* Points to the CompileEnv structure from * which to create a ByteCode structure. */ { - ByteCode *codePtr; + register ByteCode *codePtr; size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes; size_t auxDataArrayBytes, structureSize; - unsigned char *p; + register unsigned char *p; #ifdef TCL_COMPILE_DEBUG unsigned char *nextPtr; #endif int numLitObjects = envPtr->literalArrayNext; Namespace *namespacePtr; @@ -2816,14 +2155,14 @@ Tcl_Panic("TclInitByteCodeObj() called on uninitialized CompileEnv"); } iPtr = envPtr->iPtr; - codeBytes = envPtr->codeNext - envPtr->codeStart; - objArrayBytes = envPtr->literalArrayNext * sizeof(Tcl_Obj *); - exceptArrayBytes = envPtr->exceptArrayNext * sizeof(ExceptionRange); - auxDataArrayBytes = envPtr->auxDataArrayNext * sizeof(AuxData); + codeBytes = (envPtr->codeNext - envPtr->codeStart); + objArrayBytes = (envPtr->literalArrayNext * sizeof(Tcl_Obj *)); + exceptArrayBytes = (envPtr->exceptArrayNext * sizeof(ExceptionRange)); + auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData)); cmdLocBytes = GetCmdLocEncodingSize(envPtr); /* * Compute the total number of bytes needed for this bytecode. */ @@ -2839,18 +2178,17 @@ namespacePtr = envPtr->iPtr->varFramePtr->nsPtr; } else { namespacePtr = envPtr->iPtr->globalNsPtr; } - p = (unsigned char *)Tcl_Alloc(structureSize); + p = (unsigned char *) ckalloc((size_t) 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); + codePtr->refCount = 1; if (namespacePtr->compiledVarResProc || iPtr->resolverPtr) { codePtr->flags = TCL_BYTECODE_RESOLVE_VARS; } else { codePtr->flags = 0; } @@ -2867,30 +2205,30 @@ codePtr->maxExceptDepth = envPtr->maxExceptDepth; codePtr->maxStackDepth = envPtr->maxStackDepth; p += sizeof(ByteCode); codePtr->codeStart = p; - memcpy(p, envPtr->codeStart, codeBytes); + memcpy(p, envPtr->codeStart, (size_t) codeBytes); p += TCL_ALIGN(codeBytes); /* align object array */ codePtr->objArrayPtr = (Tcl_Obj **) p; for (i = 0; i < numLitObjects; i++) { - codePtr->objArrayPtr[i] = TclFetchLiteral(envPtr, i); + codePtr->objArrayPtr[i] = envPtr->literalArrayPtr[i].objPtr; } p += TCL_ALIGN(objArrayBytes); /* align exception range array */ if (exceptArrayBytes > 0) { codePtr->exceptArrayPtr = (ExceptionRange *) p; - memcpy(p, envPtr->exceptArrayPtr, exceptArrayBytes); + memcpy(p, envPtr->exceptArrayPtr, (size_t) exceptArrayBytes); } else { codePtr->exceptArrayPtr = NULL; } p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ if (auxDataArrayBytes > 0) { codePtr->auxDataArrayPtr = (AuxData *) p; - memcpy(p, envPtr->auxDataArrayPtr, auxDataArrayBytes); + memcpy(p, envPtr->auxDataArrayPtr, (size_t) auxDataArrayBytes); } else { codePtr->auxDataArrayPtr = NULL; } p += auxDataArrayBytes; @@ -2897,11 +2235,11 @@ #ifndef TCL_COMPILE_DEBUG EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p); #else nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p); if (((size_t)(nextPtr - p)) != cmdLocBytes) { - Tcl_Panic("TclInitByteCodeObj: encoded cmd location bytes %lu != expected size %lu", (unsigned long)(nextPtr - p), (unsigned long)cmdLocBytes); + Tcl_Panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d", (nextPtr - p), cmdLocBytes); } #endif /* * Record various compilation-related statistics about the new ByteCode @@ -2909,53 +2247,37 @@ */ #ifdef TCL_COMPILE_STATS codePtr->structureSize = structureSize - (sizeof(size_t) + sizeof(Tcl_Time)); - Tcl_GetTime(&codePtr->createTime); + Tcl_GetTime(&(codePtr->createTime)); RecordByteCodeStats(codePtr); #endif /* TCL_COMPILE_STATS */ + /* + * Free the old internal rep then convert the object to a bytecode object + * by making its internal rep point to the just compiled ByteCode. + */ + + TclFreeIntRep(objPtr); + objPtr->internalRep.twoPtrValue.ptr1 = (void *) codePtr; + objPtr->typePtr = &tclByteCodeType; + /* * TIP #280. Associate the extended per-word line information with the * byte code object (internal rep), for use with the bc compiler. */ - Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->lineBCPtr, codePtr, + Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->lineBCPtr, (char *) codePtr, &isNew), envPtr->extCmdMapPtr); envPtr->extCmdMapPtr = NULL; /* We've used up the CompileEnv. Mark as uninitialized. */ envPtr->iPtr = NULL; codePtr->localCachePtr = NULL; - return codePtr; -} - -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); - - /* - * Free the old internal rep then convert the object to a bytecode object - * by making its internal rep point to the just compiled ByteCode. - */ - - ByteCodeSetIntRep(objPtr, typePtr, codePtr); - return codePtr; } /* *---------------------------------------------------------------------- * @@ -2981,67 +2303,38 @@ *---------------------------------------------------------------------- */ int TclFindCompiledLocal( - const char *name, /* Points to first character of the name of a + register const char *name, /* Points to first character of the name of a * scalar or array variable. If NULL, a * temporary var should be created. */ - size_t 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*/ + int nameBytes, /* Number of bytes in the name. */ + int create, /* If non-zero, allocate a local frame entry + * for the variable if it is new. */ + register Proc *procPtr) /* Points to structure describing procedure + * containing the variable reference. */ { - CompiledLocal *localPtr; + register CompiledLocal *localPtr; int localVar = -1; - int i; - Proc *procPtr; + register int i; /* * 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; - size_t len; - - if (!cachePtr || !name) { - return -1; - } - - varNamePtr = &cachePtr->varName0; - for (i=0; i < cachePtr->numVars; varNamePtr++, i++) { - if (*varNamePtr) { - localName = TclGetStringFromObj(*varNamePtr, &len); - if ((len == nameBytes) && !strncmp(name, localName, len)) { - return i; - } - } - } - return -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)) { + (strncmp(name,localName,(unsigned)nameBytes) == 0)) { return i; } } localPtr = localPtr->nextPtr; } @@ -3051,11 +2344,13 @@ * Create a new variable if appropriate. */ if (create || (name == NULL)) { localVar = procPtr->numCompiledLocals; - localPtr = (CompiledLocal *)Tcl_Alloc(offsetof(CompiledLocal, name) + nameBytes + 1); + localPtr = (CompiledLocal *) ckalloc((unsigned) + (sizeof(CompiledLocal) - sizeof(localPtr->name) + + nameBytes + 1)); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { procPtr->lastLocalPtr->nextPtr = localPtr; procPtr->lastLocalPtr = localPtr; @@ -3069,11 +2364,11 @@ } localPtr->defValuePtr = NULL; localPtr->resolveInfo = NULL; if (name != NULL) { - memcpy(localPtr->name, name, nameBytes); + memcpy(localPtr->name, name, (size_t) nameBytes); } localPtr->name[nameBytes] = '\0'; procPtr->numCompiledLocals++; } return localVar; @@ -3101,40 +2396,39 @@ void TclExpandCodeArray( void *envArgPtr) /* Points to the CompileEnv whose code array * must be enlarged. */ { - CompileEnv *envPtr = (CompileEnv *)envArgPtr; + 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); + size_t currBytes = (envPtr->codeNext - envPtr->codeStart); + size_t newBytes = 2*(envPtr->codeEnd - envPtr->codeStart); if (envPtr->mallocedCodeArray) { - envPtr->codeStart = (unsigned char *)Tcl_Realloc(envPtr->codeStart, newBytes); + envPtr->codeStart = (unsigned char *) + ckrealloc((char *)envPtr->codeStart, newBytes); } else { /* - * envPtr->codeStart isn't a Tcl_Alloc'd pointer, so we must code a - * Tcl_Realloc equivalent for ourselves. + * envPtr->codeStart isn't a ckalloc'd pointer, so we must + * code a ckrealloc equivalent for ourselves. */ - - unsigned char *newPtr = (unsigned char *)Tcl_Alloc(newBytes); - + unsigned char *newPtr = (unsigned char *) ckalloc((unsigned) newBytes); memcpy(newPtr, envPtr->codeStart, currBytes); envPtr->codeStart = newPtr; envPtr->mallocedCodeArray = 1; } - envPtr->codeNext = envPtr->codeStart + currBytes; - envPtr->codeEnd = envPtr->codeStart + newBytes; + envPtr->codeNext = (envPtr->codeStart + currBytes); + envPtr->codeEnd = (envPtr->codeStart + newBytes); } /* *---------------------------------------------------------------------- * @@ -3177,24 +2471,23 @@ * the heap. The currently allocated CmdLocation entries are stored * from cmdMapPtr[0] up to cmdMapPtr[envPtr->cmdMapEnd] (inclusive). */ size_t currElems = envPtr->cmdMapEnd; - size_t newElems = 2 * currElems; + size_t newElems = 2*currElems; size_t currBytes = currElems * sizeof(CmdLocation); size_t newBytes = newElems * sizeof(CmdLocation); if (envPtr->mallocedCmdMap) { - envPtr->cmdMapPtr = (CmdLocation *)Tcl_Realloc(envPtr->cmdMapPtr, newBytes); + envPtr->cmdMapPtr = (CmdLocation *) + ckrealloc((char *) envPtr->cmdMapPtr, newBytes); } else { /* - * envPtr->cmdMapPtr isn't a Tcl_Alloc'd pointer, so we must code a - * Tcl_Realloc equivalent for ourselves. + * envPtr->cmdMapPtr isn't a ckalloc'd pointer, so we must + * code a ckrealloc equivalent for ourselves. */ - - CmdLocation *newPtr = (CmdLocation *)Tcl_Alloc(newBytes); - + CmdLocation *newPtr = (CmdLocation *) ckalloc((unsigned) newBytes); memcpy(newPtr, envPtr->cmdMapPtr, currBytes); envPtr->cmdMapPtr = newPtr; envPtr->mallocedCmdMap = 1; } envPtr->cmdMapEnd = newElems; @@ -3204,11 +2497,11 @@ if (codeOffset < envPtr->cmdMapPtr[cmdIndex-1].codeOffset) { Tcl_Panic("EnterCmdStartData: cmd map not sorted by code offset"); } } - cmdLocPtr = &envPtr->cmdMapPtr[cmdIndex]; + cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]); cmdLocPtr->codeOffset = codeOffset; cmdLocPtr->srcOffset = srcOffset; cmdLocPtr->numSrcBytes = -1; cmdLocPtr->numCodeBytes = -1; } @@ -3253,11 +2546,11 @@ if (cmdIndex > envPtr->cmdMapEnd) { Tcl_Panic("EnterCmdExtentData: missing start data for command %d", cmdIndex); } - cmdLocPtr = &envPtr->cmdMapPtr[cmdIndex]; + cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]); cmdLocPtr->numSrcBytes = numSrcBytes; cmdLocPtr->numCodeBytes = numCodeBytes; } /* @@ -3286,19 +2579,21 @@ * which to enter command location * information. */ int srcOffset, /* Offset of first char of the command. */ Tcl_Token *tokenPtr, const char *cmd, + int len, int numWords, int line, - int *clNext, + int* clNext, int **wlines, - CompileEnv *envPtr) + CompileEnv* envPtr) { ECL *ePtr; const char *last; - int wordIdx, wordLine, *wwlines, *wordNext; + int wordIdx, wordLine, *wwlines; + int* wordNext; if (eclPtr->nuloc >= eclPtr->nloc) { /* * Expand the ECL array by allocating more storage from the heap. The * currently allocated ECL entries are stored from eclPtr->loc[0] up @@ -3307,29 +2602,29 @@ size_t currElems = eclPtr->nloc; size_t newElems = (currElems ? 2*currElems : 1); size_t newBytes = newElems * sizeof(ECL); - eclPtr->loc = (ECL *)Tcl_Realloc(eclPtr->loc, newBytes); + eclPtr->loc = (ECL *) ckrealloc((char *)(eclPtr->loc), newBytes); eclPtr->nloc = newElems; } ePtr = &eclPtr->loc[eclPtr->nuloc]; ePtr->srcOffset = srcOffset; - ePtr->line = (int *)Tcl_Alloc(numWords * sizeof(int)); - ePtr->next = (int **)Tcl_Alloc(numWords * sizeof(int *)); + ePtr->line = (int *) ckalloc(numWords * sizeof(int)); + ePtr->next = (int**) ckalloc (numWords * sizeof (int*)); ePtr->nline = numWords; - wwlines = (int *)Tcl_Alloc(numWords * sizeof(int)); + wwlines = (int *) ckalloc(numWords * sizeof(int)); last = cmd; wordLine = line; wordNext = clNext; for (wordIdx=0 ; wordIdxnumComponents + 1) { - TclAdvanceLines(&wordLine, last, tokenPtr->start); - TclAdvanceContinuations(&wordLine, &wordNext, - tokenPtr->start - envPtr->source); + TclAdvanceLines (&wordLine, last, tokenPtr->start); + TclAdvanceContinuations (&wordLine, &wordNext, + tokenPtr->start - envPtr->source); /* See Ticket 4b61afd660 */ wwlines[wordIdx] = ((wordIdx == 0) || TclWordKnownAtCompileTime(tokenPtr, NULL)) ? wordLine : -1; ePtr->line[wordIdx] = wordLine; @@ -3362,15 +2657,14 @@ */ int TclCreateExceptRange( ExceptionRangeType type, /* The kind of ExceptionRange desired. */ - CompileEnv *envPtr)/* Points to CompileEnv for which to create a + register CompileEnv *envPtr)/* Points to CompileEnv for which to create a * new ExceptionRange structure. */ { - ExceptionRange *rangePtr; - ExceptionAux *auxPtr; + register ExceptionRange *rangePtr; int index = envPtr->exceptArrayNext; if (index >= envPtr->exceptArrayEnd) { /* * Expand the ExceptionRange array. The currently allocated entries @@ -3378,332 +2672,41 @@ * [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 *)Tcl_Realloc(envPtr->exceptArrayPtr, newBytes); - envPtr->exceptAuxArrayPtr = - (ExceptionAux *)Tcl_Realloc(envPtr->exceptAuxArrayPtr, newBytes2); + envPtr->exceptArrayPtr = (ExceptionRange *) + ckrealloc((char *)(envPtr->exceptArrayPtr), newBytes); } else { /* - * envPtr->exceptArrayPtr isn't a Tcl_Alloc'd pointer, so we must - * code a Tcl_Realloc equivalent for ourselves. + * envPtr->exceptArrayPtr isn't a ckalloc'd pointer, so we must + * code a ckrealloc equivalent for ourselves. */ - - ExceptionRange *newPtr = (ExceptionRange *)Tcl_Alloc(newBytes); - ExceptionAux *newPtr2 = (ExceptionAux *)Tcl_Alloc(newBytes2); - + ExceptionRange *newPtr = (ExceptionRange *) + ckalloc((unsigned) newBytes); memcpy(newPtr, envPtr->exceptArrayPtr, currBytes); - memcpy(newPtr2, envPtr->exceptAuxArrayPtr, currBytes2); envPtr->exceptArrayPtr = newPtr; - envPtr->exceptAuxArrayPtr = newPtr2; envPtr->mallocedExceptArray = 1; } envPtr->exceptArrayEnd = newElems; } envPtr->exceptArrayNext++; - rangePtr = &envPtr->exceptArrayPtr[index]; + rangePtr = &(envPtr->exceptArrayPtr[index]); rangePtr->type = type; rangePtr->nestingLevel = envPtr->exceptDepth; rangePtr->codeOffset = -1; rangePtr->numCodeBytes = -1; rangePtr->breakOffset = -1; rangePtr->continueOffset = -1; rangePtr->catchOffset = -1; - auxPtr = &envPtr->exceptAuxArrayPtr[index]; - auxPtr->supportsContinue = 1; - auxPtr->stackDepth = envPtr->currStackDepth; - auxPtr->expandTarget = envPtr->expandCount; - auxPtr->expandTargetDepth = -1; - auxPtr->numBreakTargets = 0; - auxPtr->breakTargets = NULL; - auxPtr->allocBreakTargets = 0; - auxPtr->numContinueTargets = 0; - auxPtr->continueTargets = NULL; - auxPtr->allocContinueTargets = 0; return index; } - -/* - * --------------------------------------------------------------------- - * - * TclGetInnermostExceptionRange -- - * - * Returns the innermost exception range that covers the current code - * creation point, and (optionally) the stack depth that is expected at - * that point. Relies on the fact that the range has a numCodeBytes = -1 - * when it is being populated and that inner ranges come after outer - * ranges. - * - * --------------------------------------------------------------------- - */ - -ExceptionRange * -TclGetInnermostExceptionRange( - CompileEnv *envPtr, - int returnCode, - ExceptionAux **auxPtrPtr) -{ - int i = envPtr->exceptArrayNext; - ExceptionRange *rangePtr = envPtr->exceptArrayPtr + i; - - while (i > 0) { - rangePtr--; i--; - - if (CurrentOffset(envPtr) >= rangePtr->codeOffset && - (rangePtr->numCodeBytes == -1 || CurrentOffset(envPtr) < - rangePtr->codeOffset+rangePtr->numCodeBytes) && - (returnCode != TCL_CONTINUE || - envPtr->exceptAuxArrayPtr[i].supportsContinue)) { - - if (auxPtrPtr) { - *auxPtrPtr = envPtr->exceptAuxArrayPtr + i; - } - return rangePtr; - } - } - return NULL; -} - -/* - * --------------------------------------------------------------------- - * - * TclAddLoopBreakFixup, TclAddLoopContinueFixup -- - * - * Adds a place that wants to break/continue to the loop exception range - * tracking that will be fixed up once the loop can be finalized. These - * functions will generate an INST_JUMP4 that will be fixed up during the - * loop finalization. - * - * --------------------------------------------------------------------- - */ - -void -TclAddLoopBreakFixup( - CompileEnv *envPtr, - ExceptionAux *auxPtr) -{ - int range = auxPtr - envPtr->exceptAuxArrayPtr; - - if (envPtr->exceptArrayPtr[range].type != LOOP_EXCEPTION_RANGE) { - 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 *)Tcl_Realloc(auxPtr->breakTargets, - sizeof(int) * auxPtr->allocBreakTargets); - } else { - auxPtr->breakTargets = - (unsigned int *)Tcl_Alloc(sizeof(int) * auxPtr->allocBreakTargets); - } - } - auxPtr->breakTargets[auxPtr->numBreakTargets - 1] = CurrentOffset(envPtr); - TclEmitInstInt4(INST_JUMP4, 0, envPtr); -} - -void -TclAddLoopContinueFixup( - CompileEnv *envPtr, - ExceptionAux *auxPtr) -{ - int range = auxPtr - envPtr->exceptAuxArrayPtr; - - if (envPtr->exceptArrayPtr[range].type != LOOP_EXCEPTION_RANGE) { - 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 *)Tcl_Realloc(auxPtr->continueTargets, - sizeof(int) * auxPtr->allocContinueTargets); - } else { - auxPtr->continueTargets = - (unsigned int *)Tcl_Alloc(sizeof(int) * auxPtr->allocContinueTargets); - } - } - auxPtr->continueTargets[auxPtr->numContinueTargets - 1] = - CurrentOffset(envPtr); - TclEmitInstInt4(INST_JUMP4, 0, envPtr); -} - -/* - * --------------------------------------------------------------------- - * - * TclCleanupStackForBreakContinue -- - * - * Ditch the extra elements from the auxiliary stack and the main stack. - * How to do this exactly depends on whether there are any elements on - * the auxiliary stack to pop. - * - * --------------------------------------------------------------------- - */ - -void -TclCleanupStackForBreakContinue( - CompileEnv *envPtr, - ExceptionAux *auxPtr) -{ - int savedStackDepth = envPtr->currStackDepth; - int toPop = envPtr->expandCount - auxPtr->expandTarget; - - if (toPop > 0) { - while (toPop --> 0) { - TclEmitOpcode(INST_EXPAND_DROP, envPtr); - } - TclAdjustStackDepth(auxPtr->expandTargetDepth - envPtr->currStackDepth, - envPtr); - envPtr->currStackDepth = auxPtr->expandTargetDepth; - } - toPop = envPtr->currStackDepth - auxPtr->stackDepth; - while (toPop --> 0) { - TclEmitOpcode(INST_POP, envPtr); - } - envPtr->currStackDepth = savedStackDepth; -} - -/* - * --------------------------------------------------------------------- - * - * StartExpanding -- - * - * Pushes an INST_EXPAND_START and does some additional housekeeping so - * that the [break] and [continue] compilers can use an exception-free - * issue to discard it. - * - * --------------------------------------------------------------------- - */ - -static void -StartExpanding( - CompileEnv *envPtr) -{ - int i; - - TclEmitOpcode(INST_EXPAND_START, envPtr); - - /* - * Update inner exception ranges with information about the environment - * where this expansion started. - */ - - for (i=0 ; iexceptArrayNext ; i++) { - ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i]; - ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[i]; - - /* - * Ignore loops unless they're still being built. - */ - - if (rangePtr->codeOffset > CurrentOffset(envPtr)) { - continue; - } - if (rangePtr->numCodeBytes != -1) { - continue; - } - - /* - * Adequate condition: further out loops and further in exceptions - * don't actually need this information. - */ - - if (auxPtr->expandTarget == envPtr->expandCount) { - auxPtr->expandTargetDepth = envPtr->currStackDepth; - } - } - - /* - * There's now one more expansion being processed on the auxiliary stack. - */ - - envPtr->expandCount++; -} - -/* - * --------------------------------------------------------------------- - * - * TclFinalizeLoopExceptionRange -- - * - * Finalizes a loop exception range, binding the registered [break] and - * [continue] implementations so that they jump to the correct place. - * Note that this must only be called after *all* the exception range - * target offsets have been set. - * - * --------------------------------------------------------------------- - */ - -void -TclFinalizeLoopExceptionRange( - CompileEnv *envPtr, - int range) -{ - ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[range]; - ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[range]; - int i, offset; - unsigned char *site; - - if (rangePtr->type != LOOP_EXCEPTION_RANGE) { - Tcl_Panic("trying to finalize a loop exception range"); - } - - /* - * Do the jump fixups. Note that these are always issued as INST_JUMP4 so - * there is no need to fuss around with updating code offsets. - */ - - for (i=0 ; inumBreakTargets ; i++) { - site = envPtr->codeStart + auxPtr->breakTargets[i]; - offset = rangePtr->breakOffset - auxPtr->breakTargets[i]; - TclUpdateInstInt4AtPc(INST_JUMP4, offset, site); - } - for (i=0 ; inumContinueTargets ; i++) { - site = envPtr->codeStart + auxPtr->continueTargets[i]; - if (rangePtr->continueOffset == -1) { - int j; - - /* - * WTF? Can't bind, so revert to an INST_CONTINUE. Not enough - * space to do anything else. - */ - - *site = INST_CONTINUE; - for (j=0 ; j<4 ; j++) { - *++site = INST_NOP; - } - } else { - offset = rangePtr->continueOffset - auxPtr->continueTargets[i]; - TclUpdateInstInt4AtPc(INST_JUMP4, offset, site); - } - } - - /* - * Drop the arrays we were holding the only reference to. - */ - - if (auxPtr->breakTargets) { - Tcl_Free(auxPtr->breakTargets); - auxPtr->breakTargets = NULL; - auxPtr->numBreakTargets = 0; - } - if (auxPtr->continueTargets) { - Tcl_Free(auxPtr->continueTargets); - auxPtr->continueTargets = NULL; - auxPtr->numContinueTargets = 0; - } -} /* *---------------------------------------------------------------------- * * TclCreateAuxData -- @@ -3728,18 +2731,18 @@ 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 + AuxDataType *typePtr, /* Pointer to the type to attach to this * AuxData */ - CompileEnv *envPtr)/* Points to the CompileEnv for which a new + register 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 */ + register AuxData *auxDataPtr; + /* Points to the new AuxData structure */ index = envPtr->auxDataArrayNext; if (index >= envPtr->auxDataArrayEnd) { /* * Expand the AuxData array. The currently allocated entries are @@ -3750,29 +2753,27 @@ size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData); int newElems = 2*envPtr->auxDataArrayEnd; size_t newBytes = newElems * sizeof(AuxData); if (envPtr->mallocedAuxDataArray) { - envPtr->auxDataArrayPtr = - (AuxData *)Tcl_Realloc(envPtr->auxDataArrayPtr, newBytes); + envPtr->auxDataArrayPtr = (AuxData *) + ckrealloc((char *)(envPtr->auxDataArrayPtr), newBytes); } else { /* - * envPtr->auxDataArrayPtr isn't a Tcl_Alloc'd pointer, so we must - * code a Tcl_Realloc equivalent for ourselves. + * envPtr->auxDataArrayPtr isn't a ckalloc'd pointer, so we must + * code a ckrealloc equivalent for ourselves. */ - - AuxData *newPtr = (AuxData *)Tcl_Alloc(newBytes); - + AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes); memcpy(newPtr, envPtr->auxDataArrayPtr, currBytes); envPtr->auxDataArrayPtr = newPtr; envPtr->mallocedAuxDataArray = 1; } envPtr->auxDataArrayEnd = newElems; } envPtr->auxDataArrayNext++; - auxDataPtr = &envPtr->auxDataArrayPtr[index]; + auxDataPtr = &(envPtr->auxDataArrayPtr[index]); auxDataPtr->clientData = clientData; auxDataPtr->type = typePtr; return index; } @@ -3793,17 +2794,17 @@ *---------------------------------------------------------------------- */ void TclInitJumpFixupArray( - JumpFixupArray *fixupArrayPtr) + register JumpFixupArray *fixupArrayPtr) /* Points to the JumpFixupArray structure to * initialize. */ { fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace; fixupArrayPtr->next = 0; - fixupArrayPtr->end = JUMPFIXUP_INIT_ENTRIES - 1; + fixupArrayPtr->end = (JUMPFIXUP_INIT_ENTRIES - 1); fixupArrayPtr->mallocedArray = 0; } /* *---------------------------------------------------------------------- @@ -3825,13 +2826,13 @@ *---------------------------------------------------------------------- */ void TclExpandJumpFixupArray( - JumpFixupArray *fixupArrayPtr) - /* Points to the JumpFixupArray structure to - * enlarge. */ + register 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. @@ -3840,19 +2841,18 @@ 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 *)Tcl_Realloc(fixupArrayPtr->fixup, newBytes); + fixupArrayPtr->fixup = (JumpFixup *) + ckrealloc((char *)(fixupArrayPtr->fixup), newBytes); } else { /* - * fixupArrayPtr->fixup isn't a Tcl_Alloc'd pointer, so we must code a - * Tcl_Realloc equivalent for ourselves. + * fixupArrayPtr->fixup isn't a ckalloc'd pointer, so we must + * code a ckrealloc equivalent for ourselves. */ - - JumpFixup *newPtr = (JumpFixup *)Tcl_Alloc(newBytes); - + JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes); memcpy(newPtr, fixupArrayPtr->fixup, currBytes); fixupArrayPtr->fixup = newPtr; fixupArrayPtr->mallocedArray = 1; } fixupArrayPtr->end = newElems; @@ -3874,16 +2874,16 @@ *---------------------------------------------------------------------- */ void TclFreeJumpFixupArray( - JumpFixupArray *fixupArrayPtr) + register JumpFixupArray *fixupArrayPtr) /* Points to the JumpFixupArray structure to * free. */ { if (fixupArrayPtr->mallocedArray) { - Tcl_Free(fixupArrayPtr->fixup); + ckfree((char *) fixupArrayPtr->fixup); } } /* *---------------------------------------------------------------------- @@ -3924,11 +2924,11 @@ * - exceptIndex is the index of the first ExceptionRange after the * current one. */ jumpFixupPtr->jumpType = jumpType; - jumpFixupPtr->codeOffset = envPtr->codeNext - envPtr->codeStart; + jumpFixupPtr->codeOffset = (envPtr->codeNext - envPtr->codeStart); jumpFixupPtr->cmdIndex = envPtr->numCommands; jumpFixupPtr->exceptIndex = envPtr->exceptArrayNext; switch (jumpType) { case TCL_UNCONDITIONAL_JUMP: @@ -3979,14 +2979,14 @@ int distThreshold) /* Maximum distance before the two byte jump * is grown to five bytes. */ { unsigned char *jumpPc, *p; int firstCmd, lastCmd, firstRange, lastRange, k; - size_t numBytes; + unsigned numBytes; if (jumpDist <= distThreshold) { - jumpPc = envPtr->codeStart + jumpFixupPtr->codeOffset; + jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset); switch (jumpFixupPtr->jumpType) { case TCL_UNCONDITIONAL_JUMP: TclUpdateInstInt1AtPc(INST_JUMP1, jumpDist, jumpPc); break; case TCL_TRUE_JUMP: @@ -4007,11 +3007,11 @@ */ if ((envPtr->codeNext + 3) > envPtr->codeEnd) { TclExpandCodeArray(envPtr); } - jumpPc = envPtr->codeStart + jumpFixupPtr->codeOffset; + jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset); numBytes = envPtr->codeNext-jumpPc-2; p = jumpPc+2; memmove(p+3, p, numBytes); envPtr->codeNext += 3; @@ -4032,23 +3032,23 @@ * Adjust the code offsets for any commands and any ExceptionRange records * between the jump and the current code address. */ firstCmd = jumpFixupPtr->cmdIndex; - lastCmd = envPtr->numCommands - 1; + lastCmd = (envPtr->numCommands - 1); if (firstCmd < lastCmd) { for (k = firstCmd; k <= lastCmd; k++) { - envPtr->cmdMapPtr[k].codeOffset += 3; + (envPtr->cmdMapPtr[k]).codeOffset += 3; } } firstRange = jumpFixupPtr->exceptIndex; - lastRange = envPtr->exceptArrayNext - 1; + lastRange = (envPtr->exceptArrayNext - 1); for (k = firstRange; k <= lastRange; k++) { - ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[k]; - + ExceptionRange *rangePtr = &(envPtr->exceptArrayPtr[k]); rangePtr->codeOffset += 3; + switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: rangePtr->breakOffset += 3; if (rangePtr->continueOffset != -1) { rangePtr->continueOffset += 3; @@ -4061,220 +3061,74 @@ Tcl_Panic("TclFixupForwardJump: bad ExceptionRange type %d", rangePtr->type); } } - for (k = 0 ; k < envPtr->exceptArrayNext ; k++) { - ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[k]; - int i; - - for (i=0 ; inumBreakTargets ; i++) { - if (jumpFixupPtr->codeOffset < auxPtr->breakTargets[i]) { - auxPtr->breakTargets[i] += 3; - } - } - for (i=0 ; inumContinueTargets ; i++) { - if (jumpFixupPtr->codeOffset < auxPtr->continueTargets[i]) { - auxPtr->continueTargets[i] += 3; - } - } - } - - return 1; /* the jump was grown */ -} - -/* - *---------------------------------------------------------------------- - * - * TclEmitInvoke -- - * - * Emit one of the invoke-related instructions, wrapping it if necessary - * in code that ensures that any break or continue operation passing - * through it gets the stack unwinding correct, converting it into an - * internal jump if in an appropriate context. - * - * Results: - * None - * - * Side effects: - * Issues the jump with all correct stack management. May create another - * loop exception range; pointers to ExceptionRange and ExceptionAux - * structures should not be held across this call. - * - *---------------------------------------------------------------------- - */ - -void -TclEmitInvoke( - CompileEnv *envPtr, - int opcode, - ...) -{ - va_list argList; - ExceptionRange *rangePtr; - ExceptionAux *auxBreakPtr, *auxContinuePtr; - int arg1, arg2, wordCount = 0, expandCount = 0; - int loopRange = 0, breakRange = 0, continueRange = 0; - int cleanup, depth = TclGetStackDepth(envPtr); - - /* - * Parse the arguments. - */ - - va_start(argList, opcode); - switch (opcode) { - case INST_INVOKE_STK1: - wordCount = arg1 = cleanup = va_arg(argList, int); - arg2 = 0; - break; - case INST_INVOKE_STK4: - wordCount = arg1 = cleanup = va_arg(argList, int); - arg2 = 0; - break; - case INST_INVOKE_REPLACE: - arg1 = va_arg(argList, int); - arg2 = va_arg(argList, int); - wordCount = arg1 + arg2 - 1; - cleanup = arg1 + 1; - break; - default: - Tcl_Panic("unexpected opcode"); - case INST_EVAL_STK: - wordCount = cleanup = 1; - arg1 = arg2 = 0; - break; - case INST_RETURN_STK: - wordCount = cleanup = 2; - arg1 = arg2 = 0; - break; - case INST_INVOKE_EXPANDED: - wordCount = arg1 = cleanup = va_arg(argList, int); - arg2 = 0; - expandCount = 1; - break; - } - va_end(argList); - - /* - * Determine if we need to handle break and continue exceptions with a - * special handling exception range (so that we can correctly unwind the - * stack). - * - * These must be done separately; they can be different (especially for - * calls from inside a [for] increment clause). - */ - - rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE, - &auxContinuePtr); - if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) { - auxContinuePtr = NULL; - } else if (auxContinuePtr->stackDepth == envPtr->currStackDepth-wordCount - && auxContinuePtr->expandTarget == envPtr->expandCount-expandCount) { - auxContinuePtr = NULL; - } else { - continueRange = auxContinuePtr - envPtr->exceptAuxArrayPtr; - } - - rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_BREAK, &auxBreakPtr); - if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) { - auxBreakPtr = NULL; - } else if (auxContinuePtr == NULL - && auxBreakPtr->stackDepth == envPtr->currStackDepth-wordCount - && auxBreakPtr->expandTarget == envPtr->expandCount-expandCount) { - auxBreakPtr = NULL; - } else { - breakRange = auxBreakPtr - envPtr->exceptAuxArrayPtr; - } - - if (auxBreakPtr != NULL || auxContinuePtr != NULL) { - loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); - ExceptionRangeStarts(envPtr, loopRange); - } - - /* - * Issue the invoke itself. - */ - - switch (opcode) { - case INST_INVOKE_STK1: - TclEmitInstInt1(INST_INVOKE_STK1, arg1, envPtr); - break; - case INST_INVOKE_STK4: - TclEmitInstInt4(INST_INVOKE_STK4, arg1, envPtr); - break; - case INST_INVOKE_EXPANDED: - TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); - envPtr->expandCount--; - TclAdjustStackDepth(1 - arg1, envPtr); - break; - case INST_EVAL_STK: - TclEmitOpcode(INST_EVAL_STK, envPtr); - break; - case INST_RETURN_STK: - TclEmitOpcode(INST_RETURN_STK, envPtr); - break; - case INST_INVOKE_REPLACE: - TclEmitInstInt4(INST_INVOKE_REPLACE, arg1, envPtr); - TclEmitInt1(arg2, envPtr); - TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs */ - break; - } - - /* - * If we're generating a special wrapper exception range, we need to - * finish that up now. - */ - - if (auxBreakPtr != NULL || auxContinuePtr != NULL) { - int savedStackDepth = envPtr->currStackDepth; - int savedExpandCount = envPtr->expandCount; - JumpFixup nonTrapFixup; - - if (auxBreakPtr != NULL) { - auxBreakPtr = envPtr->exceptAuxArrayPtr + breakRange; - } - if (auxContinuePtr != NULL) { - auxContinuePtr = envPtr->exceptAuxArrayPtr + continueRange; - } - - ExceptionRangeEnds(envPtr, loopRange); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &nonTrapFixup); - - /* - * Careful! When generating these stack unwinding sequences, the depth - * of stack in the cases where they are taken is not the same as if - * the exception is not taken. - */ - - if (auxBreakPtr != NULL) { - TclAdjustStackDepth(-1, envPtr); - - ExceptionRangeTarget(envPtr, loopRange, breakOffset); - TclCleanupStackForBreakContinue(envPtr, auxBreakPtr); - TclAddLoopBreakFixup(envPtr, auxBreakPtr); - TclAdjustStackDepth(1, envPtr); - - envPtr->currStackDepth = savedStackDepth; - envPtr->expandCount = savedExpandCount; - } - - if (auxContinuePtr != NULL) { - TclAdjustStackDepth(-1, envPtr); - - ExceptionRangeTarget(envPtr, loopRange, continueOffset); - TclCleanupStackForBreakContinue(envPtr, auxContinuePtr); - TclAddLoopContinueFixup(envPtr, auxContinuePtr); - TclAdjustStackDepth(1, envPtr); - - envPtr->currStackDepth = savedStackDepth; - envPtr->expandCount = savedExpandCount; - } - - TclFinalizeLoopExceptionRange(envPtr, loopRange); - TclFixupForwardJumpToHere(envPtr, &nonTrapFixup, 127); - } - TclCheckStackDepth(depth+1-cleanup, envPtr); + /* + * TIP #280: Adjust the mapping from PC values to the per-command + * information about arguments and their line numbers. + * + * Note: We cannot simply remove an out-of-date entry and then reinsert + * with the proper PC, because then we might overwrite another entry which + * was at that location. Therefore we pull (copy + delete) all effected + * entries (beyond the fixed PC) into an array, update them there, and at + * last reinsert them all. + */ + + { + ExtCmdLoc* eclPtr = envPtr->extCmdMapPtr; + + /* A helper structure */ + + typedef struct { + int pc; + int cmd; + } MAP; + + /* + * And the helper array. At most the whole hashtable is placed into + * this. + */ + + MAP *map = (MAP*) ckalloc (sizeof(MAP) * eclPtr->litInfo.numEntries); + + Tcl_HashSearch hSearch; + Tcl_HashEntry* hPtr; + int n, k, isnew; + + /* + * Phase I: Locate the affected entries, and save them in adjusted + * form to the array. This removes them from the hash. + */ + + for (n = 0, hPtr = Tcl_FirstHashEntry(&eclPtr->litInfo, &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + + map [n].cmd = PTR2INT(Tcl_GetHashValue(hPtr)); + map [n].pc = PTR2INT(Tcl_GetHashKey (&eclPtr->litInfo,hPtr)); + + if (map[n].pc >= (jumpFixupPtr->codeOffset + 2)) { + Tcl_DeleteHashEntry(hPtr); + map [n].pc += 3; + n++; + } + } + + /* + * Phase II: Re-insert the modified entries into the hash. + */ + + for (k=0;klitInfo, INT2PTR(map[k].pc), &isnew); + Tcl_SetHashValue(hPtr, INT2PTR(map[k].cmd)); + } + + ckfree ((char *) map); + } + + return 1; /* the jump was grown */ } /* *---------------------------------------------------------------------- * @@ -4292,15 +3146,173 @@ * None. * *---------------------------------------------------------------------- */ -const void * /* == InstructionDesc* == */ +void * /* == InstructionDesc* == */ TclGetInstructionTable(void) { return &tclInstructionTable[0]; } + +/* + *-------------------------------------------------------------- + * + * RegisterAuxDataType -- + * + * This procedure is called to register a new AuxData type in the table + * of all AuxData types supported by Tcl. + * + * Results: + * None. + * + * Side effects: + * The type is registered in the AuxData type table. If there was already + * a type with the same name as in typePtr, it is replaced with the new + * type. + * + *-------------------------------------------------------------- + */ + +static void +RegisterAuxDataType( + AuxDataType *typePtr) /* Information about object type; storage must + * be statically allocated (must live forever; + * will not be deallocated). */ +{ + register Tcl_HashEntry *hPtr; + int isNew; + + Tcl_MutexLock(&tableMutex); + if (!auxDataTypeTableInitialized) { + TclInitAuxDataTypeTable(); + } + + /* + * If there's already a type with the given name, remove it. + */ + + hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typePtr->name); + if (hPtr != NULL) { + Tcl_DeleteHashEntry(hPtr); + } + + /* + * Now insert the new object type. + */ + + hPtr = Tcl_CreateHashEntry(&auxDataTypeTable, typePtr->name, &isNew); + if (isNew) { + Tcl_SetHashValue(hPtr, typePtr); + } + Tcl_MutexUnlock(&tableMutex); +} + +/* + *---------------------------------------------------------------------- + * + * TclGetAuxDataType -- + * + * This procedure looks up an Auxdata type by name. + * + * Results: + * If an AuxData type with name matching "typeName" is found, a pointer + * to its AuxDataType structure is returned; otherwise, NULL is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +AuxDataType * +TclGetAuxDataType( + char *typeName) /* Name of AuxData type to look up. */ +{ + register Tcl_HashEntry *hPtr; + AuxDataType *typePtr = NULL; + + Tcl_MutexLock(&tableMutex); + if (!auxDataTypeTableInitialized) { + TclInitAuxDataTypeTable(); + } + + hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typeName); + if (hPtr != NULL) { + typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr); + } + Tcl_MutexUnlock(&tableMutex); + + return typePtr; +} + +/* + *-------------------------------------------------------------- + * + * TclInitAuxDataTypeTable -- + * + * This procedure is invoked to perform once-only initialization of the + * AuxData type table. It also registers the AuxData types defined in + * this file. + * + * Results: + * None. + * + * Side effects: + * Initializes the table of defined AuxData types "auxDataTypeTable" with + * builtin AuxData types defined in this file. + * + *-------------------------------------------------------------- + */ + +void +TclInitAuxDataTypeTable(void) +{ + /* + * The table mutex must already be held before this routine is invoked. + */ + + auxDataTypeTableInitialized = 1; + Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS); + + /* + * There are only two AuxData type at this time, so register them here. + */ + + RegisterAuxDataType(&tclForeachInfoType); + RegisterAuxDataType(&tclJumptableInfoType); +} + +/* + *---------------------------------------------------------------------- + * + * TclFinalizeAuxDataTypeTable -- + * + * This procedure is called by Tcl_Finalize after all exit handlers have + * been run to free up storage associated with the table of AuxData + * types. This procedure is called by TclFinalizeExecution() which is + * called by Tcl_Finalize(). + * + * Results: + * None. + * + * Side effects: + * Deletes all entries in the hash table of AuxData types. + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeAuxDataTypeTable(void) +{ + Tcl_MutexLock(&tableMutex); + if (auxDataTypeTableInitialized) { + Tcl_DeleteHashTable(&auxDataTypeTable); + auxDataTypeTableInitialized = 0; + } + Tcl_MutexUnlock(&tableMutex); +} /* *---------------------------------------------------------------------- * * GetCmdLocEncodingSize -- @@ -4321,11 +3333,11 @@ GetCmdLocEncodingSize( CompileEnv *envPtr) /* Points to compilation environment structure * containing the CmdLocation structure to * encode. */ { - CmdLocation *mapPtr = envPtr->cmdMapPtr; + register 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 @@ -4333,44 +3345,44 @@ int prevCodeOffset, prevSrcOffset, i; codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0; prevCodeOffset = prevSrcOffset = 0; for (i = 0; i < numCmds; i++) { - codeDelta = mapPtr[i].codeOffset - prevCodeOffset; + codeDelta = (mapPtr[i].codeOffset - prevCodeOffset); if (codeDelta < 0) { Tcl_Panic("GetCmdLocEncodingSize: bad code offset"); } else if (codeDelta <= 127) { codeDeltaNext++; } else { - codeDeltaNext += 5; /* 1 byte for 0xFF, 4 for positive delta */ + codeDeltaNext += 5; /* 1 byte for 0xFF, 4 for positive delta */ } prevCodeOffset = mapPtr[i].codeOffset; codeLen = mapPtr[i].numCodeBytes; if (codeLen < 0) { Tcl_Panic("GetCmdLocEncodingSize: bad code length"); } else if (codeLen <= 127) { codeLengthNext++; } else { - codeLengthNext += 5;/* 1 byte for 0xFF, 4 for length */ + codeLengthNext += 5; /* 1 byte for 0xFF, 4 for length */ } - srcDelta = mapPtr[i].srcOffset - prevSrcOffset; - if ((-127 <= srcDelta) && (srcDelta <= 127) && (srcDelta != -1)) { + srcDelta = (mapPtr[i].srcOffset - prevSrcOffset); + if ((-127 <= srcDelta) && (srcDelta <= 127)) { srcDeltaNext++; } else { - srcDeltaNext += 5; /* 1 byte for 0xFF, 4 for delta */ + srcDeltaNext += 5; /* 1 byte for 0xFF, 4 for delta */ } prevSrcOffset = mapPtr[i].srcOffset; srcLen = mapPtr[i].numSrcBytes; if (srcLen < 0) { Tcl_Panic("GetCmdLocEncodingSize: bad source length"); } else if (srcLen <= 127) { srcLengthNext++; } else { - srcLengthNext += 5; /* 1 byte for 0xFF, 4 for length */ + srcLengthNext += 5; /* 1 byte for 0xFF, 4 for length */ } } return (codeDeltaNext + codeLengthNext + srcDeltaNext + srcLengthNext); } @@ -4405,24 +3417,24 @@ * 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; + register CmdLocation *mapPtr = envPtr->cmdMapPtr; int numCmds = envPtr->numCommands; - unsigned char *p = startPtr; + register unsigned char *p = startPtr; int codeDelta, codeLen, srcDelta, srcLen, prevOffset; - int i; + register int i; /* * Encode the code offset for each command as a sequence of deltas. */ codePtr->codeDeltaStart = p; prevOffset = 0; for (i = 0; i < numCmds; i++) { - codeDelta = mapPtr[i].codeOffset - prevOffset; + codeDelta = (mapPtr[i].codeOffset - prevOffset); if (codeDelta < 0) { Tcl_Panic("EncodeCmdLocMap: bad code offset"); } else if (codeDelta <= 127) { TclStoreInt1AtPtr(codeDelta, p); p++; @@ -4460,12 +3472,12 @@ */ codePtr->srcDeltaStart = p; prevOffset = 0; for (i = 0; i < numCmds; i++) { - srcDelta = mapPtr[i].srcOffset - prevOffset; - if ((-127 <= srcDelta) && (srcDelta <= 127) && (srcDelta != -1)) { + srcDelta = (mapPtr[i].srcOffset - prevOffset); + if ((-127 <= srcDelta) && (srcDelta <= 127)) { TclStoreInt1AtPtr(srcDelta, p); p++; } else { TclStoreInt1AtPtr(0xFF, p); p++; @@ -4495,10 +3507,606 @@ } } return p; } + +#ifdef TCL_COMPILE_DEBUG +/* + *---------------------------------------------------------------------- + * + * TclPrintByteCodeObj -- + * + * This procedure prints ("disassembles") the instructions of a bytecode + * object to stdout. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclPrintByteCodeObj( + Tcl_Interp *interp, /* Used only for Tcl_GetStringFromObj. */ + Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ +{ + Tcl_Obj *bufPtr = TclDisassembleByteCodeObj(objPtr); + + fprintf(stdout, "\n%s", TclGetString(bufPtr)); + Tcl_DecrRefCount(bufPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclPrintInstruction -- + * + * This procedure prints ("disassembles") one instruction from a bytecode + * object to stdout. + * + * Results: + * Returns the length in bytes of the current instruiction. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclPrintInstruction( + ByteCode *codePtr, /* Bytecode containing the instruction. */ + unsigned char *pc) /* Points to first byte of instruction. */ +{ + Tcl_Obj *bufferObj; + int numBytes; + + TclNewObj(bufferObj); + numBytes = FormatInstruction(codePtr, pc, bufferObj); + fprintf(stdout, "%s", TclGetString(bufferObj)); + Tcl_DecrRefCount(bufferObj); + return numBytes; +} + +/* + *---------------------------------------------------------------------- + * + * TclPrintObject -- + * + * This procedure prints up to a specified number of characters from the + * argument Tcl object's string representation to a specified file. + * + * Results: + * None. + * + * Side effects: + * Outputs characters to the specified file. + * + *---------------------------------------------------------------------- + */ + +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 = Tcl_GetStringFromObj(objPtr, &length); + TclPrintSource(outFile, bytes, TclMin(length, maxChars)); +} + +/* + *---------------------------------------------------------------------- + * + * TclPrintSource -- + * + * This procedure prints up to a specified number of characters from the + * argument string to a specified file. It tries to produce legible + * output by adding backslashes as necessary. + * + * Results: + * None. + * + * Side effects: + * Outputs characters to the specified file. + * + *---------------------------------------------------------------------- + */ + +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); +} +#endif /* TCL_COMPILE_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * TclDisassembleByteCodeObj -- + * + * Given an object which is of bytecode type, return a disassembled + * version of the bytecode (in a new refcount 0 object). No guarantees + * are made about the details of the contents of the result. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclDisassembleByteCodeObj( + Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ +{ + ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; + unsigned char *codeStart, *codeLimit, *pc; + unsigned char *codeDeltaNext, *codeLengthNext; + unsigned char *srcDeltaNext, *srcLengthNext; + int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i; + Interp *iPtr = (Interp *) *codePtr->interpHandle; + Tcl_Obj *bufferObj; + char ptrBuf1[20], ptrBuf2[20]; + + TclNewObj(bufferObj); + if (codePtr->refCount <= 0) { + return bufferObj; /* Already freed. */ + } + + codeStart = codePtr->codeStart; + codeLimit = (codeStart + codePtr->numCodeBytes); + numCmds = codePtr->numCommands; + + /* + * Print header lines describing the ByteCode. + */ + + sprintf(ptrBuf1, "%p", codePtr); + sprintf(ptrBuf2, "%p", iPtr); + Tcl_AppendPrintfToObj(bufferObj, + "ByteCode 0x%s, refCt %u, epoch %u, interp 0x%s (epoch %u)\n", + ptrBuf1, codePtr->refCount, codePtr->compileEpoch, ptrBuf2, + iPtr->compileEpoch); + Tcl_AppendToObj(bufferObj, " Source ", -1); + PrintSourceToObj(bufferObj, codePtr->source, + TclMin(codePtr->numSrcBytes, 55)); + 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 + codePtr->numSrcBytes? + codePtr->structureSize/(float)codePtr->numSrcBytes : +#endif + 0.0); + +#ifdef TCL_COMPILE_STATS + Tcl_AppendPrintfToObj(bufferObj, + " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", + (unsigned long) codePtr->structureSize, + (unsigned long) (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)), + codePtr->numCodeBytes, + (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 the ByteCode is the compiled body of a Tcl procedure, print + * information about that procedure. Note that we don't know the + * procedure's name since ByteCode's can be shared among procedures. + */ + + if (codePtr->procPtr != NULL) { + Proc *procPtr = codePtr->procPtr; + int numCompiledLocals = procPtr->numCompiledLocals; + + sprintf(ptrBuf1, "%p", procPtr); + Tcl_AppendPrintfToObj(bufferObj, + " Proc 0x%s, refCt %d, args %d, compiled locals %d\n", + ptrBuf1, procPtr->refCount, procPtr->numArgs, + numCompiledLocals); + if (numCompiledLocals > 0) { + CompiledLocal *localPtr = procPtr->firstLocalPtr; + + for (i = 0; i < numCompiledLocals; i++) { + Tcl_AppendPrintfToObj(bufferObj, + " slot %d%s%s%s%s%s%s", i, + (localPtr->flags & (VAR_ARRAY|VAR_LINK)) ? "" : ", scalar", + (localPtr->flags & VAR_ARRAY) ? ", array" : "", + (localPtr->flags & VAR_LINK) ? ", link" : "", + (localPtr->flags & VAR_ARGUMENT) ? ", arg" : "", + (localPtr->flags & VAR_TEMPORARY) ? ", temp" : "", + (localPtr->flags & VAR_RESOLVED) ? ", resolved" : ""); + if (TclIsVarTemporary(localPtr)) { + Tcl_AppendToObj(bufferObj, "\n", -1); + } else { + Tcl_AppendPrintfToObj(bufferObj, ", \"%s\"\n", + localPtr->name); + } + localPtr = localPtr->nextPtr; + } + } + } + + /* + * Print the ExceptionRange array. + */ + + if (codePtr->numExceptRanges > 0) { + Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %d, depth %d:\n", + codePtr->numExceptRanges, codePtr->maxExceptDepth); + for (i = 0; i < codePtr->numExceptRanges; i++) { + ExceptionRange *rangePtr = &(codePtr->exceptArrayPtr[i]); + + Tcl_AppendPrintfToObj(bufferObj, + " %d: level %d, %s, pc %d-%d, ", + i, rangePtr->nestingLevel, + (rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"), + rangePtr->codeOffset, + (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); + switch (rangePtr->type) { + case LOOP_EXCEPTION_RANGE: + Tcl_AppendPrintfToObj(bufferObj, "continue %d, break %d\n", + rangePtr->continueOffset, rangePtr->breakOffset); + break; + case CATCH_EXCEPTION_RANGE: + Tcl_AppendPrintfToObj(bufferObj, "catch %d\n", + rangePtr->catchOffset); + break; + default: + Tcl_Panic("TclDisassembleByteCodeObj: bad ExceptionRange type %d", + rangePtr->type); + } + } + } + + /* + * If there were no commands (e.g., an expression or an empty string was + * compiled), just print all instructions and return. + */ + + if (numCmds == 0) { + pc = codeStart; + while (pc < codeLimit) { + Tcl_AppendToObj(bufferObj, " ", -1); + pc += FormatInstruction(codePtr, pc, bufferObj); + } + return bufferObj; + } + + /* + * Print table showing the code offset, source offset, and source length + * for each command. These are encoded as a sequence of bytes. + */ + + 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++; + } + + Tcl_AppendPrintfToObj(bufferObj, "%s%4d: pc %d-%d, src %d-%d", + ((i % 2)? " " : "\n "), + (i+1), codeOffset, (codeOffset + codeLen - 1), + srcOffset, (srcOffset + srcLen - 1)); + } + if (numCmds > 0) { + Tcl_AppendToObj(bufferObj, "\n", -1); + } + + /* + * Print each instruction. If the instruction corresponds to the start of + * a command, print the command's source. Note that we don't need the code + * length here. + */ + + 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++; + } + + /* + * Print instructions before command i. + */ + + while ((pc-codeStart) < codeOffset) { + Tcl_AppendToObj(bufferObj, " ", -1); + pc += FormatInstruction(codePtr, pc, bufferObj); + } + + Tcl_AppendPrintfToObj(bufferObj, " Command %d: ", i+1); + PrintSourceToObj(bufferObj, (codePtr->source + srcOffset), + TclMin(srcLen, 55)); + Tcl_AppendToObj(bufferObj, "\n", -1); + } + if (pc < codeLimit) { + /* + * Print instructions after the last command. + */ + + while (pc < codeLimit) { + Tcl_AppendToObj(bufferObj, " ", -1); + pc += FormatInstruction(codePtr, pc, bufferObj); + } + } + return bufferObj; +} + +/* + *---------------------------------------------------------------------- + * + * FormatInstruction -- + * + * Appends a representation of a bytecode instruction to a Tcl_Obj. + * + *---------------------------------------------------------------------- + */ + +static int +FormatInstruction( + ByteCode *codePtr, /* Bytecode containing the instruction. */ + 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; + register 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. */ + char *suffixSrc = NULL; + Tcl_Obj *suffixObj = NULL; + AuxData *auxPtr = NULL; + + suffixBuffer[0] = '\0'; + Tcl_AppendPrintfToObj(bufferObj, "(%u) %s ", pcOffset, instDesc->name); + for (i = 0; i < instDesc->numOperands; i++) { + switch (instDesc->opTypes[i]) { + case OPERAND_INT1: + opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++; + if (opCode == INST_JUMP1 || opCode == INST_JUMP_TRUE1 + || opCode == INST_JUMP_FALSE1) { + sprintf(suffixBuffer, "pc %u", pcOffset+opnd); + } + Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); + break; + case OPERAND_INT4: + opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; + if (opCode == INST_JUMP4 || opCode == INST_JUMP_TRUE4 + || opCode == INST_JUMP_FALSE4) { + sprintf(suffixBuffer, "pc %u", pcOffset+opnd); + } else if (opCode == INST_START_CMD) { + sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd); + } + Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); + break; + case OPERAND_UINT1: + opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; + if (opCode == INST_PUSH1) { + suffixObj = codePtr->objArrayPtr[opnd]; + } + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); + break; + case OPERAND_AUX4: + case OPERAND_UINT4: + opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; + if (opCode == INST_PUSH4) { + suffixObj = codePtr->objArrayPtr[opnd]; + } else if (opCode == INST_START_CMD && opnd != 1) { + sprintf(suffixBuffer+strlen(suffixBuffer), + ", %u cmds start here", opnd); + } + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); + if (instDesc->opTypes[i] == OPERAND_AUX4) { + 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) { + Tcl_AppendPrintfToObj(bufferObj, "end "); + } else { + Tcl_AppendPrintfToObj(bufferObj, "end-%d ", -2-opnd); + } + break; + case OPERAND_LVT1: + opnd = TclGetUInt1AtPtr(pc+numBytes); + numBytes++; + goto printLVTindex; + case OPERAND_LVT4: + opnd = TclGetUInt4AtPtr(pc+numBytes); + numBytes += 4; + printLVTindex: + if (localPtr != NULL) { + if (opnd >= localCt) { + Tcl_Panic("FormatInstruction: bad local var index %u (%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_NONE: + default: + break; + } + } + if (suffixObj) { + char *bytes; + int length; + + Tcl_AppendToObj(bufferObj, "\t# ", -1); + bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length); + PrintSourceToObj(bufferObj, bytes, TclMin(length, 40)); + } else if (suffixBuffer[0]) { + Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer); + if (suffixSrc) { + PrintSourceToObj(bufferObj, suffixSrc, 40); + } + } + Tcl_AppendToObj(bufferObj, "\n", -1); + if (auxPtr && auxPtr->type->printProc) { + Tcl_AppendToObj(bufferObj, "\t\t[", -1); + auxPtr->type->printProc(auxPtr->clientData, bufferObj, codePtr, + pcOffset); + Tcl_AppendToObj(bufferObj, "]\n", -1); + } + return numBytes; +} + +/* + *---------------------------------------------------------------------- + * + * PrintSourceToObj -- + * + * Appends a quoted representation of a string to a Tcl_Obj. + * + *---------------------------------------------------------------------- + */ + +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. */ +{ + register const char *p; + register int i = 0; + + if (stringPtr == NULL) { + Tcl_AppendToObj(appendObj, "\"\"", -1); + return; + } + + Tcl_AppendToObj(appendObj, "\"", -1); + p = stringPtr; + for (; (*p != '\0') && (i < maxChars); p++, i++) { + switch (*p) { + case '"': + Tcl_AppendToObj(appendObj, "\\\"", -1); + continue; + case '\f': + Tcl_AppendToObj(appendObj, "\\f", -1); + continue; + case '\n': + Tcl_AppendToObj(appendObj, "\\n", -1); + continue; + case '\r': + Tcl_AppendToObj(appendObj, "\\r", -1); + continue; + case '\t': + Tcl_AppendToObj(appendObj, "\\t", -1); + continue; + case '\v': + Tcl_AppendToObj(appendObj, "\\v", -1); + continue; + default: + Tcl_AppendPrintfToObj(appendObj, "%c", *p); + continue; + } + } + Tcl_AppendToObj(appendObj, "\"", -1); +} #ifdef TCL_COMPILE_STATS /* *---------------------------------------------------------------------- * @@ -4523,11 +4131,11 @@ RecordByteCodeStats( ByteCode *codePtr) /* Points to ByteCode structure with info * to add to accumulated statistics. */ { Interp *iPtr = (Interp *) *codePtr->interpHandle; - ByteCodeStats *statsPtr; + register ByteCodeStats *statsPtr; if (iPtr == NULL) { /* Avoid segfaulting in case we're called in a deleted interp */ return; } @@ -4538,11 +4146,11 @@ statsPtr->totalByteCodeBytes += (double) codePtr->structureSize; statsPtr->currentSrcBytes += (double) codePtr->numSrcBytes; statsPtr->currentByteCodeBytes += (double) codePtr->structureSize; statsPtr->srcCount[TclLog2(codePtr->numSrcBytes)]++; - statsPtr->byteCodeCount[TclLog2((int) codePtr->structureSize)]++; + statsPtr->byteCodeCount[TclLog2((int)(codePtr->structureSize))]++; statsPtr->currentInstBytes += (double) codePtr->numCodeBytes; statsPtr->currentLitBytes += (double) codePtr->numLitObjects * sizeof(Tcl_Obj *); statsPtr->currentExceptBytes += (double) @@ -4556,8 +4164,7 @@ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 - * tab-width: 8 * End: */ Index: generic/tclCompile.h ================================================================== --- generic/tclCompile.h +++ generic/tclCompile.h @@ -46,17 +46,10 @@ * This variable is linked to the Tcl variable "tcl_traceExec". */ MODULE_SCOPE int tclTraceExec; #endif - -/* - * The type of lambda expressions. Note that every lambda will *always* have a - * string representation. - */ - -MODULE_SCOPE const Tcl_ObjType tclLambdaType; /* *------------------------------------------------------------------------ * Data structures related to compilation. *------------------------------------------------------------------------ @@ -85,11 +78,11 @@ 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 { +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 @@ -104,67 +97,19 @@ * command. */ int catchOffset; /* If a CATCH_EXCEPTION_RANGE, the target PC * offset for any "exception" in range. */ } ExceptionRange; -/* - * Auxiliary data used when issuing (currently just loop) exception ranges, - * but which is not required during execution. - */ - -typedef struct ExceptionAux { - int supportsContinue; /* Whether this exception range will have a - * continueOffset created for it; if it is a - * loop exception range that *doesn't* have - * one (see [for] next-clause) then we must - * not pick up the range when scanning for a - * target to continue to. */ - int stackDepth; /* The stack depth at the point where the - * exception range was created. This is used - * to calculate the number of POPs required to - * restore the stack to its prior state. */ - int expandTarget; /* The number of expansions expected on the - * auxData stack at the time the loop starts; - * we can't currently discard them except by - * doing INST_INVOKE_EXPANDED; this is a known - * problem. */ - int expandTargetDepth; /* The stack depth expected at the outermost - * expansion within the loop. Not meaningful - * if there are no open expansions between the - * looping level and the point of jump - * issue. */ - int numBreakTargets; /* The number of [break]s that want to be - * targeted to the place where this loop - * exception will be bound to. */ - unsigned int *breakTargets; /* The offsets of the INST_JUMP4 instructions - * issued by the [break]s that we must - * update. Note that resizing a jump (via - * TclFixupForwardJump) can cause the contents - * of this array to be updated. When - * numBreakTargets==0, this is NULL. */ - int allocBreakTargets; /* The size of the breakTargets array. */ - int numContinueTargets; /* The number of [continue]s that want to be - * targeted to the place where this loop - * exception will be bound to. */ - unsigned int *continueTargets; /* The offsets of the INST_JUMP4 instructions - * issued by the [continue]s that we must - * update. Note that resizing a jump (via - * TclFixupForwardJump) can cause the contents - * of this array to be updated. When - * numContinueTargets==0, this is NULL. */ - int allocContinueTargets; /* The size of the continueTargets array. */ -} ExceptionAux; - /* * Structure used to map between instruction pc and source locations. It * defines for each compiled Tcl command its code's starting offset and its * source's starting offset and length. Note that the code offset increases * monotonically: that is, the table is sorted in code offset order. The * source offset is not monotonic. */ -typedef struct { +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; @@ -178,30 +123,38 @@ * 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 { - size_t srcOffset; /* Command location to find the entry. */ - int nline; /* Number of words in the command */ +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 + int** next; /* Transient information used by the compiler * for tracking of hidden continuation * lines. */ } ECL; -typedef struct { +typedef struct ExtCmdLoc { int type; /* Context type. */ - int start; /* Starting line for compiled script. Needed + int start; /* Starting line for compiled script. Needed * for the extended recompile check in - * tclCompileObj. */ + * TclCompEvalObj. */ + Tcl_Obj *path; /* Path of the sourced file the command is * in. */ ECL *loc; /* Command word locations (lines). */ int nloc; /* Number of allocated entries in 'loc'. */ int nuloc; /* Number of used entries in 'loc'. */ + Tcl_HashTable litInfo; /* Indexed by bytecode 'PC', to have the + * information accessible per command and + * argument, not per whole bytecode. Value is + * index of command in 'loc', giving us the + * literals to associate with line information + * as command argument, see + * TclArgumentBCEnter() */ } ExtCmdLoc; /* * CompileProcs need the ability to record information during compilation that * can be used by bytecode instructions during execution. The AuxData @@ -215,13 +168,13 @@ * to duplicate or free this auxiliary data when the containing ByteCode * objects are duplicated and freed. Pointers to these procedures are kept in * the AuxData structure. */ -typedef void *(AuxDataDupProc) (void *clientData); -typedef void (AuxDataFreeProc) (void *clientData); -typedef void (AuxDataPrintProc)(void *clientData, +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 @@ -229,11 +182,11 @@ * outside of the TCL core to manipulate (in a limited fashion!) AuxData; for * example, it makes it possible to pickle and unpickle AuxData structs. */ typedef struct AuxDataType { - const char *name; /* The name of the type. Types can be + char *name; /* The name of the type. Types can be * registered and found by name */ AuxDataDupProc *dupProc; /* Callback procedure to invoke when the aux * data is duplicated (e.g., when the ByteCode * structure containing the aux data is * duplicated). NULL means just copy the @@ -243,32 +196,22 @@ * data is freed. NULL means no proc need be * called. */ AuxDataPrintProc *printProc;/* Callback function to invoke when printing * the aux data as part of debugging. NULL * means that the data can't be printed. */ - AuxDataPrintProc *disassembleProc; - /* Callback function to invoke when doing a - * disassembly of the aux data (like the - * printProc, except that the output is - * intended to be script-readable). The - * appendObj argument should be filled in with - * a descriptive dictionary; it will start out - * with "name" mapped to the content of the - * name field. NULL means that the printProc - * should be used instead. */ } AuxDataType; /* * The definition of the AuxData structure that holds information created * during compilation by CompileProcs and used by instructions during * execution. */ typedef struct AuxData { - const AuxDataType *type; /* Pointer to the AuxData type associated with + AuxDataType *type; /* Pointer to the AuxData type associated with * this ClientData. */ - void *clientData; /* The compilation data itself. */ + ClientData clientData; /* The compilation data itself. */ } AuxData; /* * Structure defining the compilation environment. After compilation, fields * describing bytecode instructions are copied out into the more compact @@ -331,15 +274,10 @@ * current range's array entry. */ int exceptArrayEnd; /* Index after the last ExceptionRange array * entry. */ int mallocedExceptArray; /* 1 if ExceptionRange array was expanded and * exceptArrayPtr points in heap, else 0. */ - ExceptionAux *exceptAuxArrayPtr; - /* Array of information used to restore the - * state when processing BREAK/CONTINUE - * exceptions. Must be the same size as the - * exceptArrayPtr. */ CmdLocation *cmdMapPtr; /* Points to start of CmdLocation array. * numCommands is the index of the next entry * to use; (numCommands-1) is the entry index * for the last command. */ int cmdMapEnd; /* Index after last CmdLocation entry. */ @@ -357,13 +295,10 @@ /* Initial storage for code. */ LiteralEntry staticLiteralSpace[COMPILEENV_INIT_NUM_OBJECTS]; /* Initial storage of LiteralEntry array. */ ExceptionRange staticExceptArraySpace[COMPILEENV_INIT_EXCEPT_RANGES]; /* Initial ExceptionRange array storage. */ - ExceptionAux staticExAuxArraySpace[COMPILEENV_INIT_EXCEPT_RANGES]; - /* Initial static except auxiliary info array - * storage. */ CmdLocation staticCmdMapSpace[COMPILEENV_INIT_CMD_MAP_SIZE]; /* Initial storage for cmd location map. */ AuxData staticAuxDataArraySpace[COMPILEENV_INIT_AUX_DATA_SIZE]; /* Initial storage for aux data array. */ /* TIP #280 */ @@ -373,20 +308,18 @@ * invoking context, then the line of the * command currently compiled. */ int atCmdStart; /* Flag to say whether an INST_START_CMD * should be issued; they should never be * issued repeatedly, as that is significantly - * inefficient. If set to 2, that instruction - * should not be issued at all (by the generic - * part of the command compiler). */ - int expandCount; /* Number of INST_EXPAND_START instructions - * encountered that have not yet been paired - * with a corresponding - * INST_INVOKE_EXPANDED. */ - int *clNext; /* If not NULL, it refers to the next slot in - * clLoc to check for an invisible - * continuation line. */ + * inefficient. */ + ContLineLoc* clLoc; /* If not NULL, the table holding the + * locations of the invisible continuation + * lines in the input script, to adjust the + * line counter. */ + int* clNext; /* If not NULL, it refers to the next slot in + * clLoc to check for an invisible + * continuation line. */ } CompileEnv; /* * The structure defining the bytecode instructions resulting from compiling a * Tcl script. Note that this structure is variable length: a single heap @@ -407,31 +340,29 @@ * applied yet: this is indicated by the TCL_BYTECODE_RESOLVE_VARS flag. */ #define TCL_BYTECODE_RESOLVE_VARS 0x0002 -#define TCL_BYTECODE_RECOMPILE 0x0004 - 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. */ - size_t compileEpoch; /* Value of iPtr->compileEpoch when this + 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. */ - size_t nsEpoch; /* Value of nsPtr->resolverEpoch when this + int nsEpoch; /* Value of nsPtr->resolverEpoch when this * ByteCode was compiled. Used to invalidate * code when new namespace resolution rules * are put into effect. */ - size_t refCount; /* Reference count: set 1 when created plus 1 + 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 @@ -504,332 +435,240 @@ * that encode the length of each command's * source. The encoding is the same as for * code deltas. Source lengths are always * positive. This sequence is just after the * last byte in the source delta sequence. */ - LocalCache *localCachePtr; /* Pointer to the start of the cached variable + LocalCache *localCachePtr; /* Pointer to the start of the cached variable * names and initialisation data for local * variables. */ #ifdef TCL_COMPILE_STATS Tcl_Time createTime; /* Absolute time when the ByteCode was * created. */ #endif /* TCL_COMPILE_STATS */ } ByteCode; - -#define ByteCodeSetIntRep(objPtr, typePtr, codePtr) \ - do { \ - Tcl_ObjIntRep ir; \ - ir.twoPtrValue.ptr1 = (codePtr); \ - ir.twoPtrValue.ptr2 = NULL; \ - Tcl_StoreIntRep((objPtr), (typePtr), &ir); \ - } while (0) - - - -#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_BITOR) must match the entries in the array operatorStrings in + * INST_LOR) must match the entries in the array operatorStrings in * tclExecute.c. */ -enum TclInstruction { - /* Opcodes 0 to 9 */ - INST_DONE = 0, - INST_PUSH1, - INST_PUSH4, - INST_POP, - INST_DUP, - INST_STR_CONCAT1, - INST_INVOKE_STK1, - INST_INVOKE_STK4, - INST_EVAL_STK, - INST_EXPR_STK, - - /* Opcodes 10 to 23 */ - INST_LOAD_SCALAR1, - INST_LOAD_SCALAR4, - INST_LOAD_SCALAR_STK, - INST_LOAD_ARRAY1, - INST_LOAD_ARRAY4, - INST_LOAD_ARRAY_STK, - INST_LOAD_STK, - INST_STORE_SCALAR1, - INST_STORE_SCALAR4, - INST_STORE_SCALAR_STK, - INST_STORE_ARRAY1, - INST_STORE_ARRAY4, - INST_STORE_ARRAY_STK, - INST_STORE_STK, - - /* Opcodes 24 to 33 */ - INST_INCR_SCALAR1, - INST_INCR_SCALAR_STK, - INST_INCR_ARRAY1, - INST_INCR_ARRAY_STK, - INST_INCR_STK, - INST_INCR_SCALAR1_IMM, - INST_INCR_SCALAR_STK_IMM, - INST_INCR_ARRAY1_IMM, - INST_INCR_ARRAY_STK_IMM, - INST_INCR_STK_IMM, - - /* Opcodes 34 to 39 */ - INST_JUMP1, - INST_JUMP4, - INST_JUMP_TRUE1, - INST_JUMP_TRUE4, - INST_JUMP_FALSE1, - INST_JUMP_FALSE4, - - /* Opcodes 42 to 64 */ - INST_BITOR, - INST_BITXOR, - INST_BITAND, - INST_EQ, - INST_NEQ, - INST_LT, - INST_GT, - INST_LE, - INST_GE, - INST_LSHIFT, - INST_RSHIFT, - INST_ADD, - INST_SUB, - INST_MULT, - INST_DIV, - INST_MOD, - INST_UPLUS, - INST_UMINUS, - INST_BITNOT, - INST_LNOT, - INST_TRY_CVT_TO_NUMERIC, - - /* Opcodes 65 to 66 */ - INST_BREAK, - INST_CONTINUE, - - /* Opcodes 69 to 72 */ - INST_BEGIN_CATCH4, - INST_END_CATCH, - INST_PUSH_RESULT, - INST_PUSH_RETURN_CODE, - - /* Opcodes 73 to 78 */ - INST_STR_EQ, - INST_STR_NEQ, - INST_STR_CMP, - INST_STR_LEN, - INST_STR_INDEX, - INST_STR_MATCH, - - /* Opcodes 79 to 81 */ - INST_LIST, - INST_LIST_INDEX, - INST_LIST_LENGTH, - - /* Opcodes 82 to 87 */ - INST_APPEND_SCALAR1, - INST_APPEND_SCALAR4, - INST_APPEND_ARRAY1, - INST_APPEND_ARRAY4, - INST_APPEND_ARRAY_STK, - INST_APPEND_STK, - - /* Opcodes 88 to 93 */ - INST_LAPPEND_SCALAR1, - INST_LAPPEND_SCALAR4, - INST_LAPPEND_ARRAY1, - INST_LAPPEND_ARRAY4, - INST_LAPPEND_ARRAY_STK, - INST_LAPPEND_STK, - - /* TIP #22 - LINDEX operator with flat arg list */ - INST_LIST_INDEX_MULTI, - - /* - * TIP #33 - 'lset' command. Code gen also required a Forth-like - * OVER operation. - */ - INST_OVER, - INST_LSET_LIST, - INST_LSET_FLAT, - - /* TIP#90 - 'return' command. */ - INST_RETURN_IMM, - - /* TIP#123 - exponentiation operator. */ - INST_EXPON, - - /* TIP #157 - {*}... (word expansion) language syntax support. */ - INST_EXPAND_START, - INST_EXPAND_STKTOP, - INST_INVOKE_EXPANDED, - - /* - * TIP #57 - 'lassign' command. Code generation requires immediate - * LINDEX and LRANGE operators. - */ - INST_LIST_INDEX_IMM, - INST_LIST_RANGE_IMM, - INST_START_CMD, - INST_LIST_IN, - INST_LIST_NOT_IN, - INST_PUSH_RETURN_OPTIONS, - INST_RETURN_STK, - - /* - * Dictionary (TIP#111) related commands. - */ - INST_DICT_GET, - INST_DICT_SET, - INST_DICT_UNSET, - INST_DICT_INCR_IMM, - INST_DICT_APPEND, - INST_DICT_LAPPEND, - INST_DICT_FIRST, - INST_DICT_NEXT, - INST_DICT_UPDATE_START, - INST_DICT_UPDATE_END, - - /* - * Instruction to support jumps defined by tables (instead of the classic - * [switch] technique of chained comparisons). - */ - INST_JUMP_TABLE, - - /* - * Instructions to support compilation of global, variable, upvar and - * [namespace upvar]. - */ - INST_UPVAR, - INST_NSUPVAR, - INST_VARIABLE, - - /* Instruction to support compiling syntax error to bytecode */ - INST_SYNTAX, - - /* Instruction to reverse N items on top of stack */ - INST_REVERSE, - - /* regexp instruction */ - INST_REGEXP, - - /* For [info exists] compilation */ - INST_EXIST_SCALAR, - INST_EXIST_ARRAY, - INST_EXIST_ARRAY_STK, - INST_EXIST_STK, - - /* For [subst] compilation */ - INST_NOP, - INST_RETURN_CODE_BRANCH, - - /* For [unset] compilation */ - INST_UNSET_SCALAR, - INST_UNSET_ARRAY, - INST_UNSET_ARRAY_STK, - INST_UNSET_STK, - - /* For [dict with], [dict exists], [dict create] and [dict merge] */ - INST_DICT_EXPAND, - INST_DICT_RECOMBINE_STK, - INST_DICT_RECOMBINE_IMM, - INST_DICT_EXISTS, - INST_DICT_VERIFY, - - /* For [string map] and [regsub] compilation */ - INST_STR_MAP, - INST_STR_FIND, - INST_STR_FIND_LAST, - INST_STR_RANGE_IMM, - INST_STR_RANGE, - - /* For operations to do with coroutines and other NRE-manipulators */ - INST_YIELD, - INST_COROUTINE_NAME, - INST_TAILCALL, - - /* For compilation of basic information operations */ - INST_NS_CURRENT, - INST_INFO_LEVEL_NUM, - INST_INFO_LEVEL_ARGS, - INST_RESOLVE_COMMAND, - - /* For compilation relating to TclOO */ - INST_TCLOO_SELF, - INST_TCLOO_CLASS, - INST_TCLOO_NS, - INST_TCLOO_IS_OBJECT, - - /* For compilation of [array] subcommands */ - INST_ARRAY_EXISTS_STK, - INST_ARRAY_EXISTS_IMM, - INST_ARRAY_MAKE_STK, - INST_ARRAY_MAKE_IMM, - - INST_INVOKE_REPLACE, - - INST_LIST_CONCAT, - - INST_EXPAND_DROP, - - /* New foreach implementation */ - INST_FOREACH_START, - INST_FOREACH_STEP, - INST_FOREACH_END, - INST_LMAP_COLLECT, - - /* For compilation of [string trim] and related */ - INST_STR_TRIM, - INST_STR_TRIM_LEFT, - INST_STR_TRIM_RIGHT, - - INST_CONCAT_STK, - - INST_STR_UPPER, - INST_STR_LOWER, - INST_STR_TITLE, - INST_STR_REPLACE, - - INST_ORIGIN_COMMAND, - - INST_TCLOO_NEXT, - INST_TCLOO_NEXT_CLASS, - - INST_YIELD_TO_INVOKE, - - INST_NUM_TYPE, - INST_TRY_CVT_TO_BOOLEAN, - INST_STR_CLASS, - - INST_LAPPEND_LIST, - INST_LAPPEND_LIST_ARRAY, - INST_LAPPEND_LIST_ARRAY_STK, - INST_LAPPEND_LIST_STK, - - INST_CLOCK_READ, - - INST_DICT_GET_DEF, - - /* TIP 461 */ - INST_STR_LT, - INST_STR_GT, - INST_STR_LE, - INST_STR_GE, - - /* The last opcode */ - LAST_INST_OPCODE -}; +/* 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_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 +#define INST_FOREACH_STEP4 68 + +/* 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 + +/* The last opcode */ +#define LAST_INST_OPCODE 131 /* * 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 @@ -850,24 +689,17 @@ * integer, but displayed differently.) */ OPERAND_LVT1, /* One byte unsigned index into the local * variable table. */ OPERAND_LVT4, /* Four byte unsigned index into the local * variable table. */ - OPERAND_AUX4, /* Four byte unsigned index into the aux data + OPERAND_AUX4 /* Four byte unsigned index into the aux data * table. */ - OPERAND_OFFSET1, /* One byte signed jump offset. */ - OPERAND_OFFSET4, /* Four byte signed jump offset. */ - OPERAND_LIT1, /* One byte unsigned index into table of - * literals. */ - 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. */ - size_t numBytes; /* Total number of bytes for instruction. */ + 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). */ @@ -874,45 +706,11 @@ int numOperands; /* Number of operands. */ InstOperandType opTypes[MAX_INSTRUCTION_OPERANDS]; /* The type of each operand. */ } InstructionDesc; -MODULE_SCOPE InstructionDesc const tclInstructionTable[]; - -/* - * Constants used by INST_STRING_CLASS to indicate character classes. These - * correspond closely by name with what [string is] can support, but there is - * no requirement to keep the values the same. - */ - -typedef enum InstStringClassType { - STR_CLASS_ALNUM, /* Unicode alphabet or digit characters. */ - STR_CLASS_ALPHA, /* Unicode alphabet characters. */ - STR_CLASS_ASCII, /* Characters in range U+000000..U+00007F. */ - STR_CLASS_CONTROL, /* Unicode control characters. */ - STR_CLASS_DIGIT, /* Unicode digit characters. */ - STR_CLASS_GRAPH, /* Unicode printing characters, excluding - * space. */ - STR_CLASS_LOWER, /* Unicode lower-case alphabet characters. */ - STR_CLASS_PRINT, /* Unicode printing characters, including - * spaces. */ - STR_CLASS_PUNCT, /* Unicode punctuation characters. */ - STR_CLASS_SPACE, /* Unicode space characters. */ - STR_CLASS_UPPER, /* Unicode upper-case alphabet characters. */ - 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[]; +MODULE_SCOPE InstructionDesc tclInstructionTable[]; /* * Compilation of some Tcl constructs such as if commands and the logical or * (||) and logical and (&&) operators in expressions requires the generation * of forward jumps. Since the PC target of these jumps isn't known when the @@ -931,11 +729,11 @@ TCL_FALSE_JUMP } TclJumpType; typedef struct JumpFixup { TclJumpType jumpType; /* Indicates the kind of jump. */ - unsigned int codeOffset; /* Offset of the first byte of the one-byte + int codeOffset; /* Offset of the first byte of the one-byte * forward jump's code. */ int cmdIndex; /* Index of the first command after the one * for which the jump was emitted. Used to * update the code offsets for subsequent * commands if the two-byte jump at jumpPc @@ -967,11 +765,11 @@ * only scalar variables are supported for inline-compiled foreach loops. */ typedef struct ForeachVarList { int numVars; /* The number of variables in the list. */ - int varIndexes[TCLFLEXARRAY];/* An array of the indexes ("slot numbers") + int varIndexes[1]; /* An array of the indexes ("slot numbers") * for each variable in the procedure's array * of local variables. Only scalar variables * are supported. The actual size of this * field will be large enough to numVars * indexes. THIS MUST BE THE LAST FIELD IN THE @@ -991,16 +789,18 @@ * used to point to a value list. */ int loopCtTemp; /* Index of temp var in a proc frame holding * the loop's iteration count. Used to * determine next value list element to assign * each loop var. */ - ForeachVarList *varLists[TCLFLEXARRAY];/* An array of pointers to ForeachVarList + ForeachVarList *varLists[1];/* An array of pointers to ForeachVarList * structures describing each var list. The * actual size of this field will be large * enough to numVars indexes. THIS MUST BE THE * LAST FIELD IN THE STRUCTURE! */ } ForeachInfo; + +MODULE_SCOPE AuxDataType tclForeachInfoType; /* * Structure used to hold information about a switch command that is needed * during program execution. These structures are stored in CompileEnv and * ByteCode structures as auxiliary data. @@ -1009,37 +809,36 @@ typedef struct JumptableInfo { Tcl_HashTable hashTable; /* Hash that maps strings to signed ints (PC * offsets). */ } JumptableInfo; -MODULE_SCOPE const AuxDataType tclJumptableInfoType; - -#define JUMPTABLEINFO(envPtr, index) \ - ((JumptableInfo*)((envPtr)->auxDataArrayPtr[TclGetUInt4AtPtr(index)].clientData)) +MODULE_SCOPE AuxDataType tclJumptableInfoType; /* * 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 { - size_t length; /* Size of array */ - int varIndices[TCLFLEXARRAY]; /* Array of variable indices to manage when + 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; +MODULE_SCOPE AuxDataType tclDictUpdateInfoType; + /* * ClientData type used by the math operator commands. */ typedef struct { - const char *op; /* Do not call it 'operator': C++ reserved */ + const char *op; /* Do not call it 'operator': C++ reserved */ const char *expected; union { int numArgs; int identity; } i; @@ -1049,177 +848,169 @@ *---------------------------------------------------------------- * Procedures exported by tclBasic.c to be used within the engine. *---------------------------------------------------------------- */ -MODULE_SCOPE Tcl_ObjCmdProc TclNRInterpCoroutine; - +MODULE_SCOPE int TclEvalObjvInternal(Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[], + CONST char *command, int length, int flags); /* *---------------------------------------------------------------- * Procedures exported by the engine to be used by tclBasic.c *---------------------------------------------------------------- */ MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr, const CmdFrame *invoker, int word); + +MODULE_SCOPE int TclCompEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + const CmdFrame *invoker, int word); /* *---------------------------------------------------------------- * Procedures shared among Tcl bytecode compilation and execution modules but * not used outside: *---------------------------------------------------------------- */ -MODULE_SCOPE int TclAttemptCompileProc(Tcl_Interp *interp, - Tcl_Parse *parsePtr, int depth, Command *cmdPtr, - CompileEnv *envPtr); -MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr, - ExceptionAux *auxPtr); +MODULE_SCOPE void TclCleanupByteCode(ByteCode *codePtr); MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, CompileEnv *envPtr); -MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, const char *script, - size_t numBytes, CompileEnv *envPtr, int optimize); +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, size_t numWords, - CompileEnv *envPtr); MODULE_SCOPE void TclCompileScript(Tcl_Interp *interp, - const char *script, size_t numBytes, + 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(void *clientData, - const AuxDataType *typePtr, CompileEnv *envPtr); +MODULE_SCOPE int TclCreateAuxData(ClientData clientData, + AuxDataType *typePtr, CompileEnv *envPtr); MODULE_SCOPE int TclCreateExceptRange(ExceptionRangeType type, CompileEnv *envPtr); -MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, size_t size); -MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, const char *bytes, - size_t length, size_t hash, int *newPtr, - Namespace *nsPtr, int flags, - LiteralEntry **globalPtrPtr); +MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp); +MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, 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); + int catchOnly, ByteCode* codePtr); MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr); -MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp, +MODULE_SCOPE int TclExecuteByteCode(Tcl_Interp *interp, ByteCode *codePtr); -MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, size_t index); -MODULE_SCOPE int TclFindCompiledLocal(const char *name, size_t nameChars, - int create, CompileEnv *envPtr); +MODULE_SCOPE void TclFinalizeAuxDataTypeTable(void); +MODULE_SCOPE int TclFindCompiledLocal(CONST char *name, int nameChars, + int create, Proc *procPtr); 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, - size_t before, size_t 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 TclInitAuxDataTypeTable(void); +MODULE_SCOPE void TclInitByteCodeObj(Tcl_Obj *objPtr, + CompileEnv *envPtr); MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp, CompileEnv *envPtr, const char *string, - size_t numBytes, const CmdFrame *invoker, int word); + 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, size_t 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 int TclPrintInstruction(ByteCode* codePtr, + unsigned char *pc); MODULE_SCOPE void TclPrintObject(FILE *outFile, - Tcl_Obj *objPtr, size_t maxChars); + Tcl_Obj *objPtr, int maxChars); MODULE_SCOPE void TclPrintSource(FILE *outFile, - const char *string, size_t 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); + CONST char *string, int maxChars); + +static inline void +TclPreserveByteCode( + register ByteCode *codePtr) +{ + codePtr->refCount++; +} + +static inline void +TclReleaseByteCode( + register ByteCode *codePtr) +{ + if (codePtr->refCount-- > 1) { + return; + } + /* Just dropped to refcount==0. Clean up. */ + TclCleanupByteCode(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(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int TclSortingOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int TclVariadicOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int TclNoIdentOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +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, - size_t length, const unsigned char *pc, - Tcl_Obj **tosPtr); -MODULE_SCOPE Tcl_Obj *TclGetInnerContext(Tcl_Interp *interp, - const unsigned char *pc, Tcl_Obj **tosPtr); -MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); -MODULE_SCOPE int TclPushProcCallFrame(void *clientData, - Tcl_Interp *interp, 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. *---------------------------------------------------------------- */ +#define LITERAL_ON_HEAP 0x01 +#define LITERAL_NS_SCOPE 0x02 + +/* + * Form of TclRegisterLiteral with onHeap == 0. In that case, it is safe to + * cast away CONSTness, and it is cleanest to do that here, all in one place. + * + * int TclRegisterNewLiteral(CompileEnv *envPtr, const char *bytes, + * int length); + */ + +#define TclRegisterNewLiteral(envPtr, bytes, length) \ + TclRegisterLiteral(envPtr, (char *)(bytes), length, /*flags*/ 0) + /* - * Simplified form to access AuxData. + * Form of TclRegisterNSLiteral with onHeap == 0. In that case, it is safe to + * cast away CONSTness, and it is cleanest to do that here, all in one place. * - * void *TclFetchAuxData(CompileEng *envPtr, int index); + * int TclRegisterNewNSLiteral(CompileEnv *envPtr, const char *bytes, + * int length); */ -#define TclFetchAuxData(envPtr, index) \ - (envPtr)->auxDataArrayPtr[(index)].clientData - -#define LITERAL_ON_HEAP 0x01 -#define LITERAL_CMD_NAME 0x02 -#define LITERAL_UNSHARED 0x04 +#define TclRegisterNewNSLiteral(envPtr, bytes, length) \ + TclRegisterLiteral(envPtr, (char *)(bytes), length, \ + /*flags*/ LITERAL_NS_SCOPE) /* * Macro used to manually adjust the stack requirements; used in cases where * the stack effect cannot be computed from the opcode and its operands, but * is still known at compile time. @@ -1226,33 +1017,16 @@ * * void TclAdjustStackDepth(int delta, CompileEnv *envPtr); */ #define TclAdjustStackDepth(delta, envPtr) \ - do { \ - if ((delta) < 0) { \ - if ((envPtr)->maxStackDepth < (envPtr)->currStackDepth) { \ - (envPtr)->maxStackDepth = (envPtr)->currStackDepth; \ - } \ - } \ - (envPtr)->currStackDepth += (delta); \ - } while (0) - -#define TclGetStackDepth(envPtr) \ - ((envPtr)->currStackDepth) - -#define TclSetStackDepth(depth, envPtr) \ - (envPtr)->currStackDepth = (depth) - -#define TclCheckStackDepth(depth, envPtr) \ - do { \ - int _dd = (depth); \ - if (_dd != (envPtr)->currStackDepth) { \ - Tcl_Panic("bad stack depth computations: is %i, should be %i", \ - (envPtr)->currStackDepth, _dd); \ - } \ - } while (0) + if ((delta) < 0) {\ + if((envPtr)->maxStackDepth < (envPtr)->currStackDepth) {\ + (envPtr)->maxStackDepth = (envPtr)->currStackDepth;\ + }\ + }\ + (envPtr)->currStackDepth += (delta) /* * Macro used to update the stack requirements. It is called by the macros * TclEmitOpCode, TclEmitInst1 and TclEmitInst4. * Remark that the very last instruction of a bytecode always reduces the @@ -1261,30 +1035,18 @@ * * void TclUpdateStackReqs(unsigned char op, int i, CompileEnv *envPtr); */ #define TclUpdateStackReqs(op, i, envPtr) \ - do { \ - int _delta = tclInstructionTable[(op)].stackEffect; \ - if (_delta) { \ - if (_delta == INT_MIN) { \ - _delta = 1 - (i); \ - } \ - TclAdjustStackDepth(_delta, envPtr); \ - } \ - } while (0) - -/* - * Macros used to update the flag that indicates if we are at the start of a - * command, based on whether the opcode is INST_START_COMMAND. - * - * void TclUpdateAtCmdStart(unsigned char op, CompileEnv *envPtr); - */ - -#define TclUpdateAtCmdStart(op, envPtr) \ - if ((envPtr)->atCmdStart < 2) { \ - (envPtr)->atCmdStart = ((op) == INST_START_CMD ? 1 : 0); \ + {\ + int delta = tclInstructionTable[(op)].stackEffect;\ + if (delta) {\ + if (delta == INT_MIN) {\ + delta = 1 - (i);\ + }\ + TclAdjustStackDepth(delta, envPtr);\ + }\ } /* * Macro to emit an opcode byte into a CompileEnv's code array. The ANSI C * "prototype" for this macro is: @@ -1291,18 +1053,16 @@ * * void TclEmitOpcode(unsigned char op, CompileEnv *envPtr); */ #define TclEmitOpcode(op, envPtr) \ - do { \ - if ((envPtr)->codeNext == (envPtr)->codeEnd) { \ - TclExpandCodeArray(envPtr); \ - } \ - *(envPtr)->codeNext++ = (unsigned char) (op); \ - TclUpdateAtCmdStart(op, envPtr); \ - TclUpdateStackReqs(op, 0, envPtr); \ - } while (0) + if ((envPtr)->codeNext == (envPtr)->codeEnd) { \ + TclExpandCodeArray(envPtr); \ + } \ + *(envPtr)->codeNext++ = (unsigned char) (op);\ + (envPtr)->atCmdStart = ((op) == INST_START_CMD); \ + TclUpdateStackReqs(op, 0, envPtr) /* * Macros to emit an integer operand. The ANSI C "prototype" for these macros * are: * @@ -1309,31 +1069,27 @@ * void TclEmitInt1(int i, CompileEnv *envPtr); * void TclEmitInt4(int i, CompileEnv *envPtr); */ #define TclEmitInt1(i, envPtr) \ - do { \ - if ((envPtr)->codeNext == (envPtr)->codeEnd) { \ - TclExpandCodeArray(envPtr); \ - } \ - *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i)); \ - } while (0) + if ((envPtr)->codeNext == (envPtr)->codeEnd) { \ + TclExpandCodeArray(envPtr); \ + } \ + *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i)) #define TclEmitInt4(i, envPtr) \ - do { \ - if (((envPtr)->codeNext + 4) > (envPtr)->codeEnd) { \ - TclExpandCodeArray(envPtr); \ - } \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) >> 24); \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) >> 16); \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) >> 8); \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) ); \ - } while (0) + if (((envPtr)->codeNext + 4) > (envPtr)->codeEnd) { \ + TclExpandCodeArray(envPtr); \ + } \ + *(envPtr)->codeNext++ = \ + (unsigned char) ((unsigned int) (i) >> 24); \ + *(envPtr)->codeNext++ = \ + (unsigned char) ((unsigned int) (i) >> 16); \ + *(envPtr)->codeNext++ = \ + (unsigned char) ((unsigned int) (i) >> 8); \ + *(envPtr)->codeNext++ = \ + (unsigned char) ((unsigned int) (i) ) /* * Macros to emit an instruction with signed or unsigned integer operands. * Four byte integers are stored in "big-endian" order with the high order * byte stored at the lowest address. The ANSI C "prototypes" for these macros @@ -1342,37 +1098,33 @@ * void TclEmitInstInt1(unsigned char op, int i, CompileEnv *envPtr); * void TclEmitInstInt4(unsigned char op, int i, CompileEnv *envPtr); */ #define TclEmitInstInt1(op, i, envPtr) \ - do { \ - if (((envPtr)->codeNext + 2) > (envPtr)->codeEnd) { \ - TclExpandCodeArray(envPtr); \ - } \ - *(envPtr)->codeNext++ = (unsigned char) (op); \ - *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i)); \ - TclUpdateAtCmdStart(op, envPtr); \ - TclUpdateStackReqs(op, i, envPtr); \ - } while (0) + if (((envPtr)->codeNext + 2) > (envPtr)->codeEnd) { \ + TclExpandCodeArray(envPtr); \ + } \ + *(envPtr)->codeNext++ = (unsigned char) (op); \ + *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i));\ + (envPtr)->atCmdStart = ((op) == INST_START_CMD); \ + TclUpdateStackReqs(op, i, envPtr) #define TclEmitInstInt4(op, i, envPtr) \ - do { \ - if (((envPtr)->codeNext + 5) > (envPtr)->codeEnd) { \ - TclExpandCodeArray(envPtr); \ - } \ - *(envPtr)->codeNext++ = (unsigned char) (op); \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) >> 24); \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) >> 16); \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) >> 8); \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) ); \ - TclUpdateAtCmdStart(op, envPtr); \ - TclUpdateStackReqs(op, i, envPtr); \ - } while (0) + if (((envPtr)->codeNext + 5) > (envPtr)->codeEnd) { \ + TclExpandCodeArray(envPtr); \ + } \ + *(envPtr)->codeNext++ = (unsigned char) (op); \ + *(envPtr)->codeNext++ = \ + (unsigned char) ((unsigned int) (i) >> 24); \ + *(envPtr)->codeNext++ = \ + (unsigned char) ((unsigned int) (i) >> 16); \ + *(envPtr)->codeNext++ = \ + (unsigned char) ((unsigned int) (i) >> 8); \ + *(envPtr)->codeNext++ = \ + (unsigned char) ((unsigned int) (i) );\ + (envPtr)->atCmdStart = ((op) == INST_START_CMD); \ + TclUpdateStackReqs(op, i, envPtr) /* * Macro to push a Tcl object onto the Tcl evaluation stack. It emits the * object's one or four byte array index into the CompileEnv's code array. * These support, respectively, a maximum of 256 (2**8) and 2**32 objects in a @@ -1380,18 +1132,18 @@ * * 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) + {\ + register int objIndexCopy = (objIndex);\ + if (objIndexCopy <= 255) { \ + TclEmitInstInt1(INST_PUSH1, objIndexCopy, (envPtr)); \ + } else { \ + TclEmitInstInt4(INST_PUSH4, objIndexCopy, (envPtr)); \ + }\ + } /* * Macros to update a (signed or unsigned) integer starting at a pointer. The * two variants depend on the number of bytes. The ANSI C "prototypes" for * these macros are: @@ -1402,16 +1154,14 @@ #define TclStoreInt1AtPtr(i, p) \ *(p) = (unsigned char) ((unsigned int) (i)) #define TclStoreInt4AtPtr(i, p) \ - do { \ - *(p) = (unsigned char) ((unsigned int) (i) >> 24); \ - *(p+1) = (unsigned char) ((unsigned int) (i) >> 16); \ - *(p+2) = (unsigned char) ((unsigned int) (i) >> 8); \ - *(p+3) = (unsigned char) ((unsigned int) (i) ); \ - } while (0) + *(p) = (unsigned char) ((unsigned int) (i) >> 24); \ + *(p+1) = (unsigned char) ((unsigned int) (i) >> 16); \ + *(p+2) = (unsigned char) ((unsigned int) (i) >> 8); \ + *(p+3) = (unsigned char) ((unsigned int) (i) ) /* * Macros to update instructions at a particular pc with a new op code and a * (signed or unsigned) int operand. The ANSI C "prototypes" for these macros * are: @@ -1419,20 +1169,16 @@ * void TclUpdateInstInt1AtPc(unsigned char op, int i, unsigned char *pc); * void TclUpdateInstInt4AtPc(unsigned char op, int i, unsigned char *pc); */ #define TclUpdateInstInt1AtPc(op, i, pc) \ - do { \ - *(pc) = (unsigned char) (op); \ - TclStoreInt1AtPtr((i), ((pc)+1)); \ - } while (0) + *(pc) = (unsigned char) (op); \ + TclStoreInt1AtPtr((i), ((pc)+1)) #define TclUpdateInstInt4AtPc(op, i, pc) \ - do { \ - *(pc) = (unsigned char) (op); \ - TclStoreInt4AtPtr((i), ((pc)+1)); \ - } while (0) + *(pc) = (unsigned char) (op); \ + TclStoreInt4AtPtr((i), ((pc)+1)) /* * Macro to fix up a forward jump to point to the current code-generation * position in the bytecode being created (the most common case). The ANSI C * "prototypes" for this macro is: @@ -1440,11 +1186,11 @@ * int TclFixupForwardJumpToHere(CompileEnv *envPtr, JumpFixup *fixupPtr, * int threshold); */ #define TclFixupForwardJumpToHere(envPtr, fixupPtr, threshold) \ - TclFixupForwardJump((envPtr), (fixupPtr), \ + TclFixupForwardJump((envPtr), (fixupPtr), \ (envPtr)->codeNext-(envPtr)->codeStart-(fixupPtr)->codeOffset, \ (threshold)) /* * Macros to get a signed integer (GET_INT{1,2}) or an unsigned int @@ -1466,208 +1212,40 @@ * to explicitly sign-extend the value in software. */ #ifndef __CHAR_UNSIGNED__ # define TclGetInt1AtPtr(p) ((int) *((char *) p)) -#elif defined(HAVE_SIGNED_CHAR) -# define TclGetInt1AtPtr(p) ((int) *((signed char *) p)) #else -# define TclGetInt1AtPtr(p) \ - (((int) *((char *) p)) | ((*(p) & 0200) ? (-256) : 0)) +# ifdef HAVE_SIGNED_CHAR +# define TclGetInt1AtPtr(p) ((int) *((signed char *) p)) +# else +# define TclGetInt1AtPtr(p) (((int) *((char *) p)) \ + | ((*(p) & 0200) ? (-256) : 0)) +# endif #endif -#define TclGetInt4AtPtr(p) \ - (((int) (TclGetUInt1AtPtr(p) << 24)) | \ - (*((p)+1) << 16) | \ - (*((p)+2) << 8) | \ - (*((p)+3))) - -#define TclGetUInt1AtPtr(p) \ - ((unsigned int) *(p)) -#define TclGetUInt4AtPtr(p) \ - ((unsigned int) (*(p) << 24) | \ - (*((p)+1) << 16) | \ - (*((p)+2) << 8) | \ - (*((p)+3))) +#define TclGetInt4AtPtr(p) (((int) TclGetInt1AtPtr(p) << 24) | \ + (*((p)+1) << 16) | \ + (*((p)+2) << 8) | \ + (*((p)+3))) + +#define TclGetUInt1AtPtr(p) ((unsigned int) *(p)) +#define TclGetUInt4AtPtr(p) ((unsigned int) (*(p) << 24) | \ + (*((p)+1) << 16) | \ + (*((p)+2) << 8) | \ + (*((p)+3))) /* * Macros used to compute the minimum and maximum of two integers. The ANSI C * "prototypes" for these macros are: * * int TclMin(int i, int j); * int TclMax(int i, int j); */ -#define TclMin(i, j) ((((int) i) < ((int) j))? (i) : (j)) -#define TclMax(i, j) ((((int) i) > ((int) j))? (i) : (j)) - -/* - * Convenience macros for use when compiling bodies of commands. The ANSI C - * "prototype" for these macros are: - * - * static void BODY(Tcl_Token *tokenPtr, int word); - */ - -#define BODY(tokenPtr, word) \ - SetLineInformation((word)); \ - TclCompileCmdWord(interp, (tokenPtr)+1, (tokenPtr)->numComponents, \ - envPtr) - -/* - * Convenience macro for use when compiling tokens to be pushed. The ANSI C - * "prototype" for this macro is: - * - * static void CompileTokens(CompileEnv *envPtr, Tcl_Token *tokenPtr, - * Tcl_Interp *interp); - */ - -#define CompileTokens(envPtr, tokenPtr, interp) \ - 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, size_t 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, 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 ptrdiff_t CurrentOffset(CompileEnv *envPtr); - */ - -#define CurrentOffset(envPtr) \ - ((envPtr)->codeNext - (envPtr)->codeStart) - -/* - * Note: the exceptDepth is a bit of a misnomer: TEBC only needs the - * maximal depth of nested CATCH ranges in order to alloc runtime - * memory. These macros should compute precisely that? OTOH, the nesting depth - * of LOOP ranges is an interesting datum for debugging purposes, and that is - * what we compute now. - * - * static int ExceptionRangeStarts(CompileEnv *envPtr, int index); - * static void ExceptionRangeEnds(CompileEnv *envPtr, int index); - * static void ExceptionRangeTarget(CompileEnv *envPtr, int index, LABEL); - */ - -#define ExceptionRangeStarts(envPtr, index) \ - (((envPtr)->exceptDepth++), \ - ((envPtr)->maxExceptDepth = \ - TclMax((envPtr)->exceptDepth, (envPtr)->maxExceptDepth)), \ - ((envPtr)->exceptArrayPtr[(index)].codeOffset = CurrentOffset(envPtr))) -#define ExceptionRangeEnds(envPtr, index) \ - (((envPtr)->exceptDepth--), \ - ((envPtr)->exceptArrayPtr[(index)].numCodeBytes = \ - CurrentOffset(envPtr) - (envPtr)->exceptArrayPtr[(index)].codeOffset)) -#define ExceptionRangeTarget(envPtr, index, targetType) \ - ((envPtr)->exceptArrayPtr[(index)].targetType = CurrentOffset(envPtr)) - -/* - * Check if there is an LVT for compiled locals - */ - -#define EnvHasLVT(envPtr) \ - (envPtr->procPtr || envPtr->iPtr->varFramePtr->localCachePtr) - -/* - * Macros for making it easier to deal with tokens and DStrings. - */ - -#define TclDStringAppendToken(dsPtr, tokenPtr) \ - Tcl_DStringAppend((dsPtr), (tokenPtr)->start, (tokenPtr)->size) -#define TclRegisterDStringLiteral(envPtr, dsPtr) \ - TclRegisterLiteral(envPtr, Tcl_DStringValue(dsPtr), \ - Tcl_DStringLength(dsPtr), /*flags*/ 0) - -/* - * Macro that encapsulates an efficiency trick that avoids a function call for - * the simplest of compiles. The ANSI C "prototype" for this macro is: - * - * static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr, - * Tcl_Interp *interp, int word); - */ - -#define CompileWord(envPtr, tokenPtr, interp, word) \ - if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \ - PushLiteral((envPtr), (tokenPtr)[1].start, (tokenPtr)[1].size); \ - } else { \ - SetLineInformation((word)); \ - CompileTokens((envPtr), (tokenPtr), (interp)); \ - } - -/* - * TIP #280: Remember the per-word line information of the current command. An - * index is used instead of a pointer as recursive compilation may reallocate, - * i.e. move, the array. This is also the reason to save the nuloc now, it may - * change during the course of the function. - * - * Macro to encapsulate the variable definition and setup. - */ - -#define DefineLineInformation \ - ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ - int eclIndex = mapPtr->nuloc - 1 - -#define SetLineInformation(word) \ - envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ - envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] - -#define PushVarNameWord(i,v,e,f,l,sc,word) \ - SetLineInformation(word); \ - TclPushVarName(i,v,e,f,l,sc) - -/* - * Often want to issue one of two versions of an instruction based on whether - * the argument will fit in a single byte or not. This makes it much clearer. - */ - -#define Emit14Inst(nm,idx,envPtr) \ - if (idx <= 255) { \ - TclEmitInstInt1(nm##1,idx,envPtr); \ - } else { \ - TclEmitInstInt4(nm##4,idx,envPtr); \ - } - -/* - * How to get an anonymous local variable (used for holding temporary values - * off the stack) or a local simple scalar. - */ - -#define AnonymousLocal(envPtr) \ - (TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, (envPtr))) -#define LocalScalar(chars,len,envPtr) \ - TclLocalScalar(chars, len, envPtr) -#define LocalScalarFromToken(tokenPtr,envPtr) \ - TclLocalScalarFromToken(tokenPtr, envPtr) - -/* - * Flags bits used by TclPushVarName. - */ - -#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */ -#define TCL_NO_ELEMENT 2 /* Do not push the array element. */ +#define TclMin(i, j) ((((int) i) < ((int) j))? (i) : (j)) +#define TclMax(i, j) ((((int) i) > ((int) j))? (i) : (j)) /* * DTrace probe macros (NOPs if DTrace support is not enabled). */ @@ -1691,15 +1269,15 @@ */ #if !(defined(TCL_DTRACE_DEBUG) && defined(__GNUC__)) #ifdef USE_DTRACE + +#include "tclDTrace.h" #if defined(__GNUC__) && __GNUC__ > 2 -/* - * Use gcc branch prediction hint to minimize cost of DTrace ENABLED checks. - */ +/* Use gcc branch prediction hint to minimize cost of DTrace ENABLED checks. */ #define unlikely(x) (__builtin_expect((x), 0)) #else #define unlikely(x) (x) #endif @@ -1711,12 +1289,12 @@ #define TCL_DTRACE_PROC_ENTRY(a0, a1, a2) TCL_PROC_ENTRY(a0, a1, a2) #define TCL_DTRACE_PROC_RETURN(a0, a1) TCL_PROC_RETURN(a0, a1) #define TCL_DTRACE_PROC_RESULT(a0, a1, a2, a3) TCL_PROC_RESULT(a0, a1, a2, a3) #define TCL_DTRACE_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ TCL_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) -#define TCL_DTRACE_PROC_INFO(a0, a1, a2, a3, a4, a5, a6, a7) \ - TCL_PROC_INFO(a0, a1, a2, a3, a4, a5, a6, a7) +#define TCL_DTRACE_PROC_INFO(a0, a1, a2, a3, a4, a5) \ + TCL_PROC_INFO(a0, a1, a2, a3, a4, a5) #define TCL_DTRACE_CMD_ENTRY_ENABLED() unlikely(TCL_CMD_ENTRY_ENABLED()) #define TCL_DTRACE_CMD_RETURN_ENABLED() unlikely(TCL_CMD_RETURN_ENABLED()) #define TCL_DTRACE_CMD_RESULT_ENABLED() unlikely(TCL_CMD_RESULT_ENABLED()) #define TCL_DTRACE_CMD_ARGS_ENABLED() unlikely(TCL_CMD_ARGS_ENABLED()) @@ -1724,12 +1302,12 @@ #define TCL_DTRACE_CMD_ENTRY(a0, a1, a2) TCL_CMD_ENTRY(a0, a1, a2) #define TCL_DTRACE_CMD_RETURN(a0, a1) TCL_CMD_RETURN(a0, a1) #define TCL_DTRACE_CMD_RESULT(a0, a1, a2, a3) TCL_CMD_RESULT(a0, a1, a2, a3) #define TCL_DTRACE_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ TCL_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) -#define TCL_DTRACE_CMD_INFO(a0, a1, a2, a3, a4, a5, a6, a7) \ - TCL_CMD_INFO(a0, a1, a2, a3, a4, a5, a6, a7) +#define TCL_DTRACE_CMD_INFO(a0, a1, a2, a3, a4, a5) \ + TCL_CMD_INFO(a0, a1, a2, a3, a4, a5) #define TCL_DTRACE_INST_START_ENABLED() unlikely(TCL_INST_START_ENABLED()) #define TCL_DTRACE_INST_DONE_ENABLED() unlikely(TCL_INST_DONE_ENABLED()) #define TCL_DTRACE_INST_START(a0, a1, a2) TCL_INST_START(a0, a1, a2) #define TCL_DTRACE_INST_DONE(a0, a1, a2) TCL_INST_DONE(a0, a1, a2) @@ -1738,25 +1316,24 @@ #define TCL_DTRACE_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ TCL_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) #define TCL_DTRACE_DEBUG_LOG() -MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args, - int *argsi); +MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, char **args, int *argsi); #else /* USE_DTRACE */ #define TCL_DTRACE_PROC_ENTRY_ENABLED() 0 #define TCL_DTRACE_PROC_RETURN_ENABLED() 0 #define TCL_DTRACE_PROC_RESULT_ENABLED() 0 #define TCL_DTRACE_PROC_ARGS_ENABLED() 0 #define TCL_DTRACE_PROC_INFO_ENABLED() 0 -#define TCL_DTRACE_PROC_ENTRY(a0, a1, a2) {if (a0) {}} -#define TCL_DTRACE_PROC_RETURN(a0, a1) {if (a0) {}} -#define TCL_DTRACE_PROC_RESULT(a0, a1, a2, a3) {if (a0) {}; if (a3) {}} +#define TCL_DTRACE_PROC_ENTRY(a0, a1, a2) {} +#define TCL_DTRACE_PROC_RETURN(a0, a1) {} +#define TCL_DTRACE_PROC_RESULT(a0, a1, a2, a3) {} #define TCL_DTRACE_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) {} -#define TCL_DTRACE_PROC_INFO(a0, a1, a2, a3, a4, a5, a6, a7) {} +#define TCL_DTRACE_PROC_INFO(a0, a1, a2, a3, a4, a5) {} #define TCL_DTRACE_CMD_ENTRY_ENABLED() 0 #define TCL_DTRACE_CMD_RETURN_ENABLED() 0 #define TCL_DTRACE_CMD_RESULT_ENABLED() 0 #define TCL_DTRACE_CMD_ARGS_ENABLED() 0 @@ -1763,11 +1340,11 @@ #define TCL_DTRACE_CMD_INFO_ENABLED() 0 #define TCL_DTRACE_CMD_ENTRY(a0, a1, a2) {} #define TCL_DTRACE_CMD_RETURN(a0, a1) {} #define TCL_DTRACE_CMD_RESULT(a0, a1, a2, a3) {} #define TCL_DTRACE_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) {} -#define TCL_DTRACE_CMD_INFO(a0, a1, a2, a3, a4, a5, a6, a7) {} +#define TCL_DTRACE_CMD_INFO(a0, a1, a2, a3, a4, a5) {} #define TCL_DTRACE_INST_START_ENABLED() 0 #define TCL_DTRACE_INST_DONE_ENABLED() 0 #define TCL_DTRACE_INST_START(a0, a1, a2) {} #define TCL_DTRACE_INST_DONE(a0, a1, a2) {} @@ -1794,40 +1371,31 @@ #endif MODULE_SCOPE int tclDTraceDebugEnabled, tclDTraceDebugIndent; MODULE_SCOPE FILE *tclDTraceDebugLog; MODULE_SCOPE void TclDTraceOpenDebugLog(void); -MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args, int *argsi); +MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, char **args, int *argsi); #define TCL_DTRACE_DEBUG_LOG() \ - int tclDTraceDebugEnabled = TCL_DTRACE_DEBUG_LOG_ENABLED; \ - int tclDTraceDebugIndent = 0; \ - FILE *tclDTraceDebugLog = NULL; \ - void TclDTraceOpenDebugLog(void) { \ - char n[35]; \ - sprintf(n, "/tmp/tclDTraceDebug-%" TCL_Z_MODIFIER "u.log", \ - (size_t) getpid()); \ - tclDTraceDebugLog = fopen(n, "a"); \ - } - -#define TclDTraceDbgMsg(p, m, ...) \ - do { \ - if (tclDTraceDebugEnabled) { \ - int _l, _t = 0; \ - if (!tclDTraceDebugLog) { TclDTraceOpenDebugLog(); } \ - fprintf(tclDTraceDebugLog, "%.12s:%.4d:%n", \ - strrchr(__FILE__, '/')+1, __LINE__, &_l); _t += _l; \ - fprintf(tclDTraceDebugLog, " %.*s():%n", \ - (_t < 18 ? 18 - _t : 0) + 18, __func__, &_l); _t += _l; \ - fprintf(tclDTraceDebugLog, "%*s" p "%n", \ - (_t < 40 ? 40 - _t : 0) + 2 * tclDTraceDebugIndent, \ - "", &_l); _t += _l; \ - fprintf(tclDTraceDebugLog, "%*s" m "\n", \ - (_t < 64 ? 64 - _t : 1), "", ##__VA_ARGS__); \ - fflush(tclDTraceDebugLog); \ - } \ - } while (0) + 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; if (!tclDTraceDebugLog) { TclDTraceOpenDebugLog(); } \ + fprintf(tclDTraceDebugLog, "%.12s:%.4d:%n", strrchr(__FILE__, '/') + \ + 1, __LINE__, &_l); _t += _l; \ + fprintf(tclDTraceDebugLog, " %.*s():%n", (_t < 18 ? 18 - _t : 0) + \ + 18, __func__, &_l); _t += _l; \ + fprintf(tclDTraceDebugLog, "%*s" p "%n", (_t < 40 ? 40 - _t : 0) + \ + 2 * tclDTraceDebugIndent, "", &_l); _t += _l; \ + fprintf(tclDTraceDebugLog, "%*s" m "\n", (_t < 64 ? 64 - _t : 1), "", \ + ##__VA_ARGS__); fflush(tclDTraceDebugLog); \ + } } while (0) #define TCL_DTRACE_PROC_ENTRY_ENABLED() 1 #define TCL_DTRACE_PROC_RETURN_ENABLED() 1 #define TCL_DTRACE_PROC_RESULT_ENABLED() 1 #define TCL_DTRACE_PROC_ARGS_ENABLED() 1 @@ -1841,13 +1409,13 @@ #define TCL_DTRACE_PROC_RESULT(a0, a1, a2, a3) \ TclDTraceDbgMsg(" | proc-result", "%s %d %s %p", a0, a1, a2, a3) #define TCL_DTRACE_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ TclDTraceDbgMsg(" | proc-args", "%s %s %s %s %s %s %s %s %s %s", a0, \ a1, a2, a3, a4, a5, a6, a7, a8, a9) -#define TCL_DTRACE_PROC_INFO(a0, a1, a2, a3, a4, a5, a6, a7) \ - TclDTraceDbgMsg(" | proc-info", "%s %s %s %s %d %d %s %s", a0, a1, \ - a2, a3, a4, a5, a6, a7) +#define TCL_DTRACE_PROC_INFO(a0, a1, a2, a3, a4, a5) \ + TclDTraceDbgMsg(" | proc-info", "%s %s %s %s %d %d", a0, a1, \ + a2, a3, a4, a5) #define TCL_DTRACE_CMD_ENTRY_ENABLED() 1 #define TCL_DTRACE_CMD_RETURN_ENABLED() 1 #define TCL_DTRACE_CMD_RESULT_ENABLED() 1 #define TCL_DTRACE_CMD_ARGS_ENABLED() 1 @@ -1861,13 +1429,13 @@ #define TCL_DTRACE_CMD_RESULT(a0, a1, a2, a3) \ TclDTraceDbgMsg(" | cmd-result", "%s %d %s %p", a0, a1, a2, a3) #define TCL_DTRACE_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ TclDTraceDbgMsg(" | cmd-args", "%s %s %s %s %s %s %s %s %s %s", a0, \ a1, a2, a3, a4, a5, a6, a7, a8, a9) -#define TCL_DTRACE_CMD_INFO(a0, a1, a2, a3, a4, a5, a6, a7) \ - TclDTraceDbgMsg(" | cmd-info", "%s %s %s %s %d %d %s %s", a0, a1, \ - a2, a3, a4, a5, a6, a7) +#define TCL_DTRACE_CMD_INFO(a0, a1, a2, a3, a4, a5) \ + TclDTraceDbgMsg(" | cmd-info", "%s %s %s %s %d %d", a0, a1, \ + a2, a3, a4, a5) #define TCL_DTRACE_INST_START_ENABLED() TCL_DTRACE_DEBUG_INST_PROBES #define TCL_DTRACE_INST_DONE_ENABLED() TCL_DTRACE_DEBUG_INST_PROBES #define TCL_DTRACE_INST_START(a0, a1, a2) \ TclDTraceDbgMsg(" | inst-start", "%s %d %p", a0, a1, a2) @@ -1874,15 +1442,13 @@ #define TCL_DTRACE_INST_DONE(a0, a1, a2) \ TclDTraceDbgMsg(" | inst-end", "%s %d %p", a0, a1, a2) #define TCL_DTRACE_TCL_PROBE_ENABLED() 1 #define TCL_DTRACE_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ - do { \ - tclDTraceDebugEnabled = 1; \ + tclDTraceDebugEnabled = 1; \ TclDTraceDbgMsg(" | tcl-probe", "%s %s %s %s %s %s %s %s %s %s", a0, \ - a1, a2, a3, a4, a5, a6, a7, a8, a9); \ - } while (0) + a1, a2, a3, a4, a5, a6, a7, a8, a9) #endif /* TCL_DTRACE_DEBUG */ #endif /* _TCLCOMPILATION */ Index: generic/tclConfig.c ================================================================== --- generic/tclConfig.c +++ generic/tclConfig.c @@ -29,24 +29,27 @@ * 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 { +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 int QueryConfigObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + struct Tcl_Obj *CONST *objv); +static void QueryConfigDelete(ClientData clientData); static Tcl_Obj * GetConfigDict(Tcl_Interp *interp); +static void ConfigDictDeleteProc(ClientData clientData, + Tcl_Interp *interp); /* *---------------------------------------------------------------------- * * Tcl_RegisterConfig -- @@ -64,25 +67,25 @@ void Tcl_RegisterConfig( Tcl_Interp *interp, /* Interpreter the configuration command is * registered in. */ - const char *pkgName, /* Name of the package registering the + CONST char *pkgName, /* Name of the package registering the * embedded configuration. ASCII, thus in * UTF-8 too. */ - const Tcl_Config *configuration, /* Embedded configuration. */ - const char *valEncoding) /* Name of the encoding used to store the + 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 *)Tcl_Alloc(sizeof(QCCD)); + Tcl_Config *cfg; + QCCD *cdPtr = (QCCD *)ckalloc(sizeof(QCCD)); cdPtr->interp = interp; if (valEncoding) { - cdPtr->encoding = (char *)Tcl_Alloc(strlen(valEncoding)+1); + cdPtr->encoding = ckalloc(strlen(valEncoding)+1); strcpy(cdPtr->encoding, valEncoding); } else { cdPtr->encoding = NULL; } cdPtr->pkg = Tcl_NewStringObj(pkgName, -1); @@ -141,11 +144,11 @@ * Now create the interface command for retrieval of the package * information. */ Tcl_DStringInit(&cmdName); - TclDStringAppendLiteral(&cmdName, "::"); + Tcl_DStringAppend(&cmdName, "::", -1); Tcl_DStringAppend(&cmdName, pkgName, -1); /* * The incomplete command name is the name of the namespace to place it * in. @@ -159,14 +162,14 @@ Tcl_GetStringResult(interp), "Tcl_RegisterConfig", "Unable to create namespace for package configuration."); } } - TclDStringAppendLiteral(&cmdName, "::pkgconfig"); + Tcl_DStringAppend(&cmdName, "::pkgconfig", -1); if (Tcl_CreateObjCommand(interp, Tcl_DStringValue(&cmdName), - QueryConfigObjCmd, cdPtr, QueryConfigDelete) == NULL) { + QueryConfigObjCmd, (ClientData) cdPtr, QueryConfigDelete) == NULL) { Tcl_Panic("%s: %s", "Tcl_RegisterConfig", "Unable to create query command for package configuration"); } Tcl_DStringFree(&cmdName); @@ -192,29 +195,28 @@ static int QueryConfigObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, - struct Tcl_Obj *const *objv) + struct Tcl_Obj *CONST *objv) { - QCCD *cdPtr = (QCCD *)clientData; + QCCD *cdPtr = (QCCD *) clientData; Tcl_Obj *pkgName = cdPtr->pkg; Tcl_Obj *pDB, *pkgDict, *val, *listPtr; - size_t n = 0; - int index, m; - static const char *const subcmdStrings[] = { + int n, index; + static CONST char *subcmdStrings[] = { "get", "list", NULL }; enum subcmds { CFG_GET, CFG_LIST }; Tcl_DString conv; Tcl_Encoding venc = NULL; - const char *value; + CONST char *value; if ((objc < 2) || (objc > 3)) { - Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg?"); + Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?argument?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], subcmdStrings, "subcommand", 0, &index) != TCL_OK) { return TCL_ERROR; @@ -226,13 +228,11 @@ /* * Maybe a Tcl_Panic is better, because the package data has to be * present. */ - Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1)); - Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE", - TclGetString(pkgName), NULL); + Tcl_SetResult(interp, "package not known", TCL_STATIC); return TCL_ERROR; } switch ((enum subcmds) index) { case CFG_GET: @@ -241,13 +241,11 @@ return TCL_ERROR; } if (Tcl_DictObjGet(interp, pkgDict, objv[2], &val) != TCL_OK || val == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("key not known", -1)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG", - TclGetString(objv[2]), NULL); + Tcl_SetResult(interp, "key not known", TCL_STATIC); return TCL_ERROR; } if (cdPtr->encoding) { venc = Tcl_GetEncoding(interp, cdPtr->encoding); @@ -257,11 +255,11 @@ } /* * Value is stored as-is in a byte array, see Bug [9b2e636361], * so we have to decode it first. */ - value = (const char *) TclGetByteArrayFromObj(val, &n); + 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; @@ -270,21 +268,20 @@ if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - Tcl_DictObjSize(interp, pkgDict, &m); - listPtr = Tcl_NewListObj(m, NULL); + 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); + Tcl_SetResult(interp, "insufficient memory to create list", + TCL_STATIC); return TCL_ERROR; } - if (m) { + if (n) { Tcl_DictSearch s; Tcl_Obj *key; int done; for (Tcl_DictObjFirst(interp, pkgDict, &s, &key, NULL, &done); @@ -322,20 +319,20 @@ static void QueryConfigDelete( ClientData clientData) { - QCCD *cdPtr = (QCCD *)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) { - Tcl_Free(cdPtr->encoding); + ckfree((char *)cdPtr->encoding); } - Tcl_Free(cdPtr); + ckfree((char *)cdPtr); } /* *------------------------------------------------------------------------- * @@ -355,11 +352,11 @@ static Tcl_Obj * GetConfigDict( Tcl_Interp *interp) { - Tcl_Obj *pDB = (Tcl_Obj *)Tcl_GetAssocData(interp, ASSOC_KEY, NULL); + Tcl_Obj *pDB = Tcl_GetAssocData(interp, ASSOC_KEY, NULL); if (pDB == NULL) { pDB = Tcl_NewDictObj(); Tcl_IncrRefCount(pDB); Tcl_SetAssocData(interp, ASSOC_KEY, ConfigDictDeleteProc, pDB); @@ -388,17 +385,19 @@ */ static void ConfigDictDeleteProc( ClientData clientData, /* Pointer to Tcl_Obj. */ - TCL_UNUSED(Tcl_Interp *)) + Tcl_Interp *interp) /* Interpreter being deleted. */ { - Tcl_DecrRefCount((Tcl_Obj *)clientData); + Tcl_Obj *pDB = (Tcl_Obj *) clientData; + + Tcl_DecrRefCount(pDB); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclDTrace.d ================================================================== --- generic/tclDTrace.d +++ generic/tclDTrace.d @@ -1,11 +1,11 @@ /* * tclDTrace.d -- * * Tcl DTrace provider. * - * Copyright (c) 2007-2008 Daniel A. Steffen + * Copyright (c) 2007 Daniel A. Steffen * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ @@ -22,39 +22,37 @@ * 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); + probe proc__entry(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); + probe proc__return(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); + probe proc__result(char* name, int code, 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); + probe proc__args(char* name, char* arg1, char* arg2, char* arg3, + char* arg4, char* arg5, char* arg6, char* arg7, char* arg8, + 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) @@ -61,54 +59,49 @@ * 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); + probe proc__info(char* cmd, char* type, char* proc, char* file, int line, + int level); /***************************** 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); + probe cmd__entry(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); + probe cmd__return(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); + probe cmd__result(char* name, int code, 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); + probe cmd__args(char* name, char* arg1, char* arg2, char* arg3, + char* arg4, char* arg5, char* arg6, char* arg7, char* arg8, + 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) @@ -115,34 +108,31 @@ * 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); + probe cmd__info(char* cmd, char* type, char* proc, char* file, int line, + int level); /***************************** 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); + probe inst__start(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); + probe inst__done(char* name, int depth, struct Tcl_Obj **stack); /***************************** obj probes ******************************/ /* * tcl*:::obj-create probe * triggered immediately after a new Tcl_Obj has been created @@ -160,33 +150,32 @@ /* * 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); + probe tcl__probe(char* arg0, char* arg1, char* arg2, char* arg3, + char* arg4, char* arg5, char* arg6, char* arg7, char* arg8, + char* arg9); }; /* * Tcl types and constants for use in DTrace scripts */ typedef struct Tcl_ObjType { - const char *name; + char *name; void *freeIntRepProc; void *dupIntRepProc; void *updateStringProc; void *setFromAnyProc; } Tcl_ObjType; struct Tcl_Obj { - size_t refCount; + int refCount; char *bytes; - size_t length; - const Tcl_ObjType *typePtr; + int length; + Tcl_ObjType *typePtr; union { long longValue; double doubleValue; void *otherValuePtr; int64_t wideValue; Index: generic/tclDate.c ================================================================== --- generic/tclDate.c +++ generic/tclDate.c @@ -1,23 +1,26 @@ -/* A Bison parser, made by GNU Bison 3.1. */ +/* A Bison parser, made by GNU Bison 2.3. */ -/* Bison implementation for Yacc-like parsers in C +/* Skeleton implementation for Bison's Yacc-like parsers in C - Copyright (C) 1984, 1989-1990, 2000-2015, 2018 Free Software Foundation, Inc. + Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003, 2004, 2005, 2006 + Free Software Foundation, Inc. - This program is free software: you can redistribute it and/or modify + This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. + the Free Software Foundation; either version 2, or (at your option) + any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License - along with this program. If not, see . */ + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, + Boston, MA 02110-1301, USA. */ /* As a special exception, you may create a larger work that contains part or all of the Bison parser skeleton and distribute that work under terms of your choice, so long as that work isn't itself a parser generator using the skeleton or a modified version thereof @@ -42,31 +45,76 @@ /* Identify Bison output. */ #define YYBISON 1 /* Bison version. */ -#define YYBISON_VERSION "3.1" +#define YYBISON_VERSION "2.3" /* Skeleton name. */ #define YYSKELETON_NAME "yacc.c" /* Pure parsers. */ #define YYPURE 1 -/* Push parsers. */ -#define YYPUSH 0 - -/* Pull parsers. */ -#define YYPULL 1 - +/* Using locations. */ +#define YYLSP_NEEDED 1 /* Substitute the variable and function names. */ -#define yyparse TclDateparse -#define yylex TclDatelex -#define yyerror TclDateerror -#define yydebug TclDatedebug -#define yynerrs TclDatenerrs +#define yyparse TclDateparse +#define yylex TclDatelex +#define yyerror TclDateerror +#define yylval TclDatelval +#define yychar TclDatechar +#define yydebug TclDatedebug +#define yynerrs TclDatenerrs +#define yylloc TclDatelloc + +/* Tokens. */ +#ifndef YYTOKENTYPE +# define YYTOKENTYPE + /* Put the tokens into the symbol table, so that GDB and other debuggers + know about them. */ + enum yytokentype { + tAGO = 258, + tDAY = 259, + tDAYZONE = 260, + tID = 261, + tMERIDIAN = 262, + tMONTH = 263, + tMONTH_UNIT = 264, + tSTARDATE = 265, + tSEC_UNIT = 266, + tSNUMBER = 267, + tUNUMBER = 268, + tZONE = 269, + tEPOCH = 270, + tDST = 271, + tISOBASE = 272, + tDAY_UNIT = 273, + tNEXT = 274 + }; +#endif +/* Tokens. */ +#define tAGO 258 +#define tDAY 259 +#define tDAYZONE 260 +#define tID 261 +#define tMERIDIAN 262 +#define tMONTH 263 +#define tMONTH_UNIT 264 +#define tSTARDATE 265 +#define tSEC_UNIT 266 +#define tSNUMBER 267 +#define tUNUMBER 268 +#define tZONE 269 +#define tEPOCH 270 +#define tDST 271 +#define tISOBASE 272 +#define tDAY_UNIT 273 +#define tNEXT 274 + + /* Copy the first part of user declarations. */ @@ -79,11 +127,10 @@ * Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans. * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * */ #include "tclInt.h" /* * Bison generates several labels that happen to be unused. MS Visual C++ @@ -92,18 +139,10 @@ #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. */ @@ -118,11 +157,11 @@ int dateHaveDate; time_t dateHour; time_t dateMinutes; time_t dateSeconds; - MERIDIAN dateMeridian; + int dateMeridian; int dateHaveTime; time_t dateTimezone; int dateDSTmode; int dateHaveZone; @@ -144,12 +183,12 @@ time_t *dateRelPointer; int dateDigitCount; } DateInfo; -#define YYMALLOC Tcl_Alloc -#define YYFREE(x) (Tcl_Free((void*) (x))) +#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) @@ -205,99 +244,65 @@ typedef enum _DSTMODE { DSTon, DSToff, DSTmaybe } DSTMODE; +/* + * Meridian: am, pm, or 24-hour style. + */ + +typedef enum _MERIDIAN { + MERam, MERpm, MER24 +} MERIDIAN; -# ifndef YY_NULLPTR -# if defined __cplusplus && 201103L <= __cplusplus -# define YY_NULLPTR nullptr -# else -# define YY_NULLPTR 0 -# endif -# endif +/* Enabling traces. */ +#ifndef YYDEBUG +# define YYDEBUG 0 +#endif /* Enabling verbose error messages. */ #ifdef YYERROR_VERBOSE # undef YYERROR_VERBOSE # define YYERROR_VERBOSE 1 #else # define YYERROR_VERBOSE 0 #endif - -/* Debug traces. */ -#ifndef YYDEBUG -# define YYDEBUG 0 -#endif -#if YYDEBUG -extern int TclDatedebug; -#endif - -/* Token type. */ -#ifndef YYTOKENTYPE -# define YYTOKENTYPE - enum yytokentype - { - tAGO = 258, - tDAY = 259, - tDAYZONE = 260, - tID = 261, - tMERIDIAN = 262, - tMONTH = 263, - tMONTH_UNIT = 264, - tSTARDATE = 265, - tSEC_UNIT = 266, - tSNUMBER = 267, - tUNUMBER = 268, - tZONE = 269, - tEPOCH = 270, - tDST = 271, - tISOBASE = 272, - tDAY_UNIT = 273, - tNEXT = 274 - }; -#endif - -/* Value type. */ +/* Enabling the token table. */ +#ifndef YYTOKEN_TABLE +# define YYTOKEN_TABLE 0 +#endif + #if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED +typedef union YYSTYPE -union YYSTYPE { - - time_t Number; enum _MERIDIAN Meridian; +} +/* Line 187 of yacc.c. */ - -}; - -typedef union YYSTYPE YYSTYPE; -# define YYSTYPE_IS_TRIVIAL 1 + YYSTYPE; +# define yystype YYSTYPE /* obsolescent; will be withdrawn */ # define YYSTYPE_IS_DECLARED 1 +# define YYSTYPE_IS_TRIVIAL 1 #endif -/* Location type. */ #if ! defined YYLTYPE && ! defined YYLTYPE_IS_DECLARED -typedef struct YYLTYPE YYLTYPE; -struct YYLTYPE +typedef struct YYLTYPE { int first_line; int first_column; int last_line; int last_column; -}; +} YYLTYPE; +# define yyltype YYLTYPE /* obsolescent; will be withdrawn */ # define YYLTYPE_IS_DECLARED 1 # define YYLTYPE_IS_TRIVIAL 1 #endif - - - -int TclDateparse (DateInfo* info); - /* Copy the second part of user declarations. */ @@ -315,10 +320,12 @@ time_t Seconds, MERIDIAN Meridian); MODULE_SCOPE int yyparse(DateInfo*); +/* Line 216 of yacc.c. */ + #ifdef short # undef short #endif @@ -328,106 +335,75 @@ typedef unsigned char yytype_uint8; #endif #ifdef YYTYPE_INT8 typedef YYTYPE_INT8 yytype_int8; -#else +#elif (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) typedef signed char yytype_int8; +#else +typedef short int yytype_int8; #endif #ifdef YYTYPE_UINT16 typedef YYTYPE_UINT16 yytype_uint16; #else -typedef unsigned short yytype_uint16; +typedef unsigned short int yytype_uint16; #endif #ifdef YYTYPE_INT16 typedef YYTYPE_INT16 yytype_int16; #else -typedef short yytype_int16; +typedef short int yytype_int16; #endif #ifndef YYSIZE_T # ifdef __SIZE_TYPE__ # define YYSIZE_T __SIZE_TYPE__ -# elif defined size_t -# define YYSIZE_T size_t -# elif ! defined YYSIZE_T -# include /* INFRINGES ON USER NAME SPACE */ -# define YYSIZE_T size_t # else -# define YYSIZE_T unsigned +# define YYSIZE_T size_t # endif #endif #define YYSIZE_MAXIMUM ((YYSIZE_T) -1) #ifndef YY_ -# if defined YYENABLE_NLS && YYENABLE_NLS +# if YYENABLE_NLS # if ENABLE_NLS # include /* INFRINGES ON USER NAME SPACE */ -# define YY_(Msgid) dgettext ("bison-runtime", Msgid) +# define YY_(msgid) dgettext ("bison-runtime", msgid) # endif # endif # ifndef YY_ -# define YY_(Msgid) Msgid -# endif -#endif - -#ifndef YY_ATTRIBUTE -# if (defined __GNUC__ \ - && (2 < __GNUC__ || (__GNUC__ == 2 && 96 <= __GNUC_MINOR__))) \ - || defined __SUNPRO_C && 0x5110 <= __SUNPRO_C -# define YY_ATTRIBUTE(Spec) __attribute__(Spec) -# else -# define YY_ATTRIBUTE(Spec) /* empty */ -# endif -#endif - -#ifndef YY_ATTRIBUTE_PURE -# define YY_ATTRIBUTE_PURE YY_ATTRIBUTE ((__pure__)) -#endif - -#ifndef YY_ATTRIBUTE_UNUSED -# define YY_ATTRIBUTE_UNUSED YY_ATTRIBUTE ((__unused__)) -#endif - -#if !defined _Noreturn \ - && (!defined __STDC_VERSION__ || __STDC_VERSION__ < 201112) -# if defined _MSC_VER && 1200 <= _MSC_VER -# define _Noreturn __declspec (noreturn) -# else -# define _Noreturn YY_ATTRIBUTE ((__noreturn__)) +# define YY_(msgid) msgid # endif #endif /* Suppress unused-variable warnings by "using" E. */ #if ! defined lint || defined __GNUC__ -# define YYUSE(E) ((void) (E)) -#else -# define YYUSE(E) /* empty */ -#endif - -#if defined __GNUC__ && ! defined __ICC && 407 <= __GNUC__ * 100 + __GNUC_MINOR__ -/* Suppress an incorrect diagnostic about yylval being uninitialized. */ -# define YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN \ - _Pragma ("GCC diagnostic push") \ - _Pragma ("GCC diagnostic ignored \"-Wuninitialized\"")\ - _Pragma ("GCC diagnostic ignored \"-Wmaybe-uninitialized\"") -# define YY_IGNORE_MAYBE_UNINITIALIZED_END \ - _Pragma ("GCC diagnostic pop") -#else -# define YY_INITIAL_VALUE(Value) Value -#endif -#ifndef YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN -# define YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN -# define YY_IGNORE_MAYBE_UNINITIALIZED_END -#endif -#ifndef YY_INITIAL_VALUE -# define YY_INITIAL_VALUE(Value) /* Nothing. */ -#endif - +# define YYUSE(e) ((void) (e)) +#else +# define YYUSE(e) /* empty */ +#endif + +/* Identity function, used to suppress warnings about constant conditions. */ +#ifndef lint +# define YYID(n) (n) +#else +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +static int +YYID (int i) +#else +static int +YYID (i) + int i; +#endif +{ + return i; +} +#endif #if ! defined yyoverflow || YYERROR_VERBOSE /* The parser invokes alloca or malloc; define the necessary symbols. */ @@ -442,24 +418,24 @@ # elif defined _MSC_VER # include /* INFRINGES ON USER NAME SPACE */ # define alloca _alloca # else # define YYSTACK_ALLOC alloca -# if ! defined _ALLOCA_H && ! defined EXIT_SUCCESS +# if ! defined _ALLOCA_H && ! defined _STDLIB_H && (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) # include /* INFRINGES ON USER NAME SPACE */ - /* Use EXIT_SUCCESS as a witness for stdlib.h. */ -# ifndef EXIT_SUCCESS -# define EXIT_SUCCESS 0 +# ifndef _STDLIB_H +# define _STDLIB_H 1 # endif # endif # endif # endif # endif # ifdef YYSTACK_ALLOC - /* Pacify GCC's 'empty if-body' warning. */ -# define YYSTACK_FREE(Ptr) do { /* empty */; } while (0) + /* Pacify GCC's `empty if-body' warning. */ +# define YYSTACK_FREE(Ptr) do { /* empty */; } while (YYID (0)) # ifndef YYSTACK_ALLOC_MAXIMUM /* The OS might guarantee only one guard page at the bottom of the stack, and a page size can be as small as 4096 bytes. So we cannot safely invoke alloca (N) if N exceeds 4096. Use a slightly smaller number to allow for a few compiler-allocated temporary stack slots. */ @@ -469,45 +445,47 @@ # define YYSTACK_ALLOC YYMALLOC # define YYSTACK_FREE YYFREE # ifndef YYSTACK_ALLOC_MAXIMUM # define YYSTACK_ALLOC_MAXIMUM YYSIZE_MAXIMUM # endif -# if (defined __cplusplus && ! defined EXIT_SUCCESS \ +# if (defined __cplusplus && ! defined _STDLIB_H \ && ! ((defined YYMALLOC || defined malloc) \ - && (defined YYFREE || defined free))) + && (defined YYFREE || defined free))) # include /* INFRINGES ON USER NAME SPACE */ -# ifndef EXIT_SUCCESS -# define EXIT_SUCCESS 0 +# ifndef _STDLIB_H +# define _STDLIB_H 1 # endif # endif # ifndef YYMALLOC # define YYMALLOC malloc -# if ! defined malloc && ! defined EXIT_SUCCESS +# if ! defined malloc && ! defined _STDLIB_H && (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) void *malloc (YYSIZE_T); /* INFRINGES ON USER NAME SPACE */ # endif # endif # ifndef YYFREE # define YYFREE free -# if ! defined free && ! defined EXIT_SUCCESS +# if ! defined free && ! defined _STDLIB_H && (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) void free (void *); /* INFRINGES ON USER NAME SPACE */ # endif # endif # endif #endif /* ! defined yyoverflow || YYERROR_VERBOSE */ #if (! defined yyoverflow \ && (! defined __cplusplus \ - || (defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL \ - && defined YYSTYPE_IS_TRIVIAL && YYSTYPE_IS_TRIVIAL))) + || (defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL \ + && defined YYSTYPE_IS_TRIVIAL && YYSTYPE_IS_TRIVIAL))) /* A type that is properly aligned for any stack member. */ union yyalloc { - yytype_int16 yyss_alloc; - YYSTYPE yyvs_alloc; - YYLTYPE yyls_alloc; + yytype_int16 yyss; + YYSTYPE yyvs; + YYLTYPE yyls; }; /* The size of the maximum gap between one aligned stack and the next. */ # define YYSTACK_GAP_MAXIMUM (sizeof (union yyalloc) - 1) @@ -515,81 +493,75 @@ N elements. */ # define YYSTACK_BYTES(N) \ ((N) * (sizeof (yytype_int16) + sizeof (YYSTYPE) + sizeof (YYLTYPE)) \ + 2 * YYSTACK_GAP_MAXIMUM) -# define YYCOPY_NEEDED 1 +/* Copy COUNT objects from FROM to TO. The source and destination do + not overlap. */ +# ifndef YYCOPY +# if defined __GNUC__ && 1 < __GNUC__ +# define YYCOPY(To, From, Count) \ + __builtin_memcpy (To, From, (Count) * sizeof (*(From))) +# else +# define YYCOPY(To, From, Count) \ + do \ + { \ + YYSIZE_T yyi; \ + for (yyi = 0; yyi < (Count); yyi++) \ + (To)[yyi] = (From)[yyi]; \ + } \ + while (YYID (0)) +# endif +# endif /* Relocate STACK from its old location to the new one. The local variables YYSIZE and YYSTACKSIZE give the old and new number of elements in the stack, and YYPTR gives the new location of the stack. Advance YYPTR to a properly aligned location for the next stack. */ -# define YYSTACK_RELOCATE(Stack_alloc, Stack) \ - do \ - { \ - YYSIZE_T yynewbytes; \ - YYCOPY (&yyptr->Stack_alloc, Stack, yysize); \ - Stack = &yyptr->Stack_alloc; \ - yynewbytes = yystacksize * sizeof (*Stack) + YYSTACK_GAP_MAXIMUM; \ - yyptr += yynewbytes / sizeof (*yyptr); \ - } \ - while (0) +# define YYSTACK_RELOCATE(Stack) \ + do \ + { \ + YYSIZE_T yynewbytes; \ + YYCOPY (&yyptr->Stack, Stack, yysize); \ + Stack = &yyptr->Stack; \ + yynewbytes = yystacksize * sizeof (*Stack) + YYSTACK_GAP_MAXIMUM; \ + yyptr += yynewbytes / sizeof (*yyptr); \ + } \ + while (YYID (0)) #endif -#if defined YYCOPY_NEEDED && YYCOPY_NEEDED -/* Copy COUNT objects from SRC to DST. The source and destination do - not overlap. */ -# ifndef YYCOPY -# if defined __GNUC__ && 1 < __GNUC__ -# define YYCOPY(Dst, Src, Count) \ - __builtin_memcpy (Dst, Src, (Count) * sizeof (*(Src))) -# else -# define YYCOPY(Dst, Src, Count) \ - do \ - { \ - YYSIZE_T yyi; \ - for (yyi = 0; yyi < (Count); yyi++) \ - (Dst)[yyi] = (Src)[yyi]; \ - } \ - while (0) -# endif -# endif -#endif /* !YYCOPY_NEEDED */ - /* YYFINAL -- State number of the termination state. */ #define YYFINAL 2 /* YYLAST -- Last index in YYTABLE. */ -#define YYLAST 81 +#define YYLAST 79 /* YYNTOKENS -- Number of terminals. */ #define YYNTOKENS 26 /* YYNNTS -- Number of nonterminals. */ #define YYNNTS 16 /* YYNRULES -- Number of rules. */ #define YYNRULES 56 -/* YYNSTATES -- Number of states. */ -#define YYNSTATES 85 +/* YYNRULES -- Number of states. */ +#define YYNSTATES 83 -/* YYTRANSLATE[YYX] -- Symbol number corresponding to YYX as returned - by yylex, with out-of-bounds checking. */ +/* YYTRANSLATE(YYLEX) -- Bison symbol number corresponding to YYLEX. */ #define YYUNDEFTOK 2 #define YYMAXUTOK 274 -#define YYTRANSLATE(YYX) \ - ((unsigned) (YYX) <= YYMAXUTOK ? yytranslate[YYX] : YYUNDEFTOK) +#define YYTRANSLATE(YYX) \ + ((unsigned int) (YYX) <= YYMAXUTOK ? yytranslate[YYX] : YYUNDEFTOK) -/* YYTRANSLATE[TOKEN-NUM] -- Symbol number corresponding to TOKEN-NUM - as returned by yylex, without out-of-bounds checking. */ +/* YYTRANSLATE[YYLEX] -- Bison symbol number corresponding to YYLEX. */ static const yytype_uint8 yytranslate[] = { 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 25, 21, 23, 24, 22, 2, 2, + 2, 2, 2, 25, 22, 21, 24, 23, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 20, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, @@ -612,332 +584,370 @@ 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19 }; #if YYDEBUG - /* YYRLINE[YYN] -- Source line where rule number YYN was defined. */ +/* YYPRHS[YYN] -- Index of the first RHS symbol of rule number YYN in + YYRHS. */ +static const yytype_uint8 yyprhs[] = +{ + 0, 0, 3, 4, 7, 9, 11, 13, 15, 17, + 19, 21, 23, 25, 28, 33, 39, 46, 54, 57, + 59, 61, 63, 66, 69, 73, 76, 80, 86, 88, + 94, 100, 103, 108, 111, 113, 117, 120, 124, 128, + 136, 139, 144, 147, 149, 153, 156, 159, 163, 165, + 167, 169, 171, 173, 175, 177, 178 +}; + +/* YYRHS -- A `-1'-separated list of the rules' RHS. */ +static const yytype_int8 yyrhs[] = +{ + 27, 0, -1, -1, 27, 28, -1, 29, -1, 30, + -1, 32, -1, 33, -1, 31, -1, 36, -1, 34, + -1, 35, -1, 40, -1, 13, 7, -1, 13, 20, + 13, 41, -1, 13, 20, 13, 21, 13, -1, 13, + 20, 13, 20, 13, 41, -1, 13, 20, 13, 20, + 13, 21, 13, -1, 14, 16, -1, 14, -1, 5, + -1, 4, -1, 4, 22, -1, 13, 4, -1, 38, + 13, 4, -1, 19, 4, -1, 13, 23, 13, -1, + 13, 23, 13, 23, 13, -1, 17, -1, 13, 21, + 8, 21, 13, -1, 13, 21, 13, 21, 13, -1, + 8, 13, -1, 8, 13, 22, 13, -1, 13, 8, + -1, 15, -1, 13, 8, 13, -1, 19, 8, -1, + 19, 13, 8, -1, 17, 14, 17, -1, 17, 14, + 13, 20, 13, 20, 13, -1, 17, 17, -1, 10, + 13, 24, 13, -1, 37, 3, -1, 37, -1, 38, + 13, 39, -1, 13, 39, -1, 19, 39, -1, 19, + 13, 39, -1, 39, -1, 21, -1, 25, -1, 11, + -1, 18, -1, 9, -1, 13, -1, -1, 7, -1 +}; + +/* YYRLINE[YYN] -- source line where rule number YYN was defined. */ static const yytype_uint16 yyrline[] = { - 0, 223, 223, 224, 227, 230, 233, 236, 239, 242, - 245, 249, 254, 257, 263, 269, 277, 282, 287, 291, - 297, 301, 305, 309, 313, 319, 323, 328, 333, 338, - 343, 347, 352, 356, 361, 368, 372, 378, 388, 397, - 406, 416, 430, 435, 438, 441, 444, 447, 450, 455, - 458, 463, 467, 471, 477, 495, 498 + 0, 225, 225, 226, 229, 232, 235, 238, 241, 244, + 247, 251, 256, 259, 265, 271, 279, 285, 296, 300, + 304, 310, 314, 318, 322, 326, 332, 336, 341, 346, + 351, 356, 360, 365, 369, 374, 381, 385, 391, 400, + 409, 419, 433, 438, 441, 444, 447, 450, 453, 458, + 461, 466, 470, 474, 480, 498, 501 }; #endif -#if YYDEBUG || YYERROR_VERBOSE || 0 +#if YYDEBUG || YYERROR_VERBOSE || YYTOKEN_TABLE /* YYTNAME[SYMBOL-NUM] -- String name of the symbol SYMBOL-NUM. First, the terminals, then, starting at YYNTOKENS, nonterminals. */ static const char *const yytname[] = { "$end", "error", "$undefined", "tAGO", "tDAY", "tDAYZONE", "tID", "tMERIDIAN", "tMONTH", "tMONTH_UNIT", "tSTARDATE", "tSEC_UNIT", "tSNUMBER", "tUNUMBER", "tZONE", "tEPOCH", "tDST", "tISOBASE", - "tDAY_UNIT", "tNEXT", "':'", "','", "'/'", "'-'", "'.'", "'+'", + "tDAY_UNIT", "tNEXT", "':'", "'-'", "','", "'/'", "'.'", "'+'", "$accept", "spec", "item", "time", "zone", "day", "date", "ordMonth", "iso", "trek", "relspec", "relunits", "sign", "unit", "number", - "o_merid", YY_NULLPTR + "o_merid", 0 }; #endif # ifdef YYPRINT -/* YYTOKNUM[NUM] -- (External) token number corresponding to the - (internal) symbol number NUM (which must be that of a token). */ +/* YYTOKNUM[YYLEX-NUM] -- Internal token number corresponding to + token YYLEX-NUM. */ static const yytype_uint16 yytoknum[] = { 0, 256, 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, 267, 268, 269, 270, 271, 272, 273, 274, - 58, 44, 47, 45, 46, 43 + 58, 45, 44, 47, 46, 43 }; # endif -#define YYPACT_NINF -18 - -#define yypact_value_is_default(Yystate) \ - (!!((Yystate) == (-18))) - -#define YYTABLE_NINF -1 - -#define yytable_value_is_error(Yytable_value) \ - 0 - - /* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing - STATE-NUM. */ -static const yytype_int8 yypact[] = -{ - -18, 2, -18, -17, -18, -4, -18, 10, -18, 22, - 8, -18, 18, -18, 39, -18, -18, -18, -18, -18, - -18, -18, -18, -18, -18, -18, 25, 21, -18, -18, - -18, 16, 14, -18, -18, 28, 36, 41, -5, -18, - -18, 5, -18, -18, -18, 47, -18, -18, 42, 46, - 48, -18, -6, 40, 43, 44, 49, -18, -18, -18, - -18, -18, -18, -18, -18, 50, -18, 51, 55, 57, - 58, 65, -18, -18, 59, 54, -18, 62, 63, 60, - -18, 64, 61, 66, -18 +/* YYR1[YYN] -- Symbol number of symbol that rule YYN derives. */ +static const yytype_uint8 yyr1[] = +{ + 0, 26, 27, 27, 28, 28, 28, 28, 28, 28, + 28, 28, 28, 29, 29, 29, 29, 29, 30, 30, + 30, 31, 31, 31, 31, 31, 32, 32, 32, 32, + 32, 32, 32, 32, 32, 32, 33, 33, 34, 34, + 34, 35, 36, 36, 37, 37, 37, 37, 37, 38, + 38, 39, 39, 39, 40, 41, 41 +}; + +/* YYR2[YYN] -- Number of symbols composing right hand side of rule YYN. */ +static const yytype_uint8 yyr2[] = +{ + 0, 2, 0, 2, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 2, 4, 5, 6, 7, 2, 1, + 1, 1, 2, 2, 3, 2, 3, 5, 1, 5, + 5, 2, 4, 2, 1, 3, 2, 3, 3, 7, + 2, 4, 2, 1, 3, 2, 2, 3, 1, 1, + 1, 1, 1, 1, 1, 0, 1 }; - /* YYDEFACT[STATE-NUM] -- Default reduction number in state STATE-NUM. - Performed when YYTABLE does not specify something else to do. Zero - means the default is an error. */ +/* YYDEFACT[STATE-NAME] -- Default rule to reduce with in state + STATE-NUM when YYTABLE doesn't specify something else to do. Zero + means the default is an error. */ static const yytype_uint8 yydefact[] = { - 2, 0, 1, 20, 18, 0, 53, 0, 51, 54, - 17, 33, 27, 52, 0, 49, 50, 3, 4, 5, + 2, 0, 1, 21, 20, 0, 53, 0, 51, 54, + 19, 34, 28, 52, 0, 49, 50, 3, 4, 5, 8, 6, 7, 10, 11, 9, 43, 0, 48, 12, - 21, 30, 0, 22, 13, 32, 0, 0, 0, 45, - 16, 0, 40, 24, 35, 0, 46, 42, 19, 0, - 0, 34, 55, 25, 0, 0, 0, 38, 36, 47, - 23, 44, 31, 41, 56, 0, 14, 0, 0, 0, - 0, 55, 26, 28, 29, 0, 15, 0, 0, 0, - 39, 0, 0, 0, 37 -}; - - /* YYPGOTO[NTERM-NUM]. */ -static const yytype_int8 yypgoto[] = -{ - -18, -18, -18, -18, -18, -18, -18, -18, -18, -18, - -18, -18, -18, -9, -18, 7 -}; - - /* YYDEFGOTO[NTERM-NUM]. */ + 22, 31, 0, 23, 13, 33, 0, 0, 0, 45, + 18, 0, 40, 25, 36, 0, 46, 42, 0, 0, + 0, 35, 55, 0, 0, 26, 0, 38, 37, 47, + 24, 44, 32, 41, 56, 0, 0, 14, 0, 0, + 0, 0, 55, 15, 29, 30, 27, 0, 0, 16, + 0, 17, 39 +}; + +/* YYDEFGOTO[NTERM-NUM]. */ static const yytype_int8 yydefgoto[] = { -1, 1, 17, 18, 19, 20, 21, 22, 23, 24, - 25, 26, 27, 28, 29, 66 + 25, 26, 27, 28, 29, 67 +}; + +/* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing + STATE-NUM. */ +#define YYPACT_NINF -22 +static const yytype_int8 yypact[] = +{ + -22, 2, -22, -21, -22, -4, -22, 1, -22, 22, + 18, -22, 8, -22, 40, -22, -22, -22, -22, -22, + -22, -22, -22, -22, -22, -22, 32, 28, -22, -22, + -22, 24, 26, -22, -22, 42, 47, -5, 49, -22, + -22, 15, -22, -22, -22, 48, -22, -22, 43, 50, + 51, -22, 17, 44, 46, 45, 52, -22, -22, -22, + -22, -22, -22, -22, -22, 56, 57, -22, 58, 60, + 61, 62, -3, -22, -22, -22, -22, 59, 63, -22, + 64, -22, -22 +}; + +/* YYPGOTO[NTERM-NUM]. */ +static const yytype_int8 yypgoto[] = +{ + -22, -22, -22, -22, -22, -22, -22, -22, -22, -22, + -22, -22, -22, -9, -22, 6 }; - /* YYTABLE[YYPACT[STATE-NUM]] -- What to do in state STATE-NUM. If - positive, shift that token. If negative, reduce the rule whose - number is the opposite. If YYTABLE_NINF, syntax error. */ +/* YYTABLE[YYPACT[STATE-NUM]]. What to do in state STATE-NUM. If + positive, shift that token. If negative, reduce the rule which + number is the opposite. If zero, do what YYDEFACT says. + If YYTABLE_NINF, syntax error. */ +#define YYTABLE_NINF -1 static const yytype_uint8 yytable[] = { - 39, 64, 2, 54, 30, 46, 3, 4, 55, 31, - 5, 6, 7, 8, 65, 9, 10, 11, 56, 12, - 13, 14, 57, 32, 40, 15, 33, 16, 47, 34, - 35, 6, 41, 8, 48, 42, 59, 49, 50, 61, - 13, 51, 36, 43, 37, 38, 60, 44, 6, 52, - 8, 6, 45, 8, 53, 58, 6, 13, 8, 62, - 13, 63, 67, 71, 72, 13, 68, 69, 73, 70, - 74, 75, 64, 77, 78, 79, 80, 82, 76, 84, - 81, 83 + 39, 30, 2, 53, 64, 46, 3, 4, 54, 31, + 5, 6, 7, 8, 32, 9, 10, 11, 78, 12, + 13, 14, 41, 15, 64, 42, 33, 16, 56, 34, + 35, 6, 57, 8, 40, 47, 59, 65, 66, 61, + 13, 48, 36, 37, 43, 38, 49, 60, 44, 6, + 50, 8, 6, 45, 8, 51, 58, 6, 13, 8, + 52, 13, 55, 62, 63, 68, 13, 69, 70, 72, + 73, 74, 71, 75, 76, 77, 81, 82, 79, 80 }; static const yytype_uint8 yycheck[] = { - 9, 7, 0, 8, 21, 14, 4, 5, 13, 13, - 8, 9, 10, 11, 20, 13, 14, 15, 13, 17, - 18, 19, 17, 13, 16, 23, 4, 25, 3, 7, - 8, 9, 14, 11, 13, 17, 45, 21, 24, 48, - 18, 13, 20, 4, 22, 23, 4, 8, 9, 13, - 11, 9, 13, 11, 13, 8, 9, 18, 11, 13, - 18, 13, 22, 13, 13, 18, 23, 23, 13, 20, - 13, 13, 7, 14, 20, 13, 13, 13, 71, 13, - 20, 20 + 9, 22, 0, 8, 7, 14, 4, 5, 13, 13, + 8, 9, 10, 11, 13, 13, 14, 15, 21, 17, + 18, 19, 14, 21, 7, 17, 4, 25, 13, 7, + 8, 9, 17, 11, 16, 3, 45, 20, 21, 48, + 18, 13, 20, 21, 4, 23, 22, 4, 8, 9, + 24, 11, 9, 13, 11, 13, 8, 9, 18, 11, + 13, 18, 13, 13, 13, 21, 18, 21, 23, 13, + 13, 13, 20, 13, 13, 13, 13, 13, 72, 20 }; - /* YYSTOS[STATE-NUM] -- The (internal number of the) accessing - symbol of state STATE-NUM. */ +/* YYSTOS[STATE-NUM] -- The (internal number of the) accessing + symbol of state STATE-NUM. */ static const yytype_uint8 yystos[] = { 0, 27, 0, 4, 5, 8, 9, 10, 11, 13, - 14, 15, 17, 18, 19, 23, 25, 28, 29, 30, - 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, - 21, 13, 13, 4, 7, 8, 20, 22, 23, 39, - 16, 14, 17, 4, 8, 13, 39, 3, 13, 21, - 24, 13, 13, 13, 8, 13, 13, 17, 8, 39, - 4, 39, 13, 13, 7, 20, 41, 22, 23, 23, - 20, 13, 13, 13, 13, 13, 41, 14, 20, 13, - 13, 20, 13, 20, 13 -}; - - /* YYR1[YYN] -- Symbol number of symbol that rule YYN derives. */ -static const yytype_uint8 yyr1[] = -{ - 0, 26, 27, 27, 28, 28, 28, 28, 28, 28, - 28, 28, 28, 29, 29, 29, 30, 30, 30, 30, - 31, 31, 31, 31, 31, 32, 32, 32, 32, 32, - 32, 32, 32, 32, 32, 33, 33, 34, 34, 34, - 34, 35, 36, 36, 37, 37, 37, 37, 37, 38, - 38, 39, 39, 39, 40, 41, 41 -}; - - /* YYR2[YYN] -- Number of symbols on the right hand side of rule YYN. */ -static const yytype_uint8 yyr2[] = -{ - 0, 2, 0, 2, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 2, 4, 6, 2, 1, 1, 2, - 1, 2, 2, 3, 2, 3, 5, 1, 5, 5, - 2, 4, 2, 1, 3, 2, 3, 11, 3, 7, - 2, 4, 2, 1, 3, 2, 2, 3, 1, 1, - 1, 1, 1, 1, 1, 0, 1 -}; - - -#define yyerrok (yyerrstatus = 0) -#define yyclearin (yychar = YYEMPTY) -#define YYEMPTY (-2) -#define YYEOF 0 - -#define YYACCEPT goto yyacceptlab -#define YYABORT goto yyabortlab -#define YYERROR goto yyerrorlab - + 14, 15, 17, 18, 19, 21, 25, 28, 29, 30, + 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, + 22, 13, 13, 4, 7, 8, 20, 21, 23, 39, + 16, 14, 17, 4, 8, 13, 39, 3, 13, 22, + 24, 13, 13, 8, 13, 13, 13, 17, 8, 39, + 4, 39, 13, 13, 7, 20, 21, 41, 21, 21, + 23, 20, 13, 13, 13, 13, 13, 13, 21, 41, + 20, 13, 13 +}; + +#define yyerrok (yyerrstatus = 0) +#define yyclearin (yychar = YYEMPTY) +#define YYEMPTY (-2) +#define YYEOF 0 + +#define YYACCEPT goto yyacceptlab +#define YYABORT goto yyabortlab +#define YYERROR goto yyerrorlab + + +/* Like YYERROR except do call yyerror. This remains here temporarily + to ease the transition to the new meaning of YYERROR, for GCC. + Once GCC version 2 has supplanted version 1, this can go. */ + +#define YYFAIL goto yyerrlab #define YYRECOVERING() (!!yyerrstatus) -#define YYBACKUP(Token, Value) \ -do \ - if (yychar == YYEMPTY) \ - { \ - yychar = (Token); \ - yylval = (Value); \ - YYPOPSTACK (yylen); \ - yystate = *yyssp; \ - goto yybackup; \ - } \ - else \ - { \ +#define YYBACKUP(Token, Value) \ +do \ + if (yychar == YYEMPTY && yylen == 1) \ + { \ + yychar = (Token); \ + yylval = (Value); \ + yytoken = YYTRANSLATE (yychar); \ + YYPOPSTACK (1); \ + goto yybackup; \ + } \ + else \ + { \ yyerror (&yylloc, info, YY_("syntax error: cannot back up")); \ - YYERROR; \ - } \ -while (0) + YYERROR; \ + } \ +while (YYID (0)) -/* Error token number */ -#define YYTERROR 1 -#define YYERRCODE 256 + +#define YYTERROR 1 +#define YYERRCODE 256 /* YYLLOC_DEFAULT -- Set CURRENT to span from RHS[1] to RHS[N]. If N is 0, then set CURRENT to the empty location which ends the previous symbol: RHS[0] (always defined). */ +#define YYRHSLOC(Rhs, K) ((Rhs)[K]) #ifndef YYLLOC_DEFAULT -# define YYLLOC_DEFAULT(Current, Rhs, N) \ - do \ - if (N) \ - { \ - (Current).first_line = YYRHSLOC (Rhs, 1).first_line; \ - (Current).first_column = YYRHSLOC (Rhs, 1).first_column; \ - (Current).last_line = YYRHSLOC (Rhs, N).last_line; \ - (Current).last_column = YYRHSLOC (Rhs, N).last_column; \ - } \ - else \ - { \ - (Current).first_line = (Current).last_line = \ - YYRHSLOC (Rhs, 0).last_line; \ - (Current).first_column = (Current).last_column = \ - YYRHSLOC (Rhs, 0).last_column; \ - } \ - while (0) +# define YYLLOC_DEFAULT(Current, Rhs, N) \ + do \ + if (YYID (N)) \ + { \ + (Current).first_line = YYRHSLOC (Rhs, 1).first_line; \ + (Current).first_column = YYRHSLOC (Rhs, 1).first_column; \ + (Current).last_line = YYRHSLOC (Rhs, N).last_line; \ + (Current).last_column = YYRHSLOC (Rhs, N).last_column; \ + } \ + else \ + { \ + (Current).first_line = (Current).last_line = \ + YYRHSLOC (Rhs, 0).last_line; \ + (Current).first_column = (Current).last_column = \ + YYRHSLOC (Rhs, 0).last_column; \ + } \ + while (YYID (0)) +#endif + + +/* YY_LOCATION_PRINT -- Print the location on the stream. + This macro was not mandated originally: define only if we know + we won't break user code: when these are the locations we know. */ + +#ifndef YY_LOCATION_PRINT +# if YYLTYPE_IS_TRIVIAL +# define YY_LOCATION_PRINT(File, Loc) \ + fprintf (File, "%d.%d-%d.%d", \ + (Loc).first_line, (Loc).first_column, \ + (Loc).last_line, (Loc).last_column) +# else +# define YY_LOCATION_PRINT(File, Loc) ((void) 0) +# endif #endif -#define YYRHSLOC(Rhs, K) ((Rhs)[K]) +/* YYLEX -- calling `yylex' with the right arguments. */ + +#ifdef YYLEX_PARAM +# define YYLEX yylex (&yylval, &yylloc, YYLEX_PARAM) +#else +# define YYLEX yylex (&yylval, &yylloc, info) +#endif /* Enable debugging if requested. */ #if YYDEBUG # ifndef YYFPRINTF # include /* INFRINGES ON USER NAME SPACE */ # define YYFPRINTF fprintf # endif -# define YYDPRINTF(Args) \ -do { \ - if (yydebug) \ - YYFPRINTF Args; \ -} while (0) - - -/* YY_LOCATION_PRINT -- Print the location on the stream. - This macro was not mandated originally: define only if we know - we won't break user code: when these are the locations we know. */ - -#ifndef YY_LOCATION_PRINT -# if defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL - -/* Print *YYLOCP on YYO. Private, do not rely on its existence. */ - -YY_ATTRIBUTE_UNUSED -static unsigned -yy_location_print_ (FILE *yyo, YYLTYPE const * const yylocp) -{ - unsigned res = 0; - int end_col = 0 != yylocp->last_column ? yylocp->last_column - 1 : 0; - if (0 <= yylocp->first_line) - { - res += YYFPRINTF (yyo, "%d", yylocp->first_line); - if (0 <= yylocp->first_column) - res += YYFPRINTF (yyo, ".%d", yylocp->first_column); - } - if (0 <= yylocp->last_line) - { - if (yylocp->first_line < yylocp->last_line) - { - res += YYFPRINTF (yyo, "-%d", yylocp->last_line); - if (0 <= end_col) - res += YYFPRINTF (yyo, ".%d", end_col); - } - else if (0 <= end_col && yylocp->first_column < end_col) - res += YYFPRINTF (yyo, "-%d", end_col); - } - return res; - } - -# define YY_LOCATION_PRINT(File, Loc) \ - yy_location_print_ (File, &(Loc)) - -# else -# define YY_LOCATION_PRINT(File, Loc) ((void) 0) -# endif -#endif - - -# define YY_SYMBOL_PRINT(Title, Type, Value, Location) \ -do { \ - if (yydebug) \ - { \ - YYFPRINTF (stderr, "%s ", Title); \ - yy_symbol_print (stderr, \ - Type, Value, Location, info); \ - YYFPRINTF (stderr, "\n"); \ - } \ -} while (0) - - -/*----------------------------------------. -| Print this symbol's value on YYOUTPUT. | -`----------------------------------------*/ - +# define YYDPRINTF(Args) \ +do { \ + if (yydebug) \ + YYFPRINTF Args; \ +} while (YYID (0)) + +# define YY_SYMBOL_PRINT(Title, Type, Value, Location) \ +do { \ + if (yydebug) \ + { \ + YYFPRINTF (stderr, "%s ", Title); \ + yy_symbol_print (stderr, \ + Type, Value, Location, info); \ + YYFPRINTF (stderr, "\n"); \ + } \ +} while (YYID (0)) + + +/*--------------------------------. +| Print this symbol on YYOUTPUT. | +`--------------------------------*/ + +/*ARGSUSED*/ +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) static void yy_symbol_value_print (FILE *yyoutput, int yytype, YYSTYPE const * const yyvaluep, YYLTYPE const * const yylocationp, DateInfo* info) +#else +static void +yy_symbol_value_print (yyoutput, yytype, yyvaluep, yylocationp, info) + FILE *yyoutput; + int yytype; + YYSTYPE const * const yyvaluep; + YYLTYPE const * const yylocationp; + DateInfo* info; +#endif { - FILE *yyo = yyoutput; - YYUSE (yyo); + if (!yyvaluep) + return; YYUSE (yylocationp); YYUSE (info); - if (!yyvaluep) - return; # ifdef YYPRINT if (yytype < YYNTOKENS) YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep); +# else + YYUSE (yyoutput); # endif - YYUSE (yytype); + switch (yytype) + { + default: + break; + } } /*--------------------------------. | Print this symbol on YYOUTPUT. | `--------------------------------*/ +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) static void yy_symbol_print (FILE *yyoutput, int yytype, YYSTYPE const * const yyvaluep, YYLTYPE const * const yylocationp, DateInfo* info) +#else +static void +yy_symbol_print (yyoutput, yytype, yyvaluep, yylocationp, info) + FILE *yyoutput; + int yytype; + YYSTYPE const * const yyvaluep; + YYLTYPE const * const yylocationp; + DateInfo* info; +#endif { - YYFPRINTF (yyoutput, "%s %s (", - yytype < YYNTOKENS ? "token" : "nterm", yytname[yytype]); + if (yytype < YYNTOKENS) + YYFPRINTF (yyoutput, "token %s (", yytname[yytype]); + else + YYFPRINTF (yyoutput, "nterm %s (", yytname[yytype]); YY_LOCATION_PRINT (yyoutput, *yylocationp); YYFPRINTF (yyoutput, ": "); yy_symbol_value_print (yyoutput, yytype, yyvaluep, yylocationp, info); YYFPRINTF (yyoutput, ")"); @@ -946,58 +956,72 @@ /*------------------------------------------------------------------. | yy_stack_print -- Print the state stack from its BOTTOM up to its | | TOP (included). | `------------------------------------------------------------------*/ +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +static void +yy_stack_print (yytype_int16 *bottom, yytype_int16 *top) +#else static void -yy_stack_print (yytype_int16 *yybottom, yytype_int16 *yytop) +yy_stack_print (bottom, top) + yytype_int16 *bottom; + yytype_int16 *top; +#endif { YYFPRINTF (stderr, "Stack now"); - for (; yybottom <= yytop; yybottom++) - { - int yybot = *yybottom; - YYFPRINTF (stderr, " %d", yybot); - } + for (; bottom <= top; ++bottom) + YYFPRINTF (stderr, " %d", *bottom); YYFPRINTF (stderr, "\n"); } -# define YY_STACK_PRINT(Bottom, Top) \ -do { \ - if (yydebug) \ - yy_stack_print ((Bottom), (Top)); \ -} while (0) +# define YY_STACK_PRINT(Bottom, Top) \ +do { \ + if (yydebug) \ + yy_stack_print ((Bottom), (Top)); \ +} while (YYID (0)) /*------------------------------------------------. | Report that the YYRULE is going to be reduced. | `------------------------------------------------*/ +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +static void +yy_reduce_print (YYSTYPE *yyvsp, YYLTYPE *yylsp, int yyrule, DateInfo* info) +#else static void -yy_reduce_print (yytype_int16 *yyssp, YYSTYPE *yyvsp, YYLTYPE *yylsp, int yyrule, DateInfo* info) +yy_reduce_print (yyvsp, yylsp, yyrule, info) + YYSTYPE *yyvsp; + YYLTYPE *yylsp; + int yyrule; + DateInfo* info; +#endif { - unsigned long yylno = yyrline[yyrule]; int yynrhs = yyr2[yyrule]; int yyi; + unsigned long int yylno = yyrline[yyrule]; YYFPRINTF (stderr, "Reducing stack by rule %d (line %lu):\n", - yyrule - 1, yylno); + yyrule - 1, yylno); /* The symbols being reduced. */ for (yyi = 0; yyi < yynrhs; yyi++) { - YYFPRINTF (stderr, " $%d = ", yyi + 1); - yy_symbol_print (stderr, - yystos[yyssp[yyi + 1 - yynrhs]], - &(yyvsp[(yyi + 1) - (yynrhs)]) - , &(yylsp[(yyi + 1) - (yynrhs)]) , info); - YYFPRINTF (stderr, "\n"); + fprintf (stderr, " $%d = ", yyi + 1); + yy_symbol_print (stderr, yyrhs[yyprhs[yyrule] + yyi], + &(yyvsp[(yyi + 1) - (yynrhs)]) + , &(yylsp[(yyi + 1) - (yynrhs)]) , info); + fprintf (stderr, "\n"); } } -# define YY_REDUCE_PRINT(Rule) \ -do { \ - if (yydebug) \ - yy_reduce_print (yyssp, yyvsp, yylsp, Rule, info); \ -} while (0) +# define YY_REDUCE_PRINT(Rule) \ +do { \ + if (yydebug) \ + yy_reduce_print (yyvsp, yylsp, Rule, info); \ +} while (YYID (0)) /* Nonzero means print parse trace. It is left uninitialized so that multiple parsers can coexist. */ int yydebug; #else /* !YYDEBUG */ @@ -1007,11 +1031,11 @@ # define YY_REDUCE_PRINT(Rule) #endif /* !YYDEBUG */ /* YYINITDEPTH -- initial size of the parser's stacks. */ -#ifndef YYINITDEPTH +#ifndef YYINITDEPTH # define YYINITDEPTH 200 #endif /* YYMAXDEPTH -- maximum size the stacks can grow to (effective only if the built-in stack extension method is used). @@ -1022,20 +1046,28 @@ #ifndef YYMAXDEPTH # define YYMAXDEPTH 10000 #endif + #if YYERROR_VERBOSE # ifndef yystrlen # if defined __GLIBC__ && defined _STRING_H # define yystrlen strlen # else /* Return the length of YYSTR. */ +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) static YYSIZE_T yystrlen (const char *yystr) +#else +static YYSIZE_T +yystrlen (yystr) + const char *yystr; +#endif { YYSIZE_T yylen; for (yylen = 0; yystr[yylen]; yylen++) continue; return yylen; @@ -1047,12 +1079,20 @@ # if defined __GLIBC__ && defined _STRING_H && defined _GNU_SOURCE # define yystpcpy stpcpy # else /* Copy YYSRC to YYDEST, returning the address of the terminating '\0' in YYDEST. */ +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) static char * yystpcpy (char *yydest, const char *yysrc) +#else +static char * +yystpcpy (yydest, yysrc) + char *yydest; + const char *yysrc; +#endif { char *yyd = yydest; const char *yys = yysrc; while ((*yyd++ = *yys++) != '\0') @@ -1078,31 +1118,31 @@ { YYSIZE_T yyn = 0; char const *yyp = yystr; for (;;) - switch (*++yyp) - { - case '\'': - case ',': - goto do_not_strip_quotes; - - case '\\': - if (*++yyp != '\\') - goto do_not_strip_quotes; - /* Fall through. */ - default: - if (yyres) - yyres[yyn] = *yyp; - yyn++; - break; - - case '"': - if (yyres) - yyres[yyn] = '\0'; - return yyn; - } + switch (*++yyp) + { + case '\'': + case ',': + goto do_not_strip_quotes; + + case '\\': + if (*++yyp != '\\') + goto do_not_strip_quotes; + /* Fall through. */ + default: + if (yyres) + yyres[yyn] = *yyp; + yyn++; + break; + + case '"': + if (yyres) + yyres[yyn] = '\0'; + return yyn; + } do_not_strip_quotes: ; } if (! yyres) return yystrlen (yystr); @@ -1109,263 +1149,287 @@ return yystpcpy (yyres, yystr) - yyres; } # endif -/* Copy into *YYMSG, which is of size *YYMSG_ALLOC, an error message - about the unexpected token YYTOKEN for the state stack whose top is - YYSSP. - - Return 0 if *YYMSG was successfully written. Return 1 if *YYMSG is - not large enough to hold the message. In that case, also set - *YYMSG_ALLOC to the required number of bytes. Return 2 if the - required number of bytes is too large to store. */ -static int -yysyntax_error (YYSIZE_T *yymsg_alloc, char **yymsg, - yytype_int16 *yyssp, int yytoken) -{ - YYSIZE_T yysize0 = yytnamerr (YY_NULLPTR, yytname[yytoken]); - YYSIZE_T yysize = yysize0; - enum { YYERROR_VERBOSE_ARGS_MAXIMUM = 5 }; - /* Internationalized format string. */ - const char *yyformat = YY_NULLPTR; - /* Arguments of yyformat. */ - char const *yyarg[YYERROR_VERBOSE_ARGS_MAXIMUM]; - /* Number of reported tokens (one for the "unexpected", one per - "expected"). */ - int yycount = 0; - - /* There are many possibilities here to consider: - - If this state is a consistent state with a default action, then - the only way this function was invoked is if the default action - is an error action. In that case, don't check for expected - tokens because there are none. - - The only way there can be no lookahead present (in yychar) is if - this state is a consistent state with a default action. Thus, - detecting the absence of a lookahead is sufficient to determine - that there is no unexpected or expected token to report. In that - case, just report a simple "syntax error". - - Don't assume there isn't a lookahead just because this state is a - consistent state with a default action. There might have been a - previous inconsistent state, consistent state with a non-default - action, or user semantic action that manipulated yychar. - - Of course, the expected token list depends on states to have - correct lookahead information, and it depends on the parser not - to perform extra reductions after fetching a lookahead from the - scanner and before detecting a syntax error. Thus, state merging - (from LALR or IELR) and default reductions corrupt the expected - token list. However, the list is correct for canonical LR with - one exception: it will still contain any token that will not be - accepted due to an error action in a later state. - */ - if (yytoken != YYEMPTY) - { - int yyn = yypact[*yyssp]; - yyarg[yycount++] = yytname[yytoken]; - if (!yypact_value_is_default (yyn)) - { - /* Start YYX at -YYN if negative to avoid negative indexes in - YYCHECK. In other words, skip the first -YYN actions for - this state because they are default actions. */ - int yyxbegin = yyn < 0 ? -yyn : 0; - /* Stay within bounds of both yycheck and yytname. */ - int yychecklim = YYLAST - yyn + 1; - int yyxend = yychecklim < YYNTOKENS ? yychecklim : YYNTOKENS; - int yyx; - - for (yyx = yyxbegin; yyx < yyxend; ++yyx) - if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR - && !yytable_value_is_error (yytable[yyx + yyn])) - { - if (yycount == YYERROR_VERBOSE_ARGS_MAXIMUM) - { - yycount = 1; - yysize = yysize0; - break; - } - yyarg[yycount++] = yytname[yyx]; - { - YYSIZE_T yysize1 = yysize + yytnamerr (YY_NULLPTR, yytname[yyx]); - if (! (yysize <= yysize1 - && yysize1 <= YYSTACK_ALLOC_MAXIMUM)) - return 2; - yysize = yysize1; - } - } - } - } - - switch (yycount) - { -# define YYCASE_(N, S) \ - case N: \ - yyformat = S; \ - break - default: /* Avoid compiler warnings. */ - YYCASE_(0, YY_("syntax error")); - YYCASE_(1, YY_("syntax error, unexpected %s")); - YYCASE_(2, YY_("syntax error, unexpected %s, expecting %s")); - YYCASE_(3, YY_("syntax error, unexpected %s, expecting %s or %s")); - YYCASE_(4, YY_("syntax error, unexpected %s, expecting %s or %s or %s")); - YYCASE_(5, YY_("syntax error, unexpected %s, expecting %s or %s or %s or %s")); -# undef YYCASE_ - } - - { - YYSIZE_T yysize1 = yysize + yystrlen (yyformat); - if (! (yysize <= yysize1 && yysize1 <= YYSTACK_ALLOC_MAXIMUM)) - return 2; - yysize = yysize1; - } - - if (*yymsg_alloc < yysize) - { - *yymsg_alloc = 2 * yysize; - if (! (yysize <= *yymsg_alloc - && *yymsg_alloc <= YYSTACK_ALLOC_MAXIMUM)) - *yymsg_alloc = YYSTACK_ALLOC_MAXIMUM; - return 1; - } - - /* Avoid sprintf, as that infringes on the user's name space. - Don't have undefined behavior even if the translation - produced a string with the wrong number of "%s"s. */ - { - char *yyp = *yymsg; - int yyi = 0; - while ((*yyp = *yyformat) != '\0') - if (*yyp == '%' && yyformat[1] == 's' && yyi < yycount) - { - yyp += yytnamerr (yyp, yyarg[yyi++]); - yyformat += 2; - } - else - { - yyp++; - yyformat++; - } - } - return 0; +/* Copy into YYRESULT an error message about the unexpected token + YYCHAR while in state YYSTATE. Return the number of bytes copied, + including the terminating null byte. If YYRESULT is null, do not + copy anything; just return the number of bytes that would be + copied. As a special case, return 0 if an ordinary "syntax error" + message will do. Return YYSIZE_MAXIMUM if overflow occurs during + size calculation. */ +static YYSIZE_T +yysyntax_error (char *yyresult, int yystate, int yychar) +{ + int yyn = yypact[yystate]; + + if (! (YYPACT_NINF < yyn && yyn <= YYLAST)) + return 0; + else + { + int yytype = YYTRANSLATE (yychar); + YYSIZE_T yysize0 = yytnamerr (0, yytname[yytype]); + YYSIZE_T yysize = yysize0; + YYSIZE_T yysize1; + int yysize_overflow = 0; + enum { YYERROR_VERBOSE_ARGS_MAXIMUM = 5 }; + char const *yyarg[YYERROR_VERBOSE_ARGS_MAXIMUM]; + int yyx; + +# if 0 + /* This is so xgettext sees the translatable formats that are + constructed on the fly. */ + YY_("syntax error, unexpected %s"); + YY_("syntax error, unexpected %s, expecting %s"); + YY_("syntax error, unexpected %s, expecting %s or %s"); + YY_("syntax error, unexpected %s, expecting %s or %s or %s"); + YY_("syntax error, unexpected %s, expecting %s or %s or %s or %s"); +# endif + char *yyfmt; + char const *yyf; + static char const yyunexpected[] = "syntax error, unexpected %s"; + static char const yyexpecting[] = ", expecting %s"; + static char const yyor[] = " or %s"; + char yyformat[sizeof yyunexpected + + sizeof yyexpecting - 1 + + ((YYERROR_VERBOSE_ARGS_MAXIMUM - 2) + * (sizeof yyor - 1))]; + char const *yyprefix = yyexpecting; + + /* Start YYX at -YYN if negative to avoid negative indexes in + YYCHECK. */ + int yyxbegin = yyn < 0 ? -yyn : 0; + + /* Stay within bounds of both yycheck and yytname. */ + int yychecklim = YYLAST - yyn + 1; + int yyxend = yychecklim < YYNTOKENS ? yychecklim : YYNTOKENS; + int yycount = 1; + + yyarg[0] = yytname[yytype]; + yyfmt = yystpcpy (yyformat, yyunexpected); + + for (yyx = yyxbegin; yyx < yyxend; ++yyx) + if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR) + { + if (yycount == YYERROR_VERBOSE_ARGS_MAXIMUM) + { + yycount = 1; + yysize = yysize0; + yyformat[sizeof yyunexpected - 1] = '\0'; + break; + } + yyarg[yycount++] = yytname[yyx]; + yysize1 = yysize + yytnamerr (0, yytname[yyx]); + yysize_overflow |= (yysize1 < yysize); + yysize = yysize1; + yyfmt = yystpcpy (yyfmt, yyprefix); + yyprefix = yyor; + } + + yyf = YY_(yyformat); + yysize1 = yysize + yystrlen (yyf); + yysize_overflow |= (yysize1 < yysize); + yysize = yysize1; + + if (yysize_overflow) + return YYSIZE_MAXIMUM; + + if (yyresult) + { + /* Avoid sprintf, as that infringes on the user's name space. + Don't have undefined behavior even if the translation + produced a string with the wrong number of "%s"s. */ + char *yyp = yyresult; + int yyi = 0; + while ((*yyp = *yyf) != '\0') + { + if (*yyp == '%' && yyf[1] == 's' && yyi < yycount) + { + yyp += yytnamerr (yyp, yyarg[yyi++]); + yyf += 2; + } + else + { + yyp++; + yyf++; + } + } + } + return yysize; + } } #endif /* YYERROR_VERBOSE */ + /*-----------------------------------------------. | Release the memory associated to this symbol. | `-----------------------------------------------*/ +/*ARGSUSED*/ +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) static void yydestruct (const char *yymsg, int yytype, YYSTYPE *yyvaluep, YYLTYPE *yylocationp, DateInfo* info) +#else +static void +yydestruct (yymsg, yytype, yyvaluep, yylocationp, info) + const char *yymsg; + int yytype; + YYSTYPE *yyvaluep; + YYLTYPE *yylocationp; + DateInfo* info; +#endif { YYUSE (yyvaluep); YYUSE (yylocationp); YYUSE (info); + if (!yymsg) yymsg = "Deleting"; YY_SYMBOL_PRINT (yymsg, yytype, yyvaluep, yylocationp); - YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN - YYUSE (yytype); - YY_IGNORE_MAYBE_UNINITIALIZED_END + switch (yytype) + { + + default: + break; + } } + + +/* Prevent warnings from -Wmissing-prototypes. */ + +#ifdef YYPARSE_PARAM +#if defined __STDC__ || defined __cplusplus +int yyparse (void *YYPARSE_PARAM); +#else +int yyparse (); +#endif +#else /* ! YYPARSE_PARAM */ +#if defined __STDC__ || defined __cplusplus +int yyparse (DateInfo* info); +#else +int yyparse (); +#endif +#endif /* ! YYPARSE_PARAM */ + + /*----------. | yyparse. | `----------*/ +#ifdef YYPARSE_PARAM +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) +int +yyparse (void *YYPARSE_PARAM) +#else +int +yyparse (YYPARSE_PARAM) + void *YYPARSE_PARAM; +#endif +#else /* ! YYPARSE_PARAM */ +#if (defined __STDC__ || defined __C99__FUNC__ \ + || defined __cplusplus || defined _MSC_VER) int yyparse (DateInfo* info) +#else +int +yyparse (info) + DateInfo* info; +#endif +#endif { -/* The lookahead symbol. */ + /* The look-ahead symbol. */ int yychar; - -/* The semantic value of the lookahead symbol. */ -/* Default value used for initialization, for pacifying older GCCs - or non-GCC compilers. */ -YY_INITIAL_VALUE (static YYSTYPE yyval_default;) -YYSTYPE yylval YY_INITIAL_VALUE (= yyval_default); - -/* Location data for the lookahead symbol. */ -static YYLTYPE yyloc_default -# if defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL - = { 1, 1, 1, 1 } -# endif -; -YYLTYPE yylloc = yyloc_default; - - /* Number of syntax errors so far. */ - int yynerrs; - - int yystate; - /* Number of tokens to shift before error messages enabled. */ - int yyerrstatus; - - /* The stacks and their tools: - 'yyss': related to states. - 'yyvs': related to semantic values. - 'yyls': related to locations. - - Refer to the stacks through separate pointers, to allow yyoverflow - to reallocate them elsewhere. */ - - /* The state stack. */ - yytype_int16 yyssa[YYINITDEPTH]; - yytype_int16 *yyss; - yytype_int16 *yyssp; - - /* The semantic value stack. */ - YYSTYPE yyvsa[YYINITDEPTH]; - YYSTYPE *yyvs; - YYSTYPE *yyvsp; - - /* The location stack. */ - YYLTYPE yylsa[YYINITDEPTH]; - YYLTYPE *yyls; - YYLTYPE *yylsp; - - /* The locations where the error started and ended. */ - YYLTYPE yyerror_range[3]; - - YYSIZE_T yystacksize; - +/* The semantic value of the look-ahead symbol. */ +YYSTYPE yylval = {0}; + +/* Number of syntax errors so far. */ +int yynerrs; +/* Location data for the look-ahead symbol. */ +YYLTYPE yylloc; + + int yystate; int yyn; int yyresult; - /* Lookahead token as an internal (translated) token number. */ + /* Number of tokens to shift before error messages enabled. */ + int yyerrstatus; + /* Look-ahead token as an internal (translated) token number. */ int yytoken = 0; - /* The variables used to return semantic value and location from the - action routines. */ - YYSTYPE yyval; - YYLTYPE yyloc; - #if YYERROR_VERBOSE /* Buffer for error messages, and its allocated size. */ char yymsgbuf[128]; char *yymsg = yymsgbuf; YYSIZE_T yymsg_alloc = sizeof yymsgbuf; #endif + + /* Three stacks and their tools: + `yyss': related to states, + `yyvs': related to semantic values, + `yyls': related to locations. + + Refer to the stacks thru separate pointers, to allow yyoverflow + to reallocate them elsewhere. */ + + /* The state stack. */ + yytype_int16 yyssa[YYINITDEPTH]; + yytype_int16 *yyss = yyssa; + yytype_int16 *yyssp; + + /* The semantic value stack. */ + YYSTYPE yyvsa[YYINITDEPTH]; + YYSTYPE *yyvs = yyvsa; + YYSTYPE *yyvsp; + + /* The location stack. */ + YYLTYPE yylsa[YYINITDEPTH]; + YYLTYPE *yyls = yylsa; + YYLTYPE *yylsp; + /* The locations where the error started and ended. */ + YYLTYPE yyerror_range[2]; #define YYPOPSTACK(N) (yyvsp -= (N), yyssp -= (N), yylsp -= (N)) + + YYSIZE_T yystacksize = YYINITDEPTH; + + /* The variables used to return semantic value and location from the + action routines. */ + YYSTYPE yyval; + YYLTYPE yyloc; /* The number of symbols on the RHS of the reduced rule. Keep to zero when no symbol should be popped. */ int yylen = 0; - yyssp = yyss = yyssa; - yyvsp = yyvs = yyvsa; - yylsp = yyls = yylsa; - yystacksize = YYINITDEPTH; - YYDPRINTF ((stderr, "Starting parse\n")); yystate = 0; yyerrstatus = 0; yynerrs = 0; - yychar = YYEMPTY; /* Cause a token to be read. */ - yylsp[0] = yylloc; + yychar = YYEMPTY; /* Cause a token to be read. */ + + /* Initialize stack pointers. + Waste one element of value and location stack + so that they stay on the same level as the state stack. + The wasted elements are never initialized. */ + + yyssp = yyss; + yyvsp = yyvs; + yylsp = yyls; +#if YYLTYPE_IS_TRIVIAL + /* Initialize the default location before parsing starts. */ + yylloc.first_line = yylloc.last_line = 1; + yylloc.first_column = yylloc.last_column = 0; +#endif + goto yysetstate; /*------------------------------------------------------------. | yynewstate -- Push a new state, which is found in yystate. | `------------------------------------------------------------*/ @@ -1382,96 +1446,92 @@ /* Get the current used size of the three stacks, in elements. */ YYSIZE_T yysize = yyssp - yyss + 1; #ifdef yyoverflow { - /* Give user a chance to reallocate the stack. Use copies of - these so that the &'s don't force the real ones into - memory. */ - YYSTYPE *yyvs1 = yyvs; - yytype_int16 *yyss1 = yyss; - YYLTYPE *yyls1 = yyls; - - /* Each stack pointer address is followed by the size of the - data in use in that stack, in bytes. This used to be a - conditional around just the two extra args, but that might - be undefined if yyoverflow is a macro. */ - yyoverflow (YY_("memory exhausted"), - &yyss1, yysize * sizeof (*yyssp), - &yyvs1, yysize * sizeof (*yyvsp), - &yyls1, yysize * sizeof (*yylsp), - &yystacksize); - - yyls = yyls1; - yyss = yyss1; - yyvs = yyvs1; + /* Give user a chance to reallocate the stack. Use copies of + these so that the &'s don't force the real ones into + memory. */ + YYSTYPE *yyvs1 = yyvs; + yytype_int16 *yyss1 = yyss; + YYLTYPE *yyls1 = yyls; + + /* Each stack pointer address is followed by the size of the + data in use in that stack, in bytes. This used to be a + conditional around just the two extra args, but that might + be undefined if yyoverflow is a macro. */ + yyoverflow (YY_("memory exhausted"), + &yyss1, yysize * sizeof (*yyssp), + &yyvs1, yysize * sizeof (*yyvsp), + &yyls1, yysize * sizeof (*yylsp), + &yystacksize); + yyls = yyls1; + yyss = yyss1; + yyvs = yyvs1; } #else /* no yyoverflow */ # ifndef YYSTACK_RELOCATE goto yyexhaustedlab; # else /* Extend the stack our own way. */ if (YYMAXDEPTH <= yystacksize) - goto yyexhaustedlab; - yystacksize *= 2; - if (YYMAXDEPTH < yystacksize) - yystacksize = YYMAXDEPTH; - - { - yytype_int16 *yyss1 = yyss; - union yyalloc *yyptr = - (union yyalloc *) YYSTACK_ALLOC (YYSTACK_BYTES (yystacksize)); - if (! yyptr) - goto yyexhaustedlab; - YYSTACK_RELOCATE (yyss_alloc, yyss); - YYSTACK_RELOCATE (yyvs_alloc, yyvs); - YYSTACK_RELOCATE (yyls_alloc, yyls); -# undef YYSTACK_RELOCATE - if (yyss1 != yyssa) - YYSTACK_FREE (yyss1); + goto yyexhaustedlab; + yystacksize *= 2; + if (YYMAXDEPTH < yystacksize) + yystacksize = YYMAXDEPTH; + + { + yytype_int16 *yyss1 = yyss; + union yyalloc *yyptr = + (union yyalloc *) YYSTACK_ALLOC (YYSTACK_BYTES (yystacksize)); + if (! yyptr) + goto yyexhaustedlab; + YYSTACK_RELOCATE (yyss); + YYSTACK_RELOCATE (yyvs); + YYSTACK_RELOCATE (yyls); +# undef YYSTACK_RELOCATE + if (yyss1 != yyssa) + YYSTACK_FREE (yyss1); } # endif #endif /* no yyoverflow */ yyssp = yyss + yysize - 1; yyvsp = yyvs + yysize - 1; yylsp = yyls + yysize - 1; YYDPRINTF ((stderr, "Stack size increased to %lu\n", - (unsigned long) yystacksize)); + (unsigned long int) yystacksize)); if (yyss + yystacksize - 1 <= yyssp) - YYABORT; + YYABORT; } YYDPRINTF ((stderr, "Entering state %d\n", yystate)); - if (yystate == YYFINAL) - YYACCEPT; - goto yybackup; /*-----------. | yybackup. | `-----------*/ yybackup: /* Do appropriate processing given the current state. Read a - lookahead token if we need one and don't already have one. */ + look-ahead token if we need one and don't already have one. */ - /* First try to decide what to do without reference to lookahead token. */ + /* First try to decide what to do without reference to look-ahead token. */ yyn = yypact[yystate]; - if (yypact_value_is_default (yyn)) + if (yyn == YYPACT_NINF) goto yydefault; - /* Not known => get a lookahead token if don't already have one. */ + /* Not known => get a look-ahead token if don't already have one. */ - /* YYCHAR is either YYEMPTY or YYEOF or a valid lookahead symbol. */ + /* YYCHAR is either YYEMPTY or YYEOF or a valid look-ahead symbol. */ if (yychar == YYEMPTY) { YYDPRINTF ((stderr, "Reading a token: ")); - yychar = yylex (&yylval, &yylloc, info); + yychar = YYLEX; } if (yychar <= YYEOF) { yychar = yytoken = YYEOF; @@ -1489,31 +1549,33 @@ if (yyn < 0 || YYLAST < yyn || yycheck[yyn] != yytoken) goto yydefault; yyn = yytable[yyn]; if (yyn <= 0) { - if (yytable_value_is_error (yyn)) - goto yyerrlab; + if (yyn == 0 || yyn == YYTABLE_NINF) + goto yyerrlab; yyn = -yyn; goto yyreduce; } + + if (yyn == YYFINAL) + YYACCEPT; /* Count tokens shifted since error; after three, turn off error status. */ if (yyerrstatus) yyerrstatus--; - /* Shift the lookahead token. */ + /* Shift the look-ahead token. */ YY_SYMBOL_PRINT ("Shifting", yytoken, &yylval, &yylloc); - /* Discard the shifted token. */ - yychar = YYEMPTY; + /* Discard the shifted token unless it is eof. */ + if (yychar != YYEOF) + yychar = YYEMPTY; yystate = yyn; - YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN *++yyvsp = yylval; - YY_IGNORE_MAYBE_UNINITIALIZED_END *++yylsp = yylloc; goto yynewstate; /*-----------------------------------------------------------. @@ -1532,376 +1594,341 @@ yyreduce: /* yyn is the number of a rule to reduce with. */ yylen = yyr2[yyn]; /* If YYLEN is nonzero, implement the default value of the action: - '$$ = $1'. + `$$ = $1'. Otherwise, the following line sets YYVAL to garbage. This behavior is undocumented and Bison users should not rely upon it. Assigning to YYVAL unconditionally makes the parser a bit smaller, and it avoids a GCC warning that YYVAL may be used uninitialized. */ yyval = yyvsp[1-yylen]; - /* Default location. */ + /* Default location. */ YYLLOC_DEFAULT (yyloc, (yylsp - yylen), yylen); - yyerror_range[1] = yyloc; YY_REDUCE_PRINT (yyn); switch (yyn) { case 4: { yyHaveTime++; - } - + ;} break; case 5: { yyHaveZone++; - } - + ;} break; case 6: { yyHaveDate++; - } - + ;} break; case 7: { yyHaveOrdinalMonth++; - } - + ;} break; case 8: { yyHaveDay++; - } - + ;} break; case 9: { yyHaveRel++; - } - + ;} break; case 10: { yyHaveTime++; yyHaveDate++; - } - + ;} break; case 11: { yyHaveTime++; yyHaveDate++; yyHaveRel++; - } - + ;} break; case 13: { - yyHour = (yyvsp[-1].Number); + yyHour = (yyvsp[(1) - (2)].Number); yyMinutes = 0; yySeconds = 0; - yyMeridian = (yyvsp[0].Meridian); - } - + yyMeridian = (yyvsp[(2) - (2)].Meridian); + ;} break; case 14: { - yyHour = (yyvsp[-3].Number); - yyMinutes = (yyvsp[-1].Number); + yyHour = (yyvsp[(1) - (4)].Number); + yyMinutes = (yyvsp[(3) - (4)].Number); yySeconds = 0; - yyMeridian = (yyvsp[0].Meridian); - } - + yyMeridian = (yyvsp[(4) - (4)].Meridian); + ;} break; case 15: { - yyHour = (yyvsp[-5].Number); - yyMinutes = (yyvsp[-3].Number); - yySeconds = (yyvsp[-1].Number); - yyMeridian = (yyvsp[0].Meridian); - } - + yyHour = (yyvsp[(1) - (5)].Number); + yyMinutes = (yyvsp[(3) - (5)].Number); + yyMeridian = MER24; + yyDSTmode = DSToff; + yyTimezone = ((yyvsp[(5) - (5)].Number) % 100 + ((yyvsp[(5) - (5)].Number) / 100) * 60); + ++yyHaveZone; + ;} break; case 16: { - yyTimezone = (yyvsp[-1].Number); - if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100); - yyDSTmode = DSTon; - } - + yyHour = (yyvsp[(1) - (6)].Number); + yyMinutes = (yyvsp[(3) - (6)].Number); + yySeconds = (yyvsp[(5) - (6)].Number); + yyMeridian = (yyvsp[(6) - (6)].Meridian); + ;} break; case 17: { - yyTimezone = (yyvsp[0].Number); - if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100); + yyHour = (yyvsp[(1) - (7)].Number); + yyMinutes = (yyvsp[(3) - (7)].Number); + yySeconds = (yyvsp[(5) - (7)].Number); + yyMeridian = MER24; yyDSTmode = DSToff; - } - + yyTimezone = ((yyvsp[(7) - (7)].Number) % 100 + ((yyvsp[(7) - (7)].Number) / 100) * 60); + ++yyHaveZone; + ;} break; case 18: { - yyTimezone = (yyvsp[0].Number); + yyTimezone = (yyvsp[(1) - (2)].Number); yyDSTmode = DSTon; - } - + ;} break; case 19: { - yyTimezone = -(yyvsp[-1].Number)*((yyvsp[0].Number) % 100 + ((yyvsp[0].Number) / 100) * 60); + yyTimezone = (yyvsp[(1) - (1)].Number); yyDSTmode = DSToff; - } - + ;} break; case 20: { - yyDayOrdinal = 1; - yyDayNumber = (yyvsp[0].Number); - } - + yyTimezone = (yyvsp[(1) - (1)].Number); + yyDSTmode = DSTon; + ;} break; case 21: { yyDayOrdinal = 1; - yyDayNumber = (yyvsp[-1].Number); - } - + yyDayNumber = (yyvsp[(1) - (1)].Number); + ;} break; case 22: { - yyDayOrdinal = (yyvsp[-1].Number); - yyDayNumber = (yyvsp[0].Number); - } - + yyDayOrdinal = 1; + yyDayNumber = (yyvsp[(1) - (2)].Number); + ;} break; case 23: { - yyDayOrdinal = (yyvsp[-2].Number) * (yyvsp[-1].Number); - yyDayNumber = (yyvsp[0].Number); - } - + yyDayOrdinal = (yyvsp[(1) - (2)].Number); + yyDayNumber = (yyvsp[(2) - (2)].Number); + ;} break; case 24: { - yyDayOrdinal = 2; - yyDayNumber = (yyvsp[0].Number); - } - + yyDayOrdinal = (yyvsp[(1) - (3)].Number) * (yyvsp[(2) - (3)].Number); + yyDayNumber = (yyvsp[(3) - (3)].Number); + ;} break; case 25: { - yyMonth = (yyvsp[-2].Number); - yyDay = (yyvsp[0].Number); - } - + yyDayOrdinal = 2; + yyDayNumber = (yyvsp[(2) - (2)].Number); + ;} break; case 26: { - yyMonth = (yyvsp[-4].Number); - yyDay = (yyvsp[-2].Number); - yyYear = (yyvsp[0].Number); - } - + yyMonth = (yyvsp[(1) - (3)].Number); + yyDay = (yyvsp[(3) - (3)].Number); + ;} break; case 27: { - yyYear = (yyvsp[0].Number) / 10000; - yyMonth = ((yyvsp[0].Number) % 10000)/100; - yyDay = (yyvsp[0].Number) % 100; - } - + yyMonth = (yyvsp[(1) - (5)].Number); + yyDay = (yyvsp[(3) - (5)].Number); + yyYear = (yyvsp[(5) - (5)].Number); + ;} break; case 28: { - yyDay = (yyvsp[-4].Number); - yyMonth = (yyvsp[-2].Number); - yyYear = (yyvsp[0].Number); - } - + yyYear = (yyvsp[(1) - (1)].Number) / 10000; + yyMonth = ((yyvsp[(1) - (1)].Number) % 10000)/100; + yyDay = (yyvsp[(1) - (1)].Number) % 100; + ;} break; case 29: { - yyMonth = (yyvsp[-2].Number); - yyDay = (yyvsp[0].Number); - yyYear = (yyvsp[-4].Number); - } - + yyDay = (yyvsp[(1) - (5)].Number); + yyMonth = (yyvsp[(3) - (5)].Number); + yyYear = (yyvsp[(5) - (5)].Number); + ;} break; case 30: { - yyMonth = (yyvsp[-1].Number); - yyDay = (yyvsp[0].Number); - } - + yyMonth = (yyvsp[(3) - (5)].Number); + yyDay = (yyvsp[(5) - (5)].Number); + yyYear = (yyvsp[(1) - (5)].Number); + ;} break; case 31: { - yyMonth = (yyvsp[-3].Number); - yyDay = (yyvsp[-2].Number); - yyYear = (yyvsp[0].Number); - } - + yyMonth = (yyvsp[(1) - (2)].Number); + yyDay = (yyvsp[(2) - (2)].Number); + ;} break; case 32: { - yyMonth = (yyvsp[0].Number); - yyDay = (yyvsp[-1].Number); - } - + yyMonth = (yyvsp[(1) - (4)].Number); + yyDay = (yyvsp[(2) - (4)].Number); + yyYear = (yyvsp[(4) - (4)].Number); + ;} break; case 33: { - yyMonth = 1; - yyDay = 1; - yyYear = EPOCH; - } - + yyMonth = (yyvsp[(2) - (2)].Number); + yyDay = (yyvsp[(1) - (2)].Number); + ;} break; case 34: { - yyMonth = (yyvsp[-1].Number); - yyDay = (yyvsp[-2].Number); - yyYear = (yyvsp[0].Number); - } - + yyMonth = 1; + yyDay = 1; + yyYear = EPOCH; + ;} break; case 35: { - yyMonthOrdinal = 1; - yyMonth = (yyvsp[0].Number); - } - + yyMonth = (yyvsp[(2) - (3)].Number); + yyDay = (yyvsp[(1) - (3)].Number); + yyYear = (yyvsp[(3) - (3)].Number); + ;} break; case 36: { - yyMonthOrdinal = (yyvsp[-1].Number); - yyMonth = (yyvsp[0].Number); - } - + yyMonthOrdinal = 1; + yyMonth = (yyvsp[(2) - (2)].Number); + ;} break; case 37: { - if ((yyvsp[-5].Number) != HOUR( 7) + HOUR(100)) YYABORT; - yyYear = (yyvsp[-10].Number); - yyMonth = (yyvsp[-8].Number); - yyDay = (yyvsp[-6].Number); - yyHour = (yyvsp[-4].Number); - yyMinutes = (yyvsp[-2].Number); - yySeconds = (yyvsp[0].Number); - } - + yyMonthOrdinal = (yyvsp[(2) - (3)].Number); + yyMonth = (yyvsp[(3) - (3)].Number); + ;} break; case 38: { - if ((yyvsp[-1].Number) != HOUR( 7) + HOUR(100)) YYABORT; - yyYear = (yyvsp[-2].Number) / 10000; - yyMonth = ((yyvsp[-2].Number) % 10000)/100; - yyDay = (yyvsp[-2].Number) % 100; - yyHour = (yyvsp[0].Number) / 10000; - yyMinutes = ((yyvsp[0].Number) % 10000)/100; - yySeconds = (yyvsp[0].Number) % 100; - } - + if ((yyvsp[(2) - (3)].Number) != HOUR( 7)) YYABORT; + yyYear = (yyvsp[(1) - (3)].Number) / 10000; + yyMonth = ((yyvsp[(1) - (3)].Number) % 10000)/100; + yyDay = (yyvsp[(1) - (3)].Number) % 100; + yyHour = (yyvsp[(3) - (3)].Number) / 10000; + yyMinutes = ((yyvsp[(3) - (3)].Number) % 10000)/100; + yySeconds = (yyvsp[(3) - (3)].Number) % 100; + ;} break; case 39: { - if ((yyvsp[-5].Number) != HOUR( 7) + HOUR(100)) YYABORT; - yyYear = (yyvsp[-6].Number) / 10000; - yyMonth = ((yyvsp[-6].Number) % 10000)/100; - yyDay = (yyvsp[-6].Number) % 100; - yyHour = (yyvsp[-4].Number); - yyMinutes = (yyvsp[-2].Number); - yySeconds = (yyvsp[0].Number); - } - + if ((yyvsp[(2) - (7)].Number) != HOUR( 7)) YYABORT; + yyYear = (yyvsp[(1) - (7)].Number) / 10000; + yyMonth = ((yyvsp[(1) - (7)].Number) % 10000)/100; + yyDay = (yyvsp[(1) - (7)].Number) % 100; + yyHour = (yyvsp[(3) - (7)].Number); + yyMinutes = (yyvsp[(5) - (7)].Number); + yySeconds = (yyvsp[(7) - (7)].Number); + ;} break; case 40: { - yyYear = (yyvsp[-1].Number) / 10000; - yyMonth = ((yyvsp[-1].Number) % 10000)/100; - yyDay = (yyvsp[-1].Number) % 100; - yyHour = (yyvsp[0].Number) / 10000; - yyMinutes = ((yyvsp[0].Number) % 10000)/100; - yySeconds = (yyvsp[0].Number) % 100; - } - + yyYear = (yyvsp[(1) - (2)].Number) / 10000; + yyMonth = ((yyvsp[(1) - (2)].Number) % 10000)/100; + yyDay = (yyvsp[(1) - (2)].Number) % 100; + yyHour = (yyvsp[(2) - (2)].Number) / 10000; + yyMinutes = ((yyvsp[(2) - (2)].Number) % 10000)/100; + yySeconds = (yyvsp[(2) - (2)].Number) % 100; + ;} break; case 41: { @@ -1908,174 +1935,149 @@ /* * Offset computed year by -377 so that the returned years will be * in a range accessible with a 32 bit clock seconds value. */ - yyYear = (yyvsp[-2].Number)/1000 + 2323 - 377; + yyYear = (yyvsp[(2) - (4)].Number)/1000 + 2323 - 377; yyDay = 1; yyMonth = 1; - yyRelDay += (((yyvsp[-2].Number)%1000)*(365 + IsLeapYear(yyYear)))/1000; - yyRelSeconds += (yyvsp[0].Number) * 144 * 60; - } - + yyRelDay += (((yyvsp[(2) - (4)].Number)%1000)*(365 + IsLeapYear(yyYear)))/1000; + yyRelSeconds += (yyvsp[(4) - (4)].Number) * 144 * 60; + ;} break; case 42: { yyRelSeconds *= -1; yyRelMonth *= -1; yyRelDay *= -1; - } - + ;} break; case 44: { - *yyRelPointer += (yyvsp[-2].Number) * (yyvsp[-1].Number) * (yyvsp[0].Number); - } - + *yyRelPointer += (yyvsp[(1) - (3)].Number) * (yyvsp[(2) - (3)].Number) * (yyvsp[(3) - (3)].Number); + ;} break; case 45: { - *yyRelPointer += (yyvsp[-1].Number) * (yyvsp[0].Number); - } - + *yyRelPointer += (yyvsp[(1) - (2)].Number) * (yyvsp[(2) - (2)].Number); + ;} break; case 46: { - *yyRelPointer += (yyvsp[0].Number); - } - + *yyRelPointer += (yyvsp[(2) - (2)].Number); + ;} break; case 47: { - *yyRelPointer += (yyvsp[-1].Number) * (yyvsp[0].Number); - } - + *yyRelPointer += (yyvsp[(2) - (3)].Number) * (yyvsp[(3) - (3)].Number); + ;} break; case 48: { - *yyRelPointer += (yyvsp[0].Number); - } - + *yyRelPointer += (yyvsp[(1) - (1)].Number); + ;} break; case 49: { (yyval.Number) = -1; - } - + ;} break; case 50: { (yyval.Number) = 1; - } - + ;} break; case 51: { - (yyval.Number) = (yyvsp[0].Number); + (yyval.Number) = (yyvsp[(1) - (1)].Number); yyRelPointer = &yyRelSeconds; - } - + ;} break; case 52: { - (yyval.Number) = (yyvsp[0].Number); + (yyval.Number) = (yyvsp[(1) - (1)].Number); yyRelPointer = &yyRelDay; - } - + ;} break; case 53: { - (yyval.Number) = (yyvsp[0].Number); + (yyval.Number) = (yyvsp[(1) - (1)].Number); yyRelPointer = &yyRelMonth; - } - + ;} break; case 54: { if (yyHaveTime && yyHaveDate && !yyHaveRel) { - yyYear = (yyvsp[0].Number); + yyYear = (yyvsp[(1) - (1)].Number); } else { yyHaveTime++; if (yyDigitCount <= 2) { - yyHour = (yyvsp[0].Number); + yyHour = (yyvsp[(1) - (1)].Number); yyMinutes = 0; } else { - yyHour = (yyvsp[0].Number) / 100; - yyMinutes = (yyvsp[0].Number) % 100; + yyHour = (yyvsp[(1) - (1)].Number) / 100; + yyMinutes = (yyvsp[(1) - (1)].Number) % 100; } yySeconds = 0; yyMeridian = MER24; } - } - + ;} break; case 55: { (yyval.Meridian) = MER24; - } - + ;} break; case 56: { - (yyval.Meridian) = (yyvsp[0].Meridian); - } - + (yyval.Meridian) = (yyvsp[(1) - (1)].Meridian); + ;} break; +/* Line 1267 of yacc.c. */ default: break; } - /* User semantic actions sometimes alter yychar, and that requires - that yytoken be updated with the new translation. We take the - approach of translating immediately before every use of yytoken. - One alternative is translating here after every semantic action, - but that translation would be missed if the semantic action invokes - YYABORT, YYACCEPT, or YYERROR immediately after altering yychar or - if it invokes YYBACKUP. In the case of YYABORT or YYACCEPT, an - incorrect destructor might then be invoked immediately. In the - case of YYERROR or YYBACKUP, subsequent parser actions might lead - to an incorrect destructor call or verbose syntax error message - before the lookahead is translated. */ YY_SYMBOL_PRINT ("-> $$ =", yyr1[yyn], &yyval, &yyloc); YYPOPSTACK (yylen); yylen = 0; YY_STACK_PRINT (yyss, yyssp); *++yyvsp = yyval; *++yylsp = yyloc; - /* Now 'shift' the result of the reduction. Determine what state + /* Now `shift' the result of the reduction. Determine what state that goes to, based on the state we popped back to and the rule number reduced by. */ yyn = yyr1[yyn]; @@ -2086,80 +2088,77 @@ yystate = yydefgoto[yyn - YYNTOKENS]; goto yynewstate; -/*--------------------------------------. -| yyerrlab -- here on detecting error. | -`--------------------------------------*/ +/*------------------------------------. +| yyerrlab -- here on detecting error | +`------------------------------------*/ yyerrlab: - /* Make sure we have latest lookahead translation. See comments at - user semantic actions for why this is necessary. */ - yytoken = yychar == YYEMPTY ? YYEMPTY : YYTRANSLATE (yychar); - /* If not already recovering from an error, report this error. */ if (!yyerrstatus) { ++yynerrs; #if ! YYERROR_VERBOSE yyerror (&yylloc, info, YY_("syntax error")); #else -# define YYSYNTAX_ERROR yysyntax_error (&yymsg_alloc, &yymsg, \ - yyssp, yytoken) - { - char const *yymsgp = YY_("syntax error"); - int yysyntax_error_status; - yysyntax_error_status = YYSYNTAX_ERROR; - if (yysyntax_error_status == 0) - yymsgp = yymsg; - else if (yysyntax_error_status == 1) - { - if (yymsg != yymsgbuf) - YYSTACK_FREE (yymsg); - yymsg = (char *) YYSTACK_ALLOC (yymsg_alloc); - if (!yymsg) - { - yymsg = yymsgbuf; - yymsg_alloc = sizeof yymsgbuf; - yysyntax_error_status = 2; - } - else - { - yysyntax_error_status = YYSYNTAX_ERROR; - yymsgp = yymsg; - } - } - yyerror (&yylloc, info, yymsgp); - if (yysyntax_error_status == 2) - goto yyexhaustedlab; - } -# undef YYSYNTAX_ERROR + { + YYSIZE_T yysize = yysyntax_error (0, yystate, yychar); + if (yymsg_alloc < yysize && yymsg_alloc < YYSTACK_ALLOC_MAXIMUM) + { + YYSIZE_T yyalloc = 2 * yysize; + if (! (yysize <= yyalloc && yyalloc <= YYSTACK_ALLOC_MAXIMUM)) + yyalloc = YYSTACK_ALLOC_MAXIMUM; + if (yymsg != yymsgbuf) + YYSTACK_FREE (yymsg); + yymsg = (char *) YYSTACK_ALLOC (yyalloc); + if (yymsg) + yymsg_alloc = yyalloc; + else + { + yymsg = yymsgbuf; + yymsg_alloc = sizeof yymsgbuf; + } + } + + if (0 < yysize && yysize <= yymsg_alloc) + { + (void) yysyntax_error (yymsg, yystate, yychar); + yyerror (&yylloc, info, yymsg); + } + else + { + yyerror (&yylloc, info, YY_("syntax error")); + if (yysize != 0) + goto yyexhaustedlab; + } + } #endif } - yyerror_range[1] = yylloc; + yyerror_range[0] = yylloc; if (yyerrstatus == 3) { - /* If just tried and failed to reuse lookahead token after an - error, discard it. */ + /* If just tried and failed to reuse look-ahead token after an + error, discard it. */ if (yychar <= YYEOF) - { - /* Return failure if at end of input. */ - if (yychar == YYEOF) - YYABORT; - } + { + /* Return failure if at end of input. */ + if (yychar == YYEOF) + YYABORT; + } else - { - yydestruct ("Error: discarding", - yytoken, &yylval, &yylloc, info); - yychar = YYEMPTY; - } + { + yydestruct ("Error: discarding", + yytoken, &yylval, &yylloc, info); + yychar = YYEMPTY; + } } - /* Else will try to reuse lookahead token after shifting the error + /* Else will try to reuse look-ahead token after shifting the error token. */ goto yyerrlab1; /*---------------------------------------------------. @@ -2171,11 +2170,12 @@ YYERROR and the label yyerrorlab therefore never appears in user code. */ if (/*CONSTCOND*/ 0) goto yyerrorlab; - /* Do not reclaim the symbols of the rule whose action triggered + yyerror_range[0] = yylsp[1-yylen]; + /* Do not reclaim the symbols of the rule which action triggered this YYERROR. */ YYPOPSTACK (yylen); yylen = 0; YY_STACK_PRINT (yyss, yyssp); yystate = *yyssp; @@ -2184,46 +2184,47 @@ /*-------------------------------------------------------------. | yyerrlab1 -- common code for both syntax error and YYERROR. | `-------------------------------------------------------------*/ yyerrlab1: - yyerrstatus = 3; /* Each real token shifted decrements this. */ + yyerrstatus = 3; /* Each real token shifted decrements this. */ for (;;) { yyn = yypact[yystate]; - if (!yypact_value_is_default (yyn)) - { - yyn += YYTERROR; - if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR) - { - yyn = yytable[yyn]; - if (0 < yyn) - break; - } - } + if (yyn != YYPACT_NINF) + { + yyn += YYTERROR; + if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR) + { + yyn = yytable[yyn]; + if (0 < yyn) + break; + } + } /* Pop the current state because it cannot handle the error token. */ if (yyssp == yyss) - YYABORT; + YYABORT; - yyerror_range[1] = *yylsp; + yyerror_range[0] = *yylsp; yydestruct ("Error: popping", - yystos[yystate], yyvsp, yylsp, info); + yystos[yystate], yyvsp, yylsp, info); YYPOPSTACK (1); yystate = *yyssp; YY_STACK_PRINT (yyss, yyssp); } - YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN + if (yyn == YYFINAL) + YYACCEPT; + *++yyvsp = yylval; - YY_IGNORE_MAYBE_UNINITIALIZED_END - yyerror_range[2] = yylloc; + yyerror_range[1] = yylloc; /* Using YYLLOC is tempting, but would change the location of - the lookahead. YYLOC is available though. */ - YYLLOC_DEFAULT (yyloc, yyerror_range, 2); + the look-ahead. YYLOC is available though. */ + YYLLOC_DEFAULT (yyloc, (yyerror_range - 1), 2); *++yylsp = yyloc; /* Shift the error token. */ YY_SYMBOL_PRINT ("Shifting", yystos[yyn], yyvsp, yylsp); @@ -2243,11 +2244,11 @@ `-----------------------------------*/ yyabortlab: yyresult = 1; goto yyreturn; -#if !defined yyoverflow || YYERROR_VERBOSE +#ifndef yyoverflow /*-------------------------------------------------. | yyexhaustedlab -- memory exhaustion comes here. | `-------------------------------------------------*/ yyexhaustedlab: yyerror (&yylloc, info, YY_("memory exhausted")); @@ -2254,26 +2255,21 @@ yyresult = 2; /* Fall through. */ #endif yyreturn: - if (yychar != YYEMPTY) - { - /* Make sure we have latest lookahead translation. See comments at - user semantic actions for why this is necessary. */ - yytoken = YYTRANSLATE (yychar); - yydestruct ("Cleanup: discarding lookahead", - yytoken, &yylval, &yylloc, info); - } - /* Do not reclaim the symbols of the rule whose action triggered + if (yychar != YYEOF && yychar != YYEMPTY) + yydestruct ("Cleanup: discarding lookahead", + yytoken, &yylval, &yylloc, info); + /* Do not reclaim the symbols of the rule which action triggered this YYABORT or YYACCEPT. */ YYPOPSTACK (yylen); YY_STACK_PRINT (yyss, yyssp); while (yyssp != yyss) { yydestruct ("Cleanup: popping", - yystos[*yyssp], yyvsp, yylsp, info); + yystos[*yyssp], yyvsp, yylsp, info); YYPOPSTACK (1); } #ifndef yyoverflow if (yyss != yyssa) YYSTACK_FREE (yyss); @@ -2280,14 +2276,21 @@ #endif #if YYERROR_VERBOSE if (yymsg != yymsgbuf) YYSTACK_FREE (yymsg); #endif - return yyresult; + /* Make sure YYID is used. */ + return YYID (yyresult); } + + +MODULE_SCOPE int yychar; +MODULE_SCOPE YYSTYPE yylval; +MODULE_SCOPE int yynerrs; + /* * Month and day table. */ static const TABLE MonthDayTable[] = { @@ -2313,11 +2316,11 @@ { "thursday", tDAY, 4 }, { "thur", tDAY, 4 }, { "thurs", tDAY, 4 }, { "friday", tDAY, 5 }, { "saturday", tDAY, 6 }, - { NULL, 0, 0 } + { NULL } }; /* * Time units table. */ @@ -2331,11 +2334,11 @@ { "hour", tSEC_UNIT, 60 * 60 }, { "minute", tSEC_UNIT, 60 }, { "min", tSEC_UNIT, 60 }, { "second", tSEC_UNIT, 1 }, { "sec", tSEC_UNIT, 1 }, - { NULL, 0, 0 } + { NULL } }; /* * Assorted relative-time words. */ @@ -2363,11 +2366,11 @@ { "twelfth", tUNUMBER, 12 }, #endif { "ago", tAGO, 1 }, { "epoch", tEPOCH, 0 }, { "stardate", tSTARDATE, 0 }, - { NULL, 0, 0 } + { NULL } }; /* * The timezone table. (Note: This table was modified to not use any floating * point constants to work around an SGI compiler bug). @@ -2449,44 +2452,44 @@ { "nzdt", tDAYZONE, -HOUR(12) }, /* New Zealand Daylight */ { "idle", tZONE, -HOUR(12) }, /* International Date Line East */ /* ADDED BY Marco Nijdam */ { "dst", tDST, HOUR( 0) }, /* DST on (hour is ignored) */ /* End ADDED */ - { NULL, 0, 0 } + { NULL } }; /* * Military timezone table. */ static const TABLE MilitaryTable[] = { - { "a", tZONE, -HOUR( 1) + HOUR(100) }, - { "b", tZONE, -HOUR( 2) + HOUR(100) }, - { "c", tZONE, -HOUR( 3) + HOUR(100) }, - { "d", tZONE, -HOUR( 4) + HOUR(100) }, - { "e", tZONE, -HOUR( 5) + HOUR(100) }, - { "f", tZONE, -HOUR( 6) + HOUR(100) }, - { "g", tZONE, -HOUR( 7) + HOUR(100) }, - { "h", tZONE, -HOUR( 8) + HOUR(100) }, - { "i", tZONE, -HOUR( 9) + HOUR(100) }, - { "k", tZONE, -HOUR(10) + HOUR(100) }, - { "l", tZONE, -HOUR(11) + HOUR(100) }, - { "m", tZONE, -HOUR(12) + HOUR(100) }, - { "n", tZONE, HOUR( 1) + HOUR(100) }, - { "o", tZONE, HOUR( 2) + HOUR(100) }, - { "p", tZONE, HOUR( 3) + HOUR(100) }, - { "q", tZONE, HOUR( 4) + HOUR(100) }, - { "r", tZONE, HOUR( 5) + HOUR(100) }, - { "s", tZONE, HOUR( 6) + HOUR(100) }, - { "t", tZONE, HOUR( 7) + HOUR(100) }, - { "u", tZONE, HOUR( 8) + HOUR(100) }, - { "v", tZONE, HOUR( 9) + HOUR(100) }, - { "w", tZONE, HOUR( 10) + HOUR(100) }, - { "x", tZONE, HOUR( 11) + HOUR(100) }, - { "y", tZONE, HOUR( 12) + HOUR(100) }, - { "z", tZONE, HOUR( 0) + HOUR(100) }, - { NULL, 0, 0 } + { "a", tZONE, -HOUR( 1) }, + { "b", tZONE, -HOUR( 2) }, + { "c", tZONE, -HOUR( 3) }, + { "d", tZONE, -HOUR( 4) }, + { "e", tZONE, -HOUR( 5) }, + { "f", tZONE, -HOUR( 6) }, + { "g", tZONE, -HOUR( 7) }, + { "h", tZONE, -HOUR( 8) }, + { "i", tZONE, -HOUR( 9) }, + { "k", tZONE, -HOUR(10) }, + { "l", tZONE, -HOUR(11) }, + { "m", tZONE, -HOUR(12) }, + { "n", tZONE, HOUR( 1) }, + { "o", tZONE, HOUR( 2) }, + { "p", tZONE, HOUR( 3) }, + { "q", tZONE, HOUR( 4) }, + { "r", tZONE, HOUR( 5) }, + { "s", tZONE, HOUR( 6) }, + { "t", tZONE, HOUR( 7) }, + { "u", tZONE, HOUR( 8) }, + { "v", tZONE, HOUR( 9) }, + { "w", tZONE, HOUR( 10) }, + { "x", tZONE, HOUR( 11) }, + { "y", tZONE, HOUR( 12) }, + { "z", tZONE, HOUR( 0) }, + { NULL } }; /* * Dump error messages in the bit bucket. */ @@ -2499,16 +2502,16 @@ { Tcl_Obj* t; Tcl_AppendToObj(infoPtr->messages, infoPtr->separatrix, -1); Tcl_AppendToObj(infoPtr->messages, s, -1); Tcl_AppendToObj(infoPtr->messages, " (characters ", -1); - TclNewIntObj(t, location->first_column); + t = Tcl_NewIntObj(location->first_column); Tcl_IncrRefCount(t); Tcl_AppendObjToObj(infoPtr->messages, t); Tcl_DecrRefCount(t); Tcl_AppendToObj(infoPtr->messages, "-", -1); - TclNewIntObj(t, location->last_column); + t = Tcl_NewIntObj(location->last_column); Tcl_IncrRefCount(t); Tcl_AppendObjToObj(infoPtr->messages, t); Tcl_DecrRefCount(t); Tcl_AppendToObj(infoPtr->messages, ")", -1); infoPtr->separatrix = "\n"; @@ -2547,13 +2550,13 @@ static int LookupWord( YYSTYPE* yylvalPtr, char *buff) { - char *p; - char *q; - const TABLE *tp; + register char *p; + register char *q; + register const TABLE *tp; int i, abbrev; /* * Make it lowercase. */ @@ -2672,12 +2675,12 @@ TclDatelex( YYSTYPE* yylvalPtr, YYLTYPE* location, DateInfo *info) { - char c; - char *p; + register char c; + register char *p; char buff[20]; int Count; location->first_column = yyInput - info->dateStart; for ( ; ; ) { @@ -2742,14 +2745,14 @@ } } int TclClockOldscanObjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Unused */ Tcl_Interp *interp, /* Tcl interpreter */ - int objc, /* Count of paraneters */ - Tcl_Obj *const *objv) /* Parameters */ + int objc, /* Count of parameters */ + Tcl_Obj *CONST *objv) /* Parameters */ { Tcl_Obj *result, *resultElement; int yr, mo, da; DateInfo dateInfo; DateInfo* info = &dateInfo; @@ -2759,11 +2762,11 @@ Tcl_WrongNumArgs(interp, 1, objv, "stringToParse baseYear baseMonth baseDay" ); return TCL_ERROR; } - yyInput = TclGetString(objv[1]); + 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 @@ -2785,121 +2788,113 @@ yyDayOrdinal = 0; yyDayNumber = 0; yyHaveRel = 0; yyRelMonth = 0; yyRelDay = 0; yyRelSeconds = 0; yyRelPointer = NULL; - TclNewObj(dateInfo.messages); + dateInfo.messages = Tcl_NewObj(); dateInfo.separatrix = ""; Tcl_IncrRefCount(dateInfo.messages); status = yyparse(&dateInfo); if (status == 1) { Tcl_SetObjResult(interp, dateInfo.messages); Tcl_DecrRefCount(dateInfo.messages); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "PARSE", NULL); return TCL_ERROR; } else if (status == 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj("memory exhausted", -1)); Tcl_DecrRefCount(dateInfo.messages); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } else if (status != 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("Unknown status returned " "from date parser. Please " "report this error as a " "bug in Tcl.", -1)); Tcl_DecrRefCount(dateInfo.messages); - Tcl_SetErrorCode(interp, "TCL", "BUG", NULL); return TCL_ERROR; } Tcl_DecrRefCount(dateInfo.messages); if (yyHaveDate > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one date in string", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveTime > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one time of day in string", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveZone > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one time zone in string", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveDay > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one weekday in string", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveOrdinalMonth > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one ordinal month in string", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } - TclNewObj(result); - TclNewObj(resultElement); + result = Tcl_NewObj(); + resultElement = Tcl_NewObj(); if (yyHaveDate) { Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyYear)); + Tcl_NewIntObj((int) yyYear)); Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyMonth)); + Tcl_NewIntObj((int) yyMonth)); Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyDay)); + Tcl_NewIntObj((int) yyDay)); } Tcl_ListObjAppendElement(interp, result, resultElement); if (yyHaveTime) { - Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj( - ToSeconds(yyHour, yyMinutes, yySeconds, (MERIDIAN)yyMeridian))); + Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj((int) + ToSeconds(yyHour, yyMinutes, yySeconds, yyMeridian))); } else { Tcl_ListObjAppendElement(interp, result, Tcl_NewObj()); } - TclNewObj(resultElement); + resultElement = Tcl_NewObj(); if (yyHaveZone) { Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(-yyTimezone)); + Tcl_NewIntObj((int) -yyTimezone)); Tcl_ListObjAppendElement(interp, resultElement, Tcl_NewIntObj(1 - yyDSTmode)); } Tcl_ListObjAppendElement(interp, result, resultElement); - TclNewObj(resultElement); - if (yyHaveRel) { - Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyRelMonth)); - Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyRelDay)); - Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyRelSeconds)); - } - Tcl_ListObjAppendElement(interp, result, resultElement); - - TclNewObj(resultElement); - if (yyHaveDay && !yyHaveDate) { - Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyDayOrdinal)); - Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyDayNumber)); - } - Tcl_ListObjAppendElement(interp, result, resultElement); - - TclNewObj(resultElement); - if (yyHaveOrdinalMonth) { - Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyMonthOrdinal)); - Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyMonth)); + 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; @@ -2910,5 +2905,6 @@ * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ + Index: generic/tclDecls.h ================================================================== --- generic/tclDecls.h +++ generic/tclDecls.h @@ -20,19 +20,10 @@ # define TCL_STORAGE_CLASS # else # define TCL_STORAGE_CLASS DLLIMPORT # endif #endif - -#if !defined(BUILD_tcl) -# define TCL_DEPRECATED(msg) EXTERN TCL_DEPRECATED_API(msg) -#elif defined(TCL_NO_DEPRECATED) -# define TCL_DEPRECATED(msg) MODULE_SCOPE -#else -# define TCL_DEPRECATED(msg) EXTERN -#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/tcl.decls script. @@ -46,2270 +37,4052 @@ /* * Exported function declarations: */ +#ifndef Tcl_PkgProvideEx_TCL_DECLARED +#define Tcl_PkgProvideEx_TCL_DECLARED /* 0 */ EXTERN int Tcl_PkgProvideEx(Tcl_Interp *interp, - const char *name, const char *version, - const void *clientData); -/* 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 void * Tcl_Alloc(size_t size); -/* 4 */ -EXTERN void Tcl_Free(void *ptr); -/* 5 */ -EXTERN void * Tcl_Realloc(void *ptr, size_t size); -/* 6 */ -EXTERN void * Tcl_DbCkalloc(size_t size, const char *file, - int line); -/* 7 */ -EXTERN void Tcl_DbCkfree(void *ptr, const char *file, int line); -/* 8 */ -EXTERN void * Tcl_DbCkrealloc(void *ptr, size_t 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, void *clientData); -#endif /* UNIX */ -#ifdef MAC_OSX_TCL /* MACOSX */ -/* 9 */ -EXTERN void Tcl_CreateFileHandler(int fd, int mask, - Tcl_FileProc *proc, void *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 */ -EXTERN void Tcl_DeleteFileHandler(int fd); -#endif /* MACOSX */ -/* 11 */ -EXTERN void Tcl_SetTimer(const Tcl_Time *timePtr); -/* 12 */ -EXTERN void Tcl_Sleep(int ms); -/* 13 */ -EXTERN int Tcl_WaitForEvent(const Tcl_Time *timePtr); + CONST char *name, CONST char *version, + ClientData clientData); +#endif +#ifndef Tcl_PkgRequireEx_TCL_DECLARED +#define Tcl_PkgRequireEx_TCL_DECLARED +/* 1 */ +EXTERN CONST84_RETURN char * Tcl_PkgRequireEx(Tcl_Interp *interp, + CONST char *name, CONST char *version, + int exact, ClientData *clientDataPtr); +#endif +#ifndef Tcl_Panic_TCL_DECLARED +#define Tcl_Panic_TCL_DECLARED +/* 2 */ +EXTERN void Tcl_Panic(CONST char *format, ...); +#endif +#ifndef Tcl_Alloc_TCL_DECLARED +#define Tcl_Alloc_TCL_DECLARED +/* 3 */ +EXTERN char * Tcl_Alloc(unsigned int size); +#endif +#ifndef Tcl_Free_TCL_DECLARED +#define Tcl_Free_TCL_DECLARED +/* 4 */ +EXTERN void Tcl_Free(char *ptr); +#endif +#ifndef Tcl_Realloc_TCL_DECLARED +#define Tcl_Realloc_TCL_DECLARED +/* 5 */ +EXTERN char * Tcl_Realloc(char *ptr, unsigned int size); +#endif +#ifndef Tcl_DbCkalloc_TCL_DECLARED +#define Tcl_DbCkalloc_TCL_DECLARED +/* 6 */ +EXTERN char * Tcl_DbCkalloc(unsigned int size, CONST char *file, + int line); +#endif +#ifndef Tcl_DbCkfree_TCL_DECLARED +#define Tcl_DbCkfree_TCL_DECLARED +/* 7 */ +EXTERN void Tcl_DbCkfree(char *ptr, CONST char *file, int line); +#endif +#ifndef Tcl_DbCkrealloc_TCL_DECLARED +#define Tcl_DbCkrealloc_TCL_DECLARED +/* 8 */ +EXTERN char * Tcl_DbCkrealloc(char *ptr, unsigned int size, + CONST char *file, int line); +#endif +#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#ifndef Tcl_CreateFileHandler_TCL_DECLARED +#define Tcl_CreateFileHandler_TCL_DECLARED +/* 9 */ +EXTERN void Tcl_CreateFileHandler(int fd, int mask, + Tcl_FileProc *proc, ClientData clientData); +#endif +#endif /* UNIX */ +#ifdef MAC_OSX_TCL /* MACOSX */ +#ifndef Tcl_CreateFileHandler_TCL_DECLARED +#define Tcl_CreateFileHandler_TCL_DECLARED +/* 9 */ +EXTERN void Tcl_CreateFileHandler(int fd, int mask, + Tcl_FileProc *proc, ClientData clientData); +#endif +#endif /* MACOSX */ +#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#ifndef Tcl_DeleteFileHandler_TCL_DECLARED +#define Tcl_DeleteFileHandler_TCL_DECLARED +/* 10 */ +EXTERN void Tcl_DeleteFileHandler(int fd); +#endif +#endif /* UNIX */ +#ifdef MAC_OSX_TCL /* MACOSX */ +#ifndef Tcl_DeleteFileHandler_TCL_DECLARED +#define Tcl_DeleteFileHandler_TCL_DECLARED +/* 10 */ +EXTERN void Tcl_DeleteFileHandler(int fd); +#endif +#endif /* MACOSX */ +#ifndef Tcl_SetTimer_TCL_DECLARED +#define Tcl_SetTimer_TCL_DECLARED +/* 11 */ +EXTERN void Tcl_SetTimer(Tcl_Time *timePtr); +#endif +#ifndef Tcl_Sleep_TCL_DECLARED +#define Tcl_Sleep_TCL_DECLARED +/* 12 */ +EXTERN void Tcl_Sleep(int ms); +#endif +#ifndef Tcl_WaitForEvent_TCL_DECLARED +#define Tcl_WaitForEvent_TCL_DECLARED +/* 13 */ +EXTERN int Tcl_WaitForEvent(Tcl_Time *timePtr); +#endif +#ifndef Tcl_AppendAllObjTypes_TCL_DECLARED +#define Tcl_AppendAllObjTypes_TCL_DECLARED /* 14 */ EXTERN int Tcl_AppendAllObjTypes(Tcl_Interp *interp, Tcl_Obj *objPtr); +#endif +#ifndef Tcl_AppendStringsToObj_TCL_DECLARED +#define Tcl_AppendStringsToObj_TCL_DECLARED /* 15 */ EXTERN void Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...); +#endif +#ifndef Tcl_AppendToObj_TCL_DECLARED +#define Tcl_AppendToObj_TCL_DECLARED /* 16 */ -EXTERN void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes, - size_t length); +EXTERN void Tcl_AppendToObj(Tcl_Obj *objPtr, CONST char *bytes, + int length); +#endif +#ifndef Tcl_ConcatObj_TCL_DECLARED +#define Tcl_ConcatObj_TCL_DECLARED /* 17 */ -EXTERN Tcl_Obj * Tcl_ConcatObj(int objc, Tcl_Obj *const objv[]); +EXTERN Tcl_Obj * Tcl_ConcatObj(int objc, Tcl_Obj *CONST objv[]); +#endif +#ifndef Tcl_ConvertToType_TCL_DECLARED +#define Tcl_ConvertToType_TCL_DECLARED /* 18 */ EXTERN int Tcl_ConvertToType(Tcl_Interp *interp, - Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); + Tcl_Obj *objPtr, Tcl_ObjType *typePtr); +#endif +#ifndef Tcl_DbDecrRefCount_TCL_DECLARED +#define Tcl_DbDecrRefCount_TCL_DECLARED /* 19 */ -EXTERN void Tcl_DbDecrRefCount(Tcl_Obj *objPtr, const char *file, +EXTERN void Tcl_DbDecrRefCount(Tcl_Obj *objPtr, CONST char *file, int line); +#endif +#ifndef Tcl_DbIncrRefCount_TCL_DECLARED +#define Tcl_DbIncrRefCount_TCL_DECLARED /* 20 */ -EXTERN void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file, +EXTERN void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, CONST char *file, int line); +#endif +#ifndef Tcl_DbIsShared_TCL_DECLARED +#define Tcl_DbIsShared_TCL_DECLARED /* 21 */ -EXTERN int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, +EXTERN int Tcl_DbIsShared(Tcl_Obj *objPtr, CONST char *file, + int line); +#endif +#ifndef Tcl_DbNewBooleanObj_TCL_DECLARED +#define Tcl_DbNewBooleanObj_TCL_DECLARED +/* 22 */ +EXTERN Tcl_Obj * Tcl_DbNewBooleanObj(int boolValue, CONST char *file, int line); -/* Slot 22 is reserved */ +#endif +#ifndef Tcl_DbNewByteArrayObj_TCL_DECLARED +#define Tcl_DbNewByteArrayObj_TCL_DECLARED /* 23 */ -EXTERN Tcl_Obj * Tcl_DbNewByteArrayObj(const unsigned char *bytes, - size_t length, const char *file, int line); +EXTERN Tcl_Obj * Tcl_DbNewByteArrayObj(CONST unsigned char *bytes, + int length, CONST char *file, int line); +#endif +#ifndef Tcl_DbNewDoubleObj_TCL_DECLARED +#define Tcl_DbNewDoubleObj_TCL_DECLARED /* 24 */ EXTERN Tcl_Obj * Tcl_DbNewDoubleObj(double doubleValue, - const char *file, int line); + CONST char *file, int line); +#endif +#ifndef Tcl_DbNewListObj_TCL_DECLARED +#define Tcl_DbNewListObj_TCL_DECLARED /* 25 */ -EXTERN Tcl_Obj * Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv, - const char *file, int line); -/* Slot 26 is reserved */ +EXTERN Tcl_Obj * Tcl_DbNewListObj(int objc, Tcl_Obj *CONST *objv, + CONST char *file, int line); +#endif +#ifndef Tcl_DbNewLongObj_TCL_DECLARED +#define Tcl_DbNewLongObj_TCL_DECLARED +/* 26 */ +EXTERN Tcl_Obj * Tcl_DbNewLongObj(long longValue, CONST char *file, + int line); +#endif +#ifndef Tcl_DbNewObj_TCL_DECLARED +#define Tcl_DbNewObj_TCL_DECLARED /* 27 */ -EXTERN Tcl_Obj * Tcl_DbNewObj(const char *file, int line); +EXTERN Tcl_Obj * Tcl_DbNewObj(CONST char *file, int line); +#endif +#ifndef Tcl_DbNewStringObj_TCL_DECLARED +#define Tcl_DbNewStringObj_TCL_DECLARED /* 28 */ -EXTERN Tcl_Obj * Tcl_DbNewStringObj(const char *bytes, size_t length, - const char *file, int line); +EXTERN Tcl_Obj * Tcl_DbNewStringObj(CONST char *bytes, int length, + CONST char *file, int line); +#endif +#ifndef Tcl_DuplicateObj_TCL_DECLARED +#define Tcl_DuplicateObj_TCL_DECLARED /* 29 */ EXTERN Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr); +#endif +#ifndef TclFreeObj_TCL_DECLARED +#define TclFreeObj_TCL_DECLARED /* 30 */ EXTERN void TclFreeObj(Tcl_Obj *objPtr); +#endif +#ifndef Tcl_GetBoolean_TCL_DECLARED +#define Tcl_GetBoolean_TCL_DECLARED /* 31 */ -EXTERN int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, - int *boolPtr); +EXTERN int Tcl_GetBoolean(Tcl_Interp *interp, CONST char *src, + int *intPtr); +#endif +#ifndef Tcl_GetBooleanFromObj_TCL_DECLARED +#define Tcl_GetBooleanFromObj_TCL_DECLARED /* 32 */ EXTERN int Tcl_GetBooleanFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, int *boolPtr); + Tcl_Obj *objPtr, int *intPtr); +#endif +#ifndef Tcl_GetByteArrayFromObj_TCL_DECLARED +#define Tcl_GetByteArrayFromObj_TCL_DECLARED /* 33 */ EXTERN unsigned char * Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *lengthPtr); +#endif +#ifndef Tcl_GetDouble_TCL_DECLARED +#define Tcl_GetDouble_TCL_DECLARED /* 34 */ -EXTERN int Tcl_GetDouble(Tcl_Interp *interp, const char *src, +EXTERN int Tcl_GetDouble(Tcl_Interp *interp, CONST char *src, double *doublePtr); +#endif +#ifndef Tcl_GetDoubleFromObj_TCL_DECLARED +#define Tcl_GetDoubleFromObj_TCL_DECLARED /* 35 */ EXTERN int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); -/* Slot 36 is reserved */ +#endif +#ifndef Tcl_GetIndexFromObj_TCL_DECLARED +#define Tcl_GetIndexFromObj_TCL_DECLARED +/* 36 */ +EXTERN int Tcl_GetIndexFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr, CONST84 char **tablePtr, + CONST char *msg, int flags, int *indexPtr); +#endif +#ifndef Tcl_GetInt_TCL_DECLARED +#define Tcl_GetInt_TCL_DECLARED /* 37 */ -EXTERN int Tcl_GetInt(Tcl_Interp *interp, const char *src, +EXTERN int Tcl_GetInt(Tcl_Interp *interp, CONST char *src, int *intPtr); +#endif +#ifndef Tcl_GetIntFromObj_TCL_DECLARED +#define Tcl_GetIntFromObj_TCL_DECLARED /* 38 */ EXTERN int Tcl_GetIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); +#endif +#ifndef Tcl_GetLongFromObj_TCL_DECLARED +#define Tcl_GetLongFromObj_TCL_DECLARED /* 39 */ EXTERN int Tcl_GetLongFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr); +#endif +#ifndef Tcl_GetObjType_TCL_DECLARED +#define Tcl_GetObjType_TCL_DECLARED /* 40 */ -EXTERN const Tcl_ObjType * Tcl_GetObjType(const char *typeName); +EXTERN Tcl_ObjType * Tcl_GetObjType(CONST char *typeName); +#endif +#ifndef Tcl_GetStringFromObj_TCL_DECLARED +#define Tcl_GetStringFromObj_TCL_DECLARED /* 41 */ EXTERN char * Tcl_GetStringFromObj(Tcl_Obj *objPtr, int *lengthPtr); +#endif +#ifndef Tcl_InvalidateStringRep_TCL_DECLARED +#define Tcl_InvalidateStringRep_TCL_DECLARED /* 42 */ EXTERN void Tcl_InvalidateStringRep(Tcl_Obj *objPtr); +#endif +#ifndef Tcl_ListObjAppendList_TCL_DECLARED +#define Tcl_ListObjAppendList_TCL_DECLARED /* 43 */ EXTERN int Tcl_ListObjAppendList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *elemListPtr); +#endif +#ifndef Tcl_ListObjAppendElement_TCL_DECLARED +#define Tcl_ListObjAppendElement_TCL_DECLARED /* 44 */ EXTERN int Tcl_ListObjAppendElement(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *objPtr); +#endif +#ifndef Tcl_ListObjGetElements_TCL_DECLARED +#define Tcl_ListObjGetElements_TCL_DECLARED /* 45 */ EXTERN int Tcl_ListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, int *objcPtr, Tcl_Obj ***objvPtr); +#endif +#ifndef Tcl_ListObjIndex_TCL_DECLARED +#define Tcl_ListObjIndex_TCL_DECLARED /* 46 */ EXTERN int Tcl_ListObjIndex(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj **objPtrPtr); +#endif +#ifndef Tcl_ListObjLength_TCL_DECLARED +#define Tcl_ListObjLength_TCL_DECLARED /* 47 */ EXTERN int Tcl_ListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr); +#endif +#ifndef Tcl_ListObjReplace_TCL_DECLARED +#define Tcl_ListObjReplace_TCL_DECLARED /* 48 */ EXTERN int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, - int objc, Tcl_Obj *const objv[]); -/* Slot 49 is reserved */ + int objc, Tcl_Obj *CONST objv[]); +#endif +#ifndef Tcl_NewBooleanObj_TCL_DECLARED +#define Tcl_NewBooleanObj_TCL_DECLARED +/* 49 */ +EXTERN Tcl_Obj * Tcl_NewBooleanObj(int intValue); +#endif +#ifndef Tcl_NewByteArrayObj_TCL_DECLARED +#define Tcl_NewByteArrayObj_TCL_DECLARED /* 50 */ -EXTERN Tcl_Obj * Tcl_NewByteArrayObj(const unsigned char *bytes, - size_t length); +EXTERN Tcl_Obj * Tcl_NewByteArrayObj(CONST unsigned char *bytes, + int length); +#endif +#ifndef Tcl_NewDoubleObj_TCL_DECLARED +#define Tcl_NewDoubleObj_TCL_DECLARED /* 51 */ EXTERN Tcl_Obj * Tcl_NewDoubleObj(double doubleValue); -/* Slot 52 is reserved */ +#endif +#ifndef Tcl_NewIntObj_TCL_DECLARED +#define Tcl_NewIntObj_TCL_DECLARED +/* 52 */ +EXTERN Tcl_Obj * Tcl_NewIntObj(int intValue); +#endif +#ifndef Tcl_NewListObj_TCL_DECLARED +#define Tcl_NewListObj_TCL_DECLARED /* 53 */ -EXTERN Tcl_Obj * Tcl_NewListObj(int objc, Tcl_Obj *const objv[]); -/* Slot 54 is reserved */ +EXTERN Tcl_Obj * Tcl_NewListObj(int objc, Tcl_Obj *CONST objv[]); +#endif +#ifndef Tcl_NewLongObj_TCL_DECLARED +#define Tcl_NewLongObj_TCL_DECLARED +/* 54 */ +EXTERN Tcl_Obj * Tcl_NewLongObj(long longValue); +#endif +#ifndef Tcl_NewObj_TCL_DECLARED +#define Tcl_NewObj_TCL_DECLARED /* 55 */ EXTERN Tcl_Obj * Tcl_NewObj(void); +#endif +#ifndef Tcl_NewStringObj_TCL_DECLARED +#define Tcl_NewStringObj_TCL_DECLARED /* 56 */ -EXTERN Tcl_Obj * Tcl_NewStringObj(const char *bytes, size_t length); -/* Slot 57 is reserved */ +EXTERN Tcl_Obj * Tcl_NewStringObj(CONST char *bytes, int length); +#endif +#ifndef Tcl_SetBooleanObj_TCL_DECLARED +#define Tcl_SetBooleanObj_TCL_DECLARED +/* 57 */ +EXTERN void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int intValue); +#endif +#ifndef Tcl_SetByteArrayLength_TCL_DECLARED +#define Tcl_SetByteArrayLength_TCL_DECLARED /* 58 */ -EXTERN unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, - size_t length); +EXTERN unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int numBytes); +#endif +#ifndef Tcl_SetByteArrayObj_TCL_DECLARED +#define Tcl_SetByteArrayObj_TCL_DECLARED /* 59 */ EXTERN void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, - const unsigned char *bytes, size_t length); + CONST unsigned char *bytes, int numBytes); +#endif +#ifndef Tcl_SetDoubleObj_TCL_DECLARED +#define Tcl_SetDoubleObj_TCL_DECLARED /* 60 */ EXTERN void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue); -/* Slot 61 is reserved */ +#endif +#ifndef Tcl_SetIntObj_TCL_DECLARED +#define Tcl_SetIntObj_TCL_DECLARED +/* 61 */ +EXTERN void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue); +#endif +#ifndef Tcl_SetListObj_TCL_DECLARED +#define Tcl_SetListObj_TCL_DECLARED /* 62 */ EXTERN void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, - Tcl_Obj *const objv[]); -/* Slot 63 is reserved */ + Tcl_Obj *CONST objv[]); +#endif +#ifndef Tcl_SetLongObj_TCL_DECLARED +#define Tcl_SetLongObj_TCL_DECLARED +/* 63 */ +EXTERN void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue); +#endif +#ifndef Tcl_SetObjLength_TCL_DECLARED +#define Tcl_SetObjLength_TCL_DECLARED /* 64 */ -EXTERN void Tcl_SetObjLength(Tcl_Obj *objPtr, size_t length); +EXTERN void Tcl_SetObjLength(Tcl_Obj *objPtr, int length); +#endif +#ifndef Tcl_SetStringObj_TCL_DECLARED +#define Tcl_SetStringObj_TCL_DECLARED /* 65 */ -EXTERN void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, - size_t length); -/* Slot 66 is reserved */ -/* Slot 67 is reserved */ +EXTERN void Tcl_SetStringObj(Tcl_Obj *objPtr, CONST char *bytes, + int length); +#endif +#ifndef Tcl_AddErrorInfo_TCL_DECLARED +#define Tcl_AddErrorInfo_TCL_DECLARED +/* 66 */ +EXTERN void Tcl_AddErrorInfo(Tcl_Interp *interp, + CONST char *message); +#endif +#ifndef Tcl_AddObjErrorInfo_TCL_DECLARED +#define Tcl_AddObjErrorInfo_TCL_DECLARED +/* 67 */ +EXTERN void Tcl_AddObjErrorInfo(Tcl_Interp *interp, + CONST char *message, int length); +#endif +#ifndef Tcl_AllowExceptions_TCL_DECLARED +#define Tcl_AllowExceptions_TCL_DECLARED /* 68 */ EXTERN void Tcl_AllowExceptions(Tcl_Interp *interp); +#endif +#ifndef Tcl_AppendElement_TCL_DECLARED +#define Tcl_AppendElement_TCL_DECLARED /* 69 */ EXTERN void Tcl_AppendElement(Tcl_Interp *interp, - const char *element); + CONST char *element); +#endif +#ifndef Tcl_AppendResult_TCL_DECLARED +#define Tcl_AppendResult_TCL_DECLARED /* 70 */ EXTERN void Tcl_AppendResult(Tcl_Interp *interp, ...); +#endif +#ifndef Tcl_AsyncCreate_TCL_DECLARED +#define Tcl_AsyncCreate_TCL_DECLARED /* 71 */ EXTERN Tcl_AsyncHandler Tcl_AsyncCreate(Tcl_AsyncProc *proc, - void *clientData); + ClientData clientData); +#endif +#ifndef Tcl_AsyncDelete_TCL_DECLARED +#define Tcl_AsyncDelete_TCL_DECLARED /* 72 */ EXTERN void Tcl_AsyncDelete(Tcl_AsyncHandler async); +#endif +#ifndef Tcl_AsyncInvoke_TCL_DECLARED +#define Tcl_AsyncInvoke_TCL_DECLARED /* 73 */ EXTERN int Tcl_AsyncInvoke(Tcl_Interp *interp, int code); +#endif +#ifndef Tcl_AsyncMark_TCL_DECLARED +#define Tcl_AsyncMark_TCL_DECLARED /* 74 */ EXTERN void Tcl_AsyncMark(Tcl_AsyncHandler async); +#endif +#ifndef Tcl_AsyncReady_TCL_DECLARED +#define Tcl_AsyncReady_TCL_DECLARED /* 75 */ EXTERN int Tcl_AsyncReady(void); -/* Slot 76 is reserved */ -/* Slot 77 is reserved */ +#endif +#ifndef Tcl_BackgroundError_TCL_DECLARED +#define Tcl_BackgroundError_TCL_DECLARED +/* 76 */ +EXTERN void Tcl_BackgroundError(Tcl_Interp *interp); +#endif +#ifndef Tcl_Backslash_TCL_DECLARED +#define Tcl_Backslash_TCL_DECLARED +/* 77 */ +EXTERN char Tcl_Backslash(CONST char *src, int *readPtr); +#endif +#ifndef Tcl_BadChannelOption_TCL_DECLARED +#define Tcl_BadChannelOption_TCL_DECLARED /* 78 */ EXTERN int Tcl_BadChannelOption(Tcl_Interp *interp, - const char *optionName, - const char *optionList); + CONST char *optionName, + CONST char *optionList); +#endif +#ifndef Tcl_CallWhenDeleted_TCL_DECLARED +#define Tcl_CallWhenDeleted_TCL_DECLARED /* 79 */ EXTERN void Tcl_CallWhenDeleted(Tcl_Interp *interp, - Tcl_InterpDeleteProc *proc, void *clientData); + Tcl_InterpDeleteProc *proc, + ClientData clientData); +#endif +#ifndef Tcl_CancelIdleCall_TCL_DECLARED +#define Tcl_CancelIdleCall_TCL_DECLARED /* 80 */ EXTERN void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, - void *clientData); -/* Slot 81 is reserved */ + ClientData clientData); +#endif +#ifndef Tcl_Close_TCL_DECLARED +#define Tcl_Close_TCL_DECLARED +/* 81 */ +EXTERN int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan); +#endif +#ifndef Tcl_CommandComplete_TCL_DECLARED +#define Tcl_CommandComplete_TCL_DECLARED /* 82 */ -EXTERN int Tcl_CommandComplete(const char *cmd); +EXTERN int Tcl_CommandComplete(CONST char *cmd); +#endif +#ifndef Tcl_Concat_TCL_DECLARED +#define Tcl_Concat_TCL_DECLARED /* 83 */ -EXTERN char * Tcl_Concat(int argc, const char *const *argv); +EXTERN char * Tcl_Concat(int argc, CONST84 char *CONST *argv); +#endif +#ifndef Tcl_ConvertElement_TCL_DECLARED +#define Tcl_ConvertElement_TCL_DECLARED /* 84 */ -EXTERN size_t Tcl_ConvertElement(const char *src, char *dst, +EXTERN int Tcl_ConvertElement(CONST char *src, char *dst, int flags); +#endif +#ifndef Tcl_ConvertCountedElement_TCL_DECLARED +#define Tcl_ConvertCountedElement_TCL_DECLARED /* 85 */ -EXTERN size_t Tcl_ConvertCountedElement(const char *src, - size_t length, char *dst, int flags); +EXTERN int Tcl_ConvertCountedElement(CONST char *src, + int length, char *dst, int flags); +#endif +#ifndef Tcl_CreateAlias_TCL_DECLARED +#define Tcl_CreateAlias_TCL_DECLARED /* 86 */ EXTERN int Tcl_CreateAlias(Tcl_Interp *childInterp, - const char *childCmd, Tcl_Interp *target, - const char *targetCmd, int argc, - const char *const *argv); + CONST char *childCmd, Tcl_Interp *target, + CONST char *targetCmd, int argc, + CONST84 char *CONST *argv); +#endif +#ifndef Tcl_CreateAliasObj_TCL_DECLARED +#define Tcl_CreateAliasObj_TCL_DECLARED /* 87 */ EXTERN int Tcl_CreateAliasObj(Tcl_Interp *childInterp, - const char *childCmd, Tcl_Interp *target, - const char *targetCmd, int objc, - Tcl_Obj *const objv[]); + CONST char *childCmd, Tcl_Interp *target, + CONST char *targetCmd, int objc, + Tcl_Obj *CONST objv[]); +#endif +#ifndef Tcl_CreateChannel_TCL_DECLARED +#define Tcl_CreateChannel_TCL_DECLARED /* 88 */ -EXTERN Tcl_Channel Tcl_CreateChannel(const Tcl_ChannelType *typePtr, - const char *chanName, void *instanceData, - int mask); +EXTERN Tcl_Channel Tcl_CreateChannel(Tcl_ChannelType *typePtr, + CONST char *chanName, + ClientData instanceData, int mask); +#endif +#ifndef Tcl_CreateChannelHandler_TCL_DECLARED +#define Tcl_CreateChannelHandler_TCL_DECLARED /* 89 */ EXTERN void Tcl_CreateChannelHandler(Tcl_Channel chan, int mask, - Tcl_ChannelProc *proc, void *clientData); + Tcl_ChannelProc *proc, ClientData clientData); +#endif +#ifndef Tcl_CreateCloseHandler_TCL_DECLARED +#define Tcl_CreateCloseHandler_TCL_DECLARED /* 90 */ EXTERN void Tcl_CreateCloseHandler(Tcl_Channel chan, - Tcl_CloseProc *proc, void *clientData); + Tcl_CloseProc *proc, ClientData clientData); +#endif +#ifndef Tcl_CreateCommand_TCL_DECLARED +#define Tcl_CreateCommand_TCL_DECLARED /* 91 */ EXTERN Tcl_Command Tcl_CreateCommand(Tcl_Interp *interp, - const char *cmdName, Tcl_CmdProc *proc, - void *clientData, + CONST char *cmdName, Tcl_CmdProc *proc, + ClientData clientData, Tcl_CmdDeleteProc *deleteProc); +#endif +#ifndef Tcl_CreateEventSource_TCL_DECLARED +#define Tcl_CreateEventSource_TCL_DECLARED /* 92 */ EXTERN void Tcl_CreateEventSource(Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, - void *clientData); + ClientData clientData); +#endif +#ifndef Tcl_CreateExitHandler_TCL_DECLARED +#define Tcl_CreateExitHandler_TCL_DECLARED /* 93 */ EXTERN void Tcl_CreateExitHandler(Tcl_ExitProc *proc, - void *clientData); + ClientData clientData); +#endif +#ifndef Tcl_CreateInterp_TCL_DECLARED +#define Tcl_CreateInterp_TCL_DECLARED /* 94 */ EXTERN Tcl_Interp * Tcl_CreateInterp(void); -/* Slot 95 is reserved */ +#endif +#ifndef Tcl_CreateMathFunc_TCL_DECLARED +#define Tcl_CreateMathFunc_TCL_DECLARED +/* 95 */ +EXTERN void Tcl_CreateMathFunc(Tcl_Interp *interp, + CONST char *name, int numArgs, + Tcl_ValueType *argTypes, Tcl_MathProc *proc, + ClientData clientData); +#endif +#ifndef Tcl_CreateObjCommand_TCL_DECLARED +#define Tcl_CreateObjCommand_TCL_DECLARED /* 96 */ EXTERN Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp, - const char *cmdName, Tcl_ObjCmdProc *proc, - void *clientData, + CONST char *cmdName, Tcl_ObjCmdProc *proc, + ClientData clientData, Tcl_CmdDeleteProc *deleteProc); +#endif +#ifndef Tcl_CreateSlave_TCL_DECLARED +#define Tcl_CreateSlave_TCL_DECLARED /* 97 */ -EXTERN Tcl_Interp * Tcl_CreateChild(Tcl_Interp *interp, const char *name, +EXTERN Tcl_Interp * Tcl_CreateSlave(Tcl_Interp *interp, CONST char *name, int isSafe); +#endif +#ifndef Tcl_CreateTimerHandler_TCL_DECLARED +#define Tcl_CreateTimerHandler_TCL_DECLARED /* 98 */ EXTERN Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds, - Tcl_TimerProc *proc, void *clientData); + Tcl_TimerProc *proc, ClientData clientData); +#endif +#ifndef Tcl_CreateTrace_TCL_DECLARED +#define Tcl_CreateTrace_TCL_DECLARED /* 99 */ EXTERN Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level, - Tcl_CmdTraceProc *proc, void *clientData); + Tcl_CmdTraceProc *proc, + ClientData clientData); +#endif +#ifndef Tcl_DeleteAssocData_TCL_DECLARED +#define Tcl_DeleteAssocData_TCL_DECLARED /* 100 */ EXTERN void Tcl_DeleteAssocData(Tcl_Interp *interp, - const char *name); + CONST char *name); +#endif +#ifndef Tcl_DeleteChannelHandler_TCL_DECLARED +#define Tcl_DeleteChannelHandler_TCL_DECLARED /* 101 */ EXTERN void Tcl_DeleteChannelHandler(Tcl_Channel chan, - Tcl_ChannelProc *proc, void *clientData); + Tcl_ChannelProc *proc, ClientData clientData); +#endif +#ifndef Tcl_DeleteCloseHandler_TCL_DECLARED +#define Tcl_DeleteCloseHandler_TCL_DECLARED /* 102 */ EXTERN void Tcl_DeleteCloseHandler(Tcl_Channel chan, - Tcl_CloseProc *proc, void *clientData); + Tcl_CloseProc *proc, ClientData clientData); +#endif +#ifndef Tcl_DeleteCommand_TCL_DECLARED +#define Tcl_DeleteCommand_TCL_DECLARED /* 103 */ EXTERN int Tcl_DeleteCommand(Tcl_Interp *interp, - const char *cmdName); + CONST char *cmdName); +#endif +#ifndef Tcl_DeleteCommandFromToken_TCL_DECLARED +#define Tcl_DeleteCommandFromToken_TCL_DECLARED /* 104 */ EXTERN int Tcl_DeleteCommandFromToken(Tcl_Interp *interp, Tcl_Command command); +#endif +#ifndef Tcl_DeleteEvents_TCL_DECLARED +#define Tcl_DeleteEvents_TCL_DECLARED /* 105 */ EXTERN void Tcl_DeleteEvents(Tcl_EventDeleteProc *proc, - void *clientData); + ClientData clientData); +#endif +#ifndef Tcl_DeleteEventSource_TCL_DECLARED +#define Tcl_DeleteEventSource_TCL_DECLARED /* 106 */ EXTERN void Tcl_DeleteEventSource(Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, - void *clientData); + ClientData clientData); +#endif +#ifndef Tcl_DeleteExitHandler_TCL_DECLARED +#define Tcl_DeleteExitHandler_TCL_DECLARED /* 107 */ EXTERN void Tcl_DeleteExitHandler(Tcl_ExitProc *proc, - void *clientData); + ClientData clientData); +#endif +#ifndef Tcl_DeleteHashEntry_TCL_DECLARED +#define Tcl_DeleteHashEntry_TCL_DECLARED /* 108 */ EXTERN void Tcl_DeleteHashEntry(Tcl_HashEntry *entryPtr); +#endif +#ifndef Tcl_DeleteHashTable_TCL_DECLARED +#define Tcl_DeleteHashTable_TCL_DECLARED /* 109 */ EXTERN void Tcl_DeleteHashTable(Tcl_HashTable *tablePtr); +#endif +#ifndef Tcl_DeleteInterp_TCL_DECLARED +#define Tcl_DeleteInterp_TCL_DECLARED /* 110 */ EXTERN void Tcl_DeleteInterp(Tcl_Interp *interp); +#endif +#ifndef Tcl_DetachPids_TCL_DECLARED +#define Tcl_DetachPids_TCL_DECLARED /* 111 */ EXTERN void Tcl_DetachPids(int numPids, Tcl_Pid *pidPtr); +#endif +#ifndef Tcl_DeleteTimerHandler_TCL_DECLARED +#define Tcl_DeleteTimerHandler_TCL_DECLARED /* 112 */ EXTERN void Tcl_DeleteTimerHandler(Tcl_TimerToken token); +#endif +#ifndef Tcl_DeleteTrace_TCL_DECLARED +#define Tcl_DeleteTrace_TCL_DECLARED /* 113 */ EXTERN void Tcl_DeleteTrace(Tcl_Interp *interp, Tcl_Trace trace); +#endif +#ifndef Tcl_DontCallWhenDeleted_TCL_DECLARED +#define Tcl_DontCallWhenDeleted_TCL_DECLARED /* 114 */ EXTERN void Tcl_DontCallWhenDeleted(Tcl_Interp *interp, - Tcl_InterpDeleteProc *proc, void *clientData); + Tcl_InterpDeleteProc *proc, + ClientData clientData); +#endif +#ifndef Tcl_DoOneEvent_TCL_DECLARED +#define Tcl_DoOneEvent_TCL_DECLARED /* 115 */ EXTERN int Tcl_DoOneEvent(int flags); +#endif +#ifndef Tcl_DoWhenIdle_TCL_DECLARED +#define Tcl_DoWhenIdle_TCL_DECLARED /* 116 */ -EXTERN void Tcl_DoWhenIdle(Tcl_IdleProc *proc, void *clientData); +EXTERN void Tcl_DoWhenIdle(Tcl_IdleProc *proc, + ClientData clientData); +#endif +#ifndef Tcl_DStringAppend_TCL_DECLARED +#define Tcl_DStringAppend_TCL_DECLARED /* 117 */ EXTERN char * Tcl_DStringAppend(Tcl_DString *dsPtr, - const char *bytes, size_t length); + CONST char *bytes, int length); +#endif +#ifndef Tcl_DStringAppendElement_TCL_DECLARED +#define Tcl_DStringAppendElement_TCL_DECLARED /* 118 */ EXTERN char * Tcl_DStringAppendElement(Tcl_DString *dsPtr, - const char *element); + CONST char *element); +#endif +#ifndef Tcl_DStringEndSublist_TCL_DECLARED +#define Tcl_DStringEndSublist_TCL_DECLARED /* 119 */ EXTERN void Tcl_DStringEndSublist(Tcl_DString *dsPtr); +#endif +#ifndef Tcl_DStringFree_TCL_DECLARED +#define Tcl_DStringFree_TCL_DECLARED /* 120 */ EXTERN void Tcl_DStringFree(Tcl_DString *dsPtr); +#endif +#ifndef Tcl_DStringGetResult_TCL_DECLARED +#define Tcl_DStringGetResult_TCL_DECLARED /* 121 */ EXTERN void Tcl_DStringGetResult(Tcl_Interp *interp, Tcl_DString *dsPtr); +#endif +#ifndef Tcl_DStringInit_TCL_DECLARED +#define Tcl_DStringInit_TCL_DECLARED /* 122 */ EXTERN void Tcl_DStringInit(Tcl_DString *dsPtr); +#endif +#ifndef Tcl_DStringResult_TCL_DECLARED +#define Tcl_DStringResult_TCL_DECLARED /* 123 */ EXTERN void Tcl_DStringResult(Tcl_Interp *interp, Tcl_DString *dsPtr); +#endif +#ifndef Tcl_DStringSetLength_TCL_DECLARED +#define Tcl_DStringSetLength_TCL_DECLARED /* 124 */ -EXTERN void Tcl_DStringSetLength(Tcl_DString *dsPtr, - size_t length); +EXTERN void Tcl_DStringSetLength(Tcl_DString *dsPtr, int length); +#endif +#ifndef Tcl_DStringStartSublist_TCL_DECLARED +#define Tcl_DStringStartSublist_TCL_DECLARED /* 125 */ EXTERN void Tcl_DStringStartSublist(Tcl_DString *dsPtr); +#endif +#ifndef Tcl_Eof_TCL_DECLARED +#define Tcl_Eof_TCL_DECLARED /* 126 */ EXTERN int Tcl_Eof(Tcl_Channel chan); +#endif +#ifndef Tcl_ErrnoId_TCL_DECLARED +#define Tcl_ErrnoId_TCL_DECLARED /* 127 */ -EXTERN const char * Tcl_ErrnoId(void); +EXTERN CONST84_RETURN char * Tcl_ErrnoId(void); +#endif +#ifndef Tcl_ErrnoMsg_TCL_DECLARED +#define Tcl_ErrnoMsg_TCL_DECLARED /* 128 */ -EXTERN const char * Tcl_ErrnoMsg(int err); -/* Slot 129 is reserved */ +EXTERN CONST84_RETURN char * Tcl_ErrnoMsg(int err); +#endif +#ifndef Tcl_Eval_TCL_DECLARED +#define Tcl_Eval_TCL_DECLARED +/* 129 */ +EXTERN int Tcl_Eval(Tcl_Interp *interp, CONST char *script); +#endif +#ifndef Tcl_EvalFile_TCL_DECLARED +#define Tcl_EvalFile_TCL_DECLARED /* 130 */ EXTERN int Tcl_EvalFile(Tcl_Interp *interp, - const char *fileName); -/* Slot 131 is reserved */ + CONST char *fileName); +#endif +#ifndef Tcl_EvalObj_TCL_DECLARED +#define Tcl_EvalObj_TCL_DECLARED +/* 131 */ +EXTERN int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr); +#endif +#ifndef Tcl_EventuallyFree_TCL_DECLARED +#define Tcl_EventuallyFree_TCL_DECLARED /* 132 */ -EXTERN void Tcl_EventuallyFree(void *clientData, +EXTERN void Tcl_EventuallyFree(ClientData clientData, Tcl_FreeProc *freeProc); +#endif +#ifndef Tcl_Exit_TCL_DECLARED +#define Tcl_Exit_TCL_DECLARED /* 133 */ -EXTERN TCL_NORETURN void Tcl_Exit(int status); +EXTERN void Tcl_Exit(int status); +#endif +#ifndef Tcl_ExposeCommand_TCL_DECLARED +#define Tcl_ExposeCommand_TCL_DECLARED /* 134 */ EXTERN int Tcl_ExposeCommand(Tcl_Interp *interp, - const char *hiddenCmdToken, - const char *cmdName); + CONST char *hiddenCmdToken, + CONST char *cmdName); +#endif +#ifndef Tcl_ExprBoolean_TCL_DECLARED +#define Tcl_ExprBoolean_TCL_DECLARED /* 135 */ -EXTERN int Tcl_ExprBoolean(Tcl_Interp *interp, const char *expr, +EXTERN int Tcl_ExprBoolean(Tcl_Interp *interp, CONST char *expr, int *ptr); +#endif +#ifndef Tcl_ExprBooleanObj_TCL_DECLARED +#define Tcl_ExprBooleanObj_TCL_DECLARED /* 136 */ EXTERN int Tcl_ExprBooleanObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *ptr); +#endif +#ifndef Tcl_ExprDouble_TCL_DECLARED +#define Tcl_ExprDouble_TCL_DECLARED /* 137 */ -EXTERN int Tcl_ExprDouble(Tcl_Interp *interp, const char *expr, +EXTERN int Tcl_ExprDouble(Tcl_Interp *interp, CONST char *expr, double *ptr); +#endif +#ifndef Tcl_ExprDoubleObj_TCL_DECLARED +#define Tcl_ExprDoubleObj_TCL_DECLARED /* 138 */ EXTERN int Tcl_ExprDoubleObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *ptr); +#endif +#ifndef Tcl_ExprLong_TCL_DECLARED +#define Tcl_ExprLong_TCL_DECLARED /* 139 */ -EXTERN int Tcl_ExprLong(Tcl_Interp *interp, const char *expr, +EXTERN int Tcl_ExprLong(Tcl_Interp *interp, CONST char *expr, long *ptr); +#endif +#ifndef Tcl_ExprLongObj_TCL_DECLARED +#define Tcl_ExprLongObj_TCL_DECLARED /* 140 */ EXTERN int Tcl_ExprLongObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *ptr); +#endif +#ifndef Tcl_ExprObj_TCL_DECLARED +#define Tcl_ExprObj_TCL_DECLARED /* 141 */ EXTERN int Tcl_ExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr); +#endif +#ifndef Tcl_ExprString_TCL_DECLARED +#define Tcl_ExprString_TCL_DECLARED /* 142 */ -EXTERN int Tcl_ExprString(Tcl_Interp *interp, const char *expr); +EXTERN int Tcl_ExprString(Tcl_Interp *interp, CONST char *expr); +#endif +#ifndef Tcl_Finalize_TCL_DECLARED +#define Tcl_Finalize_TCL_DECLARED /* 143 */ EXTERN void Tcl_Finalize(void); -/* Slot 144 is reserved */ +#endif +#ifndef Tcl_FindExecutable_TCL_DECLARED +#define Tcl_FindExecutable_TCL_DECLARED +/* 144 */ +EXTERN void Tcl_FindExecutable(CONST char *argv0); +#endif +#ifndef Tcl_FirstHashEntry_TCL_DECLARED +#define Tcl_FirstHashEntry_TCL_DECLARED /* 145 */ EXTERN Tcl_HashEntry * Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); +#endif +#ifndef Tcl_Flush_TCL_DECLARED +#define Tcl_Flush_TCL_DECLARED /* 146 */ EXTERN int Tcl_Flush(Tcl_Channel chan); -/* Slot 147 is reserved */ +#endif +#ifndef Tcl_FreeResult_TCL_DECLARED +#define Tcl_FreeResult_TCL_DECLARED +/* 147 */ +EXTERN void Tcl_FreeResult(Tcl_Interp *interp); +#endif +#ifndef Tcl_GetAlias_TCL_DECLARED +#define Tcl_GetAlias_TCL_DECLARED /* 148 */ EXTERN int Tcl_GetAlias(Tcl_Interp *interp, - const char *childCmd, + CONST char *slaveCmd, Tcl_Interp **targetInterpPtr, - const char **targetCmdPtr, int *argcPtr, - const char ***argvPtr); + CONST84 char **targetCmdPtr, int *argcPtr, + CONST84 char ***argvPtr); +#endif +#ifndef Tcl_GetAliasObj_TCL_DECLARED +#define Tcl_GetAliasObj_TCL_DECLARED /* 149 */ EXTERN int Tcl_GetAliasObj(Tcl_Interp *interp, - const char *childCmd, + CONST char *slaveCmd, Tcl_Interp **targetInterpPtr, - const char **targetCmdPtr, int *objcPtr, + CONST84 char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); +#endif +#ifndef Tcl_GetAssocData_TCL_DECLARED +#define Tcl_GetAssocData_TCL_DECLARED /* 150 */ -EXTERN void * Tcl_GetAssocData(Tcl_Interp *interp, - const char *name, +EXTERN ClientData Tcl_GetAssocData(Tcl_Interp *interp, + CONST char *name, Tcl_InterpDeleteProc **procPtr); +#endif +#ifndef Tcl_GetChannel_TCL_DECLARED +#define Tcl_GetChannel_TCL_DECLARED /* 151 */ EXTERN Tcl_Channel Tcl_GetChannel(Tcl_Interp *interp, - const char *chanName, int *modePtr); + CONST char *chanName, int *modePtr); +#endif +#ifndef Tcl_GetChannelBufferSize_TCL_DECLARED +#define Tcl_GetChannelBufferSize_TCL_DECLARED /* 152 */ EXTERN int Tcl_GetChannelBufferSize(Tcl_Channel chan); +#endif +#ifndef Tcl_GetChannelHandle_TCL_DECLARED +#define Tcl_GetChannelHandle_TCL_DECLARED /* 153 */ EXTERN int Tcl_GetChannelHandle(Tcl_Channel chan, int direction, - void **handlePtr); + ClientData *handlePtr); +#endif +#ifndef Tcl_GetChannelInstanceData_TCL_DECLARED +#define Tcl_GetChannelInstanceData_TCL_DECLARED /* 154 */ -EXTERN void * Tcl_GetChannelInstanceData(Tcl_Channel chan); +EXTERN ClientData Tcl_GetChannelInstanceData(Tcl_Channel chan); +#endif +#ifndef Tcl_GetChannelMode_TCL_DECLARED +#define Tcl_GetChannelMode_TCL_DECLARED /* 155 */ EXTERN int Tcl_GetChannelMode(Tcl_Channel chan); +#endif +#ifndef Tcl_GetChannelName_TCL_DECLARED +#define Tcl_GetChannelName_TCL_DECLARED /* 156 */ -EXTERN const char * Tcl_GetChannelName(Tcl_Channel chan); +EXTERN CONST84_RETURN char * Tcl_GetChannelName(Tcl_Channel chan); +#endif +#ifndef Tcl_GetChannelOption_TCL_DECLARED +#define Tcl_GetChannelOption_TCL_DECLARED /* 157 */ EXTERN int Tcl_GetChannelOption(Tcl_Interp *interp, - Tcl_Channel chan, const char *optionName, + Tcl_Channel chan, CONST char *optionName, Tcl_DString *dsPtr); +#endif +#ifndef Tcl_GetChannelType_TCL_DECLARED +#define Tcl_GetChannelType_TCL_DECLARED /* 158 */ -EXTERN const Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan); +EXTERN Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan); +#endif +#ifndef Tcl_GetCommandInfo_TCL_DECLARED +#define Tcl_GetCommandInfo_TCL_DECLARED /* 159 */ EXTERN int Tcl_GetCommandInfo(Tcl_Interp *interp, - const char *cmdName, Tcl_CmdInfo *infoPtr); + CONST char *cmdName, Tcl_CmdInfo *infoPtr); +#endif +#ifndef Tcl_GetCommandName_TCL_DECLARED +#define Tcl_GetCommandName_TCL_DECLARED /* 160 */ -EXTERN const char * Tcl_GetCommandName(Tcl_Interp *interp, +EXTERN CONST84_RETURN char * Tcl_GetCommandName(Tcl_Interp *interp, Tcl_Command command); +#endif +#ifndef Tcl_GetErrno_TCL_DECLARED +#define Tcl_GetErrno_TCL_DECLARED /* 161 */ EXTERN int Tcl_GetErrno(void); +#endif +#ifndef Tcl_GetHostName_TCL_DECLARED +#define Tcl_GetHostName_TCL_DECLARED /* 162 */ -EXTERN const char * Tcl_GetHostName(void); +EXTERN CONST84_RETURN char * Tcl_GetHostName(void); +#endif +#ifndef Tcl_GetInterpPath_TCL_DECLARED +#define Tcl_GetInterpPath_TCL_DECLARED /* 163 */ EXTERN int Tcl_GetInterpPath(Tcl_Interp *interp, Tcl_Interp *childInterp); -/* 164 */ -EXTERN Tcl_Interp * Tcl_GetParent(Tcl_Interp *interp); -/* 165 */ -EXTERN const char * Tcl_GetNameOfExecutable(void); -/* 166 */ -EXTERN Tcl_Obj * Tcl_GetObjResult(Tcl_Interp *interp); -#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ -/* 167 */ -EXTERN int Tcl_GetOpenFile(Tcl_Interp *interp, - const char *chanID, int forWriting, - int checkUsage, void **filePtr); -#endif /* UNIX */ -#ifdef MAC_OSX_TCL /* MACOSX */ -/* 167 */ -EXTERN int Tcl_GetOpenFile(Tcl_Interp *interp, - const char *chanID, int forWriting, - int checkUsage, void **filePtr); -#endif /* MACOSX */ -/* 168 */ -EXTERN Tcl_PathType Tcl_GetPathType(const char *path); -/* 169 */ -EXTERN size_t Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr); -/* 170 */ -EXTERN size_t Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr); -/* 171 */ -EXTERN int Tcl_GetServiceMode(void); -/* 172 */ -EXTERN Tcl_Interp * Tcl_GetChild(Tcl_Interp *interp, const char *name); -/* 173 */ -EXTERN Tcl_Channel Tcl_GetStdChannel(int type); -/* Slot 174 is reserved */ -/* Slot 175 is reserved */ -/* 176 */ -EXTERN const char * Tcl_GetVar2(Tcl_Interp *interp, const char *part1, - const char *part2, int flags); -/* Slot 177 is reserved */ -/* Slot 178 is reserved */ -/* 179 */ -EXTERN int Tcl_HideCommand(Tcl_Interp *interp, - const char *cmdName, - const char *hiddenCmdToken); -/* 180 */ -EXTERN int Tcl_Init(Tcl_Interp *interp); +#endif +#ifndef Tcl_GetMaster_TCL_DECLARED +#define Tcl_GetMaster_TCL_DECLARED +/* 164 */ +EXTERN Tcl_Interp * Tcl_GetMaster(Tcl_Interp *interp); +#endif +#ifndef Tcl_GetNameOfExecutable_TCL_DECLARED +#define Tcl_GetNameOfExecutable_TCL_DECLARED +/* 165 */ +EXTERN CONST char * Tcl_GetNameOfExecutable(void); +#endif +#ifndef Tcl_GetObjResult_TCL_DECLARED +#define Tcl_GetObjResult_TCL_DECLARED +/* 166 */ +EXTERN Tcl_Obj * Tcl_GetObjResult(Tcl_Interp *interp); +#endif +#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#ifndef Tcl_GetOpenFile_TCL_DECLARED +#define Tcl_GetOpenFile_TCL_DECLARED +/* 167 */ +EXTERN int Tcl_GetOpenFile(Tcl_Interp *interp, + CONST char *chanID, int forWriting, + int checkUsage, ClientData *filePtr); +#endif +#endif /* UNIX */ +#ifdef MAC_OSX_TCL /* MACOSX */ +#ifndef Tcl_GetOpenFile_TCL_DECLARED +#define Tcl_GetOpenFile_TCL_DECLARED +/* 167 */ +EXTERN int Tcl_GetOpenFile(Tcl_Interp *interp, + CONST char *chanID, int forWriting, + int checkUsage, ClientData *filePtr); +#endif +#endif /* MACOSX */ +#ifndef Tcl_GetPathType_TCL_DECLARED +#define Tcl_GetPathType_TCL_DECLARED +/* 168 */ +EXTERN Tcl_PathType Tcl_GetPathType(CONST char *path); +#endif +#ifndef Tcl_Gets_TCL_DECLARED +#define Tcl_Gets_TCL_DECLARED +/* 169 */ +EXTERN int Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr); +#endif +#ifndef Tcl_GetsObj_TCL_DECLARED +#define Tcl_GetsObj_TCL_DECLARED +/* 170 */ +EXTERN int Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr); +#endif +#ifndef Tcl_GetServiceMode_TCL_DECLARED +#define Tcl_GetServiceMode_TCL_DECLARED +/* 171 */ +EXTERN int Tcl_GetServiceMode(void); +#endif +#ifndef Tcl_GetSlave_TCL_DECLARED +#define Tcl_GetSlave_TCL_DECLARED +/* 172 */ +EXTERN Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, + CONST char *slaveName); +#endif +#ifndef Tcl_GetStdChannel_TCL_DECLARED +#define Tcl_GetStdChannel_TCL_DECLARED +/* 173 */ +EXTERN Tcl_Channel Tcl_GetStdChannel(int type); +#endif +#ifndef Tcl_GetStringResult_TCL_DECLARED +#define Tcl_GetStringResult_TCL_DECLARED +/* 174 */ +EXTERN CONST84_RETURN char * Tcl_GetStringResult(Tcl_Interp *interp); +#endif +#ifndef Tcl_GetVar_TCL_DECLARED +#define Tcl_GetVar_TCL_DECLARED +/* 175 */ +EXTERN CONST84_RETURN char * Tcl_GetVar(Tcl_Interp *interp, + CONST char *varName, int flags); +#endif +#ifndef Tcl_GetVar2_TCL_DECLARED +#define Tcl_GetVar2_TCL_DECLARED +/* 176 */ +EXTERN CONST84_RETURN char * Tcl_GetVar2(Tcl_Interp *interp, + CONST char *part1, CONST char *part2, + int flags); +#endif +#ifndef Tcl_GlobalEval_TCL_DECLARED +#define Tcl_GlobalEval_TCL_DECLARED +/* 177 */ +EXTERN int Tcl_GlobalEval(Tcl_Interp *interp, + CONST char *command); +#endif +#ifndef Tcl_GlobalEvalObj_TCL_DECLARED +#define Tcl_GlobalEvalObj_TCL_DECLARED +/* 178 */ +EXTERN int Tcl_GlobalEvalObj(Tcl_Interp *interp, + Tcl_Obj *objPtr); +#endif +#ifndef Tcl_HideCommand_TCL_DECLARED +#define Tcl_HideCommand_TCL_DECLARED +/* 179 */ +EXTERN int Tcl_HideCommand(Tcl_Interp *interp, + CONST char *cmdName, + CONST char *hiddenCmdToken); +#endif +#ifndef Tcl_Init_TCL_DECLARED +#define Tcl_Init_TCL_DECLARED +/* 180 */ +EXTERN int Tcl_Init(Tcl_Interp *interp); +#endif +#ifndef Tcl_InitHashTable_TCL_DECLARED +#define Tcl_InitHashTable_TCL_DECLARED /* 181 */ EXTERN void Tcl_InitHashTable(Tcl_HashTable *tablePtr, int keyType); +#endif +#ifndef Tcl_InputBlocked_TCL_DECLARED +#define Tcl_InputBlocked_TCL_DECLARED /* 182 */ EXTERN int Tcl_InputBlocked(Tcl_Channel chan); +#endif +#ifndef Tcl_InputBuffered_TCL_DECLARED +#define Tcl_InputBuffered_TCL_DECLARED /* 183 */ EXTERN int Tcl_InputBuffered(Tcl_Channel chan); +#endif +#ifndef Tcl_InterpDeleted_TCL_DECLARED +#define Tcl_InterpDeleted_TCL_DECLARED /* 184 */ EXTERN int Tcl_InterpDeleted(Tcl_Interp *interp); +#endif +#ifndef Tcl_IsSafe_TCL_DECLARED +#define Tcl_IsSafe_TCL_DECLARED /* 185 */ EXTERN int Tcl_IsSafe(Tcl_Interp *interp); +#endif +#ifndef Tcl_JoinPath_TCL_DECLARED +#define Tcl_JoinPath_TCL_DECLARED /* 186 */ -EXTERN char * Tcl_JoinPath(int argc, const char *const *argv, +EXTERN char * Tcl_JoinPath(int argc, CONST84 char *CONST *argv, Tcl_DString *resultPtr); +#endif +#ifndef Tcl_LinkVar_TCL_DECLARED +#define Tcl_LinkVar_TCL_DECLARED /* 187 */ -EXTERN int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, - void *addr, int type); +EXTERN int Tcl_LinkVar(Tcl_Interp *interp, CONST char *varName, + char *addr, int type); +#endif /* Slot 188 is reserved */ +#ifndef Tcl_MakeFileChannel_TCL_DECLARED +#define Tcl_MakeFileChannel_TCL_DECLARED /* 189 */ -EXTERN Tcl_Channel Tcl_MakeFileChannel(void *handle, int mode); +EXTERN Tcl_Channel Tcl_MakeFileChannel(ClientData handle, int mode); +#endif +#ifndef Tcl_MakeSafe_TCL_DECLARED +#define Tcl_MakeSafe_TCL_DECLARED /* 190 */ EXTERN int Tcl_MakeSafe(Tcl_Interp *interp); +#endif +#ifndef Tcl_MakeTcpClientChannel_TCL_DECLARED +#define Tcl_MakeTcpClientChannel_TCL_DECLARED /* 191 */ -EXTERN Tcl_Channel Tcl_MakeTcpClientChannel(void *tcpSocket); +EXTERN Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket); +#endif +#ifndef Tcl_Merge_TCL_DECLARED +#define Tcl_Merge_TCL_DECLARED /* 192 */ -EXTERN char * Tcl_Merge(int argc, const char *const *argv); +EXTERN char * Tcl_Merge(int argc, CONST84 char *CONST *argv); +#endif +#ifndef Tcl_NextHashEntry_TCL_DECLARED +#define Tcl_NextHashEntry_TCL_DECLARED /* 193 */ EXTERN Tcl_HashEntry * Tcl_NextHashEntry(Tcl_HashSearch *searchPtr); +#endif +#ifndef Tcl_NotifyChannel_TCL_DECLARED +#define Tcl_NotifyChannel_TCL_DECLARED /* 194 */ EXTERN void Tcl_NotifyChannel(Tcl_Channel channel, int mask); +#endif +#ifndef Tcl_ObjGetVar2_TCL_DECLARED +#define Tcl_ObjGetVar2_TCL_DECLARED /* 195 */ EXTERN Tcl_Obj * Tcl_ObjGetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); +#endif +#ifndef Tcl_ObjSetVar2_TCL_DECLARED +#define Tcl_ObjSetVar2_TCL_DECLARED /* 196 */ EXTERN Tcl_Obj * Tcl_ObjSetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); +#endif +#ifndef Tcl_OpenCommandChannel_TCL_DECLARED +#define Tcl_OpenCommandChannel_TCL_DECLARED /* 197 */ EXTERN Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc, - const char **argv, int flags); + CONST84 char **argv, int flags); +#endif +#ifndef Tcl_OpenFileChannel_TCL_DECLARED +#define Tcl_OpenFileChannel_TCL_DECLARED /* 198 */ EXTERN Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp, - const char *fileName, const char *modeString, + CONST char *fileName, CONST char *modeString, int permissions); +#endif +#ifndef Tcl_OpenTcpClient_TCL_DECLARED +#define Tcl_OpenTcpClient_TCL_DECLARED /* 199 */ EXTERN Tcl_Channel Tcl_OpenTcpClient(Tcl_Interp *interp, int port, - const char *address, const char *myaddr, - int myport, int async); + CONST char *address, CONST char *myaddr, + int myport, int flags); +#endif +#ifndef Tcl_OpenTcpServer_TCL_DECLARED +#define Tcl_OpenTcpServer_TCL_DECLARED /* 200 */ EXTERN Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port, - const char *host, + CONST char *host, Tcl_TcpAcceptProc *acceptProc, - void *callbackData); + ClientData callbackData); +#endif +#ifndef Tcl_Preserve_TCL_DECLARED +#define Tcl_Preserve_TCL_DECLARED /* 201 */ -EXTERN void Tcl_Preserve(void *data); +EXTERN void Tcl_Preserve(ClientData data); +#endif +#ifndef Tcl_PrintDouble_TCL_DECLARED +#define Tcl_PrintDouble_TCL_DECLARED /* 202 */ EXTERN void Tcl_PrintDouble(Tcl_Interp *interp, double value, char *dst); +#endif +#ifndef Tcl_PutEnv_TCL_DECLARED +#define Tcl_PutEnv_TCL_DECLARED /* 203 */ -EXTERN int Tcl_PutEnv(const char *assignment); +EXTERN int Tcl_PutEnv(CONST char *assignment); +#endif +#ifndef Tcl_PosixError_TCL_DECLARED +#define Tcl_PosixError_TCL_DECLARED /* 204 */ -EXTERN const char * Tcl_PosixError(Tcl_Interp *interp); +EXTERN CONST84_RETURN char * Tcl_PosixError(Tcl_Interp *interp); +#endif +#ifndef Tcl_QueueEvent_TCL_DECLARED +#define Tcl_QueueEvent_TCL_DECLARED /* 205 */ EXTERN void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position); +#endif +#ifndef Tcl_Read_TCL_DECLARED +#define Tcl_Read_TCL_DECLARED /* 206 */ -EXTERN size_t Tcl_Read(Tcl_Channel chan, char *bufPtr, - size_t toRead); +EXTERN int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead); +#endif +#ifndef Tcl_ReapDetachedProcs_TCL_DECLARED +#define Tcl_ReapDetachedProcs_TCL_DECLARED /* 207 */ EXTERN void Tcl_ReapDetachedProcs(void); +#endif +#ifndef Tcl_RecordAndEval_TCL_DECLARED +#define Tcl_RecordAndEval_TCL_DECLARED /* 208 */ EXTERN int Tcl_RecordAndEval(Tcl_Interp *interp, - const char *cmd, int flags); + CONST char *cmd, int flags); +#endif +#ifndef Tcl_RecordAndEvalObj_TCL_DECLARED +#define Tcl_RecordAndEvalObj_TCL_DECLARED /* 209 */ EXTERN int Tcl_RecordAndEvalObj(Tcl_Interp *interp, Tcl_Obj *cmdPtr, int flags); +#endif +#ifndef Tcl_RegisterChannel_TCL_DECLARED +#define Tcl_RegisterChannel_TCL_DECLARED /* 210 */ EXTERN void Tcl_RegisterChannel(Tcl_Interp *interp, Tcl_Channel chan); +#endif +#ifndef Tcl_RegisterObjType_TCL_DECLARED +#define Tcl_RegisterObjType_TCL_DECLARED /* 211 */ -EXTERN void Tcl_RegisterObjType(const Tcl_ObjType *typePtr); +EXTERN void Tcl_RegisterObjType(Tcl_ObjType *typePtr); +#endif +#ifndef Tcl_RegExpCompile_TCL_DECLARED +#define Tcl_RegExpCompile_TCL_DECLARED /* 212 */ EXTERN Tcl_RegExp Tcl_RegExpCompile(Tcl_Interp *interp, - const char *pattern); + CONST char *pattern); +#endif +#ifndef Tcl_RegExpExec_TCL_DECLARED +#define Tcl_RegExpExec_TCL_DECLARED /* 213 */ EXTERN int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp, - const char *text, const char *start); + CONST char *text, CONST char *start); +#endif +#ifndef Tcl_RegExpMatch_TCL_DECLARED +#define Tcl_RegExpMatch_TCL_DECLARED /* 214 */ -EXTERN int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text, - const char *pattern); +EXTERN int Tcl_RegExpMatch(Tcl_Interp *interp, CONST char *text, + CONST char *pattern); +#endif +#ifndef Tcl_RegExpRange_TCL_DECLARED +#define Tcl_RegExpRange_TCL_DECLARED /* 215 */ -EXTERN void Tcl_RegExpRange(Tcl_RegExp regexp, size_t index, - const char **startPtr, const char **endPtr); +EXTERN void Tcl_RegExpRange(Tcl_RegExp regexp, int index, + CONST84 char **startPtr, + CONST84 char **endPtr); +#endif +#ifndef Tcl_Release_TCL_DECLARED +#define Tcl_Release_TCL_DECLARED /* 216 */ -EXTERN void Tcl_Release(void *clientData); +EXTERN void Tcl_Release(ClientData clientData); +#endif +#ifndef Tcl_ResetResult_TCL_DECLARED +#define Tcl_ResetResult_TCL_DECLARED /* 217 */ EXTERN void Tcl_ResetResult(Tcl_Interp *interp); +#endif +#ifndef Tcl_ScanElement_TCL_DECLARED +#define Tcl_ScanElement_TCL_DECLARED /* 218 */ -EXTERN size_t Tcl_ScanElement(const char *src, int *flagPtr); +EXTERN int Tcl_ScanElement(CONST char *src, int *flagPtr); +#endif +#ifndef Tcl_ScanCountedElement_TCL_DECLARED +#define Tcl_ScanCountedElement_TCL_DECLARED /* 219 */ -EXTERN size_t Tcl_ScanCountedElement(const char *src, - size_t length, int *flagPtr); -/* Slot 220 is reserved */ +EXTERN int Tcl_ScanCountedElement(CONST char *src, int length, + int *flagPtr); +#endif +#ifndef Tcl_SeekOld_TCL_DECLARED +#define Tcl_SeekOld_TCL_DECLARED +/* 220 */ +EXTERN int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode); +#endif +#ifndef Tcl_ServiceAll_TCL_DECLARED +#define Tcl_ServiceAll_TCL_DECLARED /* 221 */ EXTERN int Tcl_ServiceAll(void); +#endif +#ifndef Tcl_ServiceEvent_TCL_DECLARED +#define Tcl_ServiceEvent_TCL_DECLARED /* 222 */ EXTERN int Tcl_ServiceEvent(int flags); +#endif +#ifndef Tcl_SetAssocData_TCL_DECLARED +#define Tcl_SetAssocData_TCL_DECLARED /* 223 */ EXTERN void Tcl_SetAssocData(Tcl_Interp *interp, - const char *name, Tcl_InterpDeleteProc *proc, - void *clientData); + CONST char *name, Tcl_InterpDeleteProc *proc, + ClientData clientData); +#endif +#ifndef Tcl_SetChannelBufferSize_TCL_DECLARED +#define Tcl_SetChannelBufferSize_TCL_DECLARED /* 224 */ EXTERN void Tcl_SetChannelBufferSize(Tcl_Channel chan, int sz); +#endif +#ifndef Tcl_SetChannelOption_TCL_DECLARED +#define Tcl_SetChannelOption_TCL_DECLARED /* 225 */ EXTERN int Tcl_SetChannelOption(Tcl_Interp *interp, - Tcl_Channel chan, const char *optionName, - const char *newValue); + Tcl_Channel chan, CONST char *optionName, + CONST char *newValue); +#endif +#ifndef Tcl_SetCommandInfo_TCL_DECLARED +#define Tcl_SetCommandInfo_TCL_DECLARED /* 226 */ EXTERN int Tcl_SetCommandInfo(Tcl_Interp *interp, - const char *cmdName, - const Tcl_CmdInfo *infoPtr); + CONST char *cmdName, + CONST Tcl_CmdInfo *infoPtr); +#endif +#ifndef Tcl_SetErrno_TCL_DECLARED +#define Tcl_SetErrno_TCL_DECLARED /* 227 */ EXTERN void Tcl_SetErrno(int err); +#endif +#ifndef Tcl_SetErrorCode_TCL_DECLARED +#define Tcl_SetErrorCode_TCL_DECLARED /* 228 */ EXTERN void Tcl_SetErrorCode(Tcl_Interp *interp, ...); +#endif +#ifndef Tcl_SetMaxBlockTime_TCL_DECLARED +#define Tcl_SetMaxBlockTime_TCL_DECLARED /* 229 */ -EXTERN void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr); -/* Slot 230 is reserved */ +EXTERN void Tcl_SetMaxBlockTime(Tcl_Time *timePtr); +#endif +#ifndef Tcl_SetPanicProc_TCL_DECLARED +#define Tcl_SetPanicProc_TCL_DECLARED +/* 230 */ +EXTERN void Tcl_SetPanicProc(Tcl_PanicProc *panicProc); +#endif +#ifndef Tcl_SetRecursionLimit_TCL_DECLARED +#define Tcl_SetRecursionLimit_TCL_DECLARED /* 231 */ EXTERN int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth); -/* Slot 232 is reserved */ +#endif +#ifndef Tcl_SetResult_TCL_DECLARED +#define Tcl_SetResult_TCL_DECLARED +/* 232 */ +EXTERN void Tcl_SetResult(Tcl_Interp *interp, char *result, + Tcl_FreeProc *freeProc); +#endif +#ifndef Tcl_SetServiceMode_TCL_DECLARED +#define Tcl_SetServiceMode_TCL_DECLARED /* 233 */ EXTERN int Tcl_SetServiceMode(int mode); +#endif +#ifndef Tcl_SetObjErrorCode_TCL_DECLARED +#define Tcl_SetObjErrorCode_TCL_DECLARED /* 234 */ EXTERN void Tcl_SetObjErrorCode(Tcl_Interp *interp, Tcl_Obj *errorObjPtr); +#endif +#ifndef Tcl_SetObjResult_TCL_DECLARED +#define Tcl_SetObjResult_TCL_DECLARED /* 235 */ EXTERN void Tcl_SetObjResult(Tcl_Interp *interp, Tcl_Obj *resultObjPtr); +#endif +#ifndef Tcl_SetStdChannel_TCL_DECLARED +#define Tcl_SetStdChannel_TCL_DECLARED /* 236 */ EXTERN void Tcl_SetStdChannel(Tcl_Channel channel, int type); -/* Slot 237 is reserved */ +#endif +#ifndef Tcl_SetVar_TCL_DECLARED +#define Tcl_SetVar_TCL_DECLARED +/* 237 */ +EXTERN CONST84_RETURN char * Tcl_SetVar(Tcl_Interp *interp, + CONST char *varName, CONST char *newValue, + int flags); +#endif +#ifndef Tcl_SetVar2_TCL_DECLARED +#define Tcl_SetVar2_TCL_DECLARED /* 238 */ -EXTERN const char * Tcl_SetVar2(Tcl_Interp *interp, const char *part1, - const char *part2, const char *newValue, - int flags); +EXTERN CONST84_RETURN char * Tcl_SetVar2(Tcl_Interp *interp, + CONST char *part1, CONST char *part2, + CONST char *newValue, int flags); +#endif +#ifndef Tcl_SignalId_TCL_DECLARED +#define Tcl_SignalId_TCL_DECLARED /* 239 */ -EXTERN const char * Tcl_SignalId(int sig); +EXTERN CONST84_RETURN char * Tcl_SignalId(int sig); +#endif +#ifndef Tcl_SignalMsg_TCL_DECLARED +#define Tcl_SignalMsg_TCL_DECLARED /* 240 */ -EXTERN const char * Tcl_SignalMsg(int sig); +EXTERN CONST84_RETURN char * Tcl_SignalMsg(int sig); +#endif +#ifndef Tcl_SourceRCFile_TCL_DECLARED +#define Tcl_SourceRCFile_TCL_DECLARED /* 241 */ EXTERN void Tcl_SourceRCFile(Tcl_Interp *interp); +#endif +#ifndef Tcl_SplitList_TCL_DECLARED +#define Tcl_SplitList_TCL_DECLARED /* 242 */ EXTERN int Tcl_SplitList(Tcl_Interp *interp, - const char *listStr, int *argcPtr, - const char ***argvPtr); + CONST char *listStr, int *argcPtr, + CONST84 char ***argvPtr); +#endif +#ifndef Tcl_SplitPath_TCL_DECLARED +#define Tcl_SplitPath_TCL_DECLARED /* 243 */ -EXTERN void Tcl_SplitPath(const char *path, int *argcPtr, - const char ***argvPtr); -/* Slot 244 is reserved */ -/* Slot 245 is reserved */ -/* Slot 246 is reserved */ -/* Slot 247 is reserved */ +EXTERN void Tcl_SplitPath(CONST char *path, int *argcPtr, + CONST84 char ***argvPtr); +#endif +#ifndef Tcl_StaticPackage_TCL_DECLARED +#define Tcl_StaticPackage_TCL_DECLARED +/* 244 */ +EXTERN void Tcl_StaticPackage(Tcl_Interp *interp, + CONST char *pkgName, + Tcl_PackageInitProc *initProc, + Tcl_PackageInitProc *safeInitProc); +#endif +#ifndef Tcl_StringMatch_TCL_DECLARED +#define Tcl_StringMatch_TCL_DECLARED +/* 245 */ +EXTERN int Tcl_StringMatch(CONST char *str, CONST char *pattern); +#endif +#ifndef Tcl_TellOld_TCL_DECLARED +#define Tcl_TellOld_TCL_DECLARED +/* 246 */ +EXTERN int Tcl_TellOld(Tcl_Channel chan); +#endif +#ifndef Tcl_TraceVar_TCL_DECLARED +#define Tcl_TraceVar_TCL_DECLARED +/* 247 */ +EXTERN int Tcl_TraceVar(Tcl_Interp *interp, CONST char *varName, + int flags, Tcl_VarTraceProc *proc, + ClientData clientData); +#endif +#ifndef Tcl_TraceVar2_TCL_DECLARED +#define Tcl_TraceVar2_TCL_DECLARED /* 248 */ -EXTERN int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1, - const char *part2, int flags, - Tcl_VarTraceProc *proc, void *clientData); +EXTERN int Tcl_TraceVar2(Tcl_Interp *interp, CONST char *part1, + CONST char *part2, int flags, + Tcl_VarTraceProc *proc, + ClientData clientData); +#endif +#ifndef Tcl_TranslateFileName_TCL_DECLARED +#define Tcl_TranslateFileName_TCL_DECLARED /* 249 */ EXTERN char * Tcl_TranslateFileName(Tcl_Interp *interp, - const char *name, Tcl_DString *bufferPtr); + CONST char *name, Tcl_DString *bufferPtr); +#endif +#ifndef Tcl_Ungets_TCL_DECLARED +#define Tcl_Ungets_TCL_DECLARED /* 250 */ -EXTERN size_t Tcl_Ungets(Tcl_Channel chan, const char *str, - size_t len, int atHead); +EXTERN int Tcl_Ungets(Tcl_Channel chan, CONST char *str, + int len, int atHead); +#endif +#ifndef Tcl_UnlinkVar_TCL_DECLARED +#define Tcl_UnlinkVar_TCL_DECLARED /* 251 */ EXTERN void Tcl_UnlinkVar(Tcl_Interp *interp, - const char *varName); + CONST char *varName); +#endif +#ifndef Tcl_UnregisterChannel_TCL_DECLARED +#define Tcl_UnregisterChannel_TCL_DECLARED /* 252 */ EXTERN int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan); -/* Slot 253 is reserved */ +#endif +#ifndef Tcl_UnsetVar_TCL_DECLARED +#define Tcl_UnsetVar_TCL_DECLARED +/* 253 */ +EXTERN int Tcl_UnsetVar(Tcl_Interp *interp, CONST char *varName, + int flags); +#endif +#ifndef Tcl_UnsetVar2_TCL_DECLARED +#define Tcl_UnsetVar2_TCL_DECLARED /* 254 */ -EXTERN int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, - const char *part2, int flags); -/* Slot 255 is reserved */ +EXTERN int Tcl_UnsetVar2(Tcl_Interp *interp, CONST char *part1, + CONST char *part2, int flags); +#endif +#ifndef Tcl_UntraceVar_TCL_DECLARED +#define Tcl_UntraceVar_TCL_DECLARED +/* 255 */ +EXTERN void Tcl_UntraceVar(Tcl_Interp *interp, + CONST char *varName, int flags, + Tcl_VarTraceProc *proc, + ClientData clientData); +#endif +#ifndef Tcl_UntraceVar2_TCL_DECLARED +#define Tcl_UntraceVar2_TCL_DECLARED /* 256 */ EXTERN void Tcl_UntraceVar2(Tcl_Interp *interp, - const char *part1, const char *part2, + CONST char *part1, CONST char *part2, int flags, Tcl_VarTraceProc *proc, - void *clientData); + ClientData clientData); +#endif +#ifndef Tcl_UpdateLinkedVar_TCL_DECLARED +#define Tcl_UpdateLinkedVar_TCL_DECLARED /* 257 */ EXTERN void Tcl_UpdateLinkedVar(Tcl_Interp *interp, - const char *varName); -/* Slot 258 is reserved */ + CONST char *varName); +#endif +#ifndef Tcl_UpVar_TCL_DECLARED +#define Tcl_UpVar_TCL_DECLARED +/* 258 */ +EXTERN int Tcl_UpVar(Tcl_Interp *interp, CONST char *frameName, + CONST char *varName, CONST char *localName, + int flags); +#endif +#ifndef Tcl_UpVar2_TCL_DECLARED +#define Tcl_UpVar2_TCL_DECLARED /* 259 */ -EXTERN int Tcl_UpVar2(Tcl_Interp *interp, const char *frameName, - const char *part1, const char *part2, - const char *localName, int flags); +EXTERN int Tcl_UpVar2(Tcl_Interp *interp, CONST char *frameName, + CONST char *part1, CONST char *part2, + CONST char *localName, int flags); +#endif +#ifndef Tcl_VarEval_TCL_DECLARED +#define Tcl_VarEval_TCL_DECLARED /* 260 */ EXTERN int Tcl_VarEval(Tcl_Interp *interp, ...); -/* Slot 261 is reserved */ +#endif +#ifndef Tcl_VarTraceInfo_TCL_DECLARED +#define Tcl_VarTraceInfo_TCL_DECLARED +/* 261 */ +EXTERN ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, + CONST char *varName, int flags, + Tcl_VarTraceProc *procPtr, + ClientData prevClientData); +#endif +#ifndef Tcl_VarTraceInfo2_TCL_DECLARED +#define Tcl_VarTraceInfo2_TCL_DECLARED /* 262 */ -EXTERN void * Tcl_VarTraceInfo2(Tcl_Interp *interp, - const char *part1, const char *part2, +EXTERN ClientData Tcl_VarTraceInfo2(Tcl_Interp *interp, + CONST char *part1, CONST char *part2, int flags, Tcl_VarTraceProc *procPtr, - void *prevClientData); + ClientData prevClientData); +#endif +#ifndef Tcl_Write_TCL_DECLARED +#define Tcl_Write_TCL_DECLARED /* 263 */ -EXTERN size_t Tcl_Write(Tcl_Channel chan, const char *s, - size_t slen); +EXTERN int Tcl_Write(Tcl_Channel chan, CONST char *s, int slen); +#endif +#ifndef Tcl_WrongNumArgs_TCL_DECLARED +#define Tcl_WrongNumArgs_TCL_DECLARED /* 264 */ EXTERN void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[], const char *message); + Tcl_Obj *CONST objv[], CONST char *message); +#endif +#ifndef Tcl_DumpActiveMemory_TCL_DECLARED +#define Tcl_DumpActiveMemory_TCL_DECLARED /* 265 */ -EXTERN int Tcl_DumpActiveMemory(const char *fileName); +EXTERN int Tcl_DumpActiveMemory(CONST char *fileName); +#endif +#ifndef Tcl_ValidateAllMemory_TCL_DECLARED +#define Tcl_ValidateAllMemory_TCL_DECLARED /* 266 */ -EXTERN void Tcl_ValidateAllMemory(const char *file, int line); -/* Slot 267 is reserved */ -/* Slot 268 is reserved */ +EXTERN void Tcl_ValidateAllMemory(CONST char *file, int line); +#endif +#ifndef Tcl_AppendResultVA_TCL_DECLARED +#define Tcl_AppendResultVA_TCL_DECLARED +/* 267 */ +EXTERN void Tcl_AppendResultVA(Tcl_Interp *interp, + va_list argList); +#endif +#ifndef Tcl_AppendStringsToObjVA_TCL_DECLARED +#define Tcl_AppendStringsToObjVA_TCL_DECLARED +/* 268 */ +EXTERN void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, + va_list argList); +#endif +#ifndef Tcl_HashStats_TCL_DECLARED +#define Tcl_HashStats_TCL_DECLARED /* 269 */ EXTERN char * Tcl_HashStats(Tcl_HashTable *tablePtr); +#endif +#ifndef Tcl_ParseVar_TCL_DECLARED +#define Tcl_ParseVar_TCL_DECLARED /* 270 */ -EXTERN const char * Tcl_ParseVar(Tcl_Interp *interp, const char *start, - const char **termPtr); -/* Slot 271 is reserved */ +EXTERN CONST84_RETURN char * Tcl_ParseVar(Tcl_Interp *interp, + CONST char *start, CONST84 char **termPtr); +#endif +#ifndef Tcl_PkgPresent_TCL_DECLARED +#define Tcl_PkgPresent_TCL_DECLARED +/* 271 */ +EXTERN CONST84_RETURN char * Tcl_PkgPresent(Tcl_Interp *interp, + CONST char *name, CONST char *version, + int exact); +#endif +#ifndef Tcl_PkgPresentEx_TCL_DECLARED +#define Tcl_PkgPresentEx_TCL_DECLARED /* 272 */ -EXTERN const char * Tcl_PkgPresentEx(Tcl_Interp *interp, - const char *name, const char *version, - int exact, void *clientDataPtr); -/* Slot 273 is reserved */ -/* Slot 274 is reserved */ -/* Slot 275 is reserved */ -/* Slot 276 is reserved */ +EXTERN CONST84_RETURN char * Tcl_PkgPresentEx(Tcl_Interp *interp, + CONST char *name, CONST char *version, + int exact, ClientData *clientDataPtr); +#endif +#ifndef Tcl_PkgProvide_TCL_DECLARED +#define Tcl_PkgProvide_TCL_DECLARED +/* 273 */ +EXTERN int Tcl_PkgProvide(Tcl_Interp *interp, CONST char *name, + CONST char *version); +#endif +#ifndef Tcl_PkgRequire_TCL_DECLARED +#define Tcl_PkgRequire_TCL_DECLARED +/* 274 */ +EXTERN CONST84_RETURN char * Tcl_PkgRequire(Tcl_Interp *interp, + CONST char *name, CONST char *version, + int exact); +#endif +#ifndef Tcl_SetErrorCodeVA_TCL_DECLARED +#define Tcl_SetErrorCodeVA_TCL_DECLARED +/* 275 */ +EXTERN void Tcl_SetErrorCodeVA(Tcl_Interp *interp, + va_list argList); +#endif +#ifndef Tcl_VarEvalVA_TCL_DECLARED +#define Tcl_VarEvalVA_TCL_DECLARED +/* 276 */ +EXTERN int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList); +#endif +#ifndef Tcl_WaitPid_TCL_DECLARED +#define Tcl_WaitPid_TCL_DECLARED /* 277 */ EXTERN Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options); -/* Slot 278 is reserved */ +#endif +#ifndef Tcl_PanicVA_TCL_DECLARED +#define Tcl_PanicVA_TCL_DECLARED +/* 278 */ +EXTERN void Tcl_PanicVA(CONST char *format, va_list argList); +#endif +#ifndef Tcl_GetVersion_TCL_DECLARED +#define Tcl_GetVersion_TCL_DECLARED /* 279 */ EXTERN void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type); +#endif +#ifndef Tcl_InitMemory_TCL_DECLARED +#define Tcl_InitMemory_TCL_DECLARED /* 280 */ EXTERN void Tcl_InitMemory(Tcl_Interp *interp); +#endif +#ifndef Tcl_StackChannel_TCL_DECLARED +#define Tcl_StackChannel_TCL_DECLARED /* 281 */ EXTERN Tcl_Channel Tcl_StackChannel(Tcl_Interp *interp, - const Tcl_ChannelType *typePtr, - void *instanceData, int mask, + Tcl_ChannelType *typePtr, + ClientData instanceData, int mask, Tcl_Channel prevChan); +#endif +#ifndef Tcl_UnstackChannel_TCL_DECLARED +#define Tcl_UnstackChannel_TCL_DECLARED /* 282 */ EXTERN int Tcl_UnstackChannel(Tcl_Interp *interp, Tcl_Channel chan); +#endif +#ifndef Tcl_GetStackedChannel_TCL_DECLARED +#define Tcl_GetStackedChannel_TCL_DECLARED /* 283 */ EXTERN Tcl_Channel Tcl_GetStackedChannel(Tcl_Channel chan); +#endif +#ifndef Tcl_SetMainLoop_TCL_DECLARED +#define Tcl_SetMainLoop_TCL_DECLARED /* 284 */ EXTERN void Tcl_SetMainLoop(Tcl_MainLoopProc *proc); +#endif /* Slot 285 is reserved */ +#ifndef Tcl_AppendObjToObj_TCL_DECLARED +#define Tcl_AppendObjToObj_TCL_DECLARED /* 286 */ EXTERN void Tcl_AppendObjToObj(Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr); +#endif +#ifndef Tcl_CreateEncoding_TCL_DECLARED +#define Tcl_CreateEncoding_TCL_DECLARED /* 287 */ -EXTERN Tcl_Encoding Tcl_CreateEncoding(const Tcl_EncodingType *typePtr); +EXTERN Tcl_Encoding Tcl_CreateEncoding(CONST Tcl_EncodingType *typePtr); +#endif +#ifndef Tcl_CreateThreadExitHandler_TCL_DECLARED +#define Tcl_CreateThreadExitHandler_TCL_DECLARED /* 288 */ EXTERN void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc, - void *clientData); + ClientData clientData); +#endif +#ifndef Tcl_DeleteThreadExitHandler_TCL_DECLARED +#define Tcl_DeleteThreadExitHandler_TCL_DECLARED /* 289 */ EXTERN void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, - void *clientData); -/* Slot 290 is reserved */ + ClientData clientData); +#endif +#ifndef Tcl_DiscardResult_TCL_DECLARED +#define Tcl_DiscardResult_TCL_DECLARED +/* 290 */ +EXTERN void Tcl_DiscardResult(Tcl_SavedResult *statePtr); +#endif +#ifndef Tcl_EvalEx_TCL_DECLARED +#define Tcl_EvalEx_TCL_DECLARED /* 291 */ -EXTERN int Tcl_EvalEx(Tcl_Interp *interp, const char *script, - size_t numBytes, int flags); +EXTERN int Tcl_EvalEx(Tcl_Interp *interp, CONST char *script, + int numBytes, int flags); +#endif +#ifndef Tcl_EvalObjv_TCL_DECLARED +#define Tcl_EvalObjv_TCL_DECLARED /* 292 */ EXTERN int Tcl_EvalObjv(Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[], int flags); + Tcl_Obj *CONST objv[], int flags); +#endif +#ifndef Tcl_EvalObjEx_TCL_DECLARED +#define Tcl_EvalObjEx_TCL_DECLARED /* 293 */ EXTERN int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); +#endif +#ifndef Tcl_ExitThread_TCL_DECLARED +#define Tcl_ExitThread_TCL_DECLARED /* 294 */ -EXTERN TCL_NORETURN void Tcl_ExitThread(int status); +EXTERN void Tcl_ExitThread(int status); +#endif +#ifndef Tcl_ExternalToUtf_TCL_DECLARED +#define Tcl_ExternalToUtf_TCL_DECLARED /* 295 */ EXTERN int Tcl_ExternalToUtf(Tcl_Interp *interp, - Tcl_Encoding encoding, const char *src, - size_t srcLen, int flags, + Tcl_Encoding encoding, CONST char *src, + int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, - size_t dstLen, int *srcReadPtr, + int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); +#endif +#ifndef Tcl_ExternalToUtfDString_TCL_DECLARED +#define Tcl_ExternalToUtfDString_TCL_DECLARED /* 296 */ EXTERN char * Tcl_ExternalToUtfDString(Tcl_Encoding encoding, - const char *src, size_t srcLen, + CONST char *src, int srcLen, Tcl_DString *dsPtr); +#endif +#ifndef Tcl_FinalizeThread_TCL_DECLARED +#define Tcl_FinalizeThread_TCL_DECLARED /* 297 */ EXTERN void Tcl_FinalizeThread(void); +#endif +#ifndef Tcl_FinalizeNotifier_TCL_DECLARED +#define Tcl_FinalizeNotifier_TCL_DECLARED /* 298 */ -EXTERN void Tcl_FinalizeNotifier(void *clientData); +EXTERN void Tcl_FinalizeNotifier(ClientData clientData); +#endif +#ifndef Tcl_FreeEncoding_TCL_DECLARED +#define Tcl_FreeEncoding_TCL_DECLARED /* 299 */ EXTERN void Tcl_FreeEncoding(Tcl_Encoding encoding); +#endif +#ifndef Tcl_GetCurrentThread_TCL_DECLARED +#define Tcl_GetCurrentThread_TCL_DECLARED /* 300 */ EXTERN Tcl_ThreadId Tcl_GetCurrentThread(void); +#endif +#ifndef Tcl_GetEncoding_TCL_DECLARED +#define Tcl_GetEncoding_TCL_DECLARED /* 301 */ -EXTERN Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name); +EXTERN Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, CONST char *name); +#endif +#ifndef Tcl_GetEncodingName_TCL_DECLARED +#define Tcl_GetEncodingName_TCL_DECLARED /* 302 */ -EXTERN const char * Tcl_GetEncodingName(Tcl_Encoding encoding); +EXTERN CONST84_RETURN char * Tcl_GetEncodingName(Tcl_Encoding encoding); +#endif +#ifndef Tcl_GetEncodingNames_TCL_DECLARED +#define Tcl_GetEncodingNames_TCL_DECLARED /* 303 */ EXTERN void Tcl_GetEncodingNames(Tcl_Interp *interp); +#endif +#ifndef Tcl_GetIndexFromObjStruct_TCL_DECLARED +#define Tcl_GetIndexFromObjStruct_TCL_DECLARED /* 304 */ EXTERN int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, - Tcl_Obj *objPtr, const void *tablePtr, - size_t offset, const char *msg, int flags, + Tcl_Obj *objPtr, CONST VOID *tablePtr, + int offset, CONST char *msg, int flags, int *indexPtr); +#endif +#ifndef Tcl_GetThreadData_TCL_DECLARED +#define Tcl_GetThreadData_TCL_DECLARED /* 305 */ -EXTERN void * Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, - size_t size); +EXTERN VOID * Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, + int size); +#endif +#ifndef Tcl_GetVar2Ex_TCL_DECLARED +#define Tcl_GetVar2Ex_TCL_DECLARED /* 306 */ -EXTERN Tcl_Obj * Tcl_GetVar2Ex(Tcl_Interp *interp, const char *part1, - const char *part2, int flags); +EXTERN Tcl_Obj * Tcl_GetVar2Ex(Tcl_Interp *interp, CONST char *part1, + CONST char *part2, int flags); +#endif +#ifndef Tcl_InitNotifier_TCL_DECLARED +#define Tcl_InitNotifier_TCL_DECLARED /* 307 */ -EXTERN void * Tcl_InitNotifier(void); +EXTERN ClientData Tcl_InitNotifier(void); +#endif +#ifndef Tcl_MutexLock_TCL_DECLARED +#define Tcl_MutexLock_TCL_DECLARED /* 308 */ EXTERN void Tcl_MutexLock(Tcl_Mutex *mutexPtr); +#endif +#ifndef Tcl_MutexUnlock_TCL_DECLARED +#define Tcl_MutexUnlock_TCL_DECLARED /* 309 */ EXTERN void Tcl_MutexUnlock(Tcl_Mutex *mutexPtr); +#endif +#ifndef Tcl_ConditionNotify_TCL_DECLARED +#define Tcl_ConditionNotify_TCL_DECLARED /* 310 */ EXTERN void Tcl_ConditionNotify(Tcl_Condition *condPtr); +#endif +#ifndef Tcl_ConditionWait_TCL_DECLARED +#define Tcl_ConditionWait_TCL_DECLARED /* 311 */ EXTERN void Tcl_ConditionWait(Tcl_Condition *condPtr, - Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr); + Tcl_Mutex *mutexPtr, Tcl_Time *timePtr); +#endif +#ifndef Tcl_NumUtfChars_TCL_DECLARED +#define Tcl_NumUtfChars_TCL_DECLARED /* 312 */ -EXTERN size_t Tcl_NumUtfChars(const char *src, size_t length); +EXTERN int Tcl_NumUtfChars(CONST char *src, int length); +#endif +#ifndef Tcl_ReadChars_TCL_DECLARED +#define Tcl_ReadChars_TCL_DECLARED /* 313 */ -EXTERN size_t Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, - size_t charsToRead, int appendFlag); -/* Slot 314 is reserved */ -/* Slot 315 is reserved */ +EXTERN int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, + int charsToRead, int appendFlag); +#endif +#ifndef Tcl_RestoreResult_TCL_DECLARED +#define Tcl_RestoreResult_TCL_DECLARED +/* 314 */ +EXTERN void Tcl_RestoreResult(Tcl_Interp *interp, + Tcl_SavedResult *statePtr); +#endif +#ifndef Tcl_SaveResult_TCL_DECLARED +#define Tcl_SaveResult_TCL_DECLARED +/* 315 */ +EXTERN void Tcl_SaveResult(Tcl_Interp *interp, + Tcl_SavedResult *statePtr); +#endif +#ifndef Tcl_SetSystemEncoding_TCL_DECLARED +#define Tcl_SetSystemEncoding_TCL_DECLARED /* 316 */ EXTERN int Tcl_SetSystemEncoding(Tcl_Interp *interp, - const char *name); + CONST char *name); +#endif +#ifndef Tcl_SetVar2Ex_TCL_DECLARED +#define Tcl_SetVar2Ex_TCL_DECLARED /* 317 */ -EXTERN Tcl_Obj * Tcl_SetVar2Ex(Tcl_Interp *interp, const char *part1, - const char *part2, Tcl_Obj *newValuePtr, +EXTERN Tcl_Obj * Tcl_SetVar2Ex(Tcl_Interp *interp, CONST char *part1, + CONST char *part2, Tcl_Obj *newValuePtr, int flags); +#endif +#ifndef Tcl_ThreadAlert_TCL_DECLARED +#define Tcl_ThreadAlert_TCL_DECLARED /* 318 */ EXTERN void Tcl_ThreadAlert(Tcl_ThreadId threadId); +#endif +#ifndef Tcl_ThreadQueueEvent_TCL_DECLARED +#define Tcl_ThreadQueueEvent_TCL_DECLARED /* 319 */ EXTERN void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event *evPtr, Tcl_QueuePosition position); +#endif +#ifndef Tcl_UniCharAtIndex_TCL_DECLARED +#define Tcl_UniCharAtIndex_TCL_DECLARED /* 320 */ -EXTERN int Tcl_UniCharAtIndex(const char *src, size_t index); +EXTERN Tcl_UniChar Tcl_UniCharAtIndex(CONST char *src, int index); +#endif +#ifndef Tcl_UniCharToLower_TCL_DECLARED +#define Tcl_UniCharToLower_TCL_DECLARED /* 321 */ -EXTERN int Tcl_UniCharToLower(int ch); +EXTERN Tcl_UniChar Tcl_UniCharToLower(int ch); +#endif +#ifndef Tcl_UniCharToTitle_TCL_DECLARED +#define Tcl_UniCharToTitle_TCL_DECLARED /* 322 */ -EXTERN int Tcl_UniCharToTitle(int ch); +EXTERN Tcl_UniChar Tcl_UniCharToTitle(int ch); +#endif +#ifndef Tcl_UniCharToUpper_TCL_DECLARED +#define Tcl_UniCharToUpper_TCL_DECLARED /* 323 */ -EXTERN int Tcl_UniCharToUpper(int ch); +EXTERN Tcl_UniChar Tcl_UniCharToUpper(int ch); +#endif +#ifndef Tcl_UniCharToUtf_TCL_DECLARED +#define Tcl_UniCharToUtf_TCL_DECLARED /* 324 */ EXTERN int Tcl_UniCharToUtf(int ch, char *buf); +#endif +#ifndef Tcl_UtfAtIndex_TCL_DECLARED +#define Tcl_UtfAtIndex_TCL_DECLARED /* 325 */ -EXTERN const char * Tcl_UtfAtIndex(const char *src, size_t index); +EXTERN CONST84_RETURN char * Tcl_UtfAtIndex(CONST char *src, int index); +#endif +#ifndef Tcl_UtfCharComplete_TCL_DECLARED +#define Tcl_UtfCharComplete_TCL_DECLARED /* 326 */ -EXTERN int Tcl_UtfCharComplete(const char *src, size_t length); +EXTERN int Tcl_UtfCharComplete(CONST char *src, int length); +#endif +#ifndef Tcl_UtfBackslash_TCL_DECLARED +#define Tcl_UtfBackslash_TCL_DECLARED /* 327 */ -EXTERN size_t Tcl_UtfBackslash(const char *src, int *readPtr, +EXTERN int Tcl_UtfBackslash(CONST char *src, int *readPtr, char *dst); +#endif +#ifndef Tcl_UtfFindFirst_TCL_DECLARED +#define Tcl_UtfFindFirst_TCL_DECLARED /* 328 */ -EXTERN const char * Tcl_UtfFindFirst(const char *src, int ch); +EXTERN CONST84_RETURN char * Tcl_UtfFindFirst(CONST char *src, int ch); +#endif +#ifndef Tcl_UtfFindLast_TCL_DECLARED +#define Tcl_UtfFindLast_TCL_DECLARED /* 329 */ -EXTERN const char * Tcl_UtfFindLast(const char *src, int ch); +EXTERN CONST84_RETURN char * Tcl_UtfFindLast(CONST char *src, int ch); +#endif +#ifndef Tcl_UtfNext_TCL_DECLARED +#define Tcl_UtfNext_TCL_DECLARED /* 330 */ -EXTERN const char * Tcl_UtfNext(const char *src); +EXTERN CONST84_RETURN char * Tcl_UtfNext(CONST char *src); +#endif +#ifndef Tcl_UtfPrev_TCL_DECLARED +#define Tcl_UtfPrev_TCL_DECLARED /* 331 */ -EXTERN const char * Tcl_UtfPrev(const char *src, const char *start); +EXTERN CONST84_RETURN char * Tcl_UtfPrev(CONST char *src, CONST char *start); +#endif +#ifndef Tcl_UtfToExternal_TCL_DECLARED +#define Tcl_UtfToExternal_TCL_DECLARED /* 332 */ EXTERN int Tcl_UtfToExternal(Tcl_Interp *interp, - Tcl_Encoding encoding, const char *src, - size_t srcLen, int flags, + Tcl_Encoding encoding, CONST char *src, + int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, - size_t dstLen, int *srcReadPtr, + int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); +#endif +#ifndef Tcl_UtfToExternalDString_TCL_DECLARED +#define Tcl_UtfToExternalDString_TCL_DECLARED /* 333 */ EXTERN char * Tcl_UtfToExternalDString(Tcl_Encoding encoding, - const char *src, size_t srcLen, + CONST char *src, int srcLen, Tcl_DString *dsPtr); +#endif +#ifndef Tcl_UtfToLower_TCL_DECLARED +#define Tcl_UtfToLower_TCL_DECLARED /* 334 */ EXTERN int Tcl_UtfToLower(char *src); +#endif +#ifndef Tcl_UtfToTitle_TCL_DECLARED +#define Tcl_UtfToTitle_TCL_DECLARED /* 335 */ EXTERN int Tcl_UtfToTitle(char *src); +#endif +#ifndef Tcl_UtfToUniChar_TCL_DECLARED +#define Tcl_UtfToUniChar_TCL_DECLARED /* 336 */ -EXTERN int Tcl_UtfToChar16(const char *src, - unsigned short *chPtr); +EXTERN int Tcl_UtfToUniChar(CONST char *src, Tcl_UniChar *chPtr); +#endif +#ifndef Tcl_UtfToUpper_TCL_DECLARED +#define Tcl_UtfToUpper_TCL_DECLARED /* 337 */ EXTERN int Tcl_UtfToUpper(char *src); +#endif +#ifndef Tcl_WriteChars_TCL_DECLARED +#define Tcl_WriteChars_TCL_DECLARED /* 338 */ -EXTERN size_t Tcl_WriteChars(Tcl_Channel chan, const char *src, - size_t srcLen); +EXTERN int Tcl_WriteChars(Tcl_Channel chan, CONST char *src, + int srcLen); +#endif +#ifndef Tcl_WriteObj_TCL_DECLARED +#define Tcl_WriteObj_TCL_DECLARED /* 339 */ -EXTERN size_t Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr); +EXTERN int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr); +#endif +#ifndef Tcl_GetString_TCL_DECLARED +#define Tcl_GetString_TCL_DECLARED /* 340 */ EXTERN char * Tcl_GetString(Tcl_Obj *objPtr); -/* Slot 341 is reserved */ -/* Slot 342 is reserved */ +#endif +#ifndef Tcl_GetDefaultEncodingDir_TCL_DECLARED +#define Tcl_GetDefaultEncodingDir_TCL_DECLARED +/* 341 */ +EXTERN CONST84_RETURN char * Tcl_GetDefaultEncodingDir(void); +#endif +#ifndef Tcl_SetDefaultEncodingDir_TCL_DECLARED +#define Tcl_SetDefaultEncodingDir_TCL_DECLARED +/* 342 */ +EXTERN void Tcl_SetDefaultEncodingDir(CONST char *path); +#endif +#ifndef Tcl_AlertNotifier_TCL_DECLARED +#define Tcl_AlertNotifier_TCL_DECLARED /* 343 */ -EXTERN void Tcl_AlertNotifier(void *clientData); +EXTERN void Tcl_AlertNotifier(ClientData clientData); +#endif +#ifndef Tcl_ServiceModeHook_TCL_DECLARED +#define Tcl_ServiceModeHook_TCL_DECLARED /* 344 */ EXTERN void Tcl_ServiceModeHook(int mode); +#endif +#ifndef Tcl_UniCharIsAlnum_TCL_DECLARED +#define Tcl_UniCharIsAlnum_TCL_DECLARED /* 345 */ EXTERN int Tcl_UniCharIsAlnum(int ch); +#endif +#ifndef Tcl_UniCharIsAlpha_TCL_DECLARED +#define Tcl_UniCharIsAlpha_TCL_DECLARED /* 346 */ EXTERN int Tcl_UniCharIsAlpha(int ch); +#endif +#ifndef Tcl_UniCharIsDigit_TCL_DECLARED +#define Tcl_UniCharIsDigit_TCL_DECLARED /* 347 */ EXTERN int Tcl_UniCharIsDigit(int ch); +#endif +#ifndef Tcl_UniCharIsLower_TCL_DECLARED +#define Tcl_UniCharIsLower_TCL_DECLARED /* 348 */ EXTERN int Tcl_UniCharIsLower(int ch); +#endif +#ifndef Tcl_UniCharIsSpace_TCL_DECLARED +#define Tcl_UniCharIsSpace_TCL_DECLARED /* 349 */ EXTERN int Tcl_UniCharIsSpace(int ch); +#endif +#ifndef Tcl_UniCharIsUpper_TCL_DECLARED +#define Tcl_UniCharIsUpper_TCL_DECLARED /* 350 */ EXTERN int Tcl_UniCharIsUpper(int ch); +#endif +#ifndef Tcl_UniCharIsWordChar_TCL_DECLARED +#define Tcl_UniCharIsWordChar_TCL_DECLARED /* 351 */ EXTERN int Tcl_UniCharIsWordChar(int ch); -/* Slot 352 is reserved */ -/* Slot 353 is reserved */ +#endif +#ifndef Tcl_UniCharLen_TCL_DECLARED +#define Tcl_UniCharLen_TCL_DECLARED +/* 352 */ +EXTERN int Tcl_UniCharLen(CONST Tcl_UniChar *uniStr); +#endif +#ifndef Tcl_UniCharNcmp_TCL_DECLARED +#define Tcl_UniCharNcmp_TCL_DECLARED +/* 353 */ +EXTERN int Tcl_UniCharNcmp(CONST Tcl_UniChar *ucs, + CONST Tcl_UniChar *uct, + unsigned long numChars); +#endif +#ifndef Tcl_UniCharToUtfDString_TCL_DECLARED +#define Tcl_UniCharToUtfDString_TCL_DECLARED /* 354 */ -EXTERN char * Tcl_Char16ToUtfDString(const unsigned short *uniStr, - size_t uniLength, Tcl_DString *dsPtr); +EXTERN char * Tcl_UniCharToUtfDString(CONST Tcl_UniChar *uniStr, + int uniLength, Tcl_DString *dsPtr); +#endif +#ifndef Tcl_UtfToUniCharDString_TCL_DECLARED +#define Tcl_UtfToUniCharDString_TCL_DECLARED /* 355 */ -EXTERN unsigned short * Tcl_UtfToChar16DString(const char *src, - size_t length, Tcl_DString *dsPtr); +EXTERN Tcl_UniChar * Tcl_UtfToUniCharDString(CONST char *src, int length, + Tcl_DString *dsPtr); +#endif +#ifndef Tcl_GetRegExpFromObj_TCL_DECLARED +#define Tcl_GetRegExpFromObj_TCL_DECLARED /* 356 */ EXTERN Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags); -/* Slot 357 is reserved */ +#endif +#ifndef Tcl_EvalTokens_TCL_DECLARED +#define Tcl_EvalTokens_TCL_DECLARED +/* 357 */ +EXTERN Tcl_Obj * Tcl_EvalTokens(Tcl_Interp *interp, + Tcl_Token *tokenPtr, int count); +#endif +#ifndef Tcl_FreeParse_TCL_DECLARED +#define Tcl_FreeParse_TCL_DECLARED /* 358 */ EXTERN void Tcl_FreeParse(Tcl_Parse *parsePtr); +#endif +#ifndef Tcl_LogCommandInfo_TCL_DECLARED +#define Tcl_LogCommandInfo_TCL_DECLARED /* 359 */ EXTERN void Tcl_LogCommandInfo(Tcl_Interp *interp, - const char *script, const char *command, - size_t length); + CONST char *script, CONST char *command, + int length); +#endif +#ifndef Tcl_ParseBraces_TCL_DECLARED +#define Tcl_ParseBraces_TCL_DECLARED /* 360 */ EXTERN int Tcl_ParseBraces(Tcl_Interp *interp, - const char *start, size_t numBytes, + CONST char *start, int numBytes, Tcl_Parse *parsePtr, int append, - const char **termPtr); + CONST84 char **termPtr); +#endif +#ifndef Tcl_ParseCommand_TCL_DECLARED +#define Tcl_ParseCommand_TCL_DECLARED /* 361 */ EXTERN int Tcl_ParseCommand(Tcl_Interp *interp, - const char *start, size_t numBytes, - int nested, Tcl_Parse *parsePtr); + CONST char *start, int numBytes, int nested, + Tcl_Parse *parsePtr); +#endif +#ifndef Tcl_ParseExpr_TCL_DECLARED +#define Tcl_ParseExpr_TCL_DECLARED /* 362 */ -EXTERN int Tcl_ParseExpr(Tcl_Interp *interp, const char *start, - size_t numBytes, Tcl_Parse *parsePtr); +EXTERN int Tcl_ParseExpr(Tcl_Interp *interp, CONST char *start, + int numBytes, Tcl_Parse *parsePtr); +#endif +#ifndef Tcl_ParseQuotedString_TCL_DECLARED +#define Tcl_ParseQuotedString_TCL_DECLARED /* 363 */ EXTERN int Tcl_ParseQuotedString(Tcl_Interp *interp, - const char *start, size_t numBytes, + CONST char *start, int numBytes, Tcl_Parse *parsePtr, int append, - const char **termPtr); + CONST84 char **termPtr); +#endif +#ifndef Tcl_ParseVarName_TCL_DECLARED +#define Tcl_ParseVarName_TCL_DECLARED /* 364 */ EXTERN int Tcl_ParseVarName(Tcl_Interp *interp, - const char *start, size_t numBytes, + CONST char *start, int numBytes, Tcl_Parse *parsePtr, int append); +#endif +#ifndef Tcl_GetCwd_TCL_DECLARED +#define Tcl_GetCwd_TCL_DECLARED /* 365 */ EXTERN char * Tcl_GetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr); +#endif +#ifndef Tcl_Chdir_TCL_DECLARED +#define Tcl_Chdir_TCL_DECLARED /* 366 */ -EXTERN int Tcl_Chdir(const char *dirName); +EXTERN int Tcl_Chdir(CONST char *dirName); +#endif +#ifndef Tcl_Access_TCL_DECLARED +#define Tcl_Access_TCL_DECLARED /* 367 */ -EXTERN int Tcl_Access(const char *path, int mode); +EXTERN int Tcl_Access(CONST char *path, int mode); +#endif +#ifndef Tcl_Stat_TCL_DECLARED +#define Tcl_Stat_TCL_DECLARED /* 368 */ -EXTERN int Tcl_Stat(const char *path, struct stat *bufPtr); +EXTERN int Tcl_Stat(CONST char *path, struct stat *bufPtr); +#endif +#ifndef Tcl_UtfNcmp_TCL_DECLARED +#define Tcl_UtfNcmp_TCL_DECLARED /* 369 */ -EXTERN int Tcl_UtfNcmp(const char *s1, const char *s2, size_t n); +EXTERN int Tcl_UtfNcmp(CONST char *s1, CONST char *s2, + unsigned long n); +#endif +#ifndef Tcl_UtfNcasecmp_TCL_DECLARED +#define Tcl_UtfNcasecmp_TCL_DECLARED /* 370 */ -EXTERN int Tcl_UtfNcasecmp(const char *s1, const char *s2, - size_t n); +EXTERN int Tcl_UtfNcasecmp(CONST char *s1, CONST char *s2, + unsigned long n); +#endif +#ifndef Tcl_StringCaseMatch_TCL_DECLARED +#define Tcl_StringCaseMatch_TCL_DECLARED /* 371 */ -EXTERN int Tcl_StringCaseMatch(const char *str, - const char *pattern, int nocase); +EXTERN int Tcl_StringCaseMatch(CONST char *str, + CONST char *pattern, int nocase); +#endif +#ifndef Tcl_UniCharIsControl_TCL_DECLARED +#define Tcl_UniCharIsControl_TCL_DECLARED /* 372 */ EXTERN int Tcl_UniCharIsControl(int ch); +#endif +#ifndef Tcl_UniCharIsGraph_TCL_DECLARED +#define Tcl_UniCharIsGraph_TCL_DECLARED /* 373 */ EXTERN int Tcl_UniCharIsGraph(int ch); +#endif +#ifndef Tcl_UniCharIsPrint_TCL_DECLARED +#define Tcl_UniCharIsPrint_TCL_DECLARED /* 374 */ EXTERN int Tcl_UniCharIsPrint(int ch); +#endif +#ifndef Tcl_UniCharIsPunct_TCL_DECLARED +#define Tcl_UniCharIsPunct_TCL_DECLARED /* 375 */ EXTERN int Tcl_UniCharIsPunct(int ch); +#endif +#ifndef Tcl_RegExpExecObj_TCL_DECLARED +#define Tcl_RegExpExecObj_TCL_DECLARED /* 376 */ EXTERN int Tcl_RegExpExecObj(Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, - size_t offset, size_t nmatches, int flags); + int offset, int nmatches, int flags); +#endif +#ifndef Tcl_RegExpGetInfo_TCL_DECLARED +#define Tcl_RegExpGetInfo_TCL_DECLARED /* 377 */ EXTERN void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); +#endif +#ifndef Tcl_NewUnicodeObj_TCL_DECLARED +#define Tcl_NewUnicodeObj_TCL_DECLARED /* 378 */ -EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, - size_t numChars); +EXTERN Tcl_Obj * Tcl_NewUnicodeObj(CONST Tcl_UniChar *unicode, + int numChars); +#endif +#ifndef Tcl_SetUnicodeObj_TCL_DECLARED +#define Tcl_SetUnicodeObj_TCL_DECLARED /* 379 */ EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, size_t numChars); + CONST Tcl_UniChar *unicode, int numChars); +#endif +#ifndef Tcl_GetCharLength_TCL_DECLARED +#define Tcl_GetCharLength_TCL_DECLARED /* 380 */ -EXTERN size_t Tcl_GetCharLength(Tcl_Obj *objPtr); +EXTERN int Tcl_GetCharLength(Tcl_Obj *objPtr); +#endif +#ifndef Tcl_GetUniChar_TCL_DECLARED +#define Tcl_GetUniChar_TCL_DECLARED /* 381 */ -EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, size_t index); -/* Slot 382 is reserved */ +EXTERN Tcl_UniChar Tcl_GetUniChar(Tcl_Obj *objPtr, int index); +#endif +#ifndef Tcl_GetUnicode_TCL_DECLARED +#define Tcl_GetUnicode_TCL_DECLARED +/* 382 */ +EXTERN Tcl_UniChar * Tcl_GetUnicode(Tcl_Obj *objPtr); +#endif +#ifndef Tcl_GetRange_TCL_DECLARED +#define Tcl_GetRange_TCL_DECLARED /* 383 */ -EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, size_t first, - size_t last); -/* Slot 384 is reserved */ +EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, int first, int last); +#endif +#ifndef Tcl_AppendUnicodeToObj_TCL_DECLARED +#define Tcl_AppendUnicodeToObj_TCL_DECLARED +/* 384 */ +EXTERN void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, + CONST Tcl_UniChar *unicode, int length); +#endif +#ifndef Tcl_RegExpMatchObj_TCL_DECLARED +#define Tcl_RegExpMatchObj_TCL_DECLARED /* 385 */ EXTERN int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); +#endif +#ifndef Tcl_SetNotifier_TCL_DECLARED +#define Tcl_SetNotifier_TCL_DECLARED /* 386 */ EXTERN void Tcl_SetNotifier(Tcl_NotifierProcs *notifierProcPtr); +#endif +#ifndef Tcl_GetAllocMutex_TCL_DECLARED +#define Tcl_GetAllocMutex_TCL_DECLARED /* 387 */ EXTERN Tcl_Mutex * Tcl_GetAllocMutex(void); +#endif +#ifndef Tcl_GetChannelNames_TCL_DECLARED +#define Tcl_GetChannelNames_TCL_DECLARED /* 388 */ EXTERN int Tcl_GetChannelNames(Tcl_Interp *interp); +#endif +#ifndef Tcl_GetChannelNamesEx_TCL_DECLARED +#define Tcl_GetChannelNamesEx_TCL_DECLARED /* 389 */ EXTERN int Tcl_GetChannelNamesEx(Tcl_Interp *interp, - const char *pattern); + CONST char *pattern); +#endif +#ifndef Tcl_ProcObjCmd_TCL_DECLARED +#define Tcl_ProcObjCmd_TCL_DECLARED /* 390 */ -EXTERN int Tcl_ProcObjCmd(void *clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); +EXTERN int Tcl_ProcObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +#endif +#ifndef Tcl_ConditionFinalize_TCL_DECLARED +#define Tcl_ConditionFinalize_TCL_DECLARED /* 391 */ EXTERN void Tcl_ConditionFinalize(Tcl_Condition *condPtr); +#endif +#ifndef Tcl_MutexFinalize_TCL_DECLARED +#define Tcl_MutexFinalize_TCL_DECLARED /* 392 */ EXTERN void Tcl_MutexFinalize(Tcl_Mutex *mutex); +#endif +#ifndef Tcl_CreateThread_TCL_DECLARED +#define Tcl_CreateThread_TCL_DECLARED /* 393 */ EXTERN int Tcl_CreateThread(Tcl_ThreadId *idPtr, - Tcl_ThreadCreateProc *proc, void *clientData, - size_t stackSize, int flags); + Tcl_ThreadCreateProc proc, + ClientData clientData, int stackSize, + int flags); +#endif +#ifndef Tcl_ReadRaw_TCL_DECLARED +#define Tcl_ReadRaw_TCL_DECLARED /* 394 */ -EXTERN size_t Tcl_ReadRaw(Tcl_Channel chan, char *dst, - size_t bytesToRead); +EXTERN int Tcl_ReadRaw(Tcl_Channel chan, char *dst, + int bytesToRead); +#endif +#ifndef Tcl_WriteRaw_TCL_DECLARED +#define Tcl_WriteRaw_TCL_DECLARED /* 395 */ -EXTERN size_t Tcl_WriteRaw(Tcl_Channel chan, const char *src, - size_t srcLen); +EXTERN int Tcl_WriteRaw(Tcl_Channel chan, CONST char *src, + int srcLen); +#endif +#ifndef Tcl_GetTopChannel_TCL_DECLARED +#define Tcl_GetTopChannel_TCL_DECLARED /* 396 */ EXTERN Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan); +#endif +#ifndef Tcl_ChannelBuffered_TCL_DECLARED +#define Tcl_ChannelBuffered_TCL_DECLARED /* 397 */ EXTERN int Tcl_ChannelBuffered(Tcl_Channel chan); +#endif +#ifndef Tcl_ChannelName_TCL_DECLARED +#define Tcl_ChannelName_TCL_DECLARED /* 398 */ -EXTERN const char * Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr); +EXTERN CONST84_RETURN char * Tcl_ChannelName( + CONST Tcl_ChannelType *chanTypePtr); +#endif +#ifndef Tcl_ChannelVersion_TCL_DECLARED +#define Tcl_ChannelVersion_TCL_DECLARED /* 399 */ EXTERN Tcl_ChannelTypeVersion Tcl_ChannelVersion( - const Tcl_ChannelType *chanTypePtr); + CONST Tcl_ChannelType *chanTypePtr); +#endif +#ifndef Tcl_ChannelBlockModeProc_TCL_DECLARED +#define Tcl_ChannelBlockModeProc_TCL_DECLARED /* 400 */ EXTERN Tcl_DriverBlockModeProc * Tcl_ChannelBlockModeProc( - const Tcl_ChannelType *chanTypePtr); -/* Slot 401 is reserved */ + CONST Tcl_ChannelType *chanTypePtr); +#endif +#ifndef Tcl_ChannelCloseProc_TCL_DECLARED +#define Tcl_ChannelCloseProc_TCL_DECLARED +/* 401 */ +EXTERN Tcl_DriverCloseProc * Tcl_ChannelCloseProc( + CONST Tcl_ChannelType *chanTypePtr); +#endif +#ifndef Tcl_ChannelClose2Proc_TCL_DECLARED +#define Tcl_ChannelClose2Proc_TCL_DECLARED /* 402 */ EXTERN Tcl_DriverClose2Proc * Tcl_ChannelClose2Proc( - const Tcl_ChannelType *chanTypePtr); + CONST Tcl_ChannelType *chanTypePtr); +#endif +#ifndef Tcl_ChannelInputProc_TCL_DECLARED +#define Tcl_ChannelInputProc_TCL_DECLARED /* 403 */ EXTERN Tcl_DriverInputProc * Tcl_ChannelInputProc( - const Tcl_ChannelType *chanTypePtr); + CONST Tcl_ChannelType *chanTypePtr); +#endif +#ifndef Tcl_ChannelOutputProc_TCL_DECLARED +#define Tcl_ChannelOutputProc_TCL_DECLARED /* 404 */ EXTERN Tcl_DriverOutputProc * Tcl_ChannelOutputProc( - const Tcl_ChannelType *chanTypePtr); -/* Slot 405 is reserved */ + CONST Tcl_ChannelType *chanTypePtr); +#endif +#ifndef Tcl_ChannelSeekProc_TCL_DECLARED +#define Tcl_ChannelSeekProc_TCL_DECLARED +/* 405 */ +EXTERN Tcl_DriverSeekProc * Tcl_ChannelSeekProc( + CONST Tcl_ChannelType *chanTypePtr); +#endif +#ifndef Tcl_ChannelSetOptionProc_TCL_DECLARED +#define Tcl_ChannelSetOptionProc_TCL_DECLARED /* 406 */ EXTERN Tcl_DriverSetOptionProc * Tcl_ChannelSetOptionProc( - const Tcl_ChannelType *chanTypePtr); + CONST Tcl_ChannelType *chanTypePtr); +#endif +#ifndef Tcl_ChannelGetOptionProc_TCL_DECLARED +#define Tcl_ChannelGetOptionProc_TCL_DECLARED /* 407 */ EXTERN Tcl_DriverGetOptionProc * Tcl_ChannelGetOptionProc( - const Tcl_ChannelType *chanTypePtr); + CONST Tcl_ChannelType *chanTypePtr); +#endif +#ifndef Tcl_ChannelWatchProc_TCL_DECLARED +#define Tcl_ChannelWatchProc_TCL_DECLARED /* 408 */ EXTERN Tcl_DriverWatchProc * Tcl_ChannelWatchProc( - const Tcl_ChannelType *chanTypePtr); + CONST Tcl_ChannelType *chanTypePtr); +#endif +#ifndef Tcl_ChannelGetHandleProc_TCL_DECLARED +#define Tcl_ChannelGetHandleProc_TCL_DECLARED /* 409 */ EXTERN Tcl_DriverGetHandleProc * Tcl_ChannelGetHandleProc( - const Tcl_ChannelType *chanTypePtr); + CONST Tcl_ChannelType *chanTypePtr); +#endif +#ifndef Tcl_ChannelFlushProc_TCL_DECLARED +#define Tcl_ChannelFlushProc_TCL_DECLARED /* 410 */ EXTERN Tcl_DriverFlushProc * Tcl_ChannelFlushProc( - const Tcl_ChannelType *chanTypePtr); + CONST Tcl_ChannelType *chanTypePtr); +#endif +#ifndef Tcl_ChannelHandlerProc_TCL_DECLARED +#define Tcl_ChannelHandlerProc_TCL_DECLARED /* 411 */ EXTERN Tcl_DriverHandlerProc * Tcl_ChannelHandlerProc( - const Tcl_ChannelType *chanTypePtr); + CONST Tcl_ChannelType *chanTypePtr); +#endif +#ifndef Tcl_JoinThread_TCL_DECLARED +#define Tcl_JoinThread_TCL_DECLARED /* 412 */ EXTERN int Tcl_JoinThread(Tcl_ThreadId threadId, int *result); +#endif +#ifndef Tcl_IsChannelShared_TCL_DECLARED +#define Tcl_IsChannelShared_TCL_DECLARED /* 413 */ EXTERN int Tcl_IsChannelShared(Tcl_Channel channel); +#endif +#ifndef Tcl_IsChannelRegistered_TCL_DECLARED +#define Tcl_IsChannelRegistered_TCL_DECLARED /* 414 */ EXTERN int Tcl_IsChannelRegistered(Tcl_Interp *interp, Tcl_Channel channel); +#endif +#ifndef Tcl_CutChannel_TCL_DECLARED +#define Tcl_CutChannel_TCL_DECLARED /* 415 */ EXTERN void Tcl_CutChannel(Tcl_Channel channel); +#endif +#ifndef Tcl_SpliceChannel_TCL_DECLARED +#define Tcl_SpliceChannel_TCL_DECLARED /* 416 */ EXTERN void Tcl_SpliceChannel(Tcl_Channel channel); +#endif +#ifndef Tcl_ClearChannelHandlers_TCL_DECLARED +#define Tcl_ClearChannelHandlers_TCL_DECLARED /* 417 */ EXTERN void Tcl_ClearChannelHandlers(Tcl_Channel channel); +#endif +#ifndef Tcl_IsChannelExisting_TCL_DECLARED +#define Tcl_IsChannelExisting_TCL_DECLARED /* 418 */ -EXTERN int Tcl_IsChannelExisting(const char *channelName); -/* Slot 419 is reserved */ -/* Slot 420 is reserved */ -/* Slot 421 is reserved */ -/* Slot 422 is reserved */ +EXTERN int Tcl_IsChannelExisting(CONST char *channelName); +#endif +#ifndef Tcl_UniCharNcasecmp_TCL_DECLARED +#define Tcl_UniCharNcasecmp_TCL_DECLARED +/* 419 */ +EXTERN int Tcl_UniCharNcasecmp(CONST Tcl_UniChar *ucs, + CONST Tcl_UniChar *uct, + unsigned long numChars); +#endif +#ifndef Tcl_UniCharCaseMatch_TCL_DECLARED +#define Tcl_UniCharCaseMatch_TCL_DECLARED +/* 420 */ +EXTERN int Tcl_UniCharCaseMatch(CONST Tcl_UniChar *uniStr, + CONST Tcl_UniChar *uniPattern, int nocase); +#endif +#ifndef Tcl_FindHashEntry_TCL_DECLARED +#define Tcl_FindHashEntry_TCL_DECLARED +/* 421 */ +EXTERN Tcl_HashEntry * Tcl_FindHashEntry(Tcl_HashTable *tablePtr, + CONST char *key); +#endif +#ifndef Tcl_CreateHashEntry_TCL_DECLARED +#define Tcl_CreateHashEntry_TCL_DECLARED +/* 422 */ +EXTERN Tcl_HashEntry * Tcl_CreateHashEntry(Tcl_HashTable *tablePtr, + CONST char *key, int *newPtr); +#endif +#ifndef Tcl_InitCustomHashTable_TCL_DECLARED +#define Tcl_InitCustomHashTable_TCL_DECLARED /* 423 */ EXTERN void Tcl_InitCustomHashTable(Tcl_HashTable *tablePtr, - int keyType, const Tcl_HashKeyType *typePtr); + int keyType, Tcl_HashKeyType *typePtr); +#endif +#ifndef Tcl_InitObjHashTable_TCL_DECLARED +#define Tcl_InitObjHashTable_TCL_DECLARED /* 424 */ EXTERN void Tcl_InitObjHashTable(Tcl_HashTable *tablePtr); +#endif +#ifndef Tcl_CommandTraceInfo_TCL_DECLARED +#define Tcl_CommandTraceInfo_TCL_DECLARED /* 425 */ -EXTERN void * Tcl_CommandTraceInfo(Tcl_Interp *interp, - const char *varName, int flags, +EXTERN ClientData Tcl_CommandTraceInfo(Tcl_Interp *interp, + CONST char *varName, int flags, Tcl_CommandTraceProc *procPtr, - void *prevClientData); + ClientData prevClientData); +#endif +#ifndef Tcl_TraceCommand_TCL_DECLARED +#define Tcl_TraceCommand_TCL_DECLARED /* 426 */ EXTERN int Tcl_TraceCommand(Tcl_Interp *interp, - const char *varName, int flags, - Tcl_CommandTraceProc *proc, void *clientData); + CONST char *varName, int flags, + Tcl_CommandTraceProc *proc, + ClientData clientData); +#endif +#ifndef Tcl_UntraceCommand_TCL_DECLARED +#define Tcl_UntraceCommand_TCL_DECLARED /* 427 */ EXTERN void Tcl_UntraceCommand(Tcl_Interp *interp, - const char *varName, int flags, - Tcl_CommandTraceProc *proc, void *clientData); + CONST char *varName, int flags, + Tcl_CommandTraceProc *proc, + ClientData clientData); +#endif +#ifndef Tcl_AttemptAlloc_TCL_DECLARED +#define Tcl_AttemptAlloc_TCL_DECLARED /* 428 */ -EXTERN void * Tcl_AttemptAlloc(size_t size); +EXTERN char * Tcl_AttemptAlloc(unsigned int size); +#endif +#ifndef Tcl_AttemptDbCkalloc_TCL_DECLARED +#define Tcl_AttemptDbCkalloc_TCL_DECLARED /* 429 */ -EXTERN void * Tcl_AttemptDbCkalloc(size_t size, const char *file, - int line); +EXTERN char * Tcl_AttemptDbCkalloc(unsigned int size, + CONST char *file, int line); +#endif +#ifndef Tcl_AttemptRealloc_TCL_DECLARED +#define Tcl_AttemptRealloc_TCL_DECLARED /* 430 */ -EXTERN void * Tcl_AttemptRealloc(void *ptr, size_t size); +EXTERN char * Tcl_AttemptRealloc(char *ptr, unsigned int size); +#endif +#ifndef Tcl_AttemptDbCkrealloc_TCL_DECLARED +#define Tcl_AttemptDbCkrealloc_TCL_DECLARED /* 431 */ -EXTERN void * Tcl_AttemptDbCkrealloc(void *ptr, size_t size, - const char *file, int line); +EXTERN char * Tcl_AttemptDbCkrealloc(char *ptr, unsigned int size, + CONST char *file, int line); +#endif +#ifndef Tcl_AttemptSetObjLength_TCL_DECLARED +#define Tcl_AttemptSetObjLength_TCL_DECLARED /* 432 */ -EXTERN int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, - size_t length); +EXTERN int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, int length); +#endif +#ifndef Tcl_GetChannelThread_TCL_DECLARED +#define Tcl_GetChannelThread_TCL_DECLARED /* 433 */ EXTERN Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel); +#endif +#ifndef Tcl_GetUnicodeFromObj_TCL_DECLARED +#define Tcl_GetUnicodeFromObj_TCL_DECLARED /* 434 */ EXTERN Tcl_UniChar * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr); -/* Slot 435 is reserved */ -/* Slot 436 is reserved */ +#endif +#ifndef Tcl_GetMathFuncInfo_TCL_DECLARED +#define Tcl_GetMathFuncInfo_TCL_DECLARED +/* 435 */ +EXTERN int Tcl_GetMathFuncInfo(Tcl_Interp *interp, + CONST char *name, int *numArgsPtr, + Tcl_ValueType **argTypesPtr, + Tcl_MathProc **procPtr, + ClientData *clientDataPtr); +#endif +#ifndef Tcl_ListMathFuncs_TCL_DECLARED +#define Tcl_ListMathFuncs_TCL_DECLARED +/* 436 */ +EXTERN Tcl_Obj * Tcl_ListMathFuncs(Tcl_Interp *interp, + CONST char *pattern); +#endif +#ifndef Tcl_SubstObj_TCL_DECLARED +#define Tcl_SubstObj_TCL_DECLARED /* 437 */ EXTERN Tcl_Obj * Tcl_SubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); +#endif +#ifndef Tcl_DetachChannel_TCL_DECLARED +#define Tcl_DetachChannel_TCL_DECLARED /* 438 */ EXTERN int Tcl_DetachChannel(Tcl_Interp *interp, Tcl_Channel channel); +#endif +#ifndef Tcl_IsStandardChannel_TCL_DECLARED +#define Tcl_IsStandardChannel_TCL_DECLARED /* 439 */ EXTERN int Tcl_IsStandardChannel(Tcl_Channel channel); +#endif +#ifndef Tcl_FSCopyFile_TCL_DECLARED +#define Tcl_FSCopyFile_TCL_DECLARED /* 440 */ EXTERN int Tcl_FSCopyFile(Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr); +#endif +#ifndef Tcl_FSCopyDirectory_TCL_DECLARED +#define Tcl_FSCopyDirectory_TCL_DECLARED /* 441 */ EXTERN int Tcl_FSCopyDirectory(Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr); +#endif +#ifndef Tcl_FSCreateDirectory_TCL_DECLARED +#define Tcl_FSCreateDirectory_TCL_DECLARED /* 442 */ EXTERN int Tcl_FSCreateDirectory(Tcl_Obj *pathPtr); +#endif +#ifndef Tcl_FSDeleteFile_TCL_DECLARED +#define Tcl_FSDeleteFile_TCL_DECLARED /* 443 */ EXTERN int Tcl_FSDeleteFile(Tcl_Obj *pathPtr); +#endif +#ifndef Tcl_FSLoadFile_TCL_DECLARED +#define Tcl_FSLoadFile_TCL_DECLARED /* 444 */ EXTERN int Tcl_FSLoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, - const char *sym1, const char *sym2, + CONST char *sym1, CONST char *sym2, Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **proc2Ptr, Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr); +#endif +#ifndef Tcl_FSMatchInDirectory_TCL_DECLARED +#define Tcl_FSMatchInDirectory_TCL_DECLARED /* 445 */ EXTERN int Tcl_FSMatchInDirectory(Tcl_Interp *interp, Tcl_Obj *result, Tcl_Obj *pathPtr, - const char *pattern, Tcl_GlobTypeData *types); + CONST char *pattern, Tcl_GlobTypeData *types); +#endif +#ifndef Tcl_FSLink_TCL_DECLARED +#define Tcl_FSLink_TCL_DECLARED /* 446 */ EXTERN Tcl_Obj * Tcl_FSLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkAction); +#endif +#ifndef Tcl_FSRemoveDirectory_TCL_DECLARED +#define Tcl_FSRemoveDirectory_TCL_DECLARED /* 447 */ EXTERN int Tcl_FSRemoveDirectory(Tcl_Obj *pathPtr, int recursive, Tcl_Obj **errorPtr); +#endif +#ifndef Tcl_FSRenameFile_TCL_DECLARED +#define Tcl_FSRenameFile_TCL_DECLARED /* 448 */ EXTERN int Tcl_FSRenameFile(Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr); +#endif +#ifndef Tcl_FSLstat_TCL_DECLARED +#define Tcl_FSLstat_TCL_DECLARED /* 449 */ EXTERN int Tcl_FSLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); +#endif +#ifndef Tcl_FSUtime_TCL_DECLARED +#define Tcl_FSUtime_TCL_DECLARED /* 450 */ EXTERN int Tcl_FSUtime(Tcl_Obj *pathPtr, struct utimbuf *tval); +#endif +#ifndef Tcl_FSFileAttrsGet_TCL_DECLARED +#define Tcl_FSFileAttrsGet_TCL_DECLARED /* 451 */ EXTERN int Tcl_FSFileAttrsGet(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); +#endif +#ifndef Tcl_FSFileAttrsSet_TCL_DECLARED +#define Tcl_FSFileAttrsSet_TCL_DECLARED /* 452 */ EXTERN int Tcl_FSFileAttrsSet(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr); +#endif +#ifndef Tcl_FSFileAttrStrings_TCL_DECLARED +#define Tcl_FSFileAttrStrings_TCL_DECLARED /* 453 */ -EXTERN const char *const * Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr, +EXTERN CONST char ** Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); +#endif +#ifndef Tcl_FSStat_TCL_DECLARED +#define Tcl_FSStat_TCL_DECLARED /* 454 */ EXTERN int Tcl_FSStat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); +#endif +#ifndef Tcl_FSAccess_TCL_DECLARED +#define Tcl_FSAccess_TCL_DECLARED /* 455 */ EXTERN int Tcl_FSAccess(Tcl_Obj *pathPtr, int mode); +#endif +#ifndef Tcl_FSOpenFileChannel_TCL_DECLARED +#define Tcl_FSOpenFileChannel_TCL_DECLARED /* 456 */ EXTERN Tcl_Channel Tcl_FSOpenFileChannel(Tcl_Interp *interp, - Tcl_Obj *pathPtr, const char *modeString, + Tcl_Obj *pathPtr, CONST char *modeString, int permissions); +#endif +#ifndef Tcl_FSGetCwd_TCL_DECLARED +#define Tcl_FSGetCwd_TCL_DECLARED /* 457 */ EXTERN Tcl_Obj * Tcl_FSGetCwd(Tcl_Interp *interp); +#endif +#ifndef Tcl_FSChdir_TCL_DECLARED +#define Tcl_FSChdir_TCL_DECLARED /* 458 */ EXTERN int Tcl_FSChdir(Tcl_Obj *pathPtr); +#endif +#ifndef Tcl_FSConvertToPathType_TCL_DECLARED +#define Tcl_FSConvertToPathType_TCL_DECLARED /* 459 */ EXTERN int Tcl_FSConvertToPathType(Tcl_Interp *interp, Tcl_Obj *pathPtr); +#endif +#ifndef Tcl_FSJoinPath_TCL_DECLARED +#define Tcl_FSJoinPath_TCL_DECLARED /* 460 */ EXTERN Tcl_Obj * Tcl_FSJoinPath(Tcl_Obj *listObj, int elements); +#endif +#ifndef Tcl_FSSplitPath_TCL_DECLARED +#define Tcl_FSSplitPath_TCL_DECLARED /* 461 */ EXTERN Tcl_Obj * Tcl_FSSplitPath(Tcl_Obj *pathPtr, int *lenPtr); +#endif +#ifndef Tcl_FSEqualPaths_TCL_DECLARED +#define Tcl_FSEqualPaths_TCL_DECLARED /* 462 */ EXTERN int Tcl_FSEqualPaths(Tcl_Obj *firstPtr, Tcl_Obj *secondPtr); +#endif +#ifndef Tcl_FSGetNormalizedPath_TCL_DECLARED +#define Tcl_FSGetNormalizedPath_TCL_DECLARED /* 463 */ EXTERN Tcl_Obj * Tcl_FSGetNormalizedPath(Tcl_Interp *interp, Tcl_Obj *pathPtr); +#endif +#ifndef Tcl_FSJoinToPath_TCL_DECLARED +#define Tcl_FSJoinToPath_TCL_DECLARED /* 464 */ EXTERN Tcl_Obj * Tcl_FSJoinToPath(Tcl_Obj *pathPtr, int objc, - Tcl_Obj *const objv[]); + Tcl_Obj *CONST objv[]); +#endif +#ifndef Tcl_FSGetInternalRep_TCL_DECLARED +#define Tcl_FSGetInternalRep_TCL_DECLARED /* 465 */ -EXTERN void * Tcl_FSGetInternalRep(Tcl_Obj *pathPtr, - const Tcl_Filesystem *fsPtr); +EXTERN ClientData Tcl_FSGetInternalRep(Tcl_Obj *pathPtr, + Tcl_Filesystem *fsPtr); +#endif +#ifndef Tcl_FSGetTranslatedPath_TCL_DECLARED +#define Tcl_FSGetTranslatedPath_TCL_DECLARED /* 466 */ EXTERN Tcl_Obj * Tcl_FSGetTranslatedPath(Tcl_Interp *interp, Tcl_Obj *pathPtr); +#endif +#ifndef Tcl_FSEvalFile_TCL_DECLARED +#define Tcl_FSEvalFile_TCL_DECLARED /* 467 */ EXTERN int Tcl_FSEvalFile(Tcl_Interp *interp, Tcl_Obj *fileName); +#endif +#ifndef Tcl_FSNewNativePath_TCL_DECLARED +#define Tcl_FSNewNativePath_TCL_DECLARED /* 468 */ -EXTERN Tcl_Obj * Tcl_FSNewNativePath( - const Tcl_Filesystem *fromFilesystem, - void *clientData); +EXTERN Tcl_Obj * Tcl_FSNewNativePath(Tcl_Filesystem *fromFilesystem, + ClientData clientData); +#endif +#ifndef Tcl_FSGetNativePath_TCL_DECLARED +#define Tcl_FSGetNativePath_TCL_DECLARED /* 469 */ -EXTERN const void * Tcl_FSGetNativePath(Tcl_Obj *pathPtr); +EXTERN CONST char * Tcl_FSGetNativePath(Tcl_Obj *pathPtr); +#endif +#ifndef Tcl_FSFileSystemInfo_TCL_DECLARED +#define Tcl_FSFileSystemInfo_TCL_DECLARED /* 470 */ EXTERN Tcl_Obj * Tcl_FSFileSystemInfo(Tcl_Obj *pathPtr); +#endif +#ifndef Tcl_FSPathSeparator_TCL_DECLARED +#define Tcl_FSPathSeparator_TCL_DECLARED /* 471 */ EXTERN Tcl_Obj * Tcl_FSPathSeparator(Tcl_Obj *pathPtr); +#endif +#ifndef Tcl_FSListVolumes_TCL_DECLARED +#define Tcl_FSListVolumes_TCL_DECLARED /* 472 */ EXTERN Tcl_Obj * Tcl_FSListVolumes(void); +#endif +#ifndef Tcl_FSRegister_TCL_DECLARED +#define Tcl_FSRegister_TCL_DECLARED /* 473 */ -EXTERN int Tcl_FSRegister(void *clientData, - const Tcl_Filesystem *fsPtr); +EXTERN int Tcl_FSRegister(ClientData clientData, + Tcl_Filesystem *fsPtr); +#endif +#ifndef Tcl_FSUnregister_TCL_DECLARED +#define Tcl_FSUnregister_TCL_DECLARED /* 474 */ -EXTERN int Tcl_FSUnregister(const Tcl_Filesystem *fsPtr); +EXTERN int Tcl_FSUnregister(Tcl_Filesystem *fsPtr); +#endif +#ifndef Tcl_FSData_TCL_DECLARED +#define Tcl_FSData_TCL_DECLARED /* 475 */ -EXTERN void * Tcl_FSData(const Tcl_Filesystem *fsPtr); +EXTERN ClientData Tcl_FSData(Tcl_Filesystem *fsPtr); +#endif +#ifndef Tcl_FSGetTranslatedStringPath_TCL_DECLARED +#define Tcl_FSGetTranslatedStringPath_TCL_DECLARED /* 476 */ -EXTERN const char * Tcl_FSGetTranslatedStringPath(Tcl_Interp *interp, +EXTERN CONST char * Tcl_FSGetTranslatedStringPath(Tcl_Interp *interp, Tcl_Obj *pathPtr); +#endif +#ifndef Tcl_FSGetFileSystemForPath_TCL_DECLARED +#define Tcl_FSGetFileSystemForPath_TCL_DECLARED /* 477 */ -EXTERN const Tcl_Filesystem * Tcl_FSGetFileSystemForPath(Tcl_Obj *pathPtr); +EXTERN Tcl_Filesystem * Tcl_FSGetFileSystemForPath(Tcl_Obj *pathPtr); +#endif +#ifndef Tcl_FSGetPathType_TCL_DECLARED +#define Tcl_FSGetPathType_TCL_DECLARED /* 478 */ EXTERN Tcl_PathType Tcl_FSGetPathType(Tcl_Obj *pathPtr); +#endif +#ifndef Tcl_OutputBuffered_TCL_DECLARED +#define Tcl_OutputBuffered_TCL_DECLARED /* 479 */ EXTERN int Tcl_OutputBuffered(Tcl_Channel chan); +#endif +#ifndef Tcl_FSMountsChanged_TCL_DECLARED +#define Tcl_FSMountsChanged_TCL_DECLARED /* 480 */ -EXTERN void Tcl_FSMountsChanged(const Tcl_Filesystem *fsPtr); +EXTERN void Tcl_FSMountsChanged(Tcl_Filesystem *fsPtr); +#endif +#ifndef Tcl_EvalTokensStandard_TCL_DECLARED +#define Tcl_EvalTokensStandard_TCL_DECLARED /* 481 */ EXTERN int Tcl_EvalTokensStandard(Tcl_Interp *interp, - Tcl_Token *tokenPtr, size_t count); + Tcl_Token *tokenPtr, int count); +#endif +#ifndef Tcl_GetTime_TCL_DECLARED +#define Tcl_GetTime_TCL_DECLARED /* 482 */ EXTERN void Tcl_GetTime(Tcl_Time *timeBuf); +#endif +#ifndef Tcl_CreateObjTrace_TCL_DECLARED +#define Tcl_CreateObjTrace_TCL_DECLARED /* 483 */ EXTERN Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc *objProc, - void *clientData, + ClientData clientData, Tcl_CmdObjTraceDeleteProc *delProc); +#endif +#ifndef Tcl_GetCommandInfoFromToken_TCL_DECLARED +#define Tcl_GetCommandInfoFromToken_TCL_DECLARED /* 484 */ EXTERN int Tcl_GetCommandInfoFromToken(Tcl_Command token, Tcl_CmdInfo *infoPtr); +#endif +#ifndef Tcl_SetCommandInfoFromToken_TCL_DECLARED +#define Tcl_SetCommandInfoFromToken_TCL_DECLARED /* 485 */ EXTERN int Tcl_SetCommandInfoFromToken(Tcl_Command token, - const Tcl_CmdInfo *infoPtr); + CONST Tcl_CmdInfo *infoPtr); +#endif +#ifndef Tcl_DbNewWideIntObj_TCL_DECLARED +#define Tcl_DbNewWideIntObj_TCL_DECLARED /* 486 */ EXTERN Tcl_Obj * Tcl_DbNewWideIntObj(Tcl_WideInt wideValue, - const char *file, int line); + CONST char *file, int line); +#endif +#ifndef Tcl_GetWideIntFromObj_TCL_DECLARED +#define Tcl_GetWideIntFromObj_TCL_DECLARED /* 487 */ EXTERN int Tcl_GetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_WideInt *widePtr); +#endif +#ifndef Tcl_NewWideIntObj_TCL_DECLARED +#define Tcl_NewWideIntObj_TCL_DECLARED /* 488 */ EXTERN Tcl_Obj * Tcl_NewWideIntObj(Tcl_WideInt wideValue); +#endif +#ifndef Tcl_SetWideIntObj_TCL_DECLARED +#define Tcl_SetWideIntObj_TCL_DECLARED /* 489 */ EXTERN void Tcl_SetWideIntObj(Tcl_Obj *objPtr, Tcl_WideInt wideValue); +#endif +#ifndef Tcl_AllocStatBuf_TCL_DECLARED +#define Tcl_AllocStatBuf_TCL_DECLARED /* 490 */ EXTERN Tcl_StatBuf * Tcl_AllocStatBuf(void); +#endif +#ifndef Tcl_Seek_TCL_DECLARED +#define Tcl_Seek_TCL_DECLARED /* 491 */ EXTERN Tcl_WideInt Tcl_Seek(Tcl_Channel chan, Tcl_WideInt offset, int mode); +#endif +#ifndef Tcl_Tell_TCL_DECLARED +#define Tcl_Tell_TCL_DECLARED /* 492 */ EXTERN Tcl_WideInt Tcl_Tell(Tcl_Channel chan); +#endif +#ifndef Tcl_ChannelWideSeekProc_TCL_DECLARED +#define Tcl_ChannelWideSeekProc_TCL_DECLARED /* 493 */ EXTERN Tcl_DriverWideSeekProc * Tcl_ChannelWideSeekProc( - const Tcl_ChannelType *chanTypePtr); + CONST Tcl_ChannelType *chanTypePtr); +#endif +#ifndef Tcl_DictObjPut_TCL_DECLARED +#define Tcl_DictObjPut_TCL_DECLARED /* 494 */ EXTERN int Tcl_DictObjPut(Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr, Tcl_Obj *valuePtr); +#endif +#ifndef Tcl_DictObjGet_TCL_DECLARED +#define Tcl_DictObjGet_TCL_DECLARED /* 495 */ EXTERN int Tcl_DictObjGet(Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr, Tcl_Obj **valuePtrPtr); +#endif +#ifndef Tcl_DictObjRemove_TCL_DECLARED +#define Tcl_DictObjRemove_TCL_DECLARED /* 496 */ EXTERN int Tcl_DictObjRemove(Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr); +#endif +#ifndef Tcl_DictObjSize_TCL_DECLARED +#define Tcl_DictObjSize_TCL_DECLARED /* 497 */ EXTERN int Tcl_DictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, int *sizePtr); +#endif +#ifndef Tcl_DictObjFirst_TCL_DECLARED +#define Tcl_DictObjFirst_TCL_DECLARED /* 498 */ EXTERN int Tcl_DictObjFirst(Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_DictSearch *searchPtr, Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr, int *donePtr); +#endif +#ifndef Tcl_DictObjNext_TCL_DECLARED +#define Tcl_DictObjNext_TCL_DECLARED /* 499 */ EXTERN void Tcl_DictObjNext(Tcl_DictSearch *searchPtr, Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr, int *donePtr); +#endif +#ifndef Tcl_DictObjDone_TCL_DECLARED +#define Tcl_DictObjDone_TCL_DECLARED /* 500 */ EXTERN void Tcl_DictObjDone(Tcl_DictSearch *searchPtr); +#endif +#ifndef Tcl_DictObjPutKeyList_TCL_DECLARED +#define Tcl_DictObjPutKeyList_TCL_DECLARED /* 501 */ EXTERN int Tcl_DictObjPutKeyList(Tcl_Interp *interp, Tcl_Obj *dictPtr, int keyc, - Tcl_Obj *const *keyv, Tcl_Obj *valuePtr); + Tcl_Obj *CONST *keyv, Tcl_Obj *valuePtr); +#endif +#ifndef Tcl_DictObjRemoveKeyList_TCL_DECLARED +#define Tcl_DictObjRemoveKeyList_TCL_DECLARED /* 502 */ EXTERN int Tcl_DictObjRemoveKeyList(Tcl_Interp *interp, Tcl_Obj *dictPtr, int keyc, - Tcl_Obj *const *keyv); + Tcl_Obj *CONST *keyv); +#endif +#ifndef Tcl_NewDictObj_TCL_DECLARED +#define Tcl_NewDictObj_TCL_DECLARED /* 503 */ EXTERN Tcl_Obj * Tcl_NewDictObj(void); +#endif +#ifndef Tcl_DbNewDictObj_TCL_DECLARED +#define Tcl_DbNewDictObj_TCL_DECLARED /* 504 */ -EXTERN Tcl_Obj * Tcl_DbNewDictObj(const char *file, int line); +EXTERN Tcl_Obj * Tcl_DbNewDictObj(CONST char *file, int line); +#endif +#ifndef Tcl_RegisterConfig_TCL_DECLARED +#define Tcl_RegisterConfig_TCL_DECLARED /* 505 */ EXTERN void Tcl_RegisterConfig(Tcl_Interp *interp, - const char *pkgName, - const Tcl_Config *configuration, - const char *valEncoding); + CONST char *pkgName, + Tcl_Config *configuration, + CONST char *valEncoding); +#endif +#ifndef Tcl_CreateNamespace_TCL_DECLARED +#define Tcl_CreateNamespace_TCL_DECLARED /* 506 */ EXTERN Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp, - const char *name, void *clientData, + CONST char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); +#endif +#ifndef Tcl_DeleteNamespace_TCL_DECLARED +#define Tcl_DeleteNamespace_TCL_DECLARED /* 507 */ EXTERN void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr); +#endif +#ifndef Tcl_AppendExportList_TCL_DECLARED +#define Tcl_AppendExportList_TCL_DECLARED /* 508 */ EXTERN int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); +#endif +#ifndef Tcl_Export_TCL_DECLARED +#define Tcl_Export_TCL_DECLARED /* 509 */ EXTERN int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, - const char *pattern, int resetListFirst); + CONST char *pattern, int resetListFirst); +#endif +#ifndef Tcl_Import_TCL_DECLARED +#define Tcl_Import_TCL_DECLARED /* 510 */ EXTERN int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, - const char *pattern, int allowOverwrite); + CONST char *pattern, int allowOverwrite); +#endif +#ifndef Tcl_ForgetImport_TCL_DECLARED +#define Tcl_ForgetImport_TCL_DECLARED /* 511 */ EXTERN int Tcl_ForgetImport(Tcl_Interp *interp, - Tcl_Namespace *nsPtr, const char *pattern); + Tcl_Namespace *nsPtr, CONST char *pattern); +#endif +#ifndef Tcl_GetCurrentNamespace_TCL_DECLARED +#define Tcl_GetCurrentNamespace_TCL_DECLARED /* 512 */ EXTERN Tcl_Namespace * Tcl_GetCurrentNamespace(Tcl_Interp *interp); +#endif +#ifndef Tcl_GetGlobalNamespace_TCL_DECLARED +#define Tcl_GetGlobalNamespace_TCL_DECLARED /* 513 */ EXTERN Tcl_Namespace * Tcl_GetGlobalNamespace(Tcl_Interp *interp); +#endif +#ifndef Tcl_FindNamespace_TCL_DECLARED +#define Tcl_FindNamespace_TCL_DECLARED /* 514 */ EXTERN Tcl_Namespace * Tcl_FindNamespace(Tcl_Interp *interp, - const char *name, + CONST char *name, Tcl_Namespace *contextNsPtr, int flags); +#endif +#ifndef Tcl_FindCommand_TCL_DECLARED +#define Tcl_FindCommand_TCL_DECLARED /* 515 */ -EXTERN Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name, +EXTERN Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, CONST char *name, Tcl_Namespace *contextNsPtr, int flags); +#endif +#ifndef Tcl_GetCommandFromObj_TCL_DECLARED +#define Tcl_GetCommandFromObj_TCL_DECLARED /* 516 */ EXTERN Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); +#endif +#ifndef Tcl_GetCommandFullName_TCL_DECLARED +#define Tcl_GetCommandFullName_TCL_DECLARED /* 517 */ EXTERN void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); +#endif +#ifndef Tcl_FSEvalFileEx_TCL_DECLARED +#define Tcl_FSEvalFileEx_TCL_DECLARED /* 518 */ EXTERN int Tcl_FSEvalFileEx(Tcl_Interp *interp, - Tcl_Obj *fileName, const char *encodingName); -/* Slot 519 is reserved */ + Tcl_Obj *fileName, CONST char *encodingName); +#endif +#ifndef Tcl_SetExitProc_TCL_DECLARED +#define Tcl_SetExitProc_TCL_DECLARED +/* 519 */ +EXTERN Tcl_ExitProc * Tcl_SetExitProc(Tcl_ExitProc *proc); +#endif +#ifndef Tcl_LimitAddHandler_TCL_DECLARED +#define Tcl_LimitAddHandler_TCL_DECLARED /* 520 */ EXTERN void Tcl_LimitAddHandler(Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, - void *clientData, + ClientData clientData, Tcl_LimitHandlerDeleteProc *deleteProc); +#endif +#ifndef Tcl_LimitRemoveHandler_TCL_DECLARED +#define Tcl_LimitRemoveHandler_TCL_DECLARED /* 521 */ EXTERN void Tcl_LimitRemoveHandler(Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, - void *clientData); + ClientData clientData); +#endif +#ifndef Tcl_LimitReady_TCL_DECLARED +#define Tcl_LimitReady_TCL_DECLARED /* 522 */ EXTERN int Tcl_LimitReady(Tcl_Interp *interp); +#endif +#ifndef Tcl_LimitCheck_TCL_DECLARED +#define Tcl_LimitCheck_TCL_DECLARED /* 523 */ EXTERN int Tcl_LimitCheck(Tcl_Interp *interp); +#endif +#ifndef Tcl_LimitExceeded_TCL_DECLARED +#define Tcl_LimitExceeded_TCL_DECLARED /* 524 */ EXTERN int Tcl_LimitExceeded(Tcl_Interp *interp); +#endif +#ifndef Tcl_LimitSetCommands_TCL_DECLARED +#define Tcl_LimitSetCommands_TCL_DECLARED /* 525 */ EXTERN void Tcl_LimitSetCommands(Tcl_Interp *interp, int commandLimit); +#endif +#ifndef Tcl_LimitSetTime_TCL_DECLARED +#define Tcl_LimitSetTime_TCL_DECLARED /* 526 */ EXTERN void Tcl_LimitSetTime(Tcl_Interp *interp, Tcl_Time *timeLimitPtr); +#endif +#ifndef Tcl_LimitSetGranularity_TCL_DECLARED +#define Tcl_LimitSetGranularity_TCL_DECLARED /* 527 */ EXTERN void Tcl_LimitSetGranularity(Tcl_Interp *interp, int type, int granularity); +#endif +#ifndef Tcl_LimitTypeEnabled_TCL_DECLARED +#define Tcl_LimitTypeEnabled_TCL_DECLARED /* 528 */ EXTERN int Tcl_LimitTypeEnabled(Tcl_Interp *interp, int type); +#endif +#ifndef Tcl_LimitTypeExceeded_TCL_DECLARED +#define Tcl_LimitTypeExceeded_TCL_DECLARED /* 529 */ EXTERN int Tcl_LimitTypeExceeded(Tcl_Interp *interp, int type); +#endif +#ifndef Tcl_LimitTypeSet_TCL_DECLARED +#define Tcl_LimitTypeSet_TCL_DECLARED /* 530 */ EXTERN void Tcl_LimitTypeSet(Tcl_Interp *interp, int type); +#endif +#ifndef Tcl_LimitTypeReset_TCL_DECLARED +#define Tcl_LimitTypeReset_TCL_DECLARED /* 531 */ EXTERN void Tcl_LimitTypeReset(Tcl_Interp *interp, int type); +#endif +#ifndef Tcl_LimitGetCommands_TCL_DECLARED +#define Tcl_LimitGetCommands_TCL_DECLARED /* 532 */ EXTERN int Tcl_LimitGetCommands(Tcl_Interp *interp); +#endif +#ifndef Tcl_LimitGetTime_TCL_DECLARED +#define Tcl_LimitGetTime_TCL_DECLARED /* 533 */ EXTERN void Tcl_LimitGetTime(Tcl_Interp *interp, Tcl_Time *timeLimitPtr); +#endif +#ifndef Tcl_LimitGetGranularity_TCL_DECLARED +#define Tcl_LimitGetGranularity_TCL_DECLARED /* 534 */ EXTERN int Tcl_LimitGetGranularity(Tcl_Interp *interp, int type); +#endif +#ifndef Tcl_SaveInterpState_TCL_DECLARED +#define Tcl_SaveInterpState_TCL_DECLARED /* 535 */ EXTERN Tcl_InterpState Tcl_SaveInterpState(Tcl_Interp *interp, int status); +#endif +#ifndef Tcl_RestoreInterpState_TCL_DECLARED +#define Tcl_RestoreInterpState_TCL_DECLARED /* 536 */ EXTERN int Tcl_RestoreInterpState(Tcl_Interp *interp, Tcl_InterpState state); +#endif +#ifndef Tcl_DiscardInterpState_TCL_DECLARED +#define Tcl_DiscardInterpState_TCL_DECLARED /* 537 */ EXTERN void Tcl_DiscardInterpState(Tcl_InterpState state); +#endif +#ifndef Tcl_SetReturnOptions_TCL_DECLARED +#define Tcl_SetReturnOptions_TCL_DECLARED /* 538 */ EXTERN int Tcl_SetReturnOptions(Tcl_Interp *interp, Tcl_Obj *options); +#endif +#ifndef Tcl_GetReturnOptions_TCL_DECLARED +#define Tcl_GetReturnOptions_TCL_DECLARED /* 539 */ EXTERN Tcl_Obj * Tcl_GetReturnOptions(Tcl_Interp *interp, int result); +#endif +#ifndef Tcl_IsEnsemble_TCL_DECLARED +#define Tcl_IsEnsemble_TCL_DECLARED /* 540 */ EXTERN int Tcl_IsEnsemble(Tcl_Command token); +#endif +#ifndef Tcl_CreateEnsemble_TCL_DECLARED +#define Tcl_CreateEnsemble_TCL_DECLARED /* 541 */ EXTERN Tcl_Command Tcl_CreateEnsemble(Tcl_Interp *interp, - const char *name, + CONST char *name, Tcl_Namespace *namespacePtr, int flags); +#endif +#ifndef Tcl_FindEnsemble_TCL_DECLARED +#define Tcl_FindEnsemble_TCL_DECLARED /* 542 */ EXTERN Tcl_Command Tcl_FindEnsemble(Tcl_Interp *interp, Tcl_Obj *cmdNameObj, int flags); +#endif +#ifndef Tcl_SetEnsembleSubcommandList_TCL_DECLARED +#define Tcl_SetEnsembleSubcommandList_TCL_DECLARED /* 543 */ EXTERN int Tcl_SetEnsembleSubcommandList(Tcl_Interp *interp, Tcl_Command token, Tcl_Obj *subcmdList); +#endif +#ifndef Tcl_SetEnsembleMappingDict_TCL_DECLARED +#define Tcl_SetEnsembleMappingDict_TCL_DECLARED /* 544 */ EXTERN int Tcl_SetEnsembleMappingDict(Tcl_Interp *interp, Tcl_Command token, Tcl_Obj *mapDict); +#endif +#ifndef Tcl_SetEnsembleUnknownHandler_TCL_DECLARED +#define Tcl_SetEnsembleUnknownHandler_TCL_DECLARED /* 545 */ EXTERN int Tcl_SetEnsembleUnknownHandler(Tcl_Interp *interp, Tcl_Command token, Tcl_Obj *unknownList); +#endif +#ifndef Tcl_SetEnsembleFlags_TCL_DECLARED +#define Tcl_SetEnsembleFlags_TCL_DECLARED /* 546 */ EXTERN int Tcl_SetEnsembleFlags(Tcl_Interp *interp, Tcl_Command token, int flags); +#endif +#ifndef Tcl_GetEnsembleSubcommandList_TCL_DECLARED +#define Tcl_GetEnsembleSubcommandList_TCL_DECLARED /* 547 */ EXTERN int Tcl_GetEnsembleSubcommandList(Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **subcmdListPtr); +#endif +#ifndef Tcl_GetEnsembleMappingDict_TCL_DECLARED +#define Tcl_GetEnsembleMappingDict_TCL_DECLARED /* 548 */ EXTERN int Tcl_GetEnsembleMappingDict(Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **mapDictPtr); +#endif +#ifndef Tcl_GetEnsembleUnknownHandler_TCL_DECLARED +#define Tcl_GetEnsembleUnknownHandler_TCL_DECLARED /* 549 */ EXTERN int Tcl_GetEnsembleUnknownHandler(Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **unknownListPtr); +#endif +#ifndef Tcl_GetEnsembleFlags_TCL_DECLARED +#define Tcl_GetEnsembleFlags_TCL_DECLARED /* 550 */ EXTERN int Tcl_GetEnsembleFlags(Tcl_Interp *interp, Tcl_Command token, int *flagsPtr); +#endif +#ifndef Tcl_GetEnsembleNamespace_TCL_DECLARED +#define Tcl_GetEnsembleNamespace_TCL_DECLARED /* 551 */ EXTERN int Tcl_GetEnsembleNamespace(Tcl_Interp *interp, Tcl_Command token, Tcl_Namespace **namespacePtrPtr); +#endif +#ifndef Tcl_SetTimeProc_TCL_DECLARED +#define Tcl_SetTimeProc_TCL_DECLARED /* 552 */ EXTERN void Tcl_SetTimeProc(Tcl_GetTimeProc *getProc, Tcl_ScaleTimeProc *scaleProc, - void *clientData); + ClientData clientData); +#endif +#ifndef Tcl_QueryTimeProc_TCL_DECLARED +#define Tcl_QueryTimeProc_TCL_DECLARED /* 553 */ EXTERN void Tcl_QueryTimeProc(Tcl_GetTimeProc **getProc, Tcl_ScaleTimeProc **scaleProc, - void **clientData); + ClientData *clientData); +#endif +#ifndef Tcl_ChannelThreadActionProc_TCL_DECLARED +#define Tcl_ChannelThreadActionProc_TCL_DECLARED /* 554 */ EXTERN Tcl_DriverThreadActionProc * Tcl_ChannelThreadActionProc( - const Tcl_ChannelType *chanTypePtr); + CONST Tcl_ChannelType *chanTypePtr); +#endif +#ifndef Tcl_NewBignumObj_TCL_DECLARED +#define Tcl_NewBignumObj_TCL_DECLARED /* 555 */ -EXTERN Tcl_Obj * Tcl_NewBignumObj(void *value); +EXTERN Tcl_Obj * Tcl_NewBignumObj(mp_int *value); +#endif +#ifndef Tcl_DbNewBignumObj_TCL_DECLARED +#define Tcl_DbNewBignumObj_TCL_DECLARED /* 556 */ -EXTERN Tcl_Obj * Tcl_DbNewBignumObj(void *value, const char *file, +EXTERN Tcl_Obj * Tcl_DbNewBignumObj(mp_int *value, CONST char *file, int line); +#endif +#ifndef Tcl_SetBignumObj_TCL_DECLARED +#define Tcl_SetBignumObj_TCL_DECLARED /* 557 */ -EXTERN void Tcl_SetBignumObj(Tcl_Obj *obj, void *value); +EXTERN void Tcl_SetBignumObj(Tcl_Obj *obj, mp_int *value); +#endif +#ifndef Tcl_GetBignumFromObj_TCL_DECLARED +#define Tcl_GetBignumFromObj_TCL_DECLARED /* 558 */ EXTERN int Tcl_GetBignumFromObj(Tcl_Interp *interp, - Tcl_Obj *obj, void *value); + Tcl_Obj *obj, mp_int *value); +#endif +#ifndef Tcl_TakeBignumFromObj_TCL_DECLARED +#define Tcl_TakeBignumFromObj_TCL_DECLARED /* 559 */ EXTERN int Tcl_TakeBignumFromObj(Tcl_Interp *interp, - Tcl_Obj *obj, void *value); + Tcl_Obj *obj, mp_int *value); +#endif +#ifndef Tcl_TruncateChannel_TCL_DECLARED +#define Tcl_TruncateChannel_TCL_DECLARED /* 560 */ EXTERN int Tcl_TruncateChannel(Tcl_Channel chan, Tcl_WideInt length); +#endif +#ifndef Tcl_ChannelTruncateProc_TCL_DECLARED +#define Tcl_ChannelTruncateProc_TCL_DECLARED /* 561 */ EXTERN Tcl_DriverTruncateProc * Tcl_ChannelTruncateProc( - const Tcl_ChannelType *chanTypePtr); + CONST Tcl_ChannelType *chanTypePtr); +#endif +#ifndef Tcl_SetChannelErrorInterp_TCL_DECLARED +#define Tcl_SetChannelErrorInterp_TCL_DECLARED /* 562 */ EXTERN void Tcl_SetChannelErrorInterp(Tcl_Interp *interp, Tcl_Obj *msg); +#endif +#ifndef Tcl_GetChannelErrorInterp_TCL_DECLARED +#define Tcl_GetChannelErrorInterp_TCL_DECLARED /* 563 */ EXTERN void Tcl_GetChannelErrorInterp(Tcl_Interp *interp, Tcl_Obj **msg); +#endif +#ifndef Tcl_SetChannelError_TCL_DECLARED +#define Tcl_SetChannelError_TCL_DECLARED /* 564 */ EXTERN void Tcl_SetChannelError(Tcl_Channel chan, Tcl_Obj *msg); +#endif +#ifndef Tcl_GetChannelError_TCL_DECLARED +#define Tcl_GetChannelError_TCL_DECLARED /* 565 */ EXTERN void Tcl_GetChannelError(Tcl_Channel chan, Tcl_Obj **msg); +#endif +#ifndef Tcl_InitBignumFromDouble_TCL_DECLARED +#define Tcl_InitBignumFromDouble_TCL_DECLARED /* 566 */ EXTERN int Tcl_InitBignumFromDouble(Tcl_Interp *interp, - double initval, void *toInit); + double initval, mp_int *toInit); +#endif +#ifndef Tcl_GetNamespaceUnknownHandler_TCL_DECLARED +#define Tcl_GetNamespaceUnknownHandler_TCL_DECLARED /* 567 */ EXTERN Tcl_Obj * Tcl_GetNamespaceUnknownHandler(Tcl_Interp *interp, Tcl_Namespace *nsPtr); +#endif +#ifndef Tcl_SetNamespaceUnknownHandler_TCL_DECLARED +#define Tcl_SetNamespaceUnknownHandler_TCL_DECLARED /* 568 */ EXTERN int Tcl_SetNamespaceUnknownHandler(Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *handlerPtr); +#endif +#ifndef Tcl_GetEncodingFromObj_TCL_DECLARED +#define Tcl_GetEncodingFromObj_TCL_DECLARED /* 569 */ EXTERN int Tcl_GetEncodingFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr); +#endif +#ifndef Tcl_GetEncodingSearchPath_TCL_DECLARED +#define Tcl_GetEncodingSearchPath_TCL_DECLARED /* 570 */ EXTERN Tcl_Obj * Tcl_GetEncodingSearchPath(void); +#endif +#ifndef Tcl_SetEncodingSearchPath_TCL_DECLARED +#define Tcl_SetEncodingSearchPath_TCL_DECLARED /* 571 */ EXTERN int Tcl_SetEncodingSearchPath(Tcl_Obj *searchPath); +#endif +#ifndef Tcl_GetEncodingNameFromEnvironment_TCL_DECLARED +#define Tcl_GetEncodingNameFromEnvironment_TCL_DECLARED /* 572 */ -EXTERN const char * Tcl_GetEncodingNameFromEnvironment( +EXTERN CONST char * Tcl_GetEncodingNameFromEnvironment( Tcl_DString *bufPtr); +#endif +#ifndef Tcl_PkgRequireProc_TCL_DECLARED +#define Tcl_PkgRequireProc_TCL_DECLARED /* 573 */ EXTERN int Tcl_PkgRequireProc(Tcl_Interp *interp, - const char *name, int objc, - Tcl_Obj *const objv[], void *clientDataPtr); + CONST char *name, int objc, + Tcl_Obj *CONST objv[], + ClientData *clientDataPtr); +#endif +#ifndef Tcl_AppendObjToErrorInfo_TCL_DECLARED +#define Tcl_AppendObjToErrorInfo_TCL_DECLARED /* 574 */ EXTERN void Tcl_AppendObjToErrorInfo(Tcl_Interp *interp, Tcl_Obj *objPtr); +#endif +#ifndef Tcl_AppendLimitedToObj_TCL_DECLARED +#define Tcl_AppendLimitedToObj_TCL_DECLARED /* 575 */ EXTERN void Tcl_AppendLimitedToObj(Tcl_Obj *objPtr, - const char *bytes, size_t length, - size_t limit, const char *ellipsis); + CONST char *bytes, int length, int limit, + CONST char *ellipsis); +#endif +#ifndef Tcl_Format_TCL_DECLARED +#define Tcl_Format_TCL_DECLARED /* 576 */ -EXTERN Tcl_Obj * Tcl_Format(Tcl_Interp *interp, const char *format, - int objc, Tcl_Obj *const objv[]); +EXTERN Tcl_Obj * Tcl_Format(Tcl_Interp *interp, CONST char *format, + int objc, Tcl_Obj *CONST objv[]); +#endif +#ifndef Tcl_AppendFormatToObj_TCL_DECLARED +#define Tcl_AppendFormatToObj_TCL_DECLARED /* 577 */ EXTERN int Tcl_AppendFormatToObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, const char *format, - int objc, Tcl_Obj *const objv[]); + Tcl_Obj *objPtr, CONST char *format, + int objc, Tcl_Obj *CONST objv[]); +#endif +#ifndef Tcl_ObjPrintf_TCL_DECLARED +#define Tcl_ObjPrintf_TCL_DECLARED /* 578 */ -EXTERN Tcl_Obj * Tcl_ObjPrintf(const char *format, ...) TCL_FORMAT_PRINTF(1, 2); +EXTERN Tcl_Obj * Tcl_ObjPrintf(CONST char *format, ...); +#endif +#ifndef Tcl_AppendPrintfToObj_TCL_DECLARED +#define Tcl_AppendPrintfToObj_TCL_DECLARED /* 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, void *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, void *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, void *data0, - void *data1, void *data2, void *data3); -/* 588 */ -EXTERN int Tcl_NRCallObjProc(Tcl_Interp *interp, - Tcl_ObjCmdProc *objProc, void *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 */ -EXTERN int Tcl_GetLinkCountFromStat(const Tcl_StatBuf *statPtr); -/* 593 */ -EXTERN int Tcl_GetUserIdFromStat(const Tcl_StatBuf *statPtr); -/* 594 */ -EXTERN int Tcl_GetGroupIdFromStat(const Tcl_StatBuf *statPtr); -/* 595 */ -EXTERN int Tcl_GetDeviceTypeFromStat(const Tcl_StatBuf *statPtr); -/* 596 */ -EXTERN Tcl_WideInt Tcl_GetAccessTimeFromStat(const Tcl_StatBuf *statPtr); -/* 597 */ -EXTERN Tcl_WideInt Tcl_GetModificationTimeFromStat( - const Tcl_StatBuf *statPtr); -/* 598 */ -EXTERN Tcl_WideInt Tcl_GetChangeTimeFromStat(const Tcl_StatBuf *statPtr); -/* 599 */ -EXTERN Tcl_WideUInt Tcl_GetSizeFromStat(const Tcl_StatBuf *statPtr); -/* 600 */ -EXTERN Tcl_WideUInt Tcl_GetBlocksFromStat(const Tcl_StatBuf *statPtr); -/* 601 */ -EXTERN unsigned Tcl_GetBlockSizeFromStat(const Tcl_StatBuf *statPtr); -/* 602 */ -EXTERN int Tcl_SetEnsembleParameterList(Tcl_Interp *interp, - Tcl_Command token, Tcl_Obj *paramList); -/* 603 */ -EXTERN int Tcl_GetEnsembleParameterList(Tcl_Interp *interp, - Tcl_Command token, Tcl_Obj **paramListPtr); -/* 604 */ -EXTERN int Tcl_ParseArgsObjv(Tcl_Interp *interp, - const Tcl_ArgvInfo *argTable, int *objcPtr, - 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, size_t buffersize, - Tcl_Obj *gzipHeaderDictObj); -/* 612 */ -EXTERN unsigned int Tcl_ZlibCRC32(unsigned int crc, - const unsigned char *buf, size_t len); -/* 613 */ -EXTERN unsigned int Tcl_ZlibAdler32(unsigned int adler, - const unsigned char *buf, size_t 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, size_t 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); -/* 623 */ -EXTERN Tcl_Obj * Tcl_GetStartupScript(const char **encodingPtr); -/* 624 */ -EXTERN int Tcl_CloseEx(Tcl_Interp *interp, Tcl_Channel chan, - int flags); -/* 625 */ -EXTERN int Tcl_NRExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - Tcl_Obj *resultPtr); -/* 626 */ -EXTERN int Tcl_NRSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - int flags); -/* 627 */ -EXTERN int Tcl_LoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, - const char *const symv[], int flags, - void *procPtrs, Tcl_LoadHandle *handlePtr); -/* 628 */ -EXTERN void * Tcl_FindSymbol(Tcl_Interp *interp, - Tcl_LoadHandle handle, const char *symbol); -/* 629 */ -EXTERN int Tcl_FSUnloadFile(Tcl_Interp *interp, - Tcl_LoadHandle handlePtr); -/* 630 */ -EXTERN void Tcl_ZlibStreamSetCompressionDictionary( - 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, - void *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, - size_t 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, - size_t size); -/* 645 */ -EXTERN int Tcl_GetIntForIndex(Tcl_Interp *interp, - Tcl_Obj *objPtr, size_t endValue, - size_t *indexPtr); -/* 646 */ -EXTERN int Tcl_UtfToUniChar(const char *src, int *chPtr); -/* 647 */ -EXTERN char * Tcl_UniCharToUtfDString(const int *uniStr, - size_t uniLength, Tcl_DString *dsPtr); -/* 648 */ -EXTERN int * Tcl_UtfToUniCharDString(const char *src, - size_t length, Tcl_DString *dsPtr); - -typedef struct { - const struct TclPlatStubs *tclPlatStubs; - const struct TclIntStubs *tclIntStubs; - const struct TclIntPlatStubs *tclIntPlatStubs; + CONST char *format, ...); +#endif +/* Slot 580 is reserved */ +/* Slot 581 is reserved */ +/* Slot 582 is reserved */ +/* Slot 583 is reserved */ +/* Slot 584 is reserved */ +/* Slot 585 is reserved */ +/* Slot 586 is reserved */ +/* Slot 587 is reserved */ +/* Slot 588 is reserved */ +/* Slot 589 is reserved */ +/* Slot 590 is reserved */ +/* Slot 591 is reserved */ +/* Slot 592 is reserved */ +/* Slot 593 is reserved */ +/* Slot 594 is reserved */ +/* Slot 595 is reserved */ +/* Slot 596 is reserved */ +/* Slot 597 is reserved */ +/* Slot 598 is reserved */ +/* Slot 599 is reserved */ +/* Slot 600 is reserved */ +/* Slot 601 is reserved */ +/* Slot 602 is reserved */ +/* Slot 603 is reserved */ +/* Slot 604 is reserved */ +/* Slot 605 is reserved */ +/* Slot 606 is reserved */ +/* Slot 607 is reserved */ +/* Slot 608 is reserved */ +/* Slot 609 is reserved */ +/* Slot 610 is reserved */ +/* Slot 611 is reserved */ +/* Slot 612 is reserved */ +/* Slot 613 is reserved */ +/* Slot 614 is reserved */ +/* Slot 615 is reserved */ +/* Slot 616 is reserved */ +/* Slot 617 is reserved */ +/* Slot 618 is reserved */ +/* Slot 619 is reserved */ +/* Slot 620 is reserved */ +/* Slot 621 is reserved */ +/* Slot 622 is reserved */ +/* Slot 623 is reserved */ +/* Slot 624 is reserved */ +/* Slot 625 is reserved */ +/* Slot 626 is reserved */ +/* Slot 627 is reserved */ +/* Slot 628 is reserved */ +/* Slot 629 is reserved */ +/* Slot 630 is reserved */ +/* Slot 631 is reserved */ +/* Slot 632 is reserved */ +/* Slot 633 is reserved */ +/* Slot 634 is reserved */ +/* Slot 635 is reserved */ +/* Slot 636 is reserved */ +/* Slot 637 is reserved */ +/* Slot 638 is reserved */ +/* Slot 639 is reserved */ +/* Slot 640 is reserved */ +/* Slot 641 is reserved */ +/* Slot 642 is reserved */ +/* Slot 643 is reserved */ +/* Slot 644 is reserved */ +/* Slot 645 is reserved */ +/* Slot 646 is reserved */ +/* Slot 647 is reserved */ +/* Slot 648 is reserved */ +/* Slot 649 is reserved */ +/* Slot 650 is reserved */ +/* Slot 651 is reserved */ +/* Slot 652 is reserved */ +/* Slot 653 is reserved */ +/* Slot 654 is reserved */ +/* Slot 655 is reserved */ +/* Slot 656 is reserved */ +/* Slot 657 is reserved */ +/* Slot 658 is reserved */ +/* Slot 659 is reserved */ +/* Slot 660 is reserved */ +/* Slot 661 is reserved */ +/* Slot 662 is reserved */ +/* Slot 663 is reserved */ +/* Slot 664 is reserved */ +/* Slot 665 is reserved */ +/* Slot 666 is reserved */ +/* Slot 667 is reserved */ +/* Slot 668 is reserved */ +/* Slot 669 is reserved */ +/* Slot 670 is reserved */ +/* Slot 671 is reserved */ +/* Slot 672 is reserved */ +/* Slot 673 is reserved */ +/* Slot 674 is reserved */ +/* Slot 675 is reserved */ +/* Slot 676 is reserved */ +/* Slot 677 is reserved */ +/* Slot 678 is reserved */ +/* Slot 679 is reserved */ +/* Slot 680 is reserved */ +/* Slot 681 is reserved */ +/* Slot 682 is reserved */ +/* Slot 683 is reserved */ +/* Slot 684 is reserved */ +/* Slot 685 is reserved */ +/* Slot 686 is reserved */ +#ifndef TclUnusedStubEntry_TCL_DECLARED +#define TclUnusedStubEntry_TCL_DECLARED +/* 687 */ +EXTERN void TclUnusedStubEntry(void); +#endif + +typedef struct TclStubHooks { + struct TclPlatStubs *tclPlatStubs; + struct TclIntStubs *tclIntStubs; + 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 */ - void * (*tcl_Alloc) (size_t size); /* 3 */ - void (*tcl_Free) (void *ptr); /* 4 */ - void * (*tcl_Realloc) (void *ptr, size_t size); /* 5 */ - void * (*tcl_DbCkalloc) (size_t size, const char *file, int line); /* 6 */ - void (*tcl_DbCkfree) (void *ptr, const char *file, int line); /* 7 */ - void * (*tcl_DbCkrealloc) (void *ptr, size_t 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, void *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, void *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, size_t 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 */ - void (*reserved22)(void); - Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, size_t 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 */ - void (*reserved26)(void); - Tcl_Obj * (*tcl_DbNewObj) (const char *file, int line); /* 27 */ - Tcl_Obj * (*tcl_DbNewStringObj) (const char *bytes, size_t 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 */ - void (*reserved36)(void); - 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 */ - const Tcl_ObjType * (*tcl_GetObjType) (const char *typeName); /* 40 */ + struct TclStubHooks *hooks; + + int (*tcl_PkgProvideEx) (Tcl_Interp *interp, CONST char *name, CONST char *version, ClientData clientData); /* 0 */ + CONST84_RETURN char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, CONST char *name, CONST char *version, int exact, ClientData *clientDataPtr); /* 1 */ + void (*tcl_Panic) (CONST char *format, ...); /* 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; +#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; +#endif /* WIN */ +#ifdef MAC_OSX_TCL /* MACOSX */ + void (*tcl_DeleteFileHandler) (int fd); /* 10 */ +#endif /* MACOSX */ + void (*tcl_SetTimer) (Tcl_Time *timePtr); /* 11 */ + void (*tcl_Sleep) (int ms); /* 12 */ + int (*tcl_WaitForEvent) (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, 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_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_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 *intPtr); /* 31 */ + int (*tcl_GetBooleanFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); /* 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 */ + int (*tcl_GetIndexFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, CONST84 char **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 */ + 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 */ - void (*reserved49)(void); - Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, size_t length); /* 50 */ + int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *CONST objv[]); /* 48 */ + Tcl_Obj * (*tcl_NewBooleanObj) (int intValue); /* 49 */ + Tcl_Obj * (*tcl_NewByteArrayObj) (CONST unsigned char *bytes, int length); /* 50 */ Tcl_Obj * (*tcl_NewDoubleObj) (double doubleValue); /* 51 */ - void (*reserved52)(void); - Tcl_Obj * (*tcl_NewListObj) (int objc, Tcl_Obj *const objv[]); /* 53 */ - void (*reserved54)(void); + Tcl_Obj * (*tcl_NewIntObj) (int intValue); /* 52 */ + Tcl_Obj * (*tcl_NewListObj) (int objc, Tcl_Obj *CONST objv[]); /* 53 */ + Tcl_Obj * (*tcl_NewLongObj) (long longValue); /* 54 */ Tcl_Obj * (*tcl_NewObj) (void); /* 55 */ - Tcl_Obj * (*tcl_NewStringObj) (const char *bytes, size_t length); /* 56 */ - void (*reserved57)(void); - unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, size_t length); /* 58 */ - void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, size_t length); /* 59 */ + Tcl_Obj * (*tcl_NewStringObj) (CONST char *bytes, int length); /* 56 */ + void (*tcl_SetBooleanObj) (Tcl_Obj *objPtr, int intValue); /* 57 */ + unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, int numBytes); /* 58 */ + void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, CONST unsigned char *bytes, int numBytes); /* 59 */ void (*tcl_SetDoubleObj) (Tcl_Obj *objPtr, double doubleValue); /* 60 */ - void (*reserved61)(void); - void (*tcl_SetListObj) (Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]); /* 62 */ - void (*reserved63)(void); - void (*tcl_SetObjLength) (Tcl_Obj *objPtr, size_t length); /* 64 */ - void (*tcl_SetStringObj) (Tcl_Obj *objPtr, const char *bytes, size_t length); /* 65 */ - void (*reserved66)(void); - void (*reserved67)(void); + void (*tcl_SetIntObj) (Tcl_Obj *objPtr, int intValue); /* 61 */ + void (*tcl_SetListObj) (Tcl_Obj *objPtr, int objc, Tcl_Obj *CONST objv[]); /* 62 */ + 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 */ + void (*tcl_AddErrorInfo) (Tcl_Interp *interp, CONST char *message); /* 66 */ + 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_AppendElement) (Tcl_Interp *interp, CONST char *element); /* 69 */ void (*tcl_AppendResult) (Tcl_Interp *interp, ...); /* 70 */ - Tcl_AsyncHandler (*tcl_AsyncCreate) (Tcl_AsyncProc *proc, void *clientData); /* 71 */ + 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 */ - void (*reserved76)(void); - void (*reserved77)(void); - int (*tcl_BadChannelOption) (Tcl_Interp *interp, const char *optionName, const char *optionList); /* 78 */ - void (*tcl_CallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, void *clientData); /* 79 */ - void (*tcl_CancelIdleCall) (Tcl_IdleProc *idleProc, void *clientData); /* 80 */ - void (*reserved81)(void); - int (*tcl_CommandComplete) (const char *cmd); /* 82 */ - char * (*tcl_Concat) (int argc, const char *const *argv); /* 83 */ - size_t (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */ - size_t (*tcl_ConvertCountedElement) (const char *src, size_t length, char *dst, int flags); /* 85 */ - int (*tcl_CreateAlias) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int argc, const char *const *argv); /* 86 */ - int (*tcl_CreateAliasObj) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 87 */ - Tcl_Channel (*tcl_CreateChannel) (const Tcl_ChannelType *typePtr, const char *chanName, void *instanceData, int mask); /* 88 */ - void (*tcl_CreateChannelHandler) (Tcl_Channel chan, int mask, Tcl_ChannelProc *proc, void *clientData); /* 89 */ - void (*tcl_CreateCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, void *clientData); /* 90 */ - Tcl_Command (*tcl_CreateCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_CmdProc *proc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 91 */ - void (*tcl_CreateEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, void *clientData); /* 92 */ - void (*tcl_CreateExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 93 */ + void (*tcl_BackgroundError) (Tcl_Interp *interp); /* 76 */ + 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, CONST84 char *CONST *argv); /* 83 */ + int (*tcl_ConvertElement) (CONST char *src, char *dst, int flags); /* 84 */ + int (*tcl_ConvertCountedElement) (CONST char *src, int length, char *dst, int flags); /* 85 */ + int (*tcl_CreateAlias) (Tcl_Interp *childInterp, CONST char *childCmd, Tcl_Interp *target, CONST char *targetCmd, int argc, CONST84 char *CONST *argv); /* 86 */ + int (*tcl_CreateAliasObj) (Tcl_Interp *childInterp, CONST char *childCmd, Tcl_Interp *target, CONST char *targetCmd, int objc, Tcl_Obj *CONST objv[]); /* 87 */ + Tcl_Channel (*tcl_CreateChannel) (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 */ - void (*reserved95)(void); - Tcl_Command (*tcl_CreateObjCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 96 */ - Tcl_Interp * (*tcl_CreateChild) (Tcl_Interp *interp, const char *name, int isSafe); /* 97 */ - Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, void *clientData); /* 98 */ - Tcl_Trace (*tcl_CreateTrace) (Tcl_Interp *interp, int level, Tcl_CmdTraceProc *proc, void *clientData); /* 99 */ - void (*tcl_DeleteAssocData) (Tcl_Interp *interp, const char *name); /* 100 */ - void (*tcl_DeleteChannelHandler) (Tcl_Channel chan, Tcl_ChannelProc *proc, void *clientData); /* 101 */ - void (*tcl_DeleteCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, void *clientData); /* 102 */ - int (*tcl_DeleteCommand) (Tcl_Interp *interp, const char *cmdName); /* 103 */ + 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 *name, int isSafe); /* 97 */ + Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, ClientData clientData); /* 98 */ + Tcl_Trace (*tcl_CreateTrace) (Tcl_Interp *interp, int level, Tcl_CmdTraceProc *proc, ClientData clientData); /* 99 */ + void (*tcl_DeleteAssocData) (Tcl_Interp *interp, CONST char *name); /* 100 */ + void (*tcl_DeleteChannelHandler) (Tcl_Channel chan, Tcl_ChannelProc *proc, ClientData clientData); /* 101 */ + void (*tcl_DeleteCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, ClientData clientData); /* 102 */ + int (*tcl_DeleteCommand) (Tcl_Interp *interp, CONST char *cmdName); /* 103 */ int (*tcl_DeleteCommandFromToken) (Tcl_Interp *interp, Tcl_Command command); /* 104 */ - void (*tcl_DeleteEvents) (Tcl_EventDeleteProc *proc, void *clientData); /* 105 */ - void (*tcl_DeleteEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, void *clientData); /* 106 */ - void (*tcl_DeleteExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 107 */ + 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, void *clientData); /* 114 */ + void (*tcl_DontCallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 114 */ int (*tcl_DoOneEvent) (int flags); /* 115 */ - void (*tcl_DoWhenIdle) (Tcl_IdleProc *proc, void *clientData); /* 116 */ - char * (*tcl_DStringAppend) (Tcl_DString *dsPtr, const char *bytes, size_t length); /* 117 */ - char * (*tcl_DStringAppendElement) (Tcl_DString *dsPtr, const char *element); /* 118 */ + 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, size_t length); /* 124 */ + 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 */ - void (*reserved129)(void); - int (*tcl_EvalFile) (Tcl_Interp *interp, const char *fileName); /* 130 */ - void (*reserved131)(void); - void (*tcl_EventuallyFree) (void *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 */ + CONST84_RETURN char * (*tcl_ErrnoId) (void); /* 127 */ + CONST84_RETURN 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 */ + int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */ + void (*tcl_EventuallyFree) (ClientData clientData, Tcl_FreeProc *freeProc); /* 132 */ + 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_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_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 */ + int (*tcl_ExprString) (Tcl_Interp *interp, CONST char *expr); /* 142 */ void (*tcl_Finalize) (void); /* 143 */ - void (*reserved144)(void); + 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 */ - void (*reserved147)(void); - int (*tcl_GetAlias) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 148 */ - int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */ - void * (*tcl_GetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 150 */ - Tcl_Channel (*tcl_GetChannel) (Tcl_Interp *interp, const char *chanName, int *modePtr); /* 151 */ + void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */ + int (*tcl_GetAlias) (Tcl_Interp *interp, CONST char *slaveCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *argcPtr, CONST84 char ***argvPtr); /* 148 */ + int (*tcl_GetAliasObj) (Tcl_Interp *interp, CONST char *slaveCmd, Tcl_Interp **targetInterpPtr, CONST84 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, void **handlePtr); /* 153 */ - void * (*tcl_GetChannelInstanceData) (Tcl_Channel chan); /* 154 */ + 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 */ - const 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 */ + CONST84_RETURN char * (*tcl_GetChannelName) (Tcl_Channel chan); /* 156 */ + int (*tcl_GetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, CONST char *optionName, Tcl_DString *dsPtr); /* 157 */ + Tcl_ChannelType * (*tcl_GetChannelType) (Tcl_Channel chan); /* 158 */ + int (*tcl_GetCommandInfo) (Tcl_Interp *interp, CONST char *cmdName, Tcl_CmdInfo *infoPtr); /* 159 */ + CONST84_RETURN char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */ int (*tcl_GetErrno) (void); /* 161 */ - const char * (*tcl_GetHostName) (void); /* 162 */ + CONST84_RETURN char * (*tcl_GetHostName) (void); /* 162 */ int (*tcl_GetInterpPath) (Tcl_Interp *interp, Tcl_Interp *childInterp); /* 163 */ - Tcl_Interp * (*tcl_GetParent) (Tcl_Interp *interp); /* 164 */ - const char * (*tcl_GetNameOfExecutable) (void); /* 165 */ + Tcl_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, void **filePtr); /* 167 */ +#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); +#if defined(__WIN32__) /* WIN */ + VOID *reserved167; #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ - int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, void **filePtr); /* 167 */ + 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 */ - size_t (*tcl_Gets) (Tcl_Channel chan, Tcl_DString *dsPtr); /* 169 */ - size_t (*tcl_GetsObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 170 */ + Tcl_PathType (*tcl_GetPathType) (CONST char *path); /* 168 */ + int (*tcl_Gets) (Tcl_Channel chan, Tcl_DString *dsPtr); /* 169 */ + int (*tcl_GetsObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 170 */ int (*tcl_GetServiceMode) (void); /* 171 */ - Tcl_Interp * (*tcl_GetChild) (Tcl_Interp *interp, const char *name); /* 172 */ + Tcl_Interp * (*tcl_GetSlave) (Tcl_Interp *interp, CONST char *slaveName); /* 172 */ Tcl_Channel (*tcl_GetStdChannel) (int type); /* 173 */ - void (*reserved174)(void); - void (*reserved175)(void); - const char * (*tcl_GetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 176 */ - void (*reserved177)(void); - void (*reserved178)(void); - int (*tcl_HideCommand) (Tcl_Interp *interp, const char *cmdName, const char *hiddenCmdToken); /* 179 */ + CONST84_RETURN char * (*tcl_GetStringResult) (Tcl_Interp *interp); /* 174 */ + CONST84_RETURN char * (*tcl_GetVar) (Tcl_Interp *interp, CONST char *varName, int flags); /* 175 */ + CONST84_RETURN 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 */ + 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) (void *handle, int mode); /* 189 */ + char * (*tcl_JoinPath) (int argc, CONST84 char *CONST *argv, Tcl_DString *resultPtr); /* 186 */ + int (*tcl_LinkVar) (Tcl_Interp *interp, CONST char *varName, char *addr, int type); /* 187 */ + VOID *reserved188; + Tcl_Channel (*tcl_MakeFileChannel) (ClientData handle, int mode); /* 189 */ int (*tcl_MakeSafe) (Tcl_Interp *interp); /* 190 */ - Tcl_Channel (*tcl_MakeTcpClientChannel) (void *tcpSocket); /* 191 */ - char * (*tcl_Merge) (int argc, const char *const *argv); /* 192 */ + Tcl_Channel (*tcl_MakeTcpClientChannel) (ClientData tcpSocket); /* 191 */ + char * (*tcl_Merge) (int argc, CONST84 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, void *callbackData); /* 200 */ - void (*tcl_Preserve) (void *data); /* 201 */ + Tcl_Channel (*tcl_OpenCommandChannel) (Tcl_Interp *interp, int argc, CONST84 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 flags); /* 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 */ + int (*tcl_PutEnv) (CONST char *assignment); /* 203 */ + CONST84_RETURN char * (*tcl_PosixError) (Tcl_Interp *interp); /* 204 */ void (*tcl_QueueEvent) (Tcl_Event *evPtr, Tcl_QueuePosition position); /* 205 */ - size_t (*tcl_Read) (Tcl_Channel chan, char *bufPtr, size_t toRead); /* 206 */ + 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_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, size_t index, const char **startPtr, const char **endPtr); /* 215 */ - void (*tcl_Release) (void *clientData); /* 216 */ + void (*tcl_RegisterObjType) (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, CONST84 char **startPtr, CONST84 char **endPtr); /* 215 */ + void (*tcl_Release) (ClientData clientData); /* 216 */ void (*tcl_ResetResult) (Tcl_Interp *interp); /* 217 */ - size_t (*tcl_ScanElement) (const char *src, int *flagPtr); /* 218 */ - size_t (*tcl_ScanCountedElement) (const char *src, size_t length, int *flagPtr); /* 219 */ - void (*reserved220)(void); + int (*tcl_ScanElement) (CONST char *src, int *flagPtr); /* 218 */ + int (*tcl_ScanCountedElement) (CONST char *src, int length, int *flagPtr); /* 219 */ + 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, void *clientData); /* 223 */ + 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 */ + 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 */ - void (*reserved230)(void); + void (*tcl_SetMaxBlockTime) (Tcl_Time *timePtr); /* 229 */ + void (*tcl_SetPanicProc) (Tcl_PanicProc *panicProc); /* 230 */ int (*tcl_SetRecursionLimit) (Tcl_Interp *interp, int depth); /* 231 */ - void (*reserved232)(void); + 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 */ - void (*reserved237)(void); - 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 */ + CONST84_RETURN char * (*tcl_SetVar) (Tcl_Interp *interp, CONST char *varName, CONST char *newValue, int flags); /* 237 */ + CONST84_RETURN char * (*tcl_SetVar2) (Tcl_Interp *interp, CONST char *part1, CONST char *part2, CONST char *newValue, int flags); /* 238 */ + CONST84_RETURN char * (*tcl_SignalId) (int sig); /* 239 */ + CONST84_RETURN 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 */ - void (*reserved244)(void); - void (*reserved245)(void); - void (*reserved246)(void); - void (*reserved247)(void); - int (*tcl_TraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, void *clientData); /* 248 */ - char * (*tcl_TranslateFileName) (Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr); /* 249 */ - size_t (*tcl_Ungets) (Tcl_Channel chan, const char *str, size_t len, int atHead); /* 250 */ - void (*tcl_UnlinkVar) (Tcl_Interp *interp, const char *varName); /* 251 */ + int (*tcl_SplitList) (Tcl_Interp *interp, CONST char *listStr, int *argcPtr, CONST84 char ***argvPtr); /* 242 */ + void (*tcl_SplitPath) (CONST char *path, int *argcPtr, CONST84 char ***argvPtr); /* 243 */ + void (*tcl_StaticPackage) (Tcl_Interp *interp, CONST char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 244 */ + int (*tcl_StringMatch) (CONST char *str, CONST char *pattern); /* 245 */ + int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */ + 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 */ - void (*reserved253)(void); - int (*tcl_UnsetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 254 */ - void (*reserved255)(void); - void (*tcl_UntraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, void *clientData); /* 256 */ - void (*tcl_UpdateLinkedVar) (Tcl_Interp *interp, const char *varName); /* 257 */ - void (*reserved258)(void); - int (*tcl_UpVar2) (Tcl_Interp *interp, const char *frameName, const char *part1, const char *part2, const char *localName, int flags); /* 259 */ + 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 */ + 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 */ + 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 */ - void (*reserved261)(void); - void * (*tcl_VarTraceInfo2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, void *prevClientData); /* 262 */ - size_t (*tcl_Write) (Tcl_Channel chan, const char *s, size_t 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 */ - void (*reserved267)(void); - void (*reserved268)(void); + 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 */ + void (*tcl_AppendResultVA) (Tcl_Interp *interp, va_list argList); /* 267 */ + 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 */ - void (*reserved271)(void); - const char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */ - void (*reserved273)(void); - void (*reserved274)(void); - void (*reserved275)(void); - void (*reserved276)(void); + CONST84_RETURN char * (*tcl_ParseVar) (Tcl_Interp *interp, CONST char *start, CONST84 char **termPtr); /* 270 */ + CONST84_RETURN char * (*tcl_PkgPresent) (Tcl_Interp *interp, CONST char *name, CONST char *version, int exact); /* 271 */ + CONST84_RETURN char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, CONST char *name, CONST char *version, int exact, ClientData *clientDataPtr); /* 272 */ + int (*tcl_PkgProvide) (Tcl_Interp *interp, CONST char *name, CONST char *version); /* 273 */ + CONST84_RETURN char * (*tcl_PkgRequire) (Tcl_Interp *interp, CONST char *name, CONST char *version, int exact); /* 274 */ + void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */ + int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */ Tcl_Pid (*tcl_WaitPid) (Tcl_Pid pid, int *statPtr, int options); /* 277 */ - void (*reserved278)(void); + 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, void *instanceData, int mask, Tcl_Channel prevChan); /* 281 */ + Tcl_Channel (*tcl_StackChannel) (Tcl_Interp *interp, 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 *reserved285; void (*tcl_AppendObjToObj) (Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr); /* 286 */ - Tcl_Encoding (*tcl_CreateEncoding) (const Tcl_EncodingType *typePtr); /* 287 */ - void (*tcl_CreateThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 288 */ - void (*tcl_DeleteThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 289 */ - void (*reserved290)(void); - int (*tcl_EvalEx) (Tcl_Interp *interp, const char *script, size_t numBytes, int flags); /* 291 */ - int (*tcl_EvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 292 */ + 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, size_t srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, size_t dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 295 */ - char * (*tcl_ExternalToUtfDString) (Tcl_Encoding encoding, const char *src, size_t srcLen, Tcl_DString *dsPtr); /* 296 */ + 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) (void *clientData); /* 298 */ + 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 */ + Tcl_Encoding (*tcl_GetEncoding) (Tcl_Interp *interp, CONST char *name); /* 301 */ + CONST84_RETURN 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, size_t offset, const char *msg, int flags, int *indexPtr); /* 304 */ - void * (*tcl_GetThreadData) (Tcl_ThreadDataKey *keyPtr, size_t size); /* 305 */ - Tcl_Obj * (*tcl_GetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 306 */ - void * (*tcl_InitNotifier) (void); /* 307 */ + 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 */ - size_t (*tcl_NumUtfChars) (const char *src, size_t length); /* 312 */ - size_t (*tcl_ReadChars) (Tcl_Channel channel, Tcl_Obj *objPtr, size_t charsToRead, int appendFlag); /* 313 */ - void (*reserved314)(void); - void (*reserved315)(void); - 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_ConditionWait) (Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, 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, size_t index); /* 320 */ - int (*tcl_UniCharToLower) (int ch); /* 321 */ - int (*tcl_UniCharToTitle) (int ch); /* 322 */ - int (*tcl_UniCharToUpper) (int ch); /* 323 */ + Tcl_UniChar (*tcl_UniCharAtIndex) (CONST char *src, int index); /* 320 */ + Tcl_UniChar (*tcl_UniCharToLower) (int ch); /* 321 */ + Tcl_UniChar (*tcl_UniCharToTitle) (int ch); /* 322 */ + Tcl_UniChar (*tcl_UniCharToUpper) (int ch); /* 323 */ int (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */ - const char * (*tcl_UtfAtIndex) (const char *src, size_t index); /* 325 */ - int (*tcl_UtfCharComplete) (const char *src, size_t length); /* 326 */ - size_t (*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, size_t srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, size_t dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 332 */ - char * (*tcl_UtfToExternalDString) (Tcl_Encoding encoding, const char *src, size_t srcLen, Tcl_DString *dsPtr); /* 333 */ + CONST84_RETURN 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 */ + CONST84_RETURN char * (*tcl_UtfFindFirst) (CONST char *src, int ch); /* 328 */ + CONST84_RETURN char * (*tcl_UtfFindLast) (CONST char *src, int ch); /* 329 */ + CONST84_RETURN char * (*tcl_UtfNext) (CONST char *src); /* 330 */ + CONST84_RETURN 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_UtfToUniChar) (CONST char *src, Tcl_UniChar *chPtr); /* 336 */ int (*tcl_UtfToUpper) (char *src); /* 337 */ - size_t (*tcl_WriteChars) (Tcl_Channel chan, const char *src, size_t srcLen); /* 338 */ - size_t (*tcl_WriteObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 339 */ + 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 */ - void (*reserved341)(void); - void (*reserved342)(void); - void (*tcl_AlertNotifier) (void *clientData); /* 343 */ + CONST84_RETURN char * (*tcl_GetDefaultEncodingDir) (void); /* 341 */ + 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 */ - void (*reserved352)(void); - void (*reserved353)(void); - char * (*tcl_Char16ToUtfDString) (const unsigned short *uniStr, size_t uniLength, Tcl_DString *dsPtr); /* 354 */ - unsigned short * (*tcl_UtfToChar16DString) (const char *src, size_t length, Tcl_DString *dsPtr); /* 355 */ + int (*tcl_UniCharLen) (CONST Tcl_UniChar *uniStr); /* 352 */ + int (*tcl_UniCharNcmp) (CONST Tcl_UniChar *ucs, CONST Tcl_UniChar *uct, unsigned long numChars); /* 353 */ + char * (*tcl_UniCharToUtfDString) (CONST Tcl_UniChar *uniStr, int uniLength, Tcl_DString *dsPtr); /* 354 */ + Tcl_UniChar * (*tcl_UtfToUniCharDString) (CONST char *src, int length, Tcl_DString *dsPtr); /* 355 */ Tcl_RegExp (*tcl_GetRegExpFromObj) (Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 356 */ - void (*reserved357)(void); + 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, size_t length); /* 359 */ - int (*tcl_ParseBraces) (Tcl_Interp *interp, const char *start, size_t numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 360 */ - int (*tcl_ParseCommand) (Tcl_Interp *interp, const char *start, size_t numBytes, int nested, Tcl_Parse *parsePtr); /* 361 */ - int (*tcl_ParseExpr) (Tcl_Interp *interp, const char *start, size_t numBytes, Tcl_Parse *parsePtr); /* 362 */ - int (*tcl_ParseQuotedString) (Tcl_Interp *interp, const char *start, size_t numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 363 */ - int (*tcl_ParseVarName) (Tcl_Interp *interp, const char *start, size_t numBytes, Tcl_Parse *parsePtr, int append); /* 364 */ + 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, CONST84 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, CONST84 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, size_t n); /* 369 */ - int (*tcl_UtfNcasecmp) (const char *s1, const char *s2, size_t n); /* 370 */ - int (*tcl_StringCaseMatch) (const char *str, const char *pattern, int nocase); /* 371 */ + 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, size_t offset, size_t nmatches, int flags); /* 376 */ + 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, size_t numChars); /* 378 */ - void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t numChars); /* 379 */ - size_t (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */ - int (*tcl_GetUniChar) (Tcl_Obj *objPtr, size_t index); /* 381 */ - void (*reserved382)(void); - Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, size_t first, size_t last); /* 383 */ - void (*reserved384)(void); + 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 */ + Tcl_UniChar (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */ + Tcl_UniChar * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */ + Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, int first, int last); /* 383 */ + 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) (void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 390 */ + 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, void *clientData, size_t stackSize, int flags); /* 393 */ - size_t (*tcl_ReadRaw) (Tcl_Channel chan, char *dst, size_t bytesToRead); /* 394 */ - size_t (*tcl_WriteRaw) (Tcl_Channel chan, const char *src, size_t srcLen); /* 395 */ + 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 */ - void (*reserved401)(void); - 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 */ - void (*reserved405)(void); - 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 */ + CONST84_RETURN 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_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_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 */ - void (*reserved419)(void); - void (*reserved420)(void); - void (*reserved421)(void); - void (*reserved422)(void); - void (*tcl_InitCustomHashTable) (Tcl_HashTable *tablePtr, int keyType, const Tcl_HashKeyType *typePtr); /* 423 */ + int (*tcl_IsChannelExisting) (CONST char *channelName); /* 418 */ + int (*tcl_UniCharNcasecmp) (CONST Tcl_UniChar *ucs, CONST Tcl_UniChar *uct, unsigned long numChars); /* 419 */ + int (*tcl_UniCharCaseMatch) (CONST Tcl_UniChar *uniStr, CONST Tcl_UniChar *uniPattern, int nocase); /* 420 */ + Tcl_HashEntry * (*tcl_FindHashEntry) (Tcl_HashTable *tablePtr, CONST char *key); /* 421 */ + Tcl_HashEntry * (*tcl_CreateHashEntry) (Tcl_HashTable *tablePtr, CONST char *key, int *newPtr); /* 422 */ + void (*tcl_InitCustomHashTable) (Tcl_HashTable *tablePtr, int keyType, Tcl_HashKeyType *typePtr); /* 423 */ void (*tcl_InitObjHashTable) (Tcl_HashTable *tablePtr); /* 424 */ - void * (*tcl_CommandTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *procPtr, void *prevClientData); /* 425 */ - int (*tcl_TraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 426 */ - void (*tcl_UntraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 427 */ - void * (*tcl_AttemptAlloc) (size_t size); /* 428 */ - void * (*tcl_AttemptDbCkalloc) (size_t size, const char *file, int line); /* 429 */ - void * (*tcl_AttemptRealloc) (void *ptr, size_t size); /* 430 */ - void * (*tcl_AttemptDbCkrealloc) (void *ptr, size_t size, const char *file, int line); /* 431 */ - int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, size_t length); /* 432 */ + 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 */ - void (*reserved435)(void); - void (*reserved436)(void); + int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, CONST char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr); /* 435 */ + 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 */ + 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 *const * (*tcl_FSFileAttrStrings) (Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); /* 453 */ + CONST char ** (*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_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 */ - void * (*tcl_FSGetInternalRep) (Tcl_Obj *pathPtr, const Tcl_Filesystem *fsPtr); /* 465 */ + Tcl_Obj * (*tcl_FSJoinToPath) (Tcl_Obj *pathPtr, int objc, Tcl_Obj *CONST objv[]); /* 464 */ + ClientData (*tcl_FSGetInternalRep) (Tcl_Obj *pathPtr, 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, void *clientData); /* 468 */ - const void * (*tcl_FSGetNativePath) (Tcl_Obj *pathPtr); /* 469 */ + Tcl_Obj * (*tcl_FSNewNativePath) (Tcl_Filesystem *fromFilesystem, ClientData clientData); /* 468 */ + CONST char * (*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) (void *clientData, const Tcl_Filesystem *fsPtr); /* 473 */ - int (*tcl_FSUnregister) (const Tcl_Filesystem *fsPtr); /* 474 */ - void * (*tcl_FSData) (const Tcl_Filesystem *fsPtr); /* 475 */ - const char * (*tcl_FSGetTranslatedStringPath) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 476 */ - const Tcl_Filesystem * (*tcl_FSGetFileSystemForPath) (Tcl_Obj *pathPtr); /* 477 */ + int (*tcl_FSRegister) (ClientData clientData, Tcl_Filesystem *fsPtr); /* 473 */ + int (*tcl_FSUnregister) (Tcl_Filesystem *fsPtr); /* 474 */ + ClientData (*tcl_FSData) (Tcl_Filesystem *fsPtr); /* 475 */ + CONST char * (*tcl_FSGetTranslatedStringPath) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 476 */ + 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, size_t count); /* 481 */ + void (*tcl_FSMountsChanged) (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, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 483 */ + 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_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 */ Tcl_WideInt (*tcl_Seek) (Tcl_Channel chan, Tcl_WideInt offset, int mode); /* 491 */ Tcl_WideInt (*tcl_Tell) (Tcl_Channel chan); /* 492 */ - Tcl_DriverWideSeekProc * (*tcl_ChannelWideSeekProc) (const Tcl_ChannelType *chanTypePtr); /* 493 */ + Tcl_DriverWideSeekProc * (*tcl_ChannelWideSeekProc) (CONST Tcl_ChannelType *chanTypePtr); /* 493 */ int (*tcl_DictObjPut) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr, Tcl_Obj *valuePtr); /* 494 */ int (*tcl_DictObjGet) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr, Tcl_Obj **valuePtrPtr); /* 495 */ int (*tcl_DictObjRemove) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr); /* 496 */ int (*tcl_DictObjSize) (Tcl_Interp *interp, Tcl_Obj *dictPtr, int *sizePtr); /* 497 */ int (*tcl_DictObjFirst) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_DictSearch *searchPtr, Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr, int *donePtr); /* 498 */ 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 */ + 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, void *clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 506 */ + Tcl_Obj * (*tcl_DbNewDictObj) (CONST char *file, int line); /* 504 */ + void (*tcl_RegisterConfig) (Tcl_Interp *interp, CONST char *pkgName, 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 */ + 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_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 */ - void (*reserved519)(void); - void (*tcl_LimitAddHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, void *clientData, Tcl_LimitHandlerDeleteProc *deleteProc); /* 520 */ - void (*tcl_LimitRemoveHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, void *clientData); /* 521 */ + int (*tcl_FSEvalFileEx) (Tcl_Interp *interp, Tcl_Obj *fileName, CONST char *encodingName); /* 518 */ + Tcl_ExitProc * (*tcl_SetExitProc) (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 */ @@ -2325,11 +4098,11 @@ int (*tcl_RestoreInterpState) (Tcl_Interp *interp, Tcl_InterpState state); /* 536 */ void (*tcl_DiscardInterpState) (Tcl_InterpState state); /* 537 */ int (*tcl_SetReturnOptions) (Tcl_Interp *interp, Tcl_Obj *options); /* 538 */ Tcl_Obj * (*tcl_GetReturnOptions) (Tcl_Interp *interp, int result); /* 539 */ int (*tcl_IsEnsemble) (Tcl_Command token); /* 540 */ - Tcl_Command (*tcl_CreateEnsemble) (Tcl_Interp *interp, const char *name, Tcl_Namespace *namespacePtr, int flags); /* 541 */ + Tcl_Command (*tcl_CreateEnsemble) (Tcl_Interp *interp, CONST char *name, Tcl_Namespace *namespacePtr, int flags); /* 541 */ Tcl_Command (*tcl_FindEnsemble) (Tcl_Interp *interp, Tcl_Obj *cmdNameObj, int flags); /* 542 */ int (*tcl_SetEnsembleSubcommandList) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj *subcmdList); /* 543 */ int (*tcl_SetEnsembleMappingDict) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj *mapDict); /* 544 */ 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 */ @@ -2336,1463 +4109,2662 @@ 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, void *clientData); /* 552 */ - void (*tcl_QueryTimeProc) (Tcl_GetTimeProc **getProc, Tcl_ScaleTimeProc **scaleProc, void **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 */ + 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) (mp_int *value); /* 555 */ + Tcl_Obj * (*tcl_DbNewBignumObj) (mp_int *value, CONST char *file, int line); /* 556 */ + void (*tcl_SetBignumObj) (Tcl_Obj *obj, mp_int *value); /* 557 */ + int (*tcl_GetBignumFromObj) (Tcl_Interp *interp, Tcl_Obj *obj, mp_int *value); /* 558 */ + int (*tcl_TakeBignumFromObj) (Tcl_Interp *interp, Tcl_Obj *obj, mp_int *value); /* 559 */ int (*tcl_TruncateChannel) (Tcl_Channel chan, Tcl_WideInt length); /* 560 */ - Tcl_DriverTruncateProc * (*tcl_ChannelTruncateProc) (const Tcl_ChannelType *chanTypePtr); /* 561 */ + 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 */ + int (*tcl_InitBignumFromDouble) (Tcl_Interp *interp, double initval, mp_int *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 */ + CONST char * (*tcl_GetEncodingNameFromEnvironment) (Tcl_DString *bufPtr); /* 572 */ + int (*tcl_PkgRequireProc) (Tcl_Interp *interp, CONST char *name, int objc, Tcl_Obj *CONST objv[], ClientData *clientDataPtr); /* 573 */ void (*tcl_AppendObjToErrorInfo) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 574 */ - void (*tcl_AppendLimitedToObj) (Tcl_Obj *objPtr, const char *bytes, size_t length, size_t 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, void *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, void *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, void *data0, void *data1, void *data2, void *data3); /* 587 */ - int (*tcl_NRCallObjProc) (Tcl_Interp *interp, Tcl_ObjCmdProc *objProc, void *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, size_t buffersize, Tcl_Obj *gzipHeaderDictObj); /* 611 */ - unsigned int (*tcl_ZlibCRC32) (unsigned int crc, const unsigned char *buf, size_t len); /* 612 */ - unsigned int (*tcl_ZlibAdler32) (unsigned int adler, const unsigned char *buf, size_t 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, size_t 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, void *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, size_t 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, size_t size); /* 644 */ - int (*tcl_GetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, size_t endValue, size_t *indexPtr); /* 645 */ - int (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 646 */ - char * (*tcl_UniCharToUtfDString) (const int *uniStr, size_t uniLength, Tcl_DString *dsPtr); /* 647 */ - int * (*tcl_UtfToUniCharDString) (const char *src, size_t length, Tcl_DString *dsPtr); /* 648 */ + 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, ...); /* 578 */ + void (*tcl_AppendPrintfToObj) (Tcl_Obj *objPtr, CONST char *format, ...); /* 579 */ + VOID *reserved580; + VOID *reserved581; + VOID *reserved582; + VOID *reserved583; + VOID *reserved584; + VOID *reserved585; + VOID *reserved586; + VOID *reserved587; + VOID *reserved588; + VOID *reserved589; + VOID *reserved590; + VOID *reserved591; + VOID *reserved592; + VOID *reserved593; + VOID *reserved594; + VOID *reserved595; + VOID *reserved596; + VOID *reserved597; + VOID *reserved598; + VOID *reserved599; + VOID *reserved600; + VOID *reserved601; + VOID *reserved602; + VOID *reserved603; + VOID *reserved604; + VOID *reserved605; + VOID *reserved606; + VOID *reserved607; + VOID *reserved608; + VOID *reserved609; + VOID *reserved610; + VOID *reserved611; + VOID *reserved612; + VOID *reserved613; + VOID *reserved614; + VOID *reserved615; + VOID *reserved616; + VOID *reserved617; + VOID *reserved618; + VOID *reserved619; + VOID *reserved620; + VOID *reserved621; + VOID *reserved622; + VOID *reserved623; + VOID *reserved624; + VOID *reserved625; + VOID *reserved626; + VOID *reserved627; + VOID *reserved628; + VOID *reserved629; + VOID *reserved630; + VOID *reserved631; + VOID *reserved632; + VOID *reserved633; + VOID *reserved634; + VOID *reserved635; + VOID *reserved636; + VOID *reserved637; + VOID *reserved638; + VOID *reserved639; + VOID *reserved640; + VOID *reserved641; + VOID *reserved642; + VOID *reserved643; + VOID *reserved644; + VOID *reserved645; + VOID *reserved646; + VOID *reserved647; + VOID *reserved648; + VOID *reserved649; + VOID *reserved650; + VOID *reserved651; + VOID *reserved652; + VOID *reserved653; + VOID *reserved654; + VOID *reserved655; + VOID *reserved656; + VOID *reserved657; + VOID *reserved658; + VOID *reserved659; + VOID *reserved660; + VOID *reserved661; + VOID *reserved662; + VOID *reserved663; + VOID *reserved664; + VOID *reserved665; + VOID *reserved666; + VOID *reserved667; + VOID *reserved668; + VOID *reserved669; + VOID *reserved670; + VOID *reserved671; + VOID *reserved672; + VOID *reserved673; + VOID *reserved674; + VOID *reserved675; + VOID *reserved676; + VOID *reserved677; + VOID *reserved678; + VOID *reserved679; + VOID *reserved680; + VOID *reserved681; + VOID *reserved682; + VOID *reserved683; + VOID *reserved684; + VOID *reserved685; + VOID *reserved686; + void (*tclUnusedStubEntry) (void); /* 687 */ } TclStubs; -extern const TclStubs *tclStubsPtr; +extern TclStubs *tclStubsPtr; #ifdef __cplusplus } #endif -#if defined(USE_TCL_STUBS) +#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) /* * Inline function declarations: */ +#ifndef Tcl_PkgProvideEx #define Tcl_PkgProvideEx \ (tclStubsPtr->tcl_PkgProvideEx) /* 0 */ +#endif +#ifndef Tcl_PkgRequireEx #define Tcl_PkgRequireEx \ (tclStubsPtr->tcl_PkgRequireEx) /* 1 */ +#endif +#ifndef Tcl_Panic #define Tcl_Panic \ (tclStubsPtr->tcl_Panic) /* 2 */ +#endif +#ifndef Tcl_Alloc #define Tcl_Alloc \ (tclStubsPtr->tcl_Alloc) /* 3 */ +#endif +#ifndef Tcl_Free #define Tcl_Free \ (tclStubsPtr->tcl_Free) /* 4 */ +#endif +#ifndef Tcl_Realloc #define Tcl_Realloc \ (tclStubsPtr->tcl_Realloc) /* 5 */ -#define Tcl_DbCkalloc \ - (tclStubsPtr->tcl_DbCkalloc) /* 6 */ -#define Tcl_DbCkfree \ - (tclStubsPtr->tcl_DbCkfree) /* 7 */ -#define Tcl_DbCkrealloc \ - (tclStubsPtr->tcl_DbCkrealloc) /* 8 */ -#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ -#define Tcl_CreateFileHandler \ - (tclStubsPtr->tcl_CreateFileHandler) /* 9 */ -#endif /* UNIX */ -#ifdef MAC_OSX_TCL /* MACOSX */ -#define Tcl_CreateFileHandler \ - (tclStubsPtr->tcl_CreateFileHandler) /* 9 */ -#endif /* MACOSX */ -#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ -#define Tcl_DeleteFileHandler \ - (tclStubsPtr->tcl_DeleteFileHandler) /* 10 */ -#endif /* UNIX */ -#ifdef MAC_OSX_TCL /* MACOSX */ -#define Tcl_DeleteFileHandler \ - (tclStubsPtr->tcl_DeleteFileHandler) /* 10 */ -#endif /* MACOSX */ +#endif +#ifndef Tcl_DbCkalloc +#define Tcl_DbCkalloc \ + (tclStubsPtr->tcl_DbCkalloc) /* 6 */ +#endif +#ifndef Tcl_DbCkfree +#define Tcl_DbCkfree \ + (tclStubsPtr->tcl_DbCkfree) /* 7 */ +#endif +#ifndef Tcl_DbCkrealloc +#define Tcl_DbCkrealloc \ + (tclStubsPtr->tcl_DbCkrealloc) /* 8 */ +#endif +#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#ifndef Tcl_CreateFileHandler +#define Tcl_CreateFileHandler \ + (tclStubsPtr->tcl_CreateFileHandler) /* 9 */ +#endif +#endif /* UNIX */ +#ifdef MAC_OSX_TCL /* MACOSX */ +#ifndef Tcl_CreateFileHandler +#define Tcl_CreateFileHandler \ + (tclStubsPtr->tcl_CreateFileHandler) /* 9 */ +#endif +#endif /* MACOSX */ +#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#ifndef Tcl_DeleteFileHandler +#define Tcl_DeleteFileHandler \ + (tclStubsPtr->tcl_DeleteFileHandler) /* 10 */ +#endif +#endif /* UNIX */ +#ifdef MAC_OSX_TCL /* MACOSX */ +#ifndef Tcl_DeleteFileHandler +#define Tcl_DeleteFileHandler \ + (tclStubsPtr->tcl_DeleteFileHandler) /* 10 */ +#endif +#endif /* MACOSX */ +#ifndef Tcl_SetTimer #define Tcl_SetTimer \ (tclStubsPtr->tcl_SetTimer) /* 11 */ +#endif +#ifndef Tcl_Sleep #define Tcl_Sleep \ (tclStubsPtr->tcl_Sleep) /* 12 */ +#endif +#ifndef Tcl_WaitForEvent #define Tcl_WaitForEvent \ (tclStubsPtr->tcl_WaitForEvent) /* 13 */ +#endif +#ifndef Tcl_AppendAllObjTypes #define Tcl_AppendAllObjTypes \ (tclStubsPtr->tcl_AppendAllObjTypes) /* 14 */ +#endif +#ifndef Tcl_AppendStringsToObj #define Tcl_AppendStringsToObj \ (tclStubsPtr->tcl_AppendStringsToObj) /* 15 */ +#endif +#ifndef Tcl_AppendToObj #define Tcl_AppendToObj \ (tclStubsPtr->tcl_AppendToObj) /* 16 */ +#endif +#ifndef Tcl_ConcatObj #define Tcl_ConcatObj \ (tclStubsPtr->tcl_ConcatObj) /* 17 */ +#endif +#ifndef Tcl_ConvertToType #define Tcl_ConvertToType \ (tclStubsPtr->tcl_ConvertToType) /* 18 */ +#endif +#ifndef Tcl_DbDecrRefCount #define Tcl_DbDecrRefCount \ (tclStubsPtr->tcl_DbDecrRefCount) /* 19 */ +#endif +#ifndef Tcl_DbIncrRefCount #define Tcl_DbIncrRefCount \ (tclStubsPtr->tcl_DbIncrRefCount) /* 20 */ +#endif +#ifndef Tcl_DbIsShared #define Tcl_DbIsShared \ (tclStubsPtr->tcl_DbIsShared) /* 21 */ -/* Slot 22 is reserved */ +#endif +#ifndef Tcl_DbNewBooleanObj +#define Tcl_DbNewBooleanObj \ + (tclStubsPtr->tcl_DbNewBooleanObj) /* 22 */ +#endif +#ifndef Tcl_DbNewByteArrayObj #define Tcl_DbNewByteArrayObj \ (tclStubsPtr->tcl_DbNewByteArrayObj) /* 23 */ +#endif +#ifndef Tcl_DbNewDoubleObj #define Tcl_DbNewDoubleObj \ (tclStubsPtr->tcl_DbNewDoubleObj) /* 24 */ +#endif +#ifndef Tcl_DbNewListObj #define Tcl_DbNewListObj \ (tclStubsPtr->tcl_DbNewListObj) /* 25 */ -/* Slot 26 is reserved */ +#endif +#ifndef Tcl_DbNewLongObj +#define Tcl_DbNewLongObj \ + (tclStubsPtr->tcl_DbNewLongObj) /* 26 */ +#endif +#ifndef Tcl_DbNewObj #define Tcl_DbNewObj \ (tclStubsPtr->tcl_DbNewObj) /* 27 */ +#endif +#ifndef Tcl_DbNewStringObj #define Tcl_DbNewStringObj \ (tclStubsPtr->tcl_DbNewStringObj) /* 28 */ +#endif +#ifndef Tcl_DuplicateObj #define Tcl_DuplicateObj \ (tclStubsPtr->tcl_DuplicateObj) /* 29 */ +#endif +#ifndef TclFreeObj #define TclFreeObj \ (tclStubsPtr->tclFreeObj) /* 30 */ +#endif +#ifndef Tcl_GetBoolean #define Tcl_GetBoolean \ (tclStubsPtr->tcl_GetBoolean) /* 31 */ +#endif +#ifndef Tcl_GetBooleanFromObj #define Tcl_GetBooleanFromObj \ (tclStubsPtr->tcl_GetBooleanFromObj) /* 32 */ +#endif +#ifndef Tcl_GetByteArrayFromObj #define Tcl_GetByteArrayFromObj \ (tclStubsPtr->tcl_GetByteArrayFromObj) /* 33 */ +#endif +#ifndef Tcl_GetDouble #define Tcl_GetDouble \ (tclStubsPtr->tcl_GetDouble) /* 34 */ +#endif +#ifndef Tcl_GetDoubleFromObj #define Tcl_GetDoubleFromObj \ (tclStubsPtr->tcl_GetDoubleFromObj) /* 35 */ -/* Slot 36 is reserved */ +#endif +#ifndef Tcl_GetIndexFromObj +#define Tcl_GetIndexFromObj \ + (tclStubsPtr->tcl_GetIndexFromObj) /* 36 */ +#endif +#ifndef Tcl_GetInt #define Tcl_GetInt \ (tclStubsPtr->tcl_GetInt) /* 37 */ +#endif +#ifndef Tcl_GetIntFromObj #define Tcl_GetIntFromObj \ (tclStubsPtr->tcl_GetIntFromObj) /* 38 */ +#endif +#ifndef Tcl_GetLongFromObj #define Tcl_GetLongFromObj \ (tclStubsPtr->tcl_GetLongFromObj) /* 39 */ +#endif +#ifndef Tcl_GetObjType #define Tcl_GetObjType \ (tclStubsPtr->tcl_GetObjType) /* 40 */ +#endif +#ifndef Tcl_GetStringFromObj #define Tcl_GetStringFromObj \ (tclStubsPtr->tcl_GetStringFromObj) /* 41 */ +#endif +#ifndef Tcl_InvalidateStringRep #define Tcl_InvalidateStringRep \ (tclStubsPtr->tcl_InvalidateStringRep) /* 42 */ +#endif +#ifndef Tcl_ListObjAppendList #define Tcl_ListObjAppendList \ (tclStubsPtr->tcl_ListObjAppendList) /* 43 */ +#endif +#ifndef Tcl_ListObjAppendElement #define Tcl_ListObjAppendElement \ (tclStubsPtr->tcl_ListObjAppendElement) /* 44 */ +#endif +#ifndef Tcl_ListObjGetElements #define Tcl_ListObjGetElements \ (tclStubsPtr->tcl_ListObjGetElements) /* 45 */ +#endif +#ifndef Tcl_ListObjIndex #define Tcl_ListObjIndex \ (tclStubsPtr->tcl_ListObjIndex) /* 46 */ +#endif +#ifndef Tcl_ListObjLength #define Tcl_ListObjLength \ (tclStubsPtr->tcl_ListObjLength) /* 47 */ +#endif +#ifndef Tcl_ListObjReplace #define Tcl_ListObjReplace \ (tclStubsPtr->tcl_ListObjReplace) /* 48 */ -/* Slot 49 is reserved */ +#endif +#ifndef Tcl_NewBooleanObj +#define Tcl_NewBooleanObj \ + (tclStubsPtr->tcl_NewBooleanObj) /* 49 */ +#endif +#ifndef Tcl_NewByteArrayObj #define Tcl_NewByteArrayObj \ (tclStubsPtr->tcl_NewByteArrayObj) /* 50 */ +#endif +#ifndef Tcl_NewDoubleObj #define Tcl_NewDoubleObj \ (tclStubsPtr->tcl_NewDoubleObj) /* 51 */ -/* Slot 52 is reserved */ +#endif +#ifndef Tcl_NewIntObj +#define Tcl_NewIntObj \ + (tclStubsPtr->tcl_NewIntObj) /* 52 */ +#endif +#ifndef Tcl_NewListObj #define Tcl_NewListObj \ (tclStubsPtr->tcl_NewListObj) /* 53 */ -/* Slot 54 is reserved */ +#endif +#ifndef Tcl_NewLongObj +#define Tcl_NewLongObj \ + (tclStubsPtr->tcl_NewLongObj) /* 54 */ +#endif +#ifndef Tcl_NewObj #define Tcl_NewObj \ (tclStubsPtr->tcl_NewObj) /* 55 */ +#endif +#ifndef Tcl_NewStringObj #define Tcl_NewStringObj \ (tclStubsPtr->tcl_NewStringObj) /* 56 */ -/* Slot 57 is reserved */ +#endif +#ifndef Tcl_SetBooleanObj +#define Tcl_SetBooleanObj \ + (tclStubsPtr->tcl_SetBooleanObj) /* 57 */ +#endif +#ifndef Tcl_SetByteArrayLength #define Tcl_SetByteArrayLength \ (tclStubsPtr->tcl_SetByteArrayLength) /* 58 */ +#endif +#ifndef Tcl_SetByteArrayObj #define Tcl_SetByteArrayObj \ (tclStubsPtr->tcl_SetByteArrayObj) /* 59 */ +#endif +#ifndef Tcl_SetDoubleObj #define Tcl_SetDoubleObj \ (tclStubsPtr->tcl_SetDoubleObj) /* 60 */ -/* Slot 61 is reserved */ +#endif +#ifndef Tcl_SetIntObj +#define Tcl_SetIntObj \ + (tclStubsPtr->tcl_SetIntObj) /* 61 */ +#endif +#ifndef Tcl_SetListObj #define Tcl_SetListObj \ (tclStubsPtr->tcl_SetListObj) /* 62 */ -/* Slot 63 is reserved */ +#endif +#ifndef Tcl_SetLongObj +#define Tcl_SetLongObj \ + (tclStubsPtr->tcl_SetLongObj) /* 63 */ +#endif +#ifndef Tcl_SetObjLength #define Tcl_SetObjLength \ (tclStubsPtr->tcl_SetObjLength) /* 64 */ +#endif +#ifndef Tcl_SetStringObj #define Tcl_SetStringObj \ (tclStubsPtr->tcl_SetStringObj) /* 65 */ -/* Slot 66 is reserved */ -/* Slot 67 is reserved */ +#endif +#ifndef Tcl_AddErrorInfo +#define Tcl_AddErrorInfo \ + (tclStubsPtr->tcl_AddErrorInfo) /* 66 */ +#endif +#ifndef Tcl_AddObjErrorInfo +#define Tcl_AddObjErrorInfo \ + (tclStubsPtr->tcl_AddObjErrorInfo) /* 67 */ +#endif +#ifndef Tcl_AllowExceptions #define Tcl_AllowExceptions \ (tclStubsPtr->tcl_AllowExceptions) /* 68 */ +#endif +#ifndef Tcl_AppendElement #define Tcl_AppendElement \ (tclStubsPtr->tcl_AppendElement) /* 69 */ +#endif +#ifndef Tcl_AppendResult #define Tcl_AppendResult \ (tclStubsPtr->tcl_AppendResult) /* 70 */ +#endif +#ifndef Tcl_AsyncCreate #define Tcl_AsyncCreate \ (tclStubsPtr->tcl_AsyncCreate) /* 71 */ +#endif +#ifndef Tcl_AsyncDelete #define Tcl_AsyncDelete \ (tclStubsPtr->tcl_AsyncDelete) /* 72 */ +#endif +#ifndef Tcl_AsyncInvoke #define Tcl_AsyncInvoke \ (tclStubsPtr->tcl_AsyncInvoke) /* 73 */ +#endif +#ifndef Tcl_AsyncMark #define Tcl_AsyncMark \ (tclStubsPtr->tcl_AsyncMark) /* 74 */ +#endif +#ifndef Tcl_AsyncReady #define Tcl_AsyncReady \ (tclStubsPtr->tcl_AsyncReady) /* 75 */ -/* Slot 76 is reserved */ -/* Slot 77 is reserved */ +#endif +#ifndef Tcl_BackgroundError +#define Tcl_BackgroundError \ + (tclStubsPtr->tcl_BackgroundError) /* 76 */ +#endif +#ifndef Tcl_Backslash +#define Tcl_Backslash \ + (tclStubsPtr->tcl_Backslash) /* 77 */ +#endif +#ifndef Tcl_BadChannelOption #define Tcl_BadChannelOption \ (tclStubsPtr->tcl_BadChannelOption) /* 78 */ +#endif +#ifndef Tcl_CallWhenDeleted #define Tcl_CallWhenDeleted \ (tclStubsPtr->tcl_CallWhenDeleted) /* 79 */ +#endif +#ifndef Tcl_CancelIdleCall #define Tcl_CancelIdleCall \ (tclStubsPtr->tcl_CancelIdleCall) /* 80 */ -/* Slot 81 is reserved */ +#endif +#ifndef Tcl_Close +#define Tcl_Close \ + (tclStubsPtr->tcl_Close) /* 81 */ +#endif +#ifndef Tcl_CommandComplete #define Tcl_CommandComplete \ (tclStubsPtr->tcl_CommandComplete) /* 82 */ +#endif +#ifndef Tcl_Concat #define Tcl_Concat \ (tclStubsPtr->tcl_Concat) /* 83 */ +#endif +#ifndef Tcl_ConvertElement #define Tcl_ConvertElement \ (tclStubsPtr->tcl_ConvertElement) /* 84 */ +#endif +#ifndef Tcl_ConvertCountedElement #define Tcl_ConvertCountedElement \ (tclStubsPtr->tcl_ConvertCountedElement) /* 85 */ +#endif +#ifndef Tcl_CreateAlias #define Tcl_CreateAlias \ (tclStubsPtr->tcl_CreateAlias) /* 86 */ +#endif +#ifndef Tcl_CreateAliasObj #define Tcl_CreateAliasObj \ (tclStubsPtr->tcl_CreateAliasObj) /* 87 */ +#endif +#ifndef Tcl_CreateChannel #define Tcl_CreateChannel \ (tclStubsPtr->tcl_CreateChannel) /* 88 */ +#endif +#ifndef Tcl_CreateChannelHandler #define Tcl_CreateChannelHandler \ (tclStubsPtr->tcl_CreateChannelHandler) /* 89 */ +#endif +#ifndef Tcl_CreateCloseHandler #define Tcl_CreateCloseHandler \ (tclStubsPtr->tcl_CreateCloseHandler) /* 90 */ +#endif +#ifndef Tcl_CreateCommand #define Tcl_CreateCommand \ (tclStubsPtr->tcl_CreateCommand) /* 91 */ +#endif +#ifndef Tcl_CreateEventSource #define Tcl_CreateEventSource \ (tclStubsPtr->tcl_CreateEventSource) /* 92 */ +#endif +#ifndef Tcl_CreateExitHandler #define Tcl_CreateExitHandler \ (tclStubsPtr->tcl_CreateExitHandler) /* 93 */ +#endif +#ifndef Tcl_CreateInterp #define Tcl_CreateInterp \ (tclStubsPtr->tcl_CreateInterp) /* 94 */ -/* Slot 95 is reserved */ +#endif +#ifndef Tcl_CreateMathFunc +#define Tcl_CreateMathFunc \ + (tclStubsPtr->tcl_CreateMathFunc) /* 95 */ +#endif +#ifndef Tcl_CreateObjCommand #define Tcl_CreateObjCommand \ (tclStubsPtr->tcl_CreateObjCommand) /* 96 */ -#define Tcl_CreateChild \ - (tclStubsPtr->tcl_CreateChild) /* 97 */ +#endif +#ifndef Tcl_CreateSlave +#define Tcl_CreateSlave \ + (tclStubsPtr->tcl_CreateSlave) /* 97 */ +#endif +#ifndef Tcl_CreateTimerHandler #define Tcl_CreateTimerHandler \ (tclStubsPtr->tcl_CreateTimerHandler) /* 98 */ +#endif +#ifndef Tcl_CreateTrace #define Tcl_CreateTrace \ (tclStubsPtr->tcl_CreateTrace) /* 99 */ +#endif +#ifndef Tcl_DeleteAssocData #define Tcl_DeleteAssocData \ (tclStubsPtr->tcl_DeleteAssocData) /* 100 */ +#endif +#ifndef Tcl_DeleteChannelHandler #define Tcl_DeleteChannelHandler \ (tclStubsPtr->tcl_DeleteChannelHandler) /* 101 */ +#endif +#ifndef Tcl_DeleteCloseHandler #define Tcl_DeleteCloseHandler \ (tclStubsPtr->tcl_DeleteCloseHandler) /* 102 */ +#endif +#ifndef Tcl_DeleteCommand #define Tcl_DeleteCommand \ (tclStubsPtr->tcl_DeleteCommand) /* 103 */ +#endif +#ifndef Tcl_DeleteCommandFromToken #define Tcl_DeleteCommandFromToken \ (tclStubsPtr->tcl_DeleteCommandFromToken) /* 104 */ +#endif +#ifndef Tcl_DeleteEvents #define Tcl_DeleteEvents \ (tclStubsPtr->tcl_DeleteEvents) /* 105 */ +#endif +#ifndef Tcl_DeleteEventSource #define Tcl_DeleteEventSource \ (tclStubsPtr->tcl_DeleteEventSource) /* 106 */ +#endif +#ifndef Tcl_DeleteExitHandler #define Tcl_DeleteExitHandler \ (tclStubsPtr->tcl_DeleteExitHandler) /* 107 */ +#endif +#ifndef Tcl_DeleteHashEntry #define Tcl_DeleteHashEntry \ (tclStubsPtr->tcl_DeleteHashEntry) /* 108 */ +#endif +#ifndef Tcl_DeleteHashTable #define Tcl_DeleteHashTable \ (tclStubsPtr->tcl_DeleteHashTable) /* 109 */ +#endif +#ifndef Tcl_DeleteInterp #define Tcl_DeleteInterp \ (tclStubsPtr->tcl_DeleteInterp) /* 110 */ +#endif +#ifndef Tcl_DetachPids #define Tcl_DetachPids \ (tclStubsPtr->tcl_DetachPids) /* 111 */ +#endif +#ifndef Tcl_DeleteTimerHandler #define Tcl_DeleteTimerHandler \ (tclStubsPtr->tcl_DeleteTimerHandler) /* 112 */ +#endif +#ifndef Tcl_DeleteTrace #define Tcl_DeleteTrace \ (tclStubsPtr->tcl_DeleteTrace) /* 113 */ +#endif +#ifndef Tcl_DontCallWhenDeleted #define Tcl_DontCallWhenDeleted \ (tclStubsPtr->tcl_DontCallWhenDeleted) /* 114 */ +#endif +#ifndef Tcl_DoOneEvent #define Tcl_DoOneEvent \ (tclStubsPtr->tcl_DoOneEvent) /* 115 */ +#endif +#ifndef Tcl_DoWhenIdle #define Tcl_DoWhenIdle \ (tclStubsPtr->tcl_DoWhenIdle) /* 116 */ +#endif +#ifndef Tcl_DStringAppend #define Tcl_DStringAppend \ (tclStubsPtr->tcl_DStringAppend) /* 117 */ +#endif +#ifndef Tcl_DStringAppendElement #define Tcl_DStringAppendElement \ (tclStubsPtr->tcl_DStringAppendElement) /* 118 */ +#endif +#ifndef Tcl_DStringEndSublist #define Tcl_DStringEndSublist \ (tclStubsPtr->tcl_DStringEndSublist) /* 119 */ +#endif +#ifndef Tcl_DStringFree #define Tcl_DStringFree \ (tclStubsPtr->tcl_DStringFree) /* 120 */ +#endif +#ifndef Tcl_DStringGetResult #define Tcl_DStringGetResult \ (tclStubsPtr->tcl_DStringGetResult) /* 121 */ +#endif +#ifndef Tcl_DStringInit #define Tcl_DStringInit \ (tclStubsPtr->tcl_DStringInit) /* 122 */ +#endif +#ifndef Tcl_DStringResult #define Tcl_DStringResult \ (tclStubsPtr->tcl_DStringResult) /* 123 */ +#endif +#ifndef Tcl_DStringSetLength #define Tcl_DStringSetLength \ (tclStubsPtr->tcl_DStringSetLength) /* 124 */ +#endif +#ifndef Tcl_DStringStartSublist #define Tcl_DStringStartSublist \ (tclStubsPtr->tcl_DStringStartSublist) /* 125 */ +#endif +#ifndef Tcl_Eof #define Tcl_Eof \ (tclStubsPtr->tcl_Eof) /* 126 */ +#endif +#ifndef Tcl_ErrnoId #define Tcl_ErrnoId \ (tclStubsPtr->tcl_ErrnoId) /* 127 */ +#endif +#ifndef Tcl_ErrnoMsg #define Tcl_ErrnoMsg \ (tclStubsPtr->tcl_ErrnoMsg) /* 128 */ -/* Slot 129 is reserved */ +#endif +#ifndef Tcl_Eval +#define Tcl_Eval \ + (tclStubsPtr->tcl_Eval) /* 129 */ +#endif +#ifndef Tcl_EvalFile #define Tcl_EvalFile \ (tclStubsPtr->tcl_EvalFile) /* 130 */ -/* Slot 131 is reserved */ +#endif +#ifndef Tcl_EvalObj +#define Tcl_EvalObj \ + (tclStubsPtr->tcl_EvalObj) /* 131 */ +#endif +#ifndef Tcl_EventuallyFree #define Tcl_EventuallyFree \ (tclStubsPtr->tcl_EventuallyFree) /* 132 */ +#endif +#ifndef Tcl_Exit #define Tcl_Exit \ (tclStubsPtr->tcl_Exit) /* 133 */ +#endif +#ifndef Tcl_ExposeCommand #define Tcl_ExposeCommand \ (tclStubsPtr->tcl_ExposeCommand) /* 134 */ +#endif +#ifndef Tcl_ExprBoolean #define Tcl_ExprBoolean \ (tclStubsPtr->tcl_ExprBoolean) /* 135 */ +#endif +#ifndef Tcl_ExprBooleanObj #define Tcl_ExprBooleanObj \ (tclStubsPtr->tcl_ExprBooleanObj) /* 136 */ +#endif +#ifndef Tcl_ExprDouble #define Tcl_ExprDouble \ (tclStubsPtr->tcl_ExprDouble) /* 137 */ +#endif +#ifndef Tcl_ExprDoubleObj #define Tcl_ExprDoubleObj \ (tclStubsPtr->tcl_ExprDoubleObj) /* 138 */ +#endif +#ifndef Tcl_ExprLong #define Tcl_ExprLong \ (tclStubsPtr->tcl_ExprLong) /* 139 */ +#endif +#ifndef Tcl_ExprLongObj #define Tcl_ExprLongObj \ (tclStubsPtr->tcl_ExprLongObj) /* 140 */ +#endif +#ifndef Tcl_ExprObj #define Tcl_ExprObj \ (tclStubsPtr->tcl_ExprObj) /* 141 */ +#endif +#ifndef Tcl_ExprString #define Tcl_ExprString \ (tclStubsPtr->tcl_ExprString) /* 142 */ +#endif +#ifndef Tcl_Finalize #define Tcl_Finalize \ (tclStubsPtr->tcl_Finalize) /* 143 */ -/* Slot 144 is reserved */ +#endif +#ifndef Tcl_FindExecutable +#define Tcl_FindExecutable \ + (tclStubsPtr->tcl_FindExecutable) /* 144 */ +#endif +#ifndef Tcl_FirstHashEntry #define Tcl_FirstHashEntry \ (tclStubsPtr->tcl_FirstHashEntry) /* 145 */ +#endif +#ifndef Tcl_Flush #define Tcl_Flush \ (tclStubsPtr->tcl_Flush) /* 146 */ -/* Slot 147 is reserved */ +#endif +#ifndef Tcl_FreeResult +#define Tcl_FreeResult \ + (tclStubsPtr->tcl_FreeResult) /* 147 */ +#endif +#ifndef Tcl_GetAlias #define Tcl_GetAlias \ (tclStubsPtr->tcl_GetAlias) /* 148 */ +#endif +#ifndef Tcl_GetAliasObj #define Tcl_GetAliasObj \ (tclStubsPtr->tcl_GetAliasObj) /* 149 */ +#endif +#ifndef Tcl_GetAssocData #define Tcl_GetAssocData \ (tclStubsPtr->tcl_GetAssocData) /* 150 */ +#endif +#ifndef Tcl_GetChannel #define Tcl_GetChannel \ (tclStubsPtr->tcl_GetChannel) /* 151 */ +#endif +#ifndef Tcl_GetChannelBufferSize #define Tcl_GetChannelBufferSize \ (tclStubsPtr->tcl_GetChannelBufferSize) /* 152 */ +#endif +#ifndef Tcl_GetChannelHandle #define Tcl_GetChannelHandle \ (tclStubsPtr->tcl_GetChannelHandle) /* 153 */ +#endif +#ifndef Tcl_GetChannelInstanceData #define Tcl_GetChannelInstanceData \ (tclStubsPtr->tcl_GetChannelInstanceData) /* 154 */ +#endif +#ifndef Tcl_GetChannelMode #define Tcl_GetChannelMode \ (tclStubsPtr->tcl_GetChannelMode) /* 155 */ +#endif +#ifndef Tcl_GetChannelName #define Tcl_GetChannelName \ (tclStubsPtr->tcl_GetChannelName) /* 156 */ +#endif +#ifndef Tcl_GetChannelOption #define Tcl_GetChannelOption \ (tclStubsPtr->tcl_GetChannelOption) /* 157 */ +#endif +#ifndef Tcl_GetChannelType #define Tcl_GetChannelType \ (tclStubsPtr->tcl_GetChannelType) /* 158 */ +#endif +#ifndef Tcl_GetCommandInfo #define Tcl_GetCommandInfo \ (tclStubsPtr->tcl_GetCommandInfo) /* 159 */ +#endif +#ifndef Tcl_GetCommandName #define Tcl_GetCommandName \ (tclStubsPtr->tcl_GetCommandName) /* 160 */ +#endif +#ifndef Tcl_GetErrno #define Tcl_GetErrno \ (tclStubsPtr->tcl_GetErrno) /* 161 */ +#endif +#ifndef Tcl_GetHostName #define Tcl_GetHostName \ (tclStubsPtr->tcl_GetHostName) /* 162 */ +#endif +#ifndef Tcl_GetInterpPath #define Tcl_GetInterpPath \ (tclStubsPtr->tcl_GetInterpPath) /* 163 */ -#define Tcl_GetParent \ - (tclStubsPtr->tcl_GetParent) /* 164 */ +#endif +#ifndef Tcl_GetMaster +#define Tcl_GetMaster \ + (tclStubsPtr->tcl_GetMaster) /* 164 */ +#endif +#ifndef Tcl_GetNameOfExecutable #define Tcl_GetNameOfExecutable \ (tclStubsPtr->tcl_GetNameOfExecutable) /* 165 */ +#endif +#ifndef Tcl_GetObjResult #define Tcl_GetObjResult \ (tclStubsPtr->tcl_GetObjResult) /* 166 */ -#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ +#endif +#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#ifndef Tcl_GetOpenFile #define Tcl_GetOpenFile \ (tclStubsPtr->tcl_GetOpenFile) /* 167 */ +#endif #endif /* UNIX */ #ifdef MAC_OSX_TCL /* MACOSX */ +#ifndef Tcl_GetOpenFile #define Tcl_GetOpenFile \ (tclStubsPtr->tcl_GetOpenFile) /* 167 */ +#endif #endif /* MACOSX */ +#ifndef Tcl_GetPathType #define Tcl_GetPathType \ (tclStubsPtr->tcl_GetPathType) /* 168 */ +#endif +#ifndef Tcl_Gets #define Tcl_Gets \ (tclStubsPtr->tcl_Gets) /* 169 */ +#endif +#ifndef Tcl_GetsObj #define Tcl_GetsObj \ (tclStubsPtr->tcl_GetsObj) /* 170 */ +#endif +#ifndef Tcl_GetServiceMode #define Tcl_GetServiceMode \ (tclStubsPtr->tcl_GetServiceMode) /* 171 */ -#define Tcl_GetChild \ - (tclStubsPtr->tcl_GetChild) /* 172 */ +#endif +#ifndef Tcl_GetSlave +#define Tcl_GetSlave \ + (tclStubsPtr->tcl_GetSlave) /* 172 */ +#endif +#ifndef Tcl_GetStdChannel #define Tcl_GetStdChannel \ (tclStubsPtr->tcl_GetStdChannel) /* 173 */ -/* Slot 174 is reserved */ -/* Slot 175 is reserved */ +#endif +#ifndef Tcl_GetStringResult +#define Tcl_GetStringResult \ + (tclStubsPtr->tcl_GetStringResult) /* 174 */ +#endif +#ifndef Tcl_GetVar +#define Tcl_GetVar \ + (tclStubsPtr->tcl_GetVar) /* 175 */ +#endif +#ifndef Tcl_GetVar2 #define Tcl_GetVar2 \ (tclStubsPtr->tcl_GetVar2) /* 176 */ -/* Slot 177 is reserved */ -/* Slot 178 is reserved */ +#endif +#ifndef Tcl_GlobalEval +#define Tcl_GlobalEval \ + (tclStubsPtr->tcl_GlobalEval) /* 177 */ +#endif +#ifndef Tcl_GlobalEvalObj +#define Tcl_GlobalEvalObj \ + (tclStubsPtr->tcl_GlobalEvalObj) /* 178 */ +#endif +#ifndef Tcl_HideCommand #define Tcl_HideCommand \ (tclStubsPtr->tcl_HideCommand) /* 179 */ +#endif +#ifndef Tcl_Init #define Tcl_Init \ (tclStubsPtr->tcl_Init) /* 180 */ +#endif +#ifndef Tcl_InitHashTable #define Tcl_InitHashTable \ (tclStubsPtr->tcl_InitHashTable) /* 181 */ +#endif +#ifndef Tcl_InputBlocked #define Tcl_InputBlocked \ (tclStubsPtr->tcl_InputBlocked) /* 182 */ +#endif +#ifndef Tcl_InputBuffered #define Tcl_InputBuffered \ (tclStubsPtr->tcl_InputBuffered) /* 183 */ +#endif +#ifndef Tcl_InterpDeleted #define Tcl_InterpDeleted \ (tclStubsPtr->tcl_InterpDeleted) /* 184 */ +#endif +#ifndef Tcl_IsSafe #define Tcl_IsSafe \ (tclStubsPtr->tcl_IsSafe) /* 185 */ +#endif +#ifndef Tcl_JoinPath #define Tcl_JoinPath \ (tclStubsPtr->tcl_JoinPath) /* 186 */ +#endif +#ifndef Tcl_LinkVar #define Tcl_LinkVar \ (tclStubsPtr->tcl_LinkVar) /* 187 */ +#endif /* Slot 188 is reserved */ +#ifndef Tcl_MakeFileChannel #define Tcl_MakeFileChannel \ (tclStubsPtr->tcl_MakeFileChannel) /* 189 */ +#endif +#ifndef Tcl_MakeSafe #define Tcl_MakeSafe \ (tclStubsPtr->tcl_MakeSafe) /* 190 */ +#endif +#ifndef Tcl_MakeTcpClientChannel #define Tcl_MakeTcpClientChannel \ (tclStubsPtr->tcl_MakeTcpClientChannel) /* 191 */ +#endif +#ifndef Tcl_Merge #define Tcl_Merge \ (tclStubsPtr->tcl_Merge) /* 192 */ +#endif +#ifndef Tcl_NextHashEntry #define Tcl_NextHashEntry \ (tclStubsPtr->tcl_NextHashEntry) /* 193 */ +#endif +#ifndef Tcl_NotifyChannel #define Tcl_NotifyChannel \ (tclStubsPtr->tcl_NotifyChannel) /* 194 */ +#endif +#ifndef Tcl_ObjGetVar2 #define Tcl_ObjGetVar2 \ (tclStubsPtr->tcl_ObjGetVar2) /* 195 */ +#endif +#ifndef Tcl_ObjSetVar2 #define Tcl_ObjSetVar2 \ (tclStubsPtr->tcl_ObjSetVar2) /* 196 */ +#endif +#ifndef Tcl_OpenCommandChannel #define Tcl_OpenCommandChannel \ (tclStubsPtr->tcl_OpenCommandChannel) /* 197 */ +#endif +#ifndef Tcl_OpenFileChannel #define Tcl_OpenFileChannel \ (tclStubsPtr->tcl_OpenFileChannel) /* 198 */ +#endif +#ifndef Tcl_OpenTcpClient #define Tcl_OpenTcpClient \ (tclStubsPtr->tcl_OpenTcpClient) /* 199 */ +#endif +#ifndef Tcl_OpenTcpServer #define Tcl_OpenTcpServer \ (tclStubsPtr->tcl_OpenTcpServer) /* 200 */ +#endif +#ifndef Tcl_Preserve #define Tcl_Preserve \ (tclStubsPtr->tcl_Preserve) /* 201 */ +#endif +#ifndef Tcl_PrintDouble #define Tcl_PrintDouble \ (tclStubsPtr->tcl_PrintDouble) /* 202 */ +#endif +#ifndef Tcl_PutEnv #define Tcl_PutEnv \ (tclStubsPtr->tcl_PutEnv) /* 203 */ +#endif +#ifndef Tcl_PosixError #define Tcl_PosixError \ (tclStubsPtr->tcl_PosixError) /* 204 */ +#endif +#ifndef Tcl_QueueEvent #define Tcl_QueueEvent \ (tclStubsPtr->tcl_QueueEvent) /* 205 */ +#endif +#ifndef Tcl_Read #define Tcl_Read \ (tclStubsPtr->tcl_Read) /* 206 */ +#endif +#ifndef Tcl_ReapDetachedProcs #define Tcl_ReapDetachedProcs \ (tclStubsPtr->tcl_ReapDetachedProcs) /* 207 */ +#endif +#ifndef Tcl_RecordAndEval #define Tcl_RecordAndEval \ (tclStubsPtr->tcl_RecordAndEval) /* 208 */ +#endif +#ifndef Tcl_RecordAndEvalObj #define Tcl_RecordAndEvalObj \ (tclStubsPtr->tcl_RecordAndEvalObj) /* 209 */ +#endif +#ifndef Tcl_RegisterChannel #define Tcl_RegisterChannel \ (tclStubsPtr->tcl_RegisterChannel) /* 210 */ +#endif +#ifndef Tcl_RegisterObjType #define Tcl_RegisterObjType \ (tclStubsPtr->tcl_RegisterObjType) /* 211 */ +#endif +#ifndef Tcl_RegExpCompile #define Tcl_RegExpCompile \ (tclStubsPtr->tcl_RegExpCompile) /* 212 */ +#endif +#ifndef Tcl_RegExpExec #define Tcl_RegExpExec \ (tclStubsPtr->tcl_RegExpExec) /* 213 */ +#endif +#ifndef Tcl_RegExpMatch #define Tcl_RegExpMatch \ (tclStubsPtr->tcl_RegExpMatch) /* 214 */ +#endif +#ifndef Tcl_RegExpRange #define Tcl_RegExpRange \ (tclStubsPtr->tcl_RegExpRange) /* 215 */ +#endif +#ifndef Tcl_Release #define Tcl_Release \ (tclStubsPtr->tcl_Release) /* 216 */ +#endif +#ifndef Tcl_ResetResult #define Tcl_ResetResult \ (tclStubsPtr->tcl_ResetResult) /* 217 */ +#endif +#ifndef Tcl_ScanElement #define Tcl_ScanElement \ (tclStubsPtr->tcl_ScanElement) /* 218 */ +#endif +#ifndef Tcl_ScanCountedElement #define Tcl_ScanCountedElement \ (tclStubsPtr->tcl_ScanCountedElement) /* 219 */ -/* Slot 220 is reserved */ +#endif +#ifndef Tcl_SeekOld +#define Tcl_SeekOld \ + (tclStubsPtr->tcl_SeekOld) /* 220 */ +#endif +#ifndef Tcl_ServiceAll #define Tcl_ServiceAll \ (tclStubsPtr->tcl_ServiceAll) /* 221 */ +#endif +#ifndef Tcl_ServiceEvent #define Tcl_ServiceEvent \ (tclStubsPtr->tcl_ServiceEvent) /* 222 */ +#endif +#ifndef Tcl_SetAssocData #define Tcl_SetAssocData \ (tclStubsPtr->tcl_SetAssocData) /* 223 */ +#endif +#ifndef Tcl_SetChannelBufferSize #define Tcl_SetChannelBufferSize \ (tclStubsPtr->tcl_SetChannelBufferSize) /* 224 */ +#endif +#ifndef Tcl_SetChannelOption #define Tcl_SetChannelOption \ (tclStubsPtr->tcl_SetChannelOption) /* 225 */ +#endif +#ifndef Tcl_SetCommandInfo #define Tcl_SetCommandInfo \ (tclStubsPtr->tcl_SetCommandInfo) /* 226 */ +#endif +#ifndef Tcl_SetErrno #define Tcl_SetErrno \ (tclStubsPtr->tcl_SetErrno) /* 227 */ +#endif +#ifndef Tcl_SetErrorCode #define Tcl_SetErrorCode \ (tclStubsPtr->tcl_SetErrorCode) /* 228 */ +#endif +#ifndef Tcl_SetMaxBlockTime #define Tcl_SetMaxBlockTime \ (tclStubsPtr->tcl_SetMaxBlockTime) /* 229 */ -/* Slot 230 is reserved */ +#endif +#ifndef Tcl_SetPanicProc +#define Tcl_SetPanicProc \ + (tclStubsPtr->tcl_SetPanicProc) /* 230 */ +#endif +#ifndef Tcl_SetRecursionLimit #define Tcl_SetRecursionLimit \ (tclStubsPtr->tcl_SetRecursionLimit) /* 231 */ -/* Slot 232 is reserved */ +#endif +#ifndef Tcl_SetResult +#define Tcl_SetResult \ + (tclStubsPtr->tcl_SetResult) /* 232 */ +#endif +#ifndef Tcl_SetServiceMode #define Tcl_SetServiceMode \ (tclStubsPtr->tcl_SetServiceMode) /* 233 */ +#endif +#ifndef Tcl_SetObjErrorCode #define Tcl_SetObjErrorCode \ (tclStubsPtr->tcl_SetObjErrorCode) /* 234 */ +#endif +#ifndef Tcl_SetObjResult #define Tcl_SetObjResult \ (tclStubsPtr->tcl_SetObjResult) /* 235 */ +#endif +#ifndef Tcl_SetStdChannel #define Tcl_SetStdChannel \ (tclStubsPtr->tcl_SetStdChannel) /* 236 */ -/* Slot 237 is reserved */ +#endif +#ifndef Tcl_SetVar +#define Tcl_SetVar \ + (tclStubsPtr->tcl_SetVar) /* 237 */ +#endif +#ifndef Tcl_SetVar2 #define Tcl_SetVar2 \ (tclStubsPtr->tcl_SetVar2) /* 238 */ +#endif +#ifndef Tcl_SignalId #define Tcl_SignalId \ (tclStubsPtr->tcl_SignalId) /* 239 */ +#endif +#ifndef Tcl_SignalMsg #define Tcl_SignalMsg \ (tclStubsPtr->tcl_SignalMsg) /* 240 */ +#endif +#ifndef Tcl_SourceRCFile #define Tcl_SourceRCFile \ (tclStubsPtr->tcl_SourceRCFile) /* 241 */ +#endif +#ifndef Tcl_SplitList #define Tcl_SplitList \ (tclStubsPtr->tcl_SplitList) /* 242 */ +#endif +#ifndef Tcl_SplitPath #define Tcl_SplitPath \ (tclStubsPtr->tcl_SplitPath) /* 243 */ -/* Slot 244 is reserved */ -/* Slot 245 is reserved */ -/* Slot 246 is reserved */ -/* Slot 247 is reserved */ +#endif +#ifndef Tcl_StaticPackage +#define Tcl_StaticPackage \ + (tclStubsPtr->tcl_StaticPackage) /* 244 */ +#endif +#ifndef Tcl_StringMatch +#define Tcl_StringMatch \ + (tclStubsPtr->tcl_StringMatch) /* 245 */ +#endif +#ifndef Tcl_TellOld +#define Tcl_TellOld \ + (tclStubsPtr->tcl_TellOld) /* 246 */ +#endif +#ifndef Tcl_TraceVar +#define Tcl_TraceVar \ + (tclStubsPtr->tcl_TraceVar) /* 247 */ +#endif +#ifndef Tcl_TraceVar2 #define Tcl_TraceVar2 \ (tclStubsPtr->tcl_TraceVar2) /* 248 */ +#endif +#ifndef Tcl_TranslateFileName #define Tcl_TranslateFileName \ (tclStubsPtr->tcl_TranslateFileName) /* 249 */ +#endif +#ifndef Tcl_Ungets #define Tcl_Ungets \ (tclStubsPtr->tcl_Ungets) /* 250 */ +#endif +#ifndef Tcl_UnlinkVar #define Tcl_UnlinkVar \ (tclStubsPtr->tcl_UnlinkVar) /* 251 */ +#endif +#ifndef Tcl_UnregisterChannel #define Tcl_UnregisterChannel \ (tclStubsPtr->tcl_UnregisterChannel) /* 252 */ -/* Slot 253 is reserved */ +#endif +#ifndef Tcl_UnsetVar +#define Tcl_UnsetVar \ + (tclStubsPtr->tcl_UnsetVar) /* 253 */ +#endif +#ifndef Tcl_UnsetVar2 #define Tcl_UnsetVar2 \ (tclStubsPtr->tcl_UnsetVar2) /* 254 */ -/* Slot 255 is reserved */ +#endif +#ifndef Tcl_UntraceVar +#define Tcl_UntraceVar \ + (tclStubsPtr->tcl_UntraceVar) /* 255 */ +#endif +#ifndef Tcl_UntraceVar2 #define Tcl_UntraceVar2 \ (tclStubsPtr->tcl_UntraceVar2) /* 256 */ +#endif +#ifndef Tcl_UpdateLinkedVar #define Tcl_UpdateLinkedVar \ (tclStubsPtr->tcl_UpdateLinkedVar) /* 257 */ -/* Slot 258 is reserved */ +#endif +#ifndef Tcl_UpVar +#define Tcl_UpVar \ + (tclStubsPtr->tcl_UpVar) /* 258 */ +#endif +#ifndef Tcl_UpVar2 #define Tcl_UpVar2 \ (tclStubsPtr->tcl_UpVar2) /* 259 */ +#endif +#ifndef Tcl_VarEval #define Tcl_VarEval \ (tclStubsPtr->tcl_VarEval) /* 260 */ -/* Slot 261 is reserved */ +#endif +#ifndef Tcl_VarTraceInfo +#define Tcl_VarTraceInfo \ + (tclStubsPtr->tcl_VarTraceInfo) /* 261 */ +#endif +#ifndef Tcl_VarTraceInfo2 #define Tcl_VarTraceInfo2 \ (tclStubsPtr->tcl_VarTraceInfo2) /* 262 */ +#endif +#ifndef Tcl_Write #define Tcl_Write \ (tclStubsPtr->tcl_Write) /* 263 */ +#endif +#ifndef Tcl_WrongNumArgs #define Tcl_WrongNumArgs \ (tclStubsPtr->tcl_WrongNumArgs) /* 264 */ +#endif +#ifndef Tcl_DumpActiveMemory #define Tcl_DumpActiveMemory \ (tclStubsPtr->tcl_DumpActiveMemory) /* 265 */ +#endif +#ifndef Tcl_ValidateAllMemory #define Tcl_ValidateAllMemory \ (tclStubsPtr->tcl_ValidateAllMemory) /* 266 */ -/* Slot 267 is reserved */ -/* Slot 268 is reserved */ +#endif +#ifndef Tcl_AppendResultVA +#define Tcl_AppendResultVA \ + (tclStubsPtr->tcl_AppendResultVA) /* 267 */ +#endif +#ifndef Tcl_AppendStringsToObjVA +#define Tcl_AppendStringsToObjVA \ + (tclStubsPtr->tcl_AppendStringsToObjVA) /* 268 */ +#endif +#ifndef Tcl_HashStats #define Tcl_HashStats \ (tclStubsPtr->tcl_HashStats) /* 269 */ +#endif +#ifndef Tcl_ParseVar #define Tcl_ParseVar \ (tclStubsPtr->tcl_ParseVar) /* 270 */ -/* Slot 271 is reserved */ +#endif +#ifndef Tcl_PkgPresent +#define Tcl_PkgPresent \ + (tclStubsPtr->tcl_PkgPresent) /* 271 */ +#endif +#ifndef Tcl_PkgPresentEx #define Tcl_PkgPresentEx \ (tclStubsPtr->tcl_PkgPresentEx) /* 272 */ -/* Slot 273 is reserved */ -/* Slot 274 is reserved */ -/* Slot 275 is reserved */ -/* Slot 276 is reserved */ +#endif +#ifndef Tcl_PkgProvide +#define Tcl_PkgProvide \ + (tclStubsPtr->tcl_PkgProvide) /* 273 */ +#endif +#ifndef Tcl_PkgRequire +#define Tcl_PkgRequire \ + (tclStubsPtr->tcl_PkgRequire) /* 274 */ +#endif +#ifndef Tcl_SetErrorCodeVA +#define Tcl_SetErrorCodeVA \ + (tclStubsPtr->tcl_SetErrorCodeVA) /* 275 */ +#endif +#ifndef Tcl_VarEvalVA +#define Tcl_VarEvalVA \ + (tclStubsPtr->tcl_VarEvalVA) /* 276 */ +#endif +#ifndef Tcl_WaitPid #define Tcl_WaitPid \ (tclStubsPtr->tcl_WaitPid) /* 277 */ -/* Slot 278 is reserved */ +#endif +#ifndef Tcl_PanicVA +#define Tcl_PanicVA \ + (tclStubsPtr->tcl_PanicVA) /* 278 */ +#endif +#ifndef Tcl_GetVersion #define Tcl_GetVersion \ (tclStubsPtr->tcl_GetVersion) /* 279 */ +#endif +#ifndef Tcl_InitMemory #define Tcl_InitMemory \ (tclStubsPtr->tcl_InitMemory) /* 280 */ +#endif +#ifndef Tcl_StackChannel #define Tcl_StackChannel \ (tclStubsPtr->tcl_StackChannel) /* 281 */ +#endif +#ifndef Tcl_UnstackChannel #define Tcl_UnstackChannel \ (tclStubsPtr->tcl_UnstackChannel) /* 282 */ +#endif +#ifndef Tcl_GetStackedChannel #define Tcl_GetStackedChannel \ (tclStubsPtr->tcl_GetStackedChannel) /* 283 */ +#endif +#ifndef Tcl_SetMainLoop #define Tcl_SetMainLoop \ (tclStubsPtr->tcl_SetMainLoop) /* 284 */ +#endif /* Slot 285 is reserved */ +#ifndef Tcl_AppendObjToObj #define Tcl_AppendObjToObj \ (tclStubsPtr->tcl_AppendObjToObj) /* 286 */ +#endif +#ifndef Tcl_CreateEncoding #define Tcl_CreateEncoding \ (tclStubsPtr->tcl_CreateEncoding) /* 287 */ +#endif +#ifndef Tcl_CreateThreadExitHandler #define Tcl_CreateThreadExitHandler \ (tclStubsPtr->tcl_CreateThreadExitHandler) /* 288 */ +#endif +#ifndef Tcl_DeleteThreadExitHandler #define Tcl_DeleteThreadExitHandler \ (tclStubsPtr->tcl_DeleteThreadExitHandler) /* 289 */ -/* Slot 290 is reserved */ +#endif +#ifndef Tcl_DiscardResult +#define Tcl_DiscardResult \ + (tclStubsPtr->tcl_DiscardResult) /* 290 */ +#endif +#ifndef Tcl_EvalEx #define Tcl_EvalEx \ (tclStubsPtr->tcl_EvalEx) /* 291 */ +#endif +#ifndef Tcl_EvalObjv #define Tcl_EvalObjv \ (tclStubsPtr->tcl_EvalObjv) /* 292 */ +#endif +#ifndef Tcl_EvalObjEx #define Tcl_EvalObjEx \ (tclStubsPtr->tcl_EvalObjEx) /* 293 */ +#endif +#ifndef Tcl_ExitThread #define Tcl_ExitThread \ (tclStubsPtr->tcl_ExitThread) /* 294 */ +#endif +#ifndef Tcl_ExternalToUtf #define Tcl_ExternalToUtf \ (tclStubsPtr->tcl_ExternalToUtf) /* 295 */ +#endif +#ifndef Tcl_ExternalToUtfDString #define Tcl_ExternalToUtfDString \ (tclStubsPtr->tcl_ExternalToUtfDString) /* 296 */ +#endif +#ifndef Tcl_FinalizeThread #define Tcl_FinalizeThread \ (tclStubsPtr->tcl_FinalizeThread) /* 297 */ +#endif +#ifndef Tcl_FinalizeNotifier #define Tcl_FinalizeNotifier \ (tclStubsPtr->tcl_FinalizeNotifier) /* 298 */ +#endif +#ifndef Tcl_FreeEncoding #define Tcl_FreeEncoding \ (tclStubsPtr->tcl_FreeEncoding) /* 299 */ +#endif +#ifndef Tcl_GetCurrentThread #define Tcl_GetCurrentThread \ (tclStubsPtr->tcl_GetCurrentThread) /* 300 */ +#endif +#ifndef Tcl_GetEncoding #define Tcl_GetEncoding \ (tclStubsPtr->tcl_GetEncoding) /* 301 */ +#endif +#ifndef Tcl_GetEncodingName #define Tcl_GetEncodingName \ (tclStubsPtr->tcl_GetEncodingName) /* 302 */ +#endif +#ifndef Tcl_GetEncodingNames #define Tcl_GetEncodingNames \ (tclStubsPtr->tcl_GetEncodingNames) /* 303 */ +#endif +#ifndef Tcl_GetIndexFromObjStruct #define Tcl_GetIndexFromObjStruct \ (tclStubsPtr->tcl_GetIndexFromObjStruct) /* 304 */ +#endif +#ifndef Tcl_GetThreadData #define Tcl_GetThreadData \ (tclStubsPtr->tcl_GetThreadData) /* 305 */ +#endif +#ifndef Tcl_GetVar2Ex #define Tcl_GetVar2Ex \ (tclStubsPtr->tcl_GetVar2Ex) /* 306 */ +#endif +#ifndef Tcl_InitNotifier #define Tcl_InitNotifier \ (tclStubsPtr->tcl_InitNotifier) /* 307 */ +#endif +#ifndef Tcl_MutexLock #define Tcl_MutexLock \ (tclStubsPtr->tcl_MutexLock) /* 308 */ +#endif +#ifndef Tcl_MutexUnlock #define Tcl_MutexUnlock \ (tclStubsPtr->tcl_MutexUnlock) /* 309 */ +#endif +#ifndef Tcl_ConditionNotify #define Tcl_ConditionNotify \ (tclStubsPtr->tcl_ConditionNotify) /* 310 */ +#endif +#ifndef Tcl_ConditionWait #define Tcl_ConditionWait \ (tclStubsPtr->tcl_ConditionWait) /* 311 */ +#endif +#ifndef Tcl_NumUtfChars #define Tcl_NumUtfChars \ (tclStubsPtr->tcl_NumUtfChars) /* 312 */ +#endif +#ifndef Tcl_ReadChars #define Tcl_ReadChars \ (tclStubsPtr->tcl_ReadChars) /* 313 */ -/* Slot 314 is reserved */ -/* Slot 315 is reserved */ +#endif +#ifndef Tcl_RestoreResult +#define Tcl_RestoreResult \ + (tclStubsPtr->tcl_RestoreResult) /* 314 */ +#endif +#ifndef Tcl_SaveResult +#define Tcl_SaveResult \ + (tclStubsPtr->tcl_SaveResult) /* 315 */ +#endif +#ifndef Tcl_SetSystemEncoding #define Tcl_SetSystemEncoding \ (tclStubsPtr->tcl_SetSystemEncoding) /* 316 */ +#endif +#ifndef Tcl_SetVar2Ex #define Tcl_SetVar2Ex \ (tclStubsPtr->tcl_SetVar2Ex) /* 317 */ +#endif +#ifndef Tcl_ThreadAlert #define Tcl_ThreadAlert \ (tclStubsPtr->tcl_ThreadAlert) /* 318 */ +#endif +#ifndef Tcl_ThreadQueueEvent #define Tcl_ThreadQueueEvent \ (tclStubsPtr->tcl_ThreadQueueEvent) /* 319 */ +#endif +#ifndef Tcl_UniCharAtIndex #define Tcl_UniCharAtIndex \ (tclStubsPtr->tcl_UniCharAtIndex) /* 320 */ +#endif +#ifndef Tcl_UniCharToLower #define Tcl_UniCharToLower \ (tclStubsPtr->tcl_UniCharToLower) /* 321 */ +#endif +#ifndef Tcl_UniCharToTitle #define Tcl_UniCharToTitle \ (tclStubsPtr->tcl_UniCharToTitle) /* 322 */ +#endif +#ifndef Tcl_UniCharToUpper #define Tcl_UniCharToUpper \ (tclStubsPtr->tcl_UniCharToUpper) /* 323 */ +#endif +#ifndef Tcl_UniCharToUtf #define Tcl_UniCharToUtf \ (tclStubsPtr->tcl_UniCharToUtf) /* 324 */ +#endif +#ifndef Tcl_UtfAtIndex #define Tcl_UtfAtIndex \ (tclStubsPtr->tcl_UtfAtIndex) /* 325 */ +#endif +#ifndef Tcl_UtfCharComplete #define Tcl_UtfCharComplete \ (tclStubsPtr->tcl_UtfCharComplete) /* 326 */ +#endif +#ifndef Tcl_UtfBackslash #define Tcl_UtfBackslash \ (tclStubsPtr->tcl_UtfBackslash) /* 327 */ +#endif +#ifndef Tcl_UtfFindFirst #define Tcl_UtfFindFirst \ (tclStubsPtr->tcl_UtfFindFirst) /* 328 */ +#endif +#ifndef Tcl_UtfFindLast #define Tcl_UtfFindLast \ (tclStubsPtr->tcl_UtfFindLast) /* 329 */ +#endif +#ifndef Tcl_UtfNext #define Tcl_UtfNext \ (tclStubsPtr->tcl_UtfNext) /* 330 */ +#endif +#ifndef Tcl_UtfPrev #define Tcl_UtfPrev \ (tclStubsPtr->tcl_UtfPrev) /* 331 */ +#endif +#ifndef Tcl_UtfToExternal #define Tcl_UtfToExternal \ (tclStubsPtr->tcl_UtfToExternal) /* 332 */ +#endif +#ifndef Tcl_UtfToExternalDString #define Tcl_UtfToExternalDString \ (tclStubsPtr->tcl_UtfToExternalDString) /* 333 */ +#endif +#ifndef Tcl_UtfToLower #define Tcl_UtfToLower \ (tclStubsPtr->tcl_UtfToLower) /* 334 */ +#endif +#ifndef Tcl_UtfToTitle #define Tcl_UtfToTitle \ (tclStubsPtr->tcl_UtfToTitle) /* 335 */ -#define Tcl_UtfToChar16 \ - (tclStubsPtr->tcl_UtfToChar16) /* 336 */ +#endif +#ifndef Tcl_UtfToUniChar +#define Tcl_UtfToUniChar \ + (tclStubsPtr->tcl_UtfToUniChar) /* 336 */ +#endif +#ifndef Tcl_UtfToUpper #define Tcl_UtfToUpper \ (tclStubsPtr->tcl_UtfToUpper) /* 337 */ +#endif +#ifndef Tcl_WriteChars #define Tcl_WriteChars \ (tclStubsPtr->tcl_WriteChars) /* 338 */ +#endif +#ifndef Tcl_WriteObj #define Tcl_WriteObj \ (tclStubsPtr->tcl_WriteObj) /* 339 */ +#endif +#ifndef Tcl_GetString #define Tcl_GetString \ (tclStubsPtr->tcl_GetString) /* 340 */ -/* Slot 341 is reserved */ -/* Slot 342 is reserved */ +#endif +#ifndef Tcl_GetDefaultEncodingDir +#define Tcl_GetDefaultEncodingDir \ + (tclStubsPtr->tcl_GetDefaultEncodingDir) /* 341 */ +#endif +#ifndef Tcl_SetDefaultEncodingDir +#define Tcl_SetDefaultEncodingDir \ + (tclStubsPtr->tcl_SetDefaultEncodingDir) /* 342 */ +#endif +#ifndef Tcl_AlertNotifier #define Tcl_AlertNotifier \ (tclStubsPtr->tcl_AlertNotifier) /* 343 */ +#endif +#ifndef Tcl_ServiceModeHook #define Tcl_ServiceModeHook \ (tclStubsPtr->tcl_ServiceModeHook) /* 344 */ +#endif +#ifndef Tcl_UniCharIsAlnum #define Tcl_UniCharIsAlnum \ (tclStubsPtr->tcl_UniCharIsAlnum) /* 345 */ +#endif +#ifndef Tcl_UniCharIsAlpha #define Tcl_UniCharIsAlpha \ (tclStubsPtr->tcl_UniCharIsAlpha) /* 346 */ +#endif +#ifndef Tcl_UniCharIsDigit #define Tcl_UniCharIsDigit \ (tclStubsPtr->tcl_UniCharIsDigit) /* 347 */ +#endif +#ifndef Tcl_UniCharIsLower #define Tcl_UniCharIsLower \ (tclStubsPtr->tcl_UniCharIsLower) /* 348 */ +#endif +#ifndef Tcl_UniCharIsSpace #define Tcl_UniCharIsSpace \ (tclStubsPtr->tcl_UniCharIsSpace) /* 349 */ +#endif +#ifndef Tcl_UniCharIsUpper #define Tcl_UniCharIsUpper \ (tclStubsPtr->tcl_UniCharIsUpper) /* 350 */ +#endif +#ifndef Tcl_UniCharIsWordChar #define Tcl_UniCharIsWordChar \ (tclStubsPtr->tcl_UniCharIsWordChar) /* 351 */ -/* Slot 352 is reserved */ -/* Slot 353 is reserved */ -#define Tcl_Char16ToUtfDString \ - (tclStubsPtr->tcl_Char16ToUtfDString) /* 354 */ -#define Tcl_UtfToChar16DString \ - (tclStubsPtr->tcl_UtfToChar16DString) /* 355 */ +#endif +#ifndef Tcl_UniCharLen +#define Tcl_UniCharLen \ + (tclStubsPtr->tcl_UniCharLen) /* 352 */ +#endif +#ifndef Tcl_UniCharNcmp +#define Tcl_UniCharNcmp \ + (tclStubsPtr->tcl_UniCharNcmp) /* 353 */ +#endif +#ifndef Tcl_UniCharToUtfDString +#define Tcl_UniCharToUtfDString \ + (tclStubsPtr->tcl_UniCharToUtfDString) /* 354 */ +#endif +#ifndef Tcl_UtfToUniCharDString +#define Tcl_UtfToUniCharDString \ + (tclStubsPtr->tcl_UtfToUniCharDString) /* 355 */ +#endif +#ifndef Tcl_GetRegExpFromObj #define Tcl_GetRegExpFromObj \ (tclStubsPtr->tcl_GetRegExpFromObj) /* 356 */ -/* Slot 357 is reserved */ +#endif +#ifndef Tcl_EvalTokens +#define Tcl_EvalTokens \ + (tclStubsPtr->tcl_EvalTokens) /* 357 */ +#endif +#ifndef Tcl_FreeParse #define Tcl_FreeParse \ (tclStubsPtr->tcl_FreeParse) /* 358 */ +#endif +#ifndef Tcl_LogCommandInfo #define Tcl_LogCommandInfo \ (tclStubsPtr->tcl_LogCommandInfo) /* 359 */ +#endif +#ifndef Tcl_ParseBraces #define Tcl_ParseBraces \ (tclStubsPtr->tcl_ParseBraces) /* 360 */ +#endif +#ifndef Tcl_ParseCommand #define Tcl_ParseCommand \ (tclStubsPtr->tcl_ParseCommand) /* 361 */ +#endif +#ifndef Tcl_ParseExpr #define Tcl_ParseExpr \ (tclStubsPtr->tcl_ParseExpr) /* 362 */ +#endif +#ifndef Tcl_ParseQuotedString #define Tcl_ParseQuotedString \ (tclStubsPtr->tcl_ParseQuotedString) /* 363 */ +#endif +#ifndef Tcl_ParseVarName #define Tcl_ParseVarName \ (tclStubsPtr->tcl_ParseVarName) /* 364 */ +#endif +#ifndef Tcl_GetCwd #define Tcl_GetCwd \ (tclStubsPtr->tcl_GetCwd) /* 365 */ +#endif +#ifndef Tcl_Chdir #define Tcl_Chdir \ (tclStubsPtr->tcl_Chdir) /* 366 */ +#endif +#ifndef Tcl_Access #define Tcl_Access \ (tclStubsPtr->tcl_Access) /* 367 */ +#endif +#ifndef Tcl_Stat #define Tcl_Stat \ (tclStubsPtr->tcl_Stat) /* 368 */ +#endif +#ifndef Tcl_UtfNcmp #define Tcl_UtfNcmp \ (tclStubsPtr->tcl_UtfNcmp) /* 369 */ +#endif +#ifndef Tcl_UtfNcasecmp #define Tcl_UtfNcasecmp \ (tclStubsPtr->tcl_UtfNcasecmp) /* 370 */ +#endif +#ifndef Tcl_StringCaseMatch #define Tcl_StringCaseMatch \ (tclStubsPtr->tcl_StringCaseMatch) /* 371 */ +#endif +#ifndef Tcl_UniCharIsControl #define Tcl_UniCharIsControl \ (tclStubsPtr->tcl_UniCharIsControl) /* 372 */ +#endif +#ifndef Tcl_UniCharIsGraph #define Tcl_UniCharIsGraph \ (tclStubsPtr->tcl_UniCharIsGraph) /* 373 */ +#endif +#ifndef Tcl_UniCharIsPrint #define Tcl_UniCharIsPrint \ (tclStubsPtr->tcl_UniCharIsPrint) /* 374 */ +#endif +#ifndef Tcl_UniCharIsPunct #define Tcl_UniCharIsPunct \ (tclStubsPtr->tcl_UniCharIsPunct) /* 375 */ +#endif +#ifndef Tcl_RegExpExecObj #define Tcl_RegExpExecObj \ (tclStubsPtr->tcl_RegExpExecObj) /* 376 */ +#endif +#ifndef Tcl_RegExpGetInfo #define Tcl_RegExpGetInfo \ (tclStubsPtr->tcl_RegExpGetInfo) /* 377 */ +#endif +#ifndef Tcl_NewUnicodeObj #define Tcl_NewUnicodeObj \ (tclStubsPtr->tcl_NewUnicodeObj) /* 378 */ +#endif +#ifndef Tcl_SetUnicodeObj #define Tcl_SetUnicodeObj \ (tclStubsPtr->tcl_SetUnicodeObj) /* 379 */ +#endif +#ifndef Tcl_GetCharLength #define Tcl_GetCharLength \ (tclStubsPtr->tcl_GetCharLength) /* 380 */ +#endif +#ifndef Tcl_GetUniChar #define Tcl_GetUniChar \ (tclStubsPtr->tcl_GetUniChar) /* 381 */ -/* Slot 382 is reserved */ +#endif +#ifndef Tcl_GetUnicode +#define Tcl_GetUnicode \ + (tclStubsPtr->tcl_GetUnicode) /* 382 */ +#endif +#ifndef Tcl_GetRange #define Tcl_GetRange \ (tclStubsPtr->tcl_GetRange) /* 383 */ -/* Slot 384 is reserved */ +#endif +#ifndef Tcl_AppendUnicodeToObj +#define Tcl_AppendUnicodeToObj \ + (tclStubsPtr->tcl_AppendUnicodeToObj) /* 384 */ +#endif +#ifndef Tcl_RegExpMatchObj #define Tcl_RegExpMatchObj \ (tclStubsPtr->tcl_RegExpMatchObj) /* 385 */ +#endif +#ifndef Tcl_SetNotifier #define Tcl_SetNotifier \ (tclStubsPtr->tcl_SetNotifier) /* 386 */ +#endif +#ifndef Tcl_GetAllocMutex #define Tcl_GetAllocMutex \ (tclStubsPtr->tcl_GetAllocMutex) /* 387 */ +#endif +#ifndef Tcl_GetChannelNames #define Tcl_GetChannelNames \ (tclStubsPtr->tcl_GetChannelNames) /* 388 */ +#endif +#ifndef Tcl_GetChannelNamesEx #define Tcl_GetChannelNamesEx \ (tclStubsPtr->tcl_GetChannelNamesEx) /* 389 */ +#endif +#ifndef Tcl_ProcObjCmd #define Tcl_ProcObjCmd \ (tclStubsPtr->tcl_ProcObjCmd) /* 390 */ +#endif +#ifndef Tcl_ConditionFinalize #define Tcl_ConditionFinalize \ (tclStubsPtr->tcl_ConditionFinalize) /* 391 */ +#endif +#ifndef Tcl_MutexFinalize #define Tcl_MutexFinalize \ (tclStubsPtr->tcl_MutexFinalize) /* 392 */ +#endif +#ifndef Tcl_CreateThread #define Tcl_CreateThread \ (tclStubsPtr->tcl_CreateThread) /* 393 */ +#endif +#ifndef Tcl_ReadRaw #define Tcl_ReadRaw \ (tclStubsPtr->tcl_ReadRaw) /* 394 */ +#endif +#ifndef Tcl_WriteRaw #define Tcl_WriteRaw \ (tclStubsPtr->tcl_WriteRaw) /* 395 */ +#endif +#ifndef Tcl_GetTopChannel #define Tcl_GetTopChannel \ (tclStubsPtr->tcl_GetTopChannel) /* 396 */ +#endif +#ifndef Tcl_ChannelBuffered #define Tcl_ChannelBuffered \ (tclStubsPtr->tcl_ChannelBuffered) /* 397 */ +#endif +#ifndef Tcl_ChannelName #define Tcl_ChannelName \ (tclStubsPtr->tcl_ChannelName) /* 398 */ +#endif +#ifndef Tcl_ChannelVersion #define Tcl_ChannelVersion \ (tclStubsPtr->tcl_ChannelVersion) /* 399 */ +#endif +#ifndef Tcl_ChannelBlockModeProc #define Tcl_ChannelBlockModeProc \ (tclStubsPtr->tcl_ChannelBlockModeProc) /* 400 */ -/* Slot 401 is reserved */ +#endif +#ifndef Tcl_ChannelCloseProc +#define Tcl_ChannelCloseProc \ + (tclStubsPtr->tcl_ChannelCloseProc) /* 401 */ +#endif +#ifndef Tcl_ChannelClose2Proc #define Tcl_ChannelClose2Proc \ (tclStubsPtr->tcl_ChannelClose2Proc) /* 402 */ +#endif +#ifndef Tcl_ChannelInputProc #define Tcl_ChannelInputProc \ (tclStubsPtr->tcl_ChannelInputProc) /* 403 */ +#endif +#ifndef Tcl_ChannelOutputProc #define Tcl_ChannelOutputProc \ (tclStubsPtr->tcl_ChannelOutputProc) /* 404 */ -/* Slot 405 is reserved */ +#endif +#ifndef Tcl_ChannelSeekProc +#define Tcl_ChannelSeekProc \ + (tclStubsPtr->tcl_ChannelSeekProc) /* 405 */ +#endif +#ifndef Tcl_ChannelSetOptionProc #define Tcl_ChannelSetOptionProc \ (tclStubsPtr->tcl_ChannelSetOptionProc) /* 406 */ +#endif +#ifndef Tcl_ChannelGetOptionProc #define Tcl_ChannelGetOptionProc \ (tclStubsPtr->tcl_ChannelGetOptionProc) /* 407 */ +#endif +#ifndef Tcl_ChannelWatchProc #define Tcl_ChannelWatchProc \ (tclStubsPtr->tcl_ChannelWatchProc) /* 408 */ +#endif +#ifndef Tcl_ChannelGetHandleProc #define Tcl_ChannelGetHandleProc \ (tclStubsPtr->tcl_ChannelGetHandleProc) /* 409 */ +#endif +#ifndef Tcl_ChannelFlushProc #define Tcl_ChannelFlushProc \ (tclStubsPtr->tcl_ChannelFlushProc) /* 410 */ +#endif +#ifndef Tcl_ChannelHandlerProc #define Tcl_ChannelHandlerProc \ (tclStubsPtr->tcl_ChannelHandlerProc) /* 411 */ +#endif +#ifndef Tcl_JoinThread #define Tcl_JoinThread \ (tclStubsPtr->tcl_JoinThread) /* 412 */ +#endif +#ifndef Tcl_IsChannelShared #define Tcl_IsChannelShared \ (tclStubsPtr->tcl_IsChannelShared) /* 413 */ +#endif +#ifndef Tcl_IsChannelRegistered #define Tcl_IsChannelRegistered \ (tclStubsPtr->tcl_IsChannelRegistered) /* 414 */ +#endif +#ifndef Tcl_CutChannel #define Tcl_CutChannel \ (tclStubsPtr->tcl_CutChannel) /* 415 */ +#endif +#ifndef Tcl_SpliceChannel #define Tcl_SpliceChannel \ (tclStubsPtr->tcl_SpliceChannel) /* 416 */ +#endif +#ifndef Tcl_ClearChannelHandlers #define Tcl_ClearChannelHandlers \ (tclStubsPtr->tcl_ClearChannelHandlers) /* 417 */ +#endif +#ifndef Tcl_IsChannelExisting #define Tcl_IsChannelExisting \ (tclStubsPtr->tcl_IsChannelExisting) /* 418 */ -/* Slot 419 is reserved */ -/* Slot 420 is reserved */ -/* Slot 421 is reserved */ -/* Slot 422 is reserved */ +#endif +#ifndef Tcl_UniCharNcasecmp +#define Tcl_UniCharNcasecmp \ + (tclStubsPtr->tcl_UniCharNcasecmp) /* 419 */ +#endif +#ifndef Tcl_UniCharCaseMatch +#define Tcl_UniCharCaseMatch \ + (tclStubsPtr->tcl_UniCharCaseMatch) /* 420 */ +#endif +#ifndef Tcl_FindHashEntry +#define Tcl_FindHashEntry \ + (tclStubsPtr->tcl_FindHashEntry) /* 421 */ +#endif +#ifndef Tcl_CreateHashEntry +#define Tcl_CreateHashEntry \ + (tclStubsPtr->tcl_CreateHashEntry) /* 422 */ +#endif +#ifndef Tcl_InitCustomHashTable #define Tcl_InitCustomHashTable \ (tclStubsPtr->tcl_InitCustomHashTable) /* 423 */ +#endif +#ifndef Tcl_InitObjHashTable #define Tcl_InitObjHashTable \ (tclStubsPtr->tcl_InitObjHashTable) /* 424 */ +#endif +#ifndef Tcl_CommandTraceInfo #define Tcl_CommandTraceInfo \ (tclStubsPtr->tcl_CommandTraceInfo) /* 425 */ +#endif +#ifndef Tcl_TraceCommand #define Tcl_TraceCommand \ (tclStubsPtr->tcl_TraceCommand) /* 426 */ +#endif +#ifndef Tcl_UntraceCommand #define Tcl_UntraceCommand \ (tclStubsPtr->tcl_UntraceCommand) /* 427 */ +#endif +#ifndef Tcl_AttemptAlloc #define Tcl_AttemptAlloc \ (tclStubsPtr->tcl_AttemptAlloc) /* 428 */ +#endif +#ifndef Tcl_AttemptDbCkalloc #define Tcl_AttemptDbCkalloc \ (tclStubsPtr->tcl_AttemptDbCkalloc) /* 429 */ +#endif +#ifndef Tcl_AttemptRealloc #define Tcl_AttemptRealloc \ (tclStubsPtr->tcl_AttemptRealloc) /* 430 */ +#endif +#ifndef Tcl_AttemptDbCkrealloc #define Tcl_AttemptDbCkrealloc \ (tclStubsPtr->tcl_AttemptDbCkrealloc) /* 431 */ +#endif +#ifndef Tcl_AttemptSetObjLength #define Tcl_AttemptSetObjLength \ (tclStubsPtr->tcl_AttemptSetObjLength) /* 432 */ +#endif +#ifndef Tcl_GetChannelThread #define Tcl_GetChannelThread \ (tclStubsPtr->tcl_GetChannelThread) /* 433 */ +#endif +#ifndef Tcl_GetUnicodeFromObj #define Tcl_GetUnicodeFromObj \ (tclStubsPtr->tcl_GetUnicodeFromObj) /* 434 */ -/* Slot 435 is reserved */ -/* Slot 436 is reserved */ +#endif +#ifndef Tcl_GetMathFuncInfo +#define Tcl_GetMathFuncInfo \ + (tclStubsPtr->tcl_GetMathFuncInfo) /* 435 */ +#endif +#ifndef Tcl_ListMathFuncs +#define Tcl_ListMathFuncs \ + (tclStubsPtr->tcl_ListMathFuncs) /* 436 */ +#endif +#ifndef Tcl_SubstObj #define Tcl_SubstObj \ (tclStubsPtr->tcl_SubstObj) /* 437 */ +#endif +#ifndef Tcl_DetachChannel #define Tcl_DetachChannel \ (tclStubsPtr->tcl_DetachChannel) /* 438 */ +#endif +#ifndef Tcl_IsStandardChannel #define Tcl_IsStandardChannel \ (tclStubsPtr->tcl_IsStandardChannel) /* 439 */ +#endif +#ifndef Tcl_FSCopyFile #define Tcl_FSCopyFile \ (tclStubsPtr->tcl_FSCopyFile) /* 440 */ +#endif +#ifndef Tcl_FSCopyDirectory #define Tcl_FSCopyDirectory \ (tclStubsPtr->tcl_FSCopyDirectory) /* 441 */ +#endif +#ifndef Tcl_FSCreateDirectory #define Tcl_FSCreateDirectory \ (tclStubsPtr->tcl_FSCreateDirectory) /* 442 */ +#endif +#ifndef Tcl_FSDeleteFile #define Tcl_FSDeleteFile \ (tclStubsPtr->tcl_FSDeleteFile) /* 443 */ +#endif +#ifndef Tcl_FSLoadFile #define Tcl_FSLoadFile \ (tclStubsPtr->tcl_FSLoadFile) /* 444 */ +#endif +#ifndef Tcl_FSMatchInDirectory #define Tcl_FSMatchInDirectory \ (tclStubsPtr->tcl_FSMatchInDirectory) /* 445 */ +#endif +#ifndef Tcl_FSLink #define Tcl_FSLink \ (tclStubsPtr->tcl_FSLink) /* 446 */ +#endif +#ifndef Tcl_FSRemoveDirectory #define Tcl_FSRemoveDirectory \ (tclStubsPtr->tcl_FSRemoveDirectory) /* 447 */ +#endif +#ifndef Tcl_FSRenameFile #define Tcl_FSRenameFile \ (tclStubsPtr->tcl_FSRenameFile) /* 448 */ +#endif +#ifndef Tcl_FSLstat #define Tcl_FSLstat \ (tclStubsPtr->tcl_FSLstat) /* 449 */ +#endif +#ifndef Tcl_FSUtime #define Tcl_FSUtime \ (tclStubsPtr->tcl_FSUtime) /* 450 */ +#endif +#ifndef Tcl_FSFileAttrsGet #define Tcl_FSFileAttrsGet \ (tclStubsPtr->tcl_FSFileAttrsGet) /* 451 */ +#endif +#ifndef Tcl_FSFileAttrsSet #define Tcl_FSFileAttrsSet \ (tclStubsPtr->tcl_FSFileAttrsSet) /* 452 */ +#endif +#ifndef Tcl_FSFileAttrStrings #define Tcl_FSFileAttrStrings \ (tclStubsPtr->tcl_FSFileAttrStrings) /* 453 */ +#endif +#ifndef Tcl_FSStat #define Tcl_FSStat \ (tclStubsPtr->tcl_FSStat) /* 454 */ +#endif +#ifndef Tcl_FSAccess #define Tcl_FSAccess \ (tclStubsPtr->tcl_FSAccess) /* 455 */ +#endif +#ifndef Tcl_FSOpenFileChannel #define Tcl_FSOpenFileChannel \ (tclStubsPtr->tcl_FSOpenFileChannel) /* 456 */ +#endif +#ifndef Tcl_FSGetCwd #define Tcl_FSGetCwd \ (tclStubsPtr->tcl_FSGetCwd) /* 457 */ +#endif +#ifndef Tcl_FSChdir #define Tcl_FSChdir \ (tclStubsPtr->tcl_FSChdir) /* 458 */ +#endif +#ifndef Tcl_FSConvertToPathType #define Tcl_FSConvertToPathType \ (tclStubsPtr->tcl_FSConvertToPathType) /* 459 */ +#endif +#ifndef Tcl_FSJoinPath #define Tcl_FSJoinPath \ (tclStubsPtr->tcl_FSJoinPath) /* 460 */ +#endif +#ifndef Tcl_FSSplitPath #define Tcl_FSSplitPath \ (tclStubsPtr->tcl_FSSplitPath) /* 461 */ +#endif +#ifndef Tcl_FSEqualPaths #define Tcl_FSEqualPaths \ (tclStubsPtr->tcl_FSEqualPaths) /* 462 */ +#endif +#ifndef Tcl_FSGetNormalizedPath #define Tcl_FSGetNormalizedPath \ (tclStubsPtr->tcl_FSGetNormalizedPath) /* 463 */ +#endif +#ifndef Tcl_FSJoinToPath #define Tcl_FSJoinToPath \ (tclStubsPtr->tcl_FSJoinToPath) /* 464 */ +#endif +#ifndef Tcl_FSGetInternalRep #define Tcl_FSGetInternalRep \ (tclStubsPtr->tcl_FSGetInternalRep) /* 465 */ +#endif +#ifndef Tcl_FSGetTranslatedPath #define Tcl_FSGetTranslatedPath \ (tclStubsPtr->tcl_FSGetTranslatedPath) /* 466 */ +#endif +#ifndef Tcl_FSEvalFile #define Tcl_FSEvalFile \ (tclStubsPtr->tcl_FSEvalFile) /* 467 */ +#endif +#ifndef Tcl_FSNewNativePath #define Tcl_FSNewNativePath \ (tclStubsPtr->tcl_FSNewNativePath) /* 468 */ +#endif +#ifndef Tcl_FSGetNativePath #define Tcl_FSGetNativePath \ (tclStubsPtr->tcl_FSGetNativePath) /* 469 */ +#endif +#ifndef Tcl_FSFileSystemInfo #define Tcl_FSFileSystemInfo \ (tclStubsPtr->tcl_FSFileSystemInfo) /* 470 */ +#endif +#ifndef Tcl_FSPathSeparator #define Tcl_FSPathSeparator \ (tclStubsPtr->tcl_FSPathSeparator) /* 471 */ +#endif +#ifndef Tcl_FSListVolumes #define Tcl_FSListVolumes \ (tclStubsPtr->tcl_FSListVolumes) /* 472 */ +#endif +#ifndef Tcl_FSRegister #define Tcl_FSRegister \ (tclStubsPtr->tcl_FSRegister) /* 473 */ +#endif +#ifndef Tcl_FSUnregister #define Tcl_FSUnregister \ (tclStubsPtr->tcl_FSUnregister) /* 474 */ +#endif +#ifndef Tcl_FSData #define Tcl_FSData \ (tclStubsPtr->tcl_FSData) /* 475 */ +#endif +#ifndef Tcl_FSGetTranslatedStringPath #define Tcl_FSGetTranslatedStringPath \ (tclStubsPtr->tcl_FSGetTranslatedStringPath) /* 476 */ +#endif +#ifndef Tcl_FSGetFileSystemForPath #define Tcl_FSGetFileSystemForPath \ (tclStubsPtr->tcl_FSGetFileSystemForPath) /* 477 */ +#endif +#ifndef Tcl_FSGetPathType #define Tcl_FSGetPathType \ (tclStubsPtr->tcl_FSGetPathType) /* 478 */ +#endif +#ifndef Tcl_OutputBuffered #define Tcl_OutputBuffered \ (tclStubsPtr->tcl_OutputBuffered) /* 479 */ +#endif +#ifndef Tcl_FSMountsChanged #define Tcl_FSMountsChanged \ (tclStubsPtr->tcl_FSMountsChanged) /* 480 */ +#endif +#ifndef Tcl_EvalTokensStandard #define Tcl_EvalTokensStandard \ (tclStubsPtr->tcl_EvalTokensStandard) /* 481 */ +#endif +#ifndef Tcl_GetTime #define Tcl_GetTime \ (tclStubsPtr->tcl_GetTime) /* 482 */ +#endif +#ifndef Tcl_CreateObjTrace #define Tcl_CreateObjTrace \ (tclStubsPtr->tcl_CreateObjTrace) /* 483 */ +#endif +#ifndef Tcl_GetCommandInfoFromToken #define Tcl_GetCommandInfoFromToken \ (tclStubsPtr->tcl_GetCommandInfoFromToken) /* 484 */ +#endif +#ifndef Tcl_SetCommandInfoFromToken #define Tcl_SetCommandInfoFromToken \ (tclStubsPtr->tcl_SetCommandInfoFromToken) /* 485 */ +#endif +#ifndef Tcl_DbNewWideIntObj #define Tcl_DbNewWideIntObj \ (tclStubsPtr->tcl_DbNewWideIntObj) /* 486 */ +#endif +#ifndef Tcl_GetWideIntFromObj #define Tcl_GetWideIntFromObj \ (tclStubsPtr->tcl_GetWideIntFromObj) /* 487 */ +#endif +#ifndef Tcl_NewWideIntObj #define Tcl_NewWideIntObj \ (tclStubsPtr->tcl_NewWideIntObj) /* 488 */ +#endif +#ifndef Tcl_SetWideIntObj #define Tcl_SetWideIntObj \ (tclStubsPtr->tcl_SetWideIntObj) /* 489 */ +#endif +#ifndef Tcl_AllocStatBuf #define Tcl_AllocStatBuf \ (tclStubsPtr->tcl_AllocStatBuf) /* 490 */ +#endif +#ifndef Tcl_Seek #define Tcl_Seek \ (tclStubsPtr->tcl_Seek) /* 491 */ +#endif +#ifndef Tcl_Tell #define Tcl_Tell \ (tclStubsPtr->tcl_Tell) /* 492 */ +#endif +#ifndef Tcl_ChannelWideSeekProc #define Tcl_ChannelWideSeekProc \ (tclStubsPtr->tcl_ChannelWideSeekProc) /* 493 */ +#endif +#ifndef Tcl_DictObjPut #define Tcl_DictObjPut \ (tclStubsPtr->tcl_DictObjPut) /* 494 */ +#endif +#ifndef Tcl_DictObjGet #define Tcl_DictObjGet \ (tclStubsPtr->tcl_DictObjGet) /* 495 */ +#endif +#ifndef Tcl_DictObjRemove #define Tcl_DictObjRemove \ (tclStubsPtr->tcl_DictObjRemove) /* 496 */ +#endif +#ifndef Tcl_DictObjSize #define Tcl_DictObjSize \ (tclStubsPtr->tcl_DictObjSize) /* 497 */ +#endif +#ifndef Tcl_DictObjFirst #define Tcl_DictObjFirst \ (tclStubsPtr->tcl_DictObjFirst) /* 498 */ +#endif +#ifndef Tcl_DictObjNext #define Tcl_DictObjNext \ (tclStubsPtr->tcl_DictObjNext) /* 499 */ +#endif +#ifndef Tcl_DictObjDone #define Tcl_DictObjDone \ (tclStubsPtr->tcl_DictObjDone) /* 500 */ +#endif +#ifndef Tcl_DictObjPutKeyList #define Tcl_DictObjPutKeyList \ (tclStubsPtr->tcl_DictObjPutKeyList) /* 501 */ +#endif +#ifndef Tcl_DictObjRemoveKeyList #define Tcl_DictObjRemoveKeyList \ (tclStubsPtr->tcl_DictObjRemoveKeyList) /* 502 */ +#endif +#ifndef Tcl_NewDictObj #define Tcl_NewDictObj \ (tclStubsPtr->tcl_NewDictObj) /* 503 */ +#endif +#ifndef Tcl_DbNewDictObj #define Tcl_DbNewDictObj \ (tclStubsPtr->tcl_DbNewDictObj) /* 504 */ +#endif +#ifndef Tcl_RegisterConfig #define Tcl_RegisterConfig \ (tclStubsPtr->tcl_RegisterConfig) /* 505 */ +#endif +#ifndef Tcl_CreateNamespace #define Tcl_CreateNamespace \ (tclStubsPtr->tcl_CreateNamespace) /* 506 */ +#endif +#ifndef Tcl_DeleteNamespace #define Tcl_DeleteNamespace \ (tclStubsPtr->tcl_DeleteNamespace) /* 507 */ +#endif +#ifndef Tcl_AppendExportList #define Tcl_AppendExportList \ (tclStubsPtr->tcl_AppendExportList) /* 508 */ +#endif +#ifndef Tcl_Export #define Tcl_Export \ (tclStubsPtr->tcl_Export) /* 509 */ +#endif +#ifndef Tcl_Import #define Tcl_Import \ (tclStubsPtr->tcl_Import) /* 510 */ +#endif +#ifndef Tcl_ForgetImport #define Tcl_ForgetImport \ (tclStubsPtr->tcl_ForgetImport) /* 511 */ +#endif +#ifndef Tcl_GetCurrentNamespace #define Tcl_GetCurrentNamespace \ (tclStubsPtr->tcl_GetCurrentNamespace) /* 512 */ +#endif +#ifndef Tcl_GetGlobalNamespace #define Tcl_GetGlobalNamespace \ (tclStubsPtr->tcl_GetGlobalNamespace) /* 513 */ +#endif +#ifndef Tcl_FindNamespace #define Tcl_FindNamespace \ (tclStubsPtr->tcl_FindNamespace) /* 514 */ +#endif +#ifndef Tcl_FindCommand #define Tcl_FindCommand \ (tclStubsPtr->tcl_FindCommand) /* 515 */ +#endif +#ifndef Tcl_GetCommandFromObj #define Tcl_GetCommandFromObj \ (tclStubsPtr->tcl_GetCommandFromObj) /* 516 */ +#endif +#ifndef Tcl_GetCommandFullName #define Tcl_GetCommandFullName \ (tclStubsPtr->tcl_GetCommandFullName) /* 517 */ +#endif +#ifndef Tcl_FSEvalFileEx #define Tcl_FSEvalFileEx \ (tclStubsPtr->tcl_FSEvalFileEx) /* 518 */ -/* Slot 519 is reserved */ +#endif +#ifndef Tcl_SetExitProc +#define Tcl_SetExitProc \ + (tclStubsPtr->tcl_SetExitProc) /* 519 */ +#endif +#ifndef Tcl_LimitAddHandler #define Tcl_LimitAddHandler \ (tclStubsPtr->tcl_LimitAddHandler) /* 520 */ +#endif +#ifndef Tcl_LimitRemoveHandler #define Tcl_LimitRemoveHandler \ (tclStubsPtr->tcl_LimitRemoveHandler) /* 521 */ +#endif +#ifndef Tcl_LimitReady #define Tcl_LimitReady \ (tclStubsPtr->tcl_LimitReady) /* 522 */ +#endif +#ifndef Tcl_LimitCheck #define Tcl_LimitCheck \ (tclStubsPtr->tcl_LimitCheck) /* 523 */ +#endif +#ifndef Tcl_LimitExceeded #define Tcl_LimitExceeded \ (tclStubsPtr->tcl_LimitExceeded) /* 524 */ +#endif +#ifndef Tcl_LimitSetCommands #define Tcl_LimitSetCommands \ (tclStubsPtr->tcl_LimitSetCommands) /* 525 */ +#endif +#ifndef Tcl_LimitSetTime #define Tcl_LimitSetTime \ (tclStubsPtr->tcl_LimitSetTime) /* 526 */ +#endif +#ifndef Tcl_LimitSetGranularity #define Tcl_LimitSetGranularity \ (tclStubsPtr->tcl_LimitSetGranularity) /* 527 */ +#endif +#ifndef Tcl_LimitTypeEnabled #define Tcl_LimitTypeEnabled \ (tclStubsPtr->tcl_LimitTypeEnabled) /* 528 */ +#endif +#ifndef Tcl_LimitTypeExceeded #define Tcl_LimitTypeExceeded \ (tclStubsPtr->tcl_LimitTypeExceeded) /* 529 */ +#endif +#ifndef Tcl_LimitTypeSet #define Tcl_LimitTypeSet \ (tclStubsPtr->tcl_LimitTypeSet) /* 530 */ +#endif +#ifndef Tcl_LimitTypeReset #define Tcl_LimitTypeReset \ (tclStubsPtr->tcl_LimitTypeReset) /* 531 */ +#endif +#ifndef Tcl_LimitGetCommands #define Tcl_LimitGetCommands \ (tclStubsPtr->tcl_LimitGetCommands) /* 532 */ +#endif +#ifndef Tcl_LimitGetTime #define Tcl_LimitGetTime \ (tclStubsPtr->tcl_LimitGetTime) /* 533 */ +#endif +#ifndef Tcl_LimitGetGranularity #define Tcl_LimitGetGranularity \ (tclStubsPtr->tcl_LimitGetGranularity) /* 534 */ +#endif +#ifndef Tcl_SaveInterpState #define Tcl_SaveInterpState \ (tclStubsPtr->tcl_SaveInterpState) /* 535 */ +#endif +#ifndef Tcl_RestoreInterpState #define Tcl_RestoreInterpState \ (tclStubsPtr->tcl_RestoreInterpState) /* 536 */ +#endif +#ifndef Tcl_DiscardInterpState #define Tcl_DiscardInterpState \ (tclStubsPtr->tcl_DiscardInterpState) /* 537 */ +#endif +#ifndef Tcl_SetReturnOptions #define Tcl_SetReturnOptions \ (tclStubsPtr->tcl_SetReturnOptions) /* 538 */ +#endif +#ifndef Tcl_GetReturnOptions #define Tcl_GetReturnOptions \ (tclStubsPtr->tcl_GetReturnOptions) /* 539 */ +#endif +#ifndef Tcl_IsEnsemble #define Tcl_IsEnsemble \ (tclStubsPtr->tcl_IsEnsemble) /* 540 */ +#endif +#ifndef Tcl_CreateEnsemble #define Tcl_CreateEnsemble \ (tclStubsPtr->tcl_CreateEnsemble) /* 541 */ +#endif +#ifndef Tcl_FindEnsemble #define Tcl_FindEnsemble \ (tclStubsPtr->tcl_FindEnsemble) /* 542 */ +#endif +#ifndef Tcl_SetEnsembleSubcommandList #define Tcl_SetEnsembleSubcommandList \ (tclStubsPtr->tcl_SetEnsembleSubcommandList) /* 543 */ +#endif +#ifndef Tcl_SetEnsembleMappingDict #define Tcl_SetEnsembleMappingDict \ (tclStubsPtr->tcl_SetEnsembleMappingDict) /* 544 */ +#endif +#ifndef Tcl_SetEnsembleUnknownHandler #define Tcl_SetEnsembleUnknownHandler \ (tclStubsPtr->tcl_SetEnsembleUnknownHandler) /* 545 */ +#endif +#ifndef Tcl_SetEnsembleFlags #define Tcl_SetEnsembleFlags \ (tclStubsPtr->tcl_SetEnsembleFlags) /* 546 */ +#endif +#ifndef Tcl_GetEnsembleSubcommandList #define Tcl_GetEnsembleSubcommandList \ (tclStubsPtr->tcl_GetEnsembleSubcommandList) /* 547 */ +#endif +#ifndef Tcl_GetEnsembleMappingDict #define Tcl_GetEnsembleMappingDict \ (tclStubsPtr->tcl_GetEnsembleMappingDict) /* 548 */ +#endif +#ifndef Tcl_GetEnsembleUnknownHandler #define Tcl_GetEnsembleUnknownHandler \ (tclStubsPtr->tcl_GetEnsembleUnknownHandler) /* 549 */ +#endif +#ifndef Tcl_GetEnsembleFlags #define Tcl_GetEnsembleFlags \ (tclStubsPtr->tcl_GetEnsembleFlags) /* 550 */ +#endif +#ifndef Tcl_GetEnsembleNamespace #define Tcl_GetEnsembleNamespace \ (tclStubsPtr->tcl_GetEnsembleNamespace) /* 551 */ +#endif +#ifndef Tcl_SetTimeProc #define Tcl_SetTimeProc \ (tclStubsPtr->tcl_SetTimeProc) /* 552 */ +#endif +#ifndef Tcl_QueryTimeProc #define Tcl_QueryTimeProc \ (tclStubsPtr->tcl_QueryTimeProc) /* 553 */ +#endif +#ifndef Tcl_ChannelThreadActionProc #define Tcl_ChannelThreadActionProc \ (tclStubsPtr->tcl_ChannelThreadActionProc) /* 554 */ +#endif +#ifndef Tcl_NewBignumObj #define Tcl_NewBignumObj \ (tclStubsPtr->tcl_NewBignumObj) /* 555 */ +#endif +#ifndef Tcl_DbNewBignumObj #define Tcl_DbNewBignumObj \ (tclStubsPtr->tcl_DbNewBignumObj) /* 556 */ +#endif +#ifndef Tcl_SetBignumObj #define Tcl_SetBignumObj \ (tclStubsPtr->tcl_SetBignumObj) /* 557 */ +#endif +#ifndef Tcl_GetBignumFromObj #define Tcl_GetBignumFromObj \ (tclStubsPtr->tcl_GetBignumFromObj) /* 558 */ +#endif +#ifndef Tcl_TakeBignumFromObj #define Tcl_TakeBignumFromObj \ (tclStubsPtr->tcl_TakeBignumFromObj) /* 559 */ +#endif +#ifndef Tcl_TruncateChannel #define Tcl_TruncateChannel \ (tclStubsPtr->tcl_TruncateChannel) /* 560 */ +#endif +#ifndef Tcl_ChannelTruncateProc #define Tcl_ChannelTruncateProc \ (tclStubsPtr->tcl_ChannelTruncateProc) /* 561 */ +#endif +#ifndef Tcl_SetChannelErrorInterp #define Tcl_SetChannelErrorInterp \ (tclStubsPtr->tcl_SetChannelErrorInterp) /* 562 */ +#endif +#ifndef Tcl_GetChannelErrorInterp #define Tcl_GetChannelErrorInterp \ (tclStubsPtr->tcl_GetChannelErrorInterp) /* 563 */ +#endif +#ifndef Tcl_SetChannelError #define Tcl_SetChannelError \ (tclStubsPtr->tcl_SetChannelError) /* 564 */ +#endif +#ifndef Tcl_GetChannelError #define Tcl_GetChannelError \ (tclStubsPtr->tcl_GetChannelError) /* 565 */ +#endif +#ifndef Tcl_InitBignumFromDouble #define Tcl_InitBignumFromDouble \ (tclStubsPtr->tcl_InitBignumFromDouble) /* 566 */ +#endif +#ifndef Tcl_GetNamespaceUnknownHandler #define Tcl_GetNamespaceUnknownHandler \ (tclStubsPtr->tcl_GetNamespaceUnknownHandler) /* 567 */ +#endif +#ifndef Tcl_SetNamespaceUnknownHandler #define Tcl_SetNamespaceUnknownHandler \ (tclStubsPtr->tcl_SetNamespaceUnknownHandler) /* 568 */ +#endif +#ifndef Tcl_GetEncodingFromObj #define Tcl_GetEncodingFromObj \ (tclStubsPtr->tcl_GetEncodingFromObj) /* 569 */ +#endif +#ifndef Tcl_GetEncodingSearchPath #define Tcl_GetEncodingSearchPath \ (tclStubsPtr->tcl_GetEncodingSearchPath) /* 570 */ +#endif +#ifndef Tcl_SetEncodingSearchPath #define Tcl_SetEncodingSearchPath \ (tclStubsPtr->tcl_SetEncodingSearchPath) /* 571 */ +#endif +#ifndef Tcl_GetEncodingNameFromEnvironment #define Tcl_GetEncodingNameFromEnvironment \ (tclStubsPtr->tcl_GetEncodingNameFromEnvironment) /* 572 */ +#endif +#ifndef Tcl_PkgRequireProc #define Tcl_PkgRequireProc \ (tclStubsPtr->tcl_PkgRequireProc) /* 573 */ +#endif +#ifndef Tcl_AppendObjToErrorInfo #define Tcl_AppendObjToErrorInfo \ (tclStubsPtr->tcl_AppendObjToErrorInfo) /* 574 */ +#endif +#ifndef Tcl_AppendLimitedToObj #define Tcl_AppendLimitedToObj \ (tclStubsPtr->tcl_AppendLimitedToObj) /* 575 */ +#endif +#ifndef Tcl_Format #define Tcl_Format \ (tclStubsPtr->tcl_Format) /* 576 */ +#endif +#ifndef Tcl_AppendFormatToObj #define Tcl_AppendFormatToObj \ (tclStubsPtr->tcl_AppendFormatToObj) /* 577 */ +#endif +#ifndef Tcl_ObjPrintf #define Tcl_ObjPrintf \ (tclStubsPtr->tcl_ObjPrintf) /* 578 */ +#endif +#ifndef Tcl_AppendPrintfToObj #define Tcl_AppendPrintfToObj \ (tclStubsPtr->tcl_AppendPrintfToObj) /* 579 */ -#define Tcl_CancelEval \ - (tclStubsPtr->tcl_CancelEval) /* 580 */ -#define Tcl_Canceled \ - (tclStubsPtr->tcl_Canceled) /* 581 */ -#define Tcl_CreatePipe \ - (tclStubsPtr->tcl_CreatePipe) /* 582 */ -#define Tcl_NRCreateCommand \ - (tclStubsPtr->tcl_NRCreateCommand) /* 583 */ -#define Tcl_NREvalObj \ - (tclStubsPtr->tcl_NREvalObj) /* 584 */ -#define Tcl_NREvalObjv \ - (tclStubsPtr->tcl_NREvalObjv) /* 585 */ -#define Tcl_NRCmdSwap \ - (tclStubsPtr->tcl_NRCmdSwap) /* 586 */ -#define Tcl_NRAddCallback \ - (tclStubsPtr->tcl_NRAddCallback) /* 587 */ -#define Tcl_NRCallObjProc \ - (tclStubsPtr->tcl_NRCallObjProc) /* 588 */ -#define Tcl_GetFSDeviceFromStat \ - (tclStubsPtr->tcl_GetFSDeviceFromStat) /* 589 */ -#define Tcl_GetFSInodeFromStat \ - (tclStubsPtr->tcl_GetFSInodeFromStat) /* 590 */ -#define Tcl_GetModeFromStat \ - (tclStubsPtr->tcl_GetModeFromStat) /* 591 */ -#define Tcl_GetLinkCountFromStat \ - (tclStubsPtr->tcl_GetLinkCountFromStat) /* 592 */ -#define Tcl_GetUserIdFromStat \ - (tclStubsPtr->tcl_GetUserIdFromStat) /* 593 */ -#define Tcl_GetGroupIdFromStat \ - (tclStubsPtr->tcl_GetGroupIdFromStat) /* 594 */ -#define Tcl_GetDeviceTypeFromStat \ - (tclStubsPtr->tcl_GetDeviceTypeFromStat) /* 595 */ -#define Tcl_GetAccessTimeFromStat \ - (tclStubsPtr->tcl_GetAccessTimeFromStat) /* 596 */ -#define Tcl_GetModificationTimeFromStat \ - (tclStubsPtr->tcl_GetModificationTimeFromStat) /* 597 */ -#define Tcl_GetChangeTimeFromStat \ - (tclStubsPtr->tcl_GetChangeTimeFromStat) /* 598 */ -#define Tcl_GetSizeFromStat \ - (tclStubsPtr->tcl_GetSizeFromStat) /* 599 */ -#define Tcl_GetBlocksFromStat \ - (tclStubsPtr->tcl_GetBlocksFromStat) /* 600 */ -#define Tcl_GetBlockSizeFromStat \ - (tclStubsPtr->tcl_GetBlockSizeFromStat) /* 601 */ -#define Tcl_SetEnsembleParameterList \ - (tclStubsPtr->tcl_SetEnsembleParameterList) /* 602 */ -#define Tcl_GetEnsembleParameterList \ - (tclStubsPtr->tcl_GetEnsembleParameterList) /* 603 */ -#define Tcl_ParseArgsObjv \ - (tclStubsPtr->tcl_ParseArgsObjv) /* 604 */ -#define Tcl_GetErrorLine \ - (tclStubsPtr->tcl_GetErrorLine) /* 605 */ -#define Tcl_SetErrorLine \ - (tclStubsPtr->tcl_SetErrorLine) /* 606 */ -#define Tcl_TransferResult \ - (tclStubsPtr->tcl_TransferResult) /* 607 */ -#define Tcl_InterpActive \ - (tclStubsPtr->tcl_InterpActive) /* 608 */ -#define Tcl_BackgroundException \ - (tclStubsPtr->tcl_BackgroundException) /* 609 */ -#define Tcl_ZlibDeflate \ - (tclStubsPtr->tcl_ZlibDeflate) /* 610 */ -#define Tcl_ZlibInflate \ - (tclStubsPtr->tcl_ZlibInflate) /* 611 */ -#define Tcl_ZlibCRC32 \ - (tclStubsPtr->tcl_ZlibCRC32) /* 612 */ -#define Tcl_ZlibAdler32 \ - (tclStubsPtr->tcl_ZlibAdler32) /* 613 */ -#define Tcl_ZlibStreamInit \ - (tclStubsPtr->tcl_ZlibStreamInit) /* 614 */ -#define Tcl_ZlibStreamGetCommandName \ - (tclStubsPtr->tcl_ZlibStreamGetCommandName) /* 615 */ -#define Tcl_ZlibStreamEof \ - (tclStubsPtr->tcl_ZlibStreamEof) /* 616 */ -#define Tcl_ZlibStreamChecksum \ - (tclStubsPtr->tcl_ZlibStreamChecksum) /* 617 */ -#define Tcl_ZlibStreamPut \ - (tclStubsPtr->tcl_ZlibStreamPut) /* 618 */ -#define Tcl_ZlibStreamGet \ - (tclStubsPtr->tcl_ZlibStreamGet) /* 619 */ -#define Tcl_ZlibStreamClose \ - (tclStubsPtr->tcl_ZlibStreamClose) /* 620 */ -#define Tcl_ZlibStreamReset \ - (tclStubsPtr->tcl_ZlibStreamReset) /* 621 */ -#define Tcl_SetStartupScript \ - (tclStubsPtr->tcl_SetStartupScript) /* 622 */ -#define Tcl_GetStartupScript \ - (tclStubsPtr->tcl_GetStartupScript) /* 623 */ -#define Tcl_CloseEx \ - (tclStubsPtr->tcl_CloseEx) /* 624 */ -#define Tcl_NRExprObj \ - (tclStubsPtr->tcl_NRExprObj) /* 625 */ -#define Tcl_NRSubstObj \ - (tclStubsPtr->tcl_NRSubstObj) /* 626 */ -#define Tcl_LoadFile \ - (tclStubsPtr->tcl_LoadFile) /* 627 */ -#define Tcl_FindSymbol \ - (tclStubsPtr->tcl_FindSymbol) /* 628 */ -#define Tcl_FSUnloadFile \ - (tclStubsPtr->tcl_FSUnloadFile) /* 629 */ -#define Tcl_ZlibStreamSetCompressionDictionary \ - (tclStubsPtr->tcl_ZlibStreamSetCompressionDictionary) /* 630 */ -#define Tcl_OpenTcpServerEx \ - (tclStubsPtr->tcl_OpenTcpServerEx) /* 631 */ -#define TclZipfs_Mount \ - (tclStubsPtr->tclZipfs_Mount) /* 632 */ -#define TclZipfs_Unmount \ - (tclStubsPtr->tclZipfs_Unmount) /* 633 */ -#define TclZipfs_TclLibrary \ - (tclStubsPtr->tclZipfs_TclLibrary) /* 634 */ -#define TclZipfs_MountBuffer \ - (tclStubsPtr->tclZipfs_MountBuffer) /* 635 */ -#define Tcl_FreeIntRep \ - (tclStubsPtr->tcl_FreeIntRep) /* 636 */ -#define Tcl_InitStringRep \ - (tclStubsPtr->tcl_InitStringRep) /* 637 */ -#define Tcl_FetchIntRep \ - (tclStubsPtr->tcl_FetchIntRep) /* 638 */ -#define Tcl_StoreIntRep \ - (tclStubsPtr->tcl_StoreIntRep) /* 639 */ -#define Tcl_HasStringRep \ - (tclStubsPtr->tcl_HasStringRep) /* 640 */ -#define Tcl_IncrRefCount \ - (tclStubsPtr->tcl_IncrRefCount) /* 641 */ -#define Tcl_DecrRefCount \ - (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) */ +#endif +/* Slot 580 is reserved */ +/* Slot 581 is reserved */ +/* Slot 582 is reserved */ +/* Slot 583 is reserved */ +/* Slot 584 is reserved */ +/* Slot 585 is reserved */ +/* Slot 586 is reserved */ +/* Slot 587 is reserved */ +/* Slot 588 is reserved */ +/* Slot 589 is reserved */ +/* Slot 590 is reserved */ +/* Slot 591 is reserved */ +/* Slot 592 is reserved */ +/* Slot 593 is reserved */ +/* Slot 594 is reserved */ +/* Slot 595 is reserved */ +/* Slot 596 is reserved */ +/* Slot 597 is reserved */ +/* Slot 598 is reserved */ +/* Slot 599 is reserved */ +/* Slot 600 is reserved */ +/* Slot 601 is reserved */ +/* Slot 602 is reserved */ +/* Slot 603 is reserved */ +/* Slot 604 is reserved */ +/* Slot 605 is reserved */ +/* Slot 606 is reserved */ +/* Slot 607 is reserved */ +/* Slot 608 is reserved */ +/* Slot 609 is reserved */ +/* Slot 610 is reserved */ +/* Slot 611 is reserved */ +/* Slot 612 is reserved */ +/* Slot 613 is reserved */ +/* Slot 614 is reserved */ +/* Slot 615 is reserved */ +/* Slot 616 is reserved */ +/* Slot 617 is reserved */ +/* Slot 618 is reserved */ +/* Slot 619 is reserved */ +/* Slot 620 is reserved */ +/* Slot 621 is reserved */ +/* Slot 622 is reserved */ +/* Slot 623 is reserved */ +/* Slot 624 is reserved */ +/* Slot 625 is reserved */ +/* Slot 626 is reserved */ +/* Slot 627 is reserved */ +/* Slot 628 is reserved */ +/* Slot 629 is reserved */ +/* Slot 630 is reserved */ +/* Slot 631 is reserved */ +/* Slot 632 is reserved */ +/* Slot 633 is reserved */ +/* Slot 634 is reserved */ +/* Slot 635 is reserved */ +/* Slot 636 is reserved */ +/* Slot 637 is reserved */ +/* Slot 638 is reserved */ +/* Slot 639 is reserved */ +/* Slot 640 is reserved */ +/* Slot 641 is reserved */ +/* Slot 642 is reserved */ +/* Slot 643 is reserved */ +/* Slot 644 is reserved */ +/* Slot 645 is reserved */ +/* Slot 646 is reserved */ +/* Slot 647 is reserved */ +/* Slot 648 is reserved */ +/* Slot 649 is reserved */ +/* Slot 650 is reserved */ +/* Slot 651 is reserved */ +/* Slot 652 is reserved */ +/* Slot 653 is reserved */ +/* Slot 654 is reserved */ +/* Slot 655 is reserved */ +/* Slot 656 is reserved */ +/* Slot 657 is reserved */ +/* Slot 658 is reserved */ +/* Slot 659 is reserved */ +/* Slot 660 is reserved */ +/* Slot 661 is reserved */ +/* Slot 662 is reserved */ +/* Slot 663 is reserved */ +/* Slot 664 is reserved */ +/* Slot 665 is reserved */ +/* Slot 666 is reserved */ +/* Slot 667 is reserved */ +/* Slot 668 is reserved */ +/* Slot 669 is reserved */ +/* Slot 670 is reserved */ +/* Slot 671 is reserved */ +/* Slot 672 is reserved */ +/* Slot 673 is reserved */ +/* Slot 674 is reserved */ +/* Slot 675 is reserved */ +/* Slot 676 is reserved */ +/* Slot 677 is reserved */ +/* Slot 678 is reserved */ +/* Slot 679 is reserved */ +/* Slot 680 is reserved */ +/* Slot 681 is reserved */ +/* Slot 682 is reserved */ +/* Slot 683 is reserved */ +/* Slot 684 is reserved */ +/* Slot 685 is reserved */ +/* Slot 686 is reserved */ +#ifndef TclUnusedStubEntry +#define TclUnusedStubEntry \ + (tclStubsPtr->tclUnusedStubEntry) /* 687 */ +#endif + +#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ /* !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 - EXTERN TCL_NORETURN void Tcl_MainExW(int argc, wchar_t **argv, - Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); -#endif +#undef TclUnusedStubEntry #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT +#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) + Tcl_NewIntObj((boolValue)!=0) +#undef Tcl_DbNewBooleanObj #define Tcl_DbNewBooleanObj(boolValue, file, line) \ - Tcl_DbNewWideIntObj((boolValue)!=0, file, line) + Tcl_DbNewLongObj((boolValue)!=0, file, line) +#undef Tcl_SetBooleanObj #define Tcl_SetBooleanObj(objPtr, boolValue) \ - Tcl_SetWideIntObj(objPtr, (boolValue)!=0) + Tcl_SetIntObj((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) -#define Tcl_AddErrorInfo(interp, message) \ - Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, -1)) -#define Tcl_AddObjErrorInfo(interp, message, length) \ - Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, length)) -#define Tcl_Eval(interp, objPtr) \ - Tcl_EvalEx(interp, objPtr, -1, 0) -#define Tcl_GlobalEval(interp, objPtr) \ - Tcl_EvalEx(interp, objPtr, -1, TCL_EVAL_GLOBAL) -#define Tcl_GetStringResult(interp) Tcl_GetString(Tcl_GetObjResult(interp)) -#define Tcl_SaveResult(interp, statePtr) \ - do { \ - *(statePtr) = Tcl_GetObjResult(interp); \ - Tcl_IncrRefCount(*(statePtr)); \ - Tcl_SetObjResult(interp, Tcl_NewObj()); \ - } while(0) -#define Tcl_RestoreResult(interp, statePtr) \ - do { \ - Tcl_ResetResult(interp); \ - Tcl_SetObjResult(interp, *(statePtr)); \ - Tcl_DecrRefCount(*(statePtr)); \ - } while(0) -#define Tcl_DiscardResult(statePtr) \ - Tcl_DecrRefCount(*(statePtr)) -#define Tcl_SetResult(interp, result, freeProc) \ - do { \ - const char *__result = result; \ - Tcl_FreeProc *__freeProc = freeProc; \ - Tcl_SetObjResult(interp, Tcl_NewStringObj(__result, -1)); \ - if (__result != NULL && __freeProc != NULL && __freeProc != TCL_VOLATILE) { \ - if (__freeProc == TCL_DYNAMIC) { \ - Tcl_Free((char *)__result); \ - } else { \ - (*__freeProc)((char *)__result); \ - } \ - } \ - } while(0) #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 @@ -3799,14 +6771,24 @@ * 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_DbNewLongObj # undef Tcl_GetLongFromObj +# undef Tcl_NewLongObj +# undef Tcl_SetLongObj # undef Tcl_ExprLong # undef Tcl_ExprLongObj +# undef Tcl_UniCharNcmp +# undef Tcl_UtfNcmp +# undef Tcl_UtfNcasecmp +# undef Tcl_UniCharNcasecmp +# define Tcl_DbNewLongObj ((Tcl_Obj*(*)(long,const char*,int))Tcl_DbNewWideIntObj) # define Tcl_GetLongFromObj ((int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetWideIntFromObj) +# define Tcl_NewLongObj ((Tcl_Obj*(*)(long))Tcl_NewWideIntObj) +# define Tcl_SetLongObj ((void(*)(Tcl_Obj*,long))Tcl_SetWideIntObj) # 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; @@ -3817,124 +6799,28 @@ 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 -#ifdef TCL_MEM_DEBUG -# undef Tcl_Alloc -# define Tcl_Alloc(x) \ - (Tcl_DbCkalloc((x), __FILE__, __LINE__)) -# undef Tcl_Free -# define Tcl_Free(x) \ - Tcl_DbCkfree((x), __FILE__, __LINE__) -# undef Tcl_Realloc -# define Tcl_Realloc(x,y) \ - (Tcl_DbCkrealloc((x), (y), __FILE__, __LINE__)) -# undef Tcl_AttemptAlloc -# define Tcl_AttemptAlloc(x) \ - (Tcl_AttemptDbCkalloc((x), __FILE__, __LINE__)) -# undef Tcl_AttemptRealloc -# define Tcl_AttemptRealloc(x,y) \ - (Tcl_AttemptDbCkrealloc((x), (y), __FILE__, __LINE__)) -#endif /* !TCL_MEM_DEBUG */ - -#define Tcl_NewLongObj(value) Tcl_NewWideIntObj((long)(value)) -#define Tcl_NewIntObj(value) Tcl_NewWideIntObj((int)(value)) -#define Tcl_DbNewLongObj(value, file, line) Tcl_DbNewWideIntObj((long)(value), file, line) -#define Tcl_SetIntObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (int)(value)) -#define Tcl_SetLongObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (long)(value)) -#define Tcl_GetUnicode(objPtr) Tcl_GetUnicodeFromObj((objPtr), NULL) -#define Tcl_BackgroundError(interp) Tcl_BackgroundException((interp), TCL_ERROR) -#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 *, size_t, Tcl_DString *))tclStubsPtr->tcl_UniCharToUtfDString \ - : (char *(*)(const wchar_t *, size_t, Tcl_DString *))Tcl_Char16ToUtfDString) -# define Tcl_UtfToWCharDString (sizeof(wchar_t) != sizeof(short) \ - ? (wchar_t *(*)(const char *, size_t, Tcl_DString *))tclStubsPtr->tcl_UtfToUniCharDString \ - : (wchar_t *(*)(const char *, size_t, 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 *, size_t, Tcl_DString *))Tcl_UniCharToUtfDString \ - : (char *(*)(const wchar_t *, size_t, Tcl_DString *))Tcl_Char16ToUtfDString) -# define Tcl_UtfToWCharDString (sizeof(wchar_t) != sizeof(short) \ - ? (wchar_t *(*)(const char *, size_t, Tcl_DString *))Tcl_UtfToUniCharDString \ - : (wchar_t *(*)(const char *, size_t, 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: */ -#define Tcl_EvalObj(interp, objPtr) \ - Tcl_EvalObjEx(interp, objPtr, 0) -#define Tcl_GlobalEvalObj(interp, objPtr) \ - Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL) - -#if defined(TCL_8_COMPAT) && !defined(BUILD_tcl) -# ifdef USE_TCL_STUBS -# undef Tcl_Gets -# undef Tcl_GetsObj -# undef Tcl_Read -# undef Tcl_Ungets -# undef Tcl_Write -# undef Tcl_ReadChars -# undef Tcl_WriteChars -# undef Tcl_WriteObj -# undef Tcl_ReadRaw -# undef Tcl_WriteRaw -# define Tcl_Gets(chan, dsPtr) (((Tcl_WideInt)((tclStubsPtr->tcl_Gets)(chan, dsPtr)+1))-1) -# define Tcl_GetsObj(chan, objPtr) (((Tcl_WideInt)((tclStubsPtr->tcl_GetsObj)(chan, objPtr)+1))-1) -# define Tcl_Read(chan, bufPtr, toRead) (((Tcl_WideInt)((tclStubsPtr->tcl_Read)(chan, bufPtr, toRead)+1))-1) -# define Tcl_Ungets(chan, str, len, atHead) (((Tcl_WideInt)((tclStubsPtr->tcl_Ungets)(chan, str, len, atHead)+1))-1) -# define Tcl_Write(chan, s, slen) (((Tcl_WideInt)((tclStubsPtr->tcl_Write)(chan, s, slen)+1))-1) -# define Tcl_ReadChars(channel, objPtr, charsToRead, appendFlag) (((Tcl_WideInt)((tclStubsPtr->tcl_ReadChars)(channel, objPtr, charsToRead, appendFlag)+1))-1) -# define Tcl_WriteChars(chan, src, srcLen) (((Tcl_WideInt)((tclStubsPtr->tcl_WriteChars)(chan, src, srcLen)+1))-1) -# define Tcl_WriteObj(chan, objPtr) (((Tcl_WideInt)((tclStubsPtr->tcl_WriteObj)(chan, objPtr)+1))-1) -# define Tcl_ReadRaw(chan, dst, bytesToRead) (((Tcl_WideInt)((tclStubsPtr->tcl_ReadRaw)(chan, dst, bytesToRead)+1))-1) -# define Tcl_WriteRaw(chan, src, srcLen) (((Tcl_WideInt)((tclStubsPtr->tcl_WriteRaw()(chan, src, srcLen)+1))-1) -# else -# define Tcl_Gets(chan, dsPtr) (((Tcl_WideInt)((Tcl_Gets)(chan, dsPtr)+1))-1) -# define Tcl_GetsObj(chan, objPtr) (((Tcl_WideInt)((Tcl_GetsObj)(chan, objPtr)+1))-1) -# define Tcl_Read(chan, bufPtr, toRead) (((Tcl_WideInt)((Tcl_Read)(chan, bufPtr, toRead)+1))-1) -# define Tcl_Ungets(chan, str, len, atHead) (((Tcl_WideInt)((Tcl_Ungets)(chan, str, len, atHead)+1))-1) -# define Tcl_Write(chan, s, slen) (((Tcl_WideInt)((Tcl_Write)(chan, s, slen)+1))-1) -# define Tcl_ReadChars(channel, objPtr, charsToRead, appendFlag) (((Tcl_WideInt)((Tcl_ReadChars)(channel, objPtr, charsToRead, appendFlag)+1))-1) -# define Tcl_WriteChars(chan, src, srcLen) (((Tcl_WideInt)((Tcl_WriteChars)(chan, src, srcLen)+1))-1) -# define Tcl_WriteObj(chan, objPtr) (((Tcl_WideInt)((Tcl_WriteObj)(chan, objPtr)+1))-1) -# define Tcl_ReadRaw(chan, dst, bytesToRead) (((Tcl_WideInt)((Tcl_ReadRaw)(chan, dst, bytesToRead)+1))-1) -# define Tcl_WriteRaw(chan, src, srcLen) (((Tcl_WideInt)((Tcl_WriteRaw()(chan, src, srcLen)+1))-1) -# endif -#endif - -#define Tcl_Close(interp, chan) Tcl_CloseEx(interp, chan, 0) - -#if defined(USE_TCL_STUBS) && (TCL_UTF_MAX <= 3) -# undef Tcl_UtfCharComplete -# define Tcl_UtfCharComplete(src, length) (((unsigned)((unsigned char)*(src) - 0xF0) < 5) \ - ? ((length) >= TCL_UTF_MAX) : tclStubsPtr->tcl_UtfCharComplete((src), (length))) -#endif -#ifndef TCL_NO_DEPRECATED -# define Tcl_CreateSlave Tcl_CreateChild -# define Tcl_GetSlave Tcl_GetChild -# define Tcl_GetMaster Tcl_GetParent -#endif +#undef Tcl_EvalObj +#define Tcl_EvalObj(interp,objPtr) \ + Tcl_EvalObjEx((interp),(objPtr),0) +#undef Tcl_GlobalEvalObj +#define Tcl_GlobalEvalObj(interp,objPtr) \ + Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL) #endif /* _TCLDECLS */ Index: generic/tclDictObj.c ================================================================== --- generic/tclDictObj.c +++ generic/tclDictObj.c @@ -2,19 +2,18 @@ * 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. + * Copyright (c) 2002 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 +#include "tommath.h" /* * Forward declaration. */ struct Dict; @@ -21,78 +20,86 @@ /* * 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; +static void DeleteDict(struct Dict *dict); +static int DictAppendCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictCreateCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictExistsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictFilterCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictForCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictGetCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictIncrCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictInfoCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictKeysCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictLappendCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictMergeCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictRemoveCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictReplaceCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictSetCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictSizeCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictUnsetCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictUpdateCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictValuesCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int DictWithCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static void DupDictInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); +static void FreeDictInternalRep(Tcl_Obj *dictPtr); +static void InvalidateDictChain(Tcl_Obj *dictObj); +static int SetDictFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +static void UpdateStringOfDict(Tcl_Obj *dictPtr); +static Tcl_HashEntry * AllocChainEntry(Tcl_HashTable *tablePtr,void *keyPtr); +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); /* * Table of dict subcommand names and implementations. */ static const EnsembleImplMap implementationMap[] = { - {"append", DictAppendCmd, TclCompileDictAppendCmd, NULL, NULL, 0 }, - {"create", DictCreateCmd, TclCompileDictCreateCmd, NULL, NULL, 0 }, - {"exists", DictExistsCmd, TclCompileDictExistsCmd, NULL, NULL, 0 }, - {"filter", DictFilterCmd, NULL, NULL, NULL, 0 }, - {"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL, 0 }, - {"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL, 0 }, - {"getdef", DictGetDefCmd, TclCompileDictGetWithDefaultCmd, NULL,NULL,0}, - {"getwithdefault", DictGetDefCmd, TclCompileDictGetWithDefaultCmd, - NULL, NULL, 0 }, - {"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL, 0 }, - {"info", DictInfoCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, - {"keys", DictKeysCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, - {"lappend", DictLappendCmd, TclCompileDictLappendCmd, NULL, NULL, 0 }, - {"map", NULL, TclCompileDictMapCmd, DictMapNRCmd, NULL, 0 }, - {"merge", DictMergeCmd, TclCompileDictMergeCmd, NULL, NULL, 0 }, - {"remove", DictRemoveCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0 }, - {"replace", DictReplaceCmd, NULL, NULL, NULL, 0 }, - {"set", DictSetCmd, TclCompileDictSetCmd, NULL, NULL, 0 }, - {"size", DictSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, - {"unset", DictUnsetCmd, TclCompileDictUnsetCmd, NULL, NULL, 0 }, - {"update", DictUpdateCmd, TclCompileDictUpdateCmd, NULL, NULL, 0 }, - {"values", DictValuesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, - {"with", DictWithCmd, TclCompileDictWithCmd, NULL, NULL, 0 }, - {NULL, NULL, NULL, NULL, NULL, 0} + {"append", DictAppendCmd, TclCompileDictAppendCmd }, + {"create", DictCreateCmd, NULL }, + {"exists", DictExistsCmd, NULL }, + {"filter", DictFilterCmd, NULL }, + {"for", DictForCmd, TclCompileDictForCmd }, + {"get", DictGetCmd, TclCompileDictGetCmd }, + {"incr", DictIncrCmd, TclCompileDictIncrCmd }, + {"info", DictInfoCmd, NULL }, + {"keys", DictKeysCmd, NULL }, + {"lappend", DictLappendCmd, TclCompileDictLappendCmd }, + {"merge", DictMergeCmd, NULL }, + {"remove", DictRemoveCmd, NULL }, + {"replace", DictReplaceCmd, NULL }, + {"set", DictSetCmd, TclCompileDictSetCmd }, + {"size", DictSizeCmd, NULL }, + {"unset", DictUnsetCmd, NULL }, + {"update", DictUpdateCmd, TclCompileDictUpdateCmd }, + {"values", DictValuesCmd, NULL }, + {"with", DictWithCmd, NULL }, + {NULL, NULL, NULL} }; /* * Internal representation of the entries in the hash table that backs a * dictionary. @@ -127,12 +134,12 @@ * created. */ ChainEntry *entryChainTail; /* Other end of linked list of all entries in * the dictionary. Used for doing traversal of * the entries in the order that they are * created. */ - size_t epoch; /* Epoch counter */ - size_t refCount; /* Reference counter (see above) */ + int epoch; /* Epoch counter */ + int refcount; /* Reference counter (see above) */ Tcl_Obj *chain; /* Linked list used for invalidating the * string representations of updated nested * dictionaries. */ } Dict; @@ -139,33 +146,18 @@ /* * The structure below defines the dictionary object type by means of * functions that can be invoked by generic object code. */ -const Tcl_ObjType tclDictType = { +Tcl_ObjType tclDictType = { "dict", FreeDictInternalRep, /* freeIntRepProc */ - DupDictInternalRep, /* dupIntRepProc */ + DupDictInternalRep, /* dupIntRepProc */ UpdateStringOfDict, /* updateStringProc */ SetDictFromAny /* setFromAnyProc */ }; -#define DictSetIntRep(objPtr, dictRepPtr) \ - do { \ - Tcl_ObjIntRep ir; \ - ir.twoPtrValue.ptr1 = (dictRepPtr); \ - ir.twoPtrValue.ptr2 = NULL; \ - 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. @@ -172,35 +164,18 @@ * * Note that this type of hash table is *only* suitable for direct use in * *this* file. Everything else should use the dict iterator API. */ -static const Tcl_HashKeyType chainHashType = { +static Tcl_HashKeyType chainHashType = { TCL_HASH_KEY_TYPE_VERSION, - 0, + TCL_HASH_KEY_DIRECT_COMPARE, /* allows compare keys by pointers */ TclHashObjKey, TclCompareObjKeys, AllocChainEntry, TclFreeObjEntry }; - -/* - * Structure used in implementation of 'dict map' to hold the state that gets - * passed between parts of the implementation. - */ - -typedef struct { - Tcl_Obj *keyVarObj; /* The name of the variable that will have - * keys assigned to it. */ - Tcl_Obj *valueVarObj; /* The name of the variable that will have - * values assigned to it. */ - Tcl_DictSearch search; /* The dictionary search structure. */ - Tcl_Obj *scriptObj; /* The script to evaluate each time through - * the loop. */ - Tcl_Obj *accumulatorObj; /* The dictionary used to accumulate the - * results. */ -} DictMapStorage; /***** START OF FUNCTIONS IMPLEMENTING DICT CORE API *****/ /* *---------------------------------------------------------------------- @@ -220,20 +195,20 @@ *---------------------------------------------------------------------- */ static Tcl_HashEntry * AllocChainEntry( - TCL_UNUSED(Tcl_HashTable *), + Tcl_HashTable *tablePtr, void *keyPtr) { - Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; + Tcl_Obj *objPtr = keyPtr; ChainEntry *cPtr; - cPtr = (ChainEntry *)Tcl_Alloc(sizeof(ChainEntry)); - cPtr->entry.key.objPtr = objPtr; + cPtr = (ChainEntry *) ckalloc(sizeof(ChainEntry)); + cPtr->entry.key.oneWordValue = (char *) objPtr; Tcl_IncrRefCount(objPtr); - Tcl_SetHashValue(&cPtr->entry, NULL); + cPtr->entry.clientData = NULL; cPtr->prevPtr = cPtr->nextPtr = NULL; return &cPtr->entry; } @@ -259,11 +234,11 @@ Dict *dict) { ChainEntry *cPtr; for (cPtr=dict->entryChainHead ; cPtr!=NULL ; cPtr=cPtr->nextPtr) { - Tcl_Obj *valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry); + Tcl_Obj *valuePtr = Tcl_GetHashValue(&cPtr->entry); TclDecrRefCount(valuePtr); } Tcl_DeleteHashTable(&dict->table); } @@ -273,11 +248,11 @@ Dict *dict, Tcl_Obj *keyPtr, int *newPtr) { ChainEntry *cPtr = (ChainEntry *) - Tcl_CreateHashEntry(&dict->table, keyPtr, newPtr); + Tcl_CreateHashEntry(&dict->table, (char *) keyPtr, newPtr); /* * If this is a new entry in the hash table, stitch it into the chain. */ @@ -301,17 +276,16 @@ DeleteChainEntry( Dict *dict, Tcl_Obj *keyPtr) { ChainEntry *cPtr = (ChainEntry *) - Tcl_FindHashEntry(&dict->table, keyPtr); + Tcl_FindHashEntry(&dict->table, (char *) keyPtr); if (cPtr == NULL) { return 0; } else { - Tcl_Obj *valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry); - + Tcl_Obj *valuePtr = Tcl_GetHashValue(&cPtr->entry); TclDecrRefCount(valuePtr); } /* * Unstitch from the chain. @@ -357,47 +331,47 @@ static void DupDictInternalRep( Tcl_Obj *srcPtr, Tcl_Obj *copyPtr) { - Dict *oldDict, *newDict = (Dict *)Tcl_Alloc(sizeof(Dict)); + Dict *oldDict = srcPtr->internalRep.twoPtrValue.ptr1; + Dict *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); + void *key = Tcl_GetHashKey(&oldDict->table, &cPtr->entry); + Tcl_Obj *valuePtr = Tcl_GetHashValue(&cPtr->entry); int n; Tcl_HashEntry *hPtr = CreateChainEntry(newDict, key, &n); /* * Fill in the contents. */ - Tcl_SetHashValue(hPtr, valuePtr); + Tcl_SetHashValue(hPtr, (ClientData) valuePtr); Tcl_IncrRefCount(valuePtr); } /* * Initialise other fields. */ - newDict->epoch = 1; + newDict->epoch = 0; newDict->chain = NULL; - newDict->refCount = 1; + newDict->refcount = 1; /* * Store in the object. */ - DictSetIntRep(copyPtr, newDict); + copyPtr->internalRep.twoPtrValue.ptr1 = newDict; + copyPtr->typePtr = &tclDictType; } /* *---------------------------------------------------------------------- * @@ -418,17 +392,17 @@ static void FreeDictInternalRep( Tcl_Obj *dictPtr) { - Dict *dict; + Dict *dict = dictPtr->internalRep.twoPtrValue.ptr1; - DictGetIntRep(dictPtr, dict); - - if (dict->refCount-- <= 1) { + --dict->refcount; + if (dict->refcount <= 0) { DeleteDict(dict); } + dictPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * @@ -452,11 +426,11 @@ static void DeleteDict( Dict *dict) { DeleteChainTable(dict); - Tcl_Free(dict); + ckfree((char *) dict); } /* *---------------------------------------------------------------------- * @@ -481,87 +455,95 @@ static void UpdateStringOfDict( Tcl_Obj *dictPtr) { -#define LOCAL_SIZE 64 - char localFlags[LOCAL_SIZE], *flagPtr = NULL; - Dict *dict; +#define LOCAL_SIZE 20 + int localFlags[LOCAL_SIZE], *flagPtr = NULL; + Dict *dict = dictPtr->internalRep.twoPtrValue.ptr1; ChainEntry *cPtr; Tcl_Obj *keyPtr, *valuePtr; - size_t i, length, bytesNeeded = 0; - const char *elem; - char *dst; + int i, length, bytesNeeded = 0; + char *elem, *dst; + const int maxFlags = UINT_MAX / sizeof(int); /* * This field is the most useful one in the whole hash structure, and it * is not exposed by any API function... */ - size_t numElems; - - DictGetIntRep(dictPtr, dict); - - assert (dict != NULL); - - numElems = dict->table.numEntries * 2; + int numElems = dict->table.numEntries * 2; /* Handle empty list case first, simplifies what follows */ if (numElems == 0) { - Tcl_InitStringRep(dictPtr, NULL, 0); + dictPtr->bytes = tclEmptyStringRep; + dictPtr->length = 0; return; } /* * Pass 1: estimate space, gather flags. */ if (numElems <= LOCAL_SIZE) { flagPtr = localFlags; + } else if (numElems > maxFlags) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } else { - flagPtr = (char *)Tcl_Alloc(numElems); + flagPtr = (int *) ckalloc((unsigned) numElems*sizeof(int)); } for (i=0,cPtr=dict->entryChainHead; inextPtr) { /* * 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); + 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); + valuePtr = 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); + dictPtr->length = bytesNeeded - 1; + dictPtr->bytes = ckalloc((unsigned) bytesNeeded); + dst = dictPtr->bytes; for (i=0,cPtr=dict->entryChainHead; inextPtr) { flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 ); - keyPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry); + 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); + valuePtr = Tcl_GetHashValue(&cPtr->entry); elem = TclGetStringFromObj(valuePtr, &length); dst += TclConvertElement(elem, length, dst, flagPtr[i+1]); *dst++ = ' '; } - (void)Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1); + dictPtr->bytes[dictPtr->length] = '\0'; if (flagPtr != localFlags) { - Tcl_Free(flagPtr); + ckfree((char *) flagPtr); } } /* *---------------------------------------------------------------------- @@ -587,22 +569,22 @@ SetDictFromAny( Tcl_Interp *interp, Tcl_Obj *objPtr) { Tcl_HashEntry *hPtr; - int isNew; - Dict *dict = (Dict *)Tcl_Alloc(sizeof(Dict)); + int isNew, result; + 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. */ - if (TclHasIntRep(objPtr, &tclListType)) { + if (objPtr->typePtr == &tclListType) { int objc, i; Tcl_Obj **objv; /* Cannot fail, we already know the Tcl_ObjType is "list". */ TclListObjGetElements(NULL, objPtr, &objc, &objv); @@ -613,39 +595,39 @@ for (i=0 ; ibytes = ckalloc((unsigned) elemSize + 1); + keyPtr->length = TclCopyAndCollapse(elemSize, elemStart, + keyPtr->bytes); } - if (TclFindDictElement(interp, nextElem, (limit - nextElem), - &elemStart, &nextElem, &elemSize, &literal) != TCL_OK) { + result = TclFindElement(interp, nextElem, (limit - nextElem), + &elemStart, &nextElem, &elemSize, &literal); + if (result != TCL_OK) { TclDecrRefCount(keyPtr); - goto errorInFindDictElement; + goto errorExit; } if (literal) { TclNewStringObj(valuePtr, elemStart, elemSize); } else { /* Avoid double copy */ - char *dst; - TclNewObj(valuePtr); - Tcl_InvalidateStringRep(valuePtr); - dst = Tcl_InitStringRep(valuePtr, NULL, elemSize); - TclOOM(dst, elemSize); /* Consider error */ - (void)Tcl_InitStringRep(valuePtr, NULL, - TclCopyAndCollapse(elemSize, elemStart, dst)); + valuePtr->bytes = ckalloc((unsigned) elemSize + 1); + valuePtr->length = TclCopyAndCollapse(elemSize, elemStart, + valuePtr->bytes); } /* 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); + Tcl_Obj *discardedValue = Tcl_GetHashValue(hPtr); TclDecrRefCount(keyPtr); TclDecrRefCount(discardedValue); } Tcl_SetHashValue(hPtr, valuePtr); @@ -703,43 +678,28 @@ * 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. */ - dict->epoch = 1; + TclFreeIntRep(objPtr); + dict->epoch = 0; dict->chain = NULL; - dict->refCount = 1; - DictSetIntRep(objPtr, dict); + dict->refcount = 1; + objPtr->internalRep.twoPtrValue.ptr1 = dict; + objPtr->typePtr = &tclDictType; return TCL_OK; missingValue: if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "missing value to go with key", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL); + Tcl_SetResult(interp, "missing value to go with key", TCL_STATIC); } - errorInFindDictElement: + result = TCL_ERROR; + + errorExit: DeleteChainTable(dict); - Tcl_Free(dict); - return TCL_ERROR; -} - -static Dict * -GetDictFromObj( - Tcl_Interp *interp, - Tcl_Obj *dictPtr) -{ - Dict *dict; - - DictGetIntRep(dictPtr, dict); - if (dict == NULL) { - if (SetDictFromAny(interp, dictPtr) != TCL_OK) { - return NULL; - } - DictGetIntRep(dictPtr, dict); - } - return dict; + ckfree((char *) dict); + return result; } /* *---------------------------------------------------------------------- * @@ -781,23 +741,22 @@ int flags) { Dict *dict, *newDict; int i; - DictGetIntRep(dictPtr, dict); - if (dict == NULL) { + if (dictPtr->typePtr != &tclDictType) { if (SetDictFromAny(interp, dictPtr) != TCL_OK) { return NULL; } - DictGetIntRep(dictPtr, dict); } + dict = dictPtr->internalRep.twoPtrValue.ptr1; if (flags & DICT_PATH_UPDATE) { dict->chain = NULL; } for (i=0 ; itable, keyv[i]); + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&dict->table, (char *)keyv[i]); Tcl_Obj *tmpObj; if (hPtr == NULL) { int isNew; /* Dummy */ @@ -804,13 +763,13 @@ if (flags & DICT_PATH_EXISTS) { return DICT_PATH_NON_EXISTENT; } if ((flags & DICT_PATH_CREATE) != DICT_PATH_CREATE) { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "key \"%s\" not known in dictionary", - TclGetString(keyv[i]))); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "key \"", TclGetString(keyv[i]), + "\" not known in dictionary", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", TclGetString(keyv[i]), NULL); } return NULL; } @@ -822,30 +781,27 @@ 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) { + tmpObj = Tcl_GetHashValue(hPtr); + if (tmpObj->typePtr != &tclDictType) { if (SetDictFromAny(interp, tmpObj) != TCL_OK) { return NULL; } } } - DictGetIntRep(tmpObj, newDict); + newDict = tmpObj->internalRep.twoPtrValue.ptr1; if (flags & DICT_PATH_UPDATE) { if (Tcl_IsShared(tmpObj)) { TclDecrRefCount(tmpObj); tmpObj = Tcl_DuplicateObj(tmpObj); Tcl_IncrRefCount(tmpObj); - Tcl_SetHashValue(hPtr, tmpObj); + Tcl_SetHashValue(hPtr, (ClientData) tmpObj); dict->epoch++; - DictGetIntRep(tmpObj, newDict); + newDict = tmpObj->internalRep.twoPtrValue.ptr1; } newDict->chain = dictPtr; } dict = newDict; @@ -876,28 +832,21 @@ static void InvalidateDictChain( Tcl_Obj *dictObj) { - Dict *dict; - - DictGetIntRep(dictObj, dict); - assert( dict != NULL); + Dict *dict = dictObj->internalRep.twoPtrValue.ptr1; do { - dict->refCount++; TclInvalidateStringRep(dictObj); - TclFreeIntRep(dictObj); - DictSetIntRep(dictObj, dict); - dict->epoch++; dictObj = dict->chain; if (dictObj == NULL) { break; } dict->chain = NULL; - DictGetIntRep(dictObj, dict); + dict = dictObj->internalRep.twoPtrValue.ptr1; } while (dict != NULL); } /* *---------------------------------------------------------------------- @@ -931,23 +880,26 @@ if (Tcl_IsShared(dictPtr)) { Tcl_Panic("%s called with shared object", "Tcl_DictObjPut"); } - dict = GetDictFromObj(interp, dictPtr); - if (dict == NULL) { - return TCL_ERROR; + if (dictPtr->typePtr != &tclDictType) { + int result = SetDictFromAny(interp, dictPtr); + + if (result != TCL_OK) { + return result; + } } - TclInvalidateStringRep(dictPtr); + if (dictPtr->bytes != NULL) { + TclInvalidateStringRep(dictPtr); + } + dict = dictPtr->internalRep.twoPtrValue.ptr1; 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); + Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr); TclDecrRefCount(oldValuePtr); } Tcl_SetHashValue(hPtr, valuePtr); dict->epoch++; @@ -982,21 +934,24 @@ Tcl_Obj **valuePtrPtr) { Dict *dict; Tcl_HashEntry *hPtr; - dict = GetDictFromObj(interp, dictPtr); - if (dict == NULL) { - *valuePtrPtr = NULL; - return TCL_ERROR; + if (dictPtr->typePtr != &tclDictType) { + int result = SetDictFromAny(interp, dictPtr); + if (result != TCL_OK) { + *valuePtrPtr = NULL; + return result; + } } - hPtr = Tcl_FindHashEntry(&dict->table, keyPtr); + dict = dictPtr->internalRep.twoPtrValue.ptr1; + hPtr = Tcl_FindHashEntry(&dict->table, (char *) keyPtr); if (hPtr == NULL) { *valuePtrPtr = NULL; } else { - *valuePtrPtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr); + *valuePtrPtr = Tcl_GetHashValue(hPtr); } return TCL_OK; } /* @@ -1028,17 +983,22 @@ if (Tcl_IsShared(dictPtr)) { Tcl_Panic("%s called with shared object", "Tcl_DictObjRemove"); } - dict = GetDictFromObj(interp, dictPtr); - if (dict == NULL) { - return TCL_ERROR; + if (dictPtr->typePtr != &tclDictType) { + int result = SetDictFromAny(interp, dictPtr); + if (result != TCL_OK) { + return result; + } } - if (DeleteChainEntry(dict, keyPtr)) { + if (dictPtr->bytes != NULL) { TclInvalidateStringRep(dictPtr); + } + dict = dictPtr->internalRep.twoPtrValue.ptr1; + if (DeleteChainEntry(dict, keyPtr)) { dict->epoch++; } return TCL_OK; } @@ -1066,15 +1026,18 @@ Tcl_Obj *dictPtr, int *sizePtr) { Dict *dict; - dict = GetDictFromObj(interp, dictPtr); - if (dict == NULL) { - return TCL_ERROR; + if (dictPtr->typePtr != &tclDictType) { + int result = SetDictFromAny(interp, dictPtr); + if (result != TCL_OK) { + return result; + } } + dict = dictPtr->internalRep.twoPtrValue.ptr1; *sizePtr = dict->table.numEntries; return TCL_OK; } /* @@ -1117,30 +1080,35 @@ * otherwise. */ { Dict *dict; ChainEntry *cPtr; - dict = GetDictFromObj(interp, dictPtr); - if (dict == NULL) { - return TCL_ERROR; + if (dictPtr->typePtr != &tclDictType) { + int result = SetDictFromAny(interp, dictPtr); + + if (result != TCL_OK) { + return result; + } } + dict = dictPtr->internalRep.twoPtrValue.ptr1; cPtr = dict->entryChainHead; if (cPtr == NULL) { - searchPtr->epoch = 0; + searchPtr->epoch = -1; *donePtr = 1; } else { *donePtr = 0; searchPtr->dictionaryPtr = (Tcl_Dict) dict; searchPtr->epoch = dict->epoch; searchPtr->next = cPtr->nextPtr; - dict->refCount++; + dict->refcount++; if (keyPtrPtr != NULL) { - *keyPtrPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry); + *keyPtrPtr = (Tcl_Obj *) Tcl_GetHashKey(&dict->table, + &cPtr->entry); } if (valuePtrPtr != NULL) { - *valuePtrPtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry); + *valuePtrPtr = Tcl_GetHashValue(&cPtr->entry); } } return TCL_OK; } @@ -1185,11 +1153,11 @@ /* * If the searh is done; we do no work. */ - if (!searchPtr->epoch) { + if (searchPtr->epoch == -1) { *donePtr = 1; return; } /* @@ -1199,25 +1167,25 @@ if (((Dict *)searchPtr->dictionaryPtr)->epoch != searchPtr->epoch) { Tcl_Panic("concurrent dictionary modification and search"); } - cPtr = (ChainEntry *)searchPtr->next; + cPtr = 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( + *keyPtrPtr = (Tcl_Obj *) Tcl_GetHashKey( &((Dict *)searchPtr->dictionaryPtr)->table, &cPtr->entry); } if (valuePtrPtr != NULL) { - *valuePtrPtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry); + *valuePtrPtr = Tcl_GetHashValue(&cPtr->entry); } } /* *---------------------------------------------------------------------- @@ -1242,14 +1210,15 @@ Tcl_DictObjDone( Tcl_DictSearch *searchPtr) /* Pointer to a hash search context. */ { Dict *dict; - if (searchPtr->epoch) { - searchPtr->epoch = 0; + if (searchPtr->epoch != -1) { + searchPtr->epoch = -1; dict = (Dict *) searchPtr->dictionaryPtr; - if (dict->refCount-- <= 1) { + dict->refcount--; + if (dict->refcount <= 0) { DeleteDict(dict); } } } @@ -1295,17 +1264,15 @@ dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_CREATE); if (dictPtr == NULL) { return TCL_ERROR; } - DictGetIntRep(dictPtr, dict); - assert(dict != NULL); + dict = dictPtr->internalRep.twoPtrValue.ptr1; hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew); Tcl_IncrRefCount(valuePtr); if (!isNew) { - Tcl_Obj *oldValuePtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr); - + Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr); TclDecrRefCount(oldValuePtr); } Tcl_SetHashValue(hPtr, valuePtr); InvalidateDictChain(dictPtr); @@ -1353,12 +1320,11 @@ dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_UPDATE); if (dictPtr == NULL) { return TCL_ERROR; } - DictGetIntRep(dictPtr, dict); - assert(dict != NULL); + dict = dictPtr->internalRep.twoPtrValue.ptr1; DeleteChainEntry(dict, keyv[keyc-1]); InvalidateDictChain(dictPtr); return TCL_OK; } @@ -1395,16 +1361,17 @@ Tcl_Obj *dictPtr; Dict *dict; TclNewObj(dictPtr); TclInvalidateStringRep(dictPtr); - dict = (Dict *)Tcl_Alloc(sizeof(Dict)); + dict = (Dict *) ckalloc(sizeof(Dict)); InitChainTable(dict); - dict->epoch = 1; + dict->epoch = 0; dict->chain = NULL; - dict->refCount = 1; - DictSetIntRep(dictPtr, dict); + dict->refcount = 1; + dictPtr->internalRep.twoPtrValue.ptr1 = dict; + dictPtr->typePtr = &tclDictType; return dictPtr; #endif } /* @@ -1432,38 +1399,33 @@ * None. * *---------------------------------------------------------------------- */ -#ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewDictObj( const char *file, int line) { +#ifdef TCL_MEM_DEBUG Tcl_Obj *dictPtr; Dict *dict; TclDbNewObj(dictPtr, file, line); TclInvalidateStringRep(dictPtr); - dict = (Dict *)Tcl_Alloc(sizeof(Dict)); + dict = (Dict *) ckalloc(sizeof(Dict)); InitChainTable(dict); - dict->epoch = 1; + dict->epoch = 0; dict->chain = NULL; - dict->refCount = 1; - DictSetIntRep(dictPtr, dict); + dict->refcount = 1; + dictPtr->internalRep.twoPtrValue.ptr1 = dict; + dictPtr->typePtr = &tclDictType; 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 *****/ /* *---------------------------------------------------------------------- @@ -1483,11 +1445,11 @@ *---------------------------------------------------------------------- */ static int DictCreateCmd( - TCL_UNUSED(ClientData), + ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { Tcl_Obj *dictObj; @@ -1507,11 +1469,11 @@ dictObj = Tcl_NewDictObj(); for (i=1 ; itypePtr != &tclDictType) { + if (SetDictFromAny(interp, targetObj) != TCL_OK) { + return TCL_ERROR; + } } if (objc == 2) { /* * Single argument, return it. @@ -1874,17 +1779,17 @@ *---------------------------------------------------------------------- */ static int DictKeysCmd( - TCL_UNUSED(ClientData), + ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { Tcl_Obj *listPtr; - const char *pattern = NULL; + char *pattern = NULL; if (objc!=2 && objc!=3) { Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?pattern?"); return TCL_ERROR; } @@ -1893,12 +1798,16 @@ * A direct check that we have a dictionary. We don't start the iteration * yet because that might allocate memory or set locks that we do not * need. [Bug 1705778, leak K04] */ - if (GetDictFromObj(interp, objv[1]) == NULL) { - return TCL_ERROR; + if (objv[1]->typePtr != &tclDictType) { + int result = SetDictFromAny(interp, objv[1]); + + if (result != TCL_OK) { + return result; + } } if (objc == 3) { pattern = TclGetString(objv[2]); } @@ -1910,12 +1819,12 @@ if (valuePtr != NULL) { Tcl_ListObjAppendElement(NULL, listPtr, objv[2]); } } else { Tcl_DictSearch search; - Tcl_Obj *keyPtr = NULL; - int done = 0; + Tcl_Obj *keyPtr; + int done; /* * At this point, we know we have a dictionary (or at least something * that can be represented; it could theoretically have shimmered away * when the pattern was fetched, but that shouldn't be damaging) so we @@ -1953,19 +1862,19 @@ *---------------------------------------------------------------------- */ static int DictValuesCmd( - TCL_UNUSED(ClientData), + ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { - Tcl_Obj *valuePtr = NULL, *listPtr; + Tcl_Obj *valuePtr, *listPtr; Tcl_DictSearch search; int done; - const char *pattern; + char *pattern; if (objc!=2 && objc!=3) { Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?pattern?"); return TCL_ERROR; } @@ -2013,11 +1922,11 @@ *---------------------------------------------------------------------- */ static int DictSizeCmd( - TCL_UNUSED(ClientData), + ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { int result, size; @@ -2026,11 +1935,11 @@ Tcl_WrongNumArgs(interp, 1, objv, "dictionary"); return TCL_ERROR; } result = Tcl_DictObjSize(interp, objv[1], &size); if (result == TCL_OK) { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(size)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(size)); } return result; } /* @@ -2051,11 +1960,11 @@ *---------------------------------------------------------------------- */ static int DictExistsCmd( - TCL_UNUSED(ClientData), + ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { Tcl_Obj *dictPtr, *valuePtr; @@ -2063,13 +1972,15 @@ if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "dictionary key ?key ...?"); return TCL_ERROR; } - dictPtr = TclTraceDictPath(NULL, objv[1], objc-3, objv+2,DICT_PATH_EXISTS); - if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT || - Tcl_DictObjGet(NULL, dictPtr, objv[objc-1], &valuePtr) != TCL_OK) { + dictPtr = TclTraceDictPath(interp, objv[1], objc-3, objv+2, + DICT_PATH_EXISTS); + if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT + || Tcl_DictObjGet(interp, dictPtr, objv[objc-1], + &valuePtr) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); } else { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(valuePtr != NULL)); } return TCL_OK; @@ -2093,31 +2004,37 @@ *---------------------------------------------------------------------- */ static int DictInfoCmd( - TCL_UNUSED(ClientData), + ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { + Tcl_Obj *dictPtr; 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)); - Tcl_Free(statsStr); + dictPtr = objv[1]; + if (dictPtr->typePtr != &tclDictType) { + int result = SetDictFromAny(interp, dictPtr); + if (result != TCL_OK) { + return result; + } + } + dict = dictPtr->internalRep.twoPtrValue.ptr1; + + /* + * This next cast is actually OK. + */ + + Tcl_SetResult(interp, (char *) Tcl_HashStats(&dict->table), TCL_DYNAMIC); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -2137,20 +2054,20 @@ *---------------------------------------------------------------------- */ static int DictIncrCmd( - TCL_UNUSED(ClientData), + ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { int code = TCL_OK; Tcl_Obj *dictPtr, *valuePtr = NULL; if (objc < 3 || objc > 4) { - Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?increment?"); + Tcl_WrongNumArgs(interp, 1, objv, "varName key ?increment?"); return TCL_ERROR; } dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0); if (dictPtr == NULL) { @@ -2170,15 +2087,16 @@ /* * A little internals surgery to avoid copying a string rep that will * soon be no good. */ + char *saved = dictPtr->bytes; Tcl_Obj *oldPtr = dictPtr; - TclNewObj(dictPtr); - TclInvalidateStringRep(dictPtr); - DupDictInternalRep(oldPtr, dictPtr); + dictPtr->bytes = NULL; + dictPtr = Tcl_DuplicateObj(dictPtr); + oldPtr->bytes = saved; } if (valuePtr == NULL) { /* * Key not in dictionary. Create new key with increment as value. */ @@ -2198,33 +2116,32 @@ * Remember to dispose with the bignum as we're not actually * using it directly. [Bug 2874678] */ mp_clear(&increment); - Tcl_DictObjPut(NULL, dictPtr, objv[2], objv[3]); + Tcl_DictObjPut(interp, dictPtr, objv[2], objv[3]); } } else { - Tcl_DictObjPut(NULL, dictPtr, objv[2], Tcl_NewWideIntObj(1)); + Tcl_DictObjPut(interp, dictPtr, objv[2], Tcl_NewIntObj(1)); } } else { /* * Key in dictionary. Increment its value with minimum dup. */ if (Tcl_IsShared(valuePtr)) { valuePtr = Tcl_DuplicateObj(valuePtr); - Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr); + Tcl_DictObjPut(interp, dictPtr, objv[2], valuePtr); } if (objc == 4) { code = TclIncrObj(interp, valuePtr, objv[3]); } else { - Tcl_Obj *incrPtr; + Tcl_Obj *incrPtr = Tcl_NewIntObj(1); - TclNewIntObj(incrPtr, 1); Tcl_IncrRefCount(incrPtr); code = TclIncrObj(interp, valuePtr, incrPtr); - TclDecrRefCount(incrPtr); + Tcl_DecrRefCount(incrPtr); } } if (code == TCL_OK) { TclInvalidateStringRep(dictPtr); valuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, @@ -2233,11 +2150,11 @@ code = TCL_ERROR; } else { Tcl_SetObjResult(interp, valuePtr); } } else if (dictPtr->refCount == 0) { - TclDecrRefCount(dictPtr); + Tcl_DecrRefCount(dictPtr); } return code; } /* @@ -2258,20 +2175,20 @@ *---------------------------------------------------------------------- */ static int DictLappendCmd( - TCL_UNUSED(ClientData), + ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { Tcl_Obj *dictPtr, *valuePtr, *resultPtr; int i, allocatedDict = 0, allocatedValue = 0; if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?value ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "varName key ?value ...?"); return TCL_ERROR; } dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0); if (dictPtr == NULL) { @@ -2311,12 +2228,12 @@ } } } if (allocatedValue) { - Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr); - } else { + Tcl_DictObjPut(interp, dictPtr, objv[2], valuePtr); + } else if (dictPtr->bytes != NULL) { TclInvalidateStringRep(dictPtr); } resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr, TCL_LEAVE_ERR_MSG); @@ -2345,20 +2262,20 @@ *---------------------------------------------------------------------- */ static int DictAppendCmd( - TCL_UNUSED(ClientData), + ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { Tcl_Obj *dictPtr, *valuePtr, *resultPtr; - int allocatedDict = 0; + int i, allocatedDict = 0; if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?value ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "varName key ?value ...?"); return TCL_ERROR; } dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0); if (dictPtr == NULL) { @@ -2374,53 +2291,23 @@ TclDecrRefCount(dictPtr); } return TCL_ERROR; } - if ((objc > 3) || (valuePtr == NULL)) { - /* Only go through append activites when something will change. */ - Tcl_Obj *appendObjPtr = NULL; - - if (objc > 3) { - /* Something to append */ - - if (objc == 4) { - appendObjPtr = objv[3]; - } else { - appendObjPtr = TclStringCat(interp, objc-3, objv+3, - TCL_STRING_IN_PLACE); - if (appendObjPtr == NULL) { - return TCL_ERROR; - } - } - } - - if (appendObjPtr == NULL) { - /* => (objc == 3) => (valuePtr == NULL) */ - TclNewObj(valuePtr); - } else if (valuePtr == NULL) { - valuePtr = appendObjPtr; - appendObjPtr = NULL; - } - - if (appendObjPtr) { - if (Tcl_IsShared(valuePtr)) { - valuePtr = Tcl_DuplicateObj(valuePtr); - } - - Tcl_IncrRefCount(appendObjPtr); - Tcl_AppendObjToObj(valuePtr, appendObjPtr); - Tcl_DecrRefCount(appendObjPtr); - } - - Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr); - } - - /* - * Even if nothing changed, we still overwrite so that variable - * trace expectations are met. - */ + if (valuePtr == NULL) { + TclNewObj(valuePtr); + } else { + if (Tcl_IsShared(valuePtr)) { + valuePtr = Tcl_DuplicateObj(valuePtr); + } + } + + for (i=3 ; icmdFramePtr, 3); - - /* - * For unwinding everything on error. - */ - - error: - TclDecrRefCount(keyVarObj); - TclDecrRefCount(valueVarObj); - TclDecrRefCount(scriptObj); - Tcl_DictObjDone(searchPtr); - TclStackFree(interp, searchPtr); - return TCL_ERROR; -} - -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. - */ - - if (result == TCL_CONTINUE) { - result = TCL_OK; - } else if (result != TCL_OK) { - if (result == TCL_BREAK) { - Tcl_ResetResult(interp); - result = TCL_OK; - } else if (result == TCL_ERROR) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"dict for\" body line %d)", - Tcl_GetErrorLine(interp))); - } - goto done; - } - - /* - * Get the next mapping from the dictionary. - */ - - Tcl_DictObjNext(searchPtr, &keyObj, &valueObj, &done); - if (done) { - Tcl_ResetResult(interp); - goto done; - } - - /* - * Stop the value from getting hit in any way by any traces on the key - * variable. - */ - - Tcl_IncrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, - TCL_LEAVE_ERR_MSG) == NULL) { - TclDecrRefCount(valueObj); - result = TCL_ERROR; - goto done; - } - TclDecrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, - TCL_LEAVE_ERR_MSG) == NULL) { - result = TCL_ERROR; - goto done; - } - - /* - * Run the script. - */ - - TclNRAddCallback(interp, DictForLoopCallback, searchPtr, keyVarObj, - valueVarObj, scriptObj); - return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3); - - /* - * For unwinding everything once the iterating is done. - */ - - done: - TclDecrRefCount(keyVarObj); - TclDecrRefCount(valueVarObj); - TclDecrRefCount(scriptObj); - Tcl_DictObjDone(searchPtr); - TclStackFree(interp, searchPtr); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * DictMapNRCmd -- - * - * These functions implement the "dict map" Tcl command. See the user - * documentation for details on what it does, and TIP#405 for the formal - * specification. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * 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; - int varc, done; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, - "{keyVarName valueVarName} dictionary script"); - return TCL_ERROR; - } - - /* - * Parse arguments. - */ - - if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) { - return TCL_ERROR; - } - if (varc != 2) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "must have exactly two variable names", -1)); - Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "map", NULL); - return TCL_ERROR; - } - storagePtr = (DictMapStorage *)TclStackAlloc(interp, sizeof(DictMapStorage)); - if (Tcl_DictObjFirst(interp, objv[2], &storagePtr->search, &keyObj, - &valueObj, &done) != TCL_OK) { - TclStackFree(interp, storagePtr); - return TCL_ERROR; - } - if (done) { - /* - * Note that this exit leaves an empty value in the result (due to - * command calling conventions) but that is OK since an empty value is - * an empty dictionary. - */ - - TclStackFree(interp, storagePtr); - return TCL_OK; - } - TclNewObj(storagePtr->accumulatorObj); - TclListObjGetElements(NULL, objv[1], &varc, &varv); - storagePtr->keyVarObj = varv[0]; - storagePtr->valueVarObj = varv[1]; - storagePtr->scriptObj = objv[3]; - - /* - * Make sure that these objects (which we need throughout the body of the - * loop) don't vanish. Note that the dictionary internal rep is locked - * internally so that updates, shimmering, etc are not a problem. - */ - - Tcl_IncrRefCount(storagePtr->accumulatorObj); - Tcl_IncrRefCount(storagePtr->keyVarObj); - Tcl_IncrRefCount(storagePtr->valueVarObj); - Tcl_IncrRefCount(storagePtr->scriptObj); - - /* - * Stop the value from getting hit in any way by any traces on the key - * variable. - */ - - Tcl_IncrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, storagePtr->keyVarObj, NULL, keyObj, - TCL_LEAVE_ERR_MSG) == NULL) { - TclDecrRefCount(valueObj); - goto error; - } - if (Tcl_ObjSetVar2(interp, storagePtr->valueVarObj, NULL, valueObj, - TCL_LEAVE_ERR_MSG) == NULL) { - TclDecrRefCount(valueObj); - goto error; - } - TclDecrRefCount(valueObj); - - /* - * Run the script. - */ - - TclNRAddCallback(interp, DictMapLoopCallback, storagePtr, NULL,NULL,NULL); - return TclNREvalObjEx(interp, storagePtr->scriptObj, 0, - iPtr->cmdFramePtr, 3); - - /* - * For unwinding everything on error. - */ - - error: - TclDecrRefCount(storagePtr->keyVarObj); - TclDecrRefCount(storagePtr->valueVarObj); - TclDecrRefCount(storagePtr->scriptObj); - TclDecrRefCount(storagePtr->accumulatorObj); - Tcl_DictObjDone(&storagePtr->search); - TclStackFree(interp, storagePtr); - return TCL_ERROR; -} - -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. - */ - - if (result == TCL_CONTINUE) { - result = TCL_OK; - } else if (result != TCL_OK) { - if (result == TCL_BREAK) { - Tcl_ResetResult(interp); - result = TCL_OK; - } else if (result == TCL_ERROR) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"dict map\" body line %d)", - Tcl_GetErrorLine(interp))); - } - goto done; - } else { - keyObj = Tcl_ObjGetVar2(interp, storagePtr->keyVarObj, NULL, - TCL_LEAVE_ERR_MSG); - if (keyObj == NULL) { - result = TCL_ERROR; - goto done; - } - Tcl_DictObjPut(NULL, storagePtr->accumulatorObj, keyObj, - Tcl_GetObjResult(interp)); - } - - /* - * Get the next mapping from the dictionary. - */ - - Tcl_DictObjNext(&storagePtr->search, &keyObj, &valueObj, &done); - if (done) { - Tcl_SetObjResult(interp, storagePtr->accumulatorObj); - goto done; - } - - /* - * Stop the value from getting hit in any way by any traces on the key - * variable. - */ - - Tcl_IncrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, storagePtr->keyVarObj, NULL, keyObj, - TCL_LEAVE_ERR_MSG) == NULL) { - TclDecrRefCount(valueObj); - result = TCL_ERROR; - goto done; - } - if (Tcl_ObjSetVar2(interp, storagePtr->valueVarObj, NULL, valueObj, - TCL_LEAVE_ERR_MSG) == NULL) { - TclDecrRefCount(valueObj); - result = TCL_ERROR; - goto done; - } - TclDecrRefCount(valueObj); - - /* - * Run the script. - */ - - TclNRAddCallback(interp, DictMapLoopCallback, storagePtr, NULL,NULL,NULL); - return TclNREvalObjEx(interp, storagePtr->scriptObj, 0, - iPtr->cmdFramePtr, 3); - - /* - * For unwinding everything once the iterating is done. - */ - - done: - TclDecrRefCount(storagePtr->keyVarObj); - TclDecrRefCount(storagePtr->valueVarObj); - TclDecrRefCount(storagePtr->scriptObj); - TclDecrRefCount(storagePtr->accumulatorObj); - Tcl_DictObjDone(&storagePtr->search); - TclStackFree(interp, storagePtr); + result = TCL_OK; + while (!done) { + /* + * Stop the value from getting hit in any way by any traces on the key + * variable. + */ + + Tcl_IncrRefCount(valueObj); + if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, 0) == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't set key variable: \"", + TclGetString(keyVarObj), "\"", NULL); + TclDecrRefCount(valueObj); + result = TCL_ERROR; + break; + } + TclDecrRefCount(valueObj); + if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, 0) == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't set value variable: \"", + TclGetString(valueVarObj), "\"", NULL); + result = TCL_ERROR; + break; + } + + /* + * TIP #280. Make invoking context available to loop body. + */ + + result = TclEvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3); + if (result == TCL_CONTINUE) { + result = TCL_OK; + } else if (result != TCL_OK) { + if (result == TCL_BREAK) { + result = TCL_OK; + } else if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"dict for\" body line %d)", + interp->errorLine)); + } + break; + } + + Tcl_DictObjNext(&search, &keyObj, &valueObj, &done); + } + + /* + * Stop holding a reference to these objects. + */ + + TclDecrRefCount(keyVarObj); + TclDecrRefCount(valueVarObj); + TclDecrRefCount(scriptObj); + + Tcl_DictObjDone(&search); + if (result == TCL_OK) { + Tcl_ResetResult(interp); + } return result; } /* *---------------------------------------------------------------------- @@ -2854,20 +2459,20 @@ *---------------------------------------------------------------------- */ static int DictSetCmd( - TCL_UNUSED(ClientData), + ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { Tcl_Obj *dictPtr, *resultPtr; int result, allocatedDict = 0; if (objc < 4) { - Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?key ...? value"); + Tcl_WrongNumArgs(interp, 1, objv, "varName key ?key ...? value"); return TCL_ERROR; } dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0); if (dictPtr == NULL) { @@ -2914,20 +2519,20 @@ *---------------------------------------------------------------------- */ static int DictUnsetCmd( - TCL_UNUSED(ClientData), + ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { Tcl_Obj *dictPtr, *resultPtr; int result, allocatedDict = 0; if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?key ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "varName key ?key ...?"); return TCL_ERROR; } dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0); if (dictPtr == NULL) { @@ -2973,129 +2578,105 @@ *---------------------------------------------------------------------- */ static int DictFilterCmd( - TCL_UNUSED(ClientData), + ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { Interp *iPtr = (Interp *) interp; - static const char *const filters[] = { + static const char *filters[] = { "key", "script", "value", NULL }; enum FilterTypes { FILTER_KEYS, FILTER_SCRIPT, FILTER_VALUES }; Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj; - Tcl_Obj **varv, *keyObj = NULL, *valueObj = NULL, *resultObj, *boolObj; + Tcl_Obj **varv, *keyObj, *valueObj, *resultObj, *boolObj; Tcl_DictSearch search; int index, varc, done, result, satisfied; - const char *pattern; + char *pattern; if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "dictionary filterType ?arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "dictionary filterType ..."); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[2], filters, "filterType", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum FilterTypes) index) { case FILTER_KEYS: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "dictionary key globPattern"); + return TCL_ERROR; + } + /* * Create a dictionary whose keys all match a certain pattern. */ if (Tcl_DictObjFirst(interp, objv[1], &search, &keyObj, &valueObj, &done) != TCL_OK) { return TCL_ERROR; } - if (objc == 3) { - /* - * Nothing to match, so return nothing (== empty dictionary). - */ - - Tcl_DictObjDone(&search); - return TCL_OK; - } else if (objc == 4) { - pattern = TclGetString(objv[3]); - resultObj = Tcl_NewDictObj(); - if (TclMatchIsTrivial(pattern)) { - /* - * Must release the search lock here to prevent a memory leak - * since we are not exhausing the search. [Bug 1705778, leak - * K05] - */ - - Tcl_DictObjDone(&search); - Tcl_DictObjGet(interp, objv[1], objv[3], &valueObj); - if (valueObj != NULL) { - Tcl_DictObjPut(NULL, resultObj, objv[3], valueObj); - } - } else { - while (!done) { - if (Tcl_StringMatch(TclGetString(keyObj), pattern)) { - Tcl_DictObjPut(NULL, resultObj, keyObj, valueObj); - } - Tcl_DictObjNext(&search, &keyObj, &valueObj, &done); - } - } - } else { - /* - * Can't optimize this match for trivial globbing: would disturb - * order. - */ - - resultObj = Tcl_NewDictObj(); - while (!done) { - int i; - - for (i=3 ; ierrorLine)); default: goto abnormalResult; } TclDecrRefCount(keyObj); @@ -3258,22 +2839,23 @@ *---------------------------------------------------------------------- */ static int DictUpdateCmd( - TCL_UNUSED(ClientData), + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { Interp *iPtr = (Interp *) interp; Tcl_Obj *dictPtr, *objPtr; - int i, dummy; + int i, result, dummy; + Tcl_InterpState state; if (objc < 5 || !(objc & 1)) { Tcl_WrongNumArgs(interp, 1, objv, - "dictVarName key varName ?key varName ...? script"); + "varName key varName ?key varName ...? script"); return TCL_ERROR; } dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); if (dictPtr == NULL) { @@ -3288,72 +2870,44 @@ TclDecrRefCount(dictPtr); return TCL_ERROR; } if (objPtr == NULL) { /* ??? */ - Tcl_UnsetVar2(interp, TclGetString(objv[i+1]), NULL, 0); + Tcl_UnsetVar(interp, Tcl_GetString(objv[i+1]), 0); } else if (Tcl_ObjSetVar2(interp, objv[i+1], NULL, objPtr, TCL_LEAVE_ERR_MSG) == NULL) { TclDecrRefCount(dictPtr); return TCL_ERROR; } } TclDecrRefCount(dictPtr); /* - * Execute the body after setting up the NRE handler to process the - * results. - */ - - objPtr = Tcl_NewListObj(objc-3, objv+2); - Tcl_IncrRefCount(objPtr); - Tcl_IncrRefCount(objv[1]); - TclNRAddCallback(interp, FinalizeDictUpdate, objv[1], objPtr, NULL,NULL); - - return TclNREvalObjEx(interp, objv[objc-1], 0, iPtr->cmdFramePtr, objc-1); -} - -static int -FinalizeDictUpdate( - 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. - */ - + * Execute the body. + */ + + result = TclEvalObjEx(interp, objv[objc-1], 0, iPtr->cmdFramePtr, objc-1); if (result == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (body of \"dict update\")"); } /* * If the dictionary variable doesn't exist, drop everything silently. */ - dictPtr = Tcl_ObjGetVar2(interp, varName, NULL, 0); + dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0); if (dictPtr == NULL) { - TclDecrRefCount(varName); - TclDecrRefCount(argsObj); return result; } /* * Double-check that it is still a dictionary. */ state = Tcl_SaveInterpState(interp, result); - if (Tcl_DictObjSize(interp, dictPtr, &objc) != TCL_OK) { + if (Tcl_DictObjSize(interp, dictPtr, &dummy) != TCL_OK) { Tcl_DiscardInterpState(state); - TclDecrRefCount(varName); - TclDecrRefCount(argsObj); return TCL_ERROR; } if (Tcl_IsShared(dictPtr)) { dictPtr = Tcl_DuplicateObj(dictPtr); @@ -3362,41 +2916,38 @@ /* * Write back the values from the variables, treating failure to read as * an instruction to remove the key. */ - Tcl_ListObjGetElements(NULL, argsObj, &objc, &objv); - for (i=0 ; i 3) { - pathPtr = Tcl_NewListObj(objc-3, objv+2); - Tcl_IncrRefCount(pathPtr); - } - Tcl_IncrRefCount(objv[1]); - TclNRAddCallback(interp, FinalizeDictWith, objv[1], keysPtr, pathPtr, - NULL); - - return TclNREvalObjEx(interp, objv[objc-1], 0, iPtr->cmdFramePtr, objc-1); -} - -static int -FinalizeDictWith( - 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\")"); - } - - /* - * Save the result state; TDWF doesn't guarantee to not modify that on - * TCL_OK result. - */ - - state = Tcl_SaveInterpState(interp, result); - if (pathPtr != NULL) { - Tcl_ListObjGetElements(NULL, pathPtr, &pathc, &pathv); - } else { - pathc = 0; - pathv = NULL; - } - - /* - * Pack from local variables back into the dictionary. - */ - - varPtr = TclObjLookupVarEx(interp, varName, NULL, TCL_LEAVE_ERR_MSG, "set", - /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); - if (varPtr == NULL) { - result = TCL_ERROR; - } else { - result = TclDictWithFinish(interp, varPtr, arrayPtr, varName, NULL, -1, - pathc, pathv, keysPtr); - } - - /* - * Tidy up and return the real result (unless we had an error). - */ - - TclDecrRefCount(varName); - TclDecrRefCount(keysPtr); - if (pathPtr != NULL) { - TclDecrRefCount(pathPtr); - } - if (result != TCL_OK) { - Tcl_DiscardInterpState(state); - return TCL_ERROR; - } - return Tcl_RestoreInterpState(interp, state); -} - -/* - *---------------------------------------------------------------------- - * - * TclDictWithInit -- - * - * Part of the core of [dict with]. Pokes into a dictionary and converts - * the mappings there into assignments to (presumably) local variables. - * Returns a list of all the names that were mapped so that removal of - * either the variable or the dictionary entry won't surprise us when we - * come to stuffing everything back. - * - * Result: - * List of mapped names, or NULL if there was an error. - * - * Side effects: - * Assigns to variables, so potentially legion due to traces. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclDictWithInit( - Tcl_Interp *interp, - Tcl_Obj *dictPtr, - int pathc, - Tcl_Obj *const pathv[]) -{ - Tcl_DictSearch s; - Tcl_Obj *keyPtr, *valPtr, *keysPtr; - int done; - - if (pathc > 0) { - dictPtr = TclTraceDictPath(interp, dictPtr, pathc, pathv, + dictPtr = TclTraceDictPath(interp, dictPtr, objc-3, objv+2, DICT_PATH_READ); if (dictPtr == NULL) { - return NULL; + return TCL_ERROR; } } /* * Go over the list of keys and write each corresponding value to a @@ -3569,124 +3008,88 @@ * has been structurally modified. */ if (Tcl_DictObjFirst(interp, dictPtr, &s, &keyPtr, &valPtr, &done) != TCL_OK) { - return NULL; + return TCL_ERROR; } TclNewObj(keysPtr); + Tcl_IncrRefCount(keysPtr); for (; !done ; Tcl_DictObjNext(&s, &keyPtr, &valPtr, &done)) { Tcl_ListObjAppendElement(NULL, keysPtr, keyPtr); if (Tcl_ObjSetVar2(interp, keyPtr, NULL, valPtr, TCL_LEAVE_ERR_MSG) == NULL) { TclDecrRefCount(keysPtr); Tcl_DictObjDone(&s); - return NULL; - } - } - - return keysPtr; -} - -/* - *---------------------------------------------------------------------- - * - * TclDictWithFinish -- - * - * Part of the core of [dict with]. Reassembles the piece of the dict (in - * varName, location given by pathc/pathv) from the variables named in - * the keysPtr argument. NB, does not try to preserve errors or manage - * argument lifetimes. - * - * Result: - * TCL_OK if we succeeded, or TCL_ERROR if we failed. - * - * Side effects: - * Assigns to a variable, so potentially legion due to traces. Updates - * the dictionary in the named variable. - * - *---------------------------------------------------------------------- - */ - -int -TclDictWithFinish( - Tcl_Interp *interp, /* Command interpreter in which variable - * exists. Used for state management, traces - * and error reporting. */ - Var *varPtr, /* Reference to the variable holding the - * dictionary. */ - Var *arrayPtr, /* Reference to the array containing the - * variable, or NULL if the variable is a - * scalar. */ - Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or - * the name of a variable. NULL if the 'index' - * parameter is >= 0 */ - Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element - * in the array part1. */ - int index, /* Index into the local variable table of the - * variable, or -1. Only used when part1Ptr is - * NULL. */ - int pathc, /* The number of elements in the path into the - * dictionary. */ - Tcl_Obj *const pathv[], /* The elements of the path to the subdict. */ - Tcl_Obj *keysPtr) /* List of keys to be synchronized. This is - * the result value from TclDictWithInit. */ -{ - Tcl_Obj *dictPtr, *leafPtr, *valPtr; - int i, allocdict, keyc; - Tcl_Obj **keyv; + return TCL_ERROR; + } + } + + /* + * Execute the body, while making the invoking context available to the + * loop body (TIP#280). + */ + + result = TclEvalObjEx(interp, objv[objc-1], 0, iPtr->cmdFramePtr, objc-1); + if (result == TCL_ERROR) { + Tcl_AddErrorInfo(interp, "\n (body of \"dict with\")"); + } /* * If the dictionary variable doesn't exist, drop everything silently. */ - dictPtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, - TCL_LEAVE_ERR_MSG, index); + dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0); if (dictPtr == NULL) { - return TCL_OK; + TclDecrRefCount(keysPtr); + return result; } /* * Double-check that it is still a dictionary. */ + state = Tcl_SaveInterpState(interp, result); if (Tcl_DictObjSize(interp, dictPtr, &i) != TCL_OK) { + TclDecrRefCount(keysPtr); + Tcl_DiscardInterpState(state); return TCL_ERROR; } if (Tcl_IsShared(dictPtr)) { dictPtr = Tcl_DuplicateObj(dictPtr); allocdict = 1; - } else { - allocdict = 0; } - if (pathc > 0) { + if (objc > 3) { /* * Want to get to the dictionary which we will update; need to do * prepare-for-update de-sharing along the path *but* avoid generating * an error on a non-existant path (we'll treat that the same as a * non-existant variable. Luckily, the de-sharing operation isn't * deeply damaging if we don't go on to update; it's just less than * perfectly efficient (but no memory should be leaked). */ - leafPtr = TclTraceDictPath(interp, dictPtr, pathc, pathv, + leafPtr = TclTraceDictPath(interp, dictPtr, objc-3, objv+2, DICT_PATH_EXISTS | DICT_PATH_UPDATE); if (leafPtr == NULL) { + TclDecrRefCount(keysPtr); if (allocdict) { TclDecrRefCount(dictPtr); } + Tcl_DiscardInterpState(state); return TCL_ERROR; } if (leafPtr == DICT_PATH_NON_EXISTENT) { + TclDecrRefCount(keysPtr); if (allocdict) { TclDecrRefCount(dictPtr); } - return TCL_OK; + return Tcl_RestoreInterpState(interp, state); } } else { leafPtr = dictPtr; } @@ -3708,32 +3111,31 @@ Tcl_DictObjPut(NULL, leafPtr, keyv[i], Tcl_DuplicateObj(valPtr)); } else { Tcl_DictObjPut(NULL, leafPtr, keyv[i], valPtr); } } + TclDecrRefCount(keysPtr); /* * Ensure that none of the dictionaries in the chain still have a string * rep. */ - if (pathc > 0) { + if (objc > 3) { InvalidateDictChain(leafPtr); } /* * Write back the outermost dictionary to the variable. */ - if (TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, - dictPtr, TCL_LEAVE_ERR_MSG, index) == NULL) { - if (allocdict) { - TclDecrRefCount(dictPtr); - } + if (Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr, + TCL_LEAVE_ERR_MSG) == NULL) { + Tcl_DiscardInterpState(state); return TCL_ERROR; } - return TCL_OK; + return Tcl_RestoreInterpState(interp, state); } /* *---------------------------------------------------------------------- * DELETED generic/tclDisassemble.c Index: generic/tclDisassemble.c ================================================================== --- generic/tclDisassemble.c +++ /dev/null @@ -1,1625 +0,0 @@ -/* - * tclDisassemble.c -- - * - * This file contains procedures that disassemble bytecode into either - * human-readable or Tcl-processable forms. - * - * Copyright (c) 1996-1998 Sun Microsystems, Inc. - * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. - * Copyright (c) 2013-2016 Donal K. Fellows. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include "tclInt.h" -#include "tclCompile.h" -#include "tclOOInt.h" -#include - -/* - * 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); - -/* - * The structure below defines an instruction name Tcl object to allow - * reporting of inner contexts in errorstack without string allocation. - */ - -static const Tcl_ObjType instNameType = { - "instname", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - UpdateStringOfInstName, /* updateStringProc */ - NULL, /* setFromAnyProc */ -}; - -#define InstNameSetIntRep(objPtr, inst) \ - do { \ - Tcl_ObjIntRep ir; \ - ir.wideValue = (inst); \ - Tcl_StoreIntRep((objPtr), &instNameType, &ir); \ - } while (0) - -#define InstNameGetIntRep(objPtr, inst) \ - do { \ - const Tcl_ObjIntRep *irPtr; \ - irPtr = TclFetchIntRep((objPtr), &instNameType); \ - assert(irPtr != NULL); \ - (inst) = (size_t)irPtr->wideValue; \ - } while (0) - - -/* - *---------------------------------------------------------------------- - * - * GetLocationInformation -- - * - * This procedure looks up the information about where a procedure was - * originally declared. - * - * Results: - * Writes to the variables pointed at by fileObjPtr and linePtr. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -GetLocationInformation( - Proc *procPtr, /* What to look up the information for. */ - Tcl_Obj **fileObjPtr, /* Where to write the information about what - * file the code came from. Will be written - * to, either with the object (assume shared!) - * that describes what the file was, or with - * NULL if the information is not - * available. */ - int *linePtr) /* Where to write the information about what - * line number represented the start of the - * code in question. Will be written to, - * either with the line number or with -1 if - * the information is not available. */ -{ - CmdFrame *cfPtr = TclGetCmdFrameForProcedure(procPtr); - - *fileObjPtr = NULL; - *linePtr = -1; - if (cfPtr == NULL) { - return; - } - - /* - * Get the source location data out of the CmdFrame. - */ - - *linePtr = cfPtr->line[0]; - if (cfPtr->type == TCL_LOCATION_SOURCE) { - *fileObjPtr = cfPtr->data.eval.path; - } -} - -#ifdef TCL_COMPILE_DEBUG -/* - *---------------------------------------------------------------------- - * - * TclPrintByteCodeObj -- - * - * This procedure prints ("disassembles") the instructions of a bytecode - * object to stdout. - * - * Results: - * None. - * - * Side effects: - * 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); -} - -/* - *---------------------------------------------------------------------- - * - * TclPrintInstruction -- - * - * This procedure prints ("disassembles") one instruction from a bytecode - * object to stdout. - * - * Results: - * Returns the length in bytes of the current instruiction. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclPrintInstruction( - ByteCode *codePtr, /* Bytecode containing the instruction. */ - const unsigned char *pc) /* Points to first byte of instruction. */ -{ - Tcl_Obj *bufferObj; - int numBytes; - - TclNewObj(bufferObj); - numBytes = FormatInstruction(codePtr, pc, bufferObj); - fprintf(stdout, "%s", TclGetString(bufferObj)); - Tcl_DecrRefCount(bufferObj); - return numBytes; -} - -/* - *---------------------------------------------------------------------- - * - * TclPrintObject -- - * - * This procedure prints up to a specified number of characters from the - * argument Tcl object's string representation to a specified file. - * - * Results: - * None. - * - * Side effects: - * Outputs characters to the specified file. - * - *---------------------------------------------------------------------- - */ - -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. */ - size_t maxChars) /* Maximum number of chars to print. */ -{ - char *bytes; - size_t length; - - bytes = TclGetStringFromObj(objPtr, &length); - TclPrintSource(outFile, bytes, TclMin(length, maxChars)); -} - -/* - *---------------------------------------------------------------------- - * - * TclPrintSource -- - * - * This procedure prints up to a specified number of characters from the - * argument string to a specified file. It tries to produce legible - * output by adding backslashes as necessary. - * - * Results: - * None. - * - * Side effects: - * Outputs characters to the specified file. - * - *---------------------------------------------------------------------- - */ - -void -TclPrintSource( - FILE *outFile, /* The file to print the source to. */ - const char *stringPtr, /* The string to print. */ - size_t maxChars) /* Maximum number of chars to print. */ -{ - Tcl_Obj *bufferObj; - - TclNewObj(bufferObj); - PrintSourceToObj(bufferObj, stringPtr, maxChars); - fprintf(outFile, "%s", TclGetString(bufferObj)); - Tcl_DecrRefCount(bufferObj); -} -#endif /* TCL_COMPILE_DEBUG */ - -/* - *---------------------------------------------------------------------- - * - * DisassembleByteCodeObj -- - * - * Given an object which is of bytecode type, return a disassembled - * version of the bytecode (in a new refcount 0 object). No guarantees - * 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; - Interp *iPtr; - Tcl_Obj *bufferObj, *fileObj; - - ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); - - iPtr = (Interp *) *codePtr->interpHandle; - - TclNewObj(bufferObj); - if (!codePtr->refCount) { - return bufferObj; /* Already freed. */ - } - - codeStart = codePtr->codeStart; - codeLimit = codeStart + codePtr->numCodeBytes; - numCmds = codePtr->numCommands; - - /* - * Print header lines describing the ByteCode. - */ - - Tcl_AppendPrintfToObj(bufferObj, - "ByteCode %p, refCt %" TCL_Z_MODIFIER "u, epoch %" TCL_Z_MODIFIER "u, interp %p (epoch %" TCL_Z_MODIFIER "u)\n", - codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr, iPtr->compileEpoch); - Tcl_AppendToObj(bufferObj, " Source ", -1); - PrintSourceToObj(bufferObj, codePtr->source, - TclMin(codePtr->numSrcBytes, 55)); - GetLocationInformation(codePtr->procPtr, &fileObj, &line); - if (line >= 0 && fileObj != NULL) { - Tcl_AppendPrintfToObj(bufferObj, "\n File \"%s\" Line %d", - TclGetString(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 - codePtr->numSrcBytes? - codePtr->structureSize/(float)codePtr->numSrcBytes : -#endif - 0.0); - -#ifdef TCL_COMPILE_STATS - Tcl_AppendPrintfToObj(bufferObj, - " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", - (unsigned long) codePtr->structureSize, - (unsigned long) (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)), - codePtr->numCodeBytes, - (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 the ByteCode is the compiled body of a Tcl procedure, print - * information about that procedure. Note that we don't know the - * procedure's name since ByteCode's can be shared among procedures. - */ - - if (codePtr->procPtr != NULL) { - Proc *procPtr = codePtr->procPtr; - int numCompiledLocals = procPtr->numCompiledLocals; - - Tcl_AppendPrintfToObj(bufferObj, - " Proc %p, refCt %" TCL_Z_MODIFIER "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, - " slot %d%s%s%s%s%s%s", i, - (localPtr->flags & (VAR_ARRAY|VAR_LINK)) ? "" : ", scalar", - (localPtr->flags & VAR_ARRAY) ? ", array" : "", - (localPtr->flags & VAR_LINK) ? ", link" : "", - (localPtr->flags & VAR_ARGUMENT) ? ", arg" : "", - (localPtr->flags & VAR_TEMPORARY) ? ", temp" : "", - (localPtr->flags & VAR_RESOLVED) ? ", resolved" : ""); - if (TclIsVarTemporary(localPtr)) { - Tcl_AppendToObj(bufferObj, "\n", -1); - } else { - Tcl_AppendPrintfToObj(bufferObj, ", \"%s\"\n", - localPtr->name); - } - localPtr = localPtr->nextPtr; - } - } - } - - /* - * Print the ExceptionRange array. - */ - - if (codePtr->numExceptRanges > 0) { - Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %d, depth %d:\n", - codePtr->numExceptRanges, codePtr->maxExceptDepth); - for (i = 0; i < codePtr->numExceptRanges; i++) { - ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; - - Tcl_AppendPrintfToObj(bufferObj, - " %d: level %d, %s, pc %d-%d, ", - i, rangePtr->nestingLevel, - (rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"), - rangePtr->codeOffset, - (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); - switch (rangePtr->type) { - case LOOP_EXCEPTION_RANGE: - Tcl_AppendPrintfToObj(bufferObj, "continue %d, break %d\n", - rangePtr->continueOffset, rangePtr->breakOffset); - break; - case CATCH_EXCEPTION_RANGE: - Tcl_AppendPrintfToObj(bufferObj, "catch %d\n", - rangePtr->catchOffset); - break; - default: - Tcl_Panic("DisassembleByteCodeObj: bad ExceptionRange type %d", - rangePtr->type); - } - } - } - - /* - * If there were no commands (e.g., an expression or an empty string was - * compiled), just print all instructions and return. - */ - - if (numCmds == 0) { - pc = codeStart; - while (pc < codeLimit) { - Tcl_AppendToObj(bufferObj, " ", -1); - pc += FormatInstruction(codePtr, pc, bufferObj); - } - return bufferObj; - } - - /* - * Print table showing the code offset, source offset, and source length - * for each command. These are encoded as a sequence of bytes. - */ - - 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 (*codeDeltaNext == 0xFF) { - codeDeltaNext++; - delta = TclGetInt4AtPtr(codeDeltaNext); - codeDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(codeDeltaNext); - codeDeltaNext++; - } - codeOffset += delta; - - if (*codeLengthNext == 0xFF) { - codeLengthNext++; - codeLen = TclGetInt4AtPtr(codeLengthNext); - codeLengthNext += 4; - } else { - codeLen = TclGetInt1AtPtr(codeLengthNext); - codeLengthNext++; - } - - if (*srcDeltaNext == 0xFF) { - srcDeltaNext++; - delta = TclGetInt4AtPtr(srcDeltaNext); - srcDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(srcDeltaNext); - srcDeltaNext++; - } - srcOffset += delta; - - if (*srcLengthNext == 0xFF) { - srcLengthNext++; - srcLen = TclGetInt4AtPtr(srcLengthNext); - srcLengthNext += 4; - } else { - srcLen = TclGetInt1AtPtr(srcLengthNext); - srcLengthNext++; - } - - Tcl_AppendPrintfToObj(bufferObj, "%s%4d: pc %d-%d, src %d-%d", - ((i % 2)? " " : "\n "), - (i+1), codeOffset, (codeOffset + codeLen - 1), - srcOffset, (srcOffset + srcLen - 1)); - } - if (numCmds > 0) { - Tcl_AppendToObj(bufferObj, "\n", -1); - } - - /* - * Print each instruction. If the instruction corresponds to the start of - * a command, print the command's source. Note that we don't need the code - * length here. - */ - - codeDeltaNext = codePtr->codeDeltaStart; - srcDeltaNext = codePtr->srcDeltaStart; - srcLengthNext = codePtr->srcLengthStart; - codeOffset = srcOffset = 0; - pc = codeStart; - for (i = 0; i < numCmds; i++) { - if (*codeDeltaNext == 0xFF) { - codeDeltaNext++; - delta = TclGetInt4AtPtr(codeDeltaNext); - codeDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(codeDeltaNext); - codeDeltaNext++; - } - codeOffset += delta; - - if (*srcDeltaNext == 0xFF) { - srcDeltaNext++; - delta = TclGetInt4AtPtr(srcDeltaNext); - srcDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(srcDeltaNext); - srcDeltaNext++; - } - srcOffset += delta; - - if (*srcLengthNext == 0xFF) { - srcLengthNext++; - srcLen = TclGetInt4AtPtr(srcLengthNext); - srcLengthNext += 4; - } else { - srcLen = TclGetInt1AtPtr(srcLengthNext); - srcLengthNext++; - } - - /* - * Print instructions before command i. - */ - - while ((pc-codeStart) < codeOffset) { - Tcl_AppendToObj(bufferObj, " ", -1); - pc += FormatInstruction(codePtr, pc, bufferObj); - } - - Tcl_AppendPrintfToObj(bufferObj, " Command %d: ", i+1); - PrintSourceToObj(bufferObj, (codePtr->source + srcOffset), - TclMin(srcLen, 55)); - Tcl_AppendToObj(bufferObj, "\n", -1); - } - if (pc < codeLimit) { - /* - * Print instructions after the last command. - */ - - while (pc < codeLimit) { - Tcl_AppendToObj(bufferObj, " ", -1); - pc += FormatInstruction(codePtr, pc, bufferObj); - } - } - return bufferObj; -} - -/* - *---------------------------------------------------------------------- - * - * FormatInstruction -- - * - * Appends a representation of a bytecode instruction to a Tcl_Obj. - * - *---------------------------------------------------------------------- - */ - -static int -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. */ - char *suffixSrc = NULL; - Tcl_Obj *suffixObj = NULL; - AuxData *auxPtr = NULL; - - suffixBuffer[0] = '\0'; - Tcl_AppendPrintfToObj(bufferObj, "(%u) %s ", pcOffset, instDesc->name); - for (i = 0; i < instDesc->numOperands; i++) { - switch (instDesc->opTypes[i]) { - case OPERAND_INT1: - opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++; - Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); - 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 ", 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 ", 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 ", opnd); - break; - case OPERAND_LIT4: - opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; - suffixObj = codePtr->objArrayPtr[opnd]; - Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd); - break; - case OPERAND_AUX4: - opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; - Tcl_AppendPrintfToObj(bufferObj, "%u ", 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) { - Tcl_AppendPrintfToObj(bufferObj, "end "); - } else { - Tcl_AppendPrintfToObj(bufferObj, "end-%d ", -2-opnd); - } - break; - case OPERAND_LVT1: - opnd = TclGetUInt1AtPtr(pc+numBytes); - numBytes++; - goto printLVTindex; - case OPERAND_LVT4: - opnd = TclGetUInt4AtPtr(pc+numBytes); - numBytes += 4; - printLVTindex: - if (localPtr != NULL) { - if (opnd >= localCt) { - Tcl_Panic("FormatInstruction: bad local var index %u (%u locals)", - opnd, localCt); - } - for (j = 0; j < opnd; j++) { - localPtr = localPtr->nextPtr; - } - if (TclIsVarTemporary(localPtr)) { - sprintf(suffixBuffer, "temp var %u", opnd); - } else { - sprintf(suffixBuffer, "var "); - suffixSrc = localPtr->name; - } - } - Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", 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; - size_t length; - - Tcl_AppendToObj(bufferObj, "\t# ", -1); - bytes = TclGetStringFromObj(codePtr->objArrayPtr[opnd], &length); - PrintSourceToObj(bufferObj, bytes, TclMin(length, 40)); - } else if (suffixBuffer[0]) { - Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer); - if (suffixSrc) { - PrintSourceToObj(bufferObj, suffixSrc, 40); - } - } - Tcl_AppendToObj(bufferObj, "\n", -1); - if (auxPtr && auxPtr->type->printProc) { - Tcl_AppendToObj(bufferObj, "\t\t[", -1); - auxPtr->type->printProc(auxPtr->clientData, bufferObj, codePtr, - pcOffset); - Tcl_AppendToObj(bufferObj, "]\n", -1); - } - return numBytes; -} - -/* - *---------------------------------------------------------------------- - * - * TclGetInnerContext -- - * - * If possible, returns a list capturing the inner context. Otherwise - * return NULL. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclGetInnerContext( - Tcl_Interp *interp, - const unsigned char *pc, - Tcl_Obj **tosPtr) -{ - int objc = 0, off = 0; - Tcl_Obj *result; - Interp *iPtr = (Interp *) interp; - - switch (*pc) { - case INST_STR_LEN: - case INST_LNOT: - case INST_BITNOT: - case INST_UMINUS: - case INST_UPLUS: - case INST_TRY_CVT_TO_NUMERIC: - case INST_EXPAND_STKTOP: - case INST_EXPR_STK: - objc = 1; - break; - - case INST_LIST_IN: - case INST_LIST_NOT_IN: /* Basic list containment operators. */ - case INST_STR_EQ: - case INST_STR_NEQ: /* String (in)equality check */ - case INST_STR_CMP: /* String compare. */ - case INST_STR_INDEX: - case INST_STR_MATCH: - case INST_REGEXP: - case INST_EQ: - case INST_NEQ: - case INST_LT: - case INST_GT: - case INST_LE: - case INST_GE: - case INST_MOD: - case INST_LSHIFT: - case INST_RSHIFT: - case INST_BITOR: - case INST_BITXOR: - case INST_BITAND: - case INST_EXPON: - case INST_ADD: - case INST_SUB: - case INST_DIV: - case INST_MULT: - objc = 2; - break; - - case INST_RETURN_STK: - /* early pop. TODO: dig out opt dict too :/ */ - objc = 1; - break; - - case INST_SYNTAX: - case INST_RETURN_IMM: - objc = 2; - break; - - case INST_INVOKE_STK4: - objc = TclGetUInt4AtPtr(pc+1); - break; - - case INST_INVOKE_STK1: - objc = TclGetUInt1AtPtr(pc+1); - break; - } - - result = iPtr->innerContext; - if (Tcl_IsShared(result)) { - Tcl_DecrRefCount(result); - iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL); - Tcl_IncrRefCount(result); - } else { - int len; - - /* - * Reset while keeping the list intrep as much as possible. - */ - - Tcl_ListObjLength(interp, result, &len); - Tcl_ListObjReplace(interp, result, 0, len, 0, NULL); - } - Tcl_ListObjAppendElement(NULL, result, TclNewInstNameObj(*pc)); - - for (; objc>0 ; objc--) { - Tcl_Obj *objPtr; - - objPtr = tosPtr[1 - objc + off]; - if (!objPtr) { - Tcl_Panic("InnerContext: bad tos -- appending null object"); - } - if ((objPtr->refCount<=0) -#ifdef TCL_MEM_DEBUG - || (objPtr->refCount==0x61616161) -#endif - ) { - Tcl_Panic("InnerContext: bad tos -- appending freed object %p", - objPtr); - } - Tcl_ListObjAppendElement(NULL, result, objPtr); - } - - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclNewInstNameObj -- - * - * Creates a new InstName Tcl_Obj based on the given instruction - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclNewInstNameObj( - unsigned char inst) -{ - Tcl_Obj *objPtr; - - TclNewObj(objPtr); - TclInvalidateStringRep(objPtr); - InstNameSetIntRep(objPtr, (long) inst); - - return objPtr; -} - -/* - *---------------------------------------------------------------------- - * - * UpdateStringOfInstName -- - * - * Update the string representation for an instruction name object. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfInstName( - Tcl_Obj *objPtr) -{ - size_t inst; /* NOTE: We know this is really an unsigned char */ - char *dst; - - InstNameGetIntRep(objPtr, inst); - - if (inst > LAST_INST_OPCODE) { - dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 5); - TclOOM(dst, (size_t)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; - size_t len = strlen(s); - dst = Tcl_InitStringRep(objPtr, s, len); - TclOOM(dst, len); - } -} - -/* - *---------------------------------------------------------------------- - * - * PrintSourceToObj -- - * - * Appends a quoted representation of a string to a Tcl_Obj. - * - *---------------------------------------------------------------------- - */ - -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; - continue; - case '\n': - Tcl_AppendToObj(appendObj, "\\n", -1); - i += 2; - continue; - case '\r': - Tcl_AppendToObj(appendObj, "\\r", -1); - i += 2; - continue; - case '\t': - Tcl_AppendToObj(appendObj, "\\t", -1); - 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); - } - Tcl_AppendToObj(appendObj, "\"", -1); -} - -/* - *---------------------------------------------------------------------- - * - * DisassembleByteCodeAsDicts -- - * - * Given an object which is of bytecode type, return a disassembled - * version of the bytecode (in a new refcount 0 object) in a dictionary. - * No guarantees are made about the details of the contents of the - * result, but it is intended to be more readable than the old output - * format. - * - *---------------------------------------------------------------------- - */ - -static Tcl_Obj * -DisassembleByteCodeAsDicts( - Tcl_Obj *objPtr) /* The bytecode-holding value to take apart */ -{ - ByteCode *codePtr; - Tcl_Obj *description, *literals, *variables, *instructions, *inst; - Tcl_Obj *aux, *exn, *commands, *file; - unsigned char *pc, *opnd, *codeOffPtr, *codeLenPtr, *srcOffPtr, *srcLenPtr; - int codeOffset, codeLength, sourceOffset, sourceLength; - int i, val, line; - - ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); - - /* - * Get the literals from the bytecode. - */ - - TclNewObj(literals); - for (i=0 ; inumLitObjects ; i++) { - Tcl_ListObjAppendElement(NULL, literals, codePtr->objArrayPtr[i]); - } - - /* - * Get the variables from the bytecode. - */ - - TclNewObj(variables); - if (codePtr->procPtr) { - int localCount = codePtr->procPtr->numCompiledLocals; - CompiledLocal *localPtr = codePtr->procPtr->firstLocalPtr; - - for (i=0 ; inextPtr) { - Tcl_Obj *descriptor[2]; - - TclNewObj(descriptor[0]); - if (!(localPtr->flags & (VAR_ARRAY|VAR_LINK))) { - Tcl_ListObjAppendElement(NULL, descriptor[0], - Tcl_NewStringObj("scalar", -1)); - } - if (localPtr->flags & VAR_ARRAY) { - Tcl_ListObjAppendElement(NULL, descriptor[0], - Tcl_NewStringObj("array", -1)); - } - if (localPtr->flags & VAR_LINK) { - Tcl_ListObjAppendElement(NULL, descriptor[0], - Tcl_NewStringObj("link", -1)); - } - if (localPtr->flags & VAR_ARGUMENT) { - Tcl_ListObjAppendElement(NULL, descriptor[0], - Tcl_NewStringObj("arg", -1)); - } - if (localPtr->flags & VAR_TEMPORARY) { - Tcl_ListObjAppendElement(NULL, descriptor[0], - Tcl_NewStringObj("temp", -1)); - } - if (localPtr->flags & VAR_RESOLVED) { - Tcl_ListObjAppendElement(NULL, descriptor[0], - Tcl_NewStringObj("resolved", -1)); - } - if (localPtr->flags & VAR_TEMPORARY) { - Tcl_ListObjAppendElement(NULL, variables, - Tcl_NewListObj(1, descriptor)); - } else { - descriptor[1] = Tcl_NewStringObj(localPtr->name, -1); - Tcl_ListObjAppendElement(NULL, variables, - Tcl_NewListObj(2, descriptor)); - } - } - } - - /* - * Get the instructions from the bytecode. - */ - - TclNewObj(instructions); - for (pc=codePtr->codeStart; pccodeStart+codePtr->numCodeBytes;){ - const InstructionDesc *instDesc = &tclInstructionTable[*pc]; - int address = pc - codePtr->codeStart; - - TclNewObj(inst); - Tcl_ListObjAppendElement(NULL, inst, Tcl_NewStringObj( - instDesc->name, -1)); - opnd = pc + 1; - for (i=0 ; inumOperands ; i++) { - switch (instDesc->opTypes[i]) { - case OPERAND_INT1: - val = TclGetInt1AtPtr(opnd); - opnd += 1; - goto formatNumber; - case OPERAND_UINT1: - val = TclGetUInt1AtPtr(opnd); - opnd += 1; - goto formatNumber; - case OPERAND_INT4: - val = TclGetInt4AtPtr(opnd); - opnd += 4; - goto formatNumber; - case OPERAND_UINT4: - val = TclGetUInt4AtPtr(opnd); - opnd += 4; - formatNumber: - Tcl_ListObjAppendElement(NULL, inst, Tcl_NewWideIntObj(val)); - break; - - case OPERAND_OFFSET1: - val = TclGetInt1AtPtr(opnd); - opnd += 1; - goto formatAddress; - case OPERAND_OFFSET4: - val = TclGetInt4AtPtr(opnd); - opnd += 4; - formatAddress: - Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( - "pc %d", address + val)); - break; - - case OPERAND_LIT1: - val = TclGetUInt1AtPtr(opnd); - opnd += 1; - goto formatLiteral; - case OPERAND_LIT4: - val = TclGetUInt4AtPtr(opnd); - opnd += 4; - formatLiteral: - Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( - "@%d", val)); - break; - - case OPERAND_LVT1: - val = TclGetUInt1AtPtr(opnd); - opnd += 1; - goto formatVariable; - case OPERAND_LVT4: - val = TclGetUInt4AtPtr(opnd); - opnd += 4; - formatVariable: - Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( - "%%%d", val)); - break; - case OPERAND_IDX4: - val = TclGetInt4AtPtr(opnd); - opnd += 4; - if (val >= -1) { - Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( - ".%d", val)); - } else if (val == -2) { - Tcl_ListObjAppendElement(NULL, inst, Tcl_NewStringObj( - ".end", -1)); - } else { - Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( - ".end-%d", -2-val)); - } - break; - case OPERAND_AUX4: - val = TclGetInt4AtPtr(opnd); - opnd += 4; - Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( - "?%d", val)); - break; - case OPERAND_SCLS1: - val = TclGetUInt1AtPtr(opnd); - opnd++; - Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( - "=%s", tclStringClassTable[val].name)); - break; - case OPERAND_NONE: - Tcl_Panic("opcode %d with more than zero 'no' operands", *pc); - } - } - Tcl_DictObjPut(NULL, instructions, Tcl_NewWideIntObj(address), inst); - pc += instDesc->numBytes; - } - - /* - * Get the auxiliary data from the bytecode. - */ - - TclNewObj(aux); - for (i=0 ; inumAuxDataItems ; i++) { - AuxData *auxData = &codePtr->auxDataArrayPtr[i]; - Tcl_Obj *auxDesc = Tcl_NewStringObj(auxData->type->name, -1); - - if (auxData->type->disassembleProc) { - Tcl_Obj *desc; - - TclNewObj(desc); - Tcl_DictObjPut(NULL, desc, Tcl_NewStringObj("name", -1), auxDesc); - auxDesc = desc; - auxData->type->disassembleProc(auxData->clientData, auxDesc, - codePtr, 0); - } else if (auxData->type->printProc) { - Tcl_Obj *desc; - - TclNewObj(desc); - auxData->type->printProc(auxData->clientData, desc, codePtr, 0); - Tcl_ListObjAppendElement(NULL, auxDesc, desc); - } - Tcl_ListObjAppendElement(NULL, aux, auxDesc); - } - - /* - * Get the exception ranges from the bytecode. - */ - - TclNewObj(exn); - for (i=0 ; inumExceptRanges ; i++) { - ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; - - switch (rangePtr->type) { - case LOOP_EXCEPTION_RANGE: - Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf( - "type %s level %d from %d to %d break %d continue %d", - "loop", rangePtr->nestingLevel, rangePtr->codeOffset, - rangePtr->codeOffset + rangePtr->numCodeBytes - 1, - rangePtr->breakOffset, rangePtr->continueOffset)); - break; - case CATCH_EXCEPTION_RANGE: - Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf( - "type %s level %d from %d to %d catch %d", - "catch", rangePtr->nestingLevel, rangePtr->codeOffset, - rangePtr->codeOffset + rangePtr->numCodeBytes - 1, - rangePtr->catchOffset)); - break; - } - } - - /* - * Get the command information from the bytecode. - * - * The way these are encoded in the bytecode is non-trivial; the Decode - * macro (which updates its argument and returns the next decoded value) - * handles this so that the rest of the code does not. - */ - -#define Decode(ptr) \ - ((TclGetUInt1AtPtr(ptr) == 0xFF) \ - ? ((ptr)+=5 , TclGetInt4AtPtr((ptr)-4)) \ - : ((ptr)+=1 , TclGetInt1AtPtr((ptr)-1))) - - TclNewObj(commands); - codeOffPtr = codePtr->codeDeltaStart; - codeLenPtr = codePtr->codeLengthStart; - srcOffPtr = codePtr->srcDeltaStart; - srcLenPtr = codePtr->srcLengthStart; - codeOffset = sourceOffset = 0; - for (i=0 ; inumCommands ; i++) { - Tcl_Obj *cmd; - - codeOffset += Decode(codeOffPtr); - codeLength = Decode(codeLenPtr); - sourceOffset += Decode(srcOffPtr); - sourceLength = Decode(srcLenPtr); - TclNewObj(cmd); - Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codefrom", -1), - Tcl_NewWideIntObj(codeOffset)); - Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codeto", -1), - Tcl_NewWideIntObj(codeOffset + codeLength - 1)); - - /* - * Convert byte offsets to character offsets; important if multibyte - * characters are present in the source! - */ - - Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptfrom", -1), - Tcl_NewWideIntObj(Tcl_NumUtfChars(codePtr->source, - sourceOffset))); - Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptto", -1), - Tcl_NewWideIntObj(Tcl_NumUtfChars(codePtr->source, - sourceOffset + sourceLength - 1))); - Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("script", -1), - Tcl_NewStringObj(codePtr->source+sourceOffset, sourceLength)); - Tcl_ListObjAppendElement(NULL, commands, cmd); - } - -#undef Decode - - /* - * Get the source file and line number information from the CmdFrame - * system if it is available. - */ - - GetLocationInformation(codePtr->procPtr, &file, &line); - - /* - * Build the overall result. - */ - - TclNewObj(description); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("literals", -1), - literals); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("variables", -1), - variables); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exception", -1), exn); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("instructions", -1), - instructions); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("auxiliary", -1), aux); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("commands", -1), - commands); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("script", -1), - Tcl_NewStringObj(codePtr->source, codePtr->numSrcBytes)); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("namespace", -1), - Tcl_NewStringObj(codePtr->nsPtr->fullName, -1)); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("stackdepth", -1), - Tcl_NewWideIntObj(codePtr->maxStackDepth)); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exceptdepth", -1), - Tcl_NewWideIntObj(codePtr->maxExceptDepth)); - if (line >= 0) { - Tcl_DictObjPut(NULL, description, - Tcl_NewStringObj("initiallinenumber", -1), - Tcl_NewWideIntObj(line)); - } - if (file) { - Tcl_DictObjPut(NULL, description, - Tcl_NewStringObj("sourcefile", -1), file); - } - return description; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DisassembleObjCmd -- - * - * Implementation of the "::tcl::unsupported::disassemble" command. This - * command is not documented, but will disassemble procedures, lambda - * terms and general scripts. Note that will compile terms if necessary - * in order to disassemble them. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_DisassembleObjCmd( - ClientData clientData, /* What type of operation. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - static const char *const types[] = { - "constructor", "destructor", - "lambda", "method", "objmethod", "proc", "script", NULL - }; - enum Types { - DISAS_CLASS_CONSTRUCTOR, DISAS_CLASS_DESTRUCTOR, - DISAS_LAMBDA, DISAS_CLASS_METHOD, DISAS_OBJECT_METHOD, DISAS_PROC, - DISAS_SCRIPT - }; - int idx, result; - Tcl_Obj *codeObjPtr = NULL; - Proc *procPtr = NULL; - Tcl_HashEntry *hPtr; - Object *oPtr; - ByteCode *codePtr; - Method *methodPtr; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "type ..."); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[1], types, "type", 0, &idx)!=TCL_OK){ - return TCL_ERROR; - } - - switch ((enum Types) idx) { - case DISAS_LAMBDA: { - Command cmd; - Tcl_Obj *nsObjPtr; - Tcl_Namespace *nsPtr; - - /* - * Compile (if uncompiled) and disassemble a lambda term. - */ - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "lambdaTerm"); - return TCL_ERROR; - } - - procPtr = TclGetLambdaFromObj(interp, objv[2], &nsObjPtr); - if (procPtr == NULL) { - return TCL_ERROR; - } - - memset(&cmd, 0, sizeof(Command)); - result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); - if (result != TCL_OK) { - return result; - } - cmd.nsPtr = (Namespace *) nsPtr; - procPtr->cmdPtr = &cmd; - result = TclPushProcCallFrame(procPtr, interp, objc, objv, 1); - if (result != TCL_OK) { - return result; - } - TclPopStackFrame(interp); - codeObjPtr = procPtr->bodyPtr; - break; - } - case DISAS_PROC: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "procName"); - return TCL_ERROR; - } - - procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); - if (procPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't a procedure", TclGetString(objv[2]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC", - TclGetString(objv[2]), NULL); - return TCL_ERROR; - } - - /* - * Compile (if uncompiled) and disassemble a procedure. - */ - - result = TclPushProcCallFrame(procPtr, interp, 2, objv+1, 1); - if (result != TCL_OK) { - return result; - } - TclPopStackFrame(interp); - codeObjPtr = procPtr->bodyPtr; - break; - case DISAS_SCRIPT: - /* - * Compile and disassemble a script. - */ - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "script"); - return TCL_ERROR; - } - - if (!TclHasIntRep(objv[2], &tclByteCodeType) && (TCL_OK - != TclSetByteCodeFromAny(interp, objv[2], NULL, NULL))) { - return TCL_ERROR; - } - codeObjPtr = objv[2]; - break; - - case DISAS_CLASS_CONSTRUCTOR: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "className"); - return TCL_ERROR; - } - - /* - * Look up the body of a constructor. - */ - - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (oPtr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" is not a class", TclGetString(objv[2]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", - TclGetString(objv[2]), NULL); - return TCL_ERROR; - } - - methodPtr = oPtr->classPtr->constructorPtr; - if (methodPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" has no defined constructor", - TclGetString(objv[2]))); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "CONSRUCTOR", NULL); - return TCL_ERROR; - } - procPtr = TclOOGetProcFromMethod(methodPtr); - if (procPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "body not available for this kind of constructor", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "METHODTYPE", NULL); - return TCL_ERROR; - } - - /* - * Compile if necessary. - */ - - if (!TclHasIntRep(procPtr->bodyPtr, &tclByteCodeType)) { - Command cmd; - - /* - * Yes, this is ugly, but we need to pass the namespace in to the - * compiler in two places. - */ - - cmd.nsPtr = (Namespace *) oPtr->namespacePtr; - procPtr->cmdPtr = &cmd; - result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, - (Namespace *) oPtr->namespacePtr, "body of constructor", - TclGetString(objv[2])); - procPtr->cmdPtr = NULL; - if (result != TCL_OK) { - return result; - } - } - codeObjPtr = procPtr->bodyPtr; - break; - - case DISAS_CLASS_DESTRUCTOR: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "className"); - return TCL_ERROR; - } - - /* - * Look up the body of a destructor. - */ - - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (oPtr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" is not a class", TclGetString(objv[2]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", - TclGetString(objv[2]), NULL); - return TCL_ERROR; - } - - methodPtr = oPtr->classPtr->destructorPtr; - if (methodPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" has no defined destructor", - TclGetString(objv[2]))); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "DESRUCTOR", NULL); - return TCL_ERROR; - } - procPtr = TclOOGetProcFromMethod(methodPtr); - if (procPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "body not available for this kind of destructor", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "METHODTYPE", NULL); - return TCL_ERROR; - } - - /* - * Compile if necessary. - */ - - if (!TclHasIntRep(procPtr->bodyPtr, &tclByteCodeType)) { - Command cmd; - - /* - * Yes, this is ugly, but we need to pass the namespace in to the - * compiler in two places. - */ - - cmd.nsPtr = (Namespace *) oPtr->namespacePtr; - procPtr->cmdPtr = &cmd; - result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, - (Namespace *) oPtr->namespacePtr, "body of destructor", - TclGetString(objv[2])); - procPtr->cmdPtr = NULL; - if (result != TCL_OK) { - return result; - } - } - codeObjPtr = procPtr->bodyPtr; - break; - - case DISAS_CLASS_METHOD: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "className methodName"); - return TCL_ERROR; - } - - /* - * Look up the body of a class method. - */ - - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (oPtr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" is not a class", TclGetString(objv[2]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", - TclGetString(objv[2]), NULL); - return TCL_ERROR; - } - hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, - (char *) objv[3]); - goto methodBody; - case DISAS_OBJECT_METHOD: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "objectName methodName"); - return TCL_ERROR; - } - - /* - * Look up the body of an instance method. - */ - - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (oPtr->methodsPtr == NULL) { - goto unknownMethod; - } - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[3]); - - /* - * Compile (if necessary) and disassemble a method body. - */ - - methodBody: - if (hPtr == NULL) { - unknownMethod: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown method \"%s\"", TclGetString(objv[3]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[3]), 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; - } - if (!TclHasIntRep(procPtr->bodyPtr, &tclByteCodeType)) { - Command cmd; - - /* - * Yes, this is ugly, but we need to pass the namespace in to the - * compiler in two places. - */ - - cmd.nsPtr = (Namespace *) oPtr->namespacePtr; - procPtr->cmdPtr = &cmd; - result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, - (Namespace *) oPtr->namespacePtr, "body of method", - TclGetString(objv[3])); - procPtr->cmdPtr = NULL; - if (result != TCL_OK) { - return result; - } - } - codeObjPtr = procPtr->bodyPtr; - break; - default: - CLANG_ASSERT(0); - } - - /* - * Do the actual disassembly. - */ - - ByteCodeGetIntRep(codeObjPtr, &tclByteCodeType, codePtr); - - if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not disassemble prebuilt bytecode", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "BYTECODE", 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: - */ Index: generic/tclEncoding.c ================================================================== --- generic/tclEncoding.c +++ generic/tclEncoding.c @@ -16,11 +16,11 @@ /* * The following data structure represents an encoding, which describes how to * convert between various character sets and UTF-8. */ -typedef struct { +typedef struct Encoding { char *name; /* Name of encoding. Malloced because (1) hash * table entry that owns this encoding may be * freed prior to this encoding being freed, * (2) string passed in the Tcl_EncodingType * structure may not be persistent. */ @@ -44,11 +44,11 @@ * null-terminated strings in this encoding. * If nullSize is 1, this is strlen; if * nullSize is 2, this is a function that * returns the number of bytes in a 0x0000 * terminated string. */ - size_t refCount; /* Number of uses of this structure. */ + int refCount; /* Number of uses of this structure. */ Tcl_HashEntry *hPtr; /* Hash table entry that owns this encoding. */ } Encoding; /* * The following structure is the clientData for a dynamically-loaded, @@ -55,11 +55,11 @@ * table-driven encoding created by LoadTableEncoding(). It maps between * Unicode and a single-byte, double-byte, or multibyte (1 or 2 bytes only) * encoding. */ -typedef struct { +typedef struct TableEncodingData { int fallback; /* Character (in this encoding) to substitute * when this encoding cannot represent a UTF-8 * character. */ char prefixBytes[256]; /* If a byte in the input stream is a lead * byte for a 2-byte sequence, the @@ -81,51 +81,51 @@ * the value in the matrix is 0x0000. * malloc'd. */ } TableEncodingData; /* - * Each of the following structures is the clientData for a dynamically-loaded + * 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. */ -typedef struct { - unsigned sequenceLen; /* Length of following string. */ +typedef struct EscapeSubTable { + unsigned int sequenceLen; /* Length of following string. */ char sequence[16]; /* Escape code that marks this encoding. */ char name[32]; /* Name for encoding. */ Encoding *encodingPtr; /* Encoding loaded using above name, or NULL * if this sub-encoding has not been needed * yet. */ } EscapeSubTable; -typedef struct { +typedef struct EscapeEncodingData { int fallback; /* Character (in this encoding) to substitute * when this encoding cannot represent a UTF-8 * character. */ - unsigned initLen; /* Length of following string. */ + unsigned int initLen; /* Length of following string. */ char init[16]; /* String to emit or expect before first char * in conversion. */ - unsigned finalLen; /* Length of following string. */ + unsigned int finalLen; /* Length of following string. */ char final[16]; /* String to emit or expect after last char in * conversion. */ char prefixBytes[256]; /* If a byte in the input stream is the first * character of one of the escape sequences in * the following array, the corresponding * entry in this array is 1, otherwise it is * 0. */ int numSubTables; /* Length of following array. */ - EscapeSubTable subTables[TCLFLEXARRAY];/* Information about each EscapeSubTable used - * by this encoding type. The actual size is - * as large as necessary to hold all + EscapeSubTable subTables[1];/* Information about each EscapeSubTable used + * by this encoding type. The actual size will + * be as large as necessary to hold all * EscapeSubTables. */ } EscapeEncodingData; /* - * Constants used when loading an encoding file to identify the type of the + * constants used when loading an encoding file to identify the type of the * file. */ #define ENCODING_SINGLEBYTE 0 #define ENCODING_DOUBLEBYTE 1 @@ -154,11 +154,11 @@ /* * 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 + * the encodingSearchPath, then it will be initialized by appending /encoding * to each directory in this "libraryPath". */ static ProcessGlobalValue libraryPath = { 0, 0, NULL, NULL, TclpInitLibraryPath, NULL, NULL @@ -175,16 +175,16 @@ 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. + * the system encoding will be used to perform the conversion. */ -static Tcl_Encoding defaultEncoding = NULL; -static Tcl_Encoding systemEncoding = NULL; -Tcl_Encoding tclIdentityEncoding = NULL; +static Tcl_Encoding defaultEncoding; +static Tcl_Encoding systemEncoding; +Tcl_Encoding tclIdentityEncoding; /* * The following variable is used in the sparse matrix code for a * TableEncoding to represent a page in the table that has no entries. */ @@ -193,70 +193,94 @@ /* * 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; +static int BinaryProc(ClientData clientData, + const char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, + int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr); +static void DupEncodingIntRep(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); +static void EscapeFreeProc(ClientData clientData); +static int EscapeFromUtfProc(ClientData clientData, + const char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, + int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr); +static int EscapeToUtfProc(ClientData clientData, + const char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, + int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr); +static void FillEncodingFileMap(void); +static void FreeEncoding(Tcl_Encoding encoding); +static void FreeEncodingIntRep(Tcl_Obj *objPtr); +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 void TableFreeProc(ClientData clientData); +static int TableFromUtfProc(ClientData clientData, + const char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, + int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr); +static int TableToUtfProc(ClientData clientData, const char *src, + int srcLen, int flags, Tcl_EncodingState *statePtr, + char *dst, int dstLen, int *srcReadPtr, + int *dstWrotePtr, int *dstCharsPtr); +static size_t unilen(const char *src); +static int UnicodeToUtfProc(ClientData clientData, + const char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, + int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr); +static int UtfToUnicodeProc(ClientData clientData, + const char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, + int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr); +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 int UtfIntToUtfExtProc(ClientData clientData, + const char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, + int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr); +static int UtfExtToUtfIntProc(ClientData clientData, + const char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, + int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr); +static int Iso88591FromUtfProc(ClientData clientData, + const char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, + int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr); +static int Iso88591ToUtfProc(ClientData clientData, + const char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, + int dstLen, int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr); /* * 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]. */ -static const Tcl_ObjType encodingType = { +static Tcl_ObjType encodingType = { "encoding", FreeEncodingIntRep, DupEncodingIntRep, NULL, NULL }; -#define EncodingSetIntRep(objPtr, encoding) \ - do { \ - Tcl_ObjIntRep ir; \ - ir.twoPtrValue.ptr1 = (encoding); \ - ir.twoPtrValue.ptr2 = NULL; \ - 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 -- @@ -268,11 +292,11 @@ * * Results: * Standard Tcl return code. * * Side effects: - * Caches the Tcl_Encoding value as the internal rep of (*objPtr). + * Caches the Tcl_Encoding value as the internal rep of (*objPtr). * *---------------------------------------------------------------------- */ int @@ -279,20 +303,20 @@ Tcl_GetEncodingFromObj( Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr) { - Tcl_Encoding encoding; - const char *name = TclGetString(objPtr); + const char *name = Tcl_GetString(objPtr); + if (objPtr->typePtr != &encodingType) { + Tcl_Encoding encoding = Tcl_GetEncoding(interp, name); - EncodingGetIntRep(objPtr, encoding); - if (encoding == NULL) { - encoding = Tcl_GetEncoding(interp, name); if (encoding == NULL) { return TCL_ERROR; } - EncodingSetIntRep(objPtr, encoding); + TclFreeIntRep(objPtr); + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) encoding; + objPtr->typePtr = &encodingType; } *encodingPtr = Tcl_GetEncoding(NULL, name); return TCL_OK; } @@ -308,14 +332,12 @@ static void FreeEncodingIntRep( Tcl_Obj *objPtr) { - Tcl_Encoding encoding; - - EncodingGetIntRep(objPtr, encoding); - Tcl_FreeEncoding(encoding); + Tcl_FreeEncoding((Tcl_Encoding) objPtr->internalRep.twoPtrValue.ptr1); + objPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * @@ -329,12 +351,12 @@ static void DupEncodingIntRep( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - Tcl_Encoding encoding = Tcl_GetEncoding(NULL, TclGetString(srcPtr)); - EncodingSetIntRep(dupPtr, encoding); + dupPtr->internalRep.twoPtrValue.ptr1 = (VOID *) + Tcl_GetEncoding(NULL, srcPtr->bytes); } /* *---------------------------------------------------------------------- * @@ -405,12 +427,13 @@ * 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. + * NOTE: this routine returns void, so there's no way to report the error + * that searchPath is not a valid list. In that case, this routine will + * silently do nothing. * *---------------------------------------------------------------------- */ void @@ -428,20 +451,21 @@ /* *--------------------------------------------------------------------------- * * 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. + * Called to bring the encoding file map in sync with the current value + * of the encoding search path. + * + * Scan the directories on the encoding search path, find the *.enc + * files, and store the found pathnames in a map associated with the + * encoding name. + * + * In particular, if $dir is on the encoding search path, and the file + * $dir/foo.enc is found, then store a "foo" -> $dir entry in the map. + * Later, any need for the "foo" encoding will quickly * be able to + * construct the $dir/foo.enc pathname for reading the encoding data. * * Results: * None. * * Side effects: @@ -467,31 +491,30 @@ * Iterate backwards through the search path so as we overwrite * entries found, we favor files earlier on the search path. */ int j, numFiles; - Tcl_Obj *directory, *matchFileList; + Tcl_Obj *directory, *matchFileList = Tcl_NewObj(); Tcl_Obj **filev; Tcl_GlobTypeData readableFiles = { TCL_GLOB_TYPE_FILE, TCL_GLOB_PERM_R, NULL, NULL }; - TclNewObj(matchFileList); Tcl_ListObjIndex(NULL, searchPath, i, &directory); Tcl_IncrRefCount(directory); Tcl_IncrRefCount(matchFileList); Tcl_FSMatchInDirectory(NULL, matchFileList, directory, "*.enc", &readableFiles); Tcl_ListObjGetElements(NULL, matchFileList, &numFiles, &filev); for (j=0; jfallback = '?'; - - size = 256*(sizeof(unsigned short *) + sizeof(unsigned short)); - dataPtr->toUnicode = (unsigned short **)Tcl_Alloc(size); - memset(dataPtr->toUnicode, 0, size); - dataPtr->fromUnicode = (unsigned short **)Tcl_Alloc(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; - } - - for (i=0 ; i<256 ; i++) { - dataPtr->toUnicode[0][i] = i; - dataPtr->fromUnicode[0][i] = i; - } - - type.encodingName = "iso8859-1"; - type.toUtfProc = Iso88591ToUtfProc; - type.fromUtfProc = Iso88591FromUtfProc; - type.freeProc = TableFreeProc; - type.nullSize = 1; - type.clientData = dataPtr; - defaultEncoding = Tcl_CreateEncoding(&type); - systemEncoding = Tcl_GetEncoding(NULL, type.encodingName); + { + TableEncodingData *dataPtr = (TableEncodingData *) + ckalloc(sizeof(TableEncodingData)); + unsigned size; + unsigned short i; + + 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; + } + + for (i=0 ; i<256 ; i++) { + dataPtr->toUnicode[0][i] = i; + dataPtr->fromUnicode[0][i] = i; + } + + type.encodingName = "iso8859-1"; + type.toUtfProc = Iso88591ToUtfProc; + type.fromUtfProc = Iso88591FromUtfProc; + type.freeProc = TableFreeProc; + type.nullSize = 1; + type.clientData = dataPtr; + Tcl_CreateEncoding(&type); + } encodingsInitialized = 1; } /* @@ -657,14 +656,11 @@ Tcl_HashEntry *hPtr; Tcl_MutexLock(&encodingMutex); encodingsInitialized = 0; FreeEncoding(systemEncoding); - systemEncoding = NULL; - defaultEncoding = NULL; FreeEncoding(tclIdentityEncoding); - tclIdentityEncoding = NULL; hPtr = Tcl_FirstHashEntry(&encodingTable, &search); while (hPtr != NULL) { /* * Call FreeEncoding instead of doing it directly to handle refcounts @@ -671,17 +667,79 @@ * 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)); + 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. + * + *------------------------------------------------------------------------- + */ + +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 Tcl_GetString(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); +} /* *------------------------------------------------------------------------- * * Tcl_GetEncoding -- @@ -695,11 +753,15 @@ * 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. + * The new encoding type is entered into a table visible to all + * interpreters, keyed off the encoding's name. For each call to this + * function, there should eventually be a call to Tcl_FreeEncoding, so + * that the database can be cleaned up when encodings aren't needed + * anymore. * *------------------------------------------------------------------------- */ Tcl_Encoding @@ -718,11 +780,11 @@ return systemEncoding; } hPtr = Tcl_FindHashEntry(&encodingTable, name); if (hPtr != NULL) { - encodingPtr = (Encoding *)Tcl_GetHashValue(hPtr); + encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr); encodingPtr->refCount++; Tcl_MutexUnlock(&encodingMutex); return (Tcl_Encoding) encodingPtr; } Tcl_MutexUnlock(&encodingMutex); @@ -733,19 +795,19 @@ /* *--------------------------------------------------------------------------- * * Tcl_FreeEncoding -- * - * Releases an encoding allocated by Tcl_CreateEncoding() or - * Tcl_GetEncoding(). + * This function is called to release 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. + * the encoding may be deleted if nothing is using it anymore. * *--------------------------------------------------------------------------- */ void @@ -760,18 +822,17 @@ /* *---------------------------------------------------------------------- * * FreeEncoding -- * - * Decrements the reference count of an encoding. The caller must hold - * encodingMutes. + * This function is called to release an encoding by functions that + * already have the encodingMutex. * * 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. * *---------------------------------------------------------------------- */ @@ -778,26 +839,29 @@ static void FreeEncoding( Tcl_Encoding encoding) { - Encoding *encodingPtr = (Encoding *) encoding; + Encoding *encodingPtr; + encodingPtr = (Encoding *) encoding; if (encodingPtr == NULL) { return; } - if (encodingPtr->refCount-- <= 1) { + if (encodingPtr->refCount<=0) { + Tcl_Panic("FreeEncoding: refcount problem !!!"); + } + encodingPtr->refCount--; + if (encodingPtr->refCount == 0) { if (encodingPtr->freeProc != NULL) { - encodingPtr->freeProc(encodingPtr->clientData); + (*encodingPtr->freeProc)(encodingPtr->clientData); } if (encodingPtr->hPtr != NULL) { Tcl_DeleteHashEntry(encodingPtr->hPtr); } - if (encodingPtr->name) { - Tcl_Free(encodingPtr->name); - } - Tcl_Free(encodingPtr); + ckfree((char *) encodingPtr->name); + ckfree((char *) encodingPtr); } } /* *------------------------------------------------------------------------- @@ -850,28 +914,26 @@ Tcl_Interp *interp) /* Interp to hold result. */ { Tcl_HashTable table; Tcl_HashSearch search; Tcl_HashEntry *hPtr; - Tcl_Obj *map, *name, *result; + Tcl_Obj *map, *name, *result = Tcl_NewObj(); Tcl_DictSearch mapSearch; int dummy, done = 0; - TclNewObj(result); Tcl_InitObjHashTable(&table); /* * Copy encoding names from loaded encoding table to table. */ Tcl_MutexLock(&encodingMutex); for (hPtr = Tcl_FirstHashEntry(&encodingTable, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - Encoding *encodingPtr = (Encoding *)Tcl_GetHashValue(hPtr); - + Encoding *encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr); Tcl_CreateHashEntry(&table, - Tcl_NewStringObj(encodingPtr->name, -1), &dummy); + (char *) Tcl_NewStringObj(encodingPtr->name, -1), &dummy); } Tcl_MutexUnlock(&encodingMutex); FillEncodingFileMap(); map = TclGetProcessGlobalValue(&encodingFileMap); @@ -880,11 +942,11 @@ * Copy encoding names from encoding file map to table. */ Tcl_DictObjFirst(NULL, map, &mapSearch, &name, NULL, &done); for (; !done; Tcl_DictObjNext(&mapSearch, &name, NULL, &done)) { - Tcl_CreateHashEntry(&table, name, &dummy); + Tcl_CreateHashEntry(&table, (char *) name, &dummy); } /* * Pull all encoding names from table into the result list. */ @@ -956,37 +1018,57 @@ /* *--------------------------------------------------------------------------- * * Tcl_CreateEncoding -- * - * Defines a new encoding, along with the functions that are used to - * convert to and from Unicode. + * This function is called to define a new encoding and the functions + * that are used to convert between the specified encoding and 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. + * continues to behave as it used to, and will eventually be garbage + * collected when the last reference to it goes away. Any subsequent + * calls to Tcl_GetEncoding with the specified name will 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. + * The new encoding type is entered into a table visible to all + * interpreters, keyed off the encoding's name. For each call to this + * function, there should eventually be a call to Tcl_FreeEncoding, so + * that the database can be cleaned up when encodings aren't needed + * anymore. * *--------------------------------------------------------------------------- */ Tcl_Encoding Tcl_CreateEncoding( const Tcl_EncodingType *typePtr) /* The encoding type. */ { - Encoding *encodingPtr = (Encoding *)Tcl_Alloc(sizeof(Encoding)); - encodingPtr->name = NULL; + Tcl_HashEntry *hPtr; + int isNew; + Encoding *encodingPtr; + char *name; + + Tcl_MutexLock(&encodingMutex); + hPtr = Tcl_CreateHashEntry(&encodingTable, typePtr->encodingName, &isNew); + if (isNew == 0) { + /* + * Remove old encoding from hash table, but don't delete it until last + * reference goes away. + */ + + encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr); + encodingPtr->hPtr = NULL; + } + + name = ckalloc((unsigned) strlen(typePtr->encodingName) + 1); + + encodingPtr = (Encoding *) ckalloc(sizeof(Encoding)); + encodingPtr->name = strcpy(name, typePtr->encodingName); encodingPtr->toUtfProc = typePtr->toUtfProc; encodingPtr->fromUtfProc = typePtr->fromUtfProc; encodingPtr->freeProc = typePtr->freeProc; encodingPtr->nullSize = typePtr->nullSize; encodingPtr->clientData = typePtr->clientData; @@ -994,36 +1076,15 @@ encodingPtr->lengthProc = (LengthProc *) strlen; } else { encodingPtr->lengthProc = (LengthProc *) unilen; } encodingPtr->refCount = 1; - encodingPtr->hPtr = NULL; - - if (typePtr->encodingName) { - Tcl_HashEntry *hPtr; - int isNew; - char *name; - - Tcl_MutexLock(&encodingMutex); - hPtr = Tcl_CreateHashEntry(&encodingTable, typePtr->encodingName, &isNew); - if (isNew == 0) { - /* - * Remove old encoding from hash table, but don't delete it until last - * reference goes away. - */ - - Encoding *replaceMe = (Encoding *)Tcl_GetHashValue(hPtr); - replaceMe->hPtr = NULL; - } - - name = (char *)Tcl_Alloc(strlen(typePtr->encodingName) + 1); - encodingPtr->name = strcpy(name, typePtr->encodingName); encodingPtr->hPtr = hPtr; Tcl_SetHashValue(hPtr, encodingPtr); Tcl_MutexUnlock(&encodingMutex); - } + return (Tcl_Encoding) encodingPtr; } /* *------------------------------------------------------------------------- @@ -1049,20 +1110,19 @@ 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. */ - size_t srcLen, /* Source string length in bytes, or -1 for + 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, result, soFar, srcRead, dstWrote, dstChars; - size_t dstLen; + Encoding *encodingPtr; + int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars; Tcl_DStringInit(dstPtr); dst = Tcl_DStringValue(dstPtr); dstLen = dstPtr->spaceAvl - 1; @@ -1071,19 +1131,20 @@ } encodingPtr = (Encoding *) encoding; if (src == NULL) { srcLen = 0; - } else if (srcLen == TCL_INDEX_NONE) { - srcLen = encodingPtr->lengthProc(src); + } else if (srcLen < 0) { + srcLen = (*encodingPtr->lengthProc)(src); } flags = TCL_ENCODING_START | TCL_ENCODING_END; while (1) { - result = encodingPtr->toUtfProc(encodingPtr->clientData, src, srcLen, - flags, &state, dst, dstLen, &srcRead, &dstWrote, &dstChars); + result = (*encodingPtr->toUtfProc)(encodingPtr->clientData, src, + srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote, + &dstChars); soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); if (result != TCL_CONVERT_NOSPACE) { Tcl_DStringSetLength(dstPtr, soFar); return Tcl_DStringValue(dstPtr); @@ -1119,25 +1180,25 @@ *------------------------------------------------------------------------- */ int Tcl_ExternalToUtf( - TCL_UNUSED(Tcl_Interp *), /* TODO: Re-examine this. */ + Tcl_Interp *interp, /* Interp for error return, if not NULL. */ Tcl_Encoding encoding, /* The encoding for the source string, or NULL * for the default system encoding. */ const char *src, /* Source string in specified encoding. */ - size_t srcLen, /* Source string length in bytes, or -1 - * for encoding-specific string length. */ + 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. */ - size_t dstLen, /* The maximum length of output buffer in + 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 @@ -1147,26 +1208,23 @@ * the conversion. */ int *dstCharsPtr) /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ { - const Encoding *encodingPtr; - int result, srcRead, dstWrote, dstChars = 0; - int noTerminate = flags & TCL_ENCODING_NO_TERMINATE; - int charLimited = (flags & TCL_ENCODING_CHAR_LIMIT) && dstCharsPtr; - int maxChars = INT_MAX; + Encoding *encodingPtr; + int result, srcRead, dstWrote, dstChars; Tcl_EncodingState state; if (encoding == NULL) { encoding = systemEncoding; } encodingPtr = (Encoding *) encoding; if (src == NULL) { srcLen = 0; - } else if (srcLen == TCL_INDEX_NONE) { - srcLen = encodingPtr->lengthProc(src); + } else if (srcLen < 0) { + srcLen = (*encodingPtr->lengthProc)(src); } if (statePtr == NULL) { flags |= TCL_ENCODING_START | TCL_ENCODING_END; statePtr = &state; } @@ -1176,56 +1234,36 @@ if (dstWrotePtr == NULL) { dstWrotePtr = &dstWrote; } if (dstCharsPtr == NULL) { dstCharsPtr = &dstChars; - flags &= ~TCL_ENCODING_CHAR_LIMIT; - } else if (charLimited) { - maxChars = *dstCharsPtr; - } - - if (!noTerminate) { - /* - * If there are any null characters in the middle of the buffer, - * they will converted to the UTF-8 null character (\xC080). To get - * the actual \0 at the end of the destination buffer, we need to - * append it manually. First make room for it... - */ - - dstLen--; - } - do { - int savedFlags = flags; - Tcl_EncodingState savedState = *statePtr; - - 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'; - } + } + + /* + * If there are any null characters in the middle of the buffer, they will + * converted to the UTF-8 null character (\xC080). To get the actual \0 at + * the end of the destination buffer, we need to append it manually. + */ + + dstLen--; + result = (*encodingPtr->toUtfProc)(encodingPtr->clientData, src, srcLen, + flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, + dstCharsPtr); + dst[*dstWrotePtr] = '\0'; return result; } /* *------------------------------------------------------------------------- * * Tcl_UtfToExternalDString -- * - * Convert a source buffer from UTF-8 to the specified encoding. If any + * Convert a source buffer from UTF-8 into 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. + * in the target encoding, a default fallback character will be + * 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. @@ -1239,20 +1277,19 @@ 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. */ - size_t srcLen, /* Source string length in bytes, or -1 for + 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, result, soFar, srcRead, dstWrote, dstChars; - size_t dstLen; + Encoding *encodingPtr; + int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars; Tcl_DStringInit(dstPtr); dst = Tcl_DStringValue(dstPtr); dstLen = dstPtr->spaceAvl - 1; @@ -1261,16 +1298,16 @@ } encodingPtr = (Encoding *) encoding; if (src == NULL) { srcLen = 0; - } else if (srcLen == TCL_INDEX_NONE) { + } else if (srcLen < 0) { srcLen = strlen(src); } flags = TCL_ENCODING_START | TCL_ENCODING_END; while (1) { - result = encodingPtr->fromUtfProc(encodingPtr->clientData, src, + result = (*encodingPtr->fromUtfProc)(encodingPtr->clientData, src, srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote, &dstChars); soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); if (result != TCL_CONVERT_NOSPACE) { @@ -1311,25 +1348,25 @@ *------------------------------------------------------------------------- */ int Tcl_UtfToExternal( - TCL_UNUSED(Tcl_Interp *), /* TODO: Re-examine this. */ + Tcl_Interp *interp, /* Interp for error return, if not NULL. */ Tcl_Encoding encoding, /* The encoding for the converted string, or * NULL for the default system encoding. */ const char *src, /* Source string in UTF-8. */ - size_t srcLen, /* Source string length in bytes, or -1 - * for strlen(). */ + 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. */ - size_t dstLen, /* The maximum length of output buffer in + 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 @@ -1339,11 +1376,11 @@ * the conversion. */ int *dstCharsPtr) /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ { - const Encoding *encodingPtr; + Encoding *encodingPtr; int result, srcRead, dstWrote, dstChars; Tcl_EncodingState state; if (encoding == NULL) { encoding = systemEncoding; @@ -1350,11 +1387,11 @@ } encodingPtr = (Encoding *) encoding; if (src == NULL) { srcLen = 0; - } else if (srcLen == TCL_INDEX_NONE) { + } else if (srcLen < 0) { srcLen = strlen(src); } if (statePtr == NULL) { flags |= TCL_ENCODING_START | TCL_ENCODING_END; statePtr = &state; @@ -1368,11 +1405,11 @@ if (dstCharsPtr == NULL) { dstCharsPtr = &dstChars; } dstLen -= encodingPtr->nullSize; - result = encodingPtr->fromUtfProc(encodingPtr->clientData, src, srcLen, + result = (*encodingPtr->fromUtfProc)(encodingPtr->clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr); if (encodingPtr->nullSize == 2) { dst[*dstWrotePtr + 1] = '\0'; } @@ -1392,21 +1429,21 @@ * Results: * None. * * Side effects: * The absolute pathname for the application is computed and stored to be - * returned later by [info nameofexecutable]. + * returned later be [info nameofexecutable]. * *--------------------------------------------------------------------------- */ -#undef Tcl_FindExecutable + void Tcl_FindExecutable( const char *argv0) /* The value of the application's argv[0] * (native). */ { - Tcl_InitSubsystems(); + TclInitSubsystems(); TclpSetInitialEncodings(); TclpFindExecutable(argv0); } /* @@ -1415,13 +1452,13 @@ * OpenEncodingFileChannel -- * * Open the file believed to hold data for the encoding, "name". * * Results: - * Returns the readable Tcl_Channel from opening the file, or NULL if the - * file could not be successfully opened. If NULL was returned, an error - * message is left in interp's result object, unless interp was NULL. + * Returns the readable Tcl_Channel from opening the file, or NULL if the + * file could not be successfully opened. If NULL was returned, an error + * message is left in interp's result object, unless interp was NULL. * * Side effects: * Channel may be opened. Information about the filesystem may be cached * to speed later calls. * @@ -1459,14 +1496,13 @@ if (dir[i] == directory) { verified = 1; } } if (!verified) { - const char *dirString = TclGetString(directory); - + const char *dirString = Tcl_GetString(directory); for (i=0; ifallback = fallback; /* @@ -1694,30 +1725,27 @@ * 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 **)Tcl_Alloc(size); + 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; - size_t expected = 3 + 16 * (16 * 4 + 1); + char *p; - if (Tcl_ReadChars(chan, objPtr, expected, 0) != expected) { - return NULL; - } - p = TclGetString(objPtr); + Tcl_ReadChars(chan, objPtr, 3 + 16 * (16 * 4 + 1), 0); + p = Tcl_GetString(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) { + 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) { @@ -1739,14 +1767,14 @@ } } } /* - * Invert the toUnicode array to produce the fromUnicode array. Performs a + * Invert 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. + * by the array. While reading in the toUnicode array, we remembered what + * pages that would be needed for the fromUnicode array. */ if (symbol) { used[0] = 1; } @@ -1755,56 +1783,61 @@ if (used[hi]) { numPages++; } } size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE; - dataPtr->fromUnicode = (unsigned short **)Tcl_Alloc(size); + 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); + } else { + for (lo = 0; lo < 256; lo++) { + int ch; + + ch = dataPtr->toUnicode[hi][lo]; + if (ch != 0) { + unsigned short *page; + + 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 + * one. Otherwise, on Windows, native file names won't work because + * the backslash in the file name will map 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 (dataPtr->fromUnicode[0]['\\'] == '\0') { + dataPtr->fromUnicode[0]['\\'] = '\\'; } } } if (symbol) { + unsigned short *page; + /* - * 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. + * Make a special symbol encoding that not only maps the symbol + * characters from their Unicode code points down into page 0, but + * also ensure that the characters on page 0 map to themselves. This + * is 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; @@ -1825,81 +1858,61 @@ /* * For trailing 'R'everse encoding, see [Patch 689341] */ Tcl_DStringInit(&lineString); - - /* - * Skip leading empty lines. - */ - - while ((len = Tcl_Gets(chan, &lineString)) == 0) { - /* empty body */ - } - if (len < 0) { - goto doneParse; - } - - /* - * Require that it starts with an 'R'. - */ - - line = Tcl_DStringValue(&lineString); - if (line[0] != 'R') { - goto doneParse; - } - - /* - * Read lines until EOF. - */ - - for (TclDStringClear(&lineString); - (len = Tcl_Gets(chan, &lineString)) != -1; - TclDStringClear(&lineString)) { - const unsigned char *p; - int to, from; - - /* - * Skip short lines. - */ - - if (len < 5) { - continue; - } - - /* - * Parse the line as a sequence of hex digits. - */ - - p = (const unsigned char *) Tcl_DStringValue(&lineString); - to = (staticHex[p[0]] << 12) + (staticHex[p[1]] << 8) - + (staticHex[p[2]] << 4) + staticHex[p[3]]; - if (to == 0) { - continue; - } - 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. - */ + do { + int len; + + /* + * Skip leading empty lines. + */ + + while ((len = Tcl_Gets(chan, &lineString)) == 0) { + /* empty body */ + } + + if (len < 0) { + break; + } + line = Tcl_DStringValue(&lineString); + if (line[0] != 'R') { + break; + } + for (Tcl_DStringSetLength(&lineString, 0); + (len = Tcl_Gets(chan, &lineString)) >= 0; + Tcl_DStringSetLength(&lineString, 0)) { + unsigned char* p; + int to, from; + + if (len < 5) { + continue; + } + p = (unsigned char*) Tcl_DStringValue(&lineString); + to = (staticHex[p[0]] << 12) + (staticHex[p[1]] << 8) + + (staticHex[p[2]] << 4) + staticHex[p[3]]; + if (to == 0) { + continue; + } + 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; + } + } + } while (0); + Tcl_DStringFree(&lineString); encType.encodingName = name; encType.toUtfProc = TableToUtfProc; encType.fromUtfProc = TableFromUtfProc; encType.freeProc = TableFreeProc; encType.nullSize = (type == ENCODING_DOUBLEBYTE) ? 2 : 1; - encType.clientData = dataPtr; + encType.clientData = (ClientData) dataPtr; return Tcl_CreateEncoding(&encType); } /* @@ -1924,15 +1937,15 @@ *------------------------------------------------------------------------- */ static Tcl_Encoding LoadEscapeEncoding( - const char *name, /* Name of the new encoding. */ + const char *name, /* Name for new encoding. */ Tcl_Channel chan) /* File containing new encoding. */ { int i; - unsigned size; + unsigned int size; Tcl_DString escapeData; char init[16], final[16]; EscapeEncodingData *dataPtr; Tcl_EncodingType type; @@ -1945,16 +1958,15 @@ const char **argv; char *line; Tcl_DString lineString; Tcl_DStringInit(&lineString); - if (Tcl_Gets(chan, &lineString) == TCL_IO_FAILURE) { + if (Tcl_Gets(chan, &lineString) < 0) { break; } line = Tcl_DStringValue(&lineString); if (Tcl_SplitList(NULL, line, &argc, &argv) != TCL_OK) { - Tcl_DStringFree(&lineString); continue; } if (argc >= 2) { if (strcmp(argv[0], "name") == 0) { /* do nothing */ @@ -1978,34 +1990,34 @@ /* * To avoid infinite recursion in [encoding system iso2022-*] */ e = (Encoding *) Tcl_GetEncoding(NULL, est.name); - if ((e != NULL) && (e->toUtfProc != TableToUtfProc) - && (e->toUtfProc != Iso88591ToUtfProc)) { + if (e && e->toUtfProc != TableToUtfProc && + e->toUtfProc != Iso88591ToUtfProc) { Tcl_FreeEncoding((Tcl_Encoding) e); e = NULL; } est.encodingPtr = e; Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est)); } } - Tcl_Free((void *)argv); + ckfree((char *) argv); Tcl_DStringFree(&lineString); } - size = offsetof(EscapeEncodingData, subTables) + size = sizeof(EscapeEncodingData) - sizeof(EscapeSubTable) + Tcl_DStringLength(&escapeData); - dataPtr = (EscapeEncodingData *)Tcl_Alloc(size); + dataPtr = (EscapeEncodingData *) ckalloc(size); dataPtr->initLen = strlen(init); - memcpy(dataPtr->init, init, dataPtr->initLen + 1); + strcpy(dataPtr->init, init); dataPtr->finalLen = strlen(final); - memcpy(dataPtr->final, final, dataPtr->finalLen + 1); + strcpy(dataPtr->final, final); dataPtr->numSubTables = Tcl_DStringLength(&escapeData) / sizeof(EscapeSubTable); memcpy(dataPtr->subTables, Tcl_DStringValue(&escapeData), - Tcl_DStringLength(&escapeData)); + (size_t) Tcl_DStringLength(&escapeData)); Tcl_DStringFree(&escapeData); memset(dataPtr->prefixBytes, 0, sizeof(dataPtr->prefixBytes)); for (i = 0; i < dataPtr->numSubTables; i++) { dataPtr->prefixBytes[UCHAR(dataPtr->subTables[i].sequence[0])] = 1; @@ -2015,20 +2027,16 @@ } if (dataPtr->final[0] != '\0') { dataPtr->prefixBytes[UCHAR(dataPtr->final[0])] = 1; } - /* - * Package everything into an encoding structure. - */ - type.encodingName = name; type.toUtfProc = EscapeToUtfProc; type.fromUtfProc = EscapeFromUtfProc; type.freeProc = EscapeFreeProc; type.nullSize = 1; - type.clientData = dataPtr; + type.clientData = (ClientData) dataPtr; return Tcl_CreateEncoding(&type); } /* @@ -2049,15 +2057,19 @@ *------------------------------------------------------------------------- */ static int BinaryProc( - TCL_UNUSED(ClientData), + ClientData clientData, /* Not used. */ const char *src, /* Source string (unknown encoding). */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ - TCL_UNUSED(Tcl_EncodingState *), + 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 @@ -2074,32 +2086,29 @@ result = TCL_OK; dstLen -= TCL_UTF_MAX - 1; if (dstLen < 0) { dstLen = 0; } - if ((flags & TCL_ENCODING_CHAR_LIMIT) && srcLen > *dstCharsPtr) { - srcLen = *dstCharsPtr; - } if (srcLen > dstLen) { srcLen = dstLen; result = TCL_CONVERT_NOSPACE; } *srcReadPtr = srcLen; *dstWrotePtr = srcLen; *dstCharsPtr = srcLen; - memcpy(dst, src, srcLen); + memcpy(dst, src, (size_t) srcLen); return result; } /* *------------------------------------------------------------------------- * - * UtfIntToUtfExtProc -- + * UtfExtToUtfIntProc -- * * Convert from UTF-8 to UTF-8. While converting null-bytes from the - * Tcl's internal representation (0xC0, 0x80) to the official + * Tcl's internal representation (0xc0, 0x80) to the official * representation (0x00). See UtfToUtfProc for details. * * Results: * Returns TCL_OK if conversion was successful. * @@ -2109,11 +2118,11 @@ *------------------------------------------------------------------------- */ static int UtfIntToUtfExtProc( - ClientData clientData, + ClientData clientData, /* Not used. */ 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 @@ -2144,11 +2153,11 @@ *------------------------------------------------------------------------- * * UtfExtToUtfIntProc -- * * Convert from UTF-8 to UTF-8 while converting null-bytes from the - * official representation (0x00) to Tcl's internal representation (0xC0, + * official representation (0x00) to Tcl's internal representation (0xc0, * 0x80). See UtfToUtfProc for details. * * Results: * Returns TCL_OK if conversion was successful. * @@ -2155,14 +2164,13 @@ * Side effects: * None. * *------------------------------------------------------------------------- */ - static int UtfExtToUtfIntProc( - ClientData clientData, + ClientData clientData, /* Not used. */ 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 @@ -2207,11 +2215,11 @@ *------------------------------------------------------------------------- */ static int UtfToUtfProc( - TCL_UNUSED(ClientData), + ClientData clientData, /* Not used. */ 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 @@ -2233,37 +2241,31 @@ 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 */ + * versa. */ { const char *srcStart, *srcEnd, *srcClose; - const char *dstStart, *dstEnd; - int result, numChars, charLimit = INT_MAX; - int *chPtr = (int *) statePtr; + char *dstStart, *dstEnd; + int result, numChars; + Tcl_UniChar ch; - 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; + srcClose -= TCL_UTF_MAX; } dstStart = dst; dstEnd = dst + dstLen - TCL_UTF_MAX; - for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) { - if ((src > srcClose) && (!TclUCS4Complete(src, srcEnd - src))) { + 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. */ @@ -2274,50 +2276,36 @@ 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. + * Copy 7bit chatacters, but skip null-bytes when we are in input + * mode, so that they get converted to 0xc080. */ *dst++ = *src++; - } else if (pureNullMode == 1 && UCHAR(*src) == 0xC0 && + } 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. + * Convert 0xc080 to real nulls when we are in output mode. */ *dst++ = 0; src += 2; - } else if (!TclUCS4Complete(src, srcEnd - src)) { + } else if (!Tcl_UtfCharComplete(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. + * Always check before using Tcl_UtfToUniChar. Not doing can so + * cause it run beyond the endof the buffer! If we happen such an + * incomplete char its byts are made to represent themselves. */ - *chPtr = UCHAR(*src); + ch = (unsigned char) *src; src += 1; - dst += Tcl_UniCharToUtf(*chPtr, dst); + dst += Tcl_UniCharToUtf(ch, 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); + src += Tcl_UtfToUniChar(src, &ch); + dst += Tcl_UniCharToUtf(ch, dst); } } *srcReadPtr = src - srcStart; *dstWrotePtr = dst - dstStart; @@ -2326,13 +2314,13 @@ } /* *------------------------------------------------------------------------- * - * Utf16ToUtfProc -- + * UnicodeToUtfProc -- * - * Convert from UTF-16 to UTF-8. + * Convert from Unicode to UTF-8. * * Results: * Returns TCL_OK if conversion was successful. * * Side effects: @@ -2340,16 +2328,20 @@ * *------------------------------------------------------------------------- */ static int -Utf16ToUtfProc( - ClientData clientData, /* != NULL means LE, == NUL means BE */ +UnicodeToUtfProc( + ClientData clientData, /* Not used. */ const char *src, /* Source string in Unicode. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ - TCL_UNUSED(Tcl_EncodingState *), + 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 @@ -2363,51 +2355,36 @@ int *dstCharsPtr) /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ { const char *srcStart, *srcEnd; - const char *dstEnd, *dstStart; - int result, numChars, charLimit = INT_MAX; + char *dstEnd, *dstStart; + int result, numChars; 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) { + if ((srcLen & 1) != 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++) { + for (numChars = 0; src < srcEnd; 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. + * Special case for 1-byte utf chars for speed. Make sure we + * work with Tcl_UniChar-size data. */ + ch = *(unsigned short *)src; if (ch && ch < 0x80) { *dst++ = (ch & 0xFF); } else { dst += Tcl_UniCharToUtf(ch, dst); } @@ -2421,13 +2398,13 @@ } /* *------------------------------------------------------------------------- * - * UtfToUtf16Proc -- + * UtfToUnicodeProc -- * - * Convert from UTF-8 to UTF-16. + * Convert from UTF-8 to Unicode. * * Results: * Returns TCL_OK if conversion was successful. * * Side effects: @@ -2435,12 +2412,13 @@ * *------------------------------------------------------------------------- */ static int -UtfToUtf16Proc( - ClientData clientData, /* != NULL means LE, == NUL means BE */ +UtfToUnicodeProc( + 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_EncodingState *statePtr,/* Place for conversion routine to store state * information used during a piecewise @@ -2463,125 +2441,11 @@ * correspond to the bytes stored in the * output buffer. */ { const char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd; int result, numChars; - Tcl_UniChar *chPtr = (Tcl_UniChar *) statePtr; - - if (flags & TCL_ENCODING_START) { - *statePtr = 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; - } - 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; + Tcl_UniChar ch; srcStart = src; srcEnd = src + srcLen; srcClose = srcEnd; if ((flags & TCL_ENCODING_END) == 0) { @@ -2603,43 +2467,31 @@ 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) { + } + src += TclUtfToUniChar(src, &ch); +#if TCL_UTF_MAX > 3 + 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); - } +#ifdef WORDS_BIGENDIAN + *dst++ = (ch >> 8); + *dst++ = (ch & 0xFF); +#else + *dst++ = (ch & 0xFF); + *dst++ = (ch >> 8); +#endif } *srcReadPtr = src - srcStart; *dstWrotePtr = dst - dstStart; *dstCharsPtr = numChars; return result; } - + /* *------------------------------------------------------------------------- * * TableToUtfProc -- * @@ -2660,11 +2512,15 @@ 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 *), + 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 @@ -2678,32 +2534,30 @@ int *dstCharsPtr) /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ { 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; - } + char *dstEnd, *dstStart, *prefixBytes; + int result, byte, numChars; + Tcl_UniChar ch; + unsigned short **toUnicode; + unsigned short *pageZero; + TableEncodingData *dataPtr; + srcStart = src; srcEnd = src + srcLen; dstStart = dst; dstEnd = dst + dstLen - TCL_UTF_MAX; - toUnicode = (const unsigned short *const *) dataPtr->toUnicode; + dataPtr = (TableEncodingData *) clientData; + toUnicode = dataPtr->toUnicode; prefixBytes = dataPtr->prefixBytes; pageZero = toUnicode[0]; result = TCL_OK; - for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) { + for (numChars = 0; src < srcEnd; numChars++) { if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } byte = *((unsigned char *) src); @@ -2726,15 +2580,13 @@ if (prefixBytes[byte]) { src--; } ch = (Tcl_UniChar) byte; } - /* * Special case for 1-byte utf chars for speed. */ - if (ch && ch < 0x80) { *dst++ = (char) ch; } else { dst += Tcl_UniCharToUtf(ch, dst); } @@ -2769,11 +2621,15 @@ 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 *), + 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 @@ -2787,20 +2643,21 @@ 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; + char *dstStart, *dstEnd, *prefixBytes; + Tcl_UniChar ch; int result, len, word, numChars; - TableEncodingData *dataPtr = (TableEncodingData *)clientData; - const unsigned short *const *fromUnicode; + TableEncodingData *dataPtr; + unsigned short **fromUnicode; result = TCL_OK; + dataPtr = (TableEncodingData *) clientData; prefixBytes = dataPtr->prefixBytes; - fromUnicode = (const unsigned short *const *) dataPtr->fromUnicode; + fromUnicode = dataPtr->fromUnicode; srcStart = src; srcEnd = src + srcLen; srcClose = srcEnd; if ((flags & TCL_ENCODING_END) == 0) { @@ -2821,24 +2678,16 @@ 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) { + /* Unicode chars > +U0FFFF cannot be represented in any table encoding */ + if (ch & ~0xFFFF) { word = 0; } else #endif - word = fromUnicode[(ch >> 8)][ch & 0xFF]; + word = fromUnicode[(ch >> 8)][ch & 0xff]; if ((word == 0) && (ch != 0)) { if (flags & TCL_ENCODING_STOPONERROR) { result = TCL_CONVERT_UNKNOWN; break; @@ -2886,15 +2735,19 @@ *------------------------------------------------------------------------- */ static int Iso88591ToUtfProc( - TCL_UNUSED(ClientData), + ClientData clientData, /* Ignored. */ const char *src, /* Source string in specified encoding. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ - TCL_UNUSED(Tcl_EncodingState *), + 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 @@ -2908,36 +2761,31 @@ int *dstCharsPtr) /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ { const char *srcStart, *srcEnd; - const char *dstEnd, *dstStart; - int result, numChars, charLimit = INT_MAX; + char *dstEnd, *dstStart; + int result, numChars; - if (flags & TCL_ENCODING_CHAR_LIMIT) { - charLimit = *dstCharsPtr; - } srcStart = src; srcEnd = src + srcLen; dstStart = dst; dstEnd = dst + dstLen - TCL_UTF_MAX; result = TCL_OK; - for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) { - Tcl_UniChar ch = 0; + for (numChars = 0; src < srcEnd; numChars++) { + Tcl_UniChar ch; if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } ch = (Tcl_UniChar) *((unsigned char *) src); - /* * Special case for 1-byte utf chars for speed. */ - if (ch && ch < 0x80) { *dst++ = (char) ch; } else { dst += Tcl_UniCharToUtf(ch, dst); } @@ -2966,15 +2814,19 @@ *------------------------------------------------------------------------- */ static int Iso88591FromUtfProc( - TCL_UNUSED(ClientData), + ClientData clientData, /* Ignored. */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ - TCL_UNUSED(Tcl_EncodingState *), + 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 @@ -2988,13 +2840,14 @@ 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; + char *dstStart, *dstEnd; + int result, numChars; + + result = TCL_OK; srcStart = src; srcEnd = src + srcLen; srcClose = srcEnd; if ((flags & TCL_ENCODING_END) == 0) { @@ -3003,10 +2856,11 @@ dstStart = dst; dstEnd = dst + dstLen - 1; for (numChars = 0; src < srcEnd; numChars++) { + Tcl_UniChar ch; int len; if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { /* * If there is more string to follow, this will ensure that the @@ -3020,22 +2874,16 @@ /* * Check for illegal characters. */ - if (ch > 0xFF -#if TCL_UTF_MAX <= 3 - || ((ch >= 0xD800) && (len < 3)) -#endif - ) { + if (ch > 0xff) { 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) '?'; @@ -3075,21 +2923,20 @@ static void TableFreeProc( ClientData clientData) /* TableEncodingData that specifies * encoding. */ { - TableEncodingData *dataPtr = (TableEncodingData *)clientData; + TableEncodingData *dataPtr; /* * Make sure we aren't freeing twice on shutdown. [Bug 219314] */ - Tcl_Free(dataPtr->toUnicode); - dataPtr->toUnicode = NULL; - Tcl_Free(dataPtr->fromUnicode); - dataPtr->fromUnicode = NULL; - Tcl_Free(dataPtr); + dataPtr = (TableEncodingData *) clientData; + ckfree((char *) dataPtr->toUnicode); + ckfree((char *) dataPtr->fromUnicode); + ckfree((char *) dataPtr); } /* *------------------------------------------------------------------------- * @@ -3133,23 +2980,24 @@ * 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; - } + EscapeEncodingData *dataPtr; + char *prefixBytes, *tablePrefixBytes; + unsigned short **tableToUnicode; + Encoding *encodingPtr; + int state, result, numChars; + const char *srcStart, *srcEnd; + char *dstStart, *dstEnd; + result = TCL_OK; - tablePrefixBytes = NULL; - tableToUnicode = NULL; + + tablePrefixBytes = NULL; /* lint. */ + tableToUnicode = NULL; /* lint. */ + + dataPtr = (EscapeEncodingData *) clientData; prefixBytes = dataPtr->prefixBytes; encodingPtr = NULL; srcStart = src; srcEnd = src + srcLen; @@ -3160,22 +3008,22 @@ state = PTR2INT(*statePtr); if (flags & TCL_ENCODING_START) { state = 0; } - for (numChars = 0; src < srcEnd && numChars <= charLimit; ) { + for (numChars = 0; src < srcEnd; ) { int byte, hi, lo, ch; if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } byte = *((unsigned char *) src); if (prefixBytes[byte]) { - unsigned left, len, longest; + unsigned int left, len, longest; int checked, i; - const EscapeSubTable *subTablePtr; + EscapeSubTable *subTablePtr; /* * Saw the beginning of an escape sequence. */ @@ -3269,14 +3117,13 @@ if (encodingPtr == NULL) { TableEncodingData *tableDataPtr; encodingPtr = GetTableEncoding(dataPtr, state); - tableDataPtr = (TableEncodingData *)encodingPtr->clientData; + tableDataPtr = (TableEncodingData *) encodingPtr->clientData; tablePrefixBytes = tableDataPtr->prefixBytes; - tableToUnicode = (const unsigned short *const*) - tableDataPtr->toUnicode; + tableToUnicode = tableDataPtr->toUnicode; } if (tablePrefixBytes[byte]) { src++; if (src >= srcEnd) { @@ -3347,21 +3194,22 @@ * 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; + EscapeEncodingData *dataPtr; + Encoding *encodingPtr; const char *srcStart, *srcEnd, *srcClose; - const char *dstStart, *dstEnd; + char *dstStart, *dstEnd; int state, result, numChars; - const TableEncodingData *tableDataPtr; - const char *tablePrefixBytes; - const unsigned short *const *tableFromUnicode; - Tcl_UniChar ch = 0; + TableEncodingData *tableDataPtr; + char *tablePrefixBytes; + unsigned short **tableFromUnicode; result = TCL_OK; + + dataPtr = (EscapeEncodingData *) clientData; srcStart = src; srcEnd = src + srcLen; srcClose = srcEnd; if ((flags & TCL_ENCODING_END) == 0) { @@ -3370,11 +3218,11 @@ dstStart = dst; dstEnd = dst + dstLen - 1; /* - * RFC 1468 states that the text starts in ASCII, and switches to Japanese + * RFC1468 states that the text starts in ASCII, and switches to Japanese * characters, and that the text must end in ASCII. [Patch 474358] */ if (flags & TCL_ENCODING_START) { state = 0; @@ -3381,25 +3229,25 @@ if ((dst + dataPtr->initLen) > dstEnd) { *srcReadPtr = 0; *dstWrotePtr = 0; return TCL_CONVERT_NOSPACE; } - memcpy(dst, dataPtr->init, dataPtr->initLen); + memcpy(dst, dataPtr->init, (size_t)dataPtr->initLen); dst += dataPtr->initLen; } else { state = PTR2INT(*statePtr); } encodingPtr = GetTableEncoding(dataPtr, state); - tableDataPtr = (const TableEncodingData *)encodingPtr->clientData; + tableDataPtr = (TableEncodingData *) encodingPtr->clientData; tablePrefixBytes = tableDataPtr->prefixBytes; - tableFromUnicode = (const unsigned short *const *) - tableDataPtr->fromUnicode; + tableFromUnicode = tableDataPtr->fromUnicode; for (numChars = 0; src < srcEnd; numChars++) { - unsigned len; + unsigned int len; int word; + Tcl_UniChar ch; 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. @@ -3407,21 +3255,21 @@ result = TCL_CONVERT_MULTIBYTE; break; } len = TclUtfToUniChar(src, &ch); - word = tableFromUnicode[(ch >> 8)][ch & 0xFF]; + word = tableFromUnicode[(ch >> 8)][ch & 0xff]; if ((word == 0) && (ch != 0)) { int oldState; - const EscapeSubTable *subTablePtr; + 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]; + tableDataPtr = (TableEncodingData *) encodingPtr->clientData; + word = tableDataPtr->fromUnicode[(ch >> 8)][ch & 0xff]; if (word != 0) { break; } } @@ -3430,21 +3278,20 @@ if (flags & TCL_ENCODING_STOPONERROR) { result = TCL_CONVERT_UNKNOWN; break; } encodingPtr = GetTableEncoding(dataPtr, state); - tableDataPtr = (const TableEncodingData *)encodingPtr->clientData; + tableDataPtr = (TableEncodingData *) encodingPtr->clientData; word = tableDataPtr->fallback; } - tablePrefixBytes = (const char *) tableDataPtr->prefixBytes; - tableFromUnicode = (const unsigned short *const *) - tableDataPtr->fromUnicode; + tablePrefixBytes = tableDataPtr->prefixBytes; + tableFromUnicode = tableDataPtr->fromUnicode; /* * The state variable has the value of oldState when word is 0. - * In this case, the escape sequence should not be copied to dst + * In this case, the escape sequense should not be copied to dst * because the current character set is not changed. */ if (state != oldState) { subTablePtr = &dataPtr->subTables[state]; @@ -3458,11 +3305,12 @@ state = oldState; result = TCL_CONVERT_NOSPACE; break; } - memcpy(dst, subTablePtr->sequence, subTablePtr->sequenceLen); + memcpy(dst, subTablePtr->sequence, + (size_t) subTablePtr->sequenceLen); dst += subTablePtr->sequenceLen; } } if (tablePrefixBytes[(word >> 8)] != 0) { @@ -3483,29 +3331,29 @@ } src += len; } if ((result == TCL_OK) && (flags & TCL_ENCODING_END)) { - unsigned len = dataPtr->subTables[0].sequenceLen; - + unsigned int len = dataPtr->subTables[0].sequenceLen; /* - * Certain encodings like iso2022-jp need to write an escape sequence - * after all characters have been converted. This logic checks that - * enough room is available in the buffer for the escape bytes. The - * TCL_ENCODING_END flag is cleared after a final escape sequence has - * been added to the buffer so that another call to this method does - * not attempt to append escape bytes a second time. + * Certain encodings like iso2022-jp need to write + * an escape sequence after all characters have + * been converted. This logic checks that enough + * room is available in the buffer for the escape bytes. + * The TCL_ENCODING_END flag is cleared after a final + * escape sequence has been added to the buffer so + * that another call to this method does not attempt + * to append escape bytes a second time. */ - if ((dst + dataPtr->finalLen + (state?len:0)) > dstEnd) { result = TCL_CONVERT_NOSPACE; } else { if (state) { - memcpy(dst, dataPtr->subTables[0].sequence, len); + memcpy(dst, dataPtr->subTables[0].sequence, (size_t) len); dst += len; } - memcpy(dst, dataPtr->final, dataPtr->finalLen); + memcpy(dst, dataPtr->final, (size_t) dataPtr->finalLen); dst += dataPtr->finalLen; state &= ~TCL_ENCODING_END; } } @@ -3519,54 +3367,54 @@ /* *--------------------------------------------------------------------------- * * EscapeFreeProc -- * - * Frees resources used by the encoding. + * This function is invoked when an EscapeEncodingData encoding is + * deleted. It deletes the memory used by the encoding. * * Results: * None. * * Side effects: - * Memory is freed. + * Memory freed. * *--------------------------------------------------------------------------- */ static void EscapeFreeProc( ClientData clientData) /* EscapeEncodingData that specifies * encoding. */ { - EscapeEncodingData *dataPtr = (EscapeEncodingData *)clientData; + EscapeEncodingData *dataPtr; EscapeSubTable *subTablePtr; int i; + dataPtr = (EscapeEncodingData *) clientData; if (dataPtr == NULL) { return; } - /* - * The subTables should be freed recursively in normal operation but not - * during TclFinalizeEncodingSubsystem because they are also present as a - * weak reference in the toplevel encodingTable (i.e., they don't have a - * +1 refcount for this), and unpredictable nuking order could remove them - * from under the following loop's feet. [Bug 2891556] - * - * The encodingsInitialized flag, being reset on entry to TFES, can serve - * as a "not in finalization" test. + * The subTables should be freed recursively in normal operation but not + * during TclFinalizeEncodingSubsystem because they are also present as a + * weak reference in the toplevel encodingTable (ie they don't have a +1 + * refcount for this), and unpredictable nuking order could remove them + * from under the following loop's feet [Bug 2891556]. + * + * The encodingsInitialized flag, being reset on entry to TFES, can serve + * as a "not in finalization" test. */ - - if (encodingsInitialized) { - subTablePtr = dataPtr->subTables; - for (i = 0; i < dataPtr->numSubTables; i++) { - FreeEncoding((Tcl_Encoding) subTablePtr->encodingPtr); - subTablePtr->encodingPtr = NULL; - subTablePtr++; - } - } - Tcl_Free(dataPtr); + if (encodingsInitialized) + { + subTablePtr = dataPtr->subTables; + for (i = 0; i < dataPtr->numSubTables; i++) { + FreeEncoding((Tcl_Encoding) subTablePtr->encodingPtr); + subTablePtr++; + } + } + ckfree((char *) dataPtr); } /* *--------------------------------------------------------------------------- * @@ -3590,12 +3438,15 @@ static Encoding * GetTableEncoding( EscapeEncodingData *dataPtr,/* Contains names of encodings. */ int state) /* Index in dataPtr of desired Encoding. */ { - EscapeSubTable *subTablePtr = &dataPtr->subTables[state]; - Encoding *encodingPtr = subTablePtr->encodingPtr; + EscapeSubTable *subTablePtr; + Encoding *encodingPtr; + + subTablePtr = &dataPtr->subTables[state]; + encodingPtr = subTablePtr->encodingPtr; if (encodingPtr == NULL) { encodingPtr = (Encoding *) Tcl_GetEncoding(NULL, subTablePtr->name); if ((encodingPtr == NULL) || (encodingPtr->toUtfProc != TableToUtfProc @@ -3663,52 +3514,55 @@ */ static void InitializeEncodingSearchPath( char **valuePtr, - size_t *lengthPtr, + int *lengthPtr, Tcl_Encoding *encodingPtr) { - const char *bytes; - int i, numDirs; - Tcl_Obj *libPathObj, *encodingObj, *searchPathObj; + char *bytes; + int i, numDirs, numBytes; + Tcl_Obj *libPath, *encodingObj, *searchPath; TclNewLiteralStringObj(encodingObj, "encoding"); - TclNewObj(searchPathObj); + TclNewObj(searchPath); Tcl_IncrRefCount(encodingObj); - Tcl_IncrRefCount(searchPathObj); - libPathObj = TclGetLibraryPath(); - Tcl_IncrRefCount(libPathObj); - Tcl_ListObjLength(NULL, libPathObj, &numDirs); + Tcl_IncrRefCount(searchPath); + libPath = TclGetLibraryPath(); + Tcl_IncrRefCount(libPath); + Tcl_ListObjLength(NULL, libPath, &numDirs); for (i = 0; i < numDirs; i++) { - Tcl_Obj *directoryObj, *pathObj; + Tcl_Obj *directory, *path; Tcl_StatBuf stat; - Tcl_ListObjIndex(NULL, libPathObj, i, &directoryObj); - pathObj = Tcl_FSJoinToPath(directoryObj, 1, &encodingObj); - Tcl_IncrRefCount(pathObj); - if ((0 == Tcl_FSStat(pathObj, &stat)) && S_ISDIR(stat.st_mode)) { - Tcl_ListObjAppendElement(NULL, searchPathObj, pathObj); + Tcl_ListObjIndex(NULL, libPath, i, &directory); + path = Tcl_FSJoinToPath(directory, 1, &encodingObj); + Tcl_IncrRefCount(path); + if ((0 == Tcl_FSStat(path, &stat)) && S_ISDIR(stat.st_mode)) { + Tcl_ListObjAppendElement(NULL, searchPath, path); } - Tcl_DecrRefCount(pathObj); + Tcl_DecrRefCount(path); } - Tcl_DecrRefCount(libPathObj); + Tcl_DecrRefCount(libPath); Tcl_DecrRefCount(encodingObj); *encodingPtr = libraryPath.encoding; if (*encodingPtr) { ((Encoding *)(*encodingPtr))->refCount++; } - bytes = TclGetStringFromObj(searchPathObj, lengthPtr); - *valuePtr = (char *)Tcl_Alloc(*lengthPtr + 1); - memcpy(*valuePtr, bytes, *lengthPtr + 1); - Tcl_DecrRefCount(searchPathObj); + bytes = Tcl_GetStringFromObj(searchPath, &numBytes); + + *lengthPtr = numBytes; + *valuePtr = ckalloc((unsigned int) numBytes + 1); + memcpy(*valuePtr, bytes, (size_t) numBytes + 1); + Tcl_DecrRefCount(searchPath); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ + DELETED generic/tclEnsemble.c Index: generic/tclEnsemble.c ================================================================== --- generic/tclEnsemble.c +++ /dev/null @@ -1,3746 +0,0 @@ -/* - * tclEnsemble.c -- - * - * Contains support for ensembles (see TIP#112), which provide simple - * mechanism for creating composite commands on top of namespaces. - * - * Copyright (c) 2005-2013 Donal K. Fellows. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include "tclInt.h" -#include "tclCompile.h" - -/* - * Declarations for functions local to this file: - */ - -static inline Tcl_Obj * NewNsObj(Tcl_Namespace *namespacePtr); -static inline int EnsembleUnknownCallback(Tcl_Interp *interp, - EnsembleConfig *ensemblePtr, int objc, - Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr); -static int NsEnsembleImplementationCmdNR(ClientData clientData, - Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); -static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr); -static int NsEnsembleStringOrder(const void *strPtr1, - const void *strPtr2); -static void DeleteEnsembleConfig(ClientData clientData); -static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr, - EnsembleConfig *ensemblePtr, Tcl_HashEntry *hPtr, - Tcl_Obj *fix); -static void FreeEnsembleCmdRep(Tcl_Obj *objPtr); -static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); -static void CompileToInvokedCommand(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Tcl_Obj *replacements, - Command *cmdPtr, CompileEnv *envPtr); -static int CompileBasicNArgCommand(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - CompileEnv *envPtr); - -static Tcl_NRPostProc FreeER; - -/* - * The lists of subcommands and options for the [namespace ensemble] command. - */ - -static const char *const ensembleSubcommands[] = { - "configure", "create", "exists", NULL -}; -enum EnsSubcmds { - ENS_CONFIG, ENS_CREATE, ENS_EXISTS -}; - -static const char *const ensembleCreateOptions[] = { - "-command", "-map", "-parameters", "-prefixes", "-subcommands", - "-unknown", NULL -}; -enum EnsCreateOpts { - CRT_CMD, CRT_MAP, CRT_PARAM, CRT_PREFIX, CRT_SUBCMDS, CRT_UNKNOWN -}; - -static const char *const ensembleConfigOptions[] = { - "-map", "-namespace", "-parameters", "-prefixes", "-subcommands", - "-unknown", NULL -}; -enum EnsConfigOpts { - CONF_MAP, CONF_NAMESPACE, CONF_PARAM, CONF_PREFIX, CONF_SUBCMDS, - CONF_UNKNOWN -}; - -/* - * This structure defines a Tcl object type that contains a reference to an - * ensemble subcommand (e.g. the "length" in [string length ab]). It is used - * to cache the mapping between the subcommand itself and the real command - * that implements it. - */ - -static const Tcl_ObjType ensembleCmdType = { - "ensembleCommand", /* the type's name */ - FreeEnsembleCmdRep, /* freeIntRepProc */ - DupEnsembleCmdRep, /* dupIntRepProc */ - NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ -}; - -#define ECRSetIntRep(objPtr, ecRepPtr) \ - do { \ - Tcl_ObjIntRep ir; \ - ir.twoPtrValue.ptr1 = (ecRepPtr); \ - ir.twoPtrValue.ptr2 = NULL; \ - 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 { - size_t 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); -} - -/* - *---------------------------------------------------------------------- - * - * TclNamespaceEnsembleCmd -- - * - * Invoked to implement the "namespace ensemble" command that creates and - * manipulates ensembles built on top of namespaces. Handles the - * following syntax: - * - * namespace ensemble name ?dictionary? - * - * Results: - * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. - * - * Side effects: - * Creates the ensemble for the namespace if one did not previously - * exist. Alternatively, alters the way that the ensemble's subcommand => - * 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; - Tcl_Command token; - Tcl_DictSearch search; - Tcl_Obj *listObj; - const char *simpleName; - int index, done; - - if (nsPtr == NULL || nsPtr->flags & NS_DYING) { - if (!Tcl_InterpDeleted(interp)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "tried to manipulate ensemble of deleted namespace", - -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", NULL); - } - return TCL_ERROR; - } - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[1], ensembleSubcommands, - "subcommand", 0, &index) != TCL_OK) { - return TCL_ERROR; - } - - switch ((enum EnsSubcmds) index) { - case ENS_CREATE: { - const char *name; - int len, allocatedMapFlag = 0; - /* - * Defaults - */ - Tcl_Obj *subcmdObj = NULL; - Tcl_Obj *mapObj = NULL; - int permitPrefix = 1; - Tcl_Obj *unknownObj = NULL; - Tcl_Obj *paramObj = NULL; - - /* - * Check that we've got option-value pairs... [Bug 1558654] - */ - - if (objc & 1) { - Tcl_WrongNumArgs(interp, 2, objv, "?option value ...?"); - return TCL_ERROR; - } - objv += 2; - objc -= 2; - - name = nsPtr->name; - cxtPtr = (Namespace *) nsPtr->parentPtr; - - /* - * Parse the option list, applying type checks as we go. Note that we - * are not incrementing any reference counts in the objects at this - * stage, so the presence of an option multiple times won't cause any - * memory leaks. - */ - - for (; objc>1 ; objc-=2,objv+=2) { - if (Tcl_GetIndexFromObj(interp, objv[0], ensembleCreateOptions, - "option", 0, &index) != TCL_OK) { - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - return TCL_ERROR; - } - switch ((enum EnsCreateOpts) index) { - case CRT_CMD: - name = TclGetString(objv[1]); - cxtPtr = nsPtr; - continue; - case CRT_SUBCMDS: - if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - return TCL_ERROR; - } - subcmdObj = (len > 0 ? objv[1] : NULL); - continue; - case CRT_PARAM: - if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - return TCL_ERROR; - } - paramObj = (len > 0 ? objv[1] : NULL); - continue; - case CRT_MAP: { - Tcl_Obj *patchedDict = NULL, *subcmdWordsObj; - - /* - * Verify that the map is sensible. - */ - - if (Tcl_DictObjFirst(interp, objv[1], &search, - &subcmdWordsObj, &listObj, &done) != TCL_OK) { - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - return TCL_ERROR; - } - if (done) { - mapObj = NULL; - continue; - } - do { - Tcl_Obj **listv; - const char *cmd; - - if (TclListObjGetElements(interp, listObj, &len, - &listv) != TCL_OK) { - Tcl_DictObjDone(&search); - if (patchedDict) { - Tcl_DecrRefCount(patchedDict); - } - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - return TCL_ERROR; - } - if (len < 1) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "ensemble subcommand implementations " - "must be non-empty lists", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", - "EMPTY_TARGET", NULL); - Tcl_DictObjDone(&search); - if (patchedDict) { - Tcl_DecrRefCount(patchedDict); - } - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - return TCL_ERROR; - } - cmd = TclGetString(listv[0]); - if (!(cmd[0] == ':' && cmd[1] == ':')) { - Tcl_Obj *newList = Tcl_NewListObj(len, listv); - Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace *) nsPtr); - - if (nsPtr->parentPtr) { - Tcl_AppendStringsToObj(newCmd, "::", NULL); - } - Tcl_AppendObjToObj(newCmd, listv[0]); - Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd); - if (patchedDict == NULL) { - patchedDict = Tcl_DuplicateObj(objv[1]); - } - Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj, - newList); - } - Tcl_DictObjNext(&search, &subcmdWordsObj, &listObj, - &done); - } while (!done); - - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - mapObj = (patchedDict ? patchedDict : objv[1]); - if (patchedDict) { - allocatedMapFlag = 1; - } - continue; - } - case CRT_PREFIX: - if (Tcl_GetBooleanFromObj(interp, objv[1], - &permitPrefix) != TCL_OK) { - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - return TCL_ERROR; - } - continue; - case CRT_UNKNOWN: - if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - return TCL_ERROR; - } - unknownObj = (len > 0 ? objv[1] : NULL); - continue; - } - } - - TclGetNamespaceForQualName(interp, name, cxtPtr, - TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altFoundNsPtr, - &actualCxtPtr, &simpleName); - - /* - * Create the ensemble. Note that this might delete another ensemble - * linked to the same namespace, so we must be careful. However, we - * should be OK because we only link the namespace into the list once - * we've created it (and after any deletions have occurred.) - */ - - token = TclCreateEnsembleInNs(interp, simpleName, - (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, - (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0)); - Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj); - Tcl_SetEnsembleMappingDict(interp, token, mapObj); - Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj); - Tcl_SetEnsembleParameterList(interp, token, paramObj); - - /* - * Tricky! Must ensure that the result is not shared (command delete - * traces could have corrupted the pristine object that we started - * with). [Snit test rename-1.5] - */ - - Tcl_ResetResult(interp); - Tcl_GetCommandFullName(interp, token, Tcl_GetObjResult(interp)); - return TCL_OK; - } - - case ENS_EXISTS: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "cmdname"); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj( - Tcl_FindEnsemble(interp, objv[2], 0) != NULL)); - return TCL_OK; - - case ENS_CONFIG: - if (objc < 3 || (objc != 4 && !(objc & 1))) { - Tcl_WrongNumArgs(interp, 2, objv, - "cmdname ?-option value ...? ?arg ...?"); - return TCL_ERROR; - } - token = Tcl_FindEnsemble(interp, objv[2], TCL_LEAVE_ERR_MSG); - if (token == NULL) { - return TCL_ERROR; - } - - if (objc == 4) { - Tcl_Obj *resultObj = NULL; /* silence gcc 4 warning */ - - if (Tcl_GetIndexFromObj(interp, objv[3], ensembleConfigOptions, - "option", 0, &index) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum EnsConfigOpts) index) { - case CONF_SUBCMDS: - Tcl_GetEnsembleSubcommandList(NULL, token, &resultObj); - if (resultObj != NULL) { - Tcl_SetObjResult(interp, resultObj); - } - break; - case CONF_PARAM: - Tcl_GetEnsembleParameterList(NULL, token, &resultObj); - if (resultObj != NULL) { - Tcl_SetObjResult(interp, resultObj); - } - break; - case CONF_MAP: - Tcl_GetEnsembleMappingDict(NULL, token, &resultObj); - if (resultObj != NULL) { - Tcl_SetObjResult(interp, resultObj); - } - break; - case CONF_NAMESPACE: - namespacePtr = NULL; /* silence gcc 4 warning */ - Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); - Tcl_SetObjResult(interp, NewNsObj(namespacePtr)); - break; - case CONF_PREFIX: { - int flags = 0; /* silence gcc 4 warning */ - - Tcl_GetEnsembleFlags(NULL, token, &flags); - Tcl_SetObjResult(interp, - Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX)); - break; - } - case CONF_UNKNOWN: - Tcl_GetEnsembleUnknownHandler(NULL, token, &resultObj); - if (resultObj != NULL) { - Tcl_SetObjResult(interp, resultObj); - } - break; - } - } else if (objc == 3) { - /* - * Produce list of all information. - */ - - Tcl_Obj *resultObj, *tmpObj = NULL; /* silence gcc 4 warning */ - int flags = 0; /* silence gcc 4 warning */ - - TclNewObj(resultObj); - - /* -map option */ - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewStringObj(ensembleConfigOptions[CONF_MAP], -1)); - Tcl_GetEnsembleMappingDict(NULL, token, &tmpObj); - Tcl_ListObjAppendElement(NULL, resultObj, - (tmpObj != NULL) ? tmpObj : Tcl_NewObj()); - - /* -namespace option */ - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewStringObj(ensembleConfigOptions[CONF_NAMESPACE], - -1)); - namespacePtr = NULL; /* silence gcc 4 warning */ - Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); - Tcl_ListObjAppendElement(NULL, resultObj, NewNsObj(namespacePtr)); - - /* -parameters option */ - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewStringObj(ensembleConfigOptions[CONF_PARAM], -1)); - Tcl_GetEnsembleParameterList(NULL, token, &tmpObj); - Tcl_ListObjAppendElement(NULL, resultObj, - (tmpObj != NULL) ? tmpObj : Tcl_NewObj()); - - /* -prefix option */ - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewStringObj(ensembleConfigOptions[CONF_PREFIX], -1)); - Tcl_GetEnsembleFlags(NULL, token, &flags); - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX)); - - /* -subcommands option */ - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewStringObj(ensembleConfigOptions[CONF_SUBCMDS],-1)); - Tcl_GetEnsembleSubcommandList(NULL, token, &tmpObj); - Tcl_ListObjAppendElement(NULL, resultObj, - (tmpObj != NULL) ? tmpObj : Tcl_NewObj()); - - /* -unknown option */ - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewStringObj(ensembleConfigOptions[CONF_UNKNOWN],-1)); - Tcl_GetEnsembleUnknownHandler(NULL, token, &tmpObj); - Tcl_ListObjAppendElement(NULL, resultObj, - (tmpObj != NULL) ? tmpObj : Tcl_NewObj()); - - Tcl_SetObjResult(interp, resultObj); - } else { - int len, allocatedMapFlag = 0; - Tcl_Obj *subcmdObj = NULL, *mapObj = NULL, *paramObj = NULL, - *unknownObj = NULL; /* Defaults, silence gcc 4 warnings */ - int permitPrefix, flags = 0; /* silence gcc 4 warning */ - - Tcl_GetEnsembleSubcommandList(NULL, token, &subcmdObj); - Tcl_GetEnsembleMappingDict(NULL, token, &mapObj); - Tcl_GetEnsembleParameterList(NULL, token, ¶mObj); - Tcl_GetEnsembleUnknownHandler(NULL, token, &unknownObj); - Tcl_GetEnsembleFlags(NULL, token, &flags); - permitPrefix = (flags & TCL_ENSEMBLE_PREFIX) != 0; - - objv += 3; - objc -= 3; - - /* - * Parse the option list, applying type checks as we go. Note that - * we are not incrementing any reference counts in the objects at - * this stage, so the presence of an option multiple times won't - * cause any memory leaks. - */ - - for (; objc>0 ; objc-=2,objv+=2) { - if (Tcl_GetIndexFromObj(interp, objv[0],ensembleConfigOptions, - "option", 0, &index) != TCL_OK) { - freeMapAndError: - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - return TCL_ERROR; - } - switch ((enum EnsConfigOpts) index) { - case CONF_SUBCMDS: - if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { - goto freeMapAndError; - } - subcmdObj = (len > 0 ? objv[1] : NULL); - continue; - case CONF_PARAM: - if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { - goto freeMapAndError; - } - paramObj = (len > 0 ? objv[1] : NULL); - continue; - case CONF_MAP: { - Tcl_Obj *patchedDict = NULL, *subcmdWordsObj, **listv; - const char *cmd; - - /* - * Verify that the map is sensible. - */ - - if (Tcl_DictObjFirst(interp, objv[1], &search, - &subcmdWordsObj, &listObj, &done) != TCL_OK) { - goto freeMapAndError; - } - if (done) { - mapObj = NULL; - continue; - } - do { - if (TclListObjGetElements(interp, listObj, &len, - &listv) != TCL_OK) { - Tcl_DictObjDone(&search); - if (patchedDict) { - Tcl_DecrRefCount(patchedDict); - } - goto freeMapAndError; - } - if (len < 1) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "ensemble subcommand implementations " - "must be non-empty lists", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", - "EMPTY_TARGET", NULL); - Tcl_DictObjDone(&search); - if (patchedDict) { - Tcl_DecrRefCount(patchedDict); - } - goto freeMapAndError; - } - cmd = TclGetString(listv[0]); - if (!(cmd[0] == ':' && cmd[1] == ':')) { - Tcl_Obj *newList = Tcl_DuplicateObj(listObj); - Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace*)nsPtr); - - if (nsPtr->parentPtr) { - Tcl_AppendStringsToObj(newCmd, "::", NULL); - } - Tcl_AppendObjToObj(newCmd, listv[0]); - Tcl_ListObjReplace(NULL, newList, 0, 1, 1, - &newCmd); - if (patchedDict == NULL) { - patchedDict = Tcl_DuplicateObj(objv[1]); - } - Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj, - newList); - } - Tcl_DictObjNext(&search, &subcmdWordsObj, &listObj, - &done); - } while (!done); - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - mapObj = (patchedDict ? patchedDict : objv[1]); - if (patchedDict) { - allocatedMapFlag = 1; - } - continue; - } - case CONF_NAMESPACE: - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "option -namespace is read-only", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "READ_ONLY", - NULL); - goto freeMapAndError; - case CONF_PREFIX: - if (Tcl_GetBooleanFromObj(interp, objv[1], - &permitPrefix) != TCL_OK) { - goto freeMapAndError; - } - continue; - case CONF_UNKNOWN: - if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { - goto freeMapAndError; - } - unknownObj = (len > 0 ? objv[1] : NULL); - continue; - } - } - - /* - * Update the namespace now that we've finished the parsing stage. - */ - - flags = (permitPrefix ? flags|TCL_ENSEMBLE_PREFIX - : flags&~TCL_ENSEMBLE_PREFIX); - Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj); - Tcl_SetEnsembleMappingDict(interp, token, mapObj); - Tcl_SetEnsembleParameterList(interp, token, paramObj); - Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj); - Tcl_SetEnsembleFlags(interp, token, flags); - } - return TCL_OK; - - default: - Tcl_Panic("unexpected ensemble command"); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCreateEnsembleInNs -- - * - * Like Tcl_CreateEnsemble, but additionally accepts as an argument the - * name of the namespace to create the command in. - * - *---------------------------------------------------------------------- - */ - -Tcl_Command -TclCreateEnsembleInNs( - Tcl_Interp *interp, - const char *name, /* Simple name of command to create (no - * namespace components). */ - Tcl_Namespace *nameNsPtr, /* Name of namespace to create the command - * in. */ - Tcl_Namespace *ensembleNsPtr, - /* Name of the namespace for the ensemble. */ - int flags) -{ - Namespace *nsPtr = (Namespace *) ensembleNsPtr; - EnsembleConfig *ensemblePtr; - Tcl_Command token; - - ensemblePtr = (EnsembleConfig *)Tcl_Alloc(sizeof(EnsembleConfig)); - token = TclNRCreateCommandInNs(interp, name, - (Tcl_Namespace *) nameNsPtr, TclEnsembleImplementationCmd, - NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig); - if (token == NULL) { - Tcl_Free(ensemblePtr); - return NULL; - } - - ensemblePtr->nsPtr = nsPtr; - ensemblePtr->epoch = 0; - Tcl_InitHashTable(&ensemblePtr->subcommandTable, TCL_STRING_KEYS); - ensemblePtr->subcommandArrayPtr = NULL; - ensemblePtr->subcmdList = NULL; - ensemblePtr->subcommandDict = NULL; - ensemblePtr->flags = flags; - ensemblePtr->numParameters = 0; - ensemblePtr->parameterList = NULL; - ensemblePtr->unknownHandler = NULL; - ensemblePtr->token = token; - ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles; - nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr; - - /* - * Trigger an eventual recomputation of the ensemble command set. Note - * that this is slightly tricky, as it means that we are not actually - * counting the number of namespace export actions, but it is the simplest - * way to go! - */ - - nsPtr->exportLookupEpoch++; - - if (flags & ENSEMBLE_COMPILE) { - ((Command *) ensemblePtr->token)->compileProc = TclCompileEnsemble; - } - - return ensemblePtr->token; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CreateEnsemble - * - * Create a simple ensemble attached to the given namespace. Deprecated - * (internally) by TclCreateEnsembleInNs. - * - * Value - * - * The token for the command created. - * - * Effect - * The ensemble is created and marked for compilation. - * - * - *---------------------------------------------------------------------- - */ - -Tcl_Command -Tcl_CreateEnsemble( - Tcl_Interp *interp, - const char *name, - Tcl_Namespace *namespacePtr, - int flags) -{ - Namespace *nsPtr = (Namespace *) namespacePtr, *foundNsPtr, *altNsPtr, - *actualNsPtr; - const char * simpleName; - - if (nsPtr == NULL) { - nsPtr = (Namespace *) TclGetCurrentNamespace(interp); - } - - TclGetNamespaceForQualName(interp, name, nsPtr, TCL_CREATE_NS_IF_UNKNOWN, - &foundNsPtr, &altNsPtr, &actualNsPtr, &simpleName); - return TclCreateEnsembleInNs(interp, simpleName, - (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, flags); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetEnsembleSubcommandList -- - * - * Set the subcommand list for a particular ensemble. - * - * Results: - * Tcl result code (error if command token does not indicate an ensemble - * or the subcommand list - if non-NULL - is not a list). - * - * Side effects: - * The ensemble is updated and marked for recompilation. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_SetEnsembleSubcommandList( - Tcl_Interp *interp, - Tcl_Command token, - Tcl_Obj *subcmdList) -{ - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; - Tcl_Obj *oldList; - - 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; - } - if (subcmdList != NULL) { - int length; - - if (TclListObjLength(interp, subcmdList, &length) != TCL_OK) { - 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); - } - - /* - * Trigger an eventual recomputation of the ensemble command set. Note - * that this is slightly tricky, as it means that we are not actually - * counting the number of namespace export actions, but it is the simplest - * way to go! - */ - - ensemblePtr->nsPtr->exportLookupEpoch++; - - /* - * Special hack to make compiling of [info exists] work when the - * dictionary is modified. - */ - - if (cmdPtr->compileProc != NULL) { - ((Interp *) interp)->compileEpoch++; - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetEnsembleParameterList -- - * - * Set the parameter list for a particular ensemble. - * - * Results: - * Tcl result code (error if command token does not indicate an ensemble - * or the parameter list - if non-NULL - is not a list). - * - * Side effects: - * The ensemble is updated and marked for recompilation. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_SetEnsembleParameterList( - Tcl_Interp *interp, - Tcl_Command token, - Tcl_Obj *paramList) -{ - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; - Tcl_Obj *oldList; - int length; - - 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; - } - if (paramList == NULL) { - length = 0; - } else { - if (TclListObjLength(interp, paramList, &length) != TCL_OK) { - 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); - } - ensemblePtr->numParameters = length; - - /* - * Trigger an eventual recomputation of the ensemble command set. Note - * that this is slightly tricky, as it means that we are not actually - * counting the number of namespace export actions, but it is the simplest - * way to go! - */ - - ensemblePtr->nsPtr->exportLookupEpoch++; - - /* - * Special hack to make compiling of [info exists] work when the - * dictionary is modified. - */ - - if (cmdPtr->compileProc != NULL) { - ((Interp *) interp)->compileEpoch++; - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetEnsembleMappingDict -- - * - * Set the mapping dictionary for a particular ensemble. - * - * Results: - * Tcl result code (error if command token does not indicate an ensemble - * or the mapping - if non-NULL - is not a dict). - * - * Side effects: - * The ensemble is updated and marked for recompilation. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_SetEnsembleMappingDict( - Tcl_Interp *interp, - Tcl_Command token, - Tcl_Obj *mapDict) -{ - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; - Tcl_Obj *oldDict; - - 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; - } - if (mapDict != NULL) { - int size, done; - Tcl_DictSearch search; - Tcl_Obj *valuePtr; - - if (Tcl_DictObjSize(interp, mapDict, &size) != TCL_OK) { - return TCL_ERROR; - } - - for (Tcl_DictObjFirst(NULL, mapDict, &search, NULL, &valuePtr, &done); - !done; Tcl_DictObjNext(&search, NULL, &valuePtr, &done)) { - Tcl_Obj *cmdObjPtr; - const char *bytes; - - if (Tcl_ListObjIndex(interp, valuePtr, 0, &cmdObjPtr) != TCL_OK) { - Tcl_DictObjDone(&search); - return TCL_ERROR; - } - bytes = TclGetString(cmdObjPtr); - if (bytes[0] != ':' || bytes[1] != ':') { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "ensemble target is not a fully-qualified command", - -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", - "UNQUALIFIED_TARGET", NULL); - Tcl_DictObjDone(&search); - return TCL_ERROR; - } - } - - 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); - } - - /* - * Trigger an eventual recomputation of the ensemble command set. Note - * that this is slightly tricky, as it means that we are not actually - * counting the number of namespace export actions, but it is the simplest - * way to go! - */ - - ensemblePtr->nsPtr->exportLookupEpoch++; - - /* - * Special hack to make compiling of [info exists] work when the - * dictionary is modified. - */ - - if (cmdPtr->compileProc != NULL) { - ((Interp *) interp)->compileEpoch++; - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetEnsembleUnknownHandler -- - * - * Set the unknown handler for a particular ensemble. - * - * Results: - * Tcl result code (error if command token does not indicate an ensemble - * or the unknown handler - if non-NULL - is not a list). - * - * Side effects: - * The ensemble is updated and marked for recompilation. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_SetEnsembleUnknownHandler( - Tcl_Interp *interp, - Tcl_Command token, - Tcl_Obj *unknownList) -{ - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; - Tcl_Obj *oldList; - - 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; - } - if (unknownList != NULL) { - int length; - - if (TclListObjLength(interp, unknownList, &length) != TCL_OK) { - 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); - } - - /* - * Trigger an eventual recomputation of the ensemble command set. Note - * that this is slightly tricky, as it means that we are not actually - * counting the number of namespace export actions, but it is the simplest - * way to go! - */ - - ensemblePtr->nsPtr->exportLookupEpoch++; - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetEnsembleFlags -- - * - * Set the flags for a particular ensemble. - * - * Results: - * Tcl result code (error if command token does not indicate an - * ensemble). - * - * Side effects: - * The ensemble is updated and marked for recompilation. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_SetEnsembleFlags( - Tcl_Interp *interp, - Tcl_Command token, - int flags) -{ - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; - int wasCompiled; - - 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; - ensemblePtr->flags |= flags & ~ENSEMBLE_DEAD; - - /* - * Trigger an eventual recomputation of the ensemble command set. Note - * that this is slightly tricky, as it means that we are not actually - * counting the number of namespace export actions, but it is the simplest - * way to go! - */ - - ensemblePtr->nsPtr->exportLookupEpoch++; - - /* - * If the ENSEMBLE_COMPILE flag status was changed, install or remove the - * compiler function and bump the interpreter's compilation epoch so that - * bytecode gets regenerated. - */ - - if (flags & ENSEMBLE_COMPILE) { - if (!wasCompiled) { - ((Command*) ensemblePtr->token)->compileProc = TclCompileEnsemble; - ((Interp *) interp)->compileEpoch++; - } - } else { - if (wasCompiled) { - ((Command *) ensemblePtr->token)->compileProc = NULL; - ((Interp *) interp)->compileEpoch++; - } - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetEnsembleSubcommandList -- - * - * Get the list of subcommands associated with a particular ensemble. - * - * Results: - * Tcl result code (error if command token does not indicate an - * ensemble). The list of subcommands is returned by updating the - * variable pointed to by the last parameter (NULL if this is to be - * derived from the mapping dictionary or the associated namespace's - * exported commands). - * - * Side effects: - * None - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetEnsembleSubcommandList( - Tcl_Interp *interp, - Tcl_Command token, - Tcl_Obj **subcmdListPtr) -{ - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; - - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { - if (interp != NULL) { - 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; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetEnsembleParameterList -- - * - * Get the list of parameters associated with a particular ensemble. - * - * Results: - * Tcl result code (error if command token does not indicate an - * ensemble). The list of parameters is returned by updating the - * variable pointed to by the last parameter (NULL if there are - * no parameters). - * - * Side effects: - * None - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetEnsembleParameterList( - Tcl_Interp *interp, - Tcl_Command token, - Tcl_Obj **paramListPtr) -{ - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; - - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { - if (interp != NULL) { - 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; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetEnsembleMappingDict -- - * - * Get the command mapping dictionary associated with a particular - * ensemble. - * - * Results: - * Tcl result code (error if command token does not indicate an - * ensemble). The mapping dict is returned by updating the variable - * pointed to by the last parameter (NULL if none is installed). - * - * Side effects: - * None - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetEnsembleMappingDict( - Tcl_Interp *interp, - Tcl_Command token, - Tcl_Obj **mapDictPtr) -{ - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; - - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { - if (interp != NULL) { - 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; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetEnsembleUnknownHandler -- - * - * Get the unknown handler associated with a particular ensemble. - * - * Results: - * Tcl result code (error if command token does not indicate an - * ensemble). The unknown handler is returned by updating the variable - * pointed to by the last parameter (NULL if no handler is installed). - * - * Side effects: - * None - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetEnsembleUnknownHandler( - Tcl_Interp *interp, - Tcl_Command token, - Tcl_Obj **unknownListPtr) -{ - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; - - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { - if (interp != NULL) { - 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; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetEnsembleFlags -- - * - * Get the flags for a particular ensemble. - * - * Results: - * Tcl result code (error if command token does not indicate an - * ensemble). The flags are returned by updating the variable pointed to - * by the last parameter. - * - * Side effects: - * None - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetEnsembleFlags( - Tcl_Interp *interp, - Tcl_Command token, - int *flagsPtr) -{ - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; - - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { - if (interp != NULL) { - 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; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetEnsembleNamespace -- - * - * Get the namespace associated with a particular ensemble. - * - * Results: - * Tcl result code (error if command token does not indicate an - * ensemble). Namespace is returned by updating the variable pointed to - * by the last parameter. - * - * Side effects: - * None - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetEnsembleNamespace( - Tcl_Interp *interp, - Tcl_Command token, - Tcl_Namespace **namespacePtrPtr) -{ - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; - - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { - if (interp != NULL) { - 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; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_FindEnsemble -- - * - * Given a command name, get the ensemble token for it, allowing for - * [namespace import]s. [Bug 1017022] - * - * Results: - * The token for the ensemble command with the given name, or NULL if the - * command either does not exist or is not an ensemble (when an error - * message will be written into the interp if thats non-NULL). - * - * Side effects: - * None - * - *---------------------------------------------------------------------- - */ - -Tcl_Command -Tcl_FindEnsemble( - Tcl_Interp *interp, /* Where to do the lookup, and where to write - * the errors if TCL_LEAVE_ERR_MSG is set in - * the flags. */ - Tcl_Obj *cmdNameObj, /* Name of command to look up. */ - int flags) /* Either 0 or TCL_LEAVE_ERR_MSG; other flags - * are probably not useful. */ -{ - Command *cmdPtr; - - cmdPtr = (Command *) - Tcl_FindCommand(interp, TclGetString(cmdNameObj), NULL, flags); - if (cmdPtr == NULL) { - return NULL; - } - - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { - /* - * Reuse existing infrastructure for following import link chains - * rather than duplicating it. - */ - - cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); - - if (cmdPtr == NULL - || cmdPtr->objProc != TclEnsembleImplementationCmd) { - if (flags & TCL_LEAVE_ERR_MSG) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" is not an ensemble command", - TclGetString(cmdNameObj))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE", - TclGetString(cmdNameObj), NULL); - } - return NULL; - } - } - - return (Tcl_Command) cmdPtr; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_IsEnsemble -- - * - * Simple test for ensemble-hood that takes into account imported - * ensemble commands as well. - * - * Results: - * Boolean value - * - * Side effects: - * None - * - *---------------------------------------------------------------------- - */ - -int -Tcl_IsEnsemble( - Tcl_Command token) -{ - Command *cmdPtr = (Command *) token; - - if (cmdPtr->objProc == TclEnsembleImplementationCmd) { - return 1; - } - cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); - if (cmdPtr == NULL || cmdPtr->objProc != TclEnsembleImplementationCmd) { - return 0; - } - return 1; -} - -/* - *---------------------------------------------------------------------- - * - * TclMakeEnsemble -- - * - * Create an ensemble from a table of implementation commands. The - * ensemble will be subject to (limited) compilation if any of the - * implementation commands are compilable. - * - * The 'name' parameter may be a single command name or a list if - * creating an ensemble subcommand (see the binary implementation). - * - * Currently, the TCL_ENSEMBLE_PREFIX ensemble flag is only used on - * top-level ensemble commands. - * - * Results: - * Handle for the new ensemble, or NULL on failure. - * - * Side effects: - * May advance the bytecode compilation epoch. - * - *---------------------------------------------------------------------- - */ - -Tcl_Command -TclMakeEnsemble( - Tcl_Interp *interp, - const char *name, /* The ensemble name (as explained above) */ - const EnsembleImplMap map[]) /* The subcommands to create */ -{ - Tcl_Command ensemble; - Tcl_Namespace *ns; - Tcl_DString buf, hiddenBuf; - const char **nameParts = NULL; - const char *cmdName = NULL; - int i, nameCount = 0, ensembleFlags = 0, hiddenLen; - - /* - * Construct the path for the ensemble namespace and create it. - */ - - Tcl_DStringInit(&buf); - Tcl_DStringInit(&hiddenBuf); - TclDStringAppendLiteral(&hiddenBuf, "tcl:"); - Tcl_DStringAppend(&hiddenBuf, name, -1); - TclDStringAppendLiteral(&hiddenBuf, ":"); - hiddenLen = Tcl_DStringLength(&hiddenBuf); - if (name[0] == ':' && name[1] == ':') { - /* - * An absolute name, so use it directly. - */ - - cmdName = name; - Tcl_DStringAppend(&buf, name, -1); - ensembleFlags = TCL_ENSEMBLE_PREFIX; - } else { - /* - * Not an absolute name, so do munging of it. Note that this treats a - * multi-word list differently to a single word. - */ - - TclDStringAppendLiteral(&buf, "::tcl"); - - if (Tcl_SplitList(NULL, name, &nameCount, &nameParts) != TCL_OK) { - Tcl_Panic("invalid ensemble name '%s'", name); - } - - for (i = 0; i < nameCount; ++i) { - TclDStringAppendLiteral(&buf, "::"); - Tcl_DStringAppend(&buf, nameParts[i], -1); - } - } - - ns = Tcl_FindNamespace(interp, Tcl_DStringValue(&buf), NULL, - TCL_CREATE_NS_IF_UNKNOWN); - if (!ns) { - Tcl_Panic("unable to find or create %s namespace!", - Tcl_DStringValue(&buf)); - } - - /* - * Create the named ensemble in the correct namespace - */ - - if (cmdName == NULL) { - if (nameCount == 1) { - ensembleFlags = TCL_ENSEMBLE_PREFIX; - cmdName = Tcl_DStringValue(&buf) + 5; - } else { - ns = ns->parentPtr; - cmdName = nameParts[nameCount - 1]; - } - } - - /* - * Switch on compilation always for core ensembles now that we can do - * nice bytecode things with them. Do it now. Waiting until later will - * just cause pointless epoch bumps. - */ - - ensembleFlags |= ENSEMBLE_COMPILE; - ensemble = Tcl_CreateEnsemble(interp, cmdName, ns, ensembleFlags); - - /* - * Create the ensemble mapping dictionary and the ensemble command procs. - */ - - if (ensemble != NULL) { - Tcl_Obj *mapDict, *fromObj, *toObj; - Command *cmdPtr; - - TclDStringAppendLiteral(&buf, "::"); - TclNewObj(mapDict); - for (i=0 ; map[i].name != NULL ; i++) { - fromObj = Tcl_NewStringObj(map[i].name, -1); - TclNewStringObj(toObj, Tcl_DStringValue(&buf), - Tcl_DStringLength(&buf)); - Tcl_AppendToObj(toObj, map[i].name, -1); - Tcl_DictObjPut(NULL, mapDict, fromObj, toObj); - - if (map[i].proc || map[i].nreProc) { - /* - * If the command is unsafe, hide it when we're in a safe - * interpreter. The code to do this is really hokey! It also - * doesn't work properly yet; this function is always - * currently called before the safe-interp flag is set so the - * Tcl_IsSafe check fails. - */ - - if (map[i].unsafe && Tcl_IsSafe(interp)) { - cmdPtr = (Command *) - Tcl_NRCreateCommand(interp, "___tmp", map[i].proc, - map[i].nreProc, map[i].clientData, NULL); - Tcl_DStringSetLength(&hiddenBuf, hiddenLen); - if (Tcl_HideCommand(interp, "___tmp", - Tcl_DStringAppend(&hiddenBuf, map[i].name, -1))) { - Tcl_Panic("%s", Tcl_GetStringResult(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) { - Tcl_Free((void *)nameParts); - } - return ensemble; -} - -/* - *---------------------------------------------------------------------- - * - * TclEnsembleImplementationCmd -- - * - * Implements an ensemble of commands (being those exported by a - * namespace other than the global namespace) as a command with the same - * (short) name as the namespace in the parent namespace. - * - * Results: - * A standard Tcl result code. Will be TCL_ERROR if the command is not an - * unambiguous prefix of any command exported by the ensemble's - * namespace. - * - * Side effects: - * Depends on the command within the namespace that gets executed. If the - * ensemble itself returns TCL_ERROR, a descriptive error message will be - * placed in the interpreter's result. - * - *---------------------------------------------------------------------- - */ - -int -TclEnsembleImplementationCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - return Tcl_NRCallObjProc(interp, NsEnsembleImplementationCmdNR, - clientData, objc, objv); -} - -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; - size_t subIdx; - - /* - * Must recheck objc, since numParameters might have changed. Cf. test - * namespace-53.9. - */ - - restartEnsembleParse: - subIdx = 1 + ensemblePtr->numParameters; - if ((size_t)objc < subIdx + 1) { - /* - * We don't have a subcommand argument. Make error message. - */ - - Tcl_DString buf; /* Message being built */ - - Tcl_DStringInit(&buf); - if (ensemblePtr->parameterList) { - Tcl_DStringAppend(&buf, - TclGetString(ensemblePtr->parameterList), -1); - TclDStringAppendLiteral(&buf, " "); - } - TclDStringAppendLiteral(&buf, "subcommand ?arg ...?"); - Tcl_WrongNumArgs(interp, 1, objv, Tcl_DStringValue(&buf)); - Tcl_DStringFree(&buf); - - return TCL_ERROR; - } - - if (ensemblePtr->nsPtr->flags & NS_DYING) { - /* - * Don't know how we got here, but make things give up quickly. - */ - - if (!Tcl_InterpDeleted(interp)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "ensemble activated for deleted namespace", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", NULL); - } - return TCL_ERROR; - } - - /* - * Determine if the table of subcommands is right. If so, we can just look - * up in there and go straight to dispatch. - */ - - subObj = objv[subIdx]; - - if (ensemblePtr->epoch == ensemblePtr->nsPtr->exportLookupEpoch) { - /* - * Table of subcommands is still valid; therefore there might be a - * valid cache of discovered information which we can reuse. Do the - * check here, and if we're still valid, we can jump straight to the - * part where we do the invocation of the subcommand. - */ - 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; - } - } - } else { - BuildEnsembleConfig(ensemblePtr); - ensemblePtr->epoch = ensemblePtr->nsPtr->exportLookupEpoch; - } - - /* - * Look in the hashtable for the subcommand name; this is the fastest way - * of all if there is no cache in operation. - */ - - hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, - TclGetString(subObj)); - if (hPtr != NULL) { - - /* - * Cache for later in the subcommand object. - */ - - MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, NULL); - } else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) { - /* - * Could not map, no prefixing, go to unknown/error handling. - */ - - goto unknownOrAmbiguousSubcommand; - } else { - /* - * If we've not already confirmed the command with the hash as part of - * building our export table, we need to scan the sorted array for - * 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. */ - size_t stringLength, i; - size_t tableLength = ensemblePtr->subcommandTable.numEntries; - Tcl_Obj *fix; - - subcmdName = TclGetStringFromObj(subObj, &stringLength); - for (i=0 ; isubcommandArrayPtr[i], - stringLength); - - if (cmp == 0) { - if (fullName != NULL) { - /* - * Since there's never the exact-match case to worry about - * (hash search filters this), getting here indicates that - * our subcommand is an ambiguous prefix of (at least) two - * exported subcommands, which is an error case. - */ - - goto unknownOrAmbiguousSubcommand; - } - fullName = ensemblePtr->subcommandArrayPtr[i]; - } else if (cmp < 0) { - /* - * Because we are searching a sorted table, we can now stop - * searching because we have gone past anything that could - * possibly match. - */ - - break; - } - } - if (fullName == NULL) { - /* - * The subcommand is not a prefix of anything, so bail out! - */ - - goto unknownOrAmbiguousSubcommand; - } - hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, fullName); - if (hPtr == NULL) { - Tcl_Panic("full name %s not found in supposedly synchronized hash", - fullName); - } - - /* - * Record the spelling correction for usage message. - */ - - fix = Tcl_NewStringObj(fullName, -1); - - /* - * 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 - * feeding it back through the main command-lookup engine. In theory, we - * could look up the command in the namespace ourselves, as we already - * have the namespace in which it is guaranteed to exist, - * - * ((Q: That's not true if the -map option is used, is it?)) - * - * but we don't do that (the cacheing of the command object used should - * help with that.) - */ - - { - Tcl_Obj *copyPtr; /* The actual list of words to dispatch to. - * Will be freed by the dispatch engine. */ - Tcl_Obj **copyObjv; - int copyObjc, prefixObjc; - - Tcl_ListObjLength(NULL, prefixObj, &prefixObjc); - - if (objc == 2) { - copyPtr = TclListObjCopy(NULL, prefixObj); - } else { - copyPtr = Tcl_NewListObj(objc - 2 + prefixObjc, NULL); - Tcl_ListObjAppendList(NULL, copyPtr, prefixObj); - Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0, - ensemblePtr->numParameters, objv + 1); - Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0, - objc - 2 - ensemblePtr->numParameters, - objv + 2 + ensemblePtr->numParameters); - } - Tcl_IncrRefCount(copyPtr); - TclNRAddCallback(interp, TclNRReleaseValues, copyPtr, NULL, NULL, NULL); - TclDecrRefCount(prefixObj); - - /* - * Record what arguments the script sent in so that things like - * Tcl_WrongNumArgs can give the correct error message. Parameters - * count both as inserted and removed arguments. - */ - - if (TclInitRewriteEnsemble(interp, 2 + ensemblePtr->numParameters, - prefixObjc + ensemblePtr->numParameters, objv)) { - TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, - NULL); - } - - /* - * Hand off to the target command. - */ - - TclSkipTailcall(interp); - Tcl_ListObjGetElements(NULL, copyPtr, ©Objc, ©Objv); - ((Interp *)interp)->lookupNsPtr = ensemblePtr->nsPtr; - return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL); - } - - unknownOrAmbiguousSubcommand: - /* - * Have not been able to match the subcommand asked for with a real - * subcommand that we export. See whether a handler has been registered - * for dealing with this situation. Will only call (at most) once for any - * particular ensemble invocation. - */ - - if (ensemblePtr->unknownHandler != NULL && reparseCount++ < 1) { - switch (EnsembleUnknownCallback(interp, ensemblePtr, objc, objv, - &prefixObj)) { - case TCL_OK: - goto runResultingSubcommand; - case TCL_ERROR: - return TCL_ERROR; - case TCL_CONTINUE: - goto restartEnsembleParse; - } - } - - /* - * We cannot determine what subcommand to hand off to, so generate a - * (standard) failure message. Note the one odd case compared with - * standard ensemble-like command, which is where a namespace has no - * exported commands at all... - */ - - Tcl_ResetResult(interp); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND", - TclGetString(subObj), NULL); - if (ensemblePtr->subcommandTable.numEntries == 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown subcommand \"%s\": namespace %s does not" - " export any commands", TclGetString(subObj), - ensemblePtr->nsPtr->fullName)); - return TCL_ERROR; - } - errorObj = Tcl_ObjPrintf("unknown%s subcommand \"%s\": must be ", - (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? " or ambiguous" : ""), - TclGetString(subObj)); - if (ensemblePtr->subcommandTable.numEntries == 1) { - Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[0], -1); - } else { - size_t i; - - for (i=0 ; isubcommandTable.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; -} - -/* - *---------------------------------------------------------------------- - * - * TclInitRewriteEnsemble -- - * - * Applies a rewrite of arguments so that an ensemble subcommand will - * report error messages correctly for the overall command. - * - * Results: - * Whether this is the first rewrite applied, a value which must be - * passed to TclResetRewriteEnsemble when undoing this command's - * behaviour. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclInitRewriteEnsemble( - Tcl_Interp *interp, - size_t numRemoved, - size_t 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 { - size_t numIns = iPtr->ensembleRewrite.numInsertedObjs; - - if (numIns < numRemoved) { - iPtr->ensembleRewrite.numRemovedObjs += numRemoved - numIns; - iPtr->ensembleRewrite.numInsertedObjs = numInserted; - } else { - iPtr->ensembleRewrite.numInsertedObjs += numInserted - numRemoved; - } - } - return isRootEnsemble; -} - -/* - *---------------------------------------------------------------------- - * - * TclResetRewriteEnsemble -- - * - * Removes any rewrites applied to support proper reporting of error - * messages used in ensembles. Should be paired with - * TclInitRewriteEnsemble. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -TclResetRewriteEnsemble( - Tcl_Interp *interp, - int isRootEnsemble) -{ - Interp *iPtr = (Interp *) interp; - - if (isRootEnsemble) { - iPtr->ensembleRewrite.sourceObjs = NULL; - iPtr->ensembleRewrite.numRemovedObjs = 0; - iPtr->ensembleRewrite.numInsertedObjs = 0; - } -} - -/* - *---------------------------------------------------------------------- - * - * TclSpellFix -- - * - * Record a spelling correction that needs making in the generation of - * the WrongNumArgs usage message. - * - * Results: - * None. - * - * Side effects: - * Can create an alternative ensemble rewrite structure. - * - *---------------------------------------------------------------------- - */ - -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]; - - Tcl_Free(store); - Tcl_Free(tmp); - return result; -} - -void -TclSpellFix( - Tcl_Interp *interp, - Tcl_Obj *const *objv, - int objc, - size_t badIdx, - Tcl_Obj *bad, - Tcl_Obj *fix) -{ - Interp *iPtr = (Interp *) interp; - Tcl_Obj *const *search; - Tcl_Obj **store; - size_t idx; - size_t size; - - if (iPtr->ensembleRewrite.sourceObjs == NULL) { - iPtr->ensembleRewrite.sourceObjs = objv; - iPtr->ensembleRewrite.numRemovedObjs = 0; - iPtr->ensembleRewrite.numInsertedObjs = 0; - } - - /* - * Compute the valid length of the ensemble root. - */ - - size = iPtr->ensembleRewrite.numRemovedObjs + objc - - iPtr->ensembleRewrite.numInsertedObjs; - - search = iPtr->ensembleRewrite.sourceObjs; - if (search[0] == NULL) { - /* - * Awful casting abuse here! - */ - - search = (Tcl_Obj *const *) search[1]; - } - - if (badIdx < iPtr->ensembleRewrite.numInsertedObjs) { - /* - * Misspelled value was inserted. We cannot directly jump to the bad - * value, but have to search. - */ - - idx = 1; - while (idx < size) { - if (search[idx] == bad) { - break; - } - idx++; - } - if (idx == size) { - return; - } - } else { - /* - * Jump to the misspelled value. - */ - - idx = iPtr->ensembleRewrite.numRemovedObjs + badIdx - - iPtr->ensembleRewrite.numInsertedObjs; - - /* Verify */ - if (search[idx] != bad) { - Tcl_Panic("SpellFix: programming error"); - } - } - - search = iPtr->ensembleRewrite.sourceObjs; - if (search[0] == NULL) { - store = (Tcl_Obj **) search[2]; - } else { - Tcl_Obj **tmp = (Tcl_Obj **)Tcl_Alloc(3 * sizeof(Tcl_Obj *)); - - store = (Tcl_Obj **)Tcl_Alloc(size * sizeof(Tcl_Obj *)); - memcpy(store, iPtr->ensembleRewrite.sourceObjs, - size * sizeof(Tcl_Obj *)); - - /* - * Awful casting abuse here! Note that the NULL in the first element - * indicates that the initial objects are a raw array in the second - * element and the rewritten ones are a raw array in the third. - */ - - tmp[0] = NULL; - tmp[1] = (Tcl_Obj *) iPtr->ensembleRewrite.sourceObjs; - tmp[2] = (Tcl_Obj *) store; - iPtr->ensembleRewrite.sourceObjs = (Tcl_Obj *const *) tmp; - - TclNRAddCallback(interp, FreeER, tmp, store, NULL, NULL); - } - - store[idx] = fix; - Tcl_IncrRefCount(fix); - TclNRAddCallback(interp, TclNRReleaseValues, fix, NULL, NULL, NULL); -} - -/* - *---------------------------------------------------------------------- - * - * TclFetchEnsembleRoot -- - * - * Returns the root of ensemble rewriting, if any. - * If no root exists, returns objv instead. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj *const * -TclFetchEnsembleRoot( - Tcl_Interp *interp, - Tcl_Obj *const *objv, - int objc, - int *objcPtr) -{ - Interp *iPtr = (Interp *) interp; - - if (iPtr->ensembleRewrite.sourceObjs) { - *objcPtr = objc + iPtr->ensembleRewrite.numRemovedObjs - - iPtr->ensembleRewrite.numInsertedObjs; - return iPtr->ensembleRewrite.sourceObjs; - } - *objcPtr = objc; - return objv; -} - -/* - * ---------------------------------------------------------------------- - * - * EnsmebleUnknownCallback -- - * - * Helper for the ensemble engine that handles the procesing of unknown - * callbacks. See the user documentation of the ensemble unknown handler - * for details; this function is only ever called when such a function is - * defined, and is only ever called once per ensemble dispatch (i.e. if a - * reparse still fails, this isn't called again). - * - * Results: - * TCL_OK - *prefixObjPtr contains the command words to dispatch - * to. - * TCL_CONTINUE - Need to reparse (*prefixObjPtr is invalid). - * TCL_ERROR - Something went wrong! Error message in interpreter. - * - * Side effects: - * Calls the Tcl interpreter, so arbitrary. - * - * ---------------------------------------------------------------------- - */ - -static inline int -EnsembleUnknownCallback( - Tcl_Interp *interp, - EnsembleConfig *ensemblePtr, - int objc, - Tcl_Obj *const objv[], - Tcl_Obj **prefixObjPtr) -{ - int paramc, i, result, prefixObjc; - Tcl_Obj **paramv, *unknownCmd, *ensObj; - - /* - * Create the unknown command callback to determine what to do. - */ - - unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler); - TclNewObj(ensObj); - Tcl_GetCommandFullName(interp, ensemblePtr->token, ensObj); - Tcl_ListObjAppendElement(NULL, unknownCmd, ensObj); - for (i=1 ; iflags & ENSEMBLE_DEAD)) { - if (!Tcl_InterpDeleted(interp)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unknown subcommand handler deleted its ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_DELETED", - NULL); - } - result = TCL_ERROR; - } - Tcl_Release(ensemblePtr); - - /* - * If we succeeded, we should either have a list of words that form the - * command to be executed, or an empty list. In the empty-list case, the - * ensemble is believed to be updated so we should ask the ensemble engine - * to reparse the original command. - */ - - if (result == TCL_OK) { - *prefixObjPtr = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(*prefixObjPtr); - TclDecrRefCount(unknownCmd); - Tcl_ResetResult(interp); - - /* - * Namespace is still there. Check if the result is a valid list. If - * it is, and it is non-empty, that list is what we are using as our - * replacement. - */ - - if (TclListObjLength(interp, *prefixObjPtr, &prefixObjc) != TCL_OK) { - TclDecrRefCount(*prefixObjPtr); - Tcl_AddErrorInfo(interp, "\n while parsing result of " - "ensemble unknown subcommand handler"); - return TCL_ERROR; - } - if (prefixObjc > 0) { - return TCL_OK; - } - - /* - * Namespace alive & empty result => reparse. - */ - - TclDecrRefCount(*prefixObjPtr); - return TCL_CONTINUE; - } - - /* - * Oh no! An exceptional result. Convert to an error. - */ - - if (!Tcl_InterpDeleted(interp)) { - if (result != TCL_ERROR) { - Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unknown subcommand handler returned bad code: ", -1)); - switch (result) { - case TCL_RETURN: - Tcl_AppendToObj(Tcl_GetObjResult(interp), "return", -1); - break; - case TCL_BREAK: - Tcl_AppendToObj(Tcl_GetObjResult(interp), "break", -1); - break; - case TCL_CONTINUE: - Tcl_AppendToObj(Tcl_GetObjResult(interp), "continue", -1); - break; - default: - Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), "%d", result); - } - Tcl_AddErrorInfo(interp, "\n result of " - "ensemble unknown subcommand handler: "); - Tcl_AppendObjToErrorInfo(interp, unknownCmd); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_RESULT", - NULL); - } else { - Tcl_AddErrorInfo(interp, - "\n (ensemble unknown subcommand handler)"); - } - } - TclDecrRefCount(unknownCmd); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * MakeCachedEnsembleCommand -- - * - * Cache what we've computed so far; it's not nice to repeatedly copy - * strings about. Note that to do this, we start by deleting any old - * representation that there was (though if it was an out of date - * ensemble rep, we can skip some of the deallocation process.) - * - * Results: - * None - * - * Side effects: - * Alters the internal representation of the first object parameter. - * - *---------------------------------------------------------------------- - */ - -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 *)Tcl_Alloc(sizeof(EnsembleCmdRep)); - ECRSetIntRep(objPtr, ensembleCmd); - } - - /* - * Populate the internal rep. - */ - - ensembleCmd->epoch = ensemblePtr->epoch; - ensembleCmd->token = (Command *) ensemblePtr->token; - ensembleCmd->token->refCount++; - if (fix) { - Tcl_IncrRefCount(fix); - } - ensembleCmd->fix = fix; - ensembleCmd->hPtr = hPtr; -} - -/* - *---------------------------------------------------------------------- - * - * DeleteEnsembleConfig -- - * - * Destroys the data structure used to represent an ensemble. This is - * called when the ensemble's command is deleted (which happens - * automatically if the ensemble's namespace is deleted.) Maintainers - * should note that ensembles should be deleted by deleting their - * commands. - * - * Results: - * None. - * - * Side effects: - * Memory is (eventually) deallocated. - * - *---------------------------------------------------------------------- - */ - -static void -ClearTable( - EnsembleConfig *ensemblePtr) -{ - Tcl_HashTable *hash = &ensemblePtr->subcommandTable; - - if (hash->numEntries != 0) { - Tcl_HashSearch search; - Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(hash, &search); - - while (hPtr != NULL) { - Tcl_Obj *prefixObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr); - Tcl_DecrRefCount(prefixObj); - hPtr = Tcl_NextHashEntry(&search); - } - Tcl_Free(ensemblePtr->subcommandArrayPtr); - } - Tcl_DeleteHashTable(hash); -} - -static void -DeleteEnsembleConfig( - 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. - */ - - if (ensemblePtr->next != ensemblePtr) { - EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles; - - if (ensPtr == ensemblePtr) { - nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next; - } else { - while (ensPtr != NULL) { - if (ensPtr->next == ensemblePtr) { - ensPtr->next = ensemblePtr->next; - break; - } - ensPtr = ensPtr->next; - } - } - } - - /* - * Mark the namespace as dead so code that uses Tcl_Preserve() can tell - * whether disaster happened anyway. - */ - - ensemblePtr->flags |= ENSEMBLE_DEAD; - - /* - * Kill the pointer-containing fields. - */ - - ClearTable(ensemblePtr); - if (ensemblePtr->subcmdList != NULL) { - Tcl_DecrRefCount(ensemblePtr->subcmdList); - } - if (ensemblePtr->parameterList != NULL) { - Tcl_DecrRefCount(ensemblePtr->parameterList); - } - if (ensemblePtr->subcommandDict != NULL) { - Tcl_DecrRefCount(ensemblePtr->subcommandDict); - } - if (ensemblePtr->unknownHandler != NULL) { - Tcl_DecrRefCount(ensemblePtr->unknownHandler); - } - - /* - * Arrange for the structure to be reclaimed. Note that this is complex - * because we have to make sure that we can react sensibly when an - * ensemble is deleted during the process of initialising the ensemble - * (especially the unknown callback.) - */ - - Tcl_EventuallyFree(ensemblePtr, TCL_DYNAMIC); -} - -/* - *---------------------------------------------------------------------- - * - * BuildEnsembleConfig -- - * - * Create the internal data structures that describe how an ensemble - * looks, being a hash mapping from the full command name to the Tcl list - * that describes the implementation prefix words, and a sorted array of - * all the full command names to allow for reasonably efficient - * unambiguous prefix handling. - * - * Results: - * None. - * - * Side effects: - * Reallocates and rebuilds the hash table and array stored at the - * ensemblePtr argument. For large ensembles or large namespaces, this is - * a potentially expensive operation. - * - *---------------------------------------------------------------------- - */ - -static void -BuildEnsembleConfig( - EnsembleConfig *ensemblePtr) -{ - Tcl_HashSearch search; /* Used for scanning the set of commands in - * the namespace that backs up this - * ensemble. */ - size_t i, j; - int isNew; - Tcl_HashTable *hash = &ensemblePtr->subcommandTable; - Tcl_HashEntry *hPtr; - Tcl_Obj *mapDict = ensemblePtr->subcommandDict; - Tcl_Obj *subList = ensemblePtr->subcmdList; - - ClearTable(ensemblePtr); - Tcl_InitHashTable(hash, TCL_STRING_KEYS); - - if (subList) { - 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 < (size_t)subc; i += 2) { - name = TclGetString(subv[i]); - hPtr = Tcl_CreateHashEntry(hash, name, &isNew); - if (!isNew) { - cmdObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr); - Tcl_DecrRefCount(cmdObj); - } - Tcl_SetHashValue(hPtr, subv[i+1]); - Tcl_IncrRefCount(subv[i+1]); - - name = TclGetString(subv[i+1]); - hPtr = Tcl_CreateHashEntry(hash, name, &isNew); - if (isNew) { - cmdObj = Tcl_NewStringObj(name, -1); - cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); - Tcl_SetHashValue(hPtr, cmdPrefixObj); - Tcl_IncrRefCount(cmdPrefixObj); - } - } - } else { - /* - * Usual case where we can freely act on the list and dict. - */ - - for (i = 0; i < (size_t)subc; i++) { - name = TclGetString(subv[i]); - hPtr = Tcl_CreateHashEntry(hash, name, &isNew); - if (!isNew) { - continue; - } - - /* - * Lookup target in the dictionary. - */ - - if (mapDict) { - Tcl_DictObjGet(NULL, mapDict, subv[i], &target); - if (target) { - Tcl_SetHashValue(hPtr, target); - Tcl_IncrRefCount(target); - continue; - } - } - - /* - * target was not in the dictionary so map onto the namespace. - * Note in this case that we do not guarantee that the command - * is actually there; that is the programmer's responsibility - * (or [::unknown] of course). - */ - - cmdObj = Tcl_NewStringObj(name, -1); - cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); - Tcl_SetHashValue(hPtr, cmdPrefixObj); - Tcl_IncrRefCount(cmdPrefixObj); - } - } - } else if (mapDict) { - /* - * No subcmd list, but we do have a mapping dictionary so we should - * use the keys of that. Convert the dictionary's contents into the - * form required for the ensemble's internal hashtable. - */ - - 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 { - /* - * Discover what commands are actually exported by the namespace. - * What we have is an array of patterns and a hash table whose keys - * are the command names exported by the namespace (the contents do - * not matter here.) We must find out what commands are actually - * exported by filtering each command in the namespace against each of - * the patterns in the export list. Note that we use an intermediate - * hash table to make memory management easier, and because that makes - * exact matching far easier too. - * - * Suggestion for future enhancement: compute the unique prefixes and - * 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 ; insPtr->numExportPatterns ; i++) { - if (Tcl_StringMatch(nsCmdName, - ensemblePtr->nsPtr->exportArrayPtr[i])) { - hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew); - - /* - * Remember, hash entries have a full reference to the - * substituted part of the command (as a list) as their - * content! - */ - - if (isNew) { - Tcl_Obj *cmdObj, *cmdPrefixObj; - - TclNewObj(cmdObj); - Tcl_AppendStringsToObj(cmdObj, - ensemblePtr->nsPtr->fullName, - (ensemblePtr->nsPtr->parentPtr ? "::" : ""), - nsCmdName, NULL); - cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); - Tcl_SetHashValue(hPtr, cmdPrefixObj); - Tcl_IncrRefCount(cmdPrefixObj); - } - break; - } - } - } - } - - if (hash->numEntries == 0) { - ensemblePtr->subcommandArrayPtr = NULL; - return; - } - - /* - * Create a sorted array of all subcommands in the ensemble; hash tables - * are all very well for a quick look for an exact match, but they can't - * determine things like whether a string is a prefix of another (not - * without lots of preparation anyway) and they're no good for when we're - * generating the error message either. - * - * 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 **)Tcl_Alloc(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 ; - * hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search),i++) { - * ensemblePtr->subcommandArrayPtr[i] = Tcl_GetHashKey(hash, &hPtr); - * } - * - * can produce long runs of precisely ordered table entries when the - * commands in the namespace are declared in a sorted fashion (an ordering - * some people like) and the hashing functions (or the command names - * themselves) are fairly unfortunate. By filling from both ends, it - * requires active malice (and probably a debugger) to get qsort() to have - * awful runtime behaviour. - */ - - i = 0; - j = hash->numEntries; - hPtr = Tcl_FirstHashEntry(hash, &search); - while (hPtr != NULL) { - ensemblePtr->subcommandArrayPtr[i++] = (char *)Tcl_GetHashKey(hash, hPtr); - hPtr = Tcl_NextHashEntry(&search); - if (hPtr == NULL) { - break; - } - ensemblePtr->subcommandArrayPtr[--j] = (char *)Tcl_GetHashKey(hash, hPtr); - hPtr = Tcl_NextHashEntry(&search); - } - if (hash->numEntries > 1) { - qsort(ensemblePtr->subcommandArrayPtr, hash->numEntries, - sizeof(char *), NsEnsembleStringOrder); - } -} - -/* - *---------------------------------------------------------------------- - * - * NsEnsembleStringOrder -- - * - * Helper function to compare two pointers to two strings for use with - * qsort(). - * - * Results: - * -1 if the first string is smaller, 1 if the second string is smaller, - * and 0 if they are equal. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -NsEnsembleStringOrder( - const void *strPtr1, - const void *strPtr2) -{ - return strcmp(*(const char **)strPtr1, *(const char **)strPtr2); -} - -/* - *---------------------------------------------------------------------- - * - * FreeEnsembleCmdRep -- - * - * Destroys the internal representation of a Tcl_Obj that has been - * holding information about a command in an ensemble. - * - * Results: - * None. - * - * Side effects: - * Memory is deallocated. If this held the last reference to a - * namespace's main structure, that main structure will also be - * destroyed. - * - *---------------------------------------------------------------------- - */ - -static void -FreeEnsembleCmdRep( - Tcl_Obj *objPtr) -{ - EnsembleCmdRep *ensembleCmd; - - ECRGetIntRep(objPtr, ensembleCmd); - TclCleanupCommandMacro(ensembleCmd->token); - if (ensembleCmd->fix) { - Tcl_DecrRefCount(ensembleCmd->fix); - } - Tcl_Free(ensembleCmd); -} - -/* - *---------------------------------------------------------------------- - * - * DupEnsembleCmdRep -- - * - * Makes one Tcl_Obj into a copy of another that is a subcommand of an - * ensemble. - * - * Results: - * None. - * - * Side effects: - * Memory is allocated, and the namespace that the ensemble is built on - * top of gains another reference. - * - *---------------------------------------------------------------------- - */ - -static void -DupEnsembleCmdRep( - Tcl_Obj *objPtr, - Tcl_Obj *copyPtr) -{ - EnsembleCmdRep *ensembleCmd; - EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *)Tcl_Alloc(sizeof(EnsembleCmdRep)); - - ECRGetIntRep(objPtr, ensembleCmd); - ECRSetIntRep(copyPtr, ensembleCopy); - - ensembleCopy->epoch = ensembleCmd->epoch; - ensembleCopy->token = ensembleCmd->token; - ensembleCopy->token->refCount++; - ensembleCopy->fix = ensembleCmd->fix; - if (ensembleCopy->fix) { - Tcl_IncrRefCount(ensembleCopy->fix); - } - ensembleCopy->hPtr = ensembleCmd->hPtr; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileEnsemble -- - * - * Procedure called to compile an ensemble command. Note that most - * ensembles are not compiled, since modifying a compiled ensemble causes - * a invalidation of all existing bytecode (expensive!) which is not - * normally warranted. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the subcommands of the - * ensemble at runtime if a compile-time mapping is possible. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileEnsemble( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - DefineLineInformation; - Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems; - Tcl_Obj *replaced, *replacement; - Tcl_Command ensemble = (Tcl_Command) cmdPtr; - Command *oldCmdPtr = cmdPtr, *newCmdPtr; - int len, result, flags = 0, i, depth = 1, invokeAnyway = 0; - int ourResult = TCL_ERROR; - size_t numBytes; - const char *word; - - TclNewObj(replaced); - Tcl_IncrRefCount(replaced); - if (parsePtr->numWords < depth + 1) { - goto failed; - } - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - /* - * Too hard. - */ - - goto failed; - } - - /* - * This is where we return to if we are parsing multiple nested compiled - * ensembles. [info object] is such a beast. - */ - - checkNextWord: - word = tokenPtr[1].start; - numBytes = tokenPtr[1].size; - - /* - * There's a sporting chance we'll be able to compile this. But now we - * must check properly. To do that, check that we're compiling an ensemble - * that has a compilable command as its appropriate subcommand. - */ - - if (Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj) != TCL_OK - || mapObj == NULL) { - /* - * Either not an ensemble or a mapping isn't installed. Crud. Too hard - * to proceed. - */ - - goto failed; - } - - /* - * Also refuse to compile anything that uses a formal parameter list for - * now, on the grounds that it is too complex. - */ - - if (Tcl_GetEnsembleParameterList(NULL, ensemble, &listObj) != TCL_OK - || listObj != NULL) { - /* - * Figuring out how to compile this has become too much. Bail out. - */ - - goto failed; - } - - /* - * Next, get the flags. We need them on several code paths so that we can - * know whether we're to do prefix matching. - */ - - (void) Tcl_GetEnsembleFlags(NULL, ensemble, &flags); - - /* - * 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) { - size_t sclen; - const char *str; - Tcl_Obj *matchObj = NULL; - - if (Tcl_ListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) { - goto failed; - } - for (i=0 ; insPtr->flags & NS_SUPPRESS_COMPILATION - || newCmdPtr->flags & CMD_HAS_EXEC_TRACES - || ((Interp *)interp)->flags & DONT_COMPILE_CMDS_INLINE) { - /* - * Maps to an undefined command or a command without a compiler. - * Cannot compile. - */ - - goto cleanup; - } - cmdPtr = newCmdPtr; - depth++; - - /* - * See whether we have a nested ensemble. If we do, we can go round the - * mulberry bush again, consuming the next word. - */ - - if (cmdPtr->compileProc == TclCompileEnsemble) { - tokenPtr = TokenAfter(tokenPtr); - if (parsePtr->numWords < depth + 1 - || tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - /* - * Too hard because the user has done something unpleasant like - * omitting the sub-ensemble's command name or used a non-constant - * name for a sub-ensemble's command name; we respond by bailing - * out completely (this is a rare case). [Bug 6d2f249a01] - */ - - goto cleanup; - } - ensemble = (Tcl_Command) cmdPtr; - goto checkNextWord; - } - - /* - * Now that the mapping process is done we actually try to compile. - * If there is a subcommand compiler and that successfully produces code, - * we'll use that. Otherwise, we fall back to generating opcodes to do the - * invoke at runtime. - */ - - invokeAnyway = 1; - if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, depth, cmdPtr, - envPtr)) { - ourResult = TCL_OK; - goto cleanup; - } - - /* - * Throw out any line information generated by the failed compile attempt. - */ - - while (mapPtr->nuloc - 1 > eclIndex) { - mapPtr->nuloc--; - Tcl_Free(mapPtr->loc[mapPtr->nuloc].line); - mapPtr->loc[mapPtr->nuloc].line = NULL; - } - - /* - * Reset the index of next command. Toss out any from failed nested - * partial compiles. - */ - - envPtr->numCommands = mapPtr->nuloc; - - /* - * Failed to do a full compile for some reason. Try to do a direct invoke - * instead of going through the ensemble lookup process again. - */ - - failed: - if (depth < 250) { - if (depth > 1) { - if (!invokeAnyway) { - cmdPtr = oldCmdPtr; - depth--; - } - } - /* - * The length of the "replaced" list must be depth-1. Trim back - * any extra elements that might have been appended by failing - * pathways above. - */ - (void) Tcl_ListObjReplace(NULL, replaced, depth-1, LIST_MAX, 0, NULL); - - /* - * TODO: Reconsider whether we ought to call CompileToInvokedCommand() - * when depth==1. In that case we are choosing to emit the - * INST_INVOKE_REPLACE bytecode when there is in fact no replacing - * to be done. It would be equally functional and presumably more - * performant to fall through to cleanup below, return TCL_ERROR, - * and let the compiler harness emit the INST_INVOKE_STK - * implementation for us. - */ - - CompileToInvokedCommand(interp, parsePtr, replaced, cmdPtr, envPtr); - ourResult = TCL_OK; - } - - /* - * Release the memory we allocated. If we've got here, we've either done - * something useful or we're in a case that we can't compile at all and - * we're just giving up. - */ - - cleanup: - Tcl_DecrRefCount(replaced); - return ourResult; -} - -int -TclAttemptCompileProc( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - int depth, - Command *cmdPtr, - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - DefineLineInformation; - int result, i; - Tcl_Token *saveTokenPtr = parsePtr->tokenPtr; - int savedStackDepth = envPtr->currStackDepth; - unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart; - int savedAuxDataArrayNext = envPtr->auxDataArrayNext; - int savedExceptArrayNext = envPtr->exceptArrayNext; -#ifdef TCL_COMPILE_DEBUG - int savedExceptDepth = envPtr->exceptDepth; -#endif - - if (cmdPtr->compileProc == NULL) { - return TCL_ERROR; - } - - /* - * Advance parsePtr->tokenPtr so that it points at the last subcommand. - * This will be wrong but it will not matter, and it will put the - * tokens for the arguments in the right place without the need to - * allocate a synthetic Tcl_Parse struct or copy tokens around. - */ - - for (i = 0; i < depth - 1; i++) { - parsePtr->tokenPtr = TokenAfter(parsePtr->tokenPtr); - } - parsePtr->numWords -= (depth - 1); - - /* - * Shift the line information arrays to account for different word - * index values. - */ - - mapPtr->loc[eclIndex].line += (depth - 1); - mapPtr->loc[eclIndex].next += (depth - 1); - - /* - * Hand off compilation to the subcommand compiler. At last! - */ - - result = cmdPtr->compileProc(interp, parsePtr, cmdPtr, envPtr); - - /* - * Undo the shift. - */ - - mapPtr->loc[eclIndex].line -= (depth - 1); - mapPtr->loc[eclIndex].next -= (depth - 1); - - parsePtr->numWords += (depth - 1); - parsePtr->tokenPtr = saveTokenPtr; - - /* - * If our target failed to compile, revert any data from failed partial - * compiles. Note that envPtr->numCommands need not be checked because - * we avoid compiling subcommands that recursively call TclCompileScript(). - */ - -#ifdef TCL_COMPILE_DEBUG - if (envPtr->exceptDepth != savedExceptDepth) { - Tcl_Panic("ExceptionRange Starts and Ends do not balance"); - } -#endif - - if (result != TCL_OK) { - ExceptionAux *auxPtr = envPtr->exceptAuxArrayPtr; - - for (i = 0; i < savedExceptArrayNext; i++) { - while (auxPtr->numBreakTargets > 0 - && auxPtr->breakTargets[auxPtr->numBreakTargets - 1] - >= savedCodeNext) { - auxPtr->numBreakTargets--; - } - while (auxPtr->numContinueTargets > 0 - && auxPtr->continueTargets[auxPtr->numContinueTargets - 1] - >= savedCodeNext) { - auxPtr->numContinueTargets--; - } - auxPtr++; - } - envPtr->exceptArrayNext = savedExceptArrayNext; - - if (savedAuxDataArrayNext != envPtr->auxDataArrayNext) { - AuxData *auxDataPtr = envPtr->auxDataArrayPtr; - AuxData *auxDataEnd = auxDataPtr; - - auxDataPtr += savedAuxDataArrayNext; - auxDataEnd += envPtr->auxDataArrayNext; - - while (auxDataPtr < auxDataEnd) { - if (auxDataPtr->type->freeProc != NULL) { - auxDataPtr->type->freeProc(auxDataPtr->clientData); - } - auxDataPtr++; - } - envPtr->auxDataArrayNext = savedAuxDataArrayNext; - } - envPtr->currStackDepth = savedStackDepth; - envPtr->codeNext = envPtr->codeStart + savedCodeNext; -#ifdef TCL_COMPILE_DEBUG - } else { - /* - * Confirm that the command compiler generated a single value on - * the stack as its result. This is only done in debugging mode, - * as it *should* be correct and normal users have no reasonable - * 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)", (int)parsePtr->tokenPtr->size, - parsePtr->tokenPtr->start, diff); - } -#endif - } - - return result; -} - -/* - * How to compile a subcommand to a _replacing_ invoke of its implementation - * command. - */ - -static void -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; - size_t length; - - /* - * 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 = TclGetStringFromObj(words[i-1], &length); - PushLiteral(envPtr, bytes, length); - continue; - } - - SetLineInformation(i); - if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) { - int literal = TclRegisterLiteral(envPtr, - tokPtr[1].start, tokPtr[1].size, 0); - - if (envPtr->clNext) { - TclContinuationsEnterDerived( - TclFetchLiteral(envPtr, literal), - tokPtr[1].start - envPtr->source, - envPtr->clNext); - } - TclEmitPush(literal, envPtr); - } else { - CompileTokens(envPtr, tokPtr, interp); - } - } - - /* - * Push the name of the command we're actually dispatching to as part of - * the implementation. - */ - - TclNewObj(objPtr); - Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); - bytes = TclGetStringFromObj(objPtr, &length); - if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) { - extraLiteralFlags |= LITERAL_UNSHARED; - } - cmdLit = TclRegisterLiteral(envPtr, bytes, length, extraLiteralFlags); - TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr); - TclEmitPush(cmdLit, envPtr); - TclDecrRefCount(objPtr); - - /* - * Do the replacing dispatch. - */ - - TclEmitInvoke(envPtr, INST_INVOKE_REPLACE, parsePtr->numWords,numWords+1); -} - -/* - * Helpers that do issuing of instructions for commands that "don't have - * compilers" (well, they do; these). They all work by just generating base - * code to invoke the command; they're intended for ensemble subcommands so - * that the costs of INST_INVOKE_REPLACE can be avoided where we can work out - * that they're not needed. - * - * Note that these are NOT suitable for commands where there's an argument - * that is a script, as an [info level] or [info frame] in the inner context - * can see the difference. - */ - -static int -CompileBasicNArgCommand( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Obj *objPtr; - - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); - TclCompileInvocation(interp, parsePtr->tokenPtr, objPtr, - parsePtr->numWords, envPtr); - Tcl_DecrRefCount(objPtr); - return TCL_OK; -} - -int -TclCompileBasic0ArgCmd( - 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. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords != 1) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasic1ArgCmd( - 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. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasic2ArgCmd( - 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. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasic3ArgCmd( - 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. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords != 4) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasic0Or1ArgCmd( - 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. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords != 1 && parsePtr->numWords != 2) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasic1Or2ArgCmd( - 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. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasic2Or3ArgCmd( - 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. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords != 3 && parsePtr->numWords != 4) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasic0To2ArgCmd( - 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. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords < 1 || parsePtr->numWords > 3) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasic1To3ArgCmd( - 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. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords < 2 || parsePtr->numWords > 4) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasicMin0ArgCmd( - 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. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords < 1) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasicMin1ArgCmd( - 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. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords < 2) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasicMin2ArgCmd( - 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. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords < 3) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ Index: generic/tclEnv.c ================================================================== --- generic/tclEnv.c +++ generic/tclEnv.c @@ -15,48 +15,27 @@ #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 { - size_t cacheSize; /* Number of env strings in cache. */ + 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 + char **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. */ - size_t ourEnvironSize; /* Non-zero means that the environ array was + 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, @@ -90,133 +69,59 @@ void TclSetupEnv( Tcl_Interp *interp) /* Interpreter whose "env" array is to be * managed. */ { - Var *varPtr, *arrayPtr; - Tcl_Obj *varNamePtr; Tcl_DString envString; - Tcl_HashTable namesHash; - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; + char *p1, *p2; + int i; /* * Synchronize the values in the environ array with the contents of the * Tcl "env" variable. To do this: - * 1) Remove the trace that fires when the "env" var is updated. - * 2) Find the existing contents of the "env", storing in a hash table. - * 3) Create/update elements for each environ variable, removing - * elements from the hash table as we go. - * 4) Remove the elements for each remaining entry in the hash table, - * which must have existed before yet have no analog in the environ - * variable. - * 5) Add a trace that synchronizes the "env" array. + * 1) Remove the trace that fires when the "env" var is unset. + * 2) Unset the "env" variable. + * 3) If there are no environ variables, create an empty "env" array. + * Otherwise populate the array with current values. + * 4) Add a trace that synchronizes the "env" array. */ Tcl_UntraceVar2(interp, "env", NULL, TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, NULL); - /* - * Find out what elements are currently in the global env array. - */ - - 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_UnsetVar2(interp, "env", NULL, TCL_GLOBAL_ONLY); + + if (environ[0] == NULL) { + Tcl_Obj *varNamePtr; + + TclNewLiteralStringObj(varNamePtr, "env"); + Tcl_IncrRefCount(varNamePtr); + TclArraySet(interp, varNamePtr, NULL); + Tcl_DecrRefCount(varNamePtr); + } else { 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, '='); + for (i = 0; environ[i] != NULL; i++) { + p1 = Tcl_ExternalToUtfDString(NULL, environ[i], -1, &envString); + p2 = 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. */ - Tcl_DStringFree(&envString); continue; } p2++; p2[-1] = '\0'; -#if defined(_WIN32) - /* - * Enforce PATH and COMSPEC to be all uppercase. This eliminates - * additional trace logic otherwise required in init.tcl. - */ - - if (strcasecmp(p1, "PATH") == 0) { - p1 = "PATH"; - } else if (strcasecmp(p1, "COMSPEC") == 0) { - p1 = "COMSPEC"; - } -#endif - obj1 = Tcl_NewStringObj(p1, -1); - obj2 = Tcl_NewStringObj(p2, -1); + Tcl_SetVar2(interp, "env", p1, p2, TCL_GLOBAL_ONLY); Tcl_DStringFree(&envString); - - Tcl_IncrRefCount(obj1); - Tcl_IncrRefCount(obj2); - Tcl_ObjSetVar2(interp, varNamePtr, obj1, obj2, TCL_GLOBAL_ONLY); - hPtr = Tcl_FindHashEntry(&namesHash, obj1); - if (hPtr != NULL) { - Tcl_DeleteHashEntry(hPtr); - } - Tcl_DecrRefCount(obj1); - Tcl_DecrRefCount(obj2); } Tcl_MutexUnlock(&envMutex); } - /* - * 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); - - /* - * Re-establish the trace. - */ - Tcl_TraceVar2(interp, "env", NULL, TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, NULL); } @@ -246,14 +151,13 @@ 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; - size_t nameLength, valueLength; - size_t index, length; + int index, length, nameLength; char *p, *oldValue; - const techar *p2; + const char *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. @@ -260,75 +164,75 @@ */ Tcl_MutexLock(&envMutex); index = TclpFindVariable(name, &length); - if (index == TCL_INDEX_NONE) { + 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 **)Tcl_Alloc((length + 5) * sizeof(techar *)); + if ((env.ourEnviron != environ) || (length+2 > env.ourEnvironSize)) { + char **newEnviron = (char **) + ckalloc(((unsigned) length + 5) * sizeof(char *)); - memcpy(newEnviron, tenviron, length * sizeof(techar *)); + memcpy(newEnviron, environ, length * sizeof(char *)); if ((env.ourEnvironSize != 0) && (env.ourEnviron != NULL)) { - Tcl_Free(env.ourEnviron); + ckfree((char *) env.ourEnviron); } - tenviron = (env.ourEnviron = newEnviron); + environ = env.ourEnviron = newEnviron; env.ourEnvironSize = length + 5; } index = length; - tenviron[index + 1] = NULL; + environ[index + 1] = NULL; #endif /* USE_PUTENV */ oldValue = NULL; nameLength = strlen(name); } else { - const char *oldEnv; + const char *env; /* * 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) { + env = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envString); + if (strcmp(value, env + (length + 1)) == 0) { Tcl_DStringFree(&envString); Tcl_MutexUnlock(&envMutex); return; } Tcl_DStringFree(&envString); - oldValue = (char *)tenviron[index]; + oldValue = environ[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 *)Tcl_Alloc(nameLength + valueLength + 2); - memcpy(p, name, nameLength); + p = ckalloc((unsigned) nameLength + strlen(value) + 2); + strcpy(p, name); p[nameLength] = '='; - memcpy(p+nameLength+1, value, valueLength+1); - p2 = utf2tenvirondstr(p, -1, &envString); + strcpy(p+nameLength+1, value); + p2 = Tcl_UtfToExternalDString(NULL, p, -1, &envString); /* * Copy the native string to heap memory. */ - p = (char *)Tcl_Realloc(p, Tcl_DStringLength(&envString) + tNTL); - memcpy(p, p2, Tcl_DStringLength(&envString) + tNTL); + p = ckrealloc(p, strlen(p2) + 1); + strcpy(p, p2); Tcl_DStringFree(&envString); #ifdef USE_PUTENV /* * Update the system environment. @@ -335,28 +239,28 @@ */ putenv(p); index = TclpFindVariable(name, &length); #else - tenviron[index] = (techar *)p; + environ[index] = 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 != TCL_INDEX_NONE) && (tenviron[index] == (techar *)p)) { + if ((index != -1) && (environ[index] == p)) { ReplaceString(oldValue, p); #ifdef HAVE_PUTENV_THAT_COPIES } else { /* * This putenv() copies instead of taking ownership. */ - Tcl_Free(p); + ckfree(p); #endif /* HAVE_PUTENV_THAT_COPIES */ } Tcl_MutexUnlock(&envMutex); @@ -409,11 +313,11 @@ * 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, '='); + value = strchr(name, '='); if ((value != NULL) && (value != name)) { value[0] = '\0'; TclSetEnv(name, value+1); } @@ -444,11 +348,12 @@ void TclUnsetEnv( const char *name) /* Name of variable to remove (UTF-8). */ { char *oldValue; - size_t length, index; + int length; + int index; #ifdef USE_PUTENV_FOR_UNSET Tcl_DString envString; char *string; #else char **envPtr; @@ -460,20 +365,20 @@ /* * First make sure that the environment variable exists to avoid doing * needless work and to avoid recursion on the unset. */ - if (index == TCL_INDEX_NONE) { + 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]; + oldValue = environ[index]; /* * Update the system environment. This must be done before we update the * interpreters or we will recurse. */ @@ -482,25 +387,24 @@ /* * For those platforms that support putenv to unset, Linux indicates * that no = should be included, and Windows requires it. */ -#if defined(_WIN32) - string = (char *)Tcl_Alloc(length + 2); - memcpy(string, name, length); +#if defined(__WIN32__) + string = ckalloc((unsigned) length+2); + memcpy(string, name, (size_t) length); string[length] = '='; string[length+1] = '\0'; #else - string = (char *)Tcl_Alloc(length + 1); - memcpy(string, name, length); + string = ckalloc((unsigned) length+1); + memcpy(string, name, (size_t) length); string[length] = '\0'; -#endif /* _WIN32 */ +#endif /* WIN32 */ - utf2tenvirondstr(string, -1, &envString); - string = (char *)Tcl_Realloc(string, Tcl_DStringLength(&envString) + tNTL); - memcpy(string, Tcl_DStringValue(&envString), - Tcl_DStringLength(&envString) + tNTL); + Tcl_UtfToExternalDString(NULL, string, -1, &envString); + string = ckrealloc(string, (unsigned) Tcl_DStringLength(&envString)+1); + strcpy(string, Tcl_DStringValue(&envString)); Tcl_DStringFree(&envString); putenv(string); /* @@ -507,23 +411,23 @@ * 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) { + if (environ[index] == string) { ReplaceString(oldValue, string); #ifdef HAVE_PUTENV_THAT_COPIES } else { /* * This putenv() copies instead of taking ownership. */ - Tcl_Free(string); + ckfree(string); #endif /* HAVE_PUTENV_THAT_COPIES */ } #else /* !USE_PUTENV_FOR_UNSET */ - for (envPtr = (char **)(tenviron+index+1); ; envPtr++) { + for (envPtr = environ+index+1; ; envPtr++) { envPtr[-1] = *envPtr; if (*envPtr == NULL) { break; } } @@ -559,20 +463,20 @@ * (UTF-8). */ Tcl_DString *valuePtr) /* Uninitialized or free DString in which the * value of the environment variable is * stored. */ { - size_t length, index; + int length, index; const char *result; Tcl_MutexLock(&envMutex); index = TclpFindVariable(name, &length); result = NULL; - if (index != TCL_INDEX_NONE) { + if (index != -1) { Tcl_DString envStr; - result = tenviron2utfdstr(tenviron[index], -1, &envStr); + result = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envStr); result += length; if (*result == '=') { result++; Tcl_DStringInit(valuePtr); Tcl_DStringAppend(valuePtr, result, -1); @@ -594,24 +498,24 @@ * This function is invoked whenever an environment variable is read, * modified or deleted. It propagates the change to the global "environ" * array. * * Results: - * Returns NULL to indicate success, or an error-message if the array - * element being handled doesn't exist. + * Always returns NULL to indicate success. * * Side effects: * 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). * *---------------------------------------------------------------------- */ + /* ARGSUSED */ static char * EnvTraceProc( - TCL_UNUSED(ClientData), + ClientData clientData, /* Not used. */ 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). */ @@ -652,11 +556,11 @@ if (flags & TCL_TRACE_READS) { Tcl_DString valueString; const char *value = TclGetEnv(name2, &valueString); if (value == NULL) { - return (char *) "no such variable"; + return "no such variable"; } Tcl_SetVar2(interp, name1, name2, value, 0); Tcl_DStringFree(&valueString); } @@ -691,11 +595,11 @@ static void ReplaceString( const char *oldStr, /* Old environment string. */ char *newStr) /* New environment string. */ { - size_t i; + 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 @@ -711,11 +615,11 @@ /* * Replace or delete the old value. */ if (env.cache[i]) { - Tcl_Free(env.cache[i]); + ckfree(env.cache[i]); } if (newStr) { env.cache[i] = newStr; } else { @@ -729,15 +633,15 @@ * We need to grow the cache in order to hold the new string. */ const int growth = 5; - env.cache = (char **)Tcl_Realloc(env.cache, + env.cache = (char **) ckrealloc((char *) env.cache, (env.cacheSize + growth) * sizeof(char *)); env.cache[env.cacheSize] = newStr; - (void) memset(env.cache+env.cacheSize+1, 0, - (growth-1) * sizeof(char *)); + (void) memset(env.cache+env.cacheSize+1, (int) 0, + (size_t) (growth-1) * sizeof(char*)); env.cacheSize += growth; } } /* @@ -764,29 +668,18 @@ /* * For now we just deallocate the cache array and none of the environment * strings. This may leak more memory that strictly necessary, since some * of the strings may no longer be in the environment. However, * determining which ones are ok to delete is n-squared, and is pretty - * unlikely, so we don't bother. However, in the case of DPURIFY, just - * free all strings in the cache. + * unlikely, so we don't bother. */ if (env.cache) { -#ifdef PURIFY - size_t i; - for (i = 0; i < env.cacheSize; i++) { - Tcl_Free(env.cache[i]); - } -#endif - Tcl_Free(env.cache); + ckfree((char *) env.cache); env.cache = NULL; env.cacheSize = 0; #ifndef USE_PUTENV - if ((env.ourEnviron != NULL)) { - Tcl_Free(env.ourEnviron); - env.ourEnviron = NULL; - } env.ourEnvironSize = 0; #endif } } Index: generic/tclEvent.c ================================================================== --- generic/tclEvent.c +++ generic/tclEvent.c @@ -35,11 +35,11 @@ * One of the structures below is associated with the "tclBgError" assoc data * for each interpreter. It keeps track of the head and tail of the list of * pending background errors for the interpreter. */ -typedef struct { +typedef struct ErrAssocData { Tcl_Interp *interp; /* Interpreter in which error occurred. */ Tcl_Obj *cmdPrefix; /* First word(s) of the handler command */ BgError *firstBgPtr; /* First in list of all background errors * waiting to be processed for this * interpreter (NULL if none). */ @@ -47,17 +47,17 @@ * waiting to be processed for this * interpreter (NULL if none). */ } ErrAssocData; /* - * For each exit handler created with a call to Tcl_Create(Late)ExitHandler - * there is a structure of the following type: + * 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. */ + ClientData 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; /* @@ -72,26 +72,26 @@ /* First in list of all late exit handlers for * application. */ TCL_DECLARE_MUTEX(exitMutex) /* - * This variable is set to 1 when Tcl_Exit is called. The variable is checked - * by TclInExit() to allow different behavior for exit-time processing, e.g., - * in closing of files and pipes. + * This variable is set to 1 when Tcl_Finalize is called, and at the end of + * its work, it is reset to 0. The variable is checked by TclInExit() to allow + * different behavior for exit-time processing, e.g. in closing of files and + * pipes. */ -static int inExit = 0; - +static int inFinalize = 0; static int subsystemsInitialized = 0; /* - * This variable contains the application wide exit handler. It will be called - * by Tcl_Exit instead of the C-runtime exit if this variable is set to a - * non-NULL value. + * This variable contains the application wide exit handler. It will be + * called by Tcl_Exit instead of the C-runtime exit if this variable is set + * to a non-NULL value. */ -static TCL_NORETURN1 Tcl_ExitProc *appExitPtr = NULL; +static Tcl_ExitProc *appExitPtr = NULL; typedef struct ThreadSpecificData { ExitHandler *firstExitPtr; /* First in list of all exit handlers for this * thread. */ int inExit; /* True when this thread is exiting. This is @@ -98,35 +98,32 @@ * used as a hack to decide to close the * standard channels. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; -#if TCL_THREADS +#ifdef TCL_THREADS typedef struct { Tcl_ThreadCreateProc *proc; /* Main() function of the thread */ - void *clientData; /* The one argument to Main() */ + ClientData clientData; /* The one argument to Main() */ } ThreadClientData; -static Tcl_ThreadCreateType NewThreadProc(void *clientData); +static Tcl_ThreadCreateType NewThreadProc(ClientData clientData); #endif /* TCL_THREADS */ /* * Prototypes for functions referenced only in this file: */ -static void BgErrorDeleteProc(void *clientData, +static void BgErrorDeleteProc(ClientData 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); +static void HandleBgErrors(ClientData clientData); +static char * VwaitVarProc(ClientData clientData, Tcl_Interp *interp, + CONST char *name1, CONST char *name2, int flags); /* *---------------------------------------------------------------------- * - * Tcl_BackgroundException -- + * 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: @@ -138,11 +135,18 @@ * *---------------------------------------------------------------------- */ void -Tcl_BackgroundException( +Tcl_BackgroundError( + Tcl_Interp *interp) /* Interpreter in which an error has + * occurred. */ +{ + TclBackgroundException(interp, TCL_ERROR); +} +void +TclBackgroundException( Tcl_Interp *interp, /* Interpreter in which an exception has * occurred. */ int code) /* The exception code value */ { BgError *errPtr; @@ -150,22 +154,22 @@ if (code == TCL_OK) { return; } - errPtr = (BgError*)Tcl_Alloc(sizeof(BgError)); + 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); + assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError", NULL); if (assocPtr->firstBgPtr == NULL) { assocPtr->firstBgPtr = errPtr; - Tcl_DoWhenIdle(HandleBgErrors, assocPtr); + Tcl_DoWhenIdle(HandleBgErrors, (ClientData) assocPtr); } else { assocPtr->lastBgPtr->nextPtr = errPtr; } assocPtr->lastBgPtr = errPtr; Tcl_ResetResult(interp); @@ -188,13 +192,13 @@ *---------------------------------------------------------------------- */ static void HandleBgErrors( - void *clientData) /* Pointer to ErrAssocData structure. */ + ClientData clientData) /* Pointer to ErrAssocData structure. */ { - ErrAssocData *assocPtr = (ErrAssocData *)clientData; + ErrAssocData *assocPtr = (ErrAssocData *) clientData; Tcl_Interp *interp = assocPtr->interp; BgError *errPtr; /* * Not bothering to save/restore the interp state. Assume that any code @@ -201,27 +205,27 @@ * that has interp state it needs to keep will make its own * Tcl_SaveInterpState call before calling something like Tcl_DoOneEvent() * that could lead us here. */ - Tcl_Preserve(assocPtr); - Tcl_Preserve(interp); + Tcl_Preserve((ClientData) assocPtr); + Tcl_Preserve((ClientData) interp); while (assocPtr->firstBgPtr != NULL) { int code, prefixObjc; Tcl_Obj **prefixObjv, **tempObjv; /* - * Note we copy the handler command prefix each pass through, so we do - * support one handler setting another handler. + * Note we copy the handler command prefix each pass through, so + * we do support one handler setting another handler. */ Tcl_Obj *copyObj = TclListObjCopy(NULL, assocPtr->cmdPrefix); errPtr = assocPtr->firstBgPtr; Tcl_ListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv); - tempObjv = (Tcl_Obj**)Tcl_Alloc((prefixObjc+2) * sizeof(Tcl_Obj *)); + 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); @@ -232,12 +236,12 @@ Tcl_DecrRefCount(copyObj); Tcl_DecrRefCount(errPtr->errorMsg); Tcl_DecrRefCount(errPtr->returnOpts); assocPtr->firstBgPtr = errPtr->nextPtr; - Tcl_Free(errPtr); - Tcl_Free(tempObjv); + ckfree((char *) errPtr); + ckfree((char *) tempObjv); if (code == TCL_BREAK) { /* * Break means cancel any remaining error reports for this * interpreter. @@ -246,16 +250,16 @@ while (assocPtr->firstBgPtr != NULL) { errPtr = assocPtr->firstBgPtr; assocPtr->firstBgPtr = errPtr->nextPtr; Tcl_DecrRefCount(errPtr->errorMsg); Tcl_DecrRefCount(errPtr->returnOpts); - Tcl_Free(errPtr); + ckfree((char *) errPtr); } } else if ((code == TCL_ERROR) && !Tcl_IsSafe(interp)) { Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR); - if (errChannel != NULL) { + if (errChannel != (Tcl_Channel) NULL) { Tcl_Obj *options = Tcl_GetReturnOptions(interp, code); Tcl_Obj *keyPtr, *valuePtr = NULL; TclNewLiteralStringObj(keyPtr, "-errorinfo"); Tcl_IncrRefCount(keyPtr); @@ -274,12 +278,12 @@ Tcl_DecrRefCount(options); } } } assocPtr->lastBgPtr = NULL; - Tcl_Release(interp); - Tcl_Release(assocPtr); + Tcl_Release((ClientData) interp); + Tcl_Release((ClientData) assocPtr); } /* *---------------------------------------------------------------------- * @@ -298,14 +302,14 @@ *---------------------------------------------------------------------- */ int TclDefaultBgErrorHandlerObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { Tcl_Obj *keyPtr, *valuePtr; Tcl_Obj *tempObjv[2]; int result, code, level; Tcl_InterpState saved; @@ -324,11 +328,10 @@ result = Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); Tcl_DecrRefCount(keyPtr); if (result != TCL_OK || valuePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing return option \"-level\"", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, valuePtr, &level) == TCL_ERROR) { return TCL_ERROR; } @@ -337,38 +340,30 @@ result = Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); Tcl_DecrRefCount(keyPtr); if (result != TCL_OK || valuePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing return option \"-code\"", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, valuePtr, &code) == TCL_ERROR) { return TCL_ERROR; } if (level != 0) { - /* - * We're handling a TCL_RETURN exception. - */ - + /* We're handling a TCL_RETURN exception */ code = TCL_RETURN; } if (code == TCL_OK) { /* - * Somehow we got to exception handling with no exception. (Pass - * TCL_OK to Tcl_BackgroundException()?) Just return without doing - * anything. + * Somehow we got to exception handling with no exception. + * (Pass TCL_OK to TclBackgroundException()?) + * Just return without doing anything. */ - return TCL_OK; } - /* - * Construct the bgerror command. - */ - + /* Construct the bgerror command */ TclNewLiteralStringObj(tempObjv[0], "bgerror"); Tcl_IncrRefCount(tempObjv[0]); /* * Determine error message argument. Check the return options in case @@ -422,14 +417,11 @@ * attempts are needed. */ saved = Tcl_SaveInterpState(interp, code); - /* - * Invoke the bgerror command. - */ - + /* Invoke the bgerror command. */ Tcl_AllowExceptions(interp); code = Tcl_EvalObjv(interp, 2, tempObjv, TCL_EVAL_GLOBAL); if (code == TCL_ERROR) { /* * If the interpreter is safe, we look for a hidden command named @@ -444,12 +436,11 @@ if (Tcl_IsSafe(interp)) { Tcl_RestoreInterpState(interp, saved); TclObjInvoke(interp, 2, tempObjv, TCL_INVOKE_HIDDEN); } else { Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR); - - if (errChannel != NULL) { + if (errChannel != (Tcl_Channel) NULL) { Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(resultPtr); if (Tcl_FindCommand(interp, "bgerror", NULL, TCL_GLOBAL_ONLY) == NULL) { @@ -505,26 +496,28 @@ void TclSetBgErrorHandler( Tcl_Interp *interp, Tcl_Obj *cmdPrefix) { - ErrAssocData *assocPtr = (ErrAssocData *)Tcl_GetAssocData(interp, "tclBgError", NULL); + 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*)Tcl_Alloc(sizeof(ErrAssocData)); + assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData)); assocPtr->interp = interp; assocPtr->cmdPrefix = NULL; assocPtr->firstBgPtr = NULL; assocPtr->lastBgPtr = NULL; - Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc, assocPtr); + Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc, + (ClientData) assocPtr); } if (assocPtr->cmdPrefix) { Tcl_DecrRefCount(assocPtr->cmdPrefix); } assocPtr->cmdPrefix = cmdPrefix; @@ -550,18 +543,20 @@ Tcl_Obj * TclGetBgErrorHandler( Tcl_Interp *interp) { - ErrAssocData *assocPtr = (ErrAssocData *)Tcl_GetAssocData(interp, "tclBgError", NULL); + 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); + assocPtr = (ErrAssocData *) + Tcl_GetAssocData(interp, "tclBgError", NULL); } return assocPtr->cmdPrefix; } /* @@ -576,33 +571,33 @@ * Results: * None. * * Side effects: * Background error information is freed: if there were any pending error - * reports, they are canceled. + * reports, they are cancelled. * *---------------------------------------------------------------------- */ static void BgErrorDeleteProc( - void *clientData, /* Pointer to ErrAssocData structure. */ - TCL_UNUSED(Tcl_Interp *)) + ClientData clientData, /* Pointer to ErrAssocData structure. */ + Tcl_Interp *interp) /* Interpreter being deleted. */ { - ErrAssocData *assocPtr = (ErrAssocData *)clientData; + 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); - Tcl_Free(errPtr); + ckfree((char *) errPtr); } - Tcl_CancelIdleCall(HandleBgErrors, assocPtr); + Tcl_CancelIdleCall(HandleBgErrors, (ClientData) assocPtr); Tcl_DecrRefCount(assocPtr->cmdPrefix); - Tcl_EventuallyFree(assocPtr, TCL_DYNAMIC); + Tcl_EventuallyFree((ClientData) assocPtr, TCL_DYNAMIC); } /* *---------------------------------------------------------------------- * @@ -622,14 +617,15 @@ */ void Tcl_CreateExitHandler( Tcl_ExitProc *proc, /* Function to invoke. */ - void *clientData) /* Arbitrary value to pass to proc. */ + ClientData clientData) /* Arbitrary value to pass to proc. */ { - ExitHandler *exitPtr = (ExitHandler*)Tcl_Alloc(sizeof(ExitHandler)); + ExitHandler *exitPtr; + exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler)); exitPtr->proc = proc; exitPtr->clientData = clientData; Tcl_MutexLock(&exitMutex); exitPtr->nextPtr = firstExitPtr; firstExitPtr = exitPtr; @@ -639,12 +635,11 @@ /* *---------------------------------------------------------------------- * * TclCreateLateExitHandler -- * - * Arrange for a given function to be invoked after all pre-thread - * cleanups. + * Arrange for a given function to be invoked after all pre-thread cleanups * * Results: * None. * * Side effects: @@ -655,14 +650,15 @@ */ void TclCreateLateExitHandler( Tcl_ExitProc *proc, /* Function to invoke. */ - void *clientData) /* Arbitrary value to pass to proc. */ + ClientData clientData) /* Arbitrary value to pass to proc. */ { - ExitHandler *exitPtr = (ExitHandler*)Tcl_Alloc(sizeof(ExitHandler)); + ExitHandler *exitPtr; + exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler)); exitPtr->proc = proc; exitPtr->clientData = clientData; Tcl_MutexLock(&exitMutex); exitPtr->nextPtr = firstLateExitPtr; firstLateExitPtr = exitPtr; @@ -680,19 +676,19 @@ * Results: * None. * * Side effects: * If there is an exit handler corresponding to proc and clientData then - * it is canceled; if no such handler exists then nothing happens. + * it is cancelled; if no such handler exists then nothing happens. * *---------------------------------------------------------------------- */ void Tcl_DeleteExitHandler( Tcl_ExitProc *proc, /* Function that was previously registered. */ - void *clientData) /* Arbitrary value to pass to proc. */ + ClientData clientData) /* Arbitrary value to pass to proc. */ { ExitHandler *exitPtr, *prevPtr; Tcl_MutexLock(&exitMutex); for (prevPtr = NULL, exitPtr = firstExitPtr; exitPtr != NULL; @@ -702,11 +698,11 @@ if (prevPtr == NULL) { firstExitPtr = exitPtr->nextPtr; } else { prevPtr->nextPtr = exitPtr->nextPtr; } - Tcl_Free(exitPtr); + ckfree((char *) exitPtr); break; } } Tcl_MutexUnlock(&exitMutex); return; @@ -722,20 +718,20 @@ * * Results: * None. * * Side effects: - * If there is a late exit handler corresponding to proc and clientData - * then it is canceled; if no such handler exists then nothing happens. + * If there is a late exit handler corresponding to proc and clientData then + * it is canceled; if no such handler exists then nothing happens. * *---------------------------------------------------------------------- */ void TclDeleteLateExitHandler( Tcl_ExitProc *proc, /* Function that was previously registered. */ - void *clientData) /* Arbitrary value to pass to proc. */ + ClientData clientData) /* Arbitrary value to pass to proc. */ { ExitHandler *exitPtr, *prevPtr; Tcl_MutexLock(&exitMutex); for (prevPtr = NULL, exitPtr = firstLateExitPtr; exitPtr != NULL; @@ -745,11 +741,11 @@ if (prevPtr == NULL) { firstLateExitPtr = exitPtr->nextPtr; } else { prevPtr->nextPtr = exitPtr->nextPtr; } - Tcl_Free(exitPtr); + ckfree((char *) exitPtr); break; } } Tcl_MutexUnlock(&exitMutex); return; @@ -774,16 +770,16 @@ */ void Tcl_CreateThreadExitHandler( Tcl_ExitProc *proc, /* Function to invoke. */ - void *clientData) /* Arbitrary value to pass to proc. */ + ClientData clientData) /* Arbitrary value to pass to proc. */ { ExitHandler *exitPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - exitPtr = (ExitHandler*)Tcl_Alloc(sizeof(ExitHandler)); + exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler)); exitPtr->proc = proc; exitPtr->clientData = clientData; exitPtr->nextPtr = tsdPtr->firstExitPtr; tsdPtr->firstExitPtr = exitPtr; } @@ -799,19 +795,19 @@ * Results: * None. * * Side effects: * If there is an exit handler corresponding to proc and clientData then - * it is canceled; if no such handler exists then nothing happens. + * it is cancelled; if no such handler exists then nothing happens. * *---------------------------------------------------------------------- */ void Tcl_DeleteThreadExitHandler( Tcl_ExitProc *proc, /* Function that was previously registered. */ - void *clientData) /* Arbitrary value to pass to proc. */ + ClientData clientData) /* Arbitrary value to pass to proc. */ { ExitHandler *exitPtr, *prevPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); for (prevPtr = NULL, exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL; @@ -821,11 +817,11 @@ if (prevPtr == NULL) { tsdPtr->firstExitPtr = exitPtr->nextPtr; } else { prevPtr->nextPtr = exitPtr->nextPtr; } - Tcl_Free(exitPtr); + ckfree((char *) exitPtr); return; } } } @@ -847,11 +843,11 @@ *---------------------------------------------------------------------- */ Tcl_ExitProc * Tcl_SetExitProc( - TCL_NORETURN1 Tcl_ExitProc *proc) /* New exit handler for app or NULL */ + Tcl_ExitProc *proc) /* New exit handler for app or NULL */ { Tcl_ExitProc *prevExitProc; /* * Swap the old exit proc for the new one, saving the old one for our @@ -863,53 +859,10 @@ appExitPtr = proc; Tcl_MutexUnlock(&exitMutex); return prevExitProc; } - - -/* - *---------------------------------------------------------------------- - * - * InvokeExitHandlers -- - * - * Call the registered exit handlers. - * - * Results: - * None. - * - * Side effects: - * The exit handlers are invoked, and the ExitHandler struct is - * freed. - * - *---------------------------------------------------------------------- - */ -static void -InvokeExitHandlers(void) -{ - ExitHandler *exitPtr; - - Tcl_MutexLock(&exitMutex); - inExit = 1; - - for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = 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_DeleteExitHandler on itself. - */ - - firstExitPtr = exitPtr->nextPtr; - Tcl_MutexUnlock(&exitMutex); - exitPtr->proc(exitPtr->clientData); - Tcl_Free(exitPtr); - Tcl_MutexLock(&exitMutex); - } - firstExitPtr = NULL; - Tcl_MutexUnlock(&exitMutex); -} - /* *---------------------------------------------------------------------- * * Tcl_Exit -- @@ -923,77 +876,45 @@ * All existing exit handlers are invoked, then the application ends. * *---------------------------------------------------------------------- */ -TCL_NORETURN void +void Tcl_Exit( int status) /* Exit status for application; typically 0 * for normal return, 1 for error return. */ { - TCL_NORETURN1 Tcl_ExitProc *currentAppExitPtr; + Tcl_ExitProc *currentAppExitPtr; Tcl_MutexLock(&exitMutex); currentAppExitPtr = appExitPtr; Tcl_MutexUnlock(&exitMutex); - /* - * Warning: this function SHOULD NOT return, as there is code that depends - * on Tcl_Exit never returning. In fact, we will Tcl_Panic if anyone - * returns, so critical is this dependcy. - * - * If subsystems are not (yet) initialized, proper Tcl-finalization is - * impossible, so fallback to system exit, see bug-[f8a33ce3db5d8cc2]. - */ - if (currentAppExitPtr) { - - currentAppExitPtr(INT2PTR(status)); - - } else if (subsystemsInitialized) { - - if (TclFullFinalizationRequested()) { - - /* - * Thorough finalization for Valgrind et al. - */ - - Tcl_Finalize(); - - } else { - - /* - * Fast and deterministic exit (default behavior) - */ - - InvokeExitHandlers(); - - /* - * Ensure the thread-specific data is initialised as it is used in - * Tcl_FinalizeThread() - */ - - (void) TCL_TSD_INIT(&dataKey); - - /* - * Now finalize the calling thread only (others are not safely - * reachable). Among other things, this triggers a flush of the - * Tcl_Channels that may have data enqueued. - */ - - FinalizeThread(/* quick */ 1); - } - } - - TclpExit(status); - Tcl_Panic("OS exit failed!"); + /* + * Warning: this code SHOULD NOT return, as there is code that depends + * on Tcl_Exit never returning. In fact, we will Tcl_Panic if anyone + * returns, so critical is this dependcy. + */ + + currentAppExitPtr((ClientData) INT2PTR(status)); + Tcl_Panic("AppExitProc returned unexpectedly"); + } else { + /* + * Use default handling. + */ + + Tcl_Finalize(); + TclpExit(status); + Tcl_Panic("OS exit failed!"); + } } /* *------------------------------------------------------------------------- * - * Tcl_InitSubsystems -- + * TclInitSubsystems -- * * 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: * @@ -1012,14 +933,14 @@ * *------------------------------------------------------------------------- */ void -Tcl_InitSubsystems(void) +TclInitSubsystems(void) { - if (inExit != 0) { - Tcl_Panic("Tcl_InitSubsystems called while exiting"); + if (inFinalize != 0) { + Tcl_Panic("TclInitSubsystems called while finalizing"); } if (subsystemsInitialized == 0) { /* * Double check inside the mutex. There are definitly calls back into @@ -1033,18 +954,15 @@ * Initialize locks used by the memory allocators before anything * interesting happens so we can use the allocators in the * implementation of self-initializing locks. */ - TclInitThreadStorage(); /* Creates hash table for + TclInitThreadStorage(); /* Creates master hash table for * thread local storage */ -#if defined(USE_TCLALLOC) && USE_TCLALLOC +#if USE_TCLALLOC TclInitAlloc(); /* Process wide mutex init */ #endif -#if TCL_THREADS && defined(USE_THREAD_ALLOC) - TclInitThreadAlloc(); /* Setup thread allocator caches */ -#endif #ifdef TCL_MEM_DEBUG TclInitDbCkalloc(); /* Process wide mutex init */ #endif TclpInitPlatform(); /* Creates signal handler(s) */ @@ -1052,10 +970,11 @@ * converting to/from double. */ TclInitObjSubsystem(); /* Register obj types, create * mutexes. */ TclInitIOSubsystem(); /* Inits a tsd key (noop). */ TclInitEncodingSubsystem(); /* Process wide encoding init. */ + TclpSetInterfaces(); TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */ subsystemsInitialized = 1; } TclpInitUnlock(); } @@ -1066,12 +985,12 @@ *---------------------------------------------------------------------- * * Tcl_Finalize -- * * Shut down Tcl. First calls registered exit handlers, then carefully - * shuts down various subsystems. Should be invoked by user before the - * Tcl shared library is being unloaded in an embedded context. + * shuts down various subsystems. Called by Tcl_Exit or when the Tcl + * shared library is being unloaded. * * Results: * None. * * Side effects: @@ -1087,11 +1006,27 @@ /* * Invoke exit handlers first. */ - InvokeExitHandlers(); + Tcl_MutexLock(&exitMutex); + inFinalize = 1; + for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = 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_DeleteExitHandler on itself. + */ + + firstExitPtr = exitPtr->nextPtr; + Tcl_MutexUnlock(&exitMutex); + (*exitPtr->proc)(exitPtr->clientData); + ckfree((char *) exitPtr); + Tcl_MutexLock(&exitMutex); + } + firstExitPtr = NULL; + Tcl_MutexUnlock(&exitMutex); TclpInitLock(); if (subsystemsInitialized == 0) { goto alreadyFinalized; } @@ -1116,22 +1051,21 @@ /* * Now invoke late (process-wide) exit handlers. */ Tcl_MutexLock(&exitMutex); - for (exitPtr = firstLateExitPtr; exitPtr != NULL; - exitPtr = firstLateExitPtr) { + for (exitPtr = firstLateExitPtr; exitPtr != NULL; exitPtr = firstLateExitPtr) { /* * 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_DeleteLateExitHandler on itself. */ firstLateExitPtr = exitPtr->nextPtr; Tcl_MutexUnlock(&exitMutex); exitPtr->proc(exitPtr->clientData); - Tcl_Free(exitPtr); + ckfree((char *) exitPtr); Tcl_MutexLock(&exitMutex); } firstLateExitPtr = NULL; Tcl_MutexUnlock(&exitMutex); @@ -1138,11 +1072,10 @@ /* * Now finalize the Tcl execution environment. Note that this must be done * after the exit handlers, because there are order dependencies. */ - TclFinalizeEvaluation(); TclFinalizeExecution(); TclFinalizeEnvironment(); /* * Finalizing the filesystem must come after anything which might @@ -1150,11 +1083,11 @@ */ TclFinalizeFilesystem(); /* - * Undo all Tcl_ObjType registrations, and reset the global list of free + * Undo all Tcl_ObjType registrations, and reset the master list of free * Tcl_Obj's. After this returns, no more Tcl_Obj's should be allocated or * freed. * * Note in particular that TclFinalizeObjects() must follow * TclFinalizeFilesystem() because TclFinalizeFilesystem free's the @@ -1169,10 +1102,12 @@ * structures, this is fine. */ TclFinalizeEncodingSubsystem(); + Tcl_SetPanicProc(NULL); + /* * Repeat finalization of the thread local storage once more. Although * this step is already done by the Tcl_FinalizeThread call above, series * of events happening afterwards may re-initialize TSD slots. Those need * to be finalized again, otherwise we're leaking memory chunks. Very @@ -1181,11 +1116,11 @@ * Tcl_Objs's, among other things. * * This fixes the Tcl Bug #990552. */ - TclFinalizeThreadData(/* quick */ 0); + TclFinalizeThreadData(); /* * Now we can free constants for conversions to/from double. */ @@ -1192,14 +1127,14 @@ TclFinalizeDoubleConversion(); /* * There have been several bugs in the past that cause exit handlers to be * established during Tcl_Finalize processing. Such exit handlers leave - * malloc'ed memory, and Tcl_FinalizeMemorySubsystem or - * Tcl_FinalizeThreadAlloc will result in a corrupted heap. The result can - * be a mysterious crash on process exit. Check here that nobody's done - * this. + * malloc'ed memory, and Tcl_FinalizeThreadAlloc or + * Tcl_FinalizeMemorySubsystem will result in a corrupted heap. The result + * can be a mysterious crash on process exit. Check here that nobody's + * done this. */ if (firstExitPtr != NULL) { Tcl_Panic("exit handlers were created during Tcl_Finalize"); } @@ -1215,11 +1150,11 @@ /* * Close down the thread-specific object allocator. */ -#if TCL_THREADS && defined(USE_THREAD_ALLOC) +#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) TclFinalizeThreadAlloc(); #endif /* * We defer unloading of packages until very late to avoid memory access @@ -1238,14 +1173,15 @@ TclFinalizeLoad(); TclResetFilesystem(); /* - * At this point, there should no longer be any Tcl_Alloc'ed memory. + * At this point, there should no longer be any ckalloc'ed memory. */ TclFinalizeMemorySubsystem(); + inFinalize = 0; alreadyFinalized: TclFinalizeLock(); } @@ -1267,27 +1203,20 @@ */ void Tcl_FinalizeThread(void) { - FinalizeThread(/* quick */ 0); -} - -void -FinalizeThread( - int quick) -{ ExitHandler *exitPtr; ThreadSpecificData *tsdPtr; /* * 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); + tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); if (tsdPtr != NULL) { tsdPtr->inExit = 1; for (exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL; exitPtr = tsdPtr->firstExitPtr) { @@ -1296,12 +1225,12 @@ * 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); - Tcl_Free(exitPtr); + (*exitPtr->proc)(exitPtr->clientData); + ckfree((char *) exitPtr); } TclFinalizeIOSubsystem(); TclFinalizeNotifier(); TclFinalizeAsync(); TclFinalizeThreadObjects(); @@ -1314,11 +1243,12 @@ * interp or other Tcl subsytems. Those threads might, however, use thread * local storage, so we must unconditionally finalize it. * * Fix [Bug #571002] */ - TclFinalizeThreadData(quick); + + TclFinalizeThreadData(); } /* *---------------------------------------------------------------------- * @@ -1336,11 +1266,11 @@ */ int TclInExit(void) { - return inExit; + return inFinalize; } /* *---------------------------------------------------------------------- * @@ -1358,16 +1288,17 @@ */ int TclInThreadExit(void) { - ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); - + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) + TclThreadDataKeyGet(&dataKey); if (tsdPtr == NULL) { return 0; + } else { + return tsdPtr->inExit; } - return tsdPtr->inExit; } /* *---------------------------------------------------------------------- * @@ -1383,85 +1314,74 @@ * See the user documentation. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_VwaitObjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { int done, foundEvent; - const char *nameString; + char *nameString; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "name"); return TCL_ERROR; } - nameString = TclGetString(objv[1]); - if (Tcl_TraceVar2(interp, nameString, NULL, + nameString = Tcl_GetString(objv[1]); + if (Tcl_TraceVar(interp, nameString, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - VwaitVarProc, &done) != TCL_OK) { + VwaitVarProc, (ClientData) &done) != TCL_OK) { return TCL_ERROR; }; done = 0; foundEvent = 1; while (!done && foundEvent) { foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS); - if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { - break; - } - if (Tcl_LimitExceeded(interp)) { - Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1)); - break; - } - } - Tcl_UntraceVar2(interp, nameString, NULL, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - VwaitVarProc, &done); - - if (!foundEvent) { - Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't wait for variable \"%s\": would wait forever", - nameString)); - Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", NULL); - return TCL_ERROR; - } - if (!done) { - /* - * The interpreter's result was already set to the right error message - * prior to exiting the loop above. - */ - - return TCL_ERROR; - } + if (Tcl_LimitExceeded(interp)) { + break; + } + } + Tcl_UntraceVar(interp, nameString, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + VwaitVarProc, (ClientData) &done); /* * Clear out the interpreter's result, since it may have been set by event * handlers. */ Tcl_ResetResult(interp); + if (!foundEvent) { + Tcl_AppendResult(interp, "can't wait for variable \"", nameString, + "\": would wait forever", NULL); + return TCL_ERROR; + } + if (!done) { + Tcl_AppendResult(interp, "limit exceeded", NULL); + return TCL_ERROR; + } return TCL_OK; } + /* ARGSUSED */ static char * VwaitVarProc( - void *clientData, /* Pointer to integer to set to 1. */ + ClientData 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. */ + CONST char *name1, /* Name of variable. */ + CONST char *name2, /* Second part of variable name. */ + int flags) /* Information about what happened. */ { - int *donePtr = (int *)clientData; + int *donePtr = (int *) clientData; *donePtr = 1; - Tcl_UntraceVar2(interp, name1, name2, TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + Tcl_UntraceVar(interp, name1, TCL_TRACE_WRITES|TCL_TRACE_UNSETS, VwaitVarProc, clientData); return NULL; } /* @@ -1479,31 +1399,32 @@ * See the user documentation. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_UpdateObjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { int optionIndex; int flags = 0; /* Initialized to avoid compiler warning. */ - static const char *const updateOptions[] = {"idletasks", NULL}; - enum updateOptionsEnum {OPT_IDLETASKS}; + static CONST char *updateOptions[] = {"idletasks", NULL}; + enum updateOptions {REGEXP_IDLETASKS}; if (objc == 1) { flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; } else if (objc == 2) { if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions, "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } - switch ((enum updateOptionsEnum) optionIndex) { - case OPT_IDLETASKS: + switch ((enum updateOptions) optionIndex) { + case REGEXP_IDLETASKS: flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT; break; default: Tcl_Panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions"); } @@ -1511,16 +1432,13 @@ Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?"); return TCL_ERROR; } while (Tcl_DoOneEvent(flags) != 0) { - if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { - return TCL_ERROR; - } if (Tcl_LimitExceeded(interp)) { Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1)); + Tcl_AppendResult(interp, "limit exceeded", NULL); return TCL_ERROR; } } /* @@ -1530,40 +1448,41 @@ Tcl_ResetResult(interp); return TCL_OK; } -#if TCL_THREADS +#ifdef TCL_THREADS /* - *---------------------------------------------------------------------- + *----------------------------------------------------------------------------- * * NewThreadProc -- * - * Bootstrap function of a new Tcl thread. + * Bootstrap function of a new Tcl thread. * * Results: * None. * * Side Effects: * Initializes Tcl notifier for the current thread. * - *---------------------------------------------------------------------- + *----------------------------------------------------------------------------- */ static Tcl_ThreadCreateType NewThreadProc( - void *clientData) + ClientData clientData) { - ThreadClientData *cdPtr = (ThreadClientData *)clientData; - void *threadClientData; + ThreadClientData *cdPtr; + ClientData threadClientData; Tcl_ThreadCreateProc *threadProc; + cdPtr = (ThreadClientData *) clientData; threadProc = cdPtr->proc; threadClientData = cdPtr->clientData; - Tcl_Free(clientData); /* Allocated in Tcl_CreateThread() */ + ckfree((char *) clientData); /* Allocated in Tcl_CreateThread() */ - threadProc(threadClientData); + (*threadProc)(threadClientData); TCL_THREAD_CREATE_RETURN; } #endif @@ -1587,27 +1506,25 @@ */ 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() */ - size_t stackSize, /* Size of stack for the new 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 - ThreadClientData *cdPtr = (ThreadClientData *)Tcl_Alloc(sizeof(ThreadClientData)); - int result; +#ifdef TCL_THREADS + ThreadClientData *cdPtr; + cdPtr = (ThreadClientData *) ckalloc(sizeof(ThreadClientData)); cdPtr->proc = proc; cdPtr->clientData = clientData; - result = TclpThreadCreate(idPtr, NewThreadProc, cdPtr, stackSize, flags); - if (result != TCL_OK) { - Tcl_Free(cdPtr); - } - return result; + + return TclpThreadCreate(idPtr, NewThreadProc, (ClientData) cdPtr, + stackSize, flags); #else return TCL_ERROR; #endif /* TCL_THREADS */ } Index: generic/tclExecute.c ================================================================== --- generic/tclExecute.c +++ generic/tclExecute.c @@ -4,25 +4,24 @@ * This file contains procedures that execute byte-compiled Tcl commands. * * Copyright (c) 1996-1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. - * Copyright (c) 2002-2010 by Miguel Sofer. + * Copyright (c) 2002-2005 by Miguel Sofer. * Copyright (c) 2005-2007 by Donal K. Fellows. * Copyright (c) 2007 Daniel A. Steffen - * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclCompile.h" -#include "tclOOInt.h" -#include "tclTomMath.h" +#include "tommath.h" + #include -#include +#include /* * 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 @@ -32,29 +31,27 @@ #if (FLT_RADIX == 2) && (DBL_MANT_DIG == 53) && (DBL_MAX_EXP == 1024) #define IEEE_FLOATING_POINT #endif /* - * A counter that is used to work out when the bytecode engine should call - * Tcl_AsyncReady() to see whether there is a signal that needs handling, and - * other expensive periodic operations. + * A mask (should be 2**n-1) that is used to work out when the bytecode engine + * should call Tcl_AsyncReady() to see whether there is a signal that needs + * handling. */ -#ifndef ASYNC_CHECK_COUNT -# define ASYNC_CHECK_COUNT 64 -#endif /* !ASYNC_CHECK_COUNT */ +#ifndef ASYNC_CHECK_COUNT_MASK +# define ASYNC_CHECK_COUNT_MASK 63 +#endif /* !ASYNC_CHECK_COUNT_MASK */ /* * Boolean flag indicating whether the Tcl bytecode interpreter has been * initialized. */ static int execInitialized = 0; TCL_DECLARE_MUTEX(execMutex) -static int cachedInExit = 0; - #ifdef TCL_COMPILE_DEBUG /* * Variable that controls whether execution tracing is enabled and, if so, * what level of tracing is desired: * 0: no execution tracing @@ -71,15 +68,15 @@ * 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-compatibility reasons. + * disjoint for backward-compatability reasons. */ static const char *const operatorStrings[] = { - "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>", + "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>", "+", "-", "*", "/", "%", "+", "-", "~", "!" }; /* * Mapping from Tcl result codes to strings; used for error and debugging @@ -95,86 +92,98 @@ /* * These are used by evalstats to monitor object usage in Tcl. */ #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 }; +long tclObjsAlloced = 0; +long tclObjsFreed = 0; +long 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 /* - * NR_TEBC - * Helpers for NR - non-recursive calls to TEBC - * Minimal data required to fully reconstruct the execution state. + * 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 { - 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 - * stacks; the struct will be expanded as - * necessary */ -} TEBCdata; - -#define TEBC_YIELD() \ - do { \ - esPtr->tosPtr = tosPtr; \ - TclNRAddCallback(interp, TEBCresume, \ - TD, pc, INT2PTR(cleanup), NULL); \ - } while (0) - -#define TEBC_DATA_DIG() \ - do { \ - tosPtr = esPtr->tosPtr; \ - } while (0) - -#define PUSH_TAUX_OBJ(objPtr) \ - do { \ - if (auxObjList) { \ - objPtr->length += auxObjList->length; \ - } \ - 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) - + 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 const BuiltinFunc 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 + /* * These variable-access macros have to coincide with those in tclVar.c */ #define VarHashGetValue(hPtr) \ - ((Var *) ((char *)hPtr - offsetof(VarInHash, entry))) + ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry))) static inline Var * VarHashCreateVar( TclVarHashTable *tablePtr, Tcl_Obj *key, int *newPtr) { - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table, - key, newPtr); + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) tablePtr, + (char *) key, newPtr); if (!hPtr) { return NULL; } return VarHashGetValue(hPtr); } #define VarHashFindVar(tablePtr, key) \ VarHashCreateVar((tablePtr), (key), NULL) - + /* * The new macro for ending an instruction; note that a reasonable C-optimiser * will resolve all branches at compile time. (result) is always a constant; * the macro NEXT_INST_F handles constant (nCleanup), NEXT_INST_V is resolved * at runtime for variable (nCleanup). @@ -183,157 +192,60 @@ * pcAdjustment: how much to increment pc * nCleanup: how many objects to remove from the stack * resultHandling: 0 indicates no object should be pushed on the stack; * otherwise, push objResultPtr. If (result < 0), objResultPtr already * has the correct reference count. - * - * We use the new compile-time assertions to check that nCleanup is constant - * and within range. */ -/* Verify the stack depth, only when no expansion is in progress */ - -#ifdef TCL_COMPILE_DEBUG -#define CHECK_STACK() \ - do { \ - ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, \ - /*checkStack*/ !(starting || auxObjList)); \ - starting = 0; \ - } while (0) -#else -#define CHECK_STACK() -#endif - -#define NEXT_INST_F(pcAdjustment, nCleanup, resultHandling) \ - do { \ - TCL_CT_ASSERT((nCleanup >= 0) && (nCleanup <= 2)); \ - CHECK_STACK(); \ - if (nCleanup == 0) { \ - if (resultHandling != 0) { \ - if ((resultHandling) > 0) { \ - PUSH_OBJECT(objResultPtr); \ - } else { \ - *(++tosPtr) = objResultPtr; \ - } \ - } \ - pc += (pcAdjustment); \ - goto cleanup0; \ - } else if (resultHandling != 0) { \ - if ((resultHandling) > 0) { \ - Tcl_IncrRefCount(objResultPtr); \ - } \ - pc += (pcAdjustment); \ - switch (nCleanup) { \ - case 1: goto cleanup1_pushObjResultPtr; \ - case 2: goto cleanup2_pushObjResultPtr; \ - case 0: break; \ - } \ - } else { \ - pc += (pcAdjustment); \ - switch (nCleanup) { \ - case 1: goto cleanup1; \ - case 2: goto cleanup2; \ - case 0: break; \ - } \ - } \ - } while (0) - -#define NEXT_INST_V(pcAdjustment, nCleanup, resultHandling) \ - CHECK_STACK(); \ - do { \ - pc += (pcAdjustment); \ - cleanup = (nCleanup); \ - if (resultHandling) { \ - if ((resultHandling) > 0) { \ - Tcl_IncrRefCount(objResultPtr); \ - } \ - goto cleanupV_pushObjResultPtr; \ - } else { \ - goto cleanupV; \ - } \ - } while (0) - -#ifndef TCL_COMPILE_DEBUG -#define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \ - do { \ - pc += (pcAdjustment); \ - switch (*pc) { \ - case INST_JUMP_FALSE1: \ - NEXT_INST_F(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \ - break; \ - case INST_JUMP_TRUE1: \ - NEXT_INST_F(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \ - break; \ - case INST_JUMP_FALSE4: \ - NEXT_INST_F(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \ - break; \ - case INST_JUMP_TRUE4: \ - NEXT_INST_F(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ - break; \ - default: \ - if ((condition) < 0) { \ - TclNewIntObj(objResultPtr, -1); \ - } else { \ - objResultPtr = TCONST((condition) > 0); \ - } \ - NEXT_INST_F(0, (cleanup), 1); \ - break; \ - } \ - } while (0) -#define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \ - do { \ - pc += (pcAdjustment); \ - switch (*pc) { \ - case INST_JUMP_FALSE1: \ - NEXT_INST_V(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \ - break; \ - case INST_JUMP_TRUE1: \ - NEXT_INST_V(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \ - break; \ - case INST_JUMP_FALSE4: \ - NEXT_INST_V(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \ - break; \ - case INST_JUMP_TRUE4: \ - NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ - break; \ - default: \ - if ((condition) < 0) { \ - TclNewIntObj(objResultPtr, -1); \ - } else { \ - objResultPtr = TCONST((condition) > 0); \ - } \ - NEXT_INST_V(0, (cleanup), 1); \ - break; \ - } \ - } while (0) -#else /* TCL_COMPILE_DEBUG */ -#define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \ - do{ \ - if ((condition) < 0) { \ - TclNewIntObj(objResultPtr, -1); \ - } else { \ - objResultPtr = TCONST((condition) > 0); \ - } \ - NEXT_INST_F((pcAdjustment), (cleanup), 1); \ - } while (0) -#define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \ - do{ \ - if ((condition) < 0) { \ - TclNewIntObj(objResultPtr, -1); \ - } else { \ - objResultPtr = TCONST((condition) > 0); \ - } \ - NEXT_INST_V((pcAdjustment), (cleanup), 1); \ - } while (0) -#endif +#define NEXT_INST_F(pcAdjustment, nCleanup, resultHandling) \ + if (nCleanup == 0) {\ + if (resultHandling != 0) {\ + if ((resultHandling) > 0) {\ + PUSH_OBJECT(objResultPtr);\ + } else {\ + *(++tosPtr) = objResultPtr;\ + }\ + } \ + pc += (pcAdjustment);\ + goto cleanup0;\ + } else if (resultHandling != 0) {\ + if ((resultHandling) > 0) {\ + Tcl_IncrRefCount(objResultPtr);\ + }\ + pc += (pcAdjustment);\ + switch (nCleanup) {\ + case 1: goto cleanup1_pushObjResultPtr;\ + case 2: goto cleanup2_pushObjResultPtr;\ + default: Tcl_Panic("bad usage of macro NEXT_INST_F");\ + }\ + } else {\ + pc += (pcAdjustment);\ + switch (nCleanup) {\ + case 1: goto cleanup1;\ + case 2: goto cleanup2;\ + default: Tcl_Panic("bad usage of macro NEXT_INST_F");\ + }\ + } + +#define NEXT_INST_V(pcAdjustment, nCleanup, resultHandling) \ + pc += (pcAdjustment);\ + cleanup = (nCleanup);\ + if (resultHandling) {\ + if ((resultHandling) > 0) {\ + Tcl_IncrRefCount(objResultPtr);\ + }\ + goto cleanupV_pushObjResultPtr;\ + } else {\ + goto cleanupV;\ + } /* * Macros used to cache often-referenced Tcl evaluation stack information * in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO() - * pair must surround any call inside TclNRExecuteByteCode (and a few other + * pair must surround any call inside TclExecuteByteCode (and a few other * procedures that use this scheme) that could result in a recursive call - * to TclNRExecuteByteCode. + * to TclExecuteByteCode. */ #define CACHE_STACK_INFO() \ checkInterp = 1 @@ -364,108 +276,157 @@ #define OBJ_UNDER_TOS *(tosPtr-1) #define OBJ_AT_DEPTH(n) *(tosPtr-(n)) -#define CURR_DEPTH ((ptrdiff_t) (tosPtr - initTosPtr)) +#define CURR_DEPTH (tosPtr - initTosPtr) #define STACK_BASE(esPtr) ((esPtr)->stackWords - 1) /* * Macros used to trace instruction execution. The macros TRACE, - * TRACE_WITH_OBJ, and O2S are only used inside TclNRExecuteByteCode. O2S is + * TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode. O2S is * only used in TRACE* calls to get a string from an object. */ #ifdef TCL_COMPILE_DEBUG # define TRACE(a) \ - while (traceInstructions) { \ - fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ - (int) CURR_DEPTH, \ - (unsigned) (pc - codePtr->codeStart), \ - GetOpcodeName(pc)); \ - printf a; \ - break; \ + if (traceInstructions) { \ + fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ + (int) CURR_DEPTH, \ + (unsigned)(pc - codePtr->codeStart), \ + GetOpcodeName(pc)); \ + printf a; \ } # define TRACE_APPEND(a) \ - while (traceInstructions) { \ - printf a; \ - break; \ + if (traceInstructions) { \ + printf a; \ } -# define TRACE_ERROR(interp) \ - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); # define TRACE_WITH_OBJ(a, objPtr) \ - while (traceInstructions) { \ - fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ - (int) CURR_DEPTH, \ - (unsigned) (pc - codePtr->codeStart), \ - GetOpcodeName(pc)); \ - printf a; \ - TclPrintObject(stdout, objPtr, 30); \ - fprintf(stdout, "\n"); \ - break; \ + if (traceInstructions) { \ + fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ + (int) CURR_DEPTH, \ + (unsigned)(pc - codePtr->codeStart), \ + GetOpcodeName(pc)); \ + printf a; \ + TclPrintObject(stdout, objPtr, 30); \ + fprintf(stdout, "\n"); \ } # define O2S(objPtr) \ (objPtr ? TclGetString(objPtr) : "") #else /* !TCL_COMPILE_DEBUG */ # define TRACE(a) # define TRACE_APPEND(a) -# define TRACE_ERROR(interp) # define TRACE_WITH_OBJ(a, objPtr) # define O2S(objPtr) #endif /* TCL_COMPILE_DEBUG */ /* * DTrace instruction probe macros. */ #define TCL_DTRACE_INST_NEXT() \ - do { \ - if (TCL_DTRACE_INST_DONE_ENABLED()) { \ - if (curInstName) { \ - TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, \ - tosPtr); \ - } \ - curInstName = tclInstructionTable[*pc].name; \ - if (TCL_DTRACE_INST_START_ENABLED()) { \ - TCL_DTRACE_INST_START(curInstName, (int) CURR_DEPTH, \ - tosPtr); \ - } \ - } else if (TCL_DTRACE_INST_START_ENABLED()) { \ - TCL_DTRACE_INST_START(tclInstructionTable[*pc].name, \ - (int) CURR_DEPTH, tosPtr); \ - } \ - } while (0) + if (TCL_DTRACE_INST_DONE_ENABLED()) {\ + if (curInstName) {\ + TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, tosPtr);\ + }\ + curInstName = tclInstructionTable[*pc].name;\ + if (TCL_DTRACE_INST_START_ENABLED()) {\ + TCL_DTRACE_INST_START(curInstName, (int) CURR_DEPTH, tosPtr);\ + }\ + } else if (TCL_DTRACE_INST_START_ENABLED()) {\ + TCL_DTRACE_INST_START(tclInstructionTable[*pc].name, (int) CURR_DEPTH,\ + tosPtr);\ + } #define TCL_DTRACE_INST_LAST() \ - do { \ - if (TCL_DTRACE_INST_DONE_ENABLED() && curInstName) { \ - TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, tosPtr);\ - } \ - } while (0) - + if (TCL_DTRACE_INST_DONE_ENABLED() && curInstName) {\ + TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, tosPtr);\ + } + /* * Macro used in this file to save a function call for common uses of * TclGetNumberFromObj(). The ANSI C "prototype" is: * * 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) = (void *) \ +#ifdef NO_WIDE_TYPE + +#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ + (((objPtr)->typePtr == &tclIntType) \ + ? (*(tPtr) = TCL_NUMBER_LONG, \ + *(ptrPtr) = (ClientData) \ + (&((objPtr)->internalRep.longValue)), TCL_OK) : \ + ((objPtr)->typePtr == &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))) + +#else + +#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ + (((objPtr)->typePtr == &tclIntType) \ + ? (*(tPtr) = TCL_NUMBER_LONG, \ + *(ptrPtr) = (ClientData) \ + (&((objPtr)->internalRep.longValue)), TCL_OK) : \ + ((objPtr)->typePtr == &tclWideIntType) \ + ? (*(tPtr) = TCL_NUMBER_WIDE, \ + *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.wideValue)), TCL_OK) : \ - TclHasIntRep((objPtr), &tclDoubleType) \ + ((objPtr)->typePtr == &tclDoubleType) \ ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \ ? (*(tPtr) = TCL_NUMBER_NAN) \ : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ - *(ptrPtr) = (void *) \ + *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ - (((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \ - ? TCL_ERROR : \ + (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))? TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) + +#endif + +/* + * Macro used in this file to save a function call for common uses of + * Tcl_GetBooleanFromObj(). The ANSI C "prototype" is: + * + * MODULE_SCOPE int TclGetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + * int *boolPtr); + */ + +#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \ + ((((objPtr)->typePtr == &tclIntType) \ + || ((objPtr)->typePtr == &tclBooleanType)) \ + ? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \ + : Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr))) + +/* + * Macro used in this file to save a function call for common uses of + * Tcl_GetWideIntFromObj(). The ANSI C "prototype" is: + * + * MODULE_SCOPE int TclGetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + * Tcl_WideInt *wideIntPtr); + */ + +#ifdef NO_WIDE_TYPE +#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ + (((objPtr)->typePtr == &tclIntType) \ + ? (*(wideIntPtr) = (Tcl_WideInt) \ + ((objPtr)->internalRep.longValue), TCL_OK) : \ + Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) +#else +#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ + (((objPtr)->typePtr == &tclWideIntType) \ + ? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) : \ + ((objPtr)->typePtr == &tclIntType) \ + ? (*(wideIntPtr) = (Tcl_WideInt) \ + ((objPtr)->internalRep.longValue), TCL_OK) : \ + Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) +#endif /* * Macro used to make the check for type overflow more mnemonic. This works by * comparing sign bits; the rest of the word is irrelevant. The ANSI C * "prototype" (where inttype_t is any integer type) is: @@ -477,23 +438,56 @@ */ #define Overflowing(a,b,sum) ((((a)^(sum)) < 0) && (((a)^(b)) >= 0)) /* - * Macro for checking whether the type is NaN, used when we're thinking about - * throwing an error for supplying a non-number number. + * Custom object type only used in this file; values of its type should never + * be seen by user scripts. + */ + +static Tcl_ObjType dictIteratorType = { + "dictIterator", + NULL, NULL, NULL, NULL +}; + +/* + * Auxiliary tables used to compute powers of small integers + */ + +#if (LONG_MAX == 0x7fffffff) + +/* + * Maximum base that, when raised to powers 2, 3, ... 8, fits in a 32-bit + * signed integer + */ + +static const long MaxBase32[] = {46340, 1290, 215, 73, 35, 21, 14}; +static const size_t MaxBase32Size = sizeof(MaxBase32)/sizeof(long); + +/* + * Table giving 3, 4, ..., 11, raised to the powers 9, 10, ..., as far as they + * fit in a 32-bit signed integer. Exp32Index[i] gives the starting index of + * powers of i+3; Exp32Value[i] gives the corresponding powers. */ -#ifndef ACCEPT_NAN -#define IsErroringNaNType(type) ((type) == TCL_NUMBER_NAN) -#else -#define IsErroringNaNType(type) 0 -#endif - -/* - * Auxiliary tables used to compute powers of small integers. - */ +static const unsigned short Exp32Index[] = { + 0, 11, 18, 23, 26, 29, 31, 32, 33 +}; +static const size_t Exp32IndexSize = sizeof(Exp32Index)/sizeof(unsigned short); +static const long Exp32Value[] = { + 19683, 59049, 177147, 531441, 1594323, 4782969, 14348907, 43046721, + 129140163, 387420489, 1162261467, 262144, 1048576, 4194304, + 16777216, 67108864, 268435456, 1073741824, 1953125, 9765625, + 48828125, 244140625, 1220703125, 10077696, 60466176, 362797056, + 40353607, 282475249, 1977326743, 134217728, 1073741824, 387420489, + 1000000000 +}; +static const size_t Exp32ValueSize = sizeof(Exp32Value)/sizeof(long); + +#endif /* LONG_MAX == 0x7fffffff -- 32 bit machine */ + +#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) /* * Maximum base that, when raised to powers 2, 3, ..., 16, fits in a * Tcl_WideInt. */ @@ -506,19 +500,18 @@ (Tcl_WideInt)22, (Tcl_WideInt)18, (Tcl_WideInt)15 }; static const size_t MaxBase64Size = sizeof(MaxBase64)/sizeof(Tcl_WideInt); /* - * Table giving 3, 4, ..., 13 raised to powers greater than 16 when the + *Table giving 3, 4, ..., 13 raised to powers greater than 16 when the * results fit in a 64-bit signed integer. */ static const unsigned short Exp64Index[] = { 0, 23, 38, 49, 57, 63, 67, 70, 72, 74, 75, 76 }; -static const size_t Exp64IndexSize = - sizeof(Exp64Index) / sizeof(unsigned short); +static const size_t Exp64IndexSize = sizeof(Exp64Index)/sizeof(unsigned short); static const Tcl_WideInt Exp64Value[] = { (Tcl_WideInt)243*243*243*3*3, (Tcl_WideInt)243*243*243*3*3*3, (Tcl_WideInt)243*243*243*3*3*3*3, (Tcl_WideInt)243*243*243*243, @@ -593,21 +586,14 @@ (Tcl_WideInt)161051*161051*161051*11*11, (Tcl_WideInt)161051*161051*161051*11*11*11, (Tcl_WideInt)248832*248832*248832*12*12, (Tcl_WideInt)371293*371293*371293*13*13 }; -static const size_t Exp64ValueSize = sizeof(Exp64Value) / sizeof(Tcl_WideInt); - -/* - * 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) - +static const size_t Exp64ValueSize = sizeof(Exp64Value)/sizeof(Tcl_WideInt); + +#endif + /* * Declarations for local procedures to this file: */ #ifdef TCL_COMPILE_STATS @@ -614,112 +600,46 @@ static int EvalStatsCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); #endif /* TCL_COMPILE_STATS */ #ifdef TCL_COMPILE_DEBUG -static const char * GetOpcodeName(const unsigned char *pc); +static char * GetOpcodeName(unsigned char *pc); static void PrintByteCodeInfo(ByteCode *codePtr); static const char * StringForResultCode(int result); static void ValidatePcAndStackTop(ByteCode *codePtr, - const unsigned char *pc, int stackTop, - int checkStack); + unsigned char *pc, int stackTop, + int stackLowerBound, int checkStack); #endif /* TCL_COMPILE_DEBUG */ -static ByteCode * CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr); static void DeleteExecStack(ExecStack *esPtr); static void DupExprCodeInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); -static Tcl_Obj * ExecuteExtendedBinaryMathOp(Tcl_Interp *interp, - int opcode, Tcl_Obj **constants, - 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, size_t *lengthPtr, - const unsigned char **pcBeg, int *cmdIdxPtr); +static ExceptionRange * GetExceptRangeForPc(unsigned char *pc, int searchMode, + ByteCode *codePtr); +static const char * GetSrcInfoForPc(unsigned char *pc, ByteCode *codePtr, + int *lengthPtr); static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, int growth, int move); static void IllegalExprOperandType(Tcl_Interp *interp, - const unsigned char *pc, Tcl_Obj *opndPtr); + unsigned char *pc, Tcl_Obj *opndPtr); static void InitByteCodeExecution(Tcl_Interp *interp); -static inline int wordSkip(void *ptr); -static void ReleaseDictIterator(Tcl_Obj *objPtr); /* Useful elsewhere, make available in tclInt.h or stubs? */ -static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, size_t numWords); -static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, size_t numWords); -static Tcl_NRPostProc CopyCallback; -static Tcl_NRPostProc ExprObjCallback; -static Tcl_NRPostProc FinalizeOONext; -static Tcl_NRPostProc FinalizeOONextFilter; -static Tcl_NRPostProc TEBCresume; +static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, int numWords); +static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, int numWords); /* * The structure below defines a bytecode Tcl object type to hold the * compiled bytecode for Tcl expressions. */ -static const Tcl_ObjType exprCodeType = { +static Tcl_ObjType exprCodeType = { "exprcode", FreeExprCodeInternalRep, /* freeIntRepProc */ DupExprCodeInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ NULL /* setFromAnyProc */ }; - -/* - * Custom object type only used in this file; values of its type should never - * be seen by user scripts. - */ - -static const Tcl_ObjType dictIteratorType = { - "dictIterator", - ReleaseDictIterator, - NULL, NULL, NULL -}; - -/* - *---------------------------------------------------------------------- - * - * ReleaseDictIterator -- - * - * This takes apart a dictionary iterator that is stored in the given Tcl - * object. - * - * Results: - * None. - * - * Side effects: - * Deallocates memory, marks the object as being untyped. - * - *---------------------------------------------------------------------- - */ - -static void -ReleaseDictIterator( - Tcl_Obj *objPtr) -{ - Tcl_DictSearch *searchPtr; - Tcl_Obj *dictPtr; - const Tcl_ObjIntRep *irPtr; - - irPtr = TclFetchIntRep(objPtr, &dictIteratorType); - 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); - Tcl_Free(searchPtr); - - dictPtr = (Tcl_Obj *)irPtr->twoPtrValue.ptr2; - TclDecrRefCount(dictPtr); -} /* *---------------------------------------------------------------------- * * InitByteCodeExecution -- @@ -738,95 +658,83 @@ * "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, + if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &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 * execution. An ExecEnv points to a Tcl evaluation stack. An ExecEnv is * typically created once for each Tcl interpreter (Interp structure) and - * recursively passed to TclNRExecuteByteCode to execute ByteCode sequences + * recursively passed to TclExecuteByteCode to execute ByteCode sequences * for nested commands. * * Results: * A newly allocated ExecEnv is returned. This points to an empty * evaluation stack of the standard initial size. * * Side effects: * The bytecode interpreter is also initialized here, as this procedure - * will be called before any call to TclNRExecuteByteCode. + * will be called before any call to TclExecuteByteCode. * *---------------------------------------------------------------------- */ + +#define TCL_STACK_INITIAL_SIZE 2000 ExecEnv * TclCreateExecEnv( - Tcl_Interp *interp, /* Interpreter for which the execution + Tcl_Interp *interp) /* Interpreter for which the execution * environment is being created. */ - size_t size) /* The initial stack size, in number of words - * [sizeof(Tcl_Obj*)] */ { - ExecEnv *eePtr = (ExecEnv *)Tcl_Alloc(sizeof(ExecEnv)); - ExecStack *esPtr = (ExecStack *)Tcl_Alloc(offsetof(ExecStack, stackWords) - + size * sizeof(Tcl_Obj *)); + ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv)); + ExecStack *esPtr = (ExecStack *) ckalloc(sizeof(ExecStack) + + (size_t) (TCL_STACK_INITIAL_SIZE-1) * sizeof(Tcl_Obj *)); eePtr->execStackPtr = esPtr; - TclNewIntObj(eePtr->constants[0], 0); + TclNewBooleanObj(eePtr->constants[0], 0); Tcl_IncrRefCount(eePtr->constants[0]); - TclNewIntObj(eePtr->constants[1], 1); + TclNewBooleanObj(eePtr->constants[1], 1); Tcl_IncrRefCount(eePtr->constants[1]); - eePtr->interp = interp; - eePtr->callbackPtr = NULL; - eePtr->corPtr = NULL; - eePtr->rewind = 0; esPtr->prevPtr = NULL; esPtr->nextPtr = NULL; esPtr->markerPtr = NULL; - esPtr->endPtr = &esPtr->stackWords[size-1]; + esPtr->endPtr = &esPtr->stackWords[TCL_STACK_INITIAL_SIZE-1]; esPtr->tosPtr = STACK_BASE(esPtr); Tcl_MutexLock(&execMutex); if (!execInitialized) { + TclInitAuxDataTypeTable(); InitByteCodeExecution(interp); execInitialized = 1; } Tcl_MutexUnlock(&execMutex); return eePtr; } +#undef TCL_STACK_INITIAL_SIZE /* *---------------------------------------------------------------------- * * TclDeleteExecEnv -- @@ -845,31 +753,29 @@ static void DeleteExecStack( ExecStack *esPtr) { - if (esPtr->markerPtr && !cachedInExit) { + if (esPtr->markerPtr) { Tcl_Panic("freeing an execStack which is still in use"); } if (esPtr->prevPtr) { esPtr->prevPtr->nextPtr = esPtr->nextPtr; } if (esPtr->nextPtr) { esPtr->nextPtr->prevPtr = esPtr->prevPtr; } - Tcl_Free(esPtr); + ckfree((char *) esPtr); } void TclDeleteExecEnv( ExecEnv *eePtr) /* Execution environment to free. */ { ExecStack *esPtr = eePtr->execStackPtr, *tmpPtr; - cachedInExit = TclInExit(); - /* * Delete all stacks in this exec env. */ while (esPtr->nextPtr) { @@ -881,17 +787,11 @@ DeleteExecStack(tmpPtr); } TclDecrRefCount(eePtr->constants[0]); 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"); - } - Tcl_Free(eePtr); + ckfree((char *) eePtr); } /* *---------------------------------------------------------------------- * @@ -914,10 +814,11 @@ TclFinalizeExecution(void) { Tcl_MutexLock(&execMutex); execInitialized = 0; Tcl_MutexUnlock(&execMutex); + TclFinalizeAuxDataTypeTable(); } /* * Auxiliary code to insure that GrowEvaluationStack always returns correctly * aligned memory. @@ -947,12 +848,13 @@ /* * Given a marker, compute where the following aligned memory starts. */ -#define MEMSTART(markerPtr) \ +#define MEMSTART(markerPtr) \ ((markerPtr) + wordSkip(markerPtr)) + /* *---------------------------------------------------------------------- * * GrowEvaluationStack -- @@ -978,12 +880,12 @@ 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; - size_t newBytes; - int newElems, currElems, needed = growth - (esPtr->endPtr - esPtr->tosPtr); + int newBytes, newElems, currElems; + int needed = growth - (esPtr->endPtr - esPtr->tosPtr); Tcl_Obj **markerPtr = esPtr->markerPtr, **memStart; int moveWords = 0; if (move) { if (!markerPtr) { @@ -991,11 +893,10 @@ } if (needed <= 0) { return MEMSTART(markerPtr); } } else { -#ifndef PURIFY Tcl_Obj **tmpMarkerPtr = esPtr->tosPtr + 1; int offset = wordSkip(tmpMarkerPtr); if (needed + offset < 0) { /* @@ -1008,11 +909,10 @@ memStart = tmpMarkerPtr + offset; esPtr->tosPtr = memStart - 1; *esPtr->markerPtr = (Tcl_Obj *) markerPtr; return memStart; } -#endif } /* * Reset move to hold the number of words to be moved to new stack (if * any) and growth to hold the complete stack requirements: add one for @@ -1021,11 +921,10 @@ if (move) { moveWords = esPtr->tosPtr - MEMSTART(markerPtr) + 1; } needed = growth + moveWords + WALLOCALIGN; - /* * Check if there is enough room in the next stack (if there is one, it * should be both empty and the last one!) */ @@ -1052,23 +951,18 @@ /* * We need to allocate a new stack! It needs to store 'growth' words, * including the elements to be copied over and the new marker. */ -#ifndef PURIFY newElems = 2*currElems; while (needed > newElems) { newElems *= 2; } -#else - newElems = needed; -#endif - - newBytes = offsetof(ExecStack, stackWords) + newElems * sizeof(Tcl_Obj *); + newBytes = sizeof (ExecStack) + (newElems-1) * sizeof(Tcl_Obj *); oldPtr = esPtr; - esPtr = (ExecStack *)Tcl_Alloc(newBytes); + esPtr = (ExecStack *) ckalloc(newBytes); oldPtr->nextPtr = esPtr; esPtr->prevPtr = oldPtr; esPtr->nextPtr = NULL; esPtr->endPtr = &esPtr->stackWords[newElems-1]; @@ -1124,11 +1018,11 @@ */ static Tcl_Obj ** StackAllocWords( Tcl_Interp *interp, - size_t numWords) + int numWords) { /* * Note that GrowEvaluationStack sets a marker in the stack. This marker * is read when rewinding, e.g., by TclStackFree. */ @@ -1142,11 +1036,11 @@ } static Tcl_Obj ** StackReallocWords( Tcl_Interp *interp, - size_t numWords) + int numWords) { Interp *iPtr = (Interp *) interp; ExecEnv *eePtr = iPtr->execEnvPtr; Tcl_Obj **resPtr = GrowEvaluationStack(eePtr, numWords, 1); @@ -1160,14 +1054,14 @@ void *freePtr) { Interp *iPtr = (Interp *) interp; ExecEnv *eePtr; ExecStack *esPtr; - Tcl_Obj **markerPtr, *marker; + Tcl_Obj **markerPtr; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - Tcl_Free(freePtr); + ckfree((char *) freePtr); return; } /* * Rewind the stack to the previous marker position. The current marker, @@ -1176,81 +1070,66 @@ */ eePtr = iPtr->execEnvPtr; esPtr = eePtr->execStackPtr; markerPtr = esPtr->markerPtr; - marker = *markerPtr; - if ((freePtr != NULL) && (MEMSTART(markerPtr) != (Tcl_Obj **)freePtr)) { - Tcl_Panic("TclStackFree: incorrect freePtr (%p != %p). Call out of sequence?", - freePtr, MEMSTART(markerPtr)); + if (MEMSTART(markerPtr) != (Tcl_Obj **)freePtr) { + Tcl_Panic("TclStackFree: incorrect freePtr. Call out of sequence?"); } - esPtr->tosPtr = markerPtr - 1; - esPtr->markerPtr = (Tcl_Obj **) marker; - if (marker) { - return; + esPtr->tosPtr = markerPtr-1; + esPtr->markerPtr = (Tcl_Obj **) *markerPtr; + if (*markerPtr) { + return; } /* - * Return to previous active stack. Note that repeated expansions or - * reallocs could have generated several unused intervening stacks: free - * them too. + * Return to previous stack. */ - while (esPtr->nextPtr) { - esPtr = esPtr->nextPtr; - } esPtr->tosPtr = STACK_BASE(esPtr); - while (esPtr->prevPtr) { - ExecStack *tmpPtr = esPtr->prevPtr; - if (tmpPtr->tosPtr == STACK_BASE(tmpPtr)) { - DeleteExecStack(tmpPtr); - } else { - break; - } - } if (esPtr->prevPtr) { - eePtr->execStackPtr = esPtr->prevPtr; -#ifdef PURIFY - eePtr->execStackPtr->nextPtr = NULL; - DeleteExecStack(esPtr); -#endif - } else { - eePtr->execStackPtr = esPtr; + eePtr->execStackPtr = esPtr->prevPtr; + } + if (esPtr->nextPtr) { + if (!esPtr->prevPtr) { + eePtr->execStackPtr = esPtr->nextPtr; + } + DeleteExecStack(esPtr); } } void * TclStackAlloc( Tcl_Interp *interp, - size_t numBytes) + int numBytes) { Interp *iPtr = (Interp *) interp; - size_t numWords; + int numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - return (void *) Tcl_Alloc(numBytes); + return (void *) ckalloc(numBytes); } - numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); - return StackAllocWords(interp, numWords); + + return (void *) StackAllocWords(interp, numWords); } void * TclStackRealloc( Tcl_Interp *interp, void *ptr, - size_t numBytes) + int numBytes) { Interp *iPtr = (Interp *) interp; ExecEnv *eePtr; ExecStack *esPtr; Tcl_Obj **markerPtr; - size_t numWords; + int numWords; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - return Tcl_Realloc(ptr, numBytes); + return (void *) ckrealloc((char *) ptr, numBytes); } eePtr = iPtr->execEnvPtr; esPtr = eePtr->execStackPtr; markerPtr = esPtr->markerPtr; @@ -1288,157 +1167,52 @@ int Tcl_ExprObj( Tcl_Interp *interp, /* Context in which to evaluate the * expression. */ - Tcl_Obj *objPtr, /* Points to Tcl object containing expression + register 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); - } - return result; -} - -/* - *-------------------------------------------------------------- - * - * Tcl_NRExprObj -- - * - * Request evaluation of the expression in a Tcl_Obj by the NR stack. - * - * Results: - * Returns TCL_OK. - * - * Side effects: - * Compiles objPtr as a Tcl expression and places callbacks on the - * NR stack to execute the bytecode and store the result in resultPtr. - * If bytecode execution raises an exception, nothing is written - * to resultPtr, and the exceptional return code flows up the NR - * stack. If the exception is TCL_ERROR, an error message is left - * in the interp result and the interp's return options dictionary - * holds additional error information too. Execution of the bytecode - * may have other side effects, depending on the expression. - * - *-------------------------------------------------------------- - */ - -int -Tcl_NRExprObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - Tcl_Obj *resultPtr) -{ - ByteCode *codePtr; - Tcl_InterpState state = Tcl_SaveInterpState(interp, TCL_OK); - - Tcl_ResetResult(interp); - codePtr = CompileExprObj(interp, objPtr); - - Tcl_NRAddCallback(interp, ExprObjCallback, state, resultPtr, - NULL, NULL); - return TclNRExecuteByteCode(interp, codePtr); -} - -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); - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileExprObj -- - * Compile a Tcl expression value into ByteCode. - * - * Results: - * A (ByteCode *) is returned pointing to the resulting ByteCode. - * - * Side effects: - * The Tcl_ObjType of objPtr is changed to the "exprcode" type, - * and the ByteCode is kept in the internal rep (along with context - * data for checking validity) for faster operations the next time - * CompileExprObj is called on the same value. - * - *---------------------------------------------------------------------- - */ - -static ByteCode * -CompileExprObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr) -{ Interp *iPtr = (Interp *) interp; CompileEnv compEnv; /* Compilation environment structure allocated * in frame. */ - ByteCode *codePtr = NULL; - /* Tcl Internal type of bytecode. Initialized + register ByteCode *codePtr = NULL; + /* Tcl Internal type of bytecode. Initialized * to avoid compiler warning. */ + int result; + + /* + * Execute the expression after first saving the interpreter's result. + */ + + Tcl_Obj *saveObjPtr = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(saveObjPtr); /* * Get the expression ByteCode from the object. If it exists, make sure it * is valid in the current context. */ - - ByteCodeGetIntRep(objPtr, &exprCodeType, codePtr); - - if (codePtr != NULL) { + if (objPtr->typePtr == &exprCodeType) { Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; + codePtr = (ByteCode *) objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) - || (codePtr->nsEpoch != namespacePtr->resolverEpoch) - || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { - Tcl_StoreIntRep(objPtr, &exprCodeType, NULL); - codePtr = NULL; + || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) { + objPtr->typePtr->freeIntRepProc(objPtr); + objPtr->typePtr = (Tcl_ObjType *) NULL; } } - - if (codePtr == NULL) { + if (objPtr->typePtr != &exprCodeType) { /* * TIP #280: No invoker (yet) - Expression compilation. */ - size_t length; + int length; const char *string = TclGetStringFromObj(objPtr, &length); TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0); TclCompileExpr(interp, string, length, &compEnv, 0); @@ -1446,11 +1220,11 @@ * Successful compilation. If the expression yielded no instructions, * push an zero object as the expression's result. */ if (compEnv.codeNext == compEnv.codeStart) { - TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, 0), + TclEmitPush(TclRegisterNewLiteral(&compEnv, "0", 1), &compEnv); } /* * Add a "done" instruction as the last instruction and change the @@ -1457,43 +1231,72 @@ * object into a ByteCode object. Ownership of the literal objects and * aux data items is given to the ByteCode object. */ TclEmitOpcode(INST_DONE, &compEnv); - codePtr = TclInitByteCodeObj(objPtr, &exprCodeType, &compEnv); + TclInitByteCodeObj(objPtr, &compEnv); + objPtr->typePtr = &exprCodeType; TclFreeCompileEnv(&compEnv); - if (iPtr->varFramePtr->localCachePtr) { - codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; - codePtr->localCachePtr->refCount++; - } + codePtr = (ByteCode *) objPtr->internalRep.twoPtrValue.ptr1; #ifdef TCL_COMPILE_DEBUG if (tclTraceCompile == 2) { TclPrintByteCodeObj(interp, objPtr); fflush(stdout); } #endif /* TCL_COMPILE_DEBUG */ } - return codePtr; + + Tcl_ResetResult(interp); + + /* + * Increment the code's ref count while it is being executed. If + * afterwards no references to it remain, free the code. + */ + + codePtr->refCount++; + result = TclExecuteByteCode(interp, codePtr); + codePtr->refCount--; + if (codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } + + /* + * If the expression evaluated successfully, store a pointer to its value + * object in resultPtrPtr then restore the old interpreter result. We + * increment the object's ref count to reflect the reference that we are + * returning to the caller. We also decrement the ref count of the + * interpreter's result object after calling Tcl_SetResult since we next + * store into that field directly. + */ + + if (result == TCL_OK) { + *resultPtrPtr = iPtr->objResultPtr; + Tcl_IncrRefCount(iPtr->objResultPtr); + + Tcl_SetObjResult(interp, saveObjPtr); + } + TclDecrRefCount(saveObjPtr); + return result; } /* *---------------------------------------------------------------------- * * DupExprCodeInternalRep -- * * Part of the Tcl object type implementation for Tcl expression - * bytecode. We do not copy the bytecode intrep. Instead, we return - * without setting copyPtr->typePtr, so the copy is a plain string copy - * of the expression value, and if it is to be used as a compiled - * expression, it will just need a recompile. - * - * This makes sense, because with Tcl's copy-on-write practices, the - * usual (only?) time Tcl_DuplicateObj() will be called is when the copy - * is about to be modified, which would invalidate any copied bytecode - * anyway. The only reason it might make sense to copy the bytecode is if - * we had some modifying routines that operated directly on the intrep, - * like we do for lists and dicts. + * bytecode. We do not copy the bytecode intrep. Instead, we + * return without setting copyPtr->typePtr, so the copy is a plain + * string copy of the expression value, and if it is to be used + * as a compiled expression, it will just need a recompile. + * + * This makes sense, because with Tcl's copy-on-write practices, + * the usual (only?) time Tcl_DuplicateObj() will be called is + * when the copy is about to be modified, which would invalidate + * any copied bytecode anyway. The only reason it might make sense + * to copy the bytecode is if we had some modifying routines that + * operated directly on the intrep, like we do for lists and dicts. * * Results: * None. * * Side effects: @@ -1502,12 +1305,12 @@ *---------------------------------------------------------------------- */ static void DupExprCodeInternalRep( - TCL_UNUSED(Tcl_Obj *), - TCL_UNUSED(Tcl_Obj *)) + Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr) { return; } /* @@ -1514,45 +1317,46 @@ *---------------------------------------------------------------------- * * FreeExprCodeInternalRep -- * * Part of the Tcl object type implementation for Tcl expression - * bytecode. Frees the storage allocated to hold the internal rep, unless - * ref counts indicate bytecode execution is still in progress. + * bytecode. Frees the storage allocated to hold the internal rep, + * unless ref counts indicate bytecode execution is still in progress. * * Results: * None. * * Side effects: - * May free allocated memory. Leaves objPtr untyped. - * + * May free allocated memory. Leaves objPtr untyped. *---------------------------------------------------------------------- */ static void FreeExprCodeInternalRep( Tcl_Obj *objPtr) { - ByteCode *codePtr; - ByteCodeGetIntRep(objPtr, &exprCodeType, codePtr); - assert(codePtr != NULL); + ByteCode *codePtr = (ByteCode *) objPtr->internalRep.twoPtrValue.ptr1; - TclReleaseByteCode(codePtr); + codePtr->refCount--; + if (codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } + objPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * * TclCompileObj -- * - * This procedure compiles the script contained in a Tcl_Obj. + * This procedure compiles the script contained in a Tcl_Obj. * * Results: - * A pointer to the corresponding ByteCode, never NULL. + * A pointer to the corresponding ByteCode, never NULL. * * Side effects: - * The object is shimmered to bytecode type. + * The object is shimmered to bytecode type. * *---------------------------------------------------------------------- */ ByteCode * @@ -1560,22 +1364,21 @@ Tcl_Interp *interp, Tcl_Obj *objPtr, const CmdFrame *invoker, int word) { - Interp *iPtr = (Interp *) interp; - ByteCode *codePtr; /* Tcl Internal type of bytecode. */ + register Interp *iPtr = (Interp *) interp; + register ByteCode *codePtr; /* Tcl Internal type of bytecode. */ Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; /* * If the object is not already of tclByteCodeType, compile it (and reset * the compilation flags in the interpreter; this should be done after any * compilation). Otherwise, check that it is "fresh" enough. */ - ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); - if (codePtr != NULL) { + if (objPtr->typePtr == &tclByteCodeType) { /* * Make sure the Bytecode hasn't been invalidated by, e.g., someone * redefining a command with a compile procedure (this might make the * compiled code wrong). The object needs to be recompiled if it was * compiled in/for a different interpreter, or for a different @@ -1589,10 +1392,11 @@ * #def'ed out because [info body] was changed to never return a * bytecode type object, which should obviate us from the extra checks * here. */ + codePtr = (ByteCode *) objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) { if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { @@ -1616,15 +1420,21 @@ } /* * #280. * Literal sharing fix. This part of the fix is not required by 8.4 - * nor 8.5, because they eval-direct any literals, so just saving the - * argument locations per command in bytecode is enough, embedded - * 'eval' commands, etc. get the correct information. + * because it eval-directs any literals, so just saving the argument + * locations per command in bytecode is enough, embedded 'eval' + * commands, etc. get the correct information. + * + * It had be backported for 8.5 because we can force the separate + * compiling of a literal (in a proc body) by putting it into a control + * command with dynamic pieces, and then such literal may be shared + * and require their line-information to be reset, as for 8.6, as + * described below. * - * But in 8.6 all the embedded script are compiled, and the resulting + * In 8.6 all the embedded script are compiled, and the resulting * bytecode stored in the literal. Now the shared literal has bytecode * with location data for _one_ particular location this literal is * found at. If we get executed from a different location the bytecode * has to be recompiled to get the correct locations. Not doing this * will execute the saved bytecode with data for a different location, @@ -1646,22 +1456,23 @@ if (invoker == NULL) { return codePtr; } else { Tcl_HashEntry *hePtr = - Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr); + Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr); + ExtCmdLoc *eclPtr; CmdFrame *ctxCopyPtr; int redo; if (!hePtr) { return codePtr; } - eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hePtr); + eclPtr = Tcl_GetHashValue(hePtr); redo = 0; - ctxCopyPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame)); + ctxCopyPtr = TclStackAlloc(interp, sizeof(CmdFrame)); *ctxCopyPtr = *invoker; if (invoker->type == TCL_LOCATION_BC) { /* * Note: Type BC => ctx.data.eval.path is not used. @@ -1716,17 +1527,80 @@ iPtr->invokeCmdFramePtr = invoker; iPtr->invokeWord = word; TclSetByteCodeFromAny(interp, objPtr, NULL, NULL); iPtr->invokeCmdFramePtr = NULL; - ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); + codePtr = (ByteCode *) objPtr->internalRep.twoPtrValue.ptr1; if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; } return codePtr; } + +/* + *---------------------------------------------------------------------- + * + * TclCompEvalObj -- + * + * This procedure evaluates the script contained in a Tcl_Obj by first + * compiling it and then passing it to TclExecuteByteCode. + * + * Results: + * The return value is one of the return codes defined in tcl.h (such as + * TCL_OK), and interp->objResultPtr refers to a Tcl object that either + * contains the result of executing the code or an error message. + * + * Side effects: + * Almost certainly, depending on the ByteCode's instructions. + * + *---------------------------------------------------------------------- + */ + +int +TclCompEvalObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + const CmdFrame *invoker, + int word) +{ + register Interp *iPtr = (Interp *) interp; + register ByteCode *codePtr; /* Tcl Internal type of bytecode. */ + int result; + + /* + * Check that the interpreter is ready to execute scripts. Note that we + * manage the interp's runlevel here: it is a small white lie (maybe), but + * saves a ++/-- pair at each invocation. Amazingly enough, the impact on + * performance is noticeable. + */ + + iPtr->numLevels++; + if (TclInterpReady(interp) == TCL_ERROR) { + result = TCL_ERROR; + goto done; + } + + /* Compile objPtr to the byte code */ + codePtr = TclCompileObj(interp, objPtr, invoker, word); + + /* + * Increment the code's ref count while it is being executed. If + * afterwards no references to it remain, free the code. + */ + + codePtr->refCount++; + result = TclExecuteByteCode(interp, codePtr); + codePtr->refCount--; + if (codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } + + done: + iPtr->numLevels--; + return result; +} /* *---------------------------------------------------------------------- * * TclIncrObj -- @@ -1753,11 +1627,10 @@ 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"); } @@ -1775,10 +1648,41 @@ TclGetIntFromObj(interp, incrPtr, &type1); Tcl_AddErrorInfo(interp, "\n (reading increment)"); return TCL_ERROR; } + + if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { + long augend = *((const long *) ptr1); + long addend = *((const long *) ptr2); + long sum = augend + addend; + + /* + * Overflow when (augend and sum have different sign) and (augend and + * addend have the same sign). This is encapsulated in the Overflowing + * macro. + */ + + if (!Overflowing(augend, addend, sum)) { + TclSetLongObj(valuePtr, sum); + return TCL_OK; + } +#ifndef NO_WIDE_TYPE + { + Tcl_WideInt w1 = (Tcl_WideInt) augend; + Tcl_WideInt w2 = (Tcl_WideInt) addend; + + /* + * We know the sum value is outside the long range, so we use the + * macro form that doesn't range test again. + */ + + TclSetWideIntObj(valuePtr, w1 + w2); + return TCL_OK; + } +#endif + } if ((type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) { /* * Produce error message (reparse?!) */ @@ -1793,77 +1697,41 @@ TclGetIntFromObj(interp, incrPtr, &type1); Tcl_AddErrorInfo(interp, "\n (reading increment)"); return TCL_ERROR; } - if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) { +#ifndef NO_WIDE_TYPE + if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { Tcl_WideInt w1, w2, sum; - w1 = *((const Tcl_WideInt *)ptr1); - w2 = *((const Tcl_WideInt *)ptr2); + TclGetWideIntFromObj(NULL, valuePtr, &w1); + TclGetWideIntFromObj(NULL, incrPtr, &w2); sum = w1 + w2; /* * Check for overflow. */ if (!Overflowing(w1, w2, sum)) { - TclSetIntObj(valuePtr, sum); + Tcl_SetWideIntObj(valuePtr, sum); return TCL_OK; } } +#endif Tcl_TakeBignumFromObj(interp, valuePtr, &value); Tcl_GetBignumFromObj(interp, incrPtr, &incr); - err = mp_add(&value, &incr, &value); + mp_add(&value, &incr, &value); mp_clear(&incr); - if (err != MP_OKAY) { - return TCL_ERROR; - } Tcl_SetBignumObj(valuePtr, &value); return TCL_OK; } /* *---------------------------------------------------------------------- * - * ArgumentBCEnter -- - * - * This is a helper for TclNRExecuteByteCode/TEBCresume that encapsulates - * a code sequence that is fairly common in the code but *not* commonly - * called. - * - * Results: - * None - * - * Side effects: - * May register information about the bytecode in the command frame. - * - *---------------------------------------------------------------------- - */ - -static void -ArgumentBCEnter( - Tcl_Interp *interp, - ByteCode *codePtr, - TEBCdata *tdPtr, - const unsigned char *pc, - int objc, - Tcl_Obj **objv) -{ - int cmd; - - if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { - TclArgumentBCEnter(interp, objv, objc, codePtr, &tdPtr->cmdFrame, cmd, - pc - codePtr->codeStart); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclNRExecuteByteCode -- + * TclExecuteByteCode -- * * This procedure executes the instructions of a ByteCode structure. It * returns when a "done" instruction is executed or an error occurs. * * Results: @@ -1874,100 +1742,16 @@ * Side effects: * Almost certainly, depending on the ByteCode's instructions. * *---------------------------------------------------------------------- */ -#define bcFramePtr (&TD->cmdFrame) -#define initCatchTop ((ptrdiff_t *) (TD->stack-1)) -#define initTosPtr ((Tcl_Obj **) (initCatchTop+codePtr->maxExceptDepth)) -#define esPtr (iPtr->execEnvPtr->execStackPtr) int -TclNRExecuteByteCode( +TclExecuteByteCode( Tcl_Interp *interp, /* Token for command interpreter. */ ByteCode *codePtr) /* The bytecode sequence to interpret. */ { - Interp *iPtr = (Interp *) interp; - TEBCdata *TD; - int size = sizeof(TEBCdata) - 1 - + (codePtr->maxStackDepth + codePtr->maxExceptDepth) - * sizeof(void *); - int numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *); - - TclPreserveByteCode(codePtr); - - /* - * Reserve the stack, setup the TEBCdataPtr (TD) and CallFrame - * - * The execution uses a unified stack: first a TEBCdata, immediately - * above it a CmdFrame, then the catch stack, then the execution stack. - * - * Make sure the catch stack is large enough to hold the maximum number of - * catch commands that could ever be executing at the same time (this will - * be no more than the exception range array's depth). Make sure the - * execution stack is large enough to execute this ByteCode. - */ - - TD = (TEBCdata *) GrowEvaluationStack(iPtr->execEnvPtr, numWords, 0); - esPtr->tosPtr = initTosPtr; - - TD->codePtr = codePtr; - TD->catchTop = initCatchTop; - TD->auxObjList = NULL; - - /* - * TIP #280: Initialize the frame. Do not push it yet: it will be pushed - * every time that we call out from this TD, popped when we return to it. - */ - - bcFramePtr->type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) - ? TCL_LOCATION_PREBC : TCL_LOCATION_BC); - bcFramePtr->level = (iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level+1 : 1); - bcFramePtr->framePtr = iPtr->framePtr; - bcFramePtr->nextPtr = iPtr->cmdFramePtr; - bcFramePtr->nline = 0; - bcFramePtr->line = NULL; - bcFramePtr->litarg = NULL; - bcFramePtr->data.tebc.codePtr = codePtr; - bcFramePtr->data.tebc.pc = NULL; - bcFramePtr->cmdObj = NULL; - bcFramePtr->cmd = NULL; - bcFramePtr->len = 0; - -#ifdef TCL_COMPILE_STATS - iPtr->stats.numExecutions++; -#endif - - /* - * Test namespace-50.9 demonstrates the need for this call. - * Use a --enable-symbols=mem bug to see. - */ - - 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, - int result) -{ /* * Compiler cast directive - not a real variable. * Interp *iPtr = (Interp *) interp; */ #define iPtr ((Interp *) interp) @@ -1976,182 +1760,129 @@ * Check just the read-traced/write-traced bit of a variable. */ #define ReadTraced(varPtr) ((varPtr)->flags & VAR_TRACED_READ) #define WriteTraced(varPtr) ((varPtr)->flags & VAR_TRACED_WRITE) -#define UnsetTraced(varPtr) ((varPtr)->flags & VAR_TRACED_UNSET) - - /* - * Bottom of allocated stack holds the NR data - */ /* * Constants: variables that do not change during the execution, used - * sporadically: no special need for speed. - */ - - unsigned interruptCounter = 1; - /* Counter that is used to work out when to - * call Tcl_AsyncReady(). This must be 1 - * initially so that we call the async-check - * stanza early, otherwise there are command - * sequences that can make the interpreter - * busy-loop without an opportunity to - * recognise an interrupt. */ - const char *curInstName; -#ifdef TCL_COMPILE_DEBUG - int traceInstructions; /* Whether we are doing instruction-level - * tracing or not. */ -#endif - - Var *compiledLocals = iPtr->varFramePtr->compiledLocals; - Tcl_Obj **constants = &iPtr->execEnvPtr->constants[0]; - -#define LOCAL(i) (&compiledLocals[(i)]) -#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 */ + * sporadically. + */ + + ExecStack *esPtr; + Tcl_Obj **initTosPtr; /* Stack top at start of execution. */ + ptrdiff_t *initCatchTop; /* Catch stack top at start of execution. */ + Var *compiledLocals; + Namespace *namespacePtr; + CmdFrame *bcFramePtr; /* TIP #280: Structure for tracking lines. */ + Tcl_Obj **constants = &iPtr->execEnvPtr->constants[0]; /* * Globals: variables that store state, must remain valid at all times. */ - Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation + ptrdiff_t *catchTop; + register 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 */ + register unsigned char *pc = codePtr->codeStart; + /* The current program counter. */ + int instructionCount = 0; /* Counter that is used to work out when to + * call Tcl_AsyncReady() */ + Tcl_Obj *expandNestList = NULL; + int checkInterp = 0; /* Indicates when a check of interp readyness + * is necessary. Set by CACHE_STACK_INFO() */ + int curEvalFlags = iPtr->evalFlags; /* * Transfer variables - needed only between opcodes, but not while * executing an instruction. */ - int cleanup = PTR2INT(data[2]); + register int cleanup; Tcl_Obj *objResultPtr; - int checkInterp = 0; /* Indicates when a check of interp readyness - * is necessary. Set by CACHE_STACK_INFO() */ + + /* + * Result variable - needed only when going to checkForcatch or other + * error handlers; also used as local in some opcodes. + */ + + int result = TCL_OK; /* Return code returned after execution. */ /* * 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. + * NOTE: These are now 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 + int traceInstructions = (tclTraceExec == 3); char cmdNameBuf[21]; #endif + const char *curInstName = NULL; -#ifdef TCL_COMPILE_DEBUG - int starting = 1; - traceInstructions = (tclTraceExec == 3); -#endif + /* + * 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; - TEBC_DATA_DIG(); + /* + * The execution uses a unified stack: first the catch stack, immediately + * above it a CmdFrame, then the execution stack. + * + * Make sure the catch stack is large enough to hold the maximum number of + * catch commands that could ever be executing at the same time (this will + * be no more than the exception range array's depth). Make sure the + * execution stack is large enough to execute this ByteCode. + */ + + catchTop = initCatchTop = (ptrdiff_t *) ( + GrowEvaluationStack(iPtr->execEnvPtr, + (sizeof(CmdFrame) + sizeof(Tcl_Obj *) - 1)/sizeof(Tcl_Obj *) + + codePtr->maxExceptDepth + codePtr->maxStackDepth, 0) - 1); + bcFramePtr = (CmdFrame *) (initCatchTop + codePtr->maxExceptDepth + 1); + tosPtr = initTosPtr = ((Tcl_Obj **) (bcFramePtr + 1)) - 1; + esPtr = iPtr->execEnvPtr->execStackPtr; + + /* + * TIP #280: Initialize the frame. Do not push it yet. + */ + + bcFramePtr->type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) + ? TCL_LOCATION_PREBC : TCL_LOCATION_BC); + bcFramePtr->level = (iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level+1 : 1); + bcFramePtr->framePtr = iPtr->framePtr; + bcFramePtr->nextPtr = iPtr->cmdFramePtr; + bcFramePtr->nline = 0; + bcFramePtr->line = NULL; + + bcFramePtr->data.tebc.codePtr = codePtr; + bcFramePtr->data.tebc.pc = NULL; + bcFramePtr->cmd.str.cmd = NULL; + bcFramePtr->cmd.str.len = 0; #ifdef TCL_COMPILE_DEBUG - if (!pc && (tclTraceExec >= 2)) { + if (tclTraceExec >= 2) { PrintByteCodeInfo(codePtr); fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH); fflush(stdout); } #endif - if (!pc) { - /* bytecode is starting from scratch */ - pc = codePtr->codeStart; - - /* - * Reset the interp's result to avoid possible duplications of large - * objects [3c6e47363e], [781585], [804681], This can happen by start - * also in nested compiled blocks (enclosed in parent cycle). - * See else branch below for opposite handling by continuation/resume. - */ - - objPtr = iPtr->objResultPtr; - if (objPtr->refCount > 1) { - TclDecrRefCount(objPtr); - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - iPtr->objResultPtr = objPtr; - } - - goto cleanup0; - } else { - /* resume from invocation */ - CACHE_STACK_INFO(); - - NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr); - if (bcFramePtr->cmdObj) { - Tcl_DecrRefCount(bcFramePtr->cmdObj); - bcFramePtr->cmdObj = NULL; - bcFramePtr->cmd = NULL; - } - iPtr->cmdFramePtr = bcFramePtr->nextPtr; - if (iPtr->flags & INTERP_DEBUG_FRAME) { - 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; - } - - /* - * Push the call's object result and continue execution with the next - * instruction. - */ - - TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=", - objc, cmdNameBuf), Tcl_GetObjResult(interp)); - - /* - * Obtain and reset interp's result to avoid possible duplications of - * objects [Bug 781585]. We do not call Tcl_ResetResult to avoid any - * side effects caused by the resetting of errorInfo and errorCode - * [Bug 804681], which are not needed here. We chose instead to - * manipulate the interp's object result directly. - * - * Note that the result object is now in objResultPtr, it keeps the - * refCount it had in its role of iPtr->objResultPtr. - */ - - objResultPtr = Tcl_GetObjResult(interp); - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - iPtr->objResultPtr = objPtr; -#ifndef TCL_COMPILE_DEBUG - if (*pc == INST_POP) { - TclDecrRefCount(objResultPtr); - NEXT_INST_V(1, cleanup, 0); - } +#ifdef TCL_COMPILE_STATS + iPtr->stats.numExecutions++; #endif - NEXT_INST_V(0, cleanup, -1); - } + + namespacePtr = iPtr->varFramePtr->nsPtr; + compiledLocals = iPtr->varFramePtr->compiledLocals; + + /* + * Loop executing instructions until a "done" instruction, a TCL_RETURN, + * or some error. + */ + + goto cleanup0; /* * Targets for standard instruction endings; unrolled for speed in the * most frequent cases (instructions that consume up to two stack * elements). @@ -2158,95 +1889,117 @@ * * This used to be a "for(;;)" loop, with each instruction doing its own * cleanup. */ - cleanupV_pushObjResultPtr: - switch (cleanup) { - case 0: - *(++tosPtr) = (objResultPtr); - 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; - } - cleanup0: + { + Tcl_Obj *valuePtr; + + cleanupV_pushObjResultPtr: + switch (cleanup) { + case 0: + *(++tosPtr) = (objResultPtr); + goto cleanup0; + default: + cleanup -= 2; + while (cleanup--) { + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + } + case 2: + cleanup2_pushObjResultPtr: + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + case 1: + cleanup1_pushObjResultPtr: + valuePtr = OBJ_AT_TOS; + TclDecrRefCount(valuePtr); + } + OBJ_AT_TOS = objResultPtr; + goto cleanup0; + + cleanupV: + switch (cleanup) { + default: + cleanup -= 2; + while (cleanup--) { + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + } + case 2: + cleanup2: + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + case 1: + cleanup1: + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + case 0: + /* + * We really want to do nothing now, but this is needed for some + * compilers (SunPro CC). + */ + + break; + } + } + cleanup0: + +#ifdef TCL_COMPILE_DEBUG + /* + * Skip the stack depth check if an expansion is in progress. + */ + + ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, 0, + /*checkStack*/ expandNestList == NULL); + if (traceInstructions) { + fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH); + TclPrintInstruction(codePtr, pc); + fflush(stdout); + } +#endif /* TCL_COMPILE_DEBUG */ + +#ifdef TCL_COMPILE_STATS + iPtr->stats.instructionCount[*pc]++; +#endif /* * Check for asynchronous handlers [Bug 746722]; we do the check every - * ASYNC_CHECK_COUNT instructions. + * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1). */ - if ((--interruptCounter) == 0) { - interruptCounter = ASYNC_CHECK_COUNT; - DECACHE_STACK_INFO(); + if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) { + /* + * Check for asynchronous handlers [Bug 746722]; we do the check every + * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-<1). + */ + if (TclAsyncReady(iPtr)) { - result = Tcl_AsyncInvoke(interp, result); - if (result == TCL_ERROR) { - CACHE_STACK_INFO(); - goto gotError; + int localResult; + + DECACHE_STACK_INFO(); + localResult = Tcl_AsyncInvoke(interp, result); + CACHE_STACK_INFO(); + if (localResult == TCL_ERROR) { + result = localResult; + goto checkForCatch; } } - - if (TclCanceled(iPtr)) { - if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { - CACHE_STACK_INFO(); - goto gotError; - } - } - if (TclLimitReady(iPtr->limit)) { - if (Tcl_LimitCheck(interp) == TCL_ERROR) { - CACHE_STACK_INFO(); - goto gotError; + int localResult; + + DECACHE_STACK_INFO(); + localResult = Tcl_LimitCheck(interp); + CACHE_STACK_INFO(); + if (localResult == TCL_ERROR) { + result = localResult; + goto checkForCatch; } } - CACHE_STACK_INFO(); } + + TCL_DTRACE_INST_NEXT(); /* * These two instructions account for 26% of all instructions (according * to measurements on tclbench by Ben Vitale * [http://www.cs.toronto.edu/syslab/pubs/tcl2005-vitale-zaleski.pdf] @@ -2253,66 +2006,17 @@ * Resolving them before the switch reduces the cost of branch * mispredictions, seems to improve runtime by 5% to 15%, and (amazingly!) * reduces total obj size. */ - inst = *pc; - - peepholeStart: -#ifdef TCL_COMPILE_STATS - iPtr->stats.instructionCount[*pc]++; -#endif - -#ifdef TCL_COMPILE_DEBUG - /* - * Skip the stack depth check if an expansion is in progress. - */ - - CHECK_STACK(); - if (traceInstructions) { - fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH); - TclPrintInstruction(codePtr, pc); - fflush(stdout); - } -#endif /* TCL_COMPILE_DEBUG */ - - TCL_DTRACE_INST_NEXT(); - - if (inst == INST_LOAD_SCALAR1) { + if (*pc == INST_LOAD_SCALAR1) { goto instLoadScalar1; - } else if (inst == INST_PUSH1) { - PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]); - TRACE_WITH_OBJ(("%u => ", TclGetUInt1AtPtr(pc+1)), OBJ_AT_TOS); - inst = *(pc += 2); - goto peepholeStart; - } else if (inst == INST_START_CMD) { - /* - * Peephole: do not run INST_START_CMD, just skip it - */ - - iPtr->cmdCount += TclGetUInt4AtPtr(pc+5); - if (checkInterp) { - if (((codePtr->compileEpoch != iPtr->compileEpoch) || - (codePtr->nsEpoch != iPtr->varFramePtr->nsPtr->resolverEpoch)) && - !(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { - goto instStartCmdFailed; - } - checkInterp = 0; - } - inst = *(pc += 9); - goto peepholeStart; - } else if (inst == INST_NOP) { -#ifndef TCL_COMPILE_DEBUG - while (inst == INST_NOP) -#endif - { - inst = *++pc; - } - goto peepholeStart; - } - - switch (inst) { + } else if (*pc == INST_PUSH1) { + goto instPush1Peephole; + } + + switch (*pc) { case INST_SYNTAX: case INST_RETURN_IMM: { int code = TclGetInt4AtPtr(pc+1); int level = TclGetUInt4AtPtr(pc+5); @@ -2321,213 +2025,45 @@ */ TRACE(("%u %u => ", code, level)); result = TclProcessReturn(interp, code, level, OBJ_AT_TOS); if (result == TCL_OK) { - TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")\n", + TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")", O2S(objResultPtr))); NEXT_INST_F(9, 1, 0); - } - Tcl_SetObjResult(interp, OBJ_UNDER_TOS); - if (*pc == INST_SYNTAX) { - iPtr->flags &= ~ERR_ALREADY_LOGGED; - } - cleanup = 2; - TRACE_APPEND(("\n")); - goto processExceptionReturn; + } else { + Tcl_SetObjResult(interp, OBJ_UNDER_TOS); + if (*pc == INST_SYNTAX) { + iPtr->flags &= ~ERR_ALREADY_LOGGED; + } + cleanup = 2; + goto processExceptionReturn; + } } case INST_RETURN_STK: TRACE(("=> ")); objResultPtr = POP_OBJECT(); result = Tcl_SetReturnOptions(interp, OBJ_AT_TOS); + Tcl_DecrRefCount(OBJ_AT_TOS); + OBJ_AT_TOS = objResultPtr; if (result == TCL_OK) { - Tcl_DecrRefCount(OBJ_AT_TOS); - OBJ_AT_TOS = objResultPtr; - TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")\n", + TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")", O2S(objResultPtr))); NEXT_INST_F(1, 0, 0); - } else if (result == TCL_ERROR) { - /* - * BEWARE! Must do this in this order, because an error in the - * option dictionary overrides the result (and can be verified by - * test). - */ - - Tcl_SetObjResult(interp, objResultPtr); - Tcl_SetReturnOptions(interp, OBJ_AT_TOS); - Tcl_DecrRefCount(OBJ_AT_TOS); - OBJ_AT_TOS = objResultPtr; - } else { - Tcl_DecrRefCount(OBJ_AT_TOS); - OBJ_AT_TOS = objResultPtr; - Tcl_SetObjResult(interp, objResultPtr); - } - cleanup = 1; - TRACE_APPEND(("\n")); - goto processExceptionReturn; - - { - CoroutineData *corPtr; - int yieldParameter; - - case INST_YIELD: - corPtr = iPtr->execEnvPtr->corPtr; - TRACE(("%.30s => ", O2S(OBJ_AT_TOS))); - if (!corPtr) { - TRACE_APPEND(("ERROR: yield outside coroutine\n")); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "yield can only be called in a coroutine", -1)); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", - NULL); - CACHE_STACK_INFO(); - goto gotError; - } - -#ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { - if (traceInstructions) { - TRACE_APPEND(("YIELD...\n")); - } else { - fprintf(stdout, "%d: (%u) yielding value \"%.30s\"\n", - iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), - Tcl_GetString(OBJ_AT_TOS)); - } - fflush(stdout); - } -#endif - yieldParameter = 0; - Tcl_SetObjResult(interp, OBJ_AT_TOS); - goto doYield; - - case INST_YIELD_TO_INVOKE: - corPtr = iPtr->execEnvPtr->corPtr; - valuePtr = OBJ_AT_TOS; - if (!corPtr) { - TRACE(("[%.30s] => ERROR: yield outside coroutine\n", - O2S(valuePtr))); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "yieldto can only be called in a coroutine", -1)); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", - NULL); - CACHE_STACK_INFO(); - goto gotError; - } - if (((Namespace *)TclGetCurrentNamespace(interp))->flags & NS_DYING) { - TRACE(("[%.30s] => ERROR: yield in deleted\n", - O2S(valuePtr))); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "yieldto called in deleted namespace", -1)); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED", - NULL); - CACHE_STACK_INFO(); - goto gotError; - } - -#ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { - if (traceInstructions) { - TRACE(("[%.30s] => YIELD...\n", O2S(valuePtr))); - } else { - /* FIXME: What is the right thing to trace? */ - fprintf(stdout, "%d: (%u) yielding to [%.30s]\n", - iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), - TclGetString(valuePtr)); - } - fflush(stdout); - } -#endif - - /* - * Install a tailcall record in the caller and continue with the - * yield. The yield is switched into multi-return mode (via the - * 'yieldParameter'). - */ - - Tcl_IncrRefCount(valuePtr); - iPtr->execEnvPtr = corPtr->callerEEPtr; - TclSetTailcall(interp, valuePtr); - iPtr->execEnvPtr = corPtr->eePtr; - yieldParameter = (PTR2INT(NULL)+1); /*==CORO_ACTIVATE_YIELDM*/ - - doYield: - /* TIP #280: Record the last piece of info needed by - * 'TclGetSrcInfoForPc', and push the frame. - */ - - bcFramePtr->data.tebc.pc = (char *) pc; - iPtr->cmdFramePtr = bcFramePtr; - - if (iPtr->flags & INTERP_DEBUG_FRAME) { - ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); - } - - pc++; - cleanup = 1; - TEBC_YIELD(); - TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, - INT2PTR(yieldParameter), NULL, NULL); - return TCL_OK; - } - - case INST_TAILCALL: { - Tcl_Obj *listPtr, *nsObjPtr; - - opnd = TclGetUInt1AtPtr(pc+1); - - if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { - TRACE(("%d => ERROR: tailcall in non-proc context\n", opnd)); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "tailcall can only be called from a proc or lambda", -1)); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL); - CACHE_STACK_INFO(); - goto gotError; - } - -#ifdef TCL_COMPILE_DEBUG - /* FIXME: What is the right thing to trace? */ - { - int i; - - TRACE(("%d [", opnd)); - for (i=opnd-1 ; i>=0 ; i--) { - TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_DEPTH(i)))); - if (i > 0) { - TRACE_APPEND((" ")); - } - } - TRACE_APPEND(("] => RETURN...")); - } -#endif - - /* - * Push the evaluation of the called command into the NR callback - * stack. - */ - - listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1)); - nsObjPtr = Tcl_NewStringObj(iPtr->varFramePtr->nsPtr->fullName, -1); - TclListObjSetElement(interp, listPtr, 0, nsObjPtr); - if (iPtr->varFramePtr->tailcallPtr) { - Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr); - } - iPtr->varFramePtr->tailcallPtr = listPtr; - - result = TCL_RETURN; - cleanup = opnd; - goto processExceptionReturn; - } + } else { + Tcl_SetObjResult(interp, objResultPtr); + cleanup = 1; + 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) */ + Tcl_Obj *objPtr; TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS); objPtr = POP_OBJECT(); TclDecrRefCount(objPtr); goto abnormalReturn; } @@ -2545,137 +2081,268 @@ if (traceInstructions) { fprintf(stdout, "\n"); } #endif goto checkForCatch; + } else { + (void) POP_OBJECT(); + goto abnormalReturn; } - (void) POP_OBJECT(); - goto abnormalReturn; + + case INST_PUSH1: + instPush1Peephole: + PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]); + TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), OBJ_AT_TOS); + pc += 2; +#if !defined(TCL_COMPILE_DEBUG) + /* + * Runtime peephole optimisation: check if we are pushing again. + */ + + if (*pc == INST_PUSH1) { + TCL_DTRACE_INST_NEXT(); + goto instPush1Peephole; + } +#endif + NEXT_INST_F(0, 0, 0); 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: + case INST_POP: { + Tcl_Obj *valuePtr; + TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS); - objPtr = POP_OBJECT(); - TclDecrRefCount(objPtr); - NEXT_INST_F(1, 0, 0); - break; + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + + /* + * Runtime peephole optimisation: an INST_POP is scheduled at the end + * of most commands. If the next instruction is an INST_START_CMD, + * fall through to it. + */ + + pc++; +#if !defined(TCL_COMPILE_DEBUG) + if (*pc == INST_START_CMD) { + TCL_DTRACE_INST_NEXT(); + goto instStartCmdPeephole; + } +#endif + NEXT_INST_F(0, 0, 0); + } + + case INST_START_CMD: +#if !defined(TCL_COMPILE_DEBUG) + instStartCmdPeephole: +#endif + /* + * Remark that if the interpreter is marked for deletion its + * compileEpoch is modified, so that the epoch check also verifies + * that the interp is not deleted. If no outside call has been made + * since the last check, it is safe to omit the check. + */ + + iPtr->cmdCount += TclGetUInt4AtPtr(pc+5); + if (!checkInterp) { + instStartCmdOK: + NEXT_INST_F(9, 0, 0); + } else if (((codePtr->compileEpoch == iPtr->compileEpoch) + && (codePtr->nsEpoch == namespacePtr->resolverEpoch)) + || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { + checkInterp = 0; + goto instStartCmdOK; + } else { + const char *bytes; + int length, opnd; + Tcl_Obj *newObjResultPtr; + + bytes = GetSrcInfoForPc(pc, codePtr, &length); + DECACHE_STACK_INFO(); + result = Tcl_EvalEx(interp, bytes, length, 0); + CACHE_STACK_INFO(); + if (result != TCL_OK) { + cleanup = 0; + if (result == TCL_ERROR) { + /* + * Tcl_EvalEx already did the task of logging + * the error to the stack trace for us, so set + * a flag to prevent the TEBC exception handling + * machinery from trying to do it again. + * Tcl Bug 2037338. See test execute-8.4. + */ + iPtr->flags |= ERR_ALREADY_LOGGED; + } + goto processExceptionReturn; + } + opnd = TclGetUInt4AtPtr(pc+1); + objResultPtr = Tcl_GetObjResult(interp); + TclNewObj(newObjResultPtr); + Tcl_IncrRefCount(newObjResultPtr); + iPtr->objResultPtr = newObjResultPtr; + NEXT_INST_V(opnd, 0, -1); + } case INST_DUP: objResultPtr = OBJ_AT_TOS; TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); - break; - case INST_OVER: + case INST_OVER: { + int opnd; + opnd = TclGetUInt4AtPtr(pc+1); objResultPtr = OBJ_AT_DEPTH(opnd); - TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); + TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(5, 0, 1); - break; + } case INST_REVERSE: { + int opnd; Tcl_Obj **a, **b; opnd = TclGetUInt4AtPtr(pc+1); a = tosPtr-(opnd-1); b = tosPtr; while (a OK\n", opnd)); NEXT_INST_F(5, 0, 0); } - break; - case INST_STR_CONCAT1: + case INST_CONCAT1: { + int opnd, length, appendLen = 0; + char *bytes, *p; + Tcl_Obj **currPtr; 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; + + /* + * Compute the length to be appended. + */ + + for (currPtr=&OBJ_AT_DEPTH(opnd-2); + appendLen >= 0 && currPtr<=&OBJ_AT_TOS; currPtr++) { + bytes = TclGetStringFromObj(*currPtr, &length); + if (bytes != NULL) { + appendLen += length; + } } + + if (appendLen < 0) { + /* TODO: convert panic to error ? */ + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + + /* + * If nothing is to be appended, just return the first object by + * dropping all the others from the stack; this saves both the + * computation and copy of the string rep of the first object, + * enabling the fast '$x[set x {}]' idiom for 'K $x [set x {}]'. + */ + + if (appendLen == 0) { + TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); + NEXT_INST_V(2, (opnd-1), 0); + } + + /* + * If the first object is shared, we need a new obj for the result; + * otherwise, we can reuse the first object. In any case, make sure it + * has enough room to accomodate all the concatenated bytes. Note that + * if it is unshared its bytes are copied by ckrealloc, so that we set + * the loop parameters to avoid copying them again: p points to the + * end of the already copied bytes, currPtr to the second object. + */ + + objResultPtr = OBJ_AT_DEPTH(opnd-1); + bytes = TclGetStringFromObj(objResultPtr, &length); + if (length + appendLen < 0) { + /* TODO: convert panic to error ? */ + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } +#if !defined(TCL_COMPILE_DEBUG) + if (bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) { + TclFreeIntRep(objResultPtr); + objResultPtr->typePtr = NULL; + objResultPtr->bytes = ckrealloc(bytes, (length + appendLen + 1)); + objResultPtr->length = length + appendLen; + p = TclGetString(objResultPtr) + length; + currPtr = &OBJ_AT_DEPTH(opnd - 2); + } else { +#endif + p = (char *) ckalloc((unsigned) (length + appendLen + 1)); + TclNewObj(objResultPtr); + objResultPtr->bytes = p; + objResultPtr->length = length + appendLen; + currPtr = &OBJ_AT_DEPTH(opnd - 1); +#if !defined(TCL_COMPILE_DEBUG) + } +#endif + + /* + * Append the remaining characters. + */ + + for (; currPtr <= &OBJ_AT_TOS; currPtr++) { + bytes = TclGetStringFromObj(*currPtr, &length); + if (bytes != NULL) { + memcpy(p, bytes, (size_t) length); + p += length; + } + } + *p = '\0'; 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 + } + + case INST_EXPAND_START: { + /* + * Push an element to the expandNestList. 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 Tcl_Alloc. This also abuses the Tcl_Obj structure, as + * 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). */ + + Tcl_Obj *objPtr; 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)); + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) CURR_DEPTH; + objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) expandNestList; + expandNestList = objPtr; 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. - */ - - CLANG_ASSERT(auxObjList); - objc = CURR_DEPTH - PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2); - POP_TAUX_OBJ(); -#ifdef TCL_COMPILE_DEBUG - /* Ugly abuse! */ - starting = 1; -#endif - TRACE(("=> drop %d items\n", objc)); - NEXT_INST_V(1, objc, 0); + } case INST_EXPAND_STKTOP: { - int i; + int objc, length, i; + Tcl_Obj **objv, *valuePtr; ptrdiff_t moved; /* * Make sure that the element at stackTop is a list; if not, just * leave with an error. Note that the element from the expand list * will be removed at checkForCatch. */ - objPtr = OBJ_AT_TOS; - TRACE(("\"%.30s\" => ", O2S(objPtr))); - if (TclListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; + valuePtr = OBJ_AT_TOS; + if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK){ + TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), + Tcl_GetObjResult(interp)); + result = TCL_ERROR; + goto checkForCatch; } (void) POP_OBJECT(); /* * Make sure there is enough room in the stack to expand this list @@ -2682,30 +2349,26 @@ * *and* process the rest of the command (at least up to the next * argument expansion or command end). The operand is the current * stack depth, as seen by the compiler. */ - auxObjList->length += objc - 1; - if ((objc > 1) && (auxObjList->length > 0)) { - length = auxObjList->length /* Total expansion room we need */ - + codePtr->maxStackDepth /* Beyond the original max */ - - CURR_DEPTH; /* Relative to where we are */ - DECACHE_STACK_INFO(); - moved = GrowEvaluationStack(iPtr->execEnvPtr, length, 1) - - (Tcl_Obj **) TD; - if (moved) { - /* - * Change the global data to point to the new stack: move the - * TEBCdataPtr TD, recompute the position of every other - * stack-allocated parameter, update the stack pointers. - */ - - TD = (TEBCdata *) (((Tcl_Obj **)TD) + moved); - - catchTop += moved; - tosPtr += moved; - } + length = objc + (codePtr->maxStackDepth - TclGetInt4AtPtr(pc+1)); + DECACHE_STACK_INFO(); + moved = (GrowEvaluationStack(iPtr->execEnvPtr, length, 1) - 1) + - (Tcl_Obj **) initCatchTop; + + if (moved) { + /* + * Change the global data to point to the new stack. + */ + + initCatchTop += moved; + catchTop += moved; + bcFramePtr = (CmdFrame *) (initCatchTop + codePtr->maxExceptDepth + 1); + initTosPtr += moved; + tosPtr += moved; + esPtr = iPtr->execEnvPtr->execStackPtr; } /* * Expand the list at stacktop onto the stack; free the list. Knowing * that it has a freeIntRepProc we use Tcl_DecrRefCount(). @@ -2713,63 +2376,42 @@ for (i = 0; i < objc; i++) { PUSH_OBJECT(objv[i]); } - TRACE_APPEND(("OK\n")); - Tcl_DecrRefCount(objPtr); + Tcl_DecrRefCount(valuePtr); 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)); + int objc, pcAdjustment; case INST_INVOKE_EXPANDED: - CLANG_ASSERT(auxObjList); - objc = CURR_DEPTH - PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2); - POP_TAUX_OBJ(); + { + Tcl_Obj *objPtr = expandNestList; + + expandNestList = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2; + objc = CURR_DEPTH + - (ptrdiff_t) objPtr->internalRep.twoPtrValue.ptr1; + TclDecrRefCount(objPtr); + } + if (objc) { pcAdjustment = 1; goto doInvocation; - } - - /* - * Nothing was expanded, return {}. - */ - - TclNewObj(objResultPtr); - NEXT_INST_F(1, 0, 1); - break; + } else { + /* + * Nothing was expanded, return {}. + */ + + TclNewObj(objResultPtr); + NEXT_INST_F(1, 0, 1); + } case INST_INVOKE_STK4: objc = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; goto doInvocation; @@ -2777,129 +2419,285 @@ case INST_INVOKE_STK1: objc = TclGetUInt1AtPtr(pc+1); pcAdjustment = 2; doInvocation: - objv = &OBJ_AT_DEPTH(objc-1); - cleanup = objc; - -#ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { - int i; - - if (traceInstructions) { - strncpy(cmdNameBuf, TclGetString(objv[0]), 20); - TRACE(("%u => call ", objc)); - } else { - fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels, - (unsigned)(pc - codePtr->codeStart)); - } - for (i = 0; i < objc; i++) { - TclPrintObject(stdout, objv[i], 15); - fprintf(stdout, " "); - } - fprintf(stdout, "\n"); - fflush(stdout); - } -#endif /*TCL_COMPILE_DEBUG*/ - - /* - * Finally, let TclEvalObjv handle the command. - * - * TIP #280: Record the last piece of info needed by - * 'TclGetSrcInfoForPc', and push the frame. - */ - - bcFramePtr->data.tebc.pc = (char *) pc; - iPtr->cmdFramePtr = bcFramePtr; - - if (iPtr->flags & INTERP_DEBUG_FRAME) { - ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); - } - - 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; -#ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { - int i; - - if (traceInstructions) { - strncpy(cmdNameBuf, TclGetString(objv[0]), 20); - TRACE(("%u => call (implementation %s) ", objc, O2S(objPtr))); - } else { - fprintf(stdout, - "%d: (%u) invoking (using implementation %s) ", - iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), - O2S(objPtr)); - } - for (i = 0; i < objc; i++) { - if (i < opnd) { - fprintf(stdout, "<"); - TclPrintObject(stdout, objv[i], 15); - fprintf(stdout, ">"); - } else { - TclPrintObject(stdout, objv[i], 15); - } - fprintf(stdout, " "); - } - fprintf(stdout, "\n"); - fflush(stdout); - } -#endif /*TCL_COMPILE_DEBUG*/ - - bcFramePtr->data.tebc.pc = (char *) pc; - iPtr->cmdFramePtr = bcFramePtr; - if (iPtr->flags & INTERP_DEBUG_FRAME) { - ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); - } - - TclInitRewriteEnsemble(interp, opnd, 1, objv); - - { - Tcl_Obj *copyPtr = Tcl_NewListObj(objc - opnd + 1, NULL); - - Tcl_ListObjAppendElement(NULL, copyPtr, objPtr); - Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0, - objc - opnd, objv + opnd); - Tcl_DecrRefCount(objPtr); - objPtr = copyPtr; - } - - DECACHE_STACK_INFO(); - pc += 6; - TEBC_YIELD(); - - TclMarkTailcall(interp); - TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); - Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv); - TclNRAddCallback(interp, TclNRReleaseValues, objPtr, NULL, NULL, NULL); - return TclNREvalObjv(interp, objc, objv, TCL_EVAL_INVOKE, NULL); - - /* - * ----------------------------------------------------------------- + { + Tcl_Obj **objv = &OBJ_AT_DEPTH(objc-1); + +#ifdef TCL_COMPILE_DEBUG + if (tclTraceExec >= 2) { + int i; + + if (traceInstructions) { + strncpy(cmdNameBuf, TclGetString(objv[0]), 20); + TRACE(("%u => call ", objc)); + } else { + fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels, + (unsigned)(pc - codePtr->codeStart)); + } + for (i = 0; i < objc; i++) { + TclPrintObject(stdout, objv[i], 15); + fprintf(stdout, " "); + } + fprintf(stdout, "\n"); + fflush(stdout); + } +#endif /*TCL_COMPILE_DEBUG*/ + + /* + * Reset the instructionCount variable, since we're about to check + * for async stuff anyway while processing TclEvalObjvInternal. + */ + + instructionCount = 1; + + /* + * Finally, let TclEvalObjvInternal handle the command. + * + * TIP #280: Record the last piece of info needed by + * 'TclGetSrcInfoForPc', and push the frame. + */ + + bcFramePtr->data.tebc.pc = (char *) pc; + iPtr->cmdFramePtr = bcFramePtr; + if (iPtr->flags & INTERP_DEBUG_FRAME) { + TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, + codePtr, bcFramePtr, pc - codePtr->codeStart); + } + DECACHE_STACK_INFO(); + result = TclEvalObjvInternal(interp, objc, objv, + /* call from TEBC */(char *) -1, -1, 0); + CACHE_STACK_INFO(); + if (iPtr->flags & INTERP_DEBUG_FRAME) { + TclArgumentBCRelease((Tcl_Interp *) iPtr, objv, objc, + codePtr, pc - codePtr->codeStart); + } + iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; + + if (result == TCL_OK) { + Tcl_Obj *objPtr; + + /* + * Push the call's object result and continue execution with + * the next instruction. + */ + + TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=", + objc, cmdNameBuf), Tcl_GetObjResult(interp)); + + objResultPtr = Tcl_GetObjResult(interp); + + /* + * Reset the interp's result to avoid possible duplications of + * large objects [Bug 781585]. We do not call Tcl_ResetResult + * to avoid any side effects caused by the resetting of + * errorInfo and errorCode [Bug 804681], which are not needed + * here. We chose instead to manipulate the interp's object + * result directly. + * + * Note that the result object is now in objResultPtr, it + * keeps the refCount it had in its role of + * iPtr->objResultPtr. + */ + + TclNewObj(objPtr); + Tcl_IncrRefCount(objPtr); + iPtr->objResultPtr = objPtr; +#ifndef TCL_COMPILE_DEBUG + if (*(pc+pcAdjustment) == INST_POP) { + TclDecrRefCount(objResultPtr); + NEXT_INST_V((pcAdjustment+1), objc, 0); + } +#endif + NEXT_INST_V(pcAdjustment, objc, -1); + } else { + cleanup = objc; + goto processExceptionReturn; + } + } + +#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. + */ + + int opnd, numArgs; + Tcl_Obj *objPtr; + + opnd = TclGetUInt1AtPtr(pc+1); + if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) { + TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd)); + Tcl_Panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd); + } + + objPtr = Tcl_NewStringObj("::tcl::mathfunc::", 17); + Tcl_AppendToObj(objPtr, tclBuiltinFuncTable[opnd].name, -1); + + /* + * Only 0, 1 or 2 args. + */ + + numArgs = tclBuiltinFuncTable[opnd].numArgs; + if (numArgs == 0) { + PUSH_OBJECT(objPtr); + } else if (numArgs == 1) { + Tcl_Obj *tmpPtr1 = POP_OBJECT(); + PUSH_OBJECT(objPtr); + PUSH_OBJECT(tmpPtr1); + Tcl_DecrRefCount(tmpPtr1); + } else { + Tcl_Obj *tmpPtr1, *tmpPtr2; + 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]. + */ + + Tcl_Obj *tmpPtr, *objPtr; + + /* + * Number of arguments. The function name is the 0-th argument. + */ + + objc = TclGetUInt1AtPtr(pc+1); + + objPtr = OBJ_AT_DEPTH(objc-1); + tmpPtr = Tcl_NewStringObj("::tcl::mathfunc::", 17); + 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("TclExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found"); + case INST_CALL_FUNC1: + Tcl_Panic("TclExecuteByteCode: obsolete INST_CALL_FUNC1 found"); +#endif + } + + case INST_EVAL_STK: { + /* + * Note to maintainers: it is important that INST_EVAL_STK pop its + * argument from the stack before jumping to checkForCatch! DO NOT + * OPTIMISE! + */ + + Tcl_Obj *objPtr = OBJ_AT_TOS; + + DECACHE_STACK_INFO(); + + /* + * TIP #280: The invoking context is left NULL for a dynamically + * constructed command. We cannot match its lines to the outer + * context. + */ + + result = TclCompEvalObj(interp, objPtr, NULL, 0); + CACHE_STACK_INFO(); + if (result == TCL_OK) { + /* + * Normal return; push the eval's object result. + */ + + objResultPtr = Tcl_GetObjResult(interp); + TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), + Tcl_GetObjResult(interp)); + + /* + * Reset the interp's result to avoid possible duplications of + * large objects [Bug 781585]. We do not call Tcl_ResetResult to + * avoid any side effects caused by the resetting of errorInfo and + * errorCode [Bug 804681], which are not needed here. We chose + * instead to manipulate the interp's object result directly. + * + * Note that the result object is now in objResultPtr, it keeps + * the refCount it had in its role of iPtr->objResultPtr. + */ + + TclNewObj(objPtr); + Tcl_IncrRefCount(objPtr); + iPtr->objResultPtr = objPtr; + NEXT_INST_F(1, 1, -1); + } else { + cleanup = 1; + goto processExceptionReturn; + } + } + + case INST_EXPR_STK: { + Tcl_Obj *objPtr, *valuePtr; + + objPtr = OBJ_AT_TOS; + DECACHE_STACK_INFO(); + /*Tcl_ResetResult(interp);*/ + result = Tcl_ExprObj(interp, objPtr, &valuePtr); + CACHE_STACK_INFO(); + if (result == TCL_OK) { + objResultPtr = valuePtr; + TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr); + NEXT_INST_F(1, 1, -1); /* Already has right refct. */ + } else { + TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)), + Tcl_GetObjResult(interp)); + goto checkForCatch; + } + } + + /* + * --------------------------------------------------------- * Start of INST_LOAD instructions. * * WARNING: more 'goto' here than your doctor recommended! The different * instructions set the value of some variables and then jump to some * common execution code. */ + { + int opnd, pcAdjustment; + Tcl_Obj *part1Ptr, *part2Ptr; + Var *varPtr, *arrayPtr; + Tcl_Obj *objPtr; case INST_LOAD_SCALAR1: instLoadScalar1: opnd = TclGetUInt1AtPtr(pc+1); - varPtr = LOCAL(opnd); + varPtr = &(compiledLocals[opnd]); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } TRACE(("%u => ", opnd)); if (TclIsVarDirectReadable(varPtr)) { @@ -2917,11 +2715,11 @@ part1Ptr = part2Ptr = NULL; goto doCallPtrGetVar; case INST_LOAD_SCALAR4: opnd = TclGetUInt4AtPtr(pc+1); - varPtr = LOCAL(opnd); + varPtr = &(compiledLocals[opnd]); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } TRACE(("%u => ", opnd)); if (TclIsVarDirectReadable(varPtr)) { @@ -2949,11 +2747,11 @@ pcAdjustment = 2; doLoadArray: part1Ptr = NULL; part2Ptr = OBJ_AT_TOS; - arrayPtr = LOCAL(opnd); + arrayPtr = &(compiledLocals[opnd]); while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; } TRACE(("%u \"%.30s\" => ", opnd, O2S(part2Ptr))); if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)) { @@ -2969,12 +2767,14 @@ } } varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr, opnd); if (varPtr == NULL) { - TRACE_ERROR(interp); - goto gotError; + TRACE_APPEND(("ERROR: %.30s\n", + O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; } cleanup = 1; goto doCallPtrGetVar; case INST_LOAD_ARRAY_STK: @@ -2994,56 +2794,68 @@ doLoadStk: part1Ptr = objPtr; varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, "read", /*createPart1*/0, /*createPart2*/1, &arrayPtr); - if (!varPtr) { - TRACE_ERROR(interp); - goto gotError; - } - - if (TclIsVarDirectReadable2(varPtr, arrayPtr)) { - /* - * No errors, no traces: just get the value. - */ - - objResultPtr = varPtr->value.objPtr; - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(1, cleanup, 1); - } - pcAdjustment = 1; - opnd = -1; + if (varPtr) { + if (TclIsVarDirectReadable2(varPtr, arrayPtr)) { + /* + * No errors, no traces: just get the value. + */ + + objResultPtr = varPtr->value.objPtr; + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(1, cleanup, 1); + } + pcAdjustment = 1; + opnd = -1; + goto doCallPtrGetVar; + } else { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; + } doCallPtrGetVar: /* * There are either errors or the variable is traced: call * TclPtrGetVar to process fully. */ DECACHE_STACK_INFO(); - objResultPtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, + objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); - if (!objResultPtr) { - TRACE_ERROR(interp); - goto gotError; + if (objResultPtr) { + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(pcAdjustment, cleanup, 1); + } else { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(pcAdjustment, cleanup, 1); + } /* * End of INST_LOAD instructions. - * ----------------------------------------------------------------- + * --------------------------------------------------------- + */ + + /* + * --------------------------------------------------------- * Start of INST_STORE and related instructions. * * WARNING: more 'goto' here than your doctor recommended! The different * instructions set the value of some variables and then jump to somme * common execution code. */ { - int storeFlags, len; + int opnd, pcAdjustment, storeFlags; + Tcl_Obj *part1Ptr, *part2Ptr; + Var *varPtr, *arrayPtr; + Tcl_Obj *objPtr, *valuePtr; case INST_STORE_ARRAY4: opnd = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; goto doStoreArrayDirect; @@ -3053,11 +2865,11 @@ pcAdjustment = 2; doStoreArrayDirect: valuePtr = OBJ_AT_TOS; part2Ptr = OBJ_UNDER_TOS; - arrayPtr = LOCAL(opnd); + arrayPtr = &(compiledLocals[opnd]); TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, O2S(part2Ptr), O2S(valuePtr))); while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; } @@ -3084,44 +2896,43 @@ opnd = TclGetUInt1AtPtr(pc+1); pcAdjustment = 2; doStoreScalarDirect: valuePtr = OBJ_AT_TOS; - varPtr = LOCAL(opnd); + varPtr = &(compiledLocals[opnd]); TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - if (!TclIsVarDirectWritable(varPtr)) { - storeFlags = TCL_LEAVE_ERR_MSG; - part1Ptr = NULL; - goto doStoreScalar; - } - - /* - * No traces, no errors, plain 'set': we can safely inline. The value - * *will* be set to what's requested, so that the stack top remains - * pointing to the same Tcl_Obj. - */ - + if (TclIsVarDirectWritable(varPtr)) { doStoreVarDirect: - valuePtr = varPtr->value.objPtr; - if (valuePtr != NULL) { - TclDecrRefCount(valuePtr); - } - objResultPtr = OBJ_AT_TOS; - varPtr->value.objPtr = objResultPtr; + /* + * No traces, no errors, plain 'set': we can safely inline. The + * value *will* be set to what's requested, so that the stack top + * remains pointing to the same Tcl_Obj. + */ + + valuePtr = varPtr->value.objPtr; + if (valuePtr != NULL) { + TclDecrRefCount(valuePtr); + } + objResultPtr = OBJ_AT_TOS; + varPtr->value.objPtr = objResultPtr; #ifndef TCL_COMPILE_DEBUG - if (*(pc+pcAdjustment) == INST_POP) { - tosPtr--; - NEXT_INST_F((pcAdjustment+1), 0, 0); - } + if (*(pc+pcAdjustment) == INST_POP) { + tosPtr--; + NEXT_INST_F((pcAdjustment+1), 0, 0); + } #else - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); #endif - Tcl_IncrRefCount(objResultPtr); - NEXT_INST_F(pcAdjustment, 0, 0); + Tcl_IncrRefCount(objResultPtr); + NEXT_INST_F(pcAdjustment, 0, 0); + } + storeFlags = TCL_LEAVE_ERR_MSG; + part1Ptr = NULL; + goto doStoreScalar; case INST_LAPPEND_STK: valuePtr = OBJ_AT_TOS; /* value to append */ part2Ptr = NULL; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE @@ -3170,18 +2981,20 @@ O2S(part1Ptr), O2S(part2Ptr), O2S(valuePtr))); } #endif varPtr = TclObjLookupVarEx(interp, objPtr,part2Ptr, TCL_LEAVE_ERR_MSG, "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); - if (!varPtr) { - TRACE_ERROR(interp); - goto gotError; - } - cleanup = ((part2Ptr == NULL)? 2 : 3); - pcAdjustment = 1; - opnd = -1; - goto doCallPtrSetVar; + if (varPtr) { + cleanup = ((part2Ptr == NULL)? 2 : 3); + pcAdjustment = 1; + opnd = -1; + goto doCallPtrSetVar; + } else { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; + } case INST_LAPPEND_ARRAY4: opnd = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE @@ -3208,11 +3021,11 @@ goto doStoreArray; doStoreArray: valuePtr = OBJ_AT_TOS; part2Ptr = OBJ_UNDER_TOS; - arrayPtr = LOCAL(opnd); + arrayPtr = &(compiledLocals[opnd]); TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, O2S(part2Ptr), O2S(valuePtr))); while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; } @@ -3220,15 +3033,17 @@ part1Ptr = NULL; doStoreArrayDirectFailed: varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr, opnd); - if (!varPtr) { - TRACE_ERROR(interp); - goto gotError; + if (varPtr) { + goto doCallPtrSetVar; + } else { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; } - goto doCallPtrSetVar; case INST_LAPPEND_SCALAR4: opnd = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE @@ -3254,11 +3069,11 @@ storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); goto doStoreScalar; doStoreScalar: valuePtr = OBJ_AT_TOS; - varPtr = LOCAL(opnd); + varPtr = &(compiledLocals[opnd]); TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } cleanup = 1; @@ -3265,199 +3080,35 @@ arrayPtr = NULL; part1Ptr = part2Ptr = NULL; doCallPtrSetVar: DECACHE_STACK_INFO(); - objResultPtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, + objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, valuePtr, storeFlags, opnd); CACHE_STACK_INFO(); - if (!objResultPtr) { - TRACE_ERROR(interp); - goto gotError; - } + if (objResultPtr) { #ifndef TCL_COMPILE_DEBUG - if (*(pc+pcAdjustment) == INST_POP) { - NEXT_INST_V((pcAdjustment+1), cleanup, 0); - } + if (*(pc+pcAdjustment) == INST_POP) { + NEXT_INST_V((pcAdjustment+1), cleanup, 0); + } #endif - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(pcAdjustment, cleanup, 1); - - case INST_LAPPEND_LIST: - opnd = TclGetUInt4AtPtr(pc+1); - valuePtr = OBJ_AT_TOS; - varPtr = LOCAL(opnd); - cleanup = 1; - pcAdjustment = 5; - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); - if (TclListObjGetElements(interp, valuePtr, &objc, &objv) - != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } - if (TclIsVarDirectReadable(varPtr) - && TclIsVarDirectWritable(varPtr)) { - goto lappendListDirect; - } - arrayPtr = NULL; - part1Ptr = part2Ptr = NULL; - goto lappendListPtr; - - case INST_LAPPEND_LIST_ARRAY: - opnd = TclGetUInt4AtPtr(pc+1); - valuePtr = OBJ_AT_TOS; - part1Ptr = NULL; - part2Ptr = OBJ_UNDER_TOS; - arrayPtr = LOCAL(opnd); - cleanup = 2; - pcAdjustment = 5; - while (TclIsVarLink(arrayPtr)) { - arrayPtr = arrayPtr->value.linkPtr; - } - TRACE(("%u \"%.30s\" \"%.30s\" => ", - opnd, O2S(part2Ptr), O2S(valuePtr))); - if (TclListObjGetElements(interp, valuePtr, &objc, &objv) - != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } - if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr) - && !WriteTraced(arrayPtr)) { - varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); - if (varPtr && TclIsVarDirectReadable(varPtr) - && TclIsVarDirectWritable(varPtr)) { - goto lappendListDirect; - } - } - varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, - TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr, opnd); - if (varPtr == NULL) { - TRACE_ERROR(interp); - goto gotError; - } - goto lappendListPtr; - - case INST_LAPPEND_LIST_ARRAY_STK: - pcAdjustment = 1; - cleanup = 3; - valuePtr = OBJ_AT_TOS; - part2Ptr = OBJ_UNDER_TOS; /* element name */ - part1Ptr = OBJ_AT_DEPTH(2); /* array name */ - TRACE(("\"%.30s(%.30s)\" \"%.30s\" => ", - O2S(part1Ptr), O2S(part2Ptr), O2S(valuePtr))); - goto lappendList; - - case INST_LAPPEND_LIST_STK: - pcAdjustment = 1; - cleanup = 2; - valuePtr = OBJ_AT_TOS; - part2Ptr = NULL; - part1Ptr = OBJ_UNDER_TOS; /* variable name */ - TRACE(("\"%.30s\" \"%.30s\" => ", O2S(part1Ptr), O2S(valuePtr))); - goto lappendList; - - lappendListDirect: - objResultPtr = varPtr->value.objPtr; - if (TclListObjLength(interp, objResultPtr, &len) != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } - if (Tcl_IsShared(objResultPtr)) { - Tcl_Obj *newValue = Tcl_DuplicateObj(objResultPtr); - - TclDecrRefCount(objResultPtr); - varPtr->value.objPtr = objResultPtr = newValue; - Tcl_IncrRefCount(newValue); - } - if (Tcl_ListObjReplace(interp, objResultPtr, len, 0, objc, objv) - != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(pcAdjustment, cleanup, 1); - - lappendList: - opnd = -1; - if (TclListObjGetElements(interp, valuePtr, &objc, &objv) - != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } - DECACHE_STACK_INFO(); - varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, - TCL_LEAVE_ERR_MSG, "set", 1, 1, &arrayPtr); - CACHE_STACK_INFO(); - if (!varPtr) { - TRACE_ERROR(interp); - goto gotError; - } - - lappendListPtr: - if (TclIsVarInHash(varPtr)) { - VarHashRefCount(varPtr)++; - } - if (arrayPtr && TclIsVarInHash(arrayPtr)) { - VarHashRefCount(arrayPtr)++; - } - DECACHE_STACK_INFO(); - objResultPtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, - part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd); - CACHE_STACK_INFO(); - if (TclIsVarInHash(varPtr)) { - VarHashRefCount(varPtr)--; - } - if (arrayPtr && TclIsVarInHash(arrayPtr)) { - VarHashRefCount(arrayPtr)--; - } - - { - int createdNewObj = 0; - Tcl_Obj *valueToAssign; - - if (!objResultPtr) { - valueToAssign = valuePtr; - } else if (TclListObjLength(interp, objResultPtr, &len)!=TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } else { - if (Tcl_IsShared(objResultPtr)) { - valueToAssign = Tcl_DuplicateObj(objResultPtr); - createdNewObj = 1; - } else { - valueToAssign = objResultPtr; - } - if (Tcl_ListObjReplace(interp, valueToAssign, len, 0, - objc, objv) != TCL_OK) { - if (createdNewObj) { - TclDecrRefCount(valueToAssign); - } - goto errorInLappendListPtr; - } - } - DECACHE_STACK_INFO(); - Tcl_IncrRefCount(valueToAssign); - objResultPtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, - part2Ptr, valueToAssign, TCL_LEAVE_ERR_MSG, opnd); - TclDecrRefCount(valueToAssign); - CACHE_STACK_INFO(); - if (!objResultPtr) { - errorInLappendListPtr: - TRACE_ERROR(interp); - goto gotError; - } - } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(pcAdjustment, cleanup, 1); + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(pcAdjustment, cleanup, 1); + } else { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; + } } /* * End of INST_STORE and related instructions. - * ----------------------------------------------------------------- + * --------------------------------------------------------- + */ + + /* + * --------------------------------------------------------- * Start of INST_INCR instructions. * * WARNING: more 'goto' here than your doctor recommended! The different * instructions set the value of some variables and then jump to somme * common execution code. @@ -3464,13 +3115,18 @@ */ /*TODO: Consider more untangling here; merge with LOAD and STORE ? */ { - Tcl_Obj *incrPtr; + Tcl_Obj *objPtr, *incrPtr; + int opnd, pcAdjustment; +#ifndef NO_WIDE_TYPE Tcl_WideInt w; - long increment; +#endif + long i; + Tcl_Obj *part1Ptr, *part2Ptr; + Var *varPtr, *arrayPtr; case INST_INCR_SCALAR1: case INST_INCR_ARRAY1: case INST_INCR_ARRAY_STK: case INST_INCR_SCALAR_STK: @@ -3490,74 +3146,76 @@ } case INST_INCR_ARRAY_STK_IMM: case INST_INCR_SCALAR_STK_IMM: case INST_INCR_STK_IMM: - increment = TclGetInt1AtPtr(pc+1); - TclNewIntObj(incrPtr, increment); + i = TclGetInt1AtPtr(pc+1); + incrPtr = Tcl_NewIntObj(i); Tcl_IncrRefCount(incrPtr); pcAdjustment = 2; doIncrStk: if ((*pc == INST_INCR_ARRAY_STK_IMM) || (*pc == INST_INCR_ARRAY_STK)) { part2Ptr = OBJ_AT_TOS; objPtr = OBJ_UNDER_TOS; TRACE(("\"%.30s(%.30s)\" (by %ld) => ", - O2S(objPtr), O2S(part2Ptr), increment)); + O2S(objPtr), O2S(part2Ptr), i)); } else { part2Ptr = NULL; objPtr = OBJ_AT_TOS; - TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), increment)); + TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), i)); } part1Ptr = objPtr; opnd = -1; varPtr = TclObjLookupVarEx(interp, objPtr, part2Ptr, TCL_LEAVE_ERR_MSG, "read", 1, 1, &arrayPtr); - if (!varPtr) { - DECACHE_STACK_INFO(); - Tcl_AddErrorInfo(interp, - "\n (reading value of variable to increment)"); - CACHE_STACK_INFO(); - TRACE_ERROR(interp); + if (varPtr) { + cleanup = ((part2Ptr == NULL)? 1 : 2); + goto doIncrVar; + } else { + Tcl_AddObjErrorInfo(interp, + "\n (reading value of variable to increment)", -1); + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; Tcl_DecrRefCount(incrPtr); - goto gotError; + goto checkForCatch; } - cleanup = ((part2Ptr == NULL)? 1 : 2); - goto doIncrVar; case INST_INCR_ARRAY1_IMM: opnd = TclGetUInt1AtPtr(pc+1); - increment = TclGetInt1AtPtr(pc+2); - TclNewIntObj(incrPtr, increment); + i = TclGetInt1AtPtr(pc+2); + incrPtr = Tcl_NewIntObj(i); Tcl_IncrRefCount(incrPtr); pcAdjustment = 3; doIncrArray: part1Ptr = NULL; part2Ptr = OBJ_AT_TOS; - arrayPtr = LOCAL(opnd); + arrayPtr = &(compiledLocals[opnd]); cleanup = 1; while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; } - TRACE(("%u \"%.30s\" (by %ld) => ", opnd, O2S(part2Ptr), increment)); + TRACE(("%u \"%.30s\" (by %ld) => ", opnd, O2S(part2Ptr), i)); varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, "read", 1, 1, arrayPtr, opnd); - if (!varPtr) { - TRACE_ERROR(interp); + if (varPtr) { + goto doIncrVar; + } else { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; Tcl_DecrRefCount(incrPtr); - goto gotError; + goto checkForCatch; } - goto doIncrVar; case INST_INCR_SCALAR1_IMM: opnd = TclGetUInt1AtPtr(pc+1); - increment = TclGetInt1AtPtr(pc+2); + i = TclGetInt1AtPtr(pc+2); pcAdjustment = 3; cleanup = 0; - varPtr = LOCAL(opnd); + varPtr = &(compiledLocals[opnd]); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } if (TclIsVarDirectModifyable(varPtr)) { @@ -3564,88 +3222,127 @@ ClientData ptr; int type; objPtr = varPtr->value.objPtr; if (GetNumberFromObj(NULL, objPtr, &ptr, &type) == TCL_OK) { - if (type == TCL_NUMBER_INT) { - Tcl_WideInt augend = *((const Tcl_WideInt *)ptr); - Tcl_WideInt sum = augend + increment; - - /* - * Overflow when (augend and sum have different sign) and - * (augend and increment have the same sign). This is - * encapsulated in the Overflowing macro. - */ - - if (!Overflowing(augend, increment, sum)) { - TRACE(("%u %ld => ", opnd, increment)); - if (Tcl_IsShared(objPtr)) { - objPtr->refCount--; /* We know it's shared. */ - TclNewIntObj(objResultPtr, sum); - Tcl_IncrRefCount(objResultPtr); - varPtr->value.objPtr = objResultPtr; - } else { - objResultPtr = objPtr; - TclSetIntObj(objPtr, sum); - } - goto doneIncr; - } - w = (Tcl_WideInt)augend; - - TRACE(("%u %ld => ", opnd, increment)); - if (Tcl_IsShared(objPtr)) { - objPtr->refCount--; /* We know it's shared. */ - TclNewIntObj(objResultPtr, w + increment); - Tcl_IncrRefCount(objResultPtr); - varPtr->value.objPtr = objResultPtr; - } else { - objResultPtr = objPtr; - - /* - * We know the sum value is outside the long range; - * use macro form that doesn't range test again. - */ - - TclSetIntObj(objPtr, w+increment); - } - goto doneIncr; - } /* end if (type == TCL_NUMBER_INT) */ + if (type == TCL_NUMBER_LONG) { + long augend = *((const long *)ptr); + long sum = augend + i; + + /* + * Overflow when (augend and sum have different sign) and + * (augend and i have the same sign). This is encapsulated + * in the Overflowing macro. + */ + + if (!Overflowing(augend, i, sum)) { + TRACE(("%u %ld => ", opnd, i)); + if (Tcl_IsShared(objPtr)) { + objPtr->refCount--; /* We know it's shared. */ + TclNewLongObj(objResultPtr, sum); + Tcl_IncrRefCount(objResultPtr); + varPtr->value.objPtr = objResultPtr; + } else { + objResultPtr = objPtr; + TclSetLongObj(objPtr, sum); + } + goto doneIncr; + } +#ifndef NO_WIDE_TYPE + { + w = (Tcl_WideInt)augend; + + TRACE(("%u %ld => ", opnd, i)); + if (Tcl_IsShared(objPtr)) { + objPtr->refCount--; /* We know it's shared. */ + objResultPtr = Tcl_NewWideIntObj(w+i); + Tcl_IncrRefCount(objResultPtr); + varPtr->value.objPtr = objResultPtr; + } else { + objResultPtr = objPtr; + + /* + * We know the sum value is outside the long + * range; use macro form that doesn't range test + * again. + */ + + TclSetWideIntObj(objPtr, w+i); + } + goto doneIncr; + } +#endif + } /* end if (type == TCL_NUMBER_LONG) */ +#ifndef NO_WIDE_TYPE + if (type == TCL_NUMBER_WIDE) { + Tcl_WideInt sum; + w = *((const Tcl_WideInt *)ptr); + sum = w + i; + + /* + * Check for overflow. + */ + + if (!Overflowing(w, i, sum)) { + TRACE(("%u %ld => ", opnd, i)); + if (Tcl_IsShared(objPtr)) { + objPtr->refCount--; /* We know it's shared. */ + objResultPtr = Tcl_NewWideIntObj(sum); + Tcl_IncrRefCount(objResultPtr); + varPtr->value.objPtr = objResultPtr; + } else { + objResultPtr = objPtr; + + /* + * We *do not* know the sum value is outside the + * long range (wide + long can yield long); use + * the function call that checks range. + */ + + Tcl_SetWideIntObj(objPtr, sum); + } + goto doneIncr; + } + } +#endif } if (Tcl_IsShared(objPtr)) { objPtr->refCount--; /* We know it's shared */ objResultPtr = Tcl_DuplicateObj(objPtr); Tcl_IncrRefCount(objResultPtr); varPtr->value.objPtr = objResultPtr; } else { objResultPtr = objPtr; } - TclNewIntObj(incrPtr, increment); - if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) { - Tcl_DecrRefCount(incrPtr); - TRACE_ERROR(interp); - goto gotError; - } - Tcl_DecrRefCount(incrPtr); - goto doneIncr; + TclNewLongObj(incrPtr, i); + result = TclIncrObj(interp, objResultPtr, incrPtr); + Tcl_DecrRefCount(incrPtr); + if (result == TCL_OK) { + goto doneIncr; + } else { + TRACE_APPEND(("ERROR: %.30s\n", + O2S(Tcl_GetObjResult(interp)))); + goto checkForCatch; + } } /* * All other cases, flow through to generic handling. */ - TclNewIntObj(incrPtr, increment); + TclNewLongObj(incrPtr, i); Tcl_IncrRefCount(incrPtr); doIncrScalar: - varPtr = LOCAL(opnd); + varPtr = &(compiledLocals[opnd]); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } arrayPtr = NULL; part1Ptr = part2Ptr = NULL; cleanup = 0; - TRACE(("%u %s => ", opnd, TclGetString(incrPtr))); + TRACE(("%u %ld => ", opnd, i)); doIncrVar: if (TclIsVarDirectModifyable2(varPtr, arrayPtr)) { objPtr = varPtr->value.objPtr; if (Tcl_IsShared(objPtr)) { @@ -3654,25 +3351,30 @@ Tcl_IncrRefCount(objResultPtr); varPtr->value.objPtr = objResultPtr; } else { objResultPtr = objPtr; } - if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) { - Tcl_DecrRefCount(incrPtr); - TRACE_ERROR(interp); - goto gotError; - } - Tcl_DecrRefCount(incrPtr); - } else { - DECACHE_STACK_INFO(); - objResultPtr = TclPtrIncrObjVarIdx(interp, varPtr, arrayPtr, + result = TclIncrObj(interp, objResultPtr, incrPtr); + Tcl_DecrRefCount(incrPtr); + if (result == TCL_OK) { + goto doneIncr; + } else { + TRACE_APPEND(("ERROR: %.30s\n", + O2S(Tcl_GetObjResult(interp)))); + goto checkForCatch; + } + } else { + DECACHE_STACK_INFO(); + objResultPtr = TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, incrPtr, TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); Tcl_DecrRefCount(incrPtr); if (objResultPtr == NULL) { - TRACE_ERROR(interp); - goto gotError; + TRACE_APPEND(("ERROR: %.30s\n", + O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; } } doneIncr: TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); #ifndef TCL_COMPILE_DEBUG @@ -3683,19 +3385,25 @@ NEXT_INST_V(pcAdjustment, cleanup, 1); } /* * End of INST_INCR instructions. - * ----------------------------------------------------------------- + * --------------------------------------------------------- + */ + + /* + * --------------------------------------------------------- * Start of INST_EXIST instructions. */ + { + Tcl_Obj *part1Ptr, *part2Ptr; + Var *varPtr, *arrayPtr; - case INST_EXIST_SCALAR: - cleanup = 0; - pcAdjustment = 5; - opnd = TclGetUInt4AtPtr(pc+1); - varPtr = LOCAL(opnd); + case INST_EXIST_SCALAR: { + int opnd = TclGetUInt4AtPtr(pc+1); + + varPtr = &(compiledLocals[opnd]); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } TRACE(("%u => ", opnd)); if (ReadTraced(varPtr)) { @@ -3706,26 +3414,33 @@ if (TclIsVarUndefined(varPtr)) { TclCleanupVar(varPtr, NULL); varPtr = NULL; } } - goto afterExistsPeephole; - case INST_EXIST_ARRAY: - cleanup = 1; - pcAdjustment = 5; - opnd = TclGetUInt4AtPtr(pc+1); + /* + * Tricky! Arrays always exist. + */ + + objResultPtr = constants[!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1]; + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(5, 0, 1); + } + + case INST_EXIST_ARRAY: { + int opnd = TclGetUInt4AtPtr(pc+1); + part2Ptr = OBJ_AT_TOS; - arrayPtr = LOCAL(opnd); + arrayPtr = &(compiledLocals[opnd]); while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; } TRACE(("%u \"%.30s\" => ", opnd, O2S(part2Ptr))); if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)) { varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); if (!varPtr || !ReadTraced(varPtr)) { - goto afterExistsPeephole; + goto doneExistArray; } } varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, 0, "access", 0, 1, arrayPtr, opnd); if (varPtr) { @@ -3738,23 +3453,25 @@ if (TclIsVarUndefined(varPtr)) { TclCleanupVar(varPtr, arrayPtr); varPtr = NULL; } } - goto afterExistsPeephole; + doneExistArray: + objResultPtr = constants[!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1]; + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(5, 1, 1); + } case INST_EXIST_ARRAY_STK: cleanup = 2; - pcAdjustment = 1; part2Ptr = OBJ_AT_TOS; /* element name */ part1Ptr = OBJ_UNDER_TOS; /* array name */ TRACE(("\"%.30s(%.30s)\" => ", O2S(part1Ptr), O2S(part2Ptr))); goto doExistStk; case INST_EXIST_STK: cleanup = 1; - pcAdjustment = 1; part2Ptr = NULL; part1Ptr = OBJ_AT_TOS; /* variable name */ TRACE(("\"%.30s\" => ", O2S(part1Ptr))); doExistStk: @@ -3770,328 +3487,103 @@ if (TclIsVarUndefined(varPtr)) { TclCleanupVar(varPtr, arrayPtr); varPtr = NULL; } } - - /* - * Peep-hole optimisation: if you're about to jump, do jump from here. - */ - - afterExistsPeephole: { - int found = (varPtr && !TclIsVarUndefined(varPtr)); - - TRACE_APPEND(("%d\n", found ? 1 : 0)); - JUMP_PEEPHOLE_V(found, pcAdjustment, cleanup); + objResultPtr = constants[!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1]; + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(1, cleanup, 1); } /* * End of INST_EXIST instructions. - * ----------------------------------------------------------------- - * Start of INST_UNSET instructions. - */ - - { - int flags; - - case INST_UNSET_SCALAR: - flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; - opnd = TclGetUInt4AtPtr(pc+2); - varPtr = LOCAL(opnd); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - TRACE(("%s %u => ", (flags ? "normal" : "noerr"), opnd)); - if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) { - /* - * No errors, no traces, no searches: just make the variable cease - * to exist. - */ - - if (!TclIsVarUndefined(varPtr)) { - TclDecrRefCount(varPtr->value.objPtr); - } else if (flags & TCL_LEAVE_ERR_MSG) { - goto slowUnsetScalar; - } - varPtr->value.objPtr = NULL; - TRACE_APPEND(("OK\n")); - NEXT_INST_F(6, 0, 0); - } - - slowUnsetScalar: - DECACHE_STACK_INFO(); - if (TclPtrUnsetVarIdx(interp, varPtr, NULL, NULL, NULL, flags, - opnd) != TCL_OK && flags) { - goto errorInUnset; - } - CACHE_STACK_INFO(); - NEXT_INST_F(6, 0, 0); - - case INST_UNSET_ARRAY: - flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; - opnd = TclGetUInt4AtPtr(pc+2); - part2Ptr = OBJ_AT_TOS; - arrayPtr = LOCAL(opnd); - while (TclIsVarLink(arrayPtr)) { - arrayPtr = arrayPtr->value.linkPtr; - } - TRACE(("%s %u \"%.30s\" => ", - (flags ? "normal" : "noerr"), opnd, O2S(part2Ptr))); - if (TclIsVarArray(arrayPtr) && !UnsetTraced(arrayPtr) - && !(arrayPtr->flags & VAR_SEARCH_ACTIVE)) { - varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); - if (varPtr && TclIsVarDirectUnsettable(varPtr)) { - /* - * No nasty traces and element exists, so we can proceed to - * unset it. Might still not exist though... - */ - - if (!TclIsVarUndefined(varPtr)) { - TclDecrRefCount(varPtr->value.objPtr); - TclSetVarUndefined(varPtr); - TclClearVarNamespaceVar(varPtr); - TclCleanupVar(varPtr, arrayPtr); - } else if (flags & TCL_LEAVE_ERR_MSG) { - goto slowUnsetArray; - } - TRACE_APPEND(("OK\n")); - NEXT_INST_F(6, 1, 0); - } else if (!varPtr && !(flags & TCL_LEAVE_ERR_MSG)) { - /* - * Don't need to do anything here. - */ - - TRACE_APPEND(("OK\n")); - NEXT_INST_F(6, 1, 0); - } - } - slowUnsetArray: - DECACHE_STACK_INFO(); - varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, flags, "unset", - 0, 0, arrayPtr, opnd); - if (!varPtr) { - if (flags & TCL_LEAVE_ERR_MSG) { - goto errorInUnset; - } - } else if (TclPtrUnsetVarIdx(interp, varPtr, arrayPtr, NULL, part2Ptr, - flags, opnd) != TCL_OK && (flags & TCL_LEAVE_ERR_MSG)) { - goto errorInUnset; - } - CACHE_STACK_INFO(); - NEXT_INST_F(6, 1, 0); - - case INST_UNSET_ARRAY_STK: - flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; - cleanup = 2; - part2Ptr = OBJ_AT_TOS; /* element name */ - part1Ptr = OBJ_UNDER_TOS; /* array name */ - TRACE(("%s \"%.30s(%.30s)\" => ", (flags ? "normal" : "noerr"), - O2S(part1Ptr), O2S(part2Ptr))); - goto doUnsetStk; - - case INST_UNSET_STK: - flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; - cleanup = 1; - part2Ptr = NULL; - part1Ptr = OBJ_AT_TOS; /* variable name */ - TRACE(("%s \"%.30s\" => ", (flags ? "normal" : "noerr"), - O2S(part1Ptr))); - - doUnsetStk: - DECACHE_STACK_INFO(); - if (TclObjUnsetVar2(interp, part1Ptr, part2Ptr, flags) != TCL_OK - && (flags & TCL_LEAVE_ERR_MSG)) { - goto errorInUnset; - } - CACHE_STACK_INFO(); - TRACE_APPEND(("OK\n")); - NEXT_INST_V(2, cleanup, 0); - - errorInUnset: - CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; - } - break; - - /* - * End of INST_UNSET instructions. - * ----------------------------------------------------------------- - * Start of INST_ARRAY instructions. - */ - - case INST_ARRAY_EXISTS_IMM: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - cleanup = 0; - part1Ptr = NULL; - arrayPtr = NULL; - TRACE(("%u => ", opnd)); - varPtr = LOCAL(opnd); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - goto doArrayExists; - case INST_ARRAY_EXISTS_STK: - opnd = -1; - pcAdjustment = 1; - cleanup = 1; - part1Ptr = OBJ_AT_TOS; - TRACE(("\"%.30s\" => ", O2S(part1Ptr))); - varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL, - /*createPart1*/0, /*createPart2*/0, &arrayPtr); - doArrayExists: - DECACHE_STACK_INFO(); - result = TclCheckArrayTraces(interp, varPtr, arrayPtr, part1Ptr, opnd); - CACHE_STACK_INFO(); - if (result == TCL_ERROR) { - TRACE_ERROR(interp); - goto gotError; - } - if (varPtr && TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { - objResultPtr = TCONST(1); - } else { - objResultPtr = TCONST(0); - } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(pcAdjustment, cleanup, 1); - - case INST_ARRAY_MAKE_IMM: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - cleanup = 0; - part1Ptr = NULL; - arrayPtr = NULL; - TRACE(("%u => ", opnd)); - varPtr = LOCAL(opnd); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - goto doArrayMake; - case INST_ARRAY_MAKE_STK: - opnd = -1; - pcAdjustment = 1; - cleanup = 1; - part1Ptr = OBJ_AT_TOS; - TRACE(("\"%.30s\" => ", O2S(part1Ptr))); - varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, TCL_LEAVE_ERR_MSG, - "set", /*createPart1*/1, /*createPart2*/0, &arrayPtr); - if (varPtr == NULL) { - TRACE_ERROR(interp); - goto gotError; - } - doArrayMake: - if (varPtr && !TclIsVarArray(varPtr)) { - if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) { - /* - * Either an array element, or a scalar: lose! - */ - - TclObjVarErrMsg(interp, part1Ptr, NULL, "array set", - "variable isn't array", opnd); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); - CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; - } - TclInitArrayVar(varPtr); -#ifdef TCL_COMPILE_DEBUG - TRACE_APPEND(("done\n")); - } else { - TRACE_APPEND(("nothing to do\n")); -#endif - } - NEXT_INST_V(pcAdjustment, cleanup, 0); - - /* - * End of INST_ARRAY instructions. - * ----------------------------------------------------------------- - * Start of variable linking instructions. - */ - - { - Var *otherPtr; - CallFrame *framePtr, *savedFramePtr; - Tcl_Namespace *nsPtr; - Namespace *savedNsPtr; - - case INST_UPVAR: - TRACE(("%d %.30s %.30s => ", TclGetInt4AtPtr(pc+1), - O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); - - if (TclObjGetFrame(interp, OBJ_UNDER_TOS, &framePtr) == -1) { - TRACE_ERROR(interp); - goto gotError; - } - - /* - * Locate the other variable. - */ - - savedFramePtr = iPtr->varFramePtr; - iPtr->varFramePtr = framePtr; - otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, - TCL_LEAVE_ERR_MSG, "access", /*createPart1*/ 1, - /*createPart2*/ 1, &varPtr); - iPtr->varFramePtr = savedFramePtr; - if (!otherPtr) { - TRACE_ERROR(interp); - goto gotError; - } - goto doLinkVars; - - case INST_NSUPVAR: - TRACE(("%d %.30s %.30s => ", TclGetInt4AtPtr(pc+1), - O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); - if (TclGetNamespaceFromObj(interp, OBJ_UNDER_TOS, &nsPtr) != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } - - /* - * Locate the other variable. - */ - - savedNsPtr = iPtr->varFramePtr->nsPtr; - iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr; - otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, - (TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG|TCL_AVOID_RESOLVERS), - "access", /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); - iPtr->varFramePtr->nsPtr = savedNsPtr; - if (!otherPtr) { - TRACE_ERROR(interp); - goto gotError; - } - goto doLinkVars; + * --------------------------------------------------------- + */ + + case INST_UPVAR: { + int opnd; + Var *varPtr, *otherPtr; + + TRACE_WITH_OBJ(("upvar "), OBJ_UNDER_TOS); + + { + CallFrame *framePtr, *savedFramePtr; + + result = TclObjGetFrame(interp, OBJ_UNDER_TOS, &framePtr); + if (result != -1) { + /* + * Locate the other variable. + */ + + savedFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = framePtr; + otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, + (TCL_LEAVE_ERR_MSG), "access", + /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); + iPtr->varFramePtr = savedFramePtr; + if (otherPtr) { + result = TCL_OK; + goto doLinkVars; + } + } + result = TCL_ERROR; + goto checkForCatch; + } case INST_VARIABLE: - TRACE(("%d, %.30s => ", TclGetInt4AtPtr(pc+1), O2S(OBJ_AT_TOS))); + TRACE(("variable ")); otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); - if (!otherPtr) { - TRACE_ERROR(interp); - goto gotError; - } - - /* - * Do the [variable] magic. - */ - - TclSetVarNamespaceVar(otherPtr); + if (otherPtr) { + /* + * Do the [variable] magic. + */ + + TclSetVarNamespaceVar(otherPtr); + result = TCL_OK; + goto doLinkVars; + } + result = TCL_ERROR; + goto checkForCatch; + + case INST_NSUPVAR: + TRACE_WITH_OBJ(("nsupvar "), OBJ_UNDER_TOS); + + { + Tcl_Namespace *nsPtr, *savedNsPtr; + + result = TclGetNamespaceFromObj(interp, OBJ_UNDER_TOS, &nsPtr); + if (result == TCL_OK) { + /* + * Locate the other variable. + */ + + savedNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; + iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr; + otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, + (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", + /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); + iPtr->varFramePtr->nsPtr = (Namespace *) savedNsPtr; + if (otherPtr) { + goto doLinkVars; + } + } + result = TCL_ERROR; + goto checkForCatch; + } doLinkVars: /* * If we are here, the local variable has already been created: do the * little work of TclPtrMakeUpvar that remains to be done right here * if there are no errors; otherwise, let it handle the case. */ - opnd = TclGetInt4AtPtr(pc+1); - varPtr = LOCAL(opnd); + opnd = TclGetInt4AtPtr(pc+1);; + varPtr = &(compiledLocals[opnd]); if ((varPtr != otherPtr) && !TclIsVarTraced(varPtr) && (TclIsVarUndefined(varPtr) || TclIsVarLink(varPtr))) { if (!TclIsVarUndefined(varPtr)) { /* * Then it is a defined link. @@ -4098,12 +3590,11 @@ */ Var *linkPtr = varPtr->value.linkPtr; if (linkPtr == otherPtr) { - TRACE_APPEND(("already linked\n")); - NEXT_INST_F(5, 1, 0); + goto doLinkVarsDone; } if (TclIsVarInHash(linkPtr)) { VarHashRefCount(linkPtr)--; if (TclIsVarUndefined(linkPtr)) { TclCleanupVar(linkPtr, NULL); @@ -4113,52 +3604,51 @@ TclSetVarLink(varPtr); varPtr->value.linkPtr = otherPtr; if (TclIsVarInHash(otherPtr)) { VarHashRefCount(otherPtr)++; } - } else if (TclPtrObjMakeUpvarIdx(interp, otherPtr, NULL, 0, - opnd) != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; + } else { + result = TclPtrObjMakeUpvar(interp, otherPtr, NULL, 0, opnd); + if (result != TCL_OK) { + goto checkForCatch; + } } /* * 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); - - { - int jmpOffset[2], b; + doLinkVarsDone: + NEXT_INST_F(5, 1, 0); + } + + case INST_JUMP1: { + int 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: { + int opnd = TclGetInt4AtPtr(pc+1); + + TRACE(("%d => new pc %u\n", opnd, + (unsigned)(pc + opnd - codePtr->codeStart))); + NEXT_INST_F(opnd, 0, 0); + } + + { + int jmpOffset[2], b; + Tcl_Obj *valuePtr; /* TODO: consider rewrite so we don't compute the offset we're not * going to take. */ case INST_JUMP_FALSE4: jmpOffset[0] = TclGetInt4AtPtr(pc+1); /* FALSE offset */ - jmpOffset[1] = 5; /* TRUE offset */ + jmpOffset[1] = 5; /* TRUE offset*/ goto doCondJump; case INST_JUMP_TRUE4: jmpOffset[0] = 5; jmpOffset[1] = TclGetInt4AtPtr(pc+1); @@ -4173,53 +3663,56 @@ jmpOffset[0] = 2; jmpOffset[1] = TclGetInt1AtPtr(pc+1); doCondJump: valuePtr = OBJ_AT_TOS; - TRACE(("%d => ", jmpOffset[ - (*pc==INST_JUMP_FALSE1 || *pc==INST_JUMP_FALSE4) ? 0 : 1])); /* TODO - check claim that taking address of b harms performance */ /* TODO - consider optimization search for constants */ - if (TclGetBooleanFromObj(interp, valuePtr, &b) != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; + result = TclGetBooleanFromObj(interp, valuePtr, &b); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("%d => ERROR: ", jmpOffset[ + ((*pc == INST_JUMP_FALSE1) || (*pc == INST_JUMP_FALSE4)) + ? 0 : 1]), Tcl_GetObjResult(interp)); + goto checkForCatch; } #ifdef TCL_COMPILE_DEBUG if (b) { if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { - TRACE_APPEND(("%.20s true, new pc %u\n", O2S(valuePtr), + TRACE(("%d => %.20s true, new pc %u\n", jmpOffset[1], + O2S(valuePtr), (unsigned)(pc + jmpOffset[1] - codePtr->codeStart))); } else { - TRACE_APPEND(("%.20s true\n", O2S(valuePtr))); + TRACE(("%d => %.20s true\n", jmpOffset[0], O2S(valuePtr))); } } else { if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { - TRACE_APPEND(("%.20s false\n", O2S(valuePtr))); + TRACE(("%d => %.20s false\n", jmpOffset[0], O2S(valuePtr))); } else { - TRACE_APPEND(("%.20s false, new pc %u\n", O2S(valuePtr), - (unsigned)(pc + jmpOffset[0] - codePtr->codeStart))); + TRACE(("%d => %.20s false, new pc %u\n", jmpOffset[0], + O2S(valuePtr), + (unsigned)(pc + jmpOffset[1] - codePtr->codeStart))); } } #endif NEXT_INST_F(jmpOffset[b], 1, 0); } - break; case INST_JUMP_TABLE: { Tcl_HashEntry *hPtr; JumptableInfo *jtPtr; + int opnd; /* * Jump to location looked up in a hashtable; fall through to next * instr if lookup fails. */ opnd = TclGetInt4AtPtr(pc+1); jtPtr = (JumptableInfo *) codePtr->auxDataArrayPtr[opnd].clientData; - TRACE(("%d \"%.20s\" => ", opnd, O2S(OBJ_AT_TOS))); + TRACE(("%d => %.20s ", opnd, O2S(OBJ_AT_TOS))); hPtr = Tcl_FindHashEntry(&jtPtr->hashTable, TclGetString(OBJ_AT_TOS)); if (hPtr != NULL) { int jumpOffset = PTR2INT(Tcl_GetHashValue(hPtr)); TRACE_APPEND(("found in table, new pc %u\n", @@ -4228,562 +3721,284 @@ } else { TRACE_APPEND(("not found in table\n")); NEXT_INST_F(5, 1, 0); } } - 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_DYING)) { - 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) { - TRACE_ERROR(interp); - goto gotError; - } - if (level <= 0) { - level += framePtr->level; - } - for (; (framePtr->level!=level) && (framePtr!=rootFramePtr) ; - framePtr = framePtr->callerVarPtr) { - /* Empty loop body */ - } - if (framePtr == rootFramePtr) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad level \"%s\"", TclGetString(OBJ_AT_TOS))); - TRACE_ERROR(interp); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL", - TclGetString(OBJ_AT_TOS), NULL); - CACHE_STACK_INFO(); - goto gotError; - } - objResultPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 1, 1); - } - { - Tcl_Command cmd, origCmd; - - case INST_RESOLVE_COMMAND: - cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS); - TclNewObj(objResultPtr); - if (cmd != NULL) { - Tcl_GetCommandFullName(interp, cmd, objResultPtr); - } - TRACE_WITH_OBJ(("\"%.20s\" => ", O2S(OBJ_AT_TOS)), objResultPtr); - NEXT_INST_F(1, 1, 1); - - case INST_ORIGIN_COMMAND: - TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); - cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS); - if (cmd == NULL) { - goto instOriginError; - } - origCmd = TclGetOriginalCommand(cmd); - if (origCmd == NULL) { - origCmd = cmd; - } - - TclNewObj(objResultPtr); - Tcl_GetCommandFullName(interp, origCmd, objResultPtr); - if (TclCheckEmptyString(objResultPtr) == TCL_EMPTYSTRING_YES ) { - Tcl_DecrRefCount(objResultPtr); - instOriginError: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid command name \"%s\"", TclGetString(OBJ_AT_TOS))); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", - TclGetString(OBJ_AT_TOS), NULL); - CACHE_STACK_INFO(); - TRACE_APPEND(("ERROR: not command\n")); - goto gotError; - } - TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_TOS))); - NEXT_INST_F(1, 1, 1); - } - - /* - * ----------------------------------------------------------------- - * Start of TclOO support instructions. - */ - - { - Object *oPtr; - CallFrame *framePtr; - CallContext *contextPtr; - int skip, newDepth; - - case INST_TCLOO_SELF: - framePtr = iPtr->varFramePtr; - if (framePtr == NULL || - !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { - TRACE(("=> ERROR: no TclOO call context\n")); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "self may only be called from inside a method", - -1)); - DECACHE_STACK_INFO(); - 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); - NEXT_INST_F(1, 0, 1); - - case INST_TCLOO_NEXT_CLASS: - opnd = TclGetUInt1AtPtr(pc+1); - framePtr = iPtr->varFramePtr; - valuePtr = OBJ_AT_DEPTH(opnd - 2); - objv = &OBJ_AT_DEPTH(opnd - 1); - skip = 2; - TRACE(("%d => ", opnd)); - if (framePtr == NULL || - !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { - TRACE_APPEND(("ERROR: no TclOO call context\n")); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "nextto may only be called from inside a method", - -1)); - DECACHE_STACK_INFO(); - 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; - struct MInvoke *miPtr; - int i; - const char *methodType; - - if (classPtr == NULL) { - TRACE_APPEND(("ERROR: \"%.30s\" not class\n", O2S(valuePtr))); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" is not a class", TclGetString(valuePtr))); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL); - CACHE_STACK_INFO(); - goto gotError; - } - - for (i=contextPtr->index+1 ; icallPtr->numChain ; i++) { - miPtr = contextPtr->callPtr->chain + i; - if (!miPtr->isFilter && - miPtr->mPtr->declaringClassPtr == classPtr) { - newDepth = i; -#ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { - if (traceInstructions) { - strncpy(cmdNameBuf, TclGetString(objv[0]), 20); - } else { - fprintf(stdout, "%d: (%u) invoking ", - iPtr->numLevels, - (unsigned)(pc - codePtr->codeStart)); - } - for (i = 0; i < opnd; i++) { - TclPrintObject(stdout, objv[i], 15); - fprintf(stdout, " "); - } - fprintf(stdout, "\n"); - fflush(stdout); - } -#endif /*TCL_COMPILE_DEBUG*/ - goto doInvokeNext; - } - } - - if (contextPtr->callPtr->flags & CONSTRUCTOR) { - methodType = "constructor"; - } else if (contextPtr->callPtr->flags & DESTRUCTOR) { - methodType = "destructor"; - } else { - methodType = "method"; - } - - TRACE_APPEND(("ERROR: \"%.30s\" not on reachable chain\n", - O2S(valuePtr))); - for (i=contextPtr->index ; i>=0 ; i--) { - miPtr = contextPtr->callPtr->chain + i; - if (miPtr->isFilter - || miPtr->mPtr->declaringClassPtr != classPtr) { - continue; - } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s implementation by \"%s\" not reachable from here", - methodType, TclGetString(valuePtr))); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE", - NULL); - CACHE_STACK_INFO(); - goto gotError; - } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s has no non-filter implementation by \"%s\"", - methodType, TclGetString(valuePtr))); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL); - CACHE_STACK_INFO(); - goto gotError; - } - - case INST_TCLOO_NEXT: - opnd = TclGetUInt1AtPtr(pc+1); - objv = &OBJ_AT_DEPTH(opnd - 1); - framePtr = iPtr->varFramePtr; - skip = 1; - TRACE(("%d => ", opnd)); - if (framePtr == NULL || - !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { - TRACE_APPEND(("ERROR: no TclOO call context\n")); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "next may only be called from inside a method", - -1)); - DECACHE_STACK_INFO(); - 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 - * equivalent) unexpectedly. - */ - - const char *methodType; - - if (contextPtr->callPtr->flags & CONSTRUCTOR) { - methodType = "constructor"; - } else if (contextPtr->callPtr->flags & DESTRUCTOR) { - methodType = "destructor"; - } else { - methodType = "method"; - } - - TRACE_APPEND(("ERROR: no TclOO next impl\n")); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "no next %s implementation", methodType)); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL); - CACHE_STACK_INFO(); - goto gotError; -#ifdef TCL_COMPILE_DEBUG - } else if (tclTraceExec >= 2) { - int i; - - if (traceInstructions) { - strncpy(cmdNameBuf, TclGetString(objv[0]), 20); - } else { - fprintf(stdout, "%d: (%u) invoking ", - iPtr->numLevels, (unsigned)(pc - codePtr->codeStart)); - } - for (i = 0; i < opnd; i++) { - TclPrintObject(stdout, objv[i], 15); - fprintf(stdout, " "); - } - fprintf(stdout, "\n"); - fflush(stdout); -#endif /*TCL_COMPILE_DEBUG*/ - } - - doInvokeNext: - bcFramePtr->data.tebc.pc = (char *) pc; - iPtr->cmdFramePtr = bcFramePtr; - - if (iPtr->flags & INTERP_DEBUG_FRAME) { - ArgumentBCEnter(interp, codePtr, TD, pc, opnd, objv); - } - - pcAdjustment = 2; - cleanup = opnd; - DECACHE_STACK_INFO(); - iPtr->varFramePtr = framePtr->callerVarPtr; - pc += pcAdjustment; - TEBC_YIELD(); - - TclPushTailcallPoint(interp); - oPtr = contextPtr->oPtr; - if (oPtr->flags & FILTER_HANDLING) { - TclNRAddCallback(interp, FinalizeOONextFilter, - framePtr, contextPtr, INT2PTR(contextPtr->index), - INT2PTR(contextPtr->skip)); - } else { - TclNRAddCallback(interp, FinalizeOONext, - framePtr, contextPtr, INT2PTR(contextPtr->index), - INT2PTR(contextPtr->skip)); - } - contextPtr->skip = skip; - contextPtr->index = newDepth; - if (contextPtr->callPtr->chain[newDepth].isFilter - || contextPtr->callPtr->flags & FILTER_HANDLING) { - oPtr->flags |= FILTER_HANDLING; - } else { - oPtr->flags &= ~FILTER_HANDLING; - } - - { - Method *const mPtr = - contextPtr->callPtr->chain[newDepth].mPtr; - - return mPtr->typePtr->callProc(mPtr->clientData, interp, - (Tcl_ObjectContext) contextPtr, opnd, objv); - } - - case INST_TCLOO_IS_OBJECT: - oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); - objResultPtr = TCONST(oPtr != NULL ? 1 : 0); - TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr); - NEXT_INST_F(1, 1, 1); - case INST_TCLOO_CLASS: - oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); - if (oPtr == NULL) { - TRACE(("%.30s => ERROR: not object\n", O2S(OBJ_AT_TOS))); - goto gotError; - } - objResultPtr = TclOOObjectName(interp, oPtr->selfCls->thisPtr); - TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr); - NEXT_INST_F(1, 1, 1); - case INST_TCLOO_NS: - oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); - if (oPtr == NULL) { - TRACE(("%.30s => ERROR: not object\n", O2S(OBJ_AT_TOS))); - goto gotError; - } - - /* - * TclOO objects *never* have the global namespace as their NS. - */ - - TclNewStringObj(objResultPtr, oPtr->namespacePtr->fullName, - strlen(oPtr->namespacePtr->fullName)); - TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr); - NEXT_INST_F(1, 1, 1); - } - - /* - * End of TclOO support instructions. - * ----------------------------------------------------------------- + + /* + * 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; + Tcl_Obj *value2Ptr = OBJ_AT_TOS; + Tcl_Obj *valuePtr = OBJ_UNDER_TOS; + + result = TclGetBooleanFromObj(NULL, valuePtr, &i1); + if (result != 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 checkForCatch; + } + + result = TclGetBooleanFromObj(NULL, value2Ptr, &i2); + if (result != 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 checkForCatch; + } + + if (*pc == INST_LOR) { + iResult = (i1 || i2); + } else { + iResult = (i1 && i2); + } + objResultPtr = constants[iResult]; + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr),O2S(value2Ptr),iResult)); + NEXT_INST_F(1, 2, 1); + } + + /* + * --------------------------------------------------------- * Start of INST_LIST and related instructions. */ - { - int numIndices, nocase, match, cflags; - size_t slength, length2, fromIdx, toIdx, index, s1len, s2len; - const char *s1, *s2; - - case INST_LIST: + case INST_LIST: { /* * Pop the opnd (objc) top stack elements into a new list obj and then * decrement their ref counts. */ + + int opnd; opnd = TclGetUInt4AtPtr(pc+1); objResultPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1)); TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_V(5, opnd, 1); - - case INST_LIST_LENGTH: - TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); - if (TclListObjLength(interp, OBJ_AT_TOS, &length) != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } - TclNewIntObj(objResultPtr, length); - TRACE_APPEND(("%d\n", length)); - NEXT_INST_F(1, 1, 1); - - case INST_LIST_INDEX: /* lindex with objc == 3 */ + } + + case INST_LIST_LENGTH: { + Tcl_Obj *valuePtr; + int length; + + valuePtr = OBJ_AT_TOS; + + result = TclListObjLength(interp, valuePtr, &length); + if (result == TCL_OK) { + TclNewIntObj(objResultPtr, length); + TRACE(("%.20s => %d\n", O2S(valuePtr), length)); + NEXT_INST_F(1, 1, 1); + } else { + TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), + Tcl_GetObjResult(interp)); + goto checkForCatch; + } + } + + case INST_LIST_INDEX: { + /*** lindex with objc == 3 ***/ + + /* Variables also for INST_LIST_INDEX_IMM */ + + int listc, idx, opnd, pcAdjustment; + Tcl_Obj **listv; + Tcl_Obj *valuePtr, *value2Ptr; + + /* + * Pop the two operands. + */ + value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; - TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); /* * Extract the desired list element. */ - if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK) - && !TclHasIntRep(value2Ptr, &tclListType)) { - int code; - - DECACHE_STACK_INFO(); - code = TclGetIntForIndexM(interp, value2Ptr, objc-1, &index); - CACHE_STACK_INFO(); - if (code == TCL_OK) { - TclDecrRefCount(value2Ptr); - tosPtr--; - pcAdjustment = 1; - goto lindexFastPath; - } - Tcl_ResetResult(interp); + result = TclListObjGetElements(interp, valuePtr, &listc, &listv); + if ((result == TCL_OK) && (value2Ptr->typePtr != &tclListType) + && (TclGetIntForIndexM(NULL , value2Ptr, listc-1, + &idx) == TCL_OK)) { + TclDecrRefCount(value2Ptr); + tosPtr--; + pcAdjustment = 1; + goto lindexFastPath; } objResultPtr = TclLindexList(interp, valuePtr, value2Ptr); - if (!objResultPtr) { - TRACE_ERROR(interp); - goto gotError; + if (objResultPtr) { + /* + * Stash the list element on the stack. + */ + + TRACE(("%.20s %.20s => %s\n", + O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr))); + NEXT_INST_F(1, 2, -1); /* Already has the correct refCount */ + } else { + TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr), + O2S(value2Ptr)), Tcl_GetObjResult(interp)); + result = TCL_ERROR; + goto checkForCatch; } - /* - * Stash the list element on the stack. - */ - - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, -1); /* Already has the correct refCount */ - - case INST_LIST_INDEX_IMM: /* lindex with objc==3 and index in bytecode - * stream */ + case INST_LIST_INDEX_IMM: + /*** lindex with objc==3 and index in bytecode stream ***/ + + pcAdjustment = 5; /* * Pop the list and get the index. */ valuePtr = OBJ_AT_TOS; opnd = TclGetInt4AtPtr(pc+1); - TRACE(("\"%.30s\" %d => ", O2S(valuePtr), opnd)); /* * Get the contents of the list, making sure that it really is a list * in the process. */ - if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } - - /* Decode end-offset index values. */ - - index = TclIndexDecode(opnd, objc - 1); - pcAdjustment = 5; - - lindexFastPath: - if (index < (size_t)objc) { - objResultPtr = objv[index]; + result = TclListObjGetElements(interp, valuePtr, &listc, &listv); + + if (result == TCL_OK) { + /* + * Select the list item based on the index. Negative operand means + * end-based indexing. + */ + + if (opnd < -1) { + idx = opnd+1 + listc; + } else { + idx = opnd; + } + + lindexFastPath: + if (idx >= 0 && idx < listc) { + objResultPtr = listv[idx]; + } else { + TclNewObj(objResultPtr); + } + + TRACE_WITH_OBJ(("\"%.30s\" %d => ", O2S(valuePtr), opnd), + objResultPtr); + NEXT_INST_F(pcAdjustment, 1, 1); } else { - TclNewObj(objResultPtr); + TRACE_WITH_OBJ(("\"%.30s\" %d => ERROR: ", O2S(valuePtr), opnd), + Tcl_GetObjResult(interp)); + goto checkForCatch; } + } - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); - NEXT_INST_F(pcAdjustment, 1, 1); - - case INST_LIST_INDEX_MULTI: /* 'lindex' with multiple index args */ + case INST_LIST_INDEX_MULTI: { /* + * 'lindex' with multiple index args: + * * Determine the count of index args. */ + + int numIdx, opnd; opnd = TclGetUInt4AtPtr(pc+1); - numIndices = opnd-1; + numIdx = opnd-1; /* * Do the 'lindex' operation. */ - TRACE(("%d => ", opnd)); - objResultPtr = TclLindexFlat(interp, OBJ_AT_DEPTH(numIndices), - numIndices, &OBJ_AT_DEPTH(numIndices - 1)); - if (!objResultPtr) { - TRACE_ERROR(interp); - goto gotError; - } + objResultPtr = TclLindexFlat(interp, OBJ_AT_DEPTH(numIdx), + numIdx, &OBJ_AT_DEPTH(numIdx - 1)); /* - * Set result. + * Check for errors. */ - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd, -1); + if (objResultPtr) { + /* + * Set result. + */ - case INST_LSET_FLAT: + TRACE(("%d => %s\n", opnd, O2S(objResultPtr))); + NEXT_INST_V(5, opnd, -1); + } else { + TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); + result = TCL_ERROR; + goto checkForCatch; + } + } + + case INST_LSET_FLAT: { /* * Lset with 3, 5, or more args. Get the number of index args. */ + int numIdx,opnd; + Tcl_Obj *valuePtr, *value2Ptr; + opnd = TclGetUInt4AtPtr(pc + 1); - numIndices = opnd - 2; - TRACE(("%d => ", opnd)); + numIdx = opnd - 2; /* * Get the old value of variable, and remove the stack ref. This is * safe because the variable still references the object; the ref * count will never go zero here - we can use the smaller macro * Tcl_DecrRefCount. */ - valuePtr = POP_OBJECT(); - Tcl_DecrRefCount(valuePtr); /* This one should be done here */ + value2Ptr = POP_OBJECT(); + Tcl_DecrRefCount(value2Ptr); /* This one should be done here */ + + /* + * Get the new element value. + */ + + valuePtr = OBJ_AT_TOS; /* * Compute the new variable value. */ - objResultPtr = TclLsetFlat(interp, valuePtr, numIndices, - &OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS); - if (!objResultPtr) { - TRACE_ERROR(interp); - goto gotError; + objResultPtr = TclLsetFlat(interp, value2Ptr, numIdx, + &OBJ_AT_DEPTH(numIdx), valuePtr); + + /* + * Check for errors. + */ + + if (objResultPtr) { + /* + * Set result. + */ + + TRACE(("%d => %s\n", opnd, O2S(objResultPtr))); + NEXT_INST_V(5, (numIdx+1), -1); + } else { + TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); + result = TCL_ERROR; + goto checkForCatch; } + } + case INST_LSET_LIST: { /* - * Set result. + * 'lset' with 4 args. */ - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); - NEXT_INST_V(5, numIndices+1, -1); + Tcl_Obj *objPtr, *valuePtr, *value2Ptr; - case INST_LSET_LIST: /* 'lset' with 4 args */ /* * Get the old value of variable, and remove the stack ref. This is * safe because the variable still references the object; the ref * count will never go zero here - we can use the smaller macro * Tcl_DecrRefCount. @@ -4796,783 +4011,544 @@ * Get the new element value, and the index list. */ valuePtr = OBJ_AT_TOS; value2Ptr = OBJ_UNDER_TOS; - TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ", - O2S(value2Ptr), O2S(valuePtr), O2S(objPtr))); /* * Compute the new variable value. */ objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr); - if (!objResultPtr) { - TRACE_ERROR(interp); - goto gotError; - } /* - * Set result. + * Check for errors. */ - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, -1); + if (objResultPtr) { + /* + * Set result. + */ - case INST_LIST_RANGE_IMM: /* lrange with objc==4 and both indices in - * bytecode stream */ + TRACE(("=> %s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, -1); + } else { + TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)), + Tcl_GetObjResult(interp)); + result = TCL_ERROR; + goto checkForCatch; + } + } + + case INST_LIST_RANGE_IMM: { + /*** lrange with objc==4 and both indices in bytecode stream ***/ + + int listc, fromIdx, toIdx; + Tcl_Obj **listv, *valuePtr; /* * Pop the list and get the indices. */ valuePtr = OBJ_AT_TOS; fromIdx = TclGetInt4AtPtr(pc+1); toIdx = TclGetInt4AtPtr(pc+5); - TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), TclGetInt4AtPtr(pc+1), - TclGetInt4AtPtr(pc+5))); /* - * Get the length of the list, making sure that it really is a list + * Get the contents of the list, making sure that it really is a list * in the process. */ - - if (TclListObjLength(interp, valuePtr, &objc) != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } + result = TclListObjGetElements(interp, valuePtr, &listc, &listv); /* * Skip a lot of work if we're about to throw the result away (common * with uses of [lassign]). */ -#ifndef TCL_COMPILE_DEBUG - if (*(pc+9) == INST_POP) { - NEXT_INST_F(10, 1, 0); - } -#endif - - /* Every range of an empty list is an empty list */ - if (objc == 0) { - /* avoid return of not canonical list (e. g. spaces in string repr.) */ - if (!valuePtr->bytes || !valuePtr->length) { - TRACE_APPEND(("\n")); - NEXT_INST_F(9, 0, 0); - } - goto emptyList; - } - - /* Decode index value operands. */ - - if (toIdx == TCL_INDEX_NONE) { - emptyList: - TclNewObj(objResultPtr); - TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr))); - NEXT_INST_F(9, 1, 1); - } - toIdx = TclIndexDecode(toIdx, objc - 1); - if (toIdx == TCL_INDEX_NONE) { - goto emptyList; - } else if (toIdx + 1 >= (size_t)objc + 1) { - toIdx = objc - 1; - } - - assert (toIdx < (size_t)objc); - /* - assert ( fromIdx != TCL_INDEX_NONE ); - * - * Extra safety for legacy bytecodes: - */ - if (fromIdx == TCL_INDEX_NONE) { - fromIdx = TCL_INDEX_START; - } - - fromIdx = TclIndexDecode(fromIdx, objc - 1); - - objResultPtr = TclListObjRange(valuePtr, fromIdx, toIdx); - - TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr))); - NEXT_INST_F(9, 1, 1); + if (result == TCL_OK) { +#ifndef TCL_COMPILE_DEBUG + if (*(pc+9) == INST_POP) { + NEXT_INST_F(10, 1, 0); + } +#endif + } else { + TRACE_WITH_OBJ(("\"%.30s\" %d %d => ERROR: ", O2S(valuePtr), + fromIdx, toIdx), Tcl_GetObjResult(interp)); + goto checkForCatch; + } + + /* + * Adjust the indices for end-based handling. + */ + + if (fromIdx < -1) { + fromIdx += 1+listc; + if (fromIdx < -1) { + fromIdx = -1; + } + } else if (fromIdx > listc) { + fromIdx = listc; + } + if (toIdx < -1) { + toIdx += 1+listc; + if (toIdx < -1) { + toIdx = -1; + } + } else if (toIdx > listc) { + toIdx = listc; + } + + /* + * Check if we are referring to a valid, non-empty list range, and if + * so, build the list of elements in that range. + */ + + if (fromIdx<=toIdx && fromIdx=0) { + if (fromIdx<0) { + fromIdx = 0; + } + if (toIdx >= listc) { + toIdx = listc-1; + } + objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, listv+fromIdx); + } else { + TclNewObj(objResultPtr); + } + + TRACE_WITH_OBJ(("\"%.30s\" %d %d => ", O2S(valuePtr), + TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5)), objResultPtr); + NEXT_INST_F(9, 1, 1); + } case INST_LIST_IN: - case INST_LIST_NOT_IN: /* Basic list containment operators. */ + case INST_LIST_NOT_IN: { + /* + * Basic list containment operators. + */ + + int found, s1len, s2len, llen, i; + Tcl_Obj *valuePtr, *value2Ptr, *o; + char *s1; + const char *s2; + value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; + /* TODO: Consider more efficient tests than strcmp() */ s1 = TclGetStringFromObj(valuePtr, &s1len); - TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); - if (TclListObjLength(interp, value2Ptr, &length) != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } - match = 0; - if (length > 0) { - int i = 0; - Tcl_Obj *o; - + result = TclListObjLength(interp, value2Ptr, &llen); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ERROR: ", O2S(valuePtr), + O2S(value2Ptr)), Tcl_GetObjResult(interp)); + goto checkForCatch; + } + found = 0; + if (llen > 0) { /* * An empty list doesn't match anything. */ + i = 0; do { Tcl_ListObjIndex(NULL, value2Ptr, i, &o); if (o != NULL) { s2 = TclGetStringFromObj(o, &s2len); } else { s2 = ""; - s2len = 0; } if (s1len == s2len) { - match = (memcmp(s1, s2, s1len) == 0); + found = (strcmp(s1, s2) == 0); } i++; - } while (i < length && match == 0); + } while (i < llen && found == 0); } if (*pc == INST_LIST_NOT_IN) { - match = !match; + found = !found; } - TRACE_APPEND(("%d\n", match)); + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), found)); /* * Peep-hole optimisation: if you're about to jump, do jump from here. * We're saving the effort of pushing a boolean value only to pop it * for branching. */ - JUMP_PEEPHOLE_F(match, 1, 2); - - case INST_LIST_CONCAT: - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; - TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); - if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_DuplicateObj(valuePtr); - if (Tcl_ListObjAppendList(interp, objResultPtr, - value2Ptr) != TCL_OK) { - TRACE_ERROR(interp); - TclDecrRefCount(objResultPtr); - goto gotError; - } - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } else { - if (Tcl_ListObjAppendList(interp, valuePtr, value2Ptr) != TCL_OK){ - TRACE_ERROR(interp); - goto gotError; - } - TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); - } + pc++; +#ifndef TCL_COMPILE_DEBUG + switch (*pc) { + case INST_JUMP_FALSE1: + NEXT_INST_F((found ? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); + case INST_JUMP_TRUE1: + NEXT_INST_F((found ? TclGetInt1AtPtr(pc+1) : 2), 2, 0); + case INST_JUMP_FALSE4: + NEXT_INST_F((found ? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); + case INST_JUMP_TRUE4: + NEXT_INST_F((found ? TclGetInt4AtPtr(pc+1) : 5), 2, 0); + } +#endif + objResultPtr = constants[found]; + NEXT_INST_F(0, 2, 1); + } /* * End of INST_LIST and related instructions. - * ----------------------------------------------------------------- - * Start of string-related instructions. + * --------------------------------------------------------- */ case INST_STR_EQ: - case INST_STR_NEQ: /* String (in)equality check */ - case INST_STR_CMP: /* String compare. */ - case INST_STR_LT: - case INST_STR_GT: - case INST_STR_LE: - case INST_STR_GE: + case INST_STR_NEQ: { + /* + * String (in)equality check + * TODO: Consider merging into INST_STR_CMP + */ + + int iResult; + Tcl_Obj *valuePtr, *value2Ptr; + + value2Ptr = OBJ_AT_TOS; + valuePtr = OBJ_UNDER_TOS; + + if (valuePtr == value2Ptr) { + /* + * On the off-chance that the objects are the same, we don't + * really have to think hard about equality. + */ + + iResult = (*pc == INST_STR_EQ); + } else { + char *s1, *s2; + int s1len, s2len; + + s1 = TclGetStringFromObj(valuePtr, &s1len); + s2 = TclGetStringFromObj(value2Ptr, &s2len); + if (s1len == s2len) { + /* + * We only need to check (in)equality when we have equal + * length strings. + */ + + if (*pc == INST_STR_NEQ) { + iResult = (strcmp(s1, s2) != 0); + } else { + /* INST_STR_EQ */ + iResult = (strcmp(s1, s2) == 0); + } + } else { + iResult = (*pc == INST_STR_NEQ); + } + } + + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr),O2S(value2Ptr),iResult)); + + /* + * Peep-hole optimisation: if you're about to jump, do jump from here. + */ + + pc++; +#ifndef TCL_COMPILE_DEBUG + switch (*pc) { + case INST_JUMP_FALSE1: + NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); + case INST_JUMP_TRUE1: + NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0); + case INST_JUMP_FALSE4: + NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); + case INST_JUMP_TRUE4: + NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0); + } +#endif + objResultPtr = constants[iResult]; + NEXT_INST_F(0, 2, 1); + } + + case INST_STR_CMP: { + /* + * String compare. + */ + + const char *s1, *s2; + int s1len, s2len, iResult; + Tcl_Obj *valuePtr, *value2Ptr; + stringCompare: value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; - { - int checkEq = ((*pc == INST_EQ) || (*pc == INST_NEQ) - || (*pc == INST_STR_EQ) || (*pc == INST_STR_NEQ)); - match = TclStringCmp(valuePtr, value2Ptr, checkEq, 0, -1); + /* + * The comparison function should compare up to the minimum byte + * length only. + */ + + if (valuePtr == value2Ptr) { + /* + * In the pure equality case, set lengths too for the checks below + * (or we could goto beyond it). + */ + + iResult = s1len = s2len = 0; + } else if (TclIsPureByteArray(valuePtr) + && TclIsPureByteArray(value2Ptr)) { + s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len); + s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); + iResult = memcmp(s1, s2, + (size_t) ((s1len < s2len) ? s1len : s2len)); + } else if (((valuePtr->typePtr == &tclStringType) + && (value2Ptr->typePtr == &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. + */ + + s1len = Tcl_GetCharLength(valuePtr); + s2len = Tcl_GetCharLength(value2Ptr); + if ((s1len == valuePtr->length) && (s2len == value2Ptr->length)) { + iResult = memcmp(valuePtr->bytes, value2Ptr->bytes, + (unsigned) ((s1len < s2len) ? s1len : s2len)); + } else { + iResult = TclUniCharNcmp(Tcl_GetUnicode(valuePtr), + Tcl_GetUnicode(value2Ptr), + (unsigned) ((s1len < s2len) ? s1len : s2len)); + } + } else { + /* + * We can't do a simple memcmp in order to handle the special Tcl + * \xC0\x80 null encoding for utf-8. + */ + + s1 = TclGetStringFromObj(valuePtr, &s1len); + s2 = TclGetStringFromObj(value2Ptr, &s2len); + iResult = TclpUtfNcmp2(s1, s2, + (size_t) ((s1len < s2len) ? s1len : s2len)); } /* * Make sure only -1,0,1 is returned * TODO: consider peephole opt. */ + + if (iResult == 0) { + iResult = s1len - s2len; + } if (*pc != INST_STR_CMP) { /* * Take care of the opcodes that goto'ed into here. */ switch (*pc) { - case INST_STR_EQ: - case INST_EQ: - match = (match == 0); - break; - case INST_STR_NEQ: - case INST_NEQ: - match = (match != 0); - break; - case INST_LT: - case INST_STR_LT: - match = (match < 0); - break; - case INST_GT: - case INST_STR_GT: - match = (match > 0); - break; - case INST_LE: - case INST_STR_LE: - match = (match <= 0); - break; - case INST_GE: - case INST_STR_GE: - match = (match >= 0); - break; - } - } - - 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; - slength = Tcl_GetCharLength(valuePtr); - TclNewIntObj(objResultPtr, slength); - TRACE(("\"%.20s\" => %" TCL_Z_MODIFIER "u\n", O2S(valuePtr), slength)); - NEXT_INST_F(1, 1, 1); - - case INST_STR_UPPER: - valuePtr = OBJ_AT_TOS; - TRACE(("\"%.20s\" => ", O2S(valuePtr))); - if (Tcl_IsShared(valuePtr)) { - s1 = TclGetStringFromObj(valuePtr, &slength); - TclNewStringObj(objResultPtr, s1, slength); - slength = Tcl_UtfToUpper(TclGetString(objResultPtr)); - Tcl_SetObjLength(objResultPtr, slength); - TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr))); - NEXT_INST_F(1, 1, 1); - } else { - slength = Tcl_UtfToUpper(TclGetString(valuePtr)); - Tcl_SetObjLength(valuePtr, slength); - 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, &slength); - TclNewStringObj(objResultPtr, s1, slength); - slength = Tcl_UtfToLower(TclGetString(objResultPtr)); - Tcl_SetObjLength(objResultPtr, slength); - TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr))); - NEXT_INST_F(1, 1, 1); - } else { - slength = Tcl_UtfToLower(TclGetString(valuePtr)); - Tcl_SetObjLength(valuePtr, slength); - 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, &slength); - TclNewStringObj(objResultPtr, s1, slength); - slength = Tcl_UtfToTitle(TclGetString(objResultPtr)); - Tcl_SetObjLength(objResultPtr, slength); - TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr))); - NEXT_INST_F(1, 1, 1); - } else { - slength = Tcl_UtfToTitle(TclGetString(valuePtr)); - Tcl_SetObjLength(valuePtr, slength); - 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. - */ - - slength = Tcl_GetCharLength(valuePtr); - DECACHE_STACK_INFO(); - if (TclGetIntForIndexM(interp, value2Ptr, slength-1, &index)!=TCL_OK) { - CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; - } - CACHE_STACK_INFO(); - - if (index >= slength) { - TclNewObj(objResultPtr); - } else if (TclIsPureByteArray(valuePtr)) { - objResultPtr = Tcl_NewByteArrayObj( - Tcl_GetByteArrayFromObj(valuePtr, NULL)+index, 1); - } else if (valuePtr->bytes && slength == valuePtr->length) { - objResultPtr = Tcl_NewStringObj((const char *) - valuePtr->bytes+index, 1); - } else { - char buf[4] = ""; - int ch = Tcl_GetUniChar(valuePtr, index); - - /* - * This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch, 1) - * but creating the object as a string seems to be faster in - * practical use. - */ - if (ch == -1) { - TclNewObj(objResultPtr); - } else { - slength = Tcl_UniCharToUtf(ch, buf); - if ((ch >= 0xD800) && (slength < 3)) { - slength += Tcl_UniCharToUtf(-1, buf + slength); - } - objResultPtr = Tcl_NewStringObj(buf, slength); - } - } - - 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))); - slength = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1; - - DECACHE_STACK_INFO(); - if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, slength, - &fromIdx) != TCL_OK) { - CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; - } - if (TclGetIntForIndexM(interp, OBJ_AT_TOS, slength, - &toIdx) != TCL_OK) { - CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; - } - CACHE_STACK_INFO(); - - if (fromIdx == TCL_INDEX_NONE) { - fromIdx = TCL_INDEX_START; - } - if (toIdx + 1 >= slength + 1) { - toIdx = slength; - } - if (toIdx + 1 >= fromIdx + 1) { - 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); - slength = Tcl_GetCharLength(valuePtr); - TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), (int)(fromIdx), (int)(toIdx))); - - /* Every range of an empty value is an empty value */ - if (slength == 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, slength - 1); - if (toIdx == TCL_INDEX_NONE) { - goto emptyRange; - } else if (toIdx >= slength) { - toIdx = slength - 1; - } - - assert ( toIdx != TCL_INDEX_NONE && toIdx < slength ); - - /* - assert ( fromIdx != TCL_INDEX_NONE ); - * - * Extra safety for legacy bytecodes: - */ - if (fromIdx == TCL_INDEX_NONE) { - fromIdx = TCL_INDEX_START; - } - - fromIdx = TclIndexDecode(fromIdx, slength - 1); - if (fromIdx == TCL_INDEX_NONE) { - fromIdx = TCL_INDEX_START; - } - - if (fromIdx + 1 <= toIdx + 1) { - 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; - size_t length3; - Tcl_Obj *value3Ptr; - - case INST_STR_REPLACE: - value3Ptr = POP_OBJECT(); - valuePtr = OBJ_AT_DEPTH(2); - slength = Tcl_GetCharLength(valuePtr) - 1; - TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr), - O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(value3Ptr))); - DECACHE_STACK_INFO(); - if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, slength, - &fromIdx) != TCL_OK - || TclGetIntForIndexM(interp, OBJ_AT_TOS, slength, - &toIdx) != TCL_OK) { - CACHE_STACK_INFO(); - TclDecrRefCount(value3Ptr); - TRACE_ERROR(interp); - goto gotError; - } - CACHE_STACK_INFO(); - TclDecrRefCount(OBJ_AT_TOS); - (void) POP_OBJECT(); - TclDecrRefCount(OBJ_AT_TOS); - (void) POP_OBJECT(); - - if ((toIdx == TCL_INDEX_NONE) || - (fromIdx + 1 > slength + 1) || - (toIdx + 1 < fromIdx + 1)) { - TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); - TclDecrRefCount(value3Ptr); - NEXT_INST_F(1, 0, 0); - } - - if (fromIdx == TCL_INDEX_NONE) { - fromIdx = TCL_INDEX_START; - } - - if (toIdx + 1 > slength + 1) { - toIdx = slength; - } - - if ((fromIdx == TCL_INDEX_START) && (toIdx == slength)) { - 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, - toIdx - fromIdx + 1, value3Ptr, TCL_STRING_IN_PLACE); - - if (objResultPtr == value3Ptr) { - /* See [Bug 82e7f67325] */ - TclDecrRefCount(OBJ_AT_TOS); - OBJ_AT_TOS = value3Ptr; - TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr))); - NEXT_INST_F(1, 0, 0); - } - TclDecrRefCount(value3Ptr); - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); - NEXT_INST_F(1, 1, 1); - - case INST_STR_MAP: - valuePtr = OBJ_AT_TOS; /* "Main" string. */ - value3Ptr = OBJ_UNDER_TOS; /* "Target" string. */ - value2Ptr = OBJ_AT_DEPTH(2); /* "Source" string. */ - if (value3Ptr == value2Ptr) { - objResultPtr = valuePtr; - goto doneStringMap; - } else if (valuePtr == value2Ptr) { - objResultPtr = value3Ptr; - goto doneStringMap; - } - ustring1 = TclGetUnicodeFromObj(valuePtr, &slength); - if (slength == 0) { - objResultPtr = valuePtr; - goto doneStringMap; - } - ustring2 = TclGetUnicodeFromObj(value2Ptr, &length2); - if (length2 > slength || length2 == 0) { - objResultPtr = valuePtr; - goto doneStringMap; - } else if (length2 == slength) { - if (memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * slength)) { - objResultPtr = valuePtr; - } else { - objResultPtr = value3Ptr; - } - goto doneStringMap; - } - ustring3 = TclGetUnicodeFromObj(value3Ptr, &length3); - - objResultPtr = Tcl_NewUnicodeObj(ustring1, 0); - p = ustring1; - end = ustring1 + slength; - for (; ustring1 < end; ustring1++) { - if ((*ustring1 == *ustring2) && (length2==1 || - memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length2) - == 0)) { - if (p != ustring1) { - TclAppendUnicodeToObj(objResultPtr, p, ustring1-p); - p = ustring1 + length2; - } else { - p += length2; - } - ustring1 = p - 1; - - TclAppendUnicodeToObj(objResultPtr, ustring3, length3); - } - } - if (p != ustring1) { - /* - * Put the rest of the unmapped chars onto result. - */ - - TclAppendUnicodeToObj(objResultPtr, p, ustring1 - p); - } - 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 = TclGetUnicodeFromObj(valuePtr, &slength); - match = 1; - if (slength > 0) { - int ch; - end = ustring1 + slength; - for (p=ustring1 ; p 0); + break; + case INST_LE: + iResult = (iResult <= 0); + break; + case INST_GE: + iResult = (iResult >= 0); + break; + } + } + if (iResult < 0) { + TclNewIntObj(objResultPtr, -1); + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), -1)); + } else { + objResultPtr = constants[(iResult>0)]; + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), + (iResult > 0))); + } + + NEXT_INST_F(1, 2, 1); + } + + case INST_STR_LEN: { + int length; + Tcl_Obj *valuePtr; + + valuePtr = OBJ_AT_TOS; + + if (valuePtr->typePtr == &tclByteArrayType) { + (void) Tcl_GetByteArrayFromObj(valuePtr, &length); + } else { + length = Tcl_GetCharLength(valuePtr); + } + TclNewIntObj(objResultPtr, length); + TRACE(("%.20s => %d\n", O2S(valuePtr), length)); + NEXT_INST_F(1, 1, 1); + } + + case INST_STR_INDEX: { + /* + * String compare. + */ + + int index, length; + char *bytes; + Tcl_Obj *valuePtr, *value2Ptr; + + bytes = NULL; /* lint */ + value2Ptr = OBJ_AT_TOS; + valuePtr = OBJ_UNDER_TOS; + + /* + * If we have a ByteArray object, avoid indexing in the Utf string + * since the byte array contains one byte per character. Otherwise, + * use the Unicode string rep to get the index'th char. + */ + + if (TclIsPureByteArray(valuePtr)) { + bytes = (char *)Tcl_GetByteArrayFromObj(valuePtr, &length); + } else { + /* + * Get Unicode char length to calulate what 'end' means. + */ + + length = Tcl_GetCharLength(valuePtr); + } + + result = TclGetIntForIndexM(interp, value2Ptr, length - 1, &index); + if (result != TCL_OK) { + goto checkForCatch; + } + + if ((index >= 0) && (index < length)) { + if (TclIsPureByteArray(valuePtr)) { + objResultPtr = Tcl_NewByteArrayObj((unsigned char *) + (&bytes[index]), 1); + } else if (valuePtr->bytes && length == valuePtr->length) { + objResultPtr = Tcl_NewStringObj((const char *) + (&valuePtr->bytes[index]), 1); + } else { + char buf[TCL_UTF_MAX]; + Tcl_UniChar ch; + + 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. + */ + + length = Tcl_UniCharToUtf(ch, buf); + objResultPtr = Tcl_NewStringObj(buf, length); + } + } else { + TclNewObj(objResultPtr); + } + + TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr), + O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + + case INST_STR_MATCH: { + int nocase, match; + Tcl_Obj *valuePtr, *value2Ptr; + nocase = TclGetInt1AtPtr(pc+1); valuePtr = OBJ_AT_TOS; /* String */ value2Ptr = OBJ_UNDER_TOS; /* Pattern */ /* * Check that at least one of the objects is Unicode before promoting * both. */ - if (TclHasIntRep(valuePtr, &tclStringType) - || TclHasIntRep(value2Ptr, &tclStringType)) { + if ((valuePtr->typePtr == &tclStringType) + || (value2Ptr->typePtr == &tclStringType)) { Tcl_UniChar *ustring1, *ustring2; + int length1, length2; - ustring1 = TclGetUnicodeFromObj(valuePtr, &slength); - ustring2 = TclGetUnicodeFromObj(value2Ptr, &length2); - match = TclUniCharMatch(ustring1, slength, ustring2, length2, + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length1); + ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); + match = TclUniCharMatch(ustring1, length1, ustring2, length2, nocase); } else if (TclIsPureByteArray(valuePtr) && !nocase) { - unsigned char *bytes1, *bytes2; - size_t wlen1 = 0, wlen2 = 0; + unsigned char *string1, *string2; + int length1, length2; - bytes1 = TclGetByteArrayFromObj(valuePtr, &wlen1); - bytes2 = TclGetByteArrayFromObj(value2Ptr, &wlen2); - match = TclByteArrayMatch(bytes1, wlen1, bytes2, wlen2, 0); + string1 = Tcl_GetByteArrayFromObj(valuePtr, &length1); + string2 = Tcl_GetByteArrayFromObj(value2Ptr, &length2); + match = TclByteArrayMatch(string1, length1, string2, 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 + * TODO: consider peephole opt. */ 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; - size_t trim1, trim2; - - case INST_STR_TRIM_LEFT: - valuePtr = OBJ_UNDER_TOS; /* String */ - value2Ptr = OBJ_AT_TOS; /* TrimSet */ - string2 = TclGetStringFromObj(value2Ptr, &length2); - string1 = TclGetStringFromObj(valuePtr, &slength); - trim1 = TclTrimLeft(string1, slength, string2, length2); - trim2 = 0; - goto createTrimmedString; - case INST_STR_TRIM_RIGHT: - valuePtr = OBJ_UNDER_TOS; /* String */ - value2Ptr = OBJ_AT_TOS; /* TrimSet */ - string2 = TclGetStringFromObj(value2Ptr, &length2); - string1 = TclGetStringFromObj(valuePtr, &slength); - trim2 = TclTrimRight(string1, slength, string2, length2); - trim1 = 0; - goto createTrimmedString; - case INST_STR_TRIM: - valuePtr = OBJ_UNDER_TOS; /* String */ - value2Ptr = OBJ_AT_TOS; /* TrimSet */ - string2 = TclGetStringFromObj(value2Ptr, &length2); - string1 = TclGetStringFromObj(valuePtr, &slength); - trim1 = TclTrim(string1, slength, string2, length2, &trim2); - createTrimmedString: - /* - * Careful here; trim set often contains non-ASCII characters so we - * take care when printing. [Bug 971cb4f1db] - */ - -#ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - TRACE(("\"%.30s\" ", O2S(valuePtr))); - TclPrintObject(stdout, value2Ptr, 30); - printf(" => "); - } -#endif - if (trim1 == 0 && trim2 == 0) { -#ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - TclPrintObject(stdout, valuePtr, 30); - printf("\n"); - } -#endif - NEXT_INST_F(1, 1, 0); - } else { - objResultPtr = Tcl_NewStringObj(string1+trim1, slength-trim1-trim2); -#ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - TclPrintObject(stdout, objResultPtr, 30); - printf("\n"); - } -#endif - NEXT_INST_F(1, 2, 1); - } - } - - case INST_REGEXP: + objResultPtr = constants[match]; + NEXT_INST_F(2, 2, 1); + } + + case INST_REGEXP: { + int cflags, match; + Tcl_Obj *valuePtr, *value2Ptr; + Tcl_RegExp regExpr; + cflags = TclGetInt1AtPtr(pc+1); /* RE compile flages like NOCASE */ valuePtr = OBJ_AT_TOS; /* String */ value2Ptr = OBJ_UNDER_TOS; /* Pattern */ - TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); - - /* - * Compile and match the regular expression. - */ - - { - Tcl_RegExp regExpr = - Tcl_GetRegExpFromObj(interp, value2Ptr, cflags); - - if (regExpr == NULL) { - TRACE_ERROR(interp); - goto gotError; - } + + regExpr = Tcl_GetRegExpFromObj(interp, value2Ptr, cflags); + if (regExpr == NULL) { + match = -1; + } else { match = Tcl_RegExpExecObj(interp, regExpr, valuePtr, 0, 0, 0); - if (match < 0) { - TRACE_ERROR(interp); - goto gotError; - } - } - - TRACE_APPEND(("%d\n", match)); - - /* - * Peep-hole optimisation: if you're about to jump, do jump from here. - * Adjustment is 2 due to the nocase byte. - */ - - JUMP_PEEPHOLE_F(match, 2, 2); - } - - /* - * End of string-related instructions. - * ----------------------------------------------------------------- - * Start of numeric operator instructions. - */ - - { - ClientData ptr1, ptr2; - int type1, type2; - Tcl_WideInt w1, w2, wResult; - - case INST_NUM_TYPE: - if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) { - type1 = 0; - } else if (type1 == TCL_NUMBER_BIG) { - /* value is an integer outside the WIDE_MIN to WIDE_MAX range */ - /* [string is wideinteger] is WIDE_MIN to WIDE_MAX range */ - Tcl_WideInt w; - - if (TclGetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) { - type1 = TCL_NUMBER_INT; - } - } - TclNewIntObj(objResultPtr, type1); - TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1)); - NEXT_INST_F(1, 1, 1); + } + + /* + * Adjustment is 2 due to the nocase byte + */ + + if (match < 0) { + objResultPtr = Tcl_GetObjResult(interp); + TRACE_WITH_OBJ(("%.20s %.20s => ERROR: ", + O2S(valuePtr), O2S(value2Ptr)), objResultPtr); + result = TCL_ERROR; + goto checkForCatch; + } else { + TRACE(("%.20s %.20s => %d\n", + O2S(valuePtr), O2S(value2Ptr), match)); + objResultPtr = constants[match]; + NEXT_INST_F(2, 2, 1); + } + } case INST_EQ: case INST_NEQ: case INST_LT: case INST_GT: case INST_LE: case INST_GE: { - int iResult = 0, compare = 0; - - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; - - /* - Try to determine, without triggering generation of a string - representation, whether one value is not a number. - */ - if (TclCheckEmptyString(valuePtr) > 0 || TclCheckEmptyString(value2Ptr) > 0) { - goto stringCompare; - } + Tcl_Obj *valuePtr = OBJ_UNDER_TOS; + Tcl_Obj *value2Ptr = OBJ_AT_TOS; + ClientData ptr1, ptr2; + int iResult = 0, compare = 0, type1, type2; + double d1, d2, tmp; + long l1, l2; + mp_int big1, big2; +#ifndef NO_WIDE_TYPE + Tcl_WideInt w1, w2; +#endif if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK || GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) { /* * At least one non-numeric argument - compare as strings. @@ -5590,16 +4566,226 @@ } if (valuePtr == value2Ptr) { compare = MP_EQ; goto convertComparison; } - if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) { + switch (type1) { + case TCL_NUMBER_LONG: + l1 = *((const long *)ptr1); + switch (type2) { + case TCL_NUMBER_LONG: + l2 = *((const long *)ptr2); + longCompare: + compare = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); + break; +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: + w2 = *((const Tcl_WideInt *)ptr2); + w1 = (Tcl_WideInt)l1; + goto wideCompare; +#endif + case TCL_NUMBER_DOUBLE: + d2 = *((const double *)ptr2); + d1 = (double) l1; + + /* + * If the double has a fractional part, or if the long can be + * converted to double without loss of precision, then compare + * as doubles. + */ + + if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) + || l1 == (long) d1 + || modf(d2, &tmp) != 0.0) { + goto doubleCompare; + } + + /* + * Otherwise, to make comparision based on full precision, + * need to convert the double to a suitably sized integer. + * + * Need this to get comparsions like + * expr 20000000000000003 < 20000000000000004.0 + * right. Converting the first argument to double will yield + * two double values that are equivalent within double + * precision. Converting the double to an integer gets done + * exactly, then integer comparison can tell the difference. + */ + + if (d2 < (double)LONG_MIN) { + compare = MP_GT; + break; + } + if (d2 > (double)LONG_MAX) { + compare = MP_LT; + break; + } + l2 = (long) d2; + goto longCompare; + case TCL_NUMBER_BIG: + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + if (mp_cmp_d(&big2, 0) == MP_LT) { + compare = MP_GT; + } else { + compare = MP_LT; + } + mp_clear(&big2); + } + break; + +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: w1 = *((const Tcl_WideInt *)ptr1); - w2 = *((const Tcl_WideInt *)ptr2); - compare = (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); - } else { - compare = TclCompareTwoNumbers(valuePtr, value2Ptr); + switch (type2) { + case TCL_NUMBER_WIDE: + w2 = *((const Tcl_WideInt *)ptr2); + wideCompare: + compare = (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); + break; + case TCL_NUMBER_LONG: + l2 = *((const long *)ptr2); + w2 = (Tcl_WideInt)l2; + goto wideCompare; + case TCL_NUMBER_DOUBLE: + d2 = *((const double *)ptr2); + d1 = (double) w1; + if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) + || w1 == (Tcl_WideInt) d1 + || modf(d2, &tmp) != 0.0) { + goto doubleCompare; + } + if (d2 < (double)LLONG_MIN) { + compare = MP_GT; + break; + } + if (d2 > (double)LLONG_MAX) { + compare = MP_LT; + break; + } + w2 = (Tcl_WideInt) d2; + goto wideCompare; + case TCL_NUMBER_BIG: + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + if (mp_cmp_d(&big2, 0) == MP_LT) { + compare = MP_GT; + } else { + compare = MP_LT; + } + mp_clear(&big2); + } + break; +#endif + + case TCL_NUMBER_DOUBLE: + d1 = *((const double *)ptr1); + switch (type2) { + case TCL_NUMBER_DOUBLE: + d2 = *((const double *)ptr2); + doubleCompare: + compare = (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ); + break; + case TCL_NUMBER_LONG: + l2 = *((const long *)ptr2); + d2 = (double) l2; + if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) + || l2 == (long) d2 + || modf(d1, &tmp) != 0.0) { + goto doubleCompare; + } + if (d1 < (double)LONG_MIN) { + compare = MP_LT; + break; + } + if (d1 > (double)LONG_MAX) { + compare = MP_GT; + break; + } + l1 = (long) d1; + goto longCompare; +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: + w2 = *((const Tcl_WideInt *)ptr2); + d2 = (double) w2; + if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) + || w2 == (Tcl_WideInt) d2 + || modf(d1, &tmp) != 0.0) { + goto doubleCompare; + } + if (d1 < (double)LLONG_MIN) { + compare = MP_LT; + break; + } + if (d1 > (double)LLONG_MAX) { + compare = MP_GT; + break; + } + w1 = (Tcl_WideInt) d1; + goto wideCompare; +#endif + case TCL_NUMBER_BIG: + if (TclIsInfinite(d1)) { + compare = (d1 > 0.0) ? MP_GT : MP_LT; + break; + } + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + if ((d1 < (double)LONG_MAX) && (d1 > (double)LONG_MIN)) { + if (mp_cmp_d(&big2, 0) == MP_LT) { + compare = MP_GT; + } else { + compare = MP_LT; + } + mp_clear(&big2); + break; + } + 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) { +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: +#endif + case TCL_NUMBER_LONG: + compare = mp_cmp_d(&big1, 0); + mp_clear(&big1); + break; + case TCL_NUMBER_DOUBLE: + d2 = *((const double *)ptr2); + if (TclIsInfinite(d2)) { + compare = (d2 > 0.0) ? MP_LT : MP_GT; + mp_clear(&big1); + break; + } + if ((d2 < (double)LONG_MAX) && (d2 > (double)LONG_MIN)) { + compare = mp_cmp_d(&big1, 0); + mp_clear(&big1); + break; + } + if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) + && modf(d2, &tmp) != 0.0) { + d1 = TclBignumToDouble(&big1); + mp_clear(&big1); + goto doubleCompare; + } + Tcl_InitBignumFromDouble(NULL, d2, &big2); + goto bigCompare; + case TCL_NUMBER_BIG: + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + bigCompare: + compare = mp_cmp(&big1, &big2); + mp_clear(&big1); + mp_clear(&big2); + } } /* * Turn comparison outcome into appropriate result for opcode. */ @@ -5629,253 +4815,643 @@ /* * Peep-hole optimisation: if you're about to jump, do jump from here. */ foundResult: - TRACE(("\"%.20s\" \"%.20s\" => %d\n", O2S(valuePtr), O2S(value2Ptr), - iResult)); - JUMP_PEEPHOLE_F(iResult, 1, 2); + pc++; +#ifndef TCL_COMPILE_DEBUG + switch (*pc) { + case INST_JUMP_FALSE1: + NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); + case INST_JUMP_TRUE1: + NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0); + case INST_JUMP_FALSE4: + NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); + case INST_JUMP_TRUE4: + NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0); + } +#endif + objResultPtr = constants[iResult]; + NEXT_INST_F(0, 2, 1); } case INST_MOD: case INST_LSHIFT: - case INST_RSHIFT: - case INST_BITOR: - case INST_BITXOR: - case INST_BITAND: - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; - - if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) - || (type1==TCL_NUMBER_DOUBLE) || (type1==TCL_NUMBER_NAN)) { + case INST_RSHIFT: { + Tcl_Obj *value2Ptr = OBJ_AT_TOS; + Tcl_Obj *valuePtr = OBJ_UNDER_TOS; + ClientData ptr1, ptr2; + int invalid, shift, type1, type2; + long l1 = 0; + + result = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); + if ((result != TCL_OK) || (type1 == TCL_NUMBER_DOUBLE) + || (type1 == TCL_NUMBER_NAN)) { + result = TCL_ERROR; TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr), O2S(value2Ptr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); CACHE_STACK_INFO(); - goto gotError; + goto checkForCatch; } - if ((GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) - || (type2==TCL_NUMBER_DOUBLE) || (type2==TCL_NUMBER_NAN)) { + result = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); + if ((result != TCL_OK) || (type2 == TCL_NUMBER_DOUBLE) + || (type2 == TCL_NUMBER_NAN)) { + result = TCL_ERROR; TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr), O2S(value2Ptr), (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, value2Ptr); CACHE_STACK_INFO(); - goto gotError; + goto checkForCatch; } - /* - * Check for common, simple case. - */ - - if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) { - w1 = *((const Tcl_WideInt *)ptr1); - w2 = *((const Tcl_WideInt *)ptr2); - - switch (*pc) { - case INST_MOD: - if (w2 == 0) { + if (*pc == INST_MOD) { + /* TODO: Attempts to re-use unshared operands on stack */ + + long l2 = 0; /* silence gcc warning */ + + if (type2 == TCL_NUMBER_LONG) { + l2 = *((const long *)ptr2); + if (l2 == 0) { TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), O2S(value2Ptr))); goto divideByZero; - } else if ((w2 == 1) || (w2 == -1)) { + } + if ((l2 == 1) || (l2 == -1)) { /* * Div. by |1| always yields remainder of 0. */ - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - objResultPtr = TCONST(0); + objResultPtr = constants[0]; TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); - } else if (w1 == 0) { + } + } + if (type1 == TCL_NUMBER_LONG) { + l1 = *((const long *)ptr1); + if (l1 == 0) { /* * 0 % (non-zero) always yields remainder of 0. */ - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - objResultPtr = TCONST(0); + objResultPtr = constants[0]; + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + if (type2 == TCL_NUMBER_LONG) { + /* + * Both operands are long; do native calculation. + */ + + long lRemainder, lQuotient = l1 / l2; + + /* + * Force Tcl's integer division rules. + * TODO: examine for logic simplification + */ + + if ((lQuotient < 0 || (lQuotient == 0 && + ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) && + (lQuotient * l2 != l1)) { + lQuotient -= 1; + } + lRemainder = l1 - l2*lQuotient; + TclNewLongObj(objResultPtr, lRemainder); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + + /* + * First operand fits in long; second does not, so the second + * has greater magnitude than first. No need to divide to + * determine the remainder. + */ + +#ifndef NO_WIDE_TYPE + if (type2 == TCL_NUMBER_WIDE) { + Tcl_WideInt w2 = *((const Tcl_WideInt *)ptr2); + + if ((l1 > 0) ^ (w2 > (Tcl_WideInt)0)) { + /* + * Arguments are opposite sign; remainder is sum. + */ + + objResultPtr = Tcl_NewWideIntObj(w2+(Tcl_WideInt)l1); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + + /* + * Arguments are same sign; remainder is first operand. + */ + + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } +#endif + { + mp_int big1, big2; + + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + + if ((l1 > 0) ^ mp_isneg(&big2)) { + /* + * Arguments are same sign; remainder is first operand. + */ + + mp_clear(&big2); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + + /* + * Arguments are opposite sign; remainder is sum. + */ + + TclBNInitBignumFromLong(&big1, l1); + mp_add(&big2, &big1, &big2); + mp_clear(&big1); + objResultPtr = Tcl_NewBignumObj(&big2); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); - } else { - wResult = w1 / w2; + } + } +#ifndef NO_WIDE_TYPE + if (type1 == TCL_NUMBER_WIDE) { + Tcl_WideInt w1 = *((const Tcl_WideInt *)ptr1); + + if (type2 != TCL_NUMBER_BIG) { + Tcl_WideInt w2, wQuotient, wRemainder; + + Tcl_GetWideIntFromObj(NULL, value2Ptr, &w2); + wQuotient = w1 / w2; /* * Force Tcl's integer division rules. * TODO: examine for logic simplification */ - if ((wResult < 0 || (wResult == 0 && - ((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(); - Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", - "domain error: argument not in valid range", - NULL); - CACHE_STACK_INFO(); -#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ - goto gotError; - } else if (w1 == 0) { - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - objResultPtr = TCONST(0); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } else { - /* - * Quickly force large right shifts to 0 or -1. - */ - - if (w2 >= (Tcl_WideInt)(CHAR_BIT*sizeof(long))) { - /* - * We assume that INT_MAX is much larger than the - * number of bits in a long. This is a pretty safe - * assumption, given that the former is usually around - * 4e9 and the latter 32 or 64... - */ - - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if (w1 > 0L) { - objResultPtr = TCONST(0); - } else { - TclNewIntObj(objResultPtr, -1); - } - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } - - /* - * 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(); - Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", - "domain error: argument not in valid range", - NULL); - CACHE_STACK_INFO(); -#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ - goto gotError; - } else if (w1 == 0) { - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - objResultPtr = TCONST(0); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } else if (w2 > INT_MAX) { - /* - * Technically, we could hold the value (1 << (INT_MAX+1)) - * in an mp_int, but since we're using mp_mul_2d() to do - * the work, and it takes only an int argument, that's a - * good place to draw the line. - */ - - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "integer value too large to represent", -1)); -#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", - "integer value too large to represent", NULL); - CACHE_STACK_INFO(); -#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ - goto gotError; - } else { - int shift = (int) w2; - - /* - * Handle shifts within the native long range. - */ - - if ((size_t) shift < CHAR_BIT*sizeof(long) && (w1 != 0) - && !((w1>0 ? w1 : ~w1) & - -(1L<<(CHAR_BIT*sizeof(long) - 1 - shift)))) { - wResult = w1 << shift; - goto wideResultOfArithmetic; - } - } - - /* - * Too large; need to use the broken-out function. - */ - - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - break; - - case INST_BITAND: - wResult = w1 & w2; - goto wideResultOfArithmetic; - case INST_BITOR: - wResult = w1 | w2; - goto wideResultOfArithmetic; - case INST_BITXOR: - wResult = w1 ^ w2; - goto wideResultOfArithmetic; - } - } - - /* - * DO NOT MERGE THIS WITH THE EQUIVALENT SECTION LATER! That would - * encourage the compiler to inline ExecuteExtendedBinaryMathOp, which - * is highly undesirable due to the overall impact on size. - */ - - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - objResultPtr = ExecuteExtendedBinaryMathOp(interp, *pc, &TCONST(0), - valuePtr, value2Ptr); - if (objResultPtr == DIVIDED_BY_ZERO) { - TRACE_APPEND(("DIVIDE BY ZERO\n")); - goto divideByZero; - } 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); - } + if (((wQuotient < (Tcl_WideInt) 0) + || ((wQuotient == (Tcl_WideInt) 0) + && ((w1 < (Tcl_WideInt)0 && w2 > (Tcl_WideInt)0) + || (w1 > (Tcl_WideInt)0 && w2 < (Tcl_WideInt)0)))) + && (wQuotient * w2 != w1)) { + wQuotient -= (Tcl_WideInt) 1; + } + wRemainder = w1 - w2*wQuotient; + objResultPtr = Tcl_NewWideIntObj(wRemainder); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + { + mp_int big1, big2; + + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + + /* TODO: internals intrusion */ + if ((w1 > ((Tcl_WideInt) 0)) ^ mp_isneg(&big2)) { + /* + * Arguments are same sign; remainder is first operand. + */ + + mp_clear(&big2); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + /* + * Arguments are opposite sign; remainder is sum. + */ + + TclBNInitBignumFromWideInt(&big1, w1); + mp_add(&big2, &big1, &big2); + mp_clear(&big1); + objResultPtr = Tcl_NewBignumObj(&big2); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + + } + } +#endif + { + mp_int big1, big2, bigResult, bigRemainder; + + Tcl_GetBignumFromObj(NULL, valuePtr, &big1); + Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); + mp_init(&bigResult); + mp_init(&bigRemainder); + mp_div(&big1, &big2, &bigResult, &bigRemainder); + if (!mp_iszero(&bigRemainder) + && (mp_isneg(&bigRemainder) != mp_isneg(&big2))) { + /* + * Convert to Tcl's integer division rules. + */ + + mp_sub_d(&bigResult, 1, &bigResult); + mp_add(&bigRemainder, &big2, &bigRemainder); + } + mp_copy(&bigRemainder, &bigResult); + mp_clear(&bigRemainder); + mp_clear(&big1); + mp_clear(&big2); + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewBignumObj(&bigResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + Tcl_SetBignumObj(valuePtr, &bigResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + } + + /* + * Reject negative shift argument. + */ + + switch (type2) { + case TCL_NUMBER_LONG: + invalid = (*((const long *)ptr2) < (long)0); + break; +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: + invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0); + break; +#endif + case TCL_NUMBER_BIG: { + mp_int big2; + + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + invalid = (mp_cmp_d(&big2, 0) == MP_LT); + mp_clear(&big2); + break; + } + default: + /* Unused, here to silence compiler warning */ + invalid = 0; + } + if (invalid) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("negative shift argument", -1)); + result = TCL_ERROR; + goto checkForCatch; + } + + /* + * Zero shifted any number of bits is still zero. + */ + + if ((type1==TCL_NUMBER_LONG) && (*((const long *)ptr1) == (long)0)) { + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + objResultPtr = constants[0]; + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + + if (*pc == INST_LSHIFT) { + /* + * Large left shifts create integer overflow. + * + * BEWARE! Can't use Tcl_GetIntFromObj() here because that + * converts values in the (unsigned) range to their signed int + * counterparts, leading to incorrect results. + */ + + if ((type2 != TCL_NUMBER_LONG) + || (*((const long *)ptr2) > (long) INT_MAX)) { + /* + * Technically, we could hold the value (1 << (INT_MAX+1)) in + * an mp_int, but since we're using mp_mul_2d() to do the + * work, and it takes only an int argument, that's a good + * place to draw the line. + */ + + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "integer value too large to represent", -1)); + result = TCL_ERROR; + goto checkForCatch; + } + shift = (int)(*((const long *)ptr2)); + + /* + * Handle shifts within the native long range. + */ + + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if ((type1 == TCL_NUMBER_LONG) + && (size_t) shift < CHAR_BIT*sizeof(long) + && ((l1 = *(const long *)ptr1) != 0) + && !((l1>0 ? l1 : ~l1) + & -(1L<<(CHAR_BIT*sizeof(long) - 1 - shift)))) { + TclNewLongObj(objResultPtr, (l1< ", O2S(valuePtr), O2S(value2Ptr))); + if ((type1 != TCL_NUMBER_BIG) + && ((size_t)shift < CHAR_BIT*sizeof(Tcl_WideInt))) { + Tcl_WideInt w; + + TclGetWideIntFromObj(NULL, valuePtr, &w); + if (!((w>0 ? w : ~w) + & -(((Tcl_WideInt)1) + << (CHAR_BIT*sizeof(Tcl_WideInt) - 1 - shift)))) { + objResultPtr = Tcl_NewWideIntObj(w< ", O2S(valuePtr), O2S(value2Ptr))); + if ((type2 != TCL_NUMBER_LONG) + || (*(const long *)ptr2 > INT_MAX)) { + /* + * Again, technically, the value to be shifted could be an + * mp_int so huge that a right shift by (INT_MAX+1) bits could + * not take us to the result of 0 or -1, but since we're using + * mp_div_2d to do the work, and it takes only an int + * argument, we draw the line there. + */ + + int zero; + + switch (type1) { + case TCL_NUMBER_LONG: + zero = (*(const long *)ptr1 > 0L); + break; +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: + zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0); + break; +#endif + case TCL_NUMBER_BIG: { + mp_int big1; + Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); + zero = (mp_cmp_d(&big1, 0) == MP_GT); + mp_clear(&big1); + break; + } + default: + /* Unused, here to silence compiler warning. */ + zero = 0; + } + if (zero) { + objResultPtr = constants[0]; + } else { + TclNewIntObj(objResultPtr, -1); + } + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + shift = (int)(*(const long *)ptr2); + + /* + * Handle shifts within the native long range. + */ + + if (type1 == TCL_NUMBER_LONG) { + l1 = *((const long *)ptr1); + if ((size_t)shift >= CHAR_BIT*sizeof(long)) { + if (l1 >= (long)0) { + objResultPtr = constants[0]; + } else { + TclNewIntObj(objResultPtr, -1); + } + } else { + TclNewLongObj(objResultPtr, (l1 >> shift)); + } + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + +#ifndef NO_WIDE_TYPE + /* + * Handle shifts within the native wide range. + */ + + if (type1 == TCL_NUMBER_WIDE) { + Tcl_WideInt w = *(const Tcl_WideInt *)ptr1; + + if ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideInt)) { + if (w >= (Tcl_WideInt)0) { + objResultPtr = constants[0]; + } else { + TclNewIntObj(objResultPtr, -1); + } + } else { + objResultPtr = Tcl_NewWideIntObj(w >> shift); + } + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } +#endif + } + + { + mp_int big, bigResult, bigRemainder; + + Tcl_TakeBignumFromObj(NULL, valuePtr, &big); + + mp_init(&bigResult); + if (*pc == INST_LSHIFT) { + mp_mul_2d(&big, shift, &bigResult); + } else { + mp_init(&bigRemainder); + mp_div_2d(&big, shift, &bigResult, &bigRemainder); + if (mp_cmp_d(&bigRemainder, 0) == MP_LT) { + /* + * Convert to Tcl's integer division rules. + */ + + mp_sub_d(&bigResult, 1, &bigResult); + } + mp_clear(&bigRemainder); + } + mp_clear(&big); + + if (!Tcl_IsShared(valuePtr)) { + Tcl_SetBignumObj(valuePtr, &bigResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + objResultPtr = Tcl_NewBignumObj(&bigResult); + } + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + + case INST_BITOR: + case INST_BITXOR: + case INST_BITAND: { + ClientData ptr1, ptr2; + int type1, type2; + Tcl_Obj *value2Ptr = OBJ_AT_TOS; + Tcl_Obj *valuePtr = OBJ_UNDER_TOS; + + result = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); + if ((result != TCL_OK) + || (type1 == TCL_NUMBER_NAN) + || (type1 == TCL_NUMBER_DOUBLE)) { + result = TCL_ERROR; + TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr), + O2S(value2Ptr), (valuePtr->typePtr? + valuePtr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); + IllegalExprOperandType(interp, pc, valuePtr); + CACHE_STACK_INFO(); + goto checkForCatch; + } + result = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); + if ((result != TCL_OK) || (type2 == TCL_NUMBER_NAN) + || (type2 == TCL_NUMBER_DOUBLE)) { + result = TCL_ERROR; + TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr), + O2S(value2Ptr), (value2Ptr->typePtr? + value2Ptr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); + IllegalExprOperandType(interp, pc, value2Ptr); + CACHE_STACK_INFO(); + goto checkForCatch; + } + + if ((type1 == TCL_NUMBER_BIG) || (type2 == TCL_NUMBER_BIG)) { + mp_int big1, big2, bigResult; + + Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + + mp_init(&bigResult); + + switch (*pc) { + case INST_BITAND: + mp_and(&big1, &big2, &bigResult); + break; + + case INST_BITOR: + mp_or(&big1, &big2, &bigResult); + break; + + case INST_BITXOR: + mp_xor(&big1, &big2, &bigResult); + break; + } + + mp_clear(&big1); + mp_clear(&big2); + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewBignumObj(&bigResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + Tcl_SetBignumObj(valuePtr, &bigResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + +#ifndef NO_WIDE_TYPE + if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) { + Tcl_WideInt wResult, w1, w2; + + TclGetWideIntFromObj(NULL, valuePtr, &w1); + TclGetWideIntFromObj(NULL, value2Ptr, &w2); + + switch (*pc) { + case INST_BITAND: + wResult = w1 & w2; + break; + case INST_BITOR: + wResult = w1 | w2; + break; + case INST_BITXOR: + wResult = w1 ^ w2; + break; + default: + /* Unused, here to silence compiler warning. */ + wResult = 0; + } + + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewWideIntObj(wResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + Tcl_SetWideIntObj(valuePtr, wResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } +#endif + { + long lResult, l1 = *((const long *)ptr1); + long l2 = *((const long *)ptr2); + + switch (*pc) { + case INST_BITAND: + lResult = l1 & l2; + break; + case INST_BITOR: + lResult = l1 | l2; + break; + case INST_BITXOR: + lResult = l1 ^ l2; + break; + default: + /* Unused, here to silence compiler warning. */ + lResult = 0; + } + + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + TclNewLongObj(objResultPtr, lResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + TclSetLongObj(valuePtr, lResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + } case INST_EXPON: case INST_ADD: case INST_SUB: case INST_DIV: - case INST_MULT: - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; + case INST_MULT: { + ClientData ptr1, ptr2; + int type1, type2; + Tcl_Obj *value2Ptr = OBJ_AT_TOS; + Tcl_Obj *valuePtr = OBJ_UNDER_TOS; - if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) - || IsErroringNaNType(type1)) { + result = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); + if ((result != TCL_OK) +#ifndef ACCEPT_NAN + || (type1 == TCL_NUMBER_NAN) +#endif + ) { + result = TCL_ERROR; TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(value2Ptr), O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name: "null"))); DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); CACHE_STACK_INFO(); - goto gotError; + goto checkForCatch; } #ifdef ACCEPT_NAN if (type1 == TCL_NUMBER_NAN) { /* @@ -5884,19 +5460,24 @@ NEXT_INST_F(1, 1, 0); } #endif - if ((GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) - || IsErroringNaNType(type2)) { + result = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); + if ((result != TCL_OK) +#ifndef ACCEPT_NAN + || (type2 == TCL_NUMBER_NAN) +#endif + ) { + result = TCL_ERROR; TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(value2Ptr), O2S(valuePtr), (value2Ptr->typePtr? value2Ptr->typePtr->name: "null"))); DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, value2Ptr); CACHE_STACK_INFO(); - goto gotError; + goto checkForCatch; } #ifdef ACCEPT_NAN if (type2 == TCL_NUMBER_NAN) { /* @@ -5906,68 +5487,611 @@ objResultPtr = value2Ptr; NEXT_INST_F(1, 2, 1); } #endif - /* - * Handle (long,long) arithmetic as best we can without going out to - * an external function. - */ - - if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) { - w1 = *((const Tcl_WideInt *)ptr1); - w2 = *((const Tcl_WideInt *)ptr2); + if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) { + /* + * At least one of the values is floating-point, so perform + * floating point calculations. + */ + + double d1, d2, dResult; + + Tcl_GetDoubleFromObj(NULL, valuePtr, &d1); + Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2); + + switch (*pc) { + case INST_ADD: + dResult = d1 + d2; + break; + case INST_SUB: + dResult = d1 - d2; + break; + case INST_MULT: + dResult = d1 * d2; + break; + case INST_DIV: +#ifndef IEEE_FLOATING_POINT + if (d2 == 0.0) { + TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2)); + goto divideByZero; + } +#endif + /* + * We presume that we are running with zero-divide unmasked if + * we're on an IEEE box. Otherwise, this statement might cause + * demons to fly out our noses. + */ + + dResult = d1 / d2; + break; + case INST_EXPON: + if (d1==0.0 && d2<0.0) { + TRACE(("%.6g %.6g => EXPONENT OF ZERO\n", d1, d2)); + goto exponOfZero; + } + dResult = pow(d1, d2); + break; + default: + /* Unused, here to silence compiler warning. */ + dResult = 0; + } + +#ifndef ACCEPT_NAN + /* + * Check now for IEEE floating-point error. + */ + + if (TclIsNaN(dResult)) { + TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n", + O2S(valuePtr), O2S(value2Ptr))); + DECACHE_STACK_INFO(); + TclExprFloatError(interp, dResult); + CACHE_STACK_INFO(); + result = TCL_ERROR; + goto checkForCatch; + } +#endif + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + TclNewDoubleObj(objResultPtr, dResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + TclSetDoubleObj(valuePtr, dResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + + if ((sizeof(long) >= 2*sizeof(int)) && (*pc == INST_MULT) + && (type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { + long l1 = *((const long *)ptr1); + long l2 = *((const long *)ptr2); + + if ((l1 <= INT_MAX) && (l1 >= INT_MIN) + && (l2 <= INT_MAX) && (l2 >= INT_MIN)) { + long lResult = l1 * l2; + + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + TclNewLongObj(objResultPtr,lResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + TclSetLongObj(valuePtr, lResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + } + + if ((sizeof(Tcl_WideInt) >= 2*sizeof(long)) && (*pc == INST_MULT) + && (type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { + Tcl_WideInt w1, w2, wResult; + TclGetWideIntFromObj(NULL, valuePtr, &w1); + TclGetWideIntFromObj(NULL, value2Ptr, &w2); + + wResult = w1 * w2; + + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewWideIntObj(wResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + Tcl_SetWideIntObj(valuePtr, wResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + + /* TODO: Attempts to re-use unshared operands on stack. */ + if (*pc == INST_EXPON) { + long l1 = 0, l2 = 0; + int oddExponent = 0, negativeExponent = 0; +#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) + Tcl_WideInt w1; +#endif + + if (type2 == TCL_NUMBER_LONG) { + l2 = *((const long *) ptr2); + if (l2 == 0) { + /* + * Anything to the zero power is 1. + */ + + objResultPtr = constants[1]; + NEXT_INST_F(1, 2, 1); + } else if (l2 == 1) { + /* + * Anything to the first power is itself + */ + NEXT_INST_F(1, 1, 0); + } + } + + switch (type2) { + case TCL_NUMBER_LONG: { + negativeExponent = (l2 < 0); + oddExponent = (int) (l2 & 1); + break; + } +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: { + Tcl_WideInt w2 = *((const Tcl_WideInt *)ptr2); + + negativeExponent = (w2 < 0); + oddExponent = (int) (w2 & (Tcl_WideInt)1); + break; + } +#endif + case TCL_NUMBER_BIG: { + mp_int big2; + + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + negativeExponent = (mp_cmp_d(&big2, 0) == MP_LT); + mp_mod_2d(&big2, 1, &big2); + oddExponent = !mp_iszero(&big2); + mp_clear(&big2); + break; + } + } + + if (type1 == TCL_NUMBER_LONG) { + l1 = *((const long *)ptr1); + } + if (negativeExponent) { + if (type1 == TCL_NUMBER_LONG) { + switch (l1) { + case 0: + /* + * Zero to a negative power is div by zero error. + */ + + TRACE(("%s %s => EXPONENT OF ZERO\n", O2S(valuePtr), + O2S(value2Ptr))); + goto exponOfZero; + case -1: + if (oddExponent) { + TclNewIntObj(objResultPtr, -1); + } else { + objResultPtr = constants[1]; + } + NEXT_INST_F(1, 2, 1); + case 1: + /* + * 1 to any power is 1. + */ + + objResultPtr = constants[1]; + NEXT_INST_F(1, 2, 1); + } + } + + /* + * Integers with magnitude greater than 1 raise to a negative + * power yield the answer zero (see TIP 123). + */ + + objResultPtr = constants[0]; + NEXT_INST_F(1, 2, 1); + } + + if (type1 == TCL_NUMBER_LONG) { + switch (l1) { + case 0: + /* + * Zero to a positive power is zero. + */ + + objResultPtr = constants[0]; + NEXT_INST_F(1, 2, 1); + case 1: + /* + * 1 to any power is 1. + */ + + objResultPtr = constants[1]; + NEXT_INST_F(1, 2, 1); + case -1: + if (oddExponent) { + TclNewIntObj(objResultPtr, -1); + } else { + objResultPtr = constants[1]; + } + NEXT_INST_F(1, 2, 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_LONG type must hold a value larger + * than we accept. + */ + if (type2 != TCL_NUMBER_LONG) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("exponent too large", -1)); + result = TCL_ERROR; + goto checkForCatch; + } + + if (type1 == TCL_NUMBER_LONG) { + if (l1 == 2) { + /* + * Reduce small powers of 2 to shifts. + */ + + if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) { + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + TclNewLongObj(objResultPtr, (1L << l2)); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } +#if !defined(TCL_WIDE_INT_IS_LONG) + if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){ + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + objResultPtr = + Tcl_NewWideIntObj(((Tcl_WideInt) 1) << l2); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } +#endif + goto overflow; + } + if (l1 == -2) { + int signum = oddExponent ? -1 : 1; + + /* + * Reduce small powers of 2 to shifts. + */ + + if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) { + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + TclNewLongObj(objResultPtr, signum * (1L << l2)); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } +#if !defined(TCL_WIDE_INT_IS_LONG) + if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){ + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + objResultPtr = Tcl_NewWideIntObj( + signum * (((Tcl_WideInt) 1) << l2)); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } +#endif + goto overflow; + } +#if (LONG_MAX == 0x7fffffff) + if (l2 - 2 < (long)MaxBase32Size + && l1 <= MaxBase32[l2 - 2] + && l1 >= -MaxBase32[l2 - 2]) { + /* + * Small powers of 32-bit integers. + */ + + long lResult = l1 * l1; /* b**2 */ + switch (l2) { + case 2: + break; + case 3: + lResult *= l1; /* b**3 */ + break; + case 4: + lResult *= lResult; /* b**4 */ + break; + case 5: + lResult *= lResult; /* b**4 */ + lResult *= l1; /* b**5 */ + break; + case 6: + lResult *= l1; /* b**3 */ + lResult *= lResult; /* b**6 */ + break; + case 7: + lResult *= l1; /* b**3 */ + lResult *= lResult; /* b**6 */ + lResult *= l1; /* b**7 */ + break; + case 8: + lResult *= lResult; /* b**4 */ + lResult *= lResult; /* b**8 */ + break; + } + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + TclNewLongObj(objResultPtr, lResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + Tcl_SetLongObj(valuePtr, lResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + if (l1 - 3 >= 0 && l1 - 2 < (long)Exp32IndexSize + && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) { + + unsigned short base = Exp32Index[l1 - 3] + + (unsigned short) (l2 - 2 - MaxBase32Size); + if (base < Exp32Index[l1 - 2]) { + /* + * 32-bit number raised to intermediate power, done by + * table lookup. + */ + + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + TclNewLongObj(objResultPtr, Exp32Value[base]); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + Tcl_SetLongObj(valuePtr, Exp32Value[base]); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + } + if (-l1 - 3 >= 0 && -l1 - 2 < (long)Exp32IndexSize + && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) { + unsigned short base = Exp32Index[-l1 - 3] + + (unsigned short) (l2 - 2 - MaxBase32Size); + if (base < Exp32Index[-l1 - 2]) { + long lResult = (oddExponent) ? + -Exp32Value[base] : Exp32Value[base]; + + /* + * 32-bit number raised to intermediate power, done by + * table lookup. + */ + + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + TclNewLongObj(objResultPtr, lResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + Tcl_SetLongObj(valuePtr, lResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + } +#endif + } +#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) + if (type1 == TCL_NUMBER_LONG) { + w1 = l1; +#ifndef NO_WIDE_TYPE + } else if (type1 == TCL_NUMBER_WIDE) { + w1 = *((const Tcl_WideInt*) ptr1); +#endif + } else { + goto overflow; + } + if (l2 - 2 < (long)MaxBase64Size + && w1 <= MaxBase64[l2 - 2] + && w1 >= -MaxBase64[l2 - 2]) { + /* + * Small powers of integers whose result is wide. + */ + + Tcl_WideInt wResult = w1 * w1; /* b**2 */ + + switch (l2) { + case 2: + break; + case 3: + wResult *= l1; /* b**3 */ + break; + case 4: + wResult *= wResult; /* b**4 */ + break; + case 5: + wResult *= wResult; /* b**4 */ + wResult *= w1; /* b**5 */ + break; + case 6: + wResult *= w1; /* b**3 */ + wResult *= wResult; /* b**6 */ + break; + case 7: + wResult *= w1; /* b**3 */ + wResult *= wResult; /* b**6 */ + wResult *= w1; /* b**7 */ + break; + case 8: + wResult *= wResult; /* b**4 */ + wResult *= wResult; /* b**8 */ + break; + case 9: + wResult *= wResult; /* b**4 */ + wResult *= wResult; /* b**8 */ + wResult *= w1; /* b**9 */ + break; + case 10: + wResult *= wResult; /* b**4 */ + wResult *= w1; /* b**5 */ + wResult *= wResult; /* b**10 */ + break; + case 11: + wResult *= wResult; /* b**4 */ + wResult *= w1; /* b**5 */ + wResult *= wResult; /* b**10 */ + wResult *= w1; /* b**11 */ + break; + case 12: + wResult *= w1; /* b**3 */ + wResult *= wResult; /* b**6 */ + wResult *= wResult; /* b**12 */ + break; + case 13: + wResult *= w1; /* b**3 */ + wResult *= wResult; /* b**6 */ + wResult *= wResult; /* b**12 */ + wResult *= w1; /* b**13 */ + break; + case 14: + wResult *= w1; /* b**3 */ + wResult *= wResult; /* b**6 */ + wResult *= w1; /* b**7 */ + wResult *= wResult; /* b**14 */ + break; + case 15: + wResult *= w1; /* b**3 */ + wResult *= wResult; /* b**6 */ + wResult *= w1; /* b**7 */ + wResult *= wResult; /* b**14 */ + wResult *= w1; /* b**15 */ + break; + case 16: + wResult *= wResult; /* b**4 */ + wResult *= wResult; /* b**8 */ + wResult *= wResult; /* b**16 */ + break; + + } + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + objResultPtr = Tcl_NewWideIntObj(wResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + + /* + * Handle cases of powers > 16 that still fit in a 64-bit word by + * doing table lookup. + */ + if (w1 - 3 >= 0 && w1 - 2 < (long)Exp64IndexSize + && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { + unsigned short base = Exp64Index[w1 - 3] + + (unsigned short) (l2 - 2 - MaxBase64Size); + + if (base < Exp64Index[w1 - 2]) { + /* + * 64-bit number raised to intermediate power, done by + * table lookup. + */ + + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewWideIntObj(Exp64Value[base]); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + Tcl_SetWideIntObj(valuePtr, Exp64Value[base]); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + } + + if (-w1 - 3 >= 0 && -w1 - 2 < (long)Exp64IndexSize + && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { + unsigned short base = Exp64Index[-w1 - 3] + + (unsigned short) (l2 - 2 - MaxBase64Size); + + if (base < Exp64Index[-w1 - 2]) { + Tcl_WideInt wResult = (oddExponent) ? + -Exp64Value[base] : Exp64Value[base]; + /* + * 64-bit number raised to intermediate power, done by + * table lookup. + */ + + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewWideIntObj(wResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + Tcl_SetWideIntObj(valuePtr, wResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + } +#endif + + goto overflow; + } + + if ((*pc != INST_MULT) + && (type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { + Tcl_WideInt w1, w2, wResult; + + TclGetWideIntFromObj(NULL, valuePtr, &w1); + TclGetWideIntFromObj(NULL, value2Ptr, &w2); switch (*pc) { case INST_ADD: wResult = w1 + w2; - /* - * Check for overflow. - */ - - if (Overflowing(w1, w2, wResult)) { - goto overflow; - } - goto wideResultOfArithmetic; +#ifndef NO_WIDE_TYPE + if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) +#endif + { + /* + * Check for overflow. + */ + + if (Overflowing(w1, w2, wResult)) { + goto overflow; + } + } + break; case INST_SUB: wResult = w1 - w2; - /* - * Must check for overflow. The macro tests for overflows in - * sums by looking at the sign bits. As we have a subtraction - * here, we are adding -w2. As -w2 could in turn overflow, we - * test with ~w2 instead: it has the opposite sign bit to w2 - * so it does the job. Note that the only "bad" case (w2==0) - * is irrelevant for this macro, as in that case w1 and - * wResult have the same sign and there is no overflow anyway. - */ - - if (Overflowing(w1, ~w2, wResult)) { - goto overflow; - } - wideResultOfArithmetic: - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if (Tcl_IsShared(valuePtr)) { - TclNewIntObj(objResultPtr, wResult); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } - TclSetIntObj(valuePtr, wResult); - TRACE(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); - break; +#ifndef NO_WIDE_TYPE + if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) +#endif + { + /* + * Must check for overflow. The macro tests for overflows + * in sums by looking at the sign bits. As we have a + * subtraction here, we are adding -w2. As -w2 could in + * turn overflow, we test with ~w2 instead: it has the + * opposite sign bit to w2 so it does the job. Note that + * the only "bad" case (w2==0) is irrelevant for this + * macro, as in that case w1 and wResult have the same + * sign and there is no overflow anyway. + */ + + if (Overflowing(w1, ~w2, wResult)) { + goto overflow; + } + } + 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)) { - /* - * Can't represent (-WIDE_MIN) as a Tcl_WideInt. - */ + } + /* + * Need a bignum to represent (LLONG_MIN / -1) + */ + + if ((w1 == LLONG_MIN) && (w2 == -1)) { goto overflow; } wResult = w1 / w2; /* @@ -5978,203 +6102,323 @@ if (((wResult < 0) || ((wResult == 0) && ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) && ((wResult * w2) != w1)) { wResult -= 1; } - goto wideResultOfArithmetic; - - case INST_MULT: - if (((sizeof(Tcl_WideInt) >= 2*sizeof(int)) - && (w1 <= INT_MAX) && (w1 >= INT_MIN) - && (w2 <= INT_MAX) && (w2 >= INT_MIN)) - || ((sizeof(Tcl_WideInt) >= 2*sizeof(short)) - && (w1 <= SHRT_MAX) && (w1 >= SHRT_MIN) - && (w2 <= SHRT_MAX) && (w2 >= SHRT_MIN))) { - wResult = w1 * w2; - goto wideResultOfArithmetic; - } - } - - /* - * Fall through with INST_EXPON, INST_DIV and large multiplies. - */ + break; + default: + /* + * Unused, here to silence compiler warning. + */ + + wResult = 0; + } + + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewWideIntObj(wResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + Tcl_SetWideIntObj(valuePtr, wResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); } overflow: - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - objResultPtr = ExecuteExtendedBinaryMathOp(interp, *pc, &TCONST(0), - valuePtr, value2Ptr); - if (objResultPtr == DIVIDED_BY_ZERO) { - TRACE_APPEND(("DIVIDE BY ZERO\n")); - 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))); + { + mp_int big1, big2, bigResult, bigRemainder; + + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + mp_init(&bigResult); + switch (*pc) { + case INST_ADD: + mp_add(&big1, &big2, &bigResult); + break; + case INST_SUB: + mp_sub(&big1, &big2, &bigResult); + break; + case INST_MULT: + mp_mul(&big1, &big2, &bigResult); + break; + case INST_DIV: + if (mp_iszero(&big2)) { + TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), + O2S(value2Ptr))); + mp_clear(&big1); + mp_clear(&big2); + mp_clear(&bigResult); + goto divideByZero; + } + mp_init(&bigRemainder); + mp_div(&big1, &big2, &bigResult, &bigRemainder); + if (!mp_iszero(&bigRemainder) + && (mp_isneg(&bigRemainder) != mp_isneg(&big2))) { + /* + * Convert to Tcl's integer division rules. + */ + + mp_sub_d(&bigResult, 1, &bigResult); + mp_add(&bigRemainder, &big2, &bigRemainder); + } + mp_clear(&bigRemainder); + break; + case INST_EXPON: + if (big2.used > 1) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("exponent too large", -1)); + mp_clear(&big1); + mp_clear(&big2); + mp_clear(&bigResult); + result = TCL_ERROR; + goto checkForCatch; + } + mp_expt_d(&big1, big2.dp[0], &bigResult); + break; + } + mp_clear(&big1); + mp_clear(&big2); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewBignumObj(&bigResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + Tcl_SetBignumObj(valuePtr, &bigResult); + TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); - } else { - TRACE_APPEND(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); } + } case INST_LNOT: { int b; - - valuePtr = OBJ_AT_TOS; + Tcl_Obj *valuePtr = OBJ_AT_TOS; /* TODO - check claim that taking address of b harms performance */ /* TODO - consider optimization search for constants */ - if (TclGetBooleanFromObj(NULL, valuePtr, &b) != TCL_OK) { - TRACE(("\"%.20s\" => ERROR: illegal type %s\n", O2S(valuePtr), + result = TclGetBooleanFromObj(NULL, valuePtr, &b); + if (result != 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; + goto checkForCatch; } /* TODO: Consider peephole opt. */ - objResultPtr = TCONST(!b); - TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), objResultPtr); + objResultPtr = constants[!b]; NEXT_INST_F(1, 1, 1); } - case INST_BITNOT: - valuePtr = OBJ_AT_TOS; - TRACE(("\"%.20s\" => ", O2S(valuePtr))); - if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) - || (type1==TCL_NUMBER_NAN) || (type1==TCL_NUMBER_DOUBLE)) { + case INST_BITNOT: { + mp_int big; + ClientData ptr; + int type; + Tcl_Obj *valuePtr = OBJ_AT_TOS; + + result = GetNumberFromObj(NULL, valuePtr, &ptr, &type); + if ((result != TCL_OK) + || (type == TCL_NUMBER_NAN) || (type == TCL_NUMBER_DOUBLE)) { /* * ... ~$NonInteger => raise an error. */ - TRACE_APPEND(("ERROR: illegal type %s\n", - (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); - IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); - goto gotError; - } - if (type1 == TCL_NUMBER_INT) { - w1 = *((const Tcl_WideInt *) ptr1); - if (Tcl_IsShared(valuePtr)) { - TclNewIntObj(objResultPtr, ~w1); - TRACE_APPEND(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 1, 1); - } - TclSetIntObj(valuePtr, ~w1); - TRACE_APPEND(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 0, 0); - } - objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr); - if (objResultPtr != NULL) { - TRACE_APPEND(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 1, 1); - } else { - TRACE_APPEND(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 0, 0); - } - - case INST_UMINUS: - valuePtr = OBJ_AT_TOS; - TRACE(("\"%.20s\" => ", O2S(valuePtr))); - if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) - || IsErroringNaNType(type1)) { - TRACE_APPEND(("ERROR: illegal type %s \n", - (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); - IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); - goto gotError; - } - switch (type1) { - case TCL_NUMBER_NAN: - /* -NaN => NaN */ - TRACE_APPEND(("%s\n", O2S(valuePtr))); - 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); - } - TclSetIntObj(valuePtr, -w1); - TRACE_APPEND(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 0, 0); - } - /* FALLTHROUGH */ - } - objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr); - if (objResultPtr != NULL) { - TRACE_APPEND(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 1, 1); - } else { - TRACE_APPEND(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 0, 0); - } - - case INST_UPLUS: - case INST_TRY_CVT_TO_NUMERIC: + result = TCL_ERROR; + 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 checkForCatch; + } + if (type == TCL_NUMBER_LONG) { + long l = *((const long *)ptr); + + if (Tcl_IsShared(valuePtr)) { + TclNewLongObj(objResultPtr, ~l); + NEXT_INST_F(1, 1, 1); + } + TclSetLongObj(valuePtr, ~l); + NEXT_INST_F(1, 0, 0); + } +#ifndef NO_WIDE_TYPE + if (type == TCL_NUMBER_WIDE) { + Tcl_WideInt w = *((const Tcl_WideInt *)ptr); + + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewWideIntObj(~w); + NEXT_INST_F(1, 1, 1); + } + Tcl_SetWideIntObj(valuePtr, ~w); + NEXT_INST_F(1, 0, 0); + } +#endif + Tcl_TakeBignumFromObj(NULL, valuePtr, &big); + /* ~a = - a - 1 */ + mp_neg(&big, &big); + mp_sub_d(&big, 1, &big); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewBignumObj(&big); + NEXT_INST_F(1, 1, 1); + } + Tcl_SetBignumObj(valuePtr, &big); + NEXT_INST_F(1, 0, 0); + } + + case INST_UMINUS: { + ClientData ptr; + int type; + Tcl_Obj *valuePtr = OBJ_AT_TOS; + + result = GetNumberFromObj(NULL, valuePtr, &ptr, &type); + if ((result != TCL_OK) +#ifndef ACCEPT_NAN + || (type == TCL_NUMBER_NAN) +#endif + ) { + result = TCL_ERROR; + 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 checkForCatch; + } + switch (type) { + case TCL_NUMBER_DOUBLE: { + double d; + + if (Tcl_IsShared(valuePtr)) { + TclNewDoubleObj(objResultPtr, -(*((const double *)ptr))); + NEXT_INST_F(1, 1, 1); + } + d = *((const double *)ptr); + TclSetDoubleObj(valuePtr, -d); + NEXT_INST_F(1, 0, 0); + } + case TCL_NUMBER_LONG: { + long l = *((const long *)ptr); + + if (l != LONG_MIN) { + if (Tcl_IsShared(valuePtr)) { + TclNewLongObj(objResultPtr, -l); + NEXT_INST_F(1, 1, 1); + } + TclSetLongObj(valuePtr, -l); + NEXT_INST_F(1, 0, 0); + } + /* FALLTHROUGH */ + } +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: { + Tcl_WideInt w; + + if (type == TCL_NUMBER_LONG) { + w = (Tcl_WideInt)(*((const long *)ptr)); + } else { + w = *((const Tcl_WideInt *)ptr); + } + if (w != LLONG_MIN) { + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewWideIntObj(-w); + NEXT_INST_F(1, 1, 1); + } + Tcl_SetWideIntObj(valuePtr, -w); + NEXT_INST_F(1, 0, 0); + } + /* FALLTHROUGH */ + } +#endif + case TCL_NUMBER_BIG: { + mp_int big; + + switch (type) { +#ifdef NO_WIDE_TYPE + case TCL_NUMBER_LONG: + TclBNInitBignumFromLong(&big, *(const long *) ptr); + break; +#else + case TCL_NUMBER_WIDE: + TclBNInitBignumFromWideInt(&big, *(const Tcl_WideInt *) ptr); + break; +#endif + case TCL_NUMBER_BIG: + Tcl_TakeBignumFromObj(NULL, valuePtr, &big); + } + mp_neg(&big, &big); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewBignumObj(&big); + NEXT_INST_F(1, 1, 1); + } + Tcl_SetBignumObj(valuePtr, &big); + NEXT_INST_F(1, 0, 0); + } + case TCL_NUMBER_NAN: + /* -NaN => NaN */ + NEXT_INST_F(1, 0, 0); + } + } + + case INST_UPLUS: + case INST_TRY_CVT_TO_NUMERIC: { /* * Try to convert the topmost stack object to numeric object. This is * done in order to support [expr]'s policy of interpreting operands * if at all possible as numbers first, then strings. */ - valuePtr = OBJ_AT_TOS; - TRACE(("\"%.20s\" => ", O2S(valuePtr))); + ClientData ptr; + int type; + Tcl_Obj *valuePtr = OBJ_AT_TOS; - if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) { + if (GetNumberFromObj(NULL, valuePtr, &ptr, &type) != TCL_OK) { if (*pc == INST_UPLUS) { /* * ... +$NonNumeric => raise an error. */ - TRACE_APPEND(("ERROR: illegal type %s\n", + result = TCL_ERROR; + 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; - } - - /* ... TryConvertToNumeric($NonNumeric) is acceptable */ - TRACE_APPEND(("not numeric\n")); - NEXT_INST_F(1, 0, 0); - } - if (IsErroringNaNType(type1)) { + goto checkForCatch; + } else { + /* ... TryConvertToNumeric($NonNumeric) is acceptable */ + TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); + } + } +#ifndef ACCEPT_NAN + if (type == TCL_NUMBER_NAN) { + result = TCL_ERROR; if (*pc == INST_UPLUS) { /* * ... +$NonNumeric => raise an error. */ - TRACE_APPEND(("ERROR: illegal type %s\n", + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name:"null"))); DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); CACHE_STACK_INFO(); } else { /* * Numeric conversion of NaN -> error. */ - TRACE_APPEND(("ERROR: IEEE floating pt error\n")); + TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n", + O2S(objResultPtr))); DECACHE_STACK_INFO(); - TclExprFloatError(interp, *((const double *) ptr1)); + TclExprFloatError(interp, *((const double *)ptr)); CACHE_STACK_INFO(); } - goto gotError; + goto checkForCatch; } +#endif /* * Ensure that the numeric value has a string rep the same as the * formatted version of its internal rep. This is used, e.g., to make * sure that "expr {0001}" yields "1", not "0001". We implement this @@ -6182,11 +6426,11 @@ * regenerated, if needed later, by formatting the internal rep's * value. */ if (valuePtr->bytes == NULL) { - TRACE_APPEND(("numeric, same Tcl_Obj\n")); + TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } if (Tcl_IsShared(valuePtr)) { /* * Here we do some surgery within the Tcl_Obj internals. We want @@ -6197,45 +6441,26 @@ char *savedString = valuePtr->bytes; valuePtr->bytes = NULL; objResultPtr = Tcl_DuplicateObj(valuePtr); valuePtr->bytes = savedString; - TRACE_APPEND(("numeric, new Tcl_Obj\n")); + TRACE(("\"%.20s\" => numeric, new Tcl_Obj\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 1); } TclInvalidateStringRep(valuePtr); - TRACE_APPEND(("numeric, same Tcl_Obj\n")); + TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); 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 res = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK); - objResultPtr = TCONST(res); - } - TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(valuePtr)), objResultPtr); - NEXT_INST_F(1, 0, 1); - break; case INST_BREAK: /* DECACHE_STACK_INFO(); Tcl_ResetResult(interp); CACHE_STACK_INFO(); */ result = TCL_BREAK; cleanup = 0; - TRACE(("=> BREAK!\n")); goto processExceptionReturn; case INST_CONTINUE: /* DECACHE_STACK_INFO(); @@ -6242,125 +6467,121 @@ Tcl_ResetResult(interp); CACHE_STACK_INFO(); */ result = TCL_CONTINUE; cleanup = 0; - TRACE(("=> CONTINUE!\n")); goto processExceptionReturn; - { + case INST_FOREACH_START4: { + /* + * Initialize the temporary local var that holds the count of the + * number of iterations of the loop body to -1. + */ + + int opnd, iterTmpIndex; ForeachInfo *infoPtr; - Tcl_Obj *listPtr, **elements; - ForeachVarList *varListPtr; - int numLists, listLen, numVars; - int listTmpDepth; - size_t iterNum, iterMax, iterTmp; - int varIndex, valIndex, j; - long i; - - case INST_FOREACH_START: - /* - * Initialize the data for the looping construct, pushing the - * corresponding Tcl_Objs to the stack. - */ + Var *iterVarPtr; + Tcl_Obj *oldValuePtr; 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 - */ - - iterMax = 0; - listTmpDepth = numLists-1; - for (i = 0; i < numLists; i++) { - varListPtr = infoPtr->varLists[i]; - numVars = varListPtr->numVars; - listPtr = OBJ_AT_DEPTH(listTmpDepth); - if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) { - TRACE_APPEND(("ERROR converting list %ld, \"%s\": %s", - i, O2S(listPtr), O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - if (Tcl_IsShared(listPtr)) { - objPtr = TclListObjCopy(NULL, listPtr); - Tcl_IncrRefCount(objPtr); - Tcl_DecrRefCount(listPtr); - OBJ_AT_DEPTH(listTmpDepth) = objPtr; - } - iterTmp = (listLen + (numVars - 1))/numVars; - if (iterTmp > iterMax) { - iterMax = iterTmp; - } - listTmpDepth--; - } - - /* - * Store the iterNum and iterMax in a single Tcl_Obj; we keep a - * nul-string obj with the pointer stored in the ptrValue so that the - * thing is properly garbage collected. THIS OBJ MAKES NO SENSE, but - * it will never leave this scope and is read-only. - */ - - TclNewObj(tmpPtr); - tmpPtr->internalRep.twoPtrValue.ptr1 = NULL; - tmpPtr->internalRep.twoPtrValue.ptr2 = (void *)iterMax; - PUSH_OBJECT(tmpPtr); /* iterCounts object */ - - /* - * Store a pointer to the ForeachInfo struct; same dirty trick - * as above - */ - - TclNewObj(tmpPtr); - tmpPtr->internalRep.twoPtrValue.ptr1 = infoPtr; - PUSH_OBJECT(tmpPtr); /* infoPtr object */ - TRACE_APPEND(("jump to loop step\n")); - - /* - * Jump directly to the INST_FOREACH_STEP instruction; the C code just - * falls through. - */ - - pc += 5 - infoPtr->loopCtTemp; - - case INST_FOREACH_STEP: + infoPtr = (ForeachInfo *) codePtr->auxDataArrayPtr[opnd].clientData; + iterTmpIndex = infoPtr->loopCtTemp; + iterVarPtr = &(compiledLocals[iterTmpIndex]); + oldValuePtr = iterVarPtr->value.objPtr; + + if (oldValuePtr == NULL) { + TclNewLongObj(iterVarPtr->value.objPtr, -1); + Tcl_IncrRefCount(iterVarPtr->value.objPtr); + } else { + TclSetLongObj(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: { /* * "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; + ForeachInfo *infoPtr; + ForeachVarList *varListPtr; + Tcl_Obj *listPtr,*valuePtr, *value2Ptr, **elements; + Var *iterVarPtr, *listVarPtr, *varPtr; + int opnd, numLists, iterNum, listTmpIndex, listLen, numVars; + int varIndex, valIndex, continueLoop, j; + long i; + + opnd = TclGetUInt4AtPtr(pc+1); + infoPtr = (ForeachInfo *) codePtr->auxDataArrayPtr[opnd].clientData; numLists = infoPtr->numLists; - TRACE(("=> ")); - - tmpPtr = OBJ_AT_DEPTH(1); - iterNum = (size_t)tmpPtr->internalRep.twoPtrValue.ptr1; - iterMax = (size_t)tmpPtr->internalRep.twoPtrValue.ptr2; - - /* - * If some list still has a remaining list element iterate one more - * time. Assign to var the next element from its value list. - */ - - if (iterNum < iterMax) { - /* - * Set the variables and jump back to run the body - */ - - tmpPtr->internalRep.twoPtrValue.ptr1 =(void *)(iterNum + 1); - - listTmpDepth = numLists + 1; - + + /* + * Increment the temp holding the loop iteration number. + */ + + iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]); + valuePtr = iterVarPtr->value.objPtr; + iterNum = (valuePtr->internalRep.longValue + 1); + TclSetLongObj(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 = &(compiledLocals[listTmpIndex]); + listPtr = listVarPtr->value.objPtr; + result = TclListObjLength(interp, listPtr, &listLen); + if (result == TCL_OK) { + if (listLen > (iterNum * numVars)) { + continueLoop = 1; + } + listTmpIndex++; + } else { + TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ", + opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp)); + goto checkForCatch; + } + } + + /* + * 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; - listPtr = OBJ_AT_DEPTH(listTmpDepth); + listVarPtr = &(compiledLocals[listTmpIndex]); + listPtr = TclListObjCopy(NULL, listVarPtr->value.objPtr); TclListObjGetElements(interp, listPtr, &listLen, &elements); valIndex = (iterNum * numVars); for (j = 0; j < numVars; j++) { if (valIndex >= listLen) { @@ -6368,11 +6589,11 @@ } else { valuePtr = elements[valIndex]; } varIndex = varListPtr->varIndexes[j]; - varPtr = LOCAL(varIndex); + varPtr = &(compiledLocals[varIndex]); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } if (TclIsVarDirectWritable(varPtr)) { value2Ptr = varPtr->value.objPtr; @@ -6383,67 +6604,44 @@ 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: %.30s", - varIndex, O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - CACHE_STACK_INFO(); + value2Ptr = TclPtrSetVar(interp, varPtr, NULL, NULL, + NULL, valuePtr, TCL_LEAVE_ERR_MSG, varIndex); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(( + "%u => ERROR init. index temp %d: ", + opnd,varIndex), Tcl_GetObjResult(interp)); + result = TCL_ERROR; + TclDecrRefCount(listPtr); + goto checkForCatch; + } } valIndex++; } - listTmpDepth--; - } - TRACE_APPEND(("jump to loop start\n")); - /* loopCtTemp being 'misused' for storing the jump size */ - NEXT_INST_F(infoPtr->loopCtTemp, 0, 0); - } - - TRACE_APPEND(("loop has no more iterations\n")); -#ifdef TCL_COMPILE_DEBUG - NEXT_INST_F(1, 0, 0); -#else - /* - * FALL THROUGH - */ - 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; + TclDecrRefCount(listPtr); + listTmpIndex++; + } + } + TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, 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); + } + } 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 @@ -6453,202 +6651,105 @@ *(++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 */ + { + Tcl_Obj *newObjResultPtr; - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - iPtr->objResultPtr = objPtr; + TclNewObj(newObjResultPtr); + Tcl_IncrRefCount(newObjResultPtr); + iPtr->objResultPtr = newObjResultPtr; + } + 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!"); - } - if (code == TCL_OK) { - Tcl_Panic("INST_RETURN_CODE_BRANCH: TOS is TCL_OK!"); - } - if (code < TCL_ERROR || code > TCL_CONTINUE) { - code = TCL_CONTINUE + 1; - } - TRACE(("\"%s\" => jump offset %d\n", O2S(OBJ_AT_TOS), 2*code-1)); - NEXT_INST_F(2*code-1, 1, 0); - } - - /* - * ----------------------------------------------------------------- - * Start of dictionary-related instructions. - */ - - { - int opnd2, allocateDict, done, i, allocdict; - Tcl_Obj *dictPtr, *statePtr, *keyPtr, *listPtr, *varNamePtr, *keysPtr; - Tcl_Obj *emptyPtr, **keyPtrPtr; - Tcl_DictSearch *searchPtr; - DictUpdateInfo *duiPtr; - - case INST_DICT_VERIFY: - dictPtr = OBJ_AT_TOS; - TRACE(("\"%.30s\" => ", O2S(dictPtr))); - 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); - if (opnd > 1) { - dictPtr = TclTraceDictPath(NULL, dictPtr, opnd-1, - &OBJ_AT_DEPTH(opnd-1), DICT_PATH_EXISTS); - if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT) { - found = 0; - goto afterDictExists; - } - } - if (Tcl_DictObjGet(NULL, dictPtr, OBJ_AT_TOS, - &objResultPtr) == TCL_OK) { - found = (objResultPtr ? 1 : 0); - } else { - found = 0; - } - afterDictExists: - TRACE_APPEND(("%d\n", found)); - - /* - * The INST_DICT_EXISTS instruction is usually followed by a - * conditional jump, so we can take advantage of this to do some - * peephole optimization (note that we're careful to not close out - * someone doing something else). - */ - - JUMP_PEEPHOLE_V(found, 5, opnd+1); - } + +/* TODO: normalize "valPtr" to "valuePtr" */ + { + int opnd, opnd2, allocateDict; + Tcl_Obj *dictPtr, *valPtr; + Var *varPtr; + case INST_DICT_GET: opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); dictPtr = OBJ_AT_DEPTH(opnd); if (opnd > 1) { dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1, &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ); if (dictPtr == NULL) { TRACE_WITH_OBJ(( - "ERROR tracing dictionary path into \"%.30s\": ", - O2S(OBJ_AT_DEPTH(opnd))), - Tcl_GetObjResult(interp)); - goto gotError; - } - } - if (Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, - &objResultPtr) != TCL_OK) { - TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s", - O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - if (!objResultPtr) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "key \"%s\" not known in dictionary", - TclGetString(OBJ_AT_TOS))); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", - TclGetString(OBJ_AT_TOS), NULL); - CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; - } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+1, 1); - case INST_DICT_GET_DEF: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ", opnd)); - dictPtr = OBJ_AT_DEPTH(opnd+1); - if (opnd > 1) { - dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1, - &OBJ_AT_DEPTH(opnd), DICT_PATH_EXISTS); - if (dictPtr == NULL) { - TRACE_WITH_OBJ(( - "ERROR tracing dictionary path into \"%.30s\": ", - O2S(OBJ_AT_DEPTH(opnd+1))), - Tcl_GetObjResult(interp)); - goto gotError; - } else if (dictPtr == DICT_PATH_NON_EXISTENT) { - goto dictGetDefUseDefault; - } - } - if (Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS, - &objResultPtr) != TCL_OK) { - TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s", - O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } else if (!objResultPtr) { - dictGetDefUseDefault: - objResultPtr = OBJ_AT_TOS; - } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+2, 1); + "%u => ERROR tracing dictionary path into \"%s\": ", + opnd, O2S(OBJ_AT_DEPTH(opnd))), + Tcl_GetObjResult(interp)); + result = TCL_ERROR; + goto checkForCatch; + } + } + result = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &objResultPtr); + if ((result == TCL_OK) && objResultPtr) { + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(5, opnd+1, 1); + } + if (result != TCL_OK) { + TRACE_WITH_OBJ(( + "%u => ERROR reading leaf dictionary key \"%s\": ", + opnd, O2S(dictPtr)), Tcl_GetObjResult(interp)); + } else { + DECACHE_STACK_INFO(); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "key \"", TclGetString(OBJ_AT_TOS), + "\" not known in dictionary", NULL); + CACHE_STACK_INFO(); + TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp)); + result = TCL_ERROR; + } + goto checkForCatch; case INST_DICT_SET: case INST_DICT_UNSET: case INST_DICT_INCR_IMM: opnd = TclGetUInt4AtPtr(pc+1); opnd2 = TclGetUInt4AtPtr(pc+5); - varPtr = LOCAL(opnd2); + varPtr = &(compiledLocals[opnd2]); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } TRACE(("%u %u => ", opnd, opnd2)); if (TclIsVarDirectReadable(varPtr)) { dictPtr = varPtr->value.objPtr; } else { DECACHE_STACK_INFO(); - dictPtr = TclPtrGetVarIdx(interp, varPtr, NULL, NULL, NULL, 0, - opnd2); + dictPtr = TclPtrGetVar(interp, varPtr, NULL,NULL,NULL, 0, opnd2); CACHE_STACK_INFO(); } if (dictPtr == NULL) { TclNewObj(dictPtr); allocateDict = 1; @@ -6666,28 +6767,29 @@ &OBJ_AT_DEPTH(opnd), OBJ_AT_TOS); break; case INST_DICT_INCR_IMM: cleanup = 1; opnd = TclGetInt4AtPtr(pc+1); - result = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &valuePtr); + result = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &valPtr); if (result != TCL_OK) { break; } - if (valuePtr == NULL) { - Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, Tcl_NewWideIntObj(opnd)); + if (valPtr == NULL) { + Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS,Tcl_NewIntObj(opnd)); } else { - TclNewIntObj(value2Ptr, opnd); - Tcl_IncrRefCount(value2Ptr); - if (Tcl_IsShared(valuePtr)) { - valuePtr = Tcl_DuplicateObj(valuePtr); - Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, valuePtr); + Tcl_Obj *incrPtr = Tcl_NewIntObj(opnd); + + Tcl_IncrRefCount(incrPtr); + if (Tcl_IsShared(valPtr)) { + valPtr = Tcl_DuplicateObj(valPtr); + Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, valPtr); } - result = TclIncrObj(interp, valuePtr, value2Ptr); + result = TclIncrObj(interp, valPtr, incrPtr); if (result == TCL_OK) { TclInvalidateStringRep(dictPtr); } - TclDecrRefCount(value2Ptr); + TclDecrRefCount(incrPtr); } break; case INST_DICT_UNSET: cleanup = opnd; result = Tcl_DictObjRemoveKeyList(interp, dictPtr, opnd, @@ -6700,59 +6802,62 @@ if (result != TCL_OK) { if (allocateDict) { TclDecrRefCount(dictPtr); } - TRACE_APPEND(("ERROR updating dictionary: %s\n", - O2S(Tcl_GetObjResult(interp)))); + TRACE_WITH_OBJ(("%u %u => ERROR updating dictionary: ", + opnd, opnd2), Tcl_GetObjResult(interp)); goto checkForCatch; } if (TclIsVarDirectWritable(varPtr)) { if (allocateDict) { - value2Ptr = varPtr->value.objPtr; + Tcl_Obj *oldValuePtr = varPtr->value.objPtr; + Tcl_IncrRefCount(dictPtr); - if (value2Ptr != NULL) { - TclDecrRefCount(value2Ptr); + if (oldValuePtr != NULL) { + TclDecrRefCount(oldValuePtr); } varPtr->value.objPtr = dictPtr; } objResultPtr = dictPtr; } else { Tcl_IncrRefCount(dictPtr); DECACHE_STACK_INFO(); - objResultPtr = TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL, + objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, dictPtr, TCL_LEAVE_ERR_MSG, opnd2); CACHE_STACK_INFO(); TclDecrRefCount(dictPtr); if (objResultPtr == NULL) { - TRACE_ERROR(interp); - goto gotError; + TRACE_APPEND(("ERROR: %.30s\n", + O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; } } #ifndef TCL_COMPILE_DEBUG if (*(pc+9) == INST_POP) { NEXT_INST_V(10, cleanup, 0); } #endif - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_V(9, cleanup, 1); case INST_DICT_APPEND: case INST_DICT_LAPPEND: opnd = TclGetUInt4AtPtr(pc+1); - varPtr = LOCAL(opnd); + + varPtr = &(compiledLocals[opnd]); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } TRACE(("%u => ", opnd)); if (TclIsVarDirectReadable(varPtr)) { dictPtr = varPtr->value.objPtr; } else { DECACHE_STACK_INFO(); - dictPtr = TclPtrGetVarIdx(interp, varPtr, NULL, NULL, NULL, 0, - opnd); + dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd); CACHE_STACK_INFO(); } if (dictPtr == NULL) { TclNewObj(dictPtr); allocateDict = 1; @@ -6761,447 +6866,361 @@ if (allocateDict) { dictPtr = Tcl_DuplicateObj(dictPtr); } } - if (Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS, - &valuePtr) != TCL_OK) { + result = Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS, &valPtr); + if (result != TCL_OK) { if (allocateDict) { TclDecrRefCount(dictPtr); } - TRACE_ERROR(interp); - goto gotError; + goto checkForCatch; } /* - * Note that a non-existent key results in a NULL valuePtr, which is a + * Note that a non-existent key results in a NULL valPtr, which is a * case handled separately below. What we *can* say at this point is * that the write-back will always succeed. */ switch (*pc) { case INST_DICT_APPEND: - if (valuePtr == NULL) { - Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, OBJ_AT_TOS); - } else if (Tcl_IsShared(valuePtr)) { - valuePtr = Tcl_DuplicateObj(valuePtr); - Tcl_AppendObjToObj(valuePtr, OBJ_AT_TOS); - Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr); + if (valPtr == NULL) { + valPtr = OBJ_AT_TOS; } else { - Tcl_AppendObjToObj(valuePtr, OBJ_AT_TOS); - - /* - * Must invalidate the string representation of dictionary - * here because we have directly updated the internal - * representation; if we don't, callers could see the wrong - * string rep despite the internal version of the dictionary - * having the correct value. [Bug 3079830] - */ - - TclInvalidateStringRep(dictPtr); + if (Tcl_IsShared(valPtr)) { + valPtr = Tcl_DuplicateObj(valPtr); + } + Tcl_AppendObjToObj(valPtr, OBJ_AT_TOS); } break; case INST_DICT_LAPPEND: /* * More complex because list-append can fail. */ - if (valuePtr == NULL) { - Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, - Tcl_NewListObj(1, &OBJ_AT_TOS)); - break; - } else if (Tcl_IsShared(valuePtr)) { - valuePtr = Tcl_DuplicateObj(valuePtr); - if (Tcl_ListObjAppendElement(interp, valuePtr, - OBJ_AT_TOS) != TCL_OK) { - TclDecrRefCount(valuePtr); - if (allocateDict) { - TclDecrRefCount(dictPtr); - } - TRACE_ERROR(interp); - goto gotError; - } - Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr); - } else { - if (Tcl_ListObjAppendElement(interp, valuePtr, - OBJ_AT_TOS) != TCL_OK) { - if (allocateDict) { - TclDecrRefCount(dictPtr); - } - TRACE_ERROR(interp); - goto gotError; - } - - /* - * Must invalidate the string representation of dictionary - * here because we have directly updated the internal - * representation; if we don't, callers could see the wrong - * string rep despite the internal version of the dictionary - * having the correct value. [Bug 3079830] - */ - - TclInvalidateStringRep(dictPtr); + if (valPtr == NULL) { + valPtr = Tcl_NewListObj(1, &OBJ_AT_TOS); + } else if (Tcl_IsShared(valPtr)) { + valPtr = Tcl_DuplicateObj(valPtr); + result = Tcl_ListObjAppendElement(interp, valPtr, OBJ_AT_TOS); + if (result != TCL_OK) { + TclDecrRefCount(valPtr); + if (allocateDict) { + TclDecrRefCount(dictPtr); + } + goto checkForCatch; + } + } else { + result = Tcl_ListObjAppendElement(interp, valPtr, OBJ_AT_TOS); + if (result != TCL_OK) { + if (allocateDict) { + TclDecrRefCount(dictPtr); + } + goto checkForCatch; + } } break; default: Tcl_Panic("Should not happen!"); } + Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valPtr); + if (TclIsVarDirectWritable(varPtr)) { if (allocateDict) { - value2Ptr = varPtr->value.objPtr; + Tcl_Obj *oldValuePtr = varPtr->value.objPtr; + Tcl_IncrRefCount(dictPtr); - if (value2Ptr != NULL) { - TclDecrRefCount(value2Ptr); + if (oldValuePtr != NULL) { + TclDecrRefCount(oldValuePtr); } varPtr->value.objPtr = dictPtr; } objResultPtr = dictPtr; } else { Tcl_IncrRefCount(dictPtr); DECACHE_STACK_INFO(); - objResultPtr = TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL, + objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, dictPtr, TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); TclDecrRefCount(dictPtr); if (objResultPtr == NULL) { - TRACE_ERROR(interp); - goto gotError; + TRACE_APPEND(("ERROR: %.30s\n", + O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; } } #ifndef TCL_COMPILE_DEBUG if (*(pc+5) == INST_POP) { NEXT_INST_F(6, 2, 0); } #endif TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_F(5, 2, 1); + } + + { + int opnd, done; + Tcl_Obj *statePtr, *dictPtr, *keyPtr, *valuePtr, *emptyPtr; + Var *varPtr; + Tcl_DictSearch *searchPtr; case INST_DICT_FIRST: opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); dictPtr = POP_OBJECT(); - searchPtr = (Tcl_DictSearch *)Tcl_Alloc(sizeof(Tcl_DictSearch)); - if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr, - &valuePtr, &done) != TCL_OK) { - - /* - * dictPtr is no longer on the stack, and we're not - * moving it into the intrep of an iterator. We need - * to drop the refcount [Tcl Bug 9b352768e6]. - */ - - Tcl_DecrRefCount(dictPtr); - Tcl_Free(searchPtr); - TRACE_ERROR(interp); - goto gotError; - } - { - Tcl_ObjIntRep ir; - TclNewObj(statePtr); - ir.twoPtrValue.ptr1 = searchPtr; - ir.twoPtrValue.ptr2 = dictPtr; - Tcl_StoreIntRep(statePtr, &dictIteratorType, &ir); - } - varPtr = LOCAL(opnd); + searchPtr = (Tcl_DictSearch *) ckalloc(sizeof(Tcl_DictSearch)); + result = Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr, + &valuePtr, &done); + if (result != TCL_OK) { + ckfree((char *) searchPtr); + goto checkForCatch; + } + TclNewObj(statePtr); + statePtr->typePtr = &dictIteratorType; + statePtr->internalRep.twoPtrValue.ptr1 = (void *) searchPtr; + statePtr->internalRep.twoPtrValue.ptr2 = (void *) dictPtr; + varPtr = (compiledLocals + opnd); if (varPtr->value.objPtr) { - if (TclHasIntRep(varPtr->value.objPtr, &dictIteratorType)) { + if (varPtr->value.objPtr->typePtr != &dictIteratorType) { + TclDecrRefCount(varPtr->value.objPtr); + } else { Tcl_Panic("mis-issued dictFirst!"); } - TclDecrRefCount(varPtr->value.objPtr); } varPtr->value.objPtr = statePtr; Tcl_IncrRefCount(statePtr); goto pushDictIteratorResult; case INST_DICT_NEXT: opnd = TclGetUInt4AtPtr(pc+1); 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!"); - } - } + statePtr = compiledLocals[opnd].value.objPtr; + if (statePtr == NULL || statePtr->typePtr != &dictIteratorType) { + Tcl_Panic("mis-issued dictNext!"); + } + searchPtr = (Tcl_DictSearch *) statePtr->internalRep.twoPtrValue.ptr1; + Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done); pushDictIteratorResult: if (done) { TclNewObj(emptyPtr); PUSH_OBJECT(emptyPtr); PUSH_OBJECT(emptyPtr); } else { PUSH_OBJECT(valuePtr); PUSH_OBJECT(keyPtr); } - TRACE_APPEND(("\"%.30s\" \"%.30s\" %d\n", + TRACE_APPEND(("\"%.30s\" \"%.30s\" %d", O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done)); - - /* - * The INST_DICT_FIRST and INST_DICT_NEXT instructsions are always - * followed by a conditional jump, so we can take advantage of this to - * do some peephole optimization (note that we're careful to not close - * out someone doing something else). - */ - - JUMP_PEEPHOLE_F(done, 5, 0); + objResultPtr = constants[done]; + /* TODO: consider opt like INST_FOREACH_STEP4 */ + NEXT_INST_F(5, 0, 1); + + case INST_DICT_DONE: + opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => ", opnd)); + statePtr = compiledLocals[opnd].value.objPtr; + if (statePtr == NULL) { + Tcl_Panic("mis-issued dictDone!"); + } + + if (statePtr->typePtr == &dictIteratorType) { + /* + * First kill the search, and then release the reference to the + * dictionary that we were holding. + */ + + searchPtr = (Tcl_DictSearch *) + statePtr->internalRep.twoPtrValue.ptr1; + Tcl_DictObjDone(searchPtr); + ckfree((char *) searchPtr); + + dictPtr = (Tcl_Obj *) statePtr->internalRep.twoPtrValue.ptr2; + TclDecrRefCount(dictPtr); + + /* + * Set the internal variable to an empty object to signify that we + * don't hold an iterator. + */ + + TclDecrRefCount(statePtr); + TclNewObj(emptyPtr); + compiledLocals[opnd].value.objPtr = emptyPtr; + Tcl_IncrRefCount(emptyPtr); + } + NEXT_INST_F(5, 0, 0); + } + + { + int opnd, opnd2, i, length, allocdict; + Tcl_Obj **keyPtrPtr, *dictPtr; + DictUpdateInfo *duiPtr; + Var *varPtr; 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; + varPtr = &(compiledLocals[opnd]); + duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } + TRACE(("%u => ", opnd)); if (TclIsVarDirectReadable(varPtr)) { dictPtr = varPtr->value.objPtr; } else { DECACHE_STACK_INFO(); - dictPtr = TclPtrGetVarIdx(interp, varPtr, NULL, NULL, NULL, + dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); if (dictPtr == NULL) { - TRACE_ERROR(interp); - goto gotError; + goto dictUpdateStartFailed; } } - Tcl_IncrRefCount(dictPtr); if (TclListObjGetElements(interp, OBJ_AT_TOS, &length, &keyPtrPtr) != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; + goto dictUpdateStartFailed; } - if ((size_t)length != duiPtr->length) { + if (length != duiPtr->length) { Tcl_Panic("dictUpdateStart argument length mismatch"); } for (i=0 ; ivarIndices[i]); + varPtr = &(compiledLocals[duiPtr->varIndices[i]]); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } DECACHE_STACK_INFO(); - if (valuePtr == NULL) { + if (valPtr == NULL) { TclObjUnsetVar2(interp, localName(iPtr->varFramePtr, duiPtr->varIndices[i]), NULL, 0); - } else if (TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL, - valuePtr, TCL_LEAVE_ERR_MSG, + } else if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, + valPtr, TCL_LEAVE_ERR_MSG, duiPtr->varIndices[i]) == NULL) { CACHE_STACK_INFO(); - TRACE_ERROR(interp); - Tcl_DecrRefCount(dictPtr); - goto gotError; + dictUpdateStartFailed: + result = TCL_ERROR; + goto checkForCatch; } CACHE_STACK_INFO(); } - TclDecrRefCount(dictPtr); - TRACE_APPEND(("OK\n")); 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; + varPtr = &(compiledLocals[opnd]); + duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } + TRACE(("%u => ", opnd)); if (TclIsVarDirectReadable(varPtr)) { dictPtr = varPtr->value.objPtr; } else { DECACHE_STACK_INFO(); - dictPtr = TclPtrGetVarIdx(interp, varPtr, NULL, NULL, NULL, 0, - opnd); + dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd); CACHE_STACK_INFO(); } if (dictPtr == NULL) { - TRACE_APPEND(("storage was unset\n")); NEXT_INST_F(9, 1, 0); } if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK || TclListObjGetElements(interp, OBJ_AT_TOS, &length, &keyPtrPtr) != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; + result = TCL_ERROR; + goto checkForCatch; } allocdict = Tcl_IsShared(dictPtr); if (allocdict) { dictPtr = Tcl_DuplicateObj(dictPtr); } - if (length > 0) { - TclInvalidateStringRep(dictPtr); - } for (i=0 ; ivarIndices[i]); + Tcl_Obj *valPtr; + Var *var2Ptr; + var2Ptr = &(compiledLocals[duiPtr->varIndices[i]]); while (TclIsVarLink(var2Ptr)) { var2Ptr = var2Ptr->value.linkPtr; } if (TclIsVarDirectReadable(var2Ptr)) { - valuePtr = var2Ptr->value.objPtr; + valPtr = var2Ptr->value.objPtr; } else { DECACHE_STACK_INFO(); - valuePtr = TclPtrGetVarIdx(interp, var2Ptr, NULL, NULL, NULL, - 0, duiPtr->varIndices[i]); + valPtr = TclPtrGetVar(interp, var2Ptr, NULL, NULL, NULL, 0, + duiPtr->varIndices[i]); CACHE_STACK_INFO(); } - if (valuePtr == NULL) { + if (valPtr == NULL) { Tcl_DictObjRemove(interp, dictPtr, keyPtrPtr[i]); - } else if (dictPtr == valuePtr) { + } else if (dictPtr == valPtr) { Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], - Tcl_DuplicateObj(valuePtr)); + Tcl_DuplicateObj(valPtr)); } else { - Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], valuePtr); + Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], valPtr); } } if (TclIsVarDirectWritable(varPtr)) { Tcl_IncrRefCount(dictPtr); TclDecrRefCount(varPtr->value.objPtr); varPtr->value.objPtr = dictPtr; } else { DECACHE_STACK_INFO(); - objResultPtr = TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL, + objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, dictPtr, TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); if (objResultPtr == NULL) { if (allocdict) { TclDecrRefCount(dictPtr); } - TRACE_ERROR(interp); - goto gotError; - } - } - TRACE_APPEND(("written back\n")); - NEXT_INST_F(9, 1, 0); - - case INST_DICT_EXPAND: - dictPtr = OBJ_UNDER_TOS; - listPtr = OBJ_AT_TOS; - TRACE(("\"%.30s\" \"%.30s\" =>", O2S(dictPtr), O2S(listPtr))); - if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } - objResultPtr = TclDictWithInit(interp, dictPtr, objc, objv); - if (objResultPtr == NULL) { - TRACE_ERROR(interp); - goto gotError; - } - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - - case INST_DICT_RECOMBINE_STK: - keysPtr = POP_OBJECT(); - varNamePtr = OBJ_UNDER_TOS; - listPtr = OBJ_AT_TOS; - TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ", - O2S(varNamePtr), O2S(valuePtr), O2S(keysPtr))); - if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { - TRACE_ERROR(interp); - TclDecrRefCount(keysPtr); - goto gotError; - } - varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, - TCL_LEAVE_ERR_MSG, "set", 1, 1, &arrayPtr); - if (varPtr == NULL) { - TRACE_ERROR(interp); - TclDecrRefCount(keysPtr); - goto gotError; - } - DECACHE_STACK_INFO(); - result = TclDictWithFinish(interp, varPtr,arrayPtr,varNamePtr,NULL,-1, - objc, objv, keysPtr); - CACHE_STACK_INFO(); - TclDecrRefCount(keysPtr); - if (result != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } - TRACE_APPEND(("OK\n")); - NEXT_INST_F(1, 2, 0); - - case INST_DICT_RECOMBINE_IMM: - opnd = TclGetUInt4AtPtr(pc+1); - listPtr = OBJ_UNDER_TOS; - keysPtr = OBJ_AT_TOS; - varPtr = LOCAL(opnd); - TRACE(("%u <- \"%.30s\" \"%.30s\" => ", opnd, O2S(valuePtr), - O2S(keysPtr))); - if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - DECACHE_STACK_INFO(); - result = TclDictWithFinish(interp, varPtr, NULL, NULL, NULL, opnd, - objc, objv, keysPtr); - CACHE_STACK_INFO(); - 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: - { /* Read the wall clock */ - Tcl_WideInt wval; - Tcl_Time now; - switch(TclGetUInt1AtPtr(pc+1)) { - case 0: /* clicks */ -#ifdef TCL_WIDE_CLICKS - wval = TclpGetWideClicks(); -#else - wval = (Tcl_WideInt) TclpGetClicks(); -#endif - break; - case 1: /* microseconds */ - Tcl_GetTime(&now); - wval = (Tcl_WideInt) now.sec * 1000000 + now.usec; - break; - case 2: /* milliseconds */ - Tcl_GetTime(&now); - wval = (Tcl_WideInt) now.sec * 1000 + now.usec / 1000; - break; - case 3: /* seconds */ - Tcl_GetTime(&now); - wval = (Tcl_WideInt) now.sec; - break; - default: - Tcl_Panic("clockRead instruction with unknown clock#"); - } - TclNewIntObj(objResultPtr, wval); - TRACE_WITH_OBJ(("=> "), objResultPtr); - NEXT_INST_F(2, 0, 1); - } - break; - - default: - Tcl_Panic("TclNRExecuteByteCode: unrecognized opCode %u", *pc); - } /* end of switch on opCode */ + result = TCL_ERROR; + goto checkForCatch; + } + } + NEXT_INST_F(9, 1, 0); + } + + default: + Tcl_Panic("TclExecuteByteCode: unrecognized opCode %u", *pc); + } /* end of switch on opCode */ + + /* + * Division by zero in an expression. Control only reaches this point by + * "goto divideByZero". + */ + + divideByZero: + DECACHE_STACK_INFO(); + Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1)); + Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL); + CACHE_STACK_INFO(); + + result = TCL_ERROR; + goto checkForCatch; + + /* + * Exponentiation of zero by negative number in an expression. Control + * only reaches this point by "goto exponOfZero". + */ + + exponOfZero: + DECACHE_STACK_INFO(); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "exponentiation of zero by negative power", -1)); + Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", + "exponentiation of zero by negative power", NULL); + CACHE_STACK_INFO(); + result = TCL_ERROR; + goto checkForCatch; /* * Block for variables needed to process exception returns. */ @@ -7209,11 +7228,16 @@ ExceptionRange *rangePtr; /* Points to closest loop or catch exception * range enclosing the pc. Used by various * instructions and processCatch to process * break, continue, and errors. */ + Tcl_Obj *valuePtr; const char *bytes; + int length; +#ifdef TCL_COMPILE_DEBUG + int opnd; +#endif /* * An external evaluation (INST_INVOKE or INST_EVAL) returned * something different from TCL_OK, or else INST_BREAK or * INST_CONTINUE were called. @@ -7262,132 +7286,69 @@ pc = (codePtr->codeStart + rangePtr->breakOffset); TRACE_APPEND(("%s, range at %d, new pc %d\n", StringForResultCode(result), rangePtr->codeOffset, rangePtr->breakOffset)); NEXT_INST_F(0, 0, 0); - } - if (rangePtr->continueOffset == -1) { - TRACE_APPEND(("%s, loop w/o continue, checking for catch\n", - StringForResultCode(result))); - goto checkForCatch; - } - result = TCL_OK; - pc = (codePtr->codeStart + rangePtr->continueOffset); - TRACE_APPEND(("%s, range at %d, new pc %d\n", - StringForResultCode(result), - rangePtr->codeOffset, rangePtr->continueOffset)); - NEXT_INST_F(0, 0, 0); - } + } else { + if (rangePtr->continueOffset == -1) { + TRACE_APPEND(( + "%s, loop w/o continue, checking for catch\n", + StringForResultCode(result))); + goto checkForCatch; + } + result = TCL_OK; + pc = (codePtr->codeStart + rangePtr->continueOffset); + TRACE_APPEND(("%s, range at %d, new pc %d\n", + StringForResultCode(result), + rangePtr->codeOffset, rangePtr->continueOffset)); + NEXT_INST_F(0, 0, 0); + } #ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - objPtr = Tcl_GetObjResult(interp); + } else if (traceInstructions) { if ((result != TCL_ERROR) && (result != TCL_RETURN)) { - TRACE_APPEND(("OTHER RETURN CODE %d, result=\"%.30s\"\n ", + Tcl_Obj *objPtr = Tcl_GetObjResult(interp); + TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ", result, O2S(objPtr))); } else { - TRACE_APPEND(("%s, result=\"%.30s\"\n", + Tcl_Obj *objPtr = Tcl_GetObjResult(interp); + TRACE_APPEND(("%s, result= \"%s\"\n", StringForResultCode(result), O2S(objPtr))); } - } #endif - goto checkForCatch; - - /* - * Division by zero in an expression. Control only reaches this point - * by "goto divideByZero". - */ - - divideByZero: - Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1)); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", 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( - "exponentiation of zero by negative power", -1)); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", - "exponentiation of zero by negative power", NULL); - CACHE_STACK_INFO(); - - /* - * Almost all error paths feed through here rather than assigning to - * result themselves (for a small but consistent saving). - */ - - gotError: - result = TCL_ERROR; + } /* * Execution has generated an "exception" such as TCL_ERROR. If the * exception is an error, record information about what was being * executed when the error occurred. Find the closest enclosing catch * range, if any. If no enclosing catch range is found, stop execution * and return the "exception" code. */ - checkForCatch: - if (iPtr->execEnvPtr->rewind) { - goto abnormalReturn; - } + checkForCatch: if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { - const unsigned char *pcBeg; - size_t xxx1length; - - bytes = GetSrcInfoForPc(pc, codePtr, &xxx1length, &pcBeg, NULL); - DECACHE_STACK_INFO(); - TclLogCommandInfo(interp, codePtr->source, bytes, - bytes ? xxx1length : 0, pcBeg, tosPtr); - CACHE_STACK_INFO(); + bytes = GetSrcInfoForPc(pc, codePtr, &length); + if (bytes != NULL) { + DECACHE_STACK_INFO(); + Tcl_LogCommandInfo(interp, codePtr->source, bytes, length); + CACHE_STACK_INFO(); + } } iPtr->flags &= ~ERR_ALREADY_LOGGED; /* * Clear all expansions that may have started after the last * INST_BEGIN_CATCH. */ - while (auxObjList) { - if ((catchTop != initCatchTop) - && (*catchTop > (ptrdiff_t) - auxObjList->internalRep.twoPtrValue.ptr2)) { - break; - } - POP_TAUX_OBJ(); - } - - /* - * We must not catch if the script in progress has been canceled with - * the TCL_CANCEL_UNWIND flag. Instead, it blows outwards until we - * either hit another interpreter (presumably where the script in - * progress has not been canceled) or we get to the top-level. We do - * NOT modify the interpreter result here because we know it will - * already be set prior to vectoring down to this point in the code. - */ - - if (TclCanceled(iPtr) && (Tcl_Canceled(interp, 0) == TCL_ERROR)) { -#ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - fprintf(stdout, " ... cancel with unwind, returning %s\n", - StringForResultCode(result)); - } -#endif - goto abnormalReturn; + while ((expandNestList != NULL) && ((catchTop == initCatchTop) || + (*catchTop <= + (ptrdiff_t) expandNestList->internalRep.twoPtrValue.ptr1))) { + Tcl_Obj *objPtr = expandNestList->internalRep.twoPtrValue.ptr2; + + TclDecrRefCount(expandNestList); + expandNestList = objPtr; } /* * We must not catch an exceeded limit. Instead, it blows outwards * until we either hit another interpreter (presumably where the limit @@ -7415,11 +7376,11 @@ rangePtr = GetExceptRangeForPc(pc, TCL_ERROR, codePtr); if (rangePtr == NULL) { /* * This is only possible when compiling a [catch] that sends its * script to INST_EVAL. Cannot correct the compiler without - * breaking compat with previous .tbc compiled scripts. + * breakingcompat with previous .tbc compiled scripts. */ #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { fprintf(stdout, " ... no enclosing catch, returning %s\n", @@ -7463,1231 +7424,53 @@ * initial level. */ abnormalReturn: TCL_DTRACE_INST_LAST(); - - /* - * Clear all expansions and same-level NR calls. - * - * Note that expansion markers have a NULL type; avoid removing other - * markers. - */ - - while (auxObjList) { - POP_TAUX_OBJ(); - } while (tosPtr > initTosPtr) { - objPtr = POP_OBJECT(); + Tcl_Obj *objPtr = POP_OBJECT(); + Tcl_DecrRefCount(objPtr); } + /* + * Clear all expansions. + */ + + while (expandNestList) { + Tcl_Obj *objPtr = expandNestList->internalRep.twoPtrValue.ptr2; + + TclDecrRefCount(expandNestList); + expandNestList = objPtr; + } if (tosPtr < initTosPtr) { fprintf(stderr, - "\nTclNRExecuteByteCode: abnormal return at pc %u: " + "\nTclExecuteByteCode: abnormal return at pc %u: " "stack top %d < entry stack top %d\n", (unsigned)(pc - codePtr->codeStart), (unsigned) CURR_DEPTH, (unsigned) 0); - Tcl_Panic("TclNRExecuteByteCode execution failure: end stack top < start stack top"); - } - CLANG_ASSERT(bcFramePtr); - } - - iPtr->cmdFramePtr = bcFramePtr->nextPtr; - TclReleaseByteCode(codePtr); - TclStackFree(interp, TD); /* free my stack */ - - return result; - - /* - * INST_START_CMD failure case removed where it doesn't bother that much - * - * Remark that if the interpreter is marked for deletion its - * compileEpoch is modified, so that the epoch check also verifies - * that the interp is not deleted. If no outside call has been made - * since the last check, it is safe to omit the check. - - * case INST_START_CMD: - */ - - instStartCmdFailed: - { - const char *bytes; - size_t xxx1length; - - xxx1length = 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, &xxx1length, NULL, NULL); - opnd = TclGetUInt4AtPtr(pc+1); - pc += (opnd-1); - assert(bytes); - PUSH_OBJECT(Tcl_NewStringObj(bytes, xxx1length)); - goto instEvalStk; - } -} - -#undef codePtr -#undef iPtr -#undef bcFramePtr -#undef initCatchTop -#undef initTosPtr -#undef auxObjList -#undef catchTop -#undef TCONST -#undef esPtr - -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]); - contextPtr->skip = PTR2INT(data[3]); - contextPtr->oPtr->flags |= FILTER_HANDLING; - return result; -} - -/* - * WidePwrSmallExpon -- - * - * Helper to calculate small powers of integers whose result is wide. - */ -static inline Tcl_WideInt -WidePwrSmallExpon(Tcl_WideInt w1, long exponent) { - - Tcl_WideInt wResult; - - wResult = w1 * w1; /* b**2 */ - switch (exponent) { - case 2: - break; - case 3: - wResult *= w1; /* b**3 */ - break; - case 4: - wResult *= wResult; /* b**4 */ - break; - case 5: - wResult *= wResult; /* b**4 */ - wResult *= w1; /* b**5 */ - break; - case 6: - wResult *= w1; /* b**3 */ - wResult *= wResult; /* b**6 */ - break; - case 7: - wResult *= w1; /* b**3 */ - wResult *= wResult; /* b**6 */ - wResult *= w1; /* b**7 */ - break; - case 8: - wResult *= wResult; /* b**4 */ - wResult *= wResult; /* b**8 */ - break; - case 9: - wResult *= wResult; /* b**4 */ - wResult *= wResult; /* b**8 */ - wResult *= w1; /* b**9 */ - break; - case 10: - wResult *= wResult; /* b**4 */ - wResult *= w1; /* b**5 */ - wResult *= wResult; /* b**10 */ - break; - case 11: - wResult *= wResult; /* b**4 */ - wResult *= w1; /* b**5 */ - wResult *= wResult; /* b**10 */ - wResult *= w1; /* b**11 */ - break; - case 12: - wResult *= w1; /* b**3 */ - wResult *= wResult; /* b**6 */ - wResult *= wResult; /* b**12 */ - break; - case 13: - wResult *= w1; /* b**3 */ - wResult *= wResult; /* b**6 */ - wResult *= wResult; /* b**12 */ - wResult *= w1; /* b**13 */ - break; - case 14: - wResult *= w1; /* b**3 */ - wResult *= wResult; /* b**6 */ - wResult *= w1; /* b**7 */ - wResult *= wResult; /* b**14 */ - break; - case 15: - wResult *= w1; /* b**3 */ - wResult *= wResult; /* b**6 */ - wResult *= w1; /* b**7 */ - wResult *= wResult; /* b**14 */ - wResult *= w1; /* b**15 */ - break; - case 16: - wResult *= wResult; /* b**4 */ - wResult *= wResult; /* b**8 */ - wResult *= wResult; /* b**16 */ - break; - } - return wResult; -} -/* - *---------------------------------------------------------------------- - * - * ExecuteExtendedBinaryMathOp, ExecuteExtendedUnaryMathOp -- - * - * These functions do advanced math for binary and unary operators - * respectively, so that the main TEBC code does not bear the cost of - * them. - * - * Results: - * A Tcl_Obj* result, or a NULL (in which case valuePtr is updated to - * hold the result value), or one of the special flag values - * GENERAL_ARITHMETIC_ERROR, EXPONENT_OF_ZERO or DIVIDED_BY_ZERO. The - * latter two signify a zero value raised to a negative power or a value - * divided by zero, respectively. With GENERAL_ARITHMETIC_ERROR, all - * error information will have already been reported in the interpreter - * result. - * - * Side effects: - * May update the Tcl_Obj indicated valuePtr if it is unshared. Will - * return a NULL when that happens. - * - *---------------------------------------------------------------------- - */ - -static Tcl_Obj * -ExecuteExtendedBinaryMathOp( - Tcl_Interp *interp, /* Where to report errors. */ - int opcode, /* What operation to perform. */ - Tcl_Obj **constants, /* The execution environment's constants. */ - Tcl_Obj *valuePtr, /* The first operand on the stack. */ - Tcl_Obj *value2Ptr) /* The second operand on the stack. */ -{ -#define WIDE_RESULT(w) \ - if (Tcl_IsShared(valuePtr)) { \ - return Tcl_NewWideIntObj(w); \ - } else { \ - TclSetIntObj(valuePtr, w); \ - return NULL; \ - } -#define BIG_RESULT(b) \ - if (Tcl_IsShared(valuePtr)) { \ - return Tcl_NewBignumObj(b); \ - } else { \ - Tcl_SetBignumObj(valuePtr, b); \ - return NULL; \ - } -#define DOUBLE_RESULT(d) \ - if (Tcl_IsShared(valuePtr)) { \ - TclNewDoubleObj(objResultPtr, (d)); \ - return objResultPtr; \ - } else { \ - Tcl_SetDoubleObj(valuePtr, (d)); \ - return NULL; \ - } - - int type1, type2; - 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 */ - - w2 = 0; /* silence gcc warning */ - if (type2 == TCL_NUMBER_INT) { - w2 = *((const Tcl_WideInt *)ptr2); - if (w2 == 0) { - return DIVIDED_BY_ZERO; - } - if ((w2 == 1) || (w2 == -1)) { - /* - * Div. by |1| always yields remainder of 0. - */ - - return constants[0]; - } - } - if (type1 == TCL_NUMBER_INT) { - w1 = *((const Tcl_WideInt *)ptr1); - - if (w1 == 0) { - /* - * 0 % (non-zero) always yields remainder of 0. - */ - - return constants[0]; - } - if (type2 == TCL_NUMBER_INT) { - Tcl_WideInt wQuotient, wRemainder; - w2 = *((const Tcl_WideInt *)ptr2); - wQuotient = w1 / w2; - - /* - * Force Tcl's integer division rules. - * TODO: examine for logic simplification - */ - - if (((wQuotient < (Tcl_WideInt) 0) - || ((wQuotient == (Tcl_WideInt) 0) - && ((w1 < 0 && w2 > 0) - || (w1 > 0 && w2 < 0)))) - && (wQuotient * w2 != w1)) { - wQuotient -= (Tcl_WideInt) 1; - } - 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) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "negative shift argument", -1)); - return GENERAL_ARITHMETIC_ERROR; - } - - /* - * Zero shifted any number of bits is still zero. - */ - - if ((type1==TCL_NUMBER_INT) && (*((const Tcl_WideInt *)ptr1) == 0)) { - return constants[0]; - } - - if (opcode == INST_LSHIFT) { - /* - * Large left shifts create integer overflow. - * - * BEWARE! Can't use Tcl_GetIntFromObj() here because that - * converts values in the (unsigned) range to their signed int - * counterparts, leading to incorrect results. - */ - - if ((type2 != TCL_NUMBER_INT) - || (*((const Tcl_WideInt *)ptr2) > INT_MAX)) { - /* - * Technically, we could hold the value (1 << (INT_MAX+1)) in - * an mp_int, but since we're using mp_mul_2d() to do the - * work, and it takes only an int argument, that's a good - * place to draw the line. - */ - - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "integer value too large to represent", -1)); - return GENERAL_ARITHMETIC_ERROR; - } - shift = (int)(*((const Tcl_WideInt *)ptr2)); - - /* - * Handle shifts within the native wide range. - */ - - if ((type1 == TCL_NUMBER_INT) - && ((size_t)shift < CHAR_BIT*sizeof(Tcl_WideInt))) { - w1 = *((const Tcl_WideInt *)ptr1); - if (!((w1>0 ? w1 : ~w1) - & -(((Tcl_WideInt)1) - << (CHAR_BIT*sizeof(Tcl_WideInt) - 1 - shift)))) { - WIDE_RESULT(w1 << shift); - } - } - } else { - /* - * Quickly force large right shifts to 0 or -1. - */ - - if ((type2 != TCL_NUMBER_INT) - || (*(const Tcl_WideInt *)ptr2 > INT_MAX)) { - /* - * Again, technically, the value to be shifted could be an - * mp_int so huge that a right shift by (INT_MAX+1) bits could - * not take us to the result of 0 or -1, but since we're using - * mp_div_2d to do the work, and it takes only an int - * argument, we draw the line there. - */ - - 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) { - return constants[0]; - } - WIDE_RESULT(-1); - } - shift = (int)(*(const Tcl_WideInt *)ptr2); - - /* - * Handle shifts within the native wide range. - */ - - if (type1 == TCL_NUMBER_INT) { - w1 = *(const Tcl_WideInt *)ptr1; - if ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideInt)) { - if (w1 >= 0) { - return constants[0]; - } - WIDE_RESULT(-1); - } - 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); - } - - w1 = *((const Tcl_WideInt *)ptr1); - w2 = *((const Tcl_WideInt *)ptr2); - - switch (opcode) { - case INST_BITAND: - wResult = w1 & w2; - break; - case INST_BITOR: - wResult = w1 | w2; - break; - case INST_BITXOR: - wResult = w1 ^ w2; - break; - default: - /* Unused, here to silence compiler warning. */ - wResult = 0; - } - WIDE_RESULT(wResult); - - case INST_EXPON: { - int oddExponent = 0, negativeExponent = 0; - unsigned short base; - - if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) { - Tcl_GetDoubleFromObj(NULL, valuePtr, &d1); - Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2); - - if (d1==0.0 && d2<0.0) { - return EXPONENT_OF_ZERO; - } - dResult = pow(d1, d2); - goto doubleResult; - } - w1 = w2 = 0; /* to silence compiler warning (maybe-uninitialized) */ - if (type2 == TCL_NUMBER_INT) { - w2 = *((const Tcl_WideInt *) ptr2); - if (w2 == 0) { - /* - * Anything to the zero power is 1. - */ - - return constants[1]; - } else if (w2 == 1) { - /* - * Anything to the first power is itself - */ - - 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) { - switch (w1) { - case 0: - /* - * Zero to a negative power is div by zero error. - */ - - return EXPONENT_OF_ZERO; - case -1: - if (oddExponent) { - WIDE_RESULT(-1); - } - /* fallthrough */ - case 1: - /* - * 1 to any power is 1. - */ - - return constants[1]; - } - } - } - if (negativeExponent) { - - /* - * Integers with magnitude greater than 1 raise to a negative - * power yield the answer zero (see TIP 123). - */ - return constants[0]; - } - - if (type1 != TCL_NUMBER_INT) { - goto overflowExpon; - } - - switch (w1) { - case 0: - /* - * Zero to a positive power is zero. - */ - - return constants[0]; - case 1: - /* - * 1 to any power is 1. - */ - - return constants[1]; - case -1: - if (!oddExponent) { - 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) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "exponent too large", -1)); - return GENERAL_ARITHMETIC_ERROR; - } - - /* From here (up to overflowExpon) w1 and exponent w2 are wide-int's. */ - assert(type1 == TCL_NUMBER_INT && type2 == TCL_NUMBER_INT); - - if (w1 == 2) { - /* - * Reduce small powers of 2 to shifts. - */ - - if ((Tcl_WideUInt) w2 < (Tcl_WideUInt) CHAR_BIT*sizeof(Tcl_WideInt) - 1) { - WIDE_RESULT(((Tcl_WideInt) 1) << (int)w2); - } - goto overflowExpon; - } - if (w1 == -2) { - int signum = oddExponent ? -1 : 1; - - /* - * Reduce small powers of 2 to shifts. - */ - - if ((Tcl_WideUInt) w2 < CHAR_BIT * sizeof(Tcl_WideInt) - 1) { - WIDE_RESULT(signum * (((Tcl_WideInt) 1) << (int) w2)); - } - goto overflowExpon; - } - if (w2 - 2 < (long)MaxBase64Size - && w1 <= MaxBase64[w2 - 2] - && w1 >= -MaxBase64[w2 - 2]) { - /* - * Small powers of integers whose result is wide. - */ - wResult = WidePwrSmallExpon(w1, (long)w2); - - WIDE_RESULT(wResult); - } - - /* - * Handle cases of powers > 16 that still fit in a 64-bit word by - * doing table lookup. - */ - - if (w1 - 3 >= 0 && w1 - 2 < (long)Exp64IndexSize - && w2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { - base = Exp64Index[w1 - 3] - + (unsigned short) (w2 - 2 - MaxBase64Size); - if (base < Exp64Index[w1 - 2]) { - /* - * 64-bit number raised to intermediate power, done by - * table lookup. - */ - - WIDE_RESULT(Exp64Value[base]); - } - } - - if (-w1 - 3 >= 0 && -w1 - 2 < (long)Exp64IndexSize - && w2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { - base = Exp64Index[-w1 - 3] - + (unsigned short) (w2 - 2 - MaxBase64Size); - if (base < Exp64Index[-w1 - 2]) { - /* - * 64-bit number raised to intermediate power, done by - * table lookup. - */ - - wResult = oddExponent ? -Exp64Value[base] : Exp64Value[base]; - WIDE_RESULT(wResult); - } - } - - overflowExpon: - - if ((TclGetWideIntFromObj(NULL, value2Ptr, &w2) != TCL_OK) - || (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: - case INST_DIV: - if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) { - /* - * At least one of the values is floating-point, so perform - * floating point calculations. - */ - - Tcl_GetDoubleFromObj(NULL, valuePtr, &d1); - Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2); - - switch (opcode) { - case INST_ADD: - dResult = d1 + d2; - break; - case INST_SUB: - dResult = d1 - d2; - break; - case INST_MULT: - dResult = d1 * d2; - break; - case INST_DIV: -#ifndef IEEE_FLOATING_POINT - if (d2 == 0.0) { - return DIVIDED_BY_ZERO; - } -#endif - /* - * We presume that we are running with zero-divide unmasked if - * we're on an IEEE box. Otherwise, this statement might cause - * demons to fly out our noses. - */ - - dResult = d1 / d2; - break; - default: - /* Unused, here to silence compiler warning. */ - dResult = 0; - } - - doubleResult: -#ifndef ACCEPT_NAN - /* - * Check now for IEEE floating-point error. - */ - - if (TclIsNaN(dResult)) { - TclExprFloatError(interp, dResult); - return GENERAL_ARITHMETIC_ERROR; - } -#endif - DOUBLE_RESULT(dResult); - } - if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) { - w1 = *((const Tcl_WideInt *)ptr1); - w2 = *((const Tcl_WideInt *)ptr2); - - switch (opcode) { - case INST_ADD: - wResult = w1 + w2; - if ((type1 == TCL_NUMBER_INT) || (type2 == TCL_NUMBER_INT)) - { - /* - * Check for overflow. - */ - - if (Overflowing(w1, w2, wResult)) { - goto overflowBasic; - } - } - break; - - case INST_SUB: - wResult = w1 - w2; - if ((type1 == TCL_NUMBER_INT) || (type2 == TCL_NUMBER_INT)) - { - /* - * Must check for overflow. The macro tests for overflows - * in sums by looking at the sign bits. As we have a - * subtraction here, we are adding -w2. As -w2 could in - * turn overflow, we test with ~w2 instead: it has the - * opposite sign bit to w2 so it does the job. Note that - * the only "bad" case (w2==0) is irrelevant for this - * macro, as in that case w1 and wResult have the same - * sign and there is no overflow anyway. - */ - - if (Overflowing(w1, ~w2, wResult)) { - goto overflowBasic; - } - } - break; - - case INST_MULT: - if ((w1 < INT_MIN) || (w1 > INT_MAX) || (w2 < INT_MIN) || (w2 > INT_MAX)) { - goto overflowBasic; - } - wResult = w1 * w2; - break; - - case INST_DIV: - if (w2 == 0) { - return DIVIDED_BY_ZERO; - } - - /* - * Need a bignum to represent (WIDE_MIN / -1) - */ - - if ((w1 == WIDE_MIN) && (w2 == -1)) { - goto overflowBasic; - } - wResult = w1 / w2; - - /* - * Force Tcl's integer division rules. - * TODO: examine for logic simplification - */ - - if (((wResult < 0) || ((wResult == 0) && - ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) && - (wResult*w2 != w1)) { - wResult -= 1; - } - break; - - default: - /* - * Unused, here to silence compiler warning. - */ - - wResult = 0; - } - - 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 -#undef BIG_RESULT -#undef DOUBLE_RESULT - -/* - *---------------------------------------------------------------------- - * - * CompareTwoNumbers -- - * - * This function compares a pair of numbers in Tcl_Objs. Each argument - * must already be known to be numeric and not NaN. - * - * Results: - * One of MP_LT, MP_EQ or MP_GT, depending on whether valuePtr is less - * than, equal to, or greater than value2Ptr (respectively). - * - * Side effects: - * None, provided both values are numeric. - * - *---------------------------------------------------------------------- - */ - -int -TclCompareTwoNumbers( - Tcl_Obj *valuePtr, - Tcl_Obj *value2Ptr) -{ - int type1 = TCL_NUMBER_NAN, type2 = TCL_NUMBER_NAN, compare; - ClientData ptr1, ptr2; - mp_int big1, big2; - double d1, d2, tmp; - Tcl_WideInt w1, w2; - - (void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); - (void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); - - switch (type1) { - case TCL_NUMBER_INT: - w1 = *((const Tcl_WideInt *)ptr1); - switch (type2) { - case TCL_NUMBER_INT: - w2 = *((const Tcl_WideInt *)ptr2); - wideCompare: - return (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); - case TCL_NUMBER_DOUBLE: - d2 = *((const double *)ptr2); - d1 = (double) w1; - - /* - * If the double has a fractional part, or if the long can be - * converted to double without loss of precision, then compare as - * doubles. - */ - - if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) || w1 == (Tcl_WideInt) d1 - || modf(d2, &tmp) != 0.0) { - goto doubleCompare; - } - - /* - * Otherwise, to make comparision based on full precision, need to - * convert the double to a suitably sized integer. - * - * Need this to get comparsions like - * expr 20000000000000003 < 20000000000000004.0 - * right. Converting the first argument to double will yield two - * double values that are equivalent within double precision. - * Converting the double to an integer gets done exactly, then - * integer comparison can tell the difference. - */ - - if (d2 < (double)WIDE_MIN) { - return MP_GT; - } - 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: - return (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ); - case TCL_NUMBER_INT: - w2 = *((const Tcl_WideInt *)ptr2); - d2 = (double) w2; - if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) - || w2 == (Tcl_WideInt) d2 || modf(d1, &tmp) != 0.0) { - goto doubleCompare; - } - if (d1 < (double)WIDE_MIN) { - return MP_LT; - } - if (d1 > (double)WIDE_MAX) { - return MP_GT; - } - w1 = (Tcl_WideInt) d1; - 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); - return compare; - case TCL_NUMBER_DOUBLE: - d2 = *((const double *)ptr2); - if (TclIsInfinite(d2)) { - compare = (d2 > 0.0) ? MP_LT : MP_GT; - mp_clear(&big1); - return compare; - } - if ((d2 < (double)WIDE_MAX) && (d2 > (double)WIDE_MIN)) { - compare = mp_cmp_d(&big1, 0); - mp_clear(&big1); - return compare; - } - if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) - && modf(d2, &tmp) != 0.0) { - d1 = TclBignumToDouble(&big1); - mp_clear(&big1); - goto doubleCompare; - } - Tcl_InitBignumFromDouble(NULL, d2, &big2); - goto bigCompare; - case TCL_NUMBER_BIG: - 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; + Tcl_Panic("TclExecuteByteCode execution failure: end stack top < start stack top"); + } + } + + /* + * Restore the stack to the state it had previous to this bytecode. + */ + + TclStackFree(interp, initCatchTop+1); + return result; +#undef iPtr } #ifdef TCL_COMPILE_DEBUG /* *---------------------------------------------------------------------- * * PrintByteCodeInfo -- * * This procedure prints a summary about a bytecode object to stdout. It - * is called by TclNRExecuteByteCode when starting to execute the bytecode + * is called by TclExecuteByteCode when starting to execute the bytecode * object if tclTraceExec has the value 2 or more. * * Results: * None. * @@ -8697,19 +7480,20 @@ *---------------------------------------------------------------------- */ static void PrintByteCodeInfo( - ByteCode *codePtr) /* The bytecode whose summary is printed to + register ByteCode *codePtr) /* The bytecode whose summary is printed to * stdout. */ { Proc *procPtr = codePtr->procPtr; Interp *iPtr = (Interp *) *codePtr->interpHandle; - fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %" TCL_Z_MODIFIER "u, epoch %" TCL_Z_MODIFIER "u, interp 0x%p (epoch %" TCL_Z_MODIFIER "u)\n", + fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %u, epoch %u, interp 0x%p (epoch %u)\n", codePtr, 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, @@ -8731,11 +7515,11 @@ (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)), codePtr->numCmdLocBytes); #endif /* TCL_COMPILE_STATS */ if (procPtr != NULL) { fprintf(stdout, - " Proc 0x%p, refCt %" TCL_Z_MODIFIER "u, args %d, compiled locals %d\n", + " Proc 0x%p, refCt %d, args %d, compiled locals %d\n", procPtr, procPtr->refCount, procPtr->numArgs, procPtr->numCompiledLocals); } } #endif /* TCL_COMPILE_DEBUG */ @@ -8743,11 +7527,11 @@ /* *---------------------------------------------------------------------- * * ValidatePcAndStackTop -- * - * This procedure is called by TclNRExecuteByteCode when debugging to + * This procedure is called by TclExecuteByteCode when debugging to * verify that the program counter and stack top are valid during * execution. * * Results: * None. @@ -8760,67 +7544,68 @@ */ #ifdef TCL_COMPILE_DEBUG static void ValidatePcAndStackTop( - ByteCode *codePtr, /* The bytecode whose summary is printed to + register ByteCode *codePtr, /* The bytecode whose summary is printed to * stdout. */ - const unsigned char *pc, /* Points to first byte of a bytecode + unsigned char *pc, /* Points to first byte of a bytecode * instruction. The program counter. */ int stackTop, /* Current stack top. Must be between * stackLowerBound and stackUpperBound * (inclusive). */ + int stackLowerBound, /* Smallest legal value for stackTop. */ int checkStack) /* 0 if the stack depth check should be * skipped. */ { - int stackUpperBound = codePtr->maxStackDepth; + int stackUpperBound = stackLowerBound + codePtr->maxStackDepth; /* Greatest legal value for stackTop. */ - size_t relativePc = (size_t) (pc - codePtr->codeStart); - size_t codeStart = (size_t) codePtr->codeStart; - size_t codeEnd = (size_t) + unsigned relativePc = (unsigned) (pc - codePtr->codeStart); + unsigned long codeStart = (unsigned long) codePtr->codeStart; + unsigned long codeEnd = (unsigned long) (codePtr->codeStart + codePtr->numCodeBytes); unsigned char opCode = *pc; - if (((size_t) pc < codeStart) || ((size_t) pc > codeEnd)) { - fprintf(stderr, "\nBad instruction pc 0x%p in TclNRExecuteByteCode\n", + if (((unsigned long) pc < codeStart) || ((unsigned long) pc > codeEnd)) { + fprintf(stderr, "\nBad instruction pc 0x%p in TclExecuteByteCode\n", pc); - Tcl_Panic("TclNRExecuteByteCode execution failure: bad pc"); + Tcl_Panic("TclExecuteByteCode execution failure: bad pc"); } - if ((unsigned) opCode >= LAST_INST_OPCODE) { - fprintf(stderr, "\nBad opcode %d at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode\n", + if ((unsigned) opCode > LAST_INST_OPCODE) { + fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n", (unsigned) opCode, relativePc); - Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode"); + Tcl_Panic("TclExecuteByteCode execution failure: bad opcode"); } if (checkStack && - ((stackTop < 0) || (stackTop > stackUpperBound))) { - size_t numChars; - const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL); + ((stackTop < stackLowerBound) || (stackTop > stackUpperBound))) { + int numChars; + const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars); - fprintf(stderr, "\nBad stack top %d at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode (min 0, max %i)", - stackTop, relativePc, stackUpperBound); + fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode (min %i, max %i)", + stackTop, relativePc, stackLowerBound, stackUpperBound); if (cmd != NULL) { Tcl_Obj *message; TclNewLiteralStringObj(message, "\n executing "); Tcl_IncrRefCount(message); Tcl_AppendLimitedToObj(message, cmd, numChars, 100, NULL); - fprintf(stderr,"%s\n", TclGetString(message)); + fprintf(stderr,"%s\n", Tcl_GetString(message)); Tcl_DecrRefCount(message); } else { fprintf(stderr, "\n"); } - Tcl_Panic("TclNRExecuteByteCode execution failure: bad stack top"); + Tcl_Panic("TclExecuteByteCode execution failure: bad stack top"); } } #endif /* TCL_COMPILE_DEBUG */ /* *---------------------------------------------------------------------- * * IllegalExprOperandType -- * - * Used by TclNRExecuteByteCode to append an error message to the interp + * Used by TclExecuteByteCode to append an error message to the interp * result when an illegal operand type is detected by an expression * instruction. The argument opndPtr holds the operand object in error. * * Results: * None. @@ -8833,28 +7618,37 @@ static void IllegalExprOperandType( Tcl_Interp *interp, /* Interpreter to which error information * pertains. */ - const unsigned char *pc, /* Points to the instruction being executed + unsigned char *pc, /* Points to the instruction being executed * when the illegal type was found. */ Tcl_Obj *opndPtr) /* Points to the operand holding the value * with the illegal type. */ { ClientData ptr; int type; - const unsigned char opcode = *pc; - const char *description, *op = "unknown"; + unsigned char opcode = *pc; + const char *description, *operator = "unknown"; if (opcode == INST_EXPON) { - op = "**"; + operator = "**"; } else if (opcode <= INST_LNOT) { - op = operatorStrings[opcode - INST_BITOR]; + operator = operatorStrings[opcode - INST_LOR]; } if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) { - description = "non-numeric string"; + int numBytes; + const char *bytes = Tcl_GetStringFromObj(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 { @@ -8861,19 +7655,18 @@ /* TODO: No caller needs this. Eliminate? */ description = "(big) integer"; } Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't use %s \"%s\" as operand of \"%s\"", description, - TclGetString(opndPtr), op)); + "can't use %s as operand of \"%s\"", description, operator)); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, NULL); } /* *---------------------------------------------------------------------- * - * TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSourceFromFrame -- + * TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSrcInfoForCmd -- * * Given a program counter value, finds the closest command in the * bytecode code unit's CmdLocation array and returns information about * that command's source: a pointer to its first byte and the number of * characters. @@ -8890,71 +7683,53 @@ * The CmdFrame at *cfPtr is updated. * *---------------------------------------------------------------------- */ -Tcl_Obj * -TclGetSourceFromFrame( - CmdFrame *cfPtr, - int objc, - Tcl_Obj *const objv[]) -{ - if (cfPtr == NULL) { - return Tcl_NewListObj(objc, objv); - } - if (cfPtr->cmdObj == NULL) { - if (cfPtr->cmd == NULL) { - ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; - - cfPtr->cmd = GetSrcInfoForPc((unsigned char *) - cfPtr->data.tebc.pc, codePtr, &cfPtr->len, NULL, NULL); - } - if (cfPtr->cmd) { - cfPtr->cmdObj = Tcl_NewStringObj(cfPtr->cmd, cfPtr->len); - } else { - cfPtr->cmdObj = Tcl_NewListObj(objc, objv); - } - Tcl_IncrRefCount(cfPtr->cmdObj); - } - return cfPtr->cmdObj; +const char * +TclGetSrcInfoForCmd( + Interp *iPtr, + int *lenPtr) +{ + CmdFrame *cfPtr = iPtr->cmdFramePtr; + ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; + + return GetSrcInfoForPc((unsigned char *) cfPtr->data.tebc.pc, + codePtr, lenPtr); } void TclGetSrcInfoForPc( CmdFrame *cfPtr) { ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; - assert(cfPtr->type == TCL_LOCATION_BC); - - if (cfPtr->cmd == NULL) { - - cfPtr->cmd = GetSrcInfoForPc( + if (cfPtr->cmd.str.cmd == NULL) { + cfPtr->cmd.str.cmd = GetSrcInfoForPc( (unsigned char *) cfPtr->data.tebc.pc, codePtr, - &cfPtr->len, NULL, NULL); + &cfPtr->cmd.str.len); } - if (cfPtr->cmd != NULL) { + if (cfPtr->cmd.str.cmd != NULL) { /* * 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; - size_t srcOffset; - int i; + int srcOffset, i; Interp *iPtr = (Interp *) *codePtr->interpHandle; Tcl_HashEntry *hePtr = - Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr); + Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr); if (!hePtr) { return; } - srcOffset = cfPtr->cmd - codePtr->source; - eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hePtr); + srcOffset = cfPtr->cmd.str.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; @@ -8980,38 +7755,32 @@ } } static const char * GetSrcInfoForPc( - const unsigned char *pc, /* The program counter value for which to + 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. */ + * This points to a bytecode instruction in + * codePtr's code. */ ByteCode *codePtr, /* The bytecode sequence in which to look up * the command source for the pc. */ - size_t *lengthPtr, /* If non-NULL, the location where the length + 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. */ -{ - size_t pcOffset = (size_t)(pc - codePtr->codeStart); - size_t numCmds = codePtr->numCommands; +{ + register int pcOffset = (pc - codePtr->codeStart); + int numCmds = codePtr->numCommands; unsigned char *codeDeltaNext, *codeLengthNext; unsigned char *srcDeltaNext, *srcLengthNext; - size_t codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i; + 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 < (size_t)codePtr->numCodeBytes); + if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) { + return NULL; + } /* * Decode the code and source offset and length for each command. The * closest enclosing command is the last one whose code started before * pcOffset. @@ -9070,44 +7839,21 @@ if (dist <= bestDist) { bestDist = dist; bestSrcOffset = srcOffset; bestSrcLength = srcLen; - bestCmdIdx = i; - } - } - } - - if (pcBeg != NULL) { - const unsigned char *curr, *prev; - - /* - * Walk from beginning of command or BC to pc, by complete - * instructions. Stop when crossing pc; keep previous. - */ - - curr = ((bestDist == INT_MAX) ? codePtr->codeStart : pc - bestDist); - prev = curr; - while (curr <= pc) { - prev = curr; - curr += tclInstructionTable[*curr].numBytes; - } - *pcBeg = prev; + } + } } if (bestDist == INT_MAX) { return NULL; } if (lengthPtr != NULL) { *lengthPtr = bestSrcLength; } - - if (cmdIdxPtr != NULL) { - *cmdIdxPtr = bestCmdIdx; - } - return (codePtr->source + bestSrcOffset); } /* *---------------------------------------------------------------------- @@ -9134,11 +7880,11 @@ *---------------------------------------------------------------------- */ static ExceptionRange * GetExceptRangeForPc( - const unsigned char *pc, /* The program counter value for which to + unsigned char *pc, /* The program counter value for which to * search for a closest enclosing exception * range. This points to a bytecode * instruction in codePtr's code. */ int searchMode, /* If TCL_BREAK, consider either loop or catch * ExceptionRanges in search. If TCL_ERROR @@ -9149,13 +7895,13 @@ ByteCode *codePtr) /* Points to the ByteCode in which to search * for the enclosing ExceptionRange. */ { ExceptionRange *rangeArrayPtr; int numRanges = codePtr->numExceptRanges; - ExceptionRange *rangePtr; - size_t pcOffset = pc - codePtr->codeStart; - size_t start; + register ExceptionRange *rangePtr; + int pcOffset = pc - codePtr->codeStart; + register int start; if (numRanges == 0) { return NULL; } @@ -9189,11 +7935,11 @@ *---------------------------------------------------------------------- * * GetOpcodeName -- * * This procedure is called by the TRACE and TRACE_WITH_OBJ macros used - * in TclNRExecuteByteCode when debugging. It returns the name of the + * in TclExecuteByteCode when debugging. It returns the name of the * bytecode instruction at a specified instruction pc. * * Results: * A character string for the instruction. * @@ -9202,13 +7948,13 @@ * *---------------------------------------------------------------------- */ #ifdef TCL_COMPILE_DEBUG -static const char * +static char * GetOpcodeName( - const unsigned char *pc) /* Points to the instruction whose name should + unsigned char *pc) /* Points to the instruction whose name should * be returned. */ { unsigned char opCode = *pc; return tclInstructionTable[opCode].name; @@ -9257,11 +8003,11 @@ } else { Tcl_Obj *objPtr = Tcl_ObjPrintf( "unknown floating-point error, errno = %d", errno); Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", - TclGetString(objPtr), NULL); + Tcl_GetString(objPtr), NULL); Tcl_SetObjResult(interp, objPtr); } } #ifdef TCL_COMPILE_STATS @@ -9283,15 +8029,15 @@ *---------------------------------------------------------------------- */ int TclLog2( - int value) /* The integer for which to compute the log + register int value) /* The integer for which to compute the log * base 2. */ { - int n = value; - int result = 0; + register int n = value; + register int result = 0; while (n > 1) { n = n >> 1; result++; } @@ -9328,20 +8074,21 @@ double totalCodeBytes, currentCodeBytes; double totalLiteralBytes, currentLiteralBytes; double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved; double strBytesSharedMultX, strBytesSharedOnce; double numInstructions, currentHeaderBytes; - size_t numCurrentByteCodes, numByteCodeLits; - size_t refCountSum, literalMgmtBytes, sum, decadeHigh, length; - size_t numSharedMultX, numSharedOnce, minSizeDecade, maxSizeDecade, i; + long numCurrentByteCodes, numByteCodeLits; + long refCountSum, literalMgmtBytes, sum; + int numSharedMultX, numSharedOnce; + int decadeHigh, minSizeDecade, maxSizeDecade, length, i; char *litTableStats; LiteralEntry *entryPtr; Tcl_Obj *objPtr; #define Percent(a,b) ((a) * 100.0 / (b)) - TclNewObj(objPtr); + objPtr = Tcl_NewObj(); Tcl_IncrRefCount(objPtr); numInstructions = 0.0; for (i = 0; i < 256; i++) { if (statsPtr->instructionCount[i] != 0) { @@ -9372,67 +8119,67 @@ * Summary statistics, total and current source and ByteCode sizes. */ Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n"); Tcl_AppendPrintfToObj(objPtr, - "Compilation and execution statistics for interpreter %p\n", + "Compilation and execution statistics for interpreter %#lx\n", iPtr); - Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed %ld\n", statsPtr->numExecutions); - Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled %ld\n", statsPtr->numCompilations); - Tcl_AppendPrintfToObj(objPtr, " Mean executions/compile\t%.1f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean executions/compile %.1f\n", statsPtr->numExecutions / (float)statsPtr->numCompilations); - Tcl_AppendPrintfToObj(objPtr, "\nInstructions executed\t\t%.0f\n", + Tcl_AppendPrintfToObj(objPtr, "\nInstructions executed %.0f\n", numInstructions); - Tcl_AppendPrintfToObj(objPtr, " Mean inst/compile\t\t%.0f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean inst/compile %.0f\n", numInstructions / statsPtr->numCompilations); - Tcl_AppendPrintfToObj(objPtr, " Mean inst/execution\t\t%.0f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean inst/execution %.0f\n", numInstructions / statsPtr->numExecutions); - Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes\t\t\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes %ld\n", statsPtr->numCompilations); - Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Source bytes %.6g\n", statsPtr->totalSrcBytes); - Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Code bytes %.6g\n", totalCodeBytes); - Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes %.6g\n", statsPtr->totalByteCodeBytes); - Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Literal bytes %.6g\n", totalLiteralBytes); - Tcl_AppendPrintfToObj(objPtr, " table %" TCL_Z_MODIFIER "u + bkts %" TCL_Z_MODIFIER "u + entries %" TCL_Z_MODIFIER "u + objects %" TCL_Z_MODIFIER "u + strings %.6g\n", - sizeof(LiteralTable), - iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), - statsPtr->numLiteralsCreated * sizeof(LiteralEntry), - statsPtr->numLiteralsCreated * sizeof(Tcl_Obj), + 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) (statsPtr->numLiteralsCreated * sizeof(LiteralEntry)), + (unsigned long) (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj)), statsPtr->totalLitStringBytes); - Tcl_AppendPrintfToObj(objPtr, " Mean code/compile\t\t%.1f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean code/compile %.1f\n", totalCodeBytes / statsPtr->numCompilations); - Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean code/source %.1f\n", totalCodeBytes / statsPtr->totalSrcBytes); - Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes %ld\n", numCurrentByteCodes); - Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Source bytes %.6g\n", statsPtr->currentSrcBytes); - Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Code bytes %.6g\n", currentCodeBytes); - Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes %.6g\n", statsPtr->currentByteCodeBytes); - Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Literal bytes %.6g\n", currentLiteralBytes); - Tcl_AppendPrintfToObj(objPtr, " table %" TCL_Z_MODIFIER "u + bkts %" TCL_Z_MODIFIER "u + entries %" TCL_Z_MODIFIER "u + objects %" TCL_Z_MODIFIER "u + strings %.6g\n", - sizeof(LiteralTable), - iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), - iPtr->literalTable.numEntries * sizeof(LiteralEntry), - iPtr->literalTable.numEntries * sizeof(Tcl_Obj), + 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", + Tcl_AppendPrintfToObj(objPtr, " Mean code/source %.1f\n", currentCodeBytes / statsPtr->currentSrcBytes); - Tcl_AppendPrintfToObj(objPtr, " Code + source bytes\t\t%.6g (%0.1f mean code/src)\n", + Tcl_AppendPrintfToObj(objPtr, " Code + source bytes %.6g (%0.1f mean code/src)\n", (currentCodeBytes + statsPtr->currentSrcBytes), (currentCodeBytes / statsPtr->currentSrcBytes) + 1.0); /* * Tcl_IsShared statistics check @@ -9441,21 +8188,21 @@ * Shared objects must be duplicated before they can be modified. */ numSharedMultX = 0; Tcl_AppendPrintfToObj(objPtr, "\nTcl_IsShared object check (all objects):\n"); - Tcl_AppendPrintfToObj(objPtr, " Object had refcount <=1 (not shared)\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, " Object had refcount <=1 (not shared) %ld\n", tclObjsShared[1]); for (i = 2; i < TCL_MAX_SHARED_OBJ_STATS; i++) { - Tcl_AppendPrintfToObj(objPtr, " refcount ==%" TCL_Z_MODIFIER "u\t\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, " refcount ==%d %ld\n", i, tclObjsShared[i]); numSharedMultX += tclObjsShared[i]; } - Tcl_AppendPrintfToObj(objPtr, " refcount >=%" TCL_Z_MODIFIER "u\t\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, " refcount >=%d %ld\n", i, tclObjsShared[0]); numSharedMultX += tclObjsShared[0]; - Tcl_AppendPrintfToObj(objPtr, " Total shared objects\t\t\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, " Total shared objects %d\n", numSharedMultX); /* * Literal table statistics. */ @@ -9469,14 +8216,14 @@ strBytesSharedMultX = 0.0; strBytesSharedOnce = 0.0; for (i = 0; i < globalTablePtr->numBuckets; i++) { for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL; entryPtr = entryPtr->nextPtr) { - if (TclHasIntRep(entryPtr->objPtr, &tclByteCodeType)) { + if (entryPtr->objPtr->typePtr == &tclByteCodeType) { numByteCodeLits++; } - (void) TclGetStringFromObj(entryPtr->objPtr, &length); + (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length); refCountSum += entryPtr->refCount; objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj)); strBytesIfUnshared += (entryPtr->refCount * (length+1)); if (entryPtr->refCount > 1) { numSharedMultX++; @@ -9488,49 +8235,49 @@ } } sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared) - currentLiteralBytes; - Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps)\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps) %ld\n", tclObjsAlloced); - Tcl_AppendPrintfToObj(objPtr, "Current objects\t\t\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, "Current objects %ld\n", (tclObjsAlloced - tclObjsFreed)); - Tcl_AppendPrintfToObj(objPtr, "Total literal objects\t\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, "Total literal objects %ld\n", statsPtr->numLiteralsCreated); - Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects\t\t%" TCL_Z_MODIFIER "u (%0.1f%% of current objects)\n", + Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects %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", + Tcl_AppendPrintfToObj(objPtr, " ByteCode literals %ld (%0.1f%% of current literals)\n", numByteCodeLits, Percent(numByteCodeLits, globalTablePtr->numEntries)); - Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x\t\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x %d\n", numSharedMultX); - Tcl_AppendPrintfToObj(objPtr, " Mean reference count\t\t%.2f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean reference count %.2f\n", ((double) refCountSum) / globalTablePtr->numEntries); - Tcl_AppendPrintfToObj(objPtr, " Mean len, str reused >1x \t%.2f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean len, str reused >1x %.2f\n", (numSharedMultX ? strBytesSharedMultX/numSharedMultX : 0.0)); - Tcl_AppendPrintfToObj(objPtr, " Mean len, str used 1x\t\t%.2f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean len, str used 1x %.2f\n", (numSharedOnce ? strBytesSharedOnce/numSharedOnce : 0.0)); - Tcl_AppendPrintfToObj(objPtr, " Total sharing savings\t\t%.6g (%0.1f%% of bytes if no sharing)\n", + Tcl_AppendPrintfToObj(objPtr, " Total sharing savings %.6g (%0.1f%% of bytes if no sharing)\n", sharingBytesSaved, Percent(sharingBytesSaved, objBytesIfUnshared+strBytesIfUnshared)); - Tcl_AppendPrintfToObj(objPtr, " Bytes with sharing\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Bytes with sharing %.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, " Bytes if no sharing\t\t%.6g = objects %.6g + strings %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Bytes if no sharing %.6g = objects %.6g + strings %.6g\n", (objBytesIfUnshared + strBytesIfUnshared), objBytesIfUnshared, strBytesIfUnshared); - Tcl_AppendPrintfToObj(objPtr, " String sharing savings \t%.6g = unshared %.6g - shared %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " String sharing savings %.6g = unshared %.6g - shared %.6g\n", (strBytesIfUnshared - statsPtr->currentLitStringBytes), strBytesIfUnshared, statsPtr->currentLitStringBytes); - Tcl_AppendPrintfToObj(objPtr, " Literal mgmt overhead\t\t%" TCL_Z_MODIFIER "u (%0.1f%% of bytes with sharing)\n", + Tcl_AppendPrintfToObj(objPtr, " Literal mgmt overhead %ld (%0.1f%% of bytes with sharing)\n", literalMgmtBytes, Percent(literalMgmtBytes, currentLiteralBytes)); Tcl_AppendPrintfToObj(objPtr, " table %lu + buckets %lu + entries %lu\n", (unsigned long) sizeof(LiteralTable), (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)), @@ -9574,38 +8321,37 @@ /* * Detailed literal statistics. */ Tcl_AppendPrintfToObj(objPtr, "\nLiteral string sizes:\n"); - Tcl_AppendPrintfToObj(objPtr, "\t Up to length\t\tPercentage\n"); + Tcl_AppendPrintfToObj(objPtr, " Up to length Percentage\n"); maxSizeDecade = 0; - i = 32; - while (i-- > 0) { + for (i = 31; i >= 0; i--) { if (statsPtr->literalCount[i] > 0) { maxSizeDecade = i; break; } } sum = 0; for (i = 0; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->literalCount[i]; - Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_Z_MODIFIER "u\t\t%8.0f%%\n", + Tcl_AppendPrintfToObj(objPtr, " %10d %8.0f%%\n", decadeHigh, Percent(sum, statsPtr->numLiteralsCreated)); } litTableStats = TclLiteralStats(globalTablePtr); Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal table statistics:\n%s\n", litTableStats); - Tcl_Free(litTableStats); + ckfree((char *) litTableStats); /* * Source and ByteCode size distributions. */ Tcl_AppendPrintfToObj(objPtr, "\nSource sizes:\n"); - Tcl_AppendPrintfToObj(objPtr, "\t Up to size\t\tPercentage\n"); + Tcl_AppendPrintfToObj(objPtr, " Up to size Percentage\n"); minSizeDecade = maxSizeDecade = 0; for (i = 0; i < 31; i++) { if (statsPtr->srcCount[i] > 0) { minSizeDecade = i; break; @@ -9619,16 +8365,16 @@ } sum = 0; for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->srcCount[i]; - Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_Z_MODIFIER "u\t\t%8.0f%%\n", + Tcl_AppendPrintfToObj(objPtr, " %10d %8.0f%%\n", decadeHigh, Percent(sum, statsPtr->numCompilations)); } Tcl_AppendPrintfToObj(objPtr, "\nByteCode sizes:\n"); - Tcl_AppendPrintfToObj(objPtr, "\t Up to size\t\tPercentage\n"); + Tcl_AppendPrintfToObj(objPtr, " Up to size Percentage\n"); minSizeDecade = maxSizeDecade = 0; for (i = 0; i < 31; i++) { if (statsPtr->byteCodeCount[i] > 0) { minSizeDecade = i; break; @@ -9642,16 +8388,16 @@ } sum = 0; for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->byteCodeCount[i]; - Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_Z_MODIFIER "u\t\t%8.0f%%\n", + Tcl_AppendPrintfToObj(objPtr, " %10d %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"); + Tcl_AppendPrintfToObj(objPtr, " Up to ms Percentage\n"); minSizeDecade = maxSizeDecade = 0; for (i = 0; i < 31; i++) { if (statsPtr->lifetimeCount[i] > 0) { minSizeDecade = i; break; @@ -9665,21 +8411,21 @@ } sum = 0; for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->lifetimeCount[i]; - Tcl_AppendPrintfToObj(objPtr, "\t%12.3f\t\t%8.0f%%\n", + Tcl_AppendPrintfToObj(objPtr, " %12.3f %8.0f%%\n", decadeHigh/1000.0, Percent(sum, statsPtr->numByteCodesFreed)); } /* * 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 ", + for (i = 0; i <= LAST_INST_OPCODE; i++) { + Tcl_AppendPrintfToObj(objPtr, "%20s %8ld ", tclInstructionTable[i].name, statsPtr->instructionCount[i]); if (statsPtr->instructionCount[i]) { Tcl_AppendPrintfToObj(objPtr, "%6.1f%%\n", Percent(statsPtr->instructionCount[i], numInstructions)); } else { @@ -9687,19 +8433,19 @@ } } #ifdef TCL_MEM_DEBUG Tcl_AppendPrintfToObj(objPtr, "\nHeap Statistics:\n"); - TclDumpMemoryInfo(objPtr, 1); + TclDumpMemoryInfo((ClientData) objPtr, 1); #endif Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n"); if (objc == 1) { Tcl_SetObjResult(interp, objPtr); } else { Tcl_Channel outChan; - char *str = TclGetStringFromObj(objv[1], &length); + char *str = Tcl_GetStringFromObj(objv[1], &length); if (length) { if (strcmp(str, "stdout") == 0) { outChan = Tcl_GetStdChannel(TCL_STDOUT); } else if (strcmp(str, "stderr") == 0) { Index: generic/tclFCmd.c ================================================================== --- generic/tclFCmd.c +++ generic/tclFCmd.c @@ -9,11 +9,10 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" -#include "tclFileSystem.h" /* * Declarations for local functions defined in this file: */ @@ -20,13 +19,13 @@ static int CopyRenameOneFile(Tcl_Interp *interp, Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr, int copyFlag, int force); static Tcl_Obj * FileBasename(Tcl_Interp *interp, Tcl_Obj *pathPtr); static int FileCopyRename(Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[], int copyFlag); + int objc, Tcl_Obj *CONST objv[], int copyFlag); static int FileForceOption(Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[], int *forcePtr); + int objc, Tcl_Obj *CONST objv[], int *forcePtr); /* *--------------------------------------------------------------------------- * * TclFileRenameCmd @@ -45,15 +44,14 @@ *--------------------------------------------------------------------------- */ 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. */ + Tcl_Obj *CONST objv[]) /* Argument strings passed to Tcl_FileCmd. */ { return FileCopyRename(interp, objc, objv, 0); } /* @@ -74,15 +72,14 @@ *--------------------------------------------------------------------------- */ 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. */ + Tcl_Obj *CONST objv[]) /* Argument strings passed to Tcl_FileCmd. */ { return FileCopyRename(interp, objc, objv, 1); } /* @@ -104,32 +101,34 @@ static int FileCopyRename( Tcl_Interp *interp, /* Used for error reporting. */ int objc, /* Number of arguments. */ - Tcl_Obj *const objv[], /* Argument strings passed to Tcl_FileCmd. */ + Tcl_Obj *CONST objv[], /* Argument strings passed to Tcl_FileCmd. */ int copyFlag) /* If non-zero, copy source(s). Otherwise, * rename them. */ { int i, result, force; Tcl_StatBuf statBuf; Tcl_Obj *target; - i = FileForceOption(interp, objc - 1, objv + 1, &force); + i = FileForceOption(interp, objc - 2, objv + 2, &force); if (i < 0) { return TCL_ERROR; } - i++; + i += 2; if ((objc - i) < 2) { - Tcl_WrongNumArgs(interp, 1, objv, - "?-option value ...? source ?source ...? target"); + Tcl_AppendResult(interp, "wrong # args: should be \"", + TclGetString(objv[0]), " ", TclGetString(objv[1]), + " ?options? source ?source ...? target\"", NULL); return TCL_ERROR; } /* - * If target doesn't exist or isn't a directory, try the copy/rename. More - * than 2 arguments is only valid if the target is an existing directory. + * If target doesn't exist or isn't a directory, try the copy/rename. + * More than 2 arguments is only valid if the target is an existing + * directory. */ target = objv[objc - 1]; if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) { return TCL_ERROR; @@ -145,13 +144,13 @@ if ((Tcl_FSStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) { if ((objc - i) > 2) { errno = ENOTDIR; Tcl_PosixError(interp); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "error %s: target \"%s\" is not a directory", - (copyFlag?"copying":"renaming"), TclGetString(target))); + Tcl_AppendResult(interp, "error ", + (copyFlag ? "copying" : "renaming"), ": target \"", + TclGetString(target), "\" is not a directory", NULL); result = TCL_ERROR; } else { /* * Even though already have target == translated(objv[i+1]), pass * the original argument down, so if there's an error, the error @@ -170,23 +169,26 @@ */ for ( ; itypePtr = NULL; + } if (Tcl_FSFileAttrsGet(interp, index, filePtr, &objPtr) != TCL_OK) { goto end; } Tcl_SetObjResult(interp, objPtr); @@ -1099,560 +1088,59 @@ */ int i, index; if (numObjStrings == 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad option \"%s\", there are no file attributes in this" - " filesystem", TclGetString(objv[0]))); - Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL); - goto end; - } - - for (i = 0; i < objc ; i += 2) { - if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings, - "option", TCL_INDEX_TEMP_TABLE, &index) != TCL_OK) { - goto end; - } - if (i + 1 == objc) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "value for \"%s\" missing", TclGetString(objv[i]))); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FATTR", - "NOVALUE", NULL); - goto end; - } - if (Tcl_FSFileAttrsSet(interp, index, filePtr, - objv[i + 1]) != TCL_OK) { - goto end; - } - } + Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]), + "\", there are no file attributes in this filesystem.", + NULL); + goto end; + } + + for (i = 0; i < objc ; i += 2) { + if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings, + "option", 0, &index) != TCL_OK) { + goto end; + } + if (didAlloc) { + TclFreeIntRep(objv[i]); + objv[i]->typePtr = NULL; + } + if (i + 1 == objc) { + Tcl_AppendResult(interp, "value for \"", + TclGetString(objv[i]), "\" missing", NULL); + goto end; + } + if (Tcl_FSFileAttrsSet(interp, index, filePtr, + objv[i + 1]) != TCL_OK) { + goto end; + } + } } result = TCL_OK; - /* - * Free up the array we allocated and drop our reference to any list of - * attribute names issued by the filesystem. - */ - - end: - if (attributeStringsAllocated != NULL) { - TclStackFree(interp, (void *) attributeStringsAllocated); - } - if (objStrings != NULL) { + end: + if (didAlloc) { + /* + * Free up the array we allocated. + */ + + TclStackFree(interp, (void *)attributeStrings); + } + + if (objStrings != NULL) { + /* + * We don't need this object that was passed to us any more. + */ + Tcl_DecrRefCount(objStrings); } return result; } - -/* - *---------------------------------------------------------------------- - * - * TclFileLinkCmd -- - * - * This function is invoked to process the "file link" Tcl command. See - * the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * May create a new link. - * - *---------------------------------------------------------------------- - */ - -int -TclFileLinkCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Obj *contents; - int index; - - if (objc < 2 || objc > 4) { - Tcl_WrongNumArgs(interp, 1, objv, "?-linktype? linkname ?target?"); - return TCL_ERROR; - } - - /* - * Index of the 'source' argument. - */ - - if (objc == 4) { - index = 2; - } else { - index = 1; - } - - if (objc > 2) { - int linkAction; - - if (objc == 4) { - /* - * We have a '-linktype' argument. - */ - - static const char *const linkTypes[] = { - "-symbolic", "-hard", NULL - }; - if (Tcl_GetIndexFromObj(interp, objv[1], linkTypes, "option", 0, - &linkAction) != TCL_OK) { - return TCL_ERROR; - } - if (linkAction == 0) { - linkAction = TCL_CREATE_SYMBOLIC_LINK; - } else { - linkAction = TCL_CREATE_HARD_LINK; - } - } else { - linkAction = TCL_CREATE_SYMBOLIC_LINK | TCL_CREATE_HARD_LINK; - } - if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Create link from source to target. - */ - - contents = Tcl_FSLink(objv[index], objv[index+1], linkAction); - if (contents == NULL) { - /* - * We handle three common error cases specially, and for all other - * errors, we use the standard posix error message. - */ - - if (errno == EEXIST) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not create new link \"%s\": that path already" - " exists", TclGetString(objv[index]))); - Tcl_PosixError(interp); - } else if (errno == ENOENT) { - /* - * There are two cases here: either the target doesn't exist, - * or the directory of the src doesn't exist. - */ - - int access; - Tcl_Obj *dirPtr = TclPathPart(interp, objv[index], - TCL_PATH_DIRNAME); - - if (dirPtr == NULL) { - return TCL_ERROR; - } - access = Tcl_FSAccess(dirPtr, F_OK); - Tcl_DecrRefCount(dirPtr); - if (access != 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not create new link \"%s\": no such file" - " or directory", TclGetString(objv[index]))); - Tcl_PosixError(interp); - } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not create new link \"%s\": target \"%s\" " - "doesn't exist", TclGetString(objv[index]), - TclGetString(objv[index+1]))); - errno = ENOENT; - Tcl_PosixError(interp); - } - } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not create new link \"%s\" pointing to \"%s\": %s", - TclGetString(objv[index]), - TclGetString(objv[index+1]), Tcl_PosixError(interp))); - } - return TCL_ERROR; - } - } else { - if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Read link - */ - - contents = Tcl_FSLink(objv[index], NULL, 0); - if (contents == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not read link \"%s\": %s", - TclGetString(objv[index]), Tcl_PosixError(interp))); - return TCL_ERROR; - } - } - Tcl_SetObjResult(interp, contents); - if (objc == 2) { - /* - * If we are reading a link, we need to free this result refCount. If - * we are creating a link, this will just be objv[index+1], and so we - * don't own it. - */ - - Tcl_DecrRefCount(contents); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclFileReadLinkCmd -- - * - * This function is invoked to process the "file readlink" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclFileReadLinkCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Obj *contents; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "name"); - return TCL_ERROR; - } - - if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { - return TCL_ERROR; - } - - contents = Tcl_FSLink(objv[1], NULL, 0); - - if (contents == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not read link \"%s\": %s", - TclGetString(objv[1]), Tcl_PosixError(interp))); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, contents); - Tcl_DecrRefCount(contents); - return TCL_OK; -} - -/* - *--------------------------------------------------------------------------- - * - * TclFileTemporaryCmd -- - * - * This function implements the "tempfile" subcommand of the "file" - * command. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Creates a temporary file. Opens a channel to that file and puts the - * name of that channel in the result. *Might* register suitable exit - * handlers to ensure that the temporary file gets deleted. Might write - * 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. */ - Tcl_Channel chan; /* The channel opened (RDWR) on the temporary - * file, or NULL if there's an error. */ - Tcl_Obj *tempDirObj = NULL, *tempBaseObj = NULL, *tempExtObj = NULL; - /* Pieces of template. Each piece is NULL if - * it is omitted. The platform temporary file - * engine might ignore some pieces. */ - - if (objc < 1 || objc > 3) { - Tcl_WrongNumArgs(interp, 1, objv, "?nameVar? ?template?"); - return TCL_ERROR; - } - - if (objc > 1) { - nameVarObj = objv[1]; - TclNewObj(nameObj); - } - if (objc > 2) { - size_t length; - Tcl_Obj *templateObj = objv[2]; - const char *string = TclGetStringFromObj(templateObj, &length); - - /* - * Treat an empty string as if it wasn't there. - */ - - if (length == 0) { - goto makeTemporary; - } - - /* - * The template only gives a directory if there is a directory - * separator in it. - */ - - if (strchr(string, '/') != NULL - || (tclPlatform == TCL_PLATFORM_WINDOWS - && strchr(string, '\\') != NULL)) { - tempDirObj = TclPathPart(interp, templateObj, TCL_PATH_DIRNAME); - - /* - * Only allow creation of temporary files in the native filesystem - * since they are frequently used for integration with external - * tools or system libraries. [Bug 2388866] - */ - - if (tempDirObj != NULL && Tcl_FSGetFileSystemForPath(tempDirObj) - != &tclNativeFilesystem) { - TclDecrRefCount(tempDirObj); - tempDirObj = NULL; - } - } - - /* - * The template only gives the filename if the last character isn't a - * directory separator. - */ - - if (string[length-1] != '/' && (tclPlatform != TCL_PLATFORM_WINDOWS - || string[length-1] != '\\')) { - Tcl_Obj *tailObj = TclPathPart(interp, templateObj, - TCL_PATH_TAIL); - - if (tailObj != NULL) { - tempBaseObj = TclPathPart(interp, tailObj, TCL_PATH_ROOT); - tempExtObj = TclPathPart(interp, tailObj, TCL_PATH_EXTENSION); - TclDecrRefCount(tailObj); - } - } - } - - /* - * Convert empty parts of the template into unspecified parts. - */ - - if (tempDirObj && !TclGetString(tempDirObj)[0]) { - TclDecrRefCount(tempDirObj); - tempDirObj = NULL; - } - if (tempBaseObj && !TclGetString(tempBaseObj)[0]) { - TclDecrRefCount(tempBaseObj); - tempBaseObj = NULL; - } - if (tempExtObj && !TclGetString(tempExtObj)[0]) { - TclDecrRefCount(tempExtObj); - tempExtObj = NULL; - } - - /* - * Create and open the temporary file. - */ - - makeTemporary: - chan = TclpOpenTemporaryFile(tempDirObj,tempBaseObj,tempExtObj, nameObj); - - /* - * If we created pieces of template, get rid of them now. - */ - - if (tempDirObj) { - TclDecrRefCount(tempDirObj); - } - if (tempBaseObj) { - TclDecrRefCount(tempBaseObj); - } - if (tempExtObj) { - TclDecrRefCount(tempExtObj); - } - - /* - * Deal with results. - */ - - if (chan == NULL) { - if (nameVarObj) { - TclDecrRefCount(nameObj); - } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create temporary file: %s", Tcl_PosixError(interp))); - return TCL_ERROR; - } - Tcl_RegisterChannel(interp, chan); - if (nameVarObj != NULL) { - if (Tcl_ObjSetVar2(interp, nameVarObj, NULL, nameObj, - TCL_LEAVE_ERR_MSG) == NULL) { - Tcl_UnregisterChannel(interp, chan); - return TCL_ERROR; - } - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1)); - return TCL_OK; -} - -/* - *--------------------------------------------------------------------------- - * - * TclFileTempDirCmd -- - * - * This function implements the "tempdir" subcommand of the "file" - * command. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * 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; - /* Pieces of template. Each piece is NULL if - * it is omitted. The platform temporary file - * engine might ignore some pieces. */ - - if (objc < 1 || objc > 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?template?"); - return TCL_ERROR; - } - - if (objc > 1) { - int length; - Tcl_Obj *templateObj = objv[1]; - const char *string = TclGetStringFromObj(templateObj, &length); - const int onWindows = (tclPlatform == TCL_PLATFORM_WINDOWS); - - /* - * Treat an empty string as if it wasn't there. - */ - - if (length == 0) { - goto makeTemporary; - } - - /* - * The template only gives a directory if there is a directory - * separator in it, and only gives a base name if there's at least one - * character after the last directory separator. - */ - - if (strchr(string, '/') == NULL - && (!onWindows || strchr(string, '\\') == NULL)) { - /* - * No directory separator, so just assume we have a file name. - * This is a bit wrong on Windows where we could have problems - * with disk name prefixes... but those are much less common in - * naked form so we just pass through and let the OS figure it out - * instead. - */ - - nameBaseObj = templateObj; - Tcl_IncrRefCount(nameBaseObj); - } else if (string[length-1] != '/' - && (!onWindows || string[length-1] != '\\')) { - /* - * If the template has a non-terminal directory separator, split - * into dirname and tail. - */ - - baseDirObj = TclPathPart(interp, templateObj, TCL_PATH_DIRNAME); - nameBaseObj = TclPathPart(interp, templateObj, TCL_PATH_TAIL); - } else { - /* - * Otherwise, there must be a terminal directory separator, so - * just the directory is given. - */ - - baseDirObj = templateObj; - Tcl_IncrRefCount(baseDirObj); - } - - /* - * Only allow creation of temporary directories in the native - * filesystem since they are frequently used for integration with - * external tools or system libraries. - */ - - if (baseDirObj != NULL && Tcl_FSGetFileSystemForPath(baseDirObj) - != &tclNativeFilesystem) { - TclDecrRefCount(baseDirObj); - baseDirObj = NULL; - } - } - - /* - * Convert empty parts of the template into unspecified parts. - */ - - if (baseDirObj && !TclGetString(baseDirObj)[0]) { - TclDecrRefCount(baseDirObj); - baseDirObj = NULL; - } - if (nameBaseObj && !TclGetString(nameBaseObj)[0]) { - TclDecrRefCount(nameBaseObj); - nameBaseObj = NULL; - } - - /* - * Create and open the temporary file. - */ - - makeTemporary: - dirNameObj = TclpCreateTemporaryDirectory(baseDirObj, nameBaseObj); - - /* - * If we created pieces of template, get rid of them now. - */ - - if (baseDirObj) { - TclDecrRefCount(baseDirObj); - } - if (nameBaseObj) { - TclDecrRefCount(nameBaseObj); - } - - /* - * Deal with results. - */ - - if (dirNameObj == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create temporary directory: %s", - Tcl_PosixError(interp))); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, dirNameObj); - return TCL_OK; -} /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclFileName.c ================================================================== --- generic/tclFileName.c +++ generic/tclFileName.c @@ -35,20 +35,10 @@ static Tcl_Obj * SplitWinPath(const char *path); static Tcl_Obj * SplitUnixPath(const char *path); static int DoGlob(Tcl_Interp *interp, Tcl_Obj *resultPtr, const char *separators, Tcl_Obj *pathPtr, int flags, char *pattern, Tcl_GlobTypeData *types); - -/* - * When there is no support for getting the block size of a file in a stat() - * call, use this as a guess. Allow it to be overridden in the platform- - * specific files. - */ - -#if (!defined(HAVE_STRUCT_STAT_ST_BLKSIZE) && !defined(GUESSED_BLOCK_SIZE)) -#define GUESSED_BLOCK_SIZE 1024 -#endif /* *---------------------------------------------------------------------- * * SetResultLength -- @@ -70,13 +60,13 @@ int offset, int extended) { Tcl_DStringSetLength(resultPtr, offset); if (extended == 2) { - TclDStringAppendLiteral(resultPtr, "//?/UNC/"); + Tcl_DStringAppend(resultPtr, "//?/UNC/", 8); } else if (extended == 1) { - TclDStringAppendLiteral(resultPtr, "//?/"); + Tcl_DStringAppend(resultPtr, "//?/", 4); } } /* *---------------------------------------------------------------------- @@ -129,11 +119,11 @@ int hlen, slen; if (path[1] != '/' && path[1] != '\\') { SetResultLength(resultPtr, offset, extended); *typePtr = TCL_PATH_VOLUME_RELATIVE; - TclDStringAppendLiteral(resultPtr, "/"); + Tcl_DStringAppend(resultPtr, "/", 1); return &path[1]; } host = &path[2]; /* @@ -159,11 +149,11 @@ * interpretation would be that it is a host name, but we have * been documented that that is not the case). */ *typePtr = TCL_PATH_VOLUME_RELATIVE; - TclDStringAppendLiteral(resultPtr, "/"); + Tcl_DStringAppend(resultPtr, "/", 1); return &path[2]; } SetResultLength(resultPtr, offset, extended); share = &host[hlen]; @@ -178,13 +168,13 @@ for (slen=0; share[slen]; slen++) { if (share[slen] == '/' || share[slen] == '\\') { break; } } - TclDStringAppendLiteral(resultPtr, "//"); + Tcl_DStringAppend(resultPtr, "//", 2); Tcl_DStringAppend(resultPtr, host, hlen); - TclDStringAppendLiteral(resultPtr, "/"); + Tcl_DStringAppend(resultPtr, "/", 1); Tcl_DStringAppend(resultPtr, share, slen); tail = &share[slen]; /* @@ -219,11 +209,11 @@ tail++; } *typePtr = TCL_PATH_ABSOLUTE; Tcl_DStringAppend(resultPtr, path, 2); - TclDStringAppendLiteral(resultPtr, "/"); + Tcl_DStringAppend(resultPtr, "/", 1); return tail; } } else { int abs = 0; @@ -384,11 +374,12 @@ int *driveNameLengthPtr, /* Returns length of drive, if non-NULL and * path was absolute */ Tcl_Obj **driveNameRef) { Tcl_PathType type = TCL_PATH_ABSOLUTE; - const char *path = TclGetString(pathPtr); + int pathLen; + const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); if (path[0] == '~') { /* * This case is common to all platforms. Paths that begin with ~ are * absolute. @@ -453,11 +444,12 @@ Tcl_DStringInit(&ds); rootEnd = ExtractWinRoot(path, &ds, 0, &type); if ((rootEnd != path) && (driveNameLengthPtr != NULL)) { *driveNameLengthPtr = rootEnd - path; if (driveNameRef != NULL) { - *driveNameRef = TclDStringToObj(&ds); + *driveNameRef = Tcl_NewStringObj(Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds)); Tcl_IncrRefCount(*driveNameRef); } } Tcl_DStringFree(&ds); break; @@ -501,15 +493,15 @@ * Perform platform specific splitting. */ switch (tclPlatform) { case TCL_PLATFORM_UNIX: - resultPtr = SplitUnixPath(TclGetString(pathPtr)); + resultPtr = SplitUnixPath(Tcl_GetString(pathPtr)); break; case TCL_PLATFORM_WINDOWS: - resultPtr = SplitWinPath(TclGetString(pathPtr)); + resultPtr = SplitWinPath(Tcl_GetString(pathPtr)); break; } /* * Compute the number of elements in the result. @@ -534,11 +526,11 @@ * 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 Tcl_Free() on *argvPtr. Note: + * 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. @@ -554,12 +546,11 @@ 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_t size, len; + int i, size, len; char *p; const char *str; /* * Perform the splitting, using objectified, vfs-aware code. @@ -576,20 +567,20 @@ */ size = 1; for (i = 0; i < *argcPtr; i++) { Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr); - (void)TclGetStringFromObj(eltPtr, &len); + Tcl_GetStringFromObj(eltPtr, &len); size += len + 1; } /* * Allocate a buffer large enough to hold the contents of all of the list * plus the argv pointers and the terminating NULL pointer. */ - *argvPtr = (const char **)Tcl_Alloc( + *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. @@ -596,11 +587,11 @@ */ p = (char *) &(*argvPtr)[(*argcPtr) + 1]; for (i = 0; i < *argcPtr; i++) { Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr); - str = TclGetStringFromObj(eltPtr, &len); + str = Tcl_GetStringFromObj(eltPtr, &len); memcpy(p, str, len + 1); p += len+1; } /* @@ -641,11 +632,11 @@ static Tcl_Obj * SplitUnixPath( const char *path) /* Pointer to string containing a path. */ { - size_t length; + int length; const char *origPath = path, *elementStart; Tcl_Obj *result; /* * Deal with the root directory as a special case. @@ -731,11 +722,11 @@ static Tcl_Obj * SplitWinPath( const char *path) /* Pointer to string containing a path. */ { - size_t length; + int length; const char *p, *elementStart; Tcl_PathType type = TCL_PATH_ABSOLUTE; Tcl_DString buf; Tcl_Obj *result; Tcl_DStringInit(&buf); @@ -746,11 +737,12 @@ /* * Terminate the root portion, if we matched something. */ if (p != path) { - Tcl_ListObjAppendElement(NULL, result, TclDStringToObj(&buf)); + Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj( + Tcl_DStringValue(&buf), Tcl_DStringLength(&buf))); } Tcl_DStringFree(&buf); /* * Split on slashes. Embedded elements that start with tilde or a drive @@ -808,32 +800,36 @@ Tcl_FSJoinToPath( Tcl_Obj *pathPtr, /* Valid path or NULL. */ int objc, /* Number of array elements to join */ Tcl_Obj *const objv[]) /* Path elements to join. */ { + int i; + Tcl_Obj *lobj, *ret; + if (pathPtr == NULL) { - return TclJoinPath(objc, objv, 0); - } - if (objc == 0) { - return TclJoinPath(1, &pathPtr, 0); - } - if (objc == 1) { - Tcl_Obj *pair[2]; - - pair[0] = pathPtr; - pair[1] = objv[0]; - return TclJoinPath(2, pair, 0); + lobj = Tcl_NewListObj(0, NULL); } else { - int elemc = objc + 1; - Tcl_Obj *ret, **elemv = (Tcl_Obj**)Tcl_Alloc(elemc*sizeof(Tcl_Obj *)); - - elemv[0] = pathPtr; - memcpy(elemv+1, objv, objc*sizeof(Tcl_Obj *)); - ret = TclJoinPath(elemc, elemv, 0); - Tcl_Free(elemv); - return ret; - } + lobj = Tcl_NewListObj(1, &pathPtr); + } + + for (i = 0; irefCount--; + return ret; } /* *--------------------------------------------------------------------------- * @@ -853,17 +849,16 @@ void TclpNativeJoinPath( Tcl_Obj *prefix, const char *joining) { - int needsSep; - size_t length; + int length, needsSep; char *dest; const char *p; const char *start; - start = TclGetStringFromObj(prefix, &length); + start = Tcl_GetStringFromObj(prefix, &length); /* * Remove the ./ from tilde prefixed elements, and drive-letter prefixed * elements on Windows, unless it is the first component. */ @@ -887,21 +882,21 @@ * Append a separator if needed. */ if (length > 0 && (start[length-1] != '/')) { Tcl_AppendToObj(prefix, "/", 1); - (void)TclGetStringFromObj(prefix, &length); + Tcl_GetStringFromObj(prefix, &length); } needsSep = 0; /* * Append the element, eliminating duplicate and trailing slashes. */ Tcl_SetObjLength(prefix, length + (int) strlen(p)); - dest = TclGetString(prefix) + length; + dest = Tcl_GetString(prefix) + length; for (; *p != '\0'; p++) { if (*p == '/') { while (p[1] == '/') { p++; } @@ -911,11 +906,11 @@ } else { *dest++ = *p; needsSep = 1; } } - length = dest - TclGetString(prefix); + length = dest - Tcl_GetString(prefix); Tcl_SetObjLength(prefix, length); break; case TCL_PLATFORM_WINDOWS: /* @@ -923,20 +918,20 @@ */ if ((length > 0) && (start[length-1] != '/') && (start[length-1] != ':')) { Tcl_AppendToObj(prefix, "/", 1); - (void)TclGetStringFromObj(prefix, &length); + Tcl_GetStringFromObj(prefix, &length); } needsSep = 0; /* * Append the element, eliminating duplicate and trailing slashes. */ Tcl_SetObjLength(prefix, length + (int) strlen(p)); - dest = TclGetString(prefix) + length; + dest = Tcl_GetString(prefix) + length; for (; *p != '\0'; p++) { if ((*p == '/') || (*p == '\\')) { while ((p[1] == '/') || (p[1] == '\\')) { p++; } @@ -946,11 +941,11 @@ } else { *dest++ = *p; needsSep = 1; } } - length = dest - TclGetString(prefix); + length = dest - Tcl_GetString(prefix); Tcl_SetObjLength(prefix, length); break; } return; } @@ -978,12 +973,11 @@ Tcl_JoinPath( int argc, const char *const *argv, Tcl_DString *resultPtr) /* Pointer to previously initialized DString */ { - int i; - size_t len; + int i, len; Tcl_Obj *listObj; Tcl_Obj *resultObj; const char *resultStr; /* @@ -1007,11 +1001,11 @@ /* * Store the result. */ - resultStr = TclGetStringFromObj(resultObj, &len); + resultStr = Tcl_GetStringFromObj(resultObj, &len); Tcl_DStringAppend(resultPtr, resultStr, len); Tcl_DecrRefCount(resultObj); /* * Return a pointer to the result. @@ -1066,11 +1060,11 @@ Tcl_DecrRefCount(path); return NULL; } Tcl_DStringInit(bufferPtr); - TclDStringAppendObj(bufferPtr, transPtr); + Tcl_DStringAppend(bufferPtr, Tcl_GetString(transPtr), -1); Tcl_DecrRefCount(path); Tcl_DecrRefCount(transPtr); /* * Convert forward slashes to backslashes in Windows paths because some @@ -1183,25 +1177,23 @@ Tcl_DString dirString; dir = TclGetEnv("HOME", &dirString); if (dir == NULL) { if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "couldn't find HOME environment " - "variable to expand path", -1)); - Tcl_SetErrorCode(interp, "TCL", "FILENAME", "NO_HOME", NULL); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't find HOME environment " + "variable to expand path", NULL); } return NULL; } Tcl_JoinPath(1, &dir, resultPtr); Tcl_DStringFree(&dirString); } else if (TclpGetUserHome(user, resultPtr) == NULL) { if (interp) { Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "user \"%s\" doesn't exist", user)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "USER", user, NULL); + Tcl_AppendResult(interp, "user \"", user, "\" doesn't exist", + NULL); } return NULL; } return Tcl_DStringValue(resultPtr); } @@ -1223,40 +1215,41 @@ *---------------------------------------------------------------------- */ int Tcl_GlobObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int index, i, globFlags, length, join, dir, result; char *string; const char *separators; - Tcl_Obj *typePtr, *look; + Tcl_Obj *typePtr, *resultPtr, *look; Tcl_Obj *pathOrDir = NULL; Tcl_DString prefix; - static const char *const options[] = { + static const char *options[] = { "-directory", "-join", "-nocomplain", "-path", "-tails", "-types", "--", NULL }; enum globOptionsEnum { GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TAILS, GLOB_TYPE, GLOB_LAST }; enum pathDirOptions {PATH_NONE = -1 , PATH_GENERAL = 0, PATH_DIR = 1}; Tcl_GlobTypeData *globTypes = NULL; + (void)dummy; 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 = TclGetString(objv[i]); + string = Tcl_GetStringFromObj(objv[i], &length); if (string[0] == '-') { /* * It looks like the command contains an option so signal an * error. */ @@ -1279,21 +1272,18 @@ break; case GLOB_DIR: /* -dir */ if (i == (objc-1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing argument to \"-directory\"", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); return TCL_ERROR; } if (dir != PATH_NONE) { Tcl_SetObjResult(interp, Tcl_NewStringObj( dir == PATH_DIR ? "\"-directory\" may only be used once" : "\"-directory\" cannot be used with \"-path\"", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", - "BADOPTIONCOMBINATION", NULL); return TCL_ERROR; } dir = PATH_DIR; globFlags |= TCL_GLOBMODE_DIR; pathOrDir = objv[i+1]; @@ -1307,21 +1297,18 @@ break; case GLOB_PATH: /* -path */ if (i == (objc-1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing argument to \"-path\"", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); return TCL_ERROR; } if (dir != PATH_NONE) { Tcl_SetObjResult(interp, Tcl_NewStringObj( dir == PATH_GENERAL ? "\"-path\" may only be used once" : "\"-path\" cannot be used with \"-dictionary\"", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", - "BADOPTIONCOMBINATION", NULL); return TCL_ERROR; } dir = PATH_GENERAL; pathOrDir = objv[i+1]; i++; @@ -1328,11 +1315,10 @@ break; case GLOB_TYPE: /* -types */ if (i == (objc-1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing argument to \"-types\"", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); return TCL_ERROR; } typePtr = objv[i+1]; if (Tcl_ListObjLength(interp, typePtr, &length) != TCL_OK) { return TCL_ERROR; @@ -1344,16 +1330,18 @@ goto endOfForLoop; } } endOfForLoop: + if (objc - i < 1) { + Tcl_WrongNumArgs(interp, 1, objv, "?switches? name ?name ...?"); + return TCL_ERROR; + } if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( + Tcl_AppendResult(interp, "\"-tails\" must be used with either " - "\"-directory\" or \"-path\"", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", - "BADOPTIONCOMBINATION", NULL); + "\"-directory\" or \"-path\"", NULL); return TCL_ERROR; } separators = NULL; switch (tclPlatform) { @@ -1364,13 +1352,13 @@ separators = "/\\:"; break; } if (dir == PATH_GENERAL) { - size_t pathlength; + int pathlength; const char *last; - const char *first = TclGetStringFromObj(pathOrDir,&pathlength); + const char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength); /* * Find the last path separator in the path */ @@ -1416,11 +1404,11 @@ * 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(TclGetString(pathOrDir), "\\/") == NULL) { + if (strpbrk(Tcl_GetString(pathOrDir), "\\/") == NULL) { Tcl_AppendToObj(pathOrDir, last-1, 1); } } /* @@ -1429,11 +1417,11 @@ Tcl_DStringInit(&prefix); search = Tcl_DStringValue(&pref); while ((find = (strpbrk(search, "\\[]*?{}"))) != NULL) { Tcl_DStringAppend(&prefix, search, find-search); - TclDStringAppendLiteral(&prefix, "\\"); + Tcl_DStringAppend(&prefix, "\\", 1); Tcl_DStringAppend(&prefix, find, 1); search = find+1; if (*search == '\0') { break; } @@ -1458,22 +1446,23 @@ Tcl_ListObjLength(interp, typePtr, &length); if (length <= 0) { goto skipTypes; } - globTypes = (Tcl_GlobTypeData *)TclStackAlloc(interp, sizeof(Tcl_GlobTypeData)); + globTypes = (Tcl_GlobTypeData *) + TclStackAlloc(interp,sizeof(Tcl_GlobTypeData)); globTypes->type = 0; globTypes->perm = 0; globTypes->macType = NULL; globTypes->macCreator = NULL; while (--length >= 0) { - size_t len; + int len; const char *str; Tcl_ListObjIndex(interp, typePtr, length, &look); - str = TclGetStringFromObj(look, &len); + str = Tcl_GetStringFromObj(look, &len); if (strcmp("readonly", str) == 0) { globTypes->perm |= TCL_GLOB_PERM_RONLY; } else if (strcmp("hidden", str) == 0) { globTypes->perm |= TCL_GLOB_PERM_HIDDEN; } else if (len == 1) { @@ -1523,26 +1512,25 @@ globTypes->macType = look; Tcl_IncrRefCount(look); } else { Tcl_Obj *item; - int llen; - if ((Tcl_ListObjLength(NULL, look, &llen) == TCL_OK) - && (llen == 3)) { + if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK) + && (len == 3)) { Tcl_ListObjIndex(interp, look, 0, &item); - if (!strcmp("macintosh", TclGetString(item))) { + if (!strcmp("macintosh", Tcl_GetString(item))) { Tcl_ListObjIndex(interp, look, 1, &item); - if (!strcmp("type", TclGetString(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", TclGetString(item))) { + } else if (!strcmp("creator", Tcl_GetString(item))) { Tcl_ListObjIndex(interp, look, 2, &item); if (globTypes->macCreator != NULL) { goto badMacTypesArg; } globTypes->macCreator = item; @@ -1556,24 +1544,23 @@ * 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", - TclGetString(look))); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL); + TclNewObj(resultPtr); + Tcl_AppendToObj(resultPtr, "bad argument to \"-types\": ", -1); + Tcl_AppendObjToObj(resultPtr, look); + Tcl_SetObjResult(interp, resultPtr); result = TCL_ERROR; join = 0; goto endOfGlob; badMacTypesArg: Tcl_SetObjResult(interp, Tcl_NewStringObj( "only one MacOS type or creator argument" " to \"-types\" allowed", -1)); result = TCL_ERROR; - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL); join = 0; goto endOfGlob; } } } @@ -1592,11 +1579,12 @@ if (join) { if (dir != PATH_GENERAL) { Tcl_DStringInit(&prefix); } for (i = 0; i < objc; i++) { - TclDStringAppendObj(&prefix, objv[i]); + string = Tcl_GetStringFromObj(objv[i], &length); + Tcl_DStringAppend(&prefix, string, length); if (i != objc -1) { Tcl_DStringAppend(&prefix, separators, 1); } } if (TclGlob(interp, Tcl_DStringValue(&prefix), pathOrDir, globFlags, @@ -1605,17 +1593,18 @@ goto endOfGlob; } } else if (dir == PATH_GENERAL) { Tcl_DString str; - Tcl_DStringInit(&str); for (i = 0; i < objc; i++) { - Tcl_DStringSetLength(&str, 0); + Tcl_DStringInit(&str); if (dir == PATH_GENERAL) { - TclDStringAppendDString(&str, &prefix); + Tcl_DStringAppend(&str, Tcl_DStringValue(&prefix), + Tcl_DStringLength(&prefix)); } - TclDStringAppendObj(&str, objv[i]); + string = Tcl_GetStringFromObj(objv[i], &length); + Tcl_DStringAppend(&str, string, length); if (TclGlob(interp, Tcl_DStringValue(&str), pathOrDir, globFlags, globTypes) != TCL_OK) { result = TCL_ERROR; Tcl_DStringFree(&str); goto endOfGlob; @@ -1622,11 +1611,11 @@ } } Tcl_DStringFree(&str); } else { for (i = 0; i < objc; i++) { - string = TclGetString(objv[i]); + string = Tcl_GetString(objv[i]); if (TclGlob(interp, string, pathOrDir, globFlags, globTypes) != TCL_OK) { result = TCL_ERROR; goto endOfGlob; } @@ -1643,29 +1632,23 @@ result = TCL_ERROR; goto endOfGlob; } if (length == 0) { - Tcl_Obj *errorMsg = - Tcl_ObjPrintf("no files matched glob pattern%s \"", - (join || (objc == 1)) ? "" : "s"); - + Tcl_AppendResult(interp, "no files matched glob pattern", + (join || (objc == 1)) ? " \"" : "s \"", NULL); if (join) { - Tcl_AppendToObj(errorMsg, Tcl_DStringValue(&prefix), -1); + Tcl_AppendResult(interp, Tcl_DStringValue(&prefix), NULL); } else { const char *sep = ""; - for (i = 0; i < objc; i++) { - Tcl_AppendPrintfToObj(errorMsg, "%s%s", - sep, TclGetString(objv[i])); + string = Tcl_GetString(objv[i]); + Tcl_AppendResult(interp, sep, string, NULL); sep = " "; } } - Tcl_AppendToObj(errorMsg, "\"", -1); - Tcl_SetObjResult(interp, errorMsg); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "NOMATCH", - NULL); + Tcl_AppendResult(interp, "\"", NULL); result = TCL_ERROR; } } endOfGlob: @@ -1782,11 +1765,12 @@ return TCL_ERROR; } if (head != Tcl_DStringValue(&buffer)) { Tcl_DStringAppend(&buffer, head, -1); } - pathPrefix = TclDStringToObj(&buffer); + pathPrefix = Tcl_NewStringObj(Tcl_DStringValue(&buffer), + Tcl_DStringLength(&buffer)); Tcl_IncrRefCount(pathPrefix); globFlags |= TCL_GLOBMODE_DIR; if (c != '\0') { tail++; } @@ -1855,11 +1839,11 @@ if (cwd == NULL) { Tcl_DecrRefCount(temp); return TCL_ERROR; } - pathPrefix = Tcl_NewStringObj(TclGetString(cwd), 3); + pathPrefix = Tcl_NewStringObj(Tcl_GetString(cwd), 3); Tcl_DecrRefCount(cwd); if (tail[0] == '/') { tail++; } else { tail += 2; @@ -1889,11 +1873,11 @@ */ separators = "/\\"; } else if (tclPlatform == TCL_PLATFORM_UNIX) { - if (pathPrefix == NULL && tail[0] == '/' && tail[1] != '/') { + if (pathPrefix == NULL && tail[0] == '/') { pathPrefix = Tcl_NewStringObj(tail, 1); tail++; Tcl_IncrRefCount(pathPrefix); } } @@ -1989,11 +1973,11 @@ */ if (globFlags & TCL_GLOBMODE_TAILS) { int objc, i; Tcl_Obj **objv; - size_t prefixLen; + int prefixLen; const char *pre; /* * If this length has never been set, set it here. */ @@ -2000,11 +1984,11 @@ if (pathPrefix == NULL) { Tcl_Panic("Called TclGlob with TCL_GLOBMODE_TAILS and pathPrefix==NULL"); } - pre = TclGetStringFromObj(pathPrefix, &prefixLen); + pre = Tcl_GetStringFromObj(pathPrefix, &prefixLen); if (prefixLen > 0 && (strchr(separators, pre[prefixLen-1]) == NULL)) { /* * If we're on Windows and the prefix is a volume relative one * like 'C:', then there won't be a path separator in between, so @@ -2017,12 +2001,12 @@ } } Tcl_ListObjGetElements(NULL, filenamesObj, &objc, &objv); for (i = 0; i< objc; i++) { - size_t len; - const char *oldStr = TclGetStringFromObj(objv[i], &len); + int len; + const char *oldStr = Tcl_GetStringFromObj(objv[i], &len); Tcl_Obj *elem; if (len == prefixLen) { if ((pattern[0] == '\0') || (strchr(separators, pattern[0]) == NULL)) { @@ -2226,21 +2210,17 @@ */ closeBrace = p; break; } - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unmatched open-brace in file name", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE", - NULL); + Tcl_SetResult(interp, "unmatched open-brace in file name", + TCL_STATIC); return TCL_ERROR; } else if (*p == '}') { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unmatched close-brace in file name", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE", - NULL); + Tcl_SetResult(interp, "unmatched close-brace in file name", + TCL_STATIC); return TCL_ERROR; } } /* @@ -2349,11 +2329,11 @@ result = Tcl_ListObjGetElements(interp, subdirsPtr, &subdirc, &subdirv); for (i=0; result==TCL_OK && i 0) && (strchr(separators, joined[len-1]) == NULL)) { Tcl_AppendToObj(joinedPtr, "/", 1); } } @@ -2490,12 +2471,12 @@ * 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. */ - size_t len; - const char *joined = TclGetStringFromObj(joinedPtr,&len); + int len; + const char *joined = Tcl_GetStringFromObj(joinedPtr,&len); if ((len > 0) && (strchr(separators, joined[len-1]) == NULL)) { if (Tcl_FSGetPathType(pathPtr) != TCL_PATH_VOLUME_RELATIVE) { Tcl_AppendToObj(joinedPtr, "/", 1); } @@ -2520,11 +2501,11 @@ * 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 - * Tcl_Free(). + * ckfree(). * * Side effects: * None. * *--------------------------------------------------------------------------- @@ -2531,143 +2512,15 @@ */ Tcl_StatBuf * Tcl_AllocStatBuf(void) { - return (Tcl_StatBuf *)Tcl_Alloc(sizeof(Tcl_StatBuf)); -} - -/* - *--------------------------------------------------------------------------- - * - * Access functions for Tcl_StatBuf -- - * - * These functions provide portable read-only access to the portable - * fields of the Tcl_StatBuf structure (really a 'struct stat', 'struct - * stat64' or something else related). [TIP #316] - * - * Results: - * The value from the field being retrieved. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ - -unsigned -Tcl_GetFSDeviceFromStat( - const Tcl_StatBuf *statPtr) -{ - return statPtr->st_dev; -} - -unsigned -Tcl_GetFSInodeFromStat( - const Tcl_StatBuf *statPtr) -{ - return statPtr->st_ino; -} - -unsigned -Tcl_GetModeFromStat( - const Tcl_StatBuf *statPtr) -{ - return statPtr->st_mode; -} - -int -Tcl_GetLinkCountFromStat( - const Tcl_StatBuf *statPtr) -{ - return (int)statPtr->st_nlink; -} - -int -Tcl_GetUserIdFromStat( - const Tcl_StatBuf *statPtr) -{ - return (int) statPtr->st_uid; -} - -int -Tcl_GetGroupIdFromStat( - const Tcl_StatBuf *statPtr) -{ - return (int) statPtr->st_gid; -} - -int -Tcl_GetDeviceTypeFromStat( - const Tcl_StatBuf *statPtr) -{ - return (int) statPtr->st_rdev; -} - -Tcl_WideInt -Tcl_GetAccessTimeFromStat( - const Tcl_StatBuf *statPtr) -{ - return (Tcl_WideInt) statPtr->st_atime; -} - -Tcl_WideInt -Tcl_GetModificationTimeFromStat( - const Tcl_StatBuf *statPtr) -{ - return (Tcl_WideInt) statPtr->st_mtime; -} - -Tcl_WideInt -Tcl_GetChangeTimeFromStat( - const Tcl_StatBuf *statPtr) -{ - return (Tcl_WideInt) statPtr->st_ctime; -} - -Tcl_WideUInt -Tcl_GetSizeFromStat( - const Tcl_StatBuf *statPtr) -{ - return (Tcl_WideUInt) statPtr->st_size; -} - -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 + return (Tcl_StatBuf *)ckalloc(sizeof(Tcl_StatBuf)); +} /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclFileSystem.h ================================================================== --- generic/tclFileSystem.h +++ generic/tclFileSystem.h @@ -26,47 +26,47 @@ 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); + Tcl_Filesystem **fsPtrPtr); MODULE_SCOPE void TclFSSetPathDetails(Tcl_Obj *pathPtr, - const Tcl_Filesystem *fsPtr, void *clientData); + Tcl_Filesystem *fsPtr, ClientData clientData); MODULE_SCOPE Tcl_Obj * TclFSNormalizeAbsolutePath(Tcl_Interp *interp, Tcl_Obj *pathPtr); -MODULE_SCOPE size_t TclFSEpoch(void); +MODULE_SCOPE int TclFSEpoch(void); /* * Private shared variables for use by tclIOUtil.c and tclPathObj.c */ -MODULE_SCOPE const Tcl_Filesystem tclNativeFilesystem; +MODULE_SCOPE Tcl_Filesystem tclNativeFilesystem; /* * Private shared functions for use by tclIOUtil.c, tclPathObj.c and * tclFileName.c, and any platform-specific filesystem code. */ MODULE_SCOPE Tcl_PathType TclFSGetPathType(Tcl_Obj *pathPtr, - const Tcl_Filesystem **filesystemPtrPtr, + Tcl_Filesystem **filesystemPtrPtr, int *driveNameLengthPtr); -MODULE_SCOPE Tcl_PathType TclFSNonnativePathType(const char *pathPtr, - int pathLen, const Tcl_Filesystem **filesystemPtrPtr, +MODULE_SCOPE Tcl_PathType TclFSNonnativePathType(CONST char *pathPtr, + int pathLen, Tcl_Filesystem **filesystemPtrPtr, int *driveNameLengthPtr, Tcl_Obj **driveNameRef); MODULE_SCOPE Tcl_PathType TclGetPathType(Tcl_Obj *pathPtr, - const Tcl_Filesystem **filesystemPtrPtr, + Tcl_Filesystem **filesystemPtrPtr, int *driveNameLengthPtr, Tcl_Obj **driveNameRef); -MODULE_SCOPE int TclFSEpochOk(size_t filesystemEpoch); +MODULE_SCOPE int TclFSEpochOk(int filesystemEpoch); MODULE_SCOPE int TclFSCwdIsNative(void); MODULE_SCOPE Tcl_Obj * TclWinVolumeRelativeNormalize(Tcl_Interp *interp, - const char *path, Tcl_Obj **useThisCwdPtr); + CONST char *path, Tcl_Obj **useThisCwdPtr); MODULE_SCOPE Tcl_FSPathInFilesystemProc TclNativePathInFilesystem; MODULE_SCOPE Tcl_FSCreateInternalRepProc TclNativeCreateNativeRep; #endif /* _TCLFILESYSTEM */ - + /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 Index: generic/tclGet.c ================================================================== --- generic/tclGet.c +++ generic/tclGet.c @@ -34,11 +34,11 @@ */ int Tcl_GetInt( Tcl_Interp *interp, /* Interpreter to use for error reporting. */ - const char *src, /* String containing a (possibly signed) + CONST char *src, /* String containing a (possibly signed) * integer in a form acceptable to * Tcl_GetIntFromObj(). */ int *intPtr) /* Place to store converted result. */ { Tcl_Obj obj; @@ -51,10 +51,56 @@ code = Tcl_GetIntFromObj(interp, &obj, intPtr); if (obj.refCount > 1) { Tcl_Panic("invalid sharing of Tcl_Obj on C stack"); } + TclFreeIntRep(&obj); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetLong -- + * + * Given a string, produce the corresponding long integer value. This + * routine is a version of Tcl_GetInt but returns a "long" instead of an + * "int" (a difference that matters on 64-bit architectures). + * + * Results: + * The return value is normally TCL_OK; in this case *longPtr will be set + * to the long integer value equivalent to src. If src is improperly + * formed then TCL_ERROR is returned and an error message will be left in + * the interp's result if interp is non-NULL. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGetLong( + Tcl_Interp *interp, /* Interpreter used for error reporting if not + * NULL. */ + CONST char *src, /* String containing a (possibly signed) long + * integer in a form acceptable to + * Tcl_GetLongFromObj(). */ + long *longPtr) /* Place to store converted long result. */ +{ + Tcl_Obj obj; + int code; + + obj.refCount = 1; + obj.bytes = (char *) src; + obj.length = strlen(src); + obj.typePtr = NULL; + + code = Tcl_GetLongFromObj(interp, &obj, longPtr); + if (obj.refCount > 1) { + Tcl_Panic("invalid sharing of Tcl_Obj on C stack"); + } TclFreeIntRep(&obj); return code; } /* @@ -78,12 +124,12 @@ */ int Tcl_GetDouble( Tcl_Interp *interp, /* Interpreter used for error reporting. */ - const char *src, /* String containing a floating-point number - * in a form acceptable to + CONST char *src, /* String containing a floating-point number + * in a form acceptable to * Tcl_GetDoubleFromObj(). */ double *doublePtr) /* Place to store converted result. */ { Tcl_Obj obj; int code; @@ -122,12 +168,12 @@ */ int Tcl_GetBoolean( Tcl_Interp *interp, /* Interpreter used for error reporting. */ - const char *src, /* String containing one of the boolean values - * 1, 0, true, false, yes, no, on, off. */ + CONST char *src, /* String containing one of the boolean values + * 1, 0, true, false, yes, no, on off. */ int *boolPtr) /* Place to store converted result, which will * be 0 or 1. */ { Tcl_Obj obj; int code; @@ -135,16 +181,16 @@ obj.refCount = 1; obj.bytes = (char *) src; obj.length = strlen(src); obj.typePtr = NULL; - code = TclSetBooleanFromAny(interp, &obj); + code = Tcl_ConvertToType(interp, &obj, &tclBooleanType); if (obj.refCount > 1) { Tcl_Panic("invalid sharing of Tcl_Obj on C stack"); } if (code == TCL_OK) { - *boolPtr = obj.internalRep.wideValue != 0; + *boolPtr = obj.internalRep.longValue; } return code; } /* Index: generic/tclGetDate.y ================================================================== --- generic/tclGetDate.y +++ generic/tclGetDate.y @@ -14,11 +14,11 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ %parse-param {DateInfo* info} %lex-param {DateInfo* info} -%define api.pure +%pure-parser /* %error-verbose would be nice, but our token names are meaningless */ %locations %{ /* @@ -43,18 +43,10 @@ #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. */ @@ -69,11 +61,11 @@ int dateHaveDate; time_t dateHour; time_t dateMinutes; time_t dateSeconds; - MERIDIAN dateMeridian; + int dateMeridian; int dateHaveTime; time_t dateTimezone; int dateDSTmode; int dateHaveZone; @@ -95,12 +87,12 @@ time_t *dateRelPointer; int dateDigitCount; } DateInfo; -#define YYMALLOC Tcl_Alloc -#define YYFREE(x) (Tcl_Free((void*) (x))) +#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) @@ -156,10 +148,18 @@ typedef enum _DSTMODE { DSTon, DSToff, DSTmaybe } DSTMODE; +/* + * Meridian: am, pm, or 24-hour style. + */ + +typedef enum _MERIDIAN { + MERam, MERpm, MER24 +} MERIDIAN; + %} %union { time_t Number; enum _MERIDIAN Meridian; @@ -263,37 +263,48 @@ | tUNUMBER ':' tUNUMBER o_merid { yyHour = $1; yyMinutes = $3; yySeconds = 0; yyMeridian = $4; + } + | tUNUMBER ':' tUNUMBER '-' tUNUMBER { + yyHour = $1; + yyMinutes = $3; + yyMeridian = MER24; + yyDSTmode = DSToff; + yyTimezone = ($5 % 100 + ($5 / 100) * 60); + ++yyHaveZone; } | tUNUMBER ':' tUNUMBER ':' tUNUMBER o_merid { yyHour = $1; yyMinutes = $3; yySeconds = $5; yyMeridian = $6; } + | tUNUMBER ':' tUNUMBER ':' tUNUMBER '-' tUNUMBER { + yyHour = $1; + yyMinutes = $3; + yySeconds = $5; + yyMeridian = MER24; + yyDSTmode = DSToff; + yyTimezone = ($7 % 100 + ($7 / 100) * 60); + ++yyHaveZone; + } ; zone : tZONE tDST { yyTimezone = $1; - if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100); yyDSTmode = DSTon; } | tZONE { yyTimezone = $1; - if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100); yyDSTmode = DSToff; } | tDAYZONE { yyTimezone = $1; yyDSTmode = DSTon; } - | sign tUNUMBER { - yyTimezone = -$1*($2 % 100 + ($2 / 100) * 60); - yyDSTmode = DSToff; - } ; day : tDAY { yyDayOrdinal = 1; yyDayNumber = $1; @@ -373,31 +384,21 @@ yyMonthOrdinal = $2; yyMonth = $3; } ; -iso : tUNUMBER '-' tUNUMBER '-' tUNUMBER tZONE - tUNUMBER ':' tUNUMBER ':' tUNUMBER { - if ($6 != HOUR( 7) + HOUR(100)) YYABORT; - yyYear = $1; - yyMonth = $3; - yyDay = $5; - yyHour = $7; - yyMinutes = $9; - yySeconds = $11; - } - | tISOBASE tZONE tISOBASE { - if ($2 != HOUR( 7) + HOUR(100)) YYABORT; +iso : tISOBASE tZONE tISOBASE { + if ($2 != HOUR( 7)) YYABORT; yyYear = $1 / 10000; yyMonth = ($1 % 10000)/100; yyDay = $1 % 100; yyHour = $3 / 10000; yyMinutes = ($3 % 10000)/100; yySeconds = $3 % 100; } | tISOBASE tZONE tUNUMBER ':' tUNUMBER ':' tUNUMBER { - if ($2 != HOUR( 7) + HOUR(100)) YYABORT; + if ($2 != HOUR( 7)) YYABORT; yyYear = $1 / 10000; yyMonth = ($1 % 10000)/100; yyDay = $1 % 100; yyHour = $3; yyMinutes = $5; @@ -499,10 +500,14 @@ $$ = $1; } ; %% +MODULE_SCOPE int yychar; +MODULE_SCOPE YYSTYPE yylval; +MODULE_SCOPE int yynerrs; + /* * Month and day table. */ static const TABLE MonthDayTable[] = { @@ -528,11 +533,11 @@ { "thursday", tDAY, 4 }, { "thur", tDAY, 4 }, { "thurs", tDAY, 4 }, { "friday", tDAY, 5 }, { "saturday", tDAY, 6 }, - { NULL, 0, 0 } + { NULL } }; /* * Time units table. */ @@ -546,11 +551,11 @@ { "hour", tSEC_UNIT, 60 * 60 }, { "minute", tSEC_UNIT, 60 }, { "min", tSEC_UNIT, 60 }, { "second", tSEC_UNIT, 1 }, { "sec", tSEC_UNIT, 1 }, - { NULL, 0, 0 } + { NULL } }; /* * Assorted relative-time words. */ @@ -578,11 +583,11 @@ { "twelfth", tUNUMBER, 12 }, #endif { "ago", tAGO, 1 }, { "epoch", tEPOCH, 0 }, { "stardate", tSTARDATE, 0 }, - { NULL, 0, 0 } + { NULL } }; /* * The timezone table. (Note: This table was modified to not use any floating * point constants to work around an SGI compiler bug). @@ -664,44 +669,44 @@ { "nzdt", tDAYZONE, -HOUR(12) }, /* New Zealand Daylight */ { "idle", tZONE, -HOUR(12) }, /* International Date Line East */ /* ADDED BY Marco Nijdam */ { "dst", tDST, HOUR( 0) }, /* DST on (hour is ignored) */ /* End ADDED */ - { NULL, 0, 0 } + { NULL } }; /* * Military timezone table. */ static const TABLE MilitaryTable[] = { - { "a", tZONE, -HOUR( 1) + HOUR(100) }, - { "b", tZONE, -HOUR( 2) + HOUR(100) }, - { "c", tZONE, -HOUR( 3) + HOUR(100) }, - { "d", tZONE, -HOUR( 4) + HOUR(100) }, - { "e", tZONE, -HOUR( 5) + HOUR(100) }, - { "f", tZONE, -HOUR( 6) + HOUR(100) }, - { "g", tZONE, -HOUR( 7) + HOUR(100) }, - { "h", tZONE, -HOUR( 8) + HOUR(100) }, - { "i", tZONE, -HOUR( 9) + HOUR(100) }, - { "k", tZONE, -HOUR(10) + HOUR(100) }, - { "l", tZONE, -HOUR(11) + HOUR(100) }, - { "m", tZONE, -HOUR(12) + HOUR(100) }, - { "n", tZONE, HOUR( 1) + HOUR(100) }, - { "o", tZONE, HOUR( 2) + HOUR(100) }, - { "p", tZONE, HOUR( 3) + HOUR(100) }, - { "q", tZONE, HOUR( 4) + HOUR(100) }, - { "r", tZONE, HOUR( 5) + HOUR(100) }, - { "s", tZONE, HOUR( 6) + HOUR(100) }, - { "t", tZONE, HOUR( 7) + HOUR(100) }, - { "u", tZONE, HOUR( 8) + HOUR(100) }, - { "v", tZONE, HOUR( 9) + HOUR(100) }, - { "w", tZONE, HOUR( 10) + HOUR(100) }, - { "x", tZONE, HOUR( 11) + HOUR(100) }, - { "y", tZONE, HOUR( 12) + HOUR(100) }, - { "z", tZONE, HOUR( 0) + HOUR(100) }, - { NULL, 0, 0 } + { "a", tZONE, -HOUR( 1) }, + { "b", tZONE, -HOUR( 2) }, + { "c", tZONE, -HOUR( 3) }, + { "d", tZONE, -HOUR( 4) }, + { "e", tZONE, -HOUR( 5) }, + { "f", tZONE, -HOUR( 6) }, + { "g", tZONE, -HOUR( 7) }, + { "h", tZONE, -HOUR( 8) }, + { "i", tZONE, -HOUR( 9) }, + { "k", tZONE, -HOUR(10) }, + { "l", tZONE, -HOUR(11) }, + { "m", tZONE, -HOUR(12) }, + { "n", tZONE, HOUR( 1) }, + { "o", tZONE, HOUR( 2) }, + { "p", tZONE, HOUR( 3) }, + { "q", tZONE, HOUR( 4) }, + { "r", tZONE, HOUR( 5) }, + { "s", tZONE, HOUR( 6) }, + { "t", tZONE, HOUR( 7) }, + { "u", tZONE, HOUR( 8) }, + { "v", tZONE, HOUR( 9) }, + { "w", tZONE, HOUR( 10) }, + { "x", tZONE, HOUR( 11) }, + { "y", tZONE, HOUR( 12) }, + { "z", tZONE, HOUR( 0) }, + { NULL } }; /* * Dump error messages in the bit bucket. */ @@ -714,16 +719,16 @@ { Tcl_Obj* t; Tcl_AppendToObj(infoPtr->messages, infoPtr->separatrix, -1); Tcl_AppendToObj(infoPtr->messages, s, -1); Tcl_AppendToObj(infoPtr->messages, " (characters ", -1); - TclNewIntObj(t, location->first_column); + t = Tcl_NewIntObj(location->first_column); Tcl_IncrRefCount(t); Tcl_AppendObjToObj(infoPtr->messages, t); Tcl_DecrRefCount(t); Tcl_AppendToObj(infoPtr->messages, "-", -1); - TclNewIntObj(t, location->last_column); + t = Tcl_NewIntObj(location->last_column); Tcl_IncrRefCount(t); Tcl_AppendObjToObj(infoPtr->messages, t); Tcl_DecrRefCount(t); Tcl_AppendToObj(infoPtr->messages, ")", -1); infoPtr->separatrix = "\n"; @@ -762,13 +767,13 @@ static int LookupWord( YYSTYPE* yylvalPtr, char *buff) { - char *p; - char *q; - const TABLE *tp; + register char *p; + register char *q; + register const TABLE *tp; int i, abbrev; /* * Make it lowercase. */ @@ -887,18 +892,18 @@ TclDatelex( YYSTYPE* yylvalPtr, YYLTYPE* location, DateInfo *info) { - char c; - char *p; + register char c; + register char *p; char buff[20]; int Count; location->first_column = yyInput - info->dateStart; for ( ; ; ) { - while (TclIsSpaceProcM(*yyInput)) { + while (isspace(UCHAR(*yyInput))) { yyInput++; } if (isdigit(UCHAR(c = *yyInput))) { /* INTL: digit */ /* @@ -957,14 +962,14 @@ } } int TclClockOldscanObjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Unused */ Tcl_Interp *interp, /* Tcl interpreter */ - int objc, /* Count of paraneters */ - Tcl_Obj *const *objv) /* Parameters */ + int objc, /* Count of parameters */ + Tcl_Obj *CONST *objv) /* Parameters */ { Tcl_Obj *result, *resultElement; int yr, mo, da; DateInfo dateInfo; DateInfo* info = &dateInfo; @@ -974,11 +979,11 @@ Tcl_WrongNumArgs(interp, 1, objv, "stringToParse baseYear baseMonth baseDay" ); return TCL_ERROR; } - yyInput = TclGetString(objv[1]); + 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 @@ -1000,121 +1005,113 @@ yyDayOrdinal = 0; yyDayNumber = 0; yyHaveRel = 0; yyRelMonth = 0; yyRelDay = 0; yyRelSeconds = 0; yyRelPointer = NULL; - TclNewObj(dateInfo.messages); + dateInfo.messages = Tcl_NewObj(); dateInfo.separatrix = ""; Tcl_IncrRefCount(dateInfo.messages); status = yyparse(&dateInfo); if (status == 1) { Tcl_SetObjResult(interp, dateInfo.messages); Tcl_DecrRefCount(dateInfo.messages); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "PARSE", NULL); return TCL_ERROR; } else if (status == 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj("memory exhausted", -1)); Tcl_DecrRefCount(dateInfo.messages); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } else if (status != 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("Unknown status returned " "from date parser. Please " "report this error as a " "bug in Tcl.", -1)); Tcl_DecrRefCount(dateInfo.messages); - Tcl_SetErrorCode(interp, "TCL", "BUG", NULL); return TCL_ERROR; } Tcl_DecrRefCount(dateInfo.messages); if (yyHaveDate > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one date in string", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveTime > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one time of day in string", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveZone > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one time zone in string", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveDay > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one weekday in string", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveOrdinalMonth > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one ordinal month in string", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } - TclNewObj(result); - TclNewObj(resultElement); + result = Tcl_NewObj(); + resultElement = Tcl_NewObj(); if (yyHaveDate) { Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyYear)); + Tcl_NewIntObj((int) yyYear)); Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyMonth)); + Tcl_NewIntObj((int) yyMonth)); Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyDay)); + Tcl_NewIntObj((int) yyDay)); } Tcl_ListObjAppendElement(interp, result, resultElement); if (yyHaveTime) { - Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj( - ToSeconds(yyHour, yyMinutes, yySeconds, (MERIDIAN)yyMeridian))); + Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj((int) + ToSeconds(yyHour, yyMinutes, yySeconds, yyMeridian))); } else { Tcl_ListObjAppendElement(interp, result, Tcl_NewObj()); } - TclNewObj(resultElement); + resultElement = Tcl_NewObj(); if (yyHaveZone) { Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(-yyTimezone)); + Tcl_NewIntObj((int) -yyTimezone)); Tcl_ListObjAppendElement(interp, resultElement, Tcl_NewIntObj(1 - yyDSTmode)); } Tcl_ListObjAppendElement(interp, result, resultElement); - TclNewObj(resultElement); - if (yyHaveRel) { - Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyRelMonth)); - Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyRelDay)); - Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyRelSeconds)); - } - Tcl_ListObjAppendElement(interp, result, resultElement); - - TcNewObj(resultElement); - if (yyHaveDay && !yyHaveDate) { - Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyDayOrdinal)); - Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyDayNumber)); - } - Tcl_ListObjAppendElement(interp, result, resultElement); - - TclNewObj(resultElement); - if (yyHaveOrdinalMonth) { - Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyMonthOrdinal)); - Tcl_ListObjAppendElement(interp, resultElement, - Tcl_NewIntObj(yyMonth)); + 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; Index: generic/tclHash.c ================================================================== --- generic/tclHash.c +++ generic/tclHash.c @@ -11,10 +11,17 @@ * 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. */ @@ -26,28 +33,39 @@ * 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)*(size_t)1103515245) >> (tablePtr)->downShift) & (tablePtr)->mask) + (((((long) (i))*1103515245) >> (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); -static TCL_HASH_TYPE HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr); +static Tcl_HashEntry * AllocArrayEntry(Tcl_HashTable *tablePtr, VOID *keyPtr); +static int CompareArrayKeys(VOID *keyPtr, Tcl_HashEntry *hPtr); +static unsigned int HashArrayKey(Tcl_HashTable *tablePtr, VOID *keyPtr); + +/* + * Prototypes for the one word hash key methods. + */ + +#if 0 +static Tcl_HashEntry * AllocOneWordEntry(Tcl_HashTable *tablePtr, + VOID *keyPtr); +static int CompareOneWordKeys(VOID *keyPtr, Tcl_HashEntry *hPtr); +static unsigned int HashOneWordKey(Tcl_HashTable *tablePtr, VOID *keyPtr); +#endif /* * Prototypes for the string hash key methods. */ static Tcl_HashEntry * AllocStringEntry(Tcl_HashTable *tablePtr, - void *keyPtr); -static int CompareStringKeys(void *keyPtr, Tcl_HashEntry *hPtr); -static TCL_HASH_TYPE HashStringKey(Tcl_HashTable *tablePtr, void *keyPtr); + VOID *keyPtr); +static int CompareStringKeys(VOID *keyPtr, Tcl_HashEntry *hPtr); +static unsigned int HashStringKey(Tcl_HashTable *tablePtr, VOID *keyPtr); /* * Function prototypes for static functions in this file: */ @@ -57,29 +75,29 @@ static Tcl_HashEntry * CreateHashEntry(Tcl_HashTable *tablePtr, const char *key, int *newPtr); static Tcl_HashEntry * FindHashEntry(Tcl_HashTable *tablePtr, const char *key); static void RebuildTable(Tcl_HashTable *tablePtr); -const Tcl_HashKeyType tclArrayHashKeyType = { +Tcl_HashKeyType tclArrayHashKeyType = { TCL_HASH_KEY_TYPE_VERSION, /* version */ TCL_HASH_KEY_RANDOMIZE_HASH, /* flags */ HashArrayKey, /* hashKeyProc */ CompareArrayKeys, /* compareKeysProc */ AllocArrayEntry, /* allocEntryProc */ NULL /* freeEntryProc */ }; -const Tcl_HashKeyType tclOneWordHashKeyType = { +Tcl_HashKeyType tclOneWordHashKeyType = { TCL_HASH_KEY_TYPE_VERSION, /* version */ 0, /* flags */ NULL, /* HashOneWordKey, */ /* hashProc */ NULL, /* CompareOneWordKey, */ /* compareProc */ NULL, /* AllocOneWordKey, */ /* allocEntryProc */ NULL /* FreeOneWordKey, */ /* freeEntryProc */ }; -const Tcl_HashKeyType tclStringHashKeyType = { +Tcl_HashKeyType tclStringHashKeyType = { TCL_HASH_KEY_TYPE_VERSION, /* version */ 0, /* flags */ HashStringKey, /* hashKeyProc */ CompareStringKeys, /* compareKeysProc */ AllocStringEntry, /* allocEntryProc */ @@ -102,13 +120,14 @@ * Tcl_CreateHashEntry. * *---------------------------------------------------------------------- */ +#undef Tcl_InitHashTable void Tcl_InitHashTable( - Tcl_HashTable *tablePtr, + register 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. */ @@ -118,11 +137,11 @@ * access any of the new fields in the Tcl_HashTable. If an extension is * rebuilt then any calls to this function will be redirected to the * extended version by a macro. */ - Tcl_InitCustomHashTable(tablePtr, keyType, (const Tcl_HashKeyType *) -1); + Tcl_InitCustomHashTable(tablePtr, keyType, (Tcl_HashKeyType *) -1); } /* *---------------------------------------------------------------------- * @@ -142,18 +161,18 @@ *---------------------------------------------------------------------- */ void Tcl_InitCustomHashTable( - Tcl_HashTable *tablePtr, + register 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 + Tcl_HashKeyType *typePtr) /* Pointer to structure which defines the * behaviour of this table. */ { #if (TCL_SMALL_HASH_TABLE != 4) Tcl_Panic("Tcl_InitCustomHashTable: TCL_SMALL_HASH_TABLE is %d, not 4", TCL_SMALL_HASH_TABLE); @@ -191,11 +210,11 @@ } /* *---------------------------------------------------------------------- * - * FindHashEntry -- + * 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, @@ -204,10 +223,18 @@ * Side effects: * None. * *---------------------------------------------------------------------- */ + +Tcl_HashEntry * +Tcl_FindHashEntry( + Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */ + const char *key) /* Key to use to find matching entry. */ +{ + return (*((tablePtr)->findProc))(tablePtr, key); +} static Tcl_HashEntry * FindHashEntry( Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */ const char *key) /* Key to use to find matching entry. */ @@ -217,11 +244,11 @@ /* *---------------------------------------------------------------------- * - * CreateHashEntry -- + * 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. * @@ -234,22 +261,34 @@ * 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 char *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, 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; + register Tcl_HashEntry *hPtr; const Tcl_HashKeyType *typePtr; - size_t hash, index; + unsigned int hash; + int index; if (tablePtr->keyType == TCL_STRING_KEYS) { typePtr = &tclStringHashKeyType; } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) { typePtr = &tclOneWordHashKeyType; @@ -259,49 +298,73 @@ } else { typePtr = &tclArrayHashKeyType; } if (typePtr->hashKeyProc) { - hash = typePtr->hashKeyProc(tablePtr, (void *) key); + hash = typePtr->hashKeyProc(tablePtr, (VOID *) key); if (typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { - index = RANDOM_INDEX(tablePtr, hash); + index = RANDOM_INDEX (tablePtr, hash); } else { index = hash & tablePtr->mask; } } else { - hash = (size_t) key; - index = RANDOM_INDEX(tablePtr, hash); + 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 != 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; + if (typePtr->flags & TCL_HASH_KEY_DIRECT_COMPARE) { + for (hPtr = tablePtr->buckets[index]; hPtr != NULL; + hPtr = hPtr->nextPtr) { +#if TCL_HASH_KEY_STORE_HASH + if (hash != PTR2UINT(hPtr->hash)) { + continue; + } +#endif + /* 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 TCL_HASH_KEY_STORE_HASH + if (hash != PTR2UINT(hPtr->hash)) { + continue; + } +#endif + /* if needle pointer equals content pointer or values equal */ + if ((key == hPtr->key.string) + || compareKeysProc((VOID *) key, hPtr) + ) { + if (newPtr) { + *newPtr = 0; + } + return hPtr; + } } } } else { for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { - if (hash != hPtr->hash) { +#if TCL_HASH_KEY_STORE_HASH + if (hash != PTR2UINT(hPtr->hash)) { continue; } +#endif if (key == hPtr->key.oneWordValue) { if (newPtr) { *newPtr = 0; } return hPtr; @@ -317,21 +380,27 @@ * Entry not found. Add a new one to the bucket. */ *newPtr = 1; if (typePtr->allocEntryProc) { - hPtr = typePtr->allocEntryProc(tablePtr, (void *) key); + hPtr = typePtr->allocEntryProc(tablePtr, (VOID *) key); } else { - hPtr = (Tcl_HashEntry *)Tcl_Alloc(sizeof(Tcl_HashEntry)); + hPtr = (Tcl_HashEntry *) ckalloc((unsigned) sizeof(Tcl_HashEntry)); hPtr->key.oneWordValue = (char *) key; - Tcl_SetHashValue(hPtr, NULL); + hPtr->clientData = 0; } hPtr->tablePtr = tablePtr; - hPtr->hash = hash; +#if TCL_HASH_KEY_STORE_HASH + hPtr->hash = UINT2PTR(hash); hPtr->nextPtr = tablePtr->buckets[index]; tablePtr->buckets[index] = hPtr; +#else + hPtr->bucketPtr = &(tablePtr->buckets[index]); + hPtr->nextPtr = *hPtr->bucketPtr; + *hPtr->bucketPtr = hPtr; +#endif tablePtr->numEntries++; /* * If the table has exceeded a decent size, rebuild it with many more * buckets. @@ -363,15 +432,17 @@ void Tcl_DeleteHashEntry( Tcl_HashEntry *entryPtr) { - Tcl_HashEntry *prevPtr; + register Tcl_HashEntry *prevPtr; const Tcl_HashKeyType *typePtr; Tcl_HashTable *tablePtr; Tcl_HashEntry **bucketPtr; - size_t index; +#if TCL_HASH_KEY_STORE_HASH + int index; +#endif tablePtr = entryPtr->tablePtr; if (tablePtr->keyType == TCL_STRING_KEYS) { typePtr = &tclStringHashKeyType; @@ -382,18 +453,22 @@ typePtr = tablePtr->typePtr; } else { typePtr = &tclArrayHashKeyType; } +#if TCL_HASH_KEY_STORE_HASH if (typePtr->hashKeyProc == NULL || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { - index = RANDOM_INDEX(tablePtr, entryPtr->hash); + index = RANDOM_INDEX(tablePtr, PTR2UINT(entryPtr->hash)); } else { - index = entryPtr->hash & tablePtr->mask; + index = PTR2UINT(entryPtr->hash) & tablePtr->mask; } - bucketPtr = &tablePtr->buckets[index]; + bucketPtr = &(tablePtr->buckets[index]); +#else + bucketPtr = entryPtr->bucketPtr; +#endif if (*bucketPtr == entryPtr) { *bucketPtr = entryPtr->nextPtr; } else { for (prevPtr = *bucketPtr; ; prevPtr = prevPtr->nextPtr) { @@ -407,13 +482,13 @@ } } tablePtr->numEntries--; if (typePtr->freeEntryProc) { - typePtr->freeEntryProc(entryPtr); + typePtr->freeEntryProc (entryPtr); } else { - Tcl_Free(entryPtr); + ckfree((char *) entryPtr); } } /* *---------------------------------------------------------------------- @@ -432,15 +507,15 @@ *---------------------------------------------------------------------- */ void Tcl_DeleteHashTable( - Tcl_HashTable *tablePtr) /* Table to delete. */ + register Tcl_HashTable *tablePtr) /* Table to delete. */ { - Tcl_HashEntry *hPtr, *nextPtr; + register Tcl_HashEntry *hPtr, *nextPtr; const Tcl_HashKeyType *typePtr; - size_t i; + int i; if (tablePtr->keyType == TCL_STRING_KEYS) { typePtr = &tclStringHashKeyType; } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) { typePtr = &tclOneWordHashKeyType; @@ -458,13 +533,13 @@ for (i = 0; i < tablePtr->numBuckets; i++) { hPtr = tablePtr->buckets[i]; while (hPtr != NULL) { nextPtr = hPtr->nextPtr; if (typePtr->freeEntryProc) { - typePtr->freeEntryProc(hPtr); + typePtr->freeEntryProc (hPtr); } else { - Tcl_Free(hPtr); + ckfree((char *) hPtr); } hPtr = nextPtr; } } @@ -474,11 +549,11 @@ if (tablePtr->buckets != tablePtr->staticBuckets) { if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) { TclpSysFree((char *) tablePtr->buckets); } else { - Tcl_Free(tablePtr->buckets); + ckfree((char *) tablePtr->buckets); } } /* * Arrange for panics if the table is used again without @@ -540,11 +615,11 @@ *---------------------------------------------------------------------- */ Tcl_HashEntry * Tcl_NextHashEntry( - Tcl_HashSearch *searchPtr) + register Tcl_HashSearch *searchPtr) /* Place to store information about progress * through the table. Must have been * initialized by calling * Tcl_FirstHashEntry. */ { @@ -585,14 +660,26 @@ char * Tcl_HashStats( Tcl_HashTable *tablePtr) /* Table for which to produce stats. */ { #define NUM_COUNTERS 10 - size_t count[NUM_COUNTERS], overflow, i, j; + int count[NUM_COUNTERS], overflow, i, j; double average, tmp; - Tcl_HashEntry *hPtr; + register Tcl_HashEntry *hPtr; char *result, *p; + const Tcl_HashKeyType *typePtr; + + 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; + } /* * Compute a histogram of bucket usage. */ @@ -619,20 +706,24 @@ /* * Print out the histogram and a few other pieces of information. */ - result = (char *)Tcl_Alloc((NUM_COUNTERS * 60) + 300); - sprintf(result, "%" TCL_Z_MODIFIER "u entries in table, %" TCL_Z_MODIFIER "u buckets\n", + if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) { + result = (char *) TclpSysAlloc((unsigned) (NUM_COUNTERS*60) + 300, 0); + } else { + result = (char *) ckalloc((unsigned) (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", + 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: %" TCL_Z_MODIFIER "u\n", + 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; } @@ -654,31 +745,31 @@ */ static Tcl_HashEntry * AllocArrayEntry( Tcl_HashTable *tablePtr, /* Hash table. */ - void *keyPtr) /* Key to store in the hash table entry. */ + VOID *keyPtr) /* Key to store in the hash table entry. */ { int *array = (int *) keyPtr; - int *iPtr1, *iPtr2; + register int *iPtr1, *iPtr2; Tcl_HashEntry *hPtr; int count; - size_t size; + 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 *)Tcl_Alloc(size); + hPtr = (Tcl_HashEntry *) ckalloc(size); for (iPtr1 = array, iPtr2 = hPtr->key.words; count > 0; count--, iPtr1++, iPtr2++) { *iPtr2 = *iPtr1; } - Tcl_SetHashValue(hPtr, NULL); + hPtr->clientData = 0; return hPtr; } /* @@ -698,15 +789,15 @@ *---------------------------------------------------------------------- */ static int CompareArrayKeys( - void *keyPtr, /* New key to compare. */ + VOID *keyPtr, /* New key to compare. */ Tcl_HashEntry *hPtr) /* Existing key to compare. */ { - const int *iPtr1 = (const int *)keyPtr; - const int *iPtr2 = hPtr->key.words; + register const int *iPtr1 = (const int *) keyPtr; + register 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) { @@ -735,17 +826,17 @@ * None. * *---------------------------------------------------------------------- */ -static TCL_HASH_TYPE +static unsigned int HashArrayKey( Tcl_HashTable *tablePtr, /* Hash table. */ - void *keyPtr) /* Key from which to compute hash value. */ + VOID *keyPtr) /* Key from which to compute hash value. */ { - const int *array = (const int *) keyPtr; - TCL_HASH_TYPE result; + register const int *array = (const int *) keyPtr; + register unsigned int result; int count; for (result = 0, count = tablePtr->keyType; count > 0; count--, array++) { result += *array; @@ -769,25 +860,25 @@ *---------------------------------------------------------------------- */ static Tcl_HashEntry * AllocStringEntry( - TCL_UNUSED(Tcl_HashTable *), - void *keyPtr) /* Key to store in the hash table entry. */ + Tcl_HashTable *tablePtr, /* Hash table. */ + VOID *keyPtr) /* Key to store in the hash table entry. */ { const char *string = (const char *) keyPtr; Tcl_HashEntry *hPtr; - size_t size, allocsize; + unsigned int size, allocsize; allocsize = size = strlen(string) + 1; if (size < sizeof(hPtr->key)) { allocsize = sizeof(hPtr->key); } - hPtr = (Tcl_HashEntry *)Tcl_Alloc(offsetof(Tcl_HashEntry, key) + allocsize); + hPtr = (Tcl_HashEntry *) ckalloc(sizeof(Tcl_HashEntry) + allocsize - sizeof(hPtr->key)); memset(hPtr, 0, sizeof(Tcl_HashEntry) + allocsize - sizeof(hPtr->key)); memcpy(hPtr->key.string, string, size); - Tcl_SetHashValue(hPtr, NULL); + hPtr->clientData = 0; return hPtr; } /* *---------------------------------------------------------------------- @@ -806,14 +897,17 @@ *---------------------------------------------------------------------- */ static int CompareStringKeys( - void *keyPtr, /* New key to compare. */ + VOID *keyPtr, /* New key to compare. */ Tcl_HashEntry *hPtr) /* Existing key to compare. */ { - return !strcmp((char *)keyPtr, hPtr->key.string); + register const char *p1 = (const char *) keyPtr; + register const char *p2 = (const char *) hPtr->key.string; + + return !strcmp(p1, p2); } /* *---------------------------------------------------------------------- * @@ -829,65 +923,50 @@ * 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; +static unsigned int +HashStringKey( + Tcl_HashTable *tablePtr, /* Hash table. */ + VOID *keyPtr) /* Key from which to compute hash value. */ +{ + register const char *string = (const char *) keyPtr; + register unsigned int result; + register int 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: * * 1. Multiplying by 10 is perfect for keys that are decimal strings, and - * multiplying by 9 is just about as good. + * multiplying by 9 is just about as good. * 2. Times-9 is (shift-left-3) plus (old). This means that each - * character's bits hang around in the low-order bits of the hash value - * for ever, plus they spread fairly rapidly up to the high-order bits - * to fill out the hash value. This seems works well both for decimal - * and non-decimal strings, but isn't strong against maliciously-chosen - * keys. - * - * Note that this function is very weak against malicious strings; it's - * very easy to generate multiple keys that have the same hashcode. On the - * other hand, that hardly ever actually occurs and this function *is* - * very cheap, even by comparison with industry-standard hashes like FNV. - * If real strength of hash is required though, use a custom hash based on - * Bob Jenkins's lookup3(), but be aware that it's significantly slower. - * Since Tcl command and namespace names are usually reasonably-named (the - * main use for string hashes in modern Tcl) speed is far more important - * than strength. - * - * See also HashString in tclLiteral.c. - * See also TclObjHashKey in tclObj.c. - * - * See [tcl-Feature Request #2958832] + * character's bits hang around in the low-order bits of the hash value + * for ever, plus they spread fairly rapidly up to the high-order bits + * to fill out the hash value. This seems works well both for decimal + * and non-decimal strings, but isn't strong against maliciously-chosen + * keys. */ - if ((result = UCHAR(*string)) != 0) { - while ((c = *++string) != 0) { - result += (result << 3) + UCHAR(c); - } + result = 0; + + for (c=*string++ ; c ; c=*string++) { + result += (result<<3) + c; } return result; } /* *---------------------------------------------------------------------- * * BogusFind -- * - * This function is invoked when Tcl_FindHashEntry is called on a + * This function is invoked when an Tcl_FindHashEntry is called on a * table that has been deleted. * * Results: * If Tcl_Panic returns (which it shouldn't) this function returns NULL. * @@ -895,14 +974,15 @@ * Generates a panic. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ static Tcl_HashEntry * BogusFind( - TCL_UNUSED(Tcl_HashTable *), - TCL_UNUSED(const char *)) + Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */ + const char *key) /* Key to use to find matching entry. */ { Tcl_Panic("called %s on deleted table", "Tcl_FindHashEntry"); return NULL; } @@ -909,11 +989,11 @@ /* *---------------------------------------------------------------------- * * BogusCreate -- * - * This function is invoked when Tcl_CreateHashEntry is called on a + * This function is invoked when an Tcl_CreateHashEntry is called on a * table that has been deleted. * * Results: * If panic returns (which it shouldn't) this function returns NULL. * @@ -921,15 +1001,18 @@ * Generates a panic. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ static Tcl_HashEntry * BogusCreate( - TCL_UNUSED(Tcl_HashTable *), - TCL_UNUSED(const char *), - TCL_UNUSED(int *)) + 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_Panic("called %s on deleted table", "Tcl_CreateHashEntry"); return NULL; } @@ -951,20 +1034,20 @@ *---------------------------------------------------------------------- */ static void RebuildTable( - Tcl_HashTable *tablePtr) /* Table to enlarge. */ + register Tcl_HashTable *tablePtr) /* Table to enlarge. */ { - size_t count, index, oldSize = tablePtr->numBuckets; + int count, index, oldSize = tablePtr->numBuckets; Tcl_HashEntry **oldBuckets = tablePtr->buckets; - Tcl_HashEntry **oldChainPtr, **newChainPtr; - Tcl_HashEntry *hPtr; + register Tcl_HashEntry **oldChainPtr, **newChainPtr; + register Tcl_HashEntry *hPtr; const Tcl_HashKeyType *typePtr; /* Avoid outgrowing capability of the memory allocators */ - if (oldSize > UINT_MAX / (4 * sizeof(Tcl_HashEntry *))) { + if (oldSize > (int)(UINT_MAX / (4 * sizeof(Tcl_HashEntry *)))) { tablePtr->rebuildSize = INT_MAX; return; } if (tablePtr->keyType == TCL_STRING_KEYS) { @@ -983,41 +1066,60 @@ * 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 *)); + tablePtr->buckets = (Tcl_HashEntry **) TclpSysAlloc((unsigned) + (tablePtr->numBuckets * sizeof(Tcl_HashEntry *)), 0); } else { - tablePtr->buckets = - (Tcl_HashEntry **)Tcl_Alloc(tablePtr->numBuckets * sizeof(Tcl_HashEntry *)); + tablePtr->buckets = (Tcl_HashEntry **) ckalloc((unsigned) + (tablePtr->numBuckets * sizeof(Tcl_HashEntry *))); } for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets; count > 0; count--, newChainPtr++) { *newChainPtr = NULL; } tablePtr->rebuildSize *= 4; - if (tablePtr->downShift > 1) { - tablePtr->downShift -= 2; - } + 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 TCL_HASH_KEY_STORE_HASH if (typePtr->hashKeyProc == NULL || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { - index = RANDOM_INDEX(tablePtr, hPtr->hash); + index = RANDOM_INDEX (tablePtr, PTR2UINT(hPtr->hash)); } else { - index = hPtr->hash & tablePtr->mask; + index = PTR2UINT(hPtr->hash) & tablePtr->mask; } hPtr->nextPtr = tablePtr->buckets[index]; tablePtr->buckets[index] = hPtr; +#else + VOID *key = (VOID *) Tcl_GetHashKey(tablePtr, hPtr); + + if (typePtr->hashKeyProc) { + unsigned int hash; + + hash = typePtr->hashKeyProc(tablePtr, key); + if (typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { + index = RANDOM_INDEX (tablePtr, hash); + } else { + index = hash & tablePtr->mask; + } + } else { + index = RANDOM_INDEX (tablePtr, key); + } + + hPtr->bucketPtr = &(tablePtr->buckets[index]); + hPtr->nextPtr = *hPtr->bucketPtr; + *hPtr->bucketPtr = hPtr; +#endif } } /* * Free up the old bucket array, if it was dynamically allocated. @@ -1025,11 +1127,11 @@ if (oldBuckets != tablePtr->staticBuckets) { if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) { TclpSysFree((char *) oldBuckets); } else { - Tcl_Free(oldBuckets); + ckfree((char *) oldBuckets); } } } /* Index: generic/tclHistory.c ================================================================== --- generic/tclHistory.c +++ generic/tclHistory.c @@ -12,28 +12,10 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" - -/* - * Type of the assocData structure used to hold the reference to the [history - * add] subcommand, used in Tcl_RecordAndEvalObj. - */ - -typedef struct { - Tcl_Obj *historyObj; /* == "::history" */ - Tcl_Obj *addObj; /* == "add" */ -} HistoryObjs; - -#define HISTORY_OBJS_KEY "::tcl::HistoryObjs" - -/* - * Static functions in this file. - */ - -static Tcl_InterpDeleteProc DeleteHistoryObjs; /* *---------------------------------------------------------------------- * * Tcl_RecordAndEval -- @@ -53,28 +35,36 @@ int Tcl_RecordAndEval( Tcl_Interp *interp, /* Token for interpreter in which command will * be executed. */ - const char *cmd, /* Command to record. */ + 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; + register Tcl_Obj *cmdPtr; + int length = strlen(cmd); int result; - if (cmd[0]) { + if (length > 0) { /* * Call Tcl_RecordAndEvalObj to do the actual work. */ - cmdPtr = Tcl_NewStringObj(cmd, -1); + cmdPtr = Tcl_NewStringObj(cmd, length); 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); @@ -119,52 +109,39 @@ * TCL_EVAL_GLOBAL means evaluate the script * in global variable context instead of the * current procedure. */ { int result, call = 1; + Tcl_Obj *list[3]; + register Tcl_Obj *objPtr; 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 *)Tcl_Alloc(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); - } /* * Do not call [history] if it has been replaced by an empty proc */ - result = Tcl_GetCommandInfo(interp, "::history", &info); - if (result && (info.deleteProc == TclProcDeleteProc)) { - Proc *procPtr = (Proc *) info.objClientData; + result = Tcl_GetCommandInfo(interp, "history", &info); + + if (result && (info.objProc == TclObjInterpProc)) { + Proc *procPtr = (Proc *)(info.objClientData); call = (procPtr->cmdPtr->compileProc != TclCompileNoOp); } if (call) { - Tcl_Obj *list[3]; /* * Do recording by eval'ing a tcl history command: history add $cmd. */ - list[0] = histObjsPtr->historyObj; - list[1] = histObjsPtr->addObj; + TclNewLiteralStringObj(list[0], "history"); + TclNewLiteralStringObj(list[1], "add"); list[2] = cmdPtr; - Tcl_IncrRefCount(cmdPtr); - (void) Tcl_EvalObjv(interp, 3, list, TCL_EVAL_GLOBAL); - Tcl_DecrRefCount(cmdPtr); + objPtr = Tcl_NewListObj(3, list); + Tcl_IncrRefCount(objPtr); + (void) Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL); + Tcl_DecrRefCount(objPtr); /* * One possible failure mode above: exceeding a resource limit. */ @@ -181,42 +158,13 @@ if (!(flags & TCL_NO_EVAL)) { result = Tcl_EvalObjEx(interp, cmdPtr, flags & TCL_EVAL_GLOBAL); } return result; } - -/* - *---------------------------------------------------------------------- - * - * DeleteHistoryObjs -- - * - * Called to delete the references to the constant words used when adding - * to the history. - * - * Results: - * None. - * - * Side effects: - * The constant words may be deleted. - * - *---------------------------------------------------------------------- - */ - -static void -DeleteHistoryObjs( - ClientData clientData, - TCL_UNUSED(Tcl_Interp *)) -{ - HistoryObjs *histObjsPtr = (HistoryObjs *)clientData; - - TclDecrRefCount(histObjsPtr->historyObj); - TclDecrRefCount(histObjsPtr->addObj); - Tcl_Free(histObjsPtr); -} /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclIO.c ================================================================== --- generic/tclIO.c +++ generic/tclIO.c @@ -33,19 +33,19 @@ /* Next one in list of registered handlers. */ } ChannelHandler; /* * This structure keeps track of the current ChannelHandler being invoked in - * the current invocation of Tcl_NotifyChannel. There is a potential + * the current invocation of ChannelHandlerEventProc. There is a potential * problem if a ChannelHandler is deleted while it is the current one, since - * Tcl_NotifyChannel needs to look at the nextPtr field. To handle this + * ChannelHandlerEventProc needs to look at the nextPtr field. To handle this * problem, structures of the type below indicate the next handler to be * processed for any (recursively nested) dispatches in progress. The * nextHandlerPtr field is updated if the handler being pointed to is deleted. - * The nestedHandlerPtr field is used to chain together all recursive - * invocations, so that Tcl_DeleteChannelHandler can find all the recursively - * nested invocations of Tcl_NotifyChannel and compare the handler being + * The nextPtr field is used to chain together all recursive invocations, so + * that Tcl_DeleteChannelHandler can find all the recursively nested + * invocations of ChannelHandlerEventProc and compare the handler being * deleted against the NEXT handler to be invoked in that invocation; when it * finds such a situation, Tcl_DeleteChannelHandler updates the nextHandlerPtr * field of the structure to the next handler. */ @@ -52,13 +52,24 @@ typedef struct NextChannelHandler { ChannelHandler *nextHandlerPtr; /* The next handler to be invoked in * this invocation. */ struct NextChannelHandler *nestedHandlerPtr; /* Next nested invocation of - * Tcl_NotifyChannel. */ + * ChannelHandlerEventProc. */ } NextChannelHandler; +/* + * The following structure describes the event that is added to the Tcl + * event queue by the channel handler check procedure. + */ + +typedef struct ChannelHandlerEvent { + Tcl_Event header; /* Standard header for all events. */ + Channel *chanPtr; /* The channel that is ready. */ + int readyMask; /* Events that have occurred. */ +} ChannelHandlerEvent; + /* * The following structure is used by Tcl_GetsObj() to encapsulates the * state for a "gets" operation. */ @@ -96,11 +107,11 @@ typedef struct CopyState { struct Channel *readPtr; /* Pointer to input channel. */ struct Channel *writePtr; /* Pointer to output channel. */ int readFlags; /* Original read channel flags. */ int writeFlags; /* Original write channel flags. */ - Tcl_WideInt toRead; /* Number of bytes to copy, or -1. */ + int toRead; /* Number of bytes to copy, or -1. */ Tcl_WideInt total; /* Total bytes transferred (written). */ Tcl_Interp *interp; /* Interp that started the copy. */ Tcl_Obj *cmdPtr; /* Command to be invoked at completion. */ int bufSize; /* Size of appended buffer. */ char buffer[1]; /* Copy buffer, this must be the last @@ -114,14 +125,14 @@ * * Notice that different structures with the same name appear in other files. * The structure defined below is used in this file only. */ -typedef struct { +typedef struct ThreadSpecificData { NextChannelHandler *nestedHandlerPtr; /* This variable holds the list of nested - * Tcl_NotifyChannel invocations. */ + * ChannelHandlerEventProc invocations. */ ChannelState *firstCSPtr; /* List of all channels currently open, * indexed by ChannelState, as only one * ChannelState exists per set of stacked * channels. */ Tcl_Channel stdinChannel; /* Static variable for the stdin channel. */ @@ -165,23 +176,12 @@ static void CheckForStdChannelsBeingClosed(Tcl_Channel chan); static void CleanupChannelHandlers(Tcl_Interp *interp, Channel *chanPtr); static int CloseChannel(Tcl_Interp *interp, Channel *chanPtr, int errorCode); -static int CloseChannelPart(Tcl_Interp *interp, Channel *chanPtr, - int errorCode, int flags); -static int CloseWrite(Tcl_Interp *interp, Channel *chanPtr); static void CommonGetsCleanup(Channel *chanPtr); static int CopyData(CopyState *csPtr, int mask); -static int MoveBytes(CopyState *csPtr); - -static void MBCallback(CopyState *csPtr, Tcl_Obj *errObj); -static void MBError(CopyState *csPtr, int mask, int errorCode); -static int MBRead(CopyState *csPtr); -static int MBWrite(CopyState *csPtr); -static void MBEvent(ClientData clientData, int mask); - static void CopyEventProc(ClientData clientData, int mask); static void CreateScriptRecord(Tcl_Interp *interp, Channel *chanPtr, int mask, Tcl_Obj *scriptPtr); static void DeleteChannelTable(ClientData clientData, Tcl_Interp *interp); @@ -189,23 +189,24 @@ 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, size_t bytesToRead, - int allowShortReads); -static int DoReadChars(Channel *chan, Tcl_Obj *objPtr, size_t toRead, +static int DoRead(Channel *chanPtr, char *dst, int bytesToRead); +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_Encoding GetBinaryEncoding(); +static void FreeBinaryEncoding(ClientData clientData); static Tcl_HashTable * GetChannelTable(Tcl_Interp *interp); static int GetInput(Channel *chanPtr); +static int HaveVersion(const Tcl_ChannelType *typePtr, + Tcl_ChannelTypeVersion minimumVersion); 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, @@ -222,11 +223,11 @@ static int Write(Channel *chanPtr, const char *src, int srcLen, Tcl_Encoding encoding); static Tcl_Obj * FixLevelCode(Tcl_Obj *msg); static void SpliceChannel(Tcl_Channel chan); static void CutChannel(Tcl_Channel chan); -static int WillRead(Channel *chanPtr); +static int WillRead(Channel *chanPtr); #define WriteChars(chanPtr, src, srcLen) \ Write(chanPtr, src, srcLen, chanPtr->state->encoding) #define WriteBytes(chanPtr, src, srcLen) \ Write(chanPtr, src, srcLen, tclIdentityEncoding) @@ -235,11 +236,11 @@ * 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. * * -------------------------------------------------------------------------- - * size_t BytesLeft(ChannelBuffer *bufPtr) + * int BytesLeft(ChannelBuffer *bufPtr) * * Returns the number of bytes of data remaining in the buffer. * * int SpaceLeft(ChannelBuffer *bufPtr) * @@ -273,25 +274,25 @@ * Returns a pointer to where characters should be removed from the * buffer. * -------------------------------------------------------------------------- */ -#define BytesLeft(bufPtr) ((size_t)((bufPtr)->nextAdded - (bufPtr)->nextRemoved)) - -#define SpaceLeft(bufPtr) ((size_t)((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) - -#define IsBufferOverflowing(bufPtr) ((bufPtr)->nextAdded>(bufPtr)->bufLength) - -#define InsertPoint(bufPtr) (&(bufPtr)->buf[(bufPtr)->nextAdded]) - -#define RemovePoint(bufPtr) (&(bufPtr)->buf[(bufPtr)->nextRemoved]) +#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) + +#define IsBufferOverflowing(bufPtr) ((bufPtr)->nextAdded > (bufPtr)->bufLength) + +#define InsertPoint(bufPtr) ((bufPtr)->buf + (bufPtr)->nextAdded) + +#define RemovePoint(bufPtr) ((bufPtr)->buf + (bufPtr)->nextRemoved) /* * For working with channel state flag bits. */ @@ -317,87 +318,51 @@ */ typedef struct ResolvedChanName { ChannelState *statePtr; /* The saved lookup result */ Tcl_Interp *interp; /* The interp in which the lookup was done. */ - size_t epoch; /* The epoch of the channel when the lookup + int epoch; /* The epoch of the channel when the lookup * was done. Use to verify validity. */ - size_t refCount; /* Share this struct among many Tcl_Obj. */ + int refCount; /* Share this struct among many Tcl_Obj. */ } ResolvedChanName; static void DupChannelIntRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void FreeChannelIntRep(Tcl_Obj *objPtr); -static const Tcl_ObjType chanObjType = { +static Tcl_ObjType chanObjType = { "channel", /* name for this type */ FreeChannelIntRep, /* freeIntRepProc */ DupChannelIntRep, /* dupIntRepProc */ NULL, /* updateStringProc */ NULL /* setFromAnyProc */ }; -#define ChanSetIntRep(objPtr, resPtr) \ - do { \ - Tcl_ObjIntRep ir; \ - (resPtr)->refCount++; \ - ir.twoPtrValue.ptr1 = (resPtr); \ - ir.twoPtrValue.ptr2 = NULL; \ - 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) \ +#define BUSY_STATE(st,fl) \ ((((st)->csPtrR) && ((fl) & TCL_READABLE)) || \ (((st)->csPtrW) && ((fl) & TCL_WRITABLE))) #define MAX_CHANNEL_BUFFER_SIZE (1024*1024) /* *--------------------------------------------------------------------------- * - * ChanClose, ChanRead, ChanSeek, ChanThreadAction, ChanWatch, ChanWrite -- - * - * Simplify the access to selected channel driver "methods" that are used - * in multiple places in a stereotypical fashion. These are just thin - * wrappers around the driver functions. - * - *--------------------------------------------------------------------------- - */ - -static inline int -ChanClose( - Channel *chanPtr, - Tcl_Interp *interp) -{ - return chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, 0); -} - -/* - *--------------------------------------------------------------------------- - * * ChanRead -- * - * Read up to dstSize bytes using the inputProc of chanPtr, store them at - * dst, and return the number of bytes stored. + * Read up to dstSize bytes using the inputProc of chanPtr, store + * them at dst, and return the number of bytes stored. * * Results: * The return value of the driver inputProc, * - number of bytes stored at dst, ot - * - -1 on error, with a Posix error code available to the caller by - * calling Tcl_GetErrno(). + * - -1 on error, with a Posix error code available to the + * caller by calling Tcl_GetErrno(). * * Side effects: - * The CHANNEL_BLOCKED and CHANNEL_EOF flags of the channel state are set - * as appropriate. On EOF, the inputEncodingFlags are set to perform - * ending operations on decoding. - * + * The CHANNEL_BLOCKED and CHANNEL_EOF flags of the channel state are + * set as appropriate. + * On EOF, the inputEncodingFlags are set to perform ending operations + * on decoding. * TODO - Is this really the right place for that? * *--------------------------------------------------------------------------- */ static int @@ -407,62 +372,57 @@ int dstSize) { int bytesRead, result; /* - * If the caller asked for zero bytes, we'd force the inputProc to return - * zero bytes, and then misinterpret that as EOF. + * If the caller asked for zero bytes, we'd force the inputProc + * to return zero bytes, and then misinterpret that as EOF. */ - assert(dstSize > 0); /* * Each read op must set the blocked and eof states anew, not let * the effect of prior reads leak through. */ - if (GotFlag(chanPtr->state, CHANNEL_EOF)) { chanPtr->state->inputEncodingFlags |= TCL_ENCODING_START; } ResetFlag(chanPtr->state, CHANNEL_BLOCKED | CHANNEL_EOF); chanPtr->state->inputEncodingFlags &= ~TCL_ENCODING_END; - if (WillRead(chanPtr) == -1) { + if (WillRead(chanPtr) < 0) { return -1; } bytesRead = chanPtr->typePtr->inputProc(chanPtr->instanceData, dst, dstSize, &result); - /* - * Stop any flag leakage through stacked channel levels. - */ - + /* Stop any flag leakage through stacked channel levels */ if (GotFlag(chanPtr->state, CHANNEL_EOF)) { chanPtr->state->inputEncodingFlags |= TCL_ENCODING_START; } ResetFlag(chanPtr->state, CHANNEL_BLOCKED | CHANNEL_EOF); chanPtr->state->inputEncodingFlags &= ~TCL_ENCODING_END; - if (bytesRead == -1) { - if ((result == EWOULDBLOCK) || (result == EAGAIN)) { - SetFlag(chanPtr->state, CHANNEL_BLOCKED); - result = EAGAIN; - } - Tcl_SetErrno(result); - } else if (bytesRead == 0) { - SetFlag(chanPtr->state, CHANNEL_EOF); - chanPtr->state->inputEncodingFlags |= TCL_ENCODING_END; - } else { + 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 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 @@ -475,50 +435,25 @@ /* * Note that we prefer the wideSeekProc if that field is available in the * type and non-NULL. */ - if (Tcl_ChannelWideSeekProc(chanPtr->typePtr) == NULL) { - *errnoPtr = EINVAL; - return -1; - } - - return Tcl_ChannelWideSeekProc(chanPtr->typePtr)(chanPtr->instanceData, + if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) && + chanPtr->typePtr->wideSeekProc != NULL) { + return chanPtr->typePtr->wideSeekProc(chanPtr->instanceData, offset, mode, errnoPtr); -} - -static inline void -ChanThreadAction( - Channel *chanPtr, - int action) -{ - Tcl_DriverThreadActionProc *threadActionProc = - Tcl_ChannelThreadActionProc(chanPtr->typePtr); - - if (threadActionProc != NULL) { - threadActionProc(chanPtr->instanceData, action); - } -} - -static inline void -ChanWatch( - Channel *chanPtr, - int mask) -{ - chanPtr->typePtr->watchProc(chanPtr->instanceData, mask); -} - -static inline int -ChanWrite( - Channel *chanPtr, - const char *src, - int srcLen, - int *errnoPtr) -{ - return chanPtr->typePtr->outputProc(chanPtr->instanceData, src, srcLen, - errnoPtr); -} + } + + if (offsetTcl_LongAsWide(LONG_MAX)) { + *errnoPtr = EOVERFLOW; + return Tcl_LongAsWide(-1); + } + + return Tcl_LongAsWide(chanPtr->typePtr->seekProc(chanPtr->instanceData, + Tcl_WideAsLong(offset), mode, errnoPtr)); +} + /* *--------------------------------------------------------------------------- * * TclInitIOSubsystem -- @@ -562,33 +497,18 @@ * Depends on encoding and memory subsystems. * *------------------------------------------------------------------------- */ + /* ARGSUSED */ 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 */ - int doflushnb; - - /* - * Fetch the pre-TIP#398 compatibility flag. - */ - - { - const char *s; - Tcl_DString ds; - - s = TclGetEnv("TCL_FLUSH_NONBLOCKING_ON_EXIT", &ds); - doflushnb = ((s != NULL) && strcmp(s, "0")); - if (s != NULL) { - Tcl_DStringFree(&ds); - } - } /* * Walk all channel state structures known to this thread and close * corresponding channels. */ @@ -603,44 +523,30 @@ active = 0; for (statePtr = tsdPtr->firstCSPtr; statePtr != NULL; statePtr = statePtr->nextCSPtr) { chanPtr = statePtr->topChanPtr; - if (GotFlag(statePtr, CHANNEL_DEAD)) { - continue; - } - if (!GotFlag(statePtr, CHANNEL_INCLOSE | CHANNEL_CLOSED ) - || GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { - ResetFlag(statePtr, BG_FLUSH_SCHEDULED); + if (!GotFlag(statePtr, CHANNEL_INCLOSE|CHANNEL_CLOSED|CHANNEL_DEAD)) { active = 1; break; } } /* - * We've found a live (or bg-closing) channel. Close it. + * We've found a live channel. Close it. */ if (active) { + /* + * Set the channel back into blocking mode to ensure that we wait + * for all data to flush out. + */ + TclChannelPreserve((Tcl_Channel)chanPtr); - /* - * TIP #398: by default, we no longer set the channel back into - * blocking mode. To restore the old blocking behavior, the - * environment variable TCL_FLUSH_NONBLOCKING_ON_EXIT must be set - * and not be "0". - */ - - if (doflushnb) { - /* - * Set the channel back into blocking mode to ensure that we - * wait for all data to flush out. - */ - - (void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr, - "-blocking", "on"); - } + (void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr, + "-blocking", "on"); if ((chanPtr == (Channel *) tsdPtr->stdinChannel) || (chanPtr == (Channel *) tsdPtr->stdoutChannel) || (chanPtr == (Channel *) tsdPtr->stderrChannel)) { /* @@ -649,18 +555,18 @@ */ statePtr->refCount--; } - if (statePtr->refCount + 1 <= 1) { + 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_CloseEx(NULL, (Tcl_Channel) chanPtr, 0); + (void) Tcl_Close(NULL, (Tcl_Channel) chanPtr); } else { /* * The refcount is greater than zero, so flush the channel. */ @@ -669,11 +575,16 @@ /* * Call the device driver to actually close the underlying * device for this channel. */ - (void) ChanClose(chanPtr, NULL); + if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) { + (chanPtr->typePtr->closeProc)(chanPtr->instanceData, NULL); + } else { + (chanPtr->typePtr->close2Proc)(chanPtr->instanceData, + NULL, 0); + } /* * Finally, we clean up the fields in the channel data * structure since all of them have been deleted already. We * mark the channel with CHANNEL_DEAD to prevent any further @@ -836,11 +747,11 @@ * callback. */ { ChannelState *statePtr = ((Channel *) chan)->state; CloseCallback *cbPtr; - cbPtr = (CloseCallback *)Tcl_Alloc(sizeof(CloseCallback)); + cbPtr = (CloseCallback *) ckalloc(sizeof(CloseCallback)); cbPtr->proc = proc; cbPtr->clientData = clientData; cbPtr->nextPtr = statePtr->closeCbPtr; statePtr->closeCbPtr = cbPtr; @@ -882,14 +793,15 @@ if (cbPrevPtr == NULL) { statePtr->closeCbPtr = cbPtr->nextPtr; } else { cbPrevPtr->nextPtr = cbPtr->nextPtr; } - Tcl_Free(cbPtr); + ckfree((char *) cbPtr); break; + } else { + cbPrevPtr = cbPtr; } - cbPrevPtr = cbPtr; } } /* *---------------------------------------------------------------------- @@ -915,13 +827,13 @@ Tcl_Interp *interp) { Tcl_HashTable *hTblPtr; /* Hash table of channels. */ Tcl_Channel stdinChan, stdoutChan, stderrChan; - hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclIO", NULL); + hTblPtr = Tcl_GetAssocData(interp, "tclIO", NULL); if (hTblPtr == NULL) { - hTblPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); + hTblPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS); Tcl_SetAssocData(interp, "tclIO", (Tcl_InterpDeleteProc *) DeleteChannelTable, hTblPtr); /* @@ -985,14 +897,14 @@ /* * Delete all the registered channels - this will close channels whose * refcount reaches zero. */ - hTblPtr = (Tcl_HashTable *)clientData; + hTblPtr = clientData; for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); hPtr != NULL; hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch)) { - chanPtr = (Channel *)Tcl_GetHashValue(hPtr); + chanPtr = Tcl_GetHashValue(hPtr); statePtr = chanPtr->state; /* * Remove any fileevents registered in this interpreter. */ @@ -1006,14 +918,14 @@ } else { prevPtr->nextPtr = nextPtr; } Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, - TclChannelEventScriptInvoker, sPtr); + TclChannelEventScriptInvoker, (ClientData) sPtr); TclDecrRefCount(sPtr->scriptPtr); - Tcl_Free(sPtr); + ckfree((char *) sPtr); } else { prevPtr = sPtr; } } @@ -1024,19 +936,20 @@ * the behavior of Tcl_UnregisterChannel directly here. */ Tcl_DeleteHashEntry(hPtr); statePtr->epoch++; - if (statePtr->refCount-- <= 1) { + statePtr->refCount--; + if (statePtr->refCount <= 0) { if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { - (void) Tcl_CloseEx(interp, (Tcl_Channel) chanPtr, 0); + (void) Tcl_Close(interp, (Tcl_Channel) chanPtr); } } } Tcl_DeleteHashTable(hTblPtr); - Tcl_Free(hTblPtr); + ckfree((char *) hTblPtr); } /* *---------------------------------------------------------------------- * @@ -1067,27 +980,27 @@ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->stdinInitialized == 1 && tsdPtr->stdinChannel != NULL && statePtr == ((Channel *)tsdPtr->stdinChannel)->state) { - if (statePtr->refCount + 1 < 3) { + 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 + 1 < 3) { + 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 + 1 < 3) { + if (statePtr->refCount < 2) { statePtr->refCount = 0; tsdPtr->stderrChannel = NULL; return; } } @@ -1218,13 +1131,12 @@ statePtr = ((Channel *) chan)->state->bottomChanPtr->state; if (GotFlag(statePtr, CHANNEL_INCLOSE)) { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "illegal recursive call to close through close-handler" - " of channel", -1)); + Tcl_AppendResult(interp, "Illegal recursive call to close " + "through close-handler of channel", NULL); } return TCL_ERROR; } if (DetachChannel(interp, chan) != TCL_OK) { @@ -1245,27 +1157,27 @@ /* * If the refCount reached zero, close the actual channel. */ - if (statePtr->refCount + 1 <= 1) { - Tcl_Preserve(statePtr); + if (statePtr->refCount <= 0) { + Tcl_Preserve((ClientData)statePtr); if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { /* - * We don't want to re-enter Tcl_CloseEx(). + * We don't want to re-enter Tcl_Close(). */ if (!GotFlag(statePtr, CHANNEL_CLOSED)) { - if (Tcl_CloseEx(interp, chan, 0) != TCL_OK) { + if (Tcl_Close(interp, chan) != TCL_OK) { SetFlag(statePtr, CHANNEL_CLOSED); - Tcl_Release(statePtr); + Tcl_Release((ClientData)statePtr); return TCL_ERROR; } } } SetFlag(statePtr, CHANNEL_CLOSED); - Tcl_Release(statePtr); + Tcl_Release((ClientData)statePtr); } return TCL_OK; } /* @@ -1355,11 +1267,11 @@ chanPtr = ((Channel *) chan)->state->bottomChanPtr; statePtr = chanPtr->state; if (interp != NULL) { - hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclIO", NULL); + hTblPtr = Tcl_GetAssocData(interp, "tclIO", NULL); if (hTblPtr == NULL) { return TCL_ERROR; } hPtr = Tcl_FindHashEntry(hTblPtr, statePtr->channelName); if (hPtr == NULL) { @@ -1446,12 +1358,12 @@ } hTblPtr = GetChannelTable(interp); hPtr = Tcl_FindHashEntry(hTblPtr, name); if (hPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can not find channel named \"%s\"", chanName)); + Tcl_AppendResult(interp, "can not find channel named \"", chanName, + "\"", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CHANNEL", chanName, NULL); return NULL; } /* @@ -1458,14 +1370,14 @@ * 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 = Tcl_GetHashValue(hPtr); chanPtr = chanPtr->state->bottomChanPtr; if (modePtr != NULL) { - *modePtr = chanPtr->state->flags & (TCL_READABLE|TCL_WRITABLE); + *modePtr = GotFlag(chanPtr->state, TCL_READABLE|TCL_WRITABLE); } return (Tcl_Channel) chanPtr; } @@ -1497,69 +1409,68 @@ 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*/) + int flags) { ChannelState *statePtr; ResolvedChanName *resPtr = NULL; Tcl_Channel chan; if (interp == NULL) { return TCL_ERROR; } - ChanGetIntRep(objPtr, resPtr); - if (resPtr) { + if (objPtr->typePtr == &chanObjType) { /* * Confirm validity of saved lookup results. */ + resPtr = (ResolvedChanName *) objPtr->internalRep.twoPtrValue.ptr1; 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. - */ + /* 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); + FreeChannelIntRep(objPtr); } return TCL_ERROR; } if (resPtr && resPtr->refCount == 1) { - /* - * Re-use the ResolvedCmdName struct. - */ + /* Re-use the ResolvedCmdName struct */ + Tcl_Release((ClientData) resPtr->statePtr); - Tcl_Release(resPtr->statePtr); } else { - resPtr = (ResolvedChanName *) Tcl_Alloc(sizeof(ResolvedChanName)); - resPtr->refCount = 0; - ChanSetIntRep(objPtr, resPtr); /* Overwrites, if needed */ + TclFreeIntRep(objPtr); + + resPtr = (ResolvedChanName *) ckalloc(sizeof(ResolvedChanName)); + resPtr->refCount = 1; + objPtr->internalRep.twoPtrValue.ptr1 = (ClientData) resPtr; + objPtr->typePtr = &chanObjType; } statePtr = ((Channel *)chan)->state; resPtr->statePtr = statePtr; - Tcl_Preserve(statePtr); + Tcl_Preserve((ClientData) statePtr); resPtr->interp = interp; resPtr->epoch = statePtr->epoch; valid: - *channelPtr = (Tcl_Channel) statePtr->bottomChanPtr; + *channelPtr = (Tcl_Channel) (statePtr->bottomChanPtr); if (modePtr != NULL) { - *modePtr = statePtr->flags & (TCL_READABLE|TCL_WRITABLE); + *modePtr = GotFlag(statePtr, TCL_READABLE|TCL_WRITABLE); } return TCL_OK; } @@ -1579,21 +1490,20 @@ *---------------------------------------------------------------------- */ Tcl_Channel Tcl_CreateChannel( - const Tcl_ChannelType *typePtr, /* The channel type record. */ + Tcl_ChannelType *typePtr, /* The channel type record. */ const char *chanName, /* Name of channel to record. */ ClientData instanceData, /* Instance specific data. */ int mask) /* TCL_READABLE & TCL_WRITABLE to indicate if * the channel is readable, writable. */ { Channel *chanPtr; /* The channel structure newly created. */ ChannelState *statePtr; /* The stack-level independent state info for * the channel. */ const char *name; - char *tmp; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* * With the change of the Tcl_ChannelType structure to use a version in * 8.3.2+, we have to make sure that our assumption that the structure @@ -1602,35 +1512,19 @@ * 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); - if (Tcl_ChannelVersion(typePtr) != TCL_CHANNEL_VERSION_5) { - Tcl_Panic("channel type %s must be version TCL_CHANNEL_VERSION_5", typePtr->typeName); - } - if (typePtr->close2Proc == NULL) { - Tcl_Panic("channel type %s must define close2Proc", typePtr->typeName); - } - if ((TCL_READABLE & mask) && (NULL == typePtr->inputProc)) { - 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); - } + assert(sizeof(Tcl_ChannelTypeVersion) == sizeof(Tcl_DriverBlockModeProc*)); /* * JH: We could subsequently memset these to 0 to avoid the numerous * assignments to 0/NULL below. */ - chanPtr = (Channel *)Tcl_Alloc(sizeof(Channel)); - statePtr = (ChannelState *)Tcl_Alloc(sizeof(ChannelState)); + chanPtr = (Channel *) ckalloc(sizeof(Channel)); + statePtr = (ChannelState *) ckalloc(sizeof(ChannelState)); chanPtr->state = statePtr; chanPtr->instanceData = instanceData; chanPtr->typePtr = typePtr; @@ -1638,24 +1532,18 @@ * 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 *)Tcl_Alloc((len < 7) ? 7 : len); + char *tmp = ckalloc((unsigned) (strlen(chanName) + 1)); + + statePtr->channelName = tmp; strcpy(tmp, chanName); } else { - tmp = (char *)Tcl_Alloc(7); - tmp[0] = '\0'; + Tcl_Panic("Tcl_CreateChannel: NULL channel name"); } - statePtr->channelName = tmp; + statePtr->flags = mask; /* * Set the channel to system default encoding. * @@ -1678,11 +1566,11 @@ /* * Set the channel up initially in AUTO input translation mode to accept * "\n", "\r" and "\r\n". Output translation mode is set to a platform * specific default value. The eofChar is set to 0 for both input and - * output, so that Tcl does not look for an in-file EOF indicator (e.g., + * output, so that Tcl does not look for an in-file EOF indicator (e.g. * ^Z) and does not append an EOF indicator to files. */ statePtr->inputTranslation = TCL_TRANSLATE_AUTO; statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION; @@ -1752,21 +1640,18 @@ * Install this channel in the first empty standard channel slot, if the * channel was previously closed explicitly. */ if ((tsdPtr->stdinChannel == NULL) && (tsdPtr->stdinInitialized == 1)) { - strcpy(tmp, "stdin"); Tcl_SetStdChannel((Tcl_Channel) chanPtr, TCL_STDIN); Tcl_RegisterChannel(NULL, (Tcl_Channel) chanPtr); } else if ((tsdPtr->stdoutChannel == NULL) && (tsdPtr->stdoutInitialized == 1)) { - strcpy(tmp, "stdout"); Tcl_SetStdChannel((Tcl_Channel) chanPtr, TCL_STDOUT); Tcl_RegisterChannel(NULL, (Tcl_Channel) chanPtr); } else if ((tsdPtr->stderrChannel == NULL) && (tsdPtr->stderrInitialized == 1)) { - strcpy(tmp, "stderr"); Tcl_SetStdChannel((Tcl_Channel) chanPtr, TCL_STDERR); Tcl_RegisterChannel(NULL, (Tcl_Channel) chanPtr); } return (Tcl_Channel) chanPtr; } @@ -1799,12 +1684,11 @@ */ Tcl_Channel Tcl_StackChannel( Tcl_Interp *interp, /* The interpreter we are working in */ - const Tcl_ChannelType *typePtr, - /* The channel type record for the new + Tcl_ChannelType *typePtr, /* The channel type record for the new * channel. */ ClientData instanceData, /* Instance specific data for the new * channel. */ int mask, /* TCL_READABLE & TCL_WRITABLE to indicate if * the channel is readable, writable. */ @@ -1811,10 +1695,11 @@ Tcl_Channel prevChan) /* The channel structure to replace */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); Channel *chanPtr, *prevChanPtr; ChannelState *statePtr; + Tcl_DriverThreadActionProc *threadActionProc; /* * Find the given channel (prevChan) in the list of all channels. If we do * not find it, then it was never registered correctly. * @@ -1828,13 +1713,12 @@ statePtr = statePtr->nextCSPtr; } if (statePtr == NULL) { if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't find state for channel \"%s\"", - Tcl_GetChannelName(prevChan))); + Tcl_AppendResult(interp, "couldn't find state for channel \"", + Tcl_GetChannelName(prevChan), "\"", NULL); } return NULL; } /* @@ -1848,15 +1732,15 @@ * W | | | + | + | the capabilities of the superceded one! * RW| | + | + | + | * --+---+---+---+----+ */ - if ((mask & (statePtr->flags & (TCL_READABLE | TCL_WRITABLE))) == 0) { + if ((mask & (GotFlag(statePtr, TCL_READABLE | TCL_WRITABLE))) == 0) { if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "reading and writing both disallowed for channel \"%s\"", - Tcl_GetChannelName(prevChan))); + Tcl_AppendResult(interp, + "reading and writing both disallowed for channel \"", + Tcl_GetChannelName(prevChan), "\"", NULL); } return NULL; } /* @@ -1879,13 +1763,12 @@ */ if (Tcl_Flush((Tcl_Channel) prevChanPtr) != TCL_OK) { statePtr->csPtrR = csPtrR; statePtr->csPtrW = csPtrW; if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not flush channel \"%s\"", - Tcl_GetChannelName(prevChan))); + Tcl_AppendResult(interp, "could not flush channel \"", + Tcl_GetChannelName(prevChan), "\"", NULL); } return NULL; } statePtr->csPtrR = csPtrR; @@ -1906,10 +1789,11 @@ * transformations which pre-read data and push the unused part back when * they are going away. */ if (((mask & TCL_READABLE) != 0) && (statePtr->inQueueHead != NULL)) { + /* * When statePtr->inQueueHead is not NULL, we know * prevChanPtr->inQueueHead must be NULL. */ @@ -1921,11 +1805,11 @@ statePtr->inQueueHead = NULL; statePtr->inQueueTail = NULL; } - chanPtr = (Channel *)Tcl_Alloc(sizeof(Channel)); + chanPtr = (Channel *) ckalloc(sizeof(Channel)); /* * Save some of the current state into the new structure, reinitialize the * parts which will stay with the transformation. * @@ -1958,11 +1842,14 @@ * individual channels. And SpliceChannel would not only call the thread * actions, but also add the shared ChannelState to this list a second * time, mangling it. */ - ChanThreadAction(chanPtr, TCL_CHANNEL_THREAD_INSERT); + threadActionProc = Tcl_ChannelThreadActionProc(chanPtr->typePtr); + if (threadActionProc != NULL) { + (*threadActionProc)(chanPtr->instanceData, TCL_CHANNEL_THREAD_INSERT); + } return (Tcl_Channel) chanPtr; } void @@ -1983,20 +1870,20 @@ } if (--chanPtr->refCount) { return; } if (chanPtr->typePtr == NULL) { - Tcl_Free(chanPtr); + ckfree((char *)chanPtr); } } static void ChannelFree( Channel *chanPtr) { - if (!chanPtr->refCount) { - Tcl_Free(chanPtr); + if (chanPtr->refCount == 0) { + ckfree((char *)chanPtr); return; } chanPtr->typePtr = NULL; } @@ -2024,10 +1911,11 @@ Tcl_Channel chan) /* The channel to unstack */ { Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; int result = 0; + Tcl_DriverThreadActionProc *threadActionProc; /* * This operation should occur at the top of a channel stack. */ @@ -2034,14 +1922,16 @@ chanPtr = statePtr->topChanPtr; if (chanPtr->downChanPtr != NULL) { /* * Instead of manipulating the per-thread / per-interp list/hashtable - * of registered channels we wind down the state of the - * transformation, and then restore the state of underlying channel - * into the old structure. - * + * of registered channels we wind down the state of the transformation, + * and then restore the state of underlying channel into the old + * structure. + */ + + /* * TODO: Figure out how to handle the situation where the chan * operations called below by this unstacking operation cause * another unstacking recursively. In that case the downChanPtr * value we're holding on to will not be the right thing. */ @@ -2074,13 +1964,13 @@ * to the regular message if nothing was found in the * bypasses. */ if (!TclChanCaughtErrorBypass(interp, chan) && interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not flush channel \"%s\"", - Tcl_GetChannelName((Tcl_Channel) chanPtr))); + Tcl_AppendResult(interp, "could not flush channel \"", + Tcl_GetChannelName((Tcl_Channel) chanPtr), "\"", + NULL); } return TCL_ERROR; } statePtr->csPtrR = csPtrR; @@ -2126,11 +2016,15 @@ * only call the thread actions, but also remove the shared * ChannelState from this list despite there being more channels for * the state which are still active. */ - ChanThreadAction(chanPtr, TCL_CHANNEL_THREAD_REMOVE); + threadActionProc = Tcl_ChannelThreadActionProc(chanPtr->typePtr); + if (threadActionProc != NULL) { + (*threadActionProc)(chanPtr->instanceData, + TCL_CHANNEL_THREAD_REMOVE); + } statePtr->topChanPtr = downChanPtr; downChanPtr->upChanPtr = NULL; /* @@ -2140,11 +2034,18 @@ /* * Close and free the channel driver state. */ - result = ChanClose(chanPtr, interp); + if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) { + result = (chanPtr->typePtr->closeProc)(chanPtr->instanceData, + interp); + } else { + result = (chanPtr->typePtr->close2Proc)(chanPtr->instanceData, + interp, 0); + } + ChannelFree(chanPtr); UpdateInterest(statePtr->topChanPtr); if (result != 0) { @@ -2163,12 +2064,12 @@ /* * This channel does not cover another one. Simply do a close, if * necessary. */ - if (statePtr->refCount + 1 <= 1) { - if (Tcl_CloseEx(interp, chan, 0) != TCL_OK) { + 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". */ @@ -2311,11 +2212,11 @@ * None. * *---------------------------------------------------------------------- */ -const Tcl_ChannelType * +Tcl_ChannelType * Tcl_GetChannelType( Tcl_Channel chan) /* The channel to return type for. */ { Channel *chanPtr = (Channel *) chan; /* The actual channel. */ @@ -2346,11 +2247,11 @@ * computed. */ { ChannelState *statePtr = ((Channel *) chan)->state; /* State of actual channel. */ - return (statePtr->flags & (TCL_READABLE | TCL_WRITABLE)); + return GotFlag(statePtr, TCL_READABLE | TCL_WRITABLE); } /* *---------------------------------------------------------------------- * @@ -2370,13 +2271,13 @@ const char * Tcl_GetChannelName( Tcl_Channel chan) /* The channel for which to return the name. */ { - ChannelState *statePtr = ((Channel *) chan)->state; - /* State of actual channel. */ + ChannelState *statePtr; /* State of actual channel. */ + statePtr = ((Channel *) chan)->state; return statePtr->channelName; } /* *---------------------------------------------------------------------- @@ -2405,17 +2306,19 @@ ClientData handle; int result; chanPtr = ((Channel *) chan)->state->bottomChanPtr; if (!chanPtr->typePtr->getHandleProc) { - Tcl_SetChannelError(chan, Tcl_ObjPrintf( - "channel \"%s\" does not support OS handles", - Tcl_GetChannelName(chan))); + Tcl_Obj* err; + TclNewLiteralStringObj(err, "channel \""); + Tcl_AppendToObj(err, Tcl_GetChannelName(chan), -1); + Tcl_AppendToObj(err, "\" does not support OS handles", -1); + Tcl_SetChannelError (chan,err); return TCL_ERROR; } - result = chanPtr->typePtr->getHandleProc(chanPtr->instanceData, direction, - &handle); + result = (chanPtr->typePtr->getHandleProc)(chanPtr->instanceData, + direction, &handle); if (handlePtr) { *handlePtr = handle; } return result; } @@ -2450,11 +2353,11 @@ { ChannelBuffer *bufPtr; int n; n = length + CHANNELBUFFER_HEADER_SIZE + BUFFER_PADDING + BUFFER_PADDING; - bufPtr = (ChannelBuffer *)Tcl_Alloc(n); + bufPtr = (ChannelBuffer *) ckalloc((unsigned) n); bufPtr->nextAdded = BUFFER_PADDING; bufPtr->nextRemoved = BUFFER_PADDING; bufPtr->bufLength = length + BUFFER_PADDING; bufPtr->nextPtr = NULL; bufPtr->refCount = 1; @@ -2463,13 +2366,10 @@ static void PreserveChannelBuffer( ChannelBuffer *bufPtr) { - if (!bufPtr->refCount) { - Tcl_Panic("Reuse of ChannelBuffer! %p", bufPtr); - } bufPtr->refCount++; } static void ReleaseChannelBuffer( @@ -2476,18 +2376,18 @@ ChannelBuffer *bufPtr) { if (--bufPtr->refCount) { return; } - Tcl_Free(bufPtr); + ckfree((char *) bufPtr); } static int IsShared( ChannelBuffer *bufPtr) { - return bufPtr->refCount + 1 > 2; + return bufPtr->refCount > 1; } /* *---------------------------------------------------------------------- * @@ -2515,11 +2415,10 @@ * always. */ { /* * Do we have to free the buffer to the OS? */ - if (IsShared(bufPtr)) { mustDiscard = 1; } if (mustDiscard) { @@ -2526,12 +2425,13 @@ ReleaseChannelBuffer(bufPtr); return; } /* - * Only save buffers which have the requested buffersize for the channel. - * This is to honor dynamic changes of the buffersize made by the user. + * Only save buffers which have the requested buffersize for the + * channel. This is to honor dynamic changes of the buffersize + * made by the user. */ if ((bufPtr->bufLength - BUFFER_PADDING) != statePtr->bufSize) { ReleaseChannelBuffer(bufPtr); return; @@ -2633,30 +2533,29 @@ static int CheckForDeadChannel( Tcl_Interp *interp, /* For error reporting (can be NULL) */ ChannelState *statePtr) /* The channel state to check. */ { - if (!GotFlag(statePtr, CHANNEL_DEAD)) { - return 0; - } - - Tcl_SetErrno(EINVAL); - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unable to access channel: invalid channel", -1)); - } - return 1; + if (GotFlag(statePtr, CHANNEL_DEAD)) { + Tcl_SetErrno(EINVAL); + if (interp) { + Tcl_AppendResult(interp, + "unable to access channel: invalid channel", NULL); + } + return 1; + } + return 0; } /* *---------------------------------------------------------------------- * * FlushChannel -- * - * This function flushes as much of the queued output as is possible now. - * If calledFromAsyncFlush is nonzero, it is being called in an event - * handler to flush channel output asynchronously. + * This function flushes as much of the queued output as is possible + * now. If calledFromAsyncFlush is nonzero, it is being called in an + * event handler to flush channel output asynchronously. * * Results: * 0 if successful, else the error code that was returned by the channel * type operation. May leave a message in the interp result. * @@ -2697,22 +2596,18 @@ } /* * Should we shift the current output buffer over to the output queue? * First check that there are bytes in it. If so then... - * - * If the output queue is empty, then yes, trusting the caller called us - * only when written bytes ought to be flushed. - * - * If the current output buffer is full, then yes, so we can meet the - * post-condition that on a successful return to caller we've left space - * in the current output buffer for more writing (the flush call was to - * make new room). - * - * If the channel is blocking, then yes, so we guarantee that blocking - * flushes actually flush all pending data. - * + * If the output queue is empty, then yes, trusting the caller called + * us only when written bytes ought to be flushed. + * If the current output buffer is full, then yes, so we can meet + * the post-condition that on a successful return to caller we've + * left space in the current output buffer for more writing (the flush + * call was to make new room). + * If the channel is blocking, then yes, so we guarantee that + * blocking flushes actually flush all pending data. * Otherwise, no. Keep the current output buffer where it is so more * can be written to it, possibly filling it, to promote more efficient * buffer usage. */ @@ -2752,12 +2647,12 @@ /* * Produce the output on the channel. */ PreserveChannelBuffer(bufPtr); - written = ChanWrite(chanPtr, RemovePoint(bufPtr), BytesLeft(bufPtr), - &errorCode); + written = (chanPtr->typePtr->outputProc)(chanPtr->instanceData, + RemovePoint(bufPtr), BytesLeft(bufPtr), &errorCode); /* * If the write failed completely attempt to start the asynchronous * flush mechanism and break out of this loop - do not attempt to * write any more output at this time. @@ -2785,11 +2680,11 @@ * the channel was blocking. However, it appears that setting * stdin to -blocking 0 has some effect on the stdout when * it's a tty channel (dup'ed underneath) */ - if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED) && !TclInExit()) { + if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { SetFlag(statePtr, BG_FLUSH_SCHEDULED); UpdateInterest(chanPtr); } errorCode = 0; ReleaseChannelBuffer(bufPtr); @@ -2802,12 +2697,12 @@ if (calledFromAsyncFlush) { /* * TIP #219, Tcl Channel Reflection API. * When defering the error copy a message from the bypass into - * the unreported area. Or discard it if the new error is to - * be ignored in favor of an earlier defered error. + * the unreported area. Or discard it if the new error is to be + * ignored in favor of an earlier defered error. */ Tcl_Obj *msg = statePtr->chanMsg; if (statePtr->unreportedError == 0) { @@ -2836,12 +2731,18 @@ */ Tcl_SetErrno(errorCode); if (interp != NULL && !TclChanCaughtErrorBypass(interp, (Tcl_Channel) chanPtr)) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj(Tcl_PosixError(interp), -1)); + /* + * Casting away const here is safe because the + * TCL_VOLATILE flag guarantees const treatment of the + * Posix error string. + */ + + Tcl_SetResult(interp, (char *) Tcl_PosixError(interp), + TCL_VOLATILE); } /* * An unreportable bypassed message is kept, for the caller of * Tcl_Seek, Tcl_Write, etc. @@ -2855,15 +2756,12 @@ DiscardOutputQueued(statePtr); ReleaseChannelBuffer(bufPtr); break; } else { - /* - * TODO: Consider detecting and reacting to short writes on - * blocking channels. Ought not happen. See iocmd-24.2. - */ - + /* TODO: Consider detecting and reacting to short writes + * on blocking channels. Ought not happen. See iocmd-24.2. */ wroteSome = 1; } bufPtr->nextRemoved += written; @@ -2891,61 +2789,33 @@ if (GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { if (wroteSome) { goto done; } else if (statePtr->outQueueHead == NULL) { ResetFlag(statePtr, BG_FLUSH_SCHEDULED); - ChanWatch(chanPtr, statePtr->interestMask); + (chanPtr->typePtr->watchProc)(chanPtr->instanceData, + statePtr->interestMask); } else { - /* - * When we are calledFromAsyncFlush, that means a writable - * state on the channel triggered the call, so we should be - * 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); - */ + /* TODO: If code reaches this point, it means a writable + * event is being handled on the channel, but the channel + * could not in fact be written to. This ought not happen, + * but Unix pipes appear to act this way (see io-53.4). + * Also can imagine broken reflected channels. */ } } /* * 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 + 1 <= 1) && + if (GotFlag(statePtr, CHANNEL_CLOSED) && (statePtr->refCount <= 0) && (statePtr->outQueueHead == NULL) && ((statePtr->curOutPtr == NULL) || IsBufferEmpty(statePtr->curOutPtr))) { errorCode = CloseChannel(interp, chanPtr, errorCode); - goto done; - } - - /* - * If the write-side of the channel is flagged as closed, delete it when - * the output queue is empty and there is no output in the current output - * buffer. - */ - - if (GotFlag(statePtr, CHANNEL_CLOSEDWRITE) && - (statePtr->outQueueHead == NULL) && - ((statePtr->curOutPtr == NULL) || - IsBufferEmpty(statePtr->curOutPtr))) { - errorCode = CloseChannelPart(interp, chanPtr, errorCode, - TCL_CLOSE_WRITE); - goto done; - } - + } done: TclChannelRelease((Tcl_Channel)chanPtr); return errorCode; } @@ -3018,11 +2888,11 @@ if ((statePtr->outEofChar != 0) && GotFlag(statePtr, TCL_WRITABLE)) { int dummy; char c = (char) statePtr->outEofChar; - (void) ChanWrite(chanPtr, &c, 1, &dummy); + (chanPtr->typePtr->outputProc)(chanPtr->instanceData, &c, 1, &dummy); } /* * TIP #219, Tcl Channel Reflection API. * Move a leftover error message in the channel bypass into the @@ -3029,11 +2899,11 @@ * interpreter bypass. Just clear it if there is no interpreter. */ if (statePtr->chanMsg != NULL) { if (interp != NULL) { - Tcl_SetChannelErrorInterp(interp, statePtr->chanMsg); + Tcl_SetChannelErrorInterp(interp,statePtr->chanMsg); } TclDecrRefCount(statePtr->chanMsg); statePtr->chanMsg = NULL; } @@ -3046,20 +2916,25 @@ /* * Close and free the channel driver state. * This may leave a TIP #219 error message in the interp. */ - result = ChanClose(chanPtr, interp); + if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) { + result = (chanPtr->typePtr->closeProc)(chanPtr->instanceData, interp); + } else { + result = (chanPtr->typePtr->close2Proc)(chanPtr->instanceData, + interp, 0); + } /* * 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) { - Tcl_Free(statePtr->channelName); + ckfree((char *) statePtr->channelName); statePtr->channelName = NULL; } Tcl_FreeEncoding(statePtr->encoding); } @@ -3081,11 +2956,11 @@ if (statePtr->chanMsg != NULL) { TclDecrRefCount(statePtr->chanMsg); statePtr->chanMsg = NULL; } if (interp) { - Tcl_SetChannelErrorInterp(interp, statePtr->unreportedMsg); + Tcl_SetChannelErrorInterp(interp,statePtr->unreportedMsg); } } if (errorCode == 0) { errorCode = result; if (errorCode != 0) { @@ -3112,11 +2987,11 @@ statePtr->topChanPtr = downChanPtr; downChanPtr->upChanPtr = NULL; ChannelFree(chanPtr); - return Tcl_CloseEx(interp, (Tcl_Channel) downChanPtr, 0); + return Tcl_Close(interp, (Tcl_Channel) downChanPtr); } /* * There is only the TOP Channel, so we free the remaining pointers we * have and then ourselves. Since this is the last of the channels in the @@ -3164,10 +3039,11 @@ ChannelState *prevCSPtr; /* Preceding channel state in list of all * states - used to splice a channel out of * the list on close. */ ChannelState *statePtr = ((Channel *) chan)->state; /* State of the channel stack. */ + Tcl_DriverThreadActionProc *threadActionProc; /* * Remove this channel from of the list of all channels (in the current * thread). */ @@ -3190,14 +3066,15 @@ /* * TIP #218, Channel Thread Actions */ - ChanThreadAction((Channel *) chan, TCL_CHANNEL_THREAD_REMOVE); - - /* Channel is not managed by any thread */ - statePtr->managingThread = NULL; + threadActionProc = Tcl_ChannelThreadActionProc(Tcl_GetChannelType(chan)); + if (threadActionProc != NULL) { + (*threadActionProc)(Tcl_GetChannelInstanceData(chan), + TCL_CHANNEL_THREAD_REMOVE); + } } void Tcl_CutChannel( Tcl_Channel chan) /* The channel being added. Must not be @@ -3208,10 +3085,11 @@ ChannelState *prevCSPtr; /* Preceding channel state in list of all * states - used to splice a channel out of * the list on close. */ ChannelState *statePtr = chanPtr->state; /* State of the channel stack. */ + Tcl_DriverThreadActionProc *threadActionProc; /* * Remove this channel from of the list of all channels (in the current * thread). */ @@ -3235,16 +3113,18 @@ /* * TIP #218, Channel Thread Actions * For all transformations and the base channel. */ - for (; chanPtr != NULL ; chanPtr = chanPtr->upChanPtr) { - ChanThreadAction(chanPtr, TCL_CHANNEL_THREAD_REMOVE); + while (chanPtr) { + threadActionProc = Tcl_ChannelThreadActionProc(chanPtr->typePtr); + if (threadActionProc != NULL) { + (*threadActionProc)(chanPtr->instanceData, + TCL_CHANNEL_THREAD_REMOVE); + } + chanPtr= chanPtr->upChanPtr; } - - /* Channel is not managed by any thread */ - statePtr->managingThread = NULL; } /* *---------------------------------------------------------------------- * @@ -3276,10 +3156,11 @@ Tcl_Channel chan) /* The channel being added. Must not be * referenced in any interpreter. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); ChannelState *statePtr = ((Channel *) chan)->state; + Tcl_DriverThreadActionProc *threadActionProc; if (statePtr->nextCSPtr != NULL) { Tcl_Panic("SpliceChannel: trying to add channel used in different list"); } @@ -3296,11 +3177,15 @@ /* * TIP #218, Channel Thread Actions */ - ChanThreadAction((Channel *) chan, TCL_CHANNEL_THREAD_INSERT); + threadActionProc = Tcl_ChannelThreadActionProc(Tcl_GetChannelType(chan)); + if (threadActionProc != NULL) { + (*threadActionProc) (Tcl_GetChannelInstanceData(chan), + TCL_CHANNEL_THREAD_INSERT); + } } void Tcl_SpliceChannel( Tcl_Channel chan) /* The channel being added. Must not be @@ -3307,10 +3192,11 @@ * referenced in any interpreter. */ { Channel *chanPtr = ((Channel *) chan)->state->bottomChanPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); ChannelState *statePtr = chanPtr->state; + Tcl_DriverThreadActionProc *threadActionProc; if (statePtr->nextCSPtr != NULL) { Tcl_Panic("SpliceChannel: trying to add channel used in different list"); } @@ -3328,12 +3214,17 @@ /* * TIP #218, Channel Thread Actions * For all transformations and the base channel. */ - for (; chanPtr != NULL ; chanPtr = chanPtr->upChanPtr) { - ChanThreadAction(chanPtr, TCL_CHANNEL_THREAD_INSERT); + while (chanPtr) { + threadActionProc = Tcl_ChannelThreadActionProc(chanPtr->typePtr); + if (threadActionProc != NULL) { + (*threadActionProc)(chanPtr->instanceData, + TCL_CHANNEL_THREAD_INSERT); + } + chanPtr= chanPtr->upChanPtr; } } /* *---------------------------------------------------------------------- @@ -3355,21 +3246,22 @@ * the channel record removed, in CloseChannel, above. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int -TclClose( +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 result; /* Of calling FlushChannel. */ int flushcode; int stickyError; if (chan == NULL) { return TCL_OK; @@ -3391,19 +3283,18 @@ chanPtr = (Channel *) chan; statePtr = chanPtr->state; chanPtr = statePtr->topChanPtr; - if (statePtr->refCount + 1 > 1) { + if (statePtr->refCount > 0) { Tcl_Panic("called Tcl_Close on channel with refCount > 0"); } if (GotFlag(statePtr, CHANNEL_INCLOSE)) { if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "illegal recursive call to close through close-handler" - " of channel", -1)); + Tcl_AppendResult(interp, "Illegal recursive call to close " + "through close-handler of channel", NULL); } return TCL_ERROR; } SetFlag(statePtr, CHANNEL_INCLOSE); @@ -3414,10 +3305,11 @@ stickyError = 0; if (GotFlag(statePtr, TCL_WRITABLE) && (statePtr->encoding != NULL) && !(statePtr->outputEncodingFlags & TCL_ENCODING_START)) { + int code = CheckChannelErrors(statePtr, TCL_WRITABLE); if (code == 0) { statePtr->outputEncodingFlags |= TCL_ENCODING_END; code = WriteChars(chanPtr, "", 0); @@ -3434,44 +3326,41 @@ * interpreter bypass. Just clear it if there is no interpreter. */ if (statePtr->chanMsg != NULL) { if (interp != NULL) { - Tcl_SetChannelErrorInterp(interp, statePtr->chanMsg); + Tcl_SetChannelErrorInterp(interp,statePtr->chanMsg); } TclDecrRefCount(statePtr->chanMsg); statePtr->chanMsg = NULL; } } Tcl_ClearChannelHandlers(chan); - /* - * Cancel any outstanding timer. - */ - Tcl_DeleteTimerHandler(statePtr->timer); - /* * Invoke the registered close callbacks and delete their records. */ while (statePtr->closeCbPtr != NULL) { cbPtr = statePtr->closeCbPtr; statePtr->closeCbPtr = cbPtr->nextPtr; - cbPtr->proc(cbPtr->clientData); - Tcl_Free(cbPtr); + (cbPtr->proc)(cbPtr->clientData); + ckfree((char *) 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. */ - result = chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, TCL_CLOSE_READ); - if ((result == EINVAL) || result == ENOTCONN) { + if (chanPtr->typePtr->closeProc == TCL_CLOSE2PROC) { + result = (chanPtr->typePtr->close2Proc)(chanPtr->instanceData, interp, + TCL_CLOSE_READ); + } else { result = 0; } /* * The call to FlushChannel will flush any queued output and invoke the @@ -3506,372 +3395,23 @@ Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_PosixError(interp), -1)); } return TCL_ERROR; } - /* * Bug 97069ea11a: set error message if a flush code is set and no error * message set up to now. */ - - 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); + if (flushcode != 0 && interp != NULL + && 0 == Tcl_GetCharLength(Tcl_GetObjResult(interp)) ) { + Tcl_SetErrno(flushcode); 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 TclClose(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. - */ - - if (chanPtr != statePtr->topChanPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "half-close not applicable to stack of transformations", -1)); - return TCL_ERROR; - } - - /* - * Check direction against channel mode. It is an error if we try to close - * a direction not supported by the channel (already closed, or never - * opened for that direction). - */ - - if (!(statePtr->flags & (TCL_READABLE | TCL_WRITABLE) & flags)) { - const char *msg; - - if (flags & TCL_CLOSE_READ) { - msg = "read"; - } else { - msg = "write"; - } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "Half-close of %s-side not possible, side not opened or" - " already closed", msg)); - return TCL_ERROR; - } - - /* - * A user may try to call half-close from within a channel close handler. - * That won't do. - */ - - if (statePtr->flags & CHANNEL_INCLOSE) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "illegal recursive call to close through close-handler" - " of channel", -1)); - } - return TCL_ERROR; - } - - if (flags & TCL_CLOSE_READ) { - /* - * Call the finalization code directly. There are no events to handle, - * there cannot be for the read-side. - */ - - return CloseChannelPart(interp, chanPtr, 0, flags); - } else if (flags & TCL_CLOSE_WRITE) { - Tcl_Preserve(statePtr); - if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { - /* - * We don't want to re-enter CloseWrite(). - */ - - if (!GotFlag(statePtr, CHANNEL_CLOSEDWRITE)) { - if (CloseWrite(interp, chanPtr) != TCL_OK) { - SetFlag(statePtr, CHANNEL_CLOSEDWRITE); - Tcl_Release(statePtr); - return TCL_ERROR; - } - } - } - SetFlag(statePtr, CHANNEL_CLOSEDWRITE); - Tcl_Release(statePtr); - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * CloseWrite -- - * - * Closes the write side a channel. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Closes the write side of the channel. - * - * NOTE: - * CloseWrite removes the channel as far as the user is concerned. - * However, the ooutput data structures may continue to exist for a while - * longer if it has a background flush scheduled. The device itself is - * eventually closed and the channel structures modified, in - * CloseChannelPart, below. - * - *---------------------------------------------------------------------- - */ - -static int -CloseWrite( - Tcl_Interp *interp, /* Interpreter for errors. */ - Channel *chanPtr) /* The channel whose write side is being - * closed. May still be used by some - * interpreter */ -{ - /* - * Notes: clear-channel-handlers - write side only ? or keep around, just - * not called. - * - * No close callbacks are run - channel is still open (read side) - */ - - ChannelState *statePtr = chanPtr->state; - /* State of real IO channel. */ - int flushcode; - int result = 0; - - /* - * The call to FlushChannel will flush any queued output and invoke the - * close function of the channel driver, or it will set up the channel to - * be flushed and closed asynchronously. - */ - - SetFlag(statePtr, CHANNEL_CLOSEDWRITE); - - flushcode = FlushChannel(interp, chanPtr, 0); - - /* - * TIP #219. - * Capture error messages put by the driver into the bypass area and put - * them into the regular interpreter result. - * - * Notes: Due to the assertion of CHANNEL_CLOSEDWRITE in the flags - * FlushChannel() has called CloseChannelPart(). While we can still access - * "chan" (no structures were freed), the only place which may still - * contain a message is the interpreter itself, and "CloseChannelPart" - * made sure to lift any channel message it generated into it. Hence the - * NULL argument in the call below. - */ - - if (TclChanCaughtErrorBypass(interp, NULL)) { - result = EINVAL; - } - if ((flushcode != 0) || (result != 0)) { return TCL_ERROR; } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * CloseChannelPart -- - * - * Utility procedure to close a channel partially and free associated - * resources. If the channel was stacked it will never be run (The higher - * level forbid this). If the channel was not stacked, then we will free - * all the bits of the chosen side (read, or write) for the TOP channel. - * - * Results: - * Error code from an unreported error or the driver close2 operation. - * - * Side effects: - * May free memory, may change the value of errno. - * - *---------------------------------------------------------------------- - */ - -static int -CloseChannelPart( - Tcl_Interp *interp, /* Interpreter for errors. */ - Channel *chanPtr, /* The channel being closed. May still be used - * by some interpreter. */ - int errorCode, /* Status of operation so far. */ - int flags) /* Flags telling us which side to close. */ -{ - ChannelState *statePtr; /* State of real IO channel. */ - int result; /* Of calling the close2proc. */ - - statePtr = chanPtr->state; - - if (flags & TCL_CLOSE_READ) { - /* - * No more input can be consumed so discard any leftover input. - */ - - DiscardInputQueued(statePtr, 1); - } else if (flags & TCL_CLOSE_WRITE) { - /* - * The caller guarantees that there are no more buffers queued for - * output. - */ - - if (statePtr->outQueueHead != NULL) { - Tcl_Panic("ClosechanHalf, closed write-side of channel: " - "queued output left"); - } - - /* - * If the EOF character is set in the channel, append that to the - * output device. - */ - - if ((statePtr->outEofChar != 0) && GotFlag(statePtr, TCL_WRITABLE)) { - int dummy; - char c = (char) statePtr->outEofChar; - - (void) ChanWrite(chanPtr, &c, 1, &dummy); - } - - /* - * TIP #219, Tcl Channel Reflection API. - * Move a leftover error message in the channel bypass into the - * interpreter bypass. Just clear it if there is no interpreter. - */ - - if (statePtr->chanMsg != NULL) { - if (interp != NULL) { - Tcl_SetChannelErrorInterp(interp, statePtr->chanMsg); - } - TclDecrRefCount(statePtr->chanMsg); - statePtr->chanMsg = NULL; - } - } - - /* - * 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) { - errorCode = statePtr->unreportedError; - - /* - * TIP #219, Tcl Channel Reflection API. - * Move an error message found in the unreported area into the regular - * bypass (interp). This kills any message in the channel bypass area. - */ - - if (statePtr->chanMsg != NULL) { - TclDecrRefCount(statePtr->chanMsg); - statePtr->chanMsg = NULL; - } - if (interp) { - Tcl_SetChannelErrorInterp(interp, statePtr->unreportedMsg); - } - } - if (errorCode == 0) { - errorCode = result; - if (errorCode != 0) { - Tcl_SetErrno(errorCode); - } - } - - /* - * TIP #219. - * Capture error messages put by the driver into the bypass area and put - * them into the regular interpreter result. See also the bottom of - * CloseWrite(). - */ - - if (TclChanCaughtErrorBypass(interp, (Tcl_Channel) chanPtr)) { - result = EINVAL; - } - - if (result != 0) { - return TCL_ERROR; - } - - /* - * Remove the closed side from the channel mode/flags. - */ - - ResetFlag(statePtr, flags & (TCL_READABLE | TCL_WRITABLE)); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -3933,11 +3473,11 @@ * Remove all the channel handler records attached to the channel itself. */ for (chPtr = statePtr->chPtr; chPtr != NULL; chPtr = chNext) { chNext = chPtr->nextPtr; - Tcl_Free(chPtr); + ckfree((char *) chPtr); } statePtr->chPtr = NULL; /* * Cancel any pending copy operation. @@ -3945,14 +3485,14 @@ StopCopy(statePtr->csPtrR); StopCopy(statePtr->csPtrW); /* - * Must set the interest mask now to 0, otherwise infinite loops will - * occur if Tcl_DoOneEvent is called before the channel is finally deleted - * in FlushChannel. This can happen if the channel has a background flush - * active. + * Must set the interest mask now to 0, otherwise infinite loops + * will occur if Tcl_DoOneEvent is called before the channel is + * finally deleted in FlushChannel. This can happen if the channel + * has a background flush active. */ statePtr->interestMask = 0; /* @@ -3960,11 +3500,11 @@ */ for (ePtr = statePtr->scriptRecordPtr; ePtr != NULL; ePtr = eNextPtr) { eNextPtr = ePtr->nextPtr; TclDecrRefCount(ePtr->scriptPtr); - Tcl_Free(ePtr); + ckfree((char *) ePtr); } statePtr->scriptRecordPtr = NULL; } /* @@ -3979,25 +3519,25 @@ * 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 TCL_IO_FAILURE in case of error. If - * TCL_IO_FAILURE, Tcl_GetErrno will return the error code. + * 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. * *---------------------------------------------------------------------- */ -size_t +int Tcl_Write( Tcl_Channel chan, /* The channel to buffer output for. */ const char *src, /* Data to queue in output buffer. */ - size_t srcLen) /* Length of data in bytes, or -1 for + int srcLen) /* Length of data in bytes, or < 0 for * strlen(). */ { /* * Always use the topmost channel of the stack */ @@ -4007,18 +3547,18 @@ statePtr = ((Channel *) chan)->state; chanPtr = statePtr->topChanPtr; if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) { - return TCL_IO_FAILURE; + return -1; } - if (srcLen == TCL_INDEX_NONE) { + if (srcLen < 0) { srcLen = strlen(src); } - if (WriteBytes(chanPtr, src, srcLen) == -1) { - return TCL_IO_FAILURE; + if (WriteBytes(chanPtr, src, srcLen) < 0) { + return -1; } return srcLen; } /* @@ -4033,48 +3573,49 @@ * compensate for stacking. * * No encoding conversions are applied to the bytes being read. * * Results: - * The number of bytes written or TCL_IO_FAILURE in case of error. If - * TCL_IO_FAILURE, Tcl_GetErrno will return the error code. + * 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. * *---------------------------------------------------------------------- */ -size_t +int Tcl_WriteRaw( Tcl_Channel chan, /* The channel to buffer output for. */ const char *src, /* Data to queue in output buffer. */ - size_t srcLen) /* Length of data in bytes, or -1 for + 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; - size_t written; + int errorCode, written; if (CheckChannelErrors(statePtr, TCL_WRITABLE | CHANNEL_RAW_MODE) != 0) { - return TCL_IO_FAILURE; + return -1; } - if (srcLen == TCL_INDEX_NONE) { + 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 == TCL_IO_FAILURE) { + written = (chanPtr->typePtr->outputProc) (chanPtr->instanceData, + src, srcLen, &errorCode); + + if (written < 0) { Tcl_SetErrno(errorCode); } return written; } @@ -4090,40 +3631,40 @@ * 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 TCL_IO_FAILURE in case of error. If - * TCL_IO_FAILURE, Tcl_GetErrno will return the error code. + * 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. * *---------------------------------------------------------------------- */ -size_t +int Tcl_WriteChars( Tcl_Channel chan, /* The channel to buffer output for. */ const char *src, /* UTF-8 characters to queue in output * buffer. */ - size_t len) /* Length of string in bytes, or -1 for + 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 TCL_IO_FAILURE; + return -1; } chanPtr = statePtr->topChanPtr; - if (len == TCL_INDEX_NONE) { + if (len < 0) { len = strlen(src); } if (statePtr->encoding) { return WriteChars(chanPtr, src, len); } @@ -4138,11 +3679,11 @@ if ((len == 1) && (UCHAR(*src) < 0xC0)) { return WriteBytes(chanPtr, src, len); } objPtr = Tcl_NewStringObj(src, len); - src = (char *) TclGetByteArrayFromObj(objPtr, &len); + src = (char *) Tcl_GetByteArrayFromObj(objPtr, &len); result = WriteBytes(chanPtr, src, len); TclDecrRefCount(objPtr); return result; } @@ -4169,11 +3710,11 @@ * channel. * *---------------------------------------------------------------------- */ -size_t +int Tcl_WriteObj( Tcl_Channel chan, /* The channel to buffer output for. */ Tcl_Obj *objPtr) /* The object to write. */ { /* @@ -4180,71 +3721,64 @@ * Always use the topmost channel of the stack */ Channel *chanPtr; ChannelState *statePtr; /* State info for channel */ - const char *src; - size_t srcLen = 0; + char *src; + int srcLen; statePtr = ((Channel *) chan)->state; chanPtr = statePtr->topChanPtr; if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) { - return TCL_IO_FAILURE; + return -1; } if (statePtr->encoding == NULL) { - src = (char *) TclGetByteArrayFromObj(objPtr, &srcLen); + 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) +static void WillWrite(Channel *chanPtr) { int inputBuffered; - if (((Tcl_ChannelWideSeekProc(chanPtr->typePtr) != NULL) - ) && ((inputBuffered = Tcl_InputBuffered((Tcl_Channel) chanPtr)) > 0)){ - int ignore; - - DiscardInputQueued(chanPtr->state, 0); - ChanSeek(chanPtr, -inputBuffered, SEEK_CUR, &ignore); + if ((chanPtr->typePtr->seekProc != NULL) + && ((inputBuffered = Tcl_InputBuffered((Tcl_Channel) chanPtr)) > 0)) { + int ignore; + DiscardInputQueued(chanPtr->state, 0); + ChanSeek(chanPtr, - inputBuffered, SEEK_CUR, &ignore); } } -static int -WillRead( - Channel *chanPtr) +static int WillRead(Channel *chanPtr) { if (chanPtr->typePtr == NULL) { - /* - * Prevent read attempts on a closed channel. - */ - - DiscardInputQueued(chanPtr->state, 0); + /* Prevent read attempts on a closed channel */ + DiscardInputQueued(chanPtr->state, 0); Tcl_SetErrno(EINVAL); return -1; } - if (((Tcl_ChannelWideSeekProc(chanPtr->typePtr) != NULL) - ) && (Tcl_OutputBuffered((Tcl_Channel) chanPtr) > 0)) { + if ((chanPtr->typePtr->seekProc != NULL) + && (Tcl_OutputBuffered((Tcl_Channel) chanPtr) > 0)) { + /* - * CAVEAT - The assumption here is that FlushChannel() will push out - * the bytes of any writes that are in progress. Since this is a - * seekable channel, we assume it is not one that can block and force - * bg flushing. Channels we know that can do that - sockets, pipes - - * are not seekable. If the assumption is wrong, more drastic measures - * may be required here like temporarily setting the channel into - * blocking mode. + * 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; - } + if (FlushChannel(NULL, chanPtr, 0) != 0) { + return -1; + } } return 0; } /* @@ -4277,10 +3811,11 @@ { ChannelState *statePtr = chanPtr->state; /* State info for channel */ char *nextNewLine = NULL; int endEncoding, saved = 0, total = 0, flushed = 0, needNlFlush = 0; + char safe[BUFFER_PADDING]; if (srcLen) { WillWrite(chanPtr); } @@ -4290,22 +3825,22 @@ endEncoding = ((statePtr->outputEncodingFlags & TCL_ENCODING_END) != 0); if (GotFlag(statePtr, CHANNEL_LINEBUFFERED) || (statePtr->outputTranslation != TCL_TRANSLATE_LF)) { - nextNewLine = (char *)memchr(src, '\n', srcLen); + nextNewLine = memchr(src, '\n', srcLen); } while (srcLen + saved + endEncoding > 0) { ChannelBuffer *bufPtr; - char *dst, safe[BUFFER_PADDING]; + char *dst; int result, srcRead, dstLen, dstWrote, srcLimit = srcLen; if (nextNewLine) { srcLimit = nextNewLine - src; } - + /* Get space to write into */ bufPtr = statePtr->curOutPtr; if (bufPtr == NULL) { bufPtr = AllocChannelBuffer(statePtr->bufSize); statePtr->curOutPtr = bufPtr; @@ -4314,11 +3849,11 @@ /* * Here's some translated bytes left over from the last buffer * that we need to stick at the beginning of this buffer. */ - memcpy(InsertPoint(bufPtr), safe, saved); + memcpy(InsertPoint(bufPtr), safe, (size_t) saved); bufPtr->nextAdded += saved; saved = 0; } PreserveChannelBuffer(bufPtr); dst = InsertPoint(bufPtr); @@ -4327,21 +3862,15 @@ 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. - */ - + /* 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. - */ - + /* We're reading from invalid/incomplete UTF-8 */ ReleaseChannelBuffer(bufPtr); if (total == 0) { Tcl_SetErrno(EINVAL); return -1; } @@ -4375,38 +3904,39 @@ break; default: Tcl_Panic("unknown output translation requested"); break; } - + result |= Tcl_UtfToExternal(NULL, encoding, nl, nlLen, - statePtr->outputEncodingFlags, - &statePtr->outputEncodingState, dst, - dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL); - assert(srcRead == nlLen); + statePtr->outputEncodingFlags, + &statePtr->outputEncodingState, dst, + dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL); + + assert (srcRead == nlLen); bufPtr->nextAdded += dstWrote; src++; srcLen--; total += dstWrote; dst += dstWrote; dstLen -= dstWrote; - nextNewLine = (char *)memchr(src, '\n', srcLen); + nextNewLine = 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. + * 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 = 1 + ~SpaceLeft(bufPtr); - memcpy(safe, dst + dstLen, saved); + saved = -SpaceLeft(bufPtr); + memcpy(safe, dst + dstLen, (size_t) saved); bufPtr->nextAdded = bufPtr->bufLength; } if ((srcLen + saved == 0) && (result == TCL_OK)) { endEncoding = 0; @@ -4418,20 +3948,19 @@ return -1; } flushed += statePtr->bufSize; /* - * We just flushed. So if we have needNlFlush set to record that - * we need to flush because theres a (translated) newline in the - * buffer, that's likely not true any more. But there is a tricky - * exception. If we have saved bytes that did not really get - * flushed and those bytes came from a translation of a newline as - * the last thing taken from the src array, then needNlFlush needs - * to remain set to flag that the next buffer still needs a - * newline flush. + * We just flushed. So if we have needNlFlush set to record + * that we need to flush because theres a (translated) newline + * in the buffer, that's likely not true any more. But there + * is a tricky exception. If we have saved bytes that did not + * really get flushed and those bytes came from a translation + * of a newline as the last thing taken from the src array, + * then needNlFlush needs to remain set to flag that the + * next buffer still needs a newline flush. */ - if (needNlFlush && (saved == 0 || src[-1] != '\n')) { needNlFlush = 0; } } ReleaseChannelBuffer(bufPtr); @@ -4441,12 +3970,10 @@ if (FlushChannel(NULL, chanPtr, 0) != 0) { return -1; } } - UpdateInterest(chanPtr); - return total; } /* *--------------------------------------------------------------------------- @@ -4465,25 +3992,27 @@ * the channel. * *--------------------------------------------------------------------------- */ -size_t +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; - size_t charsStored; + int charsStored, length; + char *string; TclNewObj(objPtr); charsStored = Tcl_GetsObj(chan, objPtr); - if (charsStored + 1 > 1) { - TclDStringAppendObj(lineRead, objPtr); + if (charsStored > 0) { + string = TclGetStringFromObj(objPtr, &length); + Tcl_DStringAppend(lineRead, string, length); } TclDecrRefCount(objPtr); return charsStored; } @@ -4508,11 +4037,11 @@ * leave channel pointing after EOL, but don't return EOL in dst buffer. * *--------------------------------------------------------------------------- */ -size_t +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. */ { @@ -4519,33 +4048,32 @@ GetsState gs; Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* State info for channel */ ChannelBuffer *bufPtr; - int inEofChar, skip, copiedTotal, oldFlags, oldRemoved; - size_t oldLength; + 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 TCL_IO_FAILURE; + 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)); + assert( statePtr->inputEncodingFlags & TCL_ENCODING_END ); + assert( !GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR) ); /* TODO: Do we need this? */ UpdateInterest(chanPtr); - return TCL_IO_FAILURE; + 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 @@ -4571,11 +4099,11 @@ /* * Preserved so we can restore the channel's state in case we don't find a * newline in the available input. */ - (void)TclGetStringFromObj(objPtr, &oldLength); + TclGetStringFromObj(objPtr, &oldLength); oldFlags = statePtr->inputEncodingFlags; oldState = statePtr->inputEncodingState; oldRemoved = BUFFER_PADDING; if (bufPtr != NULL) { oldRemoved = bufPtr->nextRemoved; @@ -4668,11 +4196,11 @@ * LF at the begining of the next buffer, unless EOF char * was found already. */ if (eol >= dstEnd) { - size_t offset; + int offset; if (eol != eof) { offset = eol - objPtr->bytes; dst = dstEnd; if (FilterInputBytes(chanPtr, &gs) != 0) { @@ -4702,23 +4230,23 @@ if ((eol < dstEnd) && (*eol == '\n')) { /* * Skip the raw bytes that make up the '\n'. */ + char tmp[1 + TCL_UTF_MAX]; 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); + gs.rawRead, statePtr->inputEncodingFlags, + &gs.state, tmp, 1 + TCL_UTF_MAX, &rawRead, NULL, + NULL); bufPtr->nextRemoved += rawRead; gs.rawRead -= rawRead; gs.bytesWrote--; gs.charsWrote--; - memmove(dst, dst + 1, dstEnd - dst); + memmove(dst, dst + 1, (size_t) (dstEnd - dst)); dstEnd--; } } for (eol = dst; eol < dstEnd; eol++) { if (*eol == '\r') { @@ -4810,13 +4338,12 @@ if (bufPtr == NULL) { Tcl_Panic("Tcl_GetsObj: gotEOL reached with bufPtr==NULL"); } statePtr->inputEncodingState = gs.state; Tcl_ExternalToUtf(NULL, gs.encoding, RemovePoint(bufPtr), gs.rawRead, - statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE, - &statePtr->inputEncodingState, dst, - eol - dst + skip + TCL_UTF_MAX - 1, &gs.rawRead, NULL, + statePtr->inputEncodingFlags, &statePtr->inputEncodingState, dst, + eol - dst + skip + TCL_UTF_MAX, &gs.rawRead, NULL, &gs.charsWrote); bufPtr->nextRemoved += gs.rawRead; /* * Recycle all the emptied buffers. @@ -4877,21 +4404,21 @@ * Update the notifier state so we don't block while there is still data * in the buffers. */ done: - assert(!GotFlag(statePtr, CHANNEL_EOF) - || GotFlag(statePtr, CHANNEL_STICKY_EOF) - || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); - assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) - == (CHANNEL_EOF|CHANNEL_BLOCKED))); + assert(!GotFlag(statePtr, CHANNEL_EOF) + || GotFlag(statePtr, CHANNEL_STICKY_EOF) + || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); + + assert( !(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) + == (CHANNEL_EOF|CHANNEL_BLOCKED)) ); /* * Regenerate the top channel, in case it was changed due to * self-modifying reflected transforms. */ - if (chanPtr != statePtr->topChanPtr) { TclChannelRelease((Tcl_Channel)chanPtr); chanPtr = statePtr->topChanPtr; TclChannelPreserve((Tcl_Channel)chanPtr); } @@ -4907,13 +4434,14 @@ * * A variation of Tcl_GetsObj that works directly on the buffers until * end-of-line or end-of-file has been seen. Bytes read from the input * channel return as a ByteArray obj. * - * WARNING! The notion of "binary" used here is different from notions - * of "binary" used in other places. In particular, this "binary" routine - * may be called when an -eofchar is set on the channel. + * WARNING! The notion of "binary" used here is different from + * notions of "binary" used in other places. In particular, this + * "binary" routine may be called when an -eofchar is set on the + * channel. * * Results: * Number of characters accumulated in the object or -1 if error, * blocked, or EOF. If -1, use Tcl_GetErrno() to retrieve the POSIX error * code for the error or condition that occurred. @@ -4935,13 +4463,12 @@ { Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* State info for channel */ ChannelBuffer *bufPtr; - int inEofChar, skip, copiedTotal, oldFlags, oldRemoved; - size_t rawLen, byteLen = 0, oldLength; - int eolChar; + 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. */ @@ -4954,11 +4481,11 @@ /* * Preserved so we can restore the channel's state in case we don't find a * newline in the available input. */ - byteArray = TclGetByteArrayFromObj(objPtr, &byteLen); + byteArray = Tcl_GetByteArrayFromObj(objPtr, &byteLen); oldFlags = statePtr->inputEncodingFlags; oldRemoved = BUFFER_PADDING; oldLength = byteLen; if (bufPtr != NULL) { oldRemoved = bufPtr->nextRemoved; @@ -4966,22 +4493,18 @@ rawLen = 0; skip = 0; eof = NULL; inEofChar = statePtr->inEofChar; - - /* - * Only handle TCL_TRANSLATE_LF and TCL_TRANSLATE_CR. - */ - + /* Only handle TCL_TRANSLATE_LF and TCL_TRANSLATE_CR */ eolChar = (statePtr->inputTranslation == TCL_TRANSLATE_LF) ? '\n' : '\r'; ResetFlag(statePtr, CHANNEL_BLOCKED); while (1) { /* - * Subtract the number of bytes that were removed from channel buffer - * during last call. + * Subtract the number of bytes that were removed from channel + * buffer during last call. */ if (bufPtr != NULL) { bufPtr->nextRemoved += rawLen; if (!IsBufferReady(bufPtr)) { @@ -4989,33 +4512,32 @@ } } if ((bufPtr == NULL) || (bufPtr->nextAdded == BUFFER_PADDING)) { /* - * All channel buffers were exhausted and the caller still hasn't - * seen EOL. Need to read more bytes from the channel device. Side - * effect is to allocate another channel buffer. + * All channel buffers were exhausted and the caller still + * hasn't seen EOL. Need to read more bytes from the channel + * device. Side effect is to allocate another channel buffer. */ - if (GetInput(chanPtr) != 0) { goto restore; } bufPtr = statePtr->inQueueTail; if (bufPtr == NULL) { goto restore; } } else { /* - * Incoming CHANNEL_STICKY_EOF is filtered out on entry. A new - * CHANNEL_STICKY_EOF set in this routine leads to return before - * coming back here. When we are not dealing with - * CHANNEL_STICKY_EOF, a CHANNEL_EOF implies an empty buffer. - * Here the buffer is non-empty so we know we're a non-EOF. - */ - - assert(!GotFlag(statePtr, CHANNEL_STICKY_EOF)); - assert(!GotFlag(statePtr, CHANNEL_EOF)); + * Incoming CHANNEL_STICKY_EOF is filtered out on entry. + * A new CHANNEL_STICKY_EOF set in this routine leads to + * return before coming back here. When we are not dealing + * with CHANNEL_STICKY_EOF, a CHANNEL_EOF implies an + * empty buffer. Here the buffer is non-empty so we know + * we're a non-EOF */ + + assert ( !GotFlag(statePtr, CHANNEL_STICKY_EOF) ); + assert ( !GotFlag(statePtr, CHANNEL_EOF) ); } dst = (unsigned char *) RemovePoint(bufPtr); dstEnd = dst + BytesLeft(bufPtr); @@ -5078,17 +4600,17 @@ == (CHANNEL_BLOCKED|CHANNEL_NONBLOCKING)) { goto restore; } /* - * Copy bytes from the channel buffer to the ByteArray. This may - * realloc space, so keep track of result. + * Copy bytes from the channel buffer to the ByteArray. + * This may realloc space, so keep track of result. */ rawLen = dstEnd - dst; byteArray = Tcl_SetByteArrayLength(objPtr, byteLen + rawLen); - memcpy(byteArray + byteLen, dst, rawLen); + memcpy(byteArray + byteLen, dst, (size_t) rawLen); byteLen += rawLen; } /* * Found EOL or EOF, but the output buffer may now contain too many bytes. @@ -5101,11 +4623,11 @@ Tcl_Panic("TclGetsObjBinary: gotEOL reached with bufPtr==NULL"); } rawLen = eol - dst; byteArray = Tcl_SetByteArrayLength(objPtr, byteLen + rawLen); - memcpy(byteArray + byteLen, dst, rawLen); + memcpy(byteArray + byteLen, dst, (size_t) rawLen); byteLen += rawLen; bufPtr->nextRemoved += rawLen + skip; /* * Convert the buffer if there was an encoding. @@ -5163,15 +4685,15 @@ * Update the notifier state so we don't block while there is still data * in the buffers. */ done: - assert(!GotFlag(statePtr, CHANNEL_EOF) - || GotFlag(statePtr, CHANNEL_STICKY_EOF) - || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); - assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) - == (CHANNEL_EOF|CHANNEL_BLOCKED))); + assert(!GotFlag(statePtr, CHANNEL_EOF) + || GotFlag(statePtr, CHANNEL_STICKY_EOF) + || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); + assert( !(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) + == (CHANNEL_EOF|CHANNEL_BLOCKED)) ); UpdateInterest(chanPtr); TclChannelRelease((Tcl_Channel)chanPtr); return copiedTotal; } @@ -5189,11 +4711,11 @@ *--------------------------------------------------------------------------- */ static void FreeBinaryEncoding( - TCL_UNUSED(ClientData)) + ClientData dummy) /* Not used */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->binaryEncoding != NULL) { Tcl_FreeEncoding(tsdPtr->binaryEncoding); @@ -5300,19 +4822,19 @@ gsPtr->rawRead = 0; return -1; } } else { /* - * Incoming CHANNEL_STICKY_EOF is filtered out on entry. A new - * CHANNEL_STICKY_EOF set in this routine leads to return before - * coming back here. When we are not dealing with CHANNEL_STICKY_EOF, - * a CHANNEL_EOF implies an empty buffer. Here the buffer is - * non-empty so we know we're a non-EOF. - */ - - assert(!GotFlag(statePtr, CHANNEL_STICKY_EOF)); - assert(!GotFlag(statePtr, CHANNEL_EOF)); + * Incoming CHANNEL_STICKY_EOF is filtered out on entry. + * A new CHANNEL_STICKY_EOF set in this routine leads to + * return before coming back here. When we are not dealing + * with CHANNEL_STICKY_EOF, a CHANNEL_EOF implies an + * empty buffer. Here the buffer is non-empty so we know + * we're a non-EOF */ + + assert ( !GotFlag(statePtr, CHANNEL_STICKY_EOF) ); + assert ( !GotFlag(statePtr, CHANNEL_EOF) ); } /* * Convert some of the bytes from the channel buffer to UTF-8. Space in * objPtr's string rep is used to hold the UTF-8 characters. Grow the @@ -5345,13 +4867,13 @@ dst = objPtr->bytes + offset; *gsPtr->dstPtr = dst; } gsPtr->state = statePtr->inputEncodingState; result = Tcl_ExternalToUtf(NULL, gsPtr->encoding, raw, rawLen, - statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE, - &statePtr->inputEncodingState, dst, spaceLeft, &gsPtr->rawRead, - &gsPtr->bytesWrote, &gsPtr->charsWrote); + statePtr->inputEncodingFlags, &statePtr->inputEncodingState, + dst, spaceLeft+1, &gsPtr->rawRead, &gsPtr->bytesWrote, + &gsPtr->charsWrote); /* * Make sure that if we go through 'gets', that we reset the * TCL_ENCODING_START flag still. [Bug #523988] */ @@ -5397,11 +4919,11 @@ bufPtr->nextPtr = nextPtr; statePtr->inQueueTail = nextPtr; } extra = rawLen - gsPtr->rawRead; memcpy(nextPtr->buf + (BUFFER_PADDING - extra), - raw + gsPtr->rawRead, extra); + raw + gsPtr->rawRead, (size_t) extra); nextPtr->nextRemoved -= extra; bufPtr->nextAdded -= extra; } } @@ -5545,11 +5067,11 @@ int extra; extra = SpaceLeft(bufPtr); if (extra > 0) { memcpy(InsertPoint(bufPtr), - nextPtr->buf + (BUFFER_PADDING - extra), + nextPtr->buf + BUFFER_PADDING - extra, (size_t) extra); bufPtr->nextAdded += extra; nextPtr->nextRemoved = BUFFER_PADDING; } bufPtr = nextPtr; @@ -5577,15 +5099,15 @@ * May cause input to be buffered. * *---------------------------------------------------------------------- */ -size_t +int Tcl_Read( Tcl_Channel chan, /* The channel from which to read. */ char *dst, /* Where to store input read. */ - size_t bytesToRead) /* Maximum number of bytes to read. */ + int bytesToRead) /* Maximum number of bytes to read. */ { Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* State info for channel */ @@ -5594,14 +5116,14 @@ */ chanPtr = statePtr->topChanPtr; if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) { - return TCL_IO_FAILURE; + return -1; } - return DoRead(chanPtr, dst, bytesToRead, 0); + return DoRead(chanPtr, dst, bytesToRead); } /* *---------------------------------------------------------------------- * @@ -5622,49 +5144,43 @@ * May cause input to be buffered. * *---------------------------------------------------------------------- */ -size_t +int Tcl_ReadRaw( Tcl_Channel chan, /* The channel from which to read. */ char *readBuf, /* Where to store input read. */ - size_t bytesToRead) /* Maximum number of bytes to 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 TCL_IO_FAILURE; + return -1; } - /* - * First read bytes from the push-back buffers. - */ + /* First read bytes from the push-back buffers. */ while (chanPtr->inQueueHead && bytesToRead > 0) { ChannelBuffer *bufPtr = chanPtr->inQueueHead; int bytesInBuffer = BytesLeft(bufPtr); - int toCopy = (bytesInBuffer < (int)bytesToRead) ? bytesInBuffer - : (int)bytesToRead; - - /* - * Copy the current chunk into the read buffer. - */ - - memcpy(readBuf, RemovePoint(bufPtr), toCopy); + int toCopy = (bytesInBuffer < bytesToRead) ? bytesInBuffer + : bytesToRead; + + /* Copy the current chunk into the read buffer. */ + + memcpy(readBuf, RemovePoint(bufPtr), (size_t) toCopy); bufPtr->nextRemoved += toCopy; copied += toCopy; readBuf += toCopy; bytesToRead -= toCopy; - /* - * If the current buffer is empty recycle it. - */ + /* If the current buffer is empty recycle it. */ if (IsBufferEmpty(bufPtr)) { chanPtr->inQueueHead = bufPtr->nextPtr; if (chanPtr->inQueueHead == NULL) { chanPtr->inQueueTail = NULL; @@ -5672,47 +5188,44 @@ RecycleBuffer(chanPtr->state, bufPtr, 0); } } /* - * Go to the driver only if we got nothing from pushback. Have to do it - * this way to avoid EOF mis-timings when we consider the ability that EOF - * may not be a permanent condition in the driver, and in that case we - * have to synchronize. + * Go to the driver only if we got nothing from pushback. + * Have to do it this way to avoid EOF mis-timings when we + * consider the ability that EOF may not be a permanent + * condition in the driver, and in that case we have to + * synchronize. */ if (copied) { return copied; } - /* - * This test not needed. - */ - + /* This test not needed. */ if (bytesToRead > 0) { + int nread = ChanRead(chanPtr, readBuf, bytesToRead); - if (nread == -1) { + 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. + * 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 if (nread > 0) { - /* - * Successful read (short is OK) - add to bytes copied. - */ - - copied += nread; } else { /* * nread == 0. Driver is at EOF. Let that state filter up. */ } @@ -5740,15 +5253,15 @@ * May cause input to be buffered. * *--------------------------------------------------------------------------- */ -size_t +int Tcl_ReadChars( Tcl_Channel chan, /* The channel to read. */ Tcl_Obj *objPtr, /* Input data is stored in this object. */ - size_t toRead, /* Maximum number of characters to store, or + 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 @@ -5800,11 +5313,11 @@ static int DoReadChars( Channel *chanPtr, /* The channel to read. */ Tcl_Obj *objPtr, /* Input data is stored in this object. */ - size_t toRead, /* Maximum number of characters to store, or + 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 @@ -5818,18 +5331,14 @@ int binaryMode; #define UTF_EXPANSION_FACTOR 1024 int factor = UTF_EXPANSION_FACTOR; binaryMode = (encoding == NULL) - && (statePtr->inputTranslation == TCL_TRANSLATE_LF) + && (statePtr->inputTranslation == TCL_TRANSLATE_LF) && (statePtr->inEofChar == '\0'); - if (appendFlag) { - if (binaryMode && (NULL == TclGetBytesFromObj(NULL, objPtr, NULL))) { - binaryMode = 0; - } - } else { + if (appendFlag == 0) { if (binaryMode) { Tcl_SetByteArrayLength(objPtr, 0); } else { Tcl_SetObjLength(objPtr, 0); @@ -5846,27 +5355,25 @@ } /* * Early out when next read will see eofchar. * - * NOTE: See DoRead for argument that it's a bug (one we're keeping) to - * have this escape before the one for zero-char read request. + * NOTE: See DoRead for argument that it's a bug (one we're keeping) + * to have this escape before the one for zero-char read request. */ if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) { SetFlag(statePtr, CHANNEL_EOF); - assert(statePtr->inputEncodingFlags & TCL_ENCODING_END); - assert(!GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR)); + assert( statePtr->inputEncodingFlags & TCL_ENCODING_END ); + assert( !GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR) ); /* TODO: We don't need this call? */ UpdateInterest(chanPtr); return 0; } - /* - * Special handling for zero-char read request. - */ + /* Special handling for zero-char read request. */ if (toRead == 0) { if (GotFlag(statePtr, CHANNEL_EOF)) { statePtr->inputEncodingFlags |= TCL_ENCODING_START; } ResetFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_EOF); @@ -5881,20 +5388,17 @@ */ chanPtr = statePtr->topChanPtr; TclChannelPreserve((Tcl_Channel)chanPtr); - /* - * Must clear the BLOCKED|EOF flags here since we check before reading. - */ - + /* Must clear the BLOCKED flag here since we check before reading */ if (GotFlag(statePtr, CHANNEL_EOF)) { statePtr->inputEncodingFlags |= TCL_ENCODING_START; } ResetFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_EOF); statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; - for (copied = 0; toRead > 0; ) { + for (copied = 0; (unsigned) toRead > 0; ) { copiedNow = -1; if (statePtr->inQueueHead != NULL) { if (binaryMode) { copiedNow = ReadBytes(statePtr, objPtr, toRead); } else { @@ -5905,12 +5409,13 @@ * If the current buffer is empty recycle it. */ bufPtr = statePtr->inQueueHead; if (IsBufferEmpty(bufPtr)) { - ChannelBuffer *nextPtr = bufPtr->nextPtr; + ChannelBuffer *nextPtr; + nextPtr = bufPtr->nextPtr; RecycleBuffer(statePtr, bufPtr, 0); statePtr->inQueueHead = nextPtr; if (nextPtr == NULL) { statePtr->inQueueTail = NULL; } @@ -5942,24 +5447,22 @@ toRead -= copiedNow; } } /* - * Failure to fill a channel buffer may have left channel reporting a - * "blocked" state, but so long as we fulfilled the request here, the - * caller does not consider us blocked. + * Failure to fill a channel buffer may have left channel reporting + * a "blocked" state, but so long as we fulfilled the request here, + * the caller does not consider us blocked. */ - if (toRead == 0) { ResetFlag(statePtr, CHANNEL_BLOCKED); } /* * Regenerate the top channel, in case it was changed due to * self-modifying reflected transforms. */ - if (chanPtr != statePtr->topChanPtr) { TclChannelRelease((Tcl_Channel)chanPtr); chanPtr = statePtr->topChanPtr; TclChannelPreserve((Tcl_Channel)chanPtr); } @@ -5966,16 +5469,15 @@ /* * Update the notifier state so we don't block while there is still data * in the buffers. */ - - assert(!GotFlag(statePtr, CHANNEL_EOF) - || GotFlag(statePtr, CHANNEL_STICKY_EOF) - || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); - assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) - == (CHANNEL_EOF|CHANNEL_BLOCKED))); + assert(!GotFlag(statePtr, CHANNEL_EOF) + || GotFlag(statePtr, CHANNEL_STICKY_EOF) + || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); + assert( !(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) + == (CHANNEL_EOF|CHANNEL_BLOCKED)) ); UpdateInterest(chanPtr); TclChannelRelease((Tcl_Channel)chanPtr); return copied; } @@ -6008,11 +5510,11 @@ 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 -1 to + 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 @@ -6085,170 +5587,171 @@ Tcl_EncodingState savedState = statePtr->inputEncodingState; ChannelBuffer *bufPtr = statePtr->inQueueHead; int savedIEFlags = statePtr->inputEncodingFlags; int savedFlags = statePtr->flags; char *dst, *src = RemovePoint(bufPtr); - size_t numBytes; - int srcLen = BytesLeft(bufPtr); + int dstLimit, 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. + * 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. */ - int toRead = ((charsToRead<0)||(charsToRead > srcLen)) ? srcLen : charsToRead; + int toRead = ((unsigned) charsToRead > (unsigned) srcLen) ? srcLen : charsToRead; /* * 'factor' is how much we guess that the bytes in the source buffer will * expand when converted to UTF-8 chars. This guess comes from analyzing * how many characters were produced by the previous pass. */ - + int factor = *factorPtr; - int dstLimit = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR; + int dstNeeded = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR; (void) TclGetStringFromObj(objPtr, &numBytes); - Tcl_AppendToObj(objPtr, NULL, dstLimit); + Tcl_AppendToObj(objPtr, NULL, dstNeeded); if (toRead == srcLen) { - size_t size; - + unsigned int size; dst = TclGetStringStorage(objPtr, &size) + numBytes; - dstLimit = size - numBytes; + dstNeeded = size - numBytes; } else { dst = TclGetString(objPtr) + numBytes; } /* - * This routine is burdened with satisfying several constraints. It cannot - * append more than 'charsToRead` chars onto objPtr. This is measured - * after encoding and translation transformations are completed. There is - * no precise number of src bytes that can be associated with the limit. - * Yet, when we are done, we must know precisely the number of src bytes - * that were consumed to produce the appended chars, so that all - * subsequent bytes are left in the buffers for future read operations. - * - * The consequence is that we have no choice but to implement a "trial and - * error" approach, where in general we may need to perform - * transformations and copies multiple times to achieve a consistent set - * of results. This takes the shape of a loop. - */ - + * This routine is burdened with satisfying several constraints. + * It cannot append more than 'charsToRead` chars onto objPtr. + * This is measured after encoding and translation transformations + * are completed. There is no precise number of src bytes that can + * be associated with the limit. Yet, when we are done, we must know + * precisely the number of src bytes that were consumed to produce + * the appended chars, so that all subsequent bytes are left in + * the buffers for future read operations. + * + * The consequence is that we have no choice but to implement a + * "trial and error" approach, where in general we may need to + * perform transformations and copies multiple times to achieve + * a consistent set of results. This takes the shape of a loop. + */ + + dstLimit = dstNeeded + 1; while (1) { int dstDecoded, dstRead, dstWrote, srcRead, numChars, code; - int flags = statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE; - - if (charsToRead > 0) { - flags |= TCL_ENCODING_CHAR_LIMIT; - numChars = charsToRead; - } - - /* - * Perform the encoding transformation. Read no more than srcLen - * bytes, write no more than dstLimit bytes. - * - * Some trickiness with encoding flags here. We do not want the end - * of a buffer to be treated as the end of all input when the presence - * of bytes in a next buffer are already known to exist. This is - * checked with an assert() because so far no test case causing the - * assertion to be false has been created. The normal operations of - * channel reading appear to cause EOF and TCL_ENCODING_END setting to - * appear only in situations where there are no further bytes in any - * buffers. + + /* + * Perform the encoding transformation. Read no more than + * srcLen bytes, write no more than dstLimit bytes. + * + * Some trickiness with encoding flags here. We do not want + * the end of a buffer to be treated as the end of all input + * when the presence of bytes in a next buffer are already + * known to exist. This is checked with an assert() because + * so far no test case causing the assertion to be false has + * been created. The normal operations of channel reading + * appear to cause EOF and TCL_ENCODING_END setting to appear + * only in situations where there are no further bytes in + * any buffers. */ assert(bufPtr->nextPtr == NULL || BytesLeft(bufPtr->nextPtr) == 0 || (statePtr->inputEncodingFlags & TCL_ENCODING_END) == 0); code = Tcl_ExternalToUtf(NULL, encoding, src, srcLen, - flags, &statePtr->inputEncodingState, + statePtr->inputEncodingFlags, &statePtr->inputEncodingState, dst, dstLimit, &srcRead, &dstDecoded, &numChars); /* - * Perform the translation transformation in place. Read no more than - * the dstDecoded bytes the encoding transformation actually produced. - * Capture the number of bytes written in dstWrote. Capture the number - * of bytes actually consumed in dstRead. + * Perform the translation transformation in place. Read no more + * than the dstDecoded bytes the encoding transformation actually + * produced. Capture the number of bytes written in dstWrote. + * Capture the number of bytes actually consumed in dstRead. */ dstWrote = dstLimit; dstRead = dstDecoded; TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead); if (dstRead < dstDecoded) { + /* - * The encoding transformation produced bytes that the translation - * transformation did not consume. Why did this happen? + * The encoding transformation produced bytes that the + * translation transformation did not consume. Why did + * this happen? */ if (statePtr->inEofChar && dst[dstRead] == statePtr->inEofChar) { /* * 1) There's an eof char set on the channel, and * we saw it and stopped translating at that point. * * NOTE the bizarre spec of TranslateInputEOL in this case. - * Clearly the eof char had to be read in order to account for - * the stopping, but the value of dstRead does not include it. - * - * Also rather bizarre, our caller can only notice an EOF - * condition if we return the value -1 as the number of chars - * read. This forces us to perform a 2-call dance where the - * first call can read all the chars up to the eof char, and - * the second call is solely for consuming the encoded eof - * char then pointed at by src so that we can return that - * magic -1 value. This seems really wasteful, especially - * since the first decoding pass of each call is likely to - * decode many bytes beyond that eof char that's all we care - * about. + * Clearly the eof char had to be read in order to account + * for the stopping, but the value of dstRead does not + * include it. + * + * Also rather bizarre, our caller can only notice an + * EOF condition if we return the value -1 as the number + * of chars read. This forces us to perform a 2-call + * dance where the first call can read all the chars + * up to the eof char, and the second call is solely + * for consuming the encoded eof char then pointed at + * by src so that we can return that magic -1 value. + * This seems really wasteful, especially since + * the first decoding pass of each call is likely to + * decode many bytes beyond that eof char that's all we + * care about. */ if (dstRead == 0) { /* - * Curious choice in the eof char handling. We leave the - * eof char in the buffer. So, no need to compute a proper - * srcRead value. At this point, there are no chars before - * the eof char in the buffer. + * Curious choice in the eof char handling. We leave + * the eof char in the buffer. So, no need to compute + * a proper srcRead value. At this point, there + * are no chars before the eof char in the buffer. */ - Tcl_SetObjLength(objPtr, numBytes); return -1; } { /* - * There are chars leading the buffer before the eof char. - * Adjust the dstLimit so we go back and read only those - * and do not encounter the eof char this time. + * There are chars leading the buffer before the eof + * char. Adjust the dstLimit so we go back and read + * only those and do not encounter the eof char this + * time. */ - dstLimit = dstRead + (TCL_UTF_MAX - 1); + dstLimit = dstRead + TCL_UTF_MAX; statePtr->flags = savedFlags; statePtr->inputEncodingFlags = savedIEFlags; statePtr->inputEncodingState = savedState; continue; } } /* - * 2) The other way to read fewer bytes than are decoded is when - * the final byte is \r and we're in a CRLF translation mode so - * we cannot decide whether to record \r or \n yet. + * 2) The other way to read fewer bytes than are decoded + * is when the final byte is \r and we're in a CRLF + * translation mode so we cannot decide whether to + * record \r or \n yet. */ assert(dst[dstRead] == '\r'); assert(statePtr->inputTranslation == TCL_TRANSLATE_CRLF); if (dstWrote > 0) { /* - * There are chars we can read before we hit the bare CR. Go - * back with a smaller dstLimit so we get them in the next - * pass, compute a matching srcRead, and don't end up back - * here in this call. + * There are chars we can read before we hit the bare cr. + * Go back with a smaller dstLimit so we get them in the + * next pass, compute a matching srcRead, and don't end + * up back here in this call. */ - dstLimit = dstRead + (TCL_UTF_MAX - 1); + dstLimit = dstRead + TCL_UTF_MAX; statePtr->flags = savedFlags; statePtr->inputEncodingFlags = savedIEFlags; statePtr->inputEncodingState = savedState; continue; } @@ -6255,20 +5758,20 @@ assert(dstWrote == 0); assert(dstRead == 0); /* - * 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? + * 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) { + char buffer[TCL_UTF_MAX + 2]; int read, decoded, count; - char buffer[TCL_UTF_MAX + 1]; - /* + /* * Didn't get everything the buffer could offer */ statePtr->flags = savedFlags; statePtr->inputEncodingFlags = savedIEFlags; @@ -6277,13 +5780,12 @@ 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); + statePtr->inputEncodingFlags, &statePtr->inputEncodingState, + buffer, TCL_UTF_MAX + 2, &read, &decoded, &count); if (count == 2) { if (buffer[1] == '\n') { /* \r\n translate to \n */ dst[0] = '\n'; @@ -6291,94 +5793,94 @@ } else { dst[0] = '\r'; bufPtr->nextRemoved += srcRead; } + dst[1] = '\0'; statePtr->inputEncodingFlags &= ~TCL_ENCODING_START; Tcl_SetObjLength(objPtr, numBytes + 1); return 1; } - } else if (statePtr->flags & CHANNEL_EOF) { + } else if (GotFlag(statePtr, CHANNEL_EOF)) { + /* - * The bare \r is the only char and we will never read a - * subsequent char to make the determination. + * The bare \r is the only char and we will never read + * a subsequent char to make the determination. */ dst[0] = '\r'; bufPtr->nextRemoved = bufPtr->nextAdded; Tcl_SetObjLength(objPtr, numBytes + 1); return 1; } /* - * Revise the dstRead value so that the numChars calc below - * correctly computes zero characters read. + * Revise the dstRead value so that the numChars calc + * below correctly computes zero characters read. */ dstRead = numChars; /* FALL THROUGH - get more data (dstWrote == 0) */ } - /* - * The translation transformation can only reduce the number of chars - * when it converts \r\n into \n. The reduction in the number of chars - * is the difference in bytes read and written. + /* + * The translation transformation can only reduce the number + * of chars when it converts \r\n into \n. The reduction in + * the number of chars is the difference in bytes read and written. */ numChars -= (dstRead - dstWrote); if (charsToRead > 0 && numChars > charsToRead) { - /* - * TODO: This cannot happen anymore. - * - * We read more chars than allowed. Reset limits to prevent that - * and try again. Don't forget the extra padding of TCL_UTF_MAX - * bytes demanded by the Tcl_ExternalToUtf() call! + /* + * We read more chars than allowed. Reset limits to + * prevent that and try again. Don't forget the extra + * padding of TCL_UTF_MAX bytes demanded by the + * Tcl_ExternalToUtf() call! */ - dstLimit = Tcl_UtfAtIndex(dst, charsToRead) - dst + (TCL_UTF_MAX - 1); + dstLimit = Tcl_UtfAtIndex(dst, charsToRead) + TCL_UTF_MAX - dst; statePtr->flags = savedFlags; statePtr->inputEncodingFlags = savedIEFlags; statePtr->inputEncodingState = savedState; 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') { + /* 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 (dst[0] == '\n') { assert(statePtr->inputTranslation == TCL_TRANSLATE_AUTO); + assert(dstRead == 1); 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. + /* 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. */ nextPtr = bufPtr->nextPtr; if (nextPtr == NULL) { @@ -6389,27 +5891,27 @@ return -1; } /* * Space is made at the beginning of the buffer to copy the - * previous unused bytes there. Check first if the buffer we are - * using actually has enough space at its beginning for the data - * we are copying. Because if not we will write over the buffer - * management information, especially the 'nextPtr'. - * - * Note that the BUFFER_PADDING (See AllocChannelBuffer) is used - * to prevent exactly this situation. I.e. it should never happen. - * Therefore it is ok to panic should it happen despite the - * precautions. + * previous unused bytes there. Check first if the buffer we + * are using actually has enough space at its beginning for + * the data we are copying. Because if not we will write over + * the buffer management information, especially the 'nextPtr'. + * + * Note that the BUFFER_PADDING (See AllocChannelBuffer) is + * used to prevent exactly this situation. I.e. it should never + * happen. Therefore it is ok to panic should it happen despite + * the precautions. */ if (nextPtr->nextRemoved - srcLen < 0) { Tcl_Panic("Buffer Underflow, BUFFER_PADDING not enough"); } nextPtr->nextRemoved -= srcLen; - memcpy(RemovePoint(nextPtr), src, srcLen); + memcpy(RemovePoint(nextPtr), src, (size_t) srcLen); RecycleBuffer(statePtr, bufPtr, 0); statePtr->inQueueHead = nextPtr; Tcl_SetObjLength(objPtr, numBytes); return ReadChars(statePtr, objPtr, charsToRead, factorPtr); } @@ -6416,16 +5918,14 @@ statePtr->inputEncodingFlags &= ~TCL_ENCODING_START; consume: bufPtr->nextRemoved += srcRead; - /* - * If this read contained multibyte characters, revise factorPtr so - * the next read will allocate bigger buffers. + * If this read contained multibyte characters, revise factorPtr + * so the next read will allocate bigger buffers. */ - if (numChars && numChars < srcRead) { *factorPtr = srcRead * UTF_EXPANSION_FACTOR / numChars; } Tcl_SetObjLength(objPtr, numBytes + dstWrote); return numChars; @@ -6448,11 +5948,11 @@ * None. * *--------------------------------------------------------------------------- */ -static void +static void TranslateInputEOL( ChannelState *statePtr, /* Channel being read, for EOL translation and * EOF character. */ char *dstStart, /* Output buffer filled with chars by applying * appropriate EOL translation to source @@ -6469,31 +5969,26 @@ int dstLen = *dstLenPtr; int srcLen = *srcLenPtr; int inEofChar = statePtr->inEofChar; /* - * Depending on the translation mode in use, there's no need to scan more - * srcLen bytes at srcStart than can possibly transform to dstLen bytes. - * This keeps the scan for eof char below from being pointlessly long. + * Depending on the translation mode in use, there's no need + * to scan more srcLen bytes at srcStart than can possibly transform + * to dstLen bytes. 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. - */ - + /* 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. - */ - + /* In other modes, at most 2 src bytes become a dst byte. */ if (srcLen/2 > dstLen) { srcLen = 2 * dstLen; } break; } @@ -6502,26 +5997,26 @@ /* * 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))) { + if ((eof = 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); + memcpy(dstStart, srcStart, (size_t) srcLen); } if (statePtr->inputTranslation == TCL_TRANSLATE_CR) { char *dst = dstStart; char *dstEnd = dstStart + srcLen; - while ((dst = (char *)memchr(dst, '\r', dstEnd - dst))) { + while ((dst = memchr(dst, '\r', dstEnd - dst))) { *dst++ = '\n'; } } dstLen = srcLen; break; @@ -6528,11 +6023,11 @@ 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))) { + while ((crFound = memchr(src, '\r', lesser))) { int numBytes = crFound - src; memmove(dst, src, numBytes); dst += numBytes; dstLen -= numBytes; src += numBytes; srcLen -= numBytes; @@ -6563,16 +6058,16 @@ case TCL_TRANSLATE_AUTO: { const char *crFound, *src = srcStart; char *dst = dstStart; int lesser; - if ((statePtr->flags & INPUT_SAW_CR) && srcLen) { + if (GotFlag(statePtr, INPUT_SAW_CR) && srcLen) { if (*src == '\n') { src++; srcLen--; } ResetFlag(statePtr, INPUT_SAW_CR); } lesser = (dstLen < srcLen) ? dstLen : srcLen; - while ((crFound = (const char *)memchr(src, '\r', lesser))) { + while ((crFound = memchr(src, '\r', lesser))) { int numBytes = crFound - src; memmove(dst, src, numBytes); dst[numBytes] = '\n'; dst += numBytes + 1; dstLen -= numBytes + 1; @@ -6615,23 +6110,23 @@ * * 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 TCL_IO_FAILURE on error. + * The number of bytes stored in the channel, or -1 on error. * * Side effects: * Adds input to the input queue of a channel. * *---------------------------------------------------------------------- */ -size_t +int Tcl_Ungets( Tcl_Channel chan, /* The channel for which to add the input. */ const char *str, /* The input itself. */ - size_t len, /* The length of the input. */ + 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. */ @@ -6651,28 +6146,28 @@ * CheckChannelErrors clears too many flag bits in this one case. */ flags = statePtr->flags; if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) { - len = TCL_IO_FAILURE; + len = -1; goto done; } statePtr->flags = flags; /* * Clear the EOF flags, and clear the BLOCKED bit. */ - + if (GotFlag(statePtr, CHANNEL_EOF)) { statePtr->inputEncodingFlags |= TCL_ENCODING_START; } ResetFlag(statePtr, CHANNEL_BLOCKED | CHANNEL_STICKY_EOF | CHANNEL_EOF | INPUT_SAW_CR); statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; bufPtr = AllocChannelBuffer(len); - memcpy(InsertPoint(bufPtr), str, len); + memcpy(InsertPoint(bufPtr), str, (size_t) len); bufPtr->nextAdded += len; if (statePtr->inQueueHead == NULL) { bufPtr->nextPtr = NULL; statePtr->inQueueHead = bufPtr; @@ -6727,11 +6222,11 @@ */ chanPtr = statePtr->topChanPtr; if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) { - return TCL_ERROR; + return -1; } result = FlushChannel(NULL, chanPtr, 0); if (result != 0) { return TCL_ERROR; @@ -6816,17 +6311,17 @@ int nread; /* How much was read from channel? */ ChannelBuffer *bufPtr; /* New buffer to add to input queue. */ ChannelState *statePtr = chanPtr->state; /* State info for channel */ - /* + /* * Verify that all callers know better than to call us when * it's recorded that the next char waiting to be read is the * eofchar. */ - assert(!GotFlag(statePtr, CHANNEL_STICKY_EOF)); + assert( !GotFlag(statePtr, CHANNEL_STICKY_EOF) ); /* * Prevent reading from a dead channel -- a channel that has been closed * but not yet deallocated, which can happen if the exit handler for * channel cleanup has run but the channel is still registered in some @@ -6836,32 +6331,36 @@ if (CheckForDeadChannel(NULL, statePtr)) { return EINVAL; } /* - * WARNING: There was once a comment here claiming that it was a bad idea - * to make another call to the inputproc of a channel driver when EOF has - * already been detected on the channel. Through much of Tcl's history, - * this warning was then completely negated by having all (most?) read - * paths clear the EOF setting before reaching here. So we had a guard - * that was never triggered. - * - * Don't be tempted to restore the guard. Even if EOF is set on the - * channel, continue through and call the inputproc again. This is the - * way to enable the ability to [read] again beyond the EOF, which seems a - * strange thing to do, but for which use cases exist [Tcl Bug 5adc350683] - * and which may even be essential for channels representing things like - * ttys or other devices where the stream might take the logical form of a - * series of 'files' separated by an EOF condition. - * + * WARNING: There was once a comment here claiming that it was + * a bad idea to make another call to the inputproc of a channel + * driver when EOF has already been detected on the channel. Through + * much of Tcl's history, this warning was then completely negated + * by having all (most?) read paths clear the EOF setting before + * reaching here. So we had a guard that was never triggered. + * + * Don't be tempted to restore the guard. Even if EOF is set on + * the channel, continue through and call the inputproc again. This + * is the way to enable the ability to [read] again beyond the EOF, + * which seems a strange thing to do, but for which use cases exist + * [Tcl Bug 5adc350683] and which may even be essential for channels + * representing things like ttys or other devices where the stream + * might take the logical form of a series of 'files' separated by + * an EOF condition. + */ + + /* * First check for more buffers in the pushback area of the topmost * channel in the stack and use them. They can be the result of a * transformation which went away without reading all the information * placed in the area when it was stacked. */ if (chanPtr->inQueueHead != NULL) { + /* TODO: Tests to cover this. */ assert(statePtr->inQueueHead == NULL); statePtr->inQueueHead = chanPtr->inQueueHead; statePtr->inQueueTail = chanPtr->inQueueTail; @@ -6887,13 +6386,12 @@ bufPtr = statePtr->saveInBufPtr; statePtr->saveInBufPtr = NULL; /* * Check the actual buffersize against the requested buffersize. - * Saved buffers of the wrong size are squashed. This is done to honor - * dynamic changes of the buffersize made by the user. - * + * Saved buffers of the wrong size are squashed. This is done + * to honor dynamic changes of the buffersize made by the user. * TODO: Tests to cover this. */ if ((bufPtr != NULL) && (bufPtr->bufLength - BUFFER_PADDING != statePtr->bufSize)) { @@ -6968,11 +6466,11 @@ int wasAsync; /* Was the channel nonblocking before the seek * operation? If so, must restore to * non-blocking mode after the seek. */ if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) { - return -1; + return Tcl_LongAsWide(-1); } /* * Disallow seek on dead channels - channels that have been closed but not * yet been deallocated. Such channels can be found if the exit handler @@ -6979,11 +6477,11 @@ * for channel cleanup has run but the channel is still registered in an * interpreter. */ if (CheckForDeadChannel(NULL, statePtr)) { - return -1; + return Tcl_LongAsWide(-1); } /* * This operation should occur at the top of a channel stack. */ @@ -6993,14 +6491,13 @@ /* * 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) - ) { + if (chanPtr->typePtr->seekProc == NULL) { Tcl_SetErrno(EINVAL); - return -1; + return Tcl_LongAsWide(-1); } /* * Compute how much input and output is buffered. If both input and output * is buffered, cannot compute the current position. @@ -7009,11 +6506,11 @@ inputBuffered = Tcl_InputBuffered(chan); outputBuffered = Tcl_OutputBuffered(chan); if ((inputBuffered != 0) && (outputBuffered != 0)) { Tcl_SetErrno(EFAULT); - return -1; + return Tcl_LongAsWide(-1); } /* * If we are seeking relative to the current position, compute the * corrected offset taking into account the amount of unread input. @@ -7036,12 +6533,12 @@ */ if (GotFlag(statePtr, CHANNEL_EOF)) { statePtr->inputEncodingFlags |= TCL_ENCODING_START; } - ResetFlag(statePtr, CHANNEL_EOF | CHANNEL_STICKY_EOF | CHANNEL_BLOCKED | - INPUT_SAW_CR); + statePtr->flags &= + ~(CHANNEL_EOF | CHANNEL_STICKY_EOF | CHANNEL_BLOCKED | INPUT_SAW_CR); statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; /* * If the channel is in asynchronous output mode, switch it back to * synchronous mode and cancel any async flush that may be scheduled. @@ -7052,11 +6549,11 @@ wasAsync = 0; if (GotFlag(statePtr, CHANNEL_NONBLOCKING)) { wasAsync = 1; result = StackSetBlockMode(chanPtr, TCL_MODE_BLOCKING); if (result != 0) { - return -1; + return Tcl_LongAsWide(-1); } ResetFlag(statePtr, CHANNEL_NONBLOCKING); if (GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { ResetFlag(statePtr, BG_FLUSH_SCHEDULED); } @@ -7073,15 +6570,28 @@ if (FlushChannel(NULL, chanPtr, 0) != 0) { curPos = -1; } else { /* * Now seek to the new position in the channel as requested by the - * caller. + * caller. Note that we prefer the wideSeekProc if that is available + * and non-NULL... */ - curPos = ChanSeek(chanPtr, offset, mode, &result); - if (curPos == -1) { + if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) && + chanPtr->typePtr->wideSeekProc != NULL) { + curPos = (chanPtr->typePtr->wideSeekProc) (chanPtr->instanceData, + offset, mode, &result); + } else if (offset < Tcl_LongAsWide(LONG_MIN) || + offset > Tcl_LongAsWide(LONG_MAX)) { + result = EOVERFLOW; + curPos = Tcl_LongAsWide(-1); + } else { + curPos = Tcl_LongAsWide((chanPtr->typePtr->seekProc) ( + chanPtr->instanceData, Tcl_WideAsLong(offset), mode, + &result)); + } + if (curPos == Tcl_LongAsWide(-1)) { Tcl_SetErrno(result); } } /* @@ -7093,11 +6603,11 @@ if (wasAsync) { SetFlag(statePtr, CHANNEL_NONBLOCKING); result = StackSetBlockMode(chanPtr, TCL_MODE_NONBLOCKING); if (result != 0) { - return -1; + return Tcl_LongAsWide(-1); } } return curPos; } @@ -7133,11 +6643,11 @@ /* # bytes held in buffers. */ int result; /* Of calling device driver. */ Tcl_WideInt curPos; /* Position on device. */ if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) { - return -1; + return Tcl_LongAsWide(-1); } /* * Disallow tell on dead channels -- channels that have been closed but * not yet been deallocated. Such channels can be found if the exit @@ -7144,11 +6654,11 @@ * handler for channel cleanup has run but the channel is still registered * in an interpreter. */ if (CheckForDeadChannel(NULL, statePtr)) { - return -1; + return Tcl_LongAsWide(-1); } /* * This operation should occur at the top of a channel stack. */ @@ -7158,34 +6668,45 @@ /* * 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) - ) { + if (chanPtr->typePtr->seekProc == NULL) { Tcl_SetErrno(EINVAL); - return -1; + return Tcl_LongAsWide(-1); } /* * Compute how much input and output is buffered. If both input and output * is buffered, cannot compute the current position. */ inputBuffered = Tcl_InputBuffered(chan); outputBuffered = Tcl_OutputBuffered(chan); + + if ((inputBuffered != 0) && (outputBuffered != 0)) { + /*Tcl_SetErrno(EFAULT);*/ + /*return Tcl_LongAsWide(-1);*/ + } /* * Get the current position in the device and compute the position where * the next character will be read or written. Note that we prefer the * wideSeekProc if that is available and non-NULL... */ - curPos = ChanSeek(chanPtr, 0, SEEK_CUR, &result); - if (curPos == -1) { + if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) && + chanPtr->typePtr->wideSeekProc != NULL) { + curPos = (chanPtr->typePtr->wideSeekProc) (chanPtr->instanceData, + Tcl_LongAsWide(0), SEEK_CUR, &result); + } else { + curPos = Tcl_LongAsWide((chanPtr->typePtr->seekProc) ( + chanPtr->instanceData, 0, SEEK_CUR, &result)); + } + if (curPos == Tcl_LongAsWide(-1)) { Tcl_SetErrno(result); - return -1; + return Tcl_LongAsWide(-1); } if (inputBuffered != 0) { return curPos - inputBuffered; } @@ -7193,16 +6714,58 @@ } /* *--------------------------------------------------------------------------- * + * Tcl_SeekOld, Tcl_TellOld -- + * + * Backward-compatibility versions of the seek/tell interface that do not + * support 64-bit offsets. This interface is not documented or expected + * to be supported indefinitely. + * + * Results: + * As for Tcl_Seek and Tcl_Tell respectively, except truncated to + * whatever value will fit in an 'int'. + * + * Side effects: + * As for Tcl_Seek and Tcl_Tell respectively. + * + *--------------------------------------------------------------------------- + */ + +int +Tcl_SeekOld( + Tcl_Channel chan, /* The channel on which to seek. */ + int offset, /* Offset to seek to. */ + int mode) /* Relative to which location to seek? */ +{ + Tcl_WideInt wOffset, wResult; + + wOffset = Tcl_LongAsWide((long)offset); + wResult = Tcl_Seek(chan, wOffset, mode); + return (int)Tcl_WideAsLong(wResult); +} + +int +Tcl_TellOld( + Tcl_Channel chan) /* The channel to return pos for. */ +{ + Tcl_WideInt wResult; + + wResult = Tcl_Tell(chan); + return (int)Tcl_WideAsLong(wResult); +} + +/* + *--------------------------------------------------------------------------- + * * Tcl_TruncateChannel -- * * Truncate a channel to the given length. * * Results: - * TCL_OK on success, TCL_ERROR if the operation failed (e.g., is not + * TCL_OK on success, TCL_ERROR if the operation failed (e.g. is not * supported by the type of channel, or the underlying OS operation * failed in some way). * * Side effects: * Seeks the channel to the current location. Sets errno on OS error. @@ -7228,11 +6791,11 @@ Tcl_SetErrno(EINVAL); return TCL_ERROR; } - if (!GotFlag(chanPtr->state, TCL_WRITABLE)) { + if (!(chanPtr->state->flags & TCL_WRITABLE)) { /* * We require that the file was opened of writing. Do that check now * so that we only flush if we think we're going to succeed. */ @@ -7245,11 +6808,11 @@ * pre-read input data. */ WillWrite(chanPtr); - if (WillRead(chanPtr) == -1) { + if (WillRead(chanPtr) < 0) { return TCL_ERROR; } /* * We're all flushed to disk now and we also don't have any unfortunate @@ -7325,11 +6888,11 @@ /* * Fail if the channel is not opened for desired operation. */ - if ((statePtr->flags & direction) == 0) { + if (GotFlag(statePtr, direction) == 0) { Tcl_SetErrno(EACCES); return -1; } /* @@ -7478,11 +7041,11 @@ for (bytesBuffered = 0, bufPtr = statePtr->outQueueHead; bufPtr != NULL; bufPtr = bufPtr->nextPtr) { bytesBuffered += BytesLeft(bufPtr); } if (statePtr->curOutPtr != NULL) { - ChannelBuffer *curOutPtr = statePtr->curOutPtr; + register ChannelBuffer *curOutPtr = statePtr->curOutPtr; if (IsBufferReady(curOutPtr)) { bytesBuffered += BytesLeft(curOutPtr); } } @@ -7552,13 +7115,13 @@ /* * Clip the buffer size to force it into the [1,1M] range */ if (sz < 1) { - sz = 1; + sz = 1; } else if (sz > MAX_CHANNEL_BUFFER_SIZE) { - sz = MAX_CHANNEL_BUFFER_SIZE; + sz = MAX_CHANNEL_BUFFER_SIZE; } statePtr = ((Channel *) chan)->state; if (statePtr->bufSize == sz) { @@ -7651,33 +7214,31 @@ const char *genericopt = "blocking buffering buffersize encoding eofchar translation"; const char **argv; int argc, i; Tcl_DString ds; - Tcl_Obj *errObj; Tcl_DStringInit(&ds); Tcl_DStringAppend(&ds, genericopt, -1); if (optionList && (*optionList)) { - TclDStringAppendLiteral(&ds, " "); + Tcl_DStringAppend(&ds, " ", 1); Tcl_DStringAppend(&ds, optionList, -1); } if (Tcl_SplitList(interp, Tcl_DStringValue(&ds), &argc, &argv) != TCL_OK) { Tcl_Panic("malformed option list in channel driver"); } Tcl_ResetResult(interp); - errObj = Tcl_ObjPrintf("bad option \"%s\": should be one of ", - optionName ? optionName : ""); + Tcl_AppendResult(interp, "bad option \"", optionName, + "\": should be one of ", NULL); argc--; for (i = 0; i < argc; i++) { - Tcl_AppendPrintfToObj(errObj, "-%s, ", argv[i]); + Tcl_AppendResult(interp, "-", argv[i], ", ", NULL); } - Tcl_AppendPrintfToObj(errObj, "or -%s", argv[i]); - Tcl_SetObjResult(interp, errObj); + Tcl_AppendResult(interp, "or -", argv[i], NULL); Tcl_DStringFree(&ds); - Tcl_Free((void *)argv); + ckfree((char *) argv); } Tcl_SetErrno(EINVAL); return TCL_ERROR; } @@ -7735,13 +7296,13 @@ /* * If we are in the middle of a background copy, use the saved flags. */ if (statePtr->csPtrR) { - flags = statePtr->csPtrR->readFlags; + flags = statePtr->csPtrR->readFlags; } else if (statePtr->csPtrW) { - flags = statePtr->csPtrW->writeFlags; + flags = statePtr->csPtrW->writeFlags; } else { flags = statePtr->flags; } /* @@ -7897,12 +7458,12 @@ /* * Let the driver specific handle additional options and result code * and message. */ - return chanPtr->typePtr->getOptionProc(chanPtr->instanceData, interp, - optionName, dsPtr); + return (chanPtr->typePtr->getOptionProc) (chanPtr->instanceData, + interp, optionName, dsPtr); } else { /* * No driver specific options case. */ @@ -7949,13 +7510,12 @@ * If the channel is in the middle of a background copy, fail. */ if (statePtr->csPtrR || statePtr->csPtrW) { if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unable to set channel options: background copy in" - " progress", -1)); + Tcl_AppendResult(interp, "unable to set channel options: " + "background copy in progress", NULL); } return TCL_ERROR; } /* @@ -7990,24 +7550,26 @@ } return SetBlockMode(interp, chanPtr, newMode); } else if (HaveOpt(7, "-buffering")) { len = strlen(newValue); if ((newValue[0] == 'f') && (strncmp(newValue, "full", len) == 0)) { - ResetFlag(statePtr, CHANNEL_UNBUFFERED | CHANNEL_LINEBUFFERED); + statePtr->flags &= + ~(CHANNEL_UNBUFFERED|CHANNEL_LINEBUFFERED); } else if ((newValue[0] == 'l') && (strncmp(newValue, "line", len) == 0)) { ResetFlag(statePtr, CHANNEL_UNBUFFERED); SetFlag(statePtr, CHANNEL_LINEBUFFERED); } else if ((newValue[0] == 'n') && (strncmp(newValue, "none", len) == 0)) { ResetFlag(statePtr, CHANNEL_LINEBUFFERED); SetFlag(statePtr, CHANNEL_UNBUFFERED); - } else if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "bad value for -buffering: must be one of" - " full, line, or none", -1)); - return TCL_ERROR; + } else { + if (interp) { + Tcl_AppendResult(interp, "bad value for -buffering: " + "must be one of full, line, or none", NULL); + return TCL_ERROR; + } } return TCL_OK; } else if (HaveOpt(7, "-buffersize")) { int newBufferSize; @@ -8057,18 +7619,16 @@ statePtr->outEofChar = 0; } else if (argc == 1 || argc == 2) { int outIndex = (argc - 1); int inValue = (int) argv[0][0]; int outValue = (int) argv[outIndex][0]; - if (inValue & 0x80 || outValue & 0x80) { if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "bad value for -eofchar: must be non-NUL ASCII" - " character", -1)); + Tcl_AppendResult(interp, "bad value for -eofchar: ", + "must be non-NUL ASCII character", NULL); } - Tcl_Free((void *)argv); + ckfree((char *) argv); return TCL_ERROR; } if (GotFlag(statePtr, TCL_READABLE)) { statePtr->inEofChar = inValue; } @@ -8075,19 +7635,19 @@ if (GotFlag(statePtr, TCL_WRITABLE)) { statePtr->outEofChar = outValue; } } else { if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( + Tcl_AppendResult(interp, "bad value for -eofchar: should be a list of zero," - " one, or two elements", -1)); + " one, or two elements", NULL); } - Tcl_Free((void *)argv); + ckfree((char *) argv); return TCL_ERROR; } if (argv != NULL) { - Tcl_Free((void *)argv); + ckfree((char *) argv); } /* * [Bug 930851] Reset EOF and BLOCKED flags. Changing the character * which signals eof can transform a current eof condition into a 'go @@ -8095,12 +7655,14 @@ */ if (GotFlag(statePtr, CHANNEL_EOF)) { statePtr->inputEncodingFlags |= TCL_ENCODING_START; } - ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_STICKY_EOF|CHANNEL_BLOCKED); + statePtr->flags &= + ~(CHANNEL_EOF | CHANNEL_STICKY_EOF | CHANNEL_BLOCKED); statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; + return TCL_OK; } else if (HaveOpt(1, "-translation")) { const char *readMode, *writeMode; if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { @@ -8113,21 +7675,20 @@ } else if (argc == 2) { readMode = GotFlag(statePtr, TCL_READABLE) ? argv[0] : NULL; writeMode = GotFlag(statePtr, TCL_WRITABLE) ? argv[1] : NULL; } else { if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( + Tcl_AppendResult(interp, "bad value for -translation: must be a one or two" - " element list", -1)); + " element list", NULL); } - Tcl_Free((void *)argv); + ckfree((char *) argv); return TCL_ERROR; } if (readMode) { TclEolTranslation translation; - if (*readMode == '\0') { translation = statePtr->inputTranslation; } else if (strcmp(readMode, "auto") == 0) { translation = TCL_TRANSLATE_AUTO; } else if (strcmp(readMode, "binary") == 0) { @@ -8143,15 +7704,16 @@ translation = TCL_TRANSLATE_CRLF; } else if (strcmp(readMode, "platform") == 0) { translation = TCL_PLATFORM_TRANSLATION; } else { if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "bad value for -translation: must be one of " - "auto, binary, cr, lf, crlf, or platform", -1)); + Tcl_AppendResult(interp, + "bad value for -translation: " + "must be one of auto, binary, cr, lf, crlf," + " or platform", NULL); } - Tcl_Free((void *)argv); + ckfree((char *) argv); return TCL_ERROR; } /* * Reset the EOL flags since we need to look at any buffered data @@ -8193,23 +7755,24 @@ statePtr->outputTranslation = TCL_TRANSLATE_CRLF; } else if (strcmp(writeMode, "platform") == 0) { statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION; } else { if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "bad value for -translation: must be one of " - "auto, binary, cr, lf, crlf, or platform", -1)); + Tcl_AppendResult(interp, + "bad value for -translation: " + "must be one of auto, binary, cr, lf, crlf," + " or platform", NULL); } - Tcl_Free((void *)argv); + ckfree((char *) argv); return TCL_ERROR; } } - Tcl_Free((void *)argv); + ckfree((char *) argv); return TCL_OK; } else if (chanPtr->typePtr->setOptionProc != NULL) { - return chanPtr->typePtr->setOptionProc(chanPtr->instanceData, interp, - optionName, newValue); + return (*chanPtr->typePtr->setOptionProc)(chanPtr->instanceData, + interp, optionName, newValue); } else { return Tcl_BadChannelOption(interp, optionName, NULL); } return TCL_OK; @@ -8260,11 +7823,11 @@ Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, TclChannelEventScriptInvoker, sPtr); TclDecrRefCount(sPtr->scriptPtr); - Tcl_Free(sPtr); + ckfree((char *) sPtr); } else { prevPtr = sPtr; } } } @@ -8313,18 +7876,18 @@ * * This behaviour also allows the transformation channels to generate * their own events and pass them upward. */ - while (mask && (chanPtr->upChanPtr != NULL)) { + while (mask && (chanPtr->upChanPtr != (NULL))) { Tcl_DriverHandlerProc *upHandlerProc; upChanPtr = chanPtr->upChanPtr; upTypePtr = upChanPtr->typePtr; upHandlerProc = Tcl_ChannelHandlerProc(upTypePtr); if (upHandlerProc != NULL) { - mask = upHandlerProc(upChanPtr->instanceData, mask); + mask = (*upHandlerProc) (upChanPtr->instanceData, mask); } /* * ELSE: Ignore transformations which are unable to handle the event * coming from below. Assume that they don't change the mask and pass @@ -8353,17 +7916,10 @@ */ 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. */ @@ -8374,11 +7930,11 @@ } } /* * Add this invocation to the list of recursive invocations of - * Tcl_NotifyChannel. + * ChannelHandlerEventProc. */ nh.nextHandlerPtr = NULL; nh.nestedHandlerPtr = tsdPtr->nestedHandlerPtr; tsdPtr->nestedHandlerPtr = &nh; @@ -8389,22 +7945,15 @@ * have occurred on the channel, invoke its procedure. */ if ((chPtr->mask & mask) != 0) { nh.nextHandlerPtr = chPtr->nextPtr; - chPtr->proc(chPtr->clientData, chPtr->mask & mask); + (*(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 @@ -8418,11 +7967,10 @@ * UpdateInterest() call, one would think. */ UpdateInterest(chanPtr); } -done: Tcl_Release(statePtr); TclChannelRelease(channel); tsdPtr->nestedHandlerPtr = nh.nestedHandlerPtr; } @@ -8495,13 +8043,13 @@ * * In that case we can get into a situation where * * - Tcl drops READABLE here, because it has data in its own * buffers waiting to be read by the extension. - * - A READABLE event is synthesized via timer. + * - A READABLE event is syntesized via timer. * - The OS still reports the EXCEPTION condition on the file. - * - And the extension gets the EXCEPTION event first, and handles + * - And the extension gets the EXCPTION event first, and handles * this as EOF. * * End result ==> Premature end of reading from a file. * * The concrete example is 'Expect', and its [expect] command @@ -8518,26 +8066,16 @@ */ mask &= ~TCL_EXCEPTION; if (!statePtr->timer) { - statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, - ChannelTimerProc, chanPtr); + statePtr->timer = Tcl_CreateTimerHandler(0, ChannelTimerProc, + chanPtr); } } } - - if (!statePtr->timer - && mask & TCL_WRITABLE - && GotFlag(statePtr, CHANNEL_NONBLOCKING)) { - - statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, - ChannelTimerProc,chanPtr); - } - - - ChanWatch(chanPtr, mask); + (chanPtr->typePtr->watchProc)(chanPtr->instanceData, mask); } /* *---------------------------------------------------------------------- * @@ -8557,45 +8095,31 @@ static void ChannelTimerProc( ClientData clientData) { - Channel *chanPtr = (Channel *)clientData; + Channel *chanPtr = clientData; ChannelState *statePtr = chanPtr->state; /* State info for channel */ - Tcl_Preserve(statePtr); - statePtr->timer = NULL; - if (statePtr->interestMask & TCL_WRITABLE - && GotFlag(statePtr, CHANNEL_NONBLOCKING) - && !GotFlag(statePtr, BG_FLUSH_SCHEDULED) - ) { - /* - * Restart the timer in case a channel handler reenters the event loop - * before UpdateInterest gets called by Tcl_NotifyChannel. - */ - statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, - ChannelTimerProc,chanPtr); - Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_WRITABLE); - } - if (!GotFlag(statePtr, CHANNEL_NEED_MORE_DATA) && (statePtr->interestMask & TCL_READABLE) && (statePtr->inQueueHead != NULL) && IsBufferReady(statePtr->inQueueHead)) { /* * Restart the timer in case a channel handler reenters the event loop * before UpdateInterest gets called by Tcl_NotifyChannel. */ - statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, - ChannelTimerProc,chanPtr); + statePtr->timer = Tcl_CreateTimerHandler(0, ChannelTimerProc,chanPtr); + Tcl_Preserve(statePtr); Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE); + Tcl_Release(statePtr); } else { + statePtr->timer = NULL; UpdateInterest(chanPtr); } - Tcl_Release(statePtr); } /* *---------------------------------------------------------------------- * @@ -8645,11 +8169,11 @@ (chPtr->clientData == clientData)) { break; } } if (chPtr == NULL) { - chPtr = (ChannelHandler *)Tcl_Alloc(sizeof(ChannelHandler)); + chPtr = (ChannelHandler *) ckalloc(sizeof(ChannelHandler)); chPtr->mask = 0; chPtr->proc = proc; chPtr->clientData = clientData; chPtr->chanPtr = chanPtr; chPtr->nextPtr = statePtr->chPtr; @@ -8729,11 +8253,11 @@ if (chPtr == NULL) { return; } /* - * If Tcl_NotifyChannel is about to process this handler, tell it to + * If ChannelHandlerEventProc is about to process this handler, tell it to * process the next one instead - we are going to delete *this* one. */ for (nhPtr = tsdPtr->nestedHandlerPtr; nhPtr != NULL; nhPtr = nhPtr->nestedHandlerPtr) { @@ -8749,11 +8273,11 @@ if (prevChPtr == NULL) { statePtr->chPtr = chPtr->nextPtr; } else { prevChPtr->nextPtr = chPtr->nextPtr; } - Tcl_Free(chPtr); + ckfree((char *) chPtr); /* * Recompute the interest list for the channel, so that infinite loops * will not result if Tcl_DeleteChannelHandler is called inside an event. */ @@ -8800,19 +8324,18 @@ prevEsPtr = esPtr, esPtr = esPtr->nextPtr) { if ((esPtr->interp == interp) && (esPtr->mask == mask)) { if (esPtr == statePtr->scriptRecordPtr) { statePtr->scriptRecordPtr = esPtr->nextPtr; } else { - CLANG_ASSERT(prevEsPtr); prevEsPtr->nextPtr = esPtr->nextPtr; } Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, TclChannelEventScriptInvoker, esPtr); TclDecrRefCount(esPtr->scriptPtr); - Tcl_Free(esPtr); + ckfree((char *) esPtr); break; } } } @@ -8857,16 +8380,16 @@ } makeCH = (esPtr == NULL); if (makeCH) { - esPtr = (EventScriptRecord *)Tcl_Alloc(sizeof(EventScriptRecord)); + esPtr = (EventScriptRecord *) ckalloc(sizeof(EventScriptRecord)); } /* * Initialize the structure before calling Tcl_CreateChannelHandler, - * because a reflected channel calling 'chan postevent' aka + * because a reflected channel caling 'chan postevent' aka * 'Tcl_NotifyChannel' in its 'watch'Proc will invoke * 'TclChannelEventScriptInvoker' immediately, and we do not wish it to * see uninitialized memory and crash. See [Bug 2918110]. */ @@ -8904,27 +8427,23 @@ */ void TclChannelEventScriptInvoker( ClientData clientData, /* The script+interp record. */ - TCL_UNUSED(int) /*mask*/) + int mask) /* Not used. */ { - EventScriptRecord *esPtr = (EventScriptRecord *)clientData; - /* The event script + interpreter to eval it - * in. */ - Channel *chanPtr = esPtr->chanPtr; - /* The channel for which this handler is + Tcl_Interp *interp; /* Interpreter in which to eval the script. */ + Channel *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; + EventScriptRecord *esPtr; /* The event script + interpreter to eval it + * in. */ 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()); + esPtr = clientData; + chanPtr = esPtr->chanPtr; + mask = esPtr->mask; + interp = esPtr->interp; /* * 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. @@ -8944,11 +8463,11 @@ if (result != TCL_OK) { if (chanPtr->typePtr != NULL) { DeleteScriptRecord(interp, chanPtr, mask); } - Tcl_BackgroundException(interp, result); + TclBackgroundException(interp, result); } TclChannelRelease((Tcl_Channel)chanPtr); Tcl_Release(interp); } @@ -8969,26 +8488,27 @@ * May create a channel handler for the specified channel. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_FileEventObjCmd( - TCL_UNUSED(ClientData), + ClientData clientData, /* Not used. */ 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 */ Tcl_Channel chan; /* The opaque type for the channel. */ - const char *chanName; + char *chanName; int modeIndex; /* Index of mode argument. */ int mask; - static const char *const modeOptions[] = {"readable", "writable", NULL}; - static const int maskArray[] = {TCL_READABLE, TCL_WRITABLE}; + static const char *modeOptions[] = {"readable", "writable", NULL}; + static CONST int maskArray[] = {TCL_READABLE, TCL_WRITABLE}; if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 1, objv, "channelId event ?script?"); return TCL_ERROR; } @@ -9003,23 +8523,22 @@ if (chan == NULL) { return TCL_ERROR; } chanPtr = (Channel *) chan; statePtr = chanPtr->state; - if ((statePtr->flags & mask) == 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf("channel is not %s", - (mask == TCL_READABLE) ? "readable" : "writable")); + if (GotFlag(statePtr, mask) == 0) { + Tcl_AppendResult(interp, "channel is not ", + (mask == TCL_READABLE) ? "readable" : "writable", NULL); return TCL_ERROR; } /* * If we are supposed to return the script, do so. */ if (objc == 3) { EventScriptRecord *esPtr; - for (esPtr = statePtr->scriptRecordPtr; esPtr != NULL; esPtr = esPtr->nextPtr) { if ((esPtr->interp == interp) && (esPtr->mask == mask)) { Tcl_SetObjResult(interp, esPtr->scriptPtr); break; @@ -9070,11 +8589,11 @@ ClientData clientData) { /* calling CopyData with mask==0 still implies immediate invocation of the * -command callback, and completion of the fcopy. */ - CopyData((CopyState *)clientData, 0); + CopyData(clientData, 0); } /* *---------------------------------------------------------------------- * @@ -9099,35 +8618,34 @@ 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. */ + int toRead, /* Amount of data to copy, or -1 for all. */ Tcl_Obj *cmdPtr) /* Pointer to script to execute or NULL. */ { Channel *inPtr = (Channel *) inChan; Channel *outPtr = (Channel *) outChan; ChannelState *inStatePtr, *outStatePtr; int readFlags, writeFlags; CopyState *csPtr; int nonBlocking = (cmdPtr) ? CHANNEL_NONBLOCKING : 0; - int moveBytes; inStatePtr = inPtr->state; outStatePtr = outPtr->state; - if (BUSY_STATE(inStatePtr, TCL_READABLE)) { + if (BUSY_STATE(inStatePtr,TCL_READABLE)) { if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "channel \"%s\" is busy", Tcl_GetChannelName(inChan))); + Tcl_AppendResult(interp, "channel \"", + Tcl_GetChannelName(inChan), "\" is busy", NULL); } return TCL_ERROR; } - if (BUSY_STATE(outStatePtr, TCL_WRITABLE)) { + if (BUSY_STATE(outStatePtr,TCL_WRITABLE)) { if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "channel \"%s\" is busy", Tcl_GetChannelName(outChan))); + Tcl_AppendResult(interp, "channel \"", + Tcl_GetChannelName(outChan), "\" is busy", NULL); } return TCL_ERROR; } readFlags = inStatePtr->flags; @@ -9156,51 +8674,36 @@ /* * Make sure the output side is unbuffered. */ - outStatePtr->flags = (outStatePtr->flags & ~CHANNEL_LINEBUFFERED) - | CHANNEL_UNBUFFERED; - - /* - * Test for conditions where we know we can just move bytes from input - * channel to output channel with no transformation or even examination - * of the bytes themselves. - */ - - moveBytes = inStatePtr->inEofChar == '\0' /* No eofChar to stop input */ - && inStatePtr->inputTranslation == TCL_TRANSLATE_LF - && outStatePtr->outputTranslation == TCL_TRANSLATE_LF - && inStatePtr->encoding == outStatePtr->encoding; + outStatePtr->flags = (outStatePtr->flags & ~(CHANNEL_LINEBUFFERED)) + | CHANNEL_UNBUFFERED; /* * 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 *)Tcl_Alloc(sizeof(CopyState) + !moveBytes * inStatePtr->bufSize); - csPtr->bufSize = !moveBytes * inStatePtr->bufSize; + csPtr = (CopyState *) ckalloc(sizeof(CopyState) + inStatePtr->bufSize); + csPtr->bufSize = inStatePtr->bufSize; csPtr->readPtr = inPtr; csPtr->writePtr = outPtr; csPtr->readFlags = readFlags; csPtr->writeFlags = writeFlags; csPtr->toRead = toRead; - csPtr->total = (Tcl_WideInt) 0; + csPtr->total = 0; csPtr->interp = interp; if (cmdPtr) { Tcl_IncrRefCount(cmdPtr); } csPtr->cmdPtr = cmdPtr; inStatePtr->csPtrR = csPtr; outStatePtr->csPtrW = csPtr; - if (moveBytes) { - return MoveBytes(csPtr); - } - /* * Special handling of -size 0 async transfers, so that the -command is * still called asynchronously. */ @@ -9231,253 +8734,22 @@ * Moves data between channels, may create channel handlers. * *---------------------------------------------------------------------- */ -static void -MBCallback( - CopyState *csPtr, - Tcl_Obj *errObj) -{ - Tcl_Obj *cmdPtr = Tcl_DuplicateObj(csPtr->cmdPtr); - Tcl_WideInt total = csPtr->total; - Tcl_Interp *interp = csPtr->interp; - int code; - - Tcl_IncrRefCount(cmdPtr); - StopCopy(csPtr); - - /* TODO: What if cmdPtr is not a list?! */ - - Tcl_ListObjAppendElement(NULL, cmdPtr, Tcl_NewWideIntObj(total)); - if (errObj) { - Tcl_ListObjAppendElement(NULL, cmdPtr, errObj); - } - - Tcl_Preserve(interp); - code = Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL); - if (code != TCL_OK) { - Tcl_BackgroundException(interp, code); - } - Tcl_Release(interp); - TclDecrRefCount(cmdPtr); -} - -static void -MBError( - CopyState *csPtr, - int mask, - int errorCode) -{ - Tcl_Channel inChan = (Tcl_Channel) csPtr->readPtr; - Tcl_Channel outChan = (Tcl_Channel) csPtr->writePtr; - Tcl_Obj *errObj; - - Tcl_SetErrno(errorCode); - - errObj = Tcl_ObjPrintf( "error %sing \"%s\": %s", - (mask & TCL_READABLE) ? "read" : "writ", - Tcl_GetChannelName((mask & TCL_READABLE) ? inChan : outChan), - Tcl_PosixError(csPtr->interp)); - - if (csPtr->cmdPtr) { - MBCallback(csPtr, errObj); - } else { - Tcl_SetObjResult(csPtr->interp, errObj); - StopCopy(csPtr); - } -} - -static void -MBEvent( - ClientData clientData, - int mask) -{ - CopyState *csPtr = (CopyState *) clientData; - Tcl_Channel inChan = (Tcl_Channel) csPtr->readPtr; - Tcl_Channel outChan = (Tcl_Channel) csPtr->writePtr; - ChannelState *inStatePtr = csPtr->readPtr->state; - - if (mask & TCL_WRITABLE) { - Tcl_DeleteChannelHandler(inChan, MBEvent, csPtr); - Tcl_DeleteChannelHandler(outChan, MBEvent, csPtr); - switch (MBWrite(csPtr)) { - case TCL_OK: - MBCallback(csPtr, NULL); - break; - case TCL_CONTINUE: - Tcl_CreateChannelHandler(inChan, TCL_READABLE, MBEvent, csPtr); - break; - } - } else if (mask & TCL_READABLE) { - if (TCL_OK == MBRead(csPtr)) { - /* When at least one full buffer is present, stop reading. */ - if (IsBufferFull(inStatePtr->inQueueHead) - || !Tcl_InputBlocked(inChan)) { - Tcl_DeleteChannelHandler(inChan, MBEvent, csPtr); - } - - /* Successful read -- set up to write the bytes we read */ - Tcl_CreateChannelHandler(outChan, TCL_WRITABLE, MBEvent, csPtr); - } - } -} - -static int -MBRead( - CopyState *csPtr) -{ - ChannelState *inStatePtr = csPtr->readPtr->state; - ChannelBuffer *bufPtr = inStatePtr->inQueueHead; - int code; - - if (bufPtr && BytesLeft(bufPtr) > 0) { - return TCL_OK; - } - - code = GetInput(inStatePtr->topChanPtr); - if (code == 0 || GotFlag(inStatePtr, CHANNEL_BLOCKED)) { - return TCL_OK; - } else { - MBError(csPtr, TCL_READABLE, code); - return TCL_ERROR; - } -} - -static int -MBWrite( - CopyState *csPtr) -{ - ChannelState *inStatePtr = csPtr->readPtr->state; - ChannelState *outStatePtr = csPtr->writePtr->state; - ChannelBuffer *bufPtr = inStatePtr->inQueueHead; - ChannelBuffer *tail = NULL; - int code; - Tcl_WideInt inBytes = 0; - - /* Count up number of bytes waiting in the input queue */ - while (bufPtr) { - inBytes += BytesLeft(bufPtr); - tail = bufPtr; - if (csPtr->toRead != -1 && csPtr->toRead < inBytes) { - /* Queue has enough bytes to complete the copy */ - break; - } - bufPtr = bufPtr->nextPtr; - } - - if (bufPtr) { - /* Split the overflowing buffer in two */ - int extra = (int) (inBytes - csPtr->toRead); - /* Note that going with int for extra assumes that inBytes is not too - * much over toRead to require a wide itself. If that gets violated - * then the calculations involving extra must be made wide too. - * - * Noted with Win32/MSVC debug build treating the warning (possible of - * data in __int64 to int conversion) as error. - */ - - bufPtr = AllocChannelBuffer(extra); - - tail->nextAdded -= extra; - memcpy(InsertPoint(bufPtr), InsertPoint(tail), extra); - bufPtr->nextAdded += extra; - bufPtr->nextPtr = tail->nextPtr; - tail->nextPtr = NULL; - inBytes = csPtr->toRead; - } - - /* Update the byte counts */ - if (csPtr->toRead != -1) { - csPtr->toRead -= inBytes; - } - csPtr->total += inBytes; - - /* Move buffers from input to output channels */ - if (outStatePtr->outQueueTail) { - outStatePtr->outQueueTail->nextPtr = inStatePtr->inQueueHead; - } else { - outStatePtr->outQueueHead = inStatePtr->inQueueHead; - } - outStatePtr->outQueueTail = tail; - inStatePtr->inQueueHead = bufPtr; - if (inStatePtr->inQueueTail == tail) { - inStatePtr->inQueueTail = bufPtr; - } - if (bufPtr == NULL) { - inStatePtr->inQueueTail = NULL; - } - - code = FlushChannel(csPtr->interp, outStatePtr->topChanPtr, 0); - if (code) { - MBError(csPtr, TCL_WRITABLE, code); - return TCL_ERROR; - } - if (csPtr->toRead == 0 || GotFlag(inStatePtr, CHANNEL_EOF)) { - return TCL_OK; - } - return TCL_CONTINUE; -} - -static int -MoveBytes( - CopyState *csPtr) /* State of copy operation. */ -{ - ChannelState *outStatePtr = csPtr->writePtr->state; - ChannelBuffer *bufPtr = outStatePtr->curOutPtr; - int errorCode; - - if (bufPtr && BytesLeft(bufPtr)) { - /* If we start with unflushed bytes in the destination - * channel, flush them out of the way first. */ - - errorCode = FlushChannel(csPtr->interp, outStatePtr->topChanPtr, 0); - if (errorCode != 0) { - MBError(csPtr, TCL_WRITABLE, errorCode); - return TCL_ERROR; - } - } - - if (csPtr->cmdPtr) { - Tcl_Channel inChan = (Tcl_Channel) csPtr->readPtr; - Tcl_CreateChannelHandler(inChan, TCL_READABLE, MBEvent, csPtr); - return TCL_OK; - } - - while (1) { - int code; - - if (TCL_ERROR == MBRead(csPtr)) { - return TCL_ERROR; - } - code = MBWrite(csPtr); - if (code == TCL_OK) { - Tcl_SetObjResult(csPtr->interp, Tcl_NewWideIntObj(csPtr->total)); - StopCopy(csPtr); - return TCL_OK; - } - if (code == TCL_ERROR) { - return TCL_ERROR; - } - /* code == TCL_CONTINUE --> continue the loop */ - } - return TCL_OK; /* Silence compiler warnings */ -} - static int CopyData( 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; - size_t sizeb; + int result = TCL_OK, size, sizeb; Tcl_WideInt total; - const char *buffer; + char *buffer; int inBinary, outBinary, sameEncoding; /* Encoding control */ int underflow; /* Input underflow */ inChan = (Tcl_Channel) csPtr->readPtr; @@ -9502,11 +8774,11 @@ if (!(inBinary || sameEncoding)) { TclNewObj(bufObj); Tcl_IncrRefCount(bufObj); } - while (csPtr->toRead != (Tcl_WideInt) 0) { + while (csPtr->toRead != 0) { /* * Check for unreported background errors. */ Tcl_GetChannelError(inChan, &msg); @@ -9526,32 +8798,30 @@ /* * In async mode, we skip reading synchronously and fake an * underflow instead to prime the readable fileevent. */ - size = 0; + size = 0; underflow = 1; } else { /* * Read up to bufSize bytes. */ - if ((csPtr->toRead == (Tcl_WideInt) -1) - || (csPtr->toRead > (Tcl_WideInt) csPtr->bufSize)) { + if ((csPtr->toRead == -1) || (csPtr->toRead > csPtr->bufSize)) { sizeb = csPtr->bufSize; } else { sizeb = csPtr->toRead; } if (inBinary || sameEncoding) { - size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb, - !GotFlag(inStatePtr, CHANNEL_NONBLOCKING)); + size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb); } else { size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb, - 0 /* No append */); + 0 /* No append */); } - underflow = (size >= 0) && ((size_t)size < sizeb); /* Input underflow */ + underflow = (size >= 0) && (size < sizeb); /* Input underflow */ } if (size < 0) { readError: if (interp) { @@ -9578,26 +8848,19 @@ */ if ((size == 0) && Tcl_Eof(inChan) && !(cmdPtr && (mask == 0))) { break; } - if (cmdPtr && (!Tcl_Eof(inChan) || (mask == 0)) && - !(mask & TCL_READABLE)) { + if (((!Tcl_Eof(inChan)) || (cmdPtr && (mask == 0))) && + !(mask & TCL_READABLE)) { if (mask & TCL_WRITABLE) { Tcl_DeleteChannelHandler(outChan, CopyEventProc, csPtr); } Tcl_CreateChannelHandler(inChan, TCL_READABLE, CopyEventProc, csPtr); } if (size == 0) { - if (!GotFlag(inStatePtr, CHANNEL_NONBLOCKING)) { - /* - * We allowed a short read. Keep trying. - */ - - continue; - } if (bufObj != NULL) { TclDecrRefCount(bufObj); bufObj = NULL; } return TCL_OK; @@ -9631,11 +8894,11 @@ * 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 == TCL_INDEX_NONE) { + if (sizeb < 0) { writeError: if (interp) { TclNewObj(errObj); Tcl_AppendStringsToObj(errObj, "error writing \"", Tcl_GetChannelName(outChan), "\": ", NULL); @@ -9651,11 +8914,11 @@ } break; } /* - * Update the current byte count. Do it now so the count is valid + * (UP) Update the current byte count. Do it now so the count is valid * before a return or break takes us out of the loop. The invariant at * the top of the loop should be that csPtr->toRead holds the number * of bytes left to copy. */ @@ -9677,11 +8940,11 @@ * stop copying and wait for the channel to become writable again. * After input underflow we already installed a readable handler * therefore we don't need a writable handler. */ - if (!underflow && GotFlag(outStatePtr, BG_FLUSH_SCHEDULED)) { + if (!underflow && (outStatePtr->flags & BG_FLUSH_SCHEDULED)) { if (!(mask & TCL_WRITABLE)) { if (mask & TCL_READABLE) { Tcl_DeleteChannelHandler(inChan, CopyEventProc, csPtr); } Tcl_CreateChannelHandler(outChan, TCL_WRITABLE, @@ -9728,11 +8991,10 @@ */ total = csPtr->total; if (cmdPtr && interp) { int code; - /* * Get a private copy of the command so we can mutate it by adding * arguments. Note that StopCopy frees our saved reference to the * original command obj. */ @@ -9746,11 +9008,11 @@ if (errObj) { Tcl_ListObjAppendElement(interp, cmdPtr, errObj); } code = Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL); if (code != TCL_OK) { - Tcl_BackgroundException(interp, code); + TclBackgroundException(interp, code); result = TCL_ERROR; } TclDecrRefCount(cmdPtr); Tcl_Release(interp); } else { @@ -9772,13 +9034,14 @@ *---------------------------------------------------------------------- * * DoRead -- * * Stores up to "bytesToRead" bytes in memory pointed to by "dst". - * These bytes come from reading the channel "chanPtr" and - * performing the configured translations. No encoding conversions - * are applied to the bytes being read. + * These bytes come from reading the channel "chanPtr" and + * performing the configured translations. + * + * No encoding conversions are applied to the bytes being read. * * Results: * The number of bytes actually stored (<= bytesToRead), * or -1 if there is an error in reading the channel. Use * Tcl_GetErrno() to retrieve the error code for the error @@ -9798,16 +9061,17 @@ */ static int DoRead( Channel *chanPtr, /* The channel from which to read. */ - char *dst, /* Where to store input read. */ - size_t bytesToRead, /* Maximum number of bytes to read. */ - int allowShortReads) /* Allow half-blocking (pipes,sockets) */ + char *dst, /* Where to store input read. */ + int bytesToRead) /* Maximum number of bytes to read. */ { 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 @@ -9819,22 +9083,19 @@ * too. Keep on keeping on for now. */ if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) { SetFlag(statePtr, CHANNEL_EOF); - assert(statePtr->inputEncodingFlags & TCL_ENCODING_END); - assert(!GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR)); + assert( statePtr->inputEncodingFlags & TCL_ENCODING_END ); + assert( !GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR) ); /* TODO: Don't need this call */ UpdateInterest(chanPtr); return 0; } - /* - * Special handling for zero-char read request. - */ - + /* Special handling for zero-char read request. */ if (bytesToRead == 0) { if (GotFlag(statePtr, CHANNEL_EOF)) { statePtr->inputEncodingFlags |= TCL_ENCODING_START; } ResetFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_EOF); @@ -9845,56 +9106,50 @@ } TclChannelPreserve((Tcl_Channel)chanPtr); while (bytesToRead) { /* - * Each pass through the loop is intended to process up to one channel - * buffer. + * Each pass through the loop is intended to process up to + * one channel buffer. */ int bytesRead, bytesWritten; ChannelBuffer *bufPtr = statePtr->inQueueHead; /* - * Don't read more data if we have what we need. + * 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 */ - ((size_t)BytesLeft(bufPtr) < bytesToRead))) { - /* Not enough bytes in it yet - * to fill the dst */ + (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); + assert (bufPtr != NULL); if (GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)) { - /* - * Further reads cannot do any more. - */ - + /* Further reads cannot do any more */ break; } if (code) { - /* - * Read error - */ - + /* Read error */ UpdateInterest(chanPtr); TclChannelRelease((Tcl_Channel)chanPtr); return -1; } - assert(IsBufferFull(bufPtr)); + assert (IsBufferFull(bufPtr)); } - assert(bufPtr != NULL); + assert (bufPtr != NULL); bytesRead = BytesLeft(bufPtr); bytesWritten = bytesToRead; TranslateInputEOL(statePtr, p, RemovePoint(bufPtr), @@ -9905,12 +9160,12 @@ if (!IsBufferEmpty(bufPtr)) { /* * Buffer is not empty. How can that be? * - * 0) We stopped early because we got all the bytes we were - * seeking. That's fine. + * 0) We stopped early because we got all the bytes + * we were seeking. That's fine. */ if (bytesToRead == 0) { break; } @@ -9922,51 +9177,39 @@ if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) { break; } /* - * 2) The buffer holds a \r while in CRLF translation, followed by - * the end of the buffer. + * 2) The buffer holds a \r while in CRLF translation, + * followed by the end of the buffer. */ 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. - */ + /* There's no more buffered data.... */ + + if (GotFlag(statePtr, CHANNEL_EOF)) { + /* ...and there never will be. */ *p++ = '\r'; bytesToRead--; bufPtr->nextRemoved++; - } else if (statePtr->flags & CHANNEL_BLOCKED) { - /* - * ...and we cannot get more now. - */ - + } else if (GotFlag(statePtr, CHANNEL_BLOCKED)) { + /* ...and we cannot get more now. */ SetFlag(statePtr, CHANNEL_NEED_MORE_DATA); break; } else { - /* - * ...so we need to get some. - */ - + /* ... so we need to get some. */ goto moreData; } } if (bufPtr->nextPtr) { - /* - * There's a next buffer. Shift orphan \r to it. - */ + /* There's a next buffer. Shift orphan \r to it. */ ChannelBuffer *nextPtr = bufPtr->nextPtr; nextPtr->nextRemoved -= 1; RemovePoint(nextPtr)[0] = '\r'; @@ -9981,18 +9224,18 @@ } RecycleBuffer(statePtr, bufPtr, 0); bufPtr = statePtr->inQueueHead; } - if ((GotFlag(statePtr, CHANNEL_NONBLOCKING) || allowShortReads) - && GotFlag(statePtr, CHANNEL_BLOCKED)) { + if (GotFlag(statePtr, CHANNEL_NONBLOCKING|CHANNEL_BLOCKED) + == (CHANNEL_NONBLOCKING|CHANNEL_BLOCKED)) { break; } /* - * When there's no buffered data to read, and we're at EOF, escape to - * the caller. + * When there's no buffered data to read, and we're at EOF, + * escape to the caller. */ if (GotFlag(statePtr, CHANNEL_EOF) && (bufPtr == NULL || IsBufferEmpty(bufPtr))) { break; @@ -10000,15 +9243,15 @@ } if (bytesToRead == 0) { ResetFlag(statePtr, CHANNEL_BLOCKED); } - assert(!GotFlag(statePtr, CHANNEL_EOF) - || GotFlag(statePtr, CHANNEL_STICKY_EOF) - || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); - assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) - == (CHANNEL_EOF|CHANNEL_BLOCKED))); + assert(!GotFlag(statePtr, CHANNEL_EOF) + || GotFlag(statePtr, CHANNEL_STICKY_EOF) + || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); + assert( !(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) + == (CHANNEL_EOF|CHANNEL_BLOCKED)) ); UpdateInterest(chanPtr); TclChannelRelease((Tcl_Channel)chanPtr); return (int)(p - dst); } @@ -10033,11 +9276,11 @@ static void CopyEventProc( ClientData clientData, int mask) { - (void) CopyData((CopyState *)clientData, mask); + (void) CopyData((CopyState *) clientData, mask); } /* *---------------------------------------------------------------------- * @@ -10058,55 +9301,51 @@ static void StopCopy( CopyState *csPtr) /* State for bg copy to stop . */ { ChannelState *inStatePtr, *outStatePtr; - Tcl_Channel inChan, outChan; - int nonBlocking; if (!csPtr) { return; } - inChan = (Tcl_Channel) csPtr->readPtr; - outChan = (Tcl_Channel) csPtr->writePtr; inStatePtr = csPtr->readPtr->state; outStatePtr = csPtr->writePtr->state; /* * Restore the old blocking mode and output buffering mode. */ - nonBlocking = csPtr->readFlags & CHANNEL_NONBLOCKING; + nonBlocking = (csPtr->readFlags & CHANNEL_NONBLOCKING); if (nonBlocking != (inStatePtr->flags & CHANNEL_NONBLOCKING)) { SetBlockMode(NULL, csPtr->readPtr, nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING); } if (csPtr->readPtr != csPtr->writePtr) { - nonBlocking = csPtr->writeFlags & CHANNEL_NONBLOCKING; + nonBlocking = (csPtr->writeFlags & CHANNEL_NONBLOCKING); if (nonBlocking != (outStatePtr->flags & CHANNEL_NONBLOCKING)) { SetBlockMode(NULL, csPtr->writePtr, nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING); } } - ResetFlag(outStatePtr, CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED); + outStatePtr->flags &= ~(CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED); outStatePtr->flags |= csPtr->writeFlags & (CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED); if (csPtr->cmdPtr) { - Tcl_DeleteChannelHandler(inChan, CopyEventProc, csPtr); - if (inChan != outChan) { - Tcl_DeleteChannelHandler(outChan, CopyEventProc, csPtr); + Tcl_DeleteChannelHandler((Tcl_Channel) csPtr->readPtr, CopyEventProc, + csPtr); + if (csPtr->readPtr != csPtr->writePtr) { + Tcl_DeleteChannelHandler((Tcl_Channel) csPtr->writePtr, + CopyEventProc, csPtr); } - Tcl_DeleteChannelHandler(inChan, MBEvent, csPtr); - Tcl_DeleteChannelHandler(outChan, MBEvent, csPtr); TclDecrRefCount(csPtr->cmdPtr); } inStatePtr->csPtrR = NULL; outStatePtr->csPtrW = NULL; - Tcl_Free(csPtr); + ckfree((char *) csPtr); } /* *---------------------------------------------------------------------- * @@ -10143,11 +9382,11 @@ chanPtr = statePtr->topChanPtr; while (chanPtr != NULL) { blockModeProc = Tcl_ChannelBlockModeProc(chanPtr->typePtr); if (blockModeProc != NULL) { - result = blockModeProc(chanPtr->instanceData, mode); + result = (*blockModeProc) (chanPtr->instanceData, mode); if (result != 0) { Tcl_SetErrno(result); return result; } } @@ -10198,13 +9437,12 @@ * area, StackSetBlockMode is restricted to the channel bypass. * We still need the interp as the destination of the move. */ if (!TclChanCaughtErrorBypass(interp, (Tcl_Channel) chanPtr)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "error setting blocking mode: %s", - Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "error setting blocking mode: ", + Tcl_PosixError(interp), NULL); } } else { /* * TIP #219. * If we have no interpreter to put a bypass message into we have @@ -10297,15 +9535,14 @@ Tcl_NewStringObj(pattern, -1)) != TCL_OK)) { goto error; } goto done; } - for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { + statePtr = ((Channel *) Tcl_GetHashValue(hPtr))->state; - if (statePtr->topChanPtr == (Channel *) tsdPtr->stdinChannel) { name = "stdin"; } else if (statePtr->topChanPtr == (Channel *) tsdPtr->stdoutChannel) { name = "stdout"; } else if (statePtr->topChanPtr == (Channel *) tsdPtr->stderrChannel) { @@ -10366,11 +9603,11 @@ */ chanPtr = ((Channel *) chan)->state->bottomChanPtr; statePtr = chanPtr->state; - hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclIO", NULL); + hTblPtr = Tcl_GetAssocData(interp, "tclIO", NULL); if (hTblPtr == NULL) { return 0; } hPtr = Tcl_FindHashEntry(hTblPtr, statePtr->channelName); if (hPtr == NULL) { @@ -10404,11 +9641,11 @@ Tcl_Channel chan) /* The channel to query */ { ChannelState *statePtr = ((Channel *) chan)->state; /* State of real channel structure. */ - return ((statePtr->refCount + 1 > 2) ? 1 : 0); + return ((statePtr->refCount > 1) ? 1 : 0); } /* *---------------------------------------------------------------------- * @@ -10447,12 +9684,15 @@ name = "stderr"; } else { name = statePtr->channelName; } + /* Bug 2333466. Include \0 in the compare to prevent partial matching + * on prefixes. + */ if ((*chanName == *name) && - (memcmp(name, chanName, chanNameLen + 1) == 0)) { + (memcmp(name, chanName, (size_t) chanNameLen+1) == 0)) { return 1; } } return 0; @@ -10500,11 +9740,53 @@ Tcl_ChannelTypeVersion Tcl_ChannelVersion( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { - return chanTypePtr->version; + if (chanTypePtr->version == TCL_CHANNEL_VERSION_2) { + return TCL_CHANNEL_VERSION_2; + } else if (chanTypePtr->version == TCL_CHANNEL_VERSION_3) { + return TCL_CHANNEL_VERSION_3; + } else if (chanTypePtr->version == TCL_CHANNEL_VERSION_4) { + return TCL_CHANNEL_VERSION_4; + } else if (chanTypePtr->version == TCL_CHANNEL_VERSION_5) { + return TCL_CHANNEL_VERSION_5; + } else { + /* + * In = (PTR2INT(minimumVersion)); } /* *---------------------------------------------------------------------- * @@ -10523,11 +9805,43 @@ Tcl_DriverBlockModeProc * Tcl_ChannelBlockModeProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { - return chanTypePtr->blockModeProc; + if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_2)) { + return chanTypePtr->blockModeProc; + } else { + /* + * The v1 structure had the blockModeProc in a different place. + */ + + return (Tcl_DriverBlockModeProc *) (chanTypePtr->version); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ChannelCloseProc -- + * + * Return the Tcl_DriverCloseProc of the channel type. + * + * Results: + * A pointer to the proc. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_DriverCloseProc * +Tcl_ChannelCloseProc( + const Tcl_ChannelType *chanTypePtr) + /* Pointer to channel type. */ +{ + return chanTypePtr->closeProc; } /* *---------------------------------------------------------------------- * @@ -10597,10 +9911,34 @@ const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { return chanTypePtr->outputProc; } + +/* + *---------------------------------------------------------------------- + * + * Tcl_ChannelSeekProc -- + * + * Return the Tcl_DriverSeekProc of the channel type. + * + * Results: + * A pointer to the proc. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_DriverSeekProc * +Tcl_ChannelSeekProc( + const Tcl_ChannelType *chanTypePtr) + /* Pointer to channel type. */ +{ + return chanTypePtr->seekProc; +} /* *---------------------------------------------------------------------- * * Tcl_ChannelSetOptionProc -- @@ -10715,11 +10053,15 @@ Tcl_DriverFlushProc * Tcl_ChannelFlushProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { - return chanTypePtr->flushProc; + if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_2)) { + return chanTypePtr->flushProc; + } else { + return NULL; + } } /* *---------------------------------------------------------------------- * @@ -10739,11 +10081,15 @@ Tcl_DriverHandlerProc * Tcl_ChannelHandlerProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { - return chanTypePtr->handlerProc; + if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_2)) { + return chanTypePtr->handlerProc; + } else { + return NULL; + } } /* *---------------------------------------------------------------------- * @@ -10763,11 +10109,15 @@ Tcl_DriverWideSeekProc * Tcl_ChannelWideSeekProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { - return chanTypePtr->wideSeekProc; + if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_3)) { + return chanTypePtr->wideSeekProc; + } else { + return NULL; + } } /* *---------------------------------------------------------------------- * @@ -10788,11 +10138,15 @@ Tcl_DriverThreadActionProc * Tcl_ChannelThreadActionProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { - return chanTypePtr->threadActionProc; + if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_4)) { + return chanTypePtr->threadActionProc; + } else { + return NULL; + } } /* *---------------------------------------------------------------------- * @@ -10905,11 +10259,11 @@ * information. Hence an error means that we've got serious breakage. */ res = Tcl_ListObjGetElements(NULL, msg, &lc, &lv); if (res != TCL_OK) { - Tcl_Panic("Tcl_SetChannelError: bad syntax of message"); + Tcl_Panic("Tcl_SetChannelError(Interp): Bad syntax of message"); } explicitResult = (1 == (lc % 2)); numOptions = lc - explicitResult; @@ -10965,11 +10319,11 @@ } if (newcode >= 0) { lcn += 2; } - lvn = (Tcl_Obj **)Tcl_Alloc(lcn * sizeof(Tcl_Obj *)); + 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 @@ -10979,21 +10333,21 @@ lignore = cignore = 0; for (i=0, j=0; i= 0) { lvn[j++] = lv[i]; - lvn[j++] = Tcl_NewWideIntObj(newlevel); + lvn[j++] = Tcl_NewIntObj(newlevel); newlevel = -1; lignore = 1; continue; } else if (lignore) { continue; } } else if (0 == strcmp(TclGetString(lv[i]), "-code")) { if (newcode >= 0) { lvn[j++] = lv[i]; - lvn[j++] = Tcl_NewWideIntObj(newcode); + lvn[j++] = Tcl_NewIntObj(newcode); newcode = -1; cignore = 1; continue; } else if (cignore) { continue; @@ -11018,11 +10372,11 @@ lvn[j++] = lv[i]; } msg = Tcl_NewListObj(j, lvn); - Tcl_Free(lvn); + ckfree((char *) lvn); return msg; } /* *---------------------------------------------------------------------- @@ -11100,11 +10454,15 @@ Tcl_DriverTruncateProc * Tcl_ChannelTruncateProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { - return chanTypePtr->truncateProc; + if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_5)) { + return chanTypePtr->truncateProc; + } else { + return NULL; + } } /* *---------------------------------------------------------------------- * @@ -11123,20 +10481,21 @@ *---------------------------------------------------------------------- */ static void DupChannelIntRep( - Tcl_Obj *srcPtr, /* Object with internal rep to copy. Must have + register 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 + register Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not * currently have an internal rep.*/ { - ResolvedChanName *resPtr; + ResolvedChanName *resPtr + = (ResolvedChanName *) srcPtr->internalRep.twoPtrValue.ptr1; - ChanGetIntRep(srcPtr, resPtr); - assert(resPtr); - ChanSetIntRep(copyPtr, resPtr); + resPtr->refCount++; + copyPtr->internalRep.twoPtrValue.ptr1 = resPtr; + copyPtr->typePtr = srcPtr->typePtr; } /* *---------------------------------------------------------------------- * @@ -11155,19 +10514,19 @@ static void FreeChannelIntRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { - ResolvedChanName *resPtr; + ResolvedChanName *resPtr + = (ResolvedChanName *) objPtr->internalRep.twoPtrValue.ptr1; - ChanGetIntRep(objPtr, resPtr); - assert(resPtr); - if (resPtr->refCount-- > 1) { + objPtr->typePtr = NULL; + if (--resPtr->refCount) { return; } - Tcl_Release(resPtr->statePtr); - Tcl_Free(resPtr); + Tcl_Release((ClientData) resPtr->statePtr); + ckfree((char *)resPtr); } #if 0 /* * For future debugging work, a simple function to print the flags of a @@ -11180,11 +10539,11 @@ int flags) { char buf[20]; int i = 0; -#define ChanFlag(chr, bit) (buf[i++] = ((flags & (bit)) ? (chr) : '_')) +#define ChanFlag(chr,bit) (buf[i++] = ((flags & (bit)) ? (chr) : '_')) ChanFlag('r', TCL_READABLE); ChanFlag('w', TCL_WRITABLE); ChanFlag('n', CHANNEL_NONBLOCKING); ChanFlag('l', CHANNEL_LINEBUFFERED); Index: generic/tclIO.h ================================================================== --- generic/tclIO.h +++ generic/tclIO.h @@ -34,25 +34,25 @@ * * Buffers data being sent to or from a channel. */ typedef struct ChannelBuffer { - size_t refCount; /* Current uses count */ + 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. */ - char buf[TCLFLEXARRAY]; /* Placeholder for real buffer. The real - * buffer occuppies this space + bufSize-1 + char buf[4]; /* Placeholder for real buffer. The real + * buffer occuppies this space + bufSize-4 * bytes. This must be the last field in the * structure. */ } ChannelBuffer; -#define CHANNELBUFFER_HEADER_SIZE offsetof(ChannelBuffer, buf) +#define CHANNELBUFFER_HEADER_SIZE (sizeof(ChannelBuffer) - 4) /* * How much extra space to allocate in buffer to hold bytes from previous * buffer (when converting to UTF-8) or to hold bytes that will go to next * buffer (when converting from UTF-8). @@ -94,13 +94,13 @@ * specific) instance data, and at a channel type structure. */ typedef struct Channel { struct ChannelState *state; /* Split out state information */ - void *instanceData; /* Instance-specific data provided by creator + ClientData instanceData; /* Instance-specific data provided by creator * of channel. */ - const Tcl_ChannelType *typePtr; /* Pointer to channel type structure. */ + Tcl_ChannelType *typePtr; /* Pointer to channel type structure. */ struct Channel *downChanPtr;/* Refers to channel this one was stacked * upon. This reference is NULL for normal * channels. See Tcl_StackChannel. */ struct Channel *upChanPtr; /* Refers to the channel above stacked this * one. NULL for the top most channel. */ @@ -111,11 +111,11 @@ */ ChannelBuffer *inQueueHead; /* Points at first buffer in input queue. */ ChannelBuffer *inQueueTail; /* Points at last buffer in input queue. */ - size_t refCount; + int refCount; } Channel; /* * struct ChannelState: * @@ -161,11 +161,11 @@ 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. */ - size_t refCount; /* How many interpreters hold references to + 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 @@ -212,11 +212,11 @@ Tcl_Obj* chanMsg; Tcl_Obj* unreportedMsg; /* Non-NULL if an error report was deferred * because it happened in the background. The * value is the chanMg, if any. #219's * companion to 'unreportedError'. */ - size_t epoch; /* Used to test validity of stored channelname + int epoch; /* Used to test validity of stored channelname * lookup results. */ } ChannelState; /* * Values for the flags field in Channel. Any ORed combination of the @@ -275,23 +275,13 @@ #define CHANNEL_INCLOSE (1<<19) /* Channel is currently being closed. * Its structures are still live and * usable, but it may not be closed * again from within the close * handler. */ -#define CHANNEL_CLOSEDWRITE (1<<21) /* Channel write side has been closed. - * No further Tcl-level write IO on - * the channel is allowed. */ - -/* - * The length of time to wait between synthetic timer events. Must be zero or - * bad things tend to happen. - */ - -#define SYNTHETIC_EVENT_TIME 0 /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclIOCmd.c ================================================================== --- generic/tclIOCmd.c +++ generic/tclIOCmd.c @@ -13,21 +13,21 @@ /* * Callback structure for accept callback in a TCP server. */ -typedef struct { - Tcl_Obj *script; /* Script to invoke. */ - Tcl_Interp *interp; /* Interpreter in which to run it. */ +typedef struct AcceptCallback { + char *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 { +typedef struct ThreadSpecificData { int initialized; /* Set to 1 when the module is initialized. */ Tcl_Obj *stdoutObjPtr; /* Cached stdout channel Tcl_Obj */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; @@ -34,18 +34,23 @@ /* * 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 FinalizeIOCmdTSD(ClientData clientData); +static void AcceptCallbackProc(ClientData callbackData, + Tcl_Channel chan, char *address, int port); +static int ChanPendingObjCmd(ClientData unused, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int ChanTruncateObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static void RegisterTcpServerInterpCleanup(Tcl_Interp *interp, + AcceptCallback *acceptCallbackPtr); +static void TcpAcceptCallbacksDeleteProc(ClientData clientData, + Tcl_Interp *interp); static void TcpServerCloseProc(ClientData callbackData); static void UnregisterTcpServerInterpCleanupProc( Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr); @@ -65,11 +70,11 @@ *---------------------------------------------------------------------- */ static void FinalizeIOCmdTSD( - TCL_UNUSED(ClientData)) + ClientData clientData) /* Not used. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->stdoutObjPtr != NULL) { Tcl_DecrRefCount(tsdPtr->stdoutObjPtr); @@ -93,13 +98,14 @@ * Produces output on a channel. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_PutsObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; /* The channel to puts on. */ @@ -106,44 +112,55 @@ Tcl_Obj *string; /* String to write. */ Tcl_Obj *chanObjPtr = NULL; /* channel object. */ int newline; /* Add a newline at end? */ int result; /* Result of puts operation. */ int mode; /* Mode in which channel is opened. */ + ThreadSpecificData *tsdPtr; switch (objc) { - case 2: /* [puts $x] */ + case 2: /* [puts $x] */ string = objv[1]; newline = 1; break; - case 3: /* [puts -nonewline $x] or [puts $chan $x] */ + case 3: /* [puts -nonewline $x] or [puts $chan $x] */ if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) { newline = 0; } else { newline = 1; chanObjPtr = objv[1]; } string = objv[2]; break; - case 4: /* [puts -nonewline $chan $x] or - * [puts $chan $x nonewline] */ + 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; + } 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; } /* Fall through */ - default: /* [puts] or - * [puts some bad number of arguments...] */ + default: + /* [puts] or [puts some bad number of arguments...] */ Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string"); return TCL_ERROR; } if (chanObjPtr == NULL) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + tsdPtr = TCL_TSD_INIT(&dataKey); if (!tsdPtr->initialized) { tsdPtr->initialized = 1; TclNewLiteralStringObj(tsdPtr->stdoutObjPtr, "stdout"); Tcl_IncrRefCount(tsdPtr->stdoutObjPtr); @@ -152,25 +169,24 @@ chanObjPtr = tsdPtr->stdoutObjPtr; } if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if (!(mode & TCL_WRITABLE)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "channel \"%s\" wasn't opened for writing", - TclGetString(chanObjPtr))); + if ((mode & TCL_WRITABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), + "\" wasn't opened for writing", NULL); return TCL_ERROR; } TclChannelPreserve(chan); result = Tcl_WriteObj(chan, string); - if (result == -1) { + if (result < 0) { goto error; } if (newline != 0) { result = Tcl_WriteChars(chan, "\n", 1); - if (result == -1) { + if (result < 0) { goto error; } } TclChannelRelease(chan); return TCL_OK; @@ -182,12 +198,13 @@ * message if nothing was found in the bypass. */ error: if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf("error writing \"%s\": %s", - TclGetString(chanObjPtr), Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "error writing \"", + TclGetString(chanObjPtr), "\": ", + Tcl_PosixError(interp), NULL); } TclChannelRelease(chan); return TCL_ERROR; } @@ -206,13 +223,14 @@ * May cause output to appear on the specified channel. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_FlushObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *chanObjPtr; @@ -225,14 +243,13 @@ } chanObjPtr = objv[1]; if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if (!(mode & TCL_WRITABLE)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "channel \"%s\" wasn't opened for writing", - TclGetString(chanObjPtr))); + if ((mode & TCL_WRITABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), + "\" wasn't opened for writing", NULL); return TCL_ERROR; } TclChannelPreserve(chan); if (Tcl_Flush(chan) != TCL_OK) { @@ -242,13 +259,13 @@ * put them into the regular interpreter result. Fall back to the * regular message if nothing was found in the bypass. */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "error flushing \"%s\": %s", - TclGetString(chanObjPtr), Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "error flushing \"", + TclGetString(chanObjPtr), "\": ", + Tcl_PosixError(interp), NULL); } TclChannelRelease(chan); return TCL_ERROR; } TclChannelRelease(chan); @@ -270,13 +287,14 @@ * May consume input from channel. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_GetsObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; /* The channel to read from. */ @@ -291,35 +309,35 @@ } chanObjPtr = objv[1]; if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if (!(mode & TCL_READABLE)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "channel \"%s\" wasn't opened for reading", - TclGetString(chanObjPtr))); + if ((mode & TCL_READABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), + "\" wasn't opened for reading", NULL); return TCL_ERROR; } TclChannelPreserve(chan); - TclNewObj(linePtr); + linePtr = Tcl_NewObj(); lineLen = Tcl_GetsObj(chan, linePtr); if (lineLen < 0) { if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) { Tcl_DecrRefCount(linePtr); /* - * TIP #219. - * Capture error messages put by the driver into the bypass area - * and put them into the regular interpreter result. Fall back to - * the regular message if nothing was found in the bypass. + * TIP #219. Capture error messages put by the driver into the + * bypass area and put them into the regular interpreter result. + * Fall back to the regular message if nothing was found in the + * bypass. */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "error reading \"%s\": %s", - TclGetString(chanObjPtr), Tcl_PosixError(interp))); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error reading \"", + TclGetString(chanObjPtr), "\": ", + Tcl_PosixError(interp), NULL); } code = TCL_ERROR; goto done; } lineLen = -1; @@ -328,11 +346,11 @@ if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr, TCL_LEAVE_ERR_MSG) == NULL) { code = TCL_ERROR; goto done; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(lineLen)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen)); } else { Tcl_SetObjResult(interp, linePtr); } done: TclChannelRelease(chan); @@ -354,13 +372,14 @@ * May consume input from channel. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_ReadObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; /* The channel to read from. */ @@ -382,10 +401,11 @@ * a subcommand produce the wrong message. */ iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS; Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? channelId"); + iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS; return TCL_ERROR; } i = 1; newline = 0; @@ -400,35 +420,45 @@ chanObjPtr = objv[i]; if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if (!(mode & TCL_READABLE)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "channel \"%s\" wasn't opened for reading", - TclGetString(chanObjPtr))); + if ((mode & TCL_READABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), + "\" wasn't opened for reading", NULL); return TCL_ERROR; } - i++; /* Consumed channel name. */ + i++; /* Consumed channel name. */ /* * 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; + if (TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK) { + /* + * 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) { + return TCL_ERROR; + } + newline = 1; + } else if (toRead < 0) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "expected non-negative integer but got \"", + TclGetString(objv[i]), "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL); + return TCL_ERROR; } } - TclNewObj(resultPtr); + resultPtr = Tcl_NewObj(); Tcl_IncrRefCount(resultPtr); TclChannelPreserve(chan); charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0); if (charactersRead < 0) { /* @@ -437,13 +467,14 @@ * put them into the regular interpreter result. Fall back to the * regular message if nothing was found in the bypass. */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "error reading \"%s\": %s", - TclGetString(chanObjPtr), Tcl_PosixError(interp))); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error reading \"", + TclGetString(chanObjPtr), "\": ", + Tcl_PosixError(interp), NULL); } TclChannelRelease(chan); Tcl_DecrRefCount(resultPtr); return TCL_ERROR; } @@ -451,12 +482,12 @@ /* * If requested, remove the last newline in the channel if at EOF. */ if ((charactersRead > 0) && (newline != 0)) { - const char *result; - size_t length; + char *result; + int length; result = TclGetStringFromObj(resultPtr, &length); if (result[length - 1] == '\n') { Tcl_SetObjLength(resultPtr, length - 1); } @@ -483,26 +514,27 @@ * flush queued output. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_SeekObjCmd( - TCL_UNUSED(ClientData), + ClientData clientData, /* Not used. */ 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? */ Tcl_WideInt result; /* Of calling Tcl_Seek. */ int optionIndex; - static const char *const originOptions[] = { + static const char *originOptions[] = { "start", "current", "end", NULL }; - static const int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END}; + static CONST int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END}; if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 1, objv, "channelId offset ?origin?"); return TCL_ERROR; } @@ -521,22 +553,21 @@ mode = modeArray[optionIndex]; } TclChannelPreserve(chan); result = Tcl_Seek(chan, offset, mode); - if (result == -1) { + if (result == Tcl_LongAsWide(-1)) { /* * TIP #219. * Capture error messages put by the driver into the bypass area and * put them into the regular interpreter result. Fall back to the * regular message if nothing was found in the bypass. */ - if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "error during seek on \"%s\": %s", - TclGetString(objv[1]), Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "error during seek on \"", + TclGetString(objv[1]), "\": ", + Tcl_PosixError(interp), NULL); } TclChannelRelease(chan); return TCL_ERROR; } TclChannelRelease(chan); @@ -558,13 +589,14 @@ * None. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_TellObjCmd( - TCL_UNUSED(ClientData), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; /* The channel to tell on. */ @@ -620,69 +652,27 @@ * May discard queued input; may flush queued output. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_CloseObjCmd( - TCL_UNUSED(ClientData), + ClientData clientData, /* Not used. */ 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 - }; - static const int dirArray[] = {TCL_CLOSE_READ, TCL_CLOSE_WRITE}; - if ((objc != 2) && (objc != 3)) { - Tcl_WrongNumArgs(interp, 1, objv, "channelId ?direction?"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "channelId"); return TCL_ERROR; } if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { return TCL_ERROR; - } - - if (objc == 3) { - int index, dir; - - /* - * Get direction requested to close, and check syntax. - */ - - if (Tcl_GetIndexFromObj(interp, objv[2], dirOptions, "direction", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } - dir = dirArray[index]; - - /* - * Check direction against channel mode. It is an error if we try to - * close a direction not supported by the channel (already closed, or - * never opened for that direction). - */ - - if (!(dir & Tcl_GetChannelMode(chan))) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "Half-close of %s-side not possible, side not opened" - " 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); - } } if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) { /* * If there is an error message and it ends with a newline, remove the @@ -694,12 +684,12 @@ * because the Tcl convention is that such error messages do not have * a terminating newline. */ Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); - const char *string; - size_t len; + char *string; + int len; if (Tcl_IsShared(resultPtr)) { resultPtr = Tcl_DuplicateObj(resultPtr); Tcl_SetObjResult(interp, resultPtr); } @@ -728,23 +718,25 @@ * May modify the behavior of an IO channel. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_FconfigureObjCmd( - TCL_UNUSED(ClientData), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *optionName, *valueName; + char *optionName, *valueName; Tcl_Channel chan; /* The channel to set a mode on. */ int i; /* Iterate over arg-value pairs. */ if ((objc < 2) || (((objc % 2) == 1) && (objc != 3))) { - Tcl_WrongNumArgs(interp, 1, objv, "channelId ?-option value ...?"); + Tcl_WrongNumArgs(interp, 1, objv, + "channelId ?optionName? ?value? ?optionName value?..."); return TCL_ERROR; } if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { return TCL_ERROR; @@ -803,13 +795,14 @@ * specified channel has an EOF condition. * *--------------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_EofObjCmd( - TCL_UNUSED(ClientData), + ClientData unused, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; @@ -842,28 +835,34 @@ * See the user documentation. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_ExecObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + /* + * This function generates an argv array for the string arguments. It + * starts out with stack-allocated space but uses dynamically-allocated + * storage if needed. + */ + Tcl_Obj *resultPtr; - const char **argv; /* An array for the string arguments. Stored - * on the _Tcl_ stack. */ - const char *string; + const char **argv; + char *string; Tcl_Channel chan; - int argc, background, i, index, keepNewline, result, skip, ignoreStderr; - size_t length; - static const char *const options[] = { + int argc, background, i, index, keepNewline, result, skip, length; + int ignoreStderr; + static const char *options[] = { "-ignorestderr", "-keepnewline", "--", NULL }; - enum execOptionsEnum { + enum options { EXEC_IGNORESTDERR, EXEC_KEEPNEWLINE, EXEC_LAST }; /* * Check for any leading option arguments. @@ -874,11 +873,11 @@ for (skip = 1; skip < objc; skip++) { string = TclGetString(objv[skip]); if (string[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, objv[skip], options, "option", + if (Tcl_GetIndexFromObj(interp, objv[skip], options, "switch", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } if (index == EXEC_KEEPNEWLINE) { keepNewline = 1; @@ -888,11 +887,11 @@ skip++; break; } } if (objc <= skip) { - Tcl_WrongNumArgs(interp, 1, objv, "?-option ...? arg ?arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "?switches? arg ?arg ...?"); return TCL_ERROR; } /* * See if the command is to be run in background. @@ -909,11 +908,12 @@ * 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 *)); + argv = (const char **) + TclStackAlloc(interp, (unsigned)(argc + 1) * sizeof(char *)); /* * Copy the string conversions of each (post option) object into the * argument vector. */ @@ -921,17 +921,17 @@ for (i = 0; i < argc; i++) { argv[i] = TclGetString(objv[i + skip]); } argv[argc] = NULL; chan = Tcl_OpenCommandChannel(interp, argc, argv, (background ? 0 : - ignoreStderr ? TCL_STDOUT : TCL_STDOUT|TCL_STDERR)); + (ignoreStderr ? TCL_STDOUT : TCL_STDOUT|TCL_STDERR))); /* * Free the argv array. */ - TclStackFree(interp, (void *) argv); + TclStackFree(interp, (void *)argv); if (chan == NULL) { return TCL_ERROR; } @@ -940,30 +940,30 @@ * Store the list of PIDs from the pipeline in interp's result and * detach the PIDs (instead of waiting for them). */ TclGetAndDetachPids(interp, chan); - if (Tcl_CloseEx(interp, chan, 0) != TCL_OK) { + if (Tcl_Close(interp, chan) != TCL_OK) { return TCL_ERROR; } return TCL_OK; } - TclNewObj(resultPtr); + resultPtr = Tcl_NewObj(); if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) { - if (Tcl_ReadChars(chan, resultPtr, -1, 0) == TCL_IO_FAILURE) { + if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) { /* * TIP #219. * Capture error messages put by the driver into the bypass area * and put them into the regular interpreter result. Fall back to * the regular message if nothing was found in the bypass. */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "error reading output from command: %s", - Tcl_PosixError(interp))); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error reading output from command: ", + Tcl_PosixError(interp), NULL); Tcl_DecrRefCount(resultPtr); } return TCL_ERROR; } } @@ -972,11 +972,11 @@ * If the process produced anything on stderr, it will have been returned * in the interpreter result. It needs to be appended to the result * string. */ - result = Tcl_CloseEx(interp, chan, 0); + result = Tcl_Close(interp, chan); Tcl_AppendObjToObj(resultPtr, Tcl_GetObjResult(interp)); /* * If the last character of the result is a newline, then remove the * newline character. @@ -1009,13 +1009,14 @@ * preceeding input operation on the channel would have blocked. * *--------------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_FblockedObjCmd( - TCL_UNUSED(ClientData), + ClientData unused, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; @@ -1027,14 +1028,13 @@ } if (TclGetChannelFromObj(interp, objv[1], &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if (!(mode & TCL_READABLE)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "channel \"%s\" wasn't opened for reading", - TclGetString(objv[1]))); + if ((mode & TCL_READABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", TclGetString(objv[1]), + "\" wasn't opened for reading", NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_InputBlocked(chan))); return TCL_OK; @@ -1055,13 +1055,14 @@ * See the user documentation. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_OpenObjCmd( - TCL_UNUSED(ClientData), + ClientData notUsed, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int pipeline, prot; @@ -1076,21 +1077,19 @@ if (objc == 2) { modeString = "r"; } else { modeString = TclGetString(objv[2]); if (objc == 4) { - const char *permString = TclGetString(objv[3]); + char *permString = TclGetString(objv[3]); int code = TCL_ERROR; int scanned = TclParseAllWhiteSpace(permString, -1); - /* - * Support legacy octal numbers. - */ - + /* Support legacy octal numbers */ if ((permString[scanned] == '0') && (permString[scanned+1] >= '0') && (permString[scanned+1] <= '7')) { + Tcl_Obj *permObj; TclNewLiteralStringObj(permObj, "0o"); Tcl_AppendToObj(permObj, permString+scanned+1, -1); code = TclGetIntFromObj(NULL, permObj, &prot); @@ -1147,17 +1146,17 @@ chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags); if (binary && chan) { Tcl_SetChannelOption(interp, chan, "-translation", "binary"); } } - Tcl_Free((void *)cmdArgv); + ckfree((char *) cmdArgv); } if (chan == NULL) { return TCL_ERROR; } Tcl_RegisterChannel(interp, chan); - Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1)); + Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -1178,28 +1177,29 @@ * subsequently to eval accept scripts. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ static void TcpAcceptCallbacksDeleteProc( ClientData clientData, /* Data which was passed when the assocdata * was registered. */ - TCL_UNUSED(Tcl_Interp *)) + Tcl_Interp *interp) /* Interpreter being deleted - not used. */ { - Tcl_HashTable *hTblPtr = (Tcl_HashTable *)clientData; + Tcl_HashTable *hTblPtr = 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); + AcceptCallback *acceptCallbackPtr = Tcl_GetHashValue(hPtr); acceptCallbackPtr->interp = NULL; } Tcl_DeleteHashTable(hTblPtr); - Tcl_Free(hTblPtr); + ckfree((char *) hTblPtr); } /* *---------------------------------------------------------------------- * @@ -1232,20 +1232,21 @@ * 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); + hTblPtr = (Tcl_HashTable *) + Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL); if (hTblPtr == NULL) { - hTblPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); + hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable)); Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS); - Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks", + (void) Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks", TcpAcceptCallbacksDeleteProc, hTblPtr); } - hPtr = Tcl_CreateHashEntry(hTblPtr, acceptCallbackPtr, &isNew); + hPtr = Tcl_CreateHashEntry(hTblPtr, (char *) acceptCallbackPtr, &isNew); if (!isNew) { Tcl_Panic("RegisterTcpServerCleanup: damaged accept record table"); } Tcl_SetHashValue(hPtr, acceptCallbackPtr); } @@ -1278,11 +1279,12 @@ * registration. */ { Tcl_HashTable *hTblPtr; Tcl_HashEntry *hPtr; - hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL); + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, + "tclTCPAcceptCallbacks", NULL); if (hTblPtr == NULL) { return; } hPtr = Tcl_FindHashEntry(hTblPtr, (char *) acceptCallbackPtr); @@ -1316,49 +1318,41 @@ 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; + AcceptCallback *acceptCallbackPtr = (AcceptCallback *) callbackData; /* * Check if the callback is still valid; the interpreter may have gone * away, this is signalled by setting the interp field of the callback * data to NULL. */ if (acceptCallbackPtr->interp != NULL) { + char portBuf[TCL_INTEGER_SPACE]; + char *script = acceptCallbackPtr->script; Tcl_Interp *interp = acceptCallbackPtr->interp; - Tcl_Obj *script, *objv[2]; - int result = TCL_OK; - - objv[0] = acceptCallbackPtr->script; - objv[1] = Tcl_NewListObj(3, NULL); - Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewStringObj( - Tcl_GetChannelName(chan), -1)); - Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewStringObj(address, -1)); - Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewWideIntObj(port)); - - script = Tcl_ConcatObj(2, objv); - Tcl_IncrRefCount(script); - Tcl_DecrRefCount(objv[1]); - + int result; + + Tcl_Preserve(script); Tcl_Preserve(interp); + + TclFormatInt(portBuf, port); Tcl_RegisterChannel(interp, chan); /* * Artificially bump the refcount to protect the channel from being * deleted while the script is being evaluated. */ Tcl_RegisterChannel(NULL, chan); - result = Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT|TCL_EVAL_GLOBAL); - Tcl_DecrRefCount(script); - + result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), + " ", address, " ", portBuf, NULL); if (result != TCL_OK) { - Tcl_BackgroundException(interp, result); + TclBackgroundException(interp, result); Tcl_UnregisterChannel(interp, chan); } /* * Decrement the artificially bumped refcount. After this it is not @@ -1366,17 +1360,18 @@ */ Tcl_UnregisterChannel(NULL, chan); Tcl_Release(interp); + Tcl_Release(script); } else { /* - * The interpreter has been deleted, so there is no useful way to use - * the client socket - just close it. + * The interpreter has been deleted, so there is no useful way to + * utilize the client socket - just close it. */ - Tcl_CloseEx(NULL, chan, 0); + Tcl_Close(NULL, chan); } } /* *---------------------------------------------------------------------- @@ -1402,19 +1397,19 @@ static void TcpServerCloseProc( ClientData callbackData) /* The data passed in the call to * Tcl_CreateCloseHandler. */ { - AcceptCallback *acceptCallbackPtr = (AcceptCallback *)callbackData; + AcceptCallback *acceptCallbackPtr = (AcceptCallback *) callbackData; /* The actual data. */ if (acceptCallbackPtr->interp != NULL) { UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp, acceptCallbackPtr); } - Tcl_DecrRefCount(acceptCallbackPtr->script); - Tcl_Free(acceptCallbackPtr); + Tcl_EventuallyFree(acceptCallbackPtr->script, TCL_DYNAMIC); + ckfree((char *) acceptCallbackPtr); } /* *---------------------------------------------------------------------- * @@ -1432,69 +1427,64 @@ *---------------------------------------------------------------------- */ int Tcl_SocketObjCmd( - TCL_UNUSED(ClientData), + ClientData notUsed, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - static const char *const socketOptions[] = { - "-async", "-myaddr", "-myport", "-reuseaddr", "-reuseport", "-server", - NULL - }; - enum socketOptionsEnum { - SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_REUSEADDR, SKT_REUSEPORT, - SKT_SERVER - }; - int optionIndex, a, server = 0, myport = 0, async = 0, reusep = -1, - reusea = -1; - unsigned int flags = 0; - const char *host, *port, *myaddr = NULL; - Tcl_Obj *script = NULL; + static const char *socketOptions[] = { + "-async", "-myaddr", "-myport","-server", NULL + }; + enum socketOptions { + SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER + }; + int optionIndex, a, server = 0, port, myport = 0, async = 0; + char *host, *script = NULL, *myaddr = NULL; Tcl_Channel chan; if (TclpHasSockets(interp) != TCL_OK) { return TCL_ERROR; } for (a = 1; a < objc; a++) { - const char *arg = TclGetString(objv[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; } - switch ((enum socketOptionsEnum) optionIndex) { + switch ((enum socketOptions) optionIndex) { case SKT_ASYNC: if (server == 1) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot set -async option for server sockets", -1)); + Tcl_AppendResult(interp, + "cannot set -async option for server sockets", NULL); return TCL_ERROR; } async = 1; break; case SKT_MYADDR: a++; if (a >= objc) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "no argument given for -myaddr option", -1)); + Tcl_AppendResult(interp, + "no argument given for -myaddr option", NULL); return TCL_ERROR; } myaddr = TclGetString(objv[a]); break; case SKT_MYPORT: { - const char *myPortName; + char *myPortName; a++; if (a >= objc) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "no argument given for -myport option", -1)); + Tcl_AppendResult(interp, + "no argument given for -myport option", NULL); return TCL_ERROR; } myPortName = TclGetString(objv[a]); if (TclSockGetPort(interp, myPortName, "tcp", &myport) != TCL_OK) { return TCL_ERROR; @@ -1501,54 +1491,32 @@ } break; } case SKT_SERVER: if (async == 1) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot set -async option for server sockets", -1)); + Tcl_AppendResult(interp, + "cannot set -async option for server sockets", NULL); return TCL_ERROR; } server = 1; a++; if (a >= objc) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "no argument given for -server option", -1)); - return TCL_ERROR; - } - script = objv[a]; - break; - case SKT_REUSEADDR: - a++; - if (a >= objc) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "no argument given for -reuseaddr option", -1)); - return TCL_ERROR; - } - if (Tcl_GetBooleanFromObj(interp, objv[a], &reusea) != TCL_OK) { - return TCL_ERROR; - } - break; - case SKT_REUSEPORT: - a++; - if (a >= objc) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "no argument given for -reuseport option", -1)); - return TCL_ERROR; - } - if (Tcl_GetBooleanFromObj(interp, objv[a], &reusep) != TCL_OK) { - return TCL_ERROR; - } + Tcl_AppendResult(interp, + "no argument given for -server option", NULL); + return TCL_ERROR; + } + script = TclGetString(objv[a]); break; default: Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); } } if (server) { host = myaddr; /* NULL implies INADDR_ANY */ if (myport != 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "option -myport is not valid for servers", -1)); + Tcl_AppendResult(interp, "option -myport is not valid for servers", + NULL); return TCL_ERROR; } } else if (a < objc) { host = TclGetString(objv[a]); a++; @@ -1559,68 +1527,38 @@ iPtr = (Interp *) interp; Tcl_WrongNumArgs(interp, 1, objv, "?-myaddr addr? ?-myport myport? ?-async? host port"); iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS; Tcl_WrongNumArgs(interp, 1, objv, - "-server command ?-reuseaddr boolean? ?-reuseport boolean? " - "?-myaddr addr? port"); - return TCL_ERROR; - } - - if (!server && (reusea != -1 || reusep != -1)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "options -reuseaddr and -reuseport are only valid for servers", - -1)); - return TCL_ERROR; - } - - /* - * Set the options to their default value if the user didn't override - * their value. - */ - - if (reusep == -1) { - reusep = 0; - } - if (reusea == -1) { - reusea = 1; - } - - /* - * Build the bitset with the flags values. - */ - - if (reusea) { - flags |= TCL_TCPSERVER_REUSEADDR; - } - if (reusep) { - flags |= TCL_TCPSERVER_REUSEPORT; - } - - /* - * All the arguments should have been parsed by now, 'a' points to the - * last one, the port number. - */ - - if (a != objc-1) { + "-server command ?-myaddr addr? port"); + iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS; + return TCL_ERROR; + } + + if (a == objc-1) { + if (TclSockGetPort(interp, TclGetString(objv[a]), "tcp", + &port) != TCL_OK) { + return TCL_ERROR; + } + } else { goto wrongNumArgs; } - port = TclGetString(objv[a]); - if (server) { - AcceptCallback *acceptCallbackPtr = (AcceptCallback *)Tcl_Alloc(sizeof(AcceptCallback)); + AcceptCallback *acceptCallbackPtr = (AcceptCallback *) + ckalloc((unsigned) sizeof(AcceptCallback)); + unsigned len = strlen(script) + 1; + char *copyScript = ckalloc(len); - Tcl_IncrRefCount(script); - acceptCallbackPtr->script = script; + memcpy(copyScript, script, len); + acceptCallbackPtr->script = copyScript; acceptCallbackPtr->interp = interp; - - chan = Tcl_OpenTcpServerEx(interp, port, host, flags, - AcceptCallbackProc, acceptCallbackPtr); + chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc, + acceptCallbackPtr); if (chan == NULL) { - Tcl_DecrRefCount(script); - Tcl_Free(acceptCallbackPtr); + ckfree(copyScript); + ckfree((char *) acceptCallbackPtr); return TCL_ERROR; } /* * Register with the interpreter to let us know when the interpreter @@ -1637,24 +1575,18 @@ * be informed when the interpreter is deleted. */ Tcl_CreateCloseHandler(chan, TcpServerCloseProc, acceptCallbackPtr); } else { - int portNum; - - if (TclSockGetPort(interp, port, "tcp", &portNum) != TCL_OK) { - return TCL_ERROR; - } - - chan = Tcl_OpenTcpClient(interp, portNum, host, myaddr, myport, async); + chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async); if (chan == NULL) { return TCL_ERROR; } } - Tcl_RegisterChannel(interp, chan); - Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1)); + Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); + return TCL_OK; } /* *---------------------------------------------------------------------- @@ -1674,20 +1606,19 @@ *---------------------------------------------------------------------- */ int Tcl_FcopyObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ 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; + int mode, i, toRead, index; Tcl_Obj *cmdPtr; - static const char *const switches[] = { "-size", "-command", NULL }; + static const char* switches[] = { "-size", "-command", NULL }; enum { FcopySize, FcopyCommand }; if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) { Tcl_WrongNumArgs(interp, 1, objv, "input output ?-size size? ?-command callback?"); @@ -1700,46 +1631,43 @@ */ if (TclGetChannelFromObj(interp, objv[1], &inChan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if (!(mode & TCL_READABLE)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "channel \"%s\" wasn't opened for reading", - TclGetString(objv[1]))); + if ((mode & TCL_READABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", TclGetString(objv[1]), + "\" wasn't opened for reading", NULL); return TCL_ERROR; } if (TclGetChannelFromObj(interp, objv[2], &outChan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if (!(mode & TCL_WRITABLE)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "channel \"%s\" wasn't opened for writing", - TclGetString(objv[2]))); + if ((mode & TCL_WRITABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", TclGetString(objv[2]), + "\" wasn't opened for writing", NULL); return TCL_ERROR; } toRead = -1; cmdPtr = NULL; for (i = 3; i < objc; i += 2) { - if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, + if (Tcl_GetIndexFromObj(interp, objv[i], switches, "switch", 0, &index) != TCL_OK) { return TCL_ERROR; } switch (index) { case FcopySize: - if (Tcl_GetWideIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) { + if (TclGetIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) { return TCL_ERROR; } - if (toRead < 0) { + if (toRead<0) { /* * Handle all negative sizes like -1, meaning 'copy all'. By * resetting toRead we avoid changes in the core copying * functions (which explicitly check for -1 and crash on any * other negative value). */ - toRead = -1; } break; case FcopyCommand: cmdPtr = objv[i+1]; @@ -1767,21 +1695,22 @@ * "output"), or -1 if the channel wasn't opened for that mode. * *--------------------------------------------------------------------------- */ + /* ARGSUSED */ static int ChanPendingObjCmd( - TCL_UNUSED(ClientData), + ClientData unused, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; int index, mode; - static const char *const options[] = {"input", "output", NULL}; - enum pendingOptionsEnum {PENDING_INPUT, PENDING_OUTPUT}; + static const char *options[] = {"input", "output", NULL}; + enum options {PENDING_INPUT, PENDING_OUTPUT}; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "mode channelId"); return TCL_ERROR; } @@ -1793,23 +1722,23 @@ if (TclGetChannelFromObj(interp, objv[2], &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - switch ((enum pendingOptionsEnum) index) { + switch ((enum options) index) { case PENDING_INPUT: - if (!(mode & TCL_READABLE)) { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-1)); + if ((mode & TCL_READABLE) == 0) { + Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); } else { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_InputBuffered(chan))); + Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_InputBuffered(chan))); } break; case PENDING_OUTPUT: - if (!(mode & TCL_WRITABLE)) { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-1)); + if ((mode & TCL_WRITABLE) == 0) { + Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); } else { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_OutputBuffered(chan))); + Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_OutputBuffered(chan))); } break; } return TCL_OK; } @@ -1831,11 +1760,11 @@ *---------------------------------------------------------------------- */ static int ChanTruncateObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; @@ -1856,120 +1785,37 @@ if (Tcl_GetWideIntFromObj(interp, objv[2], &length) != TCL_OK) { return TCL_ERROR; } if (length < 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot truncate to negative length of file", -1)); + Tcl_AppendResult(interp, + "cannot truncate to negative length of file", NULL); return TCL_ERROR; } } else { /* * User wants to truncate to the current file position. */ length = Tcl_Tell(chan); - if (length == -1) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not determine current location in \"%s\": %s", - TclGetString(objv[1]), Tcl_PosixError(interp))); + if (length == Tcl_WideAsLong(-1)) { + Tcl_AppendResult(interp, + "could not determine current location in \"", + TclGetString(objv[1]), "\": ", + Tcl_PosixError(interp), NULL); return TCL_ERROR; } } if (Tcl_TruncateChannel(chan, length) != TCL_OK) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "error during truncate on \"%s\": %s", - TclGetString(objv[1]), Tcl_PosixError(interp))); - return TCL_ERROR; - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ChanPipeObjCmd -- - * - * This function is invoked to process the "chan pipe" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Creates a pair of Tcl channels wrapping both ends of a new - * anonymous pipe. - * - *---------------------------------------------------------------------- - */ - -static int -ChanPipeObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Channel rchan, wchan; - const char *channelNames[2]; - Tcl_Obj *resultPtr; - - if (objc != 1) { - Tcl_WrongNumArgs(interp, 1, objv, ""); - return TCL_ERROR; - } - - if (Tcl_CreatePipe(interp, &rchan, &wchan, 0) != TCL_OK) { - return TCL_ERROR; - } - - channelNames[0] = Tcl_GetChannelName(rchan); - channelNames[1] = Tcl_GetChannelName(wchan); - - TclNewObj(resultPtr); - Tcl_ListObjAppendElement(NULL, resultPtr, - Tcl_NewStringObj(channelNames[0], -1)); - Tcl_ListObjAppendElement(NULL, resultPtr, - Tcl_NewStringObj(channelNames[1], -1)); - Tcl_SetObjResult(interp, resultPtr); - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclChannelNamesCmd -- - * - * This function is invoked to process the "chan names" and "file - * channels" Tcl commands. See the user documentation for details on - * what they do. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * 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; - } - return Tcl_GetChannelNamesEx(interp, - ((objc == 1) ? NULL : TclGetString(objv[1]))); + Tcl_AppendResult(interp, "error during truncate on \"", + TclGetString(objv[1]), "\": ", + Tcl_PosixError(interp), NULL); + return TCL_ERROR; + } + + return TCL_OK; } /* *---------------------------------------------------------------------- * @@ -1997,33 +1843,30 @@ * (want overwriting of [fconfigure] to control that nicely), and [chan * names] because the functionality isn't available as a separate command * function at the moment. */ static const EnsembleImplMap initMap[] = { - {"blocked", Tcl_FblockedObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"close", Tcl_CloseObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"copy", Tcl_FcopyObjCmd, NULL, NULL, NULL, 0}, - {"create", TclChanCreateObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #219 */ - {"eof", Tcl_EofObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"event", Tcl_FileEventObjCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0}, - {"flush", Tcl_FlushObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"gets", Tcl_GetsObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"names", TclChannelNamesCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"pending", ChanPendingObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #287 */ - {"pipe", ChanPipeObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, /* TIP #304 */ - {"pop", TclChanPopObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, /* TIP #230 */ - {"postevent", TclChanPostEventObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #219 */ - {"push", TclChanPushObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #230 */ - {"puts", Tcl_PutsObjCmd, NULL, NULL, NULL, 0}, - {"read", Tcl_ReadObjCmd, NULL, NULL, NULL, 0}, - {"seek", Tcl_SeekObjCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0}, - {"tell", Tcl_TellObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"truncate", ChanTruncateObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, /* TIP #208 */ - {NULL, NULL, NULL, NULL, NULL, 0} + {"blocked", Tcl_FblockedObjCmd, NULL}, + {"close", Tcl_CloseObjCmd, NULL}, + {"copy", Tcl_FcopyObjCmd, NULL}, + {"create", TclChanCreateObjCmd, NULL}, /* TIP #219 */ + {"eof", Tcl_EofObjCmd, NULL}, + {"event", Tcl_FileEventObjCmd, NULL}, + {"flush", Tcl_FlushObjCmd, NULL}, + {"gets", Tcl_GetsObjCmd, NULL}, + {"pending", ChanPendingObjCmd, NULL}, /* TIP #287 */ + {"postevent", TclChanPostEventObjCmd, NULL}, /* TIP #219 */ + {"puts", Tcl_PutsObjCmd, NULL}, + {"read", Tcl_ReadObjCmd, NULL}, + {"seek", Tcl_SeekObjCmd, NULL}, + {"tell", Tcl_TellObjCmd, NULL}, + {"truncate", ChanTruncateObjCmd, NULL}, /* TIP #208 */ + {NULL,NULL, NULL} }; static const char *const extras[] = { "configure", "::fconfigure", + "names", "::file channels", NULL }; Tcl_Command ensemble; Tcl_Obj *mapObj; int i; Index: generic/tclIOGT.c ================================================================== --- generic/tclIOGT.c +++ generic/tclIOGT.c @@ -20,15 +20,17 @@ */ static int TransformBlockModeProc(ClientData instanceData, int mode); static int TransformCloseProc(ClientData instanceData, - Tcl_Interp *interp, int flags); + Tcl_Interp *interp); static int TransformInputProc(ClientData instanceData, char *buf, int toRead, int *errorCodePtr); static int TransformOutputProc(ClientData instanceData, const char *buf, int toWrite, int *errorCodePtr); +static int TransformSeekProc(ClientData instanceData, long offset, + int mode, int *errorCodePtr); 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, @@ -112,22 +114,22 @@ /* * This structure describes the channel type structure for Tcl-based * transformations. */ -static const Tcl_ChannelType transformChannelType = { +static Tcl_ChannelType transformChannelType = { "transform", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ - NULL, /* Close proc. */ + TransformCloseProc, /* Close proc. */ TransformInputProc, /* Input proc. */ TransformOutputProc, /* Output proc. */ - NULL, /* Seek proc. */ + TransformSeekProc, /* Seek proc. */ TransformSetOptionProc, /* Set option proc. */ TransformGetOptionProc, /* Get option proc. */ TransformWatchProc, /* Initialize notifier. */ TransformGetFileHandleProc, /* Get OS handles out of channel. */ - TransformCloseProc, /* close2proc */ + NULL, /* close2proc */ TransformBlockModeProc, /* Set blocking/nonblocking mode.*/ NULL, /* Flush proc. */ TransformNotifyProc, /* Handling of events bubbling up. */ TransformWideSeekProc, /* Wide seek proc. */ NULL, /* Thread action. */ @@ -207,11 +209,11 @@ Tcl_Obj *command; /* Tcl code to execute for a buffer */ ResultBuffer result; /* Internal buffer used to store the result of * a transformation of incoming data. Also * serves as buffer of all data not yet * consumed by the reader. */ - size_t refCount; + int refCount; }; static void PreserveData( TransformChannelData *dataPtr) @@ -221,16 +223,16 @@ static void ReleaseData( TransformChannelData *dataPtr) { - if (dataPtr->refCount-- > 1) { + if (--dataPtr->refCount) { return; } ResultClear(&dataPtr->result); Tcl_DecrRefCount(dataPtr->command); - Tcl_Free(dataPtr); + ckfree((char *) dataPtr); } /* *---------------------------------------------------------------------- * @@ -247,10 +249,11 @@ * None. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int TclChannelTransform( Tcl_Interp *interp, /* Interpreter for result. */ Tcl_Channel chan, /* Channel to transform. */ Tcl_Obj *cmdObjPtr) /* Script to use for transform. */ @@ -282,11 +285,11 @@ * 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 *)Tcl_Alloc(sizeof(TransformChannelData)); + dataPtr = (TransformChannelData *) ckalloc(sizeof(TransformChannelData)); dataPtr->refCount = 1; Tcl_DStringInit(&ds); Tcl_GetChannelOption(interp, chan, "-blocking", &ds); dataPtr->readIsFlushed = 0; @@ -308,12 +311,12 @@ ResultInit(&dataPtr->result); dataPtr->self = Tcl_StackChannel(interp, &transformChannelType, dataPtr, mode, chan); if (dataPtr->self == NULL) { - Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), - "\nfailed to stack channel \"%s\"", Tcl_GetChannelName(chan)); + Tcl_AppendResult(interp, "\nfailed to stack channel \"", + Tcl_GetChannelName(chan), "\"", NULL); ReleaseData(dataPtr); return TCL_ERROR; } Tcl_Preserve(dataPtr->self); @@ -373,11 +376,11 @@ int preserve) /* Flag. If true the procedure will preserve * the result state of all accessed * interpreters. */ { Tcl_Obj *resObj; /* See below, switch (transmit). */ - size_t resLen = 0; + 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; @@ -438,27 +441,27 @@ case TRANSMIT_DOWN: if (dataPtr->self == NULL) { break; } resObj = Tcl_GetObjResult(eval); - resBuf = TclGetByteArrayFromObj(resObj, &resLen); + 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 = TclGetByteArrayFromObj(resObj, &resLen); + resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen); Tcl_WriteRaw(dataPtr->self, (char *) resBuf, resLen); break; case TRANSMIT_IBUF: resObj = Tcl_GetObjResult(eval); - resBuf = TclGetByteArrayFromObj(resObj, &resLen); + resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen); ResultAdd(&dataPtr->result, resBuf, resLen); break; case TRANSMIT_NUM: /* @@ -498,11 +501,11 @@ static int TransformBlockModeProc( ClientData instanceData, /* State of transformation. */ int mode) /* New blocking mode. */ { - TransformChannelData *dataPtr = (TransformChannelData *)instanceData; + TransformChannelData *dataPtr = instanceData; if (mode == TCL_MODE_NONBLOCKING) { dataPtr->flags |= CHANNEL_ASYNC; } else { dataPtr->flags &= ~CHANNEL_ASYNC; @@ -528,18 +531,13 @@ */ 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; - } + Tcl_Interp *interp) +{ + TransformChannelData *dataPtr = instanceData; /* * Important: In this procedure 'dataPtr->self' already points to the * underlying channel. * @@ -616,11 +614,11 @@ ClientData instanceData, char *buf, int toRead, int *errorCodePtr) { - TransformChannelData *dataPtr = (TransformChannelData *)instanceData; + TransformChannelData *dataPtr = instanceData; int gotBytes, read, copied; Tcl_Channel downChan; /* * Should assert(dataPtr->mode & TCL_READABLE); @@ -683,11 +681,11 @@ if (dataPtr->eofPending) { /* * Already saw EOF from downChan; don't ask again. * NOTE: Could move this up to avoid the last maxRead * execution. Believe this would still be correct behavior, - * but the test suite tests the whole command callback + * but the test suite tests the whole command callback * sequence, so leave it unchanged for now. */ break; } @@ -696,10 +694,11 @@ * Get bytes from the underlying channel. */ read = Tcl_ReadRaw(downChan, buf, toRead); if (read < 0) { + if (Tcl_InputBlocked(downChan) && (gotBytes > 0)) { /* * Zero bytes available from downChan because blocked. * But nonzero bytes already copied, so total is a * valid blocked short read. Return to caller. @@ -783,11 +782,11 @@ ClientData instanceData, const char *buf, int toWrite, int *errorCodePtr) { - TransformChannelData *dataPtr = (TransformChannelData *)instanceData; + TransformChannelData *dataPtr = instanceData; /* * Should assert(dataPtr->mode & TCL_WRITABLE); */ @@ -807,10 +806,77 @@ } ReleaseData(dataPtr); return toWrite; } + +/* + *---------------------------------------------------------------------- + * + * TransformSeekProc -- + * + * This procedure is called by the generic IO level to move the access + * point in a channel. + * + * Side effects: + * Moves the location at which the channel will be accessed in future + * operations. Flushes all transformation buffers, then forwards it to + * the underlying channel. + * + * 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. */ +{ + TransformChannelData *dataPtr = instanceData; + Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self); + 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 + * location. Simply pass the request down. + */ + + return parentSeekProc(Tcl_GetChannelInstanceData(parent), offset, + mode, errorCodePtr); + } + + /* + * 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. + */ + + PreserveData(dataPtr); + if (dataPtr->mode & TCL_WRITABLE) { + ExecuteCallback(dataPtr, NULL, A_FLUSH_WRITE, NULL, 0, TRANSMIT_DOWN, + P_NO_PRESERVE); + } + + if (dataPtr->mode & TCL_READABLE) { + ExecuteCallback(dataPtr, NULL, A_CLEAR_READ, NULL, 0, TRANSMIT_DONT, + P_NO_PRESERVE); + ResultClear(&dataPtr->result); + dataPtr->readIsFlushed = 0; + dataPtr->eofPending = 0; + } + ReleaseData(dataPtr); + + return parentSeekProc(Tcl_GetChannelInstanceData(parent), offset, mode, + errorCodePtr); +} /* *---------------------------------------------------------------------- * * TransformWideSeekProc -- @@ -835,29 +901,30 @@ 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; + TransformChannelData *dataPtr = instanceData; Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self); - const Tcl_ChannelType *parentType = Tcl_GetChannelType(parent); + Tcl_ChannelType *parentType = Tcl_GetChannelType(parent); + Tcl_DriverSeekProc *parentSeekProc = Tcl_ChannelSeekProc(parentType); Tcl_DriverWideSeekProc *parentWideSeekProc = Tcl_ChannelWideSeekProc(parentType); ClientData parentData = Tcl_GetChannelInstanceData(parent); - if ((offset == 0) && (mode == SEEK_CUR)) { + if ((offset == Tcl_LongAsWide(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); - } else { - *errorCodePtr = EINVAL; - return -1; } + + return Tcl_LongAsWide(parentSeekProc(parentData, 0, mode, + errorCodePtr)); } /* * 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 @@ -881,15 +948,29 @@ /* * If we have a wide seek capability, we should stick with that. */ - if (parentWideSeekProc == NULL) { - *errorCodePtr = EINVAL; - return -1; - } + if (parentWideSeekProc != NULL) { return parentWideSeekProc(parentData, offset, mode, errorCodePtr); + } + + /* + * 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. + */ + + if (offsetTcl_LongAsWide(LONG_MAX)) { + *errorCodePtr = EOVERFLOW; + return Tcl_LongAsWide(-1); + } + + return Tcl_LongAsWide(parentSeekProc(parentData, Tcl_WideAsLong(offset), + mode, errorCodePtr)); } /* *---------------------------------------------------------------------- * @@ -913,11 +994,11 @@ ClientData instanceData, Tcl_Interp *interp, const char *optionName, const char *value) { - TransformChannelData *dataPtr = (TransformChannelData *)instanceData; + TransformChannelData *dataPtr = instanceData; Tcl_Channel downChan = Tcl_GetStackedChannel(dataPtr->self); Tcl_DriverSetOptionProc *setOptionProc; setOptionProc = Tcl_ChannelSetOptionProc(Tcl_GetChannelType(downChan)); if (setOptionProc == NULL) { @@ -951,11 +1032,11 @@ ClientData instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr) { - TransformChannelData *dataPtr = (TransformChannelData *)instanceData; + TransformChannelData *dataPtr = instanceData; Tcl_Channel downChan = Tcl_GetStackedChannel(dataPtr->self); Tcl_DriverGetOptionProc *getOptionProc; getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(downChan)); if (getOptionProc != NULL) { @@ -991,16 +1072,17 @@ * None. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ static void TransformWatchProc( ClientData instanceData, /* Channel to watch. */ int mask) /* Events of interest. */ { - TransformChannelData *dataPtr = (TransformChannelData *)instanceData; + TransformChannelData *dataPtr = instanceData; Tcl_Channel downChan; /* * The caller expressed interest in events occuring for this channel. We * are forwarding the call to the underlying channel now. @@ -1075,11 +1157,11 @@ TransformGetFileHandleProc( ClientData instanceData, /* Channel to query. */ int direction, /* Direction of interest. */ ClientData *handlePtr) /* Place to store the handle into. */ { - TransformChannelData *dataPtr = (TransformChannelData *)instanceData; + TransformChannelData *dataPtr = instanceData; /* * Return the handle belonging to parent channel. IOW, pass the request * down and the result up. */ @@ -1109,11 +1191,11 @@ TransformNotifyProc( ClientData clientData, /* The state of the notified * transformation. */ int mask) /* The mask of occuring events. */ { - TransformChannelData *dataPtr = (TransformChannelData *)clientData; + TransformChannelData *dataPtr = clientData; /* * An event occured in the underlying channel. This transformation doesn't * process such events thus returns the incoming mask unchanged. */ @@ -1152,11 +1234,11 @@ static void TransformChannelHandlerTimer( ClientData clientData) /* Transformation to query. */ { - TransformChannelData *dataPtr = (TransformChannelData *)clientData; + TransformChannelData *dataPtr = clientData; dataPtr->timer = NULL; if (!(dataPtr->watchMask&TCL_READABLE) || ResultEmpty(&dataPtr->result)) { /* * The timer fired, but either is there no (more) interest in the @@ -1190,11 +1272,11 @@ ResultBuffer *r) /* Reference to the buffer to clear out. */ { r->used = 0; if (r->allocated) { - Tcl_Free(r->buf); + ckfree((char *) r->buf); r->buf = NULL; r->allocated = 0; } } @@ -1334,14 +1416,14 @@ * Extension of the internal buffer is required. */ if (r->allocated == 0) { r->allocated = toWrite + INCREMENT; - r->buf = (unsigned char *)Tcl_Alloc(r->allocated); + r->buf = UCHARP(ckalloc(r->allocated)); } else { r->allocated += toWrite + INCREMENT; - r->buf = (unsigned char *)Tcl_Realloc(r->buf, r->allocated); + r->buf = UCHARP(ckrealloc((char *) r->buf, r->allocated)); } } /* * Now we may copy the data. Index: generic/tclIORChan.c ================================================================== --- generic/tclIORChan.c +++ generic/tclIORChan.c @@ -14,12 +14,12 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#include "tclInt.h" -#include "tclIO.h" +#include +#include #include #ifndef EINVAL #define EINVAL 9 #endif @@ -30,60 +30,51 @@ /* * Signatures of all functions used in the C layer of the reflection. */ static int ReflectClose(ClientData clientData, - Tcl_Interp *interp, int flags); + Tcl_Interp *interp); 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); +static int ReflectSeek(ClientData clientData, long offset, + int mode, int *errorCodePtr); 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. */ +static Tcl_ChannelType tclRChannelType = { + "tclrchannel", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ - NULL, /* Close channel, clean instance data */ - ReflectInput, /* Handle read request */ - ReflectOutput, /* Handle write request */ - NULL, - 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 */ + ReflectClose, /* Close channel, clean instance data */ + ReflectInput, /* Handle read request */ + ReflectOutput, /* Handle write request */ + ReflectSeek, /* Move location of access point. NULL'able */ + ReflectSetOption, /* Set options. NULL'able */ + ReflectGetOption, /* Get options. NULL'able */ + ReflectWatch, /* Initialize notifier */ + NULL, /* Get OS handle from the channel. NULL'able */ + NULL, /* 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 */ + NULL, /* thread action */ + NULL, /* truncate */ }; /* * Instance data for a reflected channel. =========================== */ @@ -95,48 +86,35 @@ * Tcl level part of the channel. NULL here * signals the channel is dead because the * interpreter/thread containing its Tcl * command is gone. */ -#if TCL_THREADS - Tcl_ThreadId thread; /* Thread the 'interp' belongs to. == Handler thread */ - Tcl_ThreadId owner; /* Thread owning the structure. == Channel thread */ +#ifdef TCL_THREADS + Tcl_ThreadId thread; /* Thread the 'interp' belongs to. */ #endif Tcl_Obj *cmd; /* Callback command prefix */ Tcl_Obj *methods; /* Methods to append to command prefix */ Tcl_Obj *name; /* Name of the channel as created */ int mode; /* Mask of R/W mode */ int interest; /* Mask of events the channel is interested * in. */ - int dead; /* Boolean signal that some operations - * should no longer be attempted. */ - - Tcl_TimerToken readTimer; /* - A token for the timer that is scheduled in - order to call Tcl_NotifyChannel when the - channel is readable - */ - Tcl_TimerToken writeTimer; /* - A token for the timer that is scheduled in - order to call Tcl_NotifyChannel when the - channel is writable - */ - /* * Note regarding the usage of timers. * * Most channel implementations need a timer in the C level to ensure that * data in buffers is flushed out through the generation of fake file * events. * * See 'rechan', 'memchan', etc. * - * A timer is used here as well in order to ensure at least on pass through - * the event loop when a channel becomes ready. See issues 67a5eabbd3d1 and - * ef28eb1f1516. + * Here this is _not_ required. Interest in events is posted to the Tcl + * level via 'watch'. And posting of events is possible from the Tcl level + * as well, via 'chan postevent'. This means that the generation of all + * events, fake or not, timer based or not, is completely in the hands of + * the Tcl level. Therefore no timer here. */ } ReflectedChannel; /* * Structure of the table maping from channel handles to reflected @@ -157,11 +135,11 @@ /* * Event literals. ================================================== */ -static const char *const eventOptions[] = { +static const char *eventOptions[] = { "read", "write", NULL }; typedef enum { EVENT_READ, EVENT_WRITE } EventOption; @@ -168,11 +146,11 @@ /* * Method literals. ================================================== */ -static const char *const methodNames[] = { +static const char *methodNames[] = { "blocking", /* OPT */ "cget", /* OPT \/ Together or none */ "cgetall", /* OPT /\ of these two */ "configure", /* OPT */ "finalize", /* */ @@ -208,11 +186,11 @@ #define IMPLIES(a,b) ((!(a)) || (b)) #define NEGIMPL(a,b) #define HAS(x,f) (x & FLAG(f)) -#if TCL_THREADS +#ifdef TCL_THREADS /* * Thread specific types and structures. * * We are here essentially creating a very specific implementation of 'thread * send'. @@ -243,11 +221,11 @@ * forward an operation code, the argument details, and reference to results. * The command is assembled in the CT and belongs fully to that thread. No * sharing problems. */ -typedef struct { +typedef struct ForwardParamBase { int code; /* O: Ok/Fail of the cmd handler */ char *msgStr; /* O: Error message for handler failure */ int mustFree; /* O: True if msgStr is allocated, false if * otherwise (static). */ } ForwardParamBase; @@ -259,11 +237,11 @@ */ struct ForwardParamInput { ForwardParamBase base; /* "Supertype". MUST COME FIRST. */ char *buf; /* O: Where to store the read bytes */ - size_t toRead; /* I: #bytes to read, + 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 */ @@ -318,11 +296,11 @@ /* * General event structure, with reference to operation specific data. */ -typedef struct { +typedef struct ForwardingEvent { Tcl_Event event; /* Basic event data, has to be first item */ ForwardingResult *resultPtr; ForwardedOperation op; /* Forwarded driver operation */ ReflectedChannel *rcPtr; /* Channel instance */ ForwardParam *param; /* Packaged arguments and return values, a @@ -338,12 +316,11 @@ */ struct ForwardingResult { Tcl_ThreadId src; /* Originating thread. */ Tcl_ThreadId dst; /* Thread the op was forwarded to. */ - Tcl_Interp *dsti; /* Interpreter in the thread the op was - * forwarded to. */ + Tcl_Interp* dsti; /* Interpreter in the thread the op was forwarded to. */ /* * Note regarding 'dsti' above: Its information is also available via the * chain evPtr->rcPtr->interp, however, as can be seen, two more * indirections are needed to retrieve it. And the evPtr may be gone, * breaking the chain. @@ -355,17 +332,17 @@ ForwardingResult *prevPtr, *nextPtr; /* Links into the list of pending forwarded * results. */ }; -typedef struct { +typedef struct ThreadSpecificData { /* * Table of all reflected channels owned by this thread. This is the * per-thread version of the per-interpreter map. */ - ReflectedChannelMap *rcmPtr; + ReflectedChannelMap* rcmPtr; } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* @@ -385,41 +362,41 @@ * The ExitProc ensures that things do not deadlock when the sending thread * involved in the forwarding exits. It also clean things up so that we don't * leak resources when threads go away. */ -static void ForwardOpToHandlerThread(ReflectedChannel *rcPtr, - ForwardedOperation op, const void *param); +static void ForwardOpToOwnerThread(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) { \ - Tcl_Free((p)->base.msgStr); \ + if ((p)->base.mustFree) { \ + ckfree((p)->base.msgStr); \ } #define PassReceivedErrorInterp(i,p) \ - if ((i) != NULL) { \ - Tcl_SetChannelErrorInterp((i), \ - Tcl_NewStringObj((p)->base.msgStr, -1)); \ - } \ + if ((i) != NULL) { \ + Tcl_SetChannelErrorInterp((i), \ + Tcl_NewStringObj((p)->base.msgStr, -1)); \ + } \ FreeReceivedError(p) #define PassReceivedError(c,p) \ Tcl_SetChannelError((c), Tcl_NewStringObj((p)->base.msgStr, -1)); \ FreeReceivedError(p) #define ForwardSetStaticError(p,emsg) \ - (p)->base.code = TCL_ERROR; \ - (p)->base.mustFree = 0; \ + (p)->base.code = TCL_ERROR; \ + (p)->base.mustFree = 0; \ (p)->base.msgStr = (char *) (emsg) #define ForwardSetDynamicError(p,emsg) \ - (p)->base.code = TCL_ERROR; \ - (p)->base.mustFree = 1; \ + (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; +static void DeleteThreadReflectedChannelMap(ClientData clientData); #endif /* TCL_THREADS */ #define SetChannelErrorStr(c,msgStr) \ Tcl_SetChannelError((c), Tcl_NewStringObj((msgStr), -1)) @@ -442,13 +419,13 @@ 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); +static void DeleteReflectedChannelMap(ClientData clientData, + Tcl_Interp *interp); +static int ErrnoReturn(ReflectedChannel *rcPtr, Tcl_Obj* resObj); /* * 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 @@ -457,11 +434,11 @@ static const char *msg_read_toomuch = "{read delivered more than requested}"; static const char *msg_write_toomuch = "{write wrote more than requested}"; static const char *msg_write_nothing = "{write wrote nothing}"; static const char *msg_seek_beforestart = "{Tried to seek before origin}"; -#if TCL_THREADS +#ifdef TCL_THREADS static const char *msg_send_originlost = "{Channel thread lost}"; #endif /* TCL_THREADS */ static const char *msg_send_dstlost = "{Owner lost}"; static const char *msg_dstlost = "-code 1 -level 0 -errorcode NONE -errorinfo {} -errorline 1 {Owner lost}"; @@ -487,11 +464,11 @@ *---------------------------------------------------------------------- */ int TclChanCreateObjCmd( - TCL_UNUSED(ClientData), + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { ReflectedChannel *rcPtr; /* Instance data of the new channel */ @@ -508,15 +485,13 @@ int result; /* Result code for 'initialize' */ Tcl_Obj *resObj; /* Result data for 'initialize' */ int methods; /* Bitmask for supported methods. */ Channel *chanPtr; /* 'chan' resolved to internal struct. */ Tcl_Obj *err; /* Error message */ - ReflectedChannelMap *rcmPtr; - /* Map of reflected channels with handlers in - * this interp. */ - Tcl_HashEntry *hPtr; /* Entry in the above map */ - int isNew; /* Placeholder. */ + ReflectedChannelMap* rcmPtr; /* Map of reflected channels with handlers in this interp */ + Tcl_HashEntry* hPtr; /* Entry in the above map */ + int isNew; /* Placeholder. */ /* * Syntax: chan create MODE CMDPREFIX * [0] [1] [2] [3] * @@ -539,11 +514,10 @@ /* * First argument is a list of modes. Allowed entries are "read", "write". * Expect at least one list element. Abbreviations are ok. */ - modeObj = objv[MODE]; if (EncodeEventMask(interp, "mode", objv[MODE], &mode) != TCL_OK) { return TCL_ERROR; } /* @@ -582,11 +556,10 @@ modeObj = DecodeEventMask(mode); /* assert modeObj.refCount == 1 */ result = InvokeTclMethod(rcPtr, METH_INIT, modeObj, NULL, &resObj); Tcl_DecrRefCount(modeObj); - if (result != TCL_OK) { UnmarshallErrorResult(interp, resObj); Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ goto error; } @@ -597,13 +570,15 @@ * Check for non-optionals through the mask. * Compare open mode against optional r/w. */ if (Tcl_ListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "chan handler \"%s initialize\" returned non-list: %s", - TclGetString(cmdObj), TclGetString(resObj))); + TclNewLiteralStringObj(err, "chan handler \""); + Tcl_AppendObjToObj(err, cmdObj); + Tcl_AppendToObj(err, " initialize\" returned non-list: ", -1); + Tcl_AppendObjToObj(err, resObj); + Tcl_SetObjResult(interp, err); Tcl_DecrRefCount(resObj); goto error; } methods = 0; @@ -623,41 +598,46 @@ listc--; } Tcl_DecrRefCount(resObj); if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "chan handler \"%s\" does not support all required methods", - TclGetString(cmdObj))); + TclNewLiteralStringObj(err, "chan handler \""); + Tcl_AppendObjToObj(err, cmdObj); + Tcl_AppendToObj(err, "\" does not support all required methods", -1); + Tcl_SetObjResult(interp, err); goto error; } if ((mode & TCL_READABLE) && !HAS(methods, METH_READ)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "chan handler \"%s\" lacks a \"read\" method", - TclGetString(cmdObj))); + TclNewLiteralStringObj(err, "chan handler \""); + Tcl_AppendObjToObj(err, cmdObj); + Tcl_AppendToObj(err, "\" lacks a \"read\" method", -1); + Tcl_SetObjResult(interp, err); goto error; } if ((mode & TCL_WRITABLE) && !HAS(methods, METH_WRITE)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "chan handler \"%s\" lacks a \"write\" method", - TclGetString(cmdObj))); + TclNewLiteralStringObj(err, "chan handler \""); + Tcl_AppendObjToObj(err, cmdObj); + Tcl_AppendToObj(err, "\" lacks a \"write\" method", -1); + Tcl_SetObjResult(interp, err); goto error; } if (!IMPLIES(HAS(methods, METH_CGET), HAS(methods, METH_CGETALL))) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "chan handler \"%s\" supports \"cget\" but not \"cgetall\"", - TclGetString(cmdObj))); + TclNewLiteralStringObj(err, "chan handler \""); + Tcl_AppendObjToObj(err, cmdObj); + Tcl_AppendToObj(err, "\" supports \"cget\" but not \"cgetall\"", -1); + Tcl_SetObjResult(interp, err); goto error; } if (!IMPLIES(HAS(methods, METH_CGETALL), HAS(methods, METH_CGET))) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "chan handler \"%s\" supports \"cgetall\" but not \"cget\"", - TclGetString(cmdObj))); + TclNewLiteralStringObj(err, "chan handler \""); + Tcl_AppendObjToObj(err, cmdObj); + Tcl_AppendToObj(err, "\" supports \"cgetall\" but not \"cget\"", -1); + Tcl_SetObjResult(interp, err); goto error; } Tcl_ResetResult(interp); @@ -676,11 +656,12 @@ * Some of the nullable methods are not supported. We clone the * channel type, null the associated C functions, and use the result * as the actual channel type. */ - Tcl_ChannelType *clonePtr = (Tcl_ChannelType *)Tcl_Alloc(sizeof(Tcl_ChannelType)); + Tcl_ChannelType *clonePtr = (Tcl_ChannelType *) + ckalloc(sizeof(Tcl_ChannelType)); memcpy(clonePtr, &tclRChannelType, sizeof(Tcl_ChannelType)); if (!(methods & FLAG(METH_CONFIGURE))) { clonePtr->setOptionProc = NULL; @@ -691,10 +672,11 @@ } if (!(methods & FLAG(METH_BLOCKING))) { clonePtr->blockModeProc = NULL; } if (!(methods & FLAG(METH_SEEK))) { + clonePtr->seekProc = NULL; clonePtr->wideSeekProc = NULL; } chanPtr->typePtr = clonePtr; } @@ -704,37 +686,38 @@ * postevent'. */ Tcl_RegisterChannel(interp, chan); - rcmPtr = GetReflectedChannelMap(interp); - hPtr = Tcl_CreateHashEntry(&rcmPtr->map, chanPtr->state->channelName, - &isNew); - if (!isNew && chanPtr != Tcl_GetHashValue(hPtr)) { - Tcl_Panic("TclChanCreateObjCmd: duplicate channel names"); + rcmPtr = GetReflectedChannelMap (interp); + hPtr = Tcl_CreateHashEntry(&rcmPtr->map, + chanPtr->state->channelName, &isNew); + if (!isNew) { + if (chanPtr != Tcl_GetHashValue(hPtr)) { + Tcl_Panic("TclChanCreateObjCmd: duplicate channel names"); + } } Tcl_SetHashValue(hPtr, chan); -#if TCL_THREADS +#ifdef TCL_THREADS rcmPtr = GetThreadReflectedChannelMap(); - hPtr = Tcl_CreateHashEntry(&rcmPtr->map, chanPtr->state->channelName, - &isNew); + hPtr = Tcl_CreateHashEntry(&rcmPtr->map, + chanPtr->state->channelName, &isNew); Tcl_SetHashValue(hPtr, chan); #endif /* * Return handle as result of command. */ - Tcl_SetObjResult(interp, - Tcl_NewStringObj(chanPtr->state->channelName, -1)); + Tcl_SetObjResult(interp, rcId); return TCL_OK; - error: + error: Tcl_DecrRefCount(rcPtr->name); Tcl_DecrRefCount(rcPtr->methods); Tcl_DecrRefCount(rcPtr->cmd); - Tcl_Free(rcPtr); + ckfree((char*) rcPtr); return TCL_ERROR; #undef MODE #undef CMD } @@ -755,66 +738,18 @@ * latter implies that arbitrary side effects are possible. * *---------------------------------------------------------------------- */ -#if TCL_THREADS -typedef struct { - Tcl_Event header; - 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. - */ - - ReflectEvent *e = (ReflectEvent *) ev; - - Tcl_NotifyChannel(e->rcPtr->chan, e->events); - return 1; -} - -static int -ReflectEventDelete( - Tcl_Event *ev, - ClientData cd) -{ - /* OWNER thread - * - * Invoked by DeleteThreadReflectedChannelMap() and ReflectClose(). The - * latter ensures that no pending events of this type are run on an - * invalid channel. - */ - - ReflectEvent *e = (ReflectEvent *) ev; - - if ((ev->proc != ReflectEventRun) || ((cd != NULL) && (cd != e->rcPtr))) { - return 0; - } - return 1; -} -#endif - int TclChanPostEventObjCmd( - TCL_UNUSED(ClientData), + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { /* - * Ensure -> HANDLER thread - * * Syntax: chan postevent CHANNEL EVENTSPEC * [0] [1] [2] [3] * * Actually: rPostevent CHANNEL EVENTSPEC * [0] [1] [2] @@ -829,13 +764,12 @@ Tcl_Channel chan; /* Channel associated to the handle */ const Tcl_ChannelType *chanTypePtr; /* Its associated driver structure */ ReflectedChannel *rcPtr; /* Associated instance data */ int events; /* Mask of events to post */ - ReflectedChannelMap *rcmPtr;/* Map of reflected channels with handlers in - * this interp. */ - Tcl_HashEntry *hPtr; /* Entry in the above map */ + ReflectedChannelMap* rcmPtr; /* Map of reflected channels with handlers in this interp */ + Tcl_HashEntry* hPtr; /* Entry in the above map */ /* * Number of arguments... */ @@ -849,27 +783,26 @@ * command is done from the interp defining the channel handler cmd. */ chanId = TclGetString(objv[CHAN]); - rcmPtr = GetReflectedChannelMap(interp); - hPtr = Tcl_FindHashEntry(&rcmPtr->map, chanId); + rcmPtr = GetReflectedChannelMap (interp); + hPtr = Tcl_FindHashEntry (&rcmPtr->map, chanId); if (hPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can not find reflected channel named \"%s\"", chanId)); + Tcl_AppendResult(interp, "can not find reflected channel named \"", chanId, + "\"", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CHANNEL", chanId, NULL); return TCL_ERROR; } /* - * Note that the search above subsumes several of the older checks, - * namely: + * Note that the search above subsumes several of the older checks, namely: * - * (1) Does the channel handle refer to a reflected channel? + * (1) Does the channel handle refer to a reflected channel ? * (2) Is the post event issued from the interpreter holding the handler - * of the reflected channel? + * of the reflected channel ? * * A successful search answers yes to both. Because the map holds only * handles of reflected channels, and only of such whose handler is * defined in this interpreter. * @@ -876,11 +809,11 @@ * 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); + chan = 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 @@ -889,17 +822,17 @@ * 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"); + Tcl_Panic ("TclChanPostEventObjCmd: channel is not a reflected channel"); } - rcPtr = (ReflectedChannel *)Tcl_GetChannelInstanceData(chan); + rcPtr = (ReflectedChannel *) Tcl_GetChannelInstanceData(chan); if (rcPtr->interp != interp) { - Tcl_Panic("TclChanPostEventObjCmd: postevent accepted for call from outside interpreter"); + Tcl_Panic ("TclChanPostEventObjCmd: postevent accepted for call from outside interpreter"); } /* * Second argument is a list of events. Allowed entries are "read", * "write". Expect at least one list element. Abbreviations are ok. @@ -912,70 +845,20 @@ /* * Check that the channel is actually interested in the provided events. */ if (events & ~rcPtr->interest) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "tried to post events channel \"%s\" is not interested in", - chanId)); + Tcl_AppendResult(interp, "tried to post events channel \"", chanId, + "\" is not interested in", NULL); return TCL_ERROR; } /* * We have the channel and the events to post. */ -#if TCL_THREADS - if (rcPtr->owner == rcPtr->thread) { -#endif - if (events & TCL_READABLE) { - if (rcPtr->readTimer == NULL) { - rcPtr->readTimer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, - TimerRunRead, rcPtr); - } - } - if (events & TCL_WRITABLE) { - if (rcPtr->writeTimer == NULL) { - rcPtr->writeTimer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, - TimerRunWrite, rcPtr); - } - } -#if TCL_THREADS - } else { - ReflectEvent *ev = (ReflectEvent *)Tcl_Alloc(sizeof(ReflectEvent)); - - ev->header.proc = ReflectEventRun; - ev->events = events; - ev->rcPtr = rcPtr; - - /* - * We are not preserving the structure here. When the channel is - * closed any pending events are deleted, see ReflectClose(), and - * ReflectEventDelete(). Trying to preserve and later release when the - * event is run may generate a situation where the channel structure - * is deleted but not our structure, crashing in - * FreeReflectedChannel(). - * - * Force creation of the RCM, for proper cleanup on thread teardown. - * The teardown of unprocessed events is currently coupled to the - * thread reflected channel map - */ - - (void) GetThreadReflectedChannelMap(); - - /* - * XXX Race condition !! - * XXX The destination thread may not exist anymore already. - * XXX (Delayed postevent executed after channel got removed). - * XXX Can we detect this ? (check the validity of the owner threadid ?) - * XXX Actually, in that case the channel should be dead also ! - */ - - Tcl_ThreadQueueEvent(rcPtr->owner, (Tcl_Event *) ev, TCL_QUEUE_TAIL); - Tcl_ThreadAlert(rcPtr->owner); - } -#endif + Tcl_NotifyChannel(chan, events); /* * Squash interp results left by the event script. */ @@ -983,34 +866,16 @@ return TCL_OK; #undef CHAN #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. */ -static Tcl_Obj * +static Tcl_Obj* MarshallError( Tcl_Interp *interp) { /* * Capture the result status of the interpreter into a string. => List of @@ -1061,11 +926,11 @@ if (explicitResult) { Tcl_SetObjResult(interp, lv[lc-1]); } (void) Tcl_SetReturnOptions(interp, Tcl_NewListObj(numOptions, lv)); - ((Interp *) interp)->flags &= ~ERR_ALREADY_LOGGED; + ((Interp *)interp)->flags &= ~ERR_ALREADY_LOGGED; } int TclChanCaughtErrorBypass( Tcl_Interp *interp, @@ -1144,24 +1009,18 @@ */ static int ReflectClose( ClientData clientData, - Tcl_Interp *interp, - int flags) + Tcl_Interp *interp) { - ReflectedChannel *rcPtr = (ReflectedChannel *)clientData; + 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; - } + ReflectedChannelMap* rcmPtr; /* Map of reflected channels with handlers in this interp */ + Tcl_HashEntry* hPtr; /* Entry in the above map */ + Tcl_ChannelType *tctPtr; if (TclInThreadExit()) { /* * This call comes from TclFinalizeIOSystem. There are no * interpreters, and therefore we cannot call upon the handler command @@ -1171,65 +1030,57 @@ */ /* * THREADED => Forward this to the origin thread * - * Note: DeleteThreadReflectedChannelMap() is the thread exit handler - * for the origin thread. Use this to clean up the structure? Except - * if lost? + * Note: DeleteThreadReflectedChannelMap() is the thread exit handler for the origin + * thread. Use this to clean up the structure? Except if lost? */ -#if TCL_THREADS +#ifdef TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; - ForwardOpToHandlerThread(rcPtr, ForwardedClose, &p); + ForwardOpToOwnerThread(rcPtr, ForwardedClose, &p); result = p.base.code; - /* - * Now squash the pending reflection events for this channel. - */ - - Tcl_DeleteEvents(ReflectEventDelete, rcPtr); + /* + * FreeReflectedChannel is done in the forwarded operation!, in + * the other thread. rcPtr here is gone! + */ if (result != TCL_OK) { FreeReceivedError(&p); } + return EOK; } #endif tctPtr = ((Channel *)rcPtr->chan)->typePtr; if (tctPtr && tctPtr != &tclRChannelType) { - Tcl_Free((void *)tctPtr); + ckfree((char *)tctPtr); ((Channel *)rcPtr->chan)->typePtr = NULL; } - if (rcPtr->readTimer != NULL) { - Tcl_DeleteTimerHandler(rcPtr->readTimer); - } - if (rcPtr->writeTimer != NULL) { - Tcl_DeleteTimerHandler(rcPtr->writeTimer); - } - Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); + Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); return EOK; } /* * Are we in the correct thread? */ -#if TCL_THREADS +#ifdef TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; - ForwardOpToHandlerThread(rcPtr, ForwardedClose, &p); + ForwardOpToOwnerThread(rcPtr, ForwardedClose, &p); result = p.base.code; - /* - * Now squash the pending reflection events for this channel. - */ - - Tcl_DeleteEvents(ReflectEventDelete, rcPtr); + /* + * FreeReflectedChannel is done in the forwarded operation!, in the + * other thread. rcPtr here is gone! + */ if (result != TCL_OK) { PassReceivedErrorInterp(interp, &p); } } else { @@ -1253,39 +1104,36 @@ * * NOTE: The channel may have been removed from the map already via * the per-interp DeleteReflectedChannelMap exit-handler. */ - if (!rcPtr->dead) { - rcmPtr = GetReflectedChannelMap(rcPtr->interp); - hPtr = Tcl_FindHashEntry(&rcmPtr->map, - Tcl_GetChannelName(rcPtr->chan)); - if (hPtr) { - Tcl_DeleteHashEntry(hPtr); - } - } -#if TCL_THREADS - rcmPtr = GetThreadReflectedChannelMap(); - hPtr = Tcl_FindHashEntry(&rcmPtr->map, - Tcl_GetChannelName(rcPtr->chan)); - if (hPtr) { - Tcl_DeleteHashEntry(hPtr); - } - } -#endif - tctPtr = ((Channel *)rcPtr->chan)->typePtr; - if (tctPtr && tctPtr != &tclRChannelType) { - Tcl_Free((void *)tctPtr); - ((Channel *)rcPtr->chan)->typePtr = NULL; - } - if (rcPtr->readTimer != NULL) { - Tcl_DeleteTimerHandler(rcPtr->readTimer); - } - if (rcPtr->writeTimer != NULL) { - Tcl_DeleteTimerHandler(rcPtr->writeTimer); - } - Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); + if (rcPtr->interp) { + rcmPtr = GetReflectedChannelMap (rcPtr->interp); + hPtr = Tcl_FindHashEntry (&rcmPtr->map, + Tcl_GetChannelName (rcPtr->chan)); + if (hPtr) { + Tcl_DeleteHashEntry (hPtr); + } + } +#ifdef TCL_THREADS + rcmPtr = GetThreadReflectedChannelMap(); + hPtr = Tcl_FindHashEntry (&rcmPtr->map, + Tcl_GetChannelName (rcPtr->chan)); + if (hPtr) { + Tcl_DeleteHashEntry (hPtr); + } +#endif + + tctPtr = ((Channel *)rcPtr->chan)->typePtr; + if (tctPtr && tctPtr != &tclRChannelType) { + ckfree((char *)tctPtr); + ((Channel *)rcPtr->chan)->typePtr = NULL; + } + Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); +#ifdef TCL_THREADS + } +#endif return (result == TCL_OK) ? EOK : EINVAL; } /* *---------------------------------------------------------------------- @@ -1308,41 +1156,38 @@ ClientData clientData, char *buf, int toRead, int *errorCodePtr) { - ReflectedChannel *rcPtr = (ReflectedChannel *)clientData; + ReflectedChannel *rcPtr = (ReflectedChannel *) clientData; Tcl_Obj *toReadObj; - size_t bytec = 0; /* Number of returned bytes */ + 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 +#ifdef TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; p.input.buf = buf; p.input.toRead = toRead; - ForwardOpToHandlerThread(rcPtr, ForwardedInput, &p); + ForwardOpToOwnerThread(rcPtr, ForwardedInput, &p); if (p.base.code != TCL_OK) { if (p.base.code < 0) { - /* - * No error message, this is an errno signal. - */ - + /* No error message, this is an errno signal. */ *errorCodePtr = -p.base.code; } else { PassReceivedError(rcPtr->chan, &p); *errorCodePtr = EINVAL; } - p.input.toRead = TCL_INDEX_NONE; + p.input.toRead = -1; } else { *errorCodePtr = EOK; } return p.input.toRead; @@ -1352,15 +1197,15 @@ /* ASSERT: rcPtr->method & FLAG(METH_READ) */ /* ASSERT: rcPtr->mode & TCL_READABLE */ Tcl_Preserve(rcPtr); - TclNewIntObj(toReadObj, toRead); + toReadObj = Tcl_NewIntObj(toRead); Tcl_IncrRefCount(toReadObj); if (InvokeTclMethod(rcPtr, METH_READ, toReadObj, NULL, &resObj)!=TCL_OK) { - int code = ErrnoReturn(rcPtr, resObj); + int code = ErrnoReturn (rcPtr, resObj); if (code < 0) { *errorCodePtr = -code; goto error; } @@ -1367,21 +1212,21 @@ Tcl_SetChannelError(rcPtr->chan, resObj); goto invalid; } - bytev = TclGetByteArrayFromObj(resObj, &bytec); + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); - if ((size_t)toRead < bytec) { + if (toRead < bytec) { SetChannelErrorStr(rcPtr->chan, msg_read_toomuch); - goto invalid; + goto invalid; } *errorCodePtr = EOK; - if (bytec + 1 > 1) { - memcpy(buf, bytev, bytec); + if (bytec > 0) { + memcpy(buf, bytev, (size_t)bytec); } stop: Tcl_DecrRefCount(toReadObj); Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ @@ -1415,34 +1260,31 @@ ClientData clientData, const char *buf, int toWrite, int *errorCodePtr) { - ReflectedChannel *rcPtr = (ReflectedChannel *)clientData; + 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 +#ifdef TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; p.output.buf = buf; p.output.toWrite = toWrite; - ForwardOpToHandlerThread(rcPtr, ForwardedOutput, &p); + ForwardOpToOwnerThread(rcPtr, ForwardedOutput, &p); if (p.base.code != TCL_OK) { if (p.base.code < 0) { - /* - * No error message, this is an errno signal. - */ - + /* No error message, this is an errno signal. */ *errorCodePtr = -p.base.code; } else { PassReceivedError(rcPtr->chan, &p); *errorCodePtr = EINVAL; } @@ -1489,12 +1331,12 @@ goto invalid; } if ((written == 0) && (toWrite > 0)) { /* - * The handler claims to have written nothing of what it was given. - * That is bad. + * The handler claims to have written nothing of what it was + * given. That is bad. */ SetChannelErrorStr(rcPtr->chan, msg_write_nothing); goto invalid; } @@ -1544,27 +1386,27 @@ ClientData clientData, Tcl_WideInt offset, int seekMode, int *errorCodePtr) { - ReflectedChannel *rcPtr = (ReflectedChannel *)clientData; + ReflectedChannel *rcPtr = (ReflectedChannel *) clientData; Tcl_Obj *offObj, *baseObj; Tcl_Obj *resObj; /* Result for 'seek' */ Tcl_WideInt newLoc; /* * Are we in the correct thread? */ -#if TCL_THREADS +#ifdef TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; p.seek.seekMode = seekMode; p.seek.offset = offset; - ForwardOpToHandlerThread(rcPtr, ForwardedSeek, &p); + ForwardOpToOwnerThread(rcPtr, ForwardedSeek, &p); if (p.base.code != TCL_OK) { PassReceivedError(rcPtr->chan, &p); *errorCodePtr = EINVAL; p.seek.offset = -1; @@ -1578,14 +1420,13 @@ /* ASSERT: rcPtr->method & FLAG(METH_SEEK) */ Tcl_Preserve(rcPtr); - TclNewIntObj(offObj, offset); - baseObj = Tcl_NewStringObj( - (seekMode == SEEK_SET) ? "start" : - (seekMode == SEEK_CUR) ? "current" : "end", -1); + offObj = Tcl_NewWideIntObj(offset); + baseObj = Tcl_NewStringObj((seekMode == SEEK_SET) ? "start" : + ((seekMode == SEEK_CUR) ? "current" : "end"), -1); Tcl_IncrRefCount(offObj); Tcl_IncrRefCount(baseObj); if (InvokeTclMethod(rcPtr, METH_SEEK, offObj, baseObj, &resObj)!=TCL_OK) { Tcl_SetChannelError(rcPtr->chan, resObj); @@ -1595,11 +1436,11 @@ if (Tcl_GetWideIntFromObj(rcPtr->interp, resObj, &newLoc) != TCL_OK) { Tcl_SetChannelError(rcPtr->chan, MarshallError(rcPtr->interp)); goto invalid; } - if (newLoc < 0) { + if (newLoc < Tcl_LongAsWide(0)) { SetChannelErrorStr(rcPtr->chan, msg_seek_beforestart); goto invalid; } *errorCodePtr = EOK; @@ -1612,10 +1453,28 @@ 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 (int) ReflectSeekWide(clientData, Tcl_LongAsWide(offset), seekMode, + errorCodePtr); +} /* *---------------------------------------------------------------------- * * ReflectWatch -- @@ -1635,11 +1494,11 @@ static void ReflectWatch( ClientData clientData, int mask) { - ReflectedChannel *rcPtr = (ReflectedChannel *)clientData; + 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. @@ -1658,16 +1517,16 @@ /* * Are we in the correct thread? */ -#if TCL_THREADS +#ifdef TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; p.watch.mask = mask; - ForwardOpToHandlerThread(rcPtr, ForwardedWatch, &p); + ForwardOpToOwnerThread(rcPtr, ForwardedWatch, &p); /* * Any failure from the forward is ignored. We have no place to put * this. */ @@ -1707,26 +1566,26 @@ static int ReflectBlock( ClientData clientData, int nonblocking) { - ReflectedChannel *rcPtr = (ReflectedChannel *)clientData; + 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? */ -#if TCL_THREADS +#ifdef TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; p.block.nonblocking = nonblocking; - ForwardOpToHandlerThread(rcPtr, ForwardedBlock, &p); + ForwardOpToOwnerThread(rcPtr, ForwardedBlock, &p); if (p.base.code != TCL_OK) { PassReceivedError(rcPtr->chan, &p); return EINVAL; } @@ -1738,11 +1597,11 @@ blockObj = Tcl_NewBooleanObj(!nonblocking); Tcl_IncrRefCount(blockObj); Tcl_Preserve(rcPtr); - if (InvokeTclMethod(rcPtr,METH_BLOCKING,blockObj,NULL,&resObj)!=TCL_OK) { + if (InvokeTclMethod(rcPtr, METH_BLOCKING, blockObj, NULL, &resObj) != TCL_OK) { Tcl_SetChannelError(rcPtr->chan, resObj); errorNum = EINVAL; } else { errorNum = EOK; } @@ -1752,48 +1611,10 @@ Tcl_Release(rcPtr); return errorNum; } -#if TCL_THREADS -/* - *---------------------------------------------------------------------- - * - * ReflectThread -- - * - * This function is invoked to tell the channel about thread movements. - * - * Results: - * None. - * - * Side effects: - * Allocates memory. Arbitrary, as it calls upon a script. - * - *---------------------------------------------------------------------- - */ - -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; - break; - default: - Tcl_Panic("Unknown thread action code."); - break; - } -} - -#endif /* *---------------------------------------------------------------------- * * ReflectSetOption -- * @@ -1813,27 +1634,27 @@ 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; + 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? */ -#if TCL_THREADS +#ifdef TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; p.setOpt.name = optionName; p.setOpt.value = newValue; - ForwardOpToHandlerThread(rcPtr, ForwardedSetOpt, &p); + ForwardOpToOwnerThread(rcPtr, ForwardedSetOpt, &p); if (p.base.code != TCL_OK) { Tcl_Obj *err = Tcl_NewStringObj(p.base.msgStr, -1); UnmarshallErrorResult(interp, err); @@ -1890,11 +1711,11 @@ /* * This code is special. It has regular passing of Tcl result, and errors. * The bypass functions are not required. */ - ReflectedChannel *rcPtr = (ReflectedChannel *)clientData; + ReflectedChannel *rcPtr = (ReflectedChannel*) clientData; Tcl_Obj *optionObj; Tcl_Obj *resObj; /* Result data for 'configure' */ int listc, result = TCL_OK; Tcl_Obj **listv; MethodName method; @@ -1901,13 +1722,13 @@ /* * Are we in the correct thread? */ -#if TCL_THREADS +#ifdef TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { - ForwardedOperation opcode; + int opcode; ForwardParam p; p.getOpt.name = optionName; p.getOpt.value = dsPtr; @@ -1915,11 +1736,11 @@ opcode = ForwardedGetOptAll; } else { opcode = ForwardedGetOpt; } - ForwardOpToHandlerThread(rcPtr, opcode, &p); + ForwardOpToOwnerThread(rcPtr, opcode, &p); if (p.base.code != TCL_OK) { Tcl_Obj *err = Tcl_NewStringObj(p.base.msgStr, -1); UnmarshallErrorResult(interp, err); @@ -1959,11 +1780,11 @@ * The result has to go into the 'dsPtr' for propagation to the caller of * the driver. */ if (optionObj != NULL) { - TclDStringAppendObj(dsPtr, resObj); + Tcl_DStringAppend(dsPtr, TclGetString(resObj), -1); goto ok; } /* * Extract the list and append each item as element. @@ -1990,15 +1811,15 @@ "Expected list with even number of " "elements, got %d element%s instead", listc, (listc == 1 ? "" : "s"))); goto error; } else { - size_t len; - const char *str = TclGetStringFromObj(resObj, &len); + int len; + char *str = Tcl_GetStringFromObj(resObj, &len); if (len) { - TclDStringAppendLiteral(dsPtr, " "); + Tcl_DStringAppend(dsPtr, " ", 1); Tcl_DStringAppend(dsPtr, str, len); } goto ok; } @@ -2058,12 +1879,11 @@ if (Tcl_ListObjGetElements(interp, obj, &listc, &listv) != TCL_OK) { return TCL_ERROR; } if (listc < 1) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad %s list: is empty", objName)); + Tcl_AppendResult(interp, "bad ", objName, " list: is empty", NULL); return TCL_ERROR; } events = 0; while (listc > 0) { @@ -2092,11 +1912,11 @@ * DecodeEventMask -- * * This function takes an internal bitmask of events and constructs the * equivalent list of event items. * - * Results, Contract: + * Results: * A Tcl_Obj reference. The object will have a refCount of one. The user * has to decrement it to release the object. * * Side effects: * None. @@ -2106,11 +1926,11 @@ static Tcl_Obj * DecodeEventMask( int mask) { - const char *eventStr; + register const char *eventStr; Tcl_Obj *evObj; switch (mask & RANDW) { case RANDW: eventStr = "read write"; @@ -2126,11 +1946,10 @@ break; } evObj = Tcl_NewStringObj(eventStr, -1); Tcl_IncrRefCount(evObj); - /* assert evObj.refCount == 1 */ return evObj; } /* *---------------------------------------------------------------------- @@ -2155,32 +1974,29 @@ Tcl_Obj *cmdpfxObj, int mode, Tcl_Obj *handleObj) { ReflectedChannel *rcPtr; - int mn = 0; + MethodName mn = METH_BLOCKING; - rcPtr = (ReflectedChannel *)Tcl_Alloc(sizeof(ReflectedChannel)); + 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 +#ifdef 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) { + while (mn <= METH_WRITE) { Tcl_ListObjAppendElement(NULL, rcPtr->methods, Tcl_NewStringObj(methodNames[mn++], -1)); } Tcl_IncrRefCount(rcPtr->methods); rcPtr->name = handleObj; @@ -2235,20 +2051,14 @@ ReflectedChannel *rcPtr) { Channel *chanPtr = (Channel *) rcPtr->chan; TclChannelRelease((Tcl_Channel)chanPtr); - if (rcPtr->name) { - Tcl_DecrRefCount(rcPtr->name); - } - if (rcPtr->methods) { - Tcl_DecrRefCount(rcPtr->methods); - } - if (rcPtr->cmd) { - Tcl_DecrRefCount(rcPtr->cmd); - } - Tcl_Free(rcPtr); + Tcl_DecrRefCount(rcPtr->name); + Tcl_DecrRefCount(rcPtr->methods); + Tcl_DecrRefCount(rcPtr->cmd); + ckfree((char*) rcPtr); } /* *---------------------------------------------------------------------- * @@ -2285,11 +2095,11 @@ Tcl_InterpState sr; /* State of handler interp */ int result; /* Result code of method invokation */ Tcl_Obj *resObj = NULL; /* Result of method invokation. */ Tcl_Obj *cmd; - if (rcPtr->dead) { + if (!rcPtr->interp) { /* * The channel is marked as dead. Bail out immediately, with an * appropriate error. */ @@ -2319,13 +2129,10 @@ Tcl_ListObjAppendElement(NULL, cmd, rcPtr->name); /* * Append the additional argument containing method specific details * behind the channel id. If specified. - * - * Because of the contract there is no need to increment the refcounts. - * The objects will survive the Tcl_EvalObjv without change. */ if (argOneObj) { Tcl_ListObjAppendElement(NULL, cmd, argOneObj); if (argTwoObj) { @@ -2339,11 +2146,11 @@ */ Tcl_IncrRefCount(cmd); sr = Tcl_SaveInterpState(rcPtr->interp, 0 /* Dummy */); Tcl_Preserve(rcPtr->interp); - result = Tcl_EvalObjEx(rcPtr->interp, cmd, TCL_EVAL_GLOBAL); + result = Tcl_GlobalEvalObj(rcPtr->interp, cmd); /* * We do not try to extract the result information if the caller has no * interest in it. I.e. there is no need to put effort into creating * something which is discarded immediately after. @@ -2365,12 +2172,12 @@ * 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) { - size_t cmdLen; - const char *cmdString = TclGetStringFromObj(cmd, &cmdLen); + int cmdLen; + const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen); Tcl_IncrRefCount(cmd); Tcl_ResetResult(rcPtr->interp); Tcl_SetObjResult(rcPtr->interp, Tcl_ObjPrintf( "chan handler returned bad code: %d", result)); @@ -2420,37 +2227,34 @@ * * Side effects: * None. * * Users: - * ReflectInput/Output(), to enable the signaling of EAGAIN on 0-sized - * short reads/writes. + * ReflectInput/Output(), to enable the signaling of EAGAIN + * on 0-sized short reads/writes. * *---------------------------------------------------------------------- */ static int -ErrnoReturn( - ReflectedChannel *rcPtr, - Tcl_Obj *resObj) +ErrnoReturn(ReflectedChannel *rcPtr, Tcl_Obj* resObj) { int code; Tcl_InterpState sr; /* State of handler interp */ - if (rcPtr->dead) { + if (!rcPtr->interp) { return 0; } sr = Tcl_SaveInterpState(rcPtr->interp, 0 /* Dummy */); UnmarshallErrorResult(rcPtr->interp, resObj); resObj = Tcl_GetObjResult(rcPtr->interp); - if (((Tcl_GetIntFromObj(rcPtr->interp, resObj, &code) != TCL_OK) - || (code >= 0))) { - if (strcmp("EAGAIN", TclGetString(resObj)) == 0) { - code = -EAGAIN; + if (((Tcl_GetIntFromObj(rcPtr->interp, resObj, &code) != TCL_OK) || (code >= 0))) { + if (strcmp ("EAGAIN",Tcl_GetString(resObj)) == 0) { + code = - EAGAIN; } else { code = 0; } } @@ -2477,16 +2281,17 @@ static ReflectedChannelMap * GetReflectedChannelMap( Tcl_Interp *interp) { - ReflectedChannelMap *rcmPtr = (ReflectedChannelMap *)Tcl_GetAssocData(interp, RCMKEY, NULL); + ReflectedChannelMap* rcmPtr = Tcl_GetAssocData(interp, RCMKEY, NULL); if (rcmPtr == NULL) { - rcmPtr = (ReflectedChannelMap *)Tcl_Alloc(sizeof(ReflectedChannelMap)); + rcmPtr = (ReflectedChannelMap *) ckalloc(sizeof(ReflectedChannelMap)); Tcl_InitHashTable(&rcmPtr->map, TCL_STRING_KEYS); - Tcl_SetAssocData(interp, RCMKEY, DeleteReflectedChannelMap, rcmPtr); + Tcl_SetAssocData(interp, RCMKEY, + (Tcl_InterpDeleteProc *) DeleteReflectedChannelMap, rcmPtr); } return rcmPtr; } /* @@ -2507,74 +2312,55 @@ * registered in this interpreter. * *---------------------------------------------------------------------- */ -static void -MarkDead( - ReflectedChannel *rcPtr) -{ - if (rcPtr->dead) { - return; - } - if (rcPtr->name) { - Tcl_DecrRefCount(rcPtr->name); - rcPtr->name = NULL; - } - if (rcPtr->methods) { - Tcl_DecrRefCount(rcPtr->methods); - rcPtr->methods = NULL; - } - if (rcPtr->cmd) { - Tcl_DecrRefCount(rcPtr->cmd); - rcPtr->cmd = NULL; - } - rcPtr->dead = 1; -} - static void DeleteReflectedChannelMap( ClientData clientData, /* The per-interpreter data structure. */ Tcl_Interp *interp) /* The interpreter being deleted. */ { - ReflectedChannelMap *rcmPtr = (ReflectedChannelMap *)clientData; - /* The map */ + ReflectedChannelMap* rcmPtr; /* The map */ Tcl_HashSearch hSearch; /* Search variable. */ Tcl_HashEntry *hPtr; /* Search variable. */ - ReflectedChannel *rcPtr; + ReflectedChannel* rcPtr; Tcl_Channel chan; -#if TCL_THREADS + +#ifdef TCL_THREADS ForwardingResult *resultPtr; ForwardingEvent *evPtr; ForwardParam *paramPtr; #endif /* * Delete all entries. The channels may have been closed already, or will * be closed later, by the standard IO finalization of an interpreter - * under destruction. Except for the channels which were moved to a + * under destruction. Except for the channels which were moved to a * different interpreter and/or thread. They do not exist from the IO * 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 * DeleteThreadReflectedChannelMap(), just restricted to the channels of * this interp. */ + rcmPtr = clientData; 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); + hPtr != NULL; + hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch)) { - MarkDead(rcPtr); + chan = (Tcl_Channel) Tcl_GetHashValue (hPtr); + rcPtr = (ReflectedChannel *) Tcl_GetChannelInstanceData(chan); + + rcPtr->interp = NULL; + Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(&rcmPtr->map); - Tcl_Free(&rcmPtr->map); + ckfree((char *) &rcmPtr->map); -#if TCL_THREADS +#ifdef TCL_THREADS /* * The origin interpreter for one or more reflected channels is gone. */ /* @@ -2584,17 +2370,14 @@ */ Tcl_MutexLock(&rcForwardMutex); for (resultPtr = forwardList; - resultPtr != NULL; - resultPtr = resultPtr->nextPtr) { + resultPtr != NULL; + resultPtr = resultPtr->nextPtr) { if (resultPtr->dsti != interp) { - /* - * Ignore results/events for other interpreters. - */ - + /* Ignore results/events for other interpreters. */ continue; } /* * The receiver for the event exited, before processing the event. We @@ -2605,18 +2388,10 @@ * 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; } @@ -2626,11 +2401,10 @@ ForwardSetStaticError(paramPtr, msg_send_dstlost); Tcl_ConditionNotify(&resultPtr->done); } - Tcl_MutexUnlock(&rcForwardMutex); /* * Get the map of all channels handled by the current thread. This is a * ReflectedChannelMap, but on a per-thread basis, not per-interp. Go * through the channels and remove all which were handled by this @@ -2637,30 +2411,29 @@ * 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); + 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. - */ - + /* Ignore entries for other interpreters */ continue; } - MarkDead(rcPtr); Tcl_DeleteHashEntry(hPtr); } + + Tcl_MutexUnlock(&rcForwardMutex); #endif } -#if TCL_THREADS +#ifdef TCL_THREADS /* *---------------------------------------------------------------------- * * GetThreadReflectedChannelMap -- * @@ -2675,16 +2448,16 @@ * *---------------------------------------------------------------------- */ static ReflectedChannelMap * -GetThreadReflectedChannelMap(void) +GetThreadReflectedChannelMap() { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!tsdPtr->rcmPtr) { - tsdPtr->rcmPtr = (ReflectedChannelMap *)Tcl_Alloc(sizeof(ReflectedChannelMap)); + tsdPtr->rcmPtr = (ReflectedChannelMap *) ckalloc(sizeof(ReflectedChannelMap)); Tcl_InitHashTable(&tsdPtr->rcmPtr->map, TCL_STRING_KEYS); Tcl_CreateThreadExitHandler(DeleteThreadReflectedChannelMap, NULL); } return tsdPtr->rcmPtr; @@ -2695,11 +2468,11 @@ * * DeleteThreadReflectedChannelMap -- * * Deletes the channel table for a thread. This procedure is invoked when * a thread is deleted. The channels have already been marked as dead, in - * DeleteReflectedChannelMap(). + * DeleteReflectedChannelMap(). * * Results: * None. * * Side effects: @@ -2708,43 +2481,42 @@ *---------------------------------------------------------------------- */ static void DeleteThreadReflectedChannelMap( - TCL_UNUSED(ClientData)) + ClientData clientData) /* The per-thread data structure. */ { Tcl_HashSearch hSearch; /* Search variable. */ Tcl_HashEntry *hPtr; /* Search variable. */ Tcl_ThreadId self = Tcl_GetCurrentThread(); - ReflectedChannelMap *rcmPtr; /* The map */ + + ReflectedChannelMap* rcmPtr; /* The map */ + Tcl_Channel chan; + ReflectedChannel* rcPtr; ForwardingResult *resultPtr; + ForwardingEvent *evPtr; + ForwardParam *paramPtr; /* * The origin thread for one or more reflected channels is gone. * NOTE: If this function is called due to a thread getting killed the * per-interp DeleteReflectedChannelMap is apparently not called. */ /* * 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. + * destined for this thread. While this is in progress we block any + * other access to the list of pending results. */ Tcl_MutexLock(&rcForwardMutex); for (resultPtr = forwardList; - resultPtr != NULL; - resultPtr = resultPtr->nextPtr) { - ForwardingEvent *evPtr; - ForwardParam *paramPtr; - + resultPtr != NULL; + resultPtr = resultPtr->nextPtr) { if (resultPtr->dst != self) { - /* - * Ignore results/events for other threads. - */ - + /* Ignore results/events for other threads. */ continue; } /* * The receiver for the event exited, before processing the event. We @@ -2755,18 +2527,10 @@ * 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; } @@ -2776,51 +2540,39 @@ ForwardSetStaticError(paramPtr, msg_send_dstlost); Tcl_ConditionNotify(&resultPtr->done); } - Tcl_MutexUnlock(&rcForwardMutex); - - /* - * Run over the event queue of this thread and remove all ReflectEvent's - * still pending. These are inbound events for reflected channels this - * thread owns but doesn't handle. The inverse of the channel map - * actually. - */ - - Tcl_DeleteEvents(ReflectEventDelete, NULL); /* * Get the map of all channels handled by the current thread. This is a * ReflectedChannelMap, but on a per-thread basis, not per-interp. Go * 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); + hPtr != NULL; + hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch)) { - MarkDead(rcPtr); + chan = (Tcl_Channel) Tcl_GetHashValue (hPtr); + rcPtr = (ReflectedChannel *) Tcl_GetChannelInstanceData(chan); + + rcPtr->interp = NULL; + Tcl_DeleteHashEntry(hPtr); } - Tcl_Free(rcmPtr); + + Tcl_MutexUnlock(&rcForwardMutex); } static void -ForwardOpToHandlerThread( +ForwardOpToOwnerThread( ReflectedChannel *rcPtr, /* Channel instance */ ForwardedOperation op, /* Forwarded driver operation */ - const void *param) /* Arguments */ + const VOID *param) /* Arguments */ { - /* - * Core of the communication from OWNER to HANDLER thread. The receiver is - * ForwardProc() below. - */ - Tcl_ThreadId dst = rcPtr->thread; ForwardingEvent *evPtr; ForwardingResult *resultPtr; /* @@ -2828,36 +2580,36 @@ * channel without interference from DeleteThreadReflectedChannelMap(). */ Tcl_MutexLock(&rcForwardMutex); - if (rcPtr->dead) { + if (rcPtr->interp == NULL) { /* * The channel is marked as dead. Bail out immediately, with an * appropriate error. Do not forget to unlock the mutex on this path. */ - ForwardSetStaticError((ForwardParam *) param, msg_send_dstlost); + ForwardSetStaticError((ForwardParam *)param, msg_send_dstlost); Tcl_MutexUnlock(&rcForwardMutex); return; } /* * Create and initialize the event and data structures. */ - evPtr = (ForwardingEvent *)Tcl_Alloc(sizeof(ForwardingEvent)); - resultPtr = (ForwardingResult *)Tcl_Alloc(sizeof(ForwardingResult)); + 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; - resultPtr->src = Tcl_GetCurrentThread(); - resultPtr->dst = dst; + resultPtr->src = Tcl_GetCurrentThread(); + resultPtr->dst = dst; resultPtr->dsti = rcPtr->interp; resultPtr->done = NULL; resultPtr->result = -1; resultPtr->evPtr = evPtr; @@ -2864,34 +2616,31 @@ /* * Now execute the forward. */ TclSpliceIn(resultPtr, forwardList); - - /* - * Do not unlock here. That is done by the ConditionWait. - */ + /* Do not unlock here. That is done by the ConditionWait */ /* * Ensure cleanup of the event if the origin thread exits while this event - * is pending or in progress. Exit of the destination thread is handled by - * DeleteThreadReflectedChannelMap(), this is set up by - * GetThreadReflectedChannelMap(). This is what we use the 'forwardList' + * is pending or in progress. Exitus of the destination thread is handled + * by DeleteThreadReflectionChannelMap(), this is set up by + * GetThreadReflectedChannelMap(). This is what we use the 'forwardList' * (see above) for. */ - Tcl_CreateThreadExitHandler(SrcExitProc, evPtr); + Tcl_CreateThreadExitHandler(SrcExitProc, (ClientData) evPtr); /* * Queue the event and poke the other thread's notifier. */ - Tcl_ThreadQueueEvent(dst, (Tcl_Event *) evPtr, TCL_QUEUE_TAIL); + Tcl_ThreadQueueEvent(dst, (Tcl_Event *)evPtr, TCL_QUEUE_TAIL); Tcl_ThreadAlert(dst); /* - * (*) Block until the handler thread has either processed the transfer or + * (*) Block until the other thread has either processed the transfer or * rejected it. */ while (resultPtr->result < 0) { /* @@ -2905,12 +2654,12 @@ Tcl_ConditionWait(&resultPtr->done, &rcForwardMutex, NULL); } /* - * Unlink result from the forwarder list. No need to lock. Either still - * locked, or locked by the ConditionWait + * Unlink result from the forwarder list. + * No need to lock. Either still locked, or locked by the ConditionWait */ TclSpliceOut(resultPtr, forwardList); resultPtr->nextPtr = NULL; @@ -2924,30 +2673,25 @@ * returning the success code. * * Note: The event structure has already been deleted. */ - Tcl_DeleteThreadExitHandler(SrcExitProc, evPtr); + Tcl_DeleteThreadExitHandler(SrcExitProc, (ClientData) evPtr); - Tcl_Free(resultPtr); + ckfree((char*) resultPtr); } static int ForwardProc( Tcl_Event *evGPtr, - TCL_UNUSED(int) /* mask */) + int mask) { /* - * HANDLER thread. - - * The receiver part for the operations coming from the OWNER thread. - * See ForwardOpToHandlerThread() for the transmitter. - * * 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., + * evPtr->src), however this thread is currently blocked at (*), i.e. * quiescent. Because of this we can treat the data as belonging to us, * without fear of race conditions. I.e. we can read and write as we like. * * The only thing we cannot be sure of is the resultPtr. This can be be * NULLed if the originating thread went away while the event is handled @@ -2958,13 +2702,12 @@ ForwardingResult *resultPtr = evPtr->resultPtr; ReflectedChannel *rcPtr = evPtr->rcPtr; Tcl_Interp *interp = rcPtr->interp; ForwardParam *paramPtr = evPtr->param; Tcl_Obj *resObj = NULL; /* Interp result of InvokeTclMethod */ - ReflectedChannelMap *rcmPtr;/* Map of reflected channels with handlers in - * this interp. */ - Tcl_HashEntry *hPtr; /* Entry in the above map */ + ReflectedChannelMap* rcmPtr; /* Map of reflected channels with handlers in this interp */ + Tcl_HashEntry* hPtr; /* Entry in the above map */ /* * Ignore the event if no one is waiting for its result anymore. */ @@ -2985,10 +2728,12 @@ case ForwardedClose: { /* * No parameters/results. */ + + Tcl_ChannelType *tctPtr; if (InvokeTclMethod(rcPtr, METH_FINAL, NULL, NULL, &resObj)!=TCL_OK) { ForwardSetObjError(paramPtr, resObj); } @@ -3000,55 +2745,59 @@ * We remove the channel from both interpreter and thread maps before * releasing the memory, to prevent future accesses (like by * 'postevent') from finding and dereferencing a dangling pointer. */ - rcmPtr = GetReflectedChannelMap(interp); - hPtr = Tcl_FindHashEntry(&rcmPtr->map, - Tcl_GetChannelName(rcPtr->chan)); - Tcl_DeleteHashEntry(hPtr); - - rcmPtr = GetThreadReflectedChannelMap(); - hPtr = Tcl_FindHashEntry(&rcmPtr->map, - Tcl_GetChannelName(rcPtr->chan)); - Tcl_DeleteHashEntry(hPtr); - MarkDead(rcPtr); + rcmPtr = GetReflectedChannelMap (interp); + hPtr = Tcl_FindHashEntry (&rcmPtr->map, + Tcl_GetChannelName (rcPtr->chan)); + Tcl_DeleteHashEntry (hPtr); + + rcmPtr = GetThreadReflectedChannelMap(); + hPtr = Tcl_FindHashEntry (&rcmPtr->map, + Tcl_GetChannelName (rcPtr->chan)); + Tcl_DeleteHashEntry (hPtr); + + tctPtr = ((Channel *)rcPtr->chan)->typePtr; + if (tctPtr && tctPtr != &tclRChannelType) { + ckfree((char *)tctPtr); + ((Channel *)rcPtr->chan)->typePtr = NULL; + } + Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); break; } case ForwardedInput: { - Tcl_Obj *toReadObj; + Tcl_Obj *toReadObj = Tcl_NewIntObj(paramPtr->input.toRead); + Tcl_IncrRefCount(toReadObj); - TclNewIntObj(toReadObj, paramPtr->input.toRead); - Tcl_IncrRefCount(toReadObj); - - Tcl_Preserve(rcPtr); + Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr, METH_READ, toReadObj, NULL, &resObj)!=TCL_OK){ - int code = ErrnoReturn(rcPtr, resObj); + int code = ErrnoReturn (rcPtr, resObj); if (code < 0) { paramPtr->base.code = code; } else { ForwardSetObjError(paramPtr, resObj); } - paramPtr->input.toRead = TCL_IO_FAILURE; + paramPtr->input.toRead = -1; } else { /* * Process a regular result. */ - size_t bytec = 0; /* Number of returned bytes */ + int bytec; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ - bytev = TclGetByteArrayFromObj(resObj, &bytec); + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); if (paramPtr->input.toRead < bytec) { ForwardSetStaticError(paramPtr, msg_read_toomuch); - paramPtr->input.toRead = TCL_IO_FAILURE; + paramPtr->input.toRead = -1; } else { - if (bytec + 1 > 1) { - memcpy(paramPtr->input.buf, bytev, bytec); + if (bytec > 0) { + memcpy(paramPtr->input.buf, bytev, (size_t)bytec); } paramPtr->input.toRead = bytec; } } Tcl_Release(rcPtr); @@ -3056,11 +2805,11 @@ break; } case ForwardedOutput: { Tcl_Obj *bufObj = Tcl_NewByteArrayObj((unsigned char *) - paramPtr->output.buf, paramPtr->output.toWrite); + paramPtr->output.buf, paramPtr->output.toWrite); Tcl_IncrRefCount(bufObj); Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr, METH_WRITE, bufObj, NULL, &resObj) != TCL_OK) { int code = ErrnoReturn(rcPtr, resObj); @@ -3077,13 +2826,11 @@ */ int written; if (Tcl_GetIntFromObj(interp, resObj, &written) != TCL_OK) { - Tcl_DecrRefCount(resObj); - resObj = MarshallError(interp); - ForwardSetObjError(paramPtr, resObj); + ForwardSetObjError(paramPtr, MarshallError(interp)); paramPtr->output.toWrite = -1; } else if (written==0 || paramPtr->output.toWriteoutput.toWrite = -1; } else { @@ -3094,22 +2841,19 @@ Tcl_DecrRefCount(bufObj); break; } case ForwardedSeek: { - Tcl_Obj *offObj; - Tcl_Obj *baseObj; - - TclNewIntObj(offObj, paramPtr->seek.offset); - baseObj = Tcl_NewStringObj( + Tcl_Obj *offObj = Tcl_NewWideIntObj(paramPtr->seek.offset); + Tcl_Obj *baseObj = Tcl_NewStringObj( (paramPtr->seek.seekMode==SEEK_SET) ? "start" : (paramPtr->seek.seekMode==SEEK_CUR) ? "current" : "end", -1); - Tcl_IncrRefCount(offObj); - Tcl_IncrRefCount(baseObj); + Tcl_IncrRefCount(offObj); + Tcl_IncrRefCount(baseObj); - Tcl_Preserve(rcPtr); + Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr, METH_SEEK, offObj, baseObj, &resObj)!=TCL_OK){ ForwardSetObjError(paramPtr, resObj); paramPtr->seek.offset = -1; } else { /* @@ -3118,20 +2862,18 @@ */ Tcl_WideInt newLoc; if (Tcl_GetWideIntFromObj(interp, resObj, &newLoc) == TCL_OK) { - if (newLoc < 0) { + if (newLoc < Tcl_LongAsWide(0)) { ForwardSetStaticError(paramPtr, msg_seek_beforestart); paramPtr->seek.offset = -1; } else { paramPtr->seek.offset = newLoc; } } else { - Tcl_DecrRefCount(resObj); - resObj = MarshallError(interp); - ForwardSetObjError(paramPtr, resObj); + ForwardSetObjError(paramPtr, MarshallError(interp)); paramPtr->seek.offset = -1; } } Tcl_Release(rcPtr); Tcl_DecrRefCount(offObj); @@ -3151,31 +2893,31 @@ break; } case ForwardedBlock: { Tcl_Obj *blockObj = Tcl_NewBooleanObj(!paramPtr->block.nonblocking); - Tcl_IncrRefCount(blockObj); + Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr, METH_BLOCKING, blockObj, NULL, - &resObj) != TCL_OK) { + &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); } Tcl_Release(rcPtr); Tcl_DecrRefCount(blockObj); break; } case ForwardedSetOpt: { Tcl_Obj *optionObj = Tcl_NewStringObj(paramPtr->setOpt.name, -1); - Tcl_Obj *valueObj = Tcl_NewStringObj(paramPtr->setOpt.value, -1); + Tcl_Obj *valueObj = Tcl_NewStringObj(paramPtr->setOpt.value, -1); Tcl_IncrRefCount(optionObj); Tcl_IncrRefCount(valueObj); Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr, METH_CONFIGURE, optionObj, valueObj, - &resObj) != TCL_OK) { + &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); } Tcl_Release(rcPtr); Tcl_DecrRefCount(optionObj); Tcl_DecrRefCount(valueObj); @@ -3186,17 +2928,18 @@ /* * Retrieve the value of one option. */ Tcl_Obj *optionObj = Tcl_NewStringObj(paramPtr->getOpt.name, -1); - Tcl_IncrRefCount(optionObj); + Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr, METH_CGET, optionObj, NULL, &resObj)!=TCL_OK){ ForwardSetObjError(paramPtr, resObj); } else { - TclDStringAppendObj(paramPtr->getOpt.value, resObj); + Tcl_DStringAppend(paramPtr->getOpt.value, + TclGetString(resObj), -1); } Tcl_Release(rcPtr); Tcl_DecrRefCount(optionObj); break; } @@ -3217,31 +2960,29 @@ int listc; Tcl_Obj **listv; if (Tcl_ListObjGetElements(interp, resObj, &listc, - &listv) != TCL_OK) { - Tcl_DecrRefCount(resObj); - resObj = MarshallError(interp); - ForwardSetObjError(paramPtr, resObj); + &listv) != TCL_OK) { + ForwardSetObjError(paramPtr, MarshallError(interp)); } else if ((listc % 2) == 1) { /* * Odd number of elements is wrong. [x]. */ - char *buf = (char *)Tcl_Alloc(200); + char *buf = ckalloc(200); sprintf(buf, "{Expected list with even number of elements, got %d %s instead}", listc, (listc == 1 ? "element" : "elements")); ForwardSetDynamicError(paramPtr, buf); } else { - size_t len; - const char *str = TclGetStringFromObj(resObj, &len); + int len; + const char *str = Tcl_GetStringFromObj(resObj, &len); if (len) { - TclDStringAppendLiteral(paramPtr->getOpt.value, " "); + Tcl_DStringAppend(paramPtr->getOpt.value, " ", 1); Tcl_DStringAppend(paramPtr->getOpt.value, str, len); } } } Tcl_Release(rcPtr); @@ -3283,11 +3024,11 @@ static void SrcExitProc( ClientData clientData) { - ForwardingEvent *evPtr = (ForwardingEvent *)clientData; + ForwardingEvent *evPtr = (ForwardingEvent *) clientData; ForwardingResult *resultPtr; ForwardParam *paramPtr; /* * NOTE (2): Can this handler be called with the originator blocked? @@ -3332,16 +3073,16 @@ static void ForwardSetObjError( ForwardParam *paramPtr, Tcl_Obj *obj) { - size_t len; - const char *msgStr = TclGetStringFromObj(obj, &len); + int len; + const char *msgStr = Tcl_GetStringFromObj(obj, &len); len++; - ForwardSetDynamicError(paramPtr, Tcl_Alloc(len)); - memcpy(paramPtr->base.msgStr, msgStr, len); + ForwardSetDynamicError(paramPtr, ckalloc((unsigned) len)); + memcpy(paramPtr->base.msgStr, msgStr, (unsigned) len); } #endif /* * Local Variables: DELETED generic/tclIORTrans.c Index: generic/tclIORTrans.c ================================================================== --- generic/tclIORTrans.c +++ /dev/null @@ -1,3363 +0,0 @@ -/* - * tclIORTrans.c -- - * - * This file contains the implementation of Tcl's generic transformation - * reflection code, which allows the implementation of Tcl channel - * transformations in Tcl code. - * - * Parts of this file are based on code contributed by Jean-Claude - * Wippler. - * - * See TIP #230 for the specification of this functionality. - * - * Copyright (c) 2007-2008 ActiveState. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include "tclInt.h" -#include "tclIO.h" -#include - -#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); -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. */ - NULL, /* Close channel, clean instance data. */ - ReflectInput, /* Handle read request. */ - ReflectOutput, /* Handle write request. */ - NULL, /* Move location of access point. */ - 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. */ - size_t allocated; /* Allocated size of the buffer area. */ - size_t used; /* Number of bytes in the buffer, - * <= allocated. */ -} ResultBuffer; - -#define ResultLength(r) ((r)->used) -/* static int ResultLength(ResultBuffer *r); */ - -static void ResultClear(ResultBuffer *r); -static void ResultInit(ResultBuffer *r); -static void ResultAdd(ResultBuffer *r, unsigned char *buf, - int toWrite); -static int ResultCopy(ResultBuffer *r, unsigned char *buf, - int toRead); - -#define RB_INCREMENT (512) - -/* - * Convenience macro to make some casts easier to use. - */ - -#define UCHARP(x) ((unsigned char *) (x)) - -/* - * Instance data for a reflected transformation. =========================== - */ - -typedef struct { - Tcl_Channel chan; /* Back reference to the channel of the - * transformation itself. */ - Tcl_Channel parent; /* Reference to the channel the transformation - * was pushed on. */ - Tcl_Interp *interp; /* Reference to the interpreter containing the - * Tcl level part of the channel. */ - Tcl_Obj *handle; /* Reference to transform handle. Also stored - * in the argv, see below. The separate field - * gives us direct access, needed when working - * with the reflection maps. */ -#if TCL_THREADS - Tcl_ThreadId thread; /* Thread the 'interp' belongs to. */ -#endif - - Tcl_TimerToken timer; - - /* See [==] as well. - * Storage for the command prefix and the additional words required for - * the invocation of methods in the command handler. - * - * argv [0] ... [.] | [argc-2] [argc-1] | [argc] [argc+2] - * cmd ... pfx | method chan | detail1 detail2 - * ~~~~ CT ~~~ ~~ CT ~~ - * - * CT = Belongs to the 'Command handler Thread'. - */ - - int argc; /* Number of preallocated words - 2. */ - Tcl_Obj **argv; /* Preallocated array for calling the handler. - * args[0] is placeholder for cmd word. - * Followed by the arguments in the prefix, - * plus 4 placeholders for method, channel, - * and at most two varying (method specific) - * words. */ - int methods; /* Bitmask of supported methods. */ - - /* - * NOTE (9): Should we have predefined shared literals for the method - * names? - */ - - int mode; /* Mask of R/W mode */ - int nonblocking; /* Flag: Channel is blocking or not. */ - int readIsDrained; /* Flag: Read buffers are flushed. */ - int eofPending; /* Flag: EOF seen down, but not raised up */ - int dead; /* Boolean signal that some operations - * should no longer be attempted. */ - ResultBuffer result; -} ReflectedTransform; - -/* - * Structure of the table mapping from transform handles to reflected - * transform (channels). Each interpreter which has the handler command for - * one or more reflected transforms records them in such a table, so that we - * are able to find them during interpreter/thread cleanup even if the actual - * channel they belong to was moved to a different interpreter and/or thread. - * - * The table is reachable via the standard interpreter AssocData, the key is - * defined below. - */ - -typedef struct { - Tcl_HashTable map; -} ReflectedTransformMap; - -#define RTMKEY "ReflectedTransformMap" - -/* - * Method literals. ================================================== - */ - -static const char *const methodNames[] = { - "clear", /* OPT */ - "drain", /* OPT, drain => read */ - "finalize", /* */ - "flush", /* OPT, flush => write */ - "initialize", /* */ - "limit?", /* OPT */ - "read", /* OPT */ - "write", /* OPT */ - NULL -}; -typedef enum { - METH_CLEAR, - METH_DRAIN, - METH_FINAL, - METH_FLUSH, - METH_INIT, - METH_LIMIT, - METH_READ, - METH_WRITE -} MethodName; - -#define FLAG(m) (1 << (m)) -#define REQUIRED_METHODS \ - (FLAG(METH_INIT) | FLAG(METH_FINAL)) -#define RANDW \ - (TCL_READABLE | TCL_WRITABLE) - -#define IMPLIES(a,b) ((!(a)) || (b)) -#define NEGIMPL(a,b) -#define HAS(x,f) (x & FLAG(f)) - -#if TCL_THREADS -/* - * Thread specific types and structures. - * - * We are here essentially creating a very specific implementation of 'thread - * send'. - */ - -/* - * Enumeration of all operations which can be forwarded. - */ - -typedef enum { - ForwardedClear, - ForwardedClose, - ForwardedDrain, - ForwardedFlush, - ForwardedInput, - ForwardedLimit, - ForwardedOutput -} ForwardedOperation; - -/* - * Event used to forward driver invocations to the thread actually managing - * the channel. We cannot construct the command to execute and forward that. - * Because then it will contain a mixture of Tcl_Obj's belonging to both the - * command handler thread (CT), and the thread managing the channel (MT), - * executed in CT. Tcl_Obj's are not allowed to cross thread boundaries. So we - * forward an operation code, the argument details, and reference to results. - * The command is assembled in the CT and belongs fully to that thread. No - * sharing problems. - */ - -typedef struct { - int code; /* O: Ok/Fail of the cmd handler */ - char *msgStr; /* O: Error message for handler failure */ - int mustFree; /* O: True if msgStr is allocated, false if - * otherwise (static). */ -} ForwardParamBase; - -/* - * Operation specific parameter/result structures. (These are "subtypes" of - * ForwardParamBase. Where an operation does not need any special types, it - * 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 */ - size_t 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 */ -}; - -/* - * Now join all these together in a single union for convenience. - */ - -typedef union ForwardParam { - ForwardParamBase base; - struct ForwardParamTransform transform; - struct ForwardParamLimit limit; -} ForwardParam; - -/* - * Forward declaration. - */ - -typedef struct ForwardingResult ForwardingResult; - -/* - * General event structure, with reference to operation specific data. - */ - -typedef struct { - Tcl_Event event; /* Basic event data, has to be first item */ - ForwardingResult *resultPtr; - ForwardedOperation op; /* Forwarded driver operation */ - ReflectedTransform *rtPtr; /* Channel instance */ - ForwardParam *param; /* Packaged arguments and return values, a - * ForwardParam pointer. */ -} ForwardingEvent; - -/* - * Structure to manage the result of the forwarding. This is not the result of - * the operation itself, but about the success of the forward event itself. - * The event can be successful, even if the operation which was forwarded - * failed. It is also there to manage the synchronization between the involved - * threads. - */ - -struct ForwardingResult { - Tcl_ThreadId src; /* Originating thread. */ - Tcl_ThreadId dst; /* Thread the op was forwarded to. */ - Tcl_Interp *dsti; /* Interpreter in the thread the op was - * forwarded to. */ - Tcl_Condition done; /* Condition variable the forwarder blocks - * on. */ - int result; /* TCL_OK or TCL_ERROR */ - ForwardingEvent *evPtr; /* Event the result belongs to. */ - ForwardingResult *prevPtr, *nextPtr; - /* Links into the list of pending forwarded - * results. */ -}; - -typedef struct { - /* - * Table of all reflected transformations owned by this thread. - */ - - ReflectedTransformMap *rtmPtr; -} ThreadSpecificData; - -static Tcl_ThreadDataKey dataKey; - -/* - * List of forwarded operations which have not completed yet, plus the mutex - * to protect the access to this process global list. - */ - -static ForwardingResult *forwardList = NULL; -TCL_DECLARE_MUTEX(rtForwardMutex) - -/* - * Function containing the generic code executing a forward, and wrapper - * macros for the actual operations we wish to forward. Uses ForwardProc as - * the event function executed by the thread receiving a forwarding event - * (which executes the appropriate function and collects the result, if any). - * - * The two ExitProcs are handlers so that things do not deadlock when either - * thread involved in the forwarding exits. They also clean things up so that - * we don't leak resources when threads go away. - */ - -static void ForwardOpToOwnerThread(ReflectedTransform *rtPtr, - 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) { \ - Tcl_Free((p)->base.msgStr); \ - } \ - } while (0) -#define PassReceivedErrorInterp(i,p) \ - do { \ - if ((i) != NULL) { \ - Tcl_SetChannelErrorInterp((i), \ - Tcl_NewStringObj((p)->base.msgStr, -1)); \ - } \ - FreeReceivedError(p); \ - } while (0) -#define PassReceivedError(c,p) \ - do { \ - Tcl_SetChannelError((c), \ - Tcl_NewStringObj((p)->base.msgStr, -1)); \ - FreeReceivedError(p); \ - } while (0) -#define ForwardSetStaticError(p,emsg) \ - do { \ - (p)->base.code = TCL_ERROR; \ - (p)->base.mustFree = 0; \ - (p)->base.msgStr = (char *) (emsg); \ - } while (0) -#define ForwardSetDynamicError(p,emsg) \ - do { \ - (p)->base.code = TCL_ERROR; \ - (p)->base.mustFree = 1; \ - (p)->base.msgStr = (char *) (emsg); \ - } while (0) - -static void ForwardSetObjError(ForwardParam *p, - Tcl_Obj *objPtr); -static ReflectedTransformMap * GetThreadReflectedTransformMap(void); -static void DeleteThreadReflectedTransformMap( - ClientData clientData); -#endif /* TCL_THREADS */ - -#define SetChannelErrorStr(c,msgStr) \ - Tcl_SetChannelError((c), Tcl_NewStringObj((msgStr), -1)) - -static Tcl_Obj * MarshallError(Tcl_Interp *interp); -static void UnmarshallErrorResult(Tcl_Interp *interp, - Tcl_Obj *msgObj); - -/* - * Static functions for this file: - */ - -static Tcl_Obj * DecodeEventMask(int mask); -static ReflectedTransform * NewReflectedTransform(Tcl_Interp *interp, - Tcl_Obj *cmdpfxObj, int mode, Tcl_Obj *handleObj, - Tcl_Channel parentChan); -static Tcl_Obj * NextHandle(void); -static void FreeReflectedTransform(ReflectedTransform *rtPtr); -static void FreeReflectedTransformArgs(ReflectedTransform *rtPtr); -static int InvokeTclMethod(ReflectedTransform *rtPtr, - const char *method, Tcl_Obj *argOneObj, - Tcl_Obj *argTwoObj, Tcl_Obj **resultObjPtr); - -static ReflectedTransformMap * GetReflectedTransformMap(Tcl_Interp *interp); -static void DeleteReflectedTransformMap(ClientData clientData, - Tcl_Interp *interp); - -/* - * 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 - * list-quoting to keep the words of the message together. See also [x]. - */ - -static const char *msg_read_unsup = "{read not supported by Tcl driver}"; -static const char *msg_write_unsup = "{write not supported by Tcl driver}"; -#if TCL_THREADS -static const char *msg_send_originlost = "{Channel thread lost}"; -static const char *msg_send_dstlost = "{Owner lost}"; -#endif /* TCL_THREADS */ -static const char *msg_dstlost = - "-code 1 -level 0 -errorcode NONE -errorinfo {} -errorline 1 {Owner lost}"; - -/* - * Timer management (flushing out buffered data via artificial events). - */ - -/* - * Helper functions encapsulating some of the thread forwarding to make the - * control flow in callers easier. - */ - -static void TimerKill(ReflectedTransform *rtPtr); -static void TimerSetup(ReflectedTransform *rtPtr); -static void TimerRun(ClientData clientData); -static int TransformRead(ReflectedTransform *rtPtr, - int *errorCodePtr, Tcl_Obj *bufObj); -static int TransformWrite(ReflectedTransform *rtPtr, - int *errorCodePtr, unsigned char *buf, - int toWrite); -static int TransformDrain(ReflectedTransform *rtPtr, - int *errorCodePtr); -static int TransformFlush(ReflectedTransform *rtPtr, - int *errorCodePtr, int op); -static void TransformClear(ReflectedTransform *rtPtr); -static int TransformLimit(ReflectedTransform *rtPtr, - int *errorCodePtr, int *maxPtr); - -/* - * Operation codes for TransformFlush(). - */ - -#define FLUSH_WRITE 1 -#define FLUSH_DISCARD 0 - -/* - * Main methods to plug into the 'chan' ensemble'. ================== - */ - -/* - *---------------------------------------------------------------------- - * - * TclChanPushObjCmd -- - * - * This function is invoked to process the "chan push" Tcl command. See - * the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. The handle of the new channel is placed in the - * interp result. - * - * Side effects: - * 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 */ - Tcl_Channel parentChan; /* Token of parent channel */ - int mode; /* R/W mode of parent, later the new channel. - * Has to match the abilities of the handler - * commands */ - Tcl_Obj *cmdObj; /* Command prefix, list of words */ - Tcl_Obj *cmdNameObj; /* Command name */ - Tcl_Obj *rtId; /* Handle of the new transform (channel) */ - Tcl_Obj *modeObj; /* mode in obj form for method call */ - int listc; /* Result of 'initialize', and of */ - Tcl_Obj **listv; /* its sublist in the 2nd element */ - int methIndex; /* Encoded method name */ - int result; /* Result code for 'initialize' */ - Tcl_Obj *resObj; /* Result data for 'initialize' */ - int methods; /* Bitmask for supported methods. */ - ReflectedTransformMap *rtmPtr; - /* Map of reflected transforms with handlers - * in this interp. */ - Tcl_HashEntry *hPtr; /* Entry in the above map */ - int isNew; /* Placeholder. */ - - /* - * Syntax: chan push CHANNEL CMDPREFIX - * [0] [1] [2] [3] - * - * Actually: rPush CHANNEL CMDPREFIX - * [0] [1] [2] - */ - -#define CHAN (1) -#define CMD (2) - - /* - * Number of arguments... - */ - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "channel cmdprefix"); - return TCL_ERROR; - } - - /* - * First argument is a channel handle. - */ - - chanObj = objv[CHAN]; - parentChan = Tcl_GetChannel(interp, TclGetString(chanObj), &mode); - if (parentChan == NULL) { - return TCL_ERROR; - } - parentChan = Tcl_GetTopChannel(parentChan); - - /* - * Second argument is command prefix, i.e. list of words, first word is - * name of handler command, other words are fixed arguments. Run the - * 'initialize' method to get the list of supported methods. Validate - * this. - */ - - cmdObj = objv[CMD]; - - /* - * Basic check that the command prefix truly is a list. - */ - - if (Tcl_ListObjIndex(interp, cmdObj, 0, &cmdNameObj) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Now create the transformation (channel). - */ - - rtId = NextHandle(); - rtPtr = NewReflectedTransform(interp, cmdObj, mode, rtId, parentChan); - - /* - * Invoke 'initialize' and validate that the handler is present and ok. - * Squash the transformation if not. - */ - - modeObj = DecodeEventMask(mode); - /* assert modeObj.refCount == 1 */ - result = InvokeTclMethod(rtPtr, "initialize", modeObj, NULL, &resObj); - Tcl_DecrRefCount(modeObj); - if (result != TCL_OK) { - UnmarshallErrorResult(interp, resObj); - Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ - goto error; - } - - /* - * Verify the result. - * - List, of method names. Convert to mask. Check for non-optionals - * through the mask. Compare open mode against optional r/w. - */ - - if (Tcl_ListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "chan handler \"%s initialize\" returned non-list: %s", - TclGetString(cmdObj), TclGetString(resObj))); - Tcl_DecrRefCount(resObj); - goto error; - } - - methods = 0; - while (listc > 0) { - if (Tcl_GetIndexFromObj(interp, listv[listc-1], methodNames, - "method", TCL_EXACT, &methIndex) != TCL_OK) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "chan handler \"%s initialize\" returned %s", - TclGetString(cmdObj), - Tcl_GetStringResult(interp))); - Tcl_DecrRefCount(resObj); - goto error; - } - - methods |= FLAG(methIndex); - listc--; - } - Tcl_DecrRefCount(resObj); - - if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "chan handler \"%s\" does not support all required methods", - TclGetString(cmdObj))); - goto error; - } - - /* - * Mode tell us what the parent channel supports. The methods tell us what - * the handler supports. We remove the non-supported bits from the mode - * and check that the channel is not completely inacessible. Afterward the - * mode tells us which methods are still required, and these methods will - * also be supported by the handler, by design of the check. - */ - - if (!HAS(methods, METH_READ)) { - mode &= ~TCL_READABLE; - } - if (!HAS(methods, METH_WRITE)) { - mode &= ~TCL_WRITABLE; - } - - if (!mode) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "chan handler \"%s\" makes the channel inaccessible", - TclGetString(cmdObj))); - goto error; - } - - /* - * The mode and support for it is ok, now check the internal constraints. - */ - - if (!IMPLIES(HAS(methods, METH_DRAIN), HAS(methods, METH_READ))) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "chan handler \"%s\" supports \"drain\" but not \"read\"", - TclGetString(cmdObj))); - goto error; - } - - if (!IMPLIES(HAS(methods, METH_FLUSH), HAS(methods, METH_WRITE))) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "chan handler \"%s\" supports \"flush\" but not \"write\"", - TclGetString(cmdObj))); - goto error; - } - - Tcl_ResetResult(interp); - - /* - * Everything is fine now. - */ - - rtPtr->methods = methods; - rtPtr->mode = mode; - rtPtr->chan = Tcl_StackChannel(interp, &tclRTransformType, rtPtr, mode, - rtPtr->parent); - - /* - * Register the transform in our our map for proper handling of deleted - * interpreters and/or threads. - */ - - rtmPtr = GetReflectedTransformMap(interp); - hPtr = Tcl_CreateHashEntry(&rtmPtr->map, TclGetString(rtId), &isNew); - if (!isNew && rtPtr != Tcl_GetHashValue(hPtr)) { - Tcl_Panic("TclChanPushObjCmd: duplicate transformation handle"); - } - Tcl_SetHashValue(hPtr, rtPtr); -#if TCL_THREADS - rtmPtr = GetThreadReflectedTransformMap(); - hPtr = Tcl_CreateHashEntry(&rtmPtr->map, TclGetString(rtId), &isNew); - Tcl_SetHashValue(hPtr, rtPtr); -#endif /* TCL_THREADS */ - - /* - * Return the channel as the result of the command. - */ - - Tcl_SetObjResult(interp, Tcl_NewStringObj( - Tcl_GetChannelName(rtPtr->chan), -1)); - return TCL_OK; - - error: - /* - * We are not going through ReflectClose as we never had a channel - * structure. - */ - - Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); - return TCL_ERROR; - -#undef CHAN -#undef CMD -} - -/* - *---------------------------------------------------------------------- - * - * TclChanPopObjCmd -- - * - * This function is invoked to process the "chan pop" Tcl command. See - * the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Posts events to a reflected channel, invokes event handlers. The - * 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] - * - * Actually: rPop CHANNEL - * [0] [1] - */ - -#define CHAN (1) - - const char *chanId; /* Tcl level channel handle */ - Tcl_Channel chan; /* Channel associated to the handle */ - int mode; /* Channel r/w mode */ - - /* - * Number of arguments... - */ - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "channel"); - return TCL_ERROR; - } - - /* - * First argument is a channel, which may have a (reflected) - * transformation. - */ - - chanId = TclGetString(objv[CHAN]); - chan = Tcl_GetChannel(interp, chanId, &mode); - - if (chan == NULL) { - return TCL_ERROR; - } - - /* - * Removing transformations is generic, and not restricted to reflected - * transformations. - */ - - Tcl_UnstackChannel(interp, chan); - return TCL_OK; - -#undef CHAN -} - -/* - * Channel error message marshalling utilities. - */ - -static Tcl_Obj * -MarshallError( - Tcl_Interp *interp) -{ - /* - * Capture the result status of the interpreter into a string. => List of - * options and values, followed by the error message. The result has - * refCount 0. - */ - - Tcl_Obj *returnOpt = Tcl_GetReturnOptions(interp, TCL_ERROR); - - /* - * => returnOpt.refCount == 0. We can append directly. - */ - - Tcl_ListObjAppendElement(NULL, returnOpt, Tcl_GetObjResult(interp)); - return returnOpt; -} - -static void -UnmarshallErrorResult( - Tcl_Interp *interp, - Tcl_Obj *msgObj) -{ - int lc; - Tcl_Obj **lv; - int explicitResult; - int numOptions; - - /* - * Process the caught message. - * - * Syntax = (option value)... ?message? - * - * Bad syntax causes a panic. This is OK because the other side uses - * Tcl_GetReturnOptions and list construction functions to marshall the - * information; if we panic here, something has gone badly wrong already. - */ - - if (Tcl_ListObjGetElements(interp, msgObj, &lc, &lv) != TCL_OK) { - Tcl_Panic("TclChanCaughtErrorBypass: Bad syntax of caught result"); - } - if (interp == NULL) { - return; - } - - explicitResult = lc & 1; /* Odd number of values? */ - numOptions = lc - explicitResult; - - if (explicitResult) { - Tcl_SetObjResult(interp, lv[lc-1]); - } - - Tcl_SetReturnOptions(interp, Tcl_NewListObj(numOptions, lv)); - ((Interp *) interp)->flags &= ~ERR_ALREADY_LOGGED; -} - -/* - * Driver functions. ================================================ - */ - -/* - *---------------------------------------------------------------------- - * - * ReflectClose -- - * - * This function is invoked when the channel is closed, to delete the - * driver specific instance data. - * - * Results: - * A posix error. - * - * Side effects: - * Releases memory. Arbitrary, as it calls upon a script. - * - *---------------------------------------------------------------------- - */ - -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 - * finalization functions. - */ - - /* - * THREADED => Forward this to the origin thread - * - * Note: DeleteThreadReflectedTransformMap() is the thread exit handler - * for the origin thread. Use this to clean up the structure? Except - * if lost? - */ - -#if TCL_THREADS - if (rtPtr->thread != Tcl_GetCurrentThread()) { - ForwardParam p; - - ForwardOpToOwnerThread(rtPtr, ForwardedClose, &p); - result = p.base.code; - - if (result != TCL_OK) { - FreeReceivedError(&p); - } - } -#endif /* TCL_THREADS */ - - Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); - return EOK; - } - - /* - * In the reflected channel implementation a cleaned method mask here - * implies that the channel creation was aborted, and "finalize" must not - * be called. for transformations however we are not going through here on - * such an abort, but directly through FreeReflectedTransform. So for us - * that check is not necessary. We always go through 'finalize'. - */ - - if (HAS(rtPtr->methods, METH_DRAIN) && !rtPtr->readIsDrained) { - if (!TransformDrain(rtPtr, &errorCode)) { -#if TCL_THREADS - if (rtPtr->thread != Tcl_GetCurrentThread()) { - Tcl_EventuallyFree(rtPtr, - (Tcl_FreeProc *) FreeReflectedTransform); - return errorCode; - } -#endif /* TCL_THREADS */ - errorCodeSet = 1; - goto cleanup; - } - } - - if (HAS(rtPtr->methods, METH_FLUSH)) { - if (!TransformFlush(rtPtr, &errorCode, FLUSH_WRITE)) { -#if TCL_THREADS - if (rtPtr->thread != Tcl_GetCurrentThread()) { - Tcl_EventuallyFree(rtPtr, - (Tcl_FreeProc *) FreeReflectedTransform); - return errorCode; - } -#endif /* TCL_THREADS */ - errorCodeSet = 1; - goto cleanup; - } - } - - /* - * Are we in the correct thread? - */ - -#if TCL_THREADS - if (rtPtr->thread != Tcl_GetCurrentThread()) { - ForwardParam p; - - ForwardOpToOwnerThread(rtPtr, ForwardedClose, &p); - result = p.base.code; - - Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); - - if (result != TCL_OK) { - PassReceivedErrorInterp(interp, &p); - return EINVAL; - } - return EOK; - } -#endif /* TCL_THREADS */ - - /* - * Do the actual invokation of "finalize" now; we're in the right thread. - */ - - result = InvokeTclMethod(rtPtr, "finalize", NULL, NULL, &resObj); - if ((result != TCL_OK) && (interp != NULL)) { - Tcl_SetChannelErrorInterp(interp, resObj); - } - - Tcl_DecrRefCount(resObj); /* Remove reference we held from the - * invoke. */ - - cleanup: - - /* - * Remove the transform from the map before releasing the memory, to - * prevent future accesses from finding and dereferencing a dangling - * pointer. - * - * NOTE: The transform may not be in the map. This is ok, that happens - * when the transform was created in a different interpreter and/or thread - * and then was moved here. - * - * 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, TclGetString(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 - * under a channel by deleting the owning thread. - */ - -#if TCL_THREADS - rtmPtr = GetThreadReflectedTransformMap(); - hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle)); - if (hPtr) { - Tcl_DeleteHashEntry(hPtr); - } -#endif /* TCL_THREADS */ - } - - Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); - return errorCodeSet ? errorCode : ((result == TCL_OK) ? EOK : EINVAL); -} - -/* - *---------------------------------------------------------------------- - * - * ReflectInput -- - * - * This function is invoked when more data is requested from the channel. - * - * Results: - * The number of bytes read. - * - * Side effects: - * Allocates memory. Arbitrary, as it calls upon a script. - * - *---------------------------------------------------------------------- - */ - -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. - */ - - if (!(rtPtr->methods & FLAG(METH_READ))) { - SetChannelErrorStr(rtPtr->chan, msg_read_unsup); - *errorCodePtr = EINVAL; - return -1; - } - - Tcl_Preserve(rtPtr); - - /* TODO: Consider a more appropriate buffer size. */ - bufObj = Tcl_NewByteArrayObj(NULL, toRead); - Tcl_IncrRefCount(bufObj); - gotBytes = 0; - if (rtPtr->eofPending) { - goto stop; - } - rtPtr->readIsDrained = 0; - while (toRead > 0) { - /* - * Loop until the request is satisfied (or no data available from - * below, possibly EOF). - */ - - copied = ResultCopy(&rtPtr->result, UCHARP(buf), toRead); - toRead -= copied; - buf += copied; - gotBytes += copied; - - if (toRead == 0) { - goto stop; - } - - if (rtPtr->eofPending) { - goto stop; - } - - - /* - * The buffer is exhausted, but the caller wants even more. We now - * have to go to the underlying channel, get more bytes and then - * transform them for delivery. We may not get what we want (full EOF - * or temporarily out of data). - * - * Length (rtPtr->result) == 0, toRead > 0 here. Use 'buf'! as target - * to store the intermediary information read from the parent channel. - * - * Ask the transform how much data it allows us to read from the - * underlying channel. This feature allows the transform to signal EOF - * upstream although there is none downstream. Useful to control an - * unbounded 'fcopy' for example, either through counting bytes, or by - * pattern matching. - */ - - if ((rtPtr->methods & FLAG(METH_LIMIT))) { - int maxRead = -1; - - if (!TransformLimit(rtPtr, errorCodePtr, &maxRead)) { - goto error; - } - if (maxRead == 0) { - goto stop; - } else if (maxRead > 0) { - if (maxRead < toRead) { - toRead = maxRead; - } - } /* else: 'maxRead < 0' == Accept the current value of toRead */ - } - - if (toRead <= 0) { - goto stop; - } - - - readBytes = Tcl_ReadRaw(rtPtr->parent, - (char *) Tcl_SetByteArrayLength(bufObj, toRead), toRead); - if (readBytes < 0) { - if (Tcl_InputBlocked(rtPtr->parent) && (gotBytes > 0)) { - - /* - * Down channel is blocked and offers zero additional bytes. - * The nonzero gotBytes already returned makes the total - * operation a valid short read. Return to caller. - */ - - goto stop; - } - - /* - * Either the down channel is not blocked (a real error) - * or it is and there are gotBytes==0 byte copied so far. - * In either case, pass up the error, so we either report - * any real error, or do not mistakenly signal EOF by - * returning 0 to the caller. - */ - - *errorCodePtr = Tcl_GetErrno(); - goto error; - } - - if (readBytes == 0) { - - /* - * Zero returned from Tcl_ReadRaw() always indicates EOF - * on the down channel. - */ - - rtPtr->eofPending = 1; - - /* - * Now this is a bit different. The partial data waiting is - * converted and returned. - */ - - if (HAS(rtPtr->methods, METH_DRAIN)) { - if (!TransformDrain(rtPtr, errorCodePtr)) { - goto error; - } - } - - if (ResultLength(&rtPtr->result) == 0) { - /* - * The drain delivered nothing. - */ - - goto stop; - } - - continue; /* at: while (toRead > 0) */ - } /* readBytes == 0 */ - - /* - * Transform the read chunk, which was not empty. Anything we got back - * is a transformation result is put into our buffers, and the next - * iteration will put it into the result. - */ - - Tcl_SetByteArrayLength(bufObj, readBytes); - if (!TransformRead(rtPtr, errorCodePtr, bufObj)) { - goto error; - } - if (Tcl_IsShared(bufObj)) { - Tcl_DecrRefCount(bufObj); - TclNewObj(bufObj); - Tcl_IncrRefCount(bufObj); - } - Tcl_SetByteArrayLength(bufObj, 0); - } /* while toRead > 0 */ - - stop: - if (gotBytes == 0) { - rtPtr->eofPending = 0; - } - Tcl_DecrRefCount(bufObj); - Tcl_Release(rtPtr); - return gotBytes; - - error: - gotBytes = -1; - goto stop; -} - -/* - *---------------------------------------------------------------------- - * - * ReflectOutput -- - * - * This function is invoked when data is written to the channel. - * - * Results: - * The number of bytes actually written. - * - * Side effects: - * Allocates memory. Arbitrary, as it calls upon a script. - * - *---------------------------------------------------------------------- - */ - -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. - */ - - if (!(rtPtr->methods & FLAG(METH_WRITE))) { - SetChannelErrorStr(rtPtr->chan, msg_write_unsup); - *errorCodePtr = EINVAL; - return -1; - } - - if (toWrite == 0) { - /* - * Nothing came in to write, ignore the call - */ - - return 0; - } - - /* - * Discard partial data in the input buffers, i.e. on the read side. Like - * we do when explicitly seeking as well. - */ - - Tcl_Preserve(rtPtr); - - if ((rtPtr->methods & FLAG(METH_CLEAR))) { - TransformClear(rtPtr); - } - - /* - * Hand the data to the transformation itself. Anything it deigned to - * return to us is a (partial) transformation result and written to the - * parent channel for further processing. - */ - - if (!TransformWrite(rtPtr, errorCodePtr, UCHARP(buf), toWrite)) { - Tcl_Release(rtPtr); - return -1; - } - - *errorCodePtr = EOK; - Tcl_Release(rtPtr); - return toWrite; -} - -/* - *---------------------------------------------------------------------- - * - * ReflectSeekWide / ReflectSeek -- - * - * This function is invoked when the user wishes to seek on the channel. - * - * Results: - * The new location of the access point. - * - * Side effects: - * Allocates memory. Arbitrary, per the parent channel, and the called - * scripts. - * - *---------------------------------------------------------------------- - */ - -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. - */ - - Tcl_Preserve(rtPtr); - - if (((seekMode != SEEK_CUR) || (offset != 0)) - && (HAS(rtPtr->methods, METH_CLEAR) - || HAS(rtPtr->methods, METH_FLUSH))) { - /* - * Neither a tell request, nor clear/flush both not supported. We have - * to go through the Tcl level to clear and/or flush the - * transformation. - */ - - if (rtPtr->methods & FLAG(METH_CLEAR)) { - TransformClear(rtPtr); - } - - /* - * When flushing the transform for seeking the generated results are - * irrelevant. We cannot put them into the channel, this would move - * the location, throwing it off with regard to where we are and are - * seeking to. - */ - - if (HAS(rtPtr->methods, METH_FLUSH)) { - if (!TransformFlush(rtPtr, errorCodePtr, FLUSH_DISCARD)) { - Tcl_Release(rtPtr); - return -1; - } - } - } - - /* - * 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) { - *errorCodePtr = EINVAL; - curPos = -1; - } else { - curPos = Tcl_ChannelWideSeekProc(parent->typePtr)(parent->instanceData, offset, - seekMode, errorCodePtr); - } - if (curPos == -1) { - Tcl_SetErrno(*errorCodePtr); - } - - *errorCodePtr = EOK; - Tcl_Release(rtPtr); - return curPos; -} - -/* - *---------------------------------------------------------------------- - * - * ReflectWatch -- - * - * This function is invoked to tell the channel what events the I/O - * system is interested in. - * - * Results: - * None. - * - * Side effects: - * Allocates memory. Arbitrary, as it calls upon a script. - * - *---------------------------------------------------------------------- - */ - -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. - */ - - if (!(mask & TCL_READABLE) || (ResultLength(&rtPtr->result) == 0)) { - /* - * A pending timer may exist, but either is there no (more) interest - * in the events it generates or nothing is available for reading. - * Remove it, if existing. - */ - - TimerKill(rtPtr); - } else { - /* - * There might be no pending timer, but there is interest in readable - * events and we actually have data waiting, so generate a timer to - * flush that if it does not exist. - */ - - TimerSetup(rtPtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * ReflectBlock -- - * - * This function is invoked to tell the channel which blocking behaviour - * is required of it. - * - * Results: - * A posix error number. - * - * Side effects: - * Allocates memory. Arbitrary, as it calls upon a script. - * - *---------------------------------------------------------------------- - */ - -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. - */ - - rtPtr->nonblocking = nonblocking; - return EOK; -} - -/* - *---------------------------------------------------------------------- - * - * ReflectSetOption -- - * - * This function is invoked to configure a channel option. - * - * Results: - * A standard Tcl result code. - * - * Side effects: - * Arbitrary, per the parent channel. - * - *---------------------------------------------------------------------- - */ - -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. - */ - - Tcl_DriverSetOptionProc *setOptionProc = - Tcl_ChannelSetOptionProc(Tcl_GetChannelType(rtPtr->parent)); - - if (setOptionProc == NULL) { - return TCL_ERROR; - } - return setOptionProc(Tcl_GetChannelInstanceData(rtPtr->parent), interp, - optionName, newValue); -} - -/* - *---------------------------------------------------------------------- - * - * ReflectGetOption -- - * - * This function is invoked to retrieve all or a channel options. - * - * Results: - * A standard Tcl result code. - * - * Side effects: - * Arbitrary, per the parent channel. - * - *---------------------------------------------------------------------- - */ - -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. - * - * Note that the parent not having a driver for option retrieval is not an - * immediate error. A query for all options is ok. Only a request for a - * specific option has to fail. - */ - - Tcl_DriverGetOptionProc *getOptionProc = - Tcl_ChannelGetOptionProc(Tcl_GetChannelType(rtPtr->parent)); - - if (getOptionProc != NULL) { - return getOptionProc(Tcl_GetChannelInstanceData(rtPtr->parent), - interp, optionName, dsPtr); - } else if (optionName == NULL) { - return TCL_OK; - } else { - return TCL_ERROR; - } -} - -/* - *---------------------------------------------------------------------- - * - * ReflectHandle -- - * - * This function is invoked to retrieve the associated file handle. - * - * Results: - * A standard Tcl result code. - * - * Side effects: - * Arbitrary, per the parent channel. - * - *---------------------------------------------------------------------- - */ - -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. - * - * This all happens in the thread we are in. As the Tcl level is not - * involved no forwarding is required. - */ - - return Tcl_GetChannelHandle(rtPtr->parent, direction, handlePtr); -} -/* - *---------------------------------------------------------------------- - * - * ReflectNotify -- - * - * This function is invoked to reported incoming events. - * - * Results: - * A standard Tcl result code. - * - * Side effects: - * Arbitrary, per the parent channel. - * - *---------------------------------------------------------------------- - */ - -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 - * us to recreate the timer (in ReflectWatch). - */ - - TimerKill(rtPtr); - - /* - * Pass to higher layers. - */ - - return mask; -} - -/* - * Helpers. ========================================================= - */ - - -/* - *---------------------------------------------------------------------- - * - * DecodeEventMask -- - * - * This function takes an internal bitmask of events and constructs the - * equivalent list of event items. - * - * Results: - * A Tcl_Obj reference. The object will have a refCount of one. The user - * has to decrement it to release the object. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - * 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: - eventStr = "read"; - break; - case TCL_WRITABLE: - eventStr = "write"; - break; - default: - eventStr = ""; - break; - } - - evObj = Tcl_NewStringObj(eventStr, -1); - Tcl_IncrRefCount(evObj); - return evObj; -} - -/* - *---------------------------------------------------------------------- - * - * NewReflectedTransform -- - * - * This function is invoked to allocate and initialize the instance data - * of a new reflected channel. - * - * Results: - * A heap-allocated channel instance. - * - * Side effects: - * Allocates memory. - * - *---------------------------------------------------------------------- - */ - -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 *)Tcl_Alloc(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 - rtPtr->thread = Tcl_GetCurrentThread(); -#endif - rtPtr->parent = parentChan; - rtPtr->interp = interp; - rtPtr->handle = handleObj; - Tcl_IncrRefCount(handleObj); - rtPtr->timer = NULL; - rtPtr->mode = 0; - rtPtr->readIsDrained = 0; - rtPtr->eofPending = 0; - rtPtr->nonblocking = - (((Channel *) parentChan)->state->flags & CHANNEL_NONBLOCKING); - rtPtr->dead = 0; - - /* - * Query parent for current blocking mode. - */ - - ResultInit(&rtPtr->result); - - /* - * Method placeholder. - */ - - /* ASSERT: cmdpfxObj is a Tcl List */ - - Tcl_ListObjGetElements(interp, cmdpfxObj, &listc, &listv); - - /* - * See [==] as well. - * Storage for the command prefix and the additional words required for - * the invocation of methods in the command handler. - * - * listv [0] [listc-1] | [listc] [listc+1] | - * argv [0] ... [.] | [argc-2] [argc-1] | [argc] [argc+2] - * cmd ... pfx | method chan | detail1 detail2 - */ - - rtPtr->argc = listc + 2; - rtPtr->argv = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj *) * (listc+4)); - - /* - * Duplicate object references. - */ - - for (i=0; iargv[i] = listv[i]; - - Tcl_IncrRefCount(word); - } - - i++; /* Skip placeholder for method */ - - /* - * See [x] in FreeReflectedTransform for release - */ - rtPtr->argv[i] = handleObj; - Tcl_IncrRefCount(handleObj); - - /* - * The next two objects are kept empty, varying arguments. - */ - - /* - * Initialization complete. - */ - - return rtPtr; -} - -/* - *---------------------------------------------------------------------- - * - * NextHandle -- - * - * This function is invoked to generate a channel handle for a new - * reflected channel. - * - * Results: - * A Tcl_Obj containing the string of the new channel handle. The - * refcount of the returned object is -- zero --. - * - * Side effects: - * May allocate memory. Mutex protected critical section locks out other - * threads for a short time. - * - *---------------------------------------------------------------------- - */ - -static Tcl_Obj * -NextHandle(void) -{ - /* - * Count number of generated reflected channels. Used for id generation. - * Ids are never reclaimed and there is no dealing with wrap around. On - * the other hand, "unsigned long" should be big enough except for - * absolute longrunners (generate a 100 ids per second => overflow will - * occur in 1 1/3 years). - */ - - TCL_DECLARE_MUTEX(rtCounterMutex) - static unsigned long rtCounter = 0; - Tcl_Obj *resObj; - - Tcl_MutexLock(&rtCounterMutex); - resObj = Tcl_ObjPrintf("rt%lu", rtCounter); - rtCounter++; - Tcl_MutexUnlock(&rtCounterMutex); - - return resObj; -} - -static void -FreeReflectedTransformArgs( - ReflectedTransform *rtPtr) -{ - int i, n = rtPtr->argc - 2; - - if (n < 0) { - return; - } - - Tcl_DecrRefCount(rtPtr->handle); - rtPtr->handle = NULL; - - for (i=0; iargv[i]); - } - - /* - * See [x] in NewReflectedTransform for lock - * n+1 = argc-1. - */ - Tcl_DecrRefCount(rtPtr->argv[n+1]); - - rtPtr->argc = 1; -} - -static void -FreeReflectedTransform( - ReflectedTransform *rtPtr) -{ - TimerKill(rtPtr); - ResultClear(&rtPtr->result); - - FreeReflectedTransformArgs(rtPtr); - - Tcl_Free(rtPtr->argv); - Tcl_Free(rtPtr); -} - -/* - *---------------------------------------------------------------------- - * - * InvokeTclMethod -- - * - * This function is used to invoke the Tcl level of a reflected channel. - * It handles all the command assembly, invokation, and generic state and - * result mgmt. It does *not* handle thread redirection; that is the - * responsibility of clients of this function. - * - * Results: - * Result code and data as returned by the method. - * - * Side effects: - * Arbitrary, as it calls upon a Tcl script. - * - * Contract: - * argOneObj.refCount >= 1 on entry and exit, if argOneObj != NULL - * argTwoObj.refCount >= 1 on entry and exit, if argTwoObj != NULL - * resObj.refCount in {0, 1, ...} - * - *---------------------------------------------------------------------- - * Semi-DUPLICATE of 'InvokeTclMethod' in tclIORChan.c - * - Semi because different structures are used. - * - Still possible to factor out the commonalities into a separate structure. - */ - -static int -InvokeTclMethod( - ReflectedTransform *rtPtr, - const char *method, - Tcl_Obj *argOneObj, /* NULL'able */ - Tcl_Obj *argTwoObj, /* NULL'able */ - Tcl_Obj **resultObjPtr) /* NULL'able */ -{ - int cmdc; /* #words in constructed command */ - Tcl_Obj *methObj = NULL; /* Method name in object form */ - Tcl_InterpState sr; /* State of handler interp */ - int result; /* Result code of method invokation */ - Tcl_Obj *resObj = NULL; /* Result of method invokation. */ - - if (rtPtr->dead) { - /* - * The transform is marked as dead. Bail out immediately, with an - * appropriate error. - */ - - if (resultObjPtr != NULL) { - resObj = Tcl_NewStringObj(msg_dstlost,-1); - *resultObjPtr = resObj; - Tcl_IncrRefCount(resObj); - } - return TCL_ERROR; - } - - /* - * NOTE (5): Decide impl. issue: Cache objects with method names? - * Requires TSD data as reflections can be created in many different - * threads. - * NO: Caching of command resolutions means storage per channel. - */ - - /* - * Insert method into the pre-allocated area, after the command prefix, - * before the channel id. - */ - - methObj = Tcl_NewStringObj(method, -1); - Tcl_IncrRefCount(methObj); - rtPtr->argv[rtPtr->argc - 2] = methObj; - - /* - * Append the additional argument containing method specific details - * behind the channel id. If specified. - * - * Because of the contract there is no need to increment the refcounts. - * The objects will survive the Tcl_EvalObjv without change. - */ - - cmdc = rtPtr->argc; - if (argOneObj) { - rtPtr->argv[cmdc] = argOneObj; - cmdc++; - if (argTwoObj) { - rtPtr->argv[cmdc] = argTwoObj; - cmdc++; - } - } - - /* - * And run the handler... This is done in auch a manner which leaves any - * existing state intact. - */ - - sr = Tcl_SaveInterpState(rtPtr->interp, 0 /* Dummy */); - Tcl_Preserve(rtPtr); - Tcl_Preserve(rtPtr->interp); - result = Tcl_EvalObjv(rtPtr->interp, cmdc, rtPtr->argv, TCL_EVAL_GLOBAL); - - /* - * We do not try to extract the result information if the caller has no - * interest in it. I.e. there is no need to put effort into creating - * something which is discarded immediately after. - */ - - if (resultObjPtr) { - if (result == TCL_OK) { - /* - * Ok result taken as is, also if the caller requests that there - * is no capture. - */ - - resObj = Tcl_GetObjResult(rtPtr->interp); - } else { - /* - * Non-ok result is always treated as an error. We have to capture - * 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); - size_t cmdLen; - const char *cmdString = TclGetStringFromObj(cmd, &cmdLen); - - Tcl_IncrRefCount(cmd); - Tcl_ResetResult(rtPtr->interp); - Tcl_SetObjResult(rtPtr->interp, Tcl_ObjPrintf( - "chan handler returned bad code: %d", result)); - Tcl_LogCommandInfo(rtPtr->interp, cmdString, cmdString, cmdLen); - Tcl_DecrRefCount(cmd); - result = TCL_ERROR; - } - Tcl_AppendObjToErrorInfo(rtPtr->interp, Tcl_ObjPrintf( - "\n (chan handler subcommand \"%s\")", method)); - resObj = MarshallError(rtPtr->interp); - } - Tcl_IncrRefCount(resObj); - } - Tcl_RestoreInterpState(rtPtr->interp, sr); - Tcl_Release(rtPtr->interp); - Tcl_Release(rtPtr); - - /* - * Cleanup of the dynamic parts of the command. - * - * The detail objects survived the Tcl_EvalObjv without change because of - * the contract. Therefore there is no need to decrement the refcounts. Only - * the internal method object has to be disposed of. - */ - - Tcl_DecrRefCount(methObj); - - /* - * The resObj has a ref count of 1 at this location. This means that the - * caller of InvokeTclMethod has to dispose of it (but only if it was - * returned to it). - */ - - if (resultObjPtr != NULL) { - *resultObjPtr = resObj; - } - - /* - * There no need to handle the case where nothing is returned, because for - * that case resObj was not set anyway. - */ - - return result; -} - -/* - *---------------------------------------------------------------------- - * - * GetReflectedTransformMap -- - * - * Gets and potentially initializes the reflected channel map for an - * interpreter. - * - * Results: - * A pointer to the map created, for use by the caller. - * - * Side effects: - * Initializes the reflected channel map for an interpreter. - * - *---------------------------------------------------------------------- - */ - -static ReflectedTransformMap * -GetReflectedTransformMap( - Tcl_Interp *interp) -{ - ReflectedTransformMap *rtmPtr = (ReflectedTransformMap *)Tcl_GetAssocData(interp, RTMKEY, NULL); - - if (rtmPtr == NULL) { - rtmPtr = (ReflectedTransformMap *)Tcl_Alloc(sizeof(ReflectedTransformMap)); - Tcl_InitHashTable(&rtmPtr->map, TCL_STRING_KEYS); - Tcl_SetAssocData(interp, RTMKEY, - (Tcl_InterpDeleteProc *) DeleteReflectedTransformMap, rtmPtr); - } - return rtmPtr; -} - -/* - *---------------------------------------------------------------------- - * - * DeleteReflectedTransformMap -- - * - * Deletes the channel table for an interpreter, closing any open - * channels whose refcount reaches zero. This procedure is invoked when - * an interpreter is deleted, via the AssocData cleanup mechanism. - * - * Results: - * None. - * - * Side effects: - * Deletes the hash table of channels. May close channels. May flush - * output on closed channels. Removes any channeEvent handlers that were - * registered in this interpreter. - * - *---------------------------------------------------------------------- - */ - -static void -DeleteReflectedTransformMap( - ClientData clientData, /* The per-interpreter data structure. */ - Tcl_Interp *interp) /* The interpreter being deleted. */ -{ - ReflectedTransformMap *rtmPtr; /* The map */ - Tcl_HashSearch hSearch; /* Search variable. */ - Tcl_HashEntry *hPtr; /* Search variable. */ - ReflectedTransform *rtPtr; -#if TCL_THREADS - ForwardingResult *resultPtr; - ForwardingEvent *evPtr; - ForwardParam *paramPtr; -#endif /* TCL_THREADS */ - - /* - * Delete all entries. The channels may have been closed already, or will - * be closed later, by the standard IO finalization of an interpreter - * under destruction. Except for the channels which were moved to a - * different interpreter and/or thread. They do not exist from the IO - * 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); - Tcl_Free(&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; - } - - rtPtr->dead = 1; - FreeReflectedTransformArgs(rtPtr); - Tcl_DeleteHashEntry(hPtr); - } - - /* - * Go through the list of pending results and cancel all whose events were - * destined for this interpreter. While this is in progress we block any - * other access to the list of pending results. - */ - - Tcl_MutexLock(&rtForwardMutex); - - for (resultPtr = forwardList; resultPtr != NULL; - resultPtr = resultPtr->nextPtr) { - if (resultPtr->dsti != interp) { - /* - * Ignore results/events for other interpreters. - */ - - continue; - } - - /* - * The receiver for the event exited, before processing the event. We - * detach the result now, wake the originator up and signal failure. - */ - - evPtr = resultPtr->evPtr; - if (evPtr == NULL) { - continue; - } - paramPtr = evPtr->param; - - evPtr->resultPtr = NULL; - resultPtr->evPtr = NULL; - resultPtr->result = TCL_ERROR; - - ForwardSetStaticError(paramPtr, msg_send_dstlost); - - Tcl_ConditionNotify(&resultPtr->done); - } - Tcl_MutexUnlock(&rtForwardMutex); -#endif /* TCL_THREADS */ -} - -#if TCL_THREADS -/* - *---------------------------------------------------------------------- - * - * GetThreadReflectedTransformMap -- - * - * Gets and potentially initializes the reflected channel map for a - * thread. - * - * Results: - * A pointer to the map created, for use by the caller. - * - * Side effects: - * Initializes the reflected channel map for a thread. - * - *---------------------------------------------------------------------- - */ - -static ReflectedTransformMap * -GetThreadReflectedTransformMap(void) -{ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - if (!tsdPtr->rtmPtr) { - tsdPtr->rtmPtr = (ReflectedTransformMap *)Tcl_Alloc(sizeof(ReflectedTransformMap)); - Tcl_InitHashTable(&tsdPtr->rtmPtr->map, TCL_STRING_KEYS); - Tcl_CreateThreadExitHandler(DeleteThreadReflectedTransformMap, NULL); - } - - return tsdPtr->rtmPtr; -} - -/* - *---------------------------------------------------------------------- - * - * DeleteThreadReflectedTransformMap -- - * - * Deletes the channel table for a thread. This procedure is invoked when - * a thread is deleted. The channels have already been marked as dead, in - * DeleteReflectedTransformMap(). - * - * Results: - * None. - * - * Side effects: - * 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; - - /* - * The origin thread for one or more reflected channels is gone. - * NOTE: If this function is called due to a thread getting killed the - * per-interp DeleteReflectedTransformMap is apparently not called. - */ - - /* - * 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, 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); - } - Tcl_Free(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. - */ - - Tcl_MutexLock(&rtForwardMutex); - - for (resultPtr = forwardList; resultPtr != NULL; - resultPtr = resultPtr->nextPtr) { - ForwardingEvent *evPtr; - ForwardParam *paramPtr; - - if (resultPtr->dst != self) { - /* - * Ignore results/events for other threads. - */ - - continue; - } - - /* - * The receiver for the event exited, before processing the event. We - * detach the result now, wake the originator up and signal failure. - */ - - evPtr = resultPtr->evPtr; - if (evPtr == NULL) { - continue; - } - paramPtr = evPtr->param; - - evPtr->resultPtr = NULL; - resultPtr->evPtr = NULL; - resultPtr->result = TCL_ERROR; - - ForwardSetStaticError(paramPtr, msg_send_dstlost); - - Tcl_ConditionNotify(&resultPtr->done); - } - Tcl_MutexUnlock(&rtForwardMutex); -} - -static void -ForwardOpToOwnerThread( - ReflectedTransform *rtPtr, /* Channel instance */ - ForwardedOperation op, /* Forwarded driver operation */ - const void *param) /* Arguments */ -{ - Tcl_ThreadId dst = rtPtr->thread; - ForwardingEvent *evPtr; - ForwardingResult *resultPtr; - - /* - * We gather the lock early. This allows us to check the liveness of the - * channel without interference from DeleteThreadReflectedTransformMap(). - */ - - Tcl_MutexLock(&rtForwardMutex); - - if (rtPtr->dead) { - /* - * The channel is marked as dead. Bail out immediately, with an - * appropriate error. Do not forget to unlock the mutex on this path. - */ - - ForwardSetStaticError((ForwardParam *) param, msg_send_dstlost); - Tcl_MutexUnlock(&rtForwardMutex); - return; - } - - /* - * Create and initialize the event and data structures. - */ - - evPtr = (ForwardingEvent *)Tcl_Alloc(sizeof(ForwardingEvent)); - resultPtr = (ForwardingResult *)Tcl_Alloc(sizeof(ForwardingResult)); - - evPtr->event.proc = ForwardProc; - evPtr->resultPtr = resultPtr; - evPtr->op = op; - evPtr->rtPtr = rtPtr; - evPtr->param = (ForwardParam *) param; - - resultPtr->src = Tcl_GetCurrentThread(); - resultPtr->dst = dst; - resultPtr->dsti = rtPtr->interp; - resultPtr->done = NULL; - resultPtr->result = -1; - resultPtr->evPtr = evPtr; - - /* - * Now execute the forward. - */ - - TclSpliceIn(resultPtr, forwardList); - /* Do not unlock here. That is done by the ConditionWait */ - - /* - * Ensure cleanup of the event if the origin thread exits while this event - * is pending or in progress. Exit of the destination thread is handled by - * DeleteThreadReflectionChannelMap(), this is set up by - * GetThreadReflectedTransformMap(). This is what we use the 'forwardList' - * (see above) for. - */ - - Tcl_CreateThreadExitHandler(SrcExitProc, evPtr); - - /* - * Queue the event and poke the other thread's notifier. - */ - - Tcl_ThreadQueueEvent(dst, (Tcl_Event *) evPtr, TCL_QUEUE_TAIL); - Tcl_ThreadAlert(dst); - - /* - * (*) Block until the other thread has either processed the transfer or - * rejected it. - */ - - while (resultPtr->result < 0) { - /* - * NOTE (1): Is it possible that the current thread goes away while - * waiting here? IOW Is it possible that "SrcExitProc" is called - * while we are here? See complementary note (2) in "SrcExitProc" - * - * The ConditionWait unlocks the mutex during the wait and relocks it - * immediately after. - */ - - Tcl_ConditionWait(&resultPtr->done, &rtForwardMutex, NULL); - } - - /* - * Unlink result from the forwarder list. No need to lock. Either still - * locked, or locked by the ConditionWait - */ - - TclSpliceOut(resultPtr, forwardList); - - resultPtr->nextPtr = NULL; - resultPtr->prevPtr = NULL; - - Tcl_MutexUnlock(&rtForwardMutex); - Tcl_ConditionFinalize(&resultPtr->done); - - /* - * Kill the cleanup handler now, and the result structure as well, before - * returning the success code. - * - * Note: The event structure has already been deleted by the destination - * notifier, after it serviced the event. - */ - - Tcl_DeleteThreadExitHandler(SrcExitProc, evPtr); - - Tcl_Free(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, - * without fear of race conditions. I.e. we can read and write as we like. - * - * The only thing we cannot be sure of is the resultPtr. This can be be - * NULLed if the originating thread went away while the event is handled - * here now. - */ - - ForwardingEvent *evPtr = (ForwardingEvent *) evGPtr; - ForwardingResult *resultPtr = evPtr->resultPtr; - ReflectedTransform *rtPtr = evPtr->rtPtr; - Tcl_Interp *interp = rtPtr->interp; - ForwardParam *paramPtr = evPtr->param; - Tcl_Obj *resObj = NULL; /* Interp result of InvokeTclMethod */ - ReflectedTransformMap *rtmPtr; - /* Map of reflected channels with handlers in - * this interp. */ - Tcl_HashEntry *hPtr; /* Entry in the above map */ - - /* - * Ignore the event if no one is waiting for its result anymore. - */ - - if (!resultPtr) { - return 1; - } - - paramPtr->base.code = TCL_OK; - paramPtr->base.msgStr = NULL; - paramPtr->base.mustFree = 0; - - switch (evPtr->op) { - /* - * The destination thread for the following operations is - * rtPtr->thread, which contains rtPtr->interp, the interp we have to - * call upon for the driver. - */ - - case ForwardedClose: - /* - * No parameters/results. - */ - - if (InvokeTclMethod(rtPtr, "finalize", NULL, NULL, - &resObj) != TCL_OK) { - ForwardSetObjError(paramPtr, resObj); - } - - /* - * Freeing is done here, in the origin thread, because the argv[] - * objects belong to this thread. Deallocating them in a different - * thread is not allowed - */ - - /* - * Remove the channel from the map before releasing the memory, to - * prevent future accesses (like by 'postevent') from finding and - * dereferencing a dangling pointer. - */ - - rtmPtr = GetReflectedTransformMap(interp); - hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle)); - 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 under a - * channel by deleting the owning thread. - */ - - rtmPtr = GetThreadReflectedTransformMap(); - hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle)); - Tcl_DeleteHashEntry(hPtr); - - FreeReflectedTransformArgs(rtPtr); - break; - - 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 = TCL_INDEX_NONE; - } else { - /* - * Process a regular return. Contains the transformation result. - * Sent it back to the request originator. - */ - - size_t bytec = 0; /* Number of returned bytes */ - unsigned char *bytev; - /* Array of returned bytes */ - - bytev = TclGetByteArrayFromObj(resObj, &bytec); - - paramPtr->transform.size = bytec; - - if (bytec > 0) { - paramPtr->transform.buf = (char *)Tcl_Alloc(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 = TCL_INDEX_NONE; - } else { - /* - * Process a regular return. Contains the transformation result. - * Sent it back to the request originator. - */ - - size_t bytec = 0; /* Number of returned bytes */ - unsigned char *bytev; - /* Array of returned bytes */ - - bytev = TclGetByteArrayFromObj(resObj, &bytec); - - paramPtr->transform.size = bytec; - - if (bytec > 0) { - paramPtr->transform.buf = (char *)Tcl_Alloc(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 = TCL_INDEX_NONE; - } else { - /* - * Process a regular return. Contains the transformation result. - * Sent it back to the request originator. - */ - - size_t bytec = 0; /* Number of returned bytes */ - unsigned char *bytev; /* Array of returned bytes */ - - bytev = TclGetByteArrayFromObj(resObj, &bytec); - - paramPtr->transform.size = bytec; - - if (bytec > 0) { - paramPtr->transform.buf = (char *)Tcl_Alloc(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 = TCL_INDEX_NONE; - } else { - /* - * Process a regular return. Contains the transformation result. - * Sent it back to the request originator. - */ - - size_t bytec = 0; /* Number of returned bytes */ - unsigned char *bytev; - /* Array of returned bytes */ - - bytev = TclGetByteArrayFromObj(resObj, &bytec); - - paramPtr->transform.size = bytec; - - if (bytec > 0) { - paramPtr->transform.buf = (char *)Tcl_Alloc(bytec); - memcpy(paramPtr->transform.buf, bytev, bytec); - } else { - paramPtr->transform.buf = NULL; - } - } - break; - - case ForwardedClear: - (void) InvokeTclMethod(rtPtr, "clear", NULL, NULL, NULL); - break; - - case ForwardedLimit: - if (InvokeTclMethod(rtPtr, "limit?", NULL, NULL, &resObj) != TCL_OK) { - ForwardSetObjError(paramPtr, resObj); - paramPtr->limit.max = -1; - } else if (Tcl_GetIntFromObj(interp, resObj, - ¶mPtr->limit.max) != TCL_OK) { - ForwardSetObjError(paramPtr, MarshallError(interp)); - paramPtr->limit.max = -1; - } - break; - - default: - /* - * Bad operation code. - */ - Tcl_Panic("Bad operation code in ForwardProc"); - break; - } - - /* - * Remove the reference we held on the result of the invoke, if we had - * such. - */ - - if (resObj != NULL) { - Tcl_DecrRefCount(resObj); - } - - if (resultPtr) { - /* - * Report the forwarding result synchronously to the waiting caller. - * This unblocks (*) as well. This is wrapped into a conditional - * because the caller may have exited in the mean time. - */ - - Tcl_MutexLock(&rtForwardMutex); - resultPtr->result = TCL_OK; - Tcl_ConditionNotify(&resultPtr->done); - Tcl_MutexUnlock(&rtForwardMutex); - } - - 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? - */ - - /* - * The originator for the event exited. It is not sure if this can happen, - * as the originator should be blocked at (*) while the event is in - * transit/pending. - * - * We make sure that the event cannot refer to the result anymore, remove - * it from the list of pending results and free the structure. Locking the - * access ensures that we cannot get in conflict with "ForwardProc", - * should it already execute the event. - */ - - Tcl_MutexLock(&rtForwardMutex); - - resultPtr = evPtr->resultPtr; - paramPtr = evPtr->param; - - evPtr->resultPtr = NULL; - resultPtr->evPtr = NULL; - resultPtr->result = TCL_ERROR; - - ForwardSetStaticError(paramPtr, msg_send_originlost); - - /* - * See below: TclSpliceOut(resultPtr, forwardList); - */ - - Tcl_MutexUnlock(&rtForwardMutex); - - /* - * This unlocks (*). The structure will be spliced out and freed by - * "ForwardProc". Maybe. - */ - - Tcl_ConditionNotify(&resultPtr->done); -} - -static void -ForwardSetObjError( - ForwardParam *paramPtr, - Tcl_Obj *obj) -{ - size_t len; - const char *msgStr = TclGetStringFromObj(obj, &len); - - len++; - ForwardSetDynamicError(paramPtr, Tcl_Alloc(len)); - memcpy(paramPtr->base.msgStr, msgStr, len); -} -#endif /* TCL_THREADS */ - -/* - *---------------------------------------------------------------------- - * - * TimerKill -- - * - * Timer management. Removes the internal timer if it exists. - * - * Side effects: - * See above. - * - * Result: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -TimerKill( - ReflectedTransform *rtPtr) -{ - if (rtPtr->timer == NULL) { - return; - } - - /* - * Delete an existing flush-out timer, prevent it from firing on a - * removed/dead channel. - */ - - Tcl_DeleteTimerHandler(rtPtr->timer); - rtPtr->timer = NULL; -} - -/* - *---------------------------------------------------------------------- - * - * TimerSetup -- - * - * Timer management. Creates the internal timer if it does not exist. - * - * Side effects: - * See above. - * - * Result: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -TimerSetup( - ReflectedTransform *rtPtr) -{ - if (rtPtr->timer != NULL) { - return; - } - - rtPtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, - TimerRun, rtPtr); -} - -/* - *---------------------------------------------------------------------- - * - * TimerRun -- - * - * Called by the notifier (-> timer) to flush out information waiting in - * channel buffers. - * - * Side effects: - * As of 'Tcl_NotifyChannel'. - * - * Result: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -TimerRun( - ClientData clientData) -{ - ReflectedTransform *rtPtr = (ReflectedTransform *)clientData; - - rtPtr->timer = NULL; - Tcl_NotifyChannel(rtPtr->chan, TCL_READABLE); -} - -/* - *---------------------------------------------------------------------- - * - * ResultInit -- - * - * Initializes the specified buffer structure. The structure will contain - * valid information for an emtpy buffer. - * - * Side effects: - * See above. - * - * Result: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -ResultInit( - ResultBuffer *rPtr) /* Reference to the structure to - * initialize. */ -{ - rPtr->used = 0; - rPtr->allocated = 0; - rPtr->buf = NULL; -} -/* - *---------------------------------------------------------------------- - * - * ResultClear -- - * - * Deallocates any memory allocated by 'ResultAdd'. - * - * Side effects: - * See above. - * - * Result: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -ResultClear( - ResultBuffer *rPtr) /* Reference to the buffer to clear out */ -{ - rPtr->used = 0; - - if (!rPtr->allocated) { - return; - } - - Tcl_Free(rPtr->buf); - rPtr->buf = NULL; - rPtr->allocated = 0; -} - -/* - *---------------------------------------------------------------------- - * - * ResultAdd -- - * - * Adds the bytes in the specified array to the buffer, by appending it. - * - * Side effects: - * See above. - * - * Result: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -ResultAdd( - ResultBuffer *rPtr, /* The buffer to extend */ - unsigned char *buf, /* The buffer to read from */ - int toWrite) /* The number of bytes in 'buf' */ -{ - if ((rPtr->used + toWrite + 1) > rPtr->allocated) { - /* - * 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(Tcl_Alloc(rPtr->allocated)); - } else { - rPtr->allocated += toWrite + RB_INCREMENT; - rPtr->buf = UCHARP(Tcl_Realloc((char *) rPtr->buf, - rPtr->allocated)); - } - } - - /* - * Now copy data. - */ - - memcpy(rPtr->buf + rPtr->used, buf, toWrite); - rPtr->used += toWrite; -} - -/* - *---------------------------------------------------------------------- - * - * ResultCopy -- - * - * Copies the requested number of bytes from the buffer into the - * specified array and removes them from the buffer afterward. Copies - * less if there is not enough data in the buffer. - * - * Side effects: - * See above. - * - * Result: - * The number of actually copied bytes, possibly less than 'toRead'. - * - *---------------------------------------------------------------------- - */ - -static int -ResultCopy( - ResultBuffer *rPtr, /* The buffer to read from */ - unsigned char *buf, /* The buffer to copy into */ - int toRead) /* Number of requested bytes */ -{ - int copied; - - if (rPtr->used == 0) { - /* - * Nothing to copy in the case of an empty buffer. - */ - - copied = 0; - } else if (rPtr->used == (size_t)toRead) { - /* - * We have just enough. Copy everything to the caller. - */ - - memcpy(buf, rPtr->buf, toRead); - rPtr->used = 0; - copied = toRead; - } else if (rPtr->used > (size_t)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); - - rPtr->used -= toRead; - copied = toRead; - } else { - /* - * There is not enough in the buffer to satisfy the caller, so take - * everything. - */ - - memcpy(buf, rPtr->buf, rPtr->used); - toRead = rPtr->used; - rPtr->used = 0; - copied = toRead; - } - - /* -- common postwork code ------- */ - - return copied; -} - -static int -TransformRead( - ReflectedTransform *rtPtr, - int *errorCodePtr, - Tcl_Obj *bufObj) -{ - Tcl_Obj *resObj; - size_t bytec = 0; /* 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 *) TclGetByteArrayFromObj(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); - Tcl_Free(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 = TclGetByteArrayFromObj(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; - size_t bytec = 0; /* Number of returned bytes */ - unsigned char *bytev; /* Array of returned bytes */ - int res; - - /* - * Are we in the correct thread? - */ - -#if TCL_THREADS - if (rtPtr->thread != Tcl_GetCurrentThread()) { - ForwardParam p; - - p.transform.buf = (char *) buf; - p.transform.size = toWrite; - - ForwardOpToOwnerThread(rtPtr, ForwardedOutput, &p); - - if (p.base.code != TCL_OK) { - PassReceivedError(rtPtr->chan, &p); - *errorCodePtr = EINVAL; - return 0; - } - - *errorCodePtr = EOK; - res = Tcl_WriteRaw(rtPtr->parent, (char *) p.transform.buf, - p.transform.size); - Tcl_Free(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 = TclGetByteArrayFromObj(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; - size_t bytec = 0; /* 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); - Tcl_Free(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 = TclGetByteArrayFromObj(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; - size_t bytec = 0; /* Number of returned bytes */ - unsigned char *bytev; /* Array of returned bytes */ - int res; - - /* - * Are we in the correct thread? - */ - -#if TCL_THREADS - if (rtPtr->thread != Tcl_GetCurrentThread()) { - ForwardParam p; - - ForwardOpToOwnerThread(rtPtr, ForwardedFlush, &p); - - if (p.base.code != TCL_OK) { - PassReceivedError(rtPtr->chan, &p); - *errorCodePtr = EINVAL; - return 0; - } - - *errorCodePtr = EOK; - if (op == FLUSH_WRITE) { - res = Tcl_WriteRaw(rtPtr->parent, (char *) p.transform.buf, - p.transform.size); - } else { - res = 0; - } - Tcl_Free(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 = TclGetByteArrayFromObj(resObj, &bytec); - res = Tcl_WriteRaw(rtPtr->parent, (char *) bytev, bytec); - } else { - res = 0; - } - Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ - } - - if (res < 0) { - *errorCodePtr = Tcl_GetErrno(); - return 0; - } - - return 1; -} - -static void -TransformClear( - ReflectedTransform *rtPtr) -{ - /* - * Are we in the correct thread? - */ - -#if TCL_THREADS - if (rtPtr->thread != Tcl_GetCurrentThread()) { - ForwardParam p; - - ForwardOpToOwnerThread(rtPtr, ForwardedClear, &p); - return; - } -#endif /* TCL_THREADS */ - - /* ASSERT: rtPtr->method & FLAG(METH_READ) */ - /* ASSERT: rtPtr->mode & TCL_READABLE */ - - (void) InvokeTclMethod(rtPtr, "clear", NULL, NULL, NULL); - - rtPtr->readIsDrained = 0; - rtPtr->eofPending = 0; - ResultClear(&rtPtr->result); -} - -static int -TransformLimit( - ReflectedTransform *rtPtr, - int *errorCodePtr, - int *maxPtr) -{ - Tcl_Obj *resObj; - Tcl_InterpState sr; /* State of handler interp */ - - /* - * Are we in the correct thread? - */ - -#if TCL_THREADS - if (rtPtr->thread != Tcl_GetCurrentThread()) { - ForwardParam p; - - ForwardOpToOwnerThread(rtPtr, ForwardedLimit, &p); - - if (p.base.code != TCL_OK) { - PassReceivedError(rtPtr->chan, &p); - *errorCodePtr = EINVAL; - return 0; - } - - *errorCodePtr = EOK; - *maxPtr = p.limit.max; - return 1; - } -#endif - - /* ASSERT: rtPtr->method & FLAG(METH_WRITE) */ - /* ASSERT: rtPtr->mode & TCL_WRITABLE */ - - if (InvokeTclMethod(rtPtr, "limit?", NULL, NULL, &resObj) != TCL_OK) { - Tcl_SetChannelError(rtPtr->chan, resObj); - Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ - *errorCodePtr = EINVAL; - return 0; - } - - sr = Tcl_SaveInterpState(rtPtr->interp, 0 /* Dummy */); - - if (Tcl_GetIntFromObj(rtPtr->interp, resObj, maxPtr) != TCL_OK) { - Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ - Tcl_SetChannelError(rtPtr->chan, MarshallError(rtPtr->interp)); - *errorCodePtr = EINVAL; - - Tcl_RestoreInterpState(rtPtr->interp, sr); - 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: - */ Index: generic/tclIOSock.c ================================================================== --- generic/tclIOSock.c +++ generic/tclIOSock.c @@ -8,39 +8,10 @@ * 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) -/* - * On Windows, we need to do proper Unicode->UTF-8 conversion. - */ - -typedef struct { - int initialized; - Tcl_DString errorMsg; /* UTF-8 encoded error-message */ -} ThreadSpecificData; -static Tcl_ThreadDataKey dataKey; - -#undef gai_strerror -static const char * -gai_strerror( - int code) -{ - 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 /* *--------------------------------------------------------------------------- * * TclSockGetPort -- @@ -60,12 +31,12 @@ */ int TclSockGetPort( Tcl_Interp *interp, - const char *string, /* Integer or service name */ - const char *proto, /* "tcp" or "udp", typically */ + const char *string, /* Integer or service name */ + const char *proto, /* "tcp" or "udp", typically */ int *portPtr) /* Return port number */ { struct servent *sp; /* Protocol info for named services */ Tcl_DString ds; const char *native; @@ -85,12 +56,12 @@ } if (Tcl_GetInt(interp, string, portPtr) != TCL_OK) { return TCL_ERROR; } if (*portPtr > 0xFFFF) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "couldn't open socket: port number too high", -1)); + Tcl_AppendResult(interp, "couldn't open socket: port number too high", + NULL); return TCL_ERROR; } return TCL_OK; } @@ -108,10 +79,11 @@ * Sets SO_SNDBUF and SO_RCVBUF sizes. * *---------------------------------------------------------------------- */ +#undef TclSockMinimumBuffers #if !defined(_WIN32) && !defined(__CYGWIN__) # define SOCKET int #endif int @@ -121,211 +93,26 @@ { int current; socklen_t len; len = sizeof(int); - getsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_SNDBUF, - (char *) ¤t, &len); + getsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_SNDBUF, (char *)¤t, &len); if (current < size) { len = sizeof(int); - setsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_SNDBUF, - (char *) &size, len); + setsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_SNDBUF, (char *)&size, len); } len = sizeof(int); - getsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_RCVBUF, - (char *) ¤t, &len); + getsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_RCVBUF, (char *)¤t, &len); if (current < size) { len = sizeof(int); - setsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_RCVBUF, - (char *) &size, len); + setsockopt((SOCKET)(size_t)sock, SOL_SOCKET, SO_RCVBUF, (char *)&size, len); } return TCL_OK; } - -/* - *---------------------------------------------------------------------- - * - * TclCreateSocketAddress -- - * - * This function initializes a sockaddr structure for a host and port. - * - * Results: - * 1 if the host was valid, 0 if the host could not be converted to an IP - * address. - * - * Side effects: - * Fills in the *sockaddrPtr structure. - * - *---------------------------------------------------------------------- - */ - -int -TclCreateSocketAddress( - Tcl_Interp *interp, /* Interpreter for querying the desired socket - * family */ - struct addrinfo **addrlist, /* Socket address list */ - const char *host, /* Host. NULL implies INADDR_ANY */ - int port, /* Port number */ - int willBind, /* Is this an address to bind() to or to - * connect() to? */ - const char **errorMsgPtr) /* Place to store the error message detail, if - * available. */ -{ - struct addrinfo hints; - struct addrinfo *p; - struct addrinfo *v4head = NULL, *v4ptr = NULL; - struct addrinfo *v6head = NULL, *v6ptr = NULL; - char *native = NULL, portbuf[TCL_INTEGER_SPACE], *portstring; - const char *family = NULL; - Tcl_DString ds; - int result; - - if (host != NULL) { - native = Tcl_UtfToExternalDString(NULL, host, -1, &ds); - } - - /* - * Workaround for OSX's apparent inability to resolve "localhost", "0" - * when the loopback device is the only available network interface. - */ - - if (host != NULL && port == 0) { - portstring = NULL; - } else { - TclFormatInt(portbuf, port); - portstring = portbuf; - } - - (void) memset(&hints, 0, sizeof(hints)); - hints.ai_family = AF_UNSPEC; - - /* - * Magic variable to enforce a certain address family; to be superseded - * by a TIP that adds explicit switches to [socket]. - */ - - if (interp != NULL) { - family = Tcl_GetVar2(interp, "::tcl::unsupported::socketAF", NULL, 0); - if (family != NULL) { - if (strcmp(family, "inet") == 0) { - hints.ai_family = AF_INET; - } else if (strcmp(family, "inet6") == 0) { - hints.ai_family = AF_INET6; - } - } - } - - hints.ai_socktype = SOCK_STREAM; - -#if 0 - /* - * 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 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 */ - - if (willBind) { - hints.ai_flags |= AI_PASSIVE; - } - - result = getaddrinfo(native, portstring, &hints, addrlist); - - if (host != NULL) { - Tcl_DStringFree(&ds); - } - - if (result != 0) { - *errorMsgPtr = -#ifdef EAI_SYSTEM /* Doesn't exist on Windows */ - (result == EAI_SYSTEM) ? Tcl_PosixError(interp) : -#endif /* EAI_SYSTEM */ - gai_strerror(result); - return 0; - } - - /* - * Put IPv4 addresses before IPv6 addresses to maximize backwards - * compatibility of [fconfigure -sockname] output. - * - * There might be more elegant/efficient ways to do this. - */ - - if (willBind) { - for (p = *addrlist; p != NULL; p = p->ai_next) { - if (p->ai_family == AF_INET) { - if (v4head == NULL) { - v4head = p; - } else { - v4ptr->ai_next = p; - } - v4ptr = p; - } else { - if (v6head == NULL) { - v6head = p; - } else { - v6ptr->ai_next = p; - } - v6ptr = p; - } - } - *addrlist = NULL; - if (v6head != NULL) { - *addrlist = v6head; - v6ptr->ai_next = NULL; - } - if (v4head != NULL) { - v4ptr->ai_next = *addrlist; - *addrlist = v4head; - } - } - return 1; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_OpenTcpServer -- - * - * Opens a TCP server socket and creates a channel around it. - * - * Results: - * The channel or NULL if failed. If an error occurred, an error message - * is left in the interp's result if interp is not NULL. - * - * Side effects: - * Opens a server socket and creates a new channel. - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -Tcl_OpenTcpServer( - Tcl_Interp *interp, - int port, - const char *host, - Tcl_TcpAcceptProc *acceptProc, - ClientData callbackData) -{ - char portbuf[TCL_INTEGER_SPACE]; - - TclFormatInt(portbuf, port); - return Tcl_OpenTcpServerEx(interp, portbuf, host, TCL_TCPSERVER_REUSEADDR, - acceptProc, callbackData); -} /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclIOUtil.c ================================================================== --- generic/tclIOUtil.c +++ generic/tclIOUtil.c @@ -1,13 +1,16 @@ /* * 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. + * This file contains the implementation of Tcl's generic filesystem + * code, which supports a pluggable filesystem architecture allowing both + * platform specific filesystems and 'virtual filesystems'. All + * filesystem access should go through the functions defined in this + * file. Most of this code was contributed by Vince Darley. + * + * Parts of this file are based on code contributed by 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. * @@ -14,11 +17,11 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" -#ifdef _WIN32 +#ifdef __WIN32__ # include "tclWinInt.h" #endif #include "tclFileSystem.h" #ifdef TCL_TEMPLOAD_NO_UNLINK @@ -28,238 +31,96 @@ #endif /* * struct FilesystemRecord -- * - * An item in a linked list of registered filesystems + * A filesystem record is used to keep track of each filesystem currently + * registered with the core, in a linked list. */ typedef struct FilesystemRecord { - ClientData clientData; /* Client-specific data for the filesystem + ClientData clientData; /* Client specific data for the new filesystem * (can be NULL) */ - const Tcl_Filesystem *fsPtr;/* Pointer to filesystem dispatch table. */ + Tcl_Filesystem *fsPtr; /* Pointer to filesystem dispatch table. */ struct FilesystemRecord *nextPtr; - /* The next registered filesystem, or NULL to - * indicate the end of the list. */ + /* The next filesystem registered to Tcl, or + * NULL if no more. */ struct FilesystemRecord *prevPtr; - /* The previous filesystem, or NULL to indicate - * the ned of the list */ + /* The previous filesystem registered to Tcl, + * or NULL if no more. */ } FilesystemRecord; /* + * This structure holds per-thread private copy of the current directory + * maintained by the global cwdPathPtr. This structure holds per-thread + * private copies of some global data. This way we avoid most of the + * synchronization calls which boosts performance, at cost of having to update + * this information each time the corresponding epoch counter changes. */ -typedef struct { +typedef struct ThreadSpecificData { 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. - */ + int cwdPathEpoch; + int filesystemEpoch; + Tcl_Obj *cwdPathPtr; ClientData cwdClientData; FilesystemRecord *filesystemList; - size_t claims; + int claims; } ThreadSpecificData; /* - * Forward declarations. + * Prototypes for functions defined later in this file. */ -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[]; + +/* + * 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. There is no need to place them in tclInt.h, because + * they are not (and should not be) used anywhere else. + */ + +MODULE_SCOPE const char * 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, - TclNativeDupInternalRep, - NativeFreeInternalRep, - TclpNativeToNormalized, - TclNativeCreateNativeRep, - TclpObjNormalizePath, - TclpFilesystemPathType, - NativeFilesystemSeparator, - TclpObjStat, - TclpObjAccess, - TclpOpenFileChannel, - TclpMatchInDirectory, - TclpUtime, -#ifndef S_IFLNK - NULL, -#else - TclpObjLink, -#endif /* S_IFLNK */ - TclpObjListVolumes, - NativeFileAttrStrings, - NativeFileAttrsGet, - NativeFileAttrsSet, - TclpObjCreateDirectory, - 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. - */ - +/* + * The following functions are obsolete string based APIs, and should be + * removed in a future release (Tcl 9 would be a good time). + */ + + /* Obsolete */ int Tcl_Stat( - const char *path, /* Pathname of file to stat (in current CP). */ + const char *path, /* Path 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_Obj *pathPtr = Tcl_NewStringObj(path, -1); Tcl_IncrRefCount(pathPtr); ret = Tcl_FSStat(pathPtr, &buf); Tcl_DecrRefCount(pathPtr); if (ret != -1) { #ifndef TCL_WIDE_INT_IS_LONG Tcl_WideInt tmp1, tmp2, tmp3 = 0; - # define OUT_OF_RANGE(x) \ - (((Tcl_WideInt)(x)) < LONG_MIN || \ - ((Tcl_WideInt)(x)) > LONG_MAX) + (((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \ + ((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX)) # define OUT_OF_URANGE(x) \ (((Tcl_WideUInt)(x)) > ((Tcl_WideUInt)ULONG_MAX)) /* * Perform the result-buffer overflow check manually. @@ -269,14 +130,14 @@ * Workaround gcc warning of "comparison is always false due to * limited range of data type" by assigning to tmp var of type * Tcl_WideInt. */ - tmp1 = (Tcl_WideInt) buf.st_ino; - tmp2 = (Tcl_WideInt) buf.st_size; + tmp1 = (Tcl_WideInt) buf.st_ino; + tmp2 = (Tcl_WideInt) buf.st_size; #ifdef HAVE_STRUCT_STAT_ST_BLOCKS - tmp3 = (Tcl_WideInt) buf.st_blocks; + tmp3 = (Tcl_WideInt) buf.st_blocks; #endif if (OUT_OF_URANGE(tmp1) || OUT_OF_RANGE(tmp2) || OUT_OF_RANGE(tmp3)) { #if defined(EFBIG) errno = EFBIG; @@ -306,13 +167,13 @@ 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); + oldStyleBuf->st_atime = buf.st_atime; + oldStyleBuf->st_mtime = buf.st_mtime; + oldStyleBuf->st_ctime = buf.st_ctime; #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE oldStyleBuf->st_blksize = buf.st_blksize; #endif #ifdef HAVE_STRUCT_STAT_ST_BLOCKS #ifdef HAVE_BLKCNT_T @@ -326,12 +187,11 @@ } /* Obsolete */ int Tcl_Access( - const char *path, /* Pathname of file to access (in current CP). - */ + const char *path, /* Path of file to access (in current CP). */ int mode) /* Permission setting. */ { int ret; Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); @@ -343,16 +203,17 @@ } /* Obsolete */ Tcl_Channel Tcl_OpenFileChannel( - Tcl_Interp *interp, /* Interpreter for error reporting. May be + Tcl_Interp *interp, /* Interpreter for error reporting; can be * NULL. */ - const char *path, /* Pathname of file to open. */ + const char *path, /* Name 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. */ + int permissions) /* If the open involves creating a file, with + * what modes to create it? */ { Tcl_Channel ret; Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); Tcl_IncrRefCount(pathPtr); @@ -379,50 +240,269 @@ char * Tcl_GetCwd( Tcl_Interp *interp, Tcl_DString *cwdPtr) { - Tcl_Obj *cwd = Tcl_FSGetCwd(interp); - + Tcl_Obj *cwd; + cwd = Tcl_FSGetCwd(interp); if (cwd == NULL) { return NULL; + } else { + Tcl_DStringInit(cwdPtr); + Tcl_DStringAppend(cwdPtr, Tcl_GetString(cwd), -1); + Tcl_DecrRefCount(cwd); + return Tcl_DStringValue(cwdPtr); } - Tcl_DStringInit(cwdPtr); - 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. */ + Tcl_Interp *interp, /* Interpreter in which to process file. */ + const char *fileName) /* Name of file to process. Tilde-substitution + * will be performed on this name. */ { 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. + * The 3 hooks for Stat, Access and OpenFileChannel are obsolete. The + * complete, general hooked filesystem APIs should be used instead. This + * define decides whether to include the obsolete hooks and related code. If + * these are removed, we'll also want to remove them from stubs/tclInt. The + * only known users of these APIs are prowrap and mktclapp. New + * code/extensions should not use them, since they do not provide as full + * support as the full filesystem API. + * + * As soon as prowrap and mktclapp are updated to use the full filesystem + * support, I suggest all these hooks are removed. + */ + +#undef USE_OBSOLETE_FS_HOOKS + +#ifdef USE_OBSOLETE_FS_HOOKS + +/* + * The following typedef declarations allow for hooking into the chain of + * functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' & + * 'Tcl_OpenFileChannel(...)'. Basically for each hookable function a linked + * list is defined. + */ + +typedef struct StatProc { + TclStatProc_ *proc; /* Function to process a 'stat()' call */ + struct StatProc *nextPtr; /* The next 'stat()' function to call */ +} StatProc; + +typedef struct AccessProc { + TclAccessProc_ *proc; /* Function to process a 'access()' call */ + struct AccessProc *nextPtr; /* The next 'access()' function to call */ +} AccessProc; + +typedef struct OpenFileChannelProc { + TclOpenFileChannelProc_ *proc; + /* Function to process a + * 'Tcl_OpenFileChannel()' call */ + struct OpenFileChannelProc *nextPtr; + /* The next 'Tcl_OpenFileChannel()' function + * to call */ +} OpenFileChannelProc; + +/* + * For each type of (obsolete) hookable function, a static node is declared to + * hold the function pointer for the "built-in" routine (e.g. 'TclpStat(...)') + * and the respective list is initialized as a pointer to that node. + * + * The "delete" functions (e.g. 'TclStatDeleteProc(...)') ensure that these + * statically declared list entry cannot be inadvertently removed. + * + * This method avoids the need to call any sort of "initialization" function. + * + * All three lists are protected by a global obsoleteFsHookMutex. + */ + +static StatProc *statProcList = NULL; +static AccessProc *accessProcList = NULL; +static OpenFileChannelProc *openFileChannelProcList = NULL; + +TCL_DECLARE_MUTEX(obsoleteFsHookMutex) + +#endif /* USE_OBSOLETE_FS_HOOKS */ + +/* + * Declare the native filesystem support. These functions should be considered + * private to Tcl, and should really not be called directly by any code other + * than this file (i.e. neither by Tcl's core nor by extensions). Similarly, + * the old string-based Tclp... native filesystem functions should not be + * called. + * + * The correct API to use now is the Tcl_FS... set of functions, which ensure + * correct and complete virtual filesystem support. + * + * We cannot make all of these static, since some of them are implemented in + * the platform-specific directories. + */ + +static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator; +static Tcl_FSFreeInternalRepProc NativeFreeInternalRep; +static Tcl_FSFileAttrStringsProc NativeFileAttrStrings; +static Tcl_FSFileAttrsGetProc NativeFileAttrsGet; +static Tcl_FSFileAttrsSetProc NativeFileAttrsSet; + +/* + * The only reason these functions are not static is that they are either + * called by code in the native (win/unix) directories or they are actually + * implemented in those directories. They should simply not be called by code + * outside Tcl's native filesystem core i.e. they should be considered + * 'static' to Tcl's filesystem code (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_FSUnloadFileProc TclpUnloadFile; +Tcl_FSLinkProc TclpObjLink; +Tcl_FSListVolumesProc TclpObjListVolumes; + +/* + * Define the native filesystem dispatch table. If necessary, it is ok to make + * this non-static, but it should only be accessed by the functions actually + * listed within it (or perhaps other helper functions of them). Anything + * which is not part of this 'native filesystem implementation' should not be + * delving inside here! + */ + +Tcl_Filesystem tclNativeFilesystem = { + "native", + sizeof(Tcl_Filesystem), + TCL_FILESYSTEM_VERSION_2, + &TclNativePathInFilesystem, + &TclNativeDupInternalRep, + &NativeFreeInternalRep, + &TclpNativeToNormalized, + &TclNativeCreateNativeRep, + &TclpObjNormalizePath, + &TclpFilesystemPathType, + &NativeFilesystemSeparator, + &TclpObjStat, + &TclpObjAccess, + &TclpOpenFileChannel, + &TclpMatchInDirectory, + &TclpUtime, +#ifndef S_IFLNK + NULL, +#else + &TclpObjLink, +#endif /* S_IFLNK */ + &TclpObjListVolumes, + &NativeFileAttrStrings, + &NativeFileAttrsGet, + &NativeFileAttrsSet, + &TclpObjCreateDirectory, + &TclpObjRemoveDirectory, + &TclpObjDeleteFile, + &TclpObjCopyFile, + &TclpObjRenameFile, + &TclpObjCopyDirectory, + &TclpObjLstat, + &TclpDlopen, + /* Needs a cast since we're using version_2 */ + (Tcl_FSGetCwdProc *) &TclpGetNativeCwd, + &TclpObjChdir +}; + +/* + * Define the tail of the linked list. Note that for unconventional uses of + * Tcl without a native filesystem, we may in the future wish to modify the + * current approach of hard-coding the native filesystem in the lookup list + * 'filesystemList' below. + * + * We initialize the record so that it thinks one file uses it. This means it + * will never be freed. + */ + +static FilesystemRecord nativeFilesystemRecord = { + NULL, + &tclNativeFilesystem, + NULL, + NULL +}; + +/* + * This is incremented each time we modify the linked list of filesystems. Any + * time it changes, all cached filesystem representations are suspect and must + * be freed. For multithreading builds, change of the filesystem epoch will + * trigger cache cleanup in all threads. + */ + +static int theFilesystemEpoch = 1; + +/* + * Stores the linked list of filesystems. A 1:1 copy of this list is also + * maintained in the TSD for each thread. This is to avoid synchronization + * issues. + */ + +static FilesystemRecord *filesystemList = &nativeFilesystemRecord; +TCL_DECLARE_MUTEX(filesystemMutex) + +/* + * Used to implement Tcl_FSGetCwd in a file-system independent way. + */ + +static Tcl_Obj* cwdPathPtr = NULL; +static int cwdPathEpoch = 0; +static ClientData cwdClientData = NULL; +TCL_DECLARE_MUTEX(cwdMutex) + +static Tcl_ThreadDataKey fsDataKey; + +/* + * One of these structures is used each time we successfully load a file from + * a file system by way of making a temporary copy of the file on the native + * filesystem. We need to store both the actual unloadProc/clientData + * combination which was used, and the original and modified filenames, so + * that we can correctly undo the entire operation when we want to unload the + * code. + */ + +typedef struct FsDivertLoad { + Tcl_LoadHandle loadHandle; + Tcl_FSUnloadFileProc *unloadProcPtr; + Tcl_Obj *divertedFile; + const Tcl_Filesystem *divertedFilesystem; + ClientData divertedFileNativeRep; +} FsDivertLoad; + +/* + * Now move on to the basic filesystem implementation */ static void FsThrExitProc( ClientData cd) { - ThreadSpecificData *tsdPtr = (ThreadSpecificData *)cd; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) cd; FilesystemRecord *fsRecPtr = NULL, *tmpFsRecPtr = NULL; /* - * Discard the cwd copy. + * Trash the cwd copy. */ if (tsdPtr->cwdPathPtr != NULL) { Tcl_DecrRefCount(tsdPtr->cwdPathPtr); tsdPtr->cwdPathPtr = NULL; @@ -430,18 +510,18 @@ if (tsdPtr->cwdClientData != NULL) { NativeFreeInternalRep(tsdPtr->cwdClientData); } /* - * Discard the filesystems cache. + * Trash the filesystems cache. */ fsRecPtr = tsdPtr->filesystemList; while (fsRecPtr != NULL) { tmpFsRecPtr = fsRecPtr->nextPtr; fsRecPtr->fsPtr = NULL; - Tcl_Free(fsRecPtr); + ckfree((char *)fsRecPtr); fsRecPtr = tmpFsRecPtr; } tsdPtr->filesystemList = NULL; tsdPtr->initialized = 0; } @@ -460,30 +540,30 @@ /* *---------------------------------------------------------------------- * * TclFSCwdPointerEquals -- - * Determine whether the given pathname is equal to the current working - * directory. + * + * Check whether the current working directory is equal to the path + * given. * * Results: - * 1 if equal, 0 otherwise. + * 1 (equal) or 0 (un-equal) as appropriate. * * Side effects: - * Updates TSD if needed. + * If the paths are equal, but are not the same object, this method will + * modify the given pathPtrPtr to refer to the same object. In this case + * the object pointed to by pathPtrPtr will have its refCount + * decremented, and it will be adjusted to point to the cwd (with a new + * refCount). * - * 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) + Tcl_Obj** pathPtrPtr) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); Tcl_MutexLock(&cwdMutex); if (tsdPtr->cwdPathPtr == NULL @@ -508,11 +588,11 @@ tsdPtr->cwdPathEpoch = cwdPathEpoch; } Tcl_MutexUnlock(&cwdMutex); if (tsdPtr->initialized == 0) { - Tcl_CreateThreadExitHandler(FsThrExitProc, tsdPtr); + Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData) tsdPtr); tsdPtr->initialized = 1; } if (pathPtrPtr == NULL) { return (tsdPtr->cwdPathPtr == NULL); @@ -519,19 +599,19 @@ } if (tsdPtr->cwdPathPtr == *pathPtrPtr) { return 1; } else { - size_t len1, len2; + int len1, len2; const char *str1, *str2; - str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1); - str2 = TclGetStringFromObj(*pathPtrPtr, &len2); - if ((len1 == len2) && !memcmp(str1, str2, len1)) { + str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1); + str2 = Tcl_GetStringFromObj(*pathPtrPtr, &len2); + if (len1 == len2 && !strcmp(str1,str2)) { /* - * The values are equal but the objects are different. Cache the - * current structure in place of the old one. + * They are equal, but different objects. Update so they will be + * the same object in the future. */ Tcl_DecrRefCount(*pathPtrPtr); *pathPtrPtr = tsdPtr->cwdPathPtr; Tcl_IncrRefCount(*pathPtrPtr); @@ -570,17 +650,17 @@ tmpFsRecPtr = fsRecPtr; fsRecPtr = fsRecPtr->nextPtr; } /* - * Refill the cache, honouring the order. + * Refill the cache honouring the order. */ list = NULL; fsRecPtr = tmpFsRecPtr; while (fsRecPtr != NULL) { - tmpFsRecPtr = (FilesystemRecord *)Tcl_Alloc(sizeof(FilesystemRecord)); + tmpFsRecPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord)); *tmpFsRecPtr = *fsRecPtr; tmpFsRecPtr->nextPtr = list; tmpFsRecPtr->prevPtr = NULL; list = tmpFsRecPtr; fsRecPtr = fsRecPtr->prevPtr; @@ -589,22 +669,21 @@ tsdPtr->filesystemEpoch = theFilesystemEpoch; Tcl_MutexUnlock(&filesystemMutex); while (toFree) { FilesystemRecord *next = toFree->nextPtr; - toFree->fsPtr = NULL; - Tcl_Free(toFree); + ckfree((char *)toFree); toFree = next; } /* * Make sure the above gets released on thread exit. */ if (tsdPtr->initialized == 0) { - Tcl_CreateThreadExitHandler(FsThrExitProc, tsdPtr); + Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData) tsdPtr); tsdPtr->initialized = 1; } } static FilesystemRecord * @@ -617,60 +696,58 @@ } return tsdPtr->filesystemList; } /* - * The epoch can is changed when a filesystems is added or removed, when - * "system encoding" changes, and when env(HOME) changes. + * The epoch can be changed by filesystems being added or removed, by changing + * the "system encoding" and by env(HOME) changing. */ int TclFSEpochOk( - size_t filesystemEpoch) + int filesystemEpoch) { return (filesystemEpoch == 0 || filesystemEpoch == theFilesystemEpoch); } static void -Claim(void) +Claim() { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); - tsdPtr->claims++; } static void -Disclaim(void) +Disclaim() { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); - tsdPtr->claims--; } -size_t -TclFSEpoch(void) +int +TclFSEpoch() { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); - return tsdPtr->filesystemEpoch; } + /* - * If non-NULL, take posession of clientData and free it later. + * If non-NULL, clientData is owned by us and must be freed later. */ static void FsUpdateCwd( Tcl_Obj *cwdObj, ClientData clientData) { - size_t len = 0; - const char *str = NULL; + int len; + char *str = NULL; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); if (cwdObj != NULL) { - str = TclGetStringFromObj(cwdObj, &len); + str = Tcl_GetStringFromObj(cwdObj, &len); } Tcl_MutexLock(&cwdMutex); if (cwdPathPtr != NULL) { Tcl_DecrRefCount(cwdPathPtr); @@ -682,21 +759,19 @@ if (cwdObj == NULL) { cwdPathPtr = NULL; cwdClientData = NULL; } else { /* - * This must be stored as a string obj! + * This must be stored as string obj! */ cwdPathPtr = Tcl_NewStringObj(str, len); - Tcl_IncrRefCount(cwdPathPtr); + Tcl_IncrRefCount(cwdPathPtr); cwdClientData = TclNativeDupInternalRep(clientData); } - if (++cwdPathEpoch == 0) { - ++cwdPathEpoch; - } + cwdPathEpoch++; tsdPtr->cwdPathEpoch = cwdPathEpoch; Tcl_MutexUnlock(&cwdMutex); if (tsdPtr->cwdPathPtr) { Tcl_DecrRefCount(tsdPtr->cwdPathPtr); @@ -718,21 +793,21 @@ /* *---------------------------------------------------------------------- * * TclFinalizeFilesystem -- * - * Clean up the filesystem. After this, any call to a Tcl_FS... function - * fails. + * Clean up the filesystem. After this, calls to all Tcl_FS... functions + * will fail. * - * If TclResetFilesystem is called later, it restores the filesystem to a - * pristine state. + * We will later call TclResetFilesystem to restore the FS to a pristine + * state. * * Results: * None. * * Side effects: - * Frees memory allocated for the filesystem. + * Frees any memory allocated by the filesystem. * *---------------------------------------------------------------------- */ void @@ -739,13 +814,12 @@ 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? + * Assumption that only one thread is active now. Otherwise we would need + * to put various mutexes around this code. */ if (cwdPathPtr != NULL) { Tcl_DecrRefCount(cwdPathPtr); cwdPathPtr = NULL; @@ -756,37 +830,38 @@ cwdClientData = NULL; } /* * Remove all filesystems, freeing any allocated memory that is no longer - * needed. + * needed */ fsRecPtr = filesystemList; while (fsRecPtr != NULL) { FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr; - /* - * The native filesystem is static, so don't free it. - */ + /* The native filesystem is static, so we don't free it. */ if (fsRecPtr != &nativeFilesystemRecord) { - Tcl_Free(fsRecPtr); + ckfree((char *)fsRecPtr); } fsRecPtr = tmpFsRecPtr; } - if (++theFilesystemEpoch == 0) { - ++theFilesystemEpoch; - } + theFilesystemEpoch++; filesystemList = NULL; /* - * filesystemList is now NULL. Any attempt to use the filesystem is likely - * to fail. + * Now filesystemList is NULL. This means that any attempt to use the + * filesystem is likely to fail. */ -#ifdef _WIN32 +#ifdef USE_OBSOLETE_FS_HOOKS + statProcList = NULL; + accessProcList = NULL; + openFileChannelProcList = NULL; +#endif +#ifdef __WIN32__ TclWinEncodingsCleanup(); #endif } /* @@ -807,58 +882,81 @@ void TclResetFilesystem(void) { filesystemList = &nativeFilesystemRecord; - if (++theFilesystemEpoch == 0) { - ++theFilesystemEpoch; - } + theFilesystemEpoch++; + +#ifdef __WIN32__ + /* + * Cleans up the win32 API filesystem proc lookup table. This must happen + * very late in finalization so that deleting of copied dlls can occur. + */ + + TclWinResetInterfaces(); +#endif } /* *---------------------------------------------------------------------- * * 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. + * Insert the filesystem function table at the head of the list of + * functions which are used during calls to all file-system operations. + * The filesystem will be added even if it is already in the list. (You + * can use Tcl_FSData to check if it is in the list, provided the + * ClientData used was not NULL). + * + * Note that the filesystem handling is head-to-tail of the list. Each + * filesystem is asked in turn whether it can handle a particular + * request, until one of them says 'yes'. At that point no further + * filesystems are asked. + * + * In particular this means if you want to add a diagnostic filesystem + * (which simply reports all fs activity), it must be at the head of the + * list: i.e. it must be the last registered. * * Results: - * TCL_OK, or TCL_ERROR if memory for a new node in the list could + * Normally TCL_OK; 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. + * Memory allocated and modifies the link list for filesystems. * *---------------------------------------------------------------------- */ int Tcl_FSRegister( - ClientData clientData, /* Client-specific data for this filesystem. */ - const Tcl_Filesystem *fsPtr)/* The filesystem record for the new fs. */ + ClientData clientData, /* Client specific data for this fs */ + Tcl_Filesystem *fsPtr) /* The filesystem record for the new fs. */ { FilesystemRecord *newFilesystemPtr; if (fsPtr == NULL) { return TCL_ERROR; } - newFilesystemPtr = (FilesystemRecord *)Tcl_Alloc(sizeof(FilesystemRecord)); + newFilesystemPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord)); newFilesystemPtr->clientData = clientData; newFilesystemPtr->fsPtr = fsPtr; + /* + * Is this lock and wait strictly speaking necessary? Since any iterators + * out there will have grabbed a copy of the head of the list and be + * iterating away from that, if we add a new element to the head of the + * list, it can't possibly have any effect on any of their loops. In fact + * it could be better not to wait, since we are adjusting the filesystem + * epoch, any cached representations calculated by existing iterators are + * going to have to be thrown away anyway. + * + * However, since registering and unregistering filesystems is a very rare + * action, this is not a very important point. + */ + Tcl_MutexLock(&filesystemMutex); newFilesystemPtr->nextPtr = filesystemList; newFilesystemPtr->prevPtr = NULL; if (filesystemList) { @@ -865,17 +963,15 @@ filesystemList->prevPtr = newFilesystemPtr; } filesystemList = newFilesystemPtr; /* - * Increment the filesystem epoch counter since existing pathnames might + * Increment the filesystem epoch counter, since existing paths might * conceivably now belong to different filesystems. */ - if (++theFilesystemEpoch == 0) { - ++theFilesystemEpoch; - } + theFilesystemEpoch++; Tcl_MutexUnlock(&filesystemMutex); return TCL_OK; } @@ -882,40 +978,42 @@ /* *---------------------------------------------------------------------- * * 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. + * Remove the passed filesystem from the list of filesystem function + * tables. It also ensures that the built-in (native) filesystem is not + * removable, although we may wish to change that decision in the future + * to allow a smaller Tcl core, in which the native filesystem is not + * used at all (we could, say, initialise Tcl completely over a network + * connection). * * Results: - * TCL_OK if the function pointer was successfully removed, or TCL_ERROR + * TCL_OK if the function pointer was successfully removed, TCL_ERROR * otherwise. * * Side effects: - * The list of registered filesystems is updated. Memory for the - * corresponding FilesystemRecord is eventually freed. + * Memory may be deallocated (or will be later, once no "path" objects + * refer to this filesystem), but the list of registered filesystems is + * updated immediately. * *---------------------------------------------------------------------- */ int Tcl_FSUnregister( - const Tcl_Filesystem *fsPtr)/* The filesystem record to remove. */ + 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. + * Traverse the 'filesystemList' looking for the particular node whose + * 'fsPtr' member matches 'fsPtr' and remove that one from the list. + * Ensure that the "default" node cannot be removed. */ fsRecPtr = filesystemList; while ((retVal == TCL_ERROR) && (fsRecPtr != &nativeFilesystemRecord)) { if (fsRecPtr->fsPtr == fsPtr) { @@ -927,20 +1025,20 @@ 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. + * Increment the filesystem epoch counter, since existing paths + * might conceivably now belong to different filesystems. This + * should also ensure that paths which have cached the filesystem + * which is about to be deleted do not reference that filesystem + * (which would of course lead to memory exceptions). */ - if (++theFilesystemEpoch == 0) { - ++theFilesystemEpoch; - } + theFilesystemEpoch++; - Tcl_Free(fsRecPtr); + ckfree((char *)fsRecPtr); retVal = TCL_OK; } else { fsRecPtr = fsRecPtr->nextPtr; } @@ -953,52 +1051,67 @@ /* *---------------------------------------------------------------------- * * 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 + * This routine 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 pathPtr belongs will be called. If pathPtr + * does not belong to any filesystem and if it is NULL or the empty + * string, then we assume the pattern is to be matched in the current + * working directory. To avoid have the Tcl_FSMatchInDirectoryProc for + * each filesystem from having to deal with this issue, we create a + * pathPtr on the fly (equal to the cwd), and then remove it from the + * results returned. This makes filesystems easy to write, since they can + * assume the pathPtr passed to them is an ordinary path. In fact this + * means we could remove such special case handling from Tcl's native + * filesystems. + * + * If 'pattern' is NULL, then pathPtr is assumed to be a fully specified + * path of a single file/directory which must be checked for existence + * and correct type. + * + * Results: + * + * The return value is a standard Tcl result indicating whether an error + * occurred in globbing. Error messages are placed in interp, but good + * results are placed in the resultPtr given. + * + * Recursive searches, e.g. * glob -dir $dir -join * pkgIndex.tcl - * - * Results: - * - * TCL_OK, or TCL_ERROR + * which must recurse through each directory matching '*' are handled + * internally by Tcl, by passing specific flags in a modified 'types' + * parameter. This means the actual filesystem only ever sees patterns + * which match in a single directory. * * Side effects: - * resultPtr is populated, or in the case of an TCL_ERROR, an error message is - * set in the interpreter. + * The interpreter may have an error message inserted into it. * *---------------------------------------------------------------------- */ 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. */ + Tcl_Interp *interp, /* Interpreter to receive error messages, but + * may be NULL. */ + Tcl_Obj *resultPtr, /* List object to receive results. */ + Tcl_Obj *pathPtr, /* Contains path to directory to search. */ + const char *pattern, /* Pattern to match against. */ + Tcl_GlobTypeData *types) /* Object containing list of acceptable types. + * May be NULL. In particular the directory + * flag is very important. */ { const Tcl_Filesystem *fsPtr; Tcl_Obj *cwd, *tmpResultPtr, **elemsPtr; int resLength, i, ret = -1; - if (types != NULL && (types->type & TCL_GLOB_TYPE_MOUNT)) { + 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. + * We don't currently allow querying of mounts by external code (a + * valuable future step), so since we're the only function that + * actually knows about mounts, this means we're being called + * recursively by ourself. Return no matches. */ return TCL_OK; } @@ -1006,65 +1119,68 @@ fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); } else { fsPtr = NULL; } + /* + * Check if we've successfully mapped the path to a filesystem within + * which to search. + */ + 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); + ret = (*fsPtr->matchInDirectoryProc)(interp, resultPtr, pathPtr, + pattern, types); if (ret == TCL_OK && pattern != NULL) { FsAddMountsToGlobResult(resultPtr, pathPtr, pattern, types); } return ret; } + /* + * If the path isn't empty, we have no idea how to match files in a + * directory which belongs to no known filesystem + */ + 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. + * We have an empty or NULL path. This is defined to mean we must search + * for files within the current 'cwd'. We therefore use that, but then + * since the proc we call will return results which include the cwd we + * must then trim it off the front of each path in the result. We choose + * to deal with this here (in the generic code), since if we don't, every + * single filesystem's implementation of Tcl_FSMatchInDirectory will have + * to deal with it for us. */ cwd = Tcl_FSGetCwd(NULL); if (cwd == NULL) { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "glob couldn't determine the current working directory", - -1)); + Tcl_SetResult(interp, "glob couldn't determine " + "the current working directory", TCL_STATIC); } return TCL_ERROR; } fsPtr = Tcl_FSGetFileSystemForPath(cwd); if (fsPtr != NULL && fsPtr->matchInDirectoryProc != NULL) { TclNewObj(tmpResultPtr); Tcl_IncrRefCount(tmpResultPtr); - ret = fsPtr->matchInDirectoryProc(interp, tmpResultPtr, cwd, pattern, - types); + 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. + * Note that we know resultPtr and tmpResultPtr are distinct. */ ret = Tcl_ListObjGetElements(interp, tmpResultPtr, &resLength, &elemsPtr); for (i=0 ; ret==TCL_OK && itype & TCL_GLOB_TYPE_DIR)); Tcl_Obj *mounts = FsListMounts(pathPtr, pattern); @@ -1138,44 +1256,43 @@ */ Tcl_ListObjReplace(NULL, resultPtr, j, 1, 0, NULL); gLength--; } - break; /* Break out of for loop. */ + break; /* Break out of for loop */ } } if (!found && dir) { Tcl_Obj *norm; - size_t len, mlen; + 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. + * We know mElt is absolute normalized and lies inside pathPtr, so + * now we must add to the result the right representation of mElt, + * i.e. the representation which is relative to pathPtr. */ norm = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (norm != NULL) { const char *path, *mount; - mount = TclGetStringFromObj(mElt, &mlen); - path = TclGetStringFromObj(norm, &len); + mount = Tcl_GetStringFromObj(mElt, &mlen); + path = Tcl_GetStringFromObj(norm, &len); if (path[len-1] == '/') { /* * Deal with the root of the volume. */ len--; } - len++; /* account for '/' in the mElt [Bug 1602539] */ - - + 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 + * No need to increment gLength, since we don't want to compare + * mounts against mounts. */ } } endOfMounts: @@ -1185,96 +1302,104 @@ /* *---------------------------------------------------------------------- * * Tcl_FSMountsChanged -- * - * Announecs that mount points have changed or that the system encoding - * has changed. + * Notify the filesystem that the available mounted filesystems (or + * within any one filesystem type, the number or location of mount + * points) have 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. + * The global filesystem variable 'theFilesystemEpoch' is incremented. + * The effect of this is to make all cached path representations invalid. + * Clearly it should only therefore be called when it is really required! + * There are a few circumstances when it should be called: + * + * (1) when a new filesystem is registered or unregistered. Strictly + * speaking this is only necessary if the new filesystem accepts file + * paths as is (normally the filesystem itself is really a shell which + * hasn't yet had any mount points established and so its + * 'pathInFilesystem' proc will always fail). However, for safety, Tcl + * always calls this for you in these circumstances. + * + * (2) when additional mount points are established inside any existing + * filesystem (except the native fs) + * + * (3) when any filesystem (except the native fs) changes the list of + * available volumes. + * + * (4) when the mapping from a string representation of a file to a full, + * normalized path changes. For example, if 'env(HOME)' is modified, then + * any path containing '~' will map to a different filesystem location. + * Therefore all such paths need to have their internal representation + * invalidated. + * + * Tcl has no control over (2) and (3), so any registered filesystem must + * make sure it calls this function when those situations occur. + * + * (Note: the reason for the exception in 2,3 for the native filesystem + * is that the native filesystem by default claims all unknown files even + * if it really doesn't understand them or if they don't exist). * *---------------------------------------------------------------------- */ 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. - */ + Tcl_Filesystem *fsPtr) { /* - * Increment the filesystem epoch to invalidate every existing cached - * internal representation. + * We currently don't do anything with this parameter. We could in the + * future only invalidate files for this filesystem or otherwise take more + * advanced action. + */ + + (void)fsPtr; + + /* + * Increment the filesystem epoch counter, since existing paths might now + * belong to different filesystems. */ Tcl_MutexLock(&filesystemMutex); - if (++theFilesystemEpoch == 0) { - ++theFilesystemEpoch; - } + theFilesystemEpoch++; Tcl_MutexUnlock(&filesystemMutex); } /* *---------------------------------------------------------------------- * * Tcl_FSData -- * - * Retrieves the clientData member of the given filesystem. + * Retrieve the clientData field for the filesystem given, or NULL if + * that filesystem is not registered. * * Results: - * A clientData value, or NULL if the given filesystem is not registered. - * The clientData value itself may also be NULL. + * A clientData value, or NULL. Note that if the filesystem was + * registered with a NULL clientData field, this function will return + * that NULL value. * * Side effects: * None. * *---------------------------------------------------------------------- */ ClientData Tcl_FSData( - const Tcl_Filesystem *fsPtr) /* The filesystem to find in the list of - * registered filesystems. */ + Tcl_Filesystem *fsPtr) /* The filesystem record to query. */ { ClientData retVal = NULL; FilesystemRecord *fsRecPtr = FsGetFirstFilesystem(); /* - * Find the filesystem in and retrieve its clientData. + * Traverse the list of filesystems look for a particular one. If found, + * return that filesystem's clientData (originally provided when calling + * Tcl_FSRegister). */ while ((retVal == NULL) && (fsRecPtr != NULL)) { if (fsRecPtr->fsPtr == fsPtr) { retVal = fsRecPtr->clientData; @@ -1288,121 +1413,84 @@ /* *--------------------------------------------------------------------------- * * 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. - * + * Takes a path specification containing no ../, ./ sequences, and + * converts it into a unique path for the given platform. On Unix, this + * means the path must be free of symbolic links/aliases, and on Windows + * it means we want the long form, with that long form's case-dependence + * (which gives us a unique, case-dependent path). * * Results: - * Stores the resulting pathname in pathPtr and returns the offset of the - * last byte processed in pathPtr. + * The pathPtr is modified in place. The return value is the last byte + * offset which was recognised in the path string. * * 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. + * sequences into the path, then this function will not return the + * correct result. This may be possible with symbolic links on unix. * + * Important assumption: if startAt is non-zero, it must point to a + * directory separator that we know exists and is already normalized (so + * it is important not to point to the char just after the separator). * *--------------------------------------------------------------------------- */ 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. */ + Tcl_Obj *pathPtr, /* The path to normalize in place */ + int startAt) /* Start at this char-offset */ { FilesystemRecord *fsRecPtr, *firstFsRecPtr; - size_t 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 = TclGetStringFromObj(pathPtr, &i); - - if ( (i >= 3) && ( (path[0] == '/' && path[1] == '/') - || (path[0] == '\\' && path[1] == '\\') ) ) { - for ( i = 2; ; i++) { - if (path[i] == '\0') break; - if (path[i] == path[0]) break; - } - --i; - if (path[i] == ':') isVfsPath = 1; - } - - /* - * Call the the normalizePathProc routine of each registered filesystem. - */ + /* + * Call each of the "normalise path" functions in succession. This is a + * special case, in which if we have a native filesystem handler, we call + * it first. This is because the root of Tcl's filesystem is always a + * native filesystem (i.e. '/' on unix is native). + */ + 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); + fsRecPtr = firstFsRecPtr; + while (fsRecPtr != NULL) { + if (fsRecPtr->fsPtr == &tclNativeFilesystem) { + Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc; + if (proc != NULL) { + startAt = (*proc)(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. - */ + fsRecPtr = fsRecPtr->nextPtr; + } + + fsRecPtr = firstFsRecPtr; + while (fsRecPtr != NULL) { + /* + * Skip the native system next time through. + */ + + if (fsRecPtr->fsPtr != &tclNativeFilesystem) { + Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc; + if (proc != NULL) { + startAt = (*proc)(interp, pathPtr, startAt); + } + + /* + * We could add an efficiency check like this: + * if (retVal == length-of(pathPtr)) {break;} + * but there's not much benefit. + */ + } + fsRecPtr = fsRecPtr->nextPtr; } Disclaim(); return startAt; } @@ -1410,31 +1498,30 @@ /* *--------------------------------------------------------------------------- * * TclGetOpenMode -- * - * Obsolete. A limited version of TclGetOpenModeEx() which exists only to - * satisfy any extensions imprudently using it via Tcl's internal stubs - * table. + * This routine is an obsolete, limited version of TclGetOpenModeEx() + * below. It exists only to satisfy any extensions imprudently using it + * via Tcl's internal stubs table. * * Results: - * See TclGetOpenModeEx(). + * Same as TclGetOpenModeEx(). * * Side effects: - * See TclGetOpenModeEx(). + * Same as 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. */ + Tcl_Interp *interp, /* Interpreter to use for error reporting - + * may be NULL. */ + const char *modeString, /* Mode string, e.g. "r+" or "RDONLY CREAT" */ + int *seekFlagPtr) /* Set this to 1 if the caller should seek to + * EOF during the opening of the file. */ { int binary = 0; return TclGetOpenModeEx(interp, modeString, seekFlagPtr, &binary); } @@ -1441,58 +1528,61 @@ /* *--------------------------------------------------------------------------- * * TclGetOpenModeEx -- * - * Computes a POSIX mode mask for opening a file. + * Computes a POSIX mode mask for opening a file, from a given string, + * and also sets flags to indicate whether the caller should seek to EOF + * after opening the file, and whether the caller should configure the + * channel for binary data. * * Results: - * The mode to pass to "open", or -1 if an error occurs. + * On success, returns mode to pass to "open". If an error occurs, the + * return value is -1 and if interp is not NULL, sets interp's result + * object to an error message. * * 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. + * Sets the integer referenced by seekFlagPtr to 1 to tell the caller to + * seek to EOF after opening the file, or to 0 otherwise. Sets the + * integer referenced by binaryPtr to 1 to tell the caller to seek to + * configure the channel for binary data, or to 0 otherwise. * * Special note: - * Based on a prototype implementation contributed by Mark Diekhans. + * This code is based on a prototype implementation contributed by Mark + * Diekhans. * *--------------------------------------------------------------------------- */ int TclGetOpenModeEx( - Tcl_Interp *interp, /* Interpreter, possibly NULL, to use for - * error reporting. */ + Tcl_Interp *interp, /* Interpreter to use for error reporting - + * may be NULL. */ 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 *seekFlagPtr, /* Set this to 1 if the caller should seek to + * EOF during the opening of the file. */ + int *binaryPtr) /* Set this to 1 if the caller should + * configure the opened channel for binary + * operations */ { 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 + * Check for the simpler fopen-like access modes (e.g. "r"). They 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. + * Guard against international characters before using byte oriented + * routines. */ if (!(modeString[0] & 0x80) && islower(UCHAR(modeString[0]))) { /* INTL: ISO only. */ switch (modeString[0]) { @@ -1502,30 +1592,30 @@ 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 + * Added 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; + 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] + * Must remove the O_APPEND flag so that the seek command + * works. [Bug 1773127] */ mode &= ~(O_RDONLY|O_WRONLY|O_APPEND); mode |= O_RDWR; break; @@ -1543,20 +1633,22 @@ error: *seekFlagPtr = 0; *binaryPtr = 0; if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "illegal access mode \"%s\"", modeString)); + Tcl_AppendResult(interp, "illegal access mode \"", modeString, + "\"", NULL); } return -1; } /* - * The access modes are specified as a list of POSIX modes like O_CREAT. + * The access modes are specified using a list of POSIX modes such as + * O_CREAT. * - * Tcl_SplitList must work correctly when interp is NULL. + * IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when a NULL + * interpreter is passed in. */ if (Tcl_SplitList(interp, modeString, &modeArgc, &modeArgv) != TCL_OK) { if (interp != NULL) { Tcl_AddErrorInfo(interp, @@ -1591,28 +1683,26 @@ } else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) { #ifdef O_NOCTTY mode |= O_NOCTTY; #else if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "access mode \"%s\" not supported by this system", - flag)); + Tcl_AppendResult(interp, "access mode \"", flag, + "\" not supported by this system", NULL); } - Tcl_Free((void *)modeArgv); + ckfree((char *) 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)); + Tcl_AppendResult(interp, "access mode \"", flag, + "\" not supported by this system", NULL); } - Tcl_Free((void *)modeArgv); + ckfree((char *) modeArgv); return -1; #endif } else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) { mode |= O_TRUNC; @@ -1619,175 +1709,160 @@ } 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)); + Tcl_AppendResult(interp, "invalid access mode \"", flag, + "\": must be RDONLY, WRONLY, RDWR, APPEND, BINARY, " + "CREAT, EXCL, NOCTTY, NONBLOCK, or TRUNC", NULL); } - Tcl_Free((void *)modeArgv); + ckfree((char *) modeArgv); return -1; } } - Tcl_Free((void *)modeArgv); + ckfree((char *) modeArgv); if (!gotRW) { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "access mode must include either RDONLY, WRONLY, or RDWR", - -1)); + Tcl_AppendResult(interp, "access mode must include either" + " RDONLY, WRONLY, or RDWR", NULL); } return -1; } return mode; } + +/* + * Tcl_FSEvalFile is Tcl_FSEvalFileEx without encoding argument. + */ + +int +Tcl_FSEvalFile( + Tcl_Interp *interp, /* Interpreter in which to process file. */ + Tcl_Obj *pathPtr) /* Path of file to process. Tilde-substitution + * will be performed on this name. */ +{ + return Tcl_FSEvalFileEx(interp, pathPtr, NULL); +} /* *---------------------------------------------------------------------- * - * Tcl_FSEvalFile, Tcl_FSEvalFileEx, TclNREvalFile -- + * Tcl_FSEvalFileEx -- * - * 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. + * Read in a file and process the entire file as one gigantic Tcl + * command. * * 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. + * Depends on the commands in the file. During the evaluation of the + * contents of the file, iPtr->scriptFile is made to point to pathPtr + * (the old value is cached and replaced when this function returns). * *---------------------------------------------------------------------- */ -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 utf-8 encoding. */ -{ - size_t length; - int result = TCL_ERROR; + Tcl_Interp *interp, /* Interpreter in which to process file. */ + Tcl_Obj *pathPtr, /* Path of file to process. Tilde-substitution + * will be performed on this name. */ + const char *encodingName) /* If non-NULL, then use this encoding for the + * file. NULL means use the system encoding. */ +{ + int length, result = TCL_ERROR; Tcl_StatBuf statBuf; Tcl_Obj *oldScriptFile; Interp *iPtr; - const char *string; + 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", - TclGetString(pathPtr), Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "couldn't read file \"", + Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); return result; } chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644); - if (chan == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't read file \"%s\": %s", - TclGetString(pathPtr), Tcl_PosixError(interp))); + if (chan == (Tcl_Channel) NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't read file \"", + Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); 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] + * The eofchar is \32 (^Z). This is the usual on Windows, but we effect + * this cross-platform to allow for scripted documents. [Bug: 2040] */ Tcl_SetChannelOption(interp, chan, "-eofchar", "\32 {}"); /* - * If the encoding is specified, set the channel to that encoding. - * Otherwise use utf-8. If the encoding is unknown report an error. - */ - - if (encodingName == NULL) { - encodingName = "utf-8"; - } - if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName) - != TCL_OK) { - Tcl_CloseEx(interp,chan,0); - return result; - } - - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - - /* - * Read first character of stream to check for utf-8 BOM - */ - - if (Tcl_ReadChars(chan, objPtr, 1, 0) == TCL_IO_FAILURE) { - Tcl_CloseEx(interp, chan, 0); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't read file \"%s\": %s", - TclGetString(pathPtr), Tcl_PosixError(interp))); - goto end; - } - string = TclGetString(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_CloseEx(interp, chan, 0); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't read file \"%s\": %s", - TclGetString(pathPtr), Tcl_PosixError(interp))); - goto end; - } - - if (Tcl_CloseEx(interp, chan, 0) != TCL_OK) { + * If the encoding is specified, set it for the channel. Else don't touch + * it (and use the system encoding) Report error on unknown encoding. + */ + + if (encodingName != NULL) { + if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName) + != TCL_OK) { + Tcl_Close(interp,chan); + return result; + } + } + + objPtr = Tcl_NewObj(); + Tcl_IncrRefCount(objPtr); + /* Try to read first character of stream, so we can + * check for utf-8 BOM to be handled especially. + */ + if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) { + Tcl_Close(interp, chan); + Tcl_AppendResult(interp, "couldn't read file \"", + Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + 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)) < 0) { + Tcl_Close(interp, chan); + Tcl_AppendResult(interp, "couldn't read file \"", + Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + 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. - */ - + string = Tcl_GetStringFromObj(objPtr, &length); + /* TIP #280 Force the evaluator to open a frame for a sourced + * file. */ iPtr->evalFlags |= TCL_EVAL_FILE; - result = TclEvalEx(interp, string, length, 0, 1, NULL, string); + result = Tcl_EvalEx(interp, string, length, 0); /* - * Restore the original iPtr->scriptFile value, but because the value may - * have hanged during evaluation, don't assume it currently points to - * pathPtr. + * Now we have to be careful; the script may have changed the + * iPtr->scriptFile value, so we must reset it without assuming it still + * points to 'pathPtr'. */ if (iPtr->scriptFile != NULL) { Tcl_DecrRefCount(iPtr->scriptFile); } @@ -1795,259 +1870,99 @@ 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); - unsigned limit = 150; - int overflow = (length > limit); - - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (file \"%.*s%s\" line %d)", - (overflow ? limit : (unsigned)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 utf-8 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", - TclGetString(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", - TclGetString(pathPtr), Tcl_PosixError(interp))); - return TCL_ERROR; - } - TclPkgFileSeen(interp, TclGetString(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 use utf-8. If the encoding is unknown report an error. - */ - - if (encodingName == NULL) { - encodingName = "utf-8"; - } - if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName) - != TCL_OK) { - Tcl_CloseEx(interp, chan, 0); - return TCL_ERROR; - } - - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - - /* - * Read first character of stream to check for utf-8 BOM - */ - - if (Tcl_ReadChars(chan, objPtr, 1, 0) == TCL_IO_FAILURE) { - Tcl_CloseEx(interp, chan, 0); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't read file \"%s\": %s", - TclGetString(pathPtr), Tcl_PosixError(interp))); - Tcl_DecrRefCount(objPtr); - return TCL_ERROR; - } - string = TclGetString(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_CloseEx(interp, chan, 0); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't read file \"%s\": %s", - TclGetString(pathPtr), Tcl_PosixError(interp))); - Tcl_DecrRefCount(objPtr); - return TCL_ERROR; - } - - if (Tcl_CloseEx(interp, chan, 0) != 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. - */ - - size_t length; - const char *pathString = TclGetStringFromObj(pathPtr, &length); - const unsigned int limit = 150; - int overflow = (length > limit); - - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (file \"%.*s%s\" line %d)", - (overflow ? limit : (unsigned int)length), pathString, - (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); - } - + * Record information telling where the error occurred. + */ + + const char *pathString = Tcl_GetStringFromObj(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 ? "..." : ""), interp->errorLine)); + } + + end: Tcl_DecrRefCount(objPtr); return result; } /* *---------------------------------------------------------------------- * * Tcl_GetErrno -- * - * Currently the global variable "errno", but could in the future change + * Gets the current value of the Tcl error code variable. This is + * currently the global variable "errno" but could in the future change * to something else. * * Results: - * The current Tcl error number. + * The value of the Tcl error code variable. * * 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. + * None. Note that the value of the Tcl error code variable is UNDEFINED + * if a call to Tcl_SetErrno did not precede this call. * *---------------------------------------------------------------------- */ 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! + * Sets the Tcl error code variable to the supplied value. * * Results: * None. * * Side effects: - * Modifies the the Tcl error code value. + * Modifies the value of the Tcl error code variable. * *---------------------------------------------------------------------- */ 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. + * This function is typically called after UNIX kernel calls return + * errors. It stores machine-readable information about the error in + * errorCode field of interp and returns an information string for the + * caller's use. * * Results: - * A human-readable sring describing the error. + * The return value is a human-readable string describing the error. * * Side effects: - * Sets the errorCode value of the interpreter. + * The errorCode field of the interp is set. * *---------------------------------------------------------------------- */ const char * Tcl_PosixError( - Tcl_Interp *interp) /* Interpreter to set the errorCode of */ + Tcl_Interp *interp) /* Interpreter whose errorCode field is to be + * set. */ { const char *id, *msg; msg = Tcl_ErrnoMsg(errno); id = Tcl_ErrnoId(); @@ -2059,14 +1974,15 @@ /* *---------------------------------------------------------------------- * * Tcl_FSStat -- - * Calls 'statProc' of the filesystem corresponding to pathPtr. * - * Replaces the standard library routines stat. + * This function replaces the library version of stat and lsat. * + * The appropriate function for the filesystem to which pathPtr belongs + * will be called. * * Results: * See stat documentation. * * Side effects: @@ -2075,33 +1991,93 @@ *---------------------------------------------------------------------- */ 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_Obj *pathPtr, /* Path of file to stat (in current CP). */ + Tcl_StatBuf *buf) /* Filled with results of stat call. */ +{ + const Tcl_Filesystem *fsPtr; +#ifdef USE_OBSOLETE_FS_HOOKS + struct stat oldStyleStatBuffer; + int retVal = -1; + + /* + * Call each of the "stat" function in succession. A non-return value of + * -1 indicates the particular function has succeeded. + */ + + Tcl_MutexLock(&obsoleteFsHookMutex); + + if (statProcList != NULL) { + StatProc *statProcPtr; + char *path; + Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); + if (transPtr == NULL) { + path = NULL; + } else { + path = Tcl_GetString(transPtr); + } + + statProcPtr = statProcList; + while ((retVal == -1) && (statProcPtr != NULL)) { + retVal = (*statProcPtr->proc)(path, &oldStyleStatBuffer); + statProcPtr = statProcPtr->nextPtr; + } + if (transPtr != NULL) { + Tcl_DecrRefCount(transPtr); + } + } + + Tcl_MutexUnlock(&obsoleteFsHookMutex); + if (retVal != -1) { + /* + * Note that EOVERFLOW is not a problem here, and these assignments + * should all be widening (if not identity.) + */ + + buf->st_mode = oldStyleStatBuffer.st_mode; + buf->st_ino = oldStyleStatBuffer.st_ino; + buf->st_dev = oldStyleStatBuffer.st_dev; + buf->st_rdev = oldStyleStatBuffer.st_rdev; + buf->st_nlink = oldStyleStatBuffer.st_nlink; + buf->st_uid = oldStyleStatBuffer.st_uid; + buf->st_gid = oldStyleStatBuffer.st_gid; + buf->st_size = Tcl_LongAsWide(oldStyleStatBuffer.st_size); + buf->st_atime = oldStyleStatBuffer.st_atime; + buf->st_mtime = oldStyleStatBuffer.st_mtime; + buf->st_ctime = oldStyleStatBuffer.st_ctime; +#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE + buf->st_blksize = oldStyleStatBuffer.st_blksize; +#endif +#ifdef HAVE_STRUCT_STAT_ST_BLOCKS + buf->st_blocks = Tcl_LongAsWide(oldStyleStatBuffer.st_blocks); +#endif + return retVal; + } +#endif /* USE_OBSOLETE_FS_HOOKS */ + + fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + Tcl_FSStatProc *proc = fsPtr->statProc; + if (proc != NULL) { + return (*proc)(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. + * This function replaces the library version of lstat. The appropriate + * function for the filesystem to which pathPtr belongs will be called. + * If no 'lstat' function is listed, but a 'stat' function is, then Tcl + * will fall back on the stat function. * * Results: * See lstat documentation. * * Side effects: @@ -2110,22 +2086,23 @@ *---------------------------------------------------------------------- */ 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. */ + Tcl_Obj *pathPtr, /* Path of file to stat (in current CP). */ + Tcl_StatBuf *buf) /* Filled with results of stat call. */ { 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_FSLstatProc *proc = fsPtr->lstatProc; + if (proc != NULL) { + return (*proc)(pathPtr, buf); + } else { + Tcl_FSStatProc *sproc = fsPtr->statProc; + if (sproc != NULL) { + return (*sproc)(pathPtr, buf); + } } } Tcl_SetErrno(ENOENT); return -1; } @@ -2133,13 +2110,12 @@ /* *---------------------------------------------------------------------- * * Tcl_FSAccess -- * - * Calls 'accessProc' of the filesystem corresponding to pathPtr. - * - * Replaces the library version of access. + * This function replaces the library version of access. The appropriate + * function for the filesystem to which pathPtr belongs will be called. * * Results: * See access documentation. * * Side effects: @@ -2148,126 +2124,202 @@ *---------------------------------------------------------------------- */ int Tcl_FSAccess( - Tcl_Obj *pathPtr, /* Pathname of file to access (in current CP). */ + Tcl_Obj *pathPtr, /* Path of file to access (in current CP). */ int mode) /* Permission setting. */ { - const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + const Tcl_Filesystem *fsPtr; +#ifdef USE_OBSOLETE_FS_HOOKS + int retVal = -1; - if (fsPtr != NULL && fsPtr->accessProc != NULL) { - return fsPtr->accessProc(pathPtr, mode); + /* + * Call each of the "access" function in succession. A non-return value of + * -1 indicates the particular function has succeeded. + */ + + Tcl_MutexLock(&obsoleteFsHookMutex); + + if (accessProcList != NULL) { + AccessProc *accessProcPtr; + char *path; + Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); + if (transPtr == NULL) { + path = NULL; + } else { + path = Tcl_GetString(transPtr); + } + + accessProcPtr = accessProcList; + while ((retVal == -1) && (accessProcPtr != NULL)) { + retVal = (*accessProcPtr->proc)(path, mode); + accessProcPtr = accessProcPtr->nextPtr; + } + if (transPtr != NULL) { + Tcl_DecrRefCount(transPtr); + } } + + Tcl_MutexUnlock(&obsoleteFsHookMutex); + if (retVal != -1) { + return retVal; + } +#endif /* USE_OBSOLETE_FS_HOOKS */ + + fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + Tcl_FSAccessProc *proc = fsPtr->accessProc; + if (proc != NULL) { + return (*proc)(pathPtr, mode); + } + } + Tcl_SetErrno(ENOENT); return -1; } /* *---------------------------------------------------------------------- * * Tcl_FSOpenFileChannel -- * - * Calls 'openfileChannelProc' of the filesystem corresponding to - * pathPtr. + * The appropriate function for the filesystem to which pathPtr belongs + * will be called. * * Results: - * The new channel, or NULL if the named file could not be opened. + * 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. + * May open the channel and may cause creation of a file on the file + * system. * *---------------------------------------------------------------------- */ Tcl_Channel Tcl_FSOpenFileChannel( - Tcl_Interp *interp, /* Interpreter for error reporting, or NULL */ - Tcl_Obj *pathPtr, /* Pathname of file to open. */ + Tcl_Interp *interp, /* Interpreter for error reporting; can be + * NULL. */ + Tcl_Obj *pathPtr, /* Name 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. */ + int permissions) /* If the open involves creating a file, with + * what modes to create it? */ { const Tcl_Filesystem *fsPtr; Tcl_Channel retVal = NULL; +#ifdef USE_OBSOLETE_FS_HOOKS + /* + * Call each of the "Tcl_OpenFileChannel" functions in succession. A + * non-NULL return value indicates the particular function has succeeded. + */ + + Tcl_MutexLock(&obsoleteFsHookMutex); + if (openFileChannelProcList != NULL) { + OpenFileChannelProc *openFileChannelProcPtr; + char *path; + Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr); + + if (transPtr == NULL) { + path = NULL; + } else { + path = Tcl_GetString(transPtr); + } + + openFileChannelProcPtr = openFileChannelProcList; + + while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) { + retVal = (*openFileChannelProcPtr->proc)(interp, path, + modeString, permissions); + openFileChannelProcPtr = openFileChannelProcPtr->nextPtr; + } + if (transPtr != NULL) { + Tcl_DecrRefCount(transPtr); + } + } + Tcl_MutexUnlock(&obsoleteFsHookMutex); + if (retVal != NULL) { + return retVal; + } +#endif /* USE_OBSOLETE_FS_HOOKS */ + + /* + * We need this just to ensure we return the correct error messages under + * some circumstances. + */ 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", - TclGetString(pathPtr), Tcl_PosixError(interp))); - } - Tcl_CloseEx(NULL, retVal, 0); - return NULL; - } - if (binary) { - Tcl_SetChannelOption(interp, retVal, "-translation", "binary"); - } - return retVal; + if (fsPtr != NULL) { + Tcl_FSOpenFileChannelProc *proc = fsPtr->openFileChannelProc; + if (proc != NULL) { + int mode, seekFlag, binary; + + /* + * Parse the mode, picking up whether we want to seek to start + * with and/or set the channel automatically into binary mode. + */ + + mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary); + if (mode == -1) { + return NULL; + } + + /* + * Do the actual open() call. + */ + + retVal = (*proc)(interp, pathPtr, mode, permissions); + if (retVal == NULL) { + return NULL; + } + + /* + * Apply appropriate flags parsed out above. + */ + + if (seekFlag && Tcl_Seek(retVal, (Tcl_WideInt)0, + SEEK_END) < (Tcl_WideInt)0) { + if (interp != NULL) { + Tcl_AppendResult(interp, "could not seek to end " + "of file while opening \"", Tcl_GetString(pathPtr), + "\": ", Tcl_PosixError(interp), NULL); + } + 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", - TclGetString(pathPtr), Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "couldn't open \"", Tcl_GetString(pathPtr), + "\": ", Tcl_PosixError(interp), NULL); } return NULL; } /* *---------------------------------------------------------------------- * * Tcl_FSUtime -- * - * Calls 'uTimeProc' of the filesystem corresponding to the given - * pathname. - * - * Replaces the library version of utime. + * This function replaces the library version of utime. The appropriate + * function for the filesystem to which pathPtr belongs will be called. * * Results: * See utime documentation. * * Side effects: @@ -2276,32 +2328,34 @@ *---------------------------------------------------------------------- */ int Tcl_FSUtime( - Tcl_Obj *pathPtr, /* Pathaname of file to call uTimeProc on */ - struct utimbuf *tval) /* Specifies the access/modification + Tcl_Obj *pathPtr, /* File to change access/modification times */ + struct utimbuf *tval) /* Structure containing 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); + if (fsPtr != NULL) { + Tcl_FSUtimeProc *proc = fsPtr->utimeProc; + if (proc != NULL) { + return (*proc)(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. + * This function implements the platform dependent 'file attributes' + * subcommand, for the native filesystem, for listing the set of possible + * attribute strings. This function is part of Tcl's native filesystem + * support, and is placed here because it is shared by Unix and Windows + * code. * * Results: * An array of strings * * Side effects: @@ -2308,35 +2362,33 @@ * None. * *---------------------------------------------------------------------- */ -static const char *const * +static const char ** NativeFileAttrStrings( - TCL_UNUSED(Tcl_Obj *), - TCL_UNUSED(Tcl_Obj **)) + Tcl_Obj *pathPtr, + Tcl_Obj **objPtrRef) { 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. + * This function implements the platform dependent 'file attributes' + * subcommand, for the native filesystem, for 'get' operations. This + * function is part of Tcl's native filesystem support, and is placed + * here because it is shared by Unix and Windows code. * * 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. + * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK + * was returned) is likely to have a refCount of zero. Either way we must + * either store it somewhere (e.g. the Tcl result), or Incr/Decr its + * refCount to ensure it is properly freed. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -2344,28 +2396,29 @@ 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. */ + Tcl_Obj *pathPtr, /* path of file we are operating on. */ + Tcl_Obj **objPtrRef) /* for output. */ { - return tclpFileAttrProcs[index].getProc(interp, index, pathPtr,objPtrRef); + 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. + * This function implements the platform dependent 'file attributes' + * subcommand, for the native filesystem, for 'set' operations. This + * function is part of Tcl's native filesystem support, and is placed + * here because it is shared by Unix and Windows code. * * Results: - * A standard Tcl return code. + * Standard Tcl return code. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -2373,47 +2426,52 @@ 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. */ + Tcl_Obj *pathPtr, /* path of file we are operating on. */ + Tcl_Obj *objPtr) /* set to this value. */ { - return tclpFileAttrProcs[index].setProc(interp, index, pathPtr, objPtr); + 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. + * This function implements part of the hookable 'file attributes' + * subcommand. The appropriate function for the filesystem to which + * pathPtr belongs will be called. * * 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. + * The called function may either return an array of strings, or may + * instead return NULL and place a Tcl list into the given objPtrRef. + * Tcl will take that list and first increment its refCount before using + * it. On completion of that use, Tcl will decrement its refCount. Hence + * if the list should be disposed of by Tcl when done, it should have a + * refCount of zero, and if the list should not be disposed of, the + * filesystem should ensure it retains a refCount on the object. * * Side effects: * None. * *---------------------------------------------------------------------- */ -const char *const * +const char ** Tcl_FSFileAttrStrings( Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef) { const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - if (fsPtr != NULL && fsPtr->fileAttrStringsProc != NULL) { - return fsPtr->fileAttrStringsProc(pathPtr, objPtrRef); + if (fsPtr != NULL) { + Tcl_FSFileAttrStringsProc *proc = fsPtr->fileAttrStringsProc; + if (proc != NULL) { + return (*proc)(pathPtr, objPtrRef); + } } Tcl_SetErrno(ENOENT); return NULL; } @@ -2420,32 +2478,31 @@ /* *---------------------------------------------------------------------- * * TclFSFileAttrIndex -- * - * Given an attribute name, determines the index of the attribute in the + * Helper function for converting an attribute name to an index into the * attribute table. * * Results: - * A standard Tcl result code. - * - * If there is no error, stores the index in *indexPtr. + * Tcl result code, index written to *indexPtr on result==TCL_OK * * 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 *pathPtr, /* File whose attributes are to be indexed + * into. */ + const char *attributeName, /* The attribute being looked for. */ + int *indexPtr) /* Where to write the found index. */ { Tcl_Obj *listObj = NULL; - const char *const *attrTable; + const char **attrTable; /* * Get the attribute table for the file. */ @@ -2498,20 +2555,19 @@ /* *---------------------------------------------------------------------- * * Tcl_FSFileAttrsGet -- * - * Implements read access for the hookable 'file attributes' subcommand. - * - * Calls 'fileAttrsGetProc' of the filesystem corresponding to the given - * pathname. + * This function implements read access for the hookable 'file + * attributes' subcommand. The appropriate function for the filesystem to + * which pathPtr belongs will be called. * * 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. + * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK + * was returned) is likely to have a refCount of zero. Either way we must + * either store it somewhere (e.g. the Tcl result), or Incr/Decr its + * refCount to ensure it is properly freed. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -2518,18 +2574,21 @@ */ 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. */ + int index, /* index of the attribute command. */ + Tcl_Obj *pathPtr, /* filename we are operating on. */ + Tcl_Obj **objPtrRef) /* for output. */ { const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - if (fsPtr != NULL && fsPtr->fileAttrsGetProc != NULL) { - return fsPtr->fileAttrsGetProc(interp, index, pathPtr, objPtrRef); + if (fsPtr != NULL) { + Tcl_FSFileAttrsGetProc *proc = fsPtr->fileAttrsGetProc; + if (proc != NULL) { + return (*proc)(interp, index, pathPtr, objPtrRef); + } } Tcl_SetErrno(ENOENT); return -1; } @@ -2536,18 +2595,16 @@ /* *---------------------------------------------------------------------- * * Tcl_FSFileAttrsSet -- * - * Implements write access for the hookable 'file - * attributes' subcommand. - * - * Calls 'fileAttrsSetProc' for the filesystem corresponding to the given - * pathname. + * This function implements write access for the hookable 'file + * attributes' subcommand. The appropriate function for the filesystem to + * which pathPtr belongs will be called. * * Results: - * A standard Tcl return code. + * Standard Tcl return code. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -2554,18 +2611,21 @@ */ 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. */ + int index, /* index of the attribute command. */ + Tcl_Obj *pathPtr, /* filename we are operating on. */ + Tcl_Obj *objPtr) /* Input value. */ { const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - if (fsPtr != NULL && fsPtr->fileAttrsSetProc != NULL) { - return fsPtr->fileAttrsSetProc(interp, index, pathPtr, objPtr); + if (fsPtr != NULL) { + Tcl_FSFileAttrsSetProc *proc = fsPtr->fileAttrsSetProc; + if (proc != NULL) { + return (*proc)(interp, index, pathPtr, objPtr); + } } Tcl_SetErrno(ENOENT); return -1; } @@ -2572,29 +2632,37 @@ /* *---------------------------------------------------------------------- * * 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. + * This function replaces the library version of getcwd(). + * + * Most VFS's will *not* implement a 'cwdProc'. Tcl now maintains its own + * record (in a Tcl_Obj) of the cwd, and an attempt is made to synch this + * with the cwd's containing filesystem, if that filesystem provides a + * cwdProc (e.g. the native filesystem). + * + * Note that if Tcl's cwd is not in the native filesystem, then of course + * Tcl's cwd and the native cwd are different: extensions should + * therefore ensure they only access the cwd through this function to + * avoid confusion. + * + * If a global cwdPathPtr already exists, it is cached in the thread's + * private data structures and reference to the cached copy is returned, + * subject to a synchronisation attempt in that cwdPathPtr's fs. + * + * Otherwise, the chain of functions that have been "inserted" into the + * filesystem will be called in succession until either a value other + * than NULL is returned, or the entire list is visited. * * 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. + * The result is a pointer to a Tcl_Obj specifying the current directory, + * or NULL if the current directory could not be determined. If NULL is + * returned, an error message is left in the interp's result. * - * Returns NULL if the current directory could not be determined, and - * leaves an error message in the interpreter's result. + * The result already has its refCount incremented for the caller. When + * it is no longer needed, that refCount should be decremented. * * Side effects: * Various objects may be freed and allocated. * *---------------------------------------------------------------------- @@ -2609,219 +2677,205 @@ 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. + * We've never been called before, try to find a cwd. Call each of the + * "Tcl_GetCwd" function in succession. A non-NULL return value + * indicates the particular function has succeeded. */ fsRecPtr = FsGetFirstFilesystem(); Claim(); - for (; (retVal == NULL) && (fsRecPtr != NULL); - fsRecPtr = fsRecPtr->nextPtr) { - ClientData retCd; - TclFSGetCwdProc2 *proc2; - - if (fsRecPtr->fsPtr->getCwdProc == NULL) { - continue; - } - - if (fsRecPtr->fsPtr->version == TCL_FILESYSTEM_VERSION_1) { - retVal = fsRecPtr->fsPtr->getCwdProc(interp); - continue; - } - - 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. - */ - - void *cd = (void *) Tcl_FSGetNativePath(norm); - + while ((retVal == NULL) && (fsRecPtr != NULL)) { + Tcl_FSGetCwdProc *proc = fsRecPtr->fsPtr->getCwdProc; + if (proc != NULL) { + if (fsRecPtr->fsPtr->version != TCL_FILESYSTEM_VERSION_1) { + ClientData retCd; + TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)proc; + + retCd = (*proc2)(NULL); + if (retCd != NULL) { + Tcl_Obj *norm; + /* Looks like a new current directory */ + retVal = (*fsRecPtr->fsPtr->internalToNormalizedProc)( + retCd); + Tcl_IncrRefCount(retVal); + norm = TclFSNormalizeAbsolutePath(interp,retVal); + if (norm != NULL) { + /* + * We found a cwd, which is now in our global + * storage. We must make a copy. Norm already has + * a refCount of 1. + * + * Threading issue: note that multiple threads at + * system startup could in principle call this + * function simultaneously. They will therefore + * each set the cwdPathPtr independently. That + * behaviour 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. + */ + + FsUpdateCwd(norm, retCd); + Tcl_DecrRefCount(norm); + } else { + (*fsRecPtr->fsPtr->freeInternalRepProc)(retCd); + } + Tcl_DecrRefCount(retVal); + retVal = NULL; + Disclaim(); + goto cdDidNotChange; + } else if (interp != NULL) { + Tcl_AppendResult(interp, + "error getting working directory name: ", + Tcl_PosixError(interp), NULL); + } + } else { + retVal = (*proc)(interp); + } + } + fsRecPtr = fsRecPtr->nextPtr; + } + Disclaim(); + + /* + * Now the 'cwd' may NOT be normalized, at least on some platforms. + * For the sake of efficiency, we want a completely normalized cwd at + * all times. + * + * Finally, if retVal is NULL, we do not have a cwd, which could be + * problematic. + */ + + if (retVal != NULL) { + Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal); + if (norm != NULL) { + /* + * We found a cwd, which is now in our global storage. We must + * make a copy. Norm already has a refCount of 1. + * + * Threading issue: note that multiple threads at system + * startup could in principle call this function + * simultaneously. They will therefore each set the cwdPathPtr + * independently. That behaviour 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 { - /* - * New API. - */ - - TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2 *) fsPtr->getCwdProc; - - retCd = proc2(tsdPtr->cwdClientData); - if (retCd == NULL && interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "error getting working directory name: %s", - Tcl_PosixError(interp))); - } - - if (retCd == tsdPtr->cwdClientData) { - goto cdDidNotChange; - } - - /* - * 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. - */ - - size_t 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); + } + } else { + /* + * We already have a cwd cached, but we want to give the filesystem it + * is in a chance to check whether that cwd has changed, or is perhaps + * no longer accessible. This allows an error to be thrown if, say, + * the permissions on that directory have changed. + */ + + const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(tsdPtr->cwdPathPtr); + + /* + * If the filesystem couldn't be found, or if no cwd function exists + * for this filesystem, then we simply assume the cached cwd is ok. + * If we do call a cwd, we must watch for errors (if the cwd returns + * NULL). This ensures that, say, on Unix if the permissions of the + * cwd change, 'pwd' does actually throw the correct error in Tcl. + * (This is tested for in the test suite on unix). + */ + + if (fsPtr != NULL) { + Tcl_FSGetCwdProc *proc = fsPtr->getCwdProc; + ClientData retCd = NULL; + if (proc != NULL) { + Tcl_Obj *retVal; + if (fsPtr->version != TCL_FILESYSTEM_VERSION_1) { + TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)proc; + + retCd = (*proc2)(tsdPtr->cwdClientData); + if (retCd == NULL && interp != NULL) { + Tcl_AppendResult(interp, + "error getting working directory name: ", + Tcl_PosixError(interp), NULL); + } + + if (retCd == tsdPtr->cwdClientData) { + goto cdDidNotChange; + } + + /* + * Looks like a new current directory. + */ + + retVal = (*fsPtr->internalToNormalizedProc)(retCd); + Tcl_IncrRefCount(retVal); + } else { + retVal = (*proc)(interp); + } + if (retVal != NULL) { + Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal); + + /* + * Check whether cwd has changed from the value previously + * stored in cwdPathPtr. Really 'norm' shouldn't be NULL, + * but we are careful. + */ + + if (norm == NULL) { + /* Do nothing */ + if (retCd != NULL) { + (*fsPtr->freeInternalRepProc)(retCd); + } + } else if (norm == tsdPtr->cwdPathPtr) { + goto cdEqual; + } else { + /* + * Note that both 'norm' and 'tsdPtr->cwdPathPtr' are + * normalized paths. Therefore we can be more + * efficient than calling 'Tcl_FSEqualPaths', and in + * addition avoid a nasty infinite loop bug when + * trying to normalize tsdPtr->cwdPathPtr. + */ + + int len1, len2; + char *str1, *str2; + + str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1); + str2 = Tcl_GetStringFromObj(norm, &len2); + if ((len1 == len2) && (strcmp(str1, str2) == 0)) { + /* + * If the paths were equal, we can be more + * efficient and retain the old path object which + * will probably already be shared. In this case + * we can simply free the normalized path we just + * calculated. + */ + + cdEqual: + Tcl_DecrRefCount(norm); + if (retCd != NULL) { + (*fsPtr->freeInternalRepProc)(retCd); + } + } else { + FsUpdateCwd(norm, retCd); + Tcl_DecrRefCount(norm); + } + } + Tcl_DecrRefCount(retVal); + } else { + /* + * The 'cwd' function returned an error; reset the cwd. + */ + + FsUpdateCwd(NULL, NULL); + } + } + } } cdDidNotChange: if (tsdPtr->cwdPathPtr != NULL) { Tcl_IncrRefCount(tsdPtr->cwdPathPtr); @@ -2833,87 +2887,108 @@ /* *---------------------------------------------------------------------- * * Tcl_FSChdir -- * - * Replaces the library version of chdir(). + * This function replaces the library version of chdir(). * - * Calls 'chdirProc' of the filesystem that corresponds to the given - * pathname. + * The path is normalized and then passed to the filesystem which claims + * it. * * Results: - * See chdir() documentation. + * See chdir() documentation. If successful, we keep a record of the + * successful path in cwdPathPtr for subsequent calls to getcwd. * * Side effects: - * See chdir() documentation. - * - * On success stores in cwdPathPtr the pathname of the new current - * directory. + * See chdir() documentation. The global cwdPathPtr may change value. * *---------------------------------------------------------------------- */ int Tcl_FSChdir( Tcl_Obj *pathPtr) { - const Tcl_Filesystem *fsPtr, *oldFsPtr = NULL; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); + const Tcl_Filesystem *fsPtr; int retVal = -1; - if (tsdPtr->cwdPathPtr != NULL) { - oldFsPtr = Tcl_FSGetFileSystemForPath(tsdPtr->cwdPathPtr); - } if (Tcl_FSGetNormalizedPath(NULL, pathPtr) == NULL) { Tcl_SetErrno(ENOENT); return retVal; } fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { - if (fsPtr->chdirProc != NULL) { + Tcl_FSChdirProc *proc = fsPtr->chdirProc; + if (proc != NULL) { /* - * If this fails Tcl_SetErrno() has already been called. + * If this fails, an appropriate errno will have been stored using + * 'Tcl_SetErrno()'. */ - retVal = fsPtr->chdirProc(pathPtr); + retVal = (*proc)(pathPtr); } else { /* - * Fallback to stat-based implementation. + * Fallback on stat-based implementation. */ Tcl_StatBuf buf; + /* + * If the file can be stat'ed and is a directory and is readable, + * then we can chdir. If any of these actions fail, then + * 'Tcl_SetErrno()' should automatically have been called to set + * an appropriate error code + */ + 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. + * We allow the chdir. */ retVal = 0; - } else { - /* - * 'Tcl_SetErrno()' has already been called. - */ } } } else { Tcl_SetErrno(ENOENT); } + /* + * The cwd changed, or an error was thrown. If an error was thrown, we can + * just continue (and that will report the error to the user). If there + * was no error we must assume that the cwd was actually changed to the + * normalized value we calculated above, and we must therefore cache that + * information. + */ + + /* + * If the filesystem in question has a getCwdProc, then the correct logic + * which performs the part below is already part of the Tcl_FSGetCwd() + * call, so no need to replicate it again. This will have a side effect + * though. The private authoritative representation of the current working + * directory stored in cwdPathPtr in static memory will be out-of-sync + * with the real OS-maintained value. The first call to Tcl_FSGetCwd will + * however recalculate the private copy to match the OS-value so + * everything will work right. + * + * However, if there is no getCwdProc, then we _must_ update our private + * storage of the cwd, since this is the only opportunity to do that! + * + * Note: We currently call this block of code irrespective of whether + * there was a getCwdProc or not, but the code should all in principle + * work if we only call this block if fsPtr->getCwdProc == NULL. + */ + 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. + * Note that this normalized path may be different to what we found + * above (or at least a different object), if the filesystem epoch + * changed recently. This can actually happen with scripted documents + * very easily. Therefore we ask for the normalized path again (the + * correct value will have been cached as a result of the + * Tcl_FSGetFileSystemForPath call above anyway). */ Tcl_Obj *normDirName = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (normDirName == NULL) { @@ -2921,64 +2996,41 @@ Tcl_SetErrno(ENOENT); return -1; } if (fsPtr == &tclNativeFilesystem) { + /* + * For the native filesystem, we keep a cache of the native + * representation of the cwd. But, we want to do that for the + * exact format that is returned by 'getcwd' (so that we can later + * compare the two representations for equality), which might not + * be exactly the same char-string as the native representation of + * the fully normalized path (e.g. on Windows there's a + * forward-slash vs backslash difference). Hence we ask for this + * again here. On Unix it might actually be true that we always + * have the correct form in the native rep in which case we could + * simply use: + * cd = Tcl_FSGetNativePath(pathPtr); + * instead. This should be examined by someone on Unix. + */ + + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); 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. - */ - + * Assumption we are using a filesystem version 2. + */ + + TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)fsPtr->getCwdProc; + cd = (*proc2)(oldcd); + if (cd != oldcd) { 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; } @@ -2985,236 +3037,279 @@ /* *---------------------------------------------------------------------- * * 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. + * Dynamically loads a binary code file into memory and returns the + * addresses of two functions within that file, if they are defined. The + * appropriate function for the filesystem to which pathPtr belongs will + * be called. + * + * Note that the native filesystem doesn't actually assume 'pathPtr' is a + * path. Rather it assumes pathPtr is either a path or just the name + * (tail) of a file which can be found somewhere in the environment's + * loadable path. This behaviour is not very compatible with virtual + * filesystems (and has other problems documented in the load man-page), + * so it is advised that full paths are always used. * * Results: - * A standard Tcl completion code. If an error occurs, sets the - * interpreter's result to an error message. + * A standard Tcl completion code. If an error occurs, an error message + * is left in the interp's result. * * Side effects: - * A dynamic shared object is loaded into memory. This may later be - * unloaded by passing the handlePtr to *unloadProcPtr. + * New code suddenly appears in memory. This may later be unloaded by + * passing the clientData to the unloadProc. * *---------------------------------------------------------------------- */ int Tcl_FSLoadFile( Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Obj *pathPtr, /* Pathname of the file containing the dynamic shared object. - */ + Tcl_Obj *pathPtr, /* Name of the file containing the desired + * code. */ const char *sym1, const char *sym2, - /* Names of two functions to find in the - * dynamic shared object. */ + /* Names of two functions to look up in the + * file's symbol table. */ 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 + /* Where to return the addresses corresponding + * to sym1 and sym2. */ + Tcl_LoadHandle *handlePtr, /* Filled with token for dynamically loaded + * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ - TCL_UNUSED(Tcl_FSUnloadFileProc **)) + Tcl_FSUnloadFileProc **unloadProcPtr) + /* Filled with address of Tcl_FSUnloadFileProc + * function which should be used for this + * file. */ { - const char *symbols[3]; - void *procPtrs[2]; + const char *symbols[2]; + Tcl_PackageInitProc **procPtrs[2]; + ClientData clientData; int res; + /* + * Initialize the arrays. + */ + 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; - } - + procPtrs[0] = proc1Ptr; + procPtrs[1] = proc2Ptr; + + /* + * Perform the load. + */ + + res = TclLoadFile(interp, pathPtr, 2, symbols, procPtrs, handlePtr, + &clientData, unloadProcPtr); + + /* + * Due to an unfortunate mis-design in Tcl 8.4 fs, when loading a shared + * library, we don't keep the loadHandle (for TclpFindSymbol) and the + * clientData (for the unloadProc) separately. In fact we effectively + * throw away the loadHandle and only use the clientData. It just so + * happens, for the native filesystem only, that these two are identical. + * + * This also means that the signatures Tcl_FSUnloadFileProc and + * Tcl_FSLoadFileProc are both misleading. + */ + + *handlePtr = (Tcl_LoadHandle) clientData; 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. + * TclLoadFile -- + * + * Dynamically loads a binary code file into memory and returns the + * addresses of a number of given functions within that file, if they are + * defined. The appropriate function for the filesystem to which pathPtr + * belongs will be called. + * + * Note that the native filesystem doesn't actually assume 'pathPtr' is a + * path. Rather it assumes pathPtr is either a path or just the name + * (tail) of a file which can be found somewhere in the environment's + * loadable path. This behaviour is not very compatible with virtual + * filesystems (and has other problems documented in the load man-page), + * so it is advised that full paths are always used. + * + * This function is currently private to Tcl. It may be exported in the + * future and its interface fixed (but we should clean up the + * loadHandle/clientData confusion at that time -- see the above comments + * in Tcl_FSLoadFile for details). For a public function, see + * Tcl_FSLoadFile. * * Results: - * A standard Tcl completion code. If an error occurs, sets the - * interpreter result to an error message. + * A standard Tcl completion code. If an error occurs, an error message + * is left in the interp's result. * * Side effects: - * Memory is allocated for the new object. May be freed by calling - * TclFS_UnloadFile. + * New code suddenly appears in memory. This may later be unloaded by + * passing the clientData to the unloadProc. * *---------------------------------------------------------------------- */ +typedef int (Tcl_FSLoadFileProc2) (Tcl_Interp *interp, Tcl_Obj *pathPtr, + Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); + /* - * 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. + * Workaround for issue with modern HPUX which do allow the unlink (no ETXTBSY + * error) yet somehow trash some internal data structures which prevents the + * second and further shared libraries from getting properly loaded. Only the + * first is ok. We try to get 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). - * - */ - + * For these situations the change below makes the execution of the unlink + * semi-controllable at runtime. + * + * An AUFS filesystem (if it can be detected) will force avoidance of + * unlink. The env variable TCL_TEMPLOAD_NO_UNLINK allows detection of a + * users general request (unlink and not. + * + * By default the unlink is done (if not in AUFS). However if the variable is + * present and set to true (any integer > 0) then the unlink is skipped. + */ + +int +TclSkipUnlink (Tcl_Obj* shlibFile) +{ + /* Order of testing: + * 1. On hpux we generally want to skip unlink in general + * + * Outside of hpux then: + * 2. For a general user request (TCL_TEMPLOAD_NO_UNLINK present, non-empty, => int) + * 3. For general AUFS environment (statfs, if available). + * + * Ad 2: This variable can disable/override the AUFS detection, i.e. for + * testing if a newer AUFS does not have the bug any more. + * + * Ad 3: This is conditionally compiled in. Condition currently must be set manually. + * This part needs proper tests in the configure(.in). + */ #ifdef hpux - (void)shlibFile; return 1; #else - char *skipstr = getenv("TCL_TEMPLOAD_NO_UNLINK"); + char* skipstr; + 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. - */ +#ifdef TCL_TEMPLOAD_NO_UNLINK #ifndef NO_FSTATFS { struct statfs fs; - /* - * Have fstatfs. May not have the AUFS super magic ... Indeed our build + /* 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. + * Better reference will be gladly taken. */ #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(TclGetString(shlibFile), &fs) == 0) - && (fs.f_type == 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. - */ + /* Fallback: !hpux, no EV override, no AUFS (detection, nor detected): + * Don't skip */ return 0; #endif /* hpux */ } int -Tcl_LoadFile( +TclLoadFile( 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; + Tcl_Obj *pathPtr, /* Name of the file containing the desired + * code. */ + int symc, /* Number of symbols/procPtrs in the next two + * arrays. */ + const char *symbols[], /* Names of functions to look up in the file's + * symbol table. */ + Tcl_PackageInitProc **procPtrs[], + /* Where to return the addresses corresponding + * to symbols[]. */ + Tcl_LoadHandle *handlePtr, /* Filled with token for shared library + * information which can be used in + * TclpFindSymbol. */ + ClientData *clientDataPtr, /* 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. */ +{ const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - const Tcl_Filesystem *copyFsPtr; - Tcl_FSUnloadFileProc *unloadProcPtr; + Tcl_FSLoadFileProc *proc; + Tcl_Filesystem *copyFsPtr; Tcl_Obj *copyToPtr; Tcl_LoadHandle newLoadHandle = NULL; - Tcl_LoadHandle divertedLoadHandle = NULL; + ClientData newClientData = NULL; Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL; FsDivertLoad *tvdlPtr; int retVal; - int i; if (fsPtr == NULL) { Tcl_SetErrno(ENOENT); return TCL_ERROR; } - if (fsPtr->loadFileProc != NULL) { - retVal = ((Tcl_FSLoadFileProc2 *)(void *)(fsPtr->loadFileProc)) - (interp, pathPtr, handlePtr, &unloadProcPtr, flags); - + proc = fsPtr->loadFileProc; + if (proc != NULL) { + int retVal = ((Tcl_FSLoadFileProc2 *)proc) + (interp, pathPtr, handlePtr, unloadProcPtr, 0); if (retVal == TCL_OK) { if (*handlePtr == NULL) { return TCL_ERROR; } - if (interp) { - Tcl_ResetResult(interp); - } + + /* + * Copy this across, since both are equal for the native fs. + */ + + *clientDataPtr = (ClientData)*handlePtr; + 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. + * The filesystem doesn't support 'load', so we fall back on the following + * technique: + * + * First check if it is readable -- and exists! */ if (Tcl_FSAccess(pathPtr, R_OK) != 0) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't load library \"%s\": %s", - TclGetString(pathPtr), Tcl_PosixError(interp))); - } + Tcl_AppendResult(interp, "couldn't load library \"", + Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); 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: + * The platform supports loading code from memory, so ask for a buffer of + * the appropriate size, read the file into it and load the code from the + * buffer: */ { int ret, size; void *buffer; @@ -3226,11 +3321,11 @@ goto mustCopyToTempAnyway; } size = (int) statBuf.st_size; /* - * Tcl_Read takes an int: Determine whether the file size is wide. + * Tcl_Read takes an int: check that file size isn't wide. */ if (size != (Tcl_WideInt) statBuf.st_size) { goto mustCopyToTempAnyway; } @@ -3238,70 +3333,70 @@ if (!data) { goto mustCopyToTempAnyway; } buffer = TclpLoadMemoryGetBuffer(interp, size); if (!buffer) { - Tcl_CloseEx(interp, data, 0); + Tcl_Close(interp, data); goto mustCopyToTempAnyway; } - ret = Tcl_Read(data, (char *)buffer, size); - Tcl_CloseEx(interp, data, 0); + ret = Tcl_Read(data, buffer, size); + Tcl_Close(interp, data); ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr, - &unloadProcPtr, flags); + unloadProcPtr); if (ret == TCL_OK && *handlePtr != NULL) { + *clientDataPtr = (ClientData) *handlePtr; goto resolveSymbols; } } mustCopyToTempAnyway: - if (interp) { - Tcl_ResetResult(interp); - } -#endif /* TCL_LOAD_FROM_MEMORY */ + Tcl_ResetResult(interp); +#endif /* - * Get a temporary filename, first to copy the file into, and then to load. + * Get a temporary filename to use, first to copy the file into, and then + * to load. */ - copyToPtr = TclpTempFileNameForLibrary(interp, pathPtr); + copyToPtr = TclpTempFileName(); if (copyToPtr == NULL) { + Tcl_AppendResult(interp, "couldn't create temporary file: ", + Tcl_PosixError(interp), 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. - */ + * We already know we can't use Tcl_FSLoadFile from this filesystem, + * and we must avoid a possible infinite loop. 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)); - } + Tcl_AppendResult(interp, "couldn't load from current filesystem",NULL); return TCL_ERROR; } if (TclCrossFilesystemCopy(interp, pathPtr, copyToPtr) != TCL_OK) { + /* + * Cross-platform copy failed. + */ + Tcl_FSDeleteFile(copyToPtr); Tcl_DecrRefCount(copyToPtr); return TCL_ERROR; } -#ifndef _WIN32 +#if !defined(__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: + * Do we need to set appropriate permissions on the file? This may be + * required on some systems. On Unix we could loop over the file + * attributes, and set any that are called "-permissions" to 0700. However + * we just do this directly, like this: */ { int index; Tcl_Obj *perm; @@ -3314,432 +3409,275 @@ Tcl_DecrRefCount(perm); } #endif /* - * The cross-filesystem copy may have stored the number of bytes in the - * result, so reset the result now. + * We need to reset the result now, because the cross-filesystem copy may + * have stored the number of bytes in the result. */ - if (interp) { - Tcl_ResetResult(interp); - } + Tcl_ResetResult(interp); - retVal = Tcl_LoadFile(interp, copyToPtr, symbols, flags, procPtrs, - &newLoadHandle); + retVal = TclLoadFile(interp, copyToPtr, symc, symbols, procPtrs, + &newLoadHandle, &newClientData, &newUnloadProcPtr); if (retVal != TCL_OK) { + /* + * The file didn't load successfully. + */ + 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. + * Try to delete the file immediately - this is possible in some OSes, and + * avoids any worries about leaving the copy laying around on exit. */ - if (!skipUnlink(copyToPtr) && - (Tcl_FSDeleteFile(copyToPtr) == TCL_OK)) { + if ( + !TclSkipUnlink (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. + * We tell our caller about the real shared library which was loaded. + * Note that this does mean that the package list maintained by 'load' + * will store the original (vfs) path alongside the temporary load + * handle and unload proc ptr. */ - *handlePtr = newLoadHandle; - if (interp) { - Tcl_ResetResult(interp); - } + (*handlePtr) = newLoadHandle; + (*clientDataPtr) = newClientData; + (*unloadProcPtr) = newUnloadProcPtr; + Tcl_ResetResult(interp); return TCL_OK; } /* - * Divert the unloading in order to unload and cleanup the temporary file. + * When we unload this file, we need to divert the unloading so we can + * unload and cleanup the temporary file correctly. */ - tvdlPtr = (FsDivertLoad *)Tcl_Alloc(sizeof(FsDivertLoad)); + 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. + * Remember three pieces of information. This allows us to cleanup 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. */ + /* + * copyToPtr is already incremented for this reference. + */ + 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. + * This is the filesystem we loaded it into. Since we have a reference + * to 'copyToPtr', we already have a refCount on this filesystem, so + * we don't need to worry about it disappearing on us. */ tvdlPtr->divertedFilesystem = copyFsPtr; tvdlPtr->divertedFileNativeRep = NULL; } else { /* - * Grab the native representation. + * We need the native rep. */ tvdlPtr->divertedFileNativeRep = TclNativeDupInternalRep( Tcl_FSGetInternalRep(copyToPtr, copyFsPtr)); /* - * Don't keeep a reference to the Tcl_Obj or the native filesystem. + * We don't need or want references to the copied Tcl_Obj or the + * filesystem if it is the native one. */ tvdlPtr->divertedFile = NULL; tvdlPtr->divertedFilesystem = NULL; Tcl_DecrRefCount(copyToPtr); } copyToPtr = NULL; - - divertedLoadHandle = (Tcl_LoadHandle)Tcl_Alloc(sizeof(struct Tcl_LoadHandle_)); - divertedLoadHandle->clientData = tvdlPtr; - divertedLoadHandle->findSymbolProcPtr = DivertFindSymbol; - divertedLoadHandle->unloadFileProcPtr = DivertUnloadFile; - *handlePtr = divertedLoadHandle; - - if (interp) { - Tcl_ResetResult(interp); - } + (*handlePtr) = newLoadHandle; + (*clientDataPtr) = (ClientData) tvdlPtr; + (*unloadProcPtr) = TclFSUnloadTempFile; + + 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; + { + int i; + + for (i=0 ; iclientData; - 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); - } - - Tcl_Free(tvdlPtr); - Tcl_Free(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); - } - - Tcl_Free(tvdlPtr); + *--------------------------------------------------------------------------- + * + * TclFSUnloadTempFile -- + * + * This function is called when we loaded a library of code via an + * intermediate temporary file. This function ensures the library is + * correctly unloaded and the temporary file is correctly deleted. + * + * Results: + * None. + * + * Side effects: + * The effects of the 'unload' function called, and of course the + * temporary file will be deleted. + * + *--------------------------------------------------------------------------- + */ + +void +TclFSUnloadTempFile( + Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to + * Tcl_FSLoadFile(). The loadHandle is a token + * that represents the loaded file. */ +{ + FsDivertLoad *tvdlPtr = (FsDivertLoad *) loadHandle; + + /* + * This test should never trigger, since we give the client data in the + * function above. + */ + + if (tvdlPtr == NULL) { + return; + } + + /* + * Call the real 'unloadfile' proc we actually used. It is very important + * that we call this 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. + */ + + if (tvdlPtr->unloadProcPtr != NULL) { + (*tvdlPtr->unloadProcPtr)(tvdlPtr->loadHandle); + } + + if (tvdlPtr->divertedFilesystem == NULL) { + /* + * It was the native filesystem, and we have a special function + * available just for this purpose, which we know works even at this + * late stage. + */ + + TclpDeleteFile(tvdlPtr->divertedFileNativeRep); + NativeFreeInternalRep(tvdlPtr->divertedFileNativeRep); + + } else { + /* + * Remove the temporary file we created. Note, we may crash here + * because encodings have been taken down already. + */ + + if (tvdlPtr->divertedFilesystem->deleteFileProc(tvdlPtr->divertedFile) + != TCL_OK) { + /* + * The above may have failed because the filesystem, or something + * it depends upon (e.g. encodings) have been taken down because + * Tcl is exiting. + * + * We may need to work out how to delete this file more robustly + * (or give the filesystem the information it needs to delete the + * file more robustly). + * + * In particular, one problem might be that the filesystem cannot + * extract the information it needs from the above path object + * because Tcl's entire filesystem apparatus (the code in this + * file) has been finalized, and it refuses to pass the internal + * representation to the filesystem. + */ + } + + /* + * And free up the allocations. This will also of course remove a + * refCount from the Tcl_Filesystem to which this file belongs, which + * could then free up the filesystem if we are exiting. + */ + + Tcl_DecrRefCount(tvdlPtr->divertedFile); + } + + ckfree((char*)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(). + * This function replaces the library version of readlink() and can also + * be used to make links. The appropriate function for the filesystem to + * which pathPtr belongs will be called. * * 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. + * If toPtr is NULL, then the result is a Tcl_Obj specifying the contents + * of the symbolic link given by 'pathPtr', or NULL if the symbolic link + * could not be read. The result is owned by the caller, which should + * call Tcl_DecrRefCount when the result is no longer needed. * - * 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: + * If toPtr is non-NULL, then the result is toPtr if the link action was + * successful, or NULL if not. 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 an or'd 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. + * Note that most filesystems will not support linking across to + * different filesystems, so this function will usually fail unless toPtr + * is in the same FS as pathPtr. * * Side effects: - * Creates or sets a link if toPtr is not NULL. - * - * See readlink(). + * See readlink() documentation. A new filesystem link object may appear. * *--------------------------------------------------------------------------- */ 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. */ + Tcl_Obj *pathPtr, /* Path of file to readlink or link */ + Tcl_Obj *toPtr, /* NULL or path to be linked 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 (fsPtr != NULL) { + Tcl_FSLinkProc *proc = fsPtr->linkProc; + + if (proc != NULL) { + return (*proc)(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. + * If S_IFLNK isn't defined it means that 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 you invoke readlink on a file that isn't a symbolic + * link. */ #ifndef S_IFLNK - errno = EINVAL; /* TODO: Change to Tcl_SetErrno()? */ + errno = EINVAL; #else Tcl_SetErrno(ENOENT); #endif /* S_IFLNK */ return NULL; } @@ -3747,13 +3685,20 @@ /* *--------------------------------------------------------------------------- * * Tcl_FSListVolumes -- * - * Lists the currently mounted volumes by calling `listVolumesProc` of - * each registered filesystem, and combining the results to form a list of - * volumes. + * Lists the currently mounted volumes. The chain of functions that have + * been "inserted" into the filesystem will be called in succession; each + * may return a list of volumes, all of which are added to the result + * until all mounted file systems are listed. + * + * Notice that we assume the lists returned by each filesystem (if non + * NULL) have been given a refCount for us already. However, we are NOT + * allowed to hang on to the list itself (it belongs to the filesystem we + * called). Therefore we quite naturally add its contents to the result + * we are building, and then decrement the refCount. * * Results: * The list of volumes, in an object which has refCount 0. * * Side effects: @@ -3760,35 +3705,31 @@ * None * *--------------------------------------------------------------------------- */ -Tcl_Obj * +Tcl_Obj* Tcl_FSListVolumes(void) { FilesystemRecord *fsRecPtr; - Tcl_Obj *resultPtr; + 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. + * Call each of the "listVolumes" function in succession. A non-NULL + * return value indicates the particular function has succeeded. We call + * all the functions registered, since we want a list of all drives from + * all filesystems. */ - TclNewObj(resultPtr); fsRecPtr = FsGetFirstFilesystem(); Claim(); while (fsRecPtr != NULL) { - if (fsRecPtr->fsPtr->listVolumesProc != NULL) { - Tcl_Obj *thisFsVolumes = fsRecPtr->fsPtr->listVolumesProc(); - + Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc; + if (proc != NULL) { + Tcl_Obj *thisFsVolumes = (*proc)(); 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; } @@ -3800,46 +3741,51 @@ /* *--------------------------------------------------------------------------- * * FsListMounts -- * - * Lists the mounts mathing the given pattern in the given directory. + * List all mounts within the given directory, which match the given + * pattern. * * 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. + * The list of mounts, in a list object which has refCount 0, or NULL if + * we didn't even find any filesystems to try to list mounts. * * Side effects: - * None. + * None * *--------------------------------------------------------------------------- */ static Tcl_Obj * FsListMounts( - Tcl_Obj *pathPtr, /* Pathname of directory to search. */ + Tcl_Obj *pathPtr, /* Contains path to 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. + * Call each of the "matchInDirectory" functions in succession, with the + * specific type information 'mountsOnly'. A non-NULL return value + * indicates the particular function has succeeded. We call all the + * functions registered, since we want a list from each filesystems. */ fsRecPtr = FsGetFirstFilesystem(); Claim(); while (fsRecPtr != NULL) { - if (fsRecPtr->fsPtr != &tclNativeFilesystem && - fsRecPtr->fsPtr->matchInDirectoryProc != NULL) { - if (resultPtr == NULL) { - TclNewObj(resultPtr); + if (fsRecPtr->fsPtr != &tclNativeFilesystem) { + Tcl_FSMatchInDirectoryProc *proc = + fsRecPtr->fsPtr->matchInDirectoryProc; + if (proc != NULL) { + if (resultPtr == NULL) { + resultPtr = Tcl_NewObj(); + } + (*proc)(NULL, resultPtr, pathPtr, pattern, &mountsOnly); } - fsRecPtr->fsPtr->matchInDirectoryProc(NULL, resultPtr, pathPtr, - pattern, &mountsOnly); } fsRecPtr = fsRecPtr->nextPtr; } Disclaim(); @@ -3849,35 +3795,38 @@ /* *--------------------------------------------------------------------------- * * Tcl_FSSplitPath -- * - * Splits a pathname into its components. + * This function takes the given Tcl_Obj, which should be a valid path, + * and returns a Tcl List object containing each segment of that path as + * an element. * * Results: - * A list with refCount of zero. + * Returns list object with refCount of zero. If the passed in lenPtr is + * non-NULL, we use it to return the number of elements in the returned + * list. * * Side effects: - * If lenPtr is not null, sets it to the number of elements in the result. + * None. * *--------------------------------------------------------------------------- */ Tcl_Obj * Tcl_FSSplitPath( - Tcl_Obj *pathPtr, /* The pathname to split. */ - int *lenPtr) /* A place to hold the number of pathname - * elements. */ + Tcl_Obj *pathPtr, /* Path to split. */ + int *lenPtr) /* int to store number of path elements. */ { - Tcl_Obj *result = NULL; /* Just to squelch gcc warnings. */ - const Tcl_Filesystem *fsPtr; + Tcl_Obj *result = NULL; /* Needed only to prevent gcc warnings. */ + Tcl_Filesystem *fsPtr; char separator = '/'; int driveNameLength; - const char *p; + char *p; /* - * Perform platform-specific splitting. + * Perform platform specific splitting. */ if (TclFSGetPathType(pathPtr, &fsPtr, &driveNameLength) == TCL_PATH_ABSOLUTE) { if (fsPtr == &tclNativeFilesystem) { @@ -3885,49 +3834,48 @@ } } else { return TclpNativeSplitPath(pathPtr, lenPtr); } - /* Assume each separator is a single character. */ + /* + * We assume separators are single characters. + */ if (fsPtr->filesystemSeparatorProc != NULL) { - Tcl_Obj *sep = fsPtr->filesystemSeparatorProc(pathPtr); - + Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(pathPtr); if (sep != NULL) { Tcl_IncrRefCount(sep); - separator = TclGetString(sep)[0]; + 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. + * Place the drive name as first element of the result list. The drive + * name may contain strange characters, like colons and multiple forward + * slashes (for example 'ftp://' is a valid vfs drive name) */ - TclNewObj(result); - p = TclGetString(pathPtr); + 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. + * Add the remaining path elements to the list. */ for (;;) { - const char *elementStart = p; + char *elementStart = p; int length; - while ((*p != '\0') && (*p != separator)) { p++; } length = p - elementStart; if (length > 0) { Tcl_Obj *nextElt; - if (elementStart[0] == '~') { TclNewLiteralStringObj(nextElt, "./"); Tcl_AppendToObj(nextElt, elementStart, length); } else { nextElt = Tcl_NewStringObj(elementStart, length); @@ -3937,49 +3885,60 @@ if (*p++ == '\0') { break; } } + /* + * Compute the number of elements in the result. + */ + if (lenPtr != NULL) { TclListObjLength(NULL, result, lenPtr); } return result; } + /* *---------------------------------------------------------------------- * * TclGetPathType -- * - * Helper function used by TclFSGetPathType and TclJoinPath. + * Helper function used by FSGetPathType. * * Results: - * One of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or - * TCL_PATH_VOLUME_RELATIVE. + * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or + * TCL_PATH_VOLUME_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: - * See **filesystemPtrptr, *driveNameLengthPtr and **driveNameRef, + * None. * *---------------------------------------------------------------------- */ 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. */ -{ - size_t pathLen; - const char *path = TclGetStringFromObj(pathPtr, &pathLen); + Tcl_Obj *pathPtr, /* Path to determine type for */ + Tcl_Filesystem **filesystemPtrPtr, + /* If absolute path and this is not NULL, then + * set to the filesystem which claims this + * path. */ + int *driveNameLengthPtr, /* If the path is absolute, and this is + * non-NULL, then set to the length of the + * driveName. */ + Tcl_Obj **driveNameRef) /* If the path is absolute, and this is + * non-NULL, then set to the name of the + * drive, network-volume which contains the + * path, already with a refCount for the + * caller. */ +{ + int pathLen; + char *path; Tcl_PathType type; + + path = Tcl_GetStringFromObj(pathPtr, &pathLen); type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, driveNameLengthPtr, driveNameRef); if (type != TCL_PATH_ABSOLUTE) { @@ -3995,18 +3954,18 @@ /* *---------------------------------------------------------------------- * * 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. + * Helper function used by TclGetPathType. Its purpose is to check + * whether the given path starts with a string which corresponds to a + * file volume in any registered filesystem except 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 + * Returns 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. @@ -4014,82 +3973,89 @@ *---------------------------------------------------------------------- */ 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. */ + const char *path, /* Path to determine type for */ + int pathLen, /* Length of the path */ + Tcl_Filesystem **filesystemPtrPtr, + /* If absolute path and this is not NULL, then + * set to the filesystem which claims this + * path. */ + int *driveNameLengthPtr, /* If the path is absolute, and this is + * non-NULL, then set to the length of the + * driveName. */ + Tcl_Obj **driveNameRef) /* If the path is absolute, and this is + * non-NULL, then set to the name of the + * drive, network-volume which contains the + * path, already with a refCount for the + * caller. */ { 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. + * Call each of the "listVolumes" function in succession, checking whether + * the given path is an absolute path on any of the volumes returned (this + * is done by checking whether the path's prefix matches). */ 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. + Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc; + + /* + * We want to skip the native filesystem in this loop because + * otherwise we won't necessarily pass all the Tcl testsuite -- this + * is because some of the tests artificially change the current + * platform (between win, unix) but the list of volumes we get by + * calling (*proc) will reflect the current (real) platform only and + * this may cause some tests to fail. In particular, on unix '/' will + * match the beginning of certain absolute Windows paths starting '//' + * and those tests will go wrong. + * + * Besides these test-suite issues, there is one other reason to skip + * the native filesystem --- since the tclFilename.c code has nice + * fast 'absolute path' checkers, we don't want to waste time + * repeating that effort here, and this function is actually called + * quite often, so if we can save the overhead of the native + * filesystem returning us a list of volumes all the time, it is + * better. */ - if ((fsRecPtr->fsPtr != &tclNativeFilesystem) - && (fsRecPtr->fsPtr->listVolumesProc != NULL)) { + if ((fsRecPtr->fsPtr != &tclNativeFilesystem) && (proc != NULL)) { int numVolumes; - Tcl_Obj *thisFsVolumes = fsRecPtr->fsPtr->listVolumesProc(); + Tcl_Obj *thisFsVolumes = (*proc)(); 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'. + * This is VERY bad; the Tcl_FSListVolumesProc didn't + * return a valid list. Set numVolumes to -1 so that we + * skip the while 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. + * It would be better if we could signal an error here + * (but Tcl_Panic seems a bit excessive). */ numVolumes = -1; } while (numVolumes > 0) { Tcl_Obj *vol; - size_t len; - const char *strVol; + int len; + char *strVol; numVolumes--; Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol); - strVol = TclGetStringFromObj(vol,&len); - if ((size_t) pathLen < len) { + strVol = Tcl_GetStringFromObj(vol,&len); + if (pathLen < len) { continue; } - if (strncmp(strVol, path, len) == 0) { + if (strncmp(strVol, path, (size_t) len) == 0) { type = TCL_PATH_ABSOLUTE; if (filesystemPtrPtr != NULL) { *filesystemPtrPtr = fsRecPtr->fsPtr; } if (driveNameLengthPtr != NULL) { @@ -4103,13 +4069,12 @@ } } Tcl_DecrRefCount(thisFsVolumes); if (type == TCL_PATH_ABSOLUTE) { /* - * No need to to examine additional filesystems. + * We don't need to examine any more filesystems. */ - break; } } } fsRecPtr = fsRecPtr->nextPtr; @@ -4121,39 +4086,40 @@ /* *--------------------------------------------------------------------------- * * Tcl_FSRenameFile -- * - * If the two pathnames correspond to the same filesystem, call - * 'renameFileProc' of that filesystem. Otherwise return the POSIX error - * 'EXDEV', and -1. + * If the two paths given belong to the same filesystem, we call that + * filesystems rename function. Otherwise we simply return the POSIX + * error 'EXDEV', and -1. * * Results: - * A standard Tcl error code if a rename function was called, or -1 - * otherwise. + * Standard Tcl error code if a function was called. * * 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. */ + Tcl_Obj* srcPathPtr, /* Pathname of file or dir to be renamed + * (UTF-8). */ + Tcl_Obj *destPathPtr) /* New pathname of file or directory + * (UTF-8). */ { int retVal = -1; const Tcl_Filesystem *fsPtr, *fsPtr2; - fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr); fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr); - if ((fsPtr == fsPtr2) && (fsPtr != NULL) - && (fsPtr->renameFileProc != NULL)) { - retVal = fsPtr->renameFileProc(srcPathPtr, destPathPtr); + if ((fsPtr == fsPtr2) && (fsPtr != NULL)) { + Tcl_FSRenameFileProc *proc = fsPtr->renameFileProc; + if (proc != NULL) { + retVal = (*proc)(srcPathPtr, destPathPtr); + } } if (retVal == -1) { Tcl_SetErrno(EXDEV); } return retVal; @@ -4162,40 +4128,42 @@ /* *--------------------------------------------------------------------------- * * Tcl_FSCopyFile -- * - * If both pathnames correspond to the same filesystem, calls - * 'copyFileProc' of that filesystem. + * If the two paths given belong to the same filesystem, we call that + * filesystem's copy function. Otherwise we simply return the POSIX error + * 'EXDEV', and -1. * - * In the native filesystems, 'copyFileProc' copies a link itself, not the - * thing the link points to. + * Note that in the native filesystems, 'copyFileProc' is defined to copy + * soft links (i.e. it copies the links themselves, not the things they + * point to). * * Results: - * A standard Tcl return code if a copyFileProc was called, or -1 - * otherwise. + * Standard Tcl error code if a function was called. * * Side effects: - * A file might be copied. The POSIX error 'EXDEV' is set if a copy - * function was not called. + * A file may be copied. * *--------------------------------------------------------------------------- */ int Tcl_FSCopyFile( - Tcl_Obj *srcPathPtr, /* The pathname of file to be copied. */ - Tcl_Obj *destPathPtr) /* The new pathname to copy the file to. */ + Tcl_Obj *srcPathPtr, /* Pathname of file to be copied (UTF-8). */ + Tcl_Obj *destPathPtr) /* Pathname of file to copy to (UTF-8). */ { int retVal = -1; const Tcl_Filesystem *fsPtr, *fsPtr2; - fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr); fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr); - if (fsPtr == fsPtr2 && fsPtr != NULL && fsPtr->copyFileProc != NULL) { - retVal = fsPtr->copyFileProc(srcPathPtr, destPathPtr); + if (fsPtr == fsPtr2 && fsPtr != NULL) { + Tcl_FSCopyFileProc *proc = fsPtr->copyFileProc; + if (proc != NULL) { + retVal = (*proc)(srcPathPtr, destPathPtr); + } } if (retVal == -1) { Tcl_SetErrno(EXDEV); } return retVal; @@ -4204,27 +4172,27 @@ /* *--------------------------------------------------------------------------- * * TclCrossFilesystemCopy -- * - * Helper for Tcl_FSCopyFile and Tcl_FSLoadFile. Copies a file from one - * filesystem to another, overwiting any file that already exists. + * Helper for above function, and for Tcl_FSLoadFile, to copy files from + * one filesystem to another. This function will overwrite the target + * file if it already exists. * * Results: - * A standard Tcl return code. + * Standard Tcl error code. * * Side effects: - * A file may be copied. + * A file may be created. * *--------------------------------------------------------------------------- */ - 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. */ + Tcl_Interp *interp, /* For error messages */ + Tcl_Obj *source, /* Pathname of file to be copied (UTF-8). */ + Tcl_Obj *target) /* Pathname of file to copy to (UTF-8). */ { int result = TCL_ERROR; int prot = 0666; Tcl_Channel in, out; Tcl_StatBuf sourceStatBuf; @@ -4231,48 +4199,48 @@ struct utimbuf tval; out = Tcl_FSOpenFileChannel(interp, target, "wb", prot); if (out == NULL) { /* - * Failed to open an output channel. Bail out. + * It looks like we cannot copy it over. 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? + * This is very strange, caller should have checked this... */ - Tcl_CloseEx(interp, out, 0); + 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). + * Copy it synchronously. We might wish to add an asynchronous option to + * support vfs's which 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. + * If the copy failed, assume that copy channel left a good error message. */ - Tcl_CloseEx(interp, in, 0); - Tcl_CloseEx(interp, out, 0); + 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); + tval.actime = sourceStatBuf.st_atime; + tval.modtime = sourceStatBuf.st_mtime; Tcl_FSUtime(target, &tval); } done: return result; @@ -4281,15 +4249,15 @@ /* *--------------------------------------------------------------------------- * * Tcl_FSDeleteFile -- * - * Calls 'deleteFileProc' of the filesystem corresponding to the given - * pathname. + * The appropriate function for the filesystem to which pathPtr belongs + * will be called. * * Results: - * A standard Tcl return code. + * Standard Tcl error code. * * Side effects: * A file may be deleted. * *--------------------------------------------------------------------------- @@ -4298,13 +4266,15 @@ int Tcl_FSDeleteFile( Tcl_Obj *pathPtr) /* Pathname of file to be removed (UTF-8). */ { const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - - if (fsPtr != NULL && fsPtr->deleteFileProc != NULL) { - return fsPtr->deleteFileProc(pathPtr); + if (fsPtr != NULL) { + Tcl_FSDeleteFileProc *proc = fsPtr->deleteFileProc; + if (proc != NULL) { + return (*proc)(pathPtr); + } } Tcl_SetErrno(ENOENT); return -1; } @@ -4311,31 +4281,32 @@ /* *--------------------------------------------------------------------------- * * Tcl_FSCreateDirectory -- * - * Calls 'createDirectoryProc' of the filesystem corresponding to the - * given pathname. + * The appropriate function for the filesystem to which pathPtr belongs + * will be called. * * Results: - * A standard Tcl return code, or -1 if no createDirectoryProc is found. + * Standard Tcl error code. * * Side effects: - * A directory may be created. POSIX error 'ENOENT' is set if no - * createDirectoryProc is found. + * A directory may be created. * *--------------------------------------------------------------------------- */ int Tcl_FSCreateDirectory( Tcl_Obj *pathPtr) /* Pathname of directory to create (UTF-8). */ { const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - - if (fsPtr != NULL && fsPtr->createDirectoryProc != NULL) { - return fsPtr->createDirectoryProc(pathPtr); + if (fsPtr != NULL) { + Tcl_FSCreateDirectoryProc *proc = fsPtr->createDirectoryProc; + if (proc != NULL) { + return (*proc)(pathPtr); + } } Tcl_SetErrno(ENOENT); return -1; } @@ -4342,43 +4313,42 @@ /* *--------------------------------------------------------------------------- * * Tcl_FSCopyDirectory -- * - * If both pathnames correspond to the the same filesystem, calls - * 'copyDirectoryProc' of that filesystem. + * If the two paths given belong to the same filesystem, we call that + * filesystems copy-directory function. Otherwise we simply return the + * POSIX error 'EXDEV', and -1. * * Results: - * A standard Tcl return code, or -1 if no 'copyDirectoryProc' is found. + * Standard Tcl error code if a function was called. * * Side effects: - * A directory may be copied. POSIX error 'EXDEV' is set if no - * copyDirectoryProc is found. + * A directory may be copied. * *--------------------------------------------------------------------------- */ 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. */ + Tcl_Obj* srcPathPtr, /* Pathname of directory to be copied + * (UTF-8). */ + Tcl_Obj *destPathPtr, /* Pathname of target directory (UTF-8). */ + Tcl_Obj **errorPtr) /* If non-NULL, then will be set to a new + * object containing name of file causing + * error, with refCount 1. */ { int retVal = -1; const Tcl_Filesystem *fsPtr, *fsPtr2; - fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr); fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr); - if (fsPtr == fsPtr2 && fsPtr != NULL && fsPtr->copyDirectoryProc != NULL){ - retVal = fsPtr->copyDirectoryProc(srcPathPtr, destPathPtr, errorPtr); + if (fsPtr == fsPtr2 && fsPtr != NULL) { + Tcl_FSCopyDirectoryProc *proc = fsPtr->copyDirectoryProc; + if (proc != NULL) { + retVal = (*proc)(srcPathPtr, destPathPtr, errorPtr); + } } if (retVal == -1) { Tcl_SetErrno(EXDEV); } return retVal; @@ -4387,180 +4357,202 @@ /* *--------------------------------------------------------------------------- * * Tcl_FSRemoveDirectory -- * - * Calls 'removeDirectoryProc' of the filesystem corresponding to remove - * pathPtr. + * The appropriate function for the filesystem to which pathPtr belongs + * will be called. * * Results: - * A standard Tcl return code, or -1 if no removeDirectoryProc is found. + * Standard Tcl error code. * * Side effects: - * A directory may be removed. POSIX error 'ENOENT' is set if no - * removeDirectoryProc is found. + * A directory may be deleted. * *--------------------------------------------------------------------------- */ 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. - * */ + Tcl_Obj *pathPtr, /* Pathname of directory to be removed + * (UTF-8). */ + int recursive, /* If non-zero, removes directories that are + * nonempty. Otherwise, will only remove empty + * directories. */ + Tcl_Obj **errorPtr) /* If non-NULL, then will be set to a new + * object containing name of file causing + * error, with refCount 1. */ { 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; - size_t cwdLen, normLen; - Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); - - if (normPath != NULL) { - normPathStr = TclGetStringFromObj(normPath, &normLen); - cwdStr = TclGetStringFromObj(cwdPtr, &cwdLen); - if ((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr, - normLen) == 0)) { - /* - * The cwd is inside the directory to be removed. Change - * the cwd to [file dirname $path]. - */ - - Tcl_Obj *dirPtr = TclPathPart(NULL, pathPtr, - TCL_PATH_DIRNAME); - - Tcl_FSChdir(dirPtr); - Tcl_DecrRefCount(dirPtr); - } - } - Tcl_DecrRefCount(cwdPtr); - } - } - return fsPtr->removeDirectoryProc(pathPtr, recursive, errorPtr); + if (fsPtr != NULL && fsPtr->removeDirectoryProc != NULL) { + Tcl_FSRemoveDirectoryProc *proc = fsPtr->removeDirectoryProc; + if (recursive) { + /* + * We check whether the cwd lies inside this directory and move it + * if it does. + */ + + Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL); + + if (cwdPtr != NULL) { + char *cwdStr, *normPathStr; + int cwdLen, normLen; + Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); + + if (normPath != NULL) { + normPathStr = Tcl_GetStringFromObj(normPath, &normLen); + cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); + if ((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr, + (size_t) normLen) == 0)) { + /* + * The cwd is inside the directory, so we perform a + * 'cd [file dirname $path]'. + */ + + Tcl_Obj *dirPtr = TclPathPart(NULL, pathPtr, + TCL_PATH_DIRNAME); + + Tcl_FSChdir(dirPtr); + Tcl_DecrRefCount(dirPtr); + } + } + Tcl_DecrRefCount(cwdPtr); + } + } + return (*proc)(pathPtr, recursive, errorPtr); + } + Tcl_SetErrno(ENOENT); + return -1; } /* *--------------------------------------------------------------------------- * * Tcl_FSGetFileSystemForPath -- * - * Produces the filesystem that corresponds to the given pathname. + * This function determines which filesystem to use for a particular path + * object, and returns the filesystem which accepts this file. If no + * filesystem will accept this object as a valid file path, then NULL is + * returned. * * Results: - * The corresponding Tcl_Filesystem, or NULL if the pathname is invalid. + * NULL or a filesystem which will accept this path. * * Side effects: - * The internal representation of fsPtrPtr is converted to fsPathType if - * needed, and that internal representation is updated as needed. + * The object may be converted to a path type. * *--------------------------------------------------------------------------- */ -const Tcl_Filesystem * +Tcl_Filesystem * Tcl_FSGetFileSystemForPath( - Tcl_Obj *pathPtr) + Tcl_Obj* pathPtr) { FilesystemRecord *fsRecPtr; - const Tcl_Filesystem *retVal = NULL; + Tcl_Filesystem* retVal = NULL; if (pathPtr == NULL) { Tcl_Panic("Tcl_FSGetFileSystemForPath called with NULL object"); return NULL; } + /* + * If the object has a refCount of zero, we reject it. This is to avoid + * possible segfaults or nondeterministic memory leaks (i.e. the user + * doesn't know if they should decrement the ref count on return or not). + */ + 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 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; + /* + * Check if the filesystem has changed in some way since this object's + * internal representation was calculated. Before doing that, assure we + * have the most up-to-date copy of the master filesystem. This is + * accomplished by the FsGetFirstFilesystem() call. + */ + + fsRecPtr = FsGetFirstFilesystem(); + Claim(); + + if (TclFSEnsureEpochOk(pathPtr, &retVal) != TCL_OK) { + Disclaim(); + return NULL; + } + + /* + * Call each of the "pathInFilesystem" functions in succession. A + * non-return value of -1 indicates the particular function has succeeded. + */ + + while ((retVal == NULL) && (fsRecPtr != NULL)) { + Tcl_FSPathInFilesystemProc *proc = + fsRecPtr->fsPtr->pathInFilesystemProc; + + if (proc != NULL) { + ClientData clientData = NULL; + if ((*proc)(pathPtr, &clientData) != -1) { + /* + * We assume the type of pathPtr hasn't been changed by the + * above call to the pathInFilesystemProc. + */ + + TclFSSetPathDetails(pathPtr, fsRecPtr->fsPtr, clientData); + retVal = fsRecPtr->fsPtr; + } + } + fsRecPtr = fsRecPtr->nextPtr; + } + Disclaim(); + + return retVal; } /* *--------------------------------------------------------------------------- * * Tcl_FSGetNativePath -- * - * See Tcl_FSGetInternalRep. + * This function is for use by the Win/Unix native filesystems, so that + * they can easily retrieve the native (char* or TCHAR*) representation + * of a path. Other filesystems will probably want to implement similar + * functions. They basically act as a safety net around + * Tcl_FSGetInternalRep. Normally your file-system functions will always + * be called with path objects already converted to the correct + * filesystem, but if for some reason they are called directly (i.e. by + * functions not in this file), then one cannot necessarily guarantee + * that the path object pointer is from the correct filesystem. + * + * Note: in the future it might be desireable 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: + * NULL or a valid native path. + * + * Side effects: + * See Tcl_FSGetInternalRep. * *--------------------------------------------------------------------------- */ -const void * +const char * Tcl_FSGetNativePath( Tcl_Obj *pathPtr) { - return Tcl_FSGetInternalRep(pathPtr, &tclNativeFilesystem); + return (const char *) Tcl_FSGetInternalRep(pathPtr, &tclNativeFilesystem); } /* *--------------------------------------------------------------------------- * * NativeFreeInternalRep -- * - * Free a native internal representation. + * Free a native internal representation, which will be non-NULL. * * Results: * None. * * Side effects: @@ -4571,50 +4563,49 @@ static void NativeFreeInternalRep( ClientData clientData) { - Tcl_Free(clientData); + ckfree((char *) clientData); } /* *--------------------------------------------------------------------------- * * Tcl_FSFileSystemInfo -- - * Produce the type of a pathname and the type of its filesystem. * + * This function returns a list of two elements. The first element is the + * name of the filesystem (e.g. "native" or "vfs"), and the second is the + * particular type of the given path within that 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. + * A list of two elements. * * Side effects: - * The internal representation of pathPtr may be converted to a - * fsPathType. + * The object may be converted to a path type. * *--------------------------------------------------------------------------- */ Tcl_Obj * Tcl_FSFileSystemInfo( Tcl_Obj *pathPtr) { Tcl_Obj *resPtr; + Tcl_FSFilesystemPathTypeProc *proc; const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr == NULL) { return NULL; } resPtr = Tcl_NewListObj(0, NULL); - Tcl_ListObjAppendElement(NULL, resPtr, - Tcl_NewStringObj(fsPtr->typeName, -1)); + Tcl_ListObjAppendElement(NULL,resPtr,Tcl_NewStringObj(fsPtr->typeName,-1)); - if (fsPtr->filesystemPathTypeProc != NULL) { - Tcl_Obj *typePtr = fsPtr->filesystemPathTypeProc(pathPtr); - + proc = fsPtr->filesystemPathTypeProc; + if (proc != NULL) { + Tcl_Obj *typePtr = (*proc)(pathPtr); if (typePtr != NULL) { Tcl_ListObjAppendElement(NULL, resPtr, typePtr); } } @@ -4624,68 +4615,70 @@ /* *--------------------------------------------------------------------------- * * Tcl_FSPathSeparator -- * - * Produces the separator for given pathname. + * This function returns the separator to be used for a given path. The + * object returned should have a refCount of zero * * Results: - * A Tcl object having a refCount of zero. + * A Tcl object, with a refCount of zero. If the caller needs to retain a + * reference to the object, it should call Tcl_IncrRefCount, and should + * otherwise free the object. * * Side effects: - * The internal representation of pathPtr may be converted to a fsPathType + * The path object may be converted to a path type. * *--------------------------------------------------------------------------- */ 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; + return (*fsPtr->filesystemSeparatorProc)(pathPtr); + } else { + Tcl_Obj *resultObj; + + /* + * Allow filesystems not to provide a filesystemSeparatorProc if they + * wish to use the standard forward slash. + */ + + TclNewLiteralStringObj(resultObj, "/"); + return resultObj; + } } /* *--------------------------------------------------------------------------- * * NativeFilesystemSeparator -- * - * This function, part of the native filesystem support, returns the - * separator for the given pathname. + * This function is part of the native filesystem support, and returns + * the separator for the given path. * * Results: - * The separator character. + * String object containing the separator character. * * Side effects: * None. * *--------------------------------------------------------------------------- */ static Tcl_Obj * NativeFilesystemSeparator( - TCL_UNUSED(Tcl_Obj *) /*pathPtr*/) + Tcl_Obj *pathPtr) { - const char *separator = NULL; - + const char *separator = NULL; /* lint */ switch (tclPlatform) { case TCL_PLATFORM_UNIX: separator = "/"; break; case TCL_PLATFORM_WINDOWS: @@ -4692,13 +4685,325 @@ separator = "\\"; break; } return Tcl_NewStringObj(separator,1); } + +/* Everything from here on is contained in this obsolete ifdef */ +#ifdef USE_OBSOLETE_FS_HOOKS + +/* + *---------------------------------------------------------------------- + * + * TclStatInsertProc -- + * + * Insert the passed function pointer at the head of the list of + * functions which are used during a call to 'TclStat(...)'. The passed + * function should behave exactly like 'TclStat' when called during that + * time (see 'TclStat(...)' for more information). The function will be + * added even if it already in the list. + * + * Results: + * Normally TCL_OK; TCL_ERROR if memory for a new node in the list could + * not be allocated. + * + * Side effects: + * Memory allocated and modifies the link list for 'TclStat' functions. + * + *---------------------------------------------------------------------- + */ + +int +TclStatInsertProc( + TclStatProc_ *proc) +{ + int retVal = TCL_ERROR; + + if (proc != NULL) { + StatProc *newStatProcPtr; + + newStatProcPtr = (StatProc *)ckalloc(sizeof(StatProc)); + + if (newStatProcPtr != NULL) { + newStatProcPtr->proc = proc; + Tcl_MutexLock(&obsoleteFsHookMutex); + newStatProcPtr->nextPtr = statProcList; + statProcList = newStatProcPtr; + Tcl_MutexUnlock(&obsoleteFsHookMutex); + + retVal = TCL_OK; + } + } + + return retVal; +} + +/* + *---------------------------------------------------------------------- + * + * TclStatDeleteProc -- + * + * Removed the passed function pointer from the list of 'TclStat' + * functions. Ensures that the built-in stat function is not removable. + * + * Results: + * TCL_OK if the function pointer was successfully removed, TCL_ERROR + * otherwise. + * + * Side effects: + * Memory is deallocated and the respective list updated. + * + *---------------------------------------------------------------------- + */ + +int +TclStatDeleteProc( + TclStatProc_ *proc) +{ + int retVal = TCL_ERROR; + StatProc *tmpStatProcPtr; + StatProc *prevStatProcPtr = NULL; + + Tcl_MutexLock(&obsoleteFsHookMutex); + tmpStatProcPtr = statProcList; + + /* + * Traverse the 'statProcList' looking for the particular node whose + * 'proc' member matches 'proc' and remove that one from the list. Ensure + * that the "default" node cannot be removed. + */ + + while ((retVal == TCL_ERROR) && (tmpStatProcPtr != NULL)) { + if (tmpStatProcPtr->proc == proc) { + if (prevStatProcPtr == NULL) { + statProcList = tmpStatProcPtr->nextPtr; + } else { + prevStatProcPtr->nextPtr = tmpStatProcPtr->nextPtr; + } + + ckfree((char *)tmpStatProcPtr); + + retVal = TCL_OK; + } else { + prevStatProcPtr = tmpStatProcPtr; + tmpStatProcPtr = tmpStatProcPtr->nextPtr; + } + } + + Tcl_MutexUnlock(&obsoleteFsHookMutex); + + return retVal; +} + +/* + *---------------------------------------------------------------------- + * + * TclAccessInsertProc -- + * + * Insert the passed function pointer at the head of the list of + * functions which are used during a call to 'TclAccess(...)'. The passed + * function should behave exactly like 'TclAccess' when called during + * that time (see 'TclAccess(...)' for more information). The function + * will be added even if it already in the list. + * + * Results: + * Normally TCL_OK; TCL_ERROR if memory for a new node in the list could + * not be allocated. + * + * Side effects: + * Memory allocated and modifies the link list for 'TclAccess' functions. + * + *---------------------------------------------------------------------- + */ + +int +TclAccessInsertProc( + TclAccessProc_ *proc) +{ + int retVal = TCL_ERROR; + + if (proc != NULL) { + AccessProc *newAccessProcPtr; + + newAccessProcPtr = (AccessProc *)ckalloc(sizeof(AccessProc)); + + if (newAccessProcPtr != NULL) { + newAccessProcPtr->proc = proc; + Tcl_MutexLock(&obsoleteFsHookMutex); + newAccessProcPtr->nextPtr = accessProcList; + accessProcList = newAccessProcPtr; + Tcl_MutexUnlock(&obsoleteFsHookMutex); + + retVal = TCL_OK; + } + } + + return retVal; +} + +/* + *---------------------------------------------------------------------- + * + * TclAccessDeleteProc -- + * + * Removed the passed function pointer from the list of 'TclAccess' + * functions. Ensures that the built-in access function is not removable. + * + * Results: + * TCL_OK if the function pointer was successfully removed, TCL_ERROR + * otherwise. + * + * Side effects: + * Memory is deallocated and the respective list updated. + * + *---------------------------------------------------------------------- + */ + +int +TclAccessDeleteProc( + TclAccessProc_ *proc) +{ + int retVal = TCL_ERROR; + AccessProc *tmpAccessProcPtr; + AccessProc *prevAccessProcPtr = NULL; + + /* + * Traverse the 'accessProcList' looking for the particular node whose + * 'proc' member matches 'proc' and remove that one from the list. Ensure + * that the "default" node cannot be removed. + */ + + Tcl_MutexLock(&obsoleteFsHookMutex); + tmpAccessProcPtr = accessProcList; + while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != NULL)) { + if (tmpAccessProcPtr->proc == proc) { + if (prevAccessProcPtr == NULL) { + accessProcList = tmpAccessProcPtr->nextPtr; + } else { + prevAccessProcPtr->nextPtr = tmpAccessProcPtr->nextPtr; + } + + ckfree((char *)tmpAccessProcPtr); + + retVal = TCL_OK; + } else { + prevAccessProcPtr = tmpAccessProcPtr; + tmpAccessProcPtr = tmpAccessProcPtr->nextPtr; + } + } + Tcl_MutexUnlock(&obsoleteFsHookMutex); + + return retVal; +} + +/* + *---------------------------------------------------------------------- + * + * TclOpenFileChannelInsertProc -- + * + * Insert the passed function pointer at the head of the list of + * functions which are used during a call to 'Tcl_OpenFileChannel(...)'. + * The passed function should behave exactly like 'Tcl_OpenFileChannel' + * when called during that time (see 'Tcl_OpenFileChannel(...)' for more + * information). The function will be added even if it already in the + * list. + * + * Results: + * Normally TCL_OK; TCL_ERROR if memory for a new node in the list could + * not be allocated. + * + * Side effects: + * Memory allocated and modifies the link list for 'Tcl_OpenFileChannel' + * functions. + * + *---------------------------------------------------------------------- + */ + +int +TclOpenFileChannelInsertProc( + TclOpenFileChannelProc_ *proc) +{ + int retVal = TCL_ERROR; + + if (proc != NULL) { + OpenFileChannelProc *newOpenFileChannelProcPtr; + + newOpenFileChannelProcPtr = (OpenFileChannelProc *) + ckalloc(sizeof(OpenFileChannelProc)); + + newOpenFileChannelProcPtr->proc = proc; + Tcl_MutexLock(&obsoleteFsHookMutex); + newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList; + openFileChannelProcList = newOpenFileChannelProcPtr; + Tcl_MutexUnlock(&obsoleteFsHookMutex); + + retVal = TCL_OK; + } + + return retVal; +} + +/* + *---------------------------------------------------------------------- + * + * TclOpenFileChannelDeleteProc -- + * + * Removed the passed function pointer from the list of + * 'Tcl_OpenFileChannel' functions. Ensures that the built-in open file + * channel function is not removable. + * + * Results: + * TCL_OK if the function pointer was successfully removed, TCL_ERROR + * otherwise. + * + * Side effects: + * Memory is deallocated and the respective list updated. + * + *---------------------------------------------------------------------- + */ + +int +TclOpenFileChannelDeleteProc( + TclOpenFileChannelProc_ *proc) +{ + int retVal = TCL_ERROR; + OpenFileChannelProc *tmpOpenFileChannelProcPtr = openFileChannelProcList; + OpenFileChannelProc *prevOpenFileChannelProcPtr = NULL; + + /* + * Traverse the 'openFileChannelProcList' looking for the particular node + * whose 'proc' member matches 'proc' and remove that one from the list. + */ + + Tcl_MutexLock(&obsoleteFsHookMutex); + tmpOpenFileChannelProcPtr = openFileChannelProcList; + while ((retVal == TCL_ERROR) && + (tmpOpenFileChannelProcPtr != NULL)) { + if (tmpOpenFileChannelProcPtr->proc == proc) { + if (prevOpenFileChannelProcPtr == NULL) { + openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr; + } else { + prevOpenFileChannelProcPtr->nextPtr = + tmpOpenFileChannelProcPtr->nextPtr; + } + + ckfree((char *) tmpOpenFileChannelProcPtr); + + retVal = TCL_OK; + } else { + prevOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr; + tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr; + } + } + Tcl_MutexUnlock(&obsoleteFsHookMutex); + + return retVal; +} +#endif /* USE_OBSOLETE_FS_HOOKS */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclIndexObj.c ================================================================== --- generic/tclIndexObj.c +++ generic/tclIndexObj.c @@ -1,15 +1,13 @@ /* * tclIndexObj.c -- * * This file implements objects of type "index". This object type is used * to lookup a keyword in a table of valid values and cache the index of - * the matching entry. Also provides table-based argv/argc processing. + * the matching entry. * - * Copyright (c) 1990-1994 The Regents of the University of California. * Copyright (c) 1997 Sun Microsystems, Inc. - * Copyright (c) 2006 Sam Bromley. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ @@ -17,39 +15,26 @@ /* * 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 int SetIndexFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); 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, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int PrefixMatchObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static void PrintUsage(Tcl_Interp *interp, - const Tcl_ArgvInfo *argTable); /* * The structure below defines the index Tcl object type by means of functions * that can be invoked by generic object code. */ -static const Tcl_ObjType indexType = { - "index", /* name */ - FreeIndex, /* freeIntRepProc */ - DupIndex, /* dupIntRepProc */ - UpdateStringOfIndex, /* updateStringProc */ - NULL /* setFromAnyProc */ +static Tcl_ObjType indexType = { + "index", /* name */ + FreeIndex, /* freeIntRepProc */ + DupIndex, /* dupIntRepProc */ + UpdateStringOfIndex, /* updateStringProc */ + SetIndexFromAny /* 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 @@ -57,13 +42,13 @@ * * Keep this structure declaration in sync with tclTestObj.c */ typedef struct { - void *tablePtr; /* Pointer to the table of strings */ - size_t offset; /* Offset between table entries */ - size_t index; /* Selected index into table. */ + 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... */ @@ -76,84 +61,68 @@ STRING_AT((indexRep)->tablePtr, (indexRep)->offset*(indexRep)->index) /* *---------------------------------------------------------------------- * - * GetIndexFromObjList -- + * Tcl_GetIndexFromObj -- * - * This procedure looks up an object's value in a table of strings and + * 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 tableObjPtr, 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 ...' + * one of the entries in objPtr, 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: - * Removes any internal representation that the object might have. (TODO: - * find a way to cache the lookup.) + * The result of the lookup is cached as the internal rep of objPtr, so + * that repeated lookups can be done quickly. * *---------------------------------------------------------------------- */ +#undef Tcl_GetIndexFromObj int -GetIndexFromObjList( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ +Tcl_GetIndexFromObj( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr, /* Object containing the string to lookup. */ - Tcl_Obj *tableObjPtr, /* List of strings to compare against the - * value of objPtr. */ + const char **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. */ { - int objc, result, t; - Tcl_Obj **objv; - const char **tablePtr; - - /* - * Use Tcl_GetIndexFromObjStruct to do the work to avoid duplicating most - * of the code there. This is a bit ineffiecient but simpler. - */ - - result = Tcl_ListObjGetElements(interp, tableObjPtr, &objc, &objv); - if (result != TCL_OK) { - return result; - } - - /* - * Build a string table from the list. - */ - - tablePtr = (const char **)Tcl_Alloc((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. - */ - - Tcl_Free((void *)tablePtr); - *indexPtr = t; + /* + * 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). + */ + + if (objPtr->typePtr == &indexType) { + IndexRep *indexRep = objPtr->internalRep.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; } - - tablePtr[t] = TclGetString(objv[t]); - } - tablePtr[objc] = NULL; - - result = Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, - sizeof(char *), msg, flags | TCL_INDEX_TEMP_TABLE, indexPtr); - - Tcl_Free((void *)tablePtr); - - return result; + } + return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *), + msg, flags, indexPtr); } /* *---------------------------------------------------------------------- * @@ -163,17 +132,17 @@ * an offset for the amount of space between strings. This is useful when * the strings are embedded in some other kind of array. * * 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 like 'bad option "foo": must - * be ...' + * one of the entries in objPtr, 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 like '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. * @@ -180,48 +149,44 @@ *---------------------------------------------------------------------- */ int Tcl_GetIndexFromObjStruct( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + 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. */ - size_t offset, /* The number of bytes between 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; + 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+1 <= sizeof(char *)) { - offset = sizeof(char *); + if (offset < (int)sizeof(char *)) { + offset = (int)sizeof(char *); } /* * See if there is a valid cached result from a previous lookup. */ - if (!(flags & TCL_INDEX_TEMP_TABLE)) { - irPtr = TclFetchIntRep(objPtr, &indexType); - if (irPtr) { - indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1; + if (objPtr->typePtr == &indexType) { + indexRep = objPtr->internalRep.twoPtrValue.ptr1; if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) { *indexPtr = indexRep->index; return TCL_OK; } - } } /* * Lookup the value of the object in the table. Accept unique * abbreviations unless TCL_EXACT is set in flags. @@ -236,11 +201,11 @@ * - 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; + for (entryPtr = 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; @@ -273,25 +238,21 @@ * Cache the found representation. Note that we want to avoid allocating a * new internal-rep if at all possible since that is potentially a slow * operation. */ - if (!(flags & TCL_INDEX_TEMP_TABLE)) { - irPtr = TclFetchIntRep(objPtr, &indexType); - if (irPtr) { - indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1; + if (objPtr->typePtr == &indexType) { + indexRep = objPtr->internalRep.twoPtrValue.ptr1; } else { - Tcl_ObjIntRep ir; - - indexRep = (IndexRep*)Tcl_Alloc(sizeof(IndexRep)); - ir.twoPtrValue.ptr1 = indexRep; - Tcl_StoreIntRep(objPtr, &indexType, &ir); + TclFreeIntRep(objPtr); + indexRep = (IndexRep *) ckalloc(sizeof(IndexRep)); + objPtr->internalRep.twoPtrValue.ptr1 = indexRep; + objPtr->typePtr = &indexType; } indexRep->tablePtr = (void *) tablePtr; indexRep->offset = offset; indexRep->index = index; - } *indexPtr = index; return TCL_OK; error: @@ -301,36 +262,63 @@ */ int count = 0; TclNewObj(resultPtr); - entryPtr = (const char* const *)tablePtr; + Tcl_SetObjResult(interp, resultPtr); + entryPtr = 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) { - Tcl_AppendStringsToObj(resultPtr, "\": no valid options", NULL); - } else { - Tcl_AppendStringsToObj(resultPtr, "\": must be ", - *entryPtr, NULL); - entryPtr = NEXT_ENTRY(entryPtr, offset); - while (*entryPtr != NULL) { - if (*NEXT_ENTRY(entryPtr, offset) == NULL) { - Tcl_AppendStringsToObj(resultPtr, (count > 0 ? "," : ""), - " or ", *entryPtr, NULL); - } else if (**entryPtr) { - Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, NULL); - count++; - } - entryPtr = NEXT_ENTRY(entryPtr, offset); - } - } - Tcl_SetObjResult(interp, resultPtr); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", msg, key, NULL); + Tcl_AppendStringsToObj(resultPtr, (numAbbrev > 1) && + !(flags & TCL_EXACT) ? "ambiguous " : "bad ", msg, " \"", key, + "\": must be ", *entryPtr, NULL); + entryPtr = NEXT_ENTRY(entryPtr, offset); + while (*entryPtr != NULL) { + if (*NEXT_ENTRY(entryPtr, offset) == NULL) { + Tcl_AppendStringsToObj(resultPtr, ((count > 0) ? "," : ""), + " or ", *entryPtr, NULL); + } else if (**entryPtr) { + Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, NULL); + count++; + } + entryPtr = NEXT_ENTRY(entryPtr, offset); + } + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", msg, key, NULL); + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * SetIndexFromAny -- + * + * This function is called to convert a Tcl object to index internal + * form. However, this doesn't make sense (need to have a table of + * keywords in order to do the conversion) so the function always + * generates an error. + * + * Results: + * The return value is always TCL_ERROR, and an error message is left in + * interp's result if interp isn't NULL. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +SetIndexFromAny( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr) /* The object to convert. */ +{ + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't convert value to index except via Tcl_GetIndexFromObj API", + -1)); } return TCL_ERROR; } /* @@ -352,14 +340,20 @@ static void UpdateStringOfIndex( Tcl_Obj *objPtr) { - IndexRep *indexRep = (IndexRep *)TclFetchIntRep(objPtr, &indexType)->twoPtrValue.ptr1; - const char *indexStr = EXPAND_OF(indexRep); + IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1; + register char *buf; + register unsigned len; + register const char *indexStr = EXPAND_OF(indexRep); - Tcl_InitStringRep(objPtr, indexStr, strlen(indexStr)); + len = strlen(indexStr); + buf = (char *) ckalloc(len + 1); + memcpy(buf, indexStr, len+1); + objPtr->bytes = buf; + objPtr->length = len; } /* *---------------------------------------------------------------------- * @@ -381,18 +375,16 @@ static void DupIndex( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - Tcl_ObjIntRep ir; - IndexRep *dupIndexRep = (IndexRep *)Tcl_Alloc(sizeof(IndexRep)); - - memcpy(dupIndexRep, TclFetchIntRep(srcPtr, &indexType)->twoPtrValue.ptr1, - sizeof(IndexRep)); - - ir.twoPtrValue.ptr1 = dupIndexRep; - Tcl_StoreIntRep(dupPtr, &indexType, &ir); + IndexRep *srcIndexRep = srcPtr->internalRep.twoPtrValue.ptr1; + IndexRep *dupIndexRep = (IndexRep *) ckalloc(sizeof(IndexRep)); + + memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep)); + dupPtr->internalRep.twoPtrValue.ptr1 = dupIndexRep; + dupPtr->typePtr = &indexType; } /* *---------------------------------------------------------------------- * @@ -412,327 +404,13 @@ static void FreeIndex( Tcl_Obj *objPtr) { - Tcl_Free(TclFetchIntRep(objPtr, &indexType)->twoPtrValue.ptr1); + ckfree((char *) objPtr->internalRep.twoPtrValue.ptr1); objPtr->typePtr = NULL; } - -/* - *---------------------------------------------------------------------- - * - * TclInitPrefixCmd -- - * - * This procedure creates the "prefix" Tcl command. See the user - * documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -Tcl_Command -TclInitPrefixCmd( - Tcl_Interp *interp) /* Current interpreter. */ -{ - static const EnsembleImplMap prefixImplMap[] = { - {"all", PrefixAllObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"longest", PrefixLongestObjCmd,TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"match", PrefixMatchObjCmd, TclCompileBasicMin2ArgCmd, NULL, NULL, 0}, - {NULL, NULL, NULL, NULL, NULL, 0} - }; - Tcl_Command prefixCmd; - - prefixCmd = TclMakeEnsemble(interp, "::tcl::prefix", prefixImplMap); - Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0), - "prefix", 0); - return prefixCmd; -} - -/*---------------------------------------------------------------------- - * - * PrefixMatchObjCmd -- - * - * This function implements the 'prefix match' Tcl command. Refer to the - * user documentation for details on what it does. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -PrefixMatchObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int flags = 0, result, index; - int dummyLength, i, errorLength; - Tcl_Obj *errorPtr = NULL; - const char *message = "option"; - Tcl_Obj *tablePtr, *objPtr, *resultPtr; - static const char *const matchOptions[] = { - "-error", "-exact", "-message", NULL - }; - enum matchOptionsEnum { - PRFMATCH_ERROR, PRFMATCH_EXACT, PRFMATCH_MESSAGE - }; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "?options? table string"); - return TCL_ERROR; - } - - for (i = 1; i < (objc - 2); i++) { - if (Tcl_GetIndexFromObj(interp, objv[i], matchOptions, "option", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum matchOptionsEnum) index) { - case PRFMATCH_EXACT: - flags |= TCL_EXACT; - break; - case PRFMATCH_MESSAGE: - if (i > objc-4) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "missing value for -message", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL); - return TCL_ERROR; - } - i++; - message = TclGetString(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; - } - i++; - result = Tcl_ListObjLength(interp, objv[i], &errorLength); - if (result != TCL_OK) { - return TCL_ERROR; - } - if ((errorLength % 2) != 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "error options must have an even number of elements", - -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL); - return TCL_ERROR; - } - errorPtr = objv[i]; - break; - } - } - - tablePtr = objv[objc - 2]; - objPtr = objv[objc - 1]; - - /* - * Check that table is a valid list first, since we want to handle that - * error case regardless of level. - */ - - result = Tcl_ListObjLength(interp, tablePtr, &dummyLength); - if (result != TCL_OK) { - return result; - } - - result = GetIndexFromObjList(interp, objPtr, tablePtr, message, flags, - &index); - if (result != TCL_OK) { - if (errorPtr != NULL && errorLength == 0) { - Tcl_ResetResult(interp); - return TCL_OK; - } else if (errorPtr == NULL) { - return TCL_ERROR; - } - - if (Tcl_IsShared(errorPtr)) { - errorPtr = Tcl_DuplicateObj(errorPtr); - } - Tcl_ListObjAppendElement(interp, errorPtr, - Tcl_NewStringObj("-code", 5)); - Tcl_ListObjAppendElement(interp, errorPtr, Tcl_NewWideIntObj(result)); - - return Tcl_SetReturnOptions(interp, errorPtr); - } - - result = Tcl_ListObjIndex(interp, tablePtr, index, &resultPtr); - if (result != TCL_OK) { - return result; - } - Tcl_SetObjResult(interp, resultPtr); - return TCL_OK; -} - -/*---------------------------------------------------------------------- - * - * PrefixAllObjCmd -- - * - * This function implements the 'prefix all' Tcl command. Refer to the - * user documentation for details on what it does. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * 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; - size_t length, elemLength; - const char *string, *elemString; - Tcl_Obj **tableObjv, *resultPtr; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "table string"); - return TCL_ERROR; - } - - result = Tcl_ListObjGetElements(interp, objv[1], &tableObjc, &tableObjv); - if (result != TCL_OK) { - return result; - } - resultPtr = Tcl_NewListObj(0, NULL); - string = TclGetStringFromObj(objv[2], &length); - - for (t = 0; t < tableObjc; t++) { - elemString = TclGetStringFromObj(tableObjv[t], &elemLength); - - /* - * A prefix cannot match if it is longest. - */ - - if (length <= elemLength) { - if (TclpUtfNcmp2(elemString, string, length) == 0) { - Tcl_ListObjAppendElement(interp, resultPtr, tableObjv[t]); - } - } - } - - Tcl_SetObjResult(interp, resultPtr); - return TCL_OK; -} - -/*---------------------------------------------------------------------- - * - * PrefixLongestObjCmd -- - * - * This function implements the 'prefix longest' Tcl command. Refer to - * the user documentation for details on what it does. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * 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, t; - size_t i, length, elemLength, resultLength; - const char *string, *elemString, *resultString; - Tcl_Obj **tableObjv; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "table string"); - return TCL_ERROR; - } - - result = Tcl_ListObjGetElements(interp, objv[1], &tableObjc, &tableObjv); - if (result != TCL_OK) { - return result; - } - string = TclGetStringFromObj(objv[2], &length); - - resultString = NULL; - resultLength = 0; - - for (t = 0; t < tableObjc; t++) { - elemString = TclGetStringFromObj(tableObjv[t], &elemLength); - - /* - * First check if the prefix string matches the element. A prefix - * cannot match if it is longest. - */ - - if ((length > elemLength) || - TclpUtfNcmp2(elemString, string, length) != 0) { - continue; - } - - if (resultString == NULL) { - /* - * If this is the first match, the longest common substring this - * far is the complete string. The result is part of this string - * so we only need to adjust the length later. - */ - - resultString = elemString; - resultLength = elemLength; - } else { - /* - * Longest common substring cannot be longer than shortest string. - */ - - if (elemLength < resultLength) { - resultLength = elemLength; - } - - /* - * Compare strings. - */ - - 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) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj(resultString, resultLength)); - } - return TCL_OK; -} /* *---------------------------------------------------------------------- * * Tcl_WrongNumArgs -- @@ -780,19 +458,39 @@ const char *message) /* Error message to print after the leading * objects in objv. The message may be * NULL. */ { Tcl_Obj *objPtr; - int i; - size_t len, elemLen; - char flags; + int i, len, elemLen, 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); } @@ -805,18 +503,10 @@ if (iPtr->ensembleRewrite.sourceObjs != NULL) { int toSkip = iPtr->ensembleRewrite.numInsertedObjs; int toPrint = iPtr->ensembleRewrite.numRemovedObjs; Tcl_Obj *const *origObjv = iPtr->ensembleRewrite.sourceObjs; - /* - * Check for spelling fixes, and substitute the fixed values. - */ - - if (origObjv[0] == NULL) { - origObjv = (Tcl_Obj *const *)origObjv[2]; - } - /* * We only know how to do rewriting if all the replaced objects are * actually arguments (in objv) to this function. Otherwise it just * gets too complicated and we'd be better off just giving a slightly * confusing error message... @@ -839,33 +529,42 @@ for (i=0 ; itwoPtrValue.ptr1; + if (origObjv[i]->typePtr == &indexType) { + register IndexRep *indexRep = + origObjv[i]->internalRep.twoPtrValue.ptr1; elementStr = EXPAND_OF(indexRep); + elemLen = strlen(elementStr); + } else if (origObjv[i]->typePtr == &tclEnsembleCmdType) { + register EnsembleCmdRep *ecrPtr = + origObjv[i]->internalRep.twoPtrValue.ptr1; + + elementStr = ecrPtr->fullSubcmdName; elemLen = strlen(elementStr); } else { elementStr = TclGetStringFromObj(origObjv[i], &elemLen); } flags = 0; len = TclScanElement(elementStr, elemLen, &flags); - if (len != elemLen) { - char *quotedElementStr = (char *)TclStackAlloc(interp, len + 1); + if (MAY_QUOTE_WORD && len != elemLen) { + char *quotedElementStr = TclStackAlloc(interp, + (unsigned)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). */ @@ -886,36 +585,43 @@ /* * 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; + if (objv[i]->typePtr == &indexType) { + register IndexRep *indexRep = objv[i]->internalRep.twoPtrValue.ptr1; Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL); + } else if (objv[i]->typePtr == &tclEnsembleCmdType) { + register EnsembleCmdRep *ecrPtr = + objv[i]->internalRep.twoPtrValue.ptr1; + + Tcl_AppendStringsToObj(objPtr, ecrPtr->fullSubcmdName, NULL); } else { /* * Quote the argument if it contains spaces (Bug 942757). */ elementStr = TclGetStringFromObj(objv[i], &elemLen); flags = 0; len = TclScanElement(elementStr, elemLen, &flags); - if (len != elemLen) { - char *quotedElementStr = (char *)TclStackAlloc(interp, len + 1); + if (MAY_QUOTE_WORD && len != elemLen) { + char *quotedElementStr = TclStackAlloc(interp, + (unsigned) 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). */ @@ -933,433 +639,17 @@ if (message != NULL) { Tcl_AppendStringsToObj(objPtr, message, NULL); } Tcl_AppendStringsToObj(objPtr, "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); Tcl_SetObjResult(interp, objPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ParseArgsObjv -- - * - * Process an objv array according to a table of expected command-line - * options. See the manual page for more details. - * - * Results: - * The return value is a standard Tcl return value. If an error occurs - * then an error message is left in the interp's result. Under normal - * conditions, both *objcPtr and *objv are modified to return the - * arguments that couldn't be processed here (they didn't match the - * option table, or followed an TCL_ARGV_REST argument). - * - * Side effects: - * Variables may be modified, or procedures may be called. It all depends - * on the arguments and their entries in argTable. See the user - * documentation for details. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_ParseArgsObjv( - Tcl_Interp *interp, /* Place to store error message. */ - const Tcl_ArgvInfo *argTable, - /* Array of option descriptions. */ - int *objcPtr, /* Number of arguments in objv. Modified to - * hold # args left in objv at end. */ - Tcl_Obj *const *objv, /* Array of arguments to be parsed. */ - Tcl_Obj ***remObjv) /* Pointer to array of arguments that were not - * 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. */ - size_t 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 **)Tcl_Alloc((1 + *objcPtr) * sizeof(Tcl_Obj *)); - leftovers[0] = objv[0]; - } else { - nrem = 0; - leftovers = NULL; - } - - /* - * OK, now start processing from the second element (1st argument). - */ - - srcIndex = dstIndex = 1; - objc = *objcPtr-1; - - while (objc > 0) { - curArg = objv[srcIndex]; - srcIndex++; - objc--; - str = TclGetStringFromObj(curArg, &length); - if (length > 0) { - c = str[1]; - } else { - c = 0; - } - - /* - * Loop throught the argument descriptors searching for one with the - * matching key string. If found, leave a pointer to it in matchPtr. - */ - - matchPtr = NULL; - infoPtr = argTable; - for (; infoPtr != NULL && infoPtr->type != TCL_ARGV_END ; infoPtr++) { - if (infoPtr->keyStr == NULL) { - continue; - } - if ((infoPtr->keyStr[1] != c) - || (strncmp(infoPtr->keyStr, str, length) != 0)) { - continue; - } - if (infoPtr->keyStr[length] == 0) { - matchPtr = infoPtr; - goto gotMatch; - } - if (matchPtr != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "ambiguous option \"%s\"", str)); - goto error; - } - matchPtr = infoPtr; - } - if (matchPtr == NULL) { - /* - * Unrecognized argument. Just copy it down, unless the caller - * prefers an error to be registered. - */ - - if (remObjv == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unrecognized argument \"%s\"", str)); - goto error; - } - - dstIndex++; /* This argument is now handled */ - leftovers[nrem++] = curArg; - continue; - } - - /* - * Take the appropriate action based on the option type - */ - - gotMatch: - infoPtr = matchPtr; - switch (infoPtr->type) { - case TCL_ARGV_CONSTANT: - *((int *) infoPtr->dstPtr) = PTR2INT(infoPtr->srcPtr); - break; - case TCL_ARGV_INT: - 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, TclGetString(objv[srcIndex]))); - goto error; - } - srcIndex++; - objc--; - break; - case TCL_ARGV_STRING: - if (objc == 0) { - goto missingArg; - } - *((const char **) infoPtr->dstPtr) = - TclGetString(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. - */ - - if (infoPtr->dstPtr != NULL) { - *((int *) infoPtr->dstPtr) = dstIndex; - } - goto argsDone; - case TCL_ARGV_FLOAT: - 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, TclGetString(objv[srcIndex]))); - goto error; - } - srcIndex++; - objc--; - break; - case TCL_ARGV_FUNC: { - Tcl_ArgvFuncProc *handlerProc = (Tcl_ArgvFuncProc *) - infoPtr->srcPtr; - Tcl_Obj *argObj; - - if (objc == 0) { - argObj = NULL; - } else { - argObj = objv[srcIndex]; - } - if (handlerProc(infoPtr->clientData, argObj, infoPtr->dstPtr)) { - srcIndex++; - objc--; - } - break; - } - case TCL_ARGV_GENFUNC: { - Tcl_ArgvGenFuncProc *handlerProc = (Tcl_ArgvGenFuncProc *) - infoPtr->srcPtr; - - objc = handlerProc(infoPtr->clientData, interp, objc, - &objv[srcIndex], infoPtr->dstPtr); - if (objc < 0) { - goto error; - } - break; - } - case TCL_ARGV_HELP: - PrintUsage(interp, argTable); - goto error; - default: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad argument type %d in Tcl_ArgvInfo", infoPtr->type)); - goto error; - } - } - - /* - * If we broke out of the loop because of an OPT_REST argument, copy the - * remaining arguments down. Note that there is always at least one - * argument left over - the command name - so we always have a result if - * our caller is willing to receive it. [Bug 3413857] - */ - - argsDone: - if (remObjv == NULL) { - /* - * Nothing to do. - */ - - return TCL_OK; - } - - if (objc > 0) { - memcpy(leftovers+nrem, objv+srcIndex, objc*sizeof(Tcl_Obj *)); - nrem += objc; - } - leftovers[nrem] = NULL; - *objcPtr = nrem++; - *remObjv = (Tcl_Obj **)Tcl_Realloc(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) { - Tcl_Free(leftovers); - } - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * PrintUsage -- - * - * Generate a help string describing command-line options. - * - * Results: - * The interp's result will be modified to hold a help string describing - * all the options in argTable. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -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++) { - size_t length; - - if (infoPtr->keyStr == NULL) { - continue; - } - length = strlen(infoPtr->keyStr); - if (length > (size_t)width) { - width = length; - } - } - - /* - * Now add the option information, with pretty-printing. - */ - - msg = Tcl_NewStringObj("Command-specific options:", -1); - for (infoPtr = argTable; infoPtr->type != TCL_ARGV_END; infoPtr++) { - if ((infoPtr->type == TCL_ARGV_HELP) && (infoPtr->keyStr == NULL)) { - Tcl_AppendPrintfToObj(msg, "\n%s", infoPtr->helpStr); - continue; - } - Tcl_AppendPrintfToObj(msg, "\n %s:", infoPtr->keyStr); - numSpaces = width + 1 - strlen(infoPtr->keyStr); - while (numSpaces > 0) { - if (numSpaces >= NUM_SPACES) { - Tcl_AppendToObj(msg, spaces, NUM_SPACES); - } else { - Tcl_AppendToObj(msg, spaces, numSpaces); - } - numSpaces -= NUM_SPACES; - } - Tcl_AppendToObj(msg, infoPtr->helpStr, -1); - switch (infoPtr->type) { - case TCL_ARGV_INT: - Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: %d", - *((int *) infoPtr->dstPtr)); - break; - case TCL_ARGV_FLOAT: - Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: %g", - *((double *) infoPtr->dstPtr)); - sprintf(tmp, "%g", *((double *) infoPtr->dstPtr)); - break; - case TCL_ARGV_STRING: { - char *string = *((char **) infoPtr->dstPtr); - - if (string != NULL) { - Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: \"%s\"", - string); - } - break; - } - default: - break; - } - } - Tcl_SetObjResult(interp, msg); -} - -/* - *---------------------------------------------------------------------- - * - * TclGetCompletionCodeFromObj -- - * - * Parses Completion code Code - * - * Results: - * Returns TCL_ERROR if the value is an invalid completion code. - * Otherwise, returns TCL_OK, and writes the completion code to the - * pointer provided. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclGetCompletionCodeFromObj( - Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Obj *value, - int *codePtr) /* Argument objects. */ -{ - static const char *const returnCodes[] = { - "ok", "error", "return", "break", "continue", NULL - }; - - if (!TclHasIntRep(value, &indexType) - && TclGetIntFromObj(NULL, value, codePtr) == TCL_OK) { - return TCL_OK; - } - if (Tcl_GetIndexFromObj(NULL, value, returnCodes, NULL, TCL_EXACT, - codePtr) == TCL_OK) { - return TCL_OK; - } - - /* - * Value is not a legal completion code. - */ - - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad completion code \"%s\": must be" - " ok, error, return, break, continue, or an integer", - TclGetString(value))); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_CODE", NULL); - } - return TCL_ERROR; +#undef MAY_QUOTE_WORD +#undef AFTER_FIRST_WORD } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclInt.decls ================================================================== --- generic/tclInt.decls +++ generic/tclInt.decls @@ -15,10 +15,11 @@ library tcl # Define the unsupported generic interfaces. interface tclInt +scspec EXTERN # Declare each of the functions in the unsupported internal Tcl # interface. These interfaces are allowed to changed between versions. # Use at your own risk. Note that the position of functions should not # be changed between versions to avoid gratuitous incompatibilities. @@ -46,17 +47,16 @@ } declare 6 { void TclCleanupCommand(Command *cmdPtr) } declare 7 { - size_t TclCopyAndCollapse(size_t count, const char *src, char *dst) + int TclCopyAndCollapse(int count, const char *src, char *dst) } -# Removed in 9.0: -#declare 8 { -# int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan, -# Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr) -#} +declare 8 { + int TclCopyChannel(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, @@ -78,11 +78,11 @@ #declare 13 { # int TclDoGlob(Tcl_Interp *interp, char *separators, # Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types) #} declare 14 { - int TclDumpMemoryInfo(void *clientData, int flags) + int TclDumpMemoryInfo(ClientData clientData, int flags) } # Removed in 8.1: # declare 15 { # void TclExpandParseValue(ParseValue *pvPtr, int needed) # } @@ -106,18 +106,18 @@ # 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, - size_t *sizePtr, int *bracePtr) + 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 { - size_t TclFormatInt(char *buffer, Tcl_WideInt n) + int TclFormatInt(char *buffer, long n) } declare 25 { void TclFreePackageInfo(Interp *iPtr) } # Removed in 8.1: @@ -150,26 +150,24 @@ } # Removed in 8.5: #declare 33 { # TclCmdProcType TclGetInterpProc(void) #} -# Removed in 9.0: -#declare 34 {deprecated {Use Tcl_GetIntForIndex}} { -# int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, -# int endValue, int *indexPtr) -#} +declare 34 { + 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 { -# int TclGetLong(Tcl_Interp *interp, const char *str, long *longPtr) -#} +declare 36 { + int TclGetLong(Tcl_Interp *interp, const char *str, long *longPtr) +} declare 37 { - int TclGetLoadedPackages(Tcl_Interp *interp, const char *targetName) + int TclGetLoadedPackages(Tcl_Interp *interp, char *targetName) } declare 38 { int TclGetNamespaceForQualName(Tcl_Interp *interp, const char *qualName, Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, @@ -183,11 +181,11 @@ } declare 41 { Tcl_Command TclGetOriginalCommand(Tcl_Command command) } declare 42 { - const char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr) + 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) @@ -213,29 +211,28 @@ #} #declare 49 { # Tcl_Obj *TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, # Tcl_Obj *part2Ptr, long incrAmount, int part1NotParsed) #} -# Removed in 9.0: -#declare 50 { -# void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr, -# Namespace *nsPtr) -#} +declare 50 { + void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr, + Namespace *nsPtr) +} declare 51 { int TclInterpInit(Tcl_Interp *interp) } # Removed in 8.5a2: #declare 52 { # int TclInvoke(Tcl_Interp *interp, int argc, const char **argv, # int flags) #} declare 53 { - int TclInvokeObjectCommand(void *clientData, Tcl_Interp *interp, - int argc, const char **argv) + int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp, + int argc, CONST84 char **argv) } declare 54 { - int TclInvokeStringCommand(void *clientData, Tcl_Interp *interp, + int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) } declare 55 { Proc *TclIsProc(Command *cmdPtr) } @@ -267,11 +264,11 @@ } declare 62 { int TclObjCommandComplete(Tcl_Obj *cmdPtr) } declare 63 { - int TclObjInterpProc(void *clientData, Tcl_Interp *interp, + 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) @@ -290,11 +287,11 @@ # Replaced by Tcl_FSAccess in 8.4: #declare 68 { # int TclpAccess(const char *path, int mode) #} declare 69 { - void *TclpAlloc(size_t size) + char *TclpAlloc(unsigned int size) } #declare 70 { # int TclpCopyFile(const char *source, const char *dest) #} #declare 71 { @@ -306,27 +303,26 @@ #} #declare 73 { # int TclpDeleteFile(const char *path) #} declare 74 { - void TclpFree(void *ptr) + void TclpFree(char *ptr) } declare 75 { - Tcl_WideUInt TclpGetClicks(void) + unsigned long TclpGetClicks(void) } declare 76 { - Tcl_WideUInt TclpGetSeconds(void) + unsigned long TclpGetSeconds(void) } -# Removed in 9.0: -#declare 77 { -# void TclpGetTime(Tcl_Time *time) -#} -# Removed in 8.6: -#declare 78 { -# int TclpGetTimeZone(unsigned long time) -#} +# deprecated +declare 77 { + void TclpGetTime(Tcl_Time *time) +} +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: @@ -333,11 +329,11 @@ #declare 80 { # Tcl_Channel TclpOpenFileChannel(Tcl_Interp *interp, char *fileName, # char *modeString, int permissions) #} declare 81 { - void *TclpRealloc(void *ptr, size_t size) + char *TclpRealloc(char *ptr, unsigned int size) } #declare 82 { # int TclpRemoveDirectory(const char *path, int recursive, # Tcl_DString *errorPtr) #} @@ -358,15 +354,14 @@ # int flags, char **termPtr, ParseValue *pvPtr) # } # declare 87 { # void TclPlatformInit(Tcl_Interp *interp) # } -# Removed in 9.0: -#declare 88 { -# char *TclPrecTraceProc(void *clientData, Tcl_Interp *interp, -# const char *name1, const char *name2, int flags) -#} +declare 88 { + 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): @@ -380,11 +375,11 @@ int TclProcCompileProc(Tcl_Interp *interp, Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr, const char *description, const char *procName) } declare 93 { - void TclProcDeleteProc(void *clientData) + void TclProcDeleteProc(ClientData clientData) } # Removed in 8.5: #declare 94 { # int TclProcInterpProc(void *clientData, Tcl_Interp *interp, # int argc, const char **argv) @@ -412,23 +407,22 @@ #declare 100 { # Tcl_Obj *TclSetIndexedScalar(Tcl_Interp *interp, int localIndex, # Tcl_Obj *objPtr, int flags) #} declare 101 { - const char *TclSetPreInitScript(const char *string) + char *TclSetPreInitScript(char *string) } declare 102 { void TclSetupEnv(Tcl_Interp *interp) } declare 103 { int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr) } -# Removed in 9.0: -#declare 104 { -# int TclSockMinimumBuffersOld(int sock, int size) -#} +declare 104 { + 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 { @@ -457,39 +451,33 @@ declare 111 { void Tcl_AddInterpResolvers(Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc) } -# Removed in 9.0: -#declare 112 { -# int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, -# Tcl_Obj *objPtr) -#} -# Removed in 9.0: -#declare 113 { -# Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name, -# void *clientData, Tcl_NamespaceDeleteProc *deleteProc) -#} -# Removed in 9.0: -#declare 114 { -# void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr) -#} -# Removed in 9.0: -#declare 115 { -# int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, -# const char *pattern, int resetListFirst) -#} -# Removed in 9.0: -#declare 116 { -# Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name, -# Tcl_Namespace *contextNsPtr, int flags) -#} -# Removed in 9.0: -#declare 117 { -# Tcl_Namespace *Tcl_FindNamespace(Tcl_Interp *interp, const char *name, -# Tcl_Namespace *contextNsPtr, int flags) -#} +declare 112 { + int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + Tcl_Obj *objPtr) +} +declare 113 { + Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name, + ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc) +} +declare 114 { + void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr) +} +declare 115 { + int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + const char *pattern, int resetListFirst) +} +declare 116 { + Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name, + Tcl_Namespace *contextNsPtr, int flags) +} +declare 117 { + Tcl_Namespace *Tcl_FindNamespace(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 { @@ -498,41 +486,35 @@ } declare 120 { Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags) } -# Removed in 9.0: -#declare 121 { -# int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, -# const char *pattern) -#} -# Removed in 9.0: -#declare 122 { -# Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) -#} -# Removed in 9.0: -#declare 123 { -# void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command, -# Tcl_Obj *objPtr) -#} -# Removed in 9.0: -#declare 124 { -# Tcl_Namespace *Tcl_GetCurrentNamespace(Tcl_Interp *interp) -#} -# Removed in 9.0: -#declare 125 { -# Tcl_Namespace *Tcl_GetGlobalNamespace(Tcl_Interp *interp) -#} +declare 121 { + int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + const char *pattern) +} +declare 122 { + Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) +} +declare 123 { + void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command, + Tcl_Obj *objPtr) +} +declare 124 { + Tcl_Namespace *Tcl_GetCurrentNamespace(Tcl_Interp *interp) +} +declare 125 { + Tcl_Namespace *Tcl_GetGlobalNamespace(Tcl_Interp *interp) +} declare 126 { void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr) } -# Removed in 9.0: -#declare 127 { -# int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, -# const char *pattern, int allowOverwrite) -#} +declare 127 { + int Tcl_Import(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, @@ -547,14 +529,13 @@ Tcl_ResolveCompiledVarProc *compiledVarProc) } declare 132 { int TclpHasSockets(Tcl_Interp *interp) } -# Removed in 9.0 -#declare 133 { -# struct tm *TclpGetDate(const time_t *time, int useGMT) -#} +declare 133 { + 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) #} @@ -566,11 +547,11 @@ #declare 137 { # int TclpChdir(const char *dirName) #} declare 138 { - const char *TclGetEnv(const char *name, Tcl_DString *valuePtr) + CONST84_RETURN char *TclGetEnv(const char *name, Tcl_DString *valuePtr) } #declare 139 { # int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, # char *sym2, Tcl_PackageInitProc **proc1Ptr, # Tcl_PackageInitProc **proc2Ptr, void **clientDataPtr) @@ -578,15 +559,15 @@ #declare 140 { # int TclLooksLikeInt(const char *bytes, int length) #} # This is used by TclX, but should otherwise be considered private declare 141 { - const char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) + CONST84_RETURN char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) } declare 142 { int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, - CompileHookProc *hookProc, void *clientData) + CompileHookProc *hookProc, ClientData clientData) } declare 143 { int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr) } @@ -593,11 +574,11 @@ declare 144 { void TclHideLiteral(Tcl_Interp *interp, struct CompileEnv *envPtr, int index) } declare 145 { - const struct AuxDataType *TclGetAuxDataType(const char *typeName) + struct AuxDataType *TclGetAuxDataType(char *typeName) } declare 146 { TclHandle TclHandleCreate(void *ptr) } declare 147 { @@ -614,12 +595,12 @@ declare 150 { int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re) } declare 151 { - void TclRegExpRangeUniChar(Tcl_RegExp re, size_t index, size_t *startPtr, - size_t *endPtr) + void TclRegExpRangeUniChar(Tcl_RegExp re, int index, int *startPtr, + int *endPtr) } declare 152 { void TclSetLibraryPath(Tcl_Obj *pathPtr) } declare 153 { @@ -641,18 +622,16 @@ int status) } declare 157 { Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName) } -# REMOVED - use public Tcl_SetStartupScript() -#declare 158 { -# void TclSetStartupScriptFileName(const char *filename) -#} -# REMOVED - use public Tcl_GetStartupScript() -#declare 159 { -# const char *TclGetStartupScriptFileName(void) -#} +declare 158 { + void TclSetStartupScriptFileName(const char *filename) +} +declare 159 { + CONST84_RETURN char *TclGetStartupScriptFileName(void) +} #declare 160 { # int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators, # Tcl_DString *dirPtr, char *pattern, char *tail, # GlobTypeData *types) #} @@ -661,20 +640,20 @@ declare 161 { int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr) } declare 162 { - void TclChannelEventScriptInvoker(void *clientData, int flags) + 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. declare 163 { - const void *TclGetInstructionTable(void) + void *TclGetInstructionTable(void) } # ALERT: The argument of 'TclExpandCodeArray' is actually a # "CompileEnv*" but we do not want to describe this structure in # "tclInt.h". It is described in "tclCompile.h". @@ -693,41 +672,39 @@ int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr) } # VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above) -# REMOVED - use public Tcl_SetStartupScript() -#declare 167 { -# void TclSetStartupScriptPath(Tcl_Obj *pathPtr) -#} -# REMOVED - use public Tcl_GetStartupScript() -#declare 168 { -# Tcl_Obj *TclGetStartupScriptPath(void) -#} +declare 167 { + void TclSetStartupScriptPath(Tcl_Obj *pathPtr) +} +declare 168 { + Tcl_Obj *TclGetStartupScriptPath(void) +} # variant of Tcl_UtfNCmp that takes n as bytes, not chars declare 169 { - int TclpUtfNcmp2(const char *s1, const char *s2, size_t n) + int TclpUtfNcmp2(const char *s1, const char *s2, unsigned long n) } declare 170 { int TclCheckInterpTraces(Tcl_Interp *interp, const char *command, - size_t numChars, Command *cmdPtr, int result, int traceFlags, + int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]) } declare 171 { int TclCheckExecutionTraces(Tcl_Interp *interp, const char *command, - size_t numChars, Command *cmdPtr, int result, int traceFlags, + 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, size_t strLen, - const Tcl_UniChar *pattern, size_t ptnLen, int flags) + int TclUniCharMatch(const Tcl_UniChar *string, int strLen, + const Tcl_UniChar *pattern, int ptnLen, int flags) } # added for 8.4.3 #declare 174 { @@ -746,17 +723,16 @@ } declare 177 { void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason) } -# TIP 338 made these public - now declared in tcl.h -#declare 178 { -# void Tcl_SetStartupScript(Tcl_Obj *pathPtr, const char *encodingName) -#} -#declare 179 { -# Tcl_Obj *Tcl_GetStartupScript(const char **encodingNamePtr) -#} +declare 178 { + void Tcl_SetStartupScript(Tcl_Obj *pathPtr, const char *encodingName) +} +declare 179 { + Tcl_Obj *Tcl_GetStartupScript(const char **encodingNamePtr) +} # REMOVED # Allocate lists without copying arrays # declare 180 { # Tcl_Obj *TclNewListObjDirect(int objc, Tcl_Obj **objv) @@ -764,18 +740,18 @@ #declare 181 { # Tcl_Obj *TclDbNewListObjDirect(int objc, Tcl_Obj **objv, # const char *file, int line) #} -# Removed in 9.0 -#declare 182 { -# struct tm *TclpLocaltime(const time_t *clock) -#} -# Removed in 9.0 -#declare 183 { -# struct tm *TclpGmtime(const time_t *clock) -#} +# TclpGmtime and TclpLocaltime promoted to the generic interface from unix + +declare 182 { + struct tm *TclpLocaltime(const time_t *clock) +} +declare 183 { + 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 @@ -886,11 +862,11 @@ } declare 214 { void TclSetObjNameOfExecutable(Tcl_Obj *name, Tcl_Encoding encoding) } declare 215 { - void *TclStackAlloc(Tcl_Interp *interp, size_t numBytes) + void *TclStackAlloc(Tcl_Interp *interp, int numBytes) } declare 216 { void TclStackFree(Tcl_Interp *interp, void *freePtr) } declare 217 { @@ -913,19 +889,17 @@ } declare 226 { int TclObjBeingDeleted(Tcl_Obj *objPtr) } declare 227 { - void TclSetNsPath(Namespace *nsPtr, size_t pathLength, + 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 228 { + int TclObjInterpProcCore(register 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 { @@ -956,128 +930,38 @@ void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr) } # TIP 337 made this one public -#declare 236 { -# 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(void *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 { - int TclNRRunCallbacks(Tcl_Interp *interp, int result, - struct NRE_callback *rootPtr) -} -declare 241 { - int TclNREvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, - const CmdFrame *invoker, int word) -} -declare 242 { - int TclNREvalObjv(Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[], int flags, Command *cmdPtr) +declare 236 { + void TclBackgroundException(Tcl_Interp *interp, int code) } # Tcl_Obj leak detection support. declare 243 { void TclDbDumpActiveObjects(FILE *outFile) } -# Functions to make things better for itcl -declare 244 { - Tcl_HashTable *TclGetNamespaceChildTable(Tcl_Namespace *nsPtr) -} -declare 245 { - Tcl_HashTable *TclGetNamespaceCommandTable(Tcl_Namespace *nsPtr) -} -declare 246 { - int TclInitRewriteEnsemble(Tcl_Interp *interp, size_t numRemoved, - size_t numInserted, Tcl_Obj *const *objv) -} -declare 247 { - void TclResetRewriteEnsemble(Tcl_Interp *interp, int isRootEnsemble) -} - -declare 248 { - int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan, - Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr) -} - declare 249 { char *TclDoubleDigits(double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr) } -# TIP #285: Script cancellation support. -declare 250 { - void TclSetChildCancelFlags(Tcl_Interp *interp, int flags, int force) -} # Allow extensions for optimization declare 251 { int TclRegisterLiteral(void *envPtr, - const char *bytes, size_t 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, - const int flags) -} -declare 253 { - Tcl_Obj *TclPtrSetVar(Tcl_Interp *interp, Tcl_Var varPtr, - Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - Tcl_Obj *newValuePtr, const int flags) -} -declare 254 { - Tcl_Obj *TclPtrIncrObjVar(Tcl_Interp *interp, Tcl_Var varPtr, - Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - Tcl_Obj *incrPtr, const int flags) -} -declare 255 { - int TclPtrObjMakeUpvar(Tcl_Interp *interp, Tcl_Var otherPtr, - Tcl_Obj *myNamePtr, int myFlags) -} -declare 256 { - int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, - Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags) -} + char *bytes, int length, int flags) +} + declare 257 { void TclStaticPackage(Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) } -# TIP 431: temporary directory creation function -declare 258 { - Tcl_Obj *TclpCreateTemporaryDirectory(Tcl_Obj *dirObj, - Tcl_Obj *basenameObj) -} -# TIP 542 -declare 259 { - void TclAppendUnicodeToObj(Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, size_t length) -} - -declare 260 { - unsigned char *TclGetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - size_t *lengthPtr) -} - +declare 261 { + void TclUnusedStubEntry(void) +} ############################################################################## # Define the platform specific internal Tcl interface. These functions are # only available on the designated platform. @@ -1086,58 +970,52 @@ ################################ # Windows specific functions declare 0 win { - void TclWinConvertError(int errCode) -} -# Removed in 9.0: -#declare 1 win { -# void TclWinConvertWSAError(int errCode) -#} -# Removed in 9.0: -#declare 2 win { -# struct servent *TclWinGetServByName(const char *nm, -# const char *proto) -#} -# Removed in 9.0: -#declare 3 win { -# int TclWinGetSockOpt(SOCKET s, int level, int optname, -# char *optval, int *optlen) -#} + 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 { - void *TclWinGetTclInstance(void) + 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) # } -# Removed in 9.0: -#declare 6 win { -# unsigned short TclWinNToHS(unsigned short ns) -#} -# Removed in 9.0: -#declare 7 win { -# int TclWinSetSockOpt(SOCKET s, int level, int optname, -# const char *optval, int optlen) -#} +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 { - size_t TclpGetPid(Tcl_Pid pid) -} -# Removed in 9.0: -#declare 9 win { -# int TclWinGetPlatformId(void) -#} -# Removed in 9.0: -#declare 10 win { -# Tcl_DirEntry *TclpReaddir(TclDIR *dir) -#} -# Removed in 8.3.1 (for Win32s only): + 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 @@ -1181,53 +1059,53 @@ } declare 19 win { TclFile TclpOpenFile(const char *fname, int mode) } declare 20 win { - void TclWinAddProcess(void *hProcess, size_t id) + void TclWinAddProcess(HANDLE hProcess, DWORD id) } -# Removed in 9.0: -#declare 21 win { -# char *TclpInetNtoa(struct in_addr addr) -#} +# new for 8.4.20+/8.5.12+ +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 23 win { + char *TclpGetTZName(int isdst) +} declare 24 win { char *TclWinNoBackslash(char *path) } # replaced by generic TclGetPlatform #declare 25 win { # TclPlatformType *TclWinGetPlatform(void) #} -# Removed in 9.0: -#declare 26 win { -# void TclWinSetInterfaces(int wide) -#} +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 -# Removed in 9.0: -#declare 28 win { -# void TclWinResetInterfaces(void) -#} +declare 28 win { + void TclWinResetInterfaces(void) +} +declare 29 win { + int TclWinCPUID(unsigned int index, unsigned int *regs) +} ################################ # Unix specific functions # Pipe channel functions @@ -1248,13 +1126,14 @@ 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) -} +# Signature changed in 8.1: +# declare 5 unix { +# TclFile TclpCreateTempFile(char *contents, Tcl_DString *namePtr) +# } declare 6 unix { TclFile TclpMakeFile(Tcl_Channel channel, int direction) } declare 7 unix { TclFile TclpOpenFile(const char *fname, int mode) @@ -1269,26 +1148,24 @@ TclFile TclpCreateTempFile(const char *contents) } # Added in 8.4: -# Removed in 9.0: -#declare 10 unix { -# Tcl_DirEntry *TclpReaddir(TclDIR *dir) -#} -# Removed in 9.0: -#declare 11 unix { -# struct tm *TclpLocaltime_unix(const time_t *clock) -#} -# Removed in 9.0: -#declare 12 unix { -# struct tm *TclpGmtime_unix(const time_t *clock) -#} -# Removed in 9.0: -#declare 13 unix { -# char *TclpInetNtoa(struct in_addr addr) -#} +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, @@ -1296,41 +1173,32 @@ } ################################ # Mac OS X specific functions -declare 15 {unix macosx} { +declare 15 macosx { int TclMacOSXGetFileAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr) } -declare 16 {unix macosx} { +declare 16 macosx { int TclMacOSXSetFileAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr) } -declare 17 {unix macosx} { +declare 17 macosx { int TclMacOSXCopyFileAttributes(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr) } -declare 18 {unix macosx} { +declare 18 macosx { int TclMacOSXMatchType(Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types) } -declare 19 {unix macosx} { +declare 19 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) +declare 29 unix { + int TclWinCPUID(unsigned int index, unsigned int *regs) } # Local Variables: # mode: tcl # End: Index: generic/tclInt.h ================================================================== --- generic/tclInt.h +++ generic/tclInt.h @@ -7,12 +7,10 @@ * Copyright (c) 1993-1997 Lucent Technologies. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2007 Daniel A. Steffen - * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. - * Copyright (c) 2008 by Miguel Sofer. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ @@ -21,53 +19,27 @@ /* * Some numerics configuration options. */ +#undef NO_WIDE_TYPE #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 - -#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. + * important. For example, stdio.h is needed by tcl.h, and the _ANSI_ARGS_ + * declaration in tcl.h is needed by stdlib.h in some configurations. */ #include "tclPort.h" #include #include -#include #ifdef NO_STDLIB_H # include "../compat/stdlib.h" #else # include #endif @@ -74,16 +46,16 @@ #ifdef NO_STRING_H #include "../compat/string.h" #else #include #endif -#if !defined(STDC_HEADERS) && !defined(__STDC__) && !defined(__C99__FUNC__) \ - && !defined(__cplusplus) && !defined(_MSC_VER) && !defined(__ICC) +#if defined(STDC_HEADERS) || defined(__STDC__) || defined(__C99__FUNC__) \ + || defined(__cplusplus) || defined(_MSC_VER) || defined(__ICC) +#include +#else typedef int ptrdiff_t; #endif -#include -#include /* * 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). @@ -107,59 +79,56 @@ # undef WORDS_BIGENDIAN # endif # endif #endif +/* + * 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). + */ + +#ifndef MODULE_SCOPE +# ifdef __cplusplus +# define MODULE_SCOPE extern "C" +# else +# define MODULE_SCOPE extern +# endif +#endif + +/* + * When Tcl_WideInt and long are the same type, there's no value in + * having a tclWideIntType separate from the tclIntType. + */ +#ifdef TCL_WIDE_INT_IS_LONG +#define NO_WIDE_TYPE +#endif + /* * Macros used to cast between pointers and integers (e.g. when storing an int * in ClientData), on 64-bit architectures they avoid gcc warning about "cast * to/from pointer from/to integer of different size". */ #if !defined(INT2PTR) && !defined(PTR2INT) # if defined(HAVE_INTPTR_T) || defined(intptr_t) # define INT2PTR(p) ((void *)(intptr_t)(p)) -# define PTR2INT(p) ((intptr_t)(p)) +# define PTR2INT(p) ((int)(intptr_t)(p)) # else # define INT2PTR(p) ((void *)(p)) -# define PTR2INT(p) ((long)(p)) +# define PTR2INT(p) ((int)(p)) # endif #endif #if !defined(UINT2PTR) && !defined(PTR2UINT) # if defined(HAVE_UINTPTR_T) || defined(uintptr_t) # define UINT2PTR(p) ((void *)(uintptr_t)(p)) -# define PTR2UINT(p) ((uintptr_t)(p)) +# define PTR2UINT(p) ((unsigned int)(uintptr_t)(p)) # else # define UINT2PTR(p) ((void *)(p)) -# define PTR2UINT(p) ((unsigned long)(p)) +# define PTR2UINT(p) ((unsigned int)(p)) # endif #endif -#if defined(_WIN32) && defined(_MSC_VER) -# define vsnprintf _vsnprintf -#endif - -#if !defined(TCL_THREADS) -# define TCL_THREADS 1 -#endif -#if !TCL_THREADS -# undef TCL_DECLARE_MUTEX -# define TCL_DECLARE_MUTEX(name) -# undef Tcl_MutexLock -# define Tcl_MutexLock(mutexPtr) -# undef Tcl_MutexUnlock -# define Tcl_MutexUnlock(mutexPtr) -# undef Tcl_MutexFinalize -# define Tcl_MutexFinalize(mutexPtr) -# undef Tcl_ConditionNotify -# define Tcl_ConditionNotify(condPtr) -# undef Tcl_ConditionWait -# define Tcl_ConditionWait(condPtr, mutexPtr, timePtr) -# undef Tcl_ConditionFinalize -# define Tcl_ConditionFinalize(condPtr) -#endif - /* * The following procedures allow namespaces to be customized to support * special name resolution rules for commands/variables. */ @@ -180,17 +149,17 @@ Tcl_ResolveRuntimeVarProc *fetchProc; Tcl_ResolveVarDeleteProc *deleteProc; } Tcl_ResolvedVarInfo; typedef int (Tcl_ResolveCompiledVarProc)(Tcl_Interp *interp, - const char *name, int length, Tcl_Namespace *context, + CONST84 char *name, int length, Tcl_Namespace *context, Tcl_ResolvedVarInfo **rPtr); -typedef int (Tcl_ResolveVarProc)(Tcl_Interp *interp, const char *name, +typedef int (Tcl_ResolveVarProc)(Tcl_Interp *interp, CONST84 char *name, Tcl_Namespace *context, int flags, Tcl_Var *rPtr); -typedef int (Tcl_ResolveCmdProc)(Tcl_Interp *interp, const char *name, +typedef int (Tcl_ResolveCmdProc)(Tcl_Interp *interp, CONST84 char *name, Tcl_Namespace *context, int flags, Tcl_Command *rPtr); typedef struct Tcl_ResolverInfo { Tcl_ResolveCmdProc *cmdResProc; /* Procedure handling command name @@ -202,22 +171,10 @@ Tcl_ResolveCompiledVarProc *compiledVarResProc; /* Procedure handling variable name resolution * at compile time. */ } Tcl_ResolverInfo; -/* - * 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. *---------------------------------------------------------------- */ @@ -242,18 +199,10 @@ */ #define TclVarHashFindVar(tablePtr, key) \ TclVarHashCreateVar((tablePtr), (key), NULL) -/* - * Define this to reduce the amount of space that the average namespace - * consumes by only allocating the table of child namespaces when necessary. - * Defining it breaks compatibility for Tcl extensions (e.g., itcl) which - * reach directly into the Namespace structure. - */ - -#undef BREAK_NAMESPACE_COMPAT /* * The structure below defines a namespace. * Note: the first five fields must match exactly the fields in a * Tcl_Namespace structure (see tcl.h). If you change one, be sure to change @@ -265,37 +214,30 @@ * This contains no ::'s. The name of the * global namespace is "" although "::" is an * synonym. */ char *fullName; /* The namespace's fully qualified name. This * starts with ::. */ - void *clientData; /* An arbitrary value associated with this + ClientData clientData; /* An arbitrary value associated with this * namespace. */ Tcl_NamespaceDeleteProc *deleteProc; /* Procedure invoked when deleting the * namespace to, e.g., free clientData. */ struct Namespace *parentPtr;/* Points to the namespace that contains this * one. NULL if this is the global * namespace. */ -#ifndef BREAK_NAMESPACE_COMPAT Tcl_HashTable childTable; /* Contains any child namespaces. Indexed by * 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 - size_t nsId; /* Unique id for the namespace. */ - Tcl_Interp *interp; /* The interpreter containing this + 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. */ - size_t activationCount; /* Number of "activations" or active call + 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. */ - size_t refCount; /* Count of references by namespaceName + 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 *). @@ -312,20 +254,20 @@ * 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. */ - size_t numExportPatterns; /* Number of export patterns currently + int numExportPatterns; /* Number of export patterns currently * registered using "namespace export". */ - size_t maxExportPatterns; /* Number of export patterns for which space + int maxExportPatterns; /* Mumber of export patterns for which space * is currently allocated. */ - size_t cmdRefEpoch; /* Incremented if a newly added command + 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. */ - size_t resolverEpoch; /* Incremented whenever (a) the name + 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 @@ -348,11 +290,11 @@ * usual variable resolution mechanism in Tcl. * This procedure is invoked within * LookupCompiledLocal to resolve variable * references within the namespace at compile * time. */ - size_t exportLookupEpoch; /* Incremented whenever a command is added to + 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 @@ -359,23 +301,17 @@ * 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. */ - size_t commandPathLength; /* The length of the explicit path. */ + 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; - /* Just like the deleteProc field (and called - * with the same clientData) but called at the - * start of the deletion process, so there is - * a chance for code to do stuff inside the - * namespace before deletion completes. */ } Namespace; /* * An entry on a namespace's command resolution path. */ @@ -410,21 +346,17 @@ * namespace resolution code to recognize that the namespace is * "deleted". When the last namespaceName object in any byte code * unit that refers to the namespace has been freed (i.e., when * the namespace's refCount is 0), the namespace's storage will * be freed. - * NS_KILLED - 1 means that TclTeardownNamespace has already been called on - * this namespace and it should not be called again [Bug 1355942] - * NS_SUPPRESS_COMPILATION - - * Marks the commands in this namespace for not being compiled, - * forcing them to be looked up every time. + * NS_KILLED 1 means that TclTeardownNamespace has already been called on + * this namespace and it should not be called again [Bug 1355942] */ #define NS_DYING 0x01 #define NS_DEAD 0x02 #define NS_KILLED 0x04 -#define NS_SUPPRESS_COMPILATION 0x08 /* * Flags passed to TclGetNamespaceForQualName: * * TCL_GLOBAL_ONLY - (see tcl.h) Look only in the global ns. @@ -435,95 +367,35 @@ #define TCL_CREATE_NS_IF_UNKNOWN 0x800 #define TCL_FIND_ONLY_NS 0x1000 /* - * The client data for an ensemble command. This consists of the table of - * commands that are actually exported by the namespace, and an epoch counter - * that, combined with the exportLookupEpoch field of the namespace structure, - * defines whether the table contains valid data or will need to be recomputed - * next time the ensemble command is called. - */ - -typedef struct EnsembleConfig { - Namespace *nsPtr; /* The namespace backing this ensemble up. */ - Tcl_Command token; /* The token for the command that provides - * ensemble support for the namespace, or NULL - * if the command has been deleted (or never - * existed; the global namespace never has an - * ensemble command.) */ - size_t 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, - * which are its keys so this also provides - * the storage management for those subcommand - * names. The contents of the entry values are - * object version the prefix lists to use when - * substituting for the command/subcommand to - * build the ensemble implementation command. - * Has to be stored here as well as in - * subcommandDict because that field is NULL - * when we are deriving the ensemble from the - * namespace exports list. FUTURE WORK: use - * object hash table here. */ - struct EnsembleConfig *next;/* The next ensemble in the linked list of - * ensembles associated with a namespace. If - * this field points to this ensemble, the - * structure has already been unlinked from - * all lists, and cannot be found by scanning - * the list from the namespace's ensemble - * field. */ - int flags; /* ORed combo of TCL_ENSEMBLE_PREFIX, - * ENSEMBLE_DEAD and ENSEMBLE_COMPILE. */ - - /* OBJECT FIELDS FOR ENSEMBLE CONFIGURATION */ - - Tcl_Obj *subcommandDict; /* Dictionary providing mapping from - * subcommands to their implementing command - * prefixes, or NULL if we are to build the - * map automatically from the namespace - * exports. */ - Tcl_Obj *subcmdList; /* List of commands that this ensemble - * actually provides, and whose implementation - * will be built using the subcommandDict (if - * present and defined) and by simple mapping - * to the namespace otherwise. If NULL, - * indicates that we are using the (dynamic) - * list of currently exported commands. */ - Tcl_Obj *unknownHandler; /* Script prefix used to handle the case when - * no match is found (according to the rule - * defined by flag bit TCL_ENSEMBLE_PREFIX) or - * NULL to use the default error-generating - * behaviour. The script execution gets all - * the arguments to the ensemble command - * (including objv[0]) and will have the - * results passed directly back to the caller - * (including the error code) unless the code - * is TCL_CONTINUE in which case the - * subcommand will be reparsed by the ensemble - * core, presumably because the ensemble - * itself has been updated. */ - Tcl_Obj *parameterList; /* List of ensemble parameter names. */ - int numParameters; /* Cached number of parameters. This is either - * 0 (if the parameterList field is NULL) or - * the length of the list in the parameterList - * field. */ -} EnsembleConfig; - -/* - * Various bits for the EnsembleConfig.flags field. - */ - -#define ENSEMBLE_DEAD 0x1 /* Flag value to say that the ensemble is dead - * and on its way out. */ -#define ENSEMBLE_COMPILE 0x4 /* Flag to enable bytecode compilation of an + * The data cached in an ensemble subcommand's Tcl_Obj rep (reference in + * twoPtrValue.ptr1 field). This structure is not shared between Tcl_Objs + * referring to the same subcommand, even where one is a duplicate of another. + */ + +typedef struct { + Namespace *nsPtr; /* The namespace backing the ensemble which + * this is a subcommand of. */ + int epoch; /* Used to confirm when the data in this + * really structure matches up with the * ensemble. */ + Tcl_Command token; /* Reference to the comamnd for which this + * structure is a cache of the resolution. */ + char *fullSubcmdName; /* The full (local) name of the subcommand, + * allocated with ckalloc(). */ + Tcl_Obj *realPrefixObj; /* Object containing the prefix words of the + * command that implements this ensemble + * subcommand. */ +} EnsembleCmdRep; + +/* + * Flag to enable bytecode compilation of an ensemble. + */ + +#define ENSEMBLE_COMPILE 0x4 /* *---------------------------------------------------------------- * Data structures related to variables. These are used primarily in tclVar.c *---------------------------------------------------------------- @@ -536,11 +408,11 @@ */ typedef struct VarTrace { Tcl_VarTraceProc *traceProc;/* Procedure to call when operations given by * flags are performed on variable. */ - void *clientData; /* Argument to pass to proc. */ + ClientData clientData; /* Argument to pass to proc. */ int flags; /* What events the trace procedure is * interested in: OR-ed combination of * TCL_TRACE_READS, TCL_TRACE_WRITES, * TCL_TRACE_UNSETS and TCL_TRACE_ARRAY. */ struct VarTrace *nextPtr; /* Next in list of traces associated with a @@ -555,18 +427,18 @@ typedef struct CommandTrace { Tcl_CommandTraceProc *traceProc; /* Procedure to call when operations given by * flags are performed on command. */ - void *clientData; /* Argument to pass to proc. */ + ClientData 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. */ - size_t refCount; /* Used to ensure this structure is not + 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; @@ -625,21 +497,21 @@ 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 - * Tcl_Alloc-ed data. */ + * 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; - size_t refCount; /* Counts number of active uses of this + 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 @@ -881,13 +753,10 @@ && (varPtr)->value.objPtr) #define TclIsVarDirectWritable(varPtr) \ !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_WRITE|VAR_DEAD_HASH)) -#define TclIsVarDirectUnsettable(varPtr) \ - !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_TRACED_UNSET|VAR_DEAD_HASH)) - #define TclIsVarDirectModifyable(varPtr) \ ( !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_READ|VAR_TRACED_WRITE)) \ && (varPtr)->value.objPtr) #define TclIsVarDirectReadable2(varPtr, arrayPtr) \ @@ -907,16 +776,10 @@ * Data structures related to procedures. These are used primarily in * tclProc.c, tclCompile.c, and tclExecute.c. *---------------------------------------------------------------- */ -#if defined(__GNUC__) && (__GNUC__ > 2) -# define TCLFLEXARRAY 0 -#else -# define TCLFLEXARRAY 1 -#endif - /* * Forward declaration to prevent an error when the forward reference to * Command is encountered in the Proc and ImportRef types declared below. */ @@ -938,12 +801,13 @@ typedef struct CompiledLocal { struct CompiledLocal *nextPtr; /* Next compiler-recognized local variable for * this procedure, or NULL if this is the last * local. */ - size_t nameLength; /* The number of bytes in local variable's name. - * Among others used to speed up var lookups. */ + int nameLength; /* The number of characters in local + * variable's name. Used to speed up variable + * 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, @@ -953,14 +817,14 @@ * or, if an argument, no default value. */ Tcl_ResolvedVarInfo *resolveInfo; /* Customized variable resolution info * supplied by the Tcl_ResolveCompiledVarProc * associated with a namespace. Each variable - * is marked by a unique tag during + * is marked by a unique ClientData tag during * compilation, and that same tag is used to * find the variable at runtime. */ - char name[TCLFLEXARRAY]; /* Name of the local variable starts here. If + char name[4]; /* Name of the local variable starts here. If * the name is NULL, this will just be '\0'. * The actual size of this field will be large * enough to hold the name. MUST BE THE LAST * FIELD IN THE STRUCTURE! */ } CompiledLocal; @@ -972,11 +836,11 @@ */ typedef struct Proc { struct Interp *iPtr; /* Interpreter for which this command is * defined. */ - size_t refCount; /* Reference count: 1 if still present in + 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 @@ -1003,11 +867,11 @@ /* * The type of functions called to process errors found during the execution * of a procedure (or lambda term or ...). */ -typedef void (ProcErrorProc)(Tcl_Interp *interp, Tcl_Obj *procNameObj); +typedef void (*ProcErrorProc)(Tcl_Interp *interp, Tcl_Obj *procNameObj); /* * The structure below defines a command trace. This is used to allow Tcl * clients to find out whenever a command is about to be executed. */ @@ -1014,11 +878,11 @@ typedef struct Trace { int level; /* Only trace commands at nesting level less * than or equal to this. */ Tcl_CmdObjTraceProc *proc; /* Procedure to call to trace command. */ - void *clientData; /* Arbitrary value to pass to proc. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ struct Trace *nextPtr; /* Next in list of traces for this interp. */ int flags; /* Flags governing the trace - see * Tcl_CreateObjTrace for details. */ Tcl_CmdObjTraceDeleteProc *delProc; /* Procedure to call when trace is deleted. */ @@ -1066,11 +930,11 @@ * piece of data. */ typedef struct AssocData { Tcl_InterpDeleteProc *proc; /* Proc to call when deleting. */ - void *clientData; /* Value to pass to proc. */ + ClientData clientData; /* Value to pass to proc. */ } AssocData; /* * The structure below defines a call frame. A call frame defines a naming * context for a procedure call: its local naming scope (for local variables) @@ -1089,11 +953,11 @@ * 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 { - size_t refCount; + int refCount; int numVars; Tcl_Obj *varName0; } LocalCache; #define localName(framePtr, i) \ @@ -1144,38 +1008,24 @@ * compiler including arguments. */ Var *compiledLocals; /* Points to the array of local variables * recognized by the compiler. The compiler * emits code that refers to these variables * using an index into this array. */ - void *clientData; /* Pointer to some context that is used by + ClientData clientData; /* Pointer to some context that is used by * object systems. The meaning of the contents * of this field is defined by the code that * sets it, and it should only ever be set by * the code that is pushing the frame. In that * case, the code that sets it should also * have some means of discovering what the * meaning of the value is, which we do not * specify. */ LocalCache *localCachePtr; - Tcl_Obj *tailcallPtr; - /* NULL if no tailcall is scheduled */ } CallFrame; #define FRAME_IS_PROC 0x1 #define FRAME_IS_LAMBDA 0x2 -#define FRAME_IS_METHOD 0x4 /* The frame is a method body, and the frame's - * clientData field contains a CallContext - * reference. Part of TIP#257. */ -#define FRAME_IS_OO_DEFINE 0x8 /* The frame is part of the inside workings of - * the [oo::define] command; the clientData - * field contains an Object reference that has - * been confirmed to refer to a class. Part of - * TIP#257. */ -#define FRAME_IS_PRIVATE_DEFINE 0x10 - /* Marks this frame as being used for private - * declarations with [oo::define]. Usually - * OR'd with FRAME_IS_OO_DEFINE. TIP#500. */ /* * TIP #280 * The structure below defines a command frame. A command frame provides * location information for all commands executing a tcl script (source, eval, @@ -1209,31 +1059,33 @@ /* * Data needed for Eval vs TEBC * * EXECUTION CONTEXTS and usage of CmdFrame * - * Field TEBC EvalEx - * ======= ==== ====== - * level yes yes - * type BC/PREBC SRC/EVAL - * line0 yes yes - * framePtr yes yes - * ======= ==== ====== - * - * ======= ==== ========= union data - * line1 - yes - * line3 - yes - * path - yes - * ------- ---- ------ - * codePtr yes - - * pc yes - - * ======= ==== ====== - * - * ======= ==== ========= union cmd - * str.cmd yes yes - * str.len yes yes - * ------- ---- ------ + * Field TEBC EvalEx EvalObjEx + * ======= ==== ====== ========= + * level yes yes yes + * type BC/PREBC SRC/EVAL EVAL_LIST + * line0 yes yes yes + * framePtr yes yes yes + * ======= ==== ====== ========= + * + * ======= ==== ====== ========= union data + * line1 - yes - + * line3 - yes - + * path - yes - + * ------- ---- ------ --------- + * codePtr yes - - + * pc yes - - + * ======= ==== ====== ========= + * + * ======= ==== ====== ========= | union cmd + * listPtr - - yes | + * ------- ---- ------ --------- | + * cmd yes yes - | + * cmdlen yes yes - | + * ------- ---- ------ --------- | */ union { struct { Tcl_Obj *path; /* Path of the sourced file the command is @@ -1242,37 +1094,33 @@ 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... */ - size_t 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. */ + union { + struct { + const char *cmd; /* The executed command, if possible... */ + int len; /* ... and its length. */ + } str; + Tcl_Obj *listPtr; /* Tcl_EvalObjEx, cmd list. */ + } cmd; } CmdFrame; typedef struct CFWord { CmdFrame *framePtr; /* CmdFrame to access. */ int word; /* Index of the word in the command. */ - size_t refCount; /* Number of times the word is on the + int refCount; /* Number of times the word is on the * stack. */ } CFWord; typedef struct CFWordBC { CmdFrame *framePtr; /* CmdFrame to access. */ - size_t pc; /* Instruction pointer of a command in + 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 */ } CFWordBC; /* * Structure to record the locations of invisible continuation lines in * literal scripts, as character offset from the beginning of the script. Both @@ -1294,11 +1142,11 @@ #define CLL_END (-1) typedef struct ContLineLoc { int num; /* Number of entries in loc, not counting the * final -1 marker entry. */ - int loc[TCLFLEXARRAY];/* Table of locations, as character offsets. + int loc[1]; /* Table of locations, as character offsets. * The table is allocated as part of the * structure, extending behind the nominal end * of the structure. An entry containing the * value -1 is put after the last location, as * end-marker/sentinel. */ @@ -1308,10 +1156,12 @@ * The following macros define the allowed values for the type field of the * CmdFrame structure above. Some of the values occur only in the extended * location data referenced via the 'baseLocPtr'. * * TCL_LOCATION_EVAL : Frame is for a script evaluated by EvalEx. + * TCL_LOCATION_EVAL_LIST : Frame is for a script evaluated by the list + * optimization path of EvalObjEx. * TCL_LOCATION_BC : Frame is for bytecode. * TCL_LOCATION_PREBC : Frame is for precompiled bytecode. * TCL_LOCATION_SOURCE : Frame is for a script evaluated by EvalEx, from a * sourced file. * TCL_LOCATION_PROC : Frame is for bytecode of a procedure. @@ -1319,10 +1169,12 @@ * A TCL_LOCATION_BC type in a frame can be overridden by _SOURCE and _PROC * types, per the context of the byte code in execution. */ #define TCL_LOCATION_EVAL (0) /* Location in a dynamic eval script. */ +#define TCL_LOCATION_EVAL_LIST (1) /* Location in a dynamic eval script, + * list-path. */ #define TCL_LOCATION_BC (2) /* Location in byte code. */ #define TCL_LOCATION_PREBC (3) /* Location in precompiled byte code, no * location. */ #define TCL_LOCATION_SOURCE (4) /* Location in a file. */ #define TCL_LOCATION_PROC (5) /* Location in a dynamic proc. */ @@ -1332,21 +1184,21 @@ * Structure passed to describe procedure-like "procedures" that are not * procedures (e.g. a lambda) so that their details can be reported correctly * by [info frame]. Contains a sub-structure for each extra field. */ -typedef Tcl_Obj * (GetFrameInfoValueProc)(void *clientData); +typedef Tcl_Obj *(*GetFrameInfoValueProc)(ClientData clientData); typedef struct { const char *name; /* Name of this field. */ - GetFrameInfoValueProc *proc; /* Function to generate a Tcl_Obj* from the + 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 + ClientData clientData; /* Context for above function, or Tcl_Obj* if * proc field is NULL. */ } ExtraFrameInfoField; typedef struct { - size_t length; /* Length of array. */ + int length; /* Length of array. */ ExtraFrameInfoField fields[2]; /* Really as long as necessary, but this is * long enough for nearly anything. */ } ExtraFrameInfo; @@ -1383,11 +1235,11 @@ /* * This is a convenience macro used to initialize a thread local storage ptr. */ #define TCL_TSD_INIT(keyPtr) \ - (ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData)) + (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. @@ -1431,11 +1283,11 @@ * The type of procedure called from the compilation hook point in * SetByteCodeFromAny. */ typedef int (CompileHookProc)(Tcl_Interp *interp, - struct CompileEnv *compEnvPtr, void *clientData); + struct CompileEnv *compEnvPtr, ClientData clientData); /* * The data structure for a (linked list of) execution stacks. */ @@ -1443,11 +1295,11 @@ struct ExecStack *prevPtr; struct ExecStack *nextPtr; Tcl_Obj **markerPtr; Tcl_Obj **endPtr; Tcl_Obj **tosPtr; - Tcl_Obj *stackWords[TCLFLEXARRAY]; + Tcl_Obj *stackWords[1]; } ExecStack; /* * The data structure defining the execution environment for ByteCode's. * There is one ExecEnv structure per Tcl interpreter. It holds the evaluation @@ -1454,52 +1306,16 @@ * stack that holds command operands and results. The stack grows towards * increasing addresses. The member stackPtr points to the stackItems of the * currently active execution stack. */ -typedef struct CorContext { - struct CallFrame *framePtr; - struct CallFrame *varFramePtr; - struct CmdFrame *cmdFramePtr; /* See Interp.cmdFramePtr */ - Tcl_HashTable *lineLABCPtr; /* See Interp.lineLABCPtr */ -} CorContext; - -typedef struct CoroutineData { - struct Command *cmdPtr; /* The command handle for the coroutine. */ - struct ExecEnv *eePtr; /* The special execution environment (stacks, - * etc.) for the coroutine. */ - struct ExecEnv *callerEEPtr;/* The execution environment for the caller of - * the coroutine, which might be the - * interpreter global environment or another - * coroutine. */ - CorContext caller; - CorContext running; - Tcl_HashTable *lineLABCPtr; /* See Interp.lineLABCPtr */ - void *stackLevel; - int auxNumLevels; /* While the coroutine is running the - * numLevels of the create/resume command is - * stored here; for suspended coroutines it - * holds the nesting numLevels at yield. */ - int nargs; /* Number of args required for resuming this - * coroutine; -2 means "0 or 1" (default), -1 - * means "any" */ -} CoroutineData; - typedef struct ExecEnv { ExecStack *execStackPtr; /* Points to the first item in the evaluation * stack on the heap. */ Tcl_Obj *constants[2]; /* Pointers to constant "0" and "1" objs. */ - struct Tcl_Interp *interp; - struct NRE_callback *callbackPtr; - /* Top callback in NRE's stack. */ - struct CoroutineData *corPtr; - int rewind; } ExecEnv; -#define COR_IS_SUSPENDED(corPtr) \ - ((corPtr)->stackLevel == NULL) - /* * The definitions for the LiteralTable and LiteralEntry structures. Each * interpreter contains a LiteralTable. It is used to reduce the storage * needed for all the Tcl objects that hold the literals of scripts compiled * by the interpreter. A literal's object is shared by all the ByteCodes that @@ -1518,15 +1334,15 @@ 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. */ - size_t refCount; /* If in an interpreter's global literal + 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, TCL_INDEX_NONE. */ + * 0. If in a local literal table, -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; @@ -1536,17 +1352,17 @@ * 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. */ - size_t numBuckets; /* Total number of buckets allocated at + int numBuckets; /* Total number of buckets allocated at * **buckets. */ - size_t numEntries; /* Total number of entries present in + int numEntries; /* Total number of entries present in * table. */ - size_t rebuildSize; /* Enlarge table when numEntries gets to be + int rebuildSize; /* Enlarge table when numEntries gets to be * this large. */ - size_t mask; /* Mask value used in hashing function. */ + 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 @@ -1553,37 +1369,37 @@ * interpreter's operation in that interpreter. */ #ifdef TCL_COMPILE_STATS typedef struct ByteCodeStats { - size_t numExecutions; /* Number of ByteCodes executed. */ - size_t numCompilations; /* Number of ByteCodes created. */ - size_t numByteCodesFreed; /* Number of ByteCodes destroyed. */ - size_t instructionCount[256]; /* Number of times each instruction was + long numExecutions; /* Number of ByteCodes executed. */ + long numCompilations; /* Number of ByteCodes created. */ + long numByteCodesFreed; /* Number of ByteCodes destroyed. */ + long instructionCount[256]; /* Number of times each instruction was * executed. */ double totalSrcBytes; /* Total source bytes ever compiled. */ double totalByteCodeBytes; /* Total bytes for all ByteCodes. */ double currentSrcBytes; /* Src bytes for all current ByteCodes. */ double currentByteCodeBytes;/* Code bytes in all current ByteCodes. */ - size_t srcCount[32]; /* Source size distribution: # of srcs of + long srcCount[32]; /* Source size distribution: # of srcs of * size [2**(n-1)..2**n), n in [0..32). */ - size_t byteCodeCount[32]; /* ByteCode size distribution. */ - size_t lifetimeCount[32]; /* ByteCode lifetime distribution (ms). */ + long byteCodeCount[32]; /* ByteCode size distribution. */ + long lifetimeCount[32]; /* ByteCode lifetime distribution (ms). */ double currentInstBytes; /* Instruction bytes-current ByteCodes. */ double currentLitBytes; /* Current literal bytes. */ double currentExceptBytes; /* Current exception table bytes. */ double currentAuxBytes; /* Current auxiliary information bytes. */ double currentCmdMapBytes; /* Current src<->code map bytes. */ - size_t numLiteralsCreated; /* Total literal objects ever compiled. */ + long numLiteralsCreated; /* Total literal objects ever compiled. */ double totalLitStringBytes; /* Total string bytes in all literals. */ double currentLitStringBytes; /* String bytes in current literals. */ - size_t literalCount[32]; /* Distribution of literal string sizes. */ + long literalCount[32]; /* Distribution of literal string sizes. */ } ByteCodeStats; #endif /* TCL_COMPILE_STATS */ /* * Structure used in implementation of those core ensembles which are @@ -1593,14 +1409,10 @@ typedef struct { const char *name; /* The name of the subcommand. */ Tcl_ObjCmdProc *proc; /* The implementation of the subcommand. */ CompileProc *compileProc; /* The compiler for the subcommand. */ - Tcl_ObjCmdProc *nreProc; /* NRE implementation of this command. */ - void *clientData; /* Any clientData to give the command. */ - int unsafe; /* Whether this command is to be hidden by - * default in a safe interpreter. */ } EnsembleImplMap; /* *---------------------------------------------------------------- * Data structures related to commands. @@ -1660,28 +1472,28 @@ * already (this can happen if deleteProc * causes the command to be deleted or * recreated). */ Namespace *nsPtr; /* Points to the namespace containing this * command. */ - size_t refCount; /* 1 if in command hashtable plus 1 for each + 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. */ - size_t cmdEpoch; /* Incremented to invalidate any references + 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. */ + ClientData objClientData; /* Arbitrary value passed to object proc. */ Tcl_CmdProc *proc; /* String-based command procedure. */ - void *clientData; /* Arbitrary value passed to string proc. */ + ClientData clientData; /* Arbitrary value passed to string proc. */ Tcl_CmdDeleteProc *deleteProc; /* Procedure invoked when deleting command to, * e.g., free all client data. */ - void *deleteData; /* Arbitrary value passed to deleteProc. */ + ClientData deleteData; /* Arbitrary value passed to deleteProc. */ int flags; /* Miscellaneous bits of information about * command. See below for definitions. */ ImportRef *importRefPtr; /* List of each imported Command created in * another namespace when this command is * imported. These imported commands redirect @@ -1689,45 +1501,37 @@ * is used to remove all those imported * commands when deleting this "real" * command. */ CommandTrace *tracePtr; /* First in list of all traces set for this * command. */ - Tcl_ObjCmdProc *nreProc; /* NRE implementation of this command. */ } Command; /* * Flag bits for commands. * - * CMD_DYING - If 1 the command is in the process of + * CMD_IS_DELETED - Means that the command is in the process of * being deleted (its deleteProc is currently * executing). Other attempts to delete the * command should be ignored. - * CMD_TRACE_ACTIVE - If 1 the trace processing is currently + * CMD_TRACE_ACTIVE - 1 means that trace processing is currently * underway for a rename/delete change. See the * two flags below for which is currently being * processed. - * CMD_HAS_EXEC_TRACES - If 1 means that this command has at least one + * CMD_HAS_EXEC_TRACES - 1 means that this command has at least one * execution trace (as opposed to simple * delete/rename traces) in its tracePtr list. - * CMD_COMPILES_EXPANDED - If 1 this command has a compiler that - * can handle expansion (provided it is not the - * first word). * TCL_TRACE_RENAME - A rename trace is in progress. Further * recursive renames will not be traced. * TCL_TRACE_DELETE - A delete trace is in progress. Further * recursive deletes will not be traced. * (these last two flags are defined in tcl.h) */ -#define CMD_DYING 0x01 -#define CMD_TRACE_ACTIVE 0x02 -#define CMD_HAS_EXEC_TRACES 0x04 -#define CMD_COMPILES_EXPANDED 0x08 +#define CMD_IS_DELETED 0x1 +#define CMD_TRACE_ACTIVE 0x2 +#define CMD_HAS_EXEC_TRACES 0x4 #define CMD_REDEF_IN_PROGRESS 0x10 -#define CMD_VIA_RESOLVER 0x20 -#define CMD_DEAD 0x40 - /* *---------------------------------------------------------------- * Data structures related to name resolution procedures. *---------------------------------------------------------------- @@ -1771,28 +1575,10 @@ enum PkgPreferOptions { PKG_PREFER_LATEST, PKG_PREFER_STABLE }; -/* - *---------------------------------------------------------------- - * This structure shadows the first few fields of the memory cache for the - * allocator defined in tclThreadAlloc.c; it has to be kept in sync with the - * definition there. - * Some macros require knowledge of some fields in the struct in order to - * avoid hitting the TSD unnecessarily. In order to facilitate this, a pointer - * to the relevant fields is kept in the allocCache field in struct Interp. - *---------------------------------------------------------------- - */ - -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. */ - size_t 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 @@ -1800,48 +1586,59 @@ *---------------------------------------------------------------- */ typedef struct Interp { /* - * The first two fields were named "result" and "freeProc" in earlier - * versions of Tcl. They are no longer used within Tcl, and are no - * longer available to be accessed by extensions. However, they cannot - * be removed. Why? There is a deployed base of stub-enabled extensions - * that query the value of iPtr->stubTable. For them to continue to work, - * the location of the field "stubTable" within the Interp struct cannot - * change. The most robust way to assure that is to leave all fields up to - * that one undisturbed. + * 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. */ - const char *legacyResult; - void (*legacyFreeProc) (void); + 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. In - * ancient pre-8.1 versions of Tcl this was a - * pointer to the objResultPtr or a pointer to a - * buckets array in a hash table. Deployed stubs - * enabled extensions check for a NULL pointer value - * and for a TCL_STUBS_MAGIC value to verify they - * are not [load]ing into one of those pre-stubs - * interps. - */ + 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 parent/child interps on a + ClientData interpInfo; /* Information used by tclInterp.c to keep + * track of master/slave interps on a * per-interp basis. */ - void (*optimizer)(void *envPtr); + Tcl_HashTable unused2; /* No longer used (was mathFuncTable) */ + /* * Information related to procedures and variables. See tclProc.c and * tclVar.c for usage. */ @@ -1866,10 +1663,23 @@ 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. + */ + + 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. */ + /* * Information about packages. Used only in tclPkg.c. */ Tcl_HashTable packageTable; /* Describes all of the packages loaded in or @@ -1882,22 +1692,23 @@ * NULL. */ /* * Miscellaneous information: */ - size_t cmdCount; /* Total number of times a command procedure + 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. */ - size_t compileEpoch; /* Holds the current "compilation epoch" for + 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 @@ -1925,10 +1736,12 @@ * 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. */ + char resultSpace[TCL_RESULT_SIZE+1]; + /* Static space holding small results. */ 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. */ @@ -1967,11 +1780,11 @@ * check the limits. */ int exceeded; /* Which limits have been exceeded, described * as flag values the same as the 'active' * field. */ - size_t cmdCount; /* Limit for how many commands to execute in + 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 @@ -2003,13 +1816,13 @@ 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. */ - size_t numRemovedObjs; /* How many arguments have been stripped off + int numRemovedObjs; /* How many arguments have been stripped off * because of ensemble processing. */ - size_t numInsertedObjs; /* How many of the current arguments were + int numInsertedObjs; /* How many of the current arguments were * inserted by an ensemble. */ } ensembleRewrite; /* * TIP #219: Global info for the I/O system. @@ -2089,65 +1902,33 @@ * (a) do not change during the thread's lifetime * (b) require access to TSD to determine at runtime * (c) are accessed very often (e.g., at each command call) * * Note that these are the same for all interps in the same thread. They - * just have to be initialised for the thread's parent interp, children + * just have to be initialised for the thread's master interp, slaves * inherit the value. * * They are used by the macros defined below. */ - AllocCache *allocCache; + void *allocCache; void *pendingObjDataPtr; /* Pointer to the Cache and PendingObjData * structs for this interp's thread; see * tclObj.c and tclThreadAlloc.c */ int *asyncReadyPtr; /* Pointer to the asyncReady indicator for * this interp's thread; see tclAsync.c */ - /* - * The pointer to the object system root ekeko. c.f. TIP #257. - */ - void *objectFoundation; /* Pointer to the Foundation structure of the - * object system, which contains things like - * references to key namespaces. See - * tclOOInt.h and tclOO.c for real definition - * and setup. */ - - struct NRE_callback *deferredCallbacks; - /* Callbacks that are set previous to a call - * to some Eval function but that actually - * belong to the command that is about to be - * called - i.e., they should be run *before* - * any tailcall is invoked. */ - - /* - * TIP #285, Script cancellation support. - */ - - Tcl_AsyncHandler asyncCancel; - /* Async handler token for Tcl_CancelEval. */ - Tcl_Obj *asyncCancelMsg; /* Error message set by async cancel handler - * for the propagation of arbitrary Tcl - * errors. This information, if present - * (asyncCancelMsg not NULL), takes precedence - * over the default error messages returned by - * a script cancellation operation. */ - - /* - * TIP #348 IMPLEMENTATION - Substituted error stack - */ - Tcl_Obj *errorStack; /* [info errorstack] value (as a Tcl_Obj). */ - Tcl_Obj *upLiteral; /* "UP" literal for [info errorstack] */ - Tcl_Obj *callLiteral; /* "CALL" literal for [info errorstack] */ - Tcl_Obj *innerLiteral; /* "INNER" literal for [info errorstack] */ - Tcl_Obj *innerContext; /* cached list for fast reallocation */ - int resetErrorStack; /* controls cleaning up of ::errorStack */ + int *stackBound; /* Pointer to the limit stack address + * allowable for invoking a new command + * without "risking" a C-stack overflow; see + * TclpCheckStackSpace in the platform's + * directory. */ + #ifdef TCL_COMPILE_STATS /* * Statistical information about the bytecode compiler and interpreter's - * operation. This should be the last field of Interp. + * operation. */ ByteCodeStats stats; /* Holds compilation and execution statistics * for this interpreter. */ #endif /* TCL_COMPILE_STATS */ @@ -2158,26 +1939,10 @@ */ #define TclAsyncReady(iPtr) \ *((iPtr)->asyncReadyPtr) -/* - * Macros for script cancellation support (TIP #285). - */ - -#define TclCanceled(iPtr) \ - (((iPtr)->flags & CANCELED) || ((iPtr)->flags & TCL_CANCEL_UNWIND)) - -#define TclSetCancelFlags(iPtr, cancelFlags) \ - (iPtr)->flags |= CANCELED; \ - if ((cancelFlags) & TCL_CANCEL_UNWIND) { \ - (iPtr)->flags |= TCL_CANCEL_UNWIND; \ - } - -#define TclUnsetCancelFlags(iPtr) \ - (iPtr)->flags &= (~(CANCELED | TCL_CANCEL_UNWIND)) - /* * Macros for splicing into and out of doubly linked lists. They assume * existence of struct items 'prevPtr' and 'nextPtr'. * * a = element to add or remove. @@ -2211,12 +1976,11 @@ * 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_CTX 0x08 #define TCL_EVAL_DISCARD_RESULT 0x40 /* * Flag bits for Interp structures: * @@ -2235,11 +1999,11 @@ * RAND_SEED_INITIALIZED: Non-zero means that the randSeed value of the interp * has not be initialized. This is set 1 when we first * use the rand() or srand() functions. * SAFE_INTERP: Non zero means that the current interp is a safe * interp (i.e. it has only the safe commands installed, - * less privilege than a regular interp). + * less priviledge than a regular interp). * INTERP_DEBUG_FRAME: Used for switching on various extra interpreter * debug/info mechanisms (e.g. info frame eval/uplevel * tracing) which are performance intensive. * INTERP_TRACE_IN_PROGRESS: Non-zero means that an interp trace is currently * active; so no further trace callbacks should be @@ -2246,20 +2010,10 @@ * invoked. * INTERP_ALTERNATE_WRONG_ARGS: Used for listing second and subsequent forms * of the wrong-num-args string in Tcl_WrongNumArgs. * Makes it append instead of replacing and uses * different intermediate text. - * CANCELED: Non-zero means that the script in progress should be - * canceled as soon as possible. This can be checked by - * extensions (and the core itself) by calling - * Tcl_Canceled and checking if TCL_ERROR is returned. - * This is a one-shot flag that is reset immediately upon - * being detected; however, if the TCL_CANCEL_UNWIND flag - * is set Tcl_Canceled will continue to report that the - * script in progress has been canceled thereby allowing - * the evaluation stack for the interp to be fully - * unwound. * * WARNING: For the sake of some extensions that have made use of former * internal values, do not re-use the flag values 2 (formerly ERR_IN_PROGRESS) * or 8 (formerly ERROR_CODE_SET). */ @@ -2271,11 +2025,10 @@ #define RAND_SEED_INITIALIZED 0x40 #define SAFE_INTERP 0x80 #define INTERP_TRACE_IN_PROGRESS 0x200 #define INTERP_ALTERNATE_WRONG_ARGS 0x400 #define ERR_LEGACY_COPY 0x800 -#define CANCELED 0x1000 /* * Maximum number of levels of nesting permitted in Tcl commands (used to * catch infinite recursion). */ @@ -2317,17 +2070,10 @@ * (notably tbcload) require it. */ #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 %" TCL_Z_MODIFIER "u bytes", (size_t)(size)),1))) - /* * The following enum values are used to specify the runtime platform setting * of the tclPlatform variable. */ @@ -2375,32 +2121,36 @@ * used to hold all element pointers. This is done to make append operations * faster. */ typedef struct List { - size_t refCount; + 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. */ + * accomodate all elements. */ } List; #define LIST_MAX \ (1 + (int)(((size_t)UINT_MAX - sizeof(List))/sizeof(Tcl_Obj *))) -#define LIST_SIZE(numElems) \ - (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) + +#define ListSetIntRep(objPtr, listRepPtr) \ + (objPtr)->internalRep.twoPtrValue.ptr1 = (void *)(listRepPtr), \ + (objPtr)->internalRep.twoPtrValue.ptr2 = NULL, \ + (listRepPtr)->refCount++, \ + (objPtr)->typePtr = &tclListType #define ListObjGetElements(listPtr, objc, objv) \ ((objv) = &(ListRepPtr(listPtr)->elements), \ (objc) = ListRepPtr(listPtr)->elemCount) @@ -2422,70 +2172,36 @@ #define TclListObjIsCanonical(listPtr) \ (((listPtr)->typePtr == &tclListType) ? ListObjIsCanonical((listPtr)) : 0) /* - * Modes for collecting (or not) in the implementations of TclNRForeachCmd, - * TclNRLmapCmd and their compilations. - */ - -#define TCL_EACH_KEEP_NONE 0 /* Discard iteration result like [foreach] */ -#define TCL_EACH_COLLECT 1 /* Collect iteration result like [lmap] */ - -/* - * Macros providing a faster path to booleans and integers: - * Tcl_GetBooleanFromObj, Tcl_GetLongFromObj, Tcl_GetIntFromObj - * and Tcl_GetIntForIndex. + * Macros providing a faster path to integers: Tcl_GetLongFromObj everywhere, + * Tcl_GetIntFromObj and TclGetIntForIndex on platforms where longs are ints. * * WARNING: these macros eval their args more than once. */ -#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \ - (((objPtr)->typePtr == &tclIntType \ - || (objPtr)->typePtr == &tclBooleanType) \ - ? (*(boolPtr) = ((objPtr)->internalRep.wideValue!=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))) -#else -#define TclGetLongFromObj(interp, objPtr, longPtr) \ - (((objPtr)->typePtr == &tclIntType \ - && (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(LONG_MIN) \ - && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(LONG_MAX)) \ - ? ((*(longPtr) = (long)(objPtr)->internalRep.wideValue), TCL_OK) \ - : Tcl_GetLongFromObj((interp), (objPtr), (longPtr))) -#endif - -#define TclGetIntFromObj(interp, objPtr, intPtr) \ - (((objPtr)->typePtr == &tclIntType \ - && (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(INT_MIN) \ - && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(INT_MAX)) \ - ? ((*(intPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \ + ? ((*(longPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ + : Tcl_GetLongFromObj((interp), (objPtr), (longPtr))) + +#if (LONG_MAX == INT_MAX) +#define TclGetIntFromObj(interp, objPtr, intPtr) \ + (((objPtr)->typePtr == &tclIntType) \ + ? ((*(intPtr) = (objPtr)->internalRep.longValue), 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 <= (size_t)(endValue) + 1)) \ - ? ((*(idxPtr) = (size_t)(objPtr)->internalRep.wideValue), TCL_OK) \ - : Tcl_GetIntForIndex((interp), (objPtr), (endValue), (idxPtr))) - -/* - * Macro used to save a function call for common uses of - * Tcl_GetWideIntFromObj(). The ANSI C "prototype" is: - * - * MODULE_SCOPE int TclGetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - * Tcl_WideInt *wideIntPtr); - */ - -#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ - (((objPtr)->typePtr == &tclIntType) \ - ? (*(wideIntPtr) = \ - ((objPtr)->internalRep.wideValue), TCL_OK) : \ - Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) + (((objPtr)->typePtr == &tclIntType) \ + ? ((*(idxPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ + : TclGetIntForIndex((interp), (objPtr), (endValue), (idxPtr))) +#else +#define TclGetIntFromObj(interp, objPtr, intPtr) \ + Tcl_GetIntFromObj((interp), (objPtr), (intPtr)) +#define TclGetIntForIndexM(interp, objPtr, ignore, idxPtr) \ + TclGetIntForIndex(interp, objPtr, ignore, idxPtr) +#endif /* * Flag values for TclTraceDictPath(). * * DICT_PATH_READ indicates that all entries on the path must exist but no @@ -2493,17 +2209,17 @@ * * DICT_PATH_UPDATE indicates that we are going to be doing an update at the * tip of the path, so duplication of shared objects should be done along the * way. * - * DICT_PATH_EXISTS indicates that we are performing an existence test and a + * DICT_PATH_EXISTS indicates that we are performing an existance test and a * lookup failure should therefore not be an error. If (and only if) this flag * is set, TclTraceDictPath() will return the special value * DICT_PATH_NON_EXISTENT if the path is not traceable. * * DICT_PATH_CREATE (which also requires the DICT_PATH_UPDATE bit to be set) - * indicates that we are to create non-existent dictionaries on the path. + * indicates that we are to create non-existant dictionaries on the path. */ #define DICT_PATH_READ 0 #define DICT_PATH_UPDATE 1 #define DICT_PATH_EXISTS 2 @@ -2524,13 +2240,11 @@ * more efficiency in 'path' manipulation and usage, and cleaner filesystem * code internally. */ #define TCL_FILESYSTEM_VERSION_2 ((Tcl_FSVersion) 0x2) -typedef void *(TclFSGetCwdProc2)(void *clientData); -typedef int (Tcl_FSLoadFileProc2) (Tcl_Interp *interp, Tcl_Obj *pathPtr, - Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); +typedef ClientData (TclFSGetCwdProc2)(ClientData clientData); /* * 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 @@ -2576,14 +2290,14 @@ *---------------------------------------------------------------- * Data structures related to obsolete filesystem hooks *---------------------------------------------------------------- */ -typedef int (TclStatProc_)(const char *path, struct stat *buf); -typedef int (TclAccessProc_)(const char *path, int mode); +typedef int (TclStatProc_)(CONST char *path, struct stat *buf); +typedef int (TclAccessProc_)(CONST char *path, int mode); typedef Tcl_Channel (TclOpenFileChannelProc_)(Tcl_Interp *interp, - const char *fileName, const char *modeString, int permissions); + CONST char *fileName, CONST char *modeString, int permissions); /* *---------------------------------------------------------------- * Data structures related to procedures *---------------------------------------------------------------- @@ -2596,30 +2310,30 @@ *---------------------------------------------------------------- * Data structures for process-global values. *---------------------------------------------------------------- */ -typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, size_t *lengthPtr, +typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, int *lengthPtr, Tcl_Encoding *encodingPtr); /* * A ProcessGlobalValue struct exists for each internal value in Tcl that is * to be shared among several threads. Each thread sees a (Tcl_Obj) copy of - * the value, and the gobal value is kept as a counted string, with epoch and - * mutex control. Each ProcessGlobalValue struct should be a static variable in - * some file. + * 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 { - size_t epoch; /* Epoch counter to detect changes in the - * global value. */ - size_t numBytes; /* Length of the global string. */ - char *value; /* The global string value. */ - Tcl_Encoding encoding; /* system encoding when global string was + int epoch; /* Epoch counter to detect changes in the + * master value. */ + 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 global string + /* A procedure to initialize the master string * copy when a "get" request comes in before * any "set" request has been received. */ Tcl_Mutex mutex; /* Enforce orderly access from multiple * threads. */ Tcl_ThreadDataKey key; /* Key for per-thread data holding the @@ -2644,22 +2358,19 @@ #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 +#define TCL_NUMBER_LONG 1 +#define TCL_NUMBER_WIDE 2 #define TCL_NUMBER_BIG 3 #define TCL_NUMBER_DOUBLE 4 #define TCL_NUMBER_NAN 5 /* @@ -2670,11 +2381,11 @@ MODULE_SCOPE char *tclNativeExecutableName; MODULE_SCOPE int tclFindExecutableSearchDone; MODULE_SCOPE char *tclMemDumpFileName; MODULE_SCOPE TclPlatformType tclPlatform; -MODULE_SCOPE Tcl_NotifierProcs tclNotifierHooks; +MODULE_SCOPE Tcl_NotifierProcs tclOriginalNotifier; MODULE_SCOPE Tcl_Encoding tclIdentityEncoding; /* * TIP #233 (Virtualized Time) @@ -2681,253 +2392,160 @@ * Data for the time hooks, if any. */ MODULE_SCOPE Tcl_GetTimeProc *tclGetTimeProcPtr; MODULE_SCOPE Tcl_ScaleTimeProc *tclScaleTimeProcPtr; -MODULE_SCOPE void *tclTimeClientData; +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; -MODULE_SCOPE const Tcl_ObjType tclByteArrayType; -MODULE_SCOPE const Tcl_ObjType tclByteCodeType; -MODULE_SCOPE const Tcl_ObjType tclDoubleType; -MODULE_SCOPE const Tcl_ObjType tclIntType; -MODULE_SCOPE const Tcl_ObjType tclListType; -MODULE_SCOPE const Tcl_ObjType tclDictType; -MODULE_SCOPE const Tcl_ObjType tclProcBodyType; -MODULE_SCOPE const Tcl_ObjType tclStringType; -MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType; -MODULE_SCOPE const Tcl_ObjType tclRegexpType; -MODULE_SCOPE Tcl_ObjType tclCmdNameType; +MODULE_SCOPE Tcl_ObjType tclBignumType; +MODULE_SCOPE Tcl_ObjType tclBooleanType; +MODULE_SCOPE Tcl_ObjType tclByteArrayType; +MODULE_SCOPE Tcl_ObjType tclByteCodeType; +MODULE_SCOPE Tcl_ObjType tclDoubleType; +MODULE_SCOPE Tcl_ObjType tclEndOffsetType; +MODULE_SCOPE Tcl_ObjType tclIntType; +MODULE_SCOPE Tcl_ObjType tclListType; +MODULE_SCOPE Tcl_ObjType tclDictType; +MODULE_SCOPE Tcl_ObjType tclProcBodyType; +MODULE_SCOPE Tcl_ObjType tclStringType; +MODULE_SCOPE Tcl_ObjType tclArraySearchType; +MODULE_SCOPE Tcl_ObjType tclEnsembleCmdType; +#ifndef NO_WIDE_TYPE +MODULE_SCOPE Tcl_ObjType tclWideIntType; +#endif +MODULE_SCOPE Tcl_ObjType tclRegexpType; /* * Variables denoting the hash key types defined in the core. */ -MODULE_SCOPE const Tcl_HashKeyType tclArrayHashKeyType; -MODULE_SCOPE const Tcl_HashKeyType tclOneWordHashKeyType; -MODULE_SCOPE const Tcl_HashKeyType tclStringHashKeyType; -MODULE_SCOPE const Tcl_HashKeyType tclObjHashKeyType; +MODULE_SCOPE Tcl_HashKeyType tclArrayHashKeyType; +MODULE_SCOPE Tcl_HashKeyType tclOneWordHashKeyType; +MODULE_SCOPE Tcl_HashKeyType tclStringHashKeyType; +MODULE_SCOPE Tcl_HashKeyType tclObjHashKeyType; /* * The head of the list of free Tcl objects, and the total number of Tcl * objects ever allocated and freed. */ MODULE_SCOPE Tcl_Obj * tclFreeObjList; #ifdef TCL_COMPILE_STATS -MODULE_SCOPE size_t tclObjsAlloced; -MODULE_SCOPE size_t tclObjsFreed; +MODULE_SCOPE long tclObjsAlloced; +MODULE_SCOPE long tclObjsFreed; #define TCL_MAX_SHARED_OBJ_STATS 5 -MODULE_SCOPE size_t tclObjsShared[TCL_MAX_SHARED_OBJ_STATS]; +MODULE_SCOPE long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS]; #endif /* TCL_COMPILE_STATS */ /* * Pointer to a heap-allocated string of length zero that the Tcl core uses as * the value of an empty string representation for an object. This value is * shared by all new objects allocated by Tcl_NewObj. */ +MODULE_SCOPE char * tclEmptyStringRep; MODULE_SCOPE char tclEmptyString; -enum CheckEmptyStringResult { - TCL_EMPTYSTRING_UNKNOWN = -1, TCL_EMPTYSTRING_NO, TCL_EMPTYSTRING_YES -}; - -/* - *---------------------------------------------------------------- - * Procedures shared among Tcl modules but not used by the outside world, - * introduced by/for NRE. - *---------------------------------------------------------------- - */ - -MODULE_SCOPE Tcl_ObjCmdProc TclNRApplyObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNREvalObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRExprObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRLmapCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRPackageObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRTryObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd; - -MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback; -MODULE_SCOPE Tcl_NRPostProc TclNRCoroutineActivateCallback; -MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd; -MODULE_SCOPE Tcl_NRPostProc TclNRTailcallEval; -MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRInvoke; -MODULE_SCOPE Tcl_NRPostProc TclNRReleaseValues; - -MODULE_SCOPE void TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr); -MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp); - -/* These two can be considered for the public api */ -MODULE_SCOPE void TclMarkTailcall(Tcl_Interp *interp); -MODULE_SCOPE void TclSkipTailcall(Tcl_Interp *interp); - -/* - * This structure holds the data for the various iteration callbacks used to - * NRE the 'for' and 'while' commands. We need a separate structure because we - * have more than the 4 client data entries we can provide directly thorugh - * the callback API. It is the 'word' information which puts us over the - * limit. It is needed because the loop body is argument 4 of 'for' and - * argument 2 of 'while'. Not providing the correct index confuses the #280 - * code. We TclSmallAlloc/Free this. - */ - -typedef struct ForIterData { - Tcl_Obj *cond; /* Loop condition expression. */ - Tcl_Obj *body; /* Loop body. */ - Tcl_Obj *next; /* Loop step script, NULL for 'while'. */ - const char *msg; /* Error message part. */ - int word; /* Index of the body script in the command */ -} ForIterData; - -/* TIP #357 - Structure doing the bookkeeping of handles for Tcl_LoadFile - * and Tcl_FindSymbol. This structure corresponds to an opaque - * typedef in tcl.h */ - -typedef void* TclFindSymbolProc(Tcl_Interp* interp, Tcl_LoadHandle loadHandle, - const char* symbol); -struct Tcl_LoadHandle_ { - void *clientData; /* Client data is the load handle in the - * native filesystem if a module was loaded - * there, or an opaque pointer to a structure - * for further bookkeeping on load-from-VFS - * and load-from-memory */ - TclFindSymbolProc* findSymbolProcPtr; - /* Procedure that resolves symbols in a - * loaded module */ - Tcl_FSUnloadFileProc* unloadFileProcPtr; - /* Procedure that unloads a loaded module */ -}; - /* Flags for conversion of doubles to digit strings */ +#define TCL_DD_SHORTEST 0x4 + /* Use the shortest possible string */ +#define TCL_DD_STEELE 0x5 + /* Use the original Steele&White algorithm */ #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_SHORTEN_FLAG 0x4 + /* Allow return of a shorter digit string + * if it converts losslessly */ #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 */ +#define TCL_DD_STEELE0 0x1 + /* 'Steele&White' after masking */ +#define TCL_DD_SHORTEST0 0x0 + /* 'Shortest possible' after masking */ /* *---------------------------------------------------------------- * Procedures shared among Tcl modules but not used by the outside world: *---------------------------------------------------------------- */ MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr, - const unsigned char *bytes, size_t 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 unsigned char *bytes, int len); +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, +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 TclArgumentGet(Tcl_Interp* interp, Tcl_Obj* obj, + CmdFrame **cfPtrPtr, int *wordPtr); +MODULE_SCOPE void TclArgumentBCEnter(Tcl_Interp *interp, + Tcl_Obj* objv[], int objc, + void *codePtr, CmdFrame *cfPtr, int pc); +MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp, Tcl_Obj *objv[], int objc, - void *codePtr, CmdFrame *cfPtr, int cmd, size_t 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); + void *codePtr, int pc); +MODULE_SCOPE int TclArraySet(Tcl_Interp *interp, + Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj); +MODULE_SCOPE double TclBignumToDouble(mp_int *bignum); MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string, - size_t strLen, const unsigned char *pattern, - size_t ptnLen, int flags); -MODULE_SCOPE double TclCeil(const void *a); + int strLen, const unsigned char *pattern, + int ptnLen, int flags); +MODULE_SCOPE double TclCeil(mp_int *a); MODULE_SCOPE void TclChannelPreserve(Tcl_Channel chan); MODULE_SCOPE void TclChannelRelease(Tcl_Channel chan); -MODULE_SCOPE int TclCheckArrayTraces(Tcl_Interp *interp, Var *varPtr, - Var *arrayPtr, Tcl_Obj *name, int index); -MODULE_SCOPE int TclCheckEmptyString(Tcl_Obj *objPtr); +MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp, const char *value); 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, +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 ContLineLoc* TclContinuationsGet(Tcl_Obj *objPtr); MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr, Tcl_Obj *originObjPtr); -MODULE_SCOPE size_t TclConvertElement(const char *src, size_t length, +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, void *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, - size_t *sizePtr, int *literalPtr); -/* TIP #280 - Modified token based evaluation, with line information. */ +/* TIP #280 - Modified token based evulation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, - size_t 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; + int numBytes, int flags, int line, + int *clNextOuter, CONST char *outerScript); +MODULE_SCOPE int TclFileAttrsCmd(Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int TclFileCopyCmd(Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int TclFileDeleteCmd(Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int TclFileMakeDirsCmd(Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int TclFileRenameCmd(Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); MODULE_SCOPE void TclCreateLateExitHandler(Tcl_ExitProc *proc, - void *clientData); + ClientData clientData); MODULE_SCOPE void TclDeleteLateExitHandler(Tcl_ExitProc *proc, - void *clientData); -MODULE_SCOPE char * TclDStringAppendObj(Tcl_DString *dsPtr, - Tcl_Obj *objPtr); -MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr, - Tcl_DString *toAppendPtr); -MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr); -MODULE_SCOPE Tcl_Obj *const *TclFetchEnsembleRoot(Tcl_Interp *interp, - Tcl_Obj *const *objv, int objc, int *objcPtr); -MODULE_SCOPE Tcl_Namespace *TclEnsureNamespace(Tcl_Interp *interp, - Tcl_Namespace *namespacePtr); + ClientData clientData); MODULE_SCOPE void TclFinalizeAllocSubsystem(void); MODULE_SCOPE void TclFinalizeAsync(void); MODULE_SCOPE void TclFinalizeDoubleConversion(void); MODULE_SCOPE void TclFinalizeEncodingSubsystem(void); MODULE_SCOPE void TclFinalizeEnvironment(void); -MODULE_SCOPE void TclFinalizeEvaluation(void); MODULE_SCOPE void TclFinalizeExecution(void); MODULE_SCOPE void TclFinalizeIOSubsystem(void); MODULE_SCOPE void TclFinalizeFilesystem(void); MODULE_SCOPE void TclResetFilesystem(void); MODULE_SCOPE void TclFinalizeLoad(void); @@ -2935,70 +2553,49 @@ MODULE_SCOPE void TclFinalizeMemorySubsystem(void); MODULE_SCOPE void TclFinalizeNotifier(void); MODULE_SCOPE void TclFinalizeObjects(void); 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 TclFinalizeThreadData(void); MODULE_SCOPE void TclFinalizeThreadObjects(void); -MODULE_SCOPE double TclFloor(const void *a); +MODULE_SCOPE double TclFloor(mp_int *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, - void *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, void **clientDataPtr, + 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 const char *TclGetSrcInfoForCmd(Interp *iPtr, int *lenPtr); MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, - size_t *sizePtr); -MODULE_SCOPE int TclGetLoadedPackagesEx(Tcl_Interp *interp, - const char *targetName, - const char *packageName); -MODULE_SCOPE int TclGetWideBitsFromObj(Tcl_Interp *, Tcl_Obj *, - Tcl_WideInt *); + unsigned int *sizePtr); 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(void *dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclInfoCoroutineCmd(void *dummy, Tcl_Interp *interp, +MODULE_SCOPE int TclInfoExistsCmd(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(void *dummy, Tcl_Interp *interp, +MODULE_SCOPE int TclInfoGlobalsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclInfoLocalsCmd(void *dummy, Tcl_Interp *interp, +MODULE_SCOPE int TclInfoLocalsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclInfoVarsCmd(void *dummy, Tcl_Interp *interp, +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( @@ -3007,15 +2604,13 @@ 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 void TclInitSubsystems(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 TclIsBareword(char byte); 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); MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, @@ -3022,25 +2617,28 @@ int indexCount, Tcl_Obj *const indexArray[]); /* TIP #280 */ MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, int line, int n, int *lines, Tcl_Obj *const *elems); MODULE_SCOPE Tcl_Obj * TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr); -MODULE_SCOPE Tcl_Obj * TclListObjRange(Tcl_Obj *listPtr, size_t fromIdx, - size_t toIdx); +MODULE_SCOPE int TclLoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, + int symc, const char *symbols[], + Tcl_PackageInitProc **procPtrs[], + Tcl_LoadHandle *handlePtr, + ClientData *clientDataPtr, + Tcl_FSUnloadFileProc **unloadProcPtr); 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, size_t numBytes, - const char **endPtr); +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, @@ -3049,47 +2647,43 @@ 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, - size_t numBytes, size_t *readPtr, char *dst); -MODULE_SCOPE int TclParseHex(const char *src, size_t numBytes, - int *resultPtr); + int numBytes, int *readPtr, char *dst); MODULE_SCOPE int TclParseNumber(Tcl_Interp *interp, Tcl_Obj *objPtr, const char *expected, const char *bytes, - size_t numBytes, const char **endPtrPtr, int flags); + int numBytes, const char **endPtrPtr, int flags); MODULE_SCOPE void TclParseInit(Tcl_Interp *interp, const char *string, - size_t numBytes, Tcl_Parse *parsePtr); -MODULE_SCOPE size_t TclParseAllWhiteSpace(const char *src, size_t numBytes); + 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); +#ifndef TCL_NO_STACK_CHECK +MODULE_SCOPE int TclpGetCStackParams(int **stackBoundPtr); +#endif 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, - size_t len); -MODULE_SCOPE int TclpDeleteFile(const void *path); + int len); +MODULE_SCOPE int TclpDeleteFile(const char *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, void *clientData, - size_t stackSize, int flags); -MODULE_SCOPE size_t TclpFindVariable(const char *name, size_t *lengthPtr); + Tcl_ThreadCreateProc proc, ClientData clientData, + int stackSize, int flags); +MODULE_SCOPE int TclpFindVariable(const char *name, int *lengthPtr); MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, - size_t *lengthPtr, Tcl_Encoding *encodingPtr); + int *lengthPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE void TclpInitLock(void); MODULE_SCOPE void TclpInitPlatform(void); MODULE_SCOPE void TclpInitUnlock(void); MODULE_SCOPE Tcl_Obj * TclpObjListVolumes(void); -MODULE_SCOPE void TclpGlobalLock(void); -MODULE_SCOPE void TclpGlobalUnlock(void); +MODULE_SCOPE 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); @@ -3099,118 +2693,93 @@ 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 void *TclpGetNativeCwd(void *clientData); +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); -MODULE_SCOPE void TclPkgFileSeen(Tcl_Interp *interp, const char *fileName); -MODULE_SCOPE void *TclInitPkgFiles(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_PathPart portion); +#ifndef TclpPanic +MODULE_SCOPE void TclpPanic(const char *format, ...); +#endif MODULE_SCOPE char * TclpReadlink(const char *fileName, Tcl_DString *linkPtr); +#ifndef TclpReleaseFile +MODULE_SCOPE void TclpReleaseFile(TclFile file); +#endif +MODULE_SCOPE void TclpSetInterfaces(void); MODULE_SCOPE void TclpSetVariables(Tcl_Interp *interp); -MODULE_SCOPE void * TclThreadStorageKeyGet(Tcl_ThreadDataKey *keyPtr); -MODULE_SCOPE void TclThreadStorageKeySet(Tcl_ThreadDataKey *keyPtr, +MODULE_SCOPE void TclpUnloadFile(Tcl_LoadHandle loadHandle); +MODULE_SCOPE void * TclpThreadDataKeyGet(Tcl_ThreadDataKey *keyPtr); +MODULE_SCOPE void TclpThreadDataKeySet(Tcl_ThreadDataKey *keyPtr, void *data); -MODULE_SCOPE TCL_NORETURN void TclpThreadExit(int status); +MODULE_SCOPE void TclpThreadExit(int status); +MODULE_SCOPE size_t TclpThreadGetStackSize(void); 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, - size_t reStrLen, Tcl_DString *dsPtr, int *flagsPtr, - int *quantifiersFoundPtr); -MODULE_SCOPE size_t TclScanElement(const char *string, size_t length, - char *flagPtr); + int reStrLen, Tcl_DString *dsPtr, int *flagsPtr); +MODULE_SCOPE int TclScanElement(CONST char *string, int length, + int *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); + mp_int *bignumValue); 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, size_t subIdx, - Tcl_Obj *bad, Tcl_Obj *fix); MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr, - size_t 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, size_t 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, size_t strLen, + int numBytes); +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, - size_t 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, - size_t numBytes, int flags, Tcl_Parse *parsePtr, - Tcl_InterpState *statePtr); +MODULE_SCOPE Tcl_Obj * TclStringObjReverse(Tcl_Obj *objPtr); MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, int *tokensLeftPtr, int line, - int *clNextOuter, const char *outerScript); -MODULE_SCOPE size_t TclTrim(const char *bytes, size_t numBytes, - const char *trim, size_t numTrim, size_t *trimRight); -MODULE_SCOPE size_t TclTrimLeft(const char *bytes, size_t numBytes, - const char *trim, size_t numTrim); -MODULE_SCOPE size_t TclTrimRight(const char *bytes, size_t numBytes, - const char *trim, size_t 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 size_t 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(void *clientData); + int *clNextOuter, CONST char *outerScript); +MODULE_SCOPE void TclTransferResult(Tcl_Interp *sourceInterp, int result, + Tcl_Interp *targetInterp); +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 Tcl_Obj * TclpNativeToNormalized(ClientData clientData); MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr); +MODULE_SCOPE Tcl_PackageInitProc *TclpFindSymbol(Tcl_Interp *interp, + Tcl_LoadHandle loadHandle, const char *symbol); MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_LoadHandle *loadHandle, - Tcl_FSUnloadFileProc **unloadProcPtr, int flags); + Tcl_FSUnloadFileProc **unloadProcPtr); 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); + Tcl_FSUnloadFileProc **unloadProcPtr); #endif MODULE_SCOPE void TclInitThreadStorage(void); -MODULE_SCOPE void TclFinalizeThreadDataThread(void); +MODULE_SCOPE void TclpFinalizeThreadDataThread(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 @@ -3222,324 +2791,290 @@ ((double)(clicks) * TclpWideClickInMicrosec() * 1000) # endif #endif MODULE_SCOPE Tcl_WideInt TclpGetMicroseconds(void); -MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp); -MODULE_SCOPE void * TclpThreadCreateKey(void); -MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr); -MODULE_SCOPE void TclpThreadSetGlobalTSD(void *tsdKeyPtr, void *ptr); -MODULE_SCOPE void * TclpThreadGetGlobalTSD(void *tsdKeyPtr); -MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, - const char *msg, size_t length); -/* Tip 430 */ -MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); - +MODULE_SCOPE Tcl_Obj * TclDisassembleByteCodeObj(Tcl_Obj *objPtr); +MODULE_SCOPE int TclUtfCasecmp(CONST char *cs, CONST char *ct); /* * 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); +MODULE_SCOPE int TclIsSpaceProc(char byte); # define TclIsSpaceProcM(byte) \ (((byte) > 0x20) ? 0 : TclIsSpaceProc(byte)) /* *---------------------------------------------------------------- * Command procedures in the generic core: *---------------------------------------------------------------- */ -MODULE_SCOPE int Tcl_AfterObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_AppendObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ApplyObjCmd(void *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(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_CatchObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_CdObjCmd(void *clientData, +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 int Tcl_ArrayObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_BinaryObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_BreakObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_CaseObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +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(void *clientData, +MODULE_SCOPE int TclChanCreateObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclChanPostEventObjCmd(void *clientData, +MODULE_SCOPE int TclChanPostEventObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclChanPopObjCmd(void *clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclChanPushObjCmd(void *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, + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_CloseObjCmd(void *clientData, +MODULE_SCOPE int Tcl_CloseObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ConcatObjCmd(void *clientData, +MODULE_SCOPE int Tcl_ConcatObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ContinueObjCmd(void *clientData, +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, - void *clientData); + ClientData clientData); MODULE_SCOPE int TclDefaultBgErrorHandlerObjCmd( - void *clientData, Tcl_Interp *interp, + 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(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); - -/* Assemble command function */ -MODULE_SCOPE int Tcl_AssembleObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int TclNRAssembleObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE Tcl_Command TclInitEncodingCmd(Tcl_Interp *interp); -MODULE_SCOPE int Tcl_EofObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ErrorObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_EvalObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ExecObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ExitObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ExprObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_FblockedObjCmd(void *clientData, +MODULE_SCOPE int Tcl_DisassembleObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_EncodingObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +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( - void *clientData, Tcl_Interp *interp, + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_FcopyObjCmd(void *dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE Tcl_Command TclInitFileCmd(Tcl_Interp *interp); -MODULE_SCOPE int Tcl_FileEventObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_FlushObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ForObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ForeachObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_FormatObjCmd(void *dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_GetsObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_GlobalObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_GlobObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_IfObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_IncrObjCmd(void *clientData, +MODULE_SCOPE int Tcl_FcopyObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_FileObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +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(void *clientData, +MODULE_SCOPE int Tcl_InterpObjCmd(ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_JoinObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LappendObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LassignObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LindexObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LinsertObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LlengthObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ListObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LmapObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LoadObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LpopObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LrangeObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LremoveObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LrepeatObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LreplaceObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LreverseObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LsearchObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LsetObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LsortObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE Tcl_Command TclInitNamespaceCmd(Tcl_Interp *interp); -MODULE_SCOPE int TclNamespaceEnsembleCmd(void *dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_OpenObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_PackageObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_PidObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE Tcl_Command TclInitPrefixCmd(Tcl_Interp *interp); -MODULE_SCOPE int Tcl_PutsObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_PwdObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ReadObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_RegexpObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_RegsubObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_RenameObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_RepresentationCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ReturnObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ScanObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SeekObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SetObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SplitObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SocketObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SourceObjCmd(void *clientData, +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_LoadObjCmd(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_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 int Tcl_NamespaceObjCmd(ClientData clientData, + 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 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_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(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SwitchObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_TellObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ThrowObjCmd(void *dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_TimeObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_TimeRateObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_TraceObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_TryObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_UnloadObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_UnsetObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_UpdateObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_UplevelObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_UpvarObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_VariableObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_VwaitObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_WhileObjCmd(void *clientData, +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_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_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[]); /* *---------------------------------------------------------------- @@ -3548,124 +3083,61 @@ */ MODULE_SCOPE int TclCompileAppendCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileArrayExistsCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileArraySetCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileArrayUnsetCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileBreakCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileCatchCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileClockClicksCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileClockReadingCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileConcatCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileContinueCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictAppendCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileDictCreateCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileDictExistsCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictForCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictGetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileDictGetWithDefaultCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictIncrCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictLappendCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileDictMapCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileDictMergeCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictSetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileDictUnsetCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictUpdateCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileDictWithCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileEnsemble(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileErrorCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileExprCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileForCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileForeachCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileFormatCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileGlobalCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileIfCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileInfoCommandsCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileInfoCoroutineCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileInfoExistsCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileInfoLevelCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileInfoObjectClassCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileInfoObjectIsACmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileInfoObjectNamespaceCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileIncrCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLappendCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, @@ -3674,300 +3146,159 @@ Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLindexCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileLinsertCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileListCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLlengthCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileLmapCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileLrangeCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileLreplaceCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLsetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileNamespaceCodeCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileNamespaceCurrentCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileNamespaceOriginCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileNamespaceQualifiersCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileNamespaceTailCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileNamespaceUpvarCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileNamespaceWhichCmd(Tcl_Interp *interp, +MODULE_SCOPE int TclCompileNamespaceCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileNoOp(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileObjectNextCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileObjectNextToCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileObjectSelfCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileRegexpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileRegsubCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileReturnCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileSetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStringCatCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringCmpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringEqualCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStringFirstCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringIndexCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStringInsertCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStringIsCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStringLastCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringLenCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStringMapCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringMatchCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStringRangeCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStringReplaceCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStringToLowerCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStringToTitleCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStringToUpperCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStringTrimCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStringTrimLCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStringTrimRCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileSubstCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileSwitchCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileTailcallCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileThrowCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileTryCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileUnsetCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileUpvarCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileVariableCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileWhileCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileYieldCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileYieldToCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileBasic0ArgCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileBasic1ArgCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileBasic2ArgCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileBasic3ArgCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileBasic0Or1ArgCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileBasic1Or2ArgCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileBasic2Or3ArgCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileBasic0To2ArgCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileBasic1To3ArgCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileBasicMin0ArgCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -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(void *clientData, + +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(void *clientData, +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(void *clientData, +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(void *clientData, +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(void *clientData, +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(void *clientData, +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(void *clientData, +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(void *clientData, +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(void *clientData, +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(void *clientData, +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(void *clientData, +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(void *clientData, +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(void *clientData, +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(void *clientData, +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(void *clientData, +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(void *clientData, +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(void *clientData, +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); @@ -3987,52 +3318,13 @@ Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStreqOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStrLtOpCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStrLeOpCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStrGtOpCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStrGeOpCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); - -MODULE_SCOPE int TclCompileAssembleCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); - -/* - * 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, - size_t start); -MODULE_SCOPE Tcl_Obj * TclStringLast(Tcl_Obj *needle, Tcl_Obj *haystack, - size_t last); -MODULE_SCOPE Tcl_Obj * TclStringRepeat(Tcl_Interp *interp, Tcl_Obj *objPtr, - size_t count, int flags); -MODULE_SCOPE Tcl_Obj * TclStringReplace(Tcl_Interp *interp, Tcl_Obj *objPtr, - size_t first, size_t 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) - -/* - * Functions defined in generic/tclVar.c and currently exported only for use + +/* + * Functions defined in generic/tclVar.c and currenttly exported only for use * by the bytecode compiler and engine. Some of these could later be placed in * the public interface. */ MODULE_SCOPE Var * TclObjLookupVarEx(Tcl_Interp * interp, @@ -4042,31 +3334,24 @@ MODULE_SCOPE Var * TclLookupArrayElement(Tcl_Interp *interp, Tcl_Obj *arrayNamePtr, Tcl_Obj *elNamePtr, const int flags, const char *msg, const int createPart1, const int createPart2, Var *arrayPtr, int index); -MODULE_SCOPE Tcl_Obj * TclPtrGetVarIdx(Tcl_Interp *interp, +MODULE_SCOPE Tcl_Obj * TclPtrGetVar(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags, int index); -MODULE_SCOPE Tcl_Obj * TclPtrSetVarIdx(Tcl_Interp *interp, +MODULE_SCOPE Tcl_Obj * TclPtrSetVar(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, const int flags, int index); -MODULE_SCOPE Tcl_Obj * TclPtrIncrObjVarIdx(Tcl_Interp *interp, +MODULE_SCOPE Tcl_Obj * TclPtrIncrObjVar(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, const int flags, int index); -MODULE_SCOPE int TclPtrObjMakeUpvarIdx(Tcl_Interp *interp, - Var *otherPtr, Tcl_Obj *myNamePtr, int myFlags, - int index); -MODULE_SCOPE int TclPtrUnsetVarIdx(Tcl_Interp *interp, Var *varPtr, - Var *arrayPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, const int flags, - int index); +MODULE_SCOPE int TclPtrObjMakeUpvar(Tcl_Interp *interp, Var *otherPtr, + Tcl_Obj *myNamePtr, int myFlags, int index); MODULE_SCOPE void TclInvalidateNsPath(Namespace *nsPtr); -MODULE_SCOPE void TclFindArrayPtrElements(Var *arrayPtr, - Tcl_HashTable *tablePtr); /* * The new extended interface to the variable traces. */ @@ -4078,83 +3363,11 @@ * 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); - -/* - * TIP #542 - */ - -MODULE_SCOPE size_t TclUniCharLen(const Tcl_UniChar *uniStr); -MODULE_SCOPE int TclUniCharNcmp(const Tcl_UniChar *ucs, - const Tcl_UniChar *uct, size_t numChars); -MODULE_SCOPE int TclUniCharNcasecmp(const Tcl_UniChar *ucs, - const Tcl_UniChar *uct, size_t numChars); -MODULE_SCOPE int TclUniCharCaseMatch(const Tcl_UniChar *uniStr, - const Tcl_UniChar *uniPattern, int nocase); - - -/* - * Just for the purposes of command-type registration. - */ - -MODULE_SCOPE Tcl_ObjCmdProc TclEnsembleImplementationCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclAliasObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclLocalAliasObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclChildObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclInvokeImportedCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclOOPublicObjectCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclOOPrivateObjectCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclOOMyClassObjCmd; - -/* - * TIP #462. - */ - -/* - * The following enum values give the status of a spawned process. - */ - -typedef enum TclProcessWaitStatus { - TCL_PROCESS_ERROR = -1, /* Error waiting for process to exit */ - TCL_PROCESS_UNCHANGED = 0, /* No change since the last call. */ - TCL_PROCESS_EXITED = 1, /* Process has exited. */ - TCL_PROCESS_SIGNALED = 2, /* Child killed because of a signal. */ - TCL_PROCESS_STOPPED = 3, /* Child suspended because of a signal. */ - TCL_PROCESS_UNKNOWN_STATUS = 4 - /* Child wait status didn't make sense. */ -} TclProcessWaitStatus; - -MODULE_SCOPE Tcl_Command TclInitProcessCmd(Tcl_Interp *interp); -MODULE_SCOPE void TclProcessCreated(Tcl_Pid pid); -MODULE_SCOPE TclProcessWaitStatus TclProcessWait(Tcl_Pid pid, int options, - int *codePtr, Tcl_Obj **msgObjPtr, - Tcl_Obj **errorObjPtr); -MODULE_SCOPE int TclClose(Tcl_Interp *, Tcl_Channel chan); -/* - * TIP #508: [array default] - */ - -MODULE_SCOPE void TclInitArrayVar(Var *arrayPtr); -MODULE_SCOPE Tcl_Obj * TclGetArrayDefault(Var *arrayPtr); - -/* - * Utility routines for encoding index values as integers. Used by both - * some of the command compilers and by [lsort] and [lsearch]. - */ - -MODULE_SCOPE int TclIndexEncode(Tcl_Interp *interp, Tcl_Obj *objPtr, - size_t before, size_t after, int *indexPtr); -MODULE_SCOPE size_t TclIndexDecode(int encoded, size_t endValue); - -/* Constants used in index value encoding routines. */ -#define TCL_INDEX_END ((size_t)-2) -#define TCL_INDEX_START ((size_t)0) +MODULE_SCOPE unsigned TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); /* *---------------------------------------------------------------- * Macros used by the Tcl core to create and release Tcl objects. * TclNewObj(objPtr) creates a new object denoting an empty string. @@ -4178,13 +3391,11 @@ /* * 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) {} @@ -4198,71 +3409,60 @@ #else # define TclIncrObjsAllocated() # define TclIncrObjsFreed() #endif /* TCL_COMPILE_STATS */ -# define TclAllocObjStorage(objPtr) \ - TclAllocObjStorageEx(NULL, (objPtr)) - -# define TclFreeObjStorage(objPtr) \ - TclFreeObjStorageEx(NULL, (objPtr)) - #ifndef TCL_MEM_DEBUG # define TclNewObj(objPtr) \ TclIncrObjsAllocated(); \ TclAllocObjStorage(objPtr); \ (objPtr)->refCount = 0; \ - (objPtr)->bytes = &tclEmptyString; \ + (objPtr)->bytes = tclEmptyStringRep; \ (objPtr)->length = 0; \ (objPtr)->typePtr = NULL; \ TCL_DTRACE_OBJ_CREATE(objPtr) /* * Invalidate the string rep first so we can use the bytes value for our * pointer chain, and signal an obj deletion (as opposed to shimmering) with - * 'length == TCL_INDEX_NONE'. + * '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)->refCount > 0) ; else { \ if (!(objPtr)->typePtr || !(objPtr)->typePtr->freeIntRepProc) { \ TCL_DTRACE_OBJ_FREE(objPtr); \ if ((objPtr)->bytes \ - && ((objPtr)->bytes != &tclEmptyString)) { \ - Tcl_Free((objPtr)->bytes); \ + && ((objPtr)->bytes != tclEmptyStringRep)) { \ + ckfree((char *) (objPtr)->bytes); \ } \ - (objPtr)->length = TCL_INDEX_NONE; \ + (objPtr)->length = -1; \ TclFreeObjStorage(objPtr); \ TclIncrObjsFreed(); \ } else { \ TclFreeObj(objPtr); \ } \ } -#if TCL_THREADS && !defined(USE_THREAD_ALLOC) -# define USE_THREAD_ALLOC 1 -#endif - #if defined(PURIFY) /* * 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) \ +# define TclAllocObjStorage(objPtr) \ (objPtr) = (Tcl_Obj *) Tcl_Alloc(sizeof(Tcl_Obj)) -# define TclFreeObjStorageEx(interp, objPtr) \ - Tcl_Free(objPtr) +# define TclFreeObjStorage(objPtr) \ + ckfree((char *) (objPtr)) #undef USE_THREAD_ALLOC -#undef USE_TCLALLOC -#elif TCL_THREADS && defined(USE_THREAD_ALLOC) +#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) /* * The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's from * per-thread caches. */ @@ -4272,51 +3472,17 @@ MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex(void); MODULE_SCOPE void TclFreeAllocCache(void *); MODULE_SCOPE void * TclpGetAllocCache(void); MODULE_SCOPE void TclpSetAllocCache(void *); MODULE_SCOPE void TclpFreeAllocMutex(Tcl_Mutex *mutex); -MODULE_SCOPE void TclpInitAllocCache(void); MODULE_SCOPE void TclpFreeAllocCache(void *); -/* - * These macros need to be kept in sync with the code of TclThreadAllocObj() - * and TclThreadFreeObj(). - * - * Note that the optimiser should resolve the case (interp==NULL) at compile - * time. - */ - -# define ALLOC_NOBJHIGH 1200 - -# define TclAllocObjStorageEx(interp, objPtr) \ - do { \ - 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; \ - if (((interp) == NULL) || \ - ((cachePtr = ((Interp *)(interp))->allocCache), \ - ((cachePtr->numObjects == 0) || \ - (cachePtr->numObjects >= ALLOC_NOBJHIGH)))) { \ - TclThreadFreeObj(objPtr); \ - } else { \ - (objPtr)->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr; \ - cachePtr->firstObjPtr = objPtr; \ - ++cachePtr->numObjects; \ - } \ - } while (0) +# define TclAllocObjStorage(objPtr) \ + (objPtr) = TclThreadAllocObj() + +# define TclFreeObjStorage(objPtr) \ + TclThreadFreeObj((objPtr)) #else /* not PURIFY or USE_THREAD_ALLOC */ #if defined(USE_TCLALLOC) && USE_TCLALLOC MODULE_SCOPE void TclFinalizeAllocSubsystem(); @@ -4323,48 +3489,41 @@ MODULE_SCOPE void TclInitAlloc(); #else # define USE_TCLALLOC 0 #endif -#if TCL_THREADS +#ifdef TCL_THREADS /* declared in tclObj.c */ MODULE_SCOPE Tcl_Mutex tclObjMutex; #endif -# define TclAllocObjStorageEx(interp, objPtr) \ - do { \ - Tcl_MutexLock(&tclObjMutex); \ - if (tclFreeObjList == NULL) { \ - TclAllocateFreeObjects(); \ - } \ - (objPtr) = tclFreeObjList; \ - tclFreeObjList = (Tcl_Obj *) \ - tclFreeObjList->internalRep.twoPtrValue.ptr1; \ - Tcl_MutexUnlock(&tclObjMutex); \ - } while (0) - -# define TclFreeObjStorageEx(interp, objPtr) \ - do { \ - Tcl_MutexLock(&tclObjMutex); \ +# define TclAllocObjStorage(objPtr) \ + Tcl_MutexLock(&tclObjMutex); \ + if (tclFreeObjList == NULL) { \ + TclAllocateFreeObjects(); \ + } \ + (objPtr) = tclFreeObjList; \ + tclFreeObjList = (Tcl_Obj *) \ + tclFreeObjList->internalRep.twoPtrValue.ptr1; \ + Tcl_MutexUnlock(&tclObjMutex) + +# define TclFreeObjStorage(objPtr) \ + Tcl_MutexLock(&tclObjMutex); \ (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) tclFreeObjList; \ - tclFreeObjList = (objPtr); \ - Tcl_MutexUnlock(&tclObjMutex); \ - } while (0) + tclFreeObjList = (objPtr); \ + Tcl_MutexUnlock(&tclObjMutex) #endif #else /* TCL_MEM_DEBUG */ -MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, +MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, CONST char *file, int line); # define TclDbNewObj(objPtr, file, line) \ - do { \ - TclIncrObjsAllocated(); \ - (objPtr) = (Tcl_Obj *) \ - Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \ - TclDbInitNewObj((objPtr), (file), (line)); \ - TCL_DTRACE_OBJ_CREATE(objPtr); \ - } while (0) + TclIncrObjsAllocated(); \ + (objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \ + TclDbInitNewObj((objPtr), (file), (line)); \ + TCL_DTRACE_OBJ_CREATE(objPtr) # define TclNewObj(objPtr) \ TclDbNewObj(objPtr, __FILE__, __LINE__); # define TclDecrRefCount(objPtr) \ @@ -4382,24 +3541,25 @@ * 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, size_t len); + * 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)->bytes = tclEmptyStringRep; \ (objPtr)->length = 0; \ } else { \ - (objPtr)->bytes = (char *)Tcl_Alloc((len) + 1); \ - memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (len)); \ + (objPtr)->bytes = (char *) ckalloc((unsigned) ((len) + 1)); \ + memcpy((void *) (objPtr)->bytes, (void *) (bytePtr), \ + (unsigned) (len)); \ (objPtr)->bytes[len] = '\0'; \ (objPtr)->length = (len); \ } /* @@ -4413,44 +3573,16 @@ * MODULE_SCOPE char * TclGetString(Tcl_Obj *objPtr); *---------------------------------------------------------------- */ #define TclGetString(objPtr) \ - ((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString(objPtr)) - -#if 0 - static inline char *TclGetStringFromObj(Tcl_Obj *objPtr, size_t *lenPtr) { - char *response = Tcl_GetString(objPtr); - *(lenPtr) = objPtr->length; - return response; - } - static inline Tcl_UniChar *TclGetUnicodeFromObj(Tcl_Obj *objPtr, size_t *lenPtr) { - Tcl_UniChar *response = Tcl_GetUnicodeFromObj(objPtr, NULL); - *(lenPtr) = *((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1); - return response; - } - static inline unsigned char *TclGetByteArrayFromObj(Tcl_Obj *objPtr, size_t *lenPtr) { - unsigned char *response = Tcl_GetByteArrayFromObj(objPtr, NULL); - if (response) { - *(lenPtr) = *((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1 + 1); - } - return response; - } -#else + ((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString((objPtr))) + #define TclGetStringFromObj(objPtr, lenPtr) \ - (((objPtr)->bytes \ - ? NULL : Tcl_GetString((objPtr)), \ - *(lenPtr) = (objPtr)->length, (objPtr)->bytes)) -#define TclGetUnicodeFromObj(objPtr, lenPtr) \ - (Tcl_GetUnicodeFromObj((objPtr), NULL), \ - *(lenPtr) = *((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1), \ - Tcl_GetUnicodeFromObj((objPtr), NULL)) -#define TclGetByteArrayFromObj(objPtr, lenPtr) \ - (Tcl_GetByteArrayFromObj((objPtr), NULL) ? \ - (*(lenPtr) = *((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1 + 1), \ - (unsigned char *)(((size_t *) (objPtr)->internalRep.twoPtrValue.ptr1) + 3)) : NULL) -#endif + ((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 @@ -4459,15 +3591,13 @@ * MODULE_SCOPE void TclFreeIntRep(Tcl_Obj *objPtr); *---------------------------------------------------------------- */ #define TclFreeIntRep(objPtr) \ - if ((objPtr)->typePtr != NULL) { \ - if ((objPtr)->typePtr->freeIntRepProc != NULL) { \ - (objPtr)->typePtr->freeIntRepProc(objPtr); \ - } \ - (objPtr)->typePtr = NULL; \ + if ((objPtr)->typePtr != NULL && \ + (objPtr)->typePtr->freeIntRepProc != NULL) { \ + (objPtr)->typePtr->freeIntRepProc(objPtr); \ } /* *---------------------------------------------------------------- * Macro used by the Tcl core to clean out an object's string representation. @@ -4476,72 +3606,16 @@ * MODULE_SCOPE void TclInvalidateStringRep(Tcl_Obj *objPtr); *---------------------------------------------------------------- */ #define TclInvalidateStringRep(objPtr) \ - do { \ - Tcl_Obj *_isobjPtr = (Tcl_Obj *)(objPtr); \ - if (_isobjPtr->bytes != NULL) { \ - if (_isobjPtr->bytes != &tclEmptyString) { \ - Tcl_Free((char *)_isobjPtr->bytes); \ - } \ - _isobjPtr->bytes = NULL; \ - } \ - } while (0) - -/* - * These form part of the native filesystem support. They are needed here - * because we have a few native filesystem functions (which are the same for - * win/unix) in this file. - */ - -#ifdef __cplusplus -extern "C" { -#endif -MODULE_SCOPE const char *const tclpFileAttrStrings[]; -MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; -#ifdef __cplusplus -} -#endif - -/* - *---------------------------------------------------------------- - * Macro used by the Tcl core to test whether an object has a - * string representation (or is a 'pure' internal value). - * The ANSI C "prototype" for this macro is: - * - * MODULE_SCOPE int TclHasStringRep(Tcl_Obj *objPtr); - *---------------------------------------------------------------- - */ - -#define TclHasStringRep(objPtr) \ - ((objPtr)->bytes != NULL) - -/* - *---------------------------------------------------------------- - * Macro used by the Tcl core to get the bignum out of the bignum - * representation of a Tcl_Obj. - * The ANSI C "prototype" for this macro is: - * - * MODULE_SCOPE void TclUnpackBignum(Tcl_Obj *objPtr, mp_int bignum); - *---------------------------------------------------------------- - */ - -#define TclUnpackBignum(objPtr, bignum) \ - do { \ - Tcl_Obj *bignumObj = (objPtr); \ - int bignumPayload = \ - PTR2INT(bignumObj->internalRep.twoPtrValue.ptr2); \ - if (bignumPayload == -1) { \ - (bignum) = *((mp_int *) bignumObj->internalRep.twoPtrValue.ptr1); \ - } else { \ - (bignum).dp = (mp_digit *)bignumObj->internalRep.twoPtrValue.ptr1; \ - (bignum).sign = bignumPayload >> 30; \ - (bignum).alloc = (bignumPayload >> 15) & 0x7FFF; \ - (bignum).used = bignumPayload & 0x7FFF; \ - } \ - } while (0) + if (objPtr->bytes != NULL) { \ + if (objPtr->bytes != tclEmptyStringRep) { \ + ckfree((char *) objPtr->bytes); \ + } \ + objPtr->bytes = NULL; \ + } /* *---------------------------------------------------------------- * 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 @@ -4553,61 +3627,47 @@ * MODULE_SCOPE void TclGrowParseTokenArray(Tcl_Parse *parsePtr, * int append); *---------------------------------------------------------------- */ -/* General tuning for minimum growth in Tcl growth algorithms */ -#ifndef TCL_MIN_GROWTH -# ifdef TCL_GROWTH_MIN_ALLOC - /* Support for any legacy tuners */ -# define TCL_MIN_GROWTH TCL_GROWTH_MIN_ALLOC -# else -# define TCL_MIN_GROWTH 1024 -# endif -#endif - -/* Token growth tuning, default to the general value. */ -#ifndef TCL_MIN_TOKEN_GROWTH -#define TCL_MIN_TOKEN_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Token) -#endif - -#define TCL_MAX_TOKENS (int)(UINT_MAX / sizeof(Tcl_Token)) -#define TclGrowTokenArray(tokenPtr, used, available, append, staticPtr) \ - do { \ - int _needed = (used) + (append); \ - if (_needed > TCL_MAX_TOKENS) { \ - Tcl_Panic("max # of tokens for a Tcl parse (%d) exceeded", \ - TCL_MAX_TOKENS); \ - } \ - if (_needed > (available)) { \ - int allocated = 2 * _needed; \ - Tcl_Token *oldPtr = (tokenPtr); \ - Tcl_Token *newPtr; \ - if (oldPtr == (staticPtr)) { \ - oldPtr = NULL; \ - } \ +#define TCL_MAX_TOKENS (int)(UINT_MAX / sizeof(Tcl_Token)) +#define TCL_MIN_TOKEN_GROWTH 50 +#define TclGrowTokenArray(tokenPtr, used, available, append, staticPtr) \ +{ \ + int needed = (used) + (append); \ + if (needed > TCL_MAX_TOKENS) { \ + Tcl_Panic("max # of tokens for a Tcl parse (%d) exceeded", \ + TCL_MAX_TOKENS); \ + } \ + if (needed > (available)) { \ + int allocated = 2 * needed; \ + Tcl_Token *oldPtr = (tokenPtr); \ + Tcl_Token *newPtr; \ + if (oldPtr == (staticPtr)) { \ + oldPtr = NULL; \ + } \ + if (allocated > TCL_MAX_TOKENS) { \ + allocated = TCL_MAX_TOKENS; \ + } \ + newPtr = (Tcl_Token *) attemptckrealloc((char *) oldPtr, \ + (unsigned int) (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 *) Tcl_AttemptRealloc((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 *) Tcl_Realloc((char *) oldPtr, \ - (allocated * sizeof(Tcl_Token))); \ - } \ - (available) = allocated; \ - if (oldPtr == NULL) { \ - memcpy(newPtr, staticPtr, \ - ((used) * sizeof(Tcl_Token))); \ - } \ - (tokenPtr) = newPtr; \ - } \ - } while (0) + newPtr = (Tcl_Token *) ckrealloc((char *) oldPtr, \ + (unsigned int) (allocated * sizeof(Tcl_Token))); \ + } \ + (available) = allocated; \ + if (oldPtr == NULL) { \ + memcpy((VOID *) newPtr, (VOID *) staticPtr, \ + (size_t) ((used) * sizeof(Tcl_Token))); \ + } \ + (tokenPtr) = newPtr; \ + } \ +} #define TclGrowParseTokenArray(parsePtr, append) \ TclGrowTokenArray((parsePtr)->tokenPtr, (parsePtr)->numTokens, \ (parsePtr)->tokensAvailable, (append), \ (parsePtr)->staticTokens) @@ -4622,51 +3682,23 @@ * * 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, - * size_t numBytes); - *---------------------------------------------------------------- - */ - -#define TclNumUtfChars(numChars, bytes, numBytes) \ - do { \ - size_t _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 : \ + (((src) < (start)+2) ? (start) : \ + (UCHAR(*((src) - 1))) < 0x80 ? (src)-1 : \ Tcl_UtfPrev(src, start)) +#define TclUtfNext(src) \ + (((UCHAR(*(src))) < 0x80) ? src + 1 : Tcl_UtfNext(src)) + /* *---------------------------------------------------------------- * 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 @@ -4678,18 +3710,12 @@ * * MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); *---------------------------------------------------------------- */ -MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); -#define TclIsPureDict(objPtr) \ - (((objPtr)->bytes==NULL) && ((objPtr)->typePtr==&tclDictType)) -#define TclHasIntRep(objPtr, type) \ - ((objPtr)->typePtr == (type)) -#define TclFetchIntRep(objPtr, type) \ - (TclHasIntRep((objPtr), (type)) ? &((objPtr)->internalRep) : NULL) - +#define TclIsPureByteArray(objPtr) \ + (((objPtr)->typePtr==&tclByteArrayType) && ((objPtr)->bytes==NULL)) /* *---------------------------------------------------------------- * Macro used by the Tcl core to compare Unicode strings. On big-endian * systems we can use the more efficient memcmp, but this would not be @@ -4701,15 +3727,17 @@ *---------------------------------------------------------------- */ #ifdef WORDS_BIGENDIAN # define TclUniCharNcmp(cs,ct,n) memcmp((cs),(ct),(n)*sizeof(Tcl_UniChar)) +#else /* !WORDS_BIGENDIAN */ +# define TclUniCharNcmp Tcl_UniCharNcmp #endif /* WORDS_BIGENDIAN */ /* *---------------------------------------------------------------- - * Macro used by the Tcl core to increment a namespace's export epoch + * Macro used by the Tcl core to increment a namespace's export export epoch * counter. The ANSI C "prototype" for this macro is: * * MODULE_SCOPE void TclInvalidateNsCmdLookup(Namespace *nsPtr); *---------------------------------------------------------------- */ @@ -4723,32 +3751,21 @@ } /* *---------------------------------------------------------------------- * - * Core procedure added to libtommath for bignum manipulation. + * Core procedures added to libtommath for bignum manipulation. * *---------------------------------------------------------------------- */ -MODULE_SCOPE Tcl_PackageInitProc TclTommath_Init; - -/* - *---------------------------------------------------------------------- - * - * External (platform specific) initialization routine, these declarations - * explicitly don't use EXTERN since this code does not get compiled into the - * library: - * - *---------------------------------------------------------------------- - */ - -MODULE_SCOPE Tcl_PackageInitProc TclplatformtestInit; -MODULE_SCOPE Tcl_PackageInitProc TclObjTest_Init; -MODULE_SCOPE Tcl_PackageInitProc TclThread_Init; -MODULE_SCOPE Tcl_PackageInitProc Procbodytest_Init; -MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; +MODULE_SCOPE int TclTommath_Init(Tcl_Interp *interp); +MODULE_SCOPE void TclBNInitBignumFromLong(mp_int *bignum, long initVal); +MODULE_SCOPE void TclBNInitBignumFromWideInt(mp_int *bignum, + Tcl_WideInt initVal); +MODULE_SCOPE void TclBNInitBignumFromWideUInt(mp_int *bignum, + Tcl_WideUInt initVal); /* *---------------------------------------------------------------- * Macro used by the Tcl core to check whether a pattern has any characters * special to [string match]. The ANSI C "prototype" for this macro is: @@ -4755,106 +3772,123 @@ * * MODULE_SCOPE int TclMatchIsTrivial(const char *pattern); *---------------------------------------------------------------- */ -#define TclMatchIsTrivial(pattern) \ - (strpbrk((pattern), "*[?\\") == NULL) +#define TclMatchIsTrivial(pattern) strpbrk((pattern), "*[?\\") == NULL /* *---------------------------------------------------------------- * Macros used by the Tcl core to set a Tcl_Obj's numeric representation * avoiding the corresponding function calls in time critical parts of the * core. They should only be called on unshared objects. The ANSI C * "prototypes" for these macros are: * - * MODULE_SCOPE void TclSetIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); + * MODULE_SCOPE void TclSetIntObj(Tcl_Obj *objPtr, int intValue); + * MODULE_SCOPE void TclSetLongObj(Tcl_Obj *objPtr, long longValue); + * MODULE_SCOPE void TclSetBooleanObj(Tcl_Obj *objPtr, long boolValue); + * MODULE_SCOPE void TclSetWideIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); * MODULE_SCOPE void TclSetDoubleObj(Tcl_Obj *objPtr, double d); *---------------------------------------------------------------- */ #define TclSetIntObj(objPtr, i) \ - do { \ - Tcl_ObjIntRep ir; \ - ir.wideValue = (Tcl_WideInt) i; \ - TclInvalidateStringRep(objPtr); \ - Tcl_StoreIntRep(objPtr, &tclIntType, &ir); \ - } while (0) + TclInvalidateStringRep(objPtr);\ + TclFreeIntRep(objPtr); \ + (objPtr)->internalRep.longValue = (long)(i); \ + (objPtr)->typePtr = &tclIntType + +#define TclSetLongObj(objPtr, l) \ + TclSetIntObj((objPtr), (l)) + +/* + * NOTE: There is to be no such thing as a "pure" boolean. Boolean values set + * programmatically go straight to being "int" Tcl_Obj's, with value 0 or 1. + * The only "boolean" Tcl_Obj's shall be those holding the cached boolean + * value of strings like: "yes", "no", "true", "false", "on", "off". + */ + +#define TclSetBooleanObj(objPtr, b) \ + TclSetIntObj((objPtr), ((b)? 1 : 0)); + +#ifndef NO_WIDE_TYPE +#define TclSetWideIntObj(objPtr, w) \ + TclInvalidateStringRep(objPtr);\ + TclFreeIntRep(objPtr); \ + (objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \ + (objPtr)->typePtr = &tclWideIntType +#endif #define TclSetDoubleObj(objPtr, d) \ - do { \ - Tcl_ObjIntRep ir; \ - ir.doubleValue = (double) d; \ - TclInvalidateStringRep(objPtr); \ - Tcl_StoreIntRep(objPtr, &tclDoubleType, &ir); \ - } while (0) + TclInvalidateStringRep(objPtr);\ + TclFreeIntRep(objPtr); \ + (objPtr)->internalRep.doubleValue = (double)(d); \ + (objPtr)->typePtr = &tclDoubleType /* *---------------------------------------------------------------- * 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 TclNewIntObj(Tcl_Obj *objPtr, int i); + * MODULE_SCOPE void TclNewLongObj(Tcl_Obj *objPtr, long l); + * MODULE_SCOPE void TclNewBooleanObj(Tcl_Obj *objPtr, int b); + * MODULE_SCOPE void TclNewWideObj(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, size_t len); - * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, const char *sLiteral); + * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, char *s, int len); + * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, 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 TclNewIndexObj(objPtr, w) \ - do { \ - size_t _w = (w); \ - TclIncrObjsAllocated(); \ - TclAllocObjStorage(objPtr); \ - (objPtr)->refCount = 0; \ - (objPtr)->bytes = NULL; \ - (objPtr)->internalRep.wideValue = ((_w) == TCL_INDEX_NONE) ? -1 : (Tcl_WideInt)(_w); \ - (objPtr)->typePtr = &tclIntType; \ - TCL_DTRACE_OBJ_CREATE(objPtr); \ - } while (0) +#define TclNewIntObj(objPtr, i) \ + TclIncrObjsAllocated(); \ + TclAllocObjStorage(objPtr); \ + (objPtr)->refCount = 0; \ + (objPtr)->bytes = NULL; \ + (objPtr)->internalRep.longValue = (long)(i); \ + (objPtr)->typePtr = &tclIntType; \ + TCL_DTRACE_OBJ_CREATE(objPtr) + +#define TclNewLongObj(objPtr, l) \ + TclNewIntObj((objPtr), (l)) + +/* + * NOTE: There is to be no such thing as a "pure" boolean. + * See comment above TclSetBooleanObj macro above. + */ +#define TclNewBooleanObj(objPtr, b) \ + TclNewIntObj((objPtr), ((b)? 1 : 0)) #define TclNewDoubleObj(objPtr, d) \ - do { \ - TclIncrObjsAllocated(); \ - TclAllocObjStorage(objPtr); \ - (objPtr)->refCount = 0; \ - (objPtr)->bytes = NULL; \ - (objPtr)->internalRep.doubleValue = (double)(d); \ - (objPtr)->typePtr = &tclDoubleType; \ - TCL_DTRACE_OBJ_CREATE(objPtr); \ - } while (0) + TclIncrObjsAllocated(); \ + TclAllocObjStorage(objPtr); \ + (objPtr)->refCount = 0; \ + (objPtr)->bytes = NULL; \ + (objPtr)->internalRep.doubleValue = (double)(d); \ + (objPtr)->typePtr = &tclDoubleType; \ + TCL_DTRACE_OBJ_CREATE(objPtr) #define TclNewStringObj(objPtr, s, len) \ - do { \ - TclIncrObjsAllocated(); \ - TclAllocObjStorage(objPtr); \ - (objPtr)->refCount = 0; \ - TclInitStringRep((objPtr), (s), (len)); \ - (objPtr)->typePtr = NULL; \ - TCL_DTRACE_OBJ_CREATE(objPtr); \ - } while (0) + TclIncrObjsAllocated(); \ + TclAllocObjStorage(objPtr); \ + (objPtr)->refCount = 0; \ + TclInitStringRep((objPtr), (s), (len));\ + (objPtr)->typePtr = NULL; \ + TCL_DTRACE_OBJ_CREATE(objPtr) #else /* TCL_MEM_DEBUG */ -#define TclNewIntObj(objPtr, w) \ - (objPtr) = Tcl_NewWideIntObj(w) +#define TclNewIntObj(objPtr, i) \ + (objPtr) = Tcl_NewIntObj(i) + +#define TclNewLongObj(objPtr, l) \ + (objPtr) = Tcl_NewLongObj(l) -#define TclNewIndexObj(objPtr, w) \ - (objPtr) = ((w) == TCL_INDEX_NONE) ? Tcl_NewWideIntObj(-1) : Tcl_NewWideIntObj(w) +#define TclNewBooleanObj(objPtr, b) \ + (objPtr) = Tcl_NewBooleanObj(b) #define TclNewDoubleObj(objPtr, d) \ (objPtr) = Tcl_NewDoubleObj(d) #define TclNewStringObj(objPtr, s, len) \ @@ -4864,26 +3898,11 @@ /* * 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), 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), sizeof(sLiteral "") - 1) -#define TclDStringClear(dsPtr) \ - Tcl_DStringSetLength((dsPtr), 0) + TclNewStringObj((objPtr), (sLiteral), (int) (sizeof(sLiteral "") - 1)) /* *---------------------------------------------------------------- * Macros used by the Tcl core to test for some special double values. * The ANSI C "prototypes" for these macros are: @@ -4902,13 +3921,20 @@ # 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)) +/* + * ---------------------------------------------------------------------- + * Macro to use to find the offset of a field in a structure. Computes number + * of bytes from beginning of structure to a given field. + */ + +#ifdef offsetof +#define TclOffset(type, field) ((int) offsetof(type, field)) +#else +#define TclOffset(type, field) ((int) ((char *) &((type *) 0)->field)) #endif /* *---------------------------------------------------------------- * Inline version of Tcl_GetCurrentNamespace and Tcl_GetGlobalNamespace. @@ -4924,34 +3950,14 @@ *---------------------------------------------------------------- * Inline version of TclCleanupCommand; still need the function as it is in * the internal stubs, but the core can use the macro instead. */ -#define TclCleanupCommandMacro(cmdPtr) \ - do { \ - if ((cmdPtr)->refCount-- <= 1) { \ - Tcl_Free(cmdPtr); \ - } \ - } while (0) - - -/* - * inside this routine crement refCount first incase cmdPtr is replacing itself - */ -#define TclRoutineAssign(location, cmdPtr) \ - do { \ - (cmdPtr)->refCount++; \ - if ((location) != NULL \ - && (location--) <= 1) { \ - Tcl_Free(((location))); \ - } \ - (location) = (cmdPtr); \ - } while (0) - - -#define TclRoutineHasName(cmdPtr) \ - ((cmdPtr)->hPtr != NULL) +#define TclCleanupCommandMacro(cmdPtr) \ + if (--(cmdPtr)->refCount <= 0) { \ + ckfree((char *) (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 @@ -4972,159 +3978,14 @@ (((limit).active & TCL_LIMIT_TIME) && \ (((limit).timeGranularity == 1) || \ ((limit).granularityTicker % (limit).timeGranularity == 0)))\ ? 1 : 0))) -/* - * Compile-time assertions: these produce a compile time error if the - * expression is not known to be true at compile time. If the assertion is - * known to be false, the compiler (or optimizer?) will error out with - * "division by zero". If the assertion cannot be evaluated at compile time, - * the compiler will error out with "non-static initializer". - * - * Adapted with permission from - * http://www.pixelbeat.org/programming/gcc/static_assert.html - */ - -#define TCL_CT_ASSERT(e) \ - {enum { ct_assert_value = 1/(!!(e)) };} - -/* - *---------------------------------------------------------------- - * Allocator for small structs (<=sizeof(Tcl_Obj)) using the Tcl_Obj pool. - * Only checked at compile time. - * - * ONLY USE FOR CONSTANT nBytes. - * - * DO NOT LET THEM CROSS THREAD BOUNDARIES - *---------------------------------------------------------------- - */ - -#define TclSmallAlloc(nbytes, memPtr) \ - TclSmallAllocEx(NULL, (nbytes), (memPtr)) - -#define TclSmallFree(memPtr) \ - TclSmallFreeEx(NULL, (memPtr)) - -#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 - */ - -#if defined(PURIFY) && defined(__clang__) -#if __has_feature(attribute_analyzer_noreturn) && \ - !defined(Tcl_Panic) && defined(Tcl_Panic_TCL_DECLARED) -void Tcl_Panic(const char *, ...) __attribute__((analyzer_noreturn)); -#endif -#if !defined(CLANG_ASSERT) -#include -#define CLANG_ASSERT(x) assert(x) -#endif -#elif !defined(CLANG_ASSERT) -#define CLANG_ASSERT(x) -#endif /* PURIFY && __clang__ */ - -/* - *---------------------------------------------------------------- - * Parameters, structs and macros for the non-recursive engine (NRE) - *---------------------------------------------------------------- - */ - -#define NRE_USE_SMALL_ALLOC 1 /* Only turn off for debugging purposes. */ -#ifndef NRE_ENABLE_ASSERTS -#define NRE_ENABLE_ASSERTS 0 -#endif - -/* - * 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; - void *data[4]; - struct NRE_callback *nextPtr; -} NRE_callback; - -#define TOP_CB(iPtr) (((Interp *)(iPtr))->execEnvPtr->callbackPtr) - -/* - * Inline version of Tcl_NRAddCallback. - */ - -#define TclNRAddCallback(interp,postProcPtr,data0,data1,data2,data3) \ - do { \ - NRE_callback *_callbackPtr; \ - TCLNR_ALLOC((interp), (_callbackPtr)); \ - _callbackPtr->procPtr = (postProcPtr); \ - _callbackPtr->data[0] = (void *)(data0); \ - _callbackPtr->data[1] = (void *)(data1); \ - _callbackPtr->data[2] = (void *)(data2); \ - _callbackPtr->data[3] = (void *)(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 = (Tcl_Alloc(sizeof(NRE_callback)))) -#define TCLNR_FREE(interp, ptr) Tcl_Free(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 TclpAlloc -#define Tcl_AttemptRealloc TclpRealloc -#define Tcl_Free TclpFree -#endif +#include "tclTomMathDecls.h" #endif /* _TCLINT */ /* * Local Variables: Index: generic/tclIntDecls.h ================================================================== --- generic/tclIntDecls.h +++ generic/tclIntDecls.h @@ -13,10 +13,11 @@ */ #ifndef _TCLINTDECLS #define _TCLINTDECLS +#include "tclPort.h" #undef TCL_STORAGE_CLASS #ifdef BUILD_tcl # define TCL_STORAGE_CLASS DLLEXPORT #else @@ -24,10 +25,24 @@ # define TCL_STORAGE_CLASS # else # define TCL_STORAGE_CLASS DLLIMPORT # endif #endif + +/* [Bug #803489] Tcl_FindNamespace problem in the Stubs table */ +#undef Tcl_CreateNamespace +#undef Tcl_DeleteNamespace +#undef Tcl_AppendExportList +#undef Tcl_Export +#undef Tcl_Import +#undef Tcl_ForgetImport +#undef Tcl_GetCurrentNamespace +#undef Tcl_GetGlobalNamespace +#undef Tcl_FindNamespace +#undef Tcl_FindCommand +#undef Tcl_GetCommandFromObj +#undef Tcl_GetCommandFullName /* * 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. @@ -44,367 +59,786 @@ */ /* Slot 0 is reserved */ /* Slot 1 is reserved */ /* Slot 2 is reserved */ +#ifndef TclAllocateFreeObjects_TCL_DECLARED +#define TclAllocateFreeObjects_TCL_DECLARED /* 3 */ EXTERN void TclAllocateFreeObjects(void); +#endif /* Slot 4 is reserved */ +#ifndef TclCleanupChildren_TCL_DECLARED +#define TclCleanupChildren_TCL_DECLARED /* 5 */ EXTERN int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); +#endif +#ifndef TclCleanupCommand_TCL_DECLARED +#define TclCleanupCommand_TCL_DECLARED /* 6 */ EXTERN void TclCleanupCommand(Command *cmdPtr); +#endif +#ifndef TclCopyAndCollapse_TCL_DECLARED +#define TclCopyAndCollapse_TCL_DECLARED /* 7 */ -EXTERN size_t TclCopyAndCollapse(size_t count, const char *src, +EXTERN int TclCopyAndCollapse(int count, CONST char *src, char *dst); -/* Slot 8 is reserved */ +#endif +#ifndef TclCopyChannel_TCL_DECLARED +#define TclCopyChannel_TCL_DECLARED +/* 8 */ +EXTERN int TclCopyChannel(Tcl_Interp *interp, + Tcl_Channel inChan, Tcl_Channel outChan, + int toRead, Tcl_Obj *cmdPtr); +#endif +#ifndef TclCreatePipeline_TCL_DECLARED +#define TclCreatePipeline_TCL_DECLARED /* 9 */ EXTERN int TclCreatePipeline(Tcl_Interp *interp, int argc, - const char **argv, Tcl_Pid **pidArrayPtr, + CONST char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); +#endif +#ifndef TclCreateProc_TCL_DECLARED +#define TclCreateProc_TCL_DECLARED /* 10 */ EXTERN int TclCreateProc(Tcl_Interp *interp, Namespace *nsPtr, - const char *procName, Tcl_Obj *argsPtr, + CONST char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr); +#endif +#ifndef TclDeleteCompiledLocalVars_TCL_DECLARED +#define TclDeleteCompiledLocalVars_TCL_DECLARED /* 11 */ EXTERN void TclDeleteCompiledLocalVars(Interp *iPtr, CallFrame *framePtr); +#endif +#ifndef TclDeleteVars_TCL_DECLARED +#define TclDeleteVars_TCL_DECLARED /* 12 */ EXTERN void TclDeleteVars(Interp *iPtr, TclVarHashTable *tablePtr); +#endif /* Slot 13 is reserved */ +#ifndef TclDumpMemoryInfo_TCL_DECLARED +#define TclDumpMemoryInfo_TCL_DECLARED /* 14 */ -EXTERN int TclDumpMemoryInfo(void *clientData, int flags); +EXTERN int TclDumpMemoryInfo(ClientData clientData, int flags); +#endif /* Slot 15 is reserved */ +#ifndef TclExprFloatError_TCL_DECLARED +#define TclExprFloatError_TCL_DECLARED /* 16 */ EXTERN void TclExprFloatError(Tcl_Interp *interp, double value); +#endif /* Slot 17 is reserved */ /* Slot 18 is reserved */ /* Slot 19 is reserved */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ +#ifndef TclFindElement_TCL_DECLARED +#define TclFindElement_TCL_DECLARED /* 22 */ EXTERN int TclFindElement(Tcl_Interp *interp, - const char *listStr, int listLength, - const char **elementPtr, - const char **nextPtr, size_t *sizePtr, + CONST char *listStr, int listLength, + CONST char **elementPtr, + CONST char **nextPtr, int *sizePtr, int *bracePtr); +#endif +#ifndef TclFindProc_TCL_DECLARED +#define TclFindProc_TCL_DECLARED /* 23 */ -EXTERN Proc * TclFindProc(Interp *iPtr, const char *procName); +EXTERN Proc * TclFindProc(Interp *iPtr, CONST char *procName); +#endif +#ifndef TclFormatInt_TCL_DECLARED +#define TclFormatInt_TCL_DECLARED /* 24 */ -EXTERN size_t TclFormatInt(char *buffer, Tcl_WideInt n); +EXTERN int TclFormatInt(char *buffer, long n); +#endif +#ifndef TclFreePackageInfo_TCL_DECLARED +#define TclFreePackageInfo_TCL_DECLARED /* 25 */ EXTERN void TclFreePackageInfo(Interp *iPtr); +#endif /* Slot 26 is reserved */ /* Slot 27 is reserved */ +#ifndef TclpGetDefaultStdChannel_TCL_DECLARED +#define TclpGetDefaultStdChannel_TCL_DECLARED /* 28 */ EXTERN Tcl_Channel TclpGetDefaultStdChannel(int type); +#endif /* Slot 29 is reserved */ /* Slot 30 is reserved */ +#ifndef TclGetExtension_TCL_DECLARED +#define TclGetExtension_TCL_DECLARED /* 31 */ -EXTERN const char * TclGetExtension(const char *name); +EXTERN CONST char * TclGetExtension(CONST char *name); +#endif +#ifndef TclGetFrame_TCL_DECLARED +#define TclGetFrame_TCL_DECLARED /* 32 */ -EXTERN int TclGetFrame(Tcl_Interp *interp, const char *str, +EXTERN int TclGetFrame(Tcl_Interp *interp, CONST char *str, CallFrame **framePtrPtr); +#endif /* Slot 33 is reserved */ -/* Slot 34 is reserved */ +#ifndef TclGetIntForIndex_TCL_DECLARED +#define TclGetIntForIndex_TCL_DECLARED +/* 34 */ +EXTERN int TclGetIntForIndex(Tcl_Interp *interp, + Tcl_Obj *objPtr, int endValue, int *indexPtr); +#endif /* Slot 35 is reserved */ -/* Slot 36 is reserved */ +#ifndef TclGetLong_TCL_DECLARED +#define TclGetLong_TCL_DECLARED +/* 36 */ +EXTERN int TclGetLong(Tcl_Interp *interp, CONST char *str, + long *longPtr); +#endif +#ifndef TclGetLoadedPackages_TCL_DECLARED +#define TclGetLoadedPackages_TCL_DECLARED /* 37 */ EXTERN int TclGetLoadedPackages(Tcl_Interp *interp, - const char *targetName); + char *targetName); +#endif +#ifndef TclGetNamespaceForQualName_TCL_DECLARED +#define TclGetNamespaceForQualName_TCL_DECLARED /* 38 */ EXTERN int TclGetNamespaceForQualName(Tcl_Interp *interp, - const char *qualName, Namespace *cxtNsPtr, + CONST char *qualName, Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, - const char **simpleNamePtr); + CONST char **simpleNamePtr); +#endif +#ifndef TclGetObjInterpProc_TCL_DECLARED +#define TclGetObjInterpProc_TCL_DECLARED /* 39 */ EXTERN TclObjCmdProcType TclGetObjInterpProc(void); +#endif +#ifndef TclGetOpenMode_TCL_DECLARED +#define TclGetOpenMode_TCL_DECLARED /* 40 */ -EXTERN int TclGetOpenMode(Tcl_Interp *interp, const char *str, +EXTERN int TclGetOpenMode(Tcl_Interp *interp, CONST char *str, int *seekFlagPtr); +#endif +#ifndef TclGetOriginalCommand_TCL_DECLARED +#define TclGetOriginalCommand_TCL_DECLARED /* 41 */ EXTERN Tcl_Command TclGetOriginalCommand(Tcl_Command command); +#endif +#ifndef TclpGetUserHome_TCL_DECLARED +#define TclpGetUserHome_TCL_DECLARED /* 42 */ -EXTERN const char * TclpGetUserHome(const char *name, +EXTERN char * TclpGetUserHome(CONST char *name, Tcl_DString *bufferPtr); +#endif /* Slot 43 is reserved */ +#ifndef TclGuessPackageName_TCL_DECLARED +#define TclGuessPackageName_TCL_DECLARED /* 44 */ -EXTERN int TclGuessPackageName(const char *fileName, +EXTERN int TclGuessPackageName(CONST char *fileName, Tcl_DString *bufPtr); +#endif +#ifndef TclHideUnsafeCommands_TCL_DECLARED +#define TclHideUnsafeCommands_TCL_DECLARED /* 45 */ EXTERN int TclHideUnsafeCommands(Tcl_Interp *interp); +#endif +#ifndef TclInExit_TCL_DECLARED +#define TclInExit_TCL_DECLARED /* 46 */ EXTERN int TclInExit(void); +#endif /* Slot 47 is reserved */ /* Slot 48 is reserved */ /* Slot 49 is reserved */ -/* Slot 50 is reserved */ +#ifndef TclInitCompiledLocals_TCL_DECLARED +#define TclInitCompiledLocals_TCL_DECLARED +/* 50 */ +EXTERN void TclInitCompiledLocals(Tcl_Interp *interp, + CallFrame *framePtr, Namespace *nsPtr); +#endif +#ifndef TclInterpInit_TCL_DECLARED +#define TclInterpInit_TCL_DECLARED /* 51 */ EXTERN int TclInterpInit(Tcl_Interp *interp); +#endif /* Slot 52 is reserved */ +#ifndef TclInvokeObjectCommand_TCL_DECLARED +#define TclInvokeObjectCommand_TCL_DECLARED /* 53 */ -EXTERN int TclInvokeObjectCommand(void *clientData, +EXTERN int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp, int argc, - const char **argv); + CONST84 char **argv); +#endif +#ifndef TclInvokeStringCommand_TCL_DECLARED +#define TclInvokeStringCommand_TCL_DECLARED /* 54 */ -EXTERN int TclInvokeStringCommand(void *clientData, +EXTERN int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); + Tcl_Obj *CONST objv[]); +#endif +#ifndef TclIsProc_TCL_DECLARED +#define TclIsProc_TCL_DECLARED /* 55 */ EXTERN Proc * TclIsProc(Command *cmdPtr); +#endif /* Slot 56 is reserved */ /* Slot 57 is reserved */ +#ifndef TclLookupVar_TCL_DECLARED +#define TclLookupVar_TCL_DECLARED /* 58 */ -EXTERN Var * TclLookupVar(Tcl_Interp *interp, const char *part1, - const char *part2, int flags, - const char *msg, int createPart1, +EXTERN Var * TclLookupVar(Tcl_Interp *interp, CONST char *part1, + CONST char *part2, int flags, + CONST char *msg, int createPart1, int createPart2, Var **arrayPtrPtr); +#endif /* Slot 59 is reserved */ +#ifndef TclNeedSpace_TCL_DECLARED +#define TclNeedSpace_TCL_DECLARED /* 60 */ -EXTERN int TclNeedSpace(const char *start, const char *end); +EXTERN int TclNeedSpace(CONST char *start, CONST char *end); +#endif +#ifndef TclNewProcBodyObj_TCL_DECLARED +#define TclNewProcBodyObj_TCL_DECLARED /* 61 */ EXTERN Tcl_Obj * TclNewProcBodyObj(Proc *procPtr); +#endif +#ifndef TclObjCommandComplete_TCL_DECLARED +#define TclObjCommandComplete_TCL_DECLARED /* 62 */ EXTERN int TclObjCommandComplete(Tcl_Obj *cmdPtr); +#endif +#ifndef TclObjInterpProc_TCL_DECLARED +#define TclObjInterpProc_TCL_DECLARED /* 63 */ -EXTERN int TclObjInterpProc(void *clientData, +EXTERN int TclObjInterpProc(ClientData clientData, Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); + Tcl_Obj *CONST objv[]); +#endif +#ifndef TclObjInvoke_TCL_DECLARED +#define TclObjInvoke_TCL_DECLARED /* 64 */ EXTERN int TclObjInvoke(Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[], int flags); + Tcl_Obj *CONST objv[], int flags); +#endif /* Slot 65 is reserved */ /* Slot 66 is reserved */ /* Slot 67 is reserved */ /* Slot 68 is reserved */ +#ifndef TclpAlloc_TCL_DECLARED +#define TclpAlloc_TCL_DECLARED /* 69 */ -EXTERN void * TclpAlloc(size_t size); +EXTERN char * TclpAlloc(unsigned int size); +#endif /* Slot 70 is reserved */ /* Slot 71 is reserved */ /* Slot 72 is reserved */ /* Slot 73 is reserved */ +#ifndef TclpFree_TCL_DECLARED +#define TclpFree_TCL_DECLARED /* 74 */ -EXTERN void TclpFree(void *ptr); +EXTERN void TclpFree(char *ptr); +#endif +#ifndef TclpGetClicks_TCL_DECLARED +#define TclpGetClicks_TCL_DECLARED /* 75 */ -EXTERN Tcl_WideUInt TclpGetClicks(void); +EXTERN unsigned long TclpGetClicks(void); +#endif +#ifndef TclpGetSeconds_TCL_DECLARED +#define TclpGetSeconds_TCL_DECLARED /* 76 */ -EXTERN Tcl_WideUInt TclpGetSeconds(void); -/* Slot 77 is reserved */ -/* Slot 78 is reserved */ +EXTERN unsigned long TclpGetSeconds(void); +#endif +#ifndef TclpGetTime_TCL_DECLARED +#define TclpGetTime_TCL_DECLARED +/* 77 */ +EXTERN void TclpGetTime(Tcl_Time *time); +#endif +#ifndef TclpGetTimeZone_TCL_DECLARED +#define TclpGetTimeZone_TCL_DECLARED +/* 78 */ +EXTERN int TclpGetTimeZone(unsigned long time); +#endif /* Slot 79 is reserved */ /* Slot 80 is reserved */ +#ifndef TclpRealloc_TCL_DECLARED +#define TclpRealloc_TCL_DECLARED /* 81 */ -EXTERN void * TclpRealloc(void *ptr, size_t size); +EXTERN char * TclpRealloc(char *ptr, unsigned int size); +#endif /* Slot 82 is reserved */ /* Slot 83 is reserved */ /* Slot 84 is reserved */ /* Slot 85 is reserved */ /* Slot 86 is reserved */ /* Slot 87 is reserved */ -/* Slot 88 is reserved */ +#ifndef TclPrecTraceProc_TCL_DECLARED +#define TclPrecTraceProc_TCL_DECLARED +/* 88 */ +EXTERN char * TclPrecTraceProc(ClientData clientData, + Tcl_Interp *interp, CONST char *name1, + CONST char *name2, int flags); +#endif +#ifndef TclPreventAliasLoop_TCL_DECLARED +#define TclPreventAliasLoop_TCL_DECLARED /* 89 */ EXTERN int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp, Tcl_Command cmd); +#endif /* Slot 90 is reserved */ +#ifndef TclProcCleanupProc_TCL_DECLARED +#define TclProcCleanupProc_TCL_DECLARED /* 91 */ EXTERN void TclProcCleanupProc(Proc *procPtr); +#endif +#ifndef TclProcCompileProc_TCL_DECLARED +#define TclProcCompileProc_TCL_DECLARED /* 92 */ EXTERN int TclProcCompileProc(Tcl_Interp *interp, Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr, - const char *description, - const char *procName); + CONST char *description, + CONST char *procName); +#endif +#ifndef TclProcDeleteProc_TCL_DECLARED +#define TclProcDeleteProc_TCL_DECLARED /* 93 */ -EXTERN void TclProcDeleteProc(void *clientData); +EXTERN void TclProcDeleteProc(ClientData clientData); +#endif /* Slot 94 is reserved */ /* Slot 95 is reserved */ +#ifndef TclRenameCommand_TCL_DECLARED +#define TclRenameCommand_TCL_DECLARED /* 96 */ EXTERN int TclRenameCommand(Tcl_Interp *interp, - const char *oldName, const char *newName); + CONST char *oldName, CONST char *newName); +#endif +#ifndef TclResetShadowedCmdRefs_TCL_DECLARED +#define TclResetShadowedCmdRefs_TCL_DECLARED /* 97 */ EXTERN void TclResetShadowedCmdRefs(Tcl_Interp *interp, Command *newCmdPtr); +#endif +#ifndef TclServiceIdle_TCL_DECLARED +#define TclServiceIdle_TCL_DECLARED /* 98 */ EXTERN int TclServiceIdle(void); +#endif /* Slot 99 is reserved */ /* Slot 100 is reserved */ +#ifndef TclSetPreInitScript_TCL_DECLARED +#define TclSetPreInitScript_TCL_DECLARED /* 101 */ -EXTERN const char * TclSetPreInitScript(const char *string); +EXTERN char * TclSetPreInitScript(char *string); +#endif +#ifndef TclSetupEnv_TCL_DECLARED +#define TclSetupEnv_TCL_DECLARED /* 102 */ EXTERN void TclSetupEnv(Tcl_Interp *interp); +#endif +#ifndef TclSockGetPort_TCL_DECLARED +#define TclSockGetPort_TCL_DECLARED /* 103 */ -EXTERN int TclSockGetPort(Tcl_Interp *interp, const char *str, - const char *proto, int *portPtr); -/* Slot 104 is reserved */ +EXTERN int TclSockGetPort(Tcl_Interp *interp, CONST char *str, + CONST char *proto, int *portPtr); +#endif +#ifndef TclSockMinimumBuffersOld_TCL_DECLARED +#define TclSockMinimumBuffersOld_TCL_DECLARED +/* 104 */ +EXTERN int TclSockMinimumBuffersOld(int sock, int size); +#endif /* Slot 105 is reserved */ /* Slot 106 is reserved */ /* Slot 107 is reserved */ +#ifndef TclTeardownNamespace_TCL_DECLARED +#define TclTeardownNamespace_TCL_DECLARED /* 108 */ EXTERN void TclTeardownNamespace(Namespace *nsPtr); +#endif +#ifndef TclUpdateReturnInfo_TCL_DECLARED +#define TclUpdateReturnInfo_TCL_DECLARED /* 109 */ EXTERN int TclUpdateReturnInfo(Interp *iPtr); +#endif +#ifndef TclSockMinimumBuffers_TCL_DECLARED +#define TclSockMinimumBuffers_TCL_DECLARED /* 110 */ -EXTERN int TclSockMinimumBuffers(void *sock, int size); +EXTERN int TclSockMinimumBuffers(VOID *sock, int size); +#endif +#ifndef Tcl_AddInterpResolvers_TCL_DECLARED +#define Tcl_AddInterpResolvers_TCL_DECLARED /* 111 */ EXTERN void Tcl_AddInterpResolvers(Tcl_Interp *interp, - const char *name, + CONST char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); -/* Slot 112 is reserved */ -/* Slot 113 is reserved */ -/* Slot 114 is reserved */ -/* Slot 115 is reserved */ -/* Slot 116 is reserved */ -/* Slot 117 is reserved */ +#endif +#ifndef Tcl_AppendExportList_TCL_DECLARED +#define Tcl_AppendExportList_TCL_DECLARED +/* 112 */ +EXTERN int Tcl_AppendExportList(Tcl_Interp *interp, + Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); +#endif +#ifndef Tcl_CreateNamespace_TCL_DECLARED +#define Tcl_CreateNamespace_TCL_DECLARED +/* 113 */ +EXTERN Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp, + CONST char *name, ClientData clientData, + Tcl_NamespaceDeleteProc *deleteProc); +#endif +#ifndef Tcl_DeleteNamespace_TCL_DECLARED +#define Tcl_DeleteNamespace_TCL_DECLARED +/* 114 */ +EXTERN void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr); +#endif +#ifndef Tcl_Export_TCL_DECLARED +#define Tcl_Export_TCL_DECLARED +/* 115 */ +EXTERN int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + CONST char *pattern, int resetListFirst); +#endif +#ifndef Tcl_FindCommand_TCL_DECLARED +#define Tcl_FindCommand_TCL_DECLARED +/* 116 */ +EXTERN Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, CONST char *name, + Tcl_Namespace *contextNsPtr, int flags); +#endif +#ifndef Tcl_FindNamespace_TCL_DECLARED +#define Tcl_FindNamespace_TCL_DECLARED +/* 117 */ +EXTERN Tcl_Namespace * Tcl_FindNamespace(Tcl_Interp *interp, + CONST char *name, + Tcl_Namespace *contextNsPtr, int flags); +#endif +#ifndef Tcl_GetInterpResolvers_TCL_DECLARED +#define Tcl_GetInterpResolvers_TCL_DECLARED /* 118 */ EXTERN int Tcl_GetInterpResolvers(Tcl_Interp *interp, - const char *name, Tcl_ResolverInfo *resInfo); + CONST char *name, Tcl_ResolverInfo *resInfo); +#endif +#ifndef Tcl_GetNamespaceResolvers_TCL_DECLARED +#define Tcl_GetNamespaceResolvers_TCL_DECLARED /* 119 */ EXTERN int Tcl_GetNamespaceResolvers( Tcl_Namespace *namespacePtr, Tcl_ResolverInfo *resInfo); +#endif +#ifndef Tcl_FindNamespaceVar_TCL_DECLARED +#define Tcl_FindNamespaceVar_TCL_DECLARED /* 120 */ EXTERN Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, - const char *name, + CONST char *name, Tcl_Namespace *contextNsPtr, int flags); -/* Slot 121 is reserved */ -/* Slot 122 is reserved */ -/* Slot 123 is reserved */ -/* Slot 124 is reserved */ -/* Slot 125 is reserved */ +#endif +#ifndef Tcl_ForgetImport_TCL_DECLARED +#define Tcl_ForgetImport_TCL_DECLARED +/* 121 */ +EXTERN int Tcl_ForgetImport(Tcl_Interp *interp, + Tcl_Namespace *nsPtr, CONST char *pattern); +#endif +#ifndef Tcl_GetCommandFromObj_TCL_DECLARED +#define Tcl_GetCommandFromObj_TCL_DECLARED +/* 122 */ +EXTERN Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr); +#endif +#ifndef Tcl_GetCommandFullName_TCL_DECLARED +#define Tcl_GetCommandFullName_TCL_DECLARED +/* 123 */ +EXTERN void Tcl_GetCommandFullName(Tcl_Interp *interp, + Tcl_Command command, Tcl_Obj *objPtr); +#endif +#ifndef Tcl_GetCurrentNamespace_TCL_DECLARED +#define Tcl_GetCurrentNamespace_TCL_DECLARED +/* 124 */ +EXTERN Tcl_Namespace * Tcl_GetCurrentNamespace(Tcl_Interp *interp); +#endif +#ifndef Tcl_GetGlobalNamespace_TCL_DECLARED +#define Tcl_GetGlobalNamespace_TCL_DECLARED +/* 125 */ +EXTERN Tcl_Namespace * Tcl_GetGlobalNamespace(Tcl_Interp *interp); +#endif +#ifndef Tcl_GetVariableFullName_TCL_DECLARED +#define Tcl_GetVariableFullName_TCL_DECLARED /* 126 */ EXTERN void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); -/* Slot 127 is reserved */ +#endif +#ifndef Tcl_Import_TCL_DECLARED +#define Tcl_Import_TCL_DECLARED +/* 127 */ +EXTERN int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + CONST char *pattern, int allowOverwrite); +#endif +#ifndef Tcl_PopCallFrame_TCL_DECLARED +#define Tcl_PopCallFrame_TCL_DECLARED /* 128 */ EXTERN void Tcl_PopCallFrame(Tcl_Interp *interp); +#endif +#ifndef Tcl_PushCallFrame_TCL_DECLARED +#define Tcl_PushCallFrame_TCL_DECLARED /* 129 */ EXTERN int Tcl_PushCallFrame(Tcl_Interp *interp, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame); +#endif +#ifndef Tcl_RemoveInterpResolvers_TCL_DECLARED +#define Tcl_RemoveInterpResolvers_TCL_DECLARED /* 130 */ EXTERN int Tcl_RemoveInterpResolvers(Tcl_Interp *interp, - const char *name); + CONST char *name); +#endif +#ifndef Tcl_SetNamespaceResolvers_TCL_DECLARED +#define Tcl_SetNamespaceResolvers_TCL_DECLARED /* 131 */ EXTERN void Tcl_SetNamespaceResolvers( Tcl_Namespace *namespacePtr, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); +#endif +#ifndef TclpHasSockets_TCL_DECLARED +#define TclpHasSockets_TCL_DECLARED /* 132 */ EXTERN int TclpHasSockets(Tcl_Interp *interp); -/* Slot 133 is reserved */ +#endif +#ifndef TclpGetDate_TCL_DECLARED +#define TclpGetDate_TCL_DECLARED +/* 133 */ +EXTERN struct tm * TclpGetDate(CONST time_t *time, int useGMT); +#endif /* Slot 134 is reserved */ /* Slot 135 is reserved */ /* Slot 136 is reserved */ /* Slot 137 is reserved */ +#ifndef TclGetEnv_TCL_DECLARED +#define TclGetEnv_TCL_DECLARED /* 138 */ -EXTERN const char * TclGetEnv(const char *name, Tcl_DString *valuePtr); +EXTERN CONST84_RETURN char * TclGetEnv(CONST char *name, + Tcl_DString *valuePtr); +#endif /* Slot 139 is reserved */ /* Slot 140 is reserved */ +#ifndef TclpGetCwd_TCL_DECLARED +#define TclpGetCwd_TCL_DECLARED /* 141 */ -EXTERN const char * TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr); +EXTERN CONST84_RETURN char * TclpGetCwd(Tcl_Interp *interp, + Tcl_DString *cwdPtr); +#endif +#ifndef TclSetByteCodeFromAny_TCL_DECLARED +#define TclSetByteCodeFromAny_TCL_DECLARED /* 142 */ EXTERN int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, - void *clientData); + ClientData clientData); +#endif +#ifndef TclAddLiteralObj_TCL_DECLARED +#define TclAddLiteralObj_TCL_DECLARED /* 143 */ EXTERN int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); +#endif +#ifndef TclHideLiteral_TCL_DECLARED +#define TclHideLiteral_TCL_DECLARED /* 144 */ EXTERN void TclHideLiteral(Tcl_Interp *interp, struct CompileEnv *envPtr, int index); +#endif +#ifndef TclGetAuxDataType_TCL_DECLARED +#define TclGetAuxDataType_TCL_DECLARED /* 145 */ -EXTERN const struct AuxDataType * TclGetAuxDataType(const char *typeName); +EXTERN struct AuxDataType * TclGetAuxDataType(char *typeName); +#endif +#ifndef TclHandleCreate_TCL_DECLARED +#define TclHandleCreate_TCL_DECLARED /* 146 */ -EXTERN TclHandle TclHandleCreate(void *ptr); +EXTERN TclHandle TclHandleCreate(VOID *ptr); +#endif +#ifndef TclHandleFree_TCL_DECLARED +#define TclHandleFree_TCL_DECLARED /* 147 */ EXTERN void TclHandleFree(TclHandle handle); +#endif +#ifndef TclHandlePreserve_TCL_DECLARED +#define TclHandlePreserve_TCL_DECLARED /* 148 */ EXTERN TclHandle TclHandlePreserve(TclHandle handle); +#endif +#ifndef TclHandleRelease_TCL_DECLARED +#define TclHandleRelease_TCL_DECLARED /* 149 */ EXTERN void TclHandleRelease(TclHandle handle); +#endif +#ifndef TclRegAbout_TCL_DECLARED +#define TclRegAbout_TCL_DECLARED /* 150 */ EXTERN int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re); +#endif +#ifndef TclRegExpRangeUniChar_TCL_DECLARED +#define TclRegExpRangeUniChar_TCL_DECLARED /* 151 */ -EXTERN void TclRegExpRangeUniChar(Tcl_RegExp re, size_t index, - size_t *startPtr, size_t *endPtr); +EXTERN void TclRegExpRangeUniChar(Tcl_RegExp re, int index, + int *startPtr, int *endPtr); +#endif +#ifndef TclSetLibraryPath_TCL_DECLARED +#define TclSetLibraryPath_TCL_DECLARED /* 152 */ EXTERN void TclSetLibraryPath(Tcl_Obj *pathPtr); +#endif +#ifndef TclGetLibraryPath_TCL_DECLARED +#define TclGetLibraryPath_TCL_DECLARED /* 153 */ EXTERN Tcl_Obj * TclGetLibraryPath(void); +#endif /* Slot 154 is reserved */ /* Slot 155 is reserved */ +#ifndef TclRegError_TCL_DECLARED +#define TclRegError_TCL_DECLARED /* 156 */ -EXTERN void TclRegError(Tcl_Interp *interp, const char *msg, +EXTERN void TclRegError(Tcl_Interp *interp, CONST char *msg, int status); +#endif +#ifndef TclVarTraceExists_TCL_DECLARED +#define TclVarTraceExists_TCL_DECLARED /* 157 */ EXTERN Var * TclVarTraceExists(Tcl_Interp *interp, - const char *varName); -/* Slot 158 is reserved */ -/* Slot 159 is reserved */ + CONST char *varName); +#endif +#ifndef TclSetStartupScriptFileName_TCL_DECLARED +#define TclSetStartupScriptFileName_TCL_DECLARED +/* 158 */ +EXTERN void TclSetStartupScriptFileName(CONST char *filename); +#endif +#ifndef TclGetStartupScriptFileName_TCL_DECLARED +#define TclGetStartupScriptFileName_TCL_DECLARED +/* 159 */ +EXTERN CONST84_RETURN char * TclGetStartupScriptFileName(void); +#endif /* Slot 160 is reserved */ +#ifndef TclChannelTransform_TCL_DECLARED +#define TclChannelTransform_TCL_DECLARED /* 161 */ EXTERN int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); +#endif +#ifndef TclChannelEventScriptInvoker_TCL_DECLARED +#define TclChannelEventScriptInvoker_TCL_DECLARED /* 162 */ -EXTERN void TclChannelEventScriptInvoker(void *clientData, +EXTERN void TclChannelEventScriptInvoker(ClientData clientData, int flags); +#endif +#ifndef TclGetInstructionTable_TCL_DECLARED +#define TclGetInstructionTable_TCL_DECLARED /* 163 */ -EXTERN const void * TclGetInstructionTable(void); +EXTERN VOID * TclGetInstructionTable(void); +#endif +#ifndef TclExpandCodeArray_TCL_DECLARED +#define TclExpandCodeArray_TCL_DECLARED /* 164 */ -EXTERN void TclExpandCodeArray(void *envPtr); +EXTERN void TclExpandCodeArray(VOID *envPtr); +#endif +#ifndef TclpSetInitialEncodings_TCL_DECLARED +#define TclpSetInitialEncodings_TCL_DECLARED /* 165 */ EXTERN void TclpSetInitialEncodings(void); +#endif +#ifndef TclListObjSetElement_TCL_DECLARED +#define TclListObjSetElement_TCL_DECLARED /* 166 */ EXTERN int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); -/* Slot 167 is reserved */ -/* Slot 168 is reserved */ +#endif +#ifndef TclSetStartupScriptPath_TCL_DECLARED +#define TclSetStartupScriptPath_TCL_DECLARED +/* 167 */ +EXTERN void TclSetStartupScriptPath(Tcl_Obj *pathPtr); +#endif +#ifndef TclGetStartupScriptPath_TCL_DECLARED +#define TclGetStartupScriptPath_TCL_DECLARED +/* 168 */ +EXTERN Tcl_Obj * TclGetStartupScriptPath(void); +#endif +#ifndef TclpUtfNcmp2_TCL_DECLARED +#define TclpUtfNcmp2_TCL_DECLARED /* 169 */ -EXTERN int TclpUtfNcmp2(const char *s1, const char *s2, - size_t n); +EXTERN int TclpUtfNcmp2(CONST char *s1, CONST char *s2, + unsigned long n); +#endif +#ifndef TclCheckInterpTraces_TCL_DECLARED +#define TclCheckInterpTraces_TCL_DECLARED /* 170 */ EXTERN int TclCheckInterpTraces(Tcl_Interp *interp, - const char *command, size_t numChars, + CONST char *command, int numChars, Command *cmdPtr, int result, int traceFlags, - int objc, Tcl_Obj *const objv[]); + int objc, Tcl_Obj *CONST objv[]); +#endif +#ifndef TclCheckExecutionTraces_TCL_DECLARED +#define TclCheckExecutionTraces_TCL_DECLARED /* 171 */ EXTERN int TclCheckExecutionTraces(Tcl_Interp *interp, - const char *command, size_t numChars, + CONST char *command, int numChars, Command *cmdPtr, int result, int traceFlags, - int objc, Tcl_Obj *const objv[]); + int objc, Tcl_Obj *CONST objv[]); +#endif +#ifndef TclInThreadExit_TCL_DECLARED +#define TclInThreadExit_TCL_DECLARED /* 172 */ EXTERN int TclInThreadExit(void); +#endif +#ifndef TclUniCharMatch_TCL_DECLARED +#define TclUniCharMatch_TCL_DECLARED /* 173 */ -EXTERN int TclUniCharMatch(const Tcl_UniChar *string, - size_t strLen, const Tcl_UniChar *pattern, - size_t ptnLen, int flags); +EXTERN int TclUniCharMatch(CONST Tcl_UniChar *string, + int strLen, CONST Tcl_UniChar *pattern, + int ptnLen, int flags); +#endif /* Slot 174 is reserved */ +#ifndef TclCallVarTraces_TCL_DECLARED +#define TclCallVarTraces_TCL_DECLARED /* 175 */ EXTERN int TclCallVarTraces(Interp *iPtr, Var *arrayPtr, - Var *varPtr, const char *part1, - const char *part2, int flags, + Var *varPtr, CONST char *part1, + CONST char *part2, int flags, int leaveErrMsg); +#endif +#ifndef TclCleanupVar_TCL_DECLARED +#define TclCleanupVar_TCL_DECLARED /* 176 */ EXTERN void TclCleanupVar(Var *varPtr, Var *arrayPtr); +#endif +#ifndef TclVarErrMsg_TCL_DECLARED +#define TclVarErrMsg_TCL_DECLARED /* 177 */ -EXTERN void TclVarErrMsg(Tcl_Interp *interp, const char *part1, - const char *part2, const char *operation, - const char *reason); -/* Slot 178 is reserved */ -/* Slot 179 is reserved */ +EXTERN void TclVarErrMsg(Tcl_Interp *interp, CONST char *part1, + CONST char *part2, CONST char *operation, + CONST char *reason); +#endif +#ifndef Tcl_SetStartupScript_TCL_DECLARED +#define Tcl_SetStartupScript_TCL_DECLARED +/* 178 */ +EXTERN void Tcl_SetStartupScript(Tcl_Obj *pathPtr, + CONST char *encodingName); +#endif +#ifndef Tcl_GetStartupScript_TCL_DECLARED +#define Tcl_GetStartupScript_TCL_DECLARED +/* 179 */ +EXTERN Tcl_Obj * Tcl_GetStartupScript(CONST char **encodingNamePtr); +#endif /* Slot 180 is reserved */ /* Slot 181 is reserved */ -/* Slot 182 is reserved */ -/* Slot 183 is reserved */ +#ifndef TclpLocaltime_TCL_DECLARED +#define TclpLocaltime_TCL_DECLARED +/* 182 */ +EXTERN struct tm * TclpLocaltime(CONST time_t *clock); +#endif +#ifndef TclpGmtime_TCL_DECLARED +#define TclpGmtime_TCL_DECLARED +/* 183 */ +EXTERN struct tm * TclpGmtime(CONST time_t *clock); +#endif /* Slot 184 is reserved */ /* Slot 185 is reserved */ /* Slot 186 is reserved */ /* Slot 187 is reserved */ /* Slot 188 is reserved */ @@ -415,738 +849,1077 @@ /* Slot 193 is reserved */ /* Slot 194 is reserved */ /* Slot 195 is reserved */ /* Slot 196 is reserved */ /* Slot 197 is reserved */ +#ifndef TclObjGetFrame_TCL_DECLARED +#define TclObjGetFrame_TCL_DECLARED /* 198 */ EXTERN int TclObjGetFrame(Tcl_Interp *interp, Tcl_Obj *objPtr, CallFrame **framePtrPtr); +#endif /* Slot 199 is reserved */ +#ifndef TclpObjRemoveDirectory_TCL_DECLARED +#define TclpObjRemoveDirectory_TCL_DECLARED /* 200 */ EXTERN int TclpObjRemoveDirectory(Tcl_Obj *pathPtr, int recursive, Tcl_Obj **errorPtr); +#endif +#ifndef TclpObjCopyDirectory_TCL_DECLARED +#define TclpObjCopyDirectory_TCL_DECLARED /* 201 */ EXTERN int TclpObjCopyDirectory(Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr); +#endif +#ifndef TclpObjCreateDirectory_TCL_DECLARED +#define TclpObjCreateDirectory_TCL_DECLARED /* 202 */ EXTERN int TclpObjCreateDirectory(Tcl_Obj *pathPtr); +#endif +#ifndef TclpObjDeleteFile_TCL_DECLARED +#define TclpObjDeleteFile_TCL_DECLARED /* 203 */ EXTERN int TclpObjDeleteFile(Tcl_Obj *pathPtr); +#endif +#ifndef TclpObjCopyFile_TCL_DECLARED +#define TclpObjCopyFile_TCL_DECLARED /* 204 */ EXTERN int TclpObjCopyFile(Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr); +#endif +#ifndef TclpObjRenameFile_TCL_DECLARED +#define TclpObjRenameFile_TCL_DECLARED /* 205 */ EXTERN int TclpObjRenameFile(Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr); +#endif +#ifndef TclpObjStat_TCL_DECLARED +#define TclpObjStat_TCL_DECLARED /* 206 */ EXTERN int TclpObjStat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); +#endif +#ifndef TclpObjAccess_TCL_DECLARED +#define TclpObjAccess_TCL_DECLARED /* 207 */ EXTERN int TclpObjAccess(Tcl_Obj *pathPtr, int mode); +#endif +#ifndef TclpOpenFileChannel_TCL_DECLARED +#define TclpOpenFileChannel_TCL_DECLARED /* 208 */ EXTERN Tcl_Channel TclpOpenFileChannel(Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode, int permissions); +#endif /* Slot 209 is reserved */ /* Slot 210 is reserved */ /* Slot 211 is reserved */ +#ifndef TclpFindExecutable_TCL_DECLARED +#define TclpFindExecutable_TCL_DECLARED /* 212 */ -EXTERN void TclpFindExecutable(const char *argv0); +EXTERN void TclpFindExecutable(CONST char *argv0); +#endif +#ifndef TclGetObjNameOfExecutable_TCL_DECLARED +#define TclGetObjNameOfExecutable_TCL_DECLARED /* 213 */ EXTERN Tcl_Obj * TclGetObjNameOfExecutable(void); +#endif +#ifndef TclSetObjNameOfExecutable_TCL_DECLARED +#define TclSetObjNameOfExecutable_TCL_DECLARED /* 214 */ EXTERN void TclSetObjNameOfExecutable(Tcl_Obj *name, Tcl_Encoding encoding); +#endif +#ifndef TclStackAlloc_TCL_DECLARED +#define TclStackAlloc_TCL_DECLARED /* 215 */ -EXTERN void * TclStackAlloc(Tcl_Interp *interp, size_t numBytes); +EXTERN VOID * TclStackAlloc(Tcl_Interp *interp, int numBytes); +#endif +#ifndef TclStackFree_TCL_DECLARED +#define TclStackFree_TCL_DECLARED /* 216 */ -EXTERN void TclStackFree(Tcl_Interp *interp, void *freePtr); +EXTERN void TclStackFree(Tcl_Interp *interp, VOID *freePtr); +#endif +#ifndef TclPushStackFrame_TCL_DECLARED +#define TclPushStackFrame_TCL_DECLARED /* 217 */ EXTERN int TclPushStackFrame(Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr, Tcl_Namespace *namespacePtr, int isProcCallFrame); +#endif +#ifndef TclPopStackFrame_TCL_DECLARED +#define TclPopStackFrame_TCL_DECLARED /* 218 */ EXTERN void TclPopStackFrame(Tcl_Interp *interp); +#endif /* Slot 219 is reserved */ /* Slot 220 is reserved */ /* Slot 221 is reserved */ /* Slot 222 is reserved */ /* Slot 223 is reserved */ +#ifndef TclGetPlatform_TCL_DECLARED +#define TclGetPlatform_TCL_DECLARED /* 224 */ EXTERN TclPlatformType * TclGetPlatform(void); +#endif +#ifndef TclTraceDictPath_TCL_DECLARED +#define TclTraceDictPath_TCL_DECLARED /* 225 */ EXTERN Tcl_Obj * TclTraceDictPath(Tcl_Interp *interp, Tcl_Obj *rootPtr, int keyc, - Tcl_Obj *const keyv[], int flags); + Tcl_Obj *CONST keyv[], int flags); +#endif +#ifndef TclObjBeingDeleted_TCL_DECLARED +#define TclObjBeingDeleted_TCL_DECLARED /* 226 */ EXTERN int TclObjBeingDeleted(Tcl_Obj *objPtr); +#endif +#ifndef TclSetNsPath_TCL_DECLARED +#define TclSetNsPath_TCL_DECLARED /* 227 */ -EXTERN void TclSetNsPath(Namespace *nsPtr, size_t pathLength, +EXTERN void TclSetNsPath(Namespace *nsPtr, int pathLength, Tcl_Namespace *pathAry[]); -/* Slot 228 is reserved */ +#endif +#ifndef TclObjInterpProcCore_TCL_DECLARED +#define TclObjInterpProcCore_TCL_DECLARED +/* 228 */ +EXTERN int TclObjInterpProcCore(register Tcl_Interp *interp, + Tcl_Obj *procNameObj, int skip, + ProcErrorProc errorProc); +#endif +#ifndef TclPtrMakeUpvar_TCL_DECLARED +#define TclPtrMakeUpvar_TCL_DECLARED /* 229 */ EXTERN int TclPtrMakeUpvar(Tcl_Interp *interp, Var *otherP1Ptr, - const char *myName, int myFlags, int index); + CONST char *myName, int myFlags, int index); +#endif +#ifndef TclObjLookupVar_TCL_DECLARED +#define TclObjLookupVar_TCL_DECLARED /* 230 */ EXTERN Var * TclObjLookupVar(Tcl_Interp *interp, - Tcl_Obj *part1Ptr, const char *part2, - int flags, const char *msg, - const int createPart1, const int createPart2, + Tcl_Obj *part1Ptr, CONST char *part2, + int flags, CONST char *msg, + CONST int createPart1, CONST int createPart2, Var **arrayPtrPtr); +#endif +#ifndef TclGetNamespaceFromObj_TCL_DECLARED +#define TclGetNamespaceFromObj_TCL_DECLARED /* 231 */ EXTERN int TclGetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); +#endif +#ifndef TclEvalObjEx_TCL_DECLARED +#define TclEvalObjEx_TCL_DECLARED /* 232 */ EXTERN int TclEvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, - int flags, const CmdFrame *invoker, int word); + int flags, CONST CmdFrame *invoker, int word); +#endif +#ifndef TclGetSrcInfoForPc_TCL_DECLARED +#define TclGetSrcInfoForPc_TCL_DECLARED /* 233 */ EXTERN void TclGetSrcInfoForPc(CmdFrame *contextPtr); +#endif +#ifndef TclVarHashCreateVar_TCL_DECLARED +#define TclVarHashCreateVar_TCL_DECLARED /* 234 */ EXTERN Var * TclVarHashCreateVar(TclVarHashTable *tablePtr, - const char *key, int *newPtr); + CONST char *key, int *newPtr); +#endif +#ifndef TclInitVarHashTable_TCL_DECLARED +#define TclInitVarHashTable_TCL_DECLARED /* 235 */ EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr); -/* Slot 236 is reserved */ -/* 237 */ -EXTERN int TclResetCancellation(Tcl_Interp *interp, int force); -/* 238 */ -EXTERN int TclNRInterpProc(void *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); -/* 241 */ -EXTERN int TclNREvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, - int flags, const CmdFrame *invoker, int word); -/* 242 */ -EXTERN int TclNREvalObjv(Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[], int flags, - Command *cmdPtr); +#endif +#ifndef TclBackgroundException_TCL_DECLARED +#define TclBackgroundException_TCL_DECLARED +/* 236 */ +EXTERN void TclBackgroundException(Tcl_Interp *interp, int code); +#endif +/* Slot 237 is reserved */ +/* Slot 238 is reserved */ +/* Slot 239 is reserved */ +/* Slot 240 is reserved */ +/* Slot 241 is reserved */ +/* Slot 242 is reserved */ +#ifndef TclDbDumpActiveObjects_TCL_DECLARED +#define TclDbDumpActiveObjects_TCL_DECLARED /* 243 */ 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, - size_t numRemoved, size_t 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); +#endif +/* Slot 244 is reserved */ +/* Slot 245 is reserved */ +/* Slot 246 is reserved */ +/* Slot 247 is reserved */ +/* Slot 248 is reserved */ +#ifndef TclDoubleDigits_TCL_DECLARED +#define TclDoubleDigits_TCL_DECLARED /* 249 */ EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); -/* 250 */ -EXTERN void TclSetChildCancelFlags(Tcl_Interp *interp, int flags, - int force); +#endif +/* Slot 250 is reserved */ +#ifndef TclRegisterLiteral_TCL_DECLARED +#define TclRegisterLiteral_TCL_DECLARED /* 251 */ -EXTERN int TclRegisterLiteral(void *envPtr, const char *bytes, - size_t 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, - Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, - const int flags); -/* 254 */ -EXTERN Tcl_Obj * TclPtrIncrObjVar(Tcl_Interp *interp, Tcl_Var varPtr, - Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, - const int flags); -/* 255 */ -EXTERN int TclPtrObjMakeUpvar(Tcl_Interp *interp, - Tcl_Var otherPtr, Tcl_Obj *myNamePtr, - int myFlags); -/* 256 */ -EXTERN int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, - Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, const int flags); +EXTERN int TclRegisterLiteral(VOID *envPtr, char *bytes, + int length, int flags); +#endif +/* Slot 252 is reserved */ +/* Slot 253 is reserved */ +/* Slot 254 is reserved */ +/* Slot 255 is reserved */ +/* Slot 256 is reserved */ +#ifndef TclStaticPackage_TCL_DECLARED +#define TclStaticPackage_TCL_DECLARED /* 257 */ EXTERN void TclStaticPackage(Tcl_Interp *interp, - const char *pkgName, + CONST char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); -/* 258 */ -EXTERN Tcl_Obj * TclpCreateTemporaryDirectory(Tcl_Obj *dirObj, - Tcl_Obj *basenameObj); -/* 259 */ -EXTERN void TclAppendUnicodeToObj(Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, size_t length); -/* 260 */ -EXTERN unsigned char * TclGetBytesFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, size_t *lengthPtr); +#endif +/* Slot 258 is reserved */ +/* Slot 259 is reserved */ +/* Slot 260 is reserved */ +#ifndef TclUnusedStubEntry_TCL_DECLARED +#define TclUnusedStubEntry_TCL_DECLARED +/* 261 */ +EXTERN void TclUnusedStubEntry(void); +#endif typedef struct TclIntStubs { int magic; - void *hooks; + struct TclIntStubHooks *hooks; - void (*reserved0)(void); - void (*reserved1)(void); - void (*reserved2)(void); + VOID *reserved0; + VOID *reserved1; + VOID *reserved2; void (*tclAllocateFreeObjects) (void); /* 3 */ - void (*reserved4)(void); + VOID *reserved4; int (*tclCleanupChildren) (Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */ void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */ - size_t (*tclCopyAndCollapse) (size_t count, const char *src, char *dst); /* 7 */ - void (*reserved8)(void); - 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 */ + int (*tclCopyAndCollapse) (int count, CONST char *src, char *dst); /* 7 */ + int (*tclCopyChannel) (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) (void *clientData, int flags); /* 14 */ - void (*reserved15)(void); + VOID *reserved13; + int (*tclDumpMemoryInfo) (ClientData clientData, int flags); /* 14 */ + VOID *reserved15; 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, size_t *sizePtr, int *bracePtr); /* 22 */ - Proc * (*tclFindProc) (Interp *iPtr, const char *procName); /* 23 */ - size_t (*tclFormatInt) (char *buffer, Tcl_WideInt n); /* 24 */ + VOID *reserved17; + VOID *reserved18; + VOID *reserved19; + VOID *reserved20; + VOID *reserved21; + 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, long n); /* 24 */ void (*tclFreePackageInfo) (Interp *iPtr); /* 25 */ - void (*reserved26)(void); - void (*reserved27)(void); + VOID *reserved26; + VOID *reserved27; 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); - void (*reserved34)(void); - 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 */ + VOID *reserved29; + VOID *reserved30; + CONST char * (*tclGetExtension) (CONST char *name); /* 31 */ + int (*tclGetFrame) (Tcl_Interp *interp, CONST char *str, CallFrame **framePtrPtr); /* 32 */ + VOID *reserved33; + int (*tclGetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, int endValue, int *indexPtr); /* 34 */ + VOID *reserved35; + int (*tclGetLong) (Tcl_Interp *interp, CONST char *str, long *longPtr); /* 36 */ + int (*tclGetLoadedPackages) (Tcl_Interp *interp, 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 */ + int (*tclGetOpenMode) (Tcl_Interp *interp, CONST char *str, int *seekFlagPtr); /* 40 */ Tcl_Command (*tclGetOriginalCommand) (Tcl_Command command); /* 41 */ - const char * (*tclpGetUserHome) (const char *name, Tcl_DString *bufferPtr); /* 42 */ - void (*reserved43)(void); - int (*tclGuessPackageName) (const char *fileName, Tcl_DString *bufPtr); /* 44 */ + char * (*tclpGetUserHome) (CONST char *name, Tcl_DString *bufferPtr); /* 42 */ + VOID *reserved43; + 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 (*reserved50)(void); + VOID *reserved47; + VOID *reserved48; + VOID *reserved49; + void (*tclInitCompiledLocals) (Tcl_Interp *interp, CallFrame *framePtr, Namespace *nsPtr); /* 50 */ int (*tclInterpInit) (Tcl_Interp *interp); /* 51 */ - void (*reserved52)(void); - int (*tclInvokeObjectCommand) (void *clientData, Tcl_Interp *interp, int argc, const char **argv); /* 53 */ - int (*tclInvokeStringCommand) (void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 54 */ + VOID *reserved52; + int (*tclInvokeObjectCommand) (ClientData clientData, Tcl_Interp *interp, int argc, CONST84 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 */ + VOID *reserved56; + VOID *reserved57; + 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; + int (*tclNeedSpace) (CONST char *start, CONST char *end); /* 60 */ Tcl_Obj * (*tclNewProcBodyObj) (Proc *procPtr); /* 61 */ int (*tclObjCommandComplete) (Tcl_Obj *cmdPtr); /* 62 */ - int (*tclObjInterpProc) (void *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) (size_t size); /* 69 */ - void (*reserved70)(void); - void (*reserved71)(void); - void (*reserved72)(void); - void (*reserved73)(void); - void (*tclpFree) (void *ptr); /* 74 */ - Tcl_WideUInt (*tclpGetClicks) (void); /* 75 */ - Tcl_WideUInt (*tclpGetSeconds) (void); /* 76 */ - void (*reserved77)(void); - void (*reserved78)(void); - void (*reserved79)(void); - void (*reserved80)(void); - void * (*tclpRealloc) (void *ptr, size_t size); /* 81 */ - void (*reserved82)(void); - void (*reserved83)(void); - void (*reserved84)(void); - void (*reserved85)(void); - void (*reserved86)(void); - void (*reserved87)(void); - void (*reserved88)(void); + 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 *reserved66; + VOID *reserved67; + VOID *reserved68; + char * (*tclpAlloc) (unsigned int size); /* 69 */ + VOID *reserved70; + VOID *reserved71; + VOID *reserved72; + VOID *reserved73; + void (*tclpFree) (char *ptr); /* 74 */ + unsigned long (*tclpGetClicks) (void); /* 75 */ + unsigned long (*tclpGetSeconds) (void); /* 76 */ + void (*tclpGetTime) (Tcl_Time *time); /* 77 */ + int (*tclpGetTimeZone) (unsigned long time); /* 78 */ + VOID *reserved79; + VOID *reserved80; + char * (*tclpRealloc) (char *ptr, unsigned int size); /* 81 */ + VOID *reserved82; + VOID *reserved83; + VOID *reserved84; + VOID *reserved85; + VOID *reserved86; + VOID *reserved87; + 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 *reserved90; 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) (void *clientData); /* 93 */ - void (*reserved94)(void); - void (*reserved95)(void); - int (*tclRenameCommand) (Tcl_Interp *interp, const char *oldName, const char *newName); /* 96 */ + 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 *reserved95; + 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); - const char * (*tclSetPreInitScript) (const char *string); /* 101 */ + VOID *reserved99; + VOID *reserved100; + char * (*tclSetPreInitScript) (char *string); /* 101 */ void (*tclSetupEnv) (Tcl_Interp *interp); /* 102 */ - int (*tclSockGetPort) (Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 103 */ - void (*reserved104)(void); - void (*reserved105)(void); - void (*reserved106)(void); - void (*reserved107)(void); + int (*tclSockGetPort) (Tcl_Interp *interp, CONST char *str, CONST char *proto, int *portPtr); /* 103 */ + int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */ + VOID *reserved105; + VOID *reserved106; + VOID *reserved107; 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 */ - void (*reserved112)(void); - void (*reserved113)(void); - void (*reserved114)(void); - void (*reserved115)(void); - void (*reserved116)(void); - void (*reserved117)(void); - int (*tcl_GetInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo); /* 118 */ + 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 (*tcl_AppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */ + Tcl_Namespace * (*tcl_CreateNamespace) (Tcl_Interp *interp, CONST char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */ + void (*tcl_DeleteNamespace) (Tcl_Namespace *nsPtr); /* 114 */ + int (*tcl_Export) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, CONST char *pattern, int resetListFirst); /* 115 */ + Tcl_Command (*tcl_FindCommand) (Tcl_Interp *interp, CONST char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */ + Tcl_Namespace * (*tcl_FindNamespace) (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 */ - void (*reserved121)(void); - void (*reserved122)(void); - void (*reserved123)(void); - void (*reserved124)(void); - void (*reserved125)(void); + Tcl_Var (*tcl_FindNamespaceVar) (Tcl_Interp *interp, CONST char *name, Tcl_Namespace *contextNsPtr, int flags); /* 120 */ + int (*tcl_ForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, CONST char *pattern); /* 121 */ + Tcl_Command (*tcl_GetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 122 */ + void (*tcl_GetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 123 */ + Tcl_Namespace * (*tcl_GetCurrentNamespace) (Tcl_Interp *interp); /* 124 */ + Tcl_Namespace * (*tcl_GetGlobalNamespace) (Tcl_Interp *interp); /* 125 */ void (*tcl_GetVariableFullName) (Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); /* 126 */ - void (*reserved127)(void); + int (*tcl_Import) (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 */ + 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 */ - void (*reserved133)(void); - 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, void *clientData); /* 142 */ + struct tm * (*tclpGetDate) (CONST time_t *time, int useGMT); /* 133 */ + VOID *reserved134; + VOID *reserved135; + VOID *reserved136; + VOID *reserved137; + CONST84_RETURN char * (*tclGetEnv) (CONST char *name, Tcl_DString *valuePtr); /* 138 */ + VOID *reserved139; + VOID *reserved140; + CONST84_RETURN 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 */ + struct AuxDataType * (*tclGetAuxDataType) (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, size_t index, size_t *startPtr, size_t *endPtr); /* 151 */ + 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 */ - void (*reserved158)(void); - void (*reserved159)(void); - void (*reserved160)(void); + VOID *reserved154; + VOID *reserved155; + void (*tclRegError) (Tcl_Interp *interp, CONST char *msg, int status); /* 156 */ + Var * (*tclVarTraceExists) (Tcl_Interp *interp, CONST char *varName); /* 157 */ + void (*tclSetStartupScriptFileName) (CONST char *filename); /* 158 */ + CONST84_RETURN char * (*tclGetStartupScriptFileName) (void); /* 159 */ + VOID *reserved160; int (*tclChannelTransform) (Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 161 */ - void (*tclChannelEventScriptInvoker) (void *clientData, int flags); /* 162 */ - const void * (*tclGetInstructionTable) (void); /* 163 */ - void (*tclExpandCodeArray) (void *envPtr); /* 164 */ + void (*tclChannelEventScriptInvoker) (ClientData clientData, int flags); /* 162 */ + 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 */ - void (*reserved167)(void); - void (*reserved168)(void); - int (*tclpUtfNcmp2) (const char *s1, const char *s2, size_t n); /* 169 */ - int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 170 */ - int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 171 */ + void (*tclSetStartupScriptPath) (Tcl_Obj *pathPtr); /* 167 */ + 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, size_t strLen, const Tcl_UniChar *pattern, size_t 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 */ + int (*tclUniCharMatch) (CONST Tcl_UniChar *string, int strLen, CONST Tcl_UniChar *pattern, int ptnLen, int flags); /* 173 */ + VOID *reserved174; + 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 (*reserved178)(void); - void (*reserved179)(void); - void (*reserved180)(void); - void (*reserved181)(void); - void (*reserved182)(void); - void (*reserved183)(void); - void (*reserved184)(void); - void (*reserved185)(void); - void (*reserved186)(void); - void (*reserved187)(void); - void (*reserved188)(void); - void (*reserved189)(void); - void (*reserved190)(void); - void (*reserved191)(void); - void (*reserved192)(void); - void (*reserved193)(void); - void (*reserved194)(void); - void (*reserved195)(void); - void (*reserved196)(void); - void (*reserved197)(void); + void (*tclVarErrMsg) (Tcl_Interp *interp, CONST char *part1, CONST char *part2, CONST char *operation, CONST char *reason); /* 177 */ + void (*tcl_SetStartupScript) (Tcl_Obj *pathPtr, CONST char *encodingName); /* 178 */ + Tcl_Obj * (*tcl_GetStartupScript) (CONST char **encodingNamePtr); /* 179 */ + VOID *reserved180; + VOID *reserved181; + struct tm * (*tclpLocaltime) (CONST time_t *clock); /* 182 */ + struct tm * (*tclpGmtime) (CONST time_t *clock); /* 183 */ + VOID *reserved184; + VOID *reserved185; + VOID *reserved186; + VOID *reserved187; + VOID *reserved188; + VOID *reserved189; + VOID *reserved190; + VOID *reserved191; + VOID *reserved192; + VOID *reserved193; + VOID *reserved194; + VOID *reserved195; + VOID *reserved196; + VOID *reserved197; int (*tclObjGetFrame) (Tcl_Interp *interp, Tcl_Obj *objPtr, CallFrame **framePtrPtr); /* 198 */ - void (*reserved199)(void); + VOID *reserved199; int (*tclpObjRemoveDirectory) (Tcl_Obj *pathPtr, int recursive, Tcl_Obj **errorPtr); /* 200 */ int (*tclpObjCopyDirectory) (Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr); /* 201 */ int (*tclpObjCreateDirectory) (Tcl_Obj *pathPtr); /* 202 */ int (*tclpObjDeleteFile) (Tcl_Obj *pathPtr); /* 203 */ int (*tclpObjCopyFile) (Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr); /* 204 */ int (*tclpObjRenameFile) (Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr); /* 205 */ int (*tclpObjStat) (Tcl_Obj *pathPtr, Tcl_StatBuf *buf); /* 206 */ int (*tclpObjAccess) (Tcl_Obj *pathPtr, int mode); /* 207 */ 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 */ + VOID *reserved209; + VOID *reserved210; + VOID *reserved211; + 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, size_t numBytes); /* 215 */ - void (*tclStackFree) (Tcl_Interp *interp, void *freePtr); /* 216 */ + 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); + VOID *reserved219; + VOID *reserved220; + VOID *reserved221; + VOID *reserved222; + VOID *reserved223; TclPlatformType * (*tclGetPlatform) (void); /* 224 */ - Tcl_Obj * (*tclTraceDictPath) (Tcl_Interp *interp, Tcl_Obj *rootPtr, int keyc, Tcl_Obj *const keyv[], int flags); /* 225 */ + 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, size_t 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 */ + void (*tclSetNsPath) (Namespace *nsPtr, int pathLength, Tcl_Namespace *pathAry[]); /* 227 */ + int (*tclObjInterpProcCore) (register Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc errorProc); /* 228 */ + 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 */ + 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 */ + Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, CONST char *key, int *newPtr); /* 234 */ void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */ - void (*reserved236)(void); - int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */ - int (*tclNRInterpProc) (void *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 (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */ + VOID *reserved237; + VOID *reserved238; + VOID *reserved239; + VOID *reserved240; + VOID *reserved241; + VOID *reserved242; void (*tclDbDumpActiveObjects) (FILE *outFile); /* 243 */ - Tcl_HashTable * (*tclGetNamespaceChildTable) (Tcl_Namespace *nsPtr); /* 244 */ - Tcl_HashTable * (*tclGetNamespaceCommandTable) (Tcl_Namespace *nsPtr); /* 245 */ - int (*tclInitRewriteEnsemble) (Tcl_Interp *interp, size_t numRemoved, size_t 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 */ + VOID *reserved244; + VOID *reserved245; + VOID *reserved246; + VOID *reserved247; + VOID *reserved248; char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */ - void (*tclSetChildCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */ - int (*tclRegisterLiteral) (void *envPtr, const char *bytes, size_t 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 */ - void (*tclAppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t length); /* 259 */ - unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, size_t *lengthPtr); /* 260 */ + VOID *reserved250; + int (*tclRegisterLiteral) (VOID *envPtr, char *bytes, int length, int flags); /* 251 */ + VOID *reserved252; + VOID *reserved253; + VOID *reserved254; + VOID *reserved255; + VOID *reserved256; + void (*tclStaticPackage) (Tcl_Interp *interp, CONST char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */ + VOID *reserved258; + VOID *reserved259; + VOID *reserved260; + void (*tclUnusedStubEntry) (void); /* 261 */ } TclIntStubs; -extern const TclIntStubs *tclIntStubsPtr; +extern TclIntStubs *tclIntStubsPtr; #ifdef __cplusplus } #endif -#if defined(USE_TCL_STUBS) +#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) /* * Inline function declarations: */ /* Slot 0 is reserved */ /* Slot 1 is reserved */ /* Slot 2 is reserved */ +#ifndef TclAllocateFreeObjects #define TclAllocateFreeObjects \ (tclIntStubsPtr->tclAllocateFreeObjects) /* 3 */ +#endif /* Slot 4 is reserved */ +#ifndef TclCleanupChildren #define TclCleanupChildren \ (tclIntStubsPtr->tclCleanupChildren) /* 5 */ +#endif +#ifndef TclCleanupCommand #define TclCleanupCommand \ (tclIntStubsPtr->tclCleanupCommand) /* 6 */ +#endif +#ifndef TclCopyAndCollapse #define TclCopyAndCollapse \ (tclIntStubsPtr->tclCopyAndCollapse) /* 7 */ -/* Slot 8 is reserved */ +#endif +#ifndef TclCopyChannel +#define TclCopyChannel \ + (tclIntStubsPtr->tclCopyChannel) /* 8 */ +#endif +#ifndef TclCreatePipeline #define TclCreatePipeline \ (tclIntStubsPtr->tclCreatePipeline) /* 9 */ +#endif +#ifndef TclCreateProc #define TclCreateProc \ (tclIntStubsPtr->tclCreateProc) /* 10 */ +#endif +#ifndef TclDeleteCompiledLocalVars #define TclDeleteCompiledLocalVars \ (tclIntStubsPtr->tclDeleteCompiledLocalVars) /* 11 */ +#endif +#ifndef TclDeleteVars #define TclDeleteVars \ (tclIntStubsPtr->tclDeleteVars) /* 12 */ +#endif /* Slot 13 is reserved */ +#ifndef TclDumpMemoryInfo #define TclDumpMemoryInfo \ (tclIntStubsPtr->tclDumpMemoryInfo) /* 14 */ +#endif /* Slot 15 is reserved */ +#ifndef TclExprFloatError #define TclExprFloatError \ (tclIntStubsPtr->tclExprFloatError) /* 16 */ +#endif /* Slot 17 is reserved */ /* Slot 18 is reserved */ /* Slot 19 is reserved */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ +#ifndef TclFindElement #define TclFindElement \ (tclIntStubsPtr->tclFindElement) /* 22 */ +#endif +#ifndef TclFindProc #define TclFindProc \ (tclIntStubsPtr->tclFindProc) /* 23 */ +#endif +#ifndef TclFormatInt #define TclFormatInt \ (tclIntStubsPtr->tclFormatInt) /* 24 */ +#endif +#ifndef TclFreePackageInfo #define TclFreePackageInfo \ (tclIntStubsPtr->tclFreePackageInfo) /* 25 */ +#endif /* Slot 26 is reserved */ /* Slot 27 is reserved */ +#ifndef TclpGetDefaultStdChannel #define TclpGetDefaultStdChannel \ (tclIntStubsPtr->tclpGetDefaultStdChannel) /* 28 */ +#endif /* Slot 29 is reserved */ /* Slot 30 is reserved */ +#ifndef TclGetExtension #define TclGetExtension \ (tclIntStubsPtr->tclGetExtension) /* 31 */ +#endif +#ifndef TclGetFrame #define TclGetFrame \ (tclIntStubsPtr->tclGetFrame) /* 32 */ +#endif /* Slot 33 is reserved */ -/* Slot 34 is reserved */ +#ifndef TclGetIntForIndex +#define TclGetIntForIndex \ + (tclIntStubsPtr->tclGetIntForIndex) /* 34 */ +#endif /* Slot 35 is reserved */ -/* Slot 36 is reserved */ +#ifndef TclGetLong +#define TclGetLong \ + (tclIntStubsPtr->tclGetLong) /* 36 */ +#endif +#ifndef TclGetLoadedPackages #define TclGetLoadedPackages \ (tclIntStubsPtr->tclGetLoadedPackages) /* 37 */ +#endif +#ifndef TclGetNamespaceForQualName #define TclGetNamespaceForQualName \ (tclIntStubsPtr->tclGetNamespaceForQualName) /* 38 */ +#endif +#ifndef TclGetObjInterpProc #define TclGetObjInterpProc \ (tclIntStubsPtr->tclGetObjInterpProc) /* 39 */ +#endif +#ifndef TclGetOpenMode #define TclGetOpenMode \ (tclIntStubsPtr->tclGetOpenMode) /* 40 */ +#endif +#ifndef TclGetOriginalCommand #define TclGetOriginalCommand \ (tclIntStubsPtr->tclGetOriginalCommand) /* 41 */ +#endif +#ifndef TclpGetUserHome #define TclpGetUserHome \ (tclIntStubsPtr->tclpGetUserHome) /* 42 */ +#endif /* Slot 43 is reserved */ +#ifndef TclGuessPackageName #define TclGuessPackageName \ (tclIntStubsPtr->tclGuessPackageName) /* 44 */ +#endif +#ifndef TclHideUnsafeCommands #define TclHideUnsafeCommands \ (tclIntStubsPtr->tclHideUnsafeCommands) /* 45 */ +#endif +#ifndef TclInExit #define TclInExit \ (tclIntStubsPtr->tclInExit) /* 46 */ +#endif /* Slot 47 is reserved */ /* Slot 48 is reserved */ /* Slot 49 is reserved */ -/* Slot 50 is reserved */ +#ifndef TclInitCompiledLocals +#define TclInitCompiledLocals \ + (tclIntStubsPtr->tclInitCompiledLocals) /* 50 */ +#endif +#ifndef TclInterpInit #define TclInterpInit \ (tclIntStubsPtr->tclInterpInit) /* 51 */ +#endif /* Slot 52 is reserved */ +#ifndef TclInvokeObjectCommand #define TclInvokeObjectCommand \ (tclIntStubsPtr->tclInvokeObjectCommand) /* 53 */ +#endif +#ifndef TclInvokeStringCommand #define TclInvokeStringCommand \ (tclIntStubsPtr->tclInvokeStringCommand) /* 54 */ +#endif +#ifndef TclIsProc #define TclIsProc \ (tclIntStubsPtr->tclIsProc) /* 55 */ +#endif /* Slot 56 is reserved */ /* Slot 57 is reserved */ +#ifndef TclLookupVar #define TclLookupVar \ (tclIntStubsPtr->tclLookupVar) /* 58 */ +#endif /* Slot 59 is reserved */ +#ifndef TclNeedSpace #define TclNeedSpace \ (tclIntStubsPtr->tclNeedSpace) /* 60 */ +#endif +#ifndef TclNewProcBodyObj #define TclNewProcBodyObj \ (tclIntStubsPtr->tclNewProcBodyObj) /* 61 */ +#endif +#ifndef TclObjCommandComplete #define TclObjCommandComplete \ (tclIntStubsPtr->tclObjCommandComplete) /* 62 */ +#endif +#ifndef TclObjInterpProc #define TclObjInterpProc \ (tclIntStubsPtr->tclObjInterpProc) /* 63 */ +#endif +#ifndef TclObjInvoke #define TclObjInvoke \ (tclIntStubsPtr->tclObjInvoke) /* 64 */ +#endif /* Slot 65 is reserved */ /* Slot 66 is reserved */ /* Slot 67 is reserved */ /* Slot 68 is reserved */ +#ifndef TclpAlloc #define TclpAlloc \ (tclIntStubsPtr->tclpAlloc) /* 69 */ +#endif /* Slot 70 is reserved */ /* Slot 71 is reserved */ /* Slot 72 is reserved */ /* Slot 73 is reserved */ +#ifndef TclpFree #define TclpFree \ (tclIntStubsPtr->tclpFree) /* 74 */ +#endif +#ifndef TclpGetClicks #define TclpGetClicks \ (tclIntStubsPtr->tclpGetClicks) /* 75 */ +#endif +#ifndef TclpGetSeconds #define TclpGetSeconds \ (tclIntStubsPtr->tclpGetSeconds) /* 76 */ -/* Slot 77 is reserved */ -/* Slot 78 is reserved */ +#endif +#ifndef TclpGetTime +#define TclpGetTime \ + (tclIntStubsPtr->tclpGetTime) /* 77 */ +#endif +#ifndef TclpGetTimeZone +#define TclpGetTimeZone \ + (tclIntStubsPtr->tclpGetTimeZone) /* 78 */ +#endif /* Slot 79 is reserved */ /* Slot 80 is reserved */ +#ifndef TclpRealloc #define TclpRealloc \ (tclIntStubsPtr->tclpRealloc) /* 81 */ +#endif /* Slot 82 is reserved */ /* Slot 83 is reserved */ /* Slot 84 is reserved */ /* Slot 85 is reserved */ /* Slot 86 is reserved */ /* Slot 87 is reserved */ -/* Slot 88 is reserved */ +#ifndef TclPrecTraceProc +#define TclPrecTraceProc \ + (tclIntStubsPtr->tclPrecTraceProc) /* 88 */ +#endif +#ifndef TclPreventAliasLoop #define TclPreventAliasLoop \ (tclIntStubsPtr->tclPreventAliasLoop) /* 89 */ +#endif /* Slot 90 is reserved */ +#ifndef TclProcCleanupProc #define TclProcCleanupProc \ (tclIntStubsPtr->tclProcCleanupProc) /* 91 */ +#endif +#ifndef TclProcCompileProc #define TclProcCompileProc \ (tclIntStubsPtr->tclProcCompileProc) /* 92 */ +#endif +#ifndef TclProcDeleteProc #define TclProcDeleteProc \ (tclIntStubsPtr->tclProcDeleteProc) /* 93 */ +#endif /* Slot 94 is reserved */ /* Slot 95 is reserved */ +#ifndef TclRenameCommand #define TclRenameCommand \ (tclIntStubsPtr->tclRenameCommand) /* 96 */ +#endif +#ifndef TclResetShadowedCmdRefs #define TclResetShadowedCmdRefs \ (tclIntStubsPtr->tclResetShadowedCmdRefs) /* 97 */ +#endif +#ifndef TclServiceIdle #define TclServiceIdle \ (tclIntStubsPtr->tclServiceIdle) /* 98 */ +#endif /* Slot 99 is reserved */ /* Slot 100 is reserved */ +#ifndef TclSetPreInitScript #define TclSetPreInitScript \ (tclIntStubsPtr->tclSetPreInitScript) /* 101 */ +#endif +#ifndef TclSetupEnv #define TclSetupEnv \ (tclIntStubsPtr->tclSetupEnv) /* 102 */ +#endif +#ifndef TclSockGetPort #define TclSockGetPort \ (tclIntStubsPtr->tclSockGetPort) /* 103 */ -/* Slot 104 is reserved */ +#endif +#ifndef TclSockMinimumBuffersOld +#define TclSockMinimumBuffersOld \ + (tclIntStubsPtr->tclSockMinimumBuffersOld) /* 104 */ +#endif /* Slot 105 is reserved */ /* Slot 106 is reserved */ /* Slot 107 is reserved */ +#ifndef TclTeardownNamespace #define TclTeardownNamespace \ (tclIntStubsPtr->tclTeardownNamespace) /* 108 */ +#endif +#ifndef TclUpdateReturnInfo #define TclUpdateReturnInfo \ (tclIntStubsPtr->tclUpdateReturnInfo) /* 109 */ +#endif +#ifndef TclSockMinimumBuffers #define TclSockMinimumBuffers \ (tclIntStubsPtr->tclSockMinimumBuffers) /* 110 */ +#endif +#ifndef Tcl_AddInterpResolvers #define Tcl_AddInterpResolvers \ (tclIntStubsPtr->tcl_AddInterpResolvers) /* 111 */ -/* Slot 112 is reserved */ -/* Slot 113 is reserved */ -/* Slot 114 is reserved */ -/* Slot 115 is reserved */ -/* Slot 116 is reserved */ -/* Slot 117 is reserved */ +#endif +#ifndef Tcl_AppendExportList +#define Tcl_AppendExportList \ + (tclIntStubsPtr->tcl_AppendExportList) /* 112 */ +#endif +#ifndef Tcl_CreateNamespace +#define Tcl_CreateNamespace \ + (tclIntStubsPtr->tcl_CreateNamespace) /* 113 */ +#endif +#ifndef Tcl_DeleteNamespace +#define Tcl_DeleteNamespace \ + (tclIntStubsPtr->tcl_DeleteNamespace) /* 114 */ +#endif +#ifndef Tcl_Export +#define Tcl_Export \ + (tclIntStubsPtr->tcl_Export) /* 115 */ +#endif +#ifndef Tcl_FindCommand +#define Tcl_FindCommand \ + (tclIntStubsPtr->tcl_FindCommand) /* 116 */ +#endif +#ifndef Tcl_FindNamespace +#define Tcl_FindNamespace \ + (tclIntStubsPtr->tcl_FindNamespace) /* 117 */ +#endif +#ifndef Tcl_GetInterpResolvers #define Tcl_GetInterpResolvers \ (tclIntStubsPtr->tcl_GetInterpResolvers) /* 118 */ +#endif +#ifndef Tcl_GetNamespaceResolvers #define Tcl_GetNamespaceResolvers \ (tclIntStubsPtr->tcl_GetNamespaceResolvers) /* 119 */ +#endif +#ifndef Tcl_FindNamespaceVar #define Tcl_FindNamespaceVar \ (tclIntStubsPtr->tcl_FindNamespaceVar) /* 120 */ -/* Slot 121 is reserved */ -/* Slot 122 is reserved */ -/* Slot 123 is reserved */ -/* Slot 124 is reserved */ -/* Slot 125 is reserved */ +#endif +#ifndef Tcl_ForgetImport +#define Tcl_ForgetImport \ + (tclIntStubsPtr->tcl_ForgetImport) /* 121 */ +#endif +#ifndef Tcl_GetCommandFromObj +#define Tcl_GetCommandFromObj \ + (tclIntStubsPtr->tcl_GetCommandFromObj) /* 122 */ +#endif +#ifndef Tcl_GetCommandFullName +#define Tcl_GetCommandFullName \ + (tclIntStubsPtr->tcl_GetCommandFullName) /* 123 */ +#endif +#ifndef Tcl_GetCurrentNamespace +#define Tcl_GetCurrentNamespace \ + (tclIntStubsPtr->tcl_GetCurrentNamespace) /* 124 */ +#endif +#ifndef Tcl_GetGlobalNamespace +#define Tcl_GetGlobalNamespace \ + (tclIntStubsPtr->tcl_GetGlobalNamespace) /* 125 */ +#endif +#ifndef Tcl_GetVariableFullName #define Tcl_GetVariableFullName \ (tclIntStubsPtr->tcl_GetVariableFullName) /* 126 */ -/* Slot 127 is reserved */ +#endif +#ifndef Tcl_Import +#define Tcl_Import \ + (tclIntStubsPtr->tcl_Import) /* 127 */ +#endif +#ifndef Tcl_PopCallFrame #define Tcl_PopCallFrame \ (tclIntStubsPtr->tcl_PopCallFrame) /* 128 */ +#endif +#ifndef Tcl_PushCallFrame #define Tcl_PushCallFrame \ (tclIntStubsPtr->tcl_PushCallFrame) /* 129 */ +#endif +#ifndef Tcl_RemoveInterpResolvers #define Tcl_RemoveInterpResolvers \ (tclIntStubsPtr->tcl_RemoveInterpResolvers) /* 130 */ +#endif +#ifndef Tcl_SetNamespaceResolvers #define Tcl_SetNamespaceResolvers \ (tclIntStubsPtr->tcl_SetNamespaceResolvers) /* 131 */ +#endif +#ifndef TclpHasSockets #define TclpHasSockets \ (tclIntStubsPtr->tclpHasSockets) /* 132 */ -/* Slot 133 is reserved */ +#endif +#ifndef TclpGetDate +#define TclpGetDate \ + (tclIntStubsPtr->tclpGetDate) /* 133 */ +#endif /* Slot 134 is reserved */ /* Slot 135 is reserved */ /* Slot 136 is reserved */ /* Slot 137 is reserved */ +#ifndef TclGetEnv #define TclGetEnv \ (tclIntStubsPtr->tclGetEnv) /* 138 */ +#endif /* Slot 139 is reserved */ /* Slot 140 is reserved */ +#ifndef TclpGetCwd #define TclpGetCwd \ (tclIntStubsPtr->tclpGetCwd) /* 141 */ +#endif +#ifndef TclSetByteCodeFromAny #define TclSetByteCodeFromAny \ (tclIntStubsPtr->tclSetByteCodeFromAny) /* 142 */ +#endif +#ifndef TclAddLiteralObj #define TclAddLiteralObj \ (tclIntStubsPtr->tclAddLiteralObj) /* 143 */ +#endif +#ifndef TclHideLiteral #define TclHideLiteral \ (tclIntStubsPtr->tclHideLiteral) /* 144 */ +#endif +#ifndef TclGetAuxDataType #define TclGetAuxDataType \ (tclIntStubsPtr->tclGetAuxDataType) /* 145 */ +#endif +#ifndef TclHandleCreate #define TclHandleCreate \ (tclIntStubsPtr->tclHandleCreate) /* 146 */ +#endif +#ifndef TclHandleFree #define TclHandleFree \ (tclIntStubsPtr->tclHandleFree) /* 147 */ +#endif +#ifndef TclHandlePreserve #define TclHandlePreserve \ (tclIntStubsPtr->tclHandlePreserve) /* 148 */ +#endif +#ifndef TclHandleRelease #define TclHandleRelease \ (tclIntStubsPtr->tclHandleRelease) /* 149 */ +#endif +#ifndef TclRegAbout #define TclRegAbout \ (tclIntStubsPtr->tclRegAbout) /* 150 */ +#endif +#ifndef TclRegExpRangeUniChar #define TclRegExpRangeUniChar \ (tclIntStubsPtr->tclRegExpRangeUniChar) /* 151 */ +#endif +#ifndef TclSetLibraryPath #define TclSetLibraryPath \ (tclIntStubsPtr->tclSetLibraryPath) /* 152 */ +#endif +#ifndef TclGetLibraryPath #define TclGetLibraryPath \ (tclIntStubsPtr->tclGetLibraryPath) /* 153 */ +#endif /* Slot 154 is reserved */ /* Slot 155 is reserved */ +#ifndef TclRegError #define TclRegError \ (tclIntStubsPtr->tclRegError) /* 156 */ +#endif +#ifndef TclVarTraceExists #define TclVarTraceExists \ (tclIntStubsPtr->tclVarTraceExists) /* 157 */ -/* Slot 158 is reserved */ -/* Slot 159 is reserved */ +#endif +#ifndef TclSetStartupScriptFileName +#define TclSetStartupScriptFileName \ + (tclIntStubsPtr->tclSetStartupScriptFileName) /* 158 */ +#endif +#ifndef TclGetStartupScriptFileName +#define TclGetStartupScriptFileName \ + (tclIntStubsPtr->tclGetStartupScriptFileName) /* 159 */ +#endif /* Slot 160 is reserved */ +#ifndef TclChannelTransform #define TclChannelTransform \ (tclIntStubsPtr->tclChannelTransform) /* 161 */ +#endif +#ifndef TclChannelEventScriptInvoker #define TclChannelEventScriptInvoker \ (tclIntStubsPtr->tclChannelEventScriptInvoker) /* 162 */ +#endif +#ifndef TclGetInstructionTable #define TclGetInstructionTable \ (tclIntStubsPtr->tclGetInstructionTable) /* 163 */ +#endif +#ifndef TclExpandCodeArray #define TclExpandCodeArray \ (tclIntStubsPtr->tclExpandCodeArray) /* 164 */ +#endif +#ifndef TclpSetInitialEncodings #define TclpSetInitialEncodings \ (tclIntStubsPtr->tclpSetInitialEncodings) /* 165 */ +#endif +#ifndef TclListObjSetElement #define TclListObjSetElement \ (tclIntStubsPtr->tclListObjSetElement) /* 166 */ -/* Slot 167 is reserved */ -/* Slot 168 is reserved */ +#endif +#ifndef TclSetStartupScriptPath +#define TclSetStartupScriptPath \ + (tclIntStubsPtr->tclSetStartupScriptPath) /* 167 */ +#endif +#ifndef TclGetStartupScriptPath +#define TclGetStartupScriptPath \ + (tclIntStubsPtr->tclGetStartupScriptPath) /* 168 */ +#endif +#ifndef TclpUtfNcmp2 #define TclpUtfNcmp2 \ (tclIntStubsPtr->tclpUtfNcmp2) /* 169 */ +#endif +#ifndef TclCheckInterpTraces #define TclCheckInterpTraces \ (tclIntStubsPtr->tclCheckInterpTraces) /* 170 */ +#endif +#ifndef TclCheckExecutionTraces #define TclCheckExecutionTraces \ (tclIntStubsPtr->tclCheckExecutionTraces) /* 171 */ +#endif +#ifndef TclInThreadExit #define TclInThreadExit \ (tclIntStubsPtr->tclInThreadExit) /* 172 */ +#endif +#ifndef TclUniCharMatch #define TclUniCharMatch \ (tclIntStubsPtr->tclUniCharMatch) /* 173 */ +#endif /* Slot 174 is reserved */ +#ifndef TclCallVarTraces #define TclCallVarTraces \ (tclIntStubsPtr->tclCallVarTraces) /* 175 */ +#endif +#ifndef TclCleanupVar #define TclCleanupVar \ (tclIntStubsPtr->tclCleanupVar) /* 176 */ +#endif +#ifndef TclVarErrMsg #define TclVarErrMsg \ (tclIntStubsPtr->tclVarErrMsg) /* 177 */ -/* Slot 178 is reserved */ -/* Slot 179 is reserved */ +#endif +#ifndef Tcl_SetStartupScript +#define Tcl_SetStartupScript \ + (tclIntStubsPtr->tcl_SetStartupScript) /* 178 */ +#endif +#ifndef Tcl_GetStartupScript +#define Tcl_GetStartupScript \ + (tclIntStubsPtr->tcl_GetStartupScript) /* 179 */ +#endif /* Slot 180 is reserved */ /* Slot 181 is reserved */ -/* Slot 182 is reserved */ -/* Slot 183 is reserved */ +#ifndef TclpLocaltime +#define TclpLocaltime \ + (tclIntStubsPtr->tclpLocaltime) /* 182 */ +#endif +#ifndef TclpGmtime +#define TclpGmtime \ + (tclIntStubsPtr->tclpGmtime) /* 183 */ +#endif /* Slot 184 is reserved */ /* Slot 185 is reserved */ /* Slot 186 is reserved */ /* Slot 187 is reserved */ /* Slot 188 is reserved */ @@ -1157,135 +1930,228 @@ /* Slot 193 is reserved */ /* Slot 194 is reserved */ /* Slot 195 is reserved */ /* Slot 196 is reserved */ /* Slot 197 is reserved */ +#ifndef TclObjGetFrame #define TclObjGetFrame \ (tclIntStubsPtr->tclObjGetFrame) /* 198 */ +#endif /* Slot 199 is reserved */ +#ifndef TclpObjRemoveDirectory #define TclpObjRemoveDirectory \ (tclIntStubsPtr->tclpObjRemoveDirectory) /* 200 */ +#endif +#ifndef TclpObjCopyDirectory #define TclpObjCopyDirectory \ (tclIntStubsPtr->tclpObjCopyDirectory) /* 201 */ +#endif +#ifndef TclpObjCreateDirectory #define TclpObjCreateDirectory \ (tclIntStubsPtr->tclpObjCreateDirectory) /* 202 */ +#endif +#ifndef TclpObjDeleteFile #define TclpObjDeleteFile \ (tclIntStubsPtr->tclpObjDeleteFile) /* 203 */ +#endif +#ifndef TclpObjCopyFile #define TclpObjCopyFile \ (tclIntStubsPtr->tclpObjCopyFile) /* 204 */ +#endif +#ifndef TclpObjRenameFile #define TclpObjRenameFile \ (tclIntStubsPtr->tclpObjRenameFile) /* 205 */ +#endif +#ifndef TclpObjStat #define TclpObjStat \ (tclIntStubsPtr->tclpObjStat) /* 206 */ +#endif +#ifndef TclpObjAccess #define TclpObjAccess \ (tclIntStubsPtr->tclpObjAccess) /* 207 */ +#endif +#ifndef TclpOpenFileChannel #define TclpOpenFileChannel \ (tclIntStubsPtr->tclpOpenFileChannel) /* 208 */ +#endif /* Slot 209 is reserved */ /* Slot 210 is reserved */ /* Slot 211 is reserved */ +#ifndef TclpFindExecutable #define TclpFindExecutable \ (tclIntStubsPtr->tclpFindExecutable) /* 212 */ +#endif +#ifndef TclGetObjNameOfExecutable #define TclGetObjNameOfExecutable \ (tclIntStubsPtr->tclGetObjNameOfExecutable) /* 213 */ +#endif +#ifndef TclSetObjNameOfExecutable #define TclSetObjNameOfExecutable \ (tclIntStubsPtr->tclSetObjNameOfExecutable) /* 214 */ +#endif +#ifndef TclStackAlloc #define TclStackAlloc \ (tclIntStubsPtr->tclStackAlloc) /* 215 */ +#endif +#ifndef TclStackFree #define TclStackFree \ (tclIntStubsPtr->tclStackFree) /* 216 */ +#endif +#ifndef TclPushStackFrame #define TclPushStackFrame \ (tclIntStubsPtr->tclPushStackFrame) /* 217 */ +#endif +#ifndef TclPopStackFrame #define TclPopStackFrame \ (tclIntStubsPtr->tclPopStackFrame) /* 218 */ +#endif /* Slot 219 is reserved */ /* Slot 220 is reserved */ /* Slot 221 is reserved */ /* Slot 222 is reserved */ /* Slot 223 is reserved */ +#ifndef TclGetPlatform #define TclGetPlatform \ (tclIntStubsPtr->tclGetPlatform) /* 224 */ +#endif +#ifndef TclTraceDictPath #define TclTraceDictPath \ (tclIntStubsPtr->tclTraceDictPath) /* 225 */ +#endif +#ifndef TclObjBeingDeleted #define TclObjBeingDeleted \ (tclIntStubsPtr->tclObjBeingDeleted) /* 226 */ +#endif +#ifndef TclSetNsPath #define TclSetNsPath \ (tclIntStubsPtr->tclSetNsPath) /* 227 */ -/* Slot 228 is reserved */ +#endif +#ifndef TclObjInterpProcCore +#define TclObjInterpProcCore \ + (tclIntStubsPtr->tclObjInterpProcCore) /* 228 */ +#endif +#ifndef TclPtrMakeUpvar #define TclPtrMakeUpvar \ (tclIntStubsPtr->tclPtrMakeUpvar) /* 229 */ +#endif +#ifndef TclObjLookupVar #define TclObjLookupVar \ (tclIntStubsPtr->tclObjLookupVar) /* 230 */ +#endif +#ifndef TclGetNamespaceFromObj #define TclGetNamespaceFromObj \ (tclIntStubsPtr->tclGetNamespaceFromObj) /* 231 */ +#endif +#ifndef TclEvalObjEx #define TclEvalObjEx \ (tclIntStubsPtr->tclEvalObjEx) /* 232 */ +#endif +#ifndef TclGetSrcInfoForPc #define TclGetSrcInfoForPc \ (tclIntStubsPtr->tclGetSrcInfoForPc) /* 233 */ +#endif +#ifndef TclVarHashCreateVar #define TclVarHashCreateVar \ (tclIntStubsPtr->tclVarHashCreateVar) /* 234 */ +#endif +#ifndef TclInitVarHashTable #define TclInitVarHashTable \ (tclIntStubsPtr->tclInitVarHashTable) /* 235 */ -/* Slot 236 is reserved */ -#define TclResetCancellation \ - (tclIntStubsPtr->tclResetCancellation) /* 237 */ -#define TclNRInterpProc \ - (tclIntStubsPtr->tclNRInterpProc) /* 238 */ -#define TclNRInterpProcCore \ - (tclIntStubsPtr->tclNRInterpProcCore) /* 239 */ -#define TclNRRunCallbacks \ - (tclIntStubsPtr->tclNRRunCallbacks) /* 240 */ -#define TclNREvalObjEx \ - (tclIntStubsPtr->tclNREvalObjEx) /* 241 */ -#define TclNREvalObjv \ - (tclIntStubsPtr->tclNREvalObjv) /* 242 */ +#endif +#ifndef TclBackgroundException +#define TclBackgroundException \ + (tclIntStubsPtr->tclBackgroundException) /* 236 */ +#endif +/* Slot 237 is reserved */ +/* Slot 238 is reserved */ +/* Slot 239 is reserved */ +/* Slot 240 is reserved */ +/* Slot 241 is reserved */ +/* Slot 242 is reserved */ +#ifndef TclDbDumpActiveObjects #define TclDbDumpActiveObjects \ (tclIntStubsPtr->tclDbDumpActiveObjects) /* 243 */ -#define TclGetNamespaceChildTable \ - (tclIntStubsPtr->tclGetNamespaceChildTable) /* 244 */ -#define TclGetNamespaceCommandTable \ - (tclIntStubsPtr->tclGetNamespaceCommandTable) /* 245 */ -#define TclInitRewriteEnsemble \ - (tclIntStubsPtr->tclInitRewriteEnsemble) /* 246 */ -#define TclResetRewriteEnsemble \ - (tclIntStubsPtr->tclResetRewriteEnsemble) /* 247 */ -#define TclCopyChannel \ - (tclIntStubsPtr->tclCopyChannel) /* 248 */ +#endif +/* Slot 244 is reserved */ +/* Slot 245 is reserved */ +/* Slot 246 is reserved */ +/* Slot 247 is reserved */ +/* Slot 248 is reserved */ +#ifndef TclDoubleDigits #define TclDoubleDigits \ (tclIntStubsPtr->tclDoubleDigits) /* 249 */ -#define TclSetChildCancelFlags \ - (tclIntStubsPtr->tclSetChildCancelFlags) /* 250 */ +#endif +/* Slot 250 is reserved */ +#ifndef TclRegisterLiteral #define TclRegisterLiteral \ (tclIntStubsPtr->tclRegisterLiteral) /* 251 */ -#define TclPtrGetVar \ - (tclIntStubsPtr->tclPtrGetVar) /* 252 */ -#define TclPtrSetVar \ - (tclIntStubsPtr->tclPtrSetVar) /* 253 */ -#define TclPtrIncrObjVar \ - (tclIntStubsPtr->tclPtrIncrObjVar) /* 254 */ -#define TclPtrObjMakeUpvar \ - (tclIntStubsPtr->tclPtrObjMakeUpvar) /* 255 */ -#define TclPtrUnsetVar \ - (tclIntStubsPtr->tclPtrUnsetVar) /* 256 */ +#endif +/* Slot 252 is reserved */ +/* Slot 253 is reserved */ +/* Slot 254 is reserved */ +/* Slot 255 is reserved */ +/* Slot 256 is reserved */ +#ifndef TclStaticPackage #define TclStaticPackage \ (tclIntStubsPtr->tclStaticPackage) /* 257 */ -#define TclpCreateTemporaryDirectory \ - (tclIntStubsPtr->tclpCreateTemporaryDirectory) /* 258 */ -#define TclAppendUnicodeToObj \ - (tclIntStubsPtr->tclAppendUnicodeToObj) /* 259 */ -#define TclGetBytesFromObj \ - (tclIntStubsPtr->tclGetBytesFromObj) /* 260 */ - -#endif /* defined(USE_TCL_STUBS) */ +#endif +/* Slot 258 is reserved */ +/* Slot 259 is reserved */ +/* Slot 260 is reserved */ +#ifndef TclUnusedStubEntry +#define TclUnusedStubEntry \ + (tclIntStubsPtr->tclUnusedStubEntry) /* 261 */ +#endif + +#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ /* !END!: Do not edit above this line. */ -#if defined(USE_TCL_STUBS) -#undef Tcl_StaticPackage -#define Tcl_StaticPackage \ - (tclIntStubsPtr->tclStaticPackage) -#endif /* defined(USE_TCL_STUBS) */ +#if !defined(_WIN64) +/* See bug 510001: TclSockMinimumBuffers needs plat imp */ +# undef TclSockMinimumBuffers +# define TclSockMinimumBuffers(a,b) TclSockMinimumBuffersOld(PTR2INT(a),b) +#endif #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT + +#if defined(USE_TCL_STUBS) && defined(TCL_NO_DEPRECATED) +# undef Tcl_CreateNamespace +# define Tcl_CreateNamespace \ + (tclStubsPtr->tcl_CreateNamespace) /* 506 */ +# undef Tcl_DeleteNamespace +# define Tcl_DeleteNamespace \ + (tclStubsPtr->tcl_DeleteNamespace) /* 507 */ +# undef Tcl_AppendExportList +# define Tcl_AppendExportList \ + (tclStubsPtr->tcl_AppendExportList) /* 508 */ +# undef Tcl_Export +# define Tcl_Export \ + (tclStubsPtr->tcl_Export) /* 509 */ +# undef Tcl_Import +# define Tcl_Import \ + (tclStubsPtr->tcl_Import) /* 510 */ +# undef Tcl_ForgetImport +# define Tcl_ForgetImport \ + (tclStubsPtr->tcl_ForgetImport) /* 511 */ +# undef Tcl_GetCurrentNamespace +# define Tcl_GetCurrentNamespace \ + (tclStubsPtr->tcl_GetCurrentNamespace) /* 512 */ +# undef Tcl_GetGlobalNamespace +# define Tcl_GetGlobalNamespace \ + (tclStubsPtr->tcl_GetGlobalNamespace) /* 513 */ +# undef Tcl_FindNamespace +# define Tcl_FindNamespace \ + (tclStubsPtr->tcl_FindNamespace) /* 514 */ +# undef Tcl_FindCommand +# define Tcl_FindCommand \ + (tclStubsPtr->tcl_FindCommand) /* 515 */ +# undef Tcl_GetCommandFromObj +# define Tcl_GetCommandFromObj \ + (tclStubsPtr->tcl_GetCommandFromObj) /* 516 */ +# undef Tcl_GetCommandFullName +# define Tcl_GetCommandFullName \ + (tclStubsPtr->tcl_GetCommandFullName) /* 517 */ +#endif #endif /* _TCLINTDECLS */ Index: generic/tclIntPlatDecls.h ================================================================== --- generic/tclIntPlatDecls.h +++ generic/tclIntPlatDecls.h @@ -38,510 +38,822 @@ /* * Exported function declarations: */ -#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ +#ifndef TclGetAndDetachPids_TCL_DECLARED +#define TclGetAndDetachPids_TCL_DECLARED /* 0 */ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan); +#endif +#ifndef TclpCloseFile_TCL_DECLARED +#define TclpCloseFile_TCL_DECLARED /* 1 */ EXTERN int TclpCloseFile(TclFile file); +#endif +#ifndef TclpCreateCommandChannel_TCL_DECLARED +#define TclpCreateCommandChannel_TCL_DECLARED /* 2 */ EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); +#endif +#ifndef TclpCreatePipe_TCL_DECLARED +#define TclpCreatePipe_TCL_DECLARED /* 3 */ EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); +#endif +#ifndef TclpCreateProcess_TCL_DECLARED +#define TclpCreateProcess_TCL_DECLARED /* 4 */ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, - const char **argv, TclFile inputFile, + CONST char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); -/* 5 */ -EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout); +#endif +/* Slot 5 is reserved */ +#ifndef TclpMakeFile_TCL_DECLARED +#define TclpMakeFile_TCL_DECLARED /* 6 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); +#endif +#ifndef TclpOpenFile_TCL_DECLARED +#define TclpOpenFile_TCL_DECLARED /* 7 */ -EXTERN TclFile TclpOpenFile(const char *fname, int mode); +EXTERN TclFile TclpOpenFile(CONST char *fname, int mode); +#endif +#ifndef TclUnixWaitForFile_TCL_DECLARED +#define TclUnixWaitForFile_TCL_DECLARED /* 8 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); +#endif +#ifndef TclpCreateTempFile_TCL_DECLARED +#define TclpCreateTempFile_TCL_DECLARED /* 9 */ -EXTERN TclFile TclpCreateTempFile(const char *contents); -/* Slot 10 is reserved */ -/* Slot 11 is reserved */ -/* Slot 12 is reserved */ -/* Slot 13 is reserved */ +EXTERN TclFile TclpCreateTempFile(CONST char *contents); +#endif +#ifndef TclpReaddir_TCL_DECLARED +#define TclpReaddir_TCL_DECLARED +/* 10 */ +EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); +#endif +#ifndef TclpLocaltime_unix_TCL_DECLARED +#define TclpLocaltime_unix_TCL_DECLARED +/* 11 */ +EXTERN struct tm * TclpLocaltime_unix(CONST time_t *clock); +#endif +#ifndef TclpGmtime_unix_TCL_DECLARED +#define TclpGmtime_unix_TCL_DECLARED +/* 12 */ +EXTERN struct tm * TclpGmtime_unix(CONST time_t *clock); +#endif +#ifndef TclpInetNtoa_TCL_DECLARED +#define TclpInetNtoa_TCL_DECLARED +/* 13 */ +EXTERN char * TclpInetNtoa(struct in_addr addr); +#endif +#ifndef TclUnixCopyFile_TCL_DECLARED +#define TclUnixCopyFile_TCL_DECLARED /* 14 */ -EXTERN int TclUnixCopyFile(const char *src, const char *dst, - const Tcl_StatBuf *statBufPtr, +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); +#endif +/* Slot 15 is reserved */ +/* Slot 16 is reserved */ +/* Slot 17 is reserved */ +/* Slot 18 is reserved */ +/* Slot 19 is reserved */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ -/* 22 */ -EXTERN TclFile TclpCreateTempFile_(const char *contents); +/* Slot 22 is reserved */ /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* Slot 28 is reserved */ +#ifndef TclWinCPUID_TCL_DECLARED +#define TclWinCPUID_TCL_DECLARED /* 29 */ -EXTERN int TclWinCPUID(int index, int *regs); -/* 30 */ -EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, - Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, - Tcl_Obj *resultingNameObj); +EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs); +#endif #endif /* UNIX */ -#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ +#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#ifndef TclWinConvertError_TCL_DECLARED +#define TclWinConvertError_TCL_DECLARED /* 0 */ -EXTERN void TclWinConvertError(int errCode); -/* Slot 1 is reserved */ -/* Slot 2 is reserved */ -/* Slot 3 is reserved */ +EXTERN void TclWinConvertError(DWORD errCode); +#endif +#ifndef TclWinConvertWSAError_TCL_DECLARED +#define TclWinConvertWSAError_TCL_DECLARED +/* 1 */ +EXTERN void TclWinConvertWSAError(DWORD errCode); +#endif +#ifndef TclWinGetServByName_TCL_DECLARED +#define TclWinGetServByName_TCL_DECLARED +/* 2 */ +EXTERN struct servent * TclWinGetServByName(CONST char *nm, + CONST char *proto); +#endif +#ifndef TclWinGetSockOpt_TCL_DECLARED +#define TclWinGetSockOpt_TCL_DECLARED +/* 3 */ +EXTERN int TclWinGetSockOpt(SOCKET s, int level, int optname, + char *optval, int *optlen); +#endif +#ifndef TclWinGetTclInstance_TCL_DECLARED +#define TclWinGetTclInstance_TCL_DECLARED /* 4 */ -EXTERN void * TclWinGetTclInstance(void); +EXTERN HINSTANCE TclWinGetTclInstance(void); +#endif +#ifndef TclUnixWaitForFile_TCL_DECLARED +#define TclUnixWaitForFile_TCL_DECLARED /* 5 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); -/* Slot 6 is reserved */ -/* Slot 7 is reserved */ +#endif +#ifndef TclWinNToHS_TCL_DECLARED +#define TclWinNToHS_TCL_DECLARED +/* 6 */ +EXTERN unsigned short TclWinNToHS(unsigned short ns); +#endif +#ifndef TclWinSetSockOpt_TCL_DECLARED +#define TclWinSetSockOpt_TCL_DECLARED +/* 7 */ +EXTERN int TclWinSetSockOpt(SOCKET s, int level, int optname, + CONST char *optval, int optlen); +#endif +#ifndef TclpGetPid_TCL_DECLARED +#define TclpGetPid_TCL_DECLARED /* 8 */ -EXTERN size_t TclpGetPid(Tcl_Pid pid); -/* Slot 9 is reserved */ -/* Slot 10 is reserved */ +EXTERN int TclpGetPid(Tcl_Pid pid); +#endif +#ifndef TclWinGetPlatformId_TCL_DECLARED +#define TclWinGetPlatformId_TCL_DECLARED +/* 9 */ +EXTERN int TclWinGetPlatformId(void); +#endif +#ifndef TclpReaddir_TCL_DECLARED +#define TclpReaddir_TCL_DECLARED +/* 10 */ +EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); +#endif +#ifndef TclGetAndDetachPids_TCL_DECLARED +#define TclGetAndDetachPids_TCL_DECLARED /* 11 */ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan); +#endif +#ifndef TclpCloseFile_TCL_DECLARED +#define TclpCloseFile_TCL_DECLARED /* 12 */ EXTERN int TclpCloseFile(TclFile file); +#endif +#ifndef TclpCreateCommandChannel_TCL_DECLARED +#define TclpCreateCommandChannel_TCL_DECLARED /* 13 */ EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); +#endif +#ifndef TclpCreatePipe_TCL_DECLARED +#define TclpCreatePipe_TCL_DECLARED /* 14 */ EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); +#endif +#ifndef TclpCreateProcess_TCL_DECLARED +#define TclpCreateProcess_TCL_DECLARED /* 15 */ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, - const char **argv, TclFile inputFile, + CONST char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); +#endif +#ifndef TclpIsAtty_TCL_DECLARED +#define TclpIsAtty_TCL_DECLARED /* 16 */ EXTERN int TclpIsAtty(int fd); +#endif +#ifndef TclUnixCopyFile_TCL_DECLARED +#define TclUnixCopyFile_TCL_DECLARED /* 17 */ -EXTERN int TclUnixCopyFile(const char *src, const char *dst, - const Tcl_StatBuf *statBufPtr, +EXTERN int TclUnixCopyFile(CONST char *src, CONST char *dst, + CONST Tcl_StatBuf *statBufPtr, int dontCopyAtts); +#endif +#ifndef TclpMakeFile_TCL_DECLARED +#define TclpMakeFile_TCL_DECLARED /* 18 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); +#endif +#ifndef TclpOpenFile_TCL_DECLARED +#define TclpOpenFile_TCL_DECLARED /* 19 */ -EXTERN TclFile TclpOpenFile(const char *fname, int mode); +EXTERN TclFile TclpOpenFile(CONST char *fname, int mode); +#endif +#ifndef TclWinAddProcess_TCL_DECLARED +#define TclWinAddProcess_TCL_DECLARED /* 20 */ -EXTERN void TclWinAddProcess(void *hProcess, size_t id); -/* Slot 21 is reserved */ +EXTERN void TclWinAddProcess(HANDLE hProcess, DWORD id); +#endif +#ifndef TclpInetNtoa_TCL_DECLARED +#define TclpInetNtoa_TCL_DECLARED +/* 21 */ +EXTERN char * TclpInetNtoa(struct in_addr addr); +#endif +#ifndef TclpCreateTempFile_TCL_DECLARED +#define TclpCreateTempFile_TCL_DECLARED /* 22 */ -EXTERN TclFile TclpCreateTempFile(const char *contents); -/* Slot 23 is reserved */ +EXTERN TclFile TclpCreateTempFile(CONST char *contents); +#endif +#ifndef TclpGetTZName_TCL_DECLARED +#define TclpGetTZName_TCL_DECLARED +/* 23 */ +EXTERN char * TclpGetTZName(int isdst); +#endif +#ifndef TclWinNoBackslash_TCL_DECLARED +#define TclWinNoBackslash_TCL_DECLARED /* 24 */ EXTERN char * TclWinNoBackslash(char *path); +#endif /* Slot 25 is reserved */ -/* Slot 26 is reserved */ +#ifndef TclWinSetInterfaces_TCL_DECLARED +#define TclWinSetInterfaces_TCL_DECLARED +/* 26 */ +EXTERN void TclWinSetInterfaces(int wide); +#endif +#ifndef TclWinFlushDirtyChannels_TCL_DECLARED +#define TclWinFlushDirtyChannels_TCL_DECLARED /* 27 */ EXTERN void TclWinFlushDirtyChannels(void); -/* Slot 28 is reserved */ +#endif +#ifndef TclWinResetInterfaces_TCL_DECLARED +#define TclWinResetInterfaces_TCL_DECLARED +/* 28 */ +EXTERN void TclWinResetInterfaces(void); +#endif +#ifndef TclWinCPUID_TCL_DECLARED +#define TclWinCPUID_TCL_DECLARED /* 29 */ -EXTERN int TclWinCPUID(int index, int *regs); -/* 30 */ -EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, - Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, - Tcl_Obj *resultingNameObj); +EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs); +#endif #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ +#ifndef TclGetAndDetachPids_TCL_DECLARED +#define TclGetAndDetachPids_TCL_DECLARED /* 0 */ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan); +#endif +#ifndef TclpCloseFile_TCL_DECLARED +#define TclpCloseFile_TCL_DECLARED /* 1 */ EXTERN int TclpCloseFile(TclFile file); +#endif +#ifndef TclpCreateCommandChannel_TCL_DECLARED +#define TclpCreateCommandChannel_TCL_DECLARED /* 2 */ EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); +#endif +#ifndef TclpCreatePipe_TCL_DECLARED +#define TclpCreatePipe_TCL_DECLARED /* 3 */ EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); +#endif +#ifndef TclpCreateProcess_TCL_DECLARED +#define TclpCreateProcess_TCL_DECLARED /* 4 */ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, - const char **argv, TclFile inputFile, + CONST char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); -/* 5 */ -EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout); +#endif +/* Slot 5 is reserved */ +#ifndef TclpMakeFile_TCL_DECLARED +#define TclpMakeFile_TCL_DECLARED /* 6 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); +#endif +#ifndef TclpOpenFile_TCL_DECLARED +#define TclpOpenFile_TCL_DECLARED /* 7 */ -EXTERN TclFile TclpOpenFile(const char *fname, int mode); +EXTERN TclFile TclpOpenFile(CONST char *fname, int mode); +#endif +#ifndef TclUnixWaitForFile_TCL_DECLARED +#define TclUnixWaitForFile_TCL_DECLARED /* 8 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); +#endif +#ifndef TclpCreateTempFile_TCL_DECLARED +#define TclpCreateTempFile_TCL_DECLARED /* 9 */ -EXTERN TclFile TclpCreateTempFile(const char *contents); -/* Slot 10 is reserved */ -/* Slot 11 is reserved */ -/* Slot 12 is reserved */ -/* Slot 13 is reserved */ +EXTERN TclFile TclpCreateTempFile(CONST char *contents); +#endif +#ifndef TclpReaddir_TCL_DECLARED +#define TclpReaddir_TCL_DECLARED +/* 10 */ +EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); +#endif +#ifndef TclpLocaltime_unix_TCL_DECLARED +#define TclpLocaltime_unix_TCL_DECLARED +/* 11 */ +EXTERN struct tm * TclpLocaltime_unix(CONST time_t *clock); +#endif +#ifndef TclpGmtime_unix_TCL_DECLARED +#define TclpGmtime_unix_TCL_DECLARED +/* 12 */ +EXTERN struct tm * TclpGmtime_unix(CONST time_t *clock); +#endif +#ifndef TclpInetNtoa_TCL_DECLARED +#define TclpInetNtoa_TCL_DECLARED +/* 13 */ +EXTERN char * TclpInetNtoa(struct in_addr addr); +#endif +#ifndef TclUnixCopyFile_TCL_DECLARED +#define TclUnixCopyFile_TCL_DECLARED /* 14 */ -EXTERN int TclUnixCopyFile(const char *src, const char *dst, - const Tcl_StatBuf *statBufPtr, +EXTERN int TclUnixCopyFile(CONST char *src, CONST char *dst, + CONST Tcl_StatBuf *statBufPtr, int dontCopyAtts); +#endif +#ifndef TclMacOSXGetFileAttribute_TCL_DECLARED +#define TclMacOSXGetFileAttribute_TCL_DECLARED /* 15 */ EXTERN int TclMacOSXGetFileAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); +#endif +#ifndef TclMacOSXSetFileAttribute_TCL_DECLARED +#define TclMacOSXSetFileAttribute_TCL_DECLARED /* 16 */ EXTERN int TclMacOSXSetFileAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); +#endif +#ifndef TclMacOSXCopyFileAttributes_TCL_DECLARED +#define TclMacOSXCopyFileAttributes_TCL_DECLARED /* 17 */ -EXTERN int TclMacOSXCopyFileAttributes(const char *src, - const char *dst, - const Tcl_StatBuf *statBufPtr); +EXTERN int TclMacOSXCopyFileAttributes(CONST char *src, + CONST char *dst, + CONST Tcl_StatBuf *statBufPtr); +#endif +#ifndef TclMacOSXMatchType_TCL_DECLARED +#define TclMacOSXMatchType_TCL_DECLARED /* 18 */ EXTERN int TclMacOSXMatchType(Tcl_Interp *interp, - const char *pathName, const char *fileName, + CONST char *pathName, CONST char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); +#endif +#ifndef TclMacOSXNotifierAddRunLoopMode_TCL_DECLARED +#define TclMacOSXNotifierAddRunLoopMode_TCL_DECLARED /* 19 */ EXTERN void TclMacOSXNotifierAddRunLoopMode( - const void *runLoopMode); + CONST VOID *runLoopMode); +#endif /* Slot 20 is reserved */ /* Slot 21 is reserved */ -/* 22 */ -EXTERN TclFile TclpCreateTempFile_(const char *contents); +/* Slot 22 is reserved */ /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* Slot 28 is reserved */ +#ifndef TclWinCPUID_TCL_DECLARED +#define TclWinCPUID_TCL_DECLARED /* 29 */ -EXTERN int TclWinCPUID(int index, int *regs); -/* 30 */ -EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, - Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, - Tcl_Obj *resultingNameObj); +EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs); +#endif #endif /* MACOSX */ typedef struct TclIntPlatStubs { int magic; - void *hooks; + struct TclIntPlatStubHooks *hooks; -#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ +#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 */ + int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, CONST char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */ + VOID *reserved5; TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */ - TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ + TclFile (*tclpOpenFile) (CONST char *fname, int mode); /* 7 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */ - TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ - void (*reserved10)(void); - void (*reserved11)(void); - void (*reserved12)(void); - void (*reserved13)(void); - int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */ - int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */ - int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */ - int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */ - int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */ - void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */ - void (*reserved20)(void); - void (*reserved21)(void); - TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */ - void (*reserved23)(void); - void (*reserved24)(void); - void (*reserved25)(void); - void (*reserved26)(void); - void (*reserved27)(void); - void (*reserved28)(void); - int (*tclWinCPUID) (int index, int *regs); /* 29 */ - int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ + 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 */ + VOID *reserved15; + VOID *reserved16; + VOID *reserved17; + VOID *reserved18; + VOID *reserved19; + VOID *reserved20; + VOID *reserved21; + VOID *reserved22; + VOID *reserved23; + VOID *reserved24; + VOID *reserved25; + VOID *reserved26; + VOID *reserved27; + VOID *reserved28; + int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */ #endif /* UNIX */ -#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ - void (*tclWinConvertError) (int errCode); /* 0 */ - void (*reserved1)(void); - void (*reserved2)(void); - void (*reserved3)(void); - void * (*tclWinGetTclInstance) (void); /* 4 */ +#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 */ - void (*reserved6)(void); - void (*reserved7)(void); - size_t (*tclpGetPid) (Tcl_Pid pid); /* 8 */ - void (*reserved9)(void); - void (*reserved10)(void); + 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 (*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 */ + int (*tclUnixCopyFile) (CONST char *src, CONST char *dst, CONST Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 17 */ TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 18 */ - TclFile (*tclpOpenFile) (const char *fname, int mode); /* 19 */ - void (*tclWinAddProcess) (void *hProcess, size_t id); /* 20 */ - void (*reserved21)(void); - TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */ - void (*reserved23)(void); + 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 */ + char * (*tclpGetTZName) (int isdst); /* 23 */ char * (*tclWinNoBackslash) (char *path); /* 24 */ - void (*reserved25)(void); - void (*reserved26)(void); + VOID *reserved25; + void (*tclWinSetInterfaces) (int wide); /* 26 */ void (*tclWinFlushDirtyChannels) (void); /* 27 */ - void (*reserved28)(void); - int (*tclWinCPUID) (int index, int *regs); /* 29 */ - int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ + void (*tclWinResetInterfaces) (void); /* 28 */ + int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */ #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 */ + int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, CONST char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */ + VOID *reserved5; TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */ - TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ + TclFile (*tclpOpenFile) (CONST char *fname, int mode); /* 7 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */ - TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ - void (*reserved10)(void); - void (*reserved11)(void); - void (*reserved12)(void); - void (*reserved13)(void); - int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */ + 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 */ + 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 *reserved21; + VOID *reserved22; + VOID *reserved23; + VOID *reserved24; + VOID *reserved25; + VOID *reserved26; + VOID *reserved27; + VOID *reserved28; + int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */ #endif /* MACOSX */ } TclIntPlatStubs; -extern const TclIntPlatStubs *tclIntPlatStubsPtr; +extern TclIntPlatStubs *tclIntPlatStubsPtr; #ifdef __cplusplus } #endif -#if defined(USE_TCL_STUBS) +#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) /* * Inline function declarations: */ -#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ +#ifndef TclGetAndDetachPids #define TclGetAndDetachPids \ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */ +#endif +#ifndef TclpCloseFile #define TclpCloseFile \ (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ +#endif +#ifndef TclpCreateCommandChannel #define TclpCreateCommandChannel \ (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ +#endif +#ifndef TclpCreatePipe #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ +#endif +#ifndef TclpCreateProcess #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ -#define TclUnixWaitForFile_ \ - (tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 5 */ +#endif +/* Slot 5 is reserved */ +#ifndef TclpMakeFile #define TclpMakeFile \ (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ +#endif +#ifndef TclpOpenFile #define TclpOpenFile \ (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ +#endif +#ifndef TclUnixWaitForFile #define TclUnixWaitForFile \ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */ +#endif +#ifndef TclpCreateTempFile #define TclpCreateTempFile \ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ -/* Slot 10 is reserved */ -/* Slot 11 is reserved */ -/* Slot 12 is reserved */ -/* Slot 13 is reserved */ +#endif +#ifndef TclpReaddir +#define TclpReaddir \ + (tclIntPlatStubsPtr->tclpReaddir) /* 10 */ +#endif +#ifndef TclpLocaltime_unix +#define TclpLocaltime_unix \ + (tclIntPlatStubsPtr->tclpLocaltime_unix) /* 11 */ +#endif +#ifndef TclpGmtime_unix +#define TclpGmtime_unix \ + (tclIntPlatStubsPtr->tclpGmtime_unix) /* 12 */ +#endif +#ifndef TclpInetNtoa +#define TclpInetNtoa \ + (tclIntPlatStubsPtr->tclpInetNtoa) /* 13 */ +#endif +#ifndef TclUnixCopyFile #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 */ +#endif +/* Slot 15 is reserved */ +/* Slot 16 is reserved */ +/* Slot 17 is reserved */ +/* Slot 18 is reserved */ +/* Slot 19 is reserved */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ -#define TclpCreateTempFile_ \ - (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ +/* Slot 22 is reserved */ /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* Slot 28 is reserved */ +#ifndef TclWinCPUID #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ -#define TclUnixOpenTemporaryFile \ - (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ +#endif #endif /* UNIX */ -#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ +#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#ifndef TclWinConvertError #define TclWinConvertError \ (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ -/* Slot 1 is reserved */ -/* Slot 2 is reserved */ -/* Slot 3 is reserved */ +#endif +#ifndef TclWinConvertWSAError +#define TclWinConvertWSAError \ + (tclIntPlatStubsPtr->tclWinConvertWSAError) /* 1 */ +#endif +#ifndef TclWinGetServByName +#define TclWinGetServByName \ + (tclIntPlatStubsPtr->tclWinGetServByName) /* 2 */ +#endif +#ifndef TclWinGetSockOpt +#define TclWinGetSockOpt \ + (tclIntPlatStubsPtr->tclWinGetSockOpt) /* 3 */ +#endif +#ifndef TclWinGetTclInstance #define TclWinGetTclInstance \ (tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */ +#endif +#ifndef TclUnixWaitForFile #define TclUnixWaitForFile \ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 5 */ -/* Slot 6 is reserved */ -/* Slot 7 is reserved */ +#endif +#ifndef TclWinNToHS +#define TclWinNToHS \ + (tclIntPlatStubsPtr->tclWinNToHS) /* 6 */ +#endif +#ifndef TclWinSetSockOpt +#define TclWinSetSockOpt \ + (tclIntPlatStubsPtr->tclWinSetSockOpt) /* 7 */ +#endif +#ifndef TclpGetPid #define TclpGetPid \ (tclIntPlatStubsPtr->tclpGetPid) /* 8 */ -/* Slot 9 is reserved */ -/* Slot 10 is reserved */ +#endif +#ifndef TclWinGetPlatformId +#define TclWinGetPlatformId \ + (tclIntPlatStubsPtr->tclWinGetPlatformId) /* 9 */ +#endif +#ifndef TclpReaddir +#define TclpReaddir \ + (tclIntPlatStubsPtr->tclpReaddir) /* 10 */ +#endif +#ifndef TclGetAndDetachPids #define TclGetAndDetachPids \ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */ +#endif +#ifndef TclpCloseFile #define TclpCloseFile \ (tclIntPlatStubsPtr->tclpCloseFile) /* 12 */ +#endif +#ifndef TclpCreateCommandChannel #define TclpCreateCommandChannel \ (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 13 */ +#endif +#ifndef TclpCreatePipe #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 14 */ +#endif +#ifndef TclpCreateProcess #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 15 */ +#endif +#ifndef TclpIsAtty #define TclpIsAtty \ (tclIntPlatStubsPtr->tclpIsAtty) /* 16 */ +#endif +#ifndef TclUnixCopyFile #define TclUnixCopyFile \ (tclIntPlatStubsPtr->tclUnixCopyFile) /* 17 */ +#endif +#ifndef TclpMakeFile #define TclpMakeFile \ (tclIntPlatStubsPtr->tclpMakeFile) /* 18 */ +#endif +#ifndef TclpOpenFile #define TclpOpenFile \ (tclIntPlatStubsPtr->tclpOpenFile) /* 19 */ +#endif +#ifndef TclWinAddProcess #define TclWinAddProcess \ (tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */ -/* Slot 21 is reserved */ +#endif +#ifndef TclpInetNtoa +#define TclpInetNtoa \ + (tclIntPlatStubsPtr->tclpInetNtoa) /* 21 */ +#endif +#ifndef TclpCreateTempFile #define TclpCreateTempFile \ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */ -/* Slot 23 is reserved */ +#endif +#ifndef TclpGetTZName +#define TclpGetTZName \ + (tclIntPlatStubsPtr->tclpGetTZName) /* 23 */ +#endif +#ifndef TclWinNoBackslash #define TclWinNoBackslash \ (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */ +#endif /* Slot 25 is reserved */ -/* Slot 26 is reserved */ +#ifndef TclWinSetInterfaces +#define TclWinSetInterfaces \ + (tclIntPlatStubsPtr->tclWinSetInterfaces) /* 26 */ +#endif +#ifndef TclWinFlushDirtyChannels #define TclWinFlushDirtyChannels \ (tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */ -/* Slot 28 is reserved */ +#endif +#ifndef TclWinResetInterfaces +#define TclWinResetInterfaces \ + (tclIntPlatStubsPtr->tclWinResetInterfaces) /* 28 */ +#endif +#ifndef TclWinCPUID #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ -#define TclUnixOpenTemporaryFile \ - (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ +#endif #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ +#ifndef TclGetAndDetachPids #define TclGetAndDetachPids \ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */ +#endif +#ifndef TclpCloseFile #define TclpCloseFile \ (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ +#endif +#ifndef TclpCreateCommandChannel #define TclpCreateCommandChannel \ (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ +#endif +#ifndef TclpCreatePipe #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ +#endif +#ifndef TclpCreateProcess #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ -#define TclUnixWaitForFile_ \ - (tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 5 */ +#endif +/* Slot 5 is reserved */ +#ifndef TclpMakeFile #define TclpMakeFile \ (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ +#endif +#ifndef TclpOpenFile #define TclpOpenFile \ (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ +#endif +#ifndef TclUnixWaitForFile #define TclUnixWaitForFile \ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */ +#endif +#ifndef TclpCreateTempFile #define TclpCreateTempFile \ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ -/* Slot 10 is reserved */ -/* Slot 11 is reserved */ -/* Slot 12 is reserved */ -/* Slot 13 is reserved */ +#endif +#ifndef TclpReaddir +#define TclpReaddir \ + (tclIntPlatStubsPtr->tclpReaddir) /* 10 */ +#endif +#ifndef TclpLocaltime_unix +#define TclpLocaltime_unix \ + (tclIntPlatStubsPtr->tclpLocaltime_unix) /* 11 */ +#endif +#ifndef TclpGmtime_unix +#define TclpGmtime_unix \ + (tclIntPlatStubsPtr->tclpGmtime_unix) /* 12 */ +#endif +#ifndef TclpInetNtoa +#define TclpInetNtoa \ + (tclIntPlatStubsPtr->tclpInetNtoa) /* 13 */ +#endif +#ifndef TclUnixCopyFile #define TclUnixCopyFile \ (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ +#endif +#ifndef TclMacOSXGetFileAttribute #define TclMacOSXGetFileAttribute \ (tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 15 */ +#endif +#ifndef TclMacOSXSetFileAttribute #define TclMacOSXSetFileAttribute \ (tclIntPlatStubsPtr->tclMacOSXSetFileAttribute) /* 16 */ +#endif +#ifndef TclMacOSXCopyFileAttributes #define TclMacOSXCopyFileAttributes \ (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */ +#endif +#ifndef TclMacOSXMatchType #define TclMacOSXMatchType \ (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ +#endif +#ifndef TclMacOSXNotifierAddRunLoopMode #define TclMacOSXNotifierAddRunLoopMode \ (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ +#endif /* Slot 20 is reserved */ /* Slot 21 is reserved */ -#define TclpCreateTempFile_ \ - (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ +/* Slot 22 is reserved */ /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* Slot 28 is reserved */ +#ifndef TclWinCPUID #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ -#define TclUnixOpenTemporaryFile \ - (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ +#endif #endif /* MACOSX */ -#endif /* defined(USE_TCL_STUBS) */ +#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ /* !END!: Do not edit above this line. */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT -#define TclWinConvertWSAError TclWinConvertError - -#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 TclpLocaltime_unix +#undef TclpGmtime_unix + +#if defined(__WIN32__) +# undef TclWinNToHS +# undef TclWinGetServByName +# undef TclWinGetSockOpt +# undef TclWinSetSockOpt +# define TclWinNToHS ntohs +# define TclWinGetServByName getservbyname +# define TclWinGetSockOpt getsockopt +# define TclWinSetSockOpt setsockopt +#else # undef TclpGetPid -# define TclpGetPid(pid) ((size_t)(pid)) +# define TclpGetPid(pid) ((unsigned long) (pid)) #endif #endif /* _TCLINTPLATDECLS */ Index: generic/tclInterp.c ================================================================== --- generic/tclInterp.c +++ generic/tclInterp.c @@ -17,46 +17,46 @@ * A pointer to a string that holds an initialization script that if non-NULL * is evaluated in Tcl_Init() prior to the built-in initialization script * above. This variable can be modified by the function below. */ -static const char *tclPreInitScript = NULL; +static char *tclPreInitScript = NULL; /* Forward declaration */ struct Target; /* - * Alias: + * struct Alias: * - * Stores information about an alias. Is stored in the child interpreter and - * used by the source command to find the target command in the parent when + * 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 { - Tcl_Obj *token; /* Token for the alias command in the child +typedef struct Alias { + Tcl_Obj *token; /* Token for the alias command in the slave * interp. This used to be the command name in - * the child when the alias was first + * the slave when the alias was first * created. */ Tcl_Interp *targetInterp; /* Interp in which target command will be * invoked. */ - Tcl_Command childCmd; /* Source command in child interpreter, bound + Tcl_Command slaveCmd; /* Source command in slave interpreter, bound * to command that invokes the target command * in the target interpreter. */ Tcl_HashEntry *aliasEntryPtr; - /* Entry for the alias hash table in child. + /* Entry for the alias hash table in slave. * This is used by alias deletion to remove - * the alias from the child interpreter alias + * the alias from the slave interpreter alias * table. */ - struct Target *targetPtr; /* Entry for target command in parent. This is - * used in the parent interpreter to map back + struct Target *targetPtr; /* Entry for target command in master. This is + * used in the master interpreter to map back * from the target command to aliases * redirecting to it. */ int objc; /* Count of Tcl_Obj in the prefix of the * target command to be invoked in the target * interpreter. Additional arguments specified - * when calling the alias in the child interp + * when calling the alias in the slave interp * will be appended to the prefix before the * command is invoked. */ Tcl_Obj *objPtr; /* The first actual prefix object - the target * command name; this has to be at the end of * the structure, which will be extended to @@ -64,103 +64,103 @@ * prefix. */ } Alias; /* * - * Child: + * struct Slave: * - * Used by the "interp" command to record and find information about child - * interpreters. Maps from a command name in the parent to information about a - * child interpreter, e.g. what aliases are defined in it. + * 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 { - Tcl_Interp *parentInterp; /* Parent interpreter for this child. */ - Tcl_HashEntry *childEntryPtr; - /* Hash entry in parents child table for this - * child interpreter. Used to find this - * record, and used when deleting the child - * interpreter to delete it from the parent's +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. */ - Tcl_Interp *childInterp; /* The child interpreter. */ + Tcl_Interp *slaveInterp; /* The slave interpreter. */ Tcl_Command interpCmd; /* Interpreter object command. */ Tcl_HashTable aliasTable; /* Table which maps from names of commands in - * child interpreter to struct Alias defined + * slave interpreter to struct Alias defined * below. */ -} Child; +} Slave; /* * struct Target: * - * Maps from parent interpreter commands back to the source commands in child + * Maps from master interpreter commands back to the source commands in slave * interpreters. This is needed because aliases can be created between sibling * interpreters and must be deleted when the target interpreter is deleted. In * case they would not be deleted the source interpreter would be left with a - * "dangling pointer". One such record is stored in the Parent record of the - * parent interpreter with the parent for each alias which directs to a - * command in the parent. These records are used to remove the source command - * for an from a child if/when the parent is deleted. They are organized in a - * doubly-linked list attached to the parent interpreter. + * "dangling pointer". One such record is stored in the Master record of the + * master interpreter with the master for each alias which directs to a + * command in the master. These records are used to remove the source command + * for an from a slave if/when the master is deleted. They are organized in a + * doubly-linked list attached to the master interpreter. */ typedef struct Target { - Tcl_Command childCmd; /* Command for alias in child interp. */ - Tcl_Interp *childInterp; /* Child Interpreter. */ + Tcl_Command slaveCmd; /* Command for alias in slave interp. */ + Tcl_Interp *slaveInterp; /* Slave Interpreter. */ struct Target *nextPtr; /* Next in list of target records, or NULL if * at the end of the list of targets. */ struct Target *prevPtr; /* Previous in list of target records, or NULL * if at the start of the list of targets. */ } Target; /* - * Parent: + * struct Master: * - * This record is used for two purposes: First, childTable (a hashtable) maps - * from names of commands to child interpreters. This hashtable is used to - * store information about child interpreters of this interpreter, to map over - * all children, etc. The second purpose is to store information about all - * aliases in children (or siblings) which direct to target commands in this + * 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 interpreters and can + * restricted functionality, can only create safe slave interpreters and can * only load safe extensions. */ -typedef struct { - Tcl_HashTable childTable; /* Hash table for child interpreters. Maps - * from command names to Child records. */ +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 - * children or sibling interpreters that direct + * slaves or sibling interpreters that direct * to commands in this interpreter. This list * is used to remove dangling pointers from - * the child (or sibling) interpreters when + * the slave (or sibling) interpreters when * this interpreter is deleted. */ -} Parent; +} Master; /* - * The following structure keeps track of all the Parent and Child information + * The following structure keeps track of all the Master and Slave information * on a per-interp basis. */ -typedef struct { - Parent parent; /* Keeps track of all interps for which this - * interp is the Parent. */ - Child child; /* Information necessary for this interp to - * function as a child. */ +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 { +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. */ @@ -169,11 +169,11 @@ * callback record, or NULL if the entry has * already been deleted from that hash * table. */ } ScriptLimitCallback; -typedef struct { +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; @@ -212,73 +212,72 @@ /* * Prototypes for local static functions: */ static int AliasCreate(Tcl_Interp *interp, - Tcl_Interp *childInterp, Tcl_Interp *parentInterp, + Tcl_Interp *slaveInterp, Tcl_Interp *masterInterp, Tcl_Obj *namePtr, Tcl_Obj *targetPtr, int objc, Tcl_Obj *const objv[]); static int AliasDelete(Tcl_Interp *interp, - Tcl_Interp *childInterp, Tcl_Obj *namePtr); + Tcl_Interp *slaveInterp, Tcl_Obj *namePtr); static int AliasDescribe(Tcl_Interp *interp, - Tcl_Interp *childInterp, Tcl_Obj *objPtr); -static int AliasList(Tcl_Interp *interp, Tcl_Interp *childInterp); -static Tcl_ObjCmdProc AliasNRCmd; -static Tcl_CmdDeleteProc AliasObjCmdDeleteProc; + Tcl_Interp *slaveInterp, Tcl_Obj *objPtr); +static int AliasList(Tcl_Interp *interp, Tcl_Interp *slaveInterp); +static int AliasObjCmd(ClientData dummy, + Tcl_Interp *currentInterp, int objc, + Tcl_Obj *const objv[]); +static void AliasObjCmdDeleteProc(ClientData clientData); static Tcl_Interp * GetInterp(Tcl_Interp *interp, Tcl_Obj *pathPtr); static Tcl_Interp * GetInterp2(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static Tcl_InterpDeleteProc InterpInfoDeleteProc; -static int ChildBgerror(Tcl_Interp *interp, - Tcl_Interp *childInterp, int objc, - Tcl_Obj *const objv[]); -static Tcl_Interp * ChildCreate(Tcl_Interp *interp, Tcl_Obj *pathPtr, - int safe); -static int ChildDebugCmd(Tcl_Interp *interp, - Tcl_Interp *childInterp, - int objc, Tcl_Obj *const objv[]); -static int ChildEval(Tcl_Interp *interp, Tcl_Interp *childInterp, - int objc, Tcl_Obj *const objv[]); -static int ChildExpose(Tcl_Interp *interp, - Tcl_Interp *childInterp, int objc, - Tcl_Obj *const objv[]); -static int ChildHide(Tcl_Interp *interp, Tcl_Interp *childInterp, - int objc, Tcl_Obj *const objv[]); -static int ChildHidden(Tcl_Interp *interp, - Tcl_Interp *childInterp); -static int ChildInvokeHidden(Tcl_Interp *interp, - Tcl_Interp *childInterp, +static void InterpInfoDeleteProc(ClientData clientData, + Tcl_Interp *interp); +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, + int objc, Tcl_Obj *const objv[]); +static int SlaveEval(Tcl_Interp *interp, Tcl_Interp *slaveInterp, + int objc, Tcl_Obj *const objv[]); +static int SlaveExpose(Tcl_Interp *interp, + Tcl_Interp *slaveInterp, int objc, + Tcl_Obj *const objv[]); +static int SlaveHide(Tcl_Interp *interp, Tcl_Interp *slaveInterp, + int objc, Tcl_Obj *const objv[]); +static int SlaveHidden(Tcl_Interp *interp, + Tcl_Interp *slaveInterp); +static int SlaveInvokeHidden(Tcl_Interp *interp, + Tcl_Interp *slaveInterp, const char *namespaceName, int objc, Tcl_Obj *const objv[]); -static int ChildMarkTrusted(Tcl_Interp *interp, - Tcl_Interp *childInterp); -static Tcl_CmdDeleteProc ChildObjCmdDeleteProc; -static int ChildRecursionLimit(Tcl_Interp *interp, - Tcl_Interp *childInterp, int objc, +static int SlaveMarkTrusted(Tcl_Interp *interp, + Tcl_Interp *slaveInterp); +static int SlaveObjCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static void SlaveObjCmdDeleteProc(ClientData clientData); +static int SlaveRecursionLimit(Tcl_Interp *interp, + Tcl_Interp *slaveInterp, int objc, Tcl_Obj *const objv[]); -static int ChildCommandLimitCmd(Tcl_Interp *interp, - Tcl_Interp *childInterp, int consumedObjc, - int objc, Tcl_Obj *const objv[]); -static int ChildTimeLimitCmd(Tcl_Interp *interp, - Tcl_Interp *childInterp, int consumedObjc, - int objc, Tcl_Obj *const objv[]); -static void InheritLimitsFromParent(Tcl_Interp *childInterp, - Tcl_Interp *parentInterp); +static int SlaveCommandLimitCmd(Tcl_Interp *interp, + Tcl_Interp *slaveInterp, int consumedObjc, + int objc, Tcl_Obj *const objv[]); +static int SlaveTimeLimitCmd(Tcl_Interp *interp, + Tcl_Interp *slaveInterp, int consumedObjc, + int objc, Tcl_Obj *const objv[]); +static void InheritLimitsFromMaster(Tcl_Interp *slaveInterp, + Tcl_Interp *masterInterp); static void SetScriptLimitCallback(Tcl_Interp *interp, int type, Tcl_Interp *targetInterp, Tcl_Obj *scriptObj); static void CallScriptLimitCallback(ClientData clientData, Tcl_Interp *interp); static void DeleteScriptLimitCallback(ClientData clientData); static void RunLimitHandlers(LimitHandler *handlerPtr, Tcl_Interp *interp); static void TimeLimitCallback(ClientData clientData); - -/* NRE enabling */ -static Tcl_NRPostProc NRPostInvokeHidden; -static Tcl_ObjCmdProc NRInterpCmd; -static Tcl_ObjCmdProc NRChildCmd; - /* *---------------------------------------------------------------------- * * TclSetPreInitScript -- @@ -293,15 +292,15 @@ * Changes the way Tcl_Init() routine behaves. * *---------------------------------------------------------------------- */ -const char * +char * TclSetPreInitScript( - const char *string) /* Pointer to a script. */ + char *string) /* Pointer to a script. */ { - const char *prevString = tclPreInitScript; + char *prevString = tclPreInitScript; tclPreInitScript = string; return(prevString); } /* @@ -321,29 +320,18 @@ * Depends on what's in the init.tcl script. * *---------------------------------------------------------------------- */ -typedef struct PkgName { - struct PkgName *nextPtr; /* Next in list of package names being initialized. */ - char name[4]; -} 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; - } + if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) { + return (TCL_ERROR); + }; } /* * In order to find init.tcl during initialization, the following script * is invoked by Tcl_Init(). It looks in several different directories: @@ -383,11 +371,11 @@ * * Note that this entire search mechanism can be bypassed by defining an * alternate tclInit command before calling Tcl_Init(). */ - result = Tcl_EvalEx(interp, + return Tcl_Eval(interp, "if {[namespace which -command tclInit] eq \"\"} {\n" " proc tclInit {} {\n" " global tcl_libPath tcl_library env tclDefaultLibrary\n" " rename tclInit {}\n" " if {[info exists tcl_library]} {\n" @@ -404,19 +392,17 @@ " if {[info exists tclDefaultLibrary]} {\n" " lappend scripts {set tclDefaultLibrary}\n" " } else {\n" " lappend scripts {::tcl::pkgconfig get scriptdir,runtime}\n" " }\n" -" lappend scripts {::tcl::zipfs::tcl_library_init}\n" " lappend scripts {\n" "set parentDir [file dirname [file dirname [info nameofexecutable]]]\n" "set grandParentDir [file dirname $parentDir]\n" "file join $parentDir lib tcl[info tclversion]} \\\n" " {file join $grandParentDir lib tcl[info tclversion]} \\\n" " {file join $parentDir library} \\\n" " {file join $grandParentDir library} \\\n" -" {file join $grandParentDir tcl[info tclversion] library} \\\n" " {file join $grandParentDir tcl[info patchlevel] library} \\\n" " {\n" "file join [file dirname $grandParentDir] tcl[info patchlevel] library}\n" " if {[info exists tcl_libPath]\n" " && [catch {llength $tcl_libPath} len] == 0} {\n" @@ -447,23 +433,19 @@ " append msg \"$errors\n\n\"\n" " append msg \"This probably means that Tcl wasn't installed properly.\n\"\n" " error $msg\n" " }\n" "}\n" -"tclInit", -1, 0); - -end: - *names = (*names)->nextPtr; - return result; +"tclInit"); } /* *--------------------------------------------------------------------------- * * TclInterpInit -- * - * Initializes the invoking interpreter for using the parent, child and + * Initializes the invoking interpreter for using the master, slave and * safe interp facilities. This is called from inside Tcl_CreateInterp(). * * Results: * Always returns TCL_OK for backwards compatibility. * @@ -477,29 +459,28 @@ int TclInterpInit( Tcl_Interp *interp) /* Interpreter to initialize. */ { InterpInfo *interpInfoPtr; - Parent *parentPtr; - Child *childPtr; + Master *masterPtr; + Slave *slavePtr; - interpInfoPtr = (InterpInfo *)Tcl_Alloc(sizeof(InterpInfo)); + interpInfoPtr = (InterpInfo *) ckalloc(sizeof(InterpInfo)); ((Interp *) interp)->interpInfo = interpInfoPtr; - parentPtr = &interpInfoPtr->parent; - Tcl_InitHashTable(&parentPtr->childTable, TCL_STRING_KEYS); - parentPtr->targetsPtr = NULL; - - childPtr = &interpInfoPtr->child; - childPtr->parentInterp = NULL; - childPtr->childEntryPtr = NULL; - childPtr->childInterp = interp; - childPtr->interpCmd = NULL; - Tcl_InitHashTable(&childPtr->aliasTable, TCL_STRING_KEYS); - - Tcl_NRCreateCommand(interp, "interp", Tcl_InterpObjCmd, NRInterpCmd, - NULL, NULL); + masterPtr = &interpInfoPtr->master; + Tcl_InitHashTable(&masterPtr->slaveTable, TCL_STRING_KEYS); + masterPtr->targetsPtr = NULL; + + slavePtr = &interpInfoPtr->slave; + slavePtr->masterInterp = NULL; + slavePtr->slaveEntryPtr = NULL; + slavePtr->slaveInterp = interp; + slavePtr->interpCmd = NULL; + Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); + + Tcl_CreateObjCommand(interp, "interp", Tcl_InterpObjCmd, NULL, NULL); Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL); return TCL_OK; } @@ -507,11 +488,11 @@ *--------------------------------------------------------------------------- * * InterpInfoDeleteProc -- * * Invoked when an interpreter is being deleted. It releases all storage - * used by the parent/child/safe interpreter facilities. + * used by the master/slave/safe interpreter facilities. * * Results: * None. * * Side effects: @@ -520,68 +501,68 @@ *--------------------------------------------------------------------------- */ static void InterpInfoDeleteProc( - TCL_UNUSED(void *), + ClientData clientData, /* Ignored. */ Tcl_Interp *interp) /* Interp being deleted. All commands for - * child interps should already be deleted. */ + * slave interps should already be deleted. */ { InterpInfo *interpInfoPtr; - Child *childPtr; - Parent *parentPtr; + Slave *slavePtr; + Master *masterPtr; Target *targetPtr; interpInfoPtr = (InterpInfo *) ((Interp *) interp)->interpInfo; /* * There shouldn't be any commands left. */ - parentPtr = &interpInfoPtr->parent; - if (parentPtr->childTable.numEntries != 0) { + masterPtr = &interpInfoPtr->master; + if (masterPtr->slaveTable.numEntries != 0) { Tcl_Panic("InterpInfoDeleteProc: still exist commands"); } - Tcl_DeleteHashTable(&parentPtr->childTable); + Tcl_DeleteHashTable(&masterPtr->slaveTable); /* * Tell any interps that have aliases to this interp that they should * delete those aliases. If the other interp was already dead, it would * have removed the target record already. */ - for (targetPtr = parentPtr->targetsPtr; targetPtr != NULL; ) { + for (targetPtr = masterPtr->targetsPtr; targetPtr != NULL; ) { Target *tmpPtr = targetPtr->nextPtr; - Tcl_DeleteCommandFromToken(targetPtr->childInterp, - targetPtr->childCmd); + Tcl_DeleteCommandFromToken(targetPtr->slaveInterp, + targetPtr->slaveCmd); targetPtr = tmpPtr; } - childPtr = &interpInfoPtr->child; - if (childPtr->interpCmd != NULL) { + slavePtr = &interpInfoPtr->slave; + if (slavePtr->interpCmd != NULL) { /* * Tcl_DeleteInterp() was called on this interpreter, rather "interp - * delete" or the equivalent deletion of the command in the parent. + * delete" or the equivalent deletion of the command in the master. * First ensure that the cleanup callback doesn't try to delete the * interp again. */ - childPtr->childInterp = NULL; - Tcl_DeleteCommandFromToken(childPtr->parentInterp, - childPtr->interpCmd); + slavePtr->slaveInterp = NULL; + Tcl_DeleteCommandFromToken(slavePtr->masterInterp, + slavePtr->interpCmd); } /* * There shouldn't be any aliases left. */ - if (childPtr->aliasTable.numEntries != 0) { + if (slavePtr->aliasTable.numEntries != 0) { Tcl_Panic("InterpInfoDeleteProc: still exist aliases"); } - Tcl_DeleteHashTable(&childPtr->aliasTable); + Tcl_DeleteHashTable(&slavePtr->aliasTable); - Tcl_Free(interpInfoPtr); + ckfree((char *) interpInfoPtr); } /* *---------------------------------------------------------------------- * @@ -596,198 +577,106 @@ * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ - -int -Tcl_InterpObjCmd( - ClientData clientData, - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - return Tcl_NRCallObjProc(interp, NRInterpCmd, clientData, objc, objv); -} - -static int -NRInterpCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Interp *childInterp; - int index; - static const char *const options[] = { - "alias", "aliases", "bgerror", "cancel", - "children", "create", "debug", "delete", - "eval", "exists", "expose", "hide", - "hidden", "issafe", "invokehidden", - "limit", "marktrusted", "recursionlimit", - "share", -#ifndef TCL_NO_DEPRECATED - "slaves", -#endif - "target", "transfer", NULL - }; - static const char *const optionsNoSlaves[] = { - "alias", "aliases", "bgerror", "cancel", - "children", "create", "debug", "delete", - "eval", "exists", "expose", - "hide", "hidden", "issafe", - "invokehidden", "limit", "marktrusted", "recursionlimit", - "share", "target", "transfer", - NULL - }; - enum interpOptionEnum { - OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CANCEL, - OPT_CHILDREN, OPT_CREATE, OPT_DEBUG, OPT_DELETE, - OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, OPT_HIDE, - OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID, - OPT_LIMIT, OPT_MARKTRUSTED, OPT_RECLIMIT, OPT_SHARE, -#ifndef TCL_NO_DEPRECATED - OPT_SLAVES, -#endif - OPT_TARGET, OPT_TRANSFER + /* ARGSUSED */ +int +Tcl_InterpObjCmd( + ClientData clientData, /* Unused. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int index; + static const char *options[] = { + "alias", "aliases", "bgerror", "create", + "debug", "delete", "eval", "exists", "expose", + "hide", "hidden", "issafe", "invokehidden", + "limit", "marktrusted", "recursionlimit","slaves", + "share", "target", "transfer", + NULL + }; + enum option { + OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CREATE, + OPT_DEBUG, OPT_DELETE, OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, + OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID, + OPT_LIMIT, OPT_MARKTRUSTED,OPT_RECLIMIT, OPT_SLAVES, + OPT_SHARE, OPT_TARGET, OPT_TRANSFER }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(NULL, objv[1], options, - "option", 0, &index) != TCL_OK) { - /* Don't report the "slaves" option as possibility */ - Tcl_GetIndexFromObj(interp, objv[1], optionsNoSlaves, - "option", 0, &index); + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, + &index) != TCL_OK) { return TCL_ERROR; } - switch ((enum interpOptionEnum)index) { + switch ((enum option) index) { case OPT_ALIAS: { - Tcl_Interp *parentInterp; + Tcl_Interp *slaveInterp, *masterInterp; if (objc < 4) { aliasArgs: Tcl_WrongNumArgs(interp, 2, objv, - "childPath childCmd ?parentPath parentCmd? ?arg ...?"); + "slavePath slaveCmd ?masterPath masterCmd? ?args ..?"); return TCL_ERROR; } - childInterp = GetInterp(interp, objv[2]); - if (childInterp == NULL) { + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { return TCL_ERROR; } if (objc == 4) { - return AliasDescribe(interp, childInterp, objv[3]); + return AliasDescribe(interp, slaveInterp, objv[3]); } if ((objc == 5) && (TclGetString(objv[4])[0] == '\0')) { - return AliasDelete(interp, childInterp, objv[3]); + return AliasDelete(interp, slaveInterp, objv[3]); } if (objc > 5) { - parentInterp = GetInterp(interp, objv[4]); - if (parentInterp == NULL) { + masterInterp = GetInterp(interp, objv[4]); + if (masterInterp == NULL) { return TCL_ERROR; } - - return AliasCreate(interp, childInterp, parentInterp, objv[3], - objv[5], objc - 6, objv + 6); + if (TclGetString(objv[5])[0] == '\0') { + if (objc == 6) { + return AliasDelete(interp, slaveInterp, objv[3]); + } + } else { + return AliasCreate(interp, slaveInterp, masterInterp, objv[3], + objv[5], objc - 6, objv + 6); + } } goto aliasArgs; } - case OPT_ALIASES: - childInterp = GetInterp2(interp, objc, objv); - if (childInterp == NULL) { + case OPT_ALIASES: { + Tcl_Interp *slaveInterp; + + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { return TCL_ERROR; } - return AliasList(interp, childInterp); - case OPT_BGERROR: + return AliasList(interp, slaveInterp); + } + case OPT_BGERROR: { + Tcl_Interp *slaveInterp; + if (objc != 3 && objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "path ?cmdPrefix?"); return TCL_ERROR; } - childInterp = GetInterp(interp, objv[2]); - if (childInterp == NULL) { - return TCL_ERROR; - } - return ChildBgerror(interp, childInterp, objc - 3, objv + 3); - case OPT_CANCEL: { - int i, flags; - Tcl_Obj *resultObjPtr; - static const char *const cancelOptions[] = { - "-unwind", "--", NULL - }; - enum optionCancelEnum { - OPT_UNWIND, OPT_LAST - }; - - flags = 0; - - for (i = 2; i < objc; i++) { - if (TclGetString(objv[i])[0] != '-') { - break; - } - if (Tcl_GetIndexFromObj(interp, objv[i], cancelOptions, "option", - 0, &index) != TCL_OK) { - return TCL_ERROR; - } - - switch ((enum optionCancelEnum) index) { - case OPT_UNWIND: - /* - * The evaluation stack in the target interp is to be unwound. - */ - - flags |= TCL_CANCEL_UNWIND; - break; - case OPT_LAST: - i++; - goto endOfForLoop; - } - } - - endOfForLoop: - if (i < objc - 2) { - Tcl_WrongNumArgs(interp, 2, objv, - "?-unwind? ?--? ?path? ?result?"); - return TCL_ERROR; - } - - /* - * Did they specify a child interp to cancel the script in progress - * in? If not, use the current interp. - */ - - if (i < objc) { - childInterp = GetInterp(interp, objv[i]); - if (childInterp == NULL) { - return TCL_ERROR; - } - i++; - } else { - childInterp = interp; - } - - if (i < objc) { - resultObjPtr = objv[i]; - - /* - * Tcl_CancelEval removes this reference. - */ - - Tcl_IncrRefCount(resultObjPtr); - i++; - } else { - resultObjPtr = NULL; - } - - return Tcl_CancelEval(childInterp, resultObjPtr, 0, flags); + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveBgerror(interp, slaveInterp, objc - 3, objv + 3); } case OPT_CREATE: { int i, last, safe; - Tcl_Obj *childPtr; + Tcl_Obj *slavePtr; char buf[16 + TCL_INTEGER_SPACE]; - static const char *const createOptions[] = { + static const char *options[] = { "-safe", "--", NULL }; enum option { OPT_SAFE, OPT_LAST }; @@ -796,40 +685,40 @@ /* * Weird historical rules: "-safe" is accepted at the end, too. */ - childPtr = NULL; + slavePtr = NULL; last = 0; for (i = 2; i < objc; i++) { - if ((last == 0) && (TclGetString(objv[i])[0] == '-')) { - if (Tcl_GetIndexFromObj(interp, objv[i], createOptions, - "option", 0, &index) != TCL_OK) { + if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) { + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, + &index) != TCL_OK) { return TCL_ERROR; } if (index == OPT_SAFE) { safe = 1; continue; } i++; last = 1; } - if (childPtr != NULL) { + if (slavePtr != NULL) { Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?"); return TCL_ERROR; } if (i < objc) { - childPtr = objv[i]; + slavePtr = objv[i]; } } buf[0] = '\0'; - if (childPtr == NULL) { + if (slavePtr == NULL) { /* * Create an anonymous interpreter -- we choose its name and the * name of the command. We check that the command name that we use * for the interpreter does not collide with an existing command - * in the parent interpreter. + * in the master interpreter. */ for (i = 0; ; i++) { Tcl_CmdInfo cmdInfo; @@ -836,117 +725,137 @@ sprintf(buf, "interp%d", i); if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) { break; } } - childPtr = Tcl_NewStringObj(buf, -1); + slavePtr = Tcl_NewStringObj(buf, -1); } - if (ChildCreate(interp, childPtr, safe) == NULL) { + if (SlaveCreate(interp, slavePtr, safe) == NULL) { if (buf[0] != '\0') { - Tcl_DecrRefCount(childPtr); + Tcl_DecrRefCount(slavePtr); } return TCL_ERROR; } - Tcl_SetObjResult(interp, childPtr); + Tcl_SetObjResult(interp, slavePtr); return TCL_OK; } - case OPT_DEBUG: /* TIP #378 */ + case OPT_DEBUG: { + /* TIP #378 */ + Tcl_Interp *slaveInterp; + /* * Currently only -frame supported, otherwise ?-option ?value?? */ - if (objc < 3 || objc > 5) { Tcl_WrongNumArgs(interp, 2, objv, "path ?-frame ?bool??"); return TCL_ERROR; } - childInterp = GetInterp(interp, objv[2]); - if (childInterp == NULL) { + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { return TCL_ERROR; } - return ChildDebugCmd(interp, childInterp, objc - 3, objv + 3); + return SlaveDebugCmd(interp, slaveInterp, objc - 3, objv + 3); + } case OPT_DELETE: { int i; InterpInfo *iiPtr; + Tcl_Interp *slaveInterp; for (i = 2; i < objc; i++) { - childInterp = GetInterp(interp, objv[i]); - if (childInterp == NULL) { + slaveInterp = GetInterp(interp, objv[i]); + if (slaveInterp == NULL) { return TCL_ERROR; - } else if (childInterp == interp) { + } else if (slaveInterp == interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot delete the current interpreter", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", - "DELETESELF", NULL); return TCL_ERROR; } - iiPtr = (InterpInfo *) ((Interp *) childInterp)->interpInfo; - Tcl_DeleteCommandFromToken(iiPtr->child.parentInterp, - iiPtr->child.interpCmd); + iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; + Tcl_DeleteCommandFromToken(iiPtr->slave.masterInterp, + iiPtr->slave.interpCmd); } return TCL_OK; } - case OPT_EVAL: + case OPT_EVAL: { + Tcl_Interp *slaveInterp; + if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?"); return TCL_ERROR; } - childInterp = GetInterp(interp, objv[2]); - if (childInterp == NULL) { + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { return TCL_ERROR; } - return ChildEval(interp, childInterp, objc - 3, objv + 3); + return SlaveEval(interp, slaveInterp, objc - 3, objv + 3); + } case OPT_EXISTS: { - int exists = 1; + int exists; + Tcl_Interp *slaveInterp; - childInterp = GetInterp2(interp, objc, objv); - if (childInterp == NULL) { + exists = 1; + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { if (objc > 3) { return TCL_ERROR; } Tcl_ResetResult(interp); exists = 0; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists)); return TCL_OK; } - case OPT_EXPOSE: + case OPT_EXPOSE: { + Tcl_Interp *slaveInterp; + if ((objc < 4) || (objc > 5)) { Tcl_WrongNumArgs(interp, 2, objv, "path hiddenCmdName ?cmdName?"); return TCL_ERROR; } - childInterp = GetInterp(interp, objv[2]); - if (childInterp == NULL) { + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { return TCL_ERROR; } - return ChildExpose(interp, childInterp, objc - 3, objv + 3); - case OPT_HIDE: + return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3); + } + case OPT_HIDE: { + Tcl_Interp *slaveInterp; /* A slave. */ + if ((objc < 4) || (objc > 5)) { Tcl_WrongNumArgs(interp, 2, objv, "path cmdName ?hiddenCmdName?"); return TCL_ERROR; } - childInterp = GetInterp(interp, objv[2]); - if (childInterp == NULL) { - return TCL_ERROR; - } - return ChildHide(interp, childInterp, objc - 3, objv + 3); - case OPT_HIDDEN: - childInterp = GetInterp2(interp, objc, objv); - if (childInterp == NULL) { - return TCL_ERROR; - } - return ChildHidden(interp, childInterp); - case OPT_ISSAFE: - childInterp = GetInterp2(interp, objc, objv); - if (childInterp == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(childInterp))); + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveHide(interp, slaveInterp, objc - 3, objv + 3); + } + case OPT_HIDDEN: { + Tcl_Interp *slaveInterp; /* A slave. */ + + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveHidden(interp, slaveInterp); + } + case OPT_ISSAFE: { + Tcl_Interp *slaveInterp; + + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); return TCL_OK; + } case OPT_INVOKEHID: { - int i; + int i, index; const char *namespaceName; - static const char *const hiddenOptions[] = { + Tcl_Interp *slaveInterp; + static const char *hiddenOptions[] = { "-global", "-namespace", "--", NULL }; enum hiddenOption { OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST }; @@ -976,163 +885,167 @@ if (objc - i < 1) { Tcl_WrongNumArgs(interp, 2, objv, "path ?-namespace ns? ?-global? ?--? cmd ?arg ..?"); return TCL_ERROR; } - childInterp = GetInterp(interp, objv[2]); - if (childInterp == NULL) { + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { return TCL_ERROR; } - return ChildInvokeHidden(interp, childInterp, namespaceName, objc - i, + return SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc - i, objv + i); } case OPT_LIMIT: { - static const char *const limitTypes[] = { + Tcl_Interp *slaveInterp; + static const char *limitTypes[] = { "commands", "time", NULL }; enum LimitTypes { LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME }; int limitType; if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, - "path limitType ?-option value ...?"); + Tcl_WrongNumArgs(interp, 2, objv, "path limitType ?options?"); return TCL_ERROR; } - childInterp = GetInterp(interp, objv[2]); - if (childInterp == NULL) { + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[3], limitTypes, "limit type", 0, &limitType) != TCL_OK) { return TCL_ERROR; } switch ((enum LimitTypes) limitType) { case LIMIT_TYPE_COMMANDS: - return ChildCommandLimitCmd(interp, childInterp, 4, objc,objv); + return SlaveCommandLimitCmd(interp, slaveInterp, 4, objc,objv); case LIMIT_TYPE_TIME: - return ChildTimeLimitCmd(interp, childInterp, 4, objc, objv); + return SlaveTimeLimitCmd(interp, slaveInterp, 4, objc, objv); } } break; - case OPT_MARKTRUSTED: + case OPT_MARKTRUSTED: { + Tcl_Interp *slaveInterp; + if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "path"); return TCL_ERROR; } - childInterp = GetInterp(interp, objv[2]); - if (childInterp == NULL) { + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { return TCL_ERROR; } - return ChildMarkTrusted(interp, childInterp); - case OPT_RECLIMIT: + return SlaveMarkTrusted(interp, slaveInterp); + } + case OPT_RECLIMIT: { + Tcl_Interp *slaveInterp; + if (objc != 3 && objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?"); return TCL_ERROR; } - childInterp = GetInterp(interp, objv[2]); - if (childInterp == NULL) { + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { return TCL_ERROR; } - return ChildRecursionLimit(interp, childInterp, objc - 3, objv + 3); -#ifndef TCL_NO_DEPRECATED - case OPT_SLAVES: -#endif - case OPT_CHILDREN: { + return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3); + } + case OPT_SLAVES: { + Tcl_Interp *slaveInterp; InterpInfo *iiPtr; Tcl_Obj *resultPtr; Tcl_HashEntry *hPtr; Tcl_HashSearch hashSearch; char *string; - childInterp = GetInterp2(interp, objc, objv); - if (childInterp == NULL) { + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { return TCL_ERROR; } - iiPtr = (InterpInfo *) ((Interp *) childInterp)->interpInfo; - TclNewObj(resultPtr); - hPtr = Tcl_FirstHashEntry(&iiPtr->parent.childTable, &hashSearch); + 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->parent.childTable, hPtr); + string = Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr); Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewStringObj(string, -1)); } Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } case OPT_TRANSFER: case OPT_SHARE: { - Tcl_Interp *parentInterp; /* The parent of the child. */ + Tcl_Interp *slaveInterp; /* A slave. */ + Tcl_Interp *masterInterp; /* Its master. */ Tcl_Channel chan; if (objc != 5) { Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath"); return TCL_ERROR; } - parentInterp = GetInterp(interp, objv[2]); - if (parentInterp == NULL) { + masterInterp = GetInterp(interp, objv[2]); + if (masterInterp == NULL) { return TCL_ERROR; } - chan = Tcl_GetChannel(parentInterp, TclGetString(objv[3]), NULL); + chan = Tcl_GetChannel(masterInterp, TclGetString(objv[3]), NULL); if (chan == NULL) { - Tcl_TransferResult(parentInterp, TCL_OK, interp); + TclTransferResult(masterInterp, TCL_OK, interp); return TCL_ERROR; } - childInterp = GetInterp(interp, objv[4]); - if (childInterp == NULL) { + slaveInterp = GetInterp(interp, objv[4]); + if (slaveInterp == NULL) { return TCL_ERROR; } - Tcl_RegisterChannel(childInterp, chan); + Tcl_RegisterChannel(slaveInterp, chan); if (index == OPT_TRANSFER) { /* * When transferring, as opposed to sharing, we must unhitch the * channel from the interpreter where it started. */ - if (Tcl_UnregisterChannel(parentInterp, chan) != TCL_OK) { - Tcl_TransferResult(parentInterp, TCL_OK, interp); + if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) { + TclTransferResult(masterInterp, TCL_OK, interp); return TCL_ERROR; } } return TCL_OK; } case OPT_TARGET: { + Tcl_Interp *slaveInterp; InterpInfo *iiPtr; Tcl_HashEntry *hPtr; Alias *aliasPtr; - const char *aliasName; + char *aliasName; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "path alias"); return TCL_ERROR; } - childInterp = GetInterp(interp, objv[2]); - if (childInterp == NULL) { + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { return TCL_ERROR; } aliasName = TclGetString(objv[3]); - iiPtr = (InterpInfo *) ((Interp *) childInterp)->interpInfo; - hPtr = Tcl_FindHashEntry(&iiPtr->child.aliasTable, aliasName); + 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, TclGetString(objv[2]))); + Tcl_AppendResult(interp, "alias \"", aliasName, "\" in path \"", + Tcl_GetString(objv[2]), "\" not found", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); return TCL_ERROR; } - aliasPtr = (Alias *)Tcl_GetHashValue(hPtr); + aliasPtr = Tcl_GetHashValue(hPtr); if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "target interpreter for alias \"%s\" in path \"%s\" is " - "not my descendant", aliasName, TclGetString(objv[2]))); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", - "TARGETSHROUDED", NULL); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "target interpreter for alias \"", + aliasName, "\" in path \"", Tcl_GetString(objv[2]), + "\" is not my descendant", NULL); return TCL_ERROR; } return TCL_OK; } } @@ -1186,50 +1099,51 @@ * * Results: * A standard Tcl result. * * Side effects: - * Creates a new alias, manipulates the result field of childInterp. + * Creates a new alias, manipulates the result field of slaveInterp. * *---------------------------------------------------------------------- */ int Tcl_CreateAlias( - Tcl_Interp *childInterp, /* Interpreter for source command. */ - const char *childCmd, /* Command to install in child. */ + Tcl_Interp *slaveInterp, /* Interpreter for source command. */ + const char *slaveCmd, /* Command to install in slave. */ Tcl_Interp *targetInterp, /* Interpreter for target command. */ const char *targetCmd, /* Name of target command. */ int argc, /* How many additional arguments? */ const char *const *argv) /* These are the additional args. */ { - Tcl_Obj *childObjPtr, *targetObjPtr; + Tcl_Obj *slaveObjPtr, *targetObjPtr; Tcl_Obj **objv; int i; int result; - objv = (Tcl_Obj **)TclStackAlloc(childInterp, sizeof(Tcl_Obj *) * argc); + objv = (Tcl_Obj **) + TclStackAlloc(slaveInterp, (unsigned) sizeof(Tcl_Obj *) * argc); for (i = 0; i < argc; i++) { objv[i] = Tcl_NewStringObj(argv[i], -1); Tcl_IncrRefCount(objv[i]); } - childObjPtr = Tcl_NewStringObj(childCmd, -1); - Tcl_IncrRefCount(childObjPtr); + slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1); + Tcl_IncrRefCount(slaveObjPtr); targetObjPtr = Tcl_NewStringObj(targetCmd, -1); Tcl_IncrRefCount(targetObjPtr); - result = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr, + result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr, targetObjPtr, argc, objv); for (i = 0; i < argc; i++) { Tcl_DecrRefCount(objv[i]); } - TclStackFree(childInterp, objv); + TclStackFree(slaveInterp, objv); Tcl_DecrRefCount(targetObjPtr); - Tcl_DecrRefCount(childObjPtr); + Tcl_DecrRefCount(slaveObjPtr); return result; } /* @@ -1248,30 +1162,30 @@ *---------------------------------------------------------------------- */ int Tcl_CreateAliasObj( - Tcl_Interp *childInterp, /* Interpreter for source command. */ - const char *childCmd, /* Command to install in child. */ + Tcl_Interp *slaveInterp, /* Interpreter for source command. */ + const char *slaveCmd, /* Command to install in slave. */ Tcl_Interp *targetInterp, /* Interpreter for target command. */ const char *targetCmd, /* Name of target command. */ int objc, /* How many additional arguments? */ Tcl_Obj *const objv[]) /* Argument vector. */ { - Tcl_Obj *childObjPtr, *targetObjPtr; + Tcl_Obj *slaveObjPtr, *targetObjPtr; int result; - childObjPtr = Tcl_NewStringObj(childCmd, -1); - Tcl_IncrRefCount(childObjPtr); + slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1); + Tcl_IncrRefCount(slaveObjPtr); targetObjPtr = Tcl_NewStringObj(targetCmd, -1); Tcl_IncrRefCount(targetObjPtr); - result = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr, + result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr, targetObjPtr, objc, objv); - Tcl_DecrRefCount(childObjPtr); + Tcl_DecrRefCount(slaveObjPtr); Tcl_DecrRefCount(targetObjPtr); return result; } /* @@ -1304,18 +1218,17 @@ Tcl_HashEntry *hPtr; Alias *aliasPtr; int i, objc; Tcl_Obj **objv; - hPtr = Tcl_FindHashEntry(&iiPtr->child.aliasTable, aliasName); + hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "alias \"%s\" not found", aliasName)); + Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); return TCL_ERROR; } - aliasPtr = (Alias *)Tcl_GetHashValue(hPtr); + aliasPtr = Tcl_GetHashValue(hPtr); objc = aliasPtr->objc; objv = &aliasPtr->objPtr; if (targetInterpPtr != NULL) { *targetInterpPtr = aliasPtr->targetInterp; @@ -1326,11 +1239,11 @@ if (argcPtr != NULL) { *argcPtr = objc - 1; } if (argvPtr != NULL) { *argvPtr = (const char **) - Tcl_Alloc(sizeof(const char *) * (objc - 1)); + ckalloc((unsigned) sizeof(const char *) * (objc - 1)); for (i = 1; i < objc; i++) { (*argvPtr)[i - 1] = TclGetString(objv[i]); } } return TCL_OK; @@ -1366,18 +1279,17 @@ Tcl_HashEntry *hPtr; Alias *aliasPtr; int objc; Tcl_Obj **objv; - hPtr = Tcl_FindHashEntry(&iiPtr->child.aliasTable, aliasName); + hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "alias \"%s\" not found", aliasName)); + Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); return TCL_ERROR; } - aliasPtr = (Alias *)Tcl_GetHashValue(hPtr); + aliasPtr = Tcl_GetHashValue(hPtr); objc = aliasPtr->objc; objv = &aliasPtr->objPtr; if (targetInterpPtr != NULL) { *targetInterpPtr = aliasPtr->targetInterp; @@ -1431,22 +1343,21 @@ /* * If we are not creating or renaming an alias, then it is always OK to * create or rename the command. */ - if (cmdPtr->objProc != TclAliasObjCmd - && cmdPtr->objProc != TclLocalAliasObjCmd) { + if (cmdPtr->objProc != AliasObjCmd) { return TCL_OK; } /* * 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; + aliasPtr = (Alias *) cmdPtr->objClientData; nextAliasPtr = aliasPtr; while (1) { Tcl_Obj *cmdNamePtr; /* @@ -1454,17 +1365,17 @@ * source alias, we have a loop. */ if (Tcl_InterpDeleted(nextAliasPtr->targetInterp)) { /* - * The child interpreter can be deleted while creating the alias. + * The slave interpreter can be deleted while creating the alias. * [Bug #641195] */ - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "cannot define or rename alias \"%s\": interpreter deleted", - Tcl_GetCommandName(cmdInterp, cmd))); + Tcl_AppendResult(interp, "cannot define or rename alias \"", + Tcl_GetCommandName(cmdInterp, cmd), + "\": interpreter deleted", NULL); return TCL_ERROR; } cmdNamePtr = nextAliasPtr->objPtr; aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp, TclGetString(cmdNamePtr), @@ -1473,30 +1384,29 @@ if (aliasCmd == NULL) { return TCL_OK; } aliasCmdPtr = (Command *) aliasCmd; if (aliasCmdPtr == cmdPtr) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "cannot define or rename alias \"%s\": would create a loop", - Tcl_GetCommandName(cmdInterp, cmd))); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", - "ALIASLOOP", NULL); + Tcl_AppendResult(interp, "cannot define or rename alias \"", + Tcl_GetCommandName(cmdInterp, cmd), + "\": would create a loop", NULL); return TCL_ERROR; } /* * Otherwise, follow the chain one step further. See if the target * command is an alias - if so, follow the loop to its target command. * Otherwise we do not have a loop. */ - if (aliasCmdPtr->objProc != TclAliasObjCmd - && aliasCmdPtr->objProc != TclLocalAliasObjCmd) { + if (aliasCmdPtr->objProc != AliasObjCmd) { return TCL_OK; } - nextAliasPtr = (Alias *)aliasCmdPtr->objClientData; + nextAliasPtr = (Alias *) aliasCmdPtr->objClientData; } + + /* NOTREACHED */ } /* *---------------------------------------------------------------------- * @@ -1507,39 +1417,40 @@ * Results: * A standard Tcl result. * * Side effects: * An alias command is created and entered into the alias table for the - * child interpreter. + * slave interpreter. * *---------------------------------------------------------------------- */ static int AliasCreate( Tcl_Interp *interp, /* Interp for error reporting. */ - Tcl_Interp *childInterp, /* Interp where alias cmd will live or from + Tcl_Interp *slaveInterp, /* Interp where alias cmd will live or from * which alias will be deleted. */ - Tcl_Interp *parentInterp, /* Interp in which target command will be + Tcl_Interp *masterInterp, /* Interp in which target command will be * invoked. */ Tcl_Obj *namePtr, /* Name of alias cmd. */ Tcl_Obj *targetNamePtr, /* Name of target cmd. */ int objc, /* Additional arguments to store */ Tcl_Obj *const objv[]) /* with alias. */ { Alias *aliasPtr; Tcl_HashEntry *hPtr; Target *targetPtr; - Child *childPtr; - Parent *parentPtr; + Slave *slavePtr; + Master *masterPtr; Tcl_Obj **prefv; int isNew, i; - aliasPtr = (Alias *)Tcl_Alloc(sizeof(Alias) + objc * sizeof(Tcl_Obj *)); + aliasPtr = (Alias *) ckalloc((unsigned) (sizeof(Alias) + + objc * sizeof(Tcl_Obj *))); aliasPtr->token = namePtr; Tcl_IncrRefCount(aliasPtr->token); - aliasPtr->targetInterp = parentInterp; + aliasPtr->targetInterp = masterInterp; aliasPtr->objc = objc + 1; prefv = &aliasPtr->objPtr; *prefv = targetNamePtr; @@ -1547,25 +1458,19 @@ for (i = 0; i < objc; i++) { *(++prefv) = objv[i]; Tcl_IncrRefCount(objv[i]); } - Tcl_Preserve(childInterp); - Tcl_Preserve(parentInterp); - - if (childInterp == parentInterp) { - aliasPtr->childCmd = Tcl_NRCreateCommand(childInterp, - TclGetString(namePtr), TclLocalAliasObjCmd, AliasNRCmd, - aliasPtr, AliasObjCmdDeleteProc); - } else { - aliasPtr->childCmd = Tcl_CreateObjCommand(childInterp, - TclGetString(namePtr), TclAliasObjCmd, aliasPtr, - AliasObjCmdDeleteProc); - } - - if (TclPreventAliasLoop(interp, childInterp, - aliasPtr->childCmd) != TCL_OK) { + Tcl_Preserve(slaveInterp); + Tcl_Preserve(masterInterp); + + aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp, + TclGetString(namePtr), AliasObjCmd, aliasPtr, + AliasObjCmdDeleteProc); + + if (TclPreventAliasLoop(interp, slaveInterp, + aliasPtr->slaveCmd) != TCL_OK) { /* * Found an alias loop! The last call to Tcl_CreateObjCommand made the * alias point to itself. Delete the command and its alias record. Be * careful to wipe out its client data first, so the command doesn't * try to delete itself. @@ -1577,38 +1482,38 @@ Tcl_DecrRefCount(targetNamePtr); for (i = 0; i < objc; i++) { Tcl_DecrRefCount(objv[i]); } - cmdPtr = (Command *) aliasPtr->childCmd; + cmdPtr = (Command *) aliasPtr->slaveCmd; cmdPtr->clientData = NULL; cmdPtr->deleteProc = NULL; cmdPtr->deleteData = NULL; - Tcl_DeleteCommandFromToken(childInterp, aliasPtr->childCmd); + Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); - Tcl_Free(aliasPtr); + ckfree((char *) aliasPtr); /* * The result was already set by TclPreventAliasLoop. */ - Tcl_Release(childInterp); - Tcl_Release(parentInterp); + Tcl_Release(slaveInterp); + Tcl_Release(masterInterp); return TCL_ERROR; } /* * Make an entry in the alias table. If it already exists, retry. */ - childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child; + slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; while (1) { Tcl_Obj *newToken; - const char *string; + char *string; string = TclGetString(aliasPtr->token); - hPtr = Tcl_CreateHashEntry(&childPtr->aliasTable, string, &isNew); + hPtr = Tcl_CreateHashEntry(&slavePtr->aliasTable, string, &isNew); if (isNew != 0) { break; } /* @@ -1640,73 +1545,73 @@ * interp alias {} foo {} bar # Create an alias "foo" * rename foo zop # Now rename the alias * interp alias {} foo {} zop # Now recreate "foo"... */ - targetPtr = (Target *)Tcl_Alloc(sizeof(Target)); - targetPtr->childCmd = aliasPtr->childCmd; - targetPtr->childInterp = childInterp; + targetPtr = (Target *) ckalloc((unsigned) sizeof(Target)); + targetPtr->slaveCmd = aliasPtr->slaveCmd; + targetPtr->slaveInterp = slaveInterp; - parentPtr = &((InterpInfo*) ((Interp*) parentInterp)->interpInfo)->parent; - targetPtr->nextPtr = parentPtr->targetsPtr; + masterPtr = &((InterpInfo *) ((Interp*) masterInterp)->interpInfo)->master; + targetPtr->nextPtr = masterPtr->targetsPtr; targetPtr->prevPtr = NULL; - if (parentPtr->targetsPtr != NULL) { - parentPtr->targetsPtr->prevPtr = targetPtr; + if (masterPtr->targetsPtr != NULL) { + masterPtr->targetsPtr->prevPtr = targetPtr; } - parentPtr->targetsPtr = targetPtr; + masterPtr->targetsPtr = targetPtr; aliasPtr->targetPtr = targetPtr; Tcl_SetObjResult(interp, aliasPtr->token); - Tcl_Release(childInterp); - Tcl_Release(parentInterp); + Tcl_Release(slaveInterp); + Tcl_Release(masterInterp); return TCL_OK; } /* *---------------------------------------------------------------------- * * AliasDelete -- * - * Deletes the given alias from the child interpreter given. + * Deletes the given alias from the slave interpreter given. * * Results: * A standard Tcl result. * * Side effects: - * Deletes the alias from the child interpreter. + * Deletes the alias from the slave interpreter. * *---------------------------------------------------------------------- */ static int AliasDelete( Tcl_Interp *interp, /* Interpreter for result & errors. */ - Tcl_Interp *childInterp, /* Interpreter containing alias. */ + Tcl_Interp *slaveInterp, /* Interpreter containing alias. */ Tcl_Obj *namePtr) /* Name of alias to delete. */ { - Child *childPtr; + Slave *slavePtr; Alias *aliasPtr; Tcl_HashEntry *hPtr; /* - * If the alias has been renamed in the child, the parent can still use + * 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 * delete it. */ - childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child; - hPtr = Tcl_FindHashEntry(&childPtr->aliasTable, TclGetString(namePtr)); + slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; + hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, TclGetString(namePtr)); if (hPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "alias \"%s\" not found", TclGetString(namePtr))); + Tcl_AppendResult(interp, "alias \"", TclGetString(namePtr), + "\" not found", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", TclGetString(namePtr), NULL); return TCL_ERROR; } - aliasPtr = (Alias *)Tcl_GetHashValue(hPtr); - Tcl_DeleteCommandFromToken(childInterp, aliasPtr->childCmd); + aliasPtr = Tcl_GetHashValue(hPtr); + Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -1727,30 +1632,30 @@ */ static int AliasDescribe( Tcl_Interp *interp, /* Interpreter for result & errors. */ - Tcl_Interp *childInterp, /* Interpreter containing alias. */ + Tcl_Interp *slaveInterp, /* Interpreter containing alias. */ Tcl_Obj *namePtr) /* Name of alias to describe. */ { - Child *childPtr; + Slave *slavePtr; Tcl_HashEntry *hPtr; Alias *aliasPtr; Tcl_Obj *prefixPtr; /* - * If the alias has been renamed in the child, the parent can still use + * 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. */ - childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child; - hPtr = Tcl_FindHashEntry(&childPtr->aliasTable, TclGetString(namePtr)); + 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); + aliasPtr = Tcl_GetHashValue(hPtr); prefixPtr = Tcl_NewListObj(aliasPtr->objc, &aliasPtr->objPtr); Tcl_SetObjResult(interp, prefixPtr); return TCL_OK; } @@ -1757,11 +1662,11 @@ /* *---------------------------------------------------------------------- * * AliasList -- * - * Computes a list of aliases defined in a child interpreter. + * Computes a list of aliases defined in a slave interpreter. * * Results: * A standard Tcl result. * * Side effects: @@ -1771,46 +1676,40 @@ */ static int AliasList( Tcl_Interp *interp, /* Interp for data return. */ - Tcl_Interp *childInterp) /* Interp whose aliases to compute. */ + Tcl_Interp *slaveInterp) /* Interp whose aliases to compute. */ { Tcl_HashEntry *entryPtr; Tcl_HashSearch hashSearch; - Tcl_Obj *resultPtr; + Tcl_Obj *resultPtr = Tcl_NewObj(); Alias *aliasPtr; - Child *childPtr; + Slave *slavePtr; - TclNewObj(resultPtr); - childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child; + slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; - entryPtr = Tcl_FirstHashEntry(&childPtr->aliasTable, &hashSearch); + entryPtr = Tcl_FirstHashEntry(&slavePtr->aliasTable, &hashSearch); for ( ; entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&hashSearch)) { - aliasPtr = (Alias *)Tcl_GetHashValue(entryPtr); + aliasPtr = Tcl_GetHashValue(entryPtr); Tcl_ListObjAppendElement(NULL, resultPtr, aliasPtr->token); } Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * - * TclAliasObjCmd, TclLocalAliasObjCmd -- + * AliasObjCmd -- * - * This is the function that services invocations of aliases in a child + * This is the function that services invocations of aliases in a slave * interpreter. One such command exists for each alias. When invoked, * this function redirects the invocation to the target command in the - * parent interpreter as designated by the Alias record associated with + * master interpreter as designated by the Alias record associated with * this command. * - * TclLocalAliasObjCmd is a stripped down version used when the source - * and target interpreters of the alias are the same. That lets a number - * of safety precautions be avoided: the state is much more precisely - * known. - * * Results: * A standard Tcl result. * * Side effects: * Causes forwarding of the invocation; all possible side effects may @@ -1819,72 +1718,24 @@ * *---------------------------------------------------------------------- */ 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; - - /* - * 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; - - 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; itargetInterp; int result, prefc, cmdc, i; Tcl_Obj **prefv, **cmdv; Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC]; Interp *tPtr = (Interp *) targetInterp; - int isRootEnsemble; + int isRootEnsemble = (tPtr->ensembleRewrite.sourceObjs == NULL); /* * Append the arguments to the command prefix and invoke the command in * the target interp's global namespace. */ @@ -1893,15 +1744,15 @@ prefv = &aliasPtr->objPtr; cmdc = prefc + objc - 1; if (cmdc <= ALIAS_CMDV_PREALLOC) { cmdv = cmdArr; } else { - cmdv = (Tcl_Obj **)TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *)); + cmdv = (Tcl_Obj **) TclStackAlloc(interp, cmdc*(int)sizeof(Tcl_Obj*)); } - memcpy(cmdv, prefv, prefc * sizeof(Tcl_Obj *)); - memcpy(cmdv+prefc, objv+1, (objc-1) * sizeof(Tcl_Obj *)); + memcpy(cmdv, prefv, (size_t) (prefc * sizeof(Tcl_Obj *))); + memcpy(cmdv+prefc, objv+1, (size_t) ((objc-1) * sizeof(Tcl_Obj *))); Tcl_ResetResult(targetInterp); for (i=0; iensembleRewrite.sourceObjs = objv; + tPtr->ensembleRewrite.numRemovedObjs = 1; + tPtr->ensembleRewrite.numInsertedObjs = prefc; + } else { + tPtr->ensembleRewrite.numInsertedObjs += prefc - 1; + } /* * Protect the target interpreter if it isn't the same as the source * interpreter so that we can continue to work with it after the target * command completes. @@ -1933,91 +1790,26 @@ /* * Clean up the ensemble rewrite info if we set it in the first place. */ if (isRootEnsemble) { - TclResetRewriteEnsemble((Tcl_Interp *)tPtr, 1); + tPtr->ensembleRewrite.sourceObjs = NULL; + tPtr->ensembleRewrite.numRemovedObjs = 0; + tPtr->ensembleRewrite.numInsertedObjs = 0; } /* * If it was a cross-interpreter alias, we need to transfer the result * back to the source interpreter and release the lock we previously set * on the target interpreter. */ if (targetInterp != interp) { - Tcl_TransferResult(targetInterp, result, interp); + TclTransferResult(targetInterp, result, interp); Tcl_Release(targetInterp); } - for (i=0; iobjc; - 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; itoken); @@ -2059,75 +1851,75 @@ Tcl_DecrRefCount(objv[i]); } Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr); /* - * Splice the target record out of the target interpreter's parent list. + * Splice the target record out of the target interpreter's master list. */ targetPtr = aliasPtr->targetPtr; if (targetPtr->prevPtr != NULL) { targetPtr->prevPtr->nextPtr = targetPtr->nextPtr; } else { - Parent *parentPtr = &((InterpInfo *) ((Interp *) - aliasPtr->targetInterp)->interpInfo)->parent; + Master *masterPtr = &((InterpInfo *) ((Interp *) + aliasPtr->targetInterp)->interpInfo)->master; - parentPtr->targetsPtr = targetPtr->nextPtr; + masterPtr->targetsPtr = targetPtr->nextPtr; } if (targetPtr->nextPtr != NULL) { targetPtr->nextPtr->prevPtr = targetPtr->prevPtr; } - Tcl_Free(targetPtr); - Tcl_Free(aliasPtr); + ckfree((char *) targetPtr); + ckfree((char *) aliasPtr); } /* *---------------------------------------------------------------------- * - * Tcl_CreateChild -- + * Tcl_CreateSlave -- * - * Creates a child interpreter. The childPath argument denotes the name - * of the new child relative to the current interpreter; the child is a + * Creates a slave interpreter. The slavePath argument denotes the name + * of the new slave relative to the current interpreter; the slave is a * direct descendant of the one-before-last component of the path, - * e.g. it is a descendant of the current interpreter if the childPath - * argument contains only one component. Optionally makes the child + * e.g. it is a descendant of the current interpreter if the slavePath + * argument contains only one component. Optionally makes the slave * interpreter safe. * * Results: * Returns the interpreter structure created, or NULL if an error * occurred. * * Side effects: * Creates a new interpreter and a new interpreter object command in the - * interpreter indicated by the childPath argument. + * interpreter indicated by the slavePath argument. * *---------------------------------------------------------------------- */ Tcl_Interp * -Tcl_CreateChild( +Tcl_CreateSlave( Tcl_Interp *interp, /* Interpreter to start search at. */ - const char *childPath, /* Name of child to create. */ - int isSafe) /* Should new child be "safe" ? */ + const char *slavePath, /* Name of slave to create. */ + int isSafe) /* Should new slave be "safe" ? */ { Tcl_Obj *pathPtr; - Tcl_Interp *childInterp; + Tcl_Interp *slaveInterp; - pathPtr = Tcl_NewStringObj(childPath, -1); - childInterp = ChildCreate(interp, pathPtr, isSafe); + pathPtr = Tcl_NewStringObj(slavePath, -1); + slaveInterp = SlaveCreate(interp, pathPtr, isSafe); Tcl_DecrRefCount(pathPtr); - return childInterp; + return slaveInterp; } /* *---------------------------------------------------------------------- * - * Tcl_GetChild -- + * Tcl_GetSlave -- * - * Finds a child interpreter by its path name. + * Finds a slave interpreter by its path name. * * Results: * Returns a Tcl_Interp * for the named interpreter or NULL if not found. * * Side effects: @@ -2135,117 +1927,51 @@ * *---------------------------------------------------------------------- */ Tcl_Interp * -Tcl_GetChild( +Tcl_GetSlave( Tcl_Interp *interp, /* Interpreter to start search from. */ - const char *childPath) /* Path of child to find. */ + const char *slavePath) /* Path of slave to find. */ { Tcl_Obj *pathPtr; - Tcl_Interp *childInterp; + Tcl_Interp *slaveInterp; - pathPtr = Tcl_NewStringObj(childPath, -1); - childInterp = GetInterp(interp, pathPtr); + pathPtr = Tcl_NewStringObj(slavePath, -1); + slaveInterp = GetInterp(interp, pathPtr); Tcl_DecrRefCount(pathPtr); - return childInterp; + return slaveInterp; } /* *---------------------------------------------------------------------- * - * Tcl_GetParent -- + * Tcl_GetMaster -- * - * Finds the parent interpreter of a child interpreter. + * Finds the master interpreter of a slave interpreter. * * Results: - * Returns a Tcl_Interp * for the parent interpreter or NULL if none. + * Returns a Tcl_Interp * for the master interpreter or NULL if none. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_Interp * -Tcl_GetParent( - Tcl_Interp *interp) /* Get the parent of this interpreter. */ +Tcl_GetMaster( + Tcl_Interp *interp) /* Get the master of this interpreter. */ { - Child *childPtr; /* Child record of this interpreter. */ + Slave *slavePtr; /* Slave record of this interpreter. */ if (interp == NULL) { return NULL; } - childPtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->child; - return childPtr->parentInterp; -} - -/* - *---------------------------------------------------------------------- - * - * TclSetChildCancelFlags -- - * - * This function marks all child interpreters belonging to a given - * interpreter as being canceled or not canceled, depending on the - * provided flags. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -TclSetChildCancelFlags( - Tcl_Interp *interp, /* Set cancel flags of this interpreter. */ - int flags, /* Collection of OR-ed bits that control - * the cancellation of the script. Only - * TCL_CANCEL_UNWIND is currently - * supported. */ - int force) /* Non-zero to ignore numLevels for the purpose - * of resetting the cancellation flags. */ -{ - Parent *parentPtr; /* Parent record of given interpreter. */ - Tcl_HashEntry *hPtr; /* Search element. */ - Tcl_HashSearch hashSearch; /* Search variable. */ - Child *childPtr; /* Child record of interpreter. */ - Interp *iPtr; - - if (interp == NULL) { - return; - } - - flags &= (CANCELED | TCL_CANCEL_UNWIND); - - parentPtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->parent; - - hPtr = Tcl_FirstHashEntry(&parentPtr->childTable, &hashSearch); - for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) { - childPtr = (Child *)Tcl_GetHashValue(hPtr); - iPtr = (Interp *) childPtr->childInterp; - - if (iPtr == NULL) { - continue; - } - - if (flags == 0) { - TclResetCancellation((Tcl_Interp *) iPtr, force); - } else { - TclSetCancelFlags(iPtr, flags); - } - - /* - * Now, recursively handle this for the children of this child - * interpreter. - */ - - TclSetChildCancelFlags((Tcl_Interp *) iPtr, flags, force); - } + slavePtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->slave; + return slavePtr->masterInterp; } /* *---------------------------------------------------------------------- * @@ -2252,11 +1978,11 @@ * Tcl_GetInterpPath -- * * Sets the result of the asking interpreter to a proper Tcl list * containing the names of interpreters between the asking and target * interpreters. The target interpreter must be either the same as the - * asking interpreter or one of its children (including recursively). + * asking interpreter or one of its slaves (including recursively). * * Results: * TCL_OK if the target interpreter is the same as, or a descendant of, * the asking interpreter; TCL_ERROR else. This way one can distinguish * between the case where the asking and target interps are the same (an @@ -2270,41 +1996,39 @@ *---------------------------------------------------------------------- */ int Tcl_GetInterpPath( - Tcl_Interp *interp, /* Interpreter to start search from. */ + Tcl_Interp *askingInterp, /* Interpreter to start search from. */ Tcl_Interp *targetInterp) /* Interpreter to find. */ { InterpInfo *iiPtr; - if (targetInterp == interp) { - Tcl_SetObjResult(interp, Tcl_NewObj()); + if (targetInterp == askingInterp) { return TCL_OK; } if (targetInterp == NULL) { return TCL_ERROR; } iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo; - if (Tcl_GetInterpPath(interp, iiPtr->child.parentInterp) != TCL_OK){ + if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK) { return TCL_ERROR; } - Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), - Tcl_NewStringObj((const char *)Tcl_GetHashKey(&iiPtr->parent.childTable, - iiPtr->child.childEntryPtr), -1)); + Tcl_AppendElement(askingInterp, Tcl_GetHashKey(&iiPtr->master.slaveTable, + iiPtr->slave.slaveEntryPtr)); return TCL_OK; } /* *---------------------------------------------------------------------- * * GetInterp -- * - * Helper function to find a child interpreter given a pathname. + * Helper function to find a slave interpreter given a pathname. * * Results: - * Returns the child interpreter known by that name in the calling + * Returns the slave interpreter known by that name in the calling * interpreter, or NULL if no interpreter known by that name exists. * * Side effects: * Assigns to the pointer variable passed in, if not NULL. * @@ -2316,228 +2040,225 @@ Tcl_Interp *interp, /* Interp. to start search from. */ Tcl_Obj *pathPtr) /* List object containing name of interp. to * be found. */ { Tcl_HashEntry *hPtr; /* Search element. */ - Child *childPtr; /* Interim child record. */ + Slave *slavePtr; /* Interim slave record. */ Tcl_Obj **objv; int objc, i; Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */ - InterpInfo *parentInfoPtr; + InterpInfo *masterInfoPtr; if (TclListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { return NULL; } searchInterp = interp; for (i = 0; i < objc; i++) { - parentInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo; - hPtr = Tcl_FindHashEntry(&parentInfoPtr->parent.childTable, + masterInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo; + hPtr = Tcl_FindHashEntry(&masterInfoPtr->master.slaveTable, TclGetString(objv[i])); if (hPtr == NULL) { searchInterp = NULL; break; } - childPtr = (Child *)Tcl_GetHashValue(hPtr); - searchInterp = childPtr->childInterp; + slavePtr = Tcl_GetHashValue(hPtr); + searchInterp = slavePtr->slaveInterp; if (searchInterp == NULL) { break; } } if (searchInterp == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not find interpreter \"%s\"", TclGetString(pathPtr))); + Tcl_AppendResult(interp, "could not find interpreter \"", + TclGetString(pathPtr), "\"", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INTERP", TclGetString(pathPtr), NULL); } return searchInterp; } /* *---------------------------------------------------------------------- * - * ChildBgerror -- + * SlaveBgerror -- * * Helper function to set/query the background error handling command * prefix of an interp * * Results: * A standard Tcl result. * * Side effects: - * When (objc == 1), childInterp will be set to a new background handler + * When (objc == 1), slaveInterp will be set to a new background handler * of objv[0]. * *---------------------------------------------------------------------- */ static int -ChildBgerror( +SlaveBgerror( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *childInterp, /* Interp in which limit is set/queried. */ + Tcl_Interp *slaveInterp, /* Interp in which limit is set/queried. */ int objc, /* Set or Query. */ Tcl_Obj *const objv[]) /* Argument strings. */ { if (objc) { int length; if (TCL_ERROR == TclListObjLength(NULL, objv[0], &length) || (length < 1)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cmdPrefix must be list of length >= 1", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", - "BGERRORFORMAT", NULL); + Tcl_AppendResult(interp, "cmdPrefix must be list of length >= 1", + NULL); return TCL_ERROR; } - TclSetBgErrorHandler(childInterp, objv[0]); + TclSetBgErrorHandler(slaveInterp, objv[0]); } - Tcl_SetObjResult(interp, TclGetBgErrorHandler(childInterp)); + Tcl_SetObjResult(interp, TclGetBgErrorHandler(slaveInterp)); return TCL_OK; } /* *---------------------------------------------------------------------- * - * ChildCreate -- + * SlaveCreate -- * - * Helper function to do the actual work of creating a child interp and - * new object command. Also optionally makes the new child interpreter + * Helper function to do the actual work of creating a slave interp and + * new object command. Also optionally makes the new slave interpreter * "safe". * * Results: * Returns the new Tcl_Interp * if successful or NULL if not. If failed, * the result of the invoking interpreter contains an error message. * * Side effects: - * Creates a new child interpreter and a new object command. + * Creates a new slave interpreter and a new object command. * *---------------------------------------------------------------------- */ static Tcl_Interp * -ChildCreate( +SlaveCreate( Tcl_Interp *interp, /* Interp. to start search from. */ - Tcl_Obj *pathPtr, /* Path (name) of child to create. */ + Tcl_Obj *pathPtr, /* Path (name) of slave to create. */ int safe) /* Should we make it "safe"? */ { - Tcl_Interp *parentInterp, *childInterp; - Child *childPtr; - InterpInfo *parentInfoPtr; + Tcl_Interp *masterInterp, *slaveInterp; + Slave *slavePtr; + InterpInfo *masterInfoPtr; Tcl_HashEntry *hPtr; - const char *path; + char *path; int isNew, objc; Tcl_Obj **objv; if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { return NULL; } if (objc < 2) { - parentInterp = interp; + masterInterp = interp; path = TclGetString(pathPtr); } else { Tcl_Obj *objPtr; objPtr = Tcl_NewListObj(objc - 1, objv); - parentInterp = GetInterp(interp, objPtr); + masterInterp = GetInterp(interp, objPtr); Tcl_DecrRefCount(objPtr); - if (parentInterp == NULL) { + if (masterInterp == NULL) { return NULL; } path = TclGetString(objv[objc - 1]); } if (safe == 0) { - safe = Tcl_IsSafe(parentInterp); + safe = Tcl_IsSafe(masterInterp); } - parentInfoPtr = (InterpInfo *) ((Interp *) parentInterp)->interpInfo; - hPtr = Tcl_CreateHashEntry(&parentInfoPtr->parent.childTable, path, + masterInfoPtr = (InterpInfo *) ((Interp *) masterInterp)->interpInfo; + hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path, &isNew); if (isNew == 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "interpreter named \"%s\" already exists, cannot create", - path)); + Tcl_AppendResult(interp, "interpreter named \"", path, + "\" already exists, cannot create", NULL); return NULL; } - childInterp = Tcl_CreateInterp(); - childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child; - childPtr->parentInterp = parentInterp; - childPtr->childEntryPtr = hPtr; - childPtr->childInterp = childInterp; - childPtr->interpCmd = Tcl_NRCreateCommand(parentInterp, path, - TclChildObjCmd, NRChildCmd, childInterp, ChildObjCmdDeleteProc); - Tcl_InitHashTable(&childPtr->aliasTable, TCL_STRING_KEYS); - Tcl_SetHashValue(hPtr, childPtr); - Tcl_SetVar2(childInterp, "tcl_interactive", NULL, "0", TCL_GLOBAL_ONLY); + slaveInterp = Tcl_CreateInterp(); + slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; + slavePtr->masterInterp = masterInterp; + slavePtr->slaveEntryPtr = hPtr; + slavePtr->slaveInterp = slaveInterp; + slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path, + SlaveObjCmd, slaveInterp, SlaveObjCmdDeleteProc); + Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); + Tcl_SetHashValue(hPtr, slavePtr); + Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); /* * Inherit the recursion limit. */ - ((Interp *) childInterp)->maxNestingDepth = - ((Interp *) parentInterp)->maxNestingDepth; + ((Interp *) slaveInterp)->maxNestingDepth = + ((Interp *) masterInterp)->maxNestingDepth; if (safe) { - if (Tcl_MakeSafe(childInterp) == TCL_ERROR) { + if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) { goto error; } } else { - if (Tcl_Init(childInterp) == TCL_ERROR) { + if (Tcl_Init(slaveInterp) == TCL_ERROR) { goto error; } /* - * This will create the "memory" command in child interpreters if we + * This will create the "memory" command in slave interpreters if we * compiled with TCL_MEM_DEBUG, otherwise it does nothing. */ - Tcl_InitMemory(childInterp); + Tcl_InitMemory(slaveInterp); } /* * Inherit the TIP#143 limits. */ - InheritLimitsFromParent(childInterp, parentInterp); + InheritLimitsFromMaster(slaveInterp, masterInterp); /* * The [clock] command presents a safe API, but uses unsafe features in * its implementation. This means it has to be implemented in safe interps - * as an alias to a version in the (trusted) parent. + * as an alias to a version in the (trusted) master. */ if (safe) { Tcl_Obj *clockObj; int status; TclNewLiteralStringObj(clockObj, "clock"); Tcl_IncrRefCount(clockObj); - status = AliasCreate(interp, childInterp, parentInterp, clockObj, + status = AliasCreate(interp, slaveInterp, masterInterp, clockObj, clockObj, 0, NULL); Tcl_DecrRefCount(clockObj); if (status != TCL_OK) { goto error2; } } - return childInterp; + return slaveInterp; error: - Tcl_TransferResult(childInterp, TCL_ERROR, interp); + TclTransferResult(slaveInterp, TCL_ERROR, interp); error2: - Tcl_DeleteInterp(childInterp); + Tcl_DeleteInterp(slaveInterp); return NULL; } /* *---------------------------------------------------------------------- * - * TclChildObjCmd -- + * SlaveObjCmd -- * * Command to manipulate an interpreter, e.g. to send commands to it to - * be evaluated. One such command exists for each child interpreter. + * be evaluated. One such command exists for each slave interpreter. * * Results: * A standard Tcl result. * * Side effects: @@ -2544,44 +2265,32 @@ * See user documentation for details. * *---------------------------------------------------------------------- */ -int -TclChildObjCmd( - ClientData clientData, /* Child interpreter. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - return Tcl_NRCallObjProc(interp, NRChildCmd, clientData, objc, objv); -} - -static int -NRChildCmd( - ClientData clientData, /* Child interpreter. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Interp *childInterp = (Tcl_Interp *)clientData; - int index; - static const char *const options[] = { - "alias", "aliases", "bgerror", "debug", - "eval", "expose", "hide", "hidden", - "issafe", "invokehidden", "limit", "marktrusted", - "recursionlimit", NULL - }; - enum childCmdOptionsEnum { - OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_DEBUG, - OPT_EVAL, OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, - OPT_ISSAFE, OPT_INVOKEHIDDEN, OPT_LIMIT, OPT_MARKTRUSTED, - OPT_RECLIMIT - }; - - if (childInterp == NULL) { - Tcl_Panic("TclChildObjCmd: interpreter has been deleted"); +static int +SlaveObjCmd( + ClientData clientData, /* Slave interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Interp *slaveInterp = clientData; + int index; + static const char *options[] = { + "alias", "aliases", "bgerror", "debug", "eval", + "expose", "hide", "hidden", "issafe", + "invokehidden", "limit", "marktrusted", "recursionlimit", NULL + }; + enum options { + OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_DEBUG, OPT_EVAL, + OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, + OPT_INVOKEHIDDEN, OPT_LIMIT, OPT_MARKTRUSTED, OPT_RECLIMIT + }; + + if (slaveInterp == NULL) { + Tcl_Panic("SlaveObjCmd: interpreter has been deleted"); } if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); return TCL_ERROR; @@ -2589,84 +2298,84 @@ if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } - switch ((enum childCmdOptionsEnum) index) { + switch ((enum options) index) { case OPT_ALIAS: if (objc > 2) { if (objc == 3) { - return AliasDescribe(interp, childInterp, objv[2]); + return AliasDescribe(interp, slaveInterp, objv[2]); } if (TclGetString(objv[3])[0] == '\0') { if (objc == 4) { - return AliasDelete(interp, childInterp, objv[2]); + return AliasDelete(interp, slaveInterp, objv[2]); } } else { - return AliasCreate(interp, childInterp, interp, objv[2], + return AliasCreate(interp, slaveInterp, interp, objv[2], objv[3], objc - 4, objv + 4); } } - Tcl_WrongNumArgs(interp, 2, objv, "aliasName ?targetName? ?arg ...?"); + Tcl_WrongNumArgs(interp, 2, objv, "aliasName ?targetName? ?args..?"); return TCL_ERROR; case OPT_ALIASES: if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - return AliasList(interp, childInterp); + return AliasList(interp, slaveInterp); case OPT_BGERROR: if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "?cmdPrefix?"); return TCL_ERROR; } - return ChildBgerror(interp, childInterp, objc - 2, objv + 2); + return SlaveBgerror(interp, slaveInterp, objc - 2, objv + 2); case OPT_DEBUG: /* - * TIP #378 + * TIP #378 * * Currently only -frame supported, otherwise ?-option ?value? ...? */ if (objc > 4) { Tcl_WrongNumArgs(interp, 2, objv, "?-frame ?bool??"); return TCL_ERROR; } - return ChildDebugCmd(interp, childInterp, objc - 2, objv + 2); + return SlaveDebugCmd(interp, slaveInterp, objc - 2, objv + 2); case OPT_EVAL: if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?"); return TCL_ERROR; } - return ChildEval(interp, childInterp, objc - 2, objv + 2); + return SlaveEval(interp, slaveInterp, objc - 2, objv + 2); case OPT_EXPOSE: if ((objc < 3) || (objc > 4)) { Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?"); return TCL_ERROR; } - return ChildExpose(interp, childInterp, objc - 2, objv + 2); + return SlaveExpose(interp, slaveInterp, objc - 2, objv + 2); case OPT_HIDE: if ((objc < 3) || (objc > 4)) { Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?"); return TCL_ERROR; } - return ChildHide(interp, childInterp, objc - 2, objv + 2); + return SlaveHide(interp, slaveInterp, objc - 2, objv + 2); case OPT_HIDDEN: if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - return ChildHidden(interp, childInterp); + return SlaveHidden(interp, slaveInterp); case OPT_ISSAFE: if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(childInterp))); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); return TCL_OK; case OPT_INVOKEHIDDEN: { - int i; + int i, index; const char *namespaceName; - static const char *const hiddenOptions[] = { + static const char *hiddenOptions[] = { "-global", "-namespace", "--", NULL }; enum hiddenOption { OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST }; @@ -2696,163 +2405,161 @@ if (objc - i < 1) { Tcl_WrongNumArgs(interp, 2, objv, "?-namespace ns? ?-global? ?--? cmd ?arg ..?"); return TCL_ERROR; } - return ChildInvokeHidden(interp, childInterp, namespaceName, + return SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc - i, objv + i); } case OPT_LIMIT: { - static const char *const limitTypes[] = { + static const char *limitTypes[] = { "commands", "time", NULL }; enum LimitTypes { LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME }; int limitType; if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "limitType ?-option value ...?"); + Tcl_WrongNumArgs(interp, 2, objv, "limitType ?options?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[2], limitTypes, "limit type", 0, &limitType) != TCL_OK) { return TCL_ERROR; } switch ((enum LimitTypes) limitType) { case LIMIT_TYPE_COMMANDS: - return ChildCommandLimitCmd(interp, childInterp, 3, objc,objv); + return SlaveCommandLimitCmd(interp, slaveInterp, 3, objc,objv); case LIMIT_TYPE_TIME: - return ChildTimeLimitCmd(interp, childInterp, 3, objc, objv); + return SlaveTimeLimitCmd(interp, slaveInterp, 3, objc, objv); } } break; case OPT_MARKTRUSTED: if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - return ChildMarkTrusted(interp, childInterp); + return SlaveMarkTrusted(interp, slaveInterp); case OPT_RECLIMIT: if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "?newlimit?"); return TCL_ERROR; } - return ChildRecursionLimit(interp, childInterp, objc - 2, objv + 2); + return SlaveRecursionLimit(interp, slaveInterp, objc - 2, objv + 2); } return TCL_ERROR; } /* *---------------------------------------------------------------------- * - * ChildObjCmdDeleteProc -- + * SlaveObjCmdDeleteProc -- * - * Invoked when an object command for a child interpreter is deleted; - * cleans up all state associated with the child interpreter and destroys - * the child interpreter. + * Invoked when an object command for a slave interpreter is deleted; + * cleans up all state associated with the slave interpreter and destroys + * the slave interpreter. * * Results: * None. * * Side effects: - * Cleans up all state associated with the child interpreter and destroys - * the child interpreter. + * Cleans up all state associated with the slave interpreter and destroys + * the slave interpreter. * *---------------------------------------------------------------------- */ static void -ChildObjCmdDeleteProc( - ClientData clientData) /* The ChildRecord for the command. */ -{ - Child *childPtr; /* Interim storage for Child record. */ - Tcl_Interp *childInterp = (Tcl_Interp *)clientData; - /* And for a child interp. */ - - childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child; +SlaveObjCmdDeleteProc( + ClientData clientData) /* The SlaveRecord for the command. */ +{ + Slave *slavePtr; /* Interim storage for Slave record. */ + Tcl_Interp *slaveInterp = clientData; + /* And for a slave interp. */ + + slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; /* - * Unlink the child from its parent interpreter. + * Unlink the slave from its master interpreter. */ - Tcl_DeleteHashEntry(childPtr->childEntryPtr); + Tcl_DeleteHashEntry(slavePtr->slaveEntryPtr); /* - * Set to NULL so that when the InterpInfo is cleaned up in the child it + * Set to NULL so that when the InterpInfo is cleaned up in the slave it * does not try to delete the command causing all sorts of grief. See - * ChildRecordDeleteProc(). + * SlaveRecordDeleteProc(). */ - childPtr->interpCmd = NULL; + slavePtr->interpCmd = NULL; - if (childPtr->childInterp != NULL) { - Tcl_DeleteInterp(childPtr->childInterp); + if (slavePtr->slaveInterp != NULL) { + Tcl_DeleteInterp(slavePtr->slaveInterp); } } /* *---------------------------------------------------------------------- * - * ChildDebugCmd -- TIP #378 + * SlaveDebugCmd -- TIP #378 * - * Helper function to handle 'debug' command in a child interpreter. + * Helper function to handle 'debug' command in a slave interpreter. * * Results: * A standard Tcl result. * * Side effects: - * May modify INTERP_DEBUG_FRAME flag in the child. + * May modify INTERP_DEBUG flag in the slave. * *---------------------------------------------------------------------- */ static int -ChildDebugCmd( +SlaveDebugCmd( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *childInterp, /* The child interpreter in which command + Tcl_Interp *slaveInterp, /* The slave interpreter in which command * will be evaluated. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - static const char *const debugTypes[] = { + static const char *debugTypes[] = { "-frame", NULL }; enum DebugTypes { DEBUG_TYPE_FRAME }; int debugType; Interp *iPtr; Tcl_Obj *resultPtr; - iPtr = (Interp *) childInterp; + iPtr = (Interp *) slaveInterp; if (objc == 0) { - TclNewObj(resultPtr); + resultPtr = Tcl_NewObj(); Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewStringObj("-frame", -1)); Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewBooleanObj(iPtr->flags & INTERP_DEBUG_FRAME)); Tcl_SetObjResult(interp, resultPtr); } else { - if (Tcl_GetIndexFromObj(interp, objv[0], debugTypes, "debug option", - 0, &debugType) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[0], debugTypes, + "debug option", 0, &debugType) != TCL_OK) { return TCL_ERROR; } if (debugType == DEBUG_TYPE_FRAME) { if (objc == 2) { /* set */ if (Tcl_GetBooleanFromObj(interp, objv[1], &debugType) != TCL_OK) { return TCL_ERROR; } - /* - * Quietly ignore attempts to disable interp debugging. This - * is a one-way switch as frame debug info is maintained in a - * stack that must be consistent once turned on. + * Quietly ignore attempts to disable interp debugging. + * This is a one-way switch as frame debug info is maintained + * in a stack that must be consistent once turned on. */ - if (debugType) { iPtr->flags |= INTERP_DEBUG_FRAME; } } Tcl_SetObjResult(interp, @@ -2863,13 +2570,13 @@ } /* *---------------------------------------------------------------------- * - * ChildEval -- + * SlaveEval -- * - * Helper function to evaluate a command in a child interpreter. + * Helper function to evaluate a command in a slave interpreter. * * Results: * A standard Tcl result. * * Side effects: @@ -2877,211 +2584,192 @@ * *---------------------------------------------------------------------- */ static int -ChildEval( +SlaveEval( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *childInterp, /* The child interpreter in which command + Tcl_Interp *slaveInterp, /* The slave interpreter in which command * will be evaluated. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int result; - - /* - * TIP #285: If necessary, reset the cancellation flags for the child - * interpreter now; otherwise, canceling a script in a parent interpreter - * can result in a situation where a child interpreter can no longer - * evaluate any scripts unless somebody calls the TclResetCancellation - * function for that particular Tcl_Interp. - */ - - TclSetChildCancelFlags(childInterp, 0, 0); - - Tcl_Preserve(childInterp); - Tcl_AllowExceptions(childInterp); + Tcl_Obj *objPtr; + + Tcl_Preserve(slaveInterp); + Tcl_AllowExceptions(slaveInterp); if (objc == 1) { /* * TIP #280: Make actual argument location available to eval'd script. */ - Interp *iPtr = (Interp *) interp; - CmdFrame *invoker = iPtr->cmdFramePtr; - int word = 0; + Interp *iPtr = (Interp *) interp; + CmdFrame* invoker = iPtr->cmdFramePtr; + int word = 0; - TclArgumentGet(interp, objv[0], &invoker, &word); - - result = TclEvalObjEx(childInterp, objv[0], 0, invoker, word); + TclArgumentGet (interp, objv[0], &invoker, &word); + result = TclEvalObjEx(slaveInterp, objv[0], 0, invoker, word); } else { - Tcl_Obj *objPtr = Tcl_ConcatObj(objc, objv); + objPtr = Tcl_ConcatObj(objc, objv); Tcl_IncrRefCount(objPtr); - result = Tcl_EvalObjEx(childInterp, objPtr, 0); + result = Tcl_EvalObjEx(slaveInterp, objPtr, 0); Tcl_DecrRefCount(objPtr); } - Tcl_TransferResult(childInterp, result, interp); + TclTransferResult(slaveInterp, result, interp); - Tcl_Release(childInterp); + Tcl_Release(slaveInterp); return result; } /* *---------------------------------------------------------------------- * - * ChildExpose -- + * SlaveExpose -- * - * Helper function to expose a command in a child interpreter. + * Helper function to expose a command in a slave interpreter. * * Results: * A standard Tcl result. * * Side effects: - * After this call scripts in the child will be able to invoke the newly + * After this call scripts in the slave will be able to invoke the newly * exposed command. * *---------------------------------------------------------------------- */ static int -ChildExpose( +SlaveExpose( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *childInterp, /* Interp in which command will be exposed. */ + Tcl_Interp *slaveInterp, /* Interp in which command will be exposed. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument strings. */ { - const char *name; + char *name; if (Tcl_IsSafe(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "permission denied: safe interpreter cannot expose commands", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", - NULL); return TCL_ERROR; } name = TclGetString(objv[(objc == 1) ? 0 : 1]); - if (Tcl_ExposeCommand(childInterp, TclGetString(objv[0]), + if (Tcl_ExposeCommand(slaveInterp, TclGetString(objv[0]), name) != TCL_OK) { - Tcl_TransferResult(childInterp, TCL_ERROR, interp); + TclTransferResult(slaveInterp, TCL_ERROR, interp); return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- * - * ChildRecursionLimit -- + * SlaveRecursionLimit -- * * Helper function to set/query the Recursion limit of an interp * * Results: * A standard Tcl result. * * Side effects: - * When (objc == 1), childInterp will be set to a new recursion limit of + * When (objc == 1), slaveInterp will be set to a new recursion limit of * objv[0]. * *---------------------------------------------------------------------- */ static int -ChildRecursionLimit( +SlaveRecursionLimit( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *childInterp, /* Interp in which limit is set/queried. */ + Tcl_Interp *slaveInterp, /* Interp in which limit is set/queried. */ int objc, /* Set or Query. */ Tcl_Obj *const objv[]) /* Argument strings. */ { Interp *iPtr; int limit; if (objc) { if (Tcl_IsSafe(interp)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("permission denied: " - "safe interpreters cannot change recursion limit", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", - NULL); + Tcl_AppendResult(interp, "permission denied: " + "safe interpreters cannot change recursion limit", NULL); return TCL_ERROR; } if (TclGetIntFromObj(interp, objv[0], &limit) == TCL_ERROR) { return TCL_ERROR; } if (limit <= 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "recursion limit must be > 0", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADLIMIT", - NULL); return TCL_ERROR; } - Tcl_SetRecursionLimit(childInterp, limit); - iPtr = (Interp *) childInterp; - if (interp == childInterp && iPtr->numLevels > limit) { + Tcl_SetRecursionLimit(slaveInterp, limit); + iPtr = (Interp *) slaveInterp; + if (interp == slaveInterp && iPtr->numLevels > limit) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "falling back due to new recursion limit", -1)); - Tcl_SetErrorCode(interp, "TCL", "RECURSION", NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, objv[0]); return TCL_OK; } else { - limit = Tcl_SetRecursionLimit(childInterp, 0); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(limit)); + limit = Tcl_SetRecursionLimit(slaveInterp, 0); + Tcl_SetObjResult(interp, Tcl_NewIntObj(limit)); return TCL_OK; } } /* *---------------------------------------------------------------------- * - * ChildHide -- + * SlaveHide -- * - * Helper function to hide a command in a child interpreter. + * Helper function to hide a command in a slave interpreter. * * Results: * A standard Tcl result. * * Side effects: - * After this call scripts in the child will no longer be able to invoke + * After this call scripts in the slave will no longer be able to invoke * the named command. * *---------------------------------------------------------------------- */ static int -ChildHide( +SlaveHide( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *childInterp, /* Interp in which command will be exposed. */ + Tcl_Interp *slaveInterp, /* Interp in which command will be exposed. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument strings. */ { - const char *name; + char *name; if (Tcl_IsSafe(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "permission denied: safe interpreter cannot hide commands", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", - NULL); return TCL_ERROR; } name = TclGetString(objv[(objc == 1) ? 0 : 1]); - if (Tcl_HideCommand(childInterp, TclGetString(objv[0]), name) != TCL_OK) { - Tcl_TransferResult(childInterp, TCL_ERROR, interp); + if (Tcl_HideCommand(slaveInterp, TclGetString(objv[0]), name) != TCL_OK) { + TclTransferResult(slaveInterp, TCL_ERROR, interp); return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- * - * ChildHidden -- + * SlaveHidden -- * - * Helper function to compute list of hidden commands in a child + * Helper function to compute list of hidden commands in a slave * interpreter. * * Results: * A standard Tcl result. * @@ -3090,39 +2778,38 @@ * *---------------------------------------------------------------------- */ static int -ChildHidden( +SlaveHidden( Tcl_Interp *interp, /* Interp for data return. */ - Tcl_Interp *childInterp) /* Interp whose hidden commands to query. */ + Tcl_Interp *slaveInterp) /* Interp whose hidden commands to query. */ { - Tcl_Obj *listObjPtr; /* Local object pointer. */ + Tcl_Obj *listObjPtr = Tcl_NewObj(); /* Local object pointer. */ Tcl_HashTable *hTblPtr; /* For local searches. */ Tcl_HashEntry *hPtr; /* For local searches. */ Tcl_HashSearch hSearch; /* For local searches. */ - TclNewObj(listObjPtr); - hTblPtr = ((Interp *) childInterp)->hiddenCmdTablePtr; + 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_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1)); } } Tcl_SetObjResult(interp, listObjPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * - * ChildInvokeHidden -- + * SlaveInvokeHidden -- * - * Helper function to invoke a hidden command in a child interpreter. + * Helper function to invoke a hidden command in a slave interpreter. * * Results: * A standard Tcl result. * * Side effects: @@ -3130,13 +2817,13 @@ * *---------------------------------------------------------------------- */ static int -ChildInvokeHidden( +SlaveInvokeHidden( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *childInterp, /* The child interpreter in which command will + Tcl_Interp *slaveInterp, /* The slave interpreter in which command will * be invoked. */ const char *namespaceName, /* The namespace to use, if any. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { @@ -3144,92 +2831,67 @@ if (Tcl_IsSafe(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "not allowed to invoke hidden commands from safe interpreter", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", - NULL); return TCL_ERROR; } - Tcl_Preserve(childInterp); - Tcl_AllowExceptions(childInterp); + Tcl_Preserve(slaveInterp); + Tcl_AllowExceptions(slaveInterp); if (namespaceName == NULL) { - NRE_callback *rootPtr = TOP_CB(childInterp); - - Tcl_NRAddCallback(interp, NRPostInvokeHidden, childInterp, - rootPtr, NULL, NULL); - return TclNRInvoke(NULL, childInterp, objc, objv); + result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); } else { Namespace *nsPtr, *dummy1, *dummy2; const char *tail; - result = TclGetNamespaceForQualName(childInterp, namespaceName, NULL, + result = TclGetNamespaceForQualName(slaveInterp, namespaceName, NULL, TCL_FIND_ONLY_NS | TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG | TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); if (result == TCL_OK) { - result = TclObjInvokeNamespace(childInterp, objc, objv, - (Tcl_Namespace *) nsPtr, TCL_INVOKE_HIDDEN); - } - } - - Tcl_TransferResult(childInterp, result, interp); - - Tcl_Release(childInterp); - return result; -} - -static int -NRPostInvokeHidden( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - Tcl_Interp *childInterp = (Tcl_Interp *)data[0]; - NRE_callback *rootPtr = (NRE_callback *)data[1]; - - if (interp != childInterp) { - result = TclNRRunCallbacks(childInterp, result, rootPtr); - Tcl_TransferResult(childInterp, result, interp); - } - Tcl_Release(childInterp); + result = TclObjInvokeNamespace(slaveInterp, objc, objv, + (Tcl_Namespace *)nsPtr, TCL_INVOKE_HIDDEN); + } + } + + TclTransferResult(slaveInterp, result, interp); + + Tcl_Release(slaveInterp); return result; } /* *---------------------------------------------------------------------- * - * ChildMarkTrusted -- + * SlaveMarkTrusted -- * - * Helper function to mark a child interpreter as trusted (unsafe). + * Helper function to mark a slave interpreter as trusted (unsafe). * * Results: * A standard Tcl result. * * Side effects: * After this call the hard-wired security checks in the core no longer - * prevent the child from performing certain operations. + * prevent the slave from performing certain operations. * *---------------------------------------------------------------------- */ static int -ChildMarkTrusted( +SlaveMarkTrusted( Tcl_Interp *interp, /* Interp for error return. */ - Tcl_Interp *childInterp) /* The child interpreter which will be marked + Tcl_Interp *slaveInterp) /* The slave interpreter which will be marked * trusted. */ { if (Tcl_IsSafe(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "permission denied: safe interpreter cannot mark trusted", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", - NULL); return TCL_ERROR; } - ((Interp *) childInterp)->flags &= ~SAFE_INTERP; + ((Interp *) slaveInterp)->flags &= ~SAFE_INTERP; return TCL_OK; } /* *---------------------------------------------------------------------- @@ -3282,24 +2944,28 @@ Tcl_MakeSafe( Tcl_Interp *interp) /* Interpreter to be made safe. */ { Tcl_Channel chan; /* Channel to remove from safe interpreter. */ Interp *iPtr = (Interp *) interp; - Tcl_Interp *parent = ((InterpInfo*) iPtr->interpInfo)->child.parentInterp; + Tcl_Interp *master = ((InterpInfo*) iPtr->interpInfo)->slave.masterInterp; TclHideUnsafeCommands(interp); - if (parent != NULL) { + if (master != NULL) { /* - * Alias these function implementations in the child to those in the - * parent; the overall implementations are safe, but they're normally + * Alias these function implementations in the slave to those in the + * master; the overall implementations are safe, but they're normally * defined by init.tcl which is not sourced by safe interpreters. * Assume these functions all work. [Bug 2895741] */ - (void) Tcl_EvalEx(interp, - "namespace eval ::tcl {namespace eval mathfunc {}}", -1, 0); + (void) Tcl_Eval(interp, + "namespace eval ::tcl {namespace eval mathfunc {}}"); + (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::min", master, + "::tcl::mathfunc::min", 0, NULL); + (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::max", master, + "::tcl::mathfunc::max", 0, NULL); } iPtr->flags |= SAFE_INTERP; /* @@ -3306,14 +2972,14 @@ * Unsetting variables : (which should not have been set in the first * place, but...) */ /* - * No env array in a safe interpreter. + * No env array in a safe slave. */ - Tcl_UnsetVar2(interp, "env", NULL, TCL_GLOBAL_ONLY); + Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY); /* * Remove unsafe parts of tcl_platform */ @@ -3325,13 +2991,13 @@ /* * 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); + Tcl_UnsetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY); + Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); + Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY); /* * Remove the standard channels from the interpreter; safe interpreters do * not ordinarily have access to stdin, stdout and stderr. * @@ -3380,11 +3046,11 @@ int Tcl_LimitExceeded( Tcl_Interp *interp) { - Interp *iPtr = (Interp *) interp; + register Interp *iPtr = (Interp *) interp; return iPtr->limit.exceeded != 0; } /* @@ -3411,14 +3077,14 @@ int Tcl_LimitReady( Tcl_Interp *interp) { - Interp *iPtr = (Interp *) interp; + register Interp *iPtr = (Interp *) interp; if (iPtr->limit.active != 0) { - int ticker = ++iPtr->limit.granularityTicker; + register int ticker = ++iPtr->limit.granularityTicker; if ((iPtr->limit.active & TCL_LIMIT_COMMANDS) && ((iPtr->limit.cmdGranularity == 1) || (ticker % iPtr->limit.cmdGranularity == 0))) { return 1; @@ -3458,11 +3124,11 @@ int Tcl_LimitCheck( Tcl_Interp *interp) { Interp *iPtr = (Interp *) interp; - int ticker = iPtr->limit.granularityTicker; + register int ticker = iPtr->limit.granularityTicker; if (Tcl_InterpDeleted(interp)) { return TCL_OK; } @@ -3474,13 +3140,12 @@ Tcl_Preserve(interp); RunLimitHandlers(iPtr->limit.cmdHandlers, interp); if (iPtr->limit.cmdCount >= iPtr->cmdCount) { iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS; } else if (iPtr->limit.exceeded & TCL_LIMIT_COMMANDS) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "command count limit exceeded", -1)); - Tcl_SetErrorCode(interp, "TCL", "LIMIT", "COMMANDS", NULL); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "command count limit exceeded", NULL); Tcl_Release(interp); return TCL_ERROR; } Tcl_Release(interp); } @@ -3500,13 +3165,12 @@ if (iPtr->limit.time.sec > now.sec || (iPtr->limit.time.sec == now.sec && iPtr->limit.time.usec >= now.usec)) { iPtr->limit.exceeded &= ~TCL_LIMIT_TIME; } else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "time limit exceeded", -1)); - Tcl_SetErrorCode(interp, "TCL", "LIMIT", "TIME", NULL); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "time limit exceeded", NULL); Tcl_Release(interp); return TCL_ERROR; } Tcl_Release(interp); } @@ -3555,11 +3219,11 @@ * cannot reentrantly call this handler and know to use the alternate * method of deletion if necessary. */ handlerPtr->flags |= LIMIT_HANDLER_ACTIVE; - handlerPtr->handlerProc(handlerPtr->clientData, interp); + (handlerPtr->handlerProc)(handlerPtr->clientData, interp); handlerPtr->flags &= ~LIMIT_HANDLER_ACTIVE; /* * Rediscover this value; it might have changed during the processing * of a limit handler. We have to record it here because we might @@ -3576,13 +3240,13 @@ * LIMIT_HANDLER_DELETED flag. */ if (handlerPtr->flags & LIMIT_HANDLER_DELETED) { if (handlerPtr->deleteProc != NULL) { - handlerPtr->deleteProc(handlerPtr->clientData); + (handlerPtr->deleteProc)(handlerPtr->clientData); } - Tcl_Free(handlerPtr); + ckfree((char *) handlerPtr); } } } /* @@ -3615,18 +3279,21 @@ /* * Convert everything into a real deletion callback. */ if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_DYNAMIC) { - deleteProc = (Tcl_LimitHandlerDeleteProc *) TclpFree; + deleteProc = (Tcl_LimitHandlerDeleteProc *) Tcl_Free; + } + if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_STATIC) { + deleteProc = NULL; } /* * Allocate a handler record. */ - handlerPtr = (LimitHandler *)Tcl_Alloc(sizeof(LimitHandler)); + handlerPtr = (LimitHandler *) ckalloc(sizeof(LimitHandler)); handlerPtr->flags = 0; handlerPtr->handlerProc = handlerProc; handlerPtr->clientData = clientData; handlerPtr->deleteProc = deleteProc; handlerPtr->prevPtr = NULL; @@ -3739,13 +3406,13 @@ * go away when the handler returns. */ if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) { if (handlerPtr->deleteProc != NULL) { - handlerPtr->deleteProc(handlerPtr->clientData); + (handlerPtr->deleteProc)(handlerPtr->clientData); } - Tcl_Free(handlerPtr); + ckfree((char *) handlerPtr); } return; } } @@ -3799,13 +3466,13 @@ * go away when the handler returns. */ if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) { if (handlerPtr->deleteProc != NULL) { - handlerPtr->deleteProc(handlerPtr->clientData); + (handlerPtr->deleteProc)(handlerPtr->clientData); } - Tcl_Free(handlerPtr); + ckfree((char *) handlerPtr); } } /* * Delete all time-limit handlers. @@ -3832,13 +3499,13 @@ * go away when the handler returns. */ if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) { if (handlerPtr->deleteProc != NULL) { - handlerPtr->deleteProc(handlerPtr->clientData); + (handlerPtr->deleteProc)(handlerPtr->clientData); } - Tcl_Free(handlerPtr); + ckfree((char *) handlerPtr); } } /* * Delete the timer callback that is used to trap limits that occur in @@ -4079,12 +3746,12 @@ static void TimeLimitCallback( ClientData clientData) { - Tcl_Interp *interp = (Tcl_Interp *)clientData; - Interp *iPtr = (Interp *)clientData; + Tcl_Interp *interp = clientData; + Interp *iPtr = clientData; int code; Tcl_Preserve(interp); iPtr->limit.timeEvent = NULL; @@ -4097,11 +3764,11 @@ iPtr->limit.granularityTicker = 0; code = Tcl_LimitCheck(interp); if (code != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (while waiting for event)"); - Tcl_BackgroundException(interp, code); + TclBackgroundException(interp, code); } Tcl_Release(interp); } /* @@ -4207,11 +3874,11 @@ *---------------------------------------------------------------------- * * DeleteScriptLimitCallback -- * * Callback for when a script limit (a limit callback implemented as a - * Tcl script in a parent interpreter, as set up from Tcl) is deleted. + * Tcl script in a master interpreter, as set up from Tcl) is deleted. * * Results: * None. * * Side effects: @@ -4223,17 +3890,17 @@ static void DeleteScriptLimitCallback( ClientData clientData) { - ScriptLimitCallback *limitCBPtr = (ScriptLimitCallback *)clientData; + ScriptLimitCallback *limitCBPtr = clientData; Tcl_DecrRefCount(limitCBPtr->scriptObj); if (limitCBPtr->entryPtr != NULL) { Tcl_DeleteHashEntry(limitCBPtr->entryPtr); } - Tcl_Free(limitCBPtr); + ckfree((char *) limitCBPtr); } /* *---------------------------------------------------------------------- * @@ -4253,23 +3920,23 @@ */ static void CallScriptLimitCallback( ClientData clientData, - TCL_UNUSED(Tcl_Interp *)) + Tcl_Interp *interp) /* Interpreter which failed the limit */ { - ScriptLimitCallback *limitCBPtr = (ScriptLimitCallback *)clientData; + ScriptLimitCallback *limitCBPtr = clientData; int code; if (Tcl_InterpDeleted(limitCBPtr->interp)) { return; } Tcl_Preserve(limitCBPtr->interp); code = Tcl_EvalObjEx(limitCBPtr->interp, limitCBPtr->scriptObj, TCL_EVAL_GLOBAL); if (code != TCL_OK && !Tcl_InterpDeleted(limitCBPtr->interp)) { - Tcl_BackgroundException(limitCBPtr->interp, code); + TclBackgroundException(limitCBPtr->interp, code); } Tcl_Release(limitCBPtr->interp); } /* @@ -4320,20 +3987,20 @@ Tcl_GetHashValue(hashPtr)); } return; } - hashPtr = Tcl_CreateHashEntry(&iPtr->limit.callbacks, &key, + hashPtr = Tcl_CreateHashEntry(&iPtr->limit.callbacks, (char *) &key, &isNew); if (!isNew) { - limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hashPtr); + limitCBPtr = Tcl_GetHashValue(hashPtr); limitCBPtr->entryPtr = NULL; Tcl_LimitRemoveHandler(targetInterp, type, CallScriptLimitCallback, limitCBPtr); } - limitCBPtr = (ScriptLimitCallback *)Tcl_Alloc(sizeof(ScriptLimitCallback)); + limitCBPtr = (ScriptLimitCallback *) ckalloc(sizeof(ScriptLimitCallback)); limitCBPtr->interp = interp; limitCBPtr->scriptObj = scriptObj; limitCBPtr->entryPtr = hashPtr; limitCBPtr->type = type; Tcl_IncrRefCount(scriptObj); @@ -4420,52 +4087,52 @@ } /* *---------------------------------------------------------------------- * - * InheritLimitsFromParent -- + * InheritLimitsFromMaster -- * - * Derive the interpreter limit configuration for a child interpreter - * from the limit config for the parent. + * Derive the interpreter limit configuration for a slave interpreter + * from the limit config for the master. * * Results: * None. * * Side effects: - * The child interpreter limits are set so that if the parent has a - * limit, it may not exceed it by handing off work to child interpreters. - * Note that this does not transfer limit callbacks from the parent to - * the child. + * The slave interpreter limits are set so that if the master has a + * limit, it may not exceed it by handing off work to slave interpreters. + * Note that this does not transfer limit callbacks from the master to + * the slave. * *---------------------------------------------------------------------- */ static void -InheritLimitsFromParent( - Tcl_Interp *childInterp, - Tcl_Interp *parentInterp) -{ - Interp *childPtr = (Interp *) childInterp; - Interp *parentPtr = (Interp *) parentInterp; - - if (parentPtr->limit.active & TCL_LIMIT_COMMANDS) { - childPtr->limit.active |= TCL_LIMIT_COMMANDS; - childPtr->limit.cmdCount = 0; - childPtr->limit.cmdGranularity = parentPtr->limit.cmdGranularity; - } - if (parentPtr->limit.active & TCL_LIMIT_TIME) { - childPtr->limit.active |= TCL_LIMIT_TIME; - memcpy(&childPtr->limit.time, &parentPtr->limit.time, - sizeof(Tcl_Time)); - childPtr->limit.timeGranularity = parentPtr->limit.timeGranularity; +InheritLimitsFromMaster( + Tcl_Interp *slaveInterp, + Tcl_Interp *masterInterp) +{ + Interp *slavePtr = (Interp *) slaveInterp; + Interp *masterPtr = (Interp *) masterInterp; + + if (masterPtr->limit.active & TCL_LIMIT_COMMANDS) { + slavePtr->limit.active |= TCL_LIMIT_COMMANDS; + slavePtr->limit.cmdCount = 0; + slavePtr->limit.cmdGranularity = masterPtr->limit.cmdGranularity; + } + if (masterPtr->limit.active & TCL_LIMIT_TIME) { + slavePtr->limit.active |= TCL_LIMIT_TIME; + memcpy(&slavePtr->limit.time, &masterPtr->limit.time, + sizeof(Tcl_Time)); + slavePtr->limit.timeGranularity = masterPtr->limit.timeGranularity; } } /* *---------------------------------------------------------------------- * - * ChildCommandLimitCmd -- + * SlaveCommandLimitCmd -- * * Implementation of the [interp limit $i commands] and [$i limit * commands] subcommands. See the interp manual page for a full * description. * @@ -4477,18 +4144,18 @@ * *---------------------------------------------------------------------- */ static int -ChildCommandLimitCmd( +SlaveCommandLimitCmd( Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Interp *childInterp, /* Interpreter being adjusted. */ + Tcl_Interp *slaveInterp, /* Interpreter being adjusted. */ int consumedObjc, /* Number of args already parsed. */ int objc, /* Total number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - static const char *const options[] = { + static const char *options[] = { "-command", "-granularity", "-value", NULL }; enum Options { OPT_CMD, OPT_GRAN, OPT_VAL }; @@ -4503,26 +4170,25 @@ * interpreter's limits; it may only manipulate its children. Note that * the low level API enforces this with Tcl_Panic, which we want to * avoid. [Bug 3398794] */ - if (interp == childInterp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "limits on current interpreter inaccessible", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL); + if (interp == slaveInterp) { + Tcl_AppendResult(interp, + "limits on current interpreter inaccessible", NULL); return TCL_ERROR; } if (objc == consumedObjc) { Tcl_Obj *dictPtr; TclNewObj(dictPtr); - key.interp = childInterp; + key.interp = slaveInterp; key.type = TCL_LIMIT_COMMANDS; hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); if (hPtr != NULL) { - limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr); + limitCBPtr = Tcl_GetHashValue(hPtr); if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1), limitCBPtr->scriptObj); } else { goto putEmptyCommandInDict; @@ -4534,16 +4200,16 @@ TclNewObj(empty); Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1), empty); } Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1), - Tcl_NewWideIntObj(Tcl_LimitGetGranularity(childInterp, + Tcl_NewIntObj(Tcl_LimitGetGranularity(slaveInterp, TCL_LIMIT_COMMANDS))); - if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_COMMANDS)) { + if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_COMMANDS)) { Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1), - Tcl_NewWideIntObj(Tcl_LimitGetCommands(childInterp))); + Tcl_NewIntObj(Tcl_LimitGetCommands(slaveInterp))); } else { Tcl_Obj *empty; TclNewObj(empty); Tcl_DictObjPut(NULL, dictPtr, @@ -4556,38 +4222,38 @@ 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum Options) index) { case OPT_CMD: - key.interp = childInterp; + key.interp = slaveInterp; key.type = TCL_LIMIT_COMMANDS; hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); if (hPtr != NULL) { - limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr); + limitCBPtr = Tcl_GetHashValue(hPtr); if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { Tcl_SetObjResult(interp, limitCBPtr->scriptObj); } } break; case OPT_GRAN: - Tcl_SetObjResult(interp, Tcl_NewWideIntObj( - Tcl_LimitGetGranularity(childInterp, TCL_LIMIT_COMMANDS))); + Tcl_SetObjResult(interp, Tcl_NewIntObj( + Tcl_LimitGetGranularity(slaveInterp, TCL_LIMIT_COMMANDS))); break; case OPT_VAL: - if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_COMMANDS)) { + if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_COMMANDS)) { Tcl_SetObjResult(interp, - Tcl_NewWideIntObj(Tcl_LimitGetCommands(childInterp))); + Tcl_NewIntObj(Tcl_LimitGetCommands(slaveInterp))); } break; } return TCL_OK; } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) { - Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?"); + Tcl_WrongNumArgs(interp, consumedObjc, objv, + "?-option? ?value? ?-option value ...?"); return TCL_ERROR; } else { - int i; - size_t scriptLen = 0, limitLen = 0; + int i, scriptLen = 0, limitLen = 0; Tcl_Obj *scriptObj = NULL, *granObj = NULL, *limitObj = NULL; int gran = 0, limit = 0; for (i=consumedObjc ; i 0 ? scriptObj : NULL)); } if (granObj != NULL) { - Tcl_LimitSetGranularity(childInterp, TCL_LIMIT_COMMANDS, gran); + Tcl_LimitSetGranularity(slaveInterp, TCL_LIMIT_COMMANDS, gran); } if (limitObj != NULL) { if (limitLen > 0) { - Tcl_LimitSetCommands(childInterp, limit); - Tcl_LimitTypeSet(childInterp, TCL_LIMIT_COMMANDS); + Tcl_LimitSetCommands(slaveInterp, limit); + Tcl_LimitTypeSet(slaveInterp, TCL_LIMIT_COMMANDS); } else { - Tcl_LimitTypeReset(childInterp, TCL_LIMIT_COMMANDS); + Tcl_LimitTypeReset(slaveInterp, TCL_LIMIT_COMMANDS); } } return TCL_OK; } } /* *---------------------------------------------------------------------- * - * ChildTimeLimitCmd -- + * SlaveTimeLimitCmd -- * * Implementation of the [interp limit $i time] and [$i limit time] * subcommands. See the interp manual page for a full description. * * Results: @@ -4666,18 +4328,18 @@ * *---------------------------------------------------------------------- */ static int -ChildTimeLimitCmd( +SlaveTimeLimitCmd( Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Interp *childInterp, /* Interpreter being adjusted. */ + Tcl_Interp *slaveInterp, /* Interpreter being adjusted. */ int consumedObjc, /* Number of args already parsed. */ int objc, /* Total number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - static const char *const options[] = { + static const char *options[] = { "-command", "-granularity", "-milliseconds", "-seconds", NULL }; enum Options { OPT_CMD, OPT_GRAN, OPT_MILLI, OPT_SEC }; @@ -4692,26 +4354,25 @@ * interpreter's limits; it may only manipulate its children. Note that * the low level API enforces this with Tcl_Panic, which we want to * avoid. [Bug 3398794] */ - if (interp == childInterp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "limits on current interpreter inaccessible", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL); + if (interp == slaveInterp) { + Tcl_AppendResult(interp, + "limits on current interpreter inaccessible", NULL); return TCL_ERROR; } if (objc == consumedObjc) { Tcl_Obj *dictPtr; TclNewObj(dictPtr); - key.interp = childInterp; + key.interp = slaveInterp; key.type = TCL_LIMIT_TIME; hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); if (hPtr != NULL) { - limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr); + limitCBPtr = Tcl_GetHashValue(hPtr); if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1), limitCBPtr->scriptObj); } else { goto putEmptyCommandInDict; @@ -4722,21 +4383,21 @@ TclNewObj(empty); Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1), empty); } Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1), - Tcl_NewWideIntObj(Tcl_LimitGetGranularity(childInterp, + Tcl_NewIntObj(Tcl_LimitGetGranularity(slaveInterp, TCL_LIMIT_TIME))); - if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_TIME)) { + if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) { Tcl_Time limitMoment; - Tcl_LimitGetTime(childInterp, &limitMoment); + Tcl_LimitGetTime(slaveInterp, &limitMoment); Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1), - Tcl_NewWideIntObj(limitMoment.usec/1000)); + Tcl_NewLongObj(limitMoment.usec/1000)); Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[3], -1), - Tcl_NewWideIntObj(limitMoment.sec)); + Tcl_NewLongObj(limitMoment.sec)); } else { Tcl_Obj *empty; TclNewObj(empty); Tcl_DictObjPut(NULL, dictPtr, @@ -4751,111 +4412,105 @@ 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum Options) index) { case OPT_CMD: - key.interp = childInterp; + key.interp = slaveInterp; key.type = TCL_LIMIT_TIME; hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); if (hPtr != NULL) { - limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr); + limitCBPtr = Tcl_GetHashValue(hPtr); if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { Tcl_SetObjResult(interp, limitCBPtr->scriptObj); } } break; case OPT_GRAN: - Tcl_SetObjResult(interp, Tcl_NewWideIntObj( - Tcl_LimitGetGranularity(childInterp, TCL_LIMIT_TIME))); + Tcl_SetObjResult(interp, Tcl_NewIntObj( + Tcl_LimitGetGranularity(slaveInterp, TCL_LIMIT_TIME))); break; case OPT_MILLI: - if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_TIME)) { + if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) { Tcl_Time limitMoment; - Tcl_LimitGetTime(childInterp, &limitMoment); + Tcl_LimitGetTime(slaveInterp, &limitMoment); Tcl_SetObjResult(interp, - Tcl_NewWideIntObj(limitMoment.usec/1000)); + Tcl_NewLongObj(limitMoment.usec/1000)); } break; case OPT_SEC: - if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_TIME)) { + if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) { Tcl_Time limitMoment; - Tcl_LimitGetTime(childInterp, &limitMoment); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(limitMoment.sec)); + Tcl_LimitGetTime(slaveInterp, &limitMoment); + Tcl_SetObjResult(interp, Tcl_NewLongObj(limitMoment.sec)); } break; } return TCL_OK; } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) { - Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?"); + Tcl_WrongNumArgs(interp, consumedObjc, objv, + "?-option? ?value? ?-option value ...?"); return TCL_ERROR; } else { - int i; - size_t scriptLen = 0, milliLen = 0, secLen = 0; + int i, scriptLen = 0, milliLen = 0, secLen = 0; Tcl_Obj *scriptObj = NULL, *granObj = NULL; Tcl_Obj *milliObj = NULL, *secObj = NULL; int gran = 0; Tcl_Time limitMoment; int tmp; - Tcl_LimitGetTime(childInterp, &limitMoment); + Tcl_LimitGetTime(slaveInterp, &limitMoment); for (i=consumedObjc ; i 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may only set -milliseconds if -seconds is not " - "also being reset", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", - "BADUSAGE", NULL); + Tcl_AppendResult(interp, "may only set -milliseconds " + "if -seconds is not also being reset", NULL); return TCL_ERROR; } if (milliLen == 0 && (secObj == NULL || secLen > 0)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may only reset -milliseconds if -seconds is " - "also being reset", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", - "BADUSAGE", NULL); + Tcl_AppendResult(interp, "may only reset -milliseconds " + "if -seconds is also being reset", NULL); return TCL_ERROR; } } if (milliLen > 0 || secLen > 0) { @@ -4893,22 +4542,22 @@ */ limitMoment.sec += limitMoment.usec / 1000000; limitMoment.usec %= 1000000; - Tcl_LimitSetTime(childInterp, &limitMoment); - Tcl_LimitTypeSet(childInterp, TCL_LIMIT_TIME); + Tcl_LimitSetTime(slaveInterp, &limitMoment); + Tcl_LimitTypeSet(slaveInterp, TCL_LIMIT_TIME); } else { - Tcl_LimitTypeReset(childInterp, TCL_LIMIT_TIME); + Tcl_LimitTypeReset(slaveInterp, TCL_LIMIT_TIME); } } if (scriptObj != NULL) { - SetScriptLimitCallback(interp, TCL_LIMIT_TIME, childInterp, + SetScriptLimitCallback(interp, TCL_LIMIT_TIME, slaveInterp, (scriptLen > 0 ? scriptObj : NULL)); } if (granObj != NULL) { - Tcl_LimitSetGranularity(childInterp, TCL_LIMIT_TIME, gran); + Tcl_LimitSetGranularity(slaveInterp, TCL_LIMIT_TIME, gran); } return TCL_OK; } } Index: generic/tclLink.c ================================================================== --- generic/tclLink.c +++ generic/tclLink.c @@ -6,69 +6,45 @@ * Andreas Stolcke and this implementation is based heavily on a * prototype implementation provided by him. * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * Copyright (c) 2008 Rene Zaumseil - * 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 /* * 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 { +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. */ - size_t bytes; /* Size of C variable array. This is 0 when - * single variables, and >0 used for array - * variables. */ - size_t numElems; /* Number of elements in C variable array. - * Zero for single variables. */ + char *addr; /* Location of C variable. */ int type; /* Type of link (TCL_LINK_INT, etc.). */ union { char c; unsigned char uc; int i; unsigned int ui; short s; unsigned short us; -#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) long l; unsigned long ul; -#endif Tcl_WideInt w; Tcl_WideUInt uw; float f; double d; - void *aryPtr; /* Generic array. */ - char *cPtr; /* char array */ - unsigned char *ucPtr; /* unsigned char array */ - short *sPtr; /* short array */ - unsigned short *usPtr; /* unsigned short array */ - int *iPtr; /* int array */ - unsigned int *uiPtr; /* unsigned int array */ - long *lPtr; /* long array */ - unsigned long *ulPtr; /* unsigned long array */ - Tcl_WideInt *wPtr; /* wide (long long) array */ - Tcl_WideUInt *uwPtr; /* unsigned wide (long long) array */ - float *fPtr; /* float array */ - double *dPtr; /* double array */ } lastValue; /* Last known value of C variable; used to * avoid string conversions. */ int flags; /* Miscellaneous one-bit values; see below for * definitions. */ } Link; @@ -78,46 +54,26 @@ * LINK_READ_ONLY - 1 means errors should be generated if Tcl * script attempts to write variable. * LINK_BEING_UPDATED - 1 means that a call to Tcl_UpdateLinkedVar is * in progress for this variable, so trace * callbacks on the variable should be ignored. - * LINK_ALLOC_ADDR - 1 means linkPtr->addr was allocated on the - * heap. - * LINK_ALLOC_LAST - 1 means linkPtr->valueLast.p was allocated on - * the heap. */ #define LINK_READ_ONLY 1 #define LINK_BEING_UPDATED 2 -#define LINK_ALLOC_ADDR 4 -#define LINK_ALLOC_LAST 8 /* * Forward references to functions defined later in this file: */ static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp, - const char *name1, const char *name2, int flags); + CONST char *name1, CONST char *name2, int flags); static Tcl_Obj * ObjValue(Link *linkPtr); -static void LinkFree(Link *linkPtr); -static int GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr); +static int GetInvalidIntFromObj(Tcl_Obj *objPtr, + int *intPtr); static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr, - double *doublePtr); -static int SetInvalidRealFromAny(Tcl_Interp *interp, - Tcl_Obj *objPtr); - -/* - * A marker type used to flag weirdnesses so we can pass them around right. - */ - -static Tcl_ObjType invalidRealType = { - "invalidReal", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ -}; + double *doublePtr); /* * Convenience macro for accessing the value of the C variable pointed to by a * link. Note that this macro produces something that may be regarded as an * lvalue or rvalue; it may be assigned to as well as read. Also note that @@ -149,12 +105,12 @@ */ int Tcl_LinkVar( Tcl_Interp *interp, /* Interpreter in which varName exists. */ - const char *varName, /* Name of a global variable in interp. */ - void *addr, /* Address of a C variable to be linked to + CONST char *varName, /* Name of a global variable in interp. */ + char *addr, /* Address of a C variable to be linked to * varName. */ int type) /* Type of C variable: TCL_LINK_INT, etc. Also * may have TCL_LINK_READ_ONLY OR'ed in. */ { Tcl_Obj *objPtr; @@ -161,247 +117,49 @@ Link *linkPtr; Namespace *dummy; const char *name; int code; - linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL, - TCL_GLOBAL_ONLY, LinkTraceProc, NULL); + linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY, + LinkTraceProc, (ClientData) NULL); if (linkPtr != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "variable '%s' is already linked", varName)); return TCL_ERROR; } - linkPtr = (Link *)Tcl_Alloc(sizeof(Link)); + 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) \ - || 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 if (type & TCL_LINK_READ_ONLY) { linkPtr->flags = LINK_READ_ONLY; } else { linkPtr->flags = 0; } - linkPtr->bytes = 0; - linkPtr->numElems = 0; objPtr = ObjValue(linkPtr); if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DecrRefCount(linkPtr->varName); - LinkFree(linkPtr); + ckfree((char *) linkPtr); return TCL_ERROR; } TclGetNamespaceForQualName(interp, varName, NULL, TCL_GLOBAL_ONLY, &(linkPtr->nsPtr), &dummy, &dummy, &name); linkPtr->nsPtr->refCount++; - code = Tcl_TraceVar2(interp, varName, NULL, - TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - LinkTraceProc, linkPtr); - if (code != TCL_OK) { - Tcl_DecrRefCount(linkPtr->varName); - LinkFree(linkPtr); - } - return code; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_LinkArray -- - * - * Link a C variable array to a Tcl variable so that changes to either - * one causes the other to change. - * - * Results: - * The return value is TCL_OK if everything went well or TCL_ERROR if an - * error occurred (the interp's result is also set after errors). - * - * Side effects: - * The value at *addr is linked to the Tcl variable "varName", using - * "type" to convert between string values for Tcl and binary values for - * *addr. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_LinkArray( - Tcl_Interp *interp, /* Interpreter in which varName exists. */ - 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. */ - size_t 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 *)Tcl_Alloc(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; - } - - switch (linkPtr->type) { - case TCL_LINK_INT: - case TCL_LINK_BOOLEAN: - linkPtr->bytes = size * sizeof(int); - break; - case TCL_LINK_DOUBLE: - linkPtr->bytes = size * sizeof(double); - break; - case TCL_LINK_WIDE_INT: - linkPtr->bytes = size * sizeof(Tcl_WideInt); - break; - case TCL_LINK_WIDE_UINT: - linkPtr->bytes = size * sizeof(Tcl_WideUInt); - break; - case TCL_LINK_CHAR: - linkPtr->bytes = size * sizeof(char); - break; - case TCL_LINK_UCHAR: - linkPtr->bytes = size * sizeof(unsigned char); - break; - case TCL_LINK_SHORT: - linkPtr->bytes = size * sizeof(short); - break; - case TCL_LINK_USHORT: - linkPtr->bytes = size * sizeof(unsigned short); - break; - case TCL_LINK_UINT: - linkPtr->bytes = size * sizeof(unsigned int); - break; -#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) - case TCL_LINK_LONG: - linkPtr->bytes = size * sizeof(long); - break; - case TCL_LINK_ULONG: - linkPtr->bytes = size * sizeof(unsigned long); - break; -#endif - case TCL_LINK_FLOAT: - linkPtr->bytes = size * sizeof(float); - break; - case TCL_LINK_STRING: - linkPtr->bytes = size * sizeof(char); - size = 1; /* This is a variable length string, no need - * to check last value. */ - - /* - * If no address is given create one and use as address the - * not needed linkPtr->lastValue - */ - - if (addr == NULL) { - linkPtr->lastValue.aryPtr = Tcl_Alloc(linkPtr->bytes); - linkPtr->flags |= LINK_ALLOC_LAST; - addr = (char *) &linkPtr->lastValue.cPtr; - } - 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 = Tcl_Alloc(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 = Tcl_Alloc(linkPtr->bytes); - linkPtr->flags |= LINK_ALLOC_LAST; - } - - /* - * Initialize allocated space. - */ - - if (linkPtr->flags & LINK_ALLOC_ADDR) { - memset(linkPtr->addr, 0, linkPtr->bytes); - } - if (linkPtr->flags & LINK_ALLOC_LAST) { - memset(linkPtr->lastValue.aryPtr, 0, linkPtr->bytes); - } - - /* - * Set common structure values. - */ - - linkPtr->interp = interp; - linkPtr->varName = Tcl_NewStringObj(varName, -1); - Tcl_IncrRefCount(linkPtr->varName); - - TclGetNamespaceForQualName(interp, varName, NULL, TCL_GLOBAL_ONLY, - &(linkPtr->nsPtr), &dummy, &dummy, &name); - linkPtr->nsPtr->refCount++; - - objPtr = ObjValue(linkPtr); - if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr, - TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { - Tcl_DecrRefCount(linkPtr->varName); - LinkFree(linkPtr); - return TCL_ERROR; - } - - code = Tcl_TraceVar2(interp, varName, NULL, - TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - LinkTraceProc, linkPtr); - if (code != TCL_OK) { - Tcl_DecrRefCount(linkPtr->varName); - LinkFree(linkPtr); + code = Tcl_TraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS + |TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, + (ClientData) linkPtr); + if (code != TCL_OK) { + Tcl_DecrRefCount(linkPtr->varName); + TclNsDecrRefCount(linkPtr->nsPtr); + ckfree((char *) linkPtr); } return code; } /* @@ -423,23 +181,27 @@ */ void Tcl_UnlinkVar( Tcl_Interp *interp, /* Interpreter containing variable to unlink */ - const char *varName) /* Global variable in interp to unlink. */ + CONST char *varName) /* Global variable in interp to unlink. */ { - Link *linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL, - TCL_GLOBAL_ONLY, LinkTraceProc, NULL); + Link *linkPtr; + linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY, + LinkTraceProc, (ClientData) NULL); if (linkPtr == NULL) { return; } - Tcl_UntraceVar2(interp, varName, NULL, + Tcl_UntraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - LinkTraceProc, linkPtr); + LinkTraceProc, (ClientData) linkPtr); Tcl_DecrRefCount(linkPtr->varName); - LinkFree(linkPtr); + if (linkPtr->nsPtr) { + TclNsDecrRefCount(linkPtr->nsPtr); + } + ckfree((char *) linkPtr); } /* *---------------------------------------------------------------------- * @@ -460,16 +222,17 @@ */ void Tcl_UpdateLinkedVar( Tcl_Interp *interp, /* Interpreter containing variable. */ - const char *varName) /* Name of global variable that is linked. */ + CONST char *varName) /* Name of global variable that is linked. */ { - Link *linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL, - TCL_GLOBAL_ONLY, LinkTraceProc, NULL); + Link *linkPtr; int savedFlag; + linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY, + LinkTraceProc, (ClientData) NULL); if (linkPtr == NULL) { return; } savedFlag = linkPtr->flags & LINK_BEING_UPDATED; linkPtr->flags |= LINK_BEING_UPDATED; @@ -476,252 +239,16 @@ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); /* * Callback may have unlinked the variable. [Bug 1740631] */ - linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL, - TCL_GLOBAL_ONLY, LinkTraceProc, NULL); + linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY, + LinkTraceProc, (ClientData) NULL); if (linkPtr != NULL) { linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag; } } - -/* - *---------------------------------------------------------------------- - * - * GetInt, GetWide, GetUWide, GetDouble, EqualDouble, IsSpecial -- - * - * Helper functions for LinkTraceProc and ObjValue. These are all - * factored out here to make those functions simpler. - * - *---------------------------------------------------------------------- - */ - -static inline int -GetInt( - Tcl_Obj *objPtr, - int *intPtr) -{ - return (Tcl_GetIntFromObj(NULL, objPtr, intPtr) != TCL_OK - && GetInvalidIntFromObj(objPtr, intPtr) != TCL_OK); -} - -static inline int -GetWide( - Tcl_Obj *objPtr, - Tcl_WideInt *widePtr) -{ - if (Tcl_GetWideIntFromObj(NULL, objPtr, widePtr) != TCL_OK) { - int intValue; - - if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { - return 1; - } - *widePtr = intValue; - } - return 0; -} - -static inline int -GetUWide( - Tcl_Obj *objPtr, - Tcl_WideUInt *uwidePtr) -{ - Tcl_WideInt *widePtr = (Tcl_WideInt *) uwidePtr; - ClientData clientData; - 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; - } -#ifdef WORDS_BIGENDIAN - while (numBytes-- > 0) { - value = (value << CHAR_BIT) | *bytes++; - } -#else /* !WORDS_BIGENDIAN */ - /* - * Little-endian can read the value directly. - */ - value = scratch.value; -#endif /* WORDS_BIGENDIAN */ - *uwidePtr = value; - return 0; - } - } - - /* - * Evil edge case fallback. - */ - - if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { - return 1; - } - *uwidePtr = intValue; - return 0; -} - -static inline int -GetDouble( - Tcl_Obj *objPtr, - double *dblPtr) -{ - if (Tcl_GetDoubleFromObj(NULL, objPtr, dblPtr) == TCL_OK) { - return 0; - } else { -#ifdef ACCEPT_NAN - Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &tclDoubleType); - - if (irPtr != NULL) { - *dblPtr = irPtr->doubleValue; - return 0; - } -#endif /* ACCEPT_NAN */ - return GetInvalidDoubleFromObj(objPtr, dblPtr) != TCL_OK; - } -} - -static inline int -EqualDouble( - double a, - double b) -{ - return (a == b) -#ifdef ACCEPT_NAN - || (TclIsNaN(a) && TclIsNaN(b)) -#endif /* ACCEPT_NAN */ - ; -} - -static inline int -IsSpecial( - double a) -{ - return TclIsInfinite(a) -#ifdef ACCEPT_NAN - || TclIsNaN(a) -#endif /* ACCEPT_NAN */ - ; -} - -/* - * Mark an object as holding a weird double. - */ - -static int -SetInvalidRealFromAny( - TCL_UNUSED(Tcl_Interp *), - Tcl_Obj *objPtr) -{ - size_t length; - const char *str, *endPtr; - - str = TclGetStringFromObj(objPtr, &length); - if ((length == 1) && (str[0] == '.')) { - objPtr->typePtr = &invalidRealType; - objPtr->internalRep.doubleValue = 0.0; - return TCL_OK; - } - if (TclParseNumber(NULL, objPtr, NULL, str, length, &endPtr, - TCL_PARSE_DECIMAL_ONLY) == TCL_OK) { - /* - * 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; - } - if (*endPtr == 0) { - double doubleValue = 0.0; - - Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue); - TclFreeIntRep(objPtr); - objPtr->typePtr = &invalidRealType; - objPtr->internalRep.doubleValue = doubleValue; - return TCL_OK; - } - } - } - 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" (upper- and - * lower-case). See bug [39f6304c2e]. - */ - -static int -GetInvalidIntFromObj( - Tcl_Obj *objPtr, - int *intPtr) -{ - size_t length; - const char *str = TclGetStringFromObj(objPtr, &length); - - if ((length == 0) || - ((length == 2) && (str[0] == '0') && strchr("xXbBoOdD", str[1]))) { - *intPtr = 0; - return TCL_OK; - } else if ((length == 1) && strchr("+-", str[0])) { - *intPtr = (str[0] == '+'); - 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 lower-case) - * and sequences like "1e-". See bug [39f6304c2e]. - */ - -static int -GetInvalidDoubleFromObj( - Tcl_Obj *objPtr, - double *doublePtr) -{ - int intValue; - - if (TclHasIntRep(objPtr, &invalidRealType)) { - goto gotdouble; - } - if (GetInvalidIntFromObj(objPtr, &intValue) == TCL_OK) { - *doublePtr = (double) intValue; - return TCL_OK; - } - if (SetInvalidRealFromAny(NULL, objPtr) == TCL_OK) { - gotdouble: - *doublePtr = objPtr->internalRep.doubleValue; - return TCL_OK; - } - return TCL_ERROR; -} /* *---------------------------------------------------------------------- * * LinkTraceProc -- @@ -744,46 +271,41 @@ 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. */ + CONST char *name1, /* First part of variable name. */ + CONST char *name2, /* Second part of variable name. */ int flags) /* Miscellaneous additional information. */ { - Link *linkPtr = (Link *)clientData; - int changed; - size_t valueLength = 0; - const char *value; + Link *linkPtr = (Link *) clientData; + int changed, valueLength; + CONST char *value; char **pp; Tcl_Obj *valueObj; int valueInt; Tcl_WideInt valueWide; - Tcl_WideUInt valueUWide; double valueDouble; - int objc; - Tcl_Obj **objv; - int i; /* * If the variable is being unset, then just re-create it (with a trace) * unless the whole interpreter is going away. */ if (flags & TCL_TRACE_UNSETS) { if (Tcl_InterpDeleted(interp) || TclNamespaceDeleted(linkPtr->nsPtr)) { Tcl_DecrRefCount(linkPtr->varName); - LinkFree(linkPtr); + if (linkPtr->nsPtr) { + TclNsDecrRefCount(linkPtr->nsPtr); + } + ckfree((char *) linkPtr); } else if (flags & TCL_TRACE_DESTROYED) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); - Tcl_TraceVar2(interp, TclGetString(linkPtr->varName), NULL, + Tcl_TraceVar(interp, Tcl_GetString(linkPtr->varName), TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES - |TCL_TRACE_UNSETS, LinkTraceProc, linkPtr); + |TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr); } return NULL; } /* @@ -800,68 +322,53 @@ * For read accesses, update the Tcl variable if the C variable has * changed since the last time we updated the Tcl variable. */ if (flags & TCL_TRACE_READS) { - /* - * Variable arrays - */ - - if (linkPtr->flags & LINK_ALLOC_LAST) { - changed = memcmp(linkPtr->addr, linkPtr->lastValue.aryPtr, - linkPtr->bytes); - } else { - /* single variables */ - switch (linkPtr->type) { - case TCL_LINK_INT: - case TCL_LINK_BOOLEAN: - changed = (LinkedVar(int) != linkPtr->lastValue.i); - break; - case TCL_LINK_DOUBLE: - changed = !EqualDouble(LinkedVar(double), linkPtr->lastValue.d); - break; - case TCL_LINK_WIDE_INT: - changed = (LinkedVar(Tcl_WideInt) != linkPtr->lastValue.w); - break; - case TCL_LINK_WIDE_UINT: - changed = (LinkedVar(Tcl_WideUInt) != linkPtr->lastValue.uw); - break; - case TCL_LINK_CHAR: - changed = (LinkedVar(char) != linkPtr->lastValue.c); - break; - case TCL_LINK_UCHAR: - changed = (LinkedVar(unsigned char) != linkPtr->lastValue.uc); - break; - case TCL_LINK_SHORT: - changed = (LinkedVar(short) != linkPtr->lastValue.s); - break; - case TCL_LINK_USHORT: - changed = (LinkedVar(unsigned short) != linkPtr->lastValue.us); - break; - case TCL_LINK_UINT: - changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui); - break; -#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) - case TCL_LINK_LONG: - changed = (LinkedVar(long) != linkPtr->lastValue.l); - break; - case TCL_LINK_ULONG: - changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul); - break; -#endif - case TCL_LINK_FLOAT: - changed = !EqualDouble(LinkedVar(float), linkPtr->lastValue.f); - break; - case TCL_LINK_STRING: - case TCL_LINK_CHARS: - case TCL_LINK_BINARY: - changed = 1; - break; - default: - changed = 0; - /* return (char *) "internal error: bad linked variable type"; */ - } + switch (linkPtr->type) { + case TCL_LINK_INT: + case TCL_LINK_BOOLEAN: + changed = (LinkedVar(int) != linkPtr->lastValue.i); + break; + case TCL_LINK_DOUBLE: + changed = (LinkedVar(double) != linkPtr->lastValue.d); + break; + case TCL_LINK_WIDE_INT: + changed = (LinkedVar(Tcl_WideInt) != linkPtr->lastValue.w); + break; + case TCL_LINK_WIDE_UINT: + changed = (LinkedVar(Tcl_WideUInt) != linkPtr->lastValue.uw); + break; + case TCL_LINK_CHAR: + changed = (LinkedVar(char) != linkPtr->lastValue.c); + break; + case TCL_LINK_UCHAR: + changed = (LinkedVar(unsigned char) != linkPtr->lastValue.uc); + break; + case TCL_LINK_SHORT: + changed = (LinkedVar(short) != linkPtr->lastValue.s); + break; + case TCL_LINK_USHORT: + changed = (LinkedVar(unsigned short) != linkPtr->lastValue.us); + break; + case TCL_LINK_UINT: + changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui); + break; + case TCL_LINK_LONG: + changed = (LinkedVar(long) != linkPtr->lastValue.l); + break; + case TCL_LINK_ULONG: + changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul); + break; + case TCL_LINK_FLOAT: + changed = (LinkedVar(float) != linkPtr->lastValue.f); + break; + case TCL_LINK_STRING: + changed = 1; + break; + default: + return "internal error: bad linked variable type"; } if (changed) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); } @@ -878,390 +385,226 @@ */ if (linkPtr->flags & LINK_READ_ONLY) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "linked variable is read-only"; + return "linked variable is read-only"; } valueObj = Tcl_ObjGetVar2(interp, linkPtr->varName,NULL, TCL_GLOBAL_ONLY); if (valueObj == NULL) { /* * This shouldn't ever happen. */ - return (char *) "internal error: linked variable couldn't be read"; - } - - /* - * Special cases. - */ - - switch (linkPtr->type) { - case TCL_LINK_STRING: - value = TclGetStringFromObj(valueObj, &valueLength); - pp = (char **) linkPtr->addr; - - *pp = (char *)Tcl_Realloc(*pp, ++valueLength); - memcpy(*pp, value, valueLength); - return NULL; - - case TCL_LINK_CHARS: - value = (char *) TclGetStringFromObj(valueObj, &valueLength); - valueLength++; /* include end of string char */ - if (valueLength > linkPtr->bytes) { - return (char *) "wrong size of char* value"; - } - if (linkPtr->flags & LINK_ALLOC_LAST) { - memcpy(linkPtr->lastValue.aryPtr, value, valueLength); - memcpy(linkPtr->addr, value, valueLength); - } else { - linkPtr->lastValue.c = '\0'; - LinkedVar(char) = linkPtr->lastValue.c; - } - return NULL; - - case TCL_LINK_BINARY: - value = (char *) TclGetByteArrayFromObj(valueObj, &valueLength); - if (valueLength != linkPtr->bytes) { - return (char *) "wrong size of binary value"; - } - if (linkPtr->flags & LINK_ALLOC_LAST) { - memcpy(linkPtr->lastValue.aryPtr, value, valueLength); - memcpy(linkPtr->addr, value, valueLength); - } else { - linkPtr->lastValue.uc = (unsigned char) *value; - LinkedVar(unsigned char) = linkPtr->lastValue.uc; - } - return NULL; - } - - /* - * A helper macro. Writing this as a function is messy because of type - * variance. - */ - -#define InRange(lowerLimit, value, upperLimit) \ - ((value) >= (lowerLimit) && (value) <= (upperLimit)) - - /* - * 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 - || (size_t)objc != linkPtr->numElems) { - return (char *) "wrong dimension"; - } + return "internal error: linked variable couldn't be read"; } switch (linkPtr->type) { case TCL_LINK_INT: - if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i=0; i < objc; i++) { - int *varPtr = &linkPtr->lastValue.iPtr[i]; - - if (GetInt(objv[i], varPtr)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable array must have integer values"; - } - } - } else { - int *varPtr = &linkPtr->lastValue.i; - - if (GetInt(valueObj, varPtr)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have integer value"; - } - LinkedVar(int) = *varPtr; - } + if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i) + != TCL_OK) { + if (GetInvalidIntFromObj(valueObj, &linkPtr->lastValue.i) + != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return "variable must have integer value"; + } + } + LinkedVar(int) = linkPtr->lastValue.i; break; case TCL_LINK_WIDE_INT: - if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i=0; i < objc; i++) { - Tcl_WideInt *varPtr = &linkPtr->lastValue.wPtr[i]; - - if (GetWide(objv[i], varPtr)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) - "variable array must have wide integer value"; - } - } - } else { - Tcl_WideInt *varPtr = &linkPtr->lastValue.w; - - if (GetWide(valueObj, varPtr)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have wide integer value"; - } - LinkedVar(Tcl_WideInt) = *varPtr; - } + if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w) + != TCL_OK) { + if (GetInvalidIntFromObj(valueObj, &valueInt) + != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return "variable must have integer value"; + } + linkPtr->lastValue.w = (Tcl_WideInt) valueInt; + } + LinkedVar(Tcl_WideInt) = linkPtr->lastValue.w; break; case TCL_LINK_DOUBLE: - if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i=0; i < objc; i++) { - if (GetDouble(objv[i], &linkPtr->lastValue.dPtr[i])) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable array must have real value"; - } - } - } else { - double *varPtr = &linkPtr->lastValue.d; - - if (GetDouble(valueObj, varPtr)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have real value"; - } - LinkedVar(double) = *varPtr; - } + if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d) + != TCL_OK) { +#ifdef ACCEPT_NAN + if (valueObj->typePtr != &tclDoubleType) { +#endif + if (GetInvalidDoubleFromObj(valueObj, &linkPtr->lastValue.d) + != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return "variable must have real value"; + } +#ifdef ACCEPT_NAN + } + linkPtr->lastValue.d = valueObj->internalRep.doubleValue; +#endif + } + LinkedVar(double) = linkPtr->lastValue.d; break; case TCL_LINK_BOOLEAN: - if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i=0; i < objc; i++) { - int *varPtr = &linkPtr->lastValue.iPtr[i]; - - if (Tcl_GetBooleanFromObj(NULL, objv[i], varPtr) != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable array must have boolean value"; - } - } - } else { - int *varPtr = &linkPtr->lastValue.i; - - if (Tcl_GetBooleanFromObj(NULL, valueObj, varPtr) != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have boolean value"; - } - LinkedVar(int) = *varPtr; - } + if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i) + != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return "variable must have boolean value"; + } + LinkedVar(int) = linkPtr->lastValue.i; break; case TCL_LINK_CHAR: - if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i=0; i < objc; i++) { - if (GetInt(objv[i], &valueInt) - || !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable array must have char value"; - } - linkPtr->lastValue.cPtr[i] = (char) valueInt; - } - } else { - if (GetInt(valueObj, &valueInt) - || !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have char value"; - } - LinkedVar(char) = linkPtr->lastValue.c = (char) valueInt; - } + if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK + || valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) { + if (GetInvalidIntFromObj(valueObj, &valueInt) + != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return "variable must have char value"; + } + } + linkPtr->lastValue.c = (char)valueInt; + LinkedVar(char) = linkPtr->lastValue.c; break; case TCL_LINK_UCHAR: - if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i=0; i < objc; i++) { - if (GetInt(objv[i], &valueInt) - || !InRange(0, valueInt, UCHAR_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) - "variable array must have unsigned char value"; - } - linkPtr->lastValue.ucPtr[i] = (unsigned char) valueInt; - } - } else { - if (GetInt(valueObj, &valueInt) - || !InRange(0, valueInt, UCHAR_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned char value"; - } - LinkedVar(unsigned char) = linkPtr->lastValue.uc = - (unsigned char) valueInt; - } + if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK + || valueInt < 0 || valueInt > UCHAR_MAX) { + if (GetInvalidIntFromObj(valueObj, &valueInt) + != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return "variable must have unsigned char value"; + } + } + linkPtr->lastValue.uc = (unsigned char) valueInt; + LinkedVar(unsigned char) = linkPtr->lastValue.uc; break; case TCL_LINK_SHORT: - if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i=0; i < objc; i++) { - if (GetInt(objv[i], &valueInt) - || !InRange(SHRT_MIN, valueInt, SHRT_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable array must have short value"; - } - linkPtr->lastValue.sPtr[i] = (short) valueInt; - } - } else { - if (GetInt(valueObj, &valueInt) - || !InRange(SHRT_MIN, valueInt, SHRT_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have short value"; - } - LinkedVar(short) = linkPtr->lastValue.s = (short) valueInt; - } + if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK + || valueInt < SHRT_MIN || valueInt > SHRT_MAX) { + if (GetInvalidIntFromObj(valueObj, &valueInt) + != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return "variable must have short value"; + } + } + linkPtr->lastValue.s = (short)valueInt; + LinkedVar(short) = linkPtr->lastValue.s; break; case TCL_LINK_USHORT: - if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i=0; i < objc; i++) { - if (GetInt(objv[i], &valueInt) - || !InRange(0, valueInt, USHRT_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) - "variable array must have unsigned short value"; - } - linkPtr->lastValue.usPtr[i] = (unsigned short) valueInt; - } - } else { - if (GetInt(valueObj, &valueInt) - || !InRange(0, valueInt, USHRT_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned short value"; - } - LinkedVar(unsigned short) = linkPtr->lastValue.us = - (unsigned short) valueInt; - } + if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK + || valueInt < 0 || valueInt > USHRT_MAX) { + if (GetInvalidIntFromObj(valueObj, &valueInt) + != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return "variable must have unsigned short value"; + } + } + linkPtr->lastValue.us = (unsigned short)valueInt; + LinkedVar(unsigned short) = linkPtr->lastValue.us; break; case TCL_LINK_UINT: - if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i=0; i < objc; i++) { - if (GetWide(objv[i], &valueWide) - || !InRange(0, valueWide, UINT_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) - "variable array must have unsigned int value"; - } - linkPtr->lastValue.uiPtr[i] = (unsigned int) valueWide; - } - } else { - if (GetWide(valueObj, &valueWide) - || !InRange(0, valueWide, UINT_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned int value"; - } - LinkedVar(unsigned int) = linkPtr->lastValue.ui = - (unsigned int) valueWide; - } - break; - -#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) - case TCL_LINK_LONG: - if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i=0; i < objc; i++) { - if (GetWide(objv[i], &valueWide) - || !InRange(LONG_MIN, valueWide, LONG_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable array must have long value"; - } - linkPtr->lastValue.lPtr[i] = (long) valueWide; - } - } else { - if (GetWide(valueObj, &valueWide) - || !InRange(LONG_MIN, valueWide, LONG_MAX)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have long value"; - } - LinkedVar(long) = linkPtr->lastValue.l = (long) valueWide; - } + if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK + || valueWide < 0 || valueWide > UINT_MAX) { + if (GetInvalidIntFromObj(valueObj, &valueInt) + != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return "variable must have unsigned int value"; + } + linkPtr->lastValue.ui = (unsigned int)valueInt; + } else { + linkPtr->lastValue.ui = (unsigned int)valueWide; + } + LinkedVar(unsigned int) = linkPtr->lastValue.ui; + break; + + case TCL_LINK_LONG: + if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK + || valueWide < LONG_MIN || valueWide > LONG_MAX) { + if (GetInvalidIntFromObj(valueObj, &valueInt) + != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return "variable must have long value"; + } + linkPtr->lastValue.l = (long)valueInt; + } else { + linkPtr->lastValue.l = (long)valueWide; + } + LinkedVar(long) = linkPtr->lastValue.l; 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; - } + if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK + || valueWide < 0 || (Tcl_WideUInt) valueWide > ULONG_MAX) { + if (GetInvalidIntFromObj(valueObj, &valueInt) + != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return "variable must have unsigned long value"; + } + linkPtr->lastValue.ul = (unsigned long)valueInt; } 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; - } - break; -#endif + linkPtr->lastValue.ul = (unsigned long)valueWide; + } + LinkedVar(unsigned long) = linkPtr->lastValue.ul; + break; case TCL_LINK_WIDE_UINT: - if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i=0; i < objc; i++) { - if (GetUWide(objv[i], &valueUWide)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) - "variable array must have unsigned wide int value"; - } - linkPtr->lastValue.uwPtr[i] = valueUWide; - } - } else { - if (GetUWide(valueObj, &valueUWide)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned wide int value"; - } - LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw = valueUWide; - } + /* + * FIXME: represent as a bignum. + */ + if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK) { + if (GetInvalidIntFromObj(valueObj, &valueInt) + != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return "variable must have unsigned wide int value"; + } + linkPtr->lastValue.uw = (Tcl_WideUInt)valueInt; + } else { + linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide; + } + LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw; break; case TCL_LINK_FLOAT: - if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i=0; i < objc; i++) { - if (GetDouble(objv[i], &valueDouble) - && !InRange(FLT_MIN, fabs(valueDouble), FLT_MAX) - && !IsSpecial(valueDouble)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable array must have float value"; - } - linkPtr->lastValue.fPtr[i] = (float) valueDouble; - } - } else { - if (GetDouble(valueObj, &valueDouble) - && !InRange(FLT_MIN, fabs(valueDouble), FLT_MAX) - && !IsSpecial(valueDouble)) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have float value"; - } - LinkedVar(float) = linkPtr->lastValue.f = (float) valueDouble; - } + if (Tcl_GetDoubleFromObj(NULL, valueObj, &valueDouble) != TCL_OK + || valueDouble < -FLT_MAX || valueDouble > FLT_MAX) { + if (GetInvalidDoubleFromObj(valueObj, &valueDouble) + != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return "variable must have float value"; + } + } + linkPtr->lastValue.f = (float)valueDouble; + LinkedVar(float) = linkPtr->lastValue.f; + break; + + case TCL_LINK_STRING: + value = Tcl_GetStringFromObj(valueObj, &valueLength); + valueLength++; + pp = (char **) linkPtr->addr; + + *pp = ckrealloc(*pp, valueLength); + memcpy(*pp, value, (unsigned) valueLength); break; default: - return (char *) "internal error: bad linked variable type"; - } - - if (linkPtr->flags & LINK_ALLOC_LAST) { - memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + return "internal error: bad linked variable type"; } return NULL; } /* @@ -1285,214 +628,63 @@ static Tcl_Obj * ObjValue( Link *linkPtr) /* Structure describing linked variable. */ { char *p; - Tcl_Obj *resultObj, **objv; - size_t i; + Tcl_Obj *resultObj; switch (linkPtr->type) { case TCL_LINK_INT: - if (linkPtr->flags & LINK_ALLOC_LAST) { - memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); - for (i=0; i < linkPtr->numElems; i++) { - TclNewIntObj(objv[i], linkPtr->lastValue.iPtr[i]); - } - resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(objv); - return resultObj; - } linkPtr->lastValue.i = LinkedVar(int); - return Tcl_NewWideIntObj(linkPtr->lastValue.i); + 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 **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); - for (i=0; i < linkPtr->numElems; i++) { - TclNewIntObj(objv[i], linkPtr->lastValue.wPtr[i]); - } - resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(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 **)Tcl_Alloc(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); - Tcl_Free(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 **)Tcl_Alloc(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); - Tcl_Free(objv); - return resultObj; - } linkPtr->lastValue.i = LinkedVar(int); - return Tcl_NewBooleanObj(linkPtr->lastValue.i); + return Tcl_NewBooleanObj(linkPtr->lastValue.i != 0); case TCL_LINK_CHAR: - if (linkPtr->flags & LINK_ALLOC_LAST) { - memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); - for (i=0; i < linkPtr->numElems; i++) { - TclNewIntObj(objv[i], linkPtr->lastValue.cPtr[i]); - } - resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(objv); - return resultObj; - } linkPtr->lastValue.c = LinkedVar(char); - return Tcl_NewWideIntObj(linkPtr->lastValue.c); + 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 **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); - for (i=0; i < linkPtr->numElems; i++) { - TclNewIntObj(objv[i], linkPtr->lastValue.ucPtr[i]); - } - resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(objv); - return resultObj; - } linkPtr->lastValue.uc = LinkedVar(unsigned char); - return Tcl_NewWideIntObj(linkPtr->lastValue.uc); + 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 **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); - for (i=0; i < linkPtr->numElems; i++) { - TclNewIntObj(objv[i], linkPtr->lastValue.sPtr[i]); - } - resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(objv); - return resultObj; - } linkPtr->lastValue.s = LinkedVar(short); - return Tcl_NewWideIntObj(linkPtr->lastValue.s); + 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 **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); - for (i=0; i < linkPtr->numElems; i++) { - TclNewIntObj(objv[i], linkPtr->lastValue.usPtr[i]); - } - resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(objv); - return resultObj; - } linkPtr->lastValue.us = LinkedVar(unsigned short); - return Tcl_NewWideIntObj(linkPtr->lastValue.us); + 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 **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); - for (i=0; i < linkPtr->numElems; i++) { - TclNewIntObj(objv[i], linkPtr->lastValue.uiPtr[i]); - } - resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(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 **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); - for (i=0; i < linkPtr->numElems; i++) { - TclNewIntObj(objv[i], linkPtr->lastValue.lPtr[i]); - } - resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(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 **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); - for (i=0; i < linkPtr->numElems; i++) { - TclNewIntObj(objv[i], linkPtr->lastValue.ulPtr[i]); - } - resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(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 **)Tcl_Alloc(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); - Tcl_Free(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 **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); - for (i=0; i < linkPtr->numElems; i++) { - TclNewIntObj(objv[i], (Tcl_WideInt) - linkPtr->lastValue.uwPtr[i]); - } - resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(objv); - return resultObj; - } linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt); + /* + * FIXME: represent as a bignum. + */ return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.uw); - case TCL_LINK_STRING: p = LinkedVar(char *); if (p == NULL) { TclNewLiteralStringObj(resultObj, "NULL"); return resultObj; } return Tcl_NewStringObj(p, -1); - case TCL_LINK_CHARS: - if (linkPtr->flags & LINK_ALLOC_LAST) { - memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - linkPtr->lastValue.cPtr[linkPtr->bytes-1] = '\0'; - /* take care of proper string end */ - return Tcl_NewStringObj(linkPtr->lastValue.cPtr, linkPtr->bytes); - } - linkPtr->lastValue.c = '\0'; - return Tcl_NewStringObj(&linkPtr->lastValue.c, 1); - - case TCL_LINK_BINARY: - if (linkPtr->flags & LINK_ALLOC_LAST) { - memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - return Tcl_NewByteArrayObj((unsigned char *) linkPtr->addr, - linkPtr->bytes); - } - linkPtr->lastValue.uc = LinkedVar(unsigned char); - return Tcl_NewByteArrayObj(&linkPtr->lastValue.uc, 1); - /* * This code only gets executed if the link type is unknown (shouldn't * ever happen). */ @@ -1499,45 +691,104 @@ default: TclNewLiteralStringObj(resultObj, "??"); return resultObj; } } - + +static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); + +static Tcl_ObjType invalidRealType = { + "invalidReal", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + SetInvalidRealFromAny /* setFromAnyProc */ +}; + +static int +SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) { + int length; + const char *str; + const char *endPtr; + + str = TclGetStringFromObj(objPtr, &length); + if ((length == 1) && (str[0] == '.')){ + objPtr->typePtr = &invalidRealType; + objPtr->internalRep.doubleValue = 0.0; + return TCL_OK; + } + if (TclParseNumber(NULL, objPtr, NULL, str, length, &endPtr, + TCL_PARSE_DECIMAL_ONLY) == TCL_OK) { + /* 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; + if (*endPtr == 0) { + double doubleValue = 0.0; + Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue); + if (objPtr->typePtr->freeIntRepProc) objPtr->typePtr->freeIntRepProc(objPtr); + objPtr->typePtr = &invalidRealType; + objPtr->internalRep.doubleValue = doubleValue; + return TCL_OK; + } + } + } + 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" and "0o" + * (upperand lowercase). See bug [39f6304c2e]. + */ +int +GetInvalidIntFromObj(Tcl_Obj *objPtr, + int *intPtr) +{ + int length; + const char *str = TclGetStringFromObj(objPtr, &length); + + if ((length == 1) && strchr("+-", str[0])) { + *intPtr = (str[0] == '+'); + return TCL_OK; + } else if ((length == 0) || + ((length == 2) && (str[0] == '0') && strchr("xXbBoO", str[1]))) { + *intPtr = 0; + return TCL_OK; + } + return TCL_ERROR; +} + /* - *---------------------------------------------------------------------- - * - * LinkFree -- - * - * Free's allocated space of given link and link structure. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- + * 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 void -LinkFree( - Link *linkPtr) /* Structure describing linked variable. */ -{ - if (linkPtr->nsPtr) { - TclNsDecrRefCount(linkPtr->nsPtr); - } - if (linkPtr->flags & LINK_ALLOC_ADDR) { - Tcl_Free(linkPtr->addr); - } - if (linkPtr->flags & LINK_ALLOC_LAST) { - Tcl_Free(linkPtr->lastValue.aryPtr); - } - Tcl_Free(linkPtr); +int +GetInvalidDoubleFromObj(Tcl_Obj *objPtr, + double *doublePtr) +{ + int intValue, result; + + if ((objPtr->typePtr == &invalidRealType) || + (SetInvalidRealFromAny(NULL, objPtr) == TCL_OK)) { + *doublePtr = objPtr->internalRep.doubleValue; + return TCL_OK; + } + result = GetInvalidIntFromObj(objPtr, &intValue); + if (result == TCL_OK) { + *doublePtr = (double) intValue; + } + return result; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclListObj.c ================================================================== --- generic/tclListObj.c +++ generic/tclListObj.c @@ -10,19 +10,18 @@ * 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 /* * Prototypes for functions defined later in this file: */ static List * AttemptNewList(Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static List * NewListIntRep(int objc, Tcl_Obj *const objv[], int p); + Tcl_Obj *CONST objv[]); +static List * NewListIntRep(int objc, Tcl_Obj *CONST objv[], int p); static void DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void FreeListInternalRep(Tcl_Obj *listPtr); static int SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfList(Tcl_Obj *listPtr); @@ -37,72 +36,45 @@ * The second pointer is normally NULL; during execution of functions in this * file that operate on nested sublists, it is occasionally used as working * storage to avoid an auxiliary stack. */ -const Tcl_ObjType tclListType = { +Tcl_ObjType tclListType = { "list", /* name */ FreeListInternalRep, /* freeIntRepProc */ DupListInternalRep, /* dupIntRepProc */ UpdateStringOfList, /* updateStringProc */ SetListFromAny /* setFromAnyProc */ }; - -/* Macros to manipulate the List internal rep */ - -#define ListSetIntRep(objPtr, listRepPtr) \ - do { \ - Tcl_ObjIntRep ir; \ - ir.twoPtrValue.ptr1 = (listRepPtr); \ - ir.twoPtrValue.ptr2 = NULL; \ - (listRepPtr)->refCount++; \ - 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' structure with space for 'objc' elements. 'objc' must - * be > 0. If 'objv' is not NULL, The list is initialized with first - * 'objc' values in that array. Otherwise the list is initialized to have - * 0 elements, with space to add 'objc' more. Flag value 'p' indicates + * 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. * - * Value - * - * A new 'List' structure with refCount 0. If some failure - * prevents this NULL is returned if 'p' is 0 , and 'Tcl_Panic' - * is called if it is not. - * - * Effect - * - * The refCount of each value in 'objv' is incremented as it is added - * to the list. + * 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, - Tcl_Obj *const objv[], + Tcl_Obj *CONST objv[], int p) { List *listRepPtr; if (objc <= 0) { @@ -122,15 +94,16 @@ LIST_MAX); } return NULL; } - listRepPtr = (List *)Tcl_AttemptAlloc(LIST_SIZE(objc)); + listRepPtr = (List *) + attemptckalloc(sizeof(List) + ((objc-1) * sizeof(Tcl_Obj *))); if (listRepPtr == NULL) { if (p) { - Tcl_Panic("list creation failed: unable to alloc %" TCL_Z_MODIFIER "u bytes", - LIST_SIZE(objc)); + Tcl_Panic("list creation failed: unable to alloc %u bytes", + (unsigned)(sizeof(List) + ((objc-1) * sizeof(Tcl_Obj *)))); } return NULL; } listRepPtr->canonicalFlag = 0; @@ -154,22 +127,34 @@ } /* *---------------------------------------------------------------------- * - * AttemptNewList -- + * AttemptNewList -- * - * Like NewListIntRep, but additionally sets an error message on failure. + * 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[]) + Tcl_Obj *CONST objv[]) { List *listRepPtr = NewListIntRep(objc, objv, 0); if (interp != NULL && listRepPtr == NULL) { if (objc > LIST_MAX) { @@ -176,37 +161,39 @@ 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 %" TCL_Z_MODIFIER "u bytes", - LIST_SIZE(objc))); + "list creation failed: unable to alloc %u bytes", + (unsigned)(sizeof(List) + ((objc-1) * sizeof(Tcl_Obj *))))); } - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } return listRepPtr; } /* *---------------------------------------------------------------------- * * Tcl_NewListObj -- * - * Creates a new list object and adds values to it. When TCL_MEM_DEBUG is - * defined, 'Tcl_DbNewListObj' is called instead. - * - * Value - * - * A new list 'Tcl_Obj' to which is appended values from 'objv', or if - * 'objc' is less than or equal to zero, a list 'Tcl_Obj' having no - * elements. The string representation of the new 'Tcl_Obj' is set to - * NULL. The refCount of the list is 0. - * - * Effect - * - * The refCount of each elements in 'objv' is incremented as it is added - * to the list. + * 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 @@ -213,21 +200,21 @@ #undef Tcl_NewListObj Tcl_Obj * Tcl_NewListObj( int objc, /* Count of objects referenced by objv. */ - Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */ + Tcl_Obj *CONST objv[]) /* An array of pointers to Tcl objects. */ { return Tcl_DbNewListObj(objc, objv, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewListObj( int objc, /* Count of objects referenced by objv. */ - Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */ + Tcl_Obj *CONST objv[]) /* An array of pointers to Tcl objects. */ { List *listRepPtr; Tcl_Obj *listPtr; TclNewObj(listPtr); @@ -253,29 +240,43 @@ #endif /* if TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * - * Tcl_DbNewListObj -- - * - * Like 'Tcl_NewListObj', but it calls Tcl_DbCkalloc directly with the - * file name and line number from its caller. This simplifies debugging - * since 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, 'Tcl_NewListObj' is called instead. + * 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 * Tcl_DbNewListObj( int objc, /* Count of objects referenced by objv. */ - Tcl_Obj *const objv[], /* An array of pointers to Tcl objects. */ - const char *file, /* The name of the source file calling this + Tcl_Obj *CONST objv[], /* An array of pointers to Tcl objects. */ + 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 *listPtr; @@ -306,13 +307,15 @@ #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*/) + Tcl_Obj *CONST objv[], /* An array of pointers to Tcl objects. */ + 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. */ { return Tcl_NewListObj(objc, objv); } #endif /* TCL_MEM_DEBUG */ @@ -319,21 +322,32 @@ /* *---------------------------------------------------------------------- * * Tcl_SetListObj -- * - * Like 'Tcl_NewListObj', but operates on an existing 'Tcl_Obj'instead of - * creating a new one. + * 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. */ int objc, /* Count of objects referenced by objv. */ - Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */ + Tcl_Obj *CONST objv[]) /* An array of pointers to Tcl objects. */ { List *listRepPtr; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetListObj"); @@ -342,10 +356,11 @@ /* * Free any old string rep and any internal rep for the old type. */ TclFreeIntRep(objPtr); + objPtr->typePtr = NULL; TclInvalidateStringRep(objPtr); /* * Set the object's type to "list" and initialize the internal rep. * However, if there are no elements to put in the list, just give the @@ -354,33 +369,32 @@ if (objc > 0) { listRepPtr = NewListIntRep(objc, objv, 1); ListSetIntRep(objPtr, listRepPtr); } else { - Tcl_InitStringRep(objPtr, NULL, 0); + objPtr->bytes = tclEmptyStringRep; + objPtr->length = 0; } } /* *---------------------------------------------------------------------- * * TclListObjCopy -- * - * Creates a new 'Tcl_Obj' which is a pure 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. - * - * Value - * - * The address of the new 'Tcl_Obj' which shares its internal - * representation with 'listPtr', and whose refCount is 0. If 'listPtr' - * is not actually a list, the value is NULL, and an error message is left - * in 'interp' if it is not NULL. - * - * Effect - * - * 'listPtr' is converted to a list if it isn't one already. + * 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 * @@ -388,14 +402,12 @@ Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *listPtr) /* List object for which an element array is * to be returned. */ { Tcl_Obj *copyPtr; - List *listRepPtr; - ListGetIntRep(listPtr, listRepPtr); - if (NULL == listRepPtr) { + if (listPtr->typePtr != &tclListType) { if (SetListFromAny(interp, listPtr) != TCL_OK) { return NULL; } } @@ -406,154 +418,63 @@ } /* *---------------------------------------------------------------------- * - * TclListObjRange -- + * Tcl_ListObjGetElements -- * - * Makes a slice of a list value. - * *listPtr must be known to be a valid list. + * This function returns an (objc,objv) array of the elements in a list + * object. * * Results: - * Returns a pointer to the sliced list. - * This may be a new object or the same object if not shared. + * 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. * *---------------------------------------------------------------------- */ -Tcl_Obj * -TclListObjRange( - Tcl_Obj *listPtr, /* List object to take a range from. */ - size_t fromIdx, /* Index of first element to include. */ - size_t toIdx) /* Index of last element to include. */ -{ - Tcl_Obj **elemPtrs; - int listLen; - size_t i, newLen; - List *listRepPtr; - - TclListObjGetElements(NULL, listPtr, &listLen, &elemPtrs); - - if (fromIdx == TCL_INDEX_NONE) { - fromIdx = 0; - } - if (toIdx + 1 >= (size_t)listLen + 1) { - toIdx = listLen-1; - } - if (fromIdx + 1 > toIdx + 1) { - Tcl_Obj *obj; - TclNewObj(obj); - return obj; - } - - newLen = toIdx - fromIdx + 1; - - if (Tcl_IsShared(listPtr) || - ((ListRepPtr(listPtr)->refCount > 1))) { - return Tcl_NewListObj(newLen, &elemPtrs[fromIdx]); - } - - /* - * In-place is possible. - */ - - /* - * Even if nothing below cause any changes, we still want the - * string-canonizing effect of [lrange 0 end]. - */ - - TclInvalidateStringRep(listPtr); - - /* - * Delete elements that should not be included. - */ - - for (i = 0; i < fromIdx; i++) { - TclDecrRefCount(elemPtrs[i]); - } - for (i = toIdx + 1; i < (size_t)listLen; i++) { - TclDecrRefCount(elemPtrs[i]); - } - - if (fromIdx > 0) { - memmove(elemPtrs, &elemPtrs[fromIdx], - (size_t) newLen * sizeof(Tcl_Obj*)); - } - - listRepPtr = ListRepPtr(listPtr); - listRepPtr->elemCount = newLen; - - return listPtr; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ListObjGetElements -- - * - * Retreive the elements in a list 'Tcl_Obj'. - * - * Value - * - * TCL_OK - * - * A count of list elements is stored, 'objcPtr', And a pointer to the - * array of elements in the list is stored in 'objvPtr'. - * - * The elements accessible via 'objvPtr' should be treated as readonly - * and the refCount for each object is _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. - * - * TCL_ERROR - * - * 'listPtr' is not a valid list. An error message is left in the - * interpreter's result if 'interp' is not NULL. - * - * Effect - * - * 'listPtr' is converted to a list object if it isn't one already. - * - *---------------------------------------------------------------------- - */ - int Tcl_ListObjGetElements( Tcl_Interp *interp, /* Used to report errors if not NULL. */ - Tcl_Obj *listPtr, /* List object for which an element array is + register 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; + register List *listRepPtr; - ListGetIntRep(listPtr, listRepPtr); - - if (listRepPtr == NULL) { + if (listPtr->typePtr != &tclListType) { int result; - size_t length; - (void) TclGetStringFromObj(listPtr, &length); - if (length == 0) { + if (listPtr->bytes == tclEmptyStringRep) { *objcPtr = 0; *objvPtr = NULL; return TCL_OK; } result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } - ListGetIntRep(listPtr, listRepPtr); } + listRepPtr = ListRepPtr(listPtr); *objcPtr = listRepPtr->elemCount; *objvPtr = &listRepPtr->elements; return TCL_OK; } @@ -560,90 +481,85 @@ /* *---------------------------------------------------------------------- * * Tcl_ListObjAppendList -- * - * Appends the elements of elemListPtr to those of listPtr. - * - * Value - * - * TCL_OK - * - * Success. - * - * TCL_ERROR - * - * 'listPtr' or 'elemListPtr' are not valid lists. An error - * message is left in the interpreter's result if 'interp' is not NULL. - * - * Effect - * - * The reference count of each element of 'elemListPtr' as it is added to - * 'listPtr'. 'listPtr' and 'elemListPtr' are converted to 'tclListType' - * if they are not already. Appending the new elements may cause the - * array of element pointers in 'listObj' to grow. If any objects are - * appended to 'listPtr'. Any preexisting string representation of - * 'listPtr' is invalidated. + * This function appends the objects in the list referenced by + * elemListPtr 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. If listPtr or elemListPtr do not + * refer to list objects and they can not 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: + * 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. */ + register Tcl_Obj *listPtr, /* List object to append elements to. */ Tcl_Obj *elemListPtr) /* List obj with elements to append. */ { - int objc; + int listLen, objc, result; Tcl_Obj **objv; if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendList"); } - /* - * Pull the elements to append from elemListPtr. - */ + result = TclListObjLength(interp, listPtr, &listLen); + if (result != TCL_OK) { + return result; + } - if (TCL_OK != TclListObjGetElements(interp, elemListPtr, &objc, &objv)) { - return TCL_ERROR; + result = TclListObjGetElements(interp, elemListPtr, &objc, &objv); + if (result != TCL_OK) { + return result; } /* - * Insert the new elements starting after the lists's last element. + * Insert objc new elements starting after the lists's last element. * Delete zero existing elements. */ - return Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0, objc, objv); + return Tcl_ListObjReplace(interp, listPtr, listLen, 0, objc, objv); } /* *---------------------------------------------------------------------- * * Tcl_ListObjAppendElement -- * - * Like 'Tcl_ListObjAppendList', but Appends a single value to a list. - * - * Value - * - * TCL_OK - * - * 'objPtr' is appended to the elements of 'listPtr'. - * - * TCL_ERROR - * - * listPtr does not refer to a list object and the object can not be - * converted to one. An error message will be left in the - * interpreter's result if interp is not NULL. - * - * Effect - * - * If 'listPtr' is not already of type 'tclListType', it is converted. - * The 'refCount' of 'objPtr' is incremented as it is added to 'listPtr'. - * Appending the new element may cause the the array of element pointers - * in 'listObj' to grow. Any preexisting string representation of - * 'listPtr' is invalidated. + * 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 @@ -650,141 +566,79 @@ 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; + register List *listRepPtr; + register Tcl_Obj **elemPtrs; + int numElems, numRequired, newMax, newSize, i; if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement"); } - - ListGetIntRep(listPtr, listRepPtr); - if (listRepPtr == NULL) { + if (listPtr->typePtr != &tclListType) { int result; - size_t length; - (void) TclGetStringFromObj(listPtr, &length); - if (length == 0) { + if (listPtr->bytes == tclEmptyStringRep) { Tcl_SetListObj(listPtr, 1, &objPtr); return TCL_OK; } result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } - ListGetIntRep(listPtr, listRepPtr); } + listRepPtr = ListRepPtr(listPtr); numElems = listRepPtr->elemCount; numRequired = numElems + 1 ; - needGrow = (numRequired > listRepPtr->maxElemCount); - isShared = (listRepPtr->refCount > 1); - - if (numRequired > LIST_MAX) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "max length of a Tcl list (%d elements) exceeded", - LIST_MAX)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } - return TCL_ERROR; - } - - if (needGrow && !isShared) { - /* - * Need to grow + unshared intrep => try to realloc - */ - - attempt = 2 * numRequired; - if (attempt <= LIST_MAX) { - newPtr = (List *)Tcl_AttemptRealloc(listRepPtr, LIST_SIZE(attempt)); - } - if (newPtr == NULL) { - attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH; - if (attempt > LIST_MAX) { - attempt = LIST_MAX; - } - newPtr = (List *)Tcl_AttemptRealloc(listRepPtr, LIST_SIZE(attempt)); - } - if (newPtr == NULL) { - attempt = numRequired; - newPtr = (List *)Tcl_AttemptRealloc(listRepPtr, LIST_SIZE(attempt)); - } - if (newPtr) { - listRepPtr = newPtr; - listRepPtr->maxElemCount = attempt; - needGrow = 0; - } - } - if (isShared || needGrow) { - Tcl_Obj **dst, **src = &listRepPtr->elements; - - /* - * Either we have a shared intrep and we must copy to write, or we - * need to grow and realloc attempts failed. Attempt intrep copy. - */ - - attempt = 2 * numRequired; - newPtr = AttemptNewList(NULL, attempt, NULL); - if (newPtr == NULL) { - attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH; - if (attempt > LIST_MAX) { - attempt = LIST_MAX; - } - newPtr = AttemptNewList(NULL, attempt, NULL); - } - if (newPtr == NULL) { - attempt = numRequired; - newPtr = AttemptNewList(interp, attempt, NULL); - } - if (newPtr == NULL) { - /* - * All growth attempts failed; throw the error. - */ - - return TCL_ERROR; - } - - dst = &newPtr->elements; - newPtr->refCount++; - newPtr->canonicalFlag = listRepPtr->canonicalFlag; - newPtr->elemCount = listRepPtr->elemCount; - - if (isShared) { - /* - * The original intrep must remain undisturbed. Copy into the new - * one and bump refcounts - */ - while (numElems--) { - *dst = *src++; - Tcl_IncrRefCount(*dst++); - } - listRepPtr->refCount--; - } else { - /* - * Old intrep to be freed, re-use refCounts. - */ - - memcpy(dst, src, numElems * sizeof(Tcl_Obj *)); - Tcl_Free(listRepPtr); - } - listRepPtr = newPtr; - } - ListResetIntRep(listPtr, listRepPtr); - listRepPtr->refCount++; - TclFreeIntRep(listPtr); - ListSetIntRep(listPtr, listRepPtr); - listRepPtr->refCount--; + + /* + * If there is no room in the current array of element pointers, allocate + * a new, larger array and copy the pointers to it. If the List struct is + * shared, allocate a new one. + */ + + if (numRequired > listRepPtr->maxElemCount){ + newMax = 2 * numRequired; + newSize = sizeof(List) + ((newMax-1) * sizeof(Tcl_Obj *)); + } else { + newMax = listRepPtr->maxElemCount; + newSize = 0; + } + + if (listRepPtr->refCount > 1) { + List *oldListRepPtr = listRepPtr; + Tcl_Obj **oldElems; + + listRepPtr = AttemptNewList(interp, newMax, NULL); + if (listRepPtr == NULL) { + return TCL_ERROR; + } + oldElems = &oldListRepPtr->elements; + elemPtrs = &listRepPtr->elements; + for (i=0; ielemCount = numElems; + listRepPtr->refCount++; + oldListRepPtr->refCount--; + listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; + } else if (newSize) { + listRepPtr = (List *) ckrealloc((char *)listRepPtr, (size_t)newSize); + listRepPtr->maxElemCount = newMax; + listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; + } /* * Add objPtr to the end of listPtr's array of element pointers. Increment * the ref count for the (now shared) objPtr. */ - *(&listRepPtr->elements + listRepPtr->elemCount) = objPtr; + elemPtrs = &listRepPtr->elements; + elemPtrs[numElems] = objPtr; Tcl_IncrRefCount(objPtr); listRepPtr->elemCount++; /* * Invalidate any old string representation since the list's internal @@ -798,61 +652,54 @@ /* *---------------------------------------------------------------------- * * Tcl_ListObjIndex -- * - * Retrieve a pointer to the element of 'listPtr' at 'index'. The index - * of the first element is 0. - * - * Value - * - * TCL_OK - * - * A pointer to the element at 'index' is stored in 'objPtrPtr'. If - * 'index' is out of range, NULL is stored in 'objPtrPtr'. This - * object should be treated as readonly and its 'refCount' is _not_ - * incremented. The caller must do that if it holds on to the - * reference. - * - * TCL_ERROR - * - * 'listPtr' is not a valid list. An an error message is left in the - * interpreter's result if 'interp' is not NULL. - * - * Effect - * - * If 'listPtr' is not already of type 'tclListType', it is converted. + * 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. */ + register Tcl_Obj *listPtr, /* List object to index into. */ + register int index, /* Index of element to return. */ Tcl_Obj **objPtrPtr) /* The resulting Tcl_Obj* is stored here. */ { - List *listRepPtr; + register List *listRepPtr; - ListGetIntRep(listPtr, listRepPtr); - if (listRepPtr == NULL) { + if (listPtr->typePtr != &tclListType) { int result; - size_t length; - (void) TclGetStringFromObj(listPtr, &length); - if (length == 0) { + if (listPtr->bytes == tclEmptyStringRep) { *objPtrPtr = NULL; return TCL_OK; } result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } - ListGetIntRep(listPtr, listRepPtr); } + listRepPtr = ListRepPtr(listPtr); if ((index < 0) || (index >= listRepPtr->elemCount)) { *objPtrPtr = NULL; } else { *objPtrPtr = (&listRepPtr->elements)[index]; } @@ -863,92 +710,87 @@ /* *---------------------------------------------------------------------- * * Tcl_ListObjLength -- * - * Retrieve the number of elements in a list. - * - * Value - * - * TCL_OK - * - * A count of list elements is stored at the address provided by - * 'intPtr'. If 'listPtr' is not already of type 'tclListPtr', it is - * converted. - * - * TCL_ERROR - * - * 'listPtr' is not a valid list. An error message will be left in - * the interpreter's result if 'interp' is not NULL. + * 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. */ + register Tcl_Obj *listPtr, /* List object whose #elements to return. */ + register int *intPtr) /* The resulting int is stored here. */ { - List *listRepPtr; + register List *listRepPtr; - ListGetIntRep(listPtr, listRepPtr); - if (listRepPtr == NULL) { + if (listPtr->typePtr != &tclListType) { int result; - size_t length; - (void) TclGetStringFromObj(listPtr, &length); - if (length == 0) { + if (listPtr->bytes == tclEmptyStringRep) { *intPtr = 0; return TCL_OK; } result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } - ListGetIntRep(listPtr, listRepPtr); } + listRepPtr = ListRepPtr(listPtr); *intPtr = listRepPtr->elemCount; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ListObjReplace -- * - * Replace values in a list. - * - * If 'first' is zero or negative, it refers to the first element. If - * 'first' outside the range of elements in the list, no elements are - * deleted. - * - * If 'count' is zero or negative no elements are deleted, and any new - * elements are inserted at the beginning of the list. - * - * Value - * - * TCL_OK - * - * The first 'objc' values of 'objv' replaced 'count' elements in 'listPtr' - * starting at 'first'. If 'objc' 0, no new elements are added. - * - * TCL_ERROR - * - * 'listPtr' is not a valid list. An error message is left in the - * interpreter's result if 'interp' is not NULL. - * - * Effect - * - * If 'listPtr' is not of type 'tclListType', it is converted if possible. - * - * The 'refCount' of each element appended to the list is incremented. - * Similarly, the 'refCount' for each replaced element is decremented. - * - * If 'listPtr' is modified, any previous string representation is - * invalidated. + * 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 @@ -956,39 +798,34 @@ 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 + 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; + register Tcl_Obj **elemPtrs; + int 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) { - size_t length; - - (void) TclGetStringFromObj(listPtr, &length); - if (length == 0) { - if (objc == 0) { + if (listPtr->typePtr != &tclListType) { + if (listPtr->bytes == tclEmptyStringRep) { + if (objc) { + Tcl_SetListObj(listPtr, objc, NULL); + } else { return TCL_OK; } - Tcl_SetListObj(listPtr, objc, NULL); } else { int result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } } - ListGetIntRep(listPtr, listRepPtr); } /* * Note that when count == 0 and objc == 0, this routine is logically a * no-op, removing and adding no elements to the list. However, by flowing @@ -995,10 +832,11 @@ * through this routine anyway, we get the important side effect that the * resulting listPtr is a list in canoncial form. This is important. * Resist any temptation to optimize this case. */ + listRepPtr = ListRepPtr(listPtr); elemPtrs = &listRepPtr->elements; numElems = listRepPtr->elemCount; if (first < 0) { first = 0; @@ -1008,11 +846,10 @@ } if (count < 0) { count = 0; } else if (first > INT_MAX - count /* Handle integer overflow */ || numElems < first+count) { - count = numElems - first; } if (objc > LIST_MAX - (numElems - count)) { if (interp != NULL) { @@ -1022,43 +859,16 @@ } return TCL_ERROR; } isShared = (listRepPtr->refCount > 1); numRequired = numElems - count + objc; /* Known <= LIST_MAX */ - needGrow = numRequired > listRepPtr->maxElemCount; for (i = 0; i < objc; i++) { Tcl_IncrRefCount(objv[i]); } - if (needGrow && !isShared) { - /* Try to use realloc */ - List *newPtr = NULL; - int attempt = 2 * numRequired; - if (attempt <= LIST_MAX) { - newPtr = (List *)Tcl_AttemptRealloc(listRepPtr, LIST_SIZE(attempt)); - } - if (newPtr == NULL) { - attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH; - if (attempt > LIST_MAX) { - attempt = LIST_MAX; - } - newPtr = (List *)Tcl_AttemptRealloc(listRepPtr, LIST_SIZE(attempt)); - } - if (newPtr == NULL) { - attempt = numRequired; - newPtr = (List *)Tcl_AttemptRealloc(listRepPtr, LIST_SIZE(attempt)); - } - if (newPtr) { - listRepPtr = newPtr; - ListResetIntRep(listPtr, listRepPtr); - elemPtrs = &listRepPtr->elements; - listRepPtr->maxElemCount = attempt; - needGrow = numRequired > listRepPtr->maxElemCount; - } - } - if (!needGrow && !isShared) { + if ((numRequired <= listRepPtr->maxElemCount) && !isShared) { int shift; /* * Can use the current List struct. First "delete" count elements * starting at first. @@ -1079,11 +889,11 @@ numAfterLast = numElems - start; shift = objc - count; /* numNewElems - numDeleted */ if ((numAfterLast > 0) && (shift != 0)) { Tcl_Obj **src = elemPtrs + start; - memmove(src+shift, src, numAfterLast * sizeof(Tcl_Obj*)); + 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. @@ -1091,37 +901,33 @@ List *oldListRepPtr = listRepPtr; Tcl_Obj **oldPtrs = elemPtrs; int newMax; - if (needGrow) { + if (numRequired > listRepPtr->maxElemCount){ newMax = 2 * numRequired; } else { newMax = listRepPtr->maxElemCount; } - listRepPtr = AttemptNewList(NULL, newMax, NULL); - if (listRepPtr == NULL) { - unsigned int limit = LIST_MAX - numRequired; - unsigned int extra = numRequired - numElems - + TCL_MIN_ELEMENT_GROWTH; - int growth = (int) ((extra > limit) ? limit : extra); - - 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); + listRepPtr = AttemptNewList(interp, newMax, 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; + } + } + + listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; listRepPtr->refCount++; elemPtrs = &listRepPtr->elements; if (isShared) { @@ -1146,11 +952,11 @@ /* * The old struct will be removed; use its inherited refCounts. */ if (first > 0) { - memcpy(elemPtrs, oldPtrs, first * sizeof(Tcl_Obj *)); + memcpy(elemPtrs, oldPtrs, (size_t) first * sizeof(Tcl_Obj *)); } /* * "Delete" count elements starting at first. */ @@ -1171,11 +977,11 @@ if (numAfterLast > 0) { memcpy(elemPtrs + first + objc, oldPtrs + start, (size_t) numAfterLast * sizeof(Tcl_Obj *)); } - Tcl_Free(oldListRepPtr); + ckfree((char *) oldListRepPtr); } } /* * Insert the new elements into elemPtrs before "first". @@ -1190,41 +996,39 @@ */ listRepPtr->elemCount = numRequired; /* - * Invalidate and free any old representations that may not agree - * with the revised list's internal representation. + * Invalidate and free any old string representation since it no longer + * reflects the list's internal representation. */ - listRepPtr->refCount++; - TclFreeIntRep(listPtr); - ListSetIntRep(listPtr, listRepPtr); - listRepPtr->refCount--; - TclInvalidateStringRep(listPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclLindexList -- * - * Implements the 'lindex' command when objc==3. - * - * Implemented entirely as a wrapper around 'TclLindexFlat'. Reconfigures - * the argument format into required form while taking care to manage - * shimmering so as to tend to keep the most useful intreps - * and/or avoid the most expensive conversions. - * - * Value - * - * A pointer to the specified element, with its 'refCount' incremented, or - * NULL if an error occurred. - * - * Notes + * 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 * @@ -1232,23 +1036,23 @@ Tcl_Interp *interp, /* Tcl interpreter. */ Tcl_Obj *listPtr, /* List being unpacked. */ Tcl_Obj *argPtr) /* Index or index list. */ { - size_t index; /* Index into the list. */ + int index; /* Index into the list. */ + Tcl_Obj **indices = NULL; /* Array of list indices. */ + int indexCount = -1; /* Size of the array of list indices. */ 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, (size_t)WIDE_MAX - 1, &index) == TCL_OK) { + if (argPtr->typePtr != &tclListType + && TclGetIntForIndexM(NULL , argPtr, 0, &index) == TCL_OK) { /* * argPtr designates a single index. */ return TclLindexFlat(interp, listPtr, 1, &argPtr); @@ -1274,37 +1078,38 @@ */ return TclLindexFlat(interp, listPtr, 1, &argPtr); } - ListGetIntRep(indexListCopy, listRepPtr); - - assert(listRepPtr != NULL); - - listPtr = TclLindexFlat(interp, listPtr, listRepPtr->elemCount, - &listRepPtr->elements); + TclListObjGetElements(NULL, indexListCopy, &indexCount, &indices); + listPtr = TclLindexFlat(interp, listPtr, indexCount, indices); Tcl_DecrRefCount(indexListCopy); return listPtr; } /* *---------------------------------------------------------------------- * - * TclLindexFlat -- - * - * The core of the 'lindex' command, with all index - * arguments presented as a flat list. - * - * Value - * - * A pointer to the object extracted, with its 'refCount' incremented, or - * NULL if an error occurred. Thus, the calling code will usually do - * something like: - * - * Tcl_SetObjResult(interp, result); - * Tcl_DecrRefCount(result); - * + * 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 * @@ -1318,12 +1123,11 @@ int i; Tcl_IncrRefCount(listPtr); for (i=0 ; i= (size_t)listLen) { + 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], (size_t)WIDE_MAX - 1, &index) + if (TclGetIntForIndexM(interp, indexArray[i], -1, &index) != TCL_OK) { Tcl_DecrRefCount(sublistCopy); return NULL; } } - TclNewObj(listPtr); + listPtr = Tcl_NewObj(); } else { /* * Extract the pointer to the appropriate element. */ @@ -1377,48 +1181,52 @@ /* *---------------------------------------------------------------------- * * TclLsetList -- * - * The core of [lset] when objc == 4. Objv[2] may be either a + * 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. - * - * Implemented entirely as a wrapper around 'TclLindexFlat', as described - * for 'TclLindexList'. - * - * Value - * - * The new list, with the 'refCount' of 'valuPtr' incremented, or NULL if - * there was an error. + * + * 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'. */ + Tcl_Obj *valuePtr) /* Value arg to 'lset'. */ { 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. */ - size_t index; /* Current index in the list - discarded. */ + 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, (size_t)WIDE_MAX - 1, &index) == TCL_OK) { + if (indexArgPtr->typePtr != &tclListType + && TclGetIntForIndexM(NULL, indexArgPtr, 0, &index) == TCL_OK) { /* * indexArgPtr designates a single index. */ return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr); @@ -1450,45 +1258,41 @@ *---------------------------------------------------------------------- * * TclLsetFlat -- * * Core engine of the 'lset' command. - * It also handles 'lpop' when given a NULL value. - * - * Value - * - * The resulting list - * - * The 'refCount' of 'valuePtr' is incremented. If 'listPtr' was not - * duplicated, its 'refCount' is incremented. The reference count of - * an unduplicated object is therefore 2 (one for the returned pointer - * and one for the variable that holds it). The reference count of a - * duplicate object is 1, reflecting that result is the only active - * reference. The caller is expected to store the result in the - * variable and decrement its reference count. (INST_STORE_* does - * exactly this.) - * - * NULL - * - * An error occurred. If 'listPtr' was duplicated, the reference - * count on the duplicate is decremented so that it is 0, causing any - * memory allocated by this function to be freed. - * - * - * Effect - * - * On entry, the reference count of 'listPtr' does not reflect any - * references held on the stack. The first action of this function is to - * determine whether 'listPtr' is shared and to create a duplicate - * unshared copy if it is. The reference count of the duplicate is - * incremented. At this point, the reference count is 1 in either case so - * that the object is considered unshared. - * - * The unshared list is altered directly to produce the result. - * 'TclLsetFlat' maintains a linked list of 'Tcl_Obj' values whose string + * + * 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 + * 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. * *---------------------------------------------------------------------- */ @@ -1498,39 +1302,34 @@ 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'. */ + Tcl_Obj *valuePtr) /* Value arg to 'lset'. */ { - size_t index; - int result, len; + int index, result; 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. + * If there are no indices, simply return the new value. + * (Without indices, [lset] is a synonym for [set]. */ if (indexCount == 0) { - if (valuePtr != NULL) { - Tcl_IncrRefCount(valuePtr); - } + Tcl_IncrRefCount(valuePtr); return valuePtr; } /* - * If the list is shared, make a copy we can modify (copy-on-write). We - * use Tcl_DuplicateObj() instead of TclListObjCopy() for a few reasons: - * 1) we have not yet confirmed listPtr is actually a list; 2) We make a - * verbatim copy of any existing string rep, and when we combine that with - * the delayed invalidation of string reps of modified Tcl_Obj's - * implemented below, the outcome is that any error condition that causes - * this routine to return NULL, will leave the string rep of listPtr and - * all elements to be unchanged. + * If the list is shared, make a copy we can modify (copy-on-write). + * We use Tcl_DuplicateObj() instead of TclListObjCopy() for a few + * reasons: 1) we have not yet confirmed listPtr is actually a list; + * 2) We make a verbatim copy of any existing string rep, and when + * we combine that with the delayed invalidation of string reps of + * modified Tcl_Obj's implemented below, the outcome is that any + * error condition that causes this routine to return NULL, will + * leave the string rep of listPtr and all elements to be unchanged. */ subListPtr = Tcl_IsShared(listPtr) ? Tcl_DuplicateObj(listPtr) : listPtr; /* @@ -1538,222 +1337,167 @@ * invalidated if the operation succeeds. */ retValuePtr = subListPtr; chainPtr = NULL; - result = TCL_OK; /* - * Loop through all the index arguments, and for each one dive into the - * appropriate sublist. + * Loop through all the index arguments, and for each one dive + * into the appropriate sublist. */ do { int elemCount; Tcl_Obj *parentList, **elemPtrs; - /* - * Check for the possible error conditions... - */ - + /* Check for the possible error conditions... */ + result = TCL_ERROR; if (TclListObjGetElements(interp, subListPtr, &elemCount, &elemPtrs) != TCL_OK) { /* ...the sublist we're indexing into isn't a list at all. */ - result = TCL_ERROR; break; } /* * WARNING: the macro TclGetIntForIndexM is not safe for * post-increments, avoid '*indexArray++' here. */ - + if (TclGetIntForIndexM(interp, *indexArray, elemCount - 1, &index) != TCL_OK) { /* ...the index we're trying to use isn't an index at all. */ - result = TCL_ERROR; indexArray++; break; } indexArray++; - if (index > (size_t)elemCount - || (valuePtr == NULL && index >= (size_t)elemCount)) { + if (index < 0 || 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); + Tcl_SetObjResult(interp, + Tcl_NewStringObj("list index out of range", -1)); } - 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. + * 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. */ + result = TCL_OK; if (--indexCount) { parentList = subListPtr; - if (index == (size_t)elemCount) { - TclNewObj(subListPtr); - } else { - subListPtr = elemPtrs[index]; - } + 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. + * subListPtr to become shared again, so detect that case and + * make and store another copy. */ - if (index == (size_t)elemCount) { - Tcl_ListObjAppendElement(NULL, parentList, subListPtr); - } else { - TclListObjSetElement(NULL, parentList, index, subListPtr); - } + TclListObjSetElement(NULL, parentList, index, subListPtr); if (Tcl_IsShared(subListPtr)) { subListPtr = Tcl_DuplicateObj(subListPtr); TclListObjSetElement(NULL, parentList, index, subListPtr); } /* - * The TclListObjSetElement() calls do not spoil the string rep of - * parentList, and that's fine for now, since all we've done so - * far is replace a list element with an unshared copy. The list - * value remains the same, so the string rep. is still valid, and - * unchanged, which is good because if this whole routine returns - * NULL, we'd like to leave no change to the value of the lset - * variable. Later on, when we set valuePtr in its proper place, - * then all containing lists will have their values changed, and - * will need their string reps spoiled. We maintain a list of all - * those Tcl_Obj's (via a little intrep surgery) so we can spoil - * them at that time. + * The TclListObjSetElement() calls do not spoil the string + * rep of parentList, and that's fine for now, since all we've + * done so far is replace a list element with an unshared copy. + * The list value remains the same, so the string rep. is still + * valid, and unchanged, which is good because if this whole + * routine returns NULL, we'd like to leave no change to the + * value of the lset variable. Later on, when we set valuePtr + * in its proper place, then all containing lists will have + * their values changed, and will need their string reps spoiled. + * We maintain a list of all those Tcl_Obj's (via a little intrep + * surgery) so we can spoil them at that time. */ - irPtr = TclFetchIntRep(parentList, &tclListType); - irPtr->twoPtrValue.ptr2 = chainPtr; + parentList->internalRep.twoPtrValue.ptr2 = (void *) chainPtr; chainPtr = parentList; } } while (indexCount > 0); /* - * Either we've detected and error condition, and exited the loop with - * result == TCL_ERROR, or we've successfully reached the last index, and - * we're ready to store valuePtr. In either case, we need to clean up our - * string spoiling list of Tcl_Obj's. + * Either we've detected and error condition, and exited the loop + * with result == TCL_ERROR, or we've successfully reached the last + * index, and we're ready to store valuePtr. In either case, we + * need to clean up our string spoiling list of Tcl_Obj's. */ while (chainPtr) { Tcl_Obj *objPtr = chainPtr; - 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. + * We're going to store valuePtr, so spoil string reps + * of all containing lists. */ - listRepPtr->refCount++; - TclFreeIntRep(objPtr); - ListSetIntRep(objPtr, listRepPtr); - listRepPtr->refCount--; - TclInvalidateStringRep(objPtr); - } else { - irPtr->twoPtrValue.ptr2 = NULL; } + + /* Clear away our intrep surgery mess */ + chainPtr = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; } if (result != TCL_OK) { - /* - * Error return; message is already in interp. Clean up any excess - * memory. + /* + * Error return; message is already in interp. Clean up + * any excess memory. */ - if (retValuePtr != listPtr) { Tcl_DecrRefCount(retValuePtr); } return NULL; } - /* - * Store valuePtr in proper sublist and return. The -1 is to avoid a - * compiler warning (not a problem because we checked that we have a - * proper list - or something convertible to one - above). - */ - - len = -1; - TclListObjLength(NULL, subListPtr, &len); - if (valuePtr == NULL) { - Tcl_ListObjReplace(NULL, subListPtr, index, 1, 0, NULL); - } else if (index == (size_t)len) { - Tcl_ListObjAppendElement(NULL, subListPtr, valuePtr); - } else { - TclListObjSetElement(NULL, subListPtr, index, valuePtr); - TclInvalidateStringRep(subListPtr); - } + /* Store valuePtr in proper sublist and return */ + TclListObjSetElement(NULL, subListPtr, index, valuePtr); + TclInvalidateStringRep(subListPtr); Tcl_IncrRefCount(retValuePtr); return retValuePtr; } /* *---------------------------------------------------------------------- * * TclListObjSetElement -- * - * Set a single element of a list to a specified value. + * 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 'listPtr'. - * - * Value - * - * TCL_OK - * - * Success. - * - * TCL_ERROR - * - * 'listPtr' does not refer to a list object and cannot be converted - * to one. An error message will be left in the interpreter result if - * interp is not NULL. - * - * TCL_ERROR - * - * An index designates an element outside the range [0..listLength-1], - * where 'listLength' is the count of elements in the list object - * designated by 'listPtr'. An error message is left in the - * interpreter result. - * - * Effect - * - * If 'listPtr' designates a shared object, 'Tcl_Panic' is called. If - * 'listPtr' is not already of type 'tclListType', it is converted and the - * internal representation is unshared. The 'refCount' of the element at - * 'index' is decremented and replaced in the list with the 'valuePtr', - * whose 'refCount' in turn is incremented. - * + * representation of the object. * *---------------------------------------------------------------------- */ int @@ -1776,79 +1520,66 @@ */ if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "TclListObjSetElement"); } - - ListGetIntRep(listPtr, listRepPtr); - if (listRepPtr == NULL) { + if (listPtr->typePtr != &tclListType) { int result; - size_t length; - (void) TclGetStringFromObj(listPtr, &length); - if (length == 0) { + if (listPtr->bytes == tclEmptyStringRep) { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "index \"%d\" out of range", index)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", - "OUTOFRANGE", NULL); + Tcl_SetObjResult(interp, + Tcl_NewStringObj("list index out of range", -1)); } return TCL_ERROR; } result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } - ListGetIntRep(listPtr, listRepPtr); } + listRepPtr = ListRepPtr(listPtr); elemCount = listRepPtr->elemCount; + elemPtrs = &listRepPtr->elements; /* * 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); + Tcl_SetObjResult(interp, + Tcl_NewStringObj("list index out of range", -1)); } return TCL_ERROR; } /* * If the internal rep is shared, replace it with an unshared copy. */ if (listRepPtr->refCount > 1) { - Tcl_Obj **dst, **src = &listRepPtr->elements; - List *newPtr = AttemptNewList(NULL, listRepPtr->maxElemCount, NULL); - - if (newPtr == NULL) { - newPtr = AttemptNewList(interp, elemCount, NULL); - if (newPtr == NULL) { - return TCL_ERROR; - } - } - newPtr->refCount++; - newPtr->elemCount = elemCount; - newPtr->canonicalFlag = listRepPtr->canonicalFlag; - - dst = &newPtr->elements; - while (elemCount--) { - *dst = *src++; - Tcl_IncrRefCount(*dst++); - } - - listRepPtr->refCount--; - - listRepPtr = newPtr; - ListResetIntRep(listPtr, listRepPtr); - } - elemPtrs = &listRepPtr->elements; + List *oldListRepPtr = listRepPtr; + Tcl_Obj **oldElemPtrs = elemPtrs; + int i; + + listRepPtr = AttemptNewList(interp, listRepPtr->maxElemCount, NULL); + if (listRepPtr == NULL) { + return TCL_ERROR; + } + listRepPtr->canonicalFlag = oldListRepPtr->canonicalFlag; + elemPtrs = &listRepPtr->elements; + for (i=0; i < elemCount; i++) { + elemPtrs[i] = oldElemPtrs[i]; + Tcl_IncrRefCount(elemPtrs[i]); + } + listRepPtr->refCount++; + listRepPtr->elemCount = elemCount; + listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; + oldListRepPtr->refCount--; + } /* * Add a reference to the new list element. */ @@ -1864,107 +1595,93 @@ * Stash the new object in the list. */ elemPtrs[index] = valuePtr; - /* - * Invalidate outdated intreps. - */ - - ListGetIntRep(listPtr, listRepPtr); - listRepPtr->refCount++; - TclFreeIntRep(listPtr); - ListSetIntRep(listPtr, listRepPtr); - listRepPtr->refCount--; - - TclInvalidateStringRep(listPtr); - return TCL_OK; } /* *---------------------------------------------------------------------- * * FreeListInternalRep -- * - * Deallocate the storage associated with the internal representation of a - * a list object. + * Deallocate the storage associated with a list object's internal + * representation. * - * Effect + * Results: + * None. * - * Frees listPtr's List* internal representation, if no longer shared. - * May decrement the ref counts of element objects, which may free them. + * Side effects: + * Frees listPtr's List* internal representation and sets listPtr's + * internalRep.twoPtrValue.ptr1 to NULL. Decrements the ref counts of all + * element objects, which may free them. * *---------------------------------------------------------------------- */ static void FreeListInternalRep( Tcl_Obj *listPtr) /* List object with internal rep to free. */ { - List *listRepPtr; + List *listRepPtr = ListRepPtr(listPtr); - ListGetIntRep(listPtr, listRepPtr); - assert(listRepPtr != NULL); - - if (listRepPtr->refCount-- <= 1) { + if (--listRepPtr->refCount <= 0) { Tcl_Obj **elemPtrs = &listRepPtr->elements; int i, numElems = listRepPtr->elemCount; for (i = 0; i < numElems; i++) { Tcl_DecrRefCount(elemPtrs[i]); } - Tcl_Free(listRepPtr); + ckfree((char *) listRepPtr); } + + listPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * * DupListInternalRep -- * - * Initialize the internal representation of a list 'Tcl_Obj' to share the + * Initialize the internal representation of a list Tcl_Obj to share the * internal representation of an existing list object. * - * Effect + * Results: + * None. * - * The 'refCount' of the List internal rep is incremented. + * Side effects: + * The reference count of the List internal rep is incremented. * *---------------------------------------------------------------------- */ static void DupListInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - List *listRepPtr; + List *listRepPtr = ListRepPtr(srcPtr); - ListGetIntRep(srcPtr, listRepPtr); - assert(listRepPtr != NULL); ListSetIntRep(copyPtr, listRepPtr); } /* *---------------------------------------------------------------------- * * SetListFromAny -- * - * Convert any object to a list. - * - * Value - * - * TCL_OK - * - * Success. The internal representation of 'objPtr' is set, and the type - * of 'objPtr' is 'tclListType'. - * - * TCL_ERROR - * - * An error occured during conversion. An error message is left in the - * interpreter's result if 'interp' is not NULL. - * + * 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 @@ -1981,11 +1698,11 @@ * more directly. Only do this when there's no existing string rep; if * there is, it is the string rep that's authoritative (because it could * describe duplicate keys). */ - if (!TclHasStringRep(objPtr) && TclHasIntRep(objPtr, &tclDictType)) { + if (objPtr->typePtr == &tclDictType && !objPtr->bytes) { Tcl_Obj *keyPtr, *valuePtr; Tcl_DictSearch search; int done, size; /* @@ -2016,136 +1733,116 @@ Tcl_IncrRefCount(keyPtr); Tcl_IncrRefCount(valuePtr); Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done); } } else { - int estCount; - size_t length; + int estCount, length; const char *limit, *nextElem = TclGetStringFromObj(objPtr, &length); /* * Allocate enough space to hold a (Tcl_Obj *) for each * (possible) list element. */ estCount = TclMaxListLength(nextElem, length, &limit); - estCount += (estCount == 0); /* Smallest list struct holds 1 - * element. */ + estCount += (estCount == 0); /* Smallest List struct holds 1 element. */ listRepPtr = AttemptNewList(interp, estCount, NULL); if (listRepPtr == NULL) { return TCL_ERROR; } elemPtrs = &listRepPtr->elements; - /* - * Each iteration, parse and store a list element. - */ - + /* Each iteration, parse and store a list element */ while (nextElem < limit) { const char *elemStart; - char *check; - size_t elemSize; - int literal; + int elemSize, literal; - if (TCL_OK != TclFindElement(interp, nextElem, limit - nextElem, + if (TCL_OK != TclFindElement(interp, nextElem, (limit - nextElem), &elemStart, &nextElem, &elemSize, &literal)) { - fail: while (--elemPtrs >= &listRepPtr->elements) { Tcl_DecrRefCount(*elemPtrs); } - Tcl_Free(listRepPtr); + ckfree((char *) listRepPtr); return TCL_ERROR; } if (elemStart == limit) { break; } - TclNewObj(*elemPtrs); - TclInvalidateStringRep(*elemPtrs); - check = Tcl_InitStringRep(*elemPtrs, literal ? elemStart : NULL, - elemSize); - if (elemSize && check == NULL) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot construct list, out of memory", -1)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } - goto fail; - } - if (!literal) { - Tcl_InitStringRep(*elemPtrs, NULL, - TclCopyAndCollapse(elemSize, elemStart, check)); + /* TODO: replace panic with error on alloc failure? */ + if (literal) { + TclNewStringObj(*elemPtrs, elemStart, elemSize); + } else { + TclNewObj(*elemPtrs); + (*elemPtrs)->bytes = ckalloc((unsigned) elemSize + 1); + (*elemPtrs)->length = TclCopyAndCollapse(elemSize, elemStart, + (*elemPtrs)->bytes); } Tcl_IncrRefCount(*elemPtrs++);/* Since list now holds ref to it. */ } listRepPtr->elemCount = elemPtrs - &listRepPtr->elements; } /* - * Store the new internalRep. We do this as late + * 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 the old internalRep. + * Tcl_GetStringFromObj, to use that old internalRep. */ + TclFreeIntRep(objPtr); ListSetIntRep(objPtr, listRepPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * UpdateStringOfList -- * - * Update the string representation for a list object. - * - * Any previously-exising string representation is not invalidated, so - * storage is lost if this has not been taken care of. - * - * Effect - * - * The string representation of 'listPtr' is set to the resulting string. - * This string will be empty if the list has no elements. It is assumed - * that the list internal representation is not NULL. + * 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; - size_t length, bytesNeeded = 0; - const char *elem, *start; - char *dst; +# define LOCAL_SIZE 20 + int localFlags[LOCAL_SIZE], *flagPtr = NULL; + List *listRepPtr = ListRepPtr(listPtr); + int numElems = listRepPtr->elemCount; + int i, length, bytesNeeded = 0; + char *elem, *dst; Tcl_Obj **elemPtrs; - List *listRepPtr; - - ListGetIntRep(listPtr, listRepPtr); - - assert(listRepPtr != NULL); - - numElems = listRepPtr->elemCount; /* * Mark the list as being canonical; although it will now have a string * rep, it is one we derived through proper "canonical" quoting and so * it's known to be free from nasties relating to [concat] and [eval]. */ listRepPtr->canonicalFlag = 1; - /* - * Handle empty list case first, so rest of the routine is simpler. - */ + /* Handle empty list case first, so rest of the routine is simpler */ if (numElems == 0) { - Tcl_InitStringRep(listPtr, NULL, 0); + listPtr->bytes = tclEmptyStringRep; + listPtr->length = 0; return; } /* * Pass 1: estimate space, gather flags. @@ -2152,42 +1849,61 @@ */ if (numElems <= LOCAL_SIZE) { flagPtr = localFlags; } else { - /* - * We know numElems <= LIST_MAX, so this is safe. - */ - - flagPtr = (char *)Tcl_Alloc(numElems); + /* We know numElems <= LIST_MAX, so this is safe. */ + flagPtr = (int *) ckalloc((unsigned) numElems * sizeof(int)); } elemPtrs = &listRepPtr->elements; for (i = 0; i < numElems; i++) { - flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0); + 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; + bytesNeeded += numElems; /* * Pass 2: copy into string rep buffer. */ - start = dst = Tcl_InitStringRep(listPtr, NULL, bytesNeeded); - TclOOM(dst, bytesNeeded); + /* + * We used to set the string length here, relying on a presumed + * guarantee that the number of bytes TclScanElement() calls reported + * to be needed was a precise count and not an over-estimate, so long + * as the same flag values were passed to TclConvertElement(). + * + * Then we saw [35a8f1c04a], where a bug in TclScanElement() caused + * that guarantee to fail. Rather than trust there are no more bugs, + * we set the length after the loop based on what was actually written, + * an not on what was predicted. + * + listPtr->length = bytesNeeded - 1; + * + */ + + listPtr->bytes = ckalloc((unsigned) bytesNeeded); + dst = listPtr->bytes; for (i = 0; i < numElems; i++) { - flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0); + flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 ); elem = TclGetStringFromObj(elemPtrs[i], &length); dst += TclConvertElement(elem, length, dst, flagPtr[i]); *dst++ = ' '; } + dst[-1] = '\0'; - /* Set the string length to what was actually written, the safe choice */ - (void) Tcl_InitStringRep(listPtr, NULL, dst - 1 - start); + /* Here is the safe setting of the string length. */ + listPtr->length = dst - 1 - listPtr->bytes; if (flagPtr != localFlags) { - Tcl_Free(flagPtr); + ckfree((char *) flagPtr); } } /* * Local Variables: Index: generic/tclLiteral.c ================================================================== --- generic/tclLiteral.c +++ generic/tclLiteral.c @@ -29,11 +29,11 @@ */ static int AddLocalLiteralEntry(CompileEnv *envPtr, Tcl_Obj *objPtr, int localHash); static void ExpandLocalLiteralArray(CompileEnv *envPtr); -static size_t HashString(const char *string, size_t length); +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); @@ -61,11 +61,11 @@ 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_Panic("TclInitLiteralTable: TCL_SMALL_HASH_TABLE is %d, not 4", TCL_SMALL_HASH_TABLE); #endif tablePtr->buckets = tablePtr->staticBuckets; tablePtr->staticBuckets[0] = tablePtr->staticBuckets[1] = 0; @@ -102,22 +102,20 @@ * referenced by the table to delete. */ LiteralTable *tablePtr) /* Points to the literal table to delete. */ { LiteralEntry *entryPtr, *nextPtr; Tcl_Obj *objPtr; - size_t i; + int i; /* * 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 @@ -131,21 +129,21 @@ entryPtr = tablePtr->buckets[i]; while (entryPtr != NULL) { objPtr = entryPtr->objPtr; TclDecrRefCount(objPtr); nextPtr = entryPtr->nextPtr; - Tcl_Free(entryPtr); + ckfree((char *)entryPtr); entryPtr = nextPtr; } } /* * Free up the table's bucket array if it was dynamically allocated. */ if (tablePtr->buckets != tablePtr->staticBuckets) { - Tcl_Free(tablePtr->buckets); + ckfree((char *)tablePtr->buckets); } } /* *---------------------------------------------------------------------- @@ -174,30 +172,30 @@ */ Tcl_Obj * TclCreateLiteral( Interp *iPtr, - const char *bytes, /* The start of the string. Note that this is + char *bytes, /* The start of the string. Note that this is * not a NUL-terminated string. */ - size_t length, /* Number of bytes in the string. */ - size_t hash, /* The string's hash. If -1, it will be + 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; - size_t globalHash; + int globalHash; Tcl_Obj *objPtr; /* * Is it in the interpreter's global literal table? */ - if (hash == TCL_INDEX_NONE) { + if (hash == (unsigned) -1) { hash = HashString(bytes, length); } globalHash = (hash & globalTablePtr->mask); for (globalPtr=globalTablePtr->buckets[globalHash] ; globalPtr!=NULL; globalPtr = globalPtr->nextPtr) { @@ -208,16 +206,16 @@ * is not guaranteed so we need to be careful anyway. * * https://stackoverflow.com/q/54337750/301832 */ - size_t objLength; - const char *objBytes = TclGetStringFromObj(objPtr, &objLength); + int objLength; + char *objBytes = TclGetStringFromObj(objPtr, &objLength); if ((objLength == length) && ((length == 0) || ((objBytes[0] == bytes[0]) - && (memcmp(objBytes, bytes, length) == 0)))) { + && (memcmp(objBytes, bytes, (unsigned) length) == 0)))) { /* * A literal was found: return it */ if (newPtr) { @@ -225,64 +223,47 @@ } if (globalPtrPtr) { *globalPtrPtr = globalPtr; } if (flags & LITERAL_ON_HEAP) { - Tcl_Free((void *)bytes); + ckfree(bytes); } - if (globalPtr->refCount != TCL_INDEX_NONE) { - globalPtr->refCount++; - } + globalPtr->refCount++; return objPtr; } } } if (!newPtr) { if ((flags & LITERAL_ON_HEAP)) { - Tcl_Free((void *)bytes); + ckfree(bytes); } return NULL; } /* - * The literal is new to the interpreter. + * The literal is new to the interpreter. Add it to the global literal + * table. */ TclNewObj(objPtr); + Tcl_IncrRefCount(objPtr); if ((flags & LITERAL_ON_HEAP)) { - objPtr->bytes = (char *) bytes; + objPtr->bytes = bytes; objPtr->length = length; } else { TclInitStringRep(objPtr, bytes, length); } - /* Should the new literal be shared globally? */ - - if ((flags & LITERAL_UNSHARED)) { - /* - * No, do *not* add it the global literal table - * Make clear, that no global value is returned - */ - if (globalPtrPtr != NULL) { - *globalPtrPtr = NULL; - } - return objPtr; - } - - /* - * 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 : (int)length), bytes); + "TclRegisterLiteral", (length>60? 60 : length), bytes); } #endif - globalPtr = (LiteralEntry *)Tcl_Alloc(sizeof(LiteralEntry)); + 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++; @@ -298,12 +279,11 @@ #ifdef TCL_COMPILE_DEBUG TclVerifyGlobalLiteralTable(iPtr); { LiteralEntry *entryPtr; - int found; - size_t i; + int found, i; found = 0; for (i=0 ; inumBuckets ; i++) { for (entryPtr=globalTablePtr->buckets[i]; entryPtr!=NULL ; entryPtr=entryPtr->nextPtr) { @@ -312,11 +292,11 @@ } } } if (!found) { Tcl_Panic("%s: literal \"%.*s\" wasn't global", - "TclRegisterLiteral", (length>60? 60 : (int)length), bytes); + "TclRegisterLiteral", (length>60? 60 : length), bytes); } } #endif /*TCL_COMPILE_DEBUG*/ #ifdef TCL_COMPILE_STATS @@ -330,37 +310,10 @@ *globalPtrPtr = globalPtr; } *newPtr = 1; return objPtr; } - -/* - *---------------------------------------------------------------------- - * - * TclFetchLiteral -- - * - * Fetch from a CompileEnv the literal value identified by an index - * value, as returned by a prior call to TclRegisterLiteral(). - * - * Results: - * The literal value, or NULL if the index is out of range. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclFetchLiteral( - CompileEnv *envPtr, /* Points to the CompileEnv from which to - * fetch the registered literal value. */ - size_t index) /* Index of the desired literal, as returned - * by prior call to TclRegisterLiteral() */ -{ - if (index >= (size_t) envPtr->literalArrayNext) { - return NULL; - } - return envPtr->literalArrayPtr[index].objPtr; -} /* *---------------------------------------------------------------------- * * TclRegisterLiteral -- @@ -389,32 +342,32 @@ 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 + char *bytes, /* Points to string for which to find or * create an object in CompileEnv's object * array. */ - size_t length, /* Number of bytes in the string. If -1, the + 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 + * this function. If LITERAL_NS_SCOPE then * the literal should not be shared accross * namespaces. */ { - CompileEnv *envPtr = (CompileEnv *)ePtr; + CompileEnv *envPtr = ePtr; Interp *iPtr = envPtr->iPtr; LiteralTable *localTablePtr = &envPtr->localLitTable; LiteralEntry *globalPtr, *localPtr; Tcl_Obj *objPtr; - size_t hash, localHash, objIndex; - int isNew; + unsigned hash; + int localHash, objIndex, new; Namespace *nsPtr; - if (length == TCL_INDEX_NONE) { + if (length < 0) { length = (bytes ? strlen(bytes) : 0); } hash = HashString(bytes, length); /* @@ -426,13 +379,13 @@ 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)))) { + && (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) { if ((flags & LITERAL_ON_HEAP)) { - Tcl_Free((void *)bytes); + ckfree(bytes); } objIndex = (localPtr - envPtr->literalArrayPtr); #ifdef TCL_COMPILE_DEBUG TclVerifyLocalLiteralTable(envPtr); #endif /*TCL_COMPILE_DEBUG*/ @@ -440,40 +393,34 @@ return objIndex; } } /* - * The literal is new to this CompileEnv. If it is a command name, avoid - * sharing it accross namespaces, and try not to share it with non-cmd - * literals. Note that FQ command names can be shared, so that we register - * the namespace as the interp's global NS. + * The literal is new to this CompileEnv. Should it be shared accross + * namespaces? If it is a fully qualified name, the namespace + * specification is not needed to avoid sharing. */ - if ((flags & LITERAL_CMD_NAME)) { - if ((length >= 2) && (bytes[0] == ':') && (bytes[1] == ':')) { - nsPtr = iPtr->globalNsPtr; - } else { - nsPtr = iPtr->varFramePtr->nsPtr; - } + if ((flags & LITERAL_NS_SCOPE) && iPtr->varFramePtr + && ((length <2) || (bytes[0] != ':') || (bytes[1] != ':'))) { + nsPtr = iPtr->varFramePtr->nsPtr; } else { nsPtr = NULL; } /* * 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); + objPtr = TclCreateLiteral(iPtr, bytes, length, hash, &new, 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 %" TCL_Z_MODIFIER "u", - "TclRegisterLiteral", (length>60? 60 : (int)length), bytes, - globalPtr->refCount); + if (globalPtr->refCount < 1) { + Tcl_Panic("TclRegisterLiteral: global literal \"%.*s\" had bad refCount %d", + (length>60? 60 : length), bytes, globalPtr->refCount); } TclVerifyLocalLiteralTable(envPtr); #endif /*TCL_COMPILE_DEBUG*/ return objIndex; } @@ -506,11 +453,11 @@ { Interp *iPtr = (Interp *) interp; LiteralTable *globalTablePtr = &iPtr->literalTable; LiteralEntry *entryPtr; const char *bytes; - size_t globalHash, length; + int length, globalHash; bytes = TclGetStringFromObj(objPtr, &length); globalHash = (HashString(bytes, length) & globalTablePtr->mask); for (entryPtr=globalTablePtr->buckets[globalHash] ; entryPtr!=NULL; entryPtr=entryPtr->nextPtr) { @@ -551,11 +498,11 @@ int index) /* The index of the entry in the literal * array. */ { LiteralEntry **nextPtrPtr, *entryPtr, *lPtr; LiteralTable *localTablePtr = &envPtr->localLitTable; - size_t localHash, length; + int localHash, length; const char *bytes; Tcl_Obj *newObjPtr; lPtr = &envPtr->literalArrayPtr[index]; @@ -570,11 +517,11 @@ Tcl_IncrRefCount(newObjPtr); TclReleaseLiteral(interp, lPtr->objPtr); lPtr->objPtr = newObjPtr; bytes = TclGetStringFromObj(newObjPtr, &length); - localHash = HashString(bytes, length) & localTablePtr->mask; + localHash = (HashString(bytes, length) & localTablePtr->mask); nextPtrPtr = &localTablePtr->buckets[localHash]; for (entryPtr=*nextPtrPtr ; entryPtr!=NULL ; entryPtr=*nextPtrPtr) { if (entryPtr == lPtr) { *nextPtrPtr = lPtr->nextPtr; @@ -626,11 +573,11 @@ envPtr->literalArrayNext++; lPtr = &envPtr->literalArrayPtr[objIndex]; lPtr->objPtr = objPtr; Tcl_IncrRefCount(objPtr); - lPtr->refCount = TCL_INDEX_NONE; /* i.e., unused */ + lPtr->refCount = -1; /* i.e., unused */ lPtr->nextPtr = NULL; if (litPtrPtr) { *litPtrPtr = lPtr; } @@ -688,12 +635,11 @@ #ifdef TCL_COMPILE_DEBUG TclVerifyLocalLiteralTable(envPtr); { char *bytes; - int found; - size_t length, i; + int length, found, i; found = 0; for (i=0 ; inumBuckets ; i++) { for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL ; localPtr=localPtr->nextPtr) { @@ -702,13 +648,13 @@ } } } if (!found) { - bytes = TclGetStringFromObj(objPtr, &length); + bytes = Tcl_GetStringFromObj(objPtr, &length); Tcl_Panic("%s: literal \"%.*s\" wasn't found locally", - "AddLocalLiteralEntry", (length>60? 60 : (int)length), bytes); + "AddLocalLiteralEntry", (length>60? 60 : length), bytes); } } #endif /*TCL_COMPILE_DEBUG*/ return objIndex; @@ -743,31 +689,32 @@ * The current allocated local literal entries are stored between elements * 0 and (envPtr->literalArrayNext - 1) [inclusive]. */ LiteralTable *localTablePtr = &envPtr->localLitTable; - size_t currElems = envPtr->literalArrayNext; + int currElems = envPtr->literalArrayNext; size_t currBytes = (currElems * sizeof(LiteralEntry)); LiteralEntry *currArrayPtr = envPtr->literalArrayPtr; LiteralEntry *newArrayPtr; - size_t i; - size_t newSize = (currBytes <= UINT_MAX / 2) ? 2*currBytes : UINT_MAX; + int i; + unsigned int newSize = (currBytes <= UINT_MAX / 2) ? 2*currBytes : UINT_MAX; if (currBytes == newSize) { - Tcl_Panic("max size of Tcl literal array (%" TCL_Z_MODIFIER "u literals) exceeded", + Tcl_Panic("max size of Tcl literal array (%d literals) exceeded", currElems); } if (envPtr->mallocedLiteralArray) { - newArrayPtr = (LiteralEntry *)Tcl_Realloc(currArrayPtr, newSize); + newArrayPtr = (LiteralEntry *)ckrealloc( + (char *)currArrayPtr, newSize); } else { /* - * envPtr->literalArrayPtr isn't a Tcl_Alloc'd pointer, so we must - * code a Tcl_Realloc equivalent for ourselves. + * envPtr->literalArrayPtr isn't a ckalloc'd pointer, so we must + * code a ckrealloc equivalent for ourselves. */ - newArrayPtr = (LiteralEntry *)Tcl_Alloc(newSize); + newArrayPtr = (LiteralEntry *)ckalloc(newSize); memcpy(newArrayPtr, currArrayPtr, currBytes); envPtr->mallocedLiteralArray = 1; } /* @@ -824,19 +771,19 @@ { Interp *iPtr = (Interp *) interp; LiteralTable *globalTablePtr; LiteralEntry *entryPtr, *prevPtr; const char *bytes; - size_t length, index; + int length, index; if (iPtr == NULL) { goto done; } globalTablePtr = &iPtr->literalTable; bytes = TclGetStringFromObj(objPtr, &length); - index = HashString(bytes, length) & globalTablePtr->mask; + 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. @@ -843,23 +790,25 @@ */ for (prevPtr=NULL, entryPtr=globalTablePtr->buckets[index]; entryPtr!=NULL ; prevPtr=entryPtr, entryPtr=entryPtr->nextPtr) { if (entryPtr->objPtr == objPtr) { + entryPtr->refCount--; + /* * 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 != TCL_INDEX_NONE) && (entryPtr->refCount-- <= 1)) { + if (entryPtr->refCount == 0) { if (prevPtr == NULL) { globalTablePtr->buckets[index] = entryPtr->nextPtr; } else { prevPtr->nextPtr = entryPtr->nextPtr; } - Tcl_Free(entryPtr); + ckfree((char *)entryPtr); globalTablePtr->numEntries--; TclDecrRefCount(objPtr); #ifdef TCL_COMPILE_STATS @@ -893,16 +842,17 @@ * None. * *---------------------------------------------------------------------- */ -static size_t +static unsigned int HashString( - const char *string, /* String for which to compute hash value. */ - size_t length) /* Number of bytes in the string. */ + const char *bytes, /* String for which to compute hash value. */ + int length) /* Number of bytes in the string. */ { - size_t result = 0; + unsigned int result; + int i; /* * 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 @@ -930,15 +880,13 @@ * See also TclObjHashKey in tclObj.c. * * See [tcl-Feature Request #2958832] */ - if (length > 0) { - result = UCHAR(*string); - while (--length) { - result += (result << 3) + UCHAR(*++string); - } + result = 0; + for (i=0 ; inumBuckets; oldBuckets = tablePtr->buckets; /* @@ -988,12 +937,12 @@ return; } tablePtr->numBuckets *= 4; - tablePtr->buckets = (LiteralEntry **)Tcl_Alloc( - tablePtr->numBuckets * sizeof(LiteralEntry*)); + tablePtr->buckets = (LiteralEntry **)ckalloc( + tablePtr->numBuckets * sizeof(LiteralEntry *)); for (count=tablePtr->numBuckets, newChainPtr=tablePtr->buckets; count>0 ; count--, newChainPtr++) { *newChainPtr = NULL; } tablePtr->rebuildSize *= 4; @@ -1018,56 +967,11 @@ /* * Free up the old bucket array, if it was dynamically allocated. */ if (oldBuckets != tablePtr->staticBuckets) { - Tcl_Free(oldBuckets); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclInvalidateCmdLiteral -- - * - * Invalidate a command literal entry, if present in the literal hash - * tables, by resetting its internal representation. This invalidation - * leaves it in the literal tables and in existing literal arrays. As a - * result, existing references continue to work but we force a fresh - * command look-up upon the next use (see, in particular, - * TclSetCmdNameObj()). - * - * Results: - * None. - * - * Side effects: - * Resets the internal representation of the CmdName Tcl_Obj - * using TclFreeIntRep(). - * - *---------------------------------------------------------------------- - */ - -void -TclInvalidateCmdLiteral( - Tcl_Interp *interp, /* Interpreter for which to invalidate a - * command literal. */ - const char *name, /* Points to the start of the cmd literal - * name. */ - Namespace *nsPtr) /* The namespace for which to lookup and - * invalidate a cmd literal. */ -{ - Interp *iPtr = (Interp *) interp; - Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, name, - strlen(name), -1, NULL, nsPtr, 0, NULL); - - if (literalObjPtr != NULL) { - if (TclHasIntRep(literalObjPtr, &tclCmdNameType)) { - TclFreeIntRep(literalObjPtr); - } - /* Balance the refcount effects of TclCreateLiteral() above */ - Tcl_IncrRefCount(literalObjPtr); - TclReleaseLiteral(interp, literalObjPtr); + ckfree((char *)oldBuckets); } } #ifdef TCL_COMPILE_STATS /* @@ -1091,11 +995,11 @@ char * TclLiteralStats( LiteralTable *tablePtr) /* Table for which to produce stats. */ { #define NUM_COUNTERS 10 - size_t count[NUM_COUNTERS], overflow, i, j; + int count[NUM_COUNTERS], overflow, i, j; double average, tmp; LiteralEntry *entryPtr; char *result, *p; /* @@ -1125,20 +1029,20 @@ /* * Print out the histogram and a few other pieces of information. */ - result = (char *)Tcl_Alloc(NUM_COUNTERS*60 + 300); - sprintf(result, "%" TCL_Z_MODIFIER "u entries in table, %" TCL_Z_MODIFIER "u buckets\n", + 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 ; ilocalLitTable; LiteralEntry *localPtr; char *bytes; - size_t i, length, count = 0; + int i; + int length, count; + count = 0; for (i=0 ; inumBuckets ; i++) { for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL; localPtr=localPtr->nextPtr) { count++; - if (localPtr->refCount != TCL_INDEX_NONE) { - bytes = TclGetStringFromObj(localPtr->objPtr, &length); - Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %" TCL_Z_MODIFIER "u", + if (localPtr->refCount != -1) { + bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); + Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %d", "TclVerifyLocalLiteralTable", - (length>60? 60 : (int) length), bytes, localPtr->refCount); + (length>60? 60 : length), bytes, localPtr->refCount); + } + if (LookupLiteralEntry((Tcl_Interp *) envPtr->iPtr, + localPtr->objPtr) == NULL) { + bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); + Tcl_Panic("%s: local literal \"%.*s\" is not global", + "TclVerifyLocalLiteralTable", (length>60? 60 : length), bytes); } 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 %" TCL_Z_MODIFIER "u", + Tcl_Panic("%s: local literal table had %d entries, should be %d", "TclVerifyLocalLiteralTable", count, localTablePtr->numEntries); } } @@ -1216,30 +1128,32 @@ * table is to be validated. */ { LiteralTable *globalTablePtr = &iPtr->literalTable; LiteralEntry *globalPtr; char *bytes; - size_t i, length, count = 0; + int i; + int length, count; + count = 0; for (i=0 ; inumBuckets ; i++) { for (globalPtr=globalTablePtr->buckets[i] ; globalPtr!=NULL; globalPtr=globalPtr->nextPtr) { count++; - if (globalPtr->refCount + 1 < 2) { - bytes = TclGetStringFromObj(globalPtr->objPtr, &length); - Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %" TCL_Z_MODIFIER "u", + if (globalPtr->refCount < 1) { + bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length); + Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d", "TclVerifyGlobalLiteralTable", - (length>60? 60 : (int)length), bytes, globalPtr->refCount); + (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 %" TCL_Z_MODIFIER "u", + Tcl_Panic("%s: global literal table had %d entries, should be %d", "TclVerifyGlobalLiteralTable", count, globalTablePtr->numEntries); } } #endif /*TCL_COMPILE_DEBUG*/ Index: generic/tclLoad.c ================================================================== --- generic/tclLoad.c +++ generic/tclLoad.c @@ -25,11 +25,11 @@ char *fileName; /* Name of the file from which the package was * loaded. An empty string means the package * is loaded statically. Malloc-ed. */ char *packageName; /* Name of package prefix for the package, * properly capitalized (first letter UC, - * others LC), no "_", as in "Net". + * others LC), as in "Net". * Malloc-ed. */ Tcl_LoadHandle loadHandle; /* Token for the loaded file which should be * passed to (*unLoadProcPtr)() when the file * is no longer needed. If fileName is NULL, * then this field is irrelevant. */ @@ -53,10 +53,15 @@ * the package cannot be unloaded. */ int interpRefCount; /* How many times the package has been loaded * in trusted interpreters. */ int safeInterpRefCount; /* How many times the package has been loaded * in safe interpreters. */ + Tcl_FSUnloadFileProc *unLoadProcPtr; + /* Function to use to unload this package. If + * NULL, then we do not attempt to unload the + * package. If fileName is NULL, then this + * field is irrelevant. */ struct LoadedPackage *nextPtr; /* Next in list of all packages loaded into * this application process. NULL means end of * list. */ } LoadedPackage; @@ -113,61 +118,38 @@ *---------------------------------------------------------------------- */ int Tcl_LoadObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ 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; + Tcl_PackageInitProc *initProc, *safeInitProc, *unloadProc, *safeUnloadProc; InterpPackage *ipFirstPtr, *ipPtr; int code, namesMatch, filesMatch, offset; - const char *symbols[2]; - Tcl_PackageInitProc *initProc; - const char *p, *fullFileName, *packageName; + const char *symbols[4]; + Tcl_PackageInitProc **procPtrs[4]; + ClientData clientData; + char *p, *fullFileName, *packageName; Tcl_LoadHandle loadHandle; - Tcl_UniChar ch = 0; - size_t len; - int index, flags = 0; - Tcl_Obj *const *savedobjv = objv; - static const char *const options[] = { - "-global", "-lazy", "--", NULL - }; - enum loadOptionsEnum { - LOAD_GLOBAL, LOAD_LAZY, LOAD_LAST - }; - - while (objc > 2) { - if (TclGetString(objv[1])[0] != '-') { - break; - } - if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } - ++objv; --objc; - if (LOAD_GLOBAL == (enum loadOptionsEnum) index) { - flags |= TCL_LOAD_GLOBAL; - } else if (LOAD_LAZY == (enum loadOptionsEnum) index) { - flags |= TCL_LOAD_LAZY; - } else { - break; - } - } + Tcl_FSUnloadFileProc *unLoadProcPtr = NULL; + Tcl_UniChar ch; + if ((objc < 2) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 1, savedobjv, "?-global? ?-lazy? ?--? fileName ?packageName? ?interp?"); + Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?"); return TCL_ERROR; } if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { return TCL_ERROR; } - fullFileName = TclGetString(objv[1]); + fullFileName = Tcl_GetString(objv[1]); Tcl_DStringInit(&pkgName); Tcl_DStringInit(&initName); Tcl_DStringInit(&safeInitName); Tcl_DStringInit(&unloadName); @@ -174,20 +156,19 @@ Tcl_DStringInit(&safeUnloadName); Tcl_DStringInit(&tmp); packageName = NULL; if (objc >= 3) { - packageName = TclGetString(objv[2]); + 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); + Tcl_SetResult(interp, + "must specify either file name or package name", + TCL_STATIC); code = TCL_ERROR; goto done; } /* @@ -194,13 +175,13 @@ * Figure out which interpreter we're going to load the package into. */ target = interp; if (objc == 4) { - const char *childIntName = TclGetString(objv[3]); + char *slaveIntName = Tcl_GetString(objv[3]); - target = Tcl_GetChild(interp, childIntName); + target = Tcl_GetSlave(interp, slaveIntName); if (target == NULL) { code = TCL_ERROR; goto done; } } @@ -220,13 +201,13 @@ defaultPtr = NULL; for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { if (packageName == NULL) { namesMatch = 0; } else { - TclDStringClear(&pkgName); + Tcl_DStringSetLength(&pkgName, 0); Tcl_DStringAppend(&pkgName, packageName, -1); - TclDStringClear(&tmp); + Tcl_DStringSetLength(&tmp, 0); Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); Tcl_UtfToLower(Tcl_DStringValue(&pkgName)); Tcl_UtfToLower(Tcl_DStringValue(&tmp)); if (strcmp(Tcl_DStringValue(&tmp), Tcl_DStringValue(&pkgName)) == 0) { @@ -233,11 +214,11 @@ namesMatch = 1; } else { namesMatch = 0; } } - TclDStringClear(&pkgName); + Tcl_DStringSetLength(&pkgName, 0); filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0); if (filesMatch && (namesMatch || (packageName == NULL))) { break; } @@ -247,15 +228,13 @@ if (filesMatch && !namesMatch && (fullFileName[0] != 0)) { /* * Can't have two different packages loaded from the same file. */ - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "file \"%s\" is already loaded for package \"%s\"", - fullFileName, pkgPtr->packageName)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", - "SPLITPERSONALITY", NULL); + Tcl_AppendResult(interp, "file \"", fullFileName, + "\" is already loaded for package \"", + pkgPtr->packageName, "\"", NULL); code = TCL_ERROR; Tcl_MutexUnlock(&packageMutex); goto done; } } @@ -269,11 +248,12 @@ * 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); + ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, + "tclLoad", NULL); for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { if (ipPtr->pkgPtr == pkgPtr) { code = TCL_OK; goto done; } @@ -285,14 +265,12 @@ * The desired file isn't currently loaded, so load it. It's an error * if the desired package is a static one. */ if (fullFileName[0] == 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "package \"%s\" isn't loaded statically", packageName)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOTSTATIC", - NULL); + Tcl_AppendResult(interp, "package \"", packageName, + "\" isn't loaded statically", NULL); code = TCL_ERROR; goto done; } /* @@ -308,13 +286,14 @@ * Threading note - this call used to be protected by a mutex. */ retc = TclGuessPackageName(fullFileName, &pkgName); if (!retc) { - Tcl_Obj *splitPtr, *pkgGuessPtr; + Tcl_Obj *splitPtr; + Tcl_Obj *pkgGuessPtr; int pElements; - const char *pkgGuess; + char *pkgGuess; /* * The platform-specific code couldn't figure out the module * name. Make a guess by taking the last element of the file * name, stripping off any leading "lib", and then using all @@ -322,11 +301,11 @@ * that. */ splitPtr = Tcl_FSSplitPath(objv[1], &pElements); Tcl_ListObjIndex(NULL, splitPtr, pElements -1, &pkgGuessPtr); - pkgGuess = TclGetString(pkgGuessPtr); + pkgGuess = Tcl_GetString(pkgGuessPtr); if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i') && (pkgGuess[2] == 'b')) { pkgGuess += 3; } #ifdef __CYGWIN__ @@ -334,28 +313,26 @@ && (pkgGuess[2] == 'g')) { pkgGuess += 3; } #endif /* __CYGWIN__ */ for (p = pkgGuess; *p != 0; p += offset) { - offset = TclUtfToUniChar(p, &ch); + offset = Tcl_UtfToUniChar(p, &ch); if ((ch > 0x100) || !(isalpha(UCHAR(ch)) /* INTL: ISO only */ || (UCHAR(ch) == '_'))) { break; } } if (p == pkgGuess) { Tcl_DecrRefCount(splitPtr); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't figure out package name for %s", - fullFileName)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", - "WHATPACKAGE", NULL); + Tcl_AppendResult(interp, + "couldn't figure out package name for ", + fullFileName, NULL); code = TCL_ERROR; goto done; } - Tcl_DStringAppend(&pkgName, pkgGuess, p - pkgGuess); + Tcl_DStringAppend(&pkgName, pkgGuess, (p - pkgGuess)); Tcl_DecrRefCount(splitPtr); } } /* @@ -370,148 +347,130 @@ /* * Compute the names of the two initialization functions, based on the * package name. */ - TclDStringAppendDString(&initName, &pkgName); - TclDStringAppendLiteral(&initName, "_Init"); - TclDStringAppendDString(&safeInitName, &pkgName); - TclDStringAppendLiteral(&safeInitName, "_SafeInit"); - TclDStringAppendDString(&unloadName, &pkgName); - TclDStringAppendLiteral(&unloadName, "_Unload"); - TclDStringAppendDString(&safeUnloadName, &pkgName); - TclDStringAppendLiteral(&safeUnloadName, "_SafeUnload"); + Tcl_DStringAppend(&initName, Tcl_DStringValue(&pkgName), -1); + Tcl_DStringAppend(&initName, "_Init", 5); + Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1); + Tcl_DStringAppend(&safeInitName, "_SafeInit", 9); + Tcl_DStringAppend(&unloadName, Tcl_DStringValue(&pkgName), -1); + Tcl_DStringAppend(&unloadName, "_Unload", 7); + Tcl_DStringAppend(&safeUnloadName, Tcl_DStringValue(&pkgName), -1); + Tcl_DStringAppend(&safeUnloadName, "_SafeUnload", 11); /* * Call platform-specific code to load the package and find the two * initialization functions. */ symbols[0] = Tcl_DStringValue(&initName); - symbols[1] = NULL; + symbols[1] = Tcl_DStringValue(&safeInitName); + symbols[2] = Tcl_DStringValue(&unloadName); + symbols[3] = Tcl_DStringValue(&safeUnloadName); + procPtrs[0] = &initProc; + procPtrs[1] = &safeInitProc; + procPtrs[2] = &unloadProc; + procPtrs[3] = &safeUnloadProc; Tcl_MutexLock(&packageMutex); - code = Tcl_LoadFile(interp, objv[1], symbols, flags, &initProc, - &loadHandle); + code = TclLoadFile(interp, objv[1], 4, symbols, procPtrs, + &loadHandle, &clientData, &unLoadProcPtr); Tcl_MutexUnlock(&packageMutex); + loadHandle = (Tcl_LoadHandle) clientData; if (code != TCL_OK) { goto done; } + + if (*procPtrs[0] /* initProc */ == NULL) { + Tcl_AppendResult(interp, "couldn't find procedure ", + Tcl_DStringValue(&initName), NULL); + if (unLoadProcPtr != NULL) { + (*unLoadProcPtr)(loadHandle); + } + code = TCL_ERROR; + goto done; + } /* * Create a new record to describe this package. */ - pkgPtr = (LoadedPackage *)Tcl_Alloc(sizeof(LoadedPackage)); - len = strlen(fullFileName) + 1; - pkgPtr->fileName = (char *)Tcl_Alloc(len); - memcpy(pkgPtr->fileName, fullFileName, len); - len = Tcl_DStringLength(&pkgName) + 1; - pkgPtr->packageName = (char *)Tcl_Alloc(len); - memcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName), len); + pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage)); + pkgPtr->fileName = (char *) ckalloc((unsigned) + (strlen(fullFileName) + 1)); + strcpy(pkgPtr->fileName, fullFileName); + pkgPtr->packageName = (char *) ckalloc((unsigned) + (Tcl_DStringLength(&pkgName) + 1)); + strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName)); pkgPtr->loadHandle = loadHandle; - pkgPtr->initProc = initProc; - pkgPtr->safeInitProc = (Tcl_PackageInitProc *) - Tcl_FindSymbol(interp, loadHandle, - Tcl_DStringValue(&safeInitName)); - pkgPtr->unloadProc = (Tcl_PackageUnloadProc *) - Tcl_FindSymbol(interp, loadHandle, - Tcl_DStringValue(&unloadName)); - pkgPtr->safeUnloadProc = (Tcl_PackageUnloadProc *) - Tcl_FindSymbol(interp, loadHandle, - Tcl_DStringValue(&safeUnloadName)); + pkgPtr->unLoadProcPtr = unLoadProcPtr; + pkgPtr->initProc = *procPtrs[0]; + pkgPtr->safeInitProc = *procPtrs[1]; + pkgPtr->unloadProc = (Tcl_PackageUnloadProc*) *procPtrs[2]; + pkgPtr->safeUnloadProc = (Tcl_PackageUnloadProc*) *procPtrs[3]; pkgPtr->interpRefCount = 0; pkgPtr->safeInterpRefCount = 0; Tcl_MutexLock(&packageMutex); pkgPtr->nextPtr = firstPackagePtr; firstPackagePtr = pkgPtr; Tcl_MutexUnlock(&packageMutex); - - /* - * The Tcl_FindSymbol calls may have left a spurious error message in - * the interpreter result. - */ - - Tcl_ResetResult(interp); } /* * Invoke the package's initialization function (either the normal one or * the safe one, depending on whether or not the interpreter is safe). */ if (Tcl_IsSafe(target)) { - if (pkgPtr->safeInitProc == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't use package in a safe interpreter: no" - " %s_SafeInit procedure", pkgPtr->packageName)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "UNSAFE", - NULL); - code = TCL_ERROR; - goto done; - } - code = pkgPtr->safeInitProc(target); - } else { - if (pkgPtr->initProc == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't attach package to interpreter: no %s_Init procedure", - pkgPtr->packageName)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT", - NULL); - code = TCL_ERROR; - goto done; - } - code = pkgPtr->initProc(target); - } - - /* - * 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; - if (iPtr->legacyResult && *(iPtr->legacyResult) && !iPtr->legacyFreeProc) { - /* - * 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->legacyResult, -1)); - iPtr->legacyResult = NULL; - iPtr->legacyFreeProc = (void (*) (void))-1; - } - Tcl_TransferResult(target, code, interp); - goto done; + if (pkgPtr->safeInitProc != NULL) { + code = (*pkgPtr->safeInitProc)(target); + } else { + Tcl_AppendResult(interp, + "can't use package in a safe interpreter: no ", + pkgPtr->packageName, "_SafeInit procedure", NULL); + code = TCL_ERROR; + goto done; + } + } else { + code = (*pkgPtr->initProc)(target); } /* * Record the fact that the package has been loaded in the target * interpreter. - * - * Update the proper reference count. */ - Tcl_MutexLock(&packageMutex); - if (Tcl_IsSafe(target)) { - pkgPtr->safeInterpRefCount++; + if (code == TCL_OK) { + /* + * Update the proper reference count. + */ + + Tcl_MutexLock(&packageMutex); + if (Tcl_IsSafe(target)) { + ++pkgPtr->safeInterpRefCount; + } else { + ++pkgPtr->interpRefCount; + } + 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, + (ClientData) ipPtr); } else { - pkgPtr->interpRefCount++; - } - 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 *)Tcl_Alloc(sizeof(InterpPackage)); - ipPtr->pkgPtr = pkgPtr; - ipPtr->nextPtr = ipFirstPtr; - Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipPtr); + TclTransferResult(target, code, interp); + } done: Tcl_DStringFree(&pkgName); Tcl_DStringFree(&initName); Tcl_DStringFree(&safeInitName); @@ -538,11 +497,11 @@ *---------------------------------------------------------------------- */ int Tcl_UnloadObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Interp *target; /* Which interpreter to unload from. */ @@ -551,22 +510,22 @@ Tcl_PackageUnloadProc *unloadProc; InterpPackage *ipFirstPtr, *ipPtr; int i, index, code, complain = 1, keepLibrary = 0; int trustedRefCount = -1, safeRefCount = -1; const char *fullFileName = ""; - const char *packageName; - static const char *const options[] = { + char *packageName; + static const char *options[] = { "-nocomplain", "-keeplibrary", "--", NULL }; - enum unloadOptionsEnum { + 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 = TclGetString(objv[i]); + fullFileName = Tcl_GetString(objv[i]); if (fullFileName[0] == '-') { /* * It looks like the command contains an option so signal an * error */ @@ -580,11 +539,11 @@ Tcl_ResetResult(interp); break; } } - switch ((enum unloadOptionsEnum)index) { + switch (index) { case UNLOAD_NOCOMPLAIN: /* -nocomplain */ complain = 0; break; case UNLOAD_KEEPLIB: /* -keeplibrary */ keepLibrary = 1; @@ -595,33 +554,32 @@ } } endOfForLoop: if ((objc-i < 1) || (objc-i > 3)) { Tcl_WrongNumArgs(interp, 1, objv, - "?-switch ...? fileName ?packageName? ?interp?"); + "?switches? fileName ?packageName? ?interp?"); return TCL_ERROR; } if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { return TCL_ERROR; } - fullFileName = TclGetString(objv[i]); + fullFileName = Tcl_GetString(objv[i]); Tcl_DStringInit(&pkgName); Tcl_DStringInit(&tmp); packageName = NULL; if (objc - i >= 2) { - packageName = TclGetString(objv[i+1]); + 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); + Tcl_SetResult(interp, + "must specify either file name or package name", + TCL_STATIC); code = TCL_ERROR; goto done; } /* @@ -628,13 +586,13 @@ * Figure out which interpreter we're going to load the package into. */ target = interp; if (objc - i == 3) { - const char *childIntName = TclGetString(objv[i + 2]); - - target = Tcl_GetChild(interp, childIntName); + char *slaveIntName; + slaveIntName = Tcl_GetString(objv[i+2]); + target = Tcl_GetSlave(interp, slaveIntName); if (target == NULL) { return TCL_ERROR; } } @@ -655,13 +613,13 @@ int namesMatch, filesMatch; if (packageName == NULL) { namesMatch = 0; } else { - TclDStringClear(&pkgName); + Tcl_DStringSetLength(&pkgName, 0); Tcl_DStringAppend(&pkgName, packageName, -1); - TclDStringClear(&tmp); + Tcl_DStringSetLength(&tmp, 0); Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); Tcl_UtfToLower(Tcl_DStringValue(&pkgName)); Tcl_UtfToLower(Tcl_DStringValue(&tmp)); if (strcmp(Tcl_DStringValue(&tmp), Tcl_DStringValue(&pkgName)) == 0) { @@ -668,11 +626,11 @@ namesMatch = 1; } else { namesMatch = 0; } } - TclDStringClear(&pkgName); + Tcl_DStringSetLength(&pkgName, 0); filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0); if (filesMatch && (namesMatch || (packageName == NULL))) { break; } @@ -687,27 +645,22 @@ if (fullFileName[0] == 0) { /* * It's an error to try unload a static package. */ - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "package \"%s\" is loaded statically and cannot be unloaded", - packageName)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "STATIC", - NULL); + Tcl_AppendResult(interp, "package \"", packageName, + "\" is loaded statically and cannot be unloaded", NULL); code = TCL_ERROR; goto done; } if (pkgPtr == NULL) { /* * The DLL pointed by the provided filename has never been loaded. */ - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "file \"%s\" has never been loaded", fullFileName)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED", - NULL); + Tcl_AppendResult(interp, "file \"", fullFileName, + "\" has never been loaded", NULL); code = TCL_ERROR; goto done; } /* @@ -716,11 +669,12 @@ * should proceed with unloading. */ code = TCL_ERROR; if (pkgPtr != NULL) { - ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); + ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, + "tclLoad", NULL); for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { if (ipPtr->pkgPtr == pkgPtr) { code = TCL_OK; break; } @@ -729,15 +683,12 @@ if (code != TCL_OK) { /* * The package has not been loaded in this interpreter. */ - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "file \"%s\" has never been loaded in this interpreter", - fullFileName)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED", - NULL); + Tcl_AppendResult(interp, "file \"", fullFileName, + "\" has never been loaded in this interpreter", NULL); code = TCL_ERROR; goto done; } /* @@ -746,26 +697,20 @@ * the interpreter is a safe one, pkgPtr->safeUnloadProc must be non-NULL. */ if (Tcl_IsSafe(target)) { if (pkgPtr->safeUnloadProc == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "file \"%s\" cannot be unloaded under a safe interpreter", - fullFileName)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", - NULL); + Tcl_AppendResult(interp, "file \"", fullFileName, + "\" cannot be unloaded under a safe interpreter", NULL); code = TCL_ERROR; goto done; } unloadProc = pkgPtr->safeUnloadProc; } else { if (pkgPtr->unloadProc == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "file \"%s\" cannot be unloaded under a trusted interpreter", - fullFileName)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", - NULL); + Tcl_AppendResult(interp, "file \"", fullFileName, + "\" cannot be unloaded under a trusted interpreter", NULL); code = TCL_ERROR; goto done; } unloadProc = pkgPtr->unloadProc; } @@ -786,22 +731,22 @@ trustedRefCount = pkgPtr->interpRefCount; safeRefCount = pkgPtr->safeInterpRefCount; Tcl_MutexUnlock(&packageMutex); if (Tcl_IsSafe(target)) { - safeRefCount--; + --safeRefCount; } else { - trustedRefCount--; + --trustedRefCount; } if (safeRefCount <= 0 && trustedRefCount <= 0) { code = TCL_UNLOAD_DETACH_FROM_PROCESS; } } - code = unloadProc(target, code); + code = (*unloadProc)(target, code); if (code != TCL_OK) { - Tcl_TransferResult(target, code, interp); + TclTransferResult(target, code, interp); goto done; } /* * The unload function executed fine. Examine the reference count to see @@ -808,21 +753,21 @@ * if we unload the DLL. */ Tcl_MutexLock(&packageMutex); if (Tcl_IsSafe(target)) { - pkgPtr->safeInterpRefCount--; + --pkgPtr->safeInterpRefCount; /* * Do not let counter get negative. */ if (pkgPtr->safeInterpRefCount < 0) { pkgPtr->safeInterpRefCount = 0; } } else { - pkgPtr->interpRefCount--; + --pkgPtr->interpRefCount; /* * Do not let counter get negative. */ @@ -839,21 +784,27 @@ && !keepLibrary) { /* * Unload the shared library from the application memory... */ -#if defined(TCL_UNLOAD_DLLS) || defined(_WIN32) +#if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__) /* * Some Unix dlls are poorly behaved - registering things like atexit * calls that can't be unregistered. If you unload such dlls, you get * a core on exit because it wants to call a function in the dll after * it's been unloaded. */ if (pkgPtr->fileName[0] != '\0') { - Tcl_MutexLock(&packageMutex); - if (Tcl_FSUnloadFile(interp, pkgPtr->loadHandle) == TCL_OK) { + Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr; + + if (unLoadProcPtr != NULL) { + Tcl_MutexLock(&packageMutex); + if ((pkgPtr->unloadProc != NULL) || (unLoadProcPtr == TclFSUnloadTempFile)) { + (*unLoadProcPtr)(pkgPtr->loadHandle); + } + /* * Remove this library from the loaded library cache. */ defaultPtr = pkgPtr; @@ -871,11 +822,12 @@ /* * Remove this library from the interpreter's library cache. */ - ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); + ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, + "tclLoad", NULL); ipPtr = ipFirstPtr; if (ipPtr->pkgPtr == defaultPtr) { ipFirstPtr = ipFirstPtr->nextPtr; } else { InterpPackage *ipPrevPtr; @@ -887,36 +839,66 @@ break; } } } Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, - ipFirstPtr); - Tcl_Free(defaultPtr->fileName); - Tcl_Free(defaultPtr->packageName); - Tcl_Free(defaultPtr); - Tcl_Free(ipPtr); + (ClientData) ipFirstPtr); + ckfree(defaultPtr->fileName); + ckfree(defaultPtr->packageName); + ckfree((char *) defaultPtr); + ckfree((char *) ipPtr); Tcl_MutexUnlock(&packageMutex); } else { + Tcl_AppendResult(interp, "file \"", fullFileName, + "\" cannot be unloaded: filesystem does not support unloading", + NULL); code = TCL_ERROR; } } #else - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "file \"%s\" cannot be unloaded: unloading disabled", - fullFileName)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "DISABLED", - NULL); + Tcl_AppendResult(interp, "file \"", fullFileName, + "\" cannot be unloaded: unloading disabled", NULL); code = TCL_ERROR; #endif } done: Tcl_DStringFree(&pkgName); Tcl_DStringFree(&tmp); - if (!complain && (code != TCL_OK)) { + if (!complain && code!=TCL_OK) { code = TCL_OK; Tcl_ResetResult(interp); + } + if (code == TCL_OK) { +#if 0 + /* + * Result of [unload] was not documented in TIP#100, so force to be + * the empty string by commenting this out. DKF. + */ + + Tcl_Obj *resultObjPtr, *objPtr[2]; + + /* + * Our result is the two reference counts. + */ + + objPtr[0] = Tcl_NewIntObj(trustedRefCount); + objPtr[1] = Tcl_NewIntObj(safeRefCount); + if (objPtr[0] == NULL || objPtr[1] == NULL) { + if (objPtr[0]) { + Tcl_DecrRefCount(objPtr[0]); + } + if (objPtr[1]) { + Tcl_DecrRefCount(objPtr[1]); + } + } else { + resultObjPtr = Tcl_NewListObj(2, objPtr); + if (resultObjPtr != NULL) { + Tcl_SetObjResult(interp, resultObjPtr); + } + } +#endif } return code; } /* @@ -977,15 +959,16 @@ /* * If the package is not yet recorded as being loaded statically, add it * to the list now. */ - if (pkgPtr == NULL) { - pkgPtr = (LoadedPackage *)Tcl_Alloc(sizeof(LoadedPackage)); - pkgPtr->fileName = (char *)Tcl_Alloc(1); + if ( pkgPtr == NULL ) { + pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage)); + pkgPtr->fileName = (char *) ckalloc((unsigned) 1); pkgPtr->fileName[0] = 0; - pkgPtr->packageName = (char *)Tcl_Alloc(strlen(pkgName) + 1); + pkgPtr->packageName = (char *) + ckalloc((unsigned) (strlen(pkgName) + 1)); strcpy(pkgPtr->packageName, pkgName); pkgPtr->loadHandle = NULL; pkgPtr->initProc = initProc; pkgPtr->safeInitProc = safeInitProc; Tcl_MutexLock(&packageMutex); @@ -999,36 +982,38 @@ /* * 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) { + 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 + * Package isn't loade in the current interp yet. Mark it as now being * loaded. */ - ipPtr = (InterpPackage *)Tcl_Alloc(sizeof(InterpPackage)); + ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage)); ipPtr->pkgPtr = pkgPtr; ipPtr->nextPtr = ipFirstPtr; - Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, ipPtr); + Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, + (ClientData) ipPtr); } } /* *---------------------------------------------------------------------- * - * TclGetLoadedPackages, TclGetLoadedPackagesEx -- + * TclGetLoadedPackages -- * * This function returns information about all of the files that are - * loaded (either in a particular interpreter, or for all interpreters). + * loaded (either in a particular intepreter, or for all interpreters). * * Results: * The return value is a standard Tcl completion code. If successful, a * list of lists is placed in the interp's result. Each sublist * corresponds to one loaded file; its first element is the name of the @@ -1043,90 +1028,58 @@ int TclGetLoadedPackages( Tcl_Interp *interp, /* Interpreter in which to return information * or error message. */ - const char *targetName) /* Name of target interpreter or NULL. If + char *targetName) /* Name of target interpreter or NULL. If * NULL, return info about all interps; * otherwise, just return info about this * interpreter. */ { - return TclGetLoadedPackagesEx(interp, targetName, NULL); -} - -int -TclGetLoadedPackagesEx( - Tcl_Interp *interp, /* Interpreter in which to return information - * or error message. */ - const char *targetName, /* Name of target interpreter or NULL. If - * NULL, return info about all interps; - * otherwise, just return info about this - * interpreter. */ - const char *packageName) /* Package name or NULL. If NULL, return info - * for all packages. - */ -{ Tcl_Interp *target; LoadedPackage *pkgPtr; InterpPackage *ipPtr; - Tcl_Obj *resultObj, *pkgDesc[2]; + const char *prefix; if (targetName == NULL) { - TclNewObj(resultObj); + /* + * Return information about all of the available packages. + */ + + prefix = "{"; Tcl_MutexLock(&packageMutex); for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { - pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1); - pkgDesc[1] = Tcl_NewStringObj(pkgPtr->packageName, -1); - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewListObj(2, pkgDesc)); + Tcl_AppendResult(interp, prefix, NULL); + Tcl_AppendElement(interp, pkgPtr->fileName); + Tcl_AppendElement(interp, pkgPtr->packageName); + Tcl_AppendResult(interp, "}", NULL); + prefix = " {"; } Tcl_MutexUnlock(&packageMutex); - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; - } - - target = Tcl_GetChild(interp, targetName); - if (target == NULL) { - return TCL_ERROR; - } - ipPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL); - - /* - * Return information about all of the available packages. - */ - if (packageName) { - resultObj = NULL; - - for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - pkgPtr = ipPtr->pkgPtr; - - if (!strcmp(packageName, pkgPtr->packageName)) { - resultObj = Tcl_NewStringObj(pkgPtr->fileName, -1); - break; - } - } - - if (resultObj) { - Tcl_SetObjResult(interp, resultObj); - } return TCL_OK; } /* * Return information about only the packages that are loaded in a given * interpreter. */ - TclNewObj(resultObj); - for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - pkgPtr = ipPtr->pkgPtr; - pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1); - pkgDesc[1] = Tcl_NewStringObj(pkgPtr->packageName, -1); - Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewListObj(2, pkgDesc)); - } - Tcl_SetObjResult(interp, resultObj); + target = Tcl_GetSlave(interp, targetName); + if (target == NULL) { + return TCL_ERROR; + } + ipPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", NULL); + prefix = "{"; + for ( ; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { + pkgPtr = ipPtr->pkgPtr; + Tcl_AppendResult(interp, prefix, NULL); + Tcl_AppendElement(interp, pkgPtr->fileName); + Tcl_AppendElement(interp, pkgPtr->packageName); + Tcl_AppendResult(interp, "}", NULL); + prefix = " {"; + } return TCL_OK; } /* *---------------------------------------------------------------------- @@ -1148,18 +1101,18 @@ static void LoadCleanupProc( ClientData clientData, /* Pointer to first InterpPackage structure * for interp. */ - TCL_UNUSED(Tcl_Interp *)) + Tcl_Interp *interp) /* Interpreter that is being deleted. */ { InterpPackage *ipPtr, *nextPtr; - ipPtr = (InterpPackage *)clientData; + ipPtr = (InterpPackage *) clientData; while (ipPtr != NULL) { nextPtr = ipPtr->nextPtr; - Tcl_Free(ipPtr); + ckfree((char *) ipPtr); ipPtr = nextPtr; } } /* @@ -1185,34 +1138,39 @@ LoadedPackage *pkgPtr; /* * No synchronization here because there should just be one thread alive * at this point. Logically, packageMutex should be grabbed at this point, - * but the Mutexes get finalized before the call to this routine. The only - * subsystem left alive at this point is the memory allocator. + * but the Mutexes get finalized before the call to this routine. The + * only subsystem left alive at this point is the memory allocator. */ while (firstPackagePtr != NULL) { pkgPtr = firstPackagePtr; firstPackagePtr = pkgPtr->nextPtr; -#if defined(TCL_UNLOAD_DLLS) || defined(_WIN32) +#if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__) /* * Some Unix dlls are poorly behaved - registering things like atexit * calls that can't be unregistered. If you unload such dlls, you get * a core on exit because it wants to call a function in the dll after * it has been unloaded. */ if (pkgPtr->fileName[0] != '\0') { - Tcl_FSUnloadFile(NULL, pkgPtr->loadHandle); + Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr; + if ((unLoadProcPtr != NULL) + && ((pkgPtr->unloadProc != NULL) + || (unLoadProcPtr == TclFSUnloadTempFile))) { + (*unLoadProcPtr)(pkgPtr->loadHandle); + } } #endif - Tcl_Free(pkgPtr->fileName); - Tcl_Free(pkgPtr->packageName); - Tcl_Free(pkgPtr); + ckfree(pkgPtr->fileName); + ckfree(pkgPtr->packageName); + ckfree((char *) pkgPtr); } } /* * Local Variables: Index: generic/tclLoadNone.c ================================================================== --- generic/tclLoadNone.c +++ generic/tclLoadNone.c @@ -1,9 +1,9 @@ /* * tclLoadNone.c -- * - * This procedure provides a version of the TclpDlopen for use in + * This procedure provides a version of the TclLoadFile for use in * systems that don't support dynamic loading; it just returns an error. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of @@ -37,23 +37,47 @@ Tcl_Obj *pathPtr, /* Name of the file containing the desired * code (UTF-8). */ Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ - Tcl_FSUnloadFileProc **unloadProcPtr, + Tcl_FSUnloadFileProc **unloadProcPtr) /* Filled with address of Tcl_FSUnloadFileProc * function which should be used for this * file. */ - int flags) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "dynamic loading is not currently available on this system", - -1)); - } + Tcl_SetResult(interp, + "dynamic loading is not currently available on this system", + TCL_STATIC); return TCL_ERROR; } + +/* + *---------------------------------------------------------------------- + * + * TclpFindSymbol -- + * + * Looks up a symbol, by name, through a handle associated with a + * previously loaded piece of code (shared library). This version of this + * routine should never be called because the associated TclpDlopen() + * function always returns an error. + * + * Results: + * Returns a pointer to the function associated with 'symbol' if it is + * found. Otherwise returns NULL and may leave an error message in the + * interp's result. + * + *---------------------------------------------------------------------- + */ + +Tcl_PackageInitProc * +TclpFindSymbol( + Tcl_Interp *interp, + Tcl_LoadHandle loadHandle, + CONST char *symbol) +{ + return NULL; +} /* *---------------------------------------------------------------------- * * TclGuessPackageName -- @@ -73,16 +97,42 @@ *---------------------------------------------------------------------- */ int TclGuessPackageName( - const char *fileName, /* Name of file containing package (already + CONST char *fileName, /* Name of file containing package (already * translated to local form if needed). */ Tcl_DString *bufPtr) /* Initialized empty dstring. Append package * name to this if possible. */ { return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclpUnloadFile -- + * + * This procedure is called to carry out dynamic unloading of binary code; + * it is intended for use only on systems that don't support dynamic + * loading (it does nothing). + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclpUnloadFile( + Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to + * TclpDlopen(). The loadHandle is a token + * that represents the loaded file. */ +{ } /* * These functions are fallbacks if we somehow determine that the platform can * do loading from memory but the user wishes to disable it. They just report @@ -104,19 +154,15 @@ Tcl_Interp *interp, /* Used for error reporting. */ void *buffer, /* Dummy: unused by this implementation */ int size, /* Dummy: unused by this implementation */ int codeSize, /* Dummy: unused by this implementation */ Tcl_LoadHandle *loadHandle, /* Dummy: unused by this implementation */ - Tcl_FSUnloadFileProc **unloadProcPtr, - /* Dummy: unused by this implementation */ - int flags) + Tcl_FSUnloadFileProc **unloadProcPtr) /* Dummy: unused by this implementation */ { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("dynamic loading from memory " - "is not available on this system", -1)); - } + Tcl_SetResult(interp, "dynamic loading from memory is not available " + "on this system", TCL_STATIC); return TCL_ERROR; } #endif /* TCL_LOAD_FROM_MEMORY */ Index: generic/tclMain.c ================================================================== --- generic/tclMain.c +++ generic/tclMain.c @@ -1,65 +1,29 @@ /* * tclMain.c -- * * Main program for Tcl shells and other Tcl-based applications. - * This file contains a generic main program for Tcl shells and other - * Tcl-based applications. It can be used as-is for many applications, - * just by supplying a different appInitProc function for each specific - * application. Or, it can be used as a template for creating new main - * programs for Tcl applications. * * Copyright (c) 1988-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * 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" +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLEXPORT + /* * The default prompt used when the user has not overridden it. */ #define DEFAULT_PRIMARY_PROMPT "% " -/* - * This file can be compiled on Windows in UNICODE mode, as well as on all - * other platforms using the native encoding. This is done by using the normal - * Windows functions like _tcscmp, but on platforms which don't have - * we have to translate that to strcmp here. - */ - -#ifndef _WIN32 -# define TCHAR char -# define TEXT(arg) arg -# define _tcscmp strcmp -#endif - -static Tcl_Obj * -NewNativeObj( - TCHAR *string) -{ - Tcl_DString ds; - -#ifdef UNICODE - Tcl_DStringInit(&ds); - Tcl_WCharToUtfDString(string, -1, &ds); -#else - Tcl_ExternalToUtfDString(NULL, (char *)string, -1, &ds); -#endif - return TclDStringToObj(&ds); -} - /* * Declarations for various library functions and variables (don't want to * include tclPort.h here, because people might copy this file out of the Tcl * source directory to make their own modified versions). */ @@ -67,24 +31,13 @@ #if defined _MSC_VER && _MSC_VER < 1900 /* isatty is always defined on MSVC 14.0, but not necessarily as CRTIMPORT. */ extern CRTIMPORT int isatty(int fd); #endif -/* - * The thread-local variables for this file's functions. - */ - -typedef struct { - Tcl_Obj *path; /* The filename of the script for *_Main() - * routines to [source] as a startup script, - * or NULL for none set, meaning enter - * interactive mode. */ - Tcl_Obj *encoding; /* The encoding of the startup script file. */ - Tcl_MainLoopProc *mainLoopProc; - /* Any installed main loop handler. The main - * extension that installs these is Tk. */ -} ThreadSpecificData; +static Tcl_Obj *tclStartupScriptPath = NULL; +static Tcl_Obj *tclStartupScriptEncoding = NULL; +static Tcl_MainLoopProc *mainLoopProc = NULL; /* * Structure definition for information used to keep the state of an * interactive command processor that reads lines from standard input and * writes prompts and results to standard output. @@ -94,11 +47,11 @@ PROMPT_NONE, /* Print no prompt */ PROMPT_START, /* Print prompt for command start */ PROMPT_CONTINUE /* Print prompt for command continuation */ } PromptType; -typedef struct { +typedef struct InteractiveState { Tcl_Channel input; /* The standard input channel from which lines * are read. */ int tty; /* Non-zero means standard input is a * terminal-like device. Zero means it's a * file. */ @@ -111,18 +64,13 @@ /* * Forward declarations for functions defined later in this file. */ -MODULE_SCOPE Tcl_MainLoopProc *TclGetMainLoop(void); -static void Prompt(Tcl_Interp *interp, InteractiveState *isPtr); +static void Prompt(Tcl_Interp *interp, PromptType *promptPtr); 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 -- * @@ -138,33 +86,31 @@ */ void Tcl_SetStartupScript( Tcl_Obj *path, /* Filesystem path of startup script file */ - const char *encoding) /* Encoding of the data in that file */ + CONST char *encoding) /* Encoding of the data in that file */ { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); Tcl_Obj *newEncoding = NULL; - if (encoding != NULL) { newEncoding = Tcl_NewStringObj(encoding, -1); } - if (tsdPtr->path != NULL) { - Tcl_DecrRefCount(tsdPtr->path); - } - tsdPtr->path = path; - if (tsdPtr->path != NULL) { - Tcl_IncrRefCount(tsdPtr->path); - } - - if (tsdPtr->encoding != NULL) { - Tcl_DecrRefCount(tsdPtr->encoding); - } - tsdPtr->encoding = newEncoding; - if (tsdPtr->encoding != NULL) { - Tcl_IncrRefCount(tsdPtr->encoding); + if (tclStartupScriptPath != NULL) { + Tcl_DecrRefCount(tclStartupScriptPath); + } + tclStartupScriptPath = path; + if (tclStartupScriptPath != NULL) { + Tcl_IncrRefCount(tclStartupScriptPath); + } + + if (tclStartupScriptEncoding != NULL) { + Tcl_DecrRefCount(tclStartupScriptEncoding); + } + tclStartupScriptEncoding = newEncoding; + if (tclStartupScriptEncoding != NULL) { + Tcl_IncrRefCount(tclStartupScriptEncoding); } } /* *---------------------------------------------------------------------- @@ -176,35 +122,135 @@ * * Results: * The path of the startup script; NULL if none has been set. * * Side effects: - * If encodingPtr is not NULL, stores a (const char *) in it pointing to - * the encoding name registered for the startup script. Tcl retains - * ownership of the string, and may free it. Caller should make a copy - * for long-term use. + * If encodingPtr is not NULL, stores a (CONST char *) in it pointing to + * the encoding name registered for the startup script. Tcl retains + * ownership of the string, and may free it. Caller should make a copy + * for long-term use. * *---------------------------------------------------------------------- */ Tcl_Obj * Tcl_GetStartupScript( - const char **encodingPtr) /* When not NULL, points to storage for the - * (const char *) that points to the + CONST char **encodingPtr) /* When not NULL, points to storage for the + * (CONST char *) that points to the * registered encoding name for the startup - * script. */ + * script */ { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - if (encodingPtr != NULL) { - if (tsdPtr->encoding == NULL) { + if (tclStartupScriptEncoding == NULL) { *encodingPtr = NULL; } else { - *encodingPtr = TclGetString(tsdPtr->encoding); + *encodingPtr = Tcl_GetString(tclStartupScriptEncoding); } } - return tsdPtr->path; + return tclStartupScriptPath; +} + +/* + *---------------------------------------------------------------------- + * + * TclSetStartupScriptPath -- + * + * Primes the startup script VFS path, used to override the command line + * processing. + * + * Results: + * None. + * + * Side effects: + * This function initializes the VFS path of the Tcl script to run at + * startup. + * + *---------------------------------------------------------------------- + */ + +void +TclSetStartupScriptPath( + Tcl_Obj *path) +{ + Tcl_SetStartupScript(path, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * TclGetStartupScriptPath -- + * + * Gets the startup script VFS path, used to override the command line + * processing. + * + * Results: + * The startup script VFS path, NULL if none has been set. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclGetStartupScriptPath(void) +{ + return Tcl_GetStartupScript(NULL); +} + +/* + *---------------------------------------------------------------------- + * + * TclSetStartupScriptFileName -- + * + * Primes the startup script file name, used to override the command line + * processing. + * + * Results: + * None. + * + * Side effects: + * This function initializes the file name of the Tcl script to run at + * startup. + * + *---------------------------------------------------------------------- + */ + +void +TclSetStartupScriptFileName( + CONST char *fileName) +{ + Tcl_Obj *path = Tcl_NewStringObj(fileName,-1); + Tcl_SetStartupScript(path, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * TclGetStartupScriptFileName -- + * + * Gets the startup script file name, used to override the command line + * processing. + * + * Results: + * The startup script file name, NULL if none has been set. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +CONST char * +TclGetStartupScriptFileName(void) +{ + Tcl_Obj *path = Tcl_GetStartupScript(NULL); + + if (path == NULL) { + return NULL; + } + return Tcl_GetString(path); } /*---------------------------------------------------------------------- * * Tcl_SourceRCFile -- @@ -225,17 +271,17 @@ void Tcl_SourceRCFile( Tcl_Interp *interp) /* Interpreter to source rc file into. */ { Tcl_DString temp; - const char *fileName; - Tcl_Channel chan; + CONST char *fileName; + Tcl_Channel errChannel; - fileName = Tcl_GetVar2(interp, "tcl_rcFileName", NULL, TCL_GLOBAL_ONLY); + fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY); if (fileName != NULL) { Tcl_Channel c; - const char *fullName; + CONST char *fullName; Tcl_DStringInit(&temp); fullName = Tcl_TranslateFileName(interp, fileName, &temp); if (fullName == NULL) { /* @@ -247,29 +293,28 @@ /* * Test for the existence of the rc file before trying to read it. */ c = Tcl_OpenFileChannel(NULL, fullName, "r", 0); - if (c != NULL) { - Tcl_CloseEx(NULL, c, 0); + if (c != (Tcl_Channel) NULL) { + Tcl_Close(NULL, c); if (Tcl_EvalFile(interp, fullName) != TCL_OK) { - chan = Tcl_GetStdChannel(TCL_STDERR); - if (chan) { - Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); - Tcl_WriteChars(chan, "\n", 1); - } - } - } + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); + Tcl_WriteChars(errChannel, "\n", 1); + } + } + } } Tcl_DStringFree(&temp); } } -#endif /* !UNICODE */ /*---------------------------------------------------------------------- * - * Tcl_MainEx -- + * Tcl_Main -- * * Main program for tclsh and most other Tcl-based applications. * * Results: * None. This function never returns (it exits the process when it's @@ -281,144 +326,138 @@ * interpreted. * *---------------------------------------------------------------------- */ -TCL_NORETURN void -Tcl_MainEx( +void +Tcl_Main( int argc, /* Number of arguments. */ - TCHAR **argv, /* Array of argument strings. */ - Tcl_AppInitProc *appInitProc, + char **argv, /* Array of argument strings. */ + Tcl_AppInitProc *appInitProc) /* Application-specific initialization * function to call after most initialization * but before starting to execute commands. */ - Tcl_Interp *interp) -{ - Tcl_Obj *path, *resultPtr, *argvPtr, *appName; - const char *encodingName = NULL; - int code, exitCode = 0; - Tcl_MainLoopProc *mainLoopProc; - Tcl_Channel chan; - InteractiveState is; - +{ + Tcl_Obj *path, *resultPtr, *argvPtr, *commandPtr = NULL; + CONST char *encodingName = NULL; + PromptType prompt = PROMPT_START; + int code, length, tty, exitCode = 0; + Tcl_Channel inChannel, outChannel, errChannel; + Tcl_Interp *interp; + Tcl_DString appName; + + interp = Tcl_CreateInterp(); TclpSetInitialEncodings(); - TclpFindExecutable((const char *)argv[0]); + TclpFindExecutable(argv[0]); Tcl_InitMemory(interp); - is.interp = interp; - is.prompt = PROMPT_START; - TclNewObj(is.commandPtr); - /* * If the application has not already set a startup script, parse the * first few command line arguments to determine the script path and * encoding. */ if (NULL == Tcl_GetStartupScript(NULL)) { + /* * Check whether first 3 args (argv[1] - argv[3]) look like - * -encoding ENCODING FILENAME + * -encoding ENCODING FILENAME * or like - * FILENAME + * FILENAME */ - if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1])) + if ((argc > 3) && (0 == strcmp("-encoding", argv[1])) && ('-' != argv[3][0])) { - Tcl_Obj *value = NewNativeObj(argv[2]); - Tcl_SetStartupScript(NewNativeObj(argv[3]), - TclGetString(value)); - Tcl_DecrRefCount(value); + Tcl_SetStartupScript(Tcl_NewStringObj(argv[3], -1), argv[2]); argc -= 3; argv += 3; } else if ((argc > 1) && ('-' != argv[1][0])) { - Tcl_SetStartupScript(NewNativeObj(argv[1]), NULL); + Tcl_SetStartupScript(Tcl_NewStringObj(argv[1], -1), NULL); argc--; argv++; } } path = Tcl_GetStartupScript(&encodingName); if (path == NULL) { - appName = NewNativeObj(argv[0]); + Tcl_ExternalToUtfDString(NULL, argv[0], -1, &appName); } else { - appName = path; + CONST char *pathName = Tcl_GetStringFromObj(path, &length); + Tcl_ExternalToUtfDString(NULL, pathName, length, &appName); + path = Tcl_NewStringObj(Tcl_DStringValue(&appName), -1); + Tcl_SetStartupScript(path, encodingName); } - Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&appName), TCL_GLOBAL_ONLY); + Tcl_DStringFree(&appName); argc--; argv++; - Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewWideIntObj(argc), TCL_GLOBAL_ONLY); + 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_DString ds; + Tcl_ExternalToUtfDString(NULL, *argv++, -1, &ds); + Tcl_ListObjAppendElement(NULL, argvPtr, Tcl_NewStringObj( + Tcl_DStringValue(&ds), Tcl_DStringLength(&ds))); + Tcl_DStringFree(&ds); } Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY); /* * Set the "tcl_interactive" variable. */ - is.tty = isatty(0); - Tcl_SetVar2Ex(interp, "tcl_interactive", NULL, - Tcl_NewWideIntObj(!path && is.tty), TCL_GLOBAL_ONLY); + tty = isatty(0); + Tcl_SetVar(interp, "tcl_interactive", ((path == NULL) && tty) ? "1" : "0", + TCL_GLOBAL_ONLY); /* * Invoke application-specific initialization. */ - Tcl_Preserve(interp); - if (appInitProc(interp) != TCL_OK) { - chan = Tcl_GetStdChannel(TCL_STDERR); - if (chan) { - Tcl_WriteChars(chan, + Tcl_Preserve((ClientData) interp); + if ((*appInitProc)(interp) != TCL_OK) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + Tcl_WriteChars(errChannel, "application-specific initialization failed: ", -1); - Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); - Tcl_WriteChars(chan, "\n", 1); + Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); + Tcl_WriteChars(errChannel, "\n", 1); } } if (Tcl_InterpDeleted(interp)) { goto done; } if (Tcl_LimitExceeded(interp)) { goto done; } - if (TclFullFinalizationRequested()) { - /* - * Arrange for final deletion of the main interp - */ - - /* ARGH Munchhausen effect */ - Tcl_CreateExitHandler(FreeMainInterp, interp); - } /* - * Invoke the script specified on the command line, if any. Must fetch it - * again, as the appInitProc might have reset it. + * If a script file was specified then just source that file and quit. + * Must fetch it again, as the appInitProc might have reset it. */ path = Tcl_GetStartupScript(&encodingName); if (path != NULL) { - Tcl_ResetResult(interp); code = Tcl_FSEvalFileEx(interp, path, encodingName); if (code != TCL_OK) { - chan = Tcl_GetStdChannel(TCL_STDERR); - if (chan) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { Tcl_Obj *options = Tcl_GetReturnOptions(interp, code); Tcl_Obj *keyPtr, *valuePtr; TclNewLiteralStringObj(keyPtr, "-errorinfo"); Tcl_IncrRefCount(keyPtr); Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr); Tcl_DecrRefCount(keyPtr); if (valuePtr) { - Tcl_WriteObj(chan, valuePtr); + Tcl_WriteObj(errChannel, valuePtr); } - Tcl_WriteChars(chan, "\n", 1); + Tcl_WriteChars(errChannel, "\n", 1); Tcl_DecrRefCount(options); } exitCode = 1; } goto done; @@ -438,50 +477,49 @@ * Process commands from stdin until there's an end-of-file. Note that we * need to fetch the standard channels again after every eval, since they * may have been changed. */ - Tcl_IncrRefCount(is.commandPtr); + commandPtr = Tcl_NewObj(); + Tcl_IncrRefCount(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(); + Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, TCL_LINK_BOOLEAN); + inChannel = Tcl_GetStdChannel(TCL_STDIN); + outChannel = Tcl_GetStdChannel(TCL_STDOUT); + while ((inChannel != (Tcl_Channel) NULL) && !Tcl_InterpDeleted(interp)) { if (mainLoopProc == NULL) { - size_t length; - - if (is.tty) { - Prompt(interp, &is); + if (tty) { + Prompt(interp, &prompt); if (Tcl_InterpDeleted(interp)) { break; } if (Tcl_LimitExceeded(interp)) { break; } - is.input = Tcl_GetStdChannel(TCL_STDIN); - if (is.input == NULL) { + inChannel = Tcl_GetStdChannel(TCL_STDIN); + if (inChannel == (Tcl_Channel) 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 == TCL_INDEX_NONE) { - if (Tcl_InputBlocked(is.input)) { + if (Tcl_IsShared(commandPtr)) { + Tcl_DecrRefCount(commandPtr); + commandPtr = Tcl_DuplicateObj(commandPtr); + Tcl_IncrRefCount(commandPtr); + } + length = Tcl_GetsObj(inChannel, commandPtr); + if (length < 0) { + if (Tcl_InputBlocked(inChannel)) { /* * This can only happen if stdin has been set to - * non-blocking. In that case cycle back and try again. + * 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. + * event loop running). If this causes bad CPU hogging, + * we might try toggling the blocking on stdin instead. */ continue; } @@ -491,55 +529,52 @@ break; } /* - * Add the newline removed by Tcl_GetsObj back to the string. Have - * to add it back before testing completeness, because it can make - * a difference. [Bug 1775878] + * Add the newline removed by Tcl_GetsObj back to the string. + * Have to add it back before testing completeness, because + * it can make a difference. [Bug 1775878]. */ - if (Tcl_IsShared(is.commandPtr)) { - Tcl_DecrRefCount(is.commandPtr); - is.commandPtr = Tcl_DuplicateObj(is.commandPtr); - Tcl_IncrRefCount(is.commandPtr); - } - Tcl_AppendToObj(is.commandPtr, "\n", 1); - if (!TclObjCommandComplete(is.commandPtr)) { - is.prompt = PROMPT_CONTINUE; + if (Tcl_IsShared(commandPtr)) { + Tcl_DecrRefCount(commandPtr); + commandPtr = Tcl_DuplicateObj(commandPtr); + Tcl_IncrRefCount(commandPtr); + } + Tcl_AppendToObj(commandPtr, "\n", 1); + if (!TclObjCommandComplete(commandPtr)) { + prompt = PROMPT_CONTINUE; continue; } - is.prompt = PROMPT_START; - + prompt = PROMPT_START; /* - * The final newline is syntactically redundant, and causes some - * error messages troubles deeper in, so lop it back off. + * The final newline is syntactically redundant, and causes + * some error messages troubles deeper in, so lop it back off. */ - - (void)TclGetStringFromObj(is.commandPtr, &length); - Tcl_SetObjLength(is.commandPtr, --length); - code = Tcl_RecordAndEvalObj(interp, is.commandPtr, - TCL_EVAL_GLOBAL); - is.input = Tcl_GetStdChannel(TCL_STDIN); - Tcl_DecrRefCount(is.commandPtr); - TclNewObj(is.commandPtr); - Tcl_IncrRefCount(is.commandPtr); + Tcl_GetStringFromObj(commandPtr, &length); + Tcl_SetObjLength(commandPtr, --length); + code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL); + inChannel = Tcl_GetStdChannel(TCL_STDIN); + outChannel = Tcl_GetStdChannel(TCL_STDOUT); + errChannel = Tcl_GetStdChannel(TCL_STDERR); + Tcl_DecrRefCount(commandPtr); + commandPtr = Tcl_NewObj(); + Tcl_IncrRefCount(commandPtr); if (code != TCL_OK) { - chan = Tcl_GetStdChannel(TCL_STDERR); - if (chan) { - Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); - Tcl_WriteChars(chan, "\n", 1); + if (errChannel) { + Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); + Tcl_WriteChars(errChannel, "\n", 1); } - } else if (is.tty) { + } else if (tty) { resultPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(resultPtr); - (void)TclGetStringFromObj(resultPtr, &length); - chan = Tcl_GetStdChannel(TCL_STDOUT); - if ((length > 0) && chan) { - Tcl_WriteObj(chan, resultPtr); - Tcl_WriteChars(chan, "\n", 1); + Tcl_GetStringFromObj(resultPtr, &length); + if ((length > 0) && outChannel) { + Tcl_WriteObj(outChannel, resultPtr); + Tcl_WriteChars(outChannel, "\n", 1); } Tcl_DecrRefCount(resultPtr); } } else { /* (mainLoopProc != NULL) */ /* @@ -546,92 +581,127 @@ * If a main loop has been defined while running interactively, we * want to start a fileevent based prompt by establishing a * channel handler for stdin. */ - if (is.input) { - if (is.tty) { - Prompt(interp, &is); - } - - Tcl_CreateChannelHandler(is.input, TCL_READABLE, - StdinProc, &is); - } - - mainLoopProc(); - Tcl_SetMainLoop(NULL); - - if (is.input) { - Tcl_DeleteChannelHandler(is.input, StdinProc, &is); - } - is.input = Tcl_GetStdChannel(TCL_STDIN); - } + InteractiveState *isPtr = NULL; + + if (inChannel) { + if (tty) { + Prompt(interp, &prompt); + } + isPtr = (InteractiveState *) + ckalloc((int) sizeof(InteractiveState)); + isPtr->input = inChannel; + isPtr->tty = tty; + isPtr->commandPtr = commandPtr; + isPtr->prompt = prompt; + isPtr->interp = interp; + + Tcl_UnlinkVar(interp, "tcl_interactive"); + Tcl_LinkVar(interp, "tcl_interactive", (char *) &(isPtr->tty), + TCL_LINK_BOOLEAN); + + Tcl_CreateChannelHandler(inChannel, TCL_READABLE, StdinProc, + (ClientData) isPtr); + } + + (*mainLoopProc)(); + mainLoopProc = NULL; + + if (inChannel) { + tty = isPtr->tty; + Tcl_UnlinkVar(interp, "tcl_interactive"); + Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, + TCL_LINK_BOOLEAN); + prompt = isPtr->prompt; + commandPtr = isPtr->commandPtr; + if (isPtr->input != (Tcl_Channel) NULL) { + Tcl_DeleteChannelHandler(isPtr->input, StdinProc, + (ClientData) isPtr); + } + ckfree((char *)isPtr); + } + inChannel = Tcl_GetStdChannel(TCL_STDIN); + outChannel = Tcl_GetStdChannel(TCL_STDOUT); + errChannel = Tcl_GetStdChannel(TCL_STDERR); + } +#ifdef TCL_MEM_DEBUG /* * This code here only for the (unsupported and deprecated) [checkmem] * command. */ -#ifdef TCL_MEM_DEBUG if (tclMemDumpFileName != NULL) { - Tcl_SetMainLoop(NULL); + mainLoopProc = NULL; Tcl_DeleteInterp(interp); } -#endif /* TCL_MEM_DEBUG */ +#endif } done: - mainLoopProc = TclGetMainLoop(); - if ((exitCode == 0) && mainLoopProc && !Tcl_LimitExceeded(interp)) { + if ((exitCode == 0) && (mainLoopProc != NULL) + && !Tcl_LimitExceeded(interp)) { /* * If everything has gone OK so far, call the main loop proc, if it * exists. Packages (like Tk) can set it to start processing events at * this point. */ - mainLoopProc(); - Tcl_SetMainLoop(NULL); + (*mainLoopProc)(); + mainLoopProc = NULL; } - if (is.commandPtr != NULL) { - Tcl_DecrRefCount(is.commandPtr); + if (commandPtr != NULL) { + Tcl_DecrRefCount(commandPtr); } /* * Rather than calling exit, invoke the "exit" command so that users can * replace "exit" with some other command to do additional cleanup on * exit. The Tcl_EvalObjEx call should never return. */ - if (!Tcl_InterpDeleted(interp) && !Tcl_LimitExceeded(interp)) { - Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode); + if (!Tcl_InterpDeleted(interp)) { + if (!Tcl_LimitExceeded(interp)) { + Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode); + Tcl_IncrRefCount(cmd); + Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL); + Tcl_DecrRefCount(cmd); + } + + /* + * If Tcl_EvalObjEx returns, trying to eval [exit], something unusual + * is happening. Maybe interp has been deleted; maybe [exit] was + * redefined, maybe we've blown up because of an exceeded limit. We + * still want to cleanup and exit. + */ - Tcl_IncrRefCount(cmd); - Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL); - Tcl_DecrRefCount(cmd); + if (!Tcl_InterpDeleted(interp)) { + Tcl_DeleteInterp(interp); + } } + Tcl_SetStartupScript(NULL, NULL); /* - * If Tcl_EvalObjEx returns, trying to eval [exit], something unusual is - * happening. Maybe interp has been deleted; maybe [exit] was redefined, - * maybe we've blown up because of an exceeded limit. We still want to - * cleanup and exit. + * If we get here, the master interp has been deleted. Allow its + * destruction with the last matching Tcl_Release. */ + Tcl_Release((ClientData) interp); Tcl_Exit(exitCode); } -#if !defined(_WIN32) || defined(UNICODE) - /* *--------------------------------------------------------------- * * Tcl_SetMainLoop -- * * Sets an alternative main loop function. * * Results: - * None. + * Returns the previously defined main loop function. * * Side effects: * This function will be called before Tcl exits, allowing for the * creation of an event loop. * @@ -640,79 +710,12 @@ void Tcl_SetMainLoop( Tcl_MainLoopProc *proc) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - tsdPtr->mainLoopProc = proc; -} - -/* - *--------------------------------------------------------------- - * - * TclGetMainLoop -- - * - * Returns the current alternative main loop function. - * - * Results: - * Returns the previously defined main loop function, or NULL to indicate - * that no such function has been installed and standard tclsh behaviour - * (i.e., exit once the script is evaluated if not interactive) is - * requested.. - * - * Side effects: - * None (other than possible creation of this file's TSD block). - * - *--------------------------------------------------------------- - */ - -Tcl_MainLoopProc * -TclGetMainLoop(void) -{ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - return tsdPtr->mainLoopProc; -} - -/* - *---------------------------------------------------------------------- - * - * TclFullFinalizationRequested -- - * - * This function returns true when either -DPURIFY is specified, or the - * environment variable TCL_FINALIZE_ON_EXIT is set and not "0". This - * predicate is called at places affecting the exit sequence, so that the - * default behavior is a fast and deadlock-free exit, and the modified - * behavior is a more thorough finalization for debugging purposes (leak - * hunting etc). - * - * Results: - * A boolean. - * - *---------------------------------------------------------------------- - */ - -MODULE_SCOPE int -TclFullFinalizationRequested(void) -{ -#ifdef PURIFY - return 1; -#else - const char *fin; - Tcl_DString ds; - int finalize = 0; - - fin = TclGetEnv("TCL_FINALIZE_ON_EXIT", &ds); - finalize = ((fin != NULL) && strcmp(fin, "0")); - if (fin != NULL) { - Tcl_DStringFree(&ds); - } - return finalize; -#endif /* PURIFY */ -} -#endif /* UNICODE */ + mainLoopProc = proc; +} /* *---------------------------------------------------------------------- * * StdinProc -- @@ -729,29 +732,29 @@ * Could be almost arbitrary, depending on the command that's typed. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ static void StdinProc( ClientData clientData, /* The state of interactive cmd line */ - TCL_UNUSED(int) /*mask*/) + int mask) /* Not used. */ { - int code; - size_t length; - InteractiveState *isPtr = (InteractiveState *)clientData; + InteractiveState *isPtr = (InteractiveState *) clientData; Tcl_Channel chan = isPtr->input; Tcl_Obj *commandPtr = isPtr->commandPtr; Tcl_Interp *interp = isPtr->interp; + int code, length; if (Tcl_IsShared(commandPtr)) { Tcl_DecrRefCount(commandPtr); commandPtr = Tcl_DuplicateObj(commandPtr); Tcl_IncrRefCount(commandPtr); } length = Tcl_GetsObj(chan, commandPtr); - if (length == TCL_INDEX_NONE) { + if (length < 0) { if (Tcl_InputBlocked(chan)) { return; } if (isPtr->tty) { /* @@ -760,11 +763,11 @@ * concerns. */ Tcl_Exit(0); } - Tcl_DeleteChannelHandler(chan, StdinProc, isPtr); + Tcl_DeleteChannelHandler(chan, StdinProc, (ClientData) isPtr); return; } if (Tcl_IsShared(commandPtr)) { Tcl_DecrRefCount(commandPtr); @@ -775,57 +778,55 @@ if (!TclObjCommandComplete(commandPtr)) { isPtr->prompt = PROMPT_CONTINUE; goto prompt; } isPtr->prompt = PROMPT_START; - (void)TclGetStringFromObj(commandPtr, &length); + Tcl_GetStringFromObj(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. */ - Tcl_CreateChannelHandler(chan, 0, StdinProc, isPtr); + Tcl_CreateChannelHandler(chan, 0, StdinProc, (ClientData) isPtr); code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL); isPtr->input = chan = Tcl_GetStdChannel(TCL_STDIN); Tcl_DecrRefCount(commandPtr); - TclNewObj(commandPtr); - isPtr->commandPtr = commandPtr; + isPtr->commandPtr = commandPtr = Tcl_NewObj(); Tcl_IncrRefCount(commandPtr); - if (chan != NULL) { - Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc, isPtr); + if (chan != (Tcl_Channel) NULL) { + Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc, + (ClientData) isPtr); } if (code != TCL_OK) { - chan = Tcl_GetStdChannel(TCL_STDERR); - - if (chan != NULL) { - Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); - Tcl_WriteChars(chan, "\n", 1); + Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel != (Tcl_Channel) NULL) { + Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); + Tcl_WriteChars(errChannel, "\n", 1); } } else if (isPtr->tty) { Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); - chan = Tcl_GetStdChannel(TCL_STDOUT); - + Tcl_Channel outChannel = Tcl_GetStdChannel(TCL_STDOUT); Tcl_IncrRefCount(resultPtr); - (void)TclGetStringFromObj(resultPtr, &length); - if ((length > 0) && (chan != NULL)) { - Tcl_WriteObj(chan, resultPtr); - Tcl_WriteChars(chan, "\n", 1); + Tcl_GetStringFromObj(resultPtr, &length); + if ((length >0) && (outChannel != (Tcl_Channel) NULL)) { + Tcl_WriteObj(outChannel, resultPtr); + Tcl_WriteChars(outChannel, "\n", 1); } Tcl_DecrRefCount(resultPtr); } /* * If a tty stdin is still around, output a prompt. */ prompt: - if (isPtr->tty && (isPtr->input != NULL)) { - Prompt(interp, isPtr); + if (isPtr->tty && (isPtr->input != (Tcl_Channel) NULL)) { + Prompt(interp, &(isPtr->prompt)); isPtr->input = Tcl_GetStdChannel(TCL_STDIN); } } /* @@ -846,86 +847,60 @@ */ static void Prompt( Tcl_Interp *interp, /* Interpreter to use for prompting. */ - InteractiveState *isPtr) /* InteractiveState. Filled with PROMPT_NONE - * after a prompt is printed. */ + PromptType *promptPtr) /* Points to type of prompt to print. Filled + * with PROMPT_NONE after a prompt is + * printed. */ { Tcl_Obj *promptCmdPtr; int code; - Tcl_Channel chan; + Tcl_Channel outChannel, errChannel; - if (isPtr->prompt == PROMPT_NONE) { + if (*promptPtr == PROMPT_NONE) { return; } promptCmdPtr = Tcl_GetVar2Ex(interp, - (isPtr->prompt==PROMPT_CONTINUE ? "tcl_prompt2" : "tcl_prompt1"), + ((*promptPtr == PROMPT_CONTINUE) ? "tcl_prompt2" : "tcl_prompt1"), NULL, TCL_GLOBAL_ONLY); if (Tcl_InterpDeleted(interp)) { return; } if (promptCmdPtr == NULL) { defaultPrompt: - if (isPtr->prompt == PROMPT_START) { - chan = Tcl_GetStdChannel(TCL_STDOUT); - if (chan != NULL) { - Tcl_WriteChars(chan, DEFAULT_PRIMARY_PROMPT, - strlen(DEFAULT_PRIMARY_PROMPT)); - } + outChannel = Tcl_GetStdChannel(TCL_STDOUT); + if ((*promptPtr == PROMPT_START) + && (outChannel != (Tcl_Channel) NULL)) { + Tcl_WriteChars(outChannel, DEFAULT_PRIMARY_PROMPT, + strlen(DEFAULT_PRIMARY_PROMPT)); } } else { code = Tcl_EvalObjEx(interp, promptCmdPtr, TCL_EVAL_GLOBAL); if (code != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (script that generates prompt)"); - chan = Tcl_GetStdChannel(TCL_STDERR); - if (chan != NULL) { - Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); - Tcl_WriteChars(chan, "\n", 1); + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel != (Tcl_Channel) NULL) { + Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); + Tcl_WriteChars(errChannel, "\n", 1); } goto defaultPrompt; } } - chan = Tcl_GetStdChannel(TCL_STDOUT); - if (chan != NULL) { - Tcl_Flush(chan); - } - isPtr->prompt = PROMPT_NONE; -} - -/* - *---------------------------------------------------------------------- - * - * FreeMainInterp -- - * - * Exit handler used to cleanup the main interpreter and ancillary - * startup script storage at exit. - * - *---------------------------------------------------------------------- - */ - -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); - Tcl_Release(interp); + outChannel = Tcl_GetStdChannel(TCL_STDOUT); + if (outChannel != (Tcl_Channel) NULL) { + Tcl_Flush(outChannel); + } + *promptPtr = PROMPT_NONE; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclNamesp.c ================================================================== --- generic/tclNamesp.c +++ generic/tclNamesp.c @@ -3,11 +3,12 @@ * * Contains support for namespaces, which provide a separate context of * commands and global variables. The global :: namespace is the * traditional Tcl "global" scope. Other namespaces are created as * children of the global namespace. These other namespaces contain - * special-purpose commands and variables for packages. + * special-purpose commands and variables for packages. Also includes the + * TIP#112 ensemble machinery. * * Copyright (c) 1993-1997 Lucent Technologies. * Copyright (c) 1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2002-2005 Donal K. Fellows. @@ -22,20 +23,18 @@ * 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" /* for TclLogCommandInfo visibility */ -#include /* * Thread-local storage used to avoid having a global lock on data that is not * limited to a single interpreter. */ -typedef struct { - size_t numNsCreated; /* Count of the number of namespaces created +typedef struct ThreadSpecificData { + 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, @@ -51,24 +50,100 @@ * 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 { - 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 +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. */ + int refCount; /* Reference count: 1 for each nsName object * that has a pointer to this ResolvedNsName * structure as its internal rep. This * structure can be freed when refCount * becomes zero. */ } ResolvedNsName; +/* + * The client data for an ensemble command. This consists of the table of + * commands that are actually exported by the namespace, and an epoch counter + * that, combined with the exportLookupEpoch field of the namespace structure, + * defines whether the table contains valid data or will need to be recomputed + * next time the ensemble command is called. + */ + +typedef struct EnsembleConfig { + Namespace *nsPtr; /* The namspace 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.) */ + 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, + * which are its keys so this also provides + * the storage management for those subcommand + * names. The contents of the entry values are + * object version the prefix lists to use when + * substituting for the command/subcommand to + * build the ensemble implementation command. + * Has to be stored here as well as in + * subcommandDict because that field is NULL + * when we are deriving the ensemble from the + * namespace exports list. FUTURE WORK: use + * object hash table here. */ + struct EnsembleConfig *next;/* The next ensemble in the linked list of + * ensembles associated with a namespace. If + * this field points to this ensemble, the + * structure has already been unlinked from + * all lists, and cannot be found by scanning + * the list from the namespace's ensemble + * field. */ + int flags; /* ORed combo of TCL_ENSEMBLE_PREFIX, ENS_DEAD + * and ENSEMBLE_COMPILE. */ + + /* OBJECT FIELDS FOR ENSEMBLE CONFIGURATION */ + + Tcl_Obj *subcommandDict; /* Dictionary providing mapping from + * subcommands to their implementing command + * prefixes, or NULL if we are to build the + * map automatically from the namespace + * exports. */ + Tcl_Obj *subcmdList; /* List of commands that this ensemble + * actually provides, and whose implementation + * will be built using the subcommandDict (if + * present and defined) and by simple mapping + * to the namespace otherwise. If NULL, + * indicates that we are using the (dynamic) + * list of currently exported commands. */ + Tcl_Obj *unknownHandler; /* Script prefix used to handle the case when + * no match is found (according to the rule + * defined by flag bit TCL_ENSEMBLE_PREFIX) or + * NULL to use the default error-generating + * behaviour. The script execution gets all + * the arguments to the ensemble command + * (including objv[0]) and will have the + * results passed directly back to the caller + * (including the error code) unless the code + * is TCL_CONTINUE in which case the + * subcommand will be reparsed by the ensemble + * core, presumably because the ensemble + * itself has been updated. */ +} EnsembleConfig; + +#define ENS_DEAD 0x1 /* Flag value to say that the ensemble is dead + * and on its way out. */ + /* * Declarations for functions local to this file: */ static void DeleteImportedCmd(ClientData clientData); @@ -88,95 +163,95 @@ 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, +static int InvokeImportedCmd(ClientData clientData, + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); +static int NamespaceChildrenCmd(ClientData dummy, + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); +static int NamespaceCodeCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int NamespaceCurrentCmd(ClientData dummy, + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); +static int NamespaceDeleteCmd(ClientData dummy,Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int NamespaceEnsembleCmd(ClientData dummy, 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 int NamespaceEvalCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int NamespaceExistsCmd(ClientData dummy,Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int NamespaceExportCmd(ClientData dummy,Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int NamespaceForgetCmd(ClientData dummy,Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); 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 NamespaceImportCmd(ClientData dummy,Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int NamespaceInscopeCmd(ClientData dummy, + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); +static int NamespaceOriginCmd(ClientData dummy,Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int NamespaceParentCmd(ClientData dummy,Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int NamespacePathCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int NamespaceQualifiersCmd(ClientData dummy, + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); +static int NamespaceTailCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int NamespaceUpvarCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int NamespaceUnknownCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int NamespaceWhichCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); static int SetNsNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +static int NsEnsembleImplementationCmd(ClientData clientData, + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); +static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr); +static int NsEnsembleStringOrder(const void *strPtr1, + const void *strPtr2); +static void DeleteEnsembleConfig(ClientData clientData); +static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr, + EnsembleConfig *ensemblePtr, + const char *subcmdName, Tcl_Obj *prefixObjPtr); +static void FreeEnsembleCmdRep(Tcl_Obj *objPtr); +static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); +static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr); static void UnlinkNsPath(Namespace *nsPtr); -static Tcl_NRPostProc NsEval_Callback; - /* * This structure defines a Tcl object type that contains a namespace * reference. It is used in commands that take the name of a namespace as an * argument. The namespace reference is resolved, and the result in cached in * the object. */ -static const Tcl_ObjType nsNameType = { +static Tcl_ObjType nsNameType = { "nsName", /* the type's name */ FreeNsNameInternalRep, /* freeIntRepProc */ DupNsNameInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ SetNsNameFromAny /* setFromAnyProc */ }; -#define NsNameSetIntRep(objPtr, nnPtr) \ - do { \ - Tcl_ObjIntRep ir; \ - (nnPtr)->refCount++; \ - ir.twoPtrValue.ptr1 = (nnPtr); \ - ir.twoPtrValue.ptr2 = NULL; \ - 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. + * This structure defines a Tcl object type that contains a reference to an + * ensemble subcommand (e.g. the "length" in [string length ab]). It is used + * to cache the mapping between the subcommand itself and the real command + * that implements it. */ -static const EnsembleImplMap defaultNamespaceMap[] = { - {"children", NamespaceChildrenCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 0}, - {"code", NamespaceCodeCmd, TclCompileNamespaceCodeCmd, NULL, NULL, 0}, - {"current", NamespaceCurrentCmd, TclCompileNamespaceCurrentCmd, NULL, NULL, 0}, - {"delete", NamespaceDeleteCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, - {"ensemble", TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0}, - {"eval", NamespaceEvalCmd, NULL, NRNamespaceEvalCmd, NULL, 0}, - {"exists", NamespaceExistsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"export", NamespaceExportCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, - {"forget", NamespaceForgetCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, - {"import", NamespaceImportCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, - {"inscope", NamespaceInscopeCmd, NULL, NRNamespaceInscopeCmd, NULL, 0}, - {"origin", NamespaceOriginCmd, TclCompileNamespaceOriginCmd, NULL, NULL, 0}, - {"parent", NamespaceParentCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"path", NamespacePathCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"qualifiers", NamespaceQualifiersCmd, TclCompileNamespaceQualifiersCmd, NULL, NULL, 0}, - {"tail", NamespaceTailCmd, TclCompileNamespaceTailCmd, NULL, NULL, 0}, - {"unknown", NamespaceUnknownCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"upvar", NamespaceUpvarCmd, TclCompileNamespaceUpvarCmd, NULL, NULL, 0}, - {"which", NamespaceWhichCmd, TclCompileNamespaceWhichCmd, NULL, NULL, 0}, - {NULL, NULL, NULL, NULL, NULL, 0} +Tcl_ObjType tclEnsembleCmdType = { + "ensembleCommand", /* the type's name */ + FreeEnsembleCmdRep, /* freeIntRepProc */ + DupEnsembleCmdRep, /* dupIntRepProc */ + StringOfEnsembleCmdRep, /* updateStringProc */ + NULL /* setFromAnyProc */ }; /* *---------------------------------------------------------------------- * @@ -218,11 +293,11 @@ *---------------------------------------------------------------------- */ Tcl_Namespace * Tcl_GetCurrentNamespace( - Tcl_Interp *interp)/* Interpreter whose current namespace is + register Tcl_Interp *interp)/* Interpreter whose current namespace is * being queried. */ { return TclGetCurrentNamespace(interp); } @@ -242,11 +317,11 @@ *---------------------------------------------------------------------- */ Tcl_Namespace * Tcl_GetGlobalNamespace( - Tcl_Interp *interp)/* Interpreter whose global namespace should + register Tcl_Interp *interp)/* Interpreter whose global namespace should * be returned. */ { return TclGetGlobalNamespace(interp); } @@ -294,12 +369,12 @@ * inscope" command and var references are * treated as references to namespace * variables. */ { Interp *iPtr = (Interp *) interp; - CallFrame *framePtr = (CallFrame *) callFramePtr; - Namespace *nsPtr; + register CallFrame *framePtr = (CallFrame *) callFramePtr; + register Namespace *nsPtr; if (namespacePtr == NULL) { nsPtr = (Namespace *) TclGetCurrentNamespace(interp); } else { nsPtr = (Namespace *) namespacePtr; @@ -313,10 +388,11 @@ * Review of those designs might permit stricter checking here. */ if (nsPtr->flags & NS_DEAD) { Tcl_Panic("Trying to push call frame for dead namespace"); + /*NOTREACHED*/ } } nsPtr->activationCount++; framePtr->nsPtr = nsPtr; @@ -334,20 +410,18 @@ framePtr->varTablePtr = NULL; /* and no local variables */ framePtr->numCompiledLocals = 0; framePtr->compiledLocals = NULL; framePtr->clientData = NULL; framePtr->localCachePtr = NULL; - framePtr->tailcallPtr = NULL; /* * Push the new call frame onto the interpreter's stack of procedure call * frames making it the current frame. */ iPtr->framePtr = framePtr; iPtr->varFramePtr = framePtr; - return TCL_OK; } /* *---------------------------------------------------------------------- @@ -370,12 +444,12 @@ void Tcl_PopCallFrame( Tcl_Interp *interp) /* Interpreter with call frame to pop. */ { - Interp *iPtr = (Interp *) interp; - CallFrame *framePtr = iPtr->framePtr; + register Interp *iPtr = (Interp *) interp; + register 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 @@ -389,16 +463,16 @@ /* Tcl_PopCallFrame: trying to pop rootCallFrame! */ } if (framePtr->varTablePtr != NULL) { TclDeleteVars(iPtr, framePtr->varTablePtr); - Tcl_Free(framePtr->varTablePtr); + ckfree((char *) framePtr->varTablePtr); framePtr->varTablePtr = NULL; } if (framePtr->numCompiledLocals > 0) { TclDeleteCompiledLocalVars(iPtr, framePtr); - if (framePtr->localCachePtr->refCount-- <= 1) { + if (--framePtr->localCachePtr->refCount == 0) { TclFreeLocalCache(interp, framePtr->localCachePtr); } framePtr->localCachePtr = NULL; } @@ -407,19 +481,16 @@ * is "dying" and there are no more active call frames, call * Tcl_DeleteNamespace to destroy it. */ nsPtr = framePtr->nsPtr; - if ((--nsPtr->activationCount <= (unsigned)(nsPtr == iPtr->globalNsPtr)) - && (nsPtr->flags & NS_DYING)) { + 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); - } } /* *---------------------------------------------------------------------- * @@ -456,20 +527,20 @@ * 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)); + *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. */ { - CallFrame *freePtr = ((Interp *) interp)->framePtr; + CallFrame *freePtr = ((Interp *)interp)->framePtr; Tcl_PopCallFrame(interp); TclStackFree(interp, freePtr); } @@ -490,19 +561,19 @@ *---------------------------------------------------------------------- */ static char * EstablishErrorCodeTraces( - TCL_UNUSED(ClientData), + ClientData clientData, Tcl_Interp *interp, - TCL_UNUSED(const char *) /*name1*/, - TCL_UNUSED(const char *) /*name2*/, - TCL_UNUSED(int) /*flags*/) + const char *name1, + const char *name2, + int flags) { - Tcl_TraceVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS, + Tcl_TraceVar(interp, "errorCode", TCL_GLOBAL_ONLY | TCL_TRACE_READS, ErrorCodeRead, NULL); - Tcl_TraceVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_UNSETS, + Tcl_TraceVar(interp, "errorCode", TCL_GLOBAL_ONLY | TCL_TRACE_UNSETS, EstablishErrorCodeTraces, NULL); return NULL; } /* @@ -522,17 +593,17 @@ *---------------------------------------------------------------------- */ static char * ErrorCodeRead( - TCL_UNUSED(ClientData), + ClientData clientData, Tcl_Interp *interp, - TCL_UNUSED(const char *) /*name1*/, - TCL_UNUSED(const char *) /*name2*/, - TCL_UNUSED(int) /*flags*/) + const char *name1, + const char *name2, + int flags) { - Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *)interp; if (Tcl_InterpDeleted(interp) || !(iPtr->flags & ERR_LEGACY_COPY)) { return NULL; } if (iPtr->errorCode) { @@ -564,19 +635,19 @@ *---------------------------------------------------------------------- */ static char * EstablishErrorInfoTraces( - TCL_UNUSED(ClientData), + ClientData clientData, Tcl_Interp *interp, - TCL_UNUSED(const char *) /*name1*/, - TCL_UNUSED(const char *) /*name2*/, - TCL_UNUSED(int) /*flags*/) + const char *name1, + const char *name2, + int flags) { - Tcl_TraceVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS, + Tcl_TraceVar(interp, "errorInfo", TCL_GLOBAL_ONLY | TCL_TRACE_READS, ErrorInfoRead, NULL); - Tcl_TraceVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_UNSETS, + Tcl_TraceVar(interp, "errorInfo", TCL_GLOBAL_ONLY | TCL_TRACE_UNSETS, EstablishErrorInfoTraces, NULL); return NULL; } /* @@ -596,15 +667,15 @@ *---------------------------------------------------------------------- */ static char * ErrorInfoRead( - TCL_UNUSED(ClientData), + ClientData clientData, Tcl_Interp *interp, - TCL_UNUSED(const char *) /*name1*/, - TCL_UNUSED(const char *) /*name2*/, - TCL_UNUSED(int) /*flags*/) + const char *name1, + const char *name2, + int flags) { Interp *iPtr = (Interp *) interp; if (Tcl_InterpDeleted(interp) || !(iPtr->flags & ERR_LEGACY_COPY)) { return NULL; @@ -655,19 +726,18 @@ /* 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; + register 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; - size_t nameLen; + int newEntry, nameLen; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); const char *nameStr; Tcl_DString tmpBuffer; Tcl_DStringInit(&tmpBuffer); @@ -709,14 +779,13 @@ * the global namespace despite the global namespace existing. That's * naughty! */ if (*name == '\0') { - Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create namespace" - " \"\": only global namespace can have empty name", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", - "CREATEGLOBAL", NULL); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "can't create namespace \"\": " + "only global namespace can have empty name", NULL); Tcl_DStringFree(&tmpBuffer); return NULL; } /* @@ -740,22 +809,13 @@ /* * Check for a bad namespace name and make sure that the name does not * already exist in the parent namespace. */ - if ( -#ifndef BREAK_NAMESPACE_COMPAT - Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL -#else - parentPtr->childTablePtr != NULL && - Tcl_FindHashEntry(parentPtr->childTablePtr, simpleName) != NULL -#endif - ) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create namespace \"%s\": already exists", name)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", - "CREATEEXISTING", NULL); + if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) { + Tcl_AppendResult(interp, "can't create namespace \"", name, + "\": already exists", NULL); Tcl_DStringFree(&tmpBuffer); return NULL; } /* @@ -762,23 +822,18 @@ * Create the new namespace and root it in its parent. Increment the count * of namespaces created. */ doCreate: - nsPtr = (Namespace *)Tcl_Alloc(sizeof(Namespace)); - nameLen = strlen(simpleName) + 1; - nsPtr->name = (char *)Tcl_Alloc(nameLen); - memcpy(nsPtr->name, simpleName, nameLen); + nsPtr = (Namespace *) ckalloc(sizeof(Namespace)); + nsPtr->name = ckalloc((unsigned) (strlen(simpleName)+1)); + strcpy(nsPtr->name, simpleName); 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); -#else - nsPtr->childTablePtr = NULL; -#endif nsPtr->nsId = ++(tsdPtr->numNsCreated); nsPtr->interp = interp; nsPtr->flags = 0; nsPtr->activationCount = 0; nsPtr->refCount = 0; @@ -796,16 +851,14 @@ nsPtr->ensembles = NULL; nsPtr->unknownHandlerPtr = NULL; nsPtr->commandPathLength = 0; nsPtr->commandPathArray = NULL; nsPtr->commandPathSourceList = NULL; - nsPtr->earlyDeleteProc = NULL; if (parentPtr != NULL) { - entryPtr = Tcl_CreateHashEntry( - TclGetNamespaceChildTable((Tcl_Namespace *) parentPtr), - simpleName, &newEntry); + entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName, + &newEntry); Tcl_SetHashValue(entryPtr, nsPtr); } else { /* * In the global namespace create traces to maintain the ::errorInfo * and ::errorCode variables. @@ -825,23 +878,24 @@ namePtr = &buffer1; buffPtr = &buffer2; for (ancestorPtr = nsPtr; ancestorPtr != NULL; ancestorPtr = ancestorPtr->parentPtr) { if (ancestorPtr != globalNsPtr) { - Tcl_DString *tempPtr = namePtr; + register Tcl_DString *tempPtr = namePtr; - TclDStringAppendLiteral(buffPtr, "::"); + Tcl_DStringAppend(buffPtr, "::", 2); Tcl_DStringAppend(buffPtr, ancestorPtr->name, -1); - TclDStringAppendDString(buffPtr, namePtr); + Tcl_DStringAppend(buffPtr, Tcl_DStringValue(namePtr), + Tcl_DStringLength(namePtr)); /* * Clear the unwanted buffer or we end up appending to previous * results, making the namespace fullNames of nested namespaces * very wrong (and strange). */ - TclDStringClear(namePtr); + Tcl_DStringSetLength(namePtr, 0); /* * Now swap the buffer pointers so that we build in the other * buffer. This is faster than repeated copying back and forth * between buffers. @@ -852,27 +906,17 @@ } } name = Tcl_DStringValue(namePtr); nameLen = Tcl_DStringLength(namePtr); - nsPtr->fullName = (char *)Tcl_Alloc(nameLen + 1); - memcpy(nsPtr->fullName, name, nameLen + 1); + nsPtr->fullName = ckalloc((unsigned) (nameLen+1)); + memcpy(nsPtr->fullName, name, (unsigned) nameLen + 1); Tcl_DStringFree(&buffer1); Tcl_DStringFree(&buffer2); Tcl_DStringFree(&tmpBuffer); - /* - * If compilation of commands originating from the parent NS is - * suppressed, suppress it for commands originating in this one too. - */ - - if (nsPtr->parentPtr != NULL && - nsPtr->parentPtr->flags & NS_SUPPRESS_COMPILATION) { - nsPtr->flags |= NS_SUPPRESS_COMPILATION; - } - /* * Return a pointer to the new namespace. */ return (Tcl_Namespace *) nsPtr; @@ -899,64 +943,15 @@ void Tcl_DeleteNamespace( Tcl_Namespace *namespacePtr)/* Points to the namespace to delete. */ { - Namespace *nsPtr = (Namespace *) namespacePtr; + register Namespace *nsPtr = (Namespace *) namespacePtr; Interp *iPtr = (Interp *) nsPtr->interp; Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace((Tcl_Interp *) iPtr); Tcl_HashEntry *entryPtr; - Tcl_HashSearch search; - Command *cmdPtr; - - /* - * Ensure that this namespace doesn't get deallocated in the meantime. - */ - nsPtr->refCount++; - - /* - * Give anyone interested - notably TclOO - a chance to use this namespace - * normally despite the fact that the namespace is going to go. Allows the - * calling of destructors. Will only be called once (unless re-established - * by the called function). [Bug 2950259] - * - * Note that setting this field requires access to the internal definition - * of namespaces, so it should only be accessed by code that knows about - * being careful with reentrancy. - */ - - if (nsPtr->earlyDeleteProc != NULL) { - Tcl_NamespaceDeleteProc *earlyDeleteProc = nsPtr->earlyDeleteProc; - - nsPtr->earlyDeleteProc = NULL; - nsPtr->activationCount++; - earlyDeleteProc(nsPtr->clientData); - nsPtr->activationCount--; - } - - /* - * Delete all coroutine commands now: break the circular ref cycle between - * the namespace and the coroutine command [Bug 2724403]. This code is - * essentially duplicated in TclTeardownNamespace() for all other - * commands. Don't optimize to Tcl_NextHashEntry() because of traces. - * - * 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); - } - } /* * If the namespace has associated ensemble commands, delete them first. * This leaves the actual contents of the namespace alone (unless they are * linked ensemble commands, of course). Note that this code is actually @@ -1000,16 +995,15 @@ * 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 > (unsigned)(nsPtr == globalNsPtr)) { + if (nsPtr->activationCount - (nsPtr == globalNsPtr) > 0) { nsPtr->flags |= NS_DYING; if (nsPtr->parentPtr != NULL) { - entryPtr = Tcl_FindHashEntry( - TclGetNamespaceChildTable((Tcl_Namespace *) - nsPtr->parentPtr), nsPtr->name); + entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable, + nsPtr->name); if (entryPtr != NULL) { Tcl_DeleteHashEntry(entryPtr); } } nsPtr->parentPtr = NULL; @@ -1034,21 +1028,23 @@ * one last time. */ TclDeleteNamespaceVars(nsPtr); -#ifndef BREAK_NAMESPACE_COMPAT Tcl_DeleteHashTable(&nsPtr->childTable); -#else - if (nsPtr->childTablePtr != NULL) { - Tcl_DeleteHashTable(nsPtr->childTablePtr); - Tcl_Free(nsPtr->childTablePtr); - } -#endif Tcl_DeleteHashTable(&nsPtr->cmdTable); - nsPtr ->flags |= NS_DEAD; + /* + * If the reference count is 0, then discard the namespace. + * Otherwise, mark it as "dead" so that it can't be used. + */ + + if (nsPtr->refCount == 0) { + NamespaceFree(nsPtr); + } else { + nsPtr->flags |= NS_DEAD; + } } else { /* * Restore the ::errorInfo and ::errorCode traces. */ @@ -1061,11 +1057,10 @@ */ nsPtr->flags &= ~(NS_DYING|NS_KILLED); } } - TclNsDecrRefCount(nsPtr); } int TclNamespaceDeleted( Namespace *nsPtr) @@ -1095,17 +1090,19 @@ *---------------------------------------------------------------------- */ void TclTeardownNamespace( - Namespace *nsPtr) /* Points to the namespace to be dismantled + register Namespace *nsPtr) /* Points to the namespace to be dismantled * and unlinked from its parent. */ { Interp *iPtr = (Interp *) nsPtr->interp; - Tcl_HashEntry *entryPtr; + register Tcl_HashEntry *entryPtr; Tcl_HashSearch search; - size_t i; + Tcl_Namespace *childNsPtr; + Tcl_Command cmd; + 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. @@ -1115,47 +1112,31 @@ 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. + * command table. + * + * Don't optimize to Tcl_NextHashEntry() because of traces. */ - while (nsPtr->cmdTable.numEntries > 0) { - size_t 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]); - } - TclStackFree((Tcl_Interp *) iPtr, cmds); + for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + entryPtr != NULL; + entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) { + cmd = Tcl_GetHashValue(entryPtr); + Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, cmd); } Tcl_DeleteHashTable(&nsPtr->cmdTable); Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS); /* * Remove the namespace from its parent's child hashtable. */ if (nsPtr->parentPtr != NULL) { - entryPtr = Tcl_FindHashEntry( - TclGetNamespaceChildTable((Tcl_Namespace *) - nsPtr->parentPtr), nsPtr->name); + entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable, + nsPtr->name); if (entryPtr != NULL) { Tcl_DeleteHashEntry(entryPtr); } } nsPtr->parentPtr = NULL; @@ -1168,11 +1149,10 @@ UnlinkNsPath(nsPtr); nsPtr->commandPathLength = 0; } if (nsPtr->commandPathSourceList != NULL) { NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList; - do { if (nsPathPtr->nsPtr != NULL && nsPathPtr->creatorNsPtr != NULL) { nsPathPtr->creatorNsPtr->cmdRefEpoch++; } nsPathPtr->nsPtr = NULL; @@ -1184,71 +1164,31 @@ /* * Delete all the child namespaces. * * BE CAREFUL: When each child is deleted, it will divorce itself from its * parent. You can't traverse a hash table properly if its elements are - * being deleted. Because of traces (and the desire to avoid the - * quadratic problems of just using Tcl_FirstHashEntry over and over, [Bug - * f97d4ee020]) we copy to a temporary array and then delete all those - * namespaces. - * - * Important: leave the hash table itself still live. - */ - -#ifndef BREAK_NAMESPACE_COMPAT - while (nsPtr->childTable.numEntries > 0) { - size_t 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) { - size_t 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); - children[i]->refCount++; - i++; - } - for (i = 0 ; i < length ; i++) { - Tcl_DeleteNamespace((Tcl_Namespace *) children[i]); - TclNsDecrRefCount(children[i]); - } - TclStackFree((Tcl_Interp *) iPtr, children); - } - } -#endif + * being deleted. We use only the Tcl_FirstHashEntry function to be safe. + * + * Don't optimize to Tcl_NextHashEntry() because of traces. + */ + + for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); + entryPtr != NULL; + entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) { + childNsPtr = Tcl_GetHashValue(entryPtr); + Tcl_DeleteNamespace(childNsPtr); + } /* * Free the namespace's export pattern array. */ if (nsPtr->exportArrayPtr != NULL) { for (i = 0; i < nsPtr->numExportPatterns; i++) { - Tcl_Free(nsPtr->exportArrayPtr[i]); + ckfree(nsPtr->exportArrayPtr[i]); } - Tcl_Free(nsPtr->exportArrayPtr); + ckfree((char *) nsPtr->exportArrayPtr); nsPtr->exportArrayPtr = NULL; nsPtr->numExportPatterns = 0; nsPtr->maxExportPatterns = 0; } @@ -1255,11 +1195,11 @@ /* * Free any client data associated with the namespace. */ if (nsPtr->deleteProc != NULL) { - nsPtr->deleteProc(nsPtr->clientData); + (*nsPtr->deleteProc)(nsPtr->clientData); } nsPtr->deleteProc = NULL; nsPtr->clientData = NULL; /* @@ -1288,46 +1228,48 @@ *---------------------------------------------------------------------- */ static void NamespaceFree( - Namespace *nsPtr) /* Points to the namespace to free. */ + register 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. */ - Tcl_Free(nsPtr->name); - Tcl_Free(nsPtr->fullName); - Tcl_Free(nsPtr); + ckfree(nsPtr->name); + ckfree(nsPtr->fullName); + + ckfree((char *) nsPtr); } /* *---------------------------------------------------------------------- * * TclNsDecrRefCount -- * - * Drops a reference to a namespace and frees it if the namespace has - * been deleted and the last reference has just been dropped. + * Drops a reference to a namespace and frees it if the namespace has + * been deleted and the last reference has just been dropped. * * Results: - * None. + * None. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ void TclNsDecrRefCount( Namespace *nsPtr) { - if ((nsPtr->refCount-- <= 1) && (nsPtr->flags & NS_DEAD)) { - NamespaceFree(nsPtr); + nsPtr->refCount--; + if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) { + NamespaceFree(nsPtr); } } /* *---------------------------------------------------------------------- @@ -1367,11 +1309,11 @@ #define INIT_EXPORT_PATTERNS 5 Namespace *nsPtr, *exportNsPtr, *dummyPtr; Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); const char *simplePattern; char *patternCpy; - size_t neededElems, len, i; + int neededElems, len, i; /* * If the specified namespace is NULL, use the current namespace. */ @@ -1387,13 +1329,13 @@ */ if (resetListFirst) { if (nsPtr->exportArrayPtr != NULL) { for (i = 0; i < nsPtr->numExportPatterns; i++) { - Tcl_Free(nsPtr->exportArrayPtr[i]); + ckfree(nsPtr->exportArrayPtr[i]); } - Tcl_Free(nsPtr->exportArrayPtr); + ckfree((char *) nsPtr->exportArrayPtr); nsPtr->exportArrayPtr = NULL; TclInvalidateNsCmdLookup(nsPtr); nsPtr->numExportPatterns = 0; nsPtr->maxExportPatterns = 0; } @@ -1405,13 +1347,12 @@ TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY, &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf("invalid export pattern" - " \"%s\": pattern can't specify a namespace", pattern)); - Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL); + Tcl_AppendResult(interp, "invalid export pattern \"", pattern, + "\": pattern can't specify a namespace", NULL); return TCL_ERROR; } /* * Make sure that we don't already have the pattern in the array @@ -1436,21 +1377,22 @@ neededElems = nsPtr->numExportPatterns + 1; if (neededElems > nsPtr->maxExportPatterns) { nsPtr->maxExportPatterns = nsPtr->maxExportPatterns ? 2 * nsPtr->maxExportPatterns : INIT_EXPORT_PATTERNS; - nsPtr->exportArrayPtr = (char **)Tcl_Realloc(nsPtr->exportArrayPtr, + nsPtr->exportArrayPtr = (char **) + ckrealloc((char *) nsPtr->exportArrayPtr, sizeof(char *) * nsPtr->maxExportPatterns); } /* * Add the pattern to the namespace's array of export patterns. */ len = strlen(pattern); - patternCpy = (char *)Tcl_Alloc(len + 1); - memcpy(patternCpy, pattern, len + 1); + patternCpy = ckalloc((unsigned) (len + 1)); + memcpy(patternCpy, pattern, (unsigned) len + 1); nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy; nsPtr->numExportPatterns++; /* @@ -1494,12 +1436,11 @@ * for the current namespace. */ Tcl_Obj *objPtr) /* Points to the Tcl object onto which the * export pattern list is appended. */ { Namespace *nsPtr; - size_t i; - int result; + int i, result; /* * If the specified namespace is NULL, use the current namespace. */ @@ -1564,11 +1505,11 @@ * return an error if an imported cmd * conflicts with an existing one. */ { Namespace *nsPtr, *importNsPtr, *dummyPtr; const char *simplePattern; - Tcl_HashEntry *hPtr; + register Tcl_HashEntry *hPtr; Tcl_HashSearch search; /* * If the specified namespace is NULL, use the current namespace. */ @@ -1612,34 +1553,31 @@ * From the pattern, find the namespace from which we are importing and * get the simple pattern (no namespace qualifiers or ::'s) at the end. */ if (strlen(pattern) == 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern",-1)); - Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern", -1)); return TCL_ERROR; } TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY, &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (importNsPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown namespace in import pattern \"%s\"", pattern)); + Tcl_AppendResult(interp, "unknown namespace in import pattern \"", + pattern, "\"", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL); return TCL_ERROR; } if (importNsPtr == nsPtr) { if (pattern == simplePattern) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "no namespace specified in import pattern \"%s\"", - pattern)); - Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL); + Tcl_AppendResult(interp, + "no namespace specified in import pattern \"", pattern, + "\"", NULL); } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "import pattern \"%s\" tries to import from namespace" - " \"%s\" into itself", pattern, importNsPtr->name)); - Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL); + Tcl_AppendResult(interp, "import pattern \"", pattern, + "\" tries to import from namespace \"", + importNsPtr->name, "\" into itself", NULL); } return TCL_ERROR; } /* @@ -1657,12 +1595,11 @@ 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); - + char *cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr); if (Tcl_StringMatch(cmdName, simplePattern) && DoImport(interp, nsPtr, hPtr, cmdName, pattern, importNsPtr, allowOverwrite) == TCL_ERROR) { return TCL_ERROR; } @@ -1697,21 +1634,20 @@ const char *cmdName, const char *pattern, Namespace *importNsPtr, int allowOverwrite) { - size_t i = 0, exported = 0; + 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. */ while (!exported && (i < importNsPtr->numExportPatterns)) { - exported |= Tcl_StringMatch(cmdName, - importNsPtr->exportArrayPtr[i++]); + exported |= Tcl_StringMatch(cmdName, importNsPtr->exportArrayPtr[i++]); } if (!exported) { return TCL_OK; } @@ -1735,76 +1671,71 @@ ImportRef *refPtr; Tcl_DStringInit(&ds); Tcl_DStringAppend(&ds, nsPtr->fullName, -1); if (nsPtr != ((Interp *) interp)->globalNsPtr) { - TclDStringAppendLiteral(&ds, "::"); + Tcl_DStringAppend(&ds, "::", 2); } 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); + cmdPtr = 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))); + Command *overwrite = Tcl_GetHashValue(found); + Command *link = cmdPtr; + + while (link->deleteProc == DeleteImportedCmd) { + ImportedCmdData *dataPtr = link->objClientData; + + link = dataPtr->realCmdPtr; + if (overwrite == link) { + Tcl_AppendResult(interp, "import pattern \"", pattern, + "\" would create a loop containing command \"", + Tcl_DStringValue(&ds), "\"", NULL); Tcl_DStringFree(&ds); - Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL); return TCL_ERROR; } } } - dataPtr = (ImportedCmdData *)Tcl_Alloc(sizeof(ImportedCmdData)); - importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), - TclInvokeImportedCmd, InvokeImportedNRCmd, dataPtr, - DeleteImportedCmd); + dataPtr = (ImportedCmdData *) ckalloc(sizeof(ImportedCmdData)); + importedCmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), + InvokeImportedCmd, dataPtr, DeleteImportedCmd); dataPtr->realCmdPtr = cmdPtr; - /* corresponding decrement is in DeleteImportedCmd */ - cmdPtr->refCount++; dataPtr->selfPtr = (Command *) importedCmd; dataPtr->selfPtr->compileProc = cmdPtr->compileProc; Tcl_DStringFree(&ds); /* * Create an ImportRef structure describing this new import command * and add it to the import ref list in the "real" command. */ - refPtr = (ImportRef *)Tcl_Alloc(sizeof(ImportRef)); + refPtr = (ImportRef *) ckalloc(sizeof(ImportRef)); refPtr->importedCmdPtr = (Command *) importedCmd; refPtr->nextPtr = cmdPtr->importRefPtr; cmdPtr->importRefPtr = refPtr; } else { - Command *overwrite = (Command *)Tcl_GetHashValue(found); + Command *overwrite = Tcl_GetHashValue(found); if (overwrite->deleteProc == DeleteImportedCmd) { - ImportedCmdData *dataPtr = (ImportedCmdData *)overwrite->objClientData; + ImportedCmdData *dataPtr = overwrite->objClientData; if (dataPtr->realCmdPtr == Tcl_GetHashValue(hPtr)) { /* * Repeated import of same command is acceptable. */ return TCL_OK; } } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't import command \"%s\": already exists", cmdName)); - Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL); + Tcl_AppendResult(interp, "can't import command \"", cmdName, + "\": already exists", NULL); return TCL_ERROR; } return TCL_OK; } @@ -1845,11 +1776,11 @@ * commands to remove. */ { Namespace *nsPtr, *sourceNsPtr, *dummyPtr; const char *simplePattern; char *cmdName; - Tcl_HashEntry *hPtr; + register Tcl_HashEntry *hPtr; Tcl_HashSearch search; /* * If the specified namespace is NULL, use the current namespace. */ @@ -1867,13 +1798,13 @@ TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY, &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (sourceNsPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown namespace in namespace forget pattern \"%s\"", - pattern)); + Tcl_AppendResult(interp, + "unknown namespace in namespace forget pattern \"", + pattern, "\"", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL); return TCL_ERROR; } if (strcmp(pattern, simplePattern) == 0) { @@ -1880,28 +1811,28 @@ /* * The pattern is simple. Delete any imported commands that match it. */ if (TclMatchIsTrivial(simplePattern)) { + Command *cmdPtr; + 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); - } + if ((hPtr != NULL) + && (cmdPtr = Tcl_GetHashValue(hPtr)) + && (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); + Command *cmdPtr = Tcl_GetHashValue(hPtr); if (cmdPtr->deleteProc != DeleteImportedCmd) { continue; } - cmdName = (char *)Tcl_GetHashKey(&nsPtr->cmdTable, hPtr); + cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, hPtr); if (Tcl_StringMatch(cmdName, simplePattern)) { Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); } } return TCL_OK; @@ -1912,11 +1843,11 @@ */ 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 token = Tcl_GetHashValue(hPtr); Tcl_Command origin = TclGetOriginalCommand(token); if (Tcl_GetCommandInfoFromToken(origin, &info) == 0) { continue; /* Not an imported command. */ } @@ -1925,11 +1856,11 @@ * Original not in namespace we're matching. Check the first link * in the import chain. */ Command *cmdPtr = (Command *) token; - ImportedCmdData *dataPtr = (ImportedCmdData *)cmdPtr->objClientData; + ImportedCmdData *dataPtr = cmdPtr->objClientData; Tcl_Command firstToken = (Tcl_Command) dataPtr->realCmdPtr; if (firstToken == origin) { continue; } @@ -1937,11 +1868,11 @@ if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) { continue; } origin = firstToken; } - if (Tcl_StringMatch(Tcl_GetCommandName(NULL, origin), simplePattern)){ + if (Tcl_StringMatch(Tcl_GetCommandName(NULL, origin), simplePattern)) { Tcl_DeleteCommandFromToken(interp, token); } } return TCL_OK; } @@ -1972,28 +1903,28 @@ Tcl_Command TclGetOriginalCommand( Tcl_Command command) /* The imported command for which the original * command should be returned. */ { - Command *cmdPtr = (Command *) command; + register Command *cmdPtr = (Command *) command; ImportedCmdData *dataPtr; if (cmdPtr->deleteProc != DeleteImportedCmd) { return NULL; } while (cmdPtr->deleteProc == DeleteImportedCmd) { - dataPtr = (ImportedCmdData *)cmdPtr->objClientData; + dataPtr = cmdPtr->objClientData; cmdPtr = dataPtr->realCmdPtr; } return (Tcl_Command) cmdPtr; } /* *---------------------------------------------------------------------- * - * TclInvokeImportedCmd -- + * InvokeImportedCmd -- * * Invoked by Tcl whenever the user calls an imported command that was * created by Tcl_Import. Finds the "real" command (in another * namespace), and passes control to it. * @@ -2006,33 +1937,21 @@ * *---------------------------------------------------------------------- */ static int -InvokeImportedNRCmd( +InvokeImportedCmd( 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 -TclInvokeImportedCmd( - 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. */ -{ - return Tcl_NRCallObjProc(interp, InvokeImportedNRCmd, clientData, + register ImportedCmdData *dataPtr = clientData; + register Command *realCmdPtr = dataPtr->realCmdPtr; + + return (*realCmdPtr->objProc)(realCmdPtr->objClientData, interp, objc, objv); } /* *---------------------------------------------------------------------- @@ -2058,14 +1977,14 @@ static void DeleteImportedCmd( ClientData clientData) /* Points to the imported command's * ImportedCmdData structure. */ { - ImportedCmdData *dataPtr = (ImportedCmdData *)clientData; + ImportedCmdData *dataPtr = clientData; Command *realCmdPtr = dataPtr->realCmdPtr; Command *selfPtr = dataPtr->selfPtr; - ImportRef *refPtr, *prevPtr; + register ImportRef *refPtr, *prevPtr; prevPtr = NULL; for (refPtr = realCmdPtr->importRefPtr; refPtr != NULL; refPtr = refPtr->nextPtr) { if (refPtr->importedCmdPtr == selfPtr) { @@ -2077,13 +1996,12 @@ if (prevPtr == NULL) { /* refPtr is first in list. */ realCmdPtr->importRefPtr = refPtr->nextPtr; } else { prevPtr->nextPtr = refPtr->nextPtr; } - Tcl_Free(refPtr); - TclCleanupCommandMacro(realCmdPtr); - Tcl_Free(dataPtr); + ckfree((char *) refPtr); + ckfree((char *) dataPtr); return; } prevPtr = refPtr; } @@ -2312,11 +2230,11 @@ * that might be empty. Copy the namespace qualifier to a buffer * so it can be null terminated. We can't modify the incoming * qualName since it may be a string constant. */ - TclDStringClear(&buffer); + Tcl_DStringSetLength(&buffer, 0); Tcl_DStringAppend(&buffer, start, len); nsName = Tcl_DStringValue(&buffer); } /* @@ -2325,29 +2243,21 @@ * create that qualifying namespace. This is needed for functions like * Tcl_CreateCommand that cannot fail. */ if (nsPtr != NULL) { -#ifndef BREAK_NAMESPACE_COMPAT entryPtr = Tcl_FindHashEntry(&nsPtr->childTable, nsName); -#else - if (nsPtr->childTablePtr == NULL) { - entryPtr = NULL; - } else { - entryPtr = Tcl_FindHashEntry(nsPtr->childTablePtr, nsName); - } -#endif if (entryPtr != NULL) { - nsPtr = (Namespace *)Tcl_GetHashValue(entryPtr); + nsPtr = Tcl_GetHashValue(entryPtr); } else if (flags & TCL_CREATE_NS_IF_UNKNOWN) { Tcl_CallFrame *framePtr; (void) TclPushStackFrame(interp, &framePtr, (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0); - nsPtr = (Namespace *) - Tcl_CreateNamespace(interp, nsName, NULL, NULL); + nsPtr = (Namespace *) Tcl_CreateNamespace(interp, nsName, + NULL, NULL); TclPopStackFrame(interp); if (nsPtr == NULL) { Tcl_Panic("Could not create namespace '%s'", nsName); } @@ -2360,21 +2270,13 @@ /* * Look up the namespace qualifier in the alternate search path too. */ if (altNsPtr != NULL) { -#ifndef BREAK_NAMESPACE_COMPAT entryPtr = Tcl_FindHashEntry(&altNsPtr->childTable, nsName); -#else - if (altNsPtr->childTablePtr != NULL) { - entryPtr = Tcl_FindHashEntry(altNsPtr->childTablePtr, nsName); - } else { - entryPtr = NULL; - } -#endif if (entryPtr != NULL) { - altNsPtr = (Namespace *)Tcl_GetHashValue(entryPtr); + altNsPtr = Tcl_GetHashValue(entryPtr); } else { altNsPtr = NULL; } } @@ -2424,39 +2326,10 @@ } /* *---------------------------------------------------------------------- * - * TclEnsureNamespace -- - * - * Provide a namespace that is not deleted. - * - * Value - * - * namespacePtr, if it is not scheduled for deletion, or a pointer to a - * new namespace with the same name otherwise. - * - * Effect - * None. - * - *---------------------------------------------------------------------- - */ -Tcl_Namespace * -TclEnsureNamespace( - Tcl_Interp *interp, - Tcl_Namespace *namespacePtr) -{ - Namespace *nsPtr = (Namespace *) namespacePtr; - if (!(nsPtr->flags & NS_DYING)) { - return namespacePtr; - } - return Tcl_CreateNamespace(interp, nsPtr->fullName, NULL, NULL); -} - -/* - *---------------------------------------------------------------------- - * * Tcl_FindNamespace -- * * Searches for a namespace. * * Results: @@ -2482,11 +2355,11 @@ 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 + register 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; @@ -2500,15 +2373,13 @@ TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, flags|TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); if (nsPtr != NULL) { return (Tcl_Namespace *) nsPtr; - } - - if (flags & TCL_LEAVE_ERR_MSG) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown namespace \"%s\"", name)); + } else if (flags & TCL_LEAVE_ERR_MSG) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "unknown namespace \"", name, "\"", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL); } return NULL; } @@ -2553,12 +2424,12 @@ * and TCL_NAMESPACE_ONLY are given, * TCL_GLOBAL_ONLY is ignored. */ { Interp *iPtr = (Interp *) interp; Namespace *cxtNsPtr; - Tcl_HashEntry *entryPtr; - Command *cmdPtr; + register Tcl_HashEntry *entryPtr; + register Command *cmdPtr; const char *simpleName; int result; /* * If this namespace has a command resolver, then give it first crack at @@ -2579,28 +2450,26 @@ if (cxtNsPtr->cmdResProc != NULL || iPtr->resolverPtr != NULL) { ResolverScheme *resPtr = iPtr->resolverPtr; Tcl_Command cmd; if (cxtNsPtr->cmdResProc) { - result = cxtNsPtr->cmdResProc(interp, name, + result = (*cxtNsPtr->cmdResProc)(interp, name, (Tcl_Namespace *) cxtNsPtr, flags, &cmd); } else { result = TCL_CONTINUE; } while (result == TCL_CONTINUE && resPtr) { if (resPtr->cmdResProc) { - result = resPtr->cmdResProc(interp, name, + result = (*resPtr->cmdResProc)(interp, name, (Tcl_Namespace *) cxtNsPtr, flags, &cmd); } resPtr = resPtr->nextPtr; } if (result == TCL_OK) { - ((Command *)cmd)->flags |= CMD_VIA_RESOLVER; return cmd; - } else if (result != TCL_CONTINUE) { return NULL; } } @@ -2609,11 +2478,11 @@ */ cmdPtr = NULL; if (cxtNsPtr->commandPathLength!=0 && strncmp(name, "::", 2) && !(flags & TCL_NAMESPACE_ONLY)) { - size_t i; + int i; Namespace *pathNsPtr, *realNsPtr, *dummyNsPtr; (void) TclGetNamespaceForQualName(interp, name, cxtNsPtr, TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr, &simpleName); @@ -2620,11 +2489,11 @@ 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); + cmdPtr = Tcl_GetHashValue(entryPtr); } } } /* @@ -2641,11 +2510,11 @@ &simpleName); if ((realNsPtr != NULL) && (simpleName != NULL) && !(realNsPtr->flags & NS_DYING)) { entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); if (entryPtr != NULL) { - cmdPtr = (Command *)Tcl_GetHashValue(entryPtr); + cmdPtr = Tcl_GetHashValue(entryPtr); } } } /* @@ -2659,19 +2528,19 @@ &simpleName); if ((realNsPtr != NULL) && (simpleName != NULL) && !(realNsPtr->flags & NS_DYING)) { entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); if (entryPtr != NULL) { - cmdPtr = (Command *)Tcl_GetHashValue(entryPtr); + cmdPtr = Tcl_GetHashValue(entryPtr); } } } } else { Namespace *nsPtr[2]; - int search; + register int search; - TclGetNamespaceForQualName(interp, name, cxtNsPtr, + TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, 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 @@ -2681,24 +2550,23 @@ 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); + cmdPtr = Tcl_GetHashValue(entryPtr); } } } } if (cmdPtr != NULL) { - cmdPtr->flags &= ~CMD_VIA_RESOLVER; return (Tcl_Command) cmdPtr; } if (flags & TCL_LEAVE_ERR_MSG) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown command \"%s\"", name)); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "unknown command \"", name, "\"", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", name, NULL); } return NULL; } @@ -2739,18 +2607,18 @@ Tcl_Interp *interp, /* Interpreter containing the new command. */ Command *newCmdPtr) /* Points to the new command. */ { char *cmdName; Tcl_HashEntry *hPtr; - Namespace *nsPtr; + register 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 *)); + 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. @@ -2765,11 +2633,11 @@ * 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); + cmdName = 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 @@ -2782,23 +2650,14 @@ found = 1; shadowNsPtr = globalNsPtr; for (i = trailFront; i >= 0; i--) { trailNsPtr = trailPtr[i]; -#ifndef BREAK_NAMESPACE_COMPAT hPtr = Tcl_FindHashEntry(&shadowNsPtr->childTable, trailNsPtr->name); -#else - if (shadowNsPtr->childTablePtr != NULL) { - hPtr = Tcl_FindHashEntry(shadowNsPtr->childTablePtr, - trailNsPtr->name); - } else { - hPtr = NULL; - } -#endif if (hPtr != NULL) { - shadowNsPtr = (Namespace *)Tcl_GetHashValue(hPtr); + shadowNsPtr = Tcl_GetHashValue(hPtr); } else { found = 0; break; } } @@ -2820,11 +2679,11 @@ * invalidate all the bytecodes in nsPtr, to force a new * compilation. We use the resolverEpoch to signal the need * for a fresh compilation of every bytecode. */ - if (((Command *)Tcl_GetHashValue(hPtr))->compileProc != NULL){ + if (((Command *)Tcl_GetHashValue(hPtr))->compileProc != NULL) { nsPtr->resolverEpoch++; } } } @@ -2834,13 +2693,12 @@ */ trailFront++; if (trailFront == trailSize) { int newSize = 2 * trailSize; - - trailPtr = (Namespace **)TclStackRealloc(interp, trailPtr, - newSize * sizeof(Namespace *)); + trailPtr = (Namespace **) TclStackRealloc(interp, + trailPtr, newSize * sizeof(Namespace *)); trailSize = newSize; } trailPtr[trailFront] = nsPtr; } TclStackFree(interp, trailPtr); @@ -2884,11 +2742,11 @@ } else { /* * Get the current namespace name. */ - NamespaceCurrentCmd(NULL, interp, 1, NULL); + NamespaceCurrentCmd(NULL, interp, 2, NULL); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "namespace \"%s\" not found in \"%s\"", name, Tcl_GetStringResult(interp))); } Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL); @@ -2903,61 +2761,172 @@ Tcl_Obj *objPtr, /* The object to be resolved as the name of a * namespace. */ Tcl_Namespace **nsPtrPtr) /* Result namespace pointer goes here. */ { ResolvedNsName *resNamePtr; + Namespace *nsPtr, *refNsPtr; - NsNameGetIntRep(objPtr, resNamePtr); - if (resNamePtr) { - Namespace *nsPtr, *refNsPtr; - + if (objPtr->typePtr == &nsNameType) { /* - * Check that the ResolvedNsName is still valid; avoid letting the ref + * Check that the ResolvedNsName is still valid; avoid letting the ref * cross interps. */ + resNamePtr = (ResolvedNsName *) objPtr->internalRep.twoPtrValue.ptr1; nsPtr = resNamePtr->nsPtr; refNsPtr = resNamePtr->refNsPtr; - if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) - && (!refNsPtr || (refNsPtr == - (Namespace *) TclGetCurrentNamespace(interp)))) { + if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) && + (!refNsPtr || ((interp == refNsPtr->interp) && + (refNsPtr== (Namespace *) Tcl_GetCurrentNamespace(interp))))) { *nsPtrPtr = (Tcl_Namespace *) nsPtr; return TCL_OK; } - Tcl_StoreIntRep(objPtr, &nsNameType, NULL); } if (SetNsNameFromAny(interp, objPtr) == TCL_OK) { - NsNameGetIntRep(objPtr, resNamePtr); - assert(resNamePtr != NULL); + resNamePtr = (ResolvedNsName *) objPtr->internalRep.twoPtrValue.ptr1; *nsPtrPtr = (Tcl_Namespace *) resNamePtr->nsPtr; return TCL_OK; } return TCL_ERROR; } /* *---------------------------------------------------------------------- * - * TclInitNamespaceCmd -- + * Tcl_NamespaceObjCmd -- * - * This function is called to create the "namespace" Tcl command. See the - * user documentation for details on what it does. + * Invoked to implement the "namespace" command that creates, deletes, or + * manipulates Tcl namespaces. Handles the following syntax: + * + * namespace children ?name? ?pattern? + * namespace code arg + * namespace current + * namespace delete ?name name...? + * namespace ensemble subcommand ?arg...? + * namespace eval name arg ?arg...? + * namespace exists name + * namespace export ?-clear? ?pattern pattern...? + * namespace forget ?pattern pattern...? + * namespace import ?-force? ?pattern pattern...? + * namespace inscope name arg ?arg...? + * namespace origin name + * namespace parent ?name? + * namespace qualifiers string + * namespace tail string + * namespace which ?-command? ?-variable? name * * Results: - * Handle for the namespace command, or NULL on failure. + * Returns TCL_OK if the command is successful. Returns TCL_ERROR if + * anything goes wrong. * * Side effects: - * none + * Based on the subcommand name (e.g., "import"), this function + * dispatches to a corresponding function NamespaceXXXCmd defined + * statically in this file. This function's side effects depend on + * whatever that subcommand function does. If there is an error, this + * function returns an error message in the interpreter's result object. + * Otherwise it may return a result in the interpreter's result object. * *---------------------------------------------------------------------- */ -Tcl_Command -TclInitNamespaceCmd( - Tcl_Interp *interp) /* Current interpreter. */ +int +Tcl_NamespaceObjCmd( + ClientData clientData, /* Arbitrary value passed to cmd. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - return TclMakeEnsemble(interp, "namespace", defaultNamespaceMap); + static const char *subCmds[] = { + "children", "code", "current", "delete", "ensemble", + "eval", "exists", "export", "forget", "import", + "inscope", "origin", "parent", "path", "qualifiers", + "tail", "unknown", "upvar", "which", NULL + }; + enum NSSubCmdIdx { + NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx, NSEnsembleIdx, + NSEvalIdx, NSExistsIdx, NSExportIdx, NSForgetIdx, NSImportIdx, + NSInscopeIdx, NSOriginIdx, NSParentIdx, NSPathIdx, NSQualifiersIdx, + NSTailIdx, NSUnknownIdx, NSUpvarIdx, NSWhichIdx + }; + int index, result; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); + return TCL_ERROR; + } + + /* + * Return an index reflecting the particular subcommand. + */ + + result = Tcl_GetIndexFromObj((Tcl_Interp *) interp, objv[1], subCmds, + "option", /*flags*/ 0, (int *) &index); + if (result != TCL_OK) { + return result; + } + + switch (index) { + case NSChildrenIdx: + result = NamespaceChildrenCmd(clientData, interp, objc, objv); + break; + case NSCodeIdx: + result = NamespaceCodeCmd(clientData, interp, objc, objv); + break; + case NSCurrentIdx: + result = NamespaceCurrentCmd(clientData, interp, objc, objv); + break; + case NSDeleteIdx: + result = NamespaceDeleteCmd(clientData, interp, objc, objv); + break; + case NSEnsembleIdx: + result = NamespaceEnsembleCmd(clientData, interp, objc, objv); + break; + case NSEvalIdx: + result = NamespaceEvalCmd(clientData, interp, objc, objv); + break; + case NSExistsIdx: + result = NamespaceExistsCmd(clientData, interp, objc, objv); + break; + case NSExportIdx: + result = NamespaceExportCmd(clientData, interp, objc, objv); + break; + case NSForgetIdx: + result = NamespaceForgetCmd(clientData, interp, objc, objv); + break; + case NSImportIdx: + result = NamespaceImportCmd(clientData, interp, objc, objv); + break; + case NSInscopeIdx: + result = NamespaceInscopeCmd(clientData, interp, objc, objv); + break; + case NSOriginIdx: + result = NamespaceOriginCmd(clientData, interp, objc, objv); + break; + case NSParentIdx: + result = NamespaceParentCmd(clientData, interp, objc, objv); + break; + case NSPathIdx: + result = NamespacePathCmd(clientData, interp, objc, objv); + break; + case NSQualifiersIdx: + result = NamespaceQualifiersCmd(clientData, interp, objc, objv); + break; + case NSTailIdx: + result = NamespaceTailCmd(clientData, interp, objc, objv); + break; + case NSUpvarIdx: + result = NamespaceUpvarCmd(clientData, interp, objc, objv); + break; + case NSUnknownIdx: + result = NamespaceUnknownCmd(clientData, interp, objc, objv); + break; + case NSWhichIdx: + result = NamespaceWhichCmd(clientData, interp, objc, objv); + break; + } + return result; } /* *---------------------------------------------------------------------- * @@ -2979,54 +2948,54 @@ *---------------------------------------------------------------------- */ static int NamespaceChildrenCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ 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; + char *pattern = NULL; Tcl_DString buffer; - Tcl_HashEntry *entryPtr; + register Tcl_HashEntry *entryPtr; Tcl_HashSearch search; Tcl_Obj *listPtr, *elemPtr; /* * Get a pointer to the specified namespace, or the current namespace. */ - if (objc == 1) { + if (objc == 2) { nsPtr = (Namespace *) TclGetCurrentNamespace(interp); - } else if ((objc == 2) || (objc == 3)) { - if (TclGetNamespaceFromObj(interp, objv[1], &namespacePtr) != TCL_OK){ + } else if ((objc == 3) || (objc == 4)) { + if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { return TCL_ERROR; } nsPtr = (Namespace *) namespacePtr; } else { - Tcl_WrongNumArgs(interp, 1, objv, "?name? ?pattern?"); + Tcl_WrongNumArgs(interp, 2, objv, "?name? ?pattern?"); return TCL_ERROR; } /* * Get the glob-style pattern, if any, used to narrow the search. */ Tcl_DStringInit(&buffer); - if (objc == 3) { - const char *name = TclGetString(objv[2]); + if (objc == 4) { + char *name = TclGetString(objv[3]); if ((*name == ':') && (*(name+1) == ':')) { pattern = name; } else { Tcl_DStringAppend(&buffer, nsPtr->fullName, -1); if (nsPtr != globalNsPtr) { - TclDStringAppendLiteral(&buffer, "::"); + Tcl_DStringAppend(&buffer, "::", 2); } Tcl_DStringAppend(&buffer, name, -1); pattern = Tcl_DStringValue(&buffer); } } @@ -3036,38 +3005,24 @@ * names match the specified pattern, if any. */ listPtr = Tcl_NewListObj(0, NULL); if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { - size_t length = strlen(nsPtr->fullName); + 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 -#else - nsPtr->childTablePtr != NULL && - Tcl_FindHashEntry(nsPtr->childTablePtr, pattern+length) != NULL -#endif - ) { + if (Tcl_FindHashEntry(&nsPtr->childTable, pattern+length) != NULL) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(pattern, -1)); } goto searchDone; } -#ifndef BREAK_NAMESPACE_COMPAT entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); -#else - if (nsPtr->childTablePtr == NULL) { - goto searchDone; - } - entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search); -#endif while (entryPtr != NULL) { - childNsPtr = (Namespace *)Tcl_GetHashValue(entryPtr); + childNsPtr = Tcl_GetHashValue(entryPtr); if ((pattern == NULL) || Tcl_StringMatch(childNsPtr->fullName, pattern)) { elemPtr = Tcl_NewStringObj(childNsPtr->fullName, -1); Tcl_ListObjAppendElement(interp, listPtr, elemPtr); } @@ -3108,22 +3063,22 @@ *---------------------------------------------------------------------- */ static int NamespaceCodeCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ 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; - size_t length; + register char *arg; + int length; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "arg"); + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arg"); return TCL_ERROR; } /* * If "arg" is already a scoped value, then return it directly. @@ -3131,14 +3086,14 @@ * [::namespace code] generates it. Anything more forgiving can have * the effect of failing in namespaces that contain their own custom " "namespace" command. [Bug 3202171]. */ - arg = TclGetStringFromObj(objv[1], &length); - if (*arg==':' && length > 20 + arg = TclGetStringFromObj(objv[2], &length); + if (*arg==':' && length > 20 && strncmp(arg, "::namespace inscope ", 20) == 0) { - Tcl_SetObjResult(interp, objv[1]); + Tcl_SetObjResult(interp, objv[2]); return TCL_OK; } /* * Otherwise, construct a scoped command by building a list with @@ -3160,11 +3115,11 @@ } else { objPtr = Tcl_NewStringObj(currNsPtr->fullName, -1); } Tcl_ListObjAppendElement(interp, listPtr, objPtr); - Tcl_ListObjAppendElement(interp, listPtr, objv[1]); + Tcl_ListObjAppendElement(interp, listPtr, objv[2]); Tcl_SetObjResult(interp, listPtr); return TCL_OK; } @@ -3189,19 +3144,19 @@ *---------------------------------------------------------------------- */ static int NamespaceCurrentCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Namespace *currNsPtr; + register Namespace *currNsPtr; - if (objc != 1) { - Tcl_WrongNumArgs(interp, 1, objv, NULL); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } /* * The "real" name of the global namespace ("::") is the null string, but @@ -3252,38 +3207,38 @@ *---------------------------------------------------------------------- */ static int NamespaceDeleteCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Namespace *namespacePtr; - const char *name; - int i; + char *name; + register int i; - if (objc < 1) { - Tcl_WrongNumArgs(interp, 1, objv, "?name name...?"); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 2, objv, "?name name...?"); return TCL_ERROR; } /* * Destroying one namespace may cause another to be destroyed. Break this * into two passes: first check to make sure that all namespaces on the * command line are valid, and report any errors. */ - for (i = 1; i < objc; i++) { + for (i = 2; i < objc; i++) { name = TclGetString(objv[i]); namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0); if ((namespacePtr == NULL) - || (((Namespace *) namespacePtr)->flags & NS_KILLED)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown namespace \"%s\" in namespace delete command", - TclGetString(objv[i]))); + || (((Namespace *)namespacePtr)->flags & NS_KILLED)) { + Tcl_AppendResult(interp, "unknown namespace \"", + TclGetString(objv[i]), + "\" in namespace delete command", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", TclGetString(objv[i]), NULL); return TCL_ERROR; } } @@ -3290,11 +3245,11 @@ /* * Okay, now delete each namespace. */ - for (i = 1; i < objc; i++) { + for (i = 2; i < objc; i++) { name = TclGetString(objv[i]); namespacePtr = Tcl_FindNamespace(interp, name, NULL, /* flags */ 0); if (namespacePtr) { Tcl_DeleteNamespace(namespacePtr); } @@ -3329,52 +3284,38 @@ *---------------------------------------------------------------------- */ static int NamespaceEvalCmd( - ClientData clientData, /* Arbitrary value passed to cmd. */ + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - 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; Tcl_Namespace *namespacePtr; CallFrame *framePtr, **framePtrPtr; Tcl_Obj *objPtr; int result; - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "name arg ?arg...?"); + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); return TCL_ERROR; } /* * Try to resolve the namespace reference, caching the result in the * namespace object along the way. */ - result = GetNamespaceFromObj(interp, objv[1], &namespacePtr); + result = GetNamespaceFromObj(interp, objv[2], &namespacePtr); /* * If the namespace wasn't found, try to create it. */ if (result == TCL_ERROR) { - const char *name = TclGetString(objv[1]); + char *name = TclGetString(objv[2]); namespacePtr = Tcl_CreateNamespace(interp, name, NULL, NULL); if (namespacePtr == NULL) { return TCL_ERROR; } @@ -3385,64 +3326,55 @@ * command(s). */ /* This is needed to satisfy GCC 3.3's strict aliasing rules */ framePtrPtr = &framePtr; - (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, + result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, namespacePtr, /*isProcCallFrame*/ 0); + if (result != TCL_OK) { + return TCL_ERROR; + } - framePtr->objv = TclFetchEnsembleRoot(interp, objv, objc, &framePtr->objc); + framePtr->objc = objc; + framePtr->objv = objv; - if (objc == 3) { + if (objc == 4) { /* * TIP #280: Make actual argument location available to eval'd script. */ - objPtr = objv[2]; - invoker = iPtr->cmdFramePtr; - word = 3; - TclArgumentGet(interp, objPtr, &invoker, &word); + Interp *iPtr = (Interp *) interp; + CmdFrame* invoker = iPtr->cmdFramePtr; + int word = 3; + + TclArgumentGet (interp, objv[3], &invoker, &word); + result = TclEvalObjEx(interp, objv[3], 0, invoker, word); } else { /* * More than one argument: concatenate them together with spaces * between, then evaluate the result. Tcl_EvalObjEx will delete the * object when it decrements its refcount after eval'ing it. */ - objPtr = Tcl_ConcatObj(objc-2, objv+2); - invoker = NULL; - word = 0; - } - - /* - * TIP #280: Make invoking context available to eval'd script. - */ - - TclNRAddCallback(interp, NsEval_Callback, namespacePtr, "eval", - NULL, NULL); - return TclNREvalObjEx(interp, objPtr, 0, invoker, word); -} - -static int -NsEval_Callback( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - Tcl_Namespace *namespacePtr = (Tcl_Namespace *)data[0]; + objPtr = Tcl_ConcatObj(objc-3, objv+3); + + /* + * TIP #280: Make invoking context available to eval'd script. + */ + + result = TclEvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, 0); + } if (result == TCL_ERROR) { - size_t length = strlen(namespacePtr->fullName); - unsigned limit = 200; + 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 : (unsigned)length), namespacePtr->fullName, - (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); + "\n (in namespace eval \"%.*s%s\" script line %d)", + (overflow ? limit : length), namespacePtr->fullName, + (overflow ? "..." : ""), interp->errorLine)); } /* * Restore the previous "current" namespace. */ @@ -3472,24 +3404,24 @@ *---------------------------------------------------------------------- */ static int NamespaceExistsCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Namespace *namespacePtr; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "name"); + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "name"); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj( - GetNamespaceFromObj(interp, objv[1], &namespacePtr) == TCL_OK)); + GetNamespaceFromObj(interp, objv[2], &namespacePtr) == TCL_OK)); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -3527,42 +3459,41 @@ *---------------------------------------------------------------------- */ static int NamespaceExportCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int firstArg, i; - if (objc < 1) { - Tcl_WrongNumArgs(interp, 1, objv, "?-clear? ?pattern pattern...?"); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 2, objv, "?-clear? ?pattern pattern...?"); return TCL_ERROR; } /* * If no pattern arguments are given, and "-clear" isn't specified, return * the namespace's current export pattern list. */ - if (objc == 1) { - Tcl_Obj *listPtr; + if (objc == 2) { + Tcl_Obj *listPtr = Tcl_NewObj(); - TclNewObj(listPtr); - (void)Tcl_AppendExportList(interp, NULL, listPtr); + (void) Tcl_AppendExportList(interp, NULL, listPtr); Tcl_SetObjResult(interp, listPtr); return TCL_OK; } /* * Process the optional "-clear" argument. */ - firstArg = 1; - if (strcmp("-clear", TclGetString(objv[firstArg])) == 0) { + firstArg = 2; + if (strcmp("-clear", Tcl_GetString(objv[firstArg])) == 0) { Tcl_Export(interp, NULL, "::", 1); Tcl_ResetResult(interp); firstArg++; } @@ -3569,11 +3500,11 @@ /* * Add each pattern to the namespace's export pattern list. */ for (i = firstArg; i < objc; i++) { - int result = Tcl_Export(interp, NULL, TclGetString(objv[i]), 0); + int result = Tcl_Export(interp, NULL, Tcl_GetString(objv[i]), 0); if (result != TCL_OK) { return result; } } return TCL_OK; @@ -3609,24 +3540,24 @@ *---------------------------------------------------------------------- */ static int NamespaceForgetCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *pattern; - int i, result; + char *pattern; + register int i, result; - if (objc < 1) { - Tcl_WrongNumArgs(interp, 1, objv, "?pattern pattern...?"); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 2, objv, "?pattern pattern...?"); return TCL_ERROR; } - for (i = 1; i < objc; i++) { + for (i = 2; i < objc; i++) { pattern = TclGetString(objv[i]); result = Tcl_ForgetImport(interp, NULL, pattern); if (result != TCL_OK) { return result; } @@ -3674,39 +3605,39 @@ *---------------------------------------------------------------------- */ static int NamespaceImportCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ 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; + char *string, *pattern; + register int i, result; int firstArg; - if (objc < 1) { - Tcl_WrongNumArgs(interp, 1, objv, "?-force? ?pattern pattern...?"); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 2, objv, "?-force? ?pattern pattern...?"); return TCL_ERROR; } /* * Skip over the optional "-force" as the first argument. */ - firstArg = 1; + firstArg = 2; if (firstArg < objc) { string = TclGetString(objv[firstArg]); if ((*string == '-') && (strcmp(string, "-force") == 0)) { allowOverwrite = 1; firstArg++; } } else { /* - * When objc == 1, command is just [namespace import]. Introspection + * When objc == 2, command is just [namespace import]. Introspection * form to return list of imported commands. */ Tcl_HashEntry *hPtr; Tcl_HashSearch search; @@ -3714,15 +3645,15 @@ Tcl_Obj *listPtr; TclNewObj(listPtr); for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - Command *cmdPtr = (Command *)Tcl_GetHashValue(hPtr); + Command *cmdPtr = Tcl_GetHashValue(hPtr); if (cmdPtr->deleteProc == DeleteImportedCmd) { Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewStringObj( - (char *)Tcl_GetHashKey(&nsPtr->cmdTable, hPtr) ,-1)); + Tcl_GetHashKey(&nsPtr->cmdTable, hPtr) ,-1)); } } Tcl_SetObjResult(interp, listPtr); return TCL_OK; } @@ -3778,85 +3709,92 @@ *---------------------------------------------------------------------- */ static int NamespaceInscopeCmd( - ClientData clientData, /* Arbitrary value passed to cmd. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - return Tcl_NRCallObjProc(interp, NRNamespaceInscopeCmd, clientData, objc, - objv); -} - -static int -NRNamespaceInscopeCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Namespace *namespacePtr; CallFrame *framePtr, **framePtrPtr; - int i; - Tcl_Obj *cmdObjPtr; + int i, result; - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "name arg ?arg...?"); + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); return TCL_ERROR; } /* * Resolve the namespace reference. */ - if (TclGetNamespaceFromObj(interp, objv[1], &namespacePtr) != TCL_OK) { + if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { return TCL_ERROR; } /* * Make the specified namespace the current namespace. */ framePtrPtr = &framePtr; /* This is needed to satisfy GCC's * strict aliasing rules. */ - (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, + result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, namespacePtr, /*isProcCallFrame*/ 0); + if (result != TCL_OK) { + return result; + } - framePtr->objv = TclFetchEnsembleRoot(interp, objv, objc, &framePtr->objc); + framePtr->objc = objc; + framePtr->objv = objv; /* * Execute the command. If there is just one argument, just treat it as a * script and evaluate it. Otherwise, create a list from the arguments * after the first one, then concatenate the first argument and the list * of extra arguments to form the command to evaluate. */ - if (objc == 3) { - cmdObjPtr = objv[2]; + if (objc == 4) { + result = Tcl_EvalObjEx(interp, objv[3], 0); } else { Tcl_Obj *concatObjv[2]; - Tcl_Obj *listPtr; + register Tcl_Obj *listPtr, *cmdObjPtr; listPtr = Tcl_NewListObj(0, NULL); - for (i = 3; i < objc; i++) { - if (Tcl_ListObjAppendElement(interp, listPtr, objv[i]) != TCL_OK){ + for (i = 4; i < objc; i++) { + if (Tcl_ListObjAppendElement(interp, listPtr, objv[i]) != TCL_OK) { Tcl_DecrRefCount(listPtr); /* Free unneeded obj. */ return TCL_ERROR; } } - concatObjv[0] = objv[2]; + concatObjv[0] = objv[3]; concatObjv[1] = listPtr; cmdObjPtr = Tcl_ConcatObj(2, concatObjv); + result = Tcl_EvalObjEx(interp, cmdObjPtr, TCL_EVAL_DIRECT); Tcl_DecrRefCount(listPtr); /* We're done with the list object. */ } - TclNRAddCallback(interp, NsEval_Callback, namespacePtr, "inscope", - NULL, NULL); - return TclNREvalObjEx(interp, cmdObjPtr, 0, NULL, 0); + if (result == TCL_ERROR) { + int length = strlen(namespacePtr->fullName); + int limit = 200; + int overflow = (length > limit); + + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (in namespace inscope \"%.*s%s\" script line %d)", + (overflow ? limit : length), namespacePtr->fullName, + (overflow ? "..." : ""), interp->errorLine)); + } + + /* + * Restore the previous "current" namespace. + */ + + TclPopStackFrame(interp); + return result; } /* *---------------------------------------------------------------------- * @@ -3886,46 +3824,47 @@ *---------------------------------------------------------------------- */ static int NamespaceOriginCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Command cmd, origCmd; + Tcl_Command command, origCommand; Tcl_Obj *resultPtr; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "name"); + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "name"); + return TCL_ERROR; + } + + command = Tcl_GetCommandFromObj(interp, objv[2]); + if (command == NULL) { + Tcl_AppendResult(interp, "invalid command name \"", + TclGetString(objv[2]), "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", + TclGetString(objv[2]), NULL); return TCL_ERROR; } - - cmd = Tcl_GetCommandFromObj(interp, objv[1]); - if (cmd == NULL) { - goto namespaceOriginError; - } - origCmd = TclGetOriginalCommand(cmd); - if (origCmd == NULL) { - origCmd = cmd; - } + origCommand = TclGetOriginalCommand(command); TclNewObj(resultPtr); - Tcl_GetCommandFullName(interp, origCmd, resultPtr); - if (TclCheckEmptyString(resultPtr) == TCL_EMPTYSTRING_YES ) { - Tcl_DecrRefCount(resultPtr); - namespaceOriginError: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid command name \"%s\"", TclGetString(objv[1]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", - TclGetString(objv[1]), NULL); - return TCL_ERROR; + if (origCommand == NULL) { + /* + * The specified command isn't an imported command. Return the + * command's name qualified by the full name of the namespace it was + * defined in. + */ + + Tcl_GetCommandFullName(interp, command, resultPtr); + } else { + Tcl_GetCommandFullName(interp, origCommand, resultPtr); } Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } - /* *---------------------------------------------------------------------- * * NamespaceParentCmd -- @@ -3946,25 +3885,25 @@ *---------------------------------------------------------------------- */ static int NamespaceParentCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Namespace *nsPtr; - if (objc == 1) { + if (objc == 2) { nsPtr = TclGetCurrentNamespace(interp); - } else if (objc == 2) { - if (TclGetNamespaceFromObj(interp, objv[1], &nsPtr) != TCL_OK) { + } else if (objc == 3) { + if (TclGetNamespaceFromObj(interp, objv[2], &nsPtr) != TCL_OK) { return TCL_ERROR; } } else { - Tcl_WrongNumArgs(interp, 1, objv, "?name?"); + Tcl_WrongNumArgs(interp, 2, objv, "?name?"); return TCL_ERROR; } /* * Report the parent of the specified namespace. @@ -4004,56 +3943,55 @@ *---------------------------------------------------------------------- */ static int NamespacePathCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp); - size_t i; - int nsObjc, result = TCL_ERROR; + int i, nsObjc, result = TCL_ERROR; Tcl_Obj **nsObjv; Tcl_Namespace **namespaceList = NULL; - if (objc > 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?pathList?"); + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?pathList?"); return TCL_ERROR; } /* * If no path is given, return the current path. */ - if (objc == 1) { - Tcl_Obj *resultObj; + if (objc == 2) { + /* + * Not a very fast way to compute this, but easy to get right. + */ - TclNewObj(resultObj); for (i=0 ; icommandPathLength ; i++) { if (nsPtr->commandPathArray[i].nsPtr != NULL) { - Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj( - nsPtr->commandPathArray[i].nsPtr->fullName, -1)); + Tcl_AppendElement(interp, + nsPtr->commandPathArray[i].nsPtr->fullName); } } - Tcl_SetObjResult(interp, resultObj); return TCL_OK; } /* * There is a path given, so parse it into an array of namespace pointers. */ - if (TclListObjGetElements(interp, objv[1], &nsObjc, &nsObjv) != TCL_OK) { + if (TclListObjGetElements(interp, objv[2], &nsObjc, &nsObjv) != TCL_OK) { goto badNamespace; } if (nsObjc != 0) { - namespaceList = (Tcl_Namespace **)TclStackAlloc(interp, - sizeof(Tcl_Namespace *) * nsObjc); + namespaceList = (Tcl_Namespace **) + TclStackAlloc(interp, sizeof(Tcl_Namespace *) * nsObjc); - for (i=0 ; i<(size_t)nsObjc ; i++) { + for (i=0 ; icommandPathLength ; i++) { NamespacePathEntry *nsPathPtr = &nsPtr->commandPathArray[i]; - if (nsPathPtr->prevPtr != NULL) { nsPathPtr->prevPtr->nextPtr = nsPathPtr->nextPtr; } if (nsPathPtr->nextPtr != NULL) { nsPathPtr->nextPtr->prevPtr = nsPathPtr->prevPtr; @@ -4167,11 +4104,11 @@ if (nsPathPtr->nsPtr->commandPathSourceList == nsPathPtr) { nsPathPtr->nsPtr->commandPathSourceList = nsPathPtr->nextPtr; } } } - Tcl_Free(nsPtr->commandPathArray); + ckfree((char *) nsPtr->commandPathArray); } /* *---------------------------------------------------------------------- * @@ -4195,11 +4132,10 @@ void TclInvalidateNsPath( Namespace *nsPtr) { NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList; - while (nsPathPtr != NULL) { if (nsPathPtr->nsPtr != NULL) { nsPathPtr->creatorNsPtr->cmdRefEpoch++; } nsPathPtr = nsPathPtr->nextPtr; @@ -4231,29 +4167,29 @@ *---------------------------------------------------------------------- */ static int NamespaceQualifiersCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *name, *p; - size_t length; + register char *name, *p; + int length; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "string"); + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "string"); return TCL_ERROR; } /* * Find the end of the string, then work backward and find the start of * the last "::" qualifier. */ - name = TclGetString(objv[1]); + name = TclGetString(objv[2]); for (p = name; *p != '\0'; p++) { /* empty body */ } while (--p >= name) { if ((*p == ':') && (p > name) && (*(p-1) == ':')) { @@ -4299,27 +4235,27 @@ *---------------------------------------------------------------------- */ static int NamespaceUnknownCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Namespace *currNsPtr; Tcl_Obj *resultPtr; int rc; - if (objc > 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?script?"); + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?script?"); return TCL_ERROR; } currNsPtr = TclGetCurrentNamespace(interp); - if (objc == 1) { + if (objc == 2) { /* * Introspection - return the current namespace handler. */ resultPtr = Tcl_GetNamespaceUnknownHandler(interp, currNsPtr); @@ -4326,13 +4262,13 @@ if (resultPtr == NULL) { TclNewObj(resultPtr); } Tcl_SetObjResult(interp, resultPtr); } else { - rc = Tcl_SetNamespaceUnknownHandler(interp, currNsPtr, objv[1]); + rc = Tcl_SetNamespaceUnknownHandler(interp, currNsPtr, objv[2]); if (rc == TCL_OK) { - Tcl_SetObjResult(interp, objv[1]); + Tcl_SetObjResult(interp, objv[2]); } return rc; } return TCL_OK; } @@ -4359,14 +4295,14 @@ Tcl_GetNamespaceUnknownHandler( Tcl_Interp *interp, /* The interpreter in which the namespace * exists. */ Tcl_Namespace *nsPtr) /* The namespace. */ { - Namespace *currNsPtr = (Namespace *) nsPtr; + Namespace *currNsPtr = (Namespace *)nsPtr; if (currNsPtr->unknownHandlerPtr == NULL && - currNsPtr == ((Interp *) interp)->globalNsPtr) { + currNsPtr == ((Interp *)interp)->globalNsPtr) { /* * Default handler for global namespace is "::unknown". For all other * namespaces, it is NULL (which falls back on the global unknown * handler). */ @@ -4403,11 +4339,11 @@ * exists. */ Tcl_Namespace *nsPtr, /* Namespace which is being updated. */ Tcl_Obj *handlerPtr) /* The new handler, or NULL to reset. */ { int lstlen = 0; - Namespace *currNsPtr = (Namespace *) nsPtr; + Namespace *currNsPtr = (Namespace *)nsPtr; /* * Ensure that we check for errors *first* before we change anything. */ @@ -4486,28 +4422,28 @@ *---------------------------------------------------------------------- */ static int NamespaceTailCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *name, *p; + register char *name, *p; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "string"); + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "string"); return TCL_ERROR; } /* * Find the end of the string, then work backward and find the last "::" * qualifier. */ - name = TclGetString(objv[1]); + name = TclGetString(objv[2]); for (p = name; *p != '\0'; p++) { /* empty body */ } while (--p > name) { if ((*p == ':') && (*(p-1) == ':')) { @@ -4544,42 +4480,43 @@ *---------------------------------------------------------------------- */ static int NamespaceUpvarCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ 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; - const char *myName; + char *myName; - if (objc < 2 || (objc & 1)) { - Tcl_WrongNumArgs(interp, 1, objv, "ns ?otherVar myVar ...?"); + if (objc < 5 || !(objc & 1)) { + Tcl_WrongNumArgs(interp, 2, objv, + "ns otherVar myVar ?otherVar myVar ...?"); return TCL_ERROR; } - if (TclGetNamespaceFromObj(interp, objv[1], &nsPtr) != TCL_OK) { + if (TclGetNamespaceFromObj(interp, objv[2], &nsPtr) != TCL_OK) { return TCL_ERROR; } - objc -= 2; - objv += 2; + objc -= 3; + objv += 3; for (; objc>0 ; objc-=2, objv+=2) { /* - * Locate the other variable. + * Locate the other variable */ savedNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr; otherPtr = TclObjLookupVarEx(interp, objv[0], NULL, - (TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG|TCL_AVOID_RESOLVERS), - "access", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", + /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); iPtr->varFramePtr->nsPtr = (Namespace *) savedNsPtr; if (otherPtr == NULL) { return TCL_ERROR; } @@ -4618,31 +4555,31 @@ *---------------------------------------------------------------------- */ static int NamespaceWhichCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - static const char *const opts[] = { + static const char *opts[] = { "-command", "-variable", NULL }; int lookupType = 0; Tcl_Obj *resultPtr; - if (objc < 2 || objc > 3) { + if (objc < 3 || objc > 4) { badArgs: - Tcl_WrongNumArgs(interp, 1, objv, "?-command? ?-variable? name"); + Tcl_WrongNumArgs(interp, 2, objv, "?-command? ?-variable? name"); return TCL_ERROR; - } else if (objc == 3) { + } else if (objc == 4) { /* * Look for a flag controlling the lookup. */ - if (Tcl_GetIndexFromObj(interp, objv[1], opts, "option", 0, + if (Tcl_GetIndexFromObj(interp, objv[2], opts, "option", 0, &lookupType) != TCL_OK) { /* * Preserve old style of error message! */ @@ -4694,33 +4631,39 @@ *---------------------------------------------------------------------- */ static void FreeNsNameInternalRep( - Tcl_Obj *objPtr) /* nsName object with internal representation + register Tcl_Obj *objPtr) /* nsName object with internal representation * to free. */ { - ResolvedNsName *resNamePtr; - - NsNameGetIntRep(objPtr, resNamePtr); - assert(resNamePtr != NULL); + register ResolvedNsName *resNamePtr = (ResolvedNsName *) + objPtr->internalRep.twoPtrValue.ptr1; + Namespace *nsPtr; /* * Decrement the reference count of the namespace. If there are no more * references, free it up. */ - if (resNamePtr->refCount-- <= 1) { + resNamePtr->refCount--; + if (resNamePtr->refCount == 0) { + /* * 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); - Tcl_Free(resNamePtr); + nsPtr = resNamePtr->nsPtr; + nsPtr->refCount--; + if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) { + NamespaceFree(nsPtr); + } + ckfree((char *) resNamePtr); } + objPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * @@ -4741,17 +4684,18 @@ */ static void DupNsNameInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ - Tcl_Obj *copyPtr) /* Object with internal rep to set. */ + register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - ResolvedNsName *resNamePtr; + register ResolvedNsName *resNamePtr = (ResolvedNsName *) + srcPtr->internalRep.twoPtrValue.ptr1; - NsNameGetIntRep(srcPtr, resNamePtr); - assert(resNamePtr != NULL); - NsNameSetIntRep(copyPtr, resNamePtr); + copyPtr->internalRep.twoPtrValue.ptr1 = resNamePtr; + resNamePtr->refCount++; + copyPtr->typePtr = &nsNameType; } /* *---------------------------------------------------------------------- * @@ -4777,15 +4721,15 @@ 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. */ + register Tcl_Obj *objPtr) /* The object to convert. */ { const char *dummy; Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; - ResolvedNsName *resNamePtr; + register ResolvedNsName *resNamePtr; const char *name; if (interp == NULL) { return TCL_ERROR; } @@ -4792,123 +4736,2269 @@ 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. */ + + if ((nsPtr == NULL) || (nsPtr->flags & NS_DYING)) { + /* + * Our failed lookup proves any previously cached nsName intrep is no + * longer valid. Get rid of it so we no longer waste memory storing + * it, nor time determining its invalidity again and again. + */ + + if (objPtr->typePtr == &nsNameType) { + TclFreeIntRep(objPtr); + objPtr->typePtr = NULL; + } + return TCL_ERROR; + } nsPtr->refCount++; - resNamePtr = (ResolvedNsName *)Tcl_Alloc(sizeof(ResolvedNsName)); + resNamePtr = (ResolvedNsName *) ckalloc(sizeof(ResolvedNsName)); resNamePtr->nsPtr = nsPtr; if ((name[0] == ':') && (name[1] == ':')) { resNamePtr->refNsPtr = NULL; } else { - resNamePtr->refNsPtr = (Namespace *) TclGetCurrentNamespace(interp); + resNamePtr->refNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + } + resNamePtr->refCount = 1; + TclFreeIntRep(objPtr); + objPtr->internalRep.twoPtrValue.ptr1 = resNamePtr; + objPtr->typePtr = &nsNameType; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * NamespaceEnsembleCmd -- + * + * Invoked to implement the "namespace ensemble" command that creates and + * manipulates ensembles built on top of namespaces. Handles the + * following syntax: + * + * namespace ensemble name ?dictionary? + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * + * Side effects: + * Creates the ensemble for the namespace if one did not previously + * exist. Alternatively, alters the way that the ensemble's subcommand => + * implementation prefix is configured. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceEnsembleCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Namespace *nsPtr; + Tcl_Command token; + static const char *subcommands[] = { + "configure", "create", "exists", NULL + }; + enum EnsSubcmds { + ENS_CONFIG, ENS_CREATE, ENS_EXISTS + }; + static const char *createOptions[] = { + "-command", "-map", "-prefixes", "-subcommands", "-unknown", NULL + }; + enum EnsCreateOpts { + CRT_CMD, CRT_MAP, CRT_PREFIX, CRT_SUBCMDS, CRT_UNKNOWN + }; + static const char *configOptions[] = { + "-map", "-namespace", "-prefixes", "-subcommands", "-unknown", NULL + }; + enum EnsConfigOpts { + CONF_MAP, CONF_NAMESPACE, CONF_PREFIX, CONF_SUBCMDS, CONF_UNKNOWN + }; + int index; + + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + if (nsPtr == NULL || nsPtr->flags & NS_DYING) { + if (!Tcl_InterpDeleted(interp)) { + Tcl_AppendResult(interp, + "tried to manipulate ensemble of deleted namespace", NULL); + } + return TCL_ERROR; + } + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "subcommand ?arg ...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[2], subcommands, "subcommand", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + switch ((enum EnsSubcmds) index) { + case ENS_CREATE: { + char *name; + Tcl_DictSearch search; + Tcl_Obj *listObj; + int done, len, allocatedMapFlag = 0; + /* + * Defaults + */ + Tcl_Obj *subcmdObj = NULL; + Tcl_Obj *mapObj = NULL; + int permitPrefix = 1; + Tcl_Obj *unknownObj = NULL; + + objv += 3; + objc -= 3; + + /* + * Work out what name to use for the command to create. If supplied, + * it is either fully specified or relative to the current namespace. + * If not supplied, it is exactly the name of the current namespace. + */ + + name = nsPtr->fullName; + + /* + * Parse the option list, applying type checks as we go. Note that we + * are not incrementing any reference counts in the objects at this + * stage, so the presence of an option multiple times won't cause any + * memory leaks. + */ + + for (; objc>1 ; objc-=2,objv+=2 ) { + if (Tcl_GetIndexFromObj(interp, objv[0], createOptions, "option", + 0, &index) != TCL_OK) { + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + switch ((enum EnsCreateOpts) index) { + case CRT_CMD: + name = TclGetString(objv[1]); + continue; + case CRT_SUBCMDS: + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + subcmdObj = (len > 0 ? objv[1] : NULL); + continue; + case CRT_MAP: { + Tcl_Obj *patchedDict = NULL, *subcmdObj; + + /* + * Verify that the map is sensible. + */ + + if (Tcl_DictObjFirst(interp, objv[1], &search, + &subcmdObj, &listObj, &done) != TCL_OK) { + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + if (done) { + mapObj = NULL; + continue; + } + do { + Tcl_Obj **listv; + char *cmd; + + if (TclListObjGetElements(interp, listObj, &len, + &listv) != TCL_OK) { + Tcl_DictObjDone(&search); + if (patchedDict) { + Tcl_DecrRefCount(patchedDict); + } + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + if (len < 1) { + Tcl_SetResult(interp, + "ensemble subcommand implementations " + "must be non-empty lists", TCL_STATIC); + Tcl_DictObjDone(&search); + if (patchedDict) { + Tcl_DecrRefCount(patchedDict); + } + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + cmd = TclGetString(listv[0]); + if (!(cmd[0] == ':' && cmd[1] == ':')) { + Tcl_Obj *newList = Tcl_NewListObj(len, listv); + Tcl_Obj *newCmd = Tcl_NewStringObj(nsPtr->fullName,-1); + + if (nsPtr->parentPtr) { + Tcl_AppendStringsToObj(newCmd, "::", NULL); + } + Tcl_AppendObjToObj(newCmd, listv[0]); + Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd); + if (patchedDict == NULL) { + patchedDict = Tcl_DuplicateObj(objv[1]); + } + Tcl_DictObjPut(NULL, patchedDict, subcmdObj, newList); + } + Tcl_DictObjNext(&search, &subcmdObj, &listObj, &done); + } while (!done); + + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + mapObj = (patchedDict ? patchedDict : objv[1]); + if (patchedDict) { + allocatedMapFlag = 1; + } + continue; + } + case CRT_PREFIX: + if (Tcl_GetBooleanFromObj(interp, objv[1], + &permitPrefix) != TCL_OK) { + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + continue; + case CRT_UNKNOWN: + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + unknownObj = (len > 0 ? objv[1] : NULL); + continue; + } + } + + /* + * Create the ensemble. Note that this might delete another ensemble + * linked to the same namespace, so we must be careful. However, we + * should be OK because we only link the namespace into the list once + * we've created it (and after any deletions have occurred.) + */ + + token = Tcl_CreateEnsemble(interp, name, NULL, + (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0)); + Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj); + Tcl_SetEnsembleMappingDict(interp, token, mapObj); + Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj); + + /* + * Tricky! Must ensure that the result is not shared (command delete + * traces could have corrupted the pristine object that we started + * with). [Snit test rename-1.5] + */ + + Tcl_ResetResult(interp); + Tcl_GetCommandFullName(interp, token, Tcl_GetObjResult(interp)); + return TCL_OK; + } + + case ENS_EXISTS: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 3, objv, "cmdname"); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj( + Tcl_FindEnsemble(interp, objv[3], 0) != NULL)); + return TCL_OK; + + case ENS_CONFIG: + if (objc < 4 || (objc != 5 && objc & 1)) { + Tcl_WrongNumArgs(interp, 3, objv, "cmdname ?opt? ?value? ..."); + return TCL_ERROR; + } + token = Tcl_FindEnsemble(interp, objv[3], TCL_LEAVE_ERR_MSG); + if (token == NULL) { + return TCL_ERROR; + } + + if (objc == 5) { + Tcl_Obj *resultObj = NULL; /* silence gcc 4 warning */ + + if (Tcl_GetIndexFromObj(interp, objv[4], configOptions, "option", + 0, &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum EnsConfigOpts) index) { + case CONF_SUBCMDS: + Tcl_GetEnsembleSubcommandList(NULL, token, &resultObj); + if (resultObj != NULL) { + Tcl_SetObjResult(interp, resultObj); + } + break; + case CONF_MAP: + Tcl_GetEnsembleMappingDict(NULL, token, &resultObj); + if (resultObj != NULL) { + Tcl_SetObjResult(interp, resultObj); + } + break; + case CONF_NAMESPACE: { + Tcl_Namespace *namespacePtr = NULL; /* silence gcc 4 warning */ + + Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); + Tcl_SetResult(interp, ((Namespace *)namespacePtr)->fullName, + TCL_VOLATILE); + break; + } + case CONF_PREFIX: { + int flags = 0; /* silence gcc 4 warning */ + + Tcl_GetEnsembleFlags(NULL, token, &flags); + Tcl_SetObjResult(interp, + Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX)); + break; + } + case CONF_UNKNOWN: + Tcl_GetEnsembleUnknownHandler(NULL, token, &resultObj); + if (resultObj != NULL) { + Tcl_SetObjResult(interp, resultObj); + } + break; + } + return TCL_OK; + + } else if (objc == 4) { + /* + * Produce list of all information. + */ + + Tcl_Obj *resultObj, *tmpObj = NULL; /* silence gcc 4 warning */ + Tcl_Namespace *namespacePtr = NULL; /* silence gcc 4 warning */ + int flags = 0; /* silence gcc 4 warning */ + + TclNewObj(resultObj); + + /* -map option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(configOptions[CONF_MAP], -1)); + Tcl_GetEnsembleMappingDict(NULL, token, &tmpObj); + Tcl_ListObjAppendElement(NULL, resultObj, + (tmpObj != NULL) ? tmpObj : Tcl_NewObj()); + + /* -namespace option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(configOptions[CONF_NAMESPACE], -1)); + Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(((Namespace *)namespacePtr)->fullName, + -1)); + + /* -prefix option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(configOptions[CONF_PREFIX], -1)); + Tcl_GetEnsembleFlags(NULL, token, &flags); + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX)); + + /* -subcommands option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(configOptions[CONF_SUBCMDS], -1)); + Tcl_GetEnsembleSubcommandList(NULL, token, &tmpObj); + Tcl_ListObjAppendElement(NULL, resultObj, + (tmpObj != NULL) ? tmpObj : Tcl_NewObj()); + + /* -unknown option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(configOptions[CONF_UNKNOWN], -1)); + Tcl_GetEnsembleUnknownHandler(NULL, token, &tmpObj); + Tcl_ListObjAppendElement(NULL, resultObj, + (tmpObj != NULL) ? tmpObj : Tcl_NewObj()); + + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; + } else { + Tcl_DictSearch search; + Tcl_Obj *listObj; + int done, len, allocatedMapFlag = 0; + Tcl_Obj *subcmdObj = NULL, *mapObj = NULL, + *unknownObj = NULL; /* Defaults, silence gcc 4 warnings */ + int permitPrefix, flags = 0; /* silence gcc 4 warning */ + + Tcl_GetEnsembleSubcommandList(NULL, token, &subcmdObj); + Tcl_GetEnsembleMappingDict(NULL, token, &mapObj); + Tcl_GetEnsembleUnknownHandler(NULL, token, &unknownObj); + Tcl_GetEnsembleFlags(NULL, token, &flags); + permitPrefix = (flags & TCL_ENSEMBLE_PREFIX) != 0; + + objv += 4; + objc -= 4; + + /* + * Parse the option list, applying type checks as we go. Note that + * we are not incrementing any reference counts in the objects at + * this stage, so the presence of an option multiple times won't + * cause any memory leaks. + */ + + for (; objc>0 ; objc-=2,objv+=2 ) { + if (Tcl_GetIndexFromObj(interp, objv[0], configOptions, + "option", 0, &index) != TCL_OK) { + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + switch ((enum EnsConfigOpts) index) { + case CONF_SUBCMDS: + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + subcmdObj = (len > 0 ? objv[1] : NULL); + continue; + case CONF_MAP: { + Tcl_Obj *patchedDict = NULL, *subcmdObj; + + /* + * Verify that the map is sensible. + */ + + if (Tcl_DictObjFirst(interp, objv[1], &search, + &subcmdObj, &listObj, &done) != TCL_OK) { + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + if (done) { + mapObj = NULL; + continue; + } + do { + Tcl_Obj **listv; + char *cmd; + + if (TclListObjGetElements(interp, listObj, &len, + &listv) != TCL_OK) { + Tcl_DictObjDone(&search); + if (patchedDict) { + Tcl_DecrRefCount(patchedDict); + } + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + if (len < 1) { + Tcl_SetResult(interp, + "ensemble subcommand implementations " + "must be non-empty lists", TCL_STATIC); + Tcl_DictObjDone(&search); + if (patchedDict) { + Tcl_DecrRefCount(patchedDict); + } + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + cmd = TclGetString(listv[0]); + if (!(cmd[0] == ':' && cmd[1] == ':')) { + Tcl_Obj *newList = Tcl_NewListObj(len, listv); + Tcl_Obj *newCmd = + Tcl_NewStringObj(nsPtr->fullName, -1); + if (nsPtr->parentPtr) { + Tcl_AppendStringsToObj(newCmd, "::", NULL); + } + Tcl_AppendObjToObj(newCmd, listv[0]); + Tcl_ListObjReplace(NULL, newList, 0,1, 1,&newCmd); + if (patchedDict == NULL) { + patchedDict = Tcl_DuplicateObj(objv[1]); + } + Tcl_DictObjPut(NULL, patchedDict, subcmdObj, + newList); + } + Tcl_DictObjNext(&search, &subcmdObj, &listObj, &done); + } while (!done); + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + mapObj = (patchedDict ? patchedDict : objv[1]); + if (patchedDict) { + allocatedMapFlag = 1; + } + continue; + } + case CONF_NAMESPACE: + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + Tcl_AppendResult(interp, "option -namespace is read-only", + NULL); + return TCL_ERROR; + case CONF_PREFIX: + if (Tcl_GetBooleanFromObj(interp, objv[1], + &permitPrefix) != TCL_OK) { + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + continue; + case CONF_UNKNOWN: + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + unknownObj = (len > 0 ? objv[1] : NULL); + continue; + } + } + + /* + * Update the namespace now that we've finished the parsing stage. + */ + + flags = (permitPrefix ? flags|TCL_ENSEMBLE_PREFIX + : flags&~TCL_ENSEMBLE_PREFIX); + Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj); + Tcl_SetEnsembleMappingDict(interp, token, mapObj); + Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj); + Tcl_SetEnsembleFlags(interp, token, flags); + return TCL_OK; + } + + default: + Tcl_Panic("unexpected ensemble command"); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateEnsemble -- + * + * Create a simple ensemble attached to the given namespace. + * + * Results: + * The token for the command created. + * + * Side effects: + * The ensemble is created and marked for compilation. + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +Tcl_CreateEnsemble( + Tcl_Interp *interp, + const char *name, + Tcl_Namespace *namespacePtr, + int flags) +{ + Namespace *nsPtr = (Namespace *) namespacePtr; + EnsembleConfig *ensemblePtr = (EnsembleConfig *) + ckalloc(sizeof(EnsembleConfig)); + Tcl_Obj *nameObj = NULL; + + if (nsPtr == NULL) { + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + } + + /* + * Make the name of the ensemble into a fully qualified name. This might + * allocate a temporary object. + */ + + if (!(name[0] == ':' && name[1] == ':')) { + nameObj = Tcl_NewStringObj(nsPtr->fullName, -1); + if (nsPtr->parentPtr == NULL) { + Tcl_AppendStringsToObj(nameObj, name, NULL); + } else { + Tcl_AppendStringsToObj(nameObj, "::", name, NULL); + } + Tcl_IncrRefCount(nameObj); + name = TclGetString(nameObj); + } + + ensemblePtr->nsPtr = nsPtr; + ensemblePtr->epoch = 0; + Tcl_InitHashTable(&ensemblePtr->subcommandTable, TCL_STRING_KEYS); + ensemblePtr->subcommandArrayPtr = NULL; + ensemblePtr->subcmdList = NULL; + ensemblePtr->subcommandDict = NULL; + ensemblePtr->flags = flags; + ensemblePtr->unknownHandler = NULL; + ensemblePtr->token = Tcl_CreateObjCommand(interp, name, + NsEnsembleImplementationCmd, ensemblePtr, DeleteEnsembleConfig); + ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles; + nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr; + + /* + * Trigger an eventual recomputation of the ensemble command set. Note + * that this is slightly tricky, as it means that we are not actually + * counting the number of namespace export actions, but it is the simplest + * way to go! + */ + + nsPtr->exportLookupEpoch++; + + if (flags & ENSEMBLE_COMPILE) { + ((Command *) ensemblePtr->token)->compileProc = TclCompileEnsemble; + } + + if (nameObj != NULL) { + TclDecrRefCount(nameObj); + } + return ensemblePtr->token; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetEnsembleSubcommandList -- + * + * Set the subcommand list for a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an ensemble + * or the subcommand list - if non-NULL - is not a list). + * + * Side effects: + * The ensemble is updated and marked for recompilation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetEnsembleSubcommandList( + Tcl_Interp *interp, + Tcl_Command token, + Tcl_Obj *subcmdList) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + Tcl_Obj *oldList; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + return TCL_ERROR; + } + if (subcmdList != NULL) { + int length; + + if (TclListObjLength(interp, subcmdList, &length) != TCL_OK) { + return TCL_ERROR; + } + if (length < 1) { + subcmdList = NULL; + } + } + + ensemblePtr = cmdPtr->objClientData; + oldList = ensemblePtr->subcmdList; + ensemblePtr->subcmdList = subcmdList; + if (subcmdList != NULL) { + Tcl_IncrRefCount(subcmdList); + } + if (oldList != NULL) { + TclDecrRefCount(oldList); + } + + /* + * Trigger an eventual recomputation of the ensemble command set. Note + * that this is slightly tricky, as it means that we are not actually + * counting the number of namespace export actions, but it is the simplest + * way to go! + */ + + ensemblePtr->nsPtr->exportLookupEpoch++; + + /* + * Special hack to make compiling of [info exists] work when the + * dictionary is modified. + */ + + if (cmdPtr->compileProc != NULL) { + ((Interp *)interp)->compileEpoch++; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetEnsembleMappingDict -- + * + * Set the mapping dictionary for a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an ensemble + * or the mapping - if non-NULL - is not a dict). + * + * Side effects: + * The ensemble is updated and marked for recompilation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetEnsembleMappingDict( + Tcl_Interp *interp, + Tcl_Command token, + Tcl_Obj *mapDict) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + Tcl_Obj *oldDict; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + return TCL_ERROR; + } + if (mapDict != NULL) { + int size, done; + Tcl_DictSearch search; + Tcl_Obj *valuePtr; + + if (Tcl_DictObjSize(interp, mapDict, &size) != TCL_OK) { + return TCL_ERROR; + } + + for (Tcl_DictObjFirst(NULL, mapDict, &search, NULL, &valuePtr, &done); + !done; Tcl_DictObjNext(&search, NULL, &valuePtr, &done)) { + Tcl_Obj *cmdPtr; + const char *bytes; + + if (Tcl_ListObjIndex(interp, valuePtr, 0, &cmdPtr) != TCL_OK) { + Tcl_DictObjDone(&search); + return TCL_ERROR; + } + bytes = TclGetString(cmdPtr); + if (bytes[0] != ':' || bytes[1] != ':') { + Tcl_AppendResult(interp, + "ensemble target is not a fully-qualified command", + NULL); + Tcl_DictObjDone(&search); + return TCL_ERROR; + } + } + + if (size < 1) { + mapDict = NULL; + } + } + + ensemblePtr = cmdPtr->objClientData; + oldDict = ensemblePtr->subcommandDict; + ensemblePtr->subcommandDict = mapDict; + if (mapDict != NULL) { + Tcl_IncrRefCount(mapDict); + } + if (oldDict != NULL) { + TclDecrRefCount(oldDict); + } + + /* + * Trigger an eventual recomputation of the ensemble command set. Note + * that this is slightly tricky, as it means that we are not actually + * counting the number of namespace export actions, but it is the simplest + * way to go! + */ + + ensemblePtr->nsPtr->exportLookupEpoch++; + + /* + * Special hack to make compiling of [info exists] work when the + * dictionary is modified. + */ + + if (cmdPtr->compileProc != NULL) { + ((Interp *)interp)->compileEpoch++; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetEnsembleUnknownHandler -- + * + * Set the unknown handler for a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an ensemble + * or the unknown handler - if non-NULL - is not a list). + * + * Side effects: + * The ensemble is updated and marked for recompilation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetEnsembleUnknownHandler( + Tcl_Interp *interp, + Tcl_Command token, + Tcl_Obj *unknownList) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + Tcl_Obj *oldList; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + return TCL_ERROR; + } + if (unknownList != NULL) { + int length; + + if (TclListObjLength(interp, unknownList, &length) != TCL_OK) { + return TCL_ERROR; + } + if (length < 1) { + unknownList = NULL; + } + } + + ensemblePtr = cmdPtr->objClientData; + oldList = ensemblePtr->unknownHandler; + ensemblePtr->unknownHandler = unknownList; + if (unknownList != NULL) { + Tcl_IncrRefCount(unknownList); + } + if (oldList != NULL) { + TclDecrRefCount(oldList); + } + + /* + * Trigger an eventual recomputation of the ensemble command set. Note + * that this is slightly tricky, as it means that we are not actually + * counting the number of namespace export actions, but it is the simplest + * way to go! + */ + + ensemblePtr->nsPtr->exportLookupEpoch++; + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetEnsembleFlags -- + * + * Set the flags for a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an + * ensemble). + * + * Side effects: + * The ensemble is updated and marked for recompilation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetEnsembleFlags( + Tcl_Interp *interp, + Tcl_Command token, + int flags) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + int wasCompiled; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + return TCL_ERROR; + } + + ensemblePtr = cmdPtr->objClientData; + wasCompiled = ensemblePtr->flags & ENSEMBLE_COMPILE; + + /* + * This API refuses to set the ENS_DEAD flag... + */ + + ensemblePtr->flags &= ENS_DEAD; + ensemblePtr->flags |= flags & ~ENS_DEAD; + + /* + * Trigger an eventual recomputation of the ensemble command set. Note + * that this is slightly tricky, as it means that we are not actually + * counting the number of namespace export actions, but it is the simplest + * way to go! + */ + + ensemblePtr->nsPtr->exportLookupEpoch++; + + /* + * If the ENSEMBLE_COMPILE flag status was changed, install or remove the + * compiler function and bump the interpreter's compilation epoch so that + * bytecode gets regenerated. + */ + + if (flags & ENSEMBLE_COMPILE) { + if (!wasCompiled) { + ((Command*) ensemblePtr->token)->compileProc = TclCompileEnsemble; + ((Interp *) interp)->compileEpoch++; + } + } else { + if (wasCompiled) { + ((Command*) ensemblePtr->token)->compileProc = NULL; + ((Interp *) interp)->compileEpoch++; + } + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetEnsembleSubcommandList -- + * + * Get the list of subcommands associated with a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an + * ensemble). The list of subcommands is returned by updating the + * variable pointed to by the last parameter (NULL if this is to be + * derived from the mapping dictionary or the associated namespace's + * exported commands). + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetEnsembleSubcommandList( + Tcl_Interp *interp, + Tcl_Command token, + Tcl_Obj **subcmdListPtr) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (interp != NULL) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + } + return TCL_ERROR; + } + + ensemblePtr = cmdPtr->objClientData; + *subcmdListPtr = ensemblePtr->subcmdList; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetEnsembleMappingDict -- + * + * Get the command mapping dictionary associated with a particular + * ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an + * ensemble). The mapping dict is returned by updating the variable + * pointed to by the last parameter (NULL if none is installed). + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetEnsembleMappingDict( + Tcl_Interp *interp, + Tcl_Command token, + Tcl_Obj **mapDictPtr) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (interp != NULL) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + } + return TCL_ERROR; + } + + ensemblePtr = cmdPtr->objClientData; + *mapDictPtr = ensemblePtr->subcommandDict; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetEnsembleUnknownHandler -- + * + * Get the unknown handler associated with a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an + * ensemble). The unknown handler is returned by updating the variable + * pointed to by the last parameter (NULL if no handler is installed). + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetEnsembleUnknownHandler( + Tcl_Interp *interp, + Tcl_Command token, + Tcl_Obj **unknownListPtr) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (interp != NULL) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + } + return TCL_ERROR; + } + + ensemblePtr = cmdPtr->objClientData; + *unknownListPtr = ensemblePtr->unknownHandler; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetEnsembleFlags -- + * + * Get the flags for a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an + * ensemble). The flags are returned by updating the variable pointed to + * by the last parameter. + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetEnsembleFlags( + Tcl_Interp *interp, + Tcl_Command token, + int *flagsPtr) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (interp != NULL) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + } + return TCL_ERROR; + } + + ensemblePtr = cmdPtr->objClientData; + *flagsPtr = ensemblePtr->flags; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetEnsembleNamespace -- + * + * Get the namespace associated with a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an + * ensemble). Namespace is returned by updating the variable pointed to + * by the last parameter. + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetEnsembleNamespace( + Tcl_Interp *interp, + Tcl_Command token, + Tcl_Namespace **namespacePtrPtr) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (interp != NULL) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + } + return TCL_ERROR; } - resNamePtr->refCount = 0; - NsNameSetIntRep(objPtr, resNamePtr); + + ensemblePtr = cmdPtr->objClientData; + *namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr; return TCL_OK; } /* *---------------------------------------------------------------------- * - * TclGetNamespaceCommandTable -- - * - * Returns the hash table of commands. - * - * Results: - * Pointer to the hash table. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Tcl_HashTable * -TclGetNamespaceCommandTable( - Tcl_Namespace *nsPtr) -{ - return &((Namespace *) nsPtr)->cmdTable; -} - -/* - *---------------------------------------------------------------------- - * - * TclGetNamespaceChildTable -- - * - * Returns the hash table of child namespaces. - * - * Results: - * Pointer to the hash table. - * - * Side effects: - * Might allocate memory. - * - *---------------------------------------------------------------------- - */ - -Tcl_HashTable * -TclGetNamespaceChildTable( - Tcl_Namespace *nsPtr) -{ - Namespace *nPtr = (Namespace *) nsPtr; -#ifndef BREAK_NAMESPACE_COMPAT - return &nPtr->childTable; -#else - if (nPtr->childTablePtr == NULL) { - nPtr->childTablePtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(nPtr->childTablePtr, TCL_STRING_KEYS); - } - return nPtr->childTablePtr; -#endif -} - -/* - *---------------------------------------------------------------------- - * - * TclLogCommandInfo -- - * - * This function is invoked after an error occurs in an interpreter. It - * adds information to iPtr->errorInfo/errorStack fields to describe the - * command that was being executed when the error occurred. When pc and - * tosPtr are non-NULL, conveying a bytecode execution "inner context", - * and the offending instruction is suitable, that inner context is - * recorded in errorStack. - * - * Results: - * None. - * - * Side effects: - * Information about the command is added to errorInfo/errorStack and the - * line number stored internally in the interpreter is set. - * - *---------------------------------------------------------------------- - */ - -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. */ - size_t 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; + * Tcl_FindEnsemble -- + * + * Given a command name, get the ensemble token for it, allowing for + * [namespace import]s. [Bug 1017022] + * + * Results: + * The token for the ensemble command with the given name, or NULL if the + * command either does not exist or is not an ensemble (when an error + * message will be written into the interp if thats non-NULL). + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +Tcl_FindEnsemble( + Tcl_Interp *interp, /* Where to do the lookup, and where to write + * the errors if TCL_LEAVE_ERR_MSG is set in + * the flags. */ + Tcl_Obj *cmdNameObj, /* Name of command to look up. */ + int flags) /* Either 0 or TCL_LEAVE_ERR_MSG; other flags + * are probably not useful. */ +{ + Command *cmdPtr; + + cmdPtr = (Command *) + Tcl_FindCommand(interp, TclGetString(cmdNameObj), NULL, flags); + if (cmdPtr == NULL) { + return NULL; + } + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + /* + * Reuse existing infrastructure for following import link chains + * rather than duplicating it. + */ + + cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); + + if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (flags & TCL_LEAVE_ERR_MSG) { + Tcl_AppendResult(interp, "\"", TclGetString(cmdNameObj), + "\" is not an ensemble command", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE", + TclGetString(cmdNameObj), NULL); + } + return NULL; + } + } + + return (Tcl_Command) cmdPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_IsEnsemble -- + * + * Simple test for ensemble-hood that takes into account imported + * ensemble commands as well. + * + * Results: + * Boolean value + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +int +Tcl_IsEnsemble( + Tcl_Command token) +{ + Command *cmdPtr = (Command *) token; + if (cmdPtr->objProc == NsEnsembleImplementationCmd) { + return 1; + } + cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); + if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) { + return 0; + } + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * TclMakeEnsemble -- + * + * Create an ensemble from a table of implementation commands. The + * ensemble will be subject to (limited) compilation if any of the + * implementation commands are compilable. + * + * Results: + * Handle for the ensemble, or NULL if creation of it fails. + * + * Side effects: + * May advance bytecode compilation epoch. + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +TclMakeEnsemble( + Tcl_Interp *interp, + const char *name, + const EnsembleImplMap map[]) +{ + Tcl_Command ensemble; /* The overall ensemble. */ + Tcl_Namespace *tclNsPtr; /* Reference to the "::tcl" namespace. */ + Tcl_DString buf; + + tclNsPtr = Tcl_FindNamespace(interp, "::tcl", NULL, + TCL_CREATE_NS_IF_UNKNOWN); + if (tclNsPtr == NULL) { + Tcl_Panic("unable to find or create ::tcl namespace!"); + } + Tcl_DStringInit(&buf); + Tcl_DStringAppend(&buf, "::tcl::", -1); + Tcl_DStringAppend(&buf, name, -1); + tclNsPtr = Tcl_FindNamespace(interp, Tcl_DStringValue(&buf), NULL, + TCL_CREATE_NS_IF_UNKNOWN); + if (tclNsPtr == NULL) { + Tcl_Panic("unable to find or create %s namespace!", + Tcl_DStringValue(&buf)); + } + ensemble = Tcl_CreateEnsemble(interp, Tcl_DStringValue(&buf)+5, tclNsPtr, + TCL_ENSEMBLE_PREFIX); + Tcl_DStringAppend(&buf, "::", -1); + if (ensemble != NULL) { + Tcl_Obj *mapDict; + int i, compile = 0; + + TclNewObj(mapDict); + for (i=0 ; map[i].name != NULL ; i++) { + Tcl_Obj *fromObj, *toObj; + Command *cmdPtr; + + fromObj = Tcl_NewStringObj(map[i].name, -1); + TclNewStringObj(toObj, Tcl_DStringValue(&buf), + Tcl_DStringLength(&buf)); + Tcl_AppendToObj(toObj, map[i].name, -1); + Tcl_DictObjPut(NULL, mapDict, fromObj, toObj); + cmdPtr = (Command *) Tcl_CreateObjCommand(interp, + TclGetString(toObj), map[i].proc, NULL, NULL); + cmdPtr->compileProc = map[i].compileProc; + compile |= (map[i].compileProc != NULL); + } + Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict); + if (compile) { + Tcl_SetEnsembleFlags(interp, ensemble, + TCL_ENSEMBLE_PREFIX | ENSEMBLE_COMPILE); + } + } + Tcl_DStringFree(&buf); + + return ensemble; +} + +/* + *---------------------------------------------------------------------- + * + * NsEnsembleImplementationCmd -- + * + * Implements an ensemble of commands (being those exported by a + * namespace other than the global namespace) as a command with the same + * (short) name as the namespace in the parent namespace. + * + * Results: + * A standard Tcl result code. Will be TCL_ERROR if the command is not an + * unambiguous prefix of any command exported by the ensemble's + * namespace. + * + * Side effects: + * Depends on the command within the namespace that gets executed. If the + * ensemble itself returns TCL_ERROR, a descriptive error message will be + * placed in the interpreter's result. + * + *---------------------------------------------------------------------- + */ + +static int +NsEnsembleImplementationCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + EnsembleConfig *ensemblePtr = clientData; + /* The ensemble itself. */ + Tcl_Obj **tempObjv; /* Space used to construct the list of + * arguments to pass to the command that + * implements the ensemble subcommand. */ + int result; /* The result of the subcommand execution. */ + 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. */ + Tcl_Obj **prefixObjv; /* The list of objects to substitute in as the + * target command prefix. */ + int prefixObjc; /* Size of prefixObjv of course! */ + int reparseCount = 0; /* Number of reparses. */ + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?argument ...?"); + return TCL_ERROR; + } + + restartEnsembleParse: + if (ensemblePtr->nsPtr->flags & NS_DYING) { + /* + * Don't know how we got here, but make things give up quickly. + */ + + if (!Tcl_InterpDeleted(interp)) { + Tcl_AppendResult(interp, + "ensemble activated for deleted namespace", NULL); + } + return TCL_ERROR; + } + + /* + * Determine if the table of subcommands is right. If so, we can just look + * up in there and go straight to dispatch. + */ + + if (ensemblePtr->epoch == ensemblePtr->nsPtr->exportLookupEpoch) { + /* + * Table of subcommands is still valid; therefore there might be a + * valid cache of discovered information which we can reuse. Do the + * check here, and if we're still valid, we can jump straight to the + * part where we do the invocation of the subcommand. + */ + + if (objv[1]->typePtr == &tclEnsembleCmdType) { + EnsembleCmdRep *ensembleCmd = objv[1]->internalRep.twoPtrValue.ptr1; + + if (ensembleCmd->nsPtr == ensemblePtr->nsPtr && + ensembleCmd->epoch == ensemblePtr->epoch && + ensembleCmd->token == ensemblePtr->token) { + prefixObj = ensembleCmd->realPrefixObj; + Tcl_IncrRefCount(prefixObj); + goto runResultingSubcommand; + } + } + } else { + BuildEnsembleConfig(ensemblePtr); + ensemblePtr->epoch = ensemblePtr->nsPtr->exportLookupEpoch; + } + + /* + * Look in the hashtable for the subcommand name; this is the fastest way + * of all. + */ + + hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, + TclGetString(objv[1])); + if (hPtr != NULL) { + char *fullName = Tcl_GetHashKey(&ensemblePtr->subcommandTable, hPtr); + + prefixObj = Tcl_GetHashValue(hPtr); + + /* + * Cache for later in the subcommand object. + */ + + MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj); + } else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) { + /* + * Could not map, no prefixing, go to unknown/error handling. + */ + + goto unknownOrAmbiguousSubcommand; + } else { + /* + * If we've not already confirmed the command with the hash as part of + * building our export table, we need to scan the sorted array for + * matches. + */ + + 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; + + subcmdName = TclGetString(objv[1]); + stringLength = objv[1]->length; + for (i=0 ; isubcommandArrayPtr[i], + (unsigned) stringLength); + + if (cmp == 0) { + if (fullName != NULL) { + /* + * Since there's never the exact-match case to worry about + * (hash search filters this), getting here indicates that + * our subcommand is an ambiguous prefix of (at least) two + * exported subcommands, which is an error case. + */ + + goto unknownOrAmbiguousSubcommand; + } + fullName = ensemblePtr->subcommandArrayPtr[i]; + } else if (cmp < 0) { + /* + * Because we are searching a sorted table, we can now stop + * searching because we have gone past anything that could + * possibly match. + */ + + break; + } + } + if (fullName == NULL) { + /* + * The subcommand is not a prefix of anything, so bail out! + */ + + goto unknownOrAmbiguousSubcommand; + } + hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, fullName); + if (hPtr == NULL) { + Tcl_Panic("full name %s not found in supposedly synchronized hash", + fullName); + } + prefixObj = Tcl_GetHashValue(hPtr); + + /* + * Cache for later in the subcommand object. + */ + + MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj); + } + + 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 + * feeding it back through the main command-lookup engine. In theory, we + * could look up the command in the namespace ourselves, as we already + * have the namespace in which it is guaranteed to exist, but we don't do + * that (the cacheing of the command object used should help with that.) + */ + + { + Interp *iPtr = (Interp *) interp; + int isRootEnsemble; + Tcl_Obj *copyObj; + + /* + * Get the prefix that we're rewriting to. To do this we need to + * ensure that the internal representation of the list does not change + * so that we can safely keep the internal representations of the + * elements in the list. + */ + + copyObj = TclListObjCopy(NULL, prefixObj); + TclListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv); + + /* + * Record what arguments the script sent in so that things like + * Tcl_WrongNumArgs can give the correct error message. + */ + + isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); + if (isRootEnsemble) { + iPtr->ensembleRewrite.sourceObjs = objv; + iPtr->ensembleRewrite.numRemovedObjs = 2; + iPtr->ensembleRewrite.numInsertedObjs = prefixObjc; + } else { + int ni = iPtr->ensembleRewrite.numInsertedObjs; + + if (ni < 2) { + iPtr->ensembleRewrite.numRemovedObjs += 2 - ni; + iPtr->ensembleRewrite.numInsertedObjs += prefixObjc-1; + } else { + iPtr->ensembleRewrite.numInsertedObjs += prefixObjc-2; + } + } + + /* + * Allocate a workspace and build the list of arguments to pass to the + * target command in it. + */ + + tempObjv = (Tcl_Obj **) TclStackAlloc(interp, + (int) sizeof(Tcl_Obj *) * (objc - 2 + prefixObjc)); + memcpy(tempObjv, prefixObjv, sizeof(Tcl_Obj *) * prefixObjc); + memcpy(tempObjv+prefixObjc, objv+2, sizeof(Tcl_Obj *) * (objc-2)); + + /* + * Hand off to the target command. + */ + + result = Tcl_EvalObjv(interp, objc-2+prefixObjc, tempObjv, + TCL_EVAL_INVOKE); + + /* + * Clean up. + */ + + TclStackFree(interp, tempObjv); + Tcl_DecrRefCount(copyObj); + if (isRootEnsemble) { + iPtr->ensembleRewrite.sourceObjs = NULL; + iPtr->ensembleRewrite.numRemovedObjs = 0; + iPtr->ensembleRewrite.numInsertedObjs = 0; + } + } + Tcl_DecrRefCount(prefixObj); + return result; + + unknownOrAmbiguousSubcommand: + /* + * Have not been able to match the subcommand asked for with a real + * subcommand that we export. See whether a handler has been registered + * for dealing with this situation. Will only call (at most) once for any + * particular ensemble invocation. + */ + + if (ensemblePtr->unknownHandler != NULL && reparseCount++ < 1) { + int paramc, i; + Tcl_Obj **paramv, *unknownCmd, *ensObj; + + unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler); + TclNewObj(ensObj); + Tcl_GetCommandFullName(interp, ensemblePtr->token, ensObj); + Tcl_ListObjAppendElement(NULL, unknownCmd, ensObj); + for (i=1 ; iflags & ENS_DEAD) { + Tcl_DecrRefCount(prefixObj); + Tcl_SetResult(interp, + "unknown subcommand handler deleted its ensemble", + TCL_STATIC); + return TCL_ERROR; + } + + /* + * Namespace is still there. Check if the result is a valid list. + * If it is, and it is non-empty, that list is what we are using + * as our replacement. + */ + + if (TclListObjLength(interp, prefixObj, &prefixObjc) != TCL_OK) { + Tcl_DecrRefCount(prefixObj); + Tcl_AddErrorInfo(interp, "\n while parsing result of " + "ensemble unknown subcommand handler"); + return TCL_ERROR; + } + if (prefixObjc > 0) { + goto runResultingSubcommand; + } + + /* + * Namespace alive & empty result => reparse. + */ + + Tcl_DecrRefCount(prefixObj); + goto restartEnsembleParse; + } + if (!Tcl_InterpDeleted(interp)) { + if (result != TCL_ERROR) { + char buf[TCL_INTEGER_SPACE]; + + Tcl_ResetResult(interp); + Tcl_SetResult(interp, + "unknown subcommand handler returned bad code: ", + TCL_STATIC); + switch (result) { + case TCL_RETURN: + Tcl_AppendResult(interp, "return", NULL); + break; + case TCL_BREAK: + Tcl_AppendResult(interp, "break", NULL); + break; + case TCL_CONTINUE: + Tcl_AppendResult(interp, "continue", NULL); + break; + default: + sprintf(buf, "%d", result); + Tcl_AppendResult(interp, buf, NULL); + } + Tcl_AddErrorInfo(interp, "\n result of " + "ensemble unknown subcommand handler: "); + Tcl_AddErrorInfo(interp, TclGetString(unknownCmd)); + } else { + Tcl_AddErrorInfo(interp, + "\n (ensemble unknown subcommand handler)"); + } + } + Tcl_DecrRefCount(unknownCmd); + Tcl_Release(ensemblePtr); + return TCL_ERROR; + } + + /* + * We cannot determine what subcommand to hand off to, so generate a + * (standard) failure message. Note the one odd case compared with + * standard ensemble-like command, which is where a namespace has no + * exported commands at all... + */ + + Tcl_ResetResult(interp); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE", + TclGetString(objv[1]), NULL); + if (ensemblePtr->subcommandTable.numEntries == 0) { + Tcl_AppendResult(interp, "unknown subcommand \"",TclGetString(objv[1]), + "\": namespace ", ensemblePtr->nsPtr->fullName, + " does not export any commands", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND", + TclGetString(objv[1]), NULL); + return TCL_ERROR; + } + Tcl_AppendResult(interp, "unknown ", + (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? "or ambiguous " : ""), + "subcommand \"", TclGetString(objv[1]), "\": must be ", NULL); + if (ensemblePtr->subcommandTable.numEntries == 1) { + Tcl_AppendResult(interp, ensemblePtr->subcommandArrayPtr[0], NULL); + } else { + int i; + + for (i=0 ; isubcommandTable.numEntries-1 ; i++) { + Tcl_AppendResult(interp, + ensemblePtr->subcommandArrayPtr[i], ", ", NULL); + } + Tcl_AppendResult(interp, "or ", + ensemblePtr->subcommandArrayPtr[i], NULL); + } + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND", + TclGetString(objv[1]), NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * MakeCachedEnsembleCommand -- + * + * Cache what we've computed so far; it's not nice to repeatedly copy + * strings about. Note that to do this, we start by deleting any old + * representation that there was (though if it was an out of date + * ensemble rep, we can skip some of the deallocation process.) + * + * Results: + * None + * + * Side effects: + * Alters the internal representation of the first object parameter. + * + *---------------------------------------------------------------------- + */ + +static void +MakeCachedEnsembleCommand( + Tcl_Obj *objPtr, + EnsembleConfig *ensemblePtr, + const char *subcommandName, + Tcl_Obj *prefixObjPtr) +{ + register EnsembleCmdRep *ensembleCmd; + int length; + + if (objPtr->typePtr == &tclEnsembleCmdType) { + ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; + Tcl_DecrRefCount(ensembleCmd->realPrefixObj); + ensembleCmd->nsPtr->refCount--; + if ((ensembleCmd->nsPtr->refCount == 0) + && (ensembleCmd->nsPtr->flags & NS_DEAD)) { + NamespaceFree(ensembleCmd->nsPtr); + } + ckfree(ensembleCmd->fullSubcmdName); + } else { + /* + * Kill the old internal rep, and replace it with a brand new one of + * our own. + */ + + TclFreeIntRep(objPtr); + ensembleCmd = (EnsembleCmdRep *) ckalloc(sizeof(EnsembleCmdRep)); + objPtr->internalRep.twoPtrValue.ptr1 = ensembleCmd; + objPtr->typePtr = &tclEnsembleCmdType; + } + + /* + * Populate the internal rep. + */ + + ensembleCmd->nsPtr = ensemblePtr->nsPtr; + ensembleCmd->epoch = ensemblePtr->epoch; + ensembleCmd->token = ensemblePtr->token; + ensemblePtr->nsPtr->refCount++; + ensembleCmd->realPrefixObj = prefixObjPtr; + length = strlen(subcommandName)+1; + ensembleCmd->fullSubcmdName = ckalloc((unsigned) length); + memcpy(ensembleCmd->fullSubcmdName, subcommandName, (unsigned) length); + Tcl_IncrRefCount(ensembleCmd->realPrefixObj); +} + +/* + *---------------------------------------------------------------------- + * + * DeleteEnsembleConfig -- + * + * Destroys the data structure used to represent an ensemble. This is + * called when the ensemble's command is deleted (which happens + * automatically if the ensemble's namespace is deleted.) Maintainers + * should note that ensembles should be deleted by deleting their + * commands. + * + * Results: + * None. + * + * Side effects: + * Memory is (eventually) deallocated. + * + *---------------------------------------------------------------------- + */ + +static void +ClearTable( + EnsembleConfig *ensemblePtr) +{ + 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_GetHashValue(hPtr); + Tcl_DecrRefCount(prefixObj); + hPtr = Tcl_NextHashEntry(&search); + } + ckfree((char *) ensemblePtr->subcommandArrayPtr); + } + Tcl_DeleteHashTable(hash); +} + +static void +DeleteEnsembleConfig( + ClientData clientData) +{ + EnsembleConfig *ensemblePtr = clientData; + Namespace *nsPtr = ensemblePtr->nsPtr; + + /* + * Unlink from the ensemble chain if it has not been marked as having been + * done already. + */ + + if (ensemblePtr->next != ensemblePtr) { + EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles; + if (ensPtr == ensemblePtr) { + nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next; + } else { + while (ensPtr != NULL) { + if (ensPtr->next == ensemblePtr) { + ensPtr->next = ensemblePtr->next; + break; + } + ensPtr = ensPtr->next; + } + } + } + + /* + * Mark the namespace as dead so code that uses Tcl_Preserve() can tell + * whether disaster happened anyway. + */ + + ensemblePtr->flags |= ENS_DEAD; + + /* + * Kill the pointer-containing fields. + */ + + ClearTable(ensemblePtr); + + if (ensemblePtr->subcmdList != NULL) { + Tcl_DecrRefCount(ensemblePtr->subcmdList); + } + if (ensemblePtr->subcommandDict != NULL) { + Tcl_DecrRefCount(ensemblePtr->subcommandDict); + } + if (ensemblePtr->unknownHandler != NULL) { + Tcl_DecrRefCount(ensemblePtr->unknownHandler); + } + + /* + * Arrange for the structure to be reclaimed. Note that this is complex + * because we have to make sure that we can react sensibly when an + * ensemble is deleted during the process of initialising the ensemble + * (especially the unknown callback.) + */ + + Tcl_EventuallyFree(ensemblePtr, TCL_DYNAMIC); +} + +/* + *---------------------------------------------------------------------- + * + * BuildEnsembleConfig -- + * + * Create the internal data structures that describe how an ensemble + * looks, being a hash mapping from the full command name to the Tcl list + * that describes the implementation prefix words, and a sorted array of + * all the full command names to allow for reasonably efficient + * unambiguous prefix handling. + * + * Results: + * None. + * + * Side effects: + * Reallocates and rebuilds the hash table and array stored at the + * ensemblePtr argument. For large ensembles or large namespaces, this is + * a potentially expensive operation. + * + *---------------------------------------------------------------------- + */ + +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; + 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]); + Tcl_IncrRefCount(subv[i+1]); + + name = TclGetString(subv[i+1]); + hPtr = Tcl_CreateHashEntry(hash, name, &isNew); + if (isNew) { + cmdObj = Tcl_NewStringObj(ensemblePtr->nsPtr->fullName, -1); + if (ensemblePtr->nsPtr->parentPtr != NULL) { + Tcl_AppendStringsToObj(cmdObj, "::", name, NULL); + } else { + Tcl_AppendStringsToObj(cmdObj, name, NULL); + } + cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); + Tcl_SetHashValue(hPtr, cmdPrefixObj); + Tcl_IncrRefCount(cmdPrefixObj); + } + } + } else { + /* Usual case where we can freely act on the list and dict. */ + + for (i = 0; i < subc; i++) { + name = TclGetString(subv[i]); + hPtr = Tcl_CreateHashEntry(hash, name, &isNew); + if (!isNew) { + continue; + } + + /* Lookup target in the dictionary */ + if (mapDict) { + Tcl_DictObjGet(NULL, mapDict, subv[i], &target); + if (target) { + Tcl_SetHashValue(hPtr, target); + Tcl_IncrRefCount(target); + continue; + } + } + + /* + * target was not in the dictionary so map onto the namespace. + * Note in this case that we do not guarantee that the + * command is actually there; that is the programmer's + * responsibility (or [::unknown] of course). + */ + cmdObj = Tcl_NewStringObj(ensemblePtr->nsPtr->fullName, -1); + if (ensemblePtr->nsPtr->parentPtr != NULL) { + Tcl_AppendStringsToObj(cmdObj, "::", name, NULL); + } else { + Tcl_AppendStringsToObj(cmdObj, name, NULL); + } + cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); + Tcl_SetHashValue(hPtr, cmdPrefixObj); + Tcl_IncrRefCount(cmdPrefixObj); + } + } + } else if (mapDict) { + /* + * No subcmd list, but we do have a mapping dictionary so we should + * use the keys of that. Convert the dictionary's contents into the + * form required for the ensemble's internal hashtable. + */ + + Tcl_DictSearch dictSearch; + Tcl_Obj *keyObj, *valueObj; + int done; + + Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch, + &keyObj, &valueObj, &done); + while (!done) { + char *name = TclGetString(keyObj); + + hPtr = Tcl_CreateHashEntry(hash, name, &isNew); + Tcl_SetHashValue(hPtr, valueObj); + Tcl_IncrRefCount(valueObj); + Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done); + } + } else { + /* + * Discover what commands are actually exported by the namespace. + * What we have is an array of patterns and a hash table whose keys + * are the command names exported by the namespace (the contents do + * not matter here.) We must find out what commands are actually + * exported by filtering each command in the namespace against each of + * the patterns in the export list. Note that we use an intermediate + * hash table to make memory management easier, and because that makes + * exact matching far easier too. + * + * Suggestion for future enhancement: compute the unique prefixes and + * 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. */ + Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr); + + for (i=0 ; insPtr->numExportPatterns ; i++) { + if (Tcl_StringMatch(nsCmdName, + ensemblePtr->nsPtr->exportArrayPtr[i])) { + hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew); + + /* + * Remember, hash entries have a full reference to the + * substituted part of the command (as a list) as their + * content! + */ + + if (isNew) { + Tcl_Obj *cmdObj, *cmdPrefixObj; + + TclNewObj(cmdObj); + Tcl_AppendStringsToObj(cmdObj, + ensemblePtr->nsPtr->fullName, + (ensemblePtr->nsPtr->parentPtr ? "::" : ""), + nsCmdName, NULL); + cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); + Tcl_SetHashValue(hPtr, cmdPrefixObj); + Tcl_IncrRefCount(cmdPrefixObj); + } + break; + } + } + } + } + + if (hash->numEntries == 0) { + ensemblePtr->subcommandArrayPtr = NULL; + return; + } + + /* + * Create a sorted array of all subcommands in the ensemble; hash tables + * are all very well for a quick look for an exact match, but they can't + * determine things like whether a string is a prefix of another (not + * without lots of preparation anyway) and they're no good for when we're + * generating the error message either. + * + * 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 ; + * hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search),i++) { + * ensemblePtr->subcommandArrayPtr[i] = Tcl_GetHashKey(hash, &hPtr); + * } + * + * can produce long runs of precisely ordered table entries when the + * commands in the namespace are declared in a sorted fashion (an ordering + * some people like) and the hashing functions (or the command names + * themselves) are fairly unfortunate. By filling from both ends, it + * requires active malice (and probably a debugger) to get qsort() to have + * awful runtime behaviour. + */ + + i = 0; + j = hash->numEntries; + hPtr = Tcl_FirstHashEntry(hash, &search); + while (hPtr != NULL) { + ensemblePtr->subcommandArrayPtr[i++] = Tcl_GetHashKey(hash, hPtr); + hPtr = Tcl_NextHashEntry(&search); + if (hPtr == NULL) { + break; + } + ensemblePtr->subcommandArrayPtr[--j] = Tcl_GetHashKey(hash, hPtr); + hPtr = Tcl_NextHashEntry(&search); + } + if (hash->numEntries > 1) { + qsort(ensemblePtr->subcommandArrayPtr, (unsigned)hash->numEntries, + sizeof(char *), NsEnsembleStringOrder); + } +} + +/* + *---------------------------------------------------------------------- + * + * NsEnsembleStringOrder -- + * + * Helper function to compare two pointers to two strings for use with + * qsort(). + * + * Results: + * -1 if the first string is smaller, 1 if the second string is smaller, + * and 0 if they are equal. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +NsEnsembleStringOrder( + const void *strPtr1, + const void *strPtr2) +{ + return strcmp(*(const char **)strPtr1, *(const char **)strPtr2); +} + +/* + *---------------------------------------------------------------------- + * + * FreeEnsembleCmdRep -- + * + * Destroys the internal representation of a Tcl_Obj that has been + * holding information about a command in an ensemble. + * + * Results: + * None. + * + * Side effects: + * Memory is deallocated. If this held the last reference to a + * namespace's main structure, that main structure will also be + * destroyed. + * + *---------------------------------------------------------------------- + */ + +static void +FreeEnsembleCmdRep( + Tcl_Obj *objPtr) +{ + EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; + + Tcl_DecrRefCount(ensembleCmd->realPrefixObj); + ckfree(ensembleCmd->fullSubcmdName); + ensembleCmd->nsPtr->refCount--; + if ((ensembleCmd->nsPtr->refCount == 0) + && (ensembleCmd->nsPtr->flags & NS_DEAD)) { + NamespaceFree(ensembleCmd->nsPtr); + } + ckfree((char *) ensembleCmd); +} + +/* + *---------------------------------------------------------------------- + * + * DupEnsembleCmdRep -- + * + * Makes one Tcl_Obj into a copy of another that is a subcommand of an + * ensemble. + * + * Results: + * None. + * + * Side effects: + * Memory is allocated, and the namespace that the ensemble is built on + * top of gains another reference. + * + *---------------------------------------------------------------------- + */ + +static void +DupEnsembleCmdRep( + Tcl_Obj *objPtr, + Tcl_Obj *copyPtr) +{ + EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; + EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *) + ckalloc(sizeof(EnsembleCmdRep)); + int length = strlen(ensembleCmd->fullSubcmdName); + + copyPtr->typePtr = &tclEnsembleCmdType; + copyPtr->internalRep.twoPtrValue.ptr1 = ensembleCopy; + ensembleCopy->nsPtr = ensembleCmd->nsPtr; + ensembleCopy->epoch = ensembleCmd->epoch; + ensembleCopy->token = ensembleCmd->token; + ensembleCopy->nsPtr->refCount++; + ensembleCopy->realPrefixObj = ensembleCmd->realPrefixObj; + Tcl_IncrRefCount(ensembleCopy->realPrefixObj); + ensembleCopy->fullSubcmdName = ckalloc((unsigned) length+1); + memcpy(ensembleCopy->fullSubcmdName, ensembleCmd->fullSubcmdName, + (unsigned) length+1); +} + +/* + *---------------------------------------------------------------------- + * + * StringOfEnsembleCmdRep -- + * + * Creates a string representation of a Tcl_Obj that holds a subcommand + * of an ensemble. + * + * Results: + * None. + * + * Side effects: + * The object gains a string (UTF-8) representation. + * + *---------------------------------------------------------------------- + */ + +static void +StringOfEnsembleCmdRep( + Tcl_Obj *objPtr) +{ + EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; + int length = strlen(ensembleCmd->fullSubcmdName); + + objPtr->length = length; + objPtr->bytes = ckalloc((unsigned) length+1); + memcpy(objPtr->bytes, ensembleCmd->fullSubcmdName, (unsigned) length+1); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LogCommandInfo -- + * + * This function is invoked after an error occurs in an interpreter. It + * adds information to iPtr->errorInfo field to describe the command that + * was being executed when the error occurred. + * + * Results: + * None. + * + * Side effects: + * Information about the command is added to errorInfo and the line + * number stored internally in the interpreter is set. + * + *---------------------------------------------------------------------- + */ + +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). */ +{ + register const char *p; Interp *iPtr = (Interp *) interp; int overflow, limit = 150; Var *varPtr, *arrayPtr; if (iPtr->flags & ERR_ALREADY_LOGGED) { @@ -4918,212 +7008,61 @@ */ return; } - if (command != NULL) { - /* - * Compute the line number where the error occurred. - */ - - iPtr->errorLine = 1; - for (p = script; p != command; p++) { - if (*p == '\n') { - iPtr->errorLine++; - } - } - - if (length == TCL_INDEX_NONE) { - length = strlen(command); - } - overflow = (length > (size_t)limit); - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n %s\n\"%.*s%s\"", ((iPtr->errorInfo == NULL) - ? "while executing" : "invoked from within"), - (overflow ? limit : (int)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 - * ::errorInfo that existed Tcl releases before 8.5. To - * satisfy that compatibility need, we write the current - * -errorinfo value to the ::errorInfo variable. - */ - - Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo, - TCL_GLOBAL_ONLY); - } - } - } - - /* - * TIP #348 - */ - - if (Tcl_IsShared(iPtr->errorStack)) { - Tcl_Obj *newObj; - - newObj = Tcl_DuplicateObj(iPtr->errorStack); - Tcl_DecrRefCount(iPtr->errorStack); - Tcl_IncrRefCount(newObj); - iPtr->errorStack = newObj; - } - if (iPtr->resetErrorStack) { - int len; - - iPtr->resetErrorStack = 0; - Tcl_ListObjLength(interp, iPtr->errorStack, &len); - - /* - * Reset while keeping the list intrep as much as possible. - */ - - Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL); - if (pc != NULL) { - Tcl_Obj *innerContext; - - innerContext = TclGetInnerContext(interp, pc, tosPtr); - if (innerContext != NULL) { - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, - iPtr->innerLiteral); - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, innerContext); - } - } else if (command != NULL) { - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, - iPtr->innerLiteral); - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, - Tcl_NewStringObj(command, length)); - } - } - - if (!iPtr->framePtr->objc) { - /* - * Special frame, nothing to report. - */ - } else if (iPtr->varFramePtr != iPtr->framePtr) { - /* - * uplevel case, [lappend errorstack UP $relativelevel] - */ - - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral); - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewWideIntObj( - iPtr->framePtr->level - iPtr->varFramePtr->level)); - } else if (iPtr->framePtr != iPtr->rootFramePtr) { - /* - * normal case, [lappend errorstack CALL [info level 0]] - */ - - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->callLiteral); - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewListObj( - iPtr->framePtr->objc, iPtr->framePtr->objv)); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclErrorStackResetIf -- - * - * The TIP 348 reset/no-bc part of TLCI, for specific use by - * TclCompileSyntaxError. - * - * Results: - * None. - * - * Side effects: - * Reset errorstack if it needs be, and in that case remember the - * passed-in error message as inner context. - * - *---------------------------------------------------------------------- - */ - -void -TclErrorStackResetIf( - Tcl_Interp *interp, - const char *msg, - size_t length) -{ - Interp *iPtr = (Interp *) interp; - - if (Tcl_IsShared(iPtr->errorStack)) { - Tcl_Obj *newObj; - - newObj = Tcl_DuplicateObj(iPtr->errorStack); - Tcl_DecrRefCount(iPtr->errorStack); - Tcl_IncrRefCount(newObj); - iPtr->errorStack = newObj; - } - if (iPtr->resetErrorStack) { - int len; - - iPtr->resetErrorStack = 0; - Tcl_ListObjLength(interp, iPtr->errorStack, &len); - - /* - * Reset while keeping the list intrep as much as possible. - */ - - Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL); - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral); - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, - Tcl_NewStringObj(msg, length)); - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_LogCommandInfo -- - * - * This function is invoked after an error occurs in an interpreter. It - * adds information to iPtr->errorInfo/errorStack fields to describe the - * command that was being executed when the error occurred. - * - * Results: - * None. - * - * Side effects: - * Information about the command is added to errorInfo/errorStack and the - * line number stored internally in the interpreter is set. - * - *---------------------------------------------------------------------- - */ - -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. */ - size_t length) /* Number of bytes in command (-1 means use - * all bytes up to first null byte). */ -{ - TclLogCommandInfo(interp, script, command, length, NULL, NULL); -} - + /* + * Compute the line number where the error occurred. + */ + + 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 = 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 ::errorInfo that existed + * Tcl releases before 8.5. To satisfy that compatibility need, we + * write the current -errorinfo value to the ::errorInfo variable. + */ + + Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo, + TCL_GLOBAL_ONLY); + } + } +} /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 - * tab-width: 8 * End: */ Index: generic/tclNotify.c ================================================================== --- generic/tclNotify.c +++ generic/tclNotify.c @@ -15,18 +15,11 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" -/* - * Module-scope struct of notifier hooks that are checked in the default - * notifier functions (for overriding via Tcl_SetNotifier). - */ - -Tcl_NotifierProcs tclNotifierHooks = { - NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL -}; +extern TclStubs tclStubs; /* * For each event source (created with Tcl_CreateEventSource) there is a * structure of the following type: */ @@ -93,11 +86,11 @@ /* * Declarations for routines used only in this file. */ static void QueueEvent(ThreadSpecificData *tsdPtr, - Tcl_Event *evPtr, Tcl_QueuePosition position); + Tcl_Event* evPtr, Tcl_QueuePosition position); /* *---------------------------------------------------------------------- * * TclInitNotifier -- @@ -131,11 +124,11 @@ * Notifier not yet initialized in this thread. */ tsdPtr = TCL_TSD_INIT(&dataKey); tsdPtr->threadId = threadId; - tsdPtr->clientData = Tcl_InitNotifier(); + tsdPtr->clientData = tclStubs.tcl_InitNotifier(); tsdPtr->initialized = 1; tsdPtr->nextPtr = firstNotifierPtr; firstNotifierPtr = tsdPtr; } Tcl_MutexUnlock(&listLock); @@ -179,19 +172,21 @@ Tcl_MutexLock(&(tsdPtr->queueMutex)); for (evPtr = tsdPtr->firstEventPtr; evPtr != NULL; ) { hold = evPtr; evPtr = evPtr->nextPtr; - Tcl_Free(hold); + ckfree((char *) hold); } tsdPtr->firstEventPtr = NULL; tsdPtr->lastEventPtr = NULL; Tcl_MutexUnlock(&(tsdPtr->queueMutex)); Tcl_MutexLock(&listLock); - Tcl_FinalizeNotifier(tsdPtr->clientData); + if (tclStubs.tcl_FinalizeNotifier) { + tclStubs.tcl_FinalizeNotifier(tsdPtr->clientData); + } Tcl_MutexFinalize(&(tsdPtr->queueMutex)); for (prevPtrPtr = &firstNotifierPtr; *prevPtrPtr != NULL; prevPtrPtr = &((*prevPtrPtr)->nextPtr)) { if (*prevPtrPtr == tsdPtr) { *prevPtrPtr = tsdPtr->nextPtr; @@ -214,21 +209,31 @@ * * Results: * None. * * Side effects: - * Set the tclNotifierHooks global, which is checked in the default - * notifier functions. + * Overstomps part of the stub vector. This relies on hooks added to the + * default functions in case those are called directly (i.e., not through + * the stub table.) * *---------------------------------------------------------------------- */ void Tcl_SetNotifier( Tcl_NotifierProcs *notifierProcPtr) { - tclNotifierHooks = *notifierProcPtr; +#if !defined(__WIN32__) /* UNIX */ + tclStubs.tcl_CreateFileHandler = notifierProcPtr->createFileHandlerProc; + tclStubs.tcl_DeleteFileHandler = notifierProcPtr->deleteFileHandlerProc; +#endif + tclStubs.tcl_SetTimer = notifierProcPtr->setTimerProc; + tclStubs.tcl_WaitForEvent = notifierProcPtr->waitForEventProc; + tclStubs.tcl_InitNotifier = notifierProcPtr->initNotifierProc; + tclStubs.tcl_FinalizeNotifier = notifierProcPtr->finalizeNotifierProc; + tclStubs.tcl_AlertNotifier = notifierProcPtr->alertNotifierProc; + tclStubs.tcl_ServiceModeHook = notifierProcPtr->serviceModeHookProc; } /* *---------------------------------------------------------------------- * @@ -274,11 +279,11 @@ * happened. */ ClientData clientData) /* One-word argument to pass to setupProc and * checkProc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - EventSource *sourcePtr = (EventSource *)Tcl_Alloc(sizeof(EventSource)); + EventSource *sourcePtr = (EventSource *) ckalloc(sizeof(EventSource)); sourcePtr->setupProc = setupProc; sourcePtr->checkProc = checkProc; sourcePtr->clientData = clientData; sourcePtr->nextPtr = tsdPtr->firstEventSourcePtr; @@ -295,11 +300,11 @@ * * Results: * None. * * Side effects: - * The given event source is canceled, so its function will never again + * The given event source is cancelled, so its function will never again * be called. If no such source exists, nothing happens. * *---------------------------------------------------------------------- */ @@ -328,11 +333,11 @@ if (prevPtr == NULL) { tsdPtr->firstEventSourcePtr = sourcePtr->nextPtr; } else { prevPtr->nextPtr = sourcePtr->nextPtr; } - Tcl_Free(sourcePtr); + ckfree((char *) sourcePtr); return; } } /* @@ -351,20 +356,19 @@ *---------------------------------------------------------------------- */ void Tcl_QueueEvent( - Tcl_Event *evPtr, /* Event to add to queue. The storage space + Tcl_Event* evPtr, /* Event to add to queue. The storage space * must have been allocated the caller with - * malloc (Tcl_Alloc), and it becomes the + * 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); - QueueEvent(tsdPtr, evPtr, position); } /* *---------------------------------------------------------------------- @@ -385,11 +389,11 @@ 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 (Tcl_Alloc), and it becomes the + * 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. */ { @@ -410,11 +414,11 @@ */ if (tsdPtr) { QueueEvent(tsdPtr, evPtr, position); } else { - Tcl_Free(evPtr); + ckfree((char *) evPtr); } Tcl_MutexUnlock(&listLock); } /* @@ -442,11 +446,11 @@ 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 (Tcl_Alloc), and it becomes the + * 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. */ { @@ -514,17 +518,18 @@ */ void Tcl_DeleteEvents( Tcl_EventDeleteProc *proc, /* The function to call. */ - ClientData clientData) /* The type-specific data. */ + ClientData clientData) /* The type-specific data. */ { Tcl_Event *evPtr; /* Pointer to the event being examined */ Tcl_Event *prevPtr; /* Pointer to evPtr's predecessor, or NULL if * evPtr designates the first event in the * queue for the thread. */ - Tcl_Event *hold; + Tcl_Event* hold; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); Tcl_MutexLock(&(tsdPtr->queueMutex)); /* @@ -533,11 +538,11 @@ */ prevPtr = NULL; evPtr = tsdPtr->firstEventPtr; while (evPtr != NULL) { - if (proc(evPtr, clientData) == 1) { + if ((*proc)(evPtr, clientData) == 1) { /* * This event should be deleted. Unlink it. */ if (prevPtr == NULL) { @@ -561,11 +566,11 @@ * Delete the event data structure. */ hold = evPtr; evPtr = evPtr->nextPtr; - Tcl_Free(hold); + ckfree((char *) hold); } else { /* * Event is to be retained. */ @@ -665,11 +670,11 @@ * this thread. Note that we are making the assumption that if the * proc returns 0, the event is still in the list. */ Tcl_MutexUnlock(&(tsdPtr->queueMutex)); - result = proc(evPtr, flags); + result = (*proc)(evPtr, flags); Tcl_MutexLock(&(tsdPtr->queueMutex)); if (result) { /* * The event was processed, so remove it from the queue. @@ -700,11 +705,11 @@ } else { evPtr = NULL; } } if (evPtr) { - Tcl_Free(evPtr); + ckfree((char *) evPtr); } Tcl_MutexUnlock(&(tsdPtr->queueMutex)); return 1; } else { /* @@ -767,11 +772,13 @@ int oldMode; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); oldMode = tsdPtr->serviceMode; tsdPtr->serviceMode = mode; - Tcl_ServiceModeHook(mode); + if (tclStubs.tcl_ServiceModeHook) { + tclStubs.tcl_ServiceModeHook(mode); + } return oldMode; } /* *---------------------------------------------------------------------- @@ -792,11 +799,11 @@ *---------------------------------------------------------------------- */ void Tcl_SetMaxBlockTime( - const Tcl_Time *timePtr) /* Specifies a maximum elapsed time for the + Tcl_Time *timePtr) /* Specifies a maximum elapsed time for the * next blocking operation in the event * tsdPtr-> */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -925,11 +932,11 @@ tsdPtr->inTraversal = 1; for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL; sourcePtr = sourcePtr->nextPtr) { if (sourcePtr->setupProc) { - sourcePtr->setupProc(sourcePtr->clientData, flags); + (sourcePtr->setupProc)(sourcePtr->clientData, flags); } } tsdPtr->inTraversal = 0; if ((flags & TCL_DONT_WAIT) || tsdPtr->blockTimeSet) { @@ -954,11 +961,11 @@ */ for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL; sourcePtr = sourcePtr->nextPtr) { if (sourcePtr->checkProc) { - sourcePtr->checkProc(sourcePtr->clientData, flags); + (sourcePtr->checkProc)(sourcePtr->clientData, flags); } } /* * Check for events queued by the notifier or event sources. @@ -1064,17 +1071,17 @@ tsdPtr->blockTimeSet = 0; for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL; sourcePtr = sourcePtr->nextPtr) { if (sourcePtr->setupProc) { - sourcePtr->setupProc(sourcePtr->clientData, TCL_ALL_EVENTS); + (sourcePtr->setupProc)(sourcePtr->clientData, TCL_ALL_EVENTS); } } for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL; sourcePtr = sourcePtr->nextPtr) { if (sourcePtr->checkProc) { - sourcePtr->checkProc(sourcePtr->clientData, TCL_ALL_EVENTS); + (sourcePtr->checkProc)(sourcePtr->clientData, TCL_ALL_EVENTS); } } while (Tcl_ServiceEvent(0)) { result = 1; @@ -1123,11 +1130,13 @@ */ Tcl_MutexLock(&listLock); for (tsdPtr = firstNotifierPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) { if (tsdPtr->threadId == threadId) { - Tcl_AlertNotifier(tsdPtr->clientData); + if (tclStubs.tcl_AlertNotifier) { + tclStubs.tcl_AlertNotifier(tsdPtr->clientData); + } break; } } Tcl_MutexUnlock(&listLock); } DELETED generic/tclOO.c Index: generic/tclOO.c ================================================================== --- generic/tclOO.c +++ /dev/null @@ -1,3147 +0,0 @@ -/* - * tclOO.c -- - * - * This file contains the object-system core (NB: not Tcl_Obj, but ::oo) - * - * Copyright (c) 2005-2012 by Donal K. Fellows - * Copyright (c) 2017 by Nathan Coulter - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#ifdef HAVE_CONFIG_H -#include "config.h" -#endif -#include "tclInt.h" -#include "tclOOInt.h" - -/* - * Commands in oo::define. - */ - -static const struct { - const char *name; - Tcl_ObjCmdProc *objProc; - int flag; -} defineCmds[] = { - {"constructor", TclOODefineConstructorObjCmd, 0}, - {"definitionnamespace", TclOODefineDefnNsObjCmd, 0}, - {"deletemethod", TclOODefineDeleteMethodObjCmd, 0}, - {"destructor", TclOODefineDestructorObjCmd, 0}, - {"export", TclOODefineExportObjCmd, 0}, - {"forward", TclOODefineForwardObjCmd, 0}, - {"method", TclOODefineMethodObjCmd, 0}, - {"private", TclOODefinePrivateObjCmd, 0}, - {"renamemethod", TclOODefineRenameMethodObjCmd, 0}, - {"self", TclOODefineSelfObjCmd, 0}, - {"unexport", TclOODefineUnexportObjCmd, 0}, - {NULL, NULL, 0} -}, objdefCmds[] = { - {"class", TclOODefineClassObjCmd, 1}, - {"deletemethod", TclOODefineDeleteMethodObjCmd, 1}, - {"export", TclOODefineExportObjCmd, 1}, - {"forward", TclOODefineForwardObjCmd, 1}, - {"method", TclOODefineMethodObjCmd, 1}, - {"private", TclOODefinePrivateObjCmd, 1}, - {"renamemethod", TclOODefineRenameMethodObjCmd, 1}, - {"self", TclOODefineObjSelfObjCmd, 0}, - {"unexport", TclOODefineUnexportObjCmd, 1}, - {NULL, NULL, 0} -}; - -/* - * What sort of size of things we like to allocate. - */ - -#define ALLOC_CHUNK 8 - -/* - * Function declarations for things defined in this file. - */ - -static Object * AllocObject(Tcl_Interp *interp, const char *nameStr, - Namespace *nsPtr, const char *nsNameStr); -static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr, - Method *mPtr, Tcl_Obj *namePtr, - Method **newMPtrPtr); -static int CloneObjectMethod(Tcl_Interp *interp, Object *oPtr, - Method *mPtr, Tcl_Obj *namePtr); -static void DeletedDefineNamespace(ClientData clientData); -static void DeletedObjdefNamespace(ClientData clientData); -static void DeletedHelpersNamespace(ClientData clientData); -static Tcl_NRPostProc FinalizeAlloc; -static Tcl_NRPostProc FinalizeNext; -static Tcl_NRPostProc FinalizeObjectCall; -static inline void InitClassPath(Tcl_Interp * interp, Class *clsPtr); -static void InitClassSystemRoots(Tcl_Interp *interp, - Foundation *fPtr); -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); -static int PrivateNRObjectCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -static int MyClassNRObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -static void MyClassDeleted(ClientData clientData); - -/* - * Methods in the oo::object and oo::class classes. First, we define a helper - * macro that makes building the method type declaration structure a lot - * easier. No point in making life harder than it has to be! - * - * Note that the core methods don't need clone or free proc callbacks. - */ - -#define DCM(name,visibility,proc) \ - {name,visibility,\ - {TCL_OO_METHOD_VERSION_CURRENT,"core method: "#name,proc,NULL,NULL}} - -static const DeclaredClassMethod objMethods[] = { - DCM("destroy", 1, TclOO_Object_Destroy), - DCM("eval", 0, TclOO_Object_Eval), - DCM("unknown", 0, TclOO_Object_Unknown), - DCM("variable", 0, TclOO_Object_LinkVar), - DCM("varname", 0, TclOO_Object_VarName), - {NULL, 0, {0, NULL, NULL, NULL, NULL}} -}, clsMethods[] = { - DCM("create", 1, TclOO_Class_Create), - DCM("new", 1, TclOO_Class_New), - DCM("createWithNamespace", 0, TclOO_Class_CreateNs), - {NULL, 0, {0, NULL, NULL, NULL, NULL}} -}; - -/* - * And for the oo::class constructor... - */ - -static const Tcl_MethodType classConstructor = { - TCL_OO_METHOD_VERSION_CURRENT, - "oo::class constructor", - TclOO_Class_Constructor, NULL, NULL -}; - -/* - * Scripted parts of TclOO. First, the main script (cannot be outside this - * file). - */ - -static const char *initScript = -"package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};" -"namespace eval ::oo { variable version " TCLOO_VERSION " };" -"namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };"; -/* "tcl_findLibrary tcloo $oo::version $oo::version" */ -/* " tcloo.tcl OO_LIBRARY oo::library;"; */ - -/* - * The scripted part of the definitions of TclOO. - */ - -#include "tclOOScript.h" - -/* - * The actual definition of the variable holding the TclOO stub table. - */ - -MODULE_SCOPE const TclOOStubs tclOOStubs; - -/* - * Convenience macro for getting the foundation from an interpreter. - */ - -#define GetFoundation(interp) \ - ((Foundation *)((Interp *)(interp))->objectFoundation) - -/* - * Macros to make inspecting into the guts of an object cleaner. - * - * 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); \ - (lst).num--; \ - } while (0) - -/* - * ---------------------------------------------------------------------- - * - * RemoveClass, RemoveObject -- - * - * Helpers for the RemoveItem macro for deleting a class or object from a - * list. Setting the "empty" location to NULL makes debugging a little - * easier. - * - * ---------------------------------------------------------------------- - */ - -static inline void -RemoveClass( - Class **list, - int num, - int idx) -{ - for (; idx < num - 1; idx++) { - list[idx] = list[idx + 1]; - } - list[idx] = NULL; -} - -static inline void -RemoveObject( - Object **list, - int num, - int idx) -{ - for (; idx < num - 1; idx++) { - list[idx] = list[idx + 1]; - } - list[idx] = NULL; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOInit -- - * - * Called to initialise the OO system within an interpreter. - * - * Result: - * TCL_OK if the setup succeeded. Currently assumed to always work. - * - * Side effects: - * Creates namespaces, commands, several classes and a number of - * callbacks. Upon return, the OO system is ready for use. - * - * ---------------------------------------------------------------------- - */ - -int -TclOOInit( - Tcl_Interp *interp) /* The interpreter to install into. */ -{ - /* - * Build the core of the OO system. - */ - - if (InitFoundation(interp) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Run our initialization script and, if that works, declare the package - * to be fully provided. - */ - - if (Tcl_EvalEx(interp, initScript, -1, 0) != TCL_OK) { - return TCL_ERROR; - } - - return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL, - (void *) &tclOOStubs); -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOGetFoundation -- - * - * Get a reference to the OO core class system. - * - * ---------------------------------------------------------------------- - */ - -Foundation * -TclOOGetFoundation( - Tcl_Interp *interp) -{ - return GetFoundation(interp); -} - -/* - * ---------------------------------------------------------------------- - * - * InitFoundation -- - * - * Set up the core of the OO core class system. This is a structure - * holding references to the magical bits that need to be known about in - * other places, plus the oo::object and oo::class classes. - * - * ---------------------------------------------------------------------- - */ - -static int -InitFoundation( - Tcl_Interp *interp) -{ - static Tcl_ThreadDataKey tsdKey; - ThreadLocalData *tsdPtr = - (ThreadLocalData *)Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData)); - Foundation *fPtr = (Foundation *)Tcl_Alloc(sizeof(Foundation)); - Tcl_Obj *namePtr; - Tcl_DString buffer; - Command *cmdPtr; - int i; - - /* - * Initialize the structure that holds the OO system core. This is - * attached to the interpreter via an assocData entry; not very efficient, - * but the best we can do without hacking the core more. - */ - - memset(fPtr, 0, sizeof(Foundation)); - ((Interp *) interp)->objectFoundation = fPtr; - fPtr->interp = interp; - fPtr->ooNs = Tcl_CreateNamespace(interp, "::oo", fPtr, NULL); - Tcl_Export(interp, fPtr->ooNs, "[a-z]*", 1); - 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 = 1; - fPtr->tsdPtr = tsdPtr; - TclNewLiteralStringObj(fPtr->unknownMethodNameObj, "unknown"); - TclNewLiteralStringObj(fPtr->constructorName, ""); - TclNewLiteralStringObj(fPtr->destructorName, ""); - TclNewLiteralStringObj(fPtr->clonedName, ""); - TclNewLiteralStringObj(fPtr->defineName, "::oo::define"); - Tcl_IncrRefCount(fPtr->unknownMethodNameObj); - Tcl_IncrRefCount(fPtr->constructorName); - Tcl_IncrRefCount(fPtr->destructorName); - Tcl_IncrRefCount(fPtr->clonedName); - Tcl_IncrRefCount(fPtr->defineName); - Tcl_CreateObjCommand(interp, "::oo::UnknownDefinition", - TclOOUnknownDefinition, NULL, NULL); - TclNewLiteralStringObj(namePtr, "::oo::UnknownDefinition"); - Tcl_SetNamespaceUnknownHandler(interp, fPtr->defineNs, namePtr); - Tcl_SetNamespaceUnknownHandler(interp, fPtr->objdefNs, namePtr); - - /* - * Create the subcommands in the oo::define and oo::objdefine spaces. - */ - - Tcl_DStringInit(&buffer); - for (i = 0 ; defineCmds[i].name ; i++) { - TclDStringAppendLiteral(&buffer, "::oo::define::"); - Tcl_DStringAppend(&buffer, defineCmds[i].name, -1); - Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), - defineCmds[i].objProc, INT2PTR(defineCmds[i].flag), NULL); - Tcl_DStringFree(&buffer); - } - for (i = 0 ; objdefCmds[i].name ; i++) { - TclDStringAppendLiteral(&buffer, "::oo::objdefine::"); - Tcl_DStringAppend(&buffer, objdefCmds[i].name, -1); - Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), - objdefCmds[i].objProc, INT2PTR(objdefCmds[i].flag), NULL); - Tcl_DStringFree(&buffer); - } - - Tcl_CallWhenDeleted(interp, KillFoundation, NULL); - - /* - * Create the special objects at the core of the object system. - */ - - InitClassSystemRoots(interp, fPtr); - - /* - * Basic method declarations for the core classes. - */ - - for (i = 0 ; objMethods[i].name ; i++) { - TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]); - } - for (i = 0 ; clsMethods[i].name ; i++) { - TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]); - } - - /* - * Finish setting up the class of classes by marking the 'new' method as - * private; classes, unlike general objects, must have explicit names. We - * also need to create the constructor for classes. - */ - - TclNewLiteralStringObj(namePtr, "new"); - Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr, - namePtr /* keeps ref */, 0 /* private */, NULL, NULL); - fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp, - (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL); - - /* - * Create non-object commands and plug ourselves into the Tcl [info] - * ensemble. - */ - - cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::next", - NULL, TclOONextObjCmd, NULL, NULL); - cmdPtr->compileProc = TclCompileObjectNextCmd; - cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto", - NULL, TclOONextToObjCmd, NULL, NULL); - cmdPtr->compileProc = TclCompileObjectNextToCmd; - cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self", - TclOOSelfObjCmd, NULL, NULL); - cmdPtr->compileProc = TclCompileObjectSelfCmd; - Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL, - NULL); - Tcl_CreateObjCommand(interp, "::oo::objdefine", TclOOObjDefObjCmd, NULL, - NULL); - Tcl_CreateObjCommand(interp, "::oo::copy", TclOOCopyObjectCmd, NULL,NULL); - TclOOInitInfo(interp); - - /* - * Now make the class of slots. - */ - - if (TclOODefineSlots(fPtr) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Evaluate the remaining definitions, which are a compiled-in Tcl script. - */ - - return Tcl_EvalEx(interp, tclOOSetupScript, -1, 0); -} - -/* - * ---------------------------------------------------------------------- - * - * InitClassSystemRoots -- - * - * Creates the objects at the core of the object system. These need to be - * spliced manually. - * - * ---------------------------------------------------------------------- - */ - -static void -InitClassSystemRoots( - Tcl_Interp *interp, - Foundation *fPtr) -{ - Class fakeCls; - Object fakeObject; - Tcl_Obj *defNsName; - - /* Stand up a phony class for bootstrapping. */ - fPtr->objectCls = &fakeCls; - /* referenced in TclOOAllocClass to increment the refCount. */ - fakeCls.thisPtr = &fakeObject; - - fPtr->objectCls = TclOOAllocClass(interp, - AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL)); - /* Corresponding TclOODecrRefCount in KillFoudation */ - AddRef(fPtr->objectCls->thisPtr); - - /* - * This is why it is unnecessary in this routine to replace the - * incremented reference count of fPtr->objectCls that was swallowed by - * fakeObject. - */ - - fPtr->objectCls->superclasses.num = 0; - Tcl_Free(fPtr->objectCls->superclasses.list); - fPtr->objectCls->superclasses.list = NULL; - - /* - * Special initialization for the primordial objects. - */ - - fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT; - fPtr->objectCls->flags |= ROOT_OBJECT; - TclNewLiteralStringObj(defNsName, "::oo::objdefine"); - fPtr->objectCls->objDefinitionNs = defNsName; - Tcl_IncrRefCount(defNsName); - - fPtr->classCls = TclOOAllocClass(interp, - AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL)); - /* Corresponding TclOODecrRefCount in KillFoudation */ - AddRef(fPtr->classCls->thisPtr); - - /* - * Increment reference counts for each reference because these - * relationships can be dynamically changed. - * - * Corresponding TclOODecrRefCount for all incremented refcounts is in - * KillFoundation. - */ - - /* - * Rewire bootstrapped objects. - */ - - fPtr->objectCls->thisPtr->selfCls = fPtr->classCls; - AddRef(fPtr->classCls->thisPtr); - TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls); - - fPtr->classCls->thisPtr->selfCls = fPtr->classCls; - AddRef(fPtr->classCls->thisPtr); - TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls); - - fPtr->classCls->thisPtr->flags |= ROOT_CLASS; - fPtr->classCls->flags |= ROOT_CLASS; - TclNewLiteralStringObj(defNsName, "::oo::define"); - fPtr->classCls->clsDefinitionNs = defNsName; - Tcl_IncrRefCount(defNsName); - - /* Standard initialization for new Objects */ - TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls); - - /* - * THIS IS THE ONLY FUNCTION THAT DOES NON-STANDARD CLASS SPLICING. - * Everything else is careful to prohibit looping. - */ -} - -/* - * ---------------------------------------------------------------------- - * - * DeletedDefineNamespace, DeletedObjdefNamespace, DeletedHelpersNamespace -- - * - * Simple helpers used to clear fields of the foundation when they no - * longer hold useful information. - * - * ---------------------------------------------------------------------- - */ - -static void -DeletedDefineNamespace( - ClientData clientData) -{ - Foundation *fPtr = (Foundation *)clientData; - - fPtr->defineNs = NULL; -} - -static void -DeletedObjdefNamespace( - ClientData clientData) -{ - Foundation *fPtr = (Foundation *)clientData; - - fPtr->objdefNs = NULL; -} - -static void -DeletedHelpersNamespace( - ClientData clientData) -{ - Foundation *fPtr = (Foundation *)clientData; - - fPtr->helpersNs = NULL; -} - -/* - * ---------------------------------------------------------------------- - * - * KillFoundation -- - * - * Delete those parts of the OO core that are not deleted automatically - * when the objects and classes themselves are destroyed. - * - * ---------------------------------------------------------------------- - */ - -static void -KillFoundation( - TCL_UNUSED(void *), - Tcl_Interp *interp) /* The interpreter containing the OO system - * foundation. */ -{ - Foundation *fPtr = GetFoundation(interp); - - TclDecrRefCount(fPtr->unknownMethodNameObj); - TclDecrRefCount(fPtr->constructorName); - TclDecrRefCount(fPtr->destructorName); - TclDecrRefCount(fPtr->clonedName); - TclDecrRefCount(fPtr->defineName); - TclOODecrRefCount(fPtr->objectCls->thisPtr); - TclOODecrRefCount(fPtr->classCls->thisPtr); - - Tcl_Free(fPtr); -} - -/* - * ---------------------------------------------------------------------- - * - * AllocObject -- - * - * Allocate an object of basic type. Does not splice the object into its - * class's instance list. The caller must set the classPtr on the object - * to either a class or NULL, call TclOOAddToInstances to add the object - * to the class's instance list, and if the object itself is a class, use - * call TclOOAddToSubclasses() to add it to the right class's list of - * subclasses. - * - * ---------------------------------------------------------------------- - */ - -static Object * -AllocObject( - Tcl_Interp *interp, /* Interpreter within which to create the - * object. */ - const char *nameStr, /* The name of the object to create, or NULL - * if the OO system should pick the object - * name itself (equal to the namespace - * name). */ - Namespace *nsPtr, /* The namespace to create the object in, or - * NULL if *nameStr is NULL */ - const char *nsNameStr) /* The name of the namespace to create, or - * NULL if the OO system should pick a unique - * name itself. If this is non-NULL but names - * 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; - size_t creationEpoch; - - oPtr = (Object *)Tcl_Alloc(sizeof(Object)); - memset(oPtr, 0, sizeof(Object)); - - /* - * Every object has a namespace; make one. Note that this also normally - * computes the creation epoch value for the object, a sequence number - * that is unique to the object (and which allows us to manage method - * caching without comparing pointers). - * - * When creating a namespace, we first check to see if the caller - * specified the name for the namespace. If not, we generate namespace - * names using the epoch until such time as a new namespace is actually - * created. - */ - - if (nsNameStr != NULL) { - oPtr->namespacePtr = Tcl_CreateNamespace(interp, nsNameStr, oPtr, NULL); - if (oPtr->namespacePtr != NULL) { - creationEpoch = ++fPtr->tsdPtr->nsCount; - goto configNamespace; - } - Tcl_ResetResult(interp); - } - - while (1) { - char objName[10 + TCL_INTEGER_SPACE]; - - sprintf(objName, "::oo::Obj%" TCL_Z_MODIFIER "u", ++fPtr->tsdPtr->nsCount); - oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, NULL); - if (oPtr->namespacePtr != NULL) { - creationEpoch = fPtr->tsdPtr->nsCount; - break; - } - - /* - * Could not make that namespace, so we make another. But first we - * have to get rid of the error message from Tcl_CreateNamespace, - * since that's something that should not be exposed to the user. - */ - - Tcl_ResetResult(interp); - } - - configNamespace: - ((Namespace *) oPtr->namespacePtr)->refCount++; - - /* - * Make the namespace know about the helper commands. This grants access - * to the [self] and [next] commands. - */ - - if (fPtr->helpersNs != NULL) { - TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs); - } - TclOOSetupVariableResolver(oPtr->namespacePtr); - - /* - * Suppress use of compiled versions of the commands in this object's - * namespace and its children; causes wrong behaviour without expensive - * recompilation. [Bug 2037727] - */ - - ((Namespace *) oPtr->namespacePtr)->flags |= NS_SUPPRESS_COMPILATION; - - /* - * Set up a callback to get notification of the deletion of a namespace - * when enough of the namespace still remains to execute commands and - * access variables in it. [Bug 2950259] - */ - - ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc = ObjectNamespaceDeleted; - - /* - * Fill in the rest of the non-zero/NULL parts of the structure. - */ - - oPtr->fPtr = fPtr; - oPtr->creationEpoch = creationEpoch; - - /* - * An object starts life with a refCount of 2 to mark the two stages of - * destruction it occur: A call to ObjectRenamedTrace(), and a call to - * ObjectNamespaceDeleted(). - */ - - oPtr->refCount = 2; - oPtr->flags = USE_CLASS_CACHE; - - /* - * Finally, create the object commands and initialize the trace on the - * public command (so that the object structures are deleted when the - * command is deleted). - */ - - if (!nameStr) { - nameStr = oPtr->namespacePtr->name; - nsPtr = (Namespace *)oPtr->namespacePtr; - if (nsPtr->parentPtr != NULL) { - nsPtr = nsPtr->parentPtr; - } - } - oPtr->command = TclCreateObjCommandInNs(interp, nameStr, - (Tcl_Namespace *)nsPtr, TclOOPublicObjectCmd, oPtr, NULL); - - /* - * Add the NRE command and trace directly. While this breaks a number of - * abstractions, it is faster and we're inside Tcl here so we're allowed. - */ - - cmdPtr = (Command *) oPtr->command; - cmdPtr->nreProc = PublicNRObjectCmd; - cmdPtr->tracePtr = tracePtr = (CommandTrace *)Tcl_Alloc(sizeof(CommandTrace)); - tracePtr->traceProc = ObjectRenamedTrace; - tracePtr->clientData = oPtr; - tracePtr->flags = TCL_TRACE_RENAME|TCL_TRACE_DELETE; - tracePtr->nextPtr = NULL; - tracePtr->refCount = 1; - - oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr, - TclOOPrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted); - oPtr->myclassCommand = TclNRCreateCommandInNs(interp, "myclass", - oPtr->namespacePtr, TclOOMyClassObjCmd, MyClassNRObjCmd, oPtr, - MyClassDeleted); - return oPtr; -} - -/* - * ---------------------------------------------------------------------- - * - * SquelchCachedName -- - * - * Encapsulates how to throw away a cached object name. Called from - * object rename traces and at object destruction. - * - * ---------------------------------------------------------------------- - */ - -static inline void -SquelchCachedName( - Object *oPtr) -{ - if (oPtr->cachedNameObj) { - Tcl_DecrRefCount(oPtr->cachedNameObj); - oPtr->cachedNameObj = NULL; - } -} - -/* - * ---------------------------------------------------------------------- - * - * MyDeleted, MyClassDeleted -- - * - * These callbacks are triggered when the object's [my] or [myclass] - * commands are deleted by any mechanism. They just mark the object as - * not having a [my] command or [myclass] command, and so prevent cleanup - * of those commands when the object itself is deleted. - * - * ---------------------------------------------------------------------- - */ - -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; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODeleteDescendants -- - * - * Delete all descendants of a particular class. - * - * ---------------------------------------------------------------------- - */ - -void -TclOODeleteDescendants( - Tcl_Interp *interp, /* The interpreter containing the class. */ - Object *oPtr) /* The object representing the class. */ -{ - Class *clsPtr = oPtr->classPtr, *subclassPtr, *mixinSubclassPtr; - Object *instancePtr; - - /* - * Squelch classes that this class has been mixed into. - */ - - if (clsPtr->mixinSubs.num > 0) { - while (clsPtr->mixinSubs.num > 0) { - mixinSubclassPtr = - 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) { - Tcl_Free(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) { - Tcl_Free(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) { - Tcl_Free(clsPtr->instances.list); - clsPtr->instances.list = NULL; - clsPtr->instances.size = 0; - } -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOReleaseClassContents -- - * - * Tear down the special class data structure, including deleting all - * dependent classes and objects. - * - * ---------------------------------------------------------------------- - */ - -void -TclOOReleaseClassContents( - Tcl_Interp *interp, /* The interpreter containing the class. */ - Object *oPtr) /* The object representing the class. */ -{ - FOREACH_HASH_DECLS; - int i; - Class *clsPtr = oPtr->classPtr, *tmpClsPtr; - Method *mPtr; - Foundation *fPtr = oPtr->fPtr; - 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"); - } - } - - /* - * Stop using the class for definition information. - */ - - if (clsPtr->clsDefinitionNs) { - Tcl_DecrRefCount(clsPtr->clsDefinitionNs); - clsPtr->clsDefinitionNs = NULL; - } - if (clsPtr->objDefinitionNs) { - Tcl_DecrRefCount(clsPtr->objDefinitionNs); - clsPtr->objDefinitionNs = NULL; - } - - /* - * Squelch method implementation chain caches. - */ - - if (clsPtr->constructorChainPtr) { - TclOODeleteChain(clsPtr->constructorChainPtr); - clsPtr->constructorChainPtr = NULL; - } - if (clsPtr->destructorChainPtr) { - TclOODeleteChain(clsPtr->destructorChainPtr); - clsPtr->destructorChainPtr = NULL; - } - if (clsPtr->classChainCache) { - CallChain *callPtr; - - FOREACH_HASH_VALUE(callPtr, clsPtr->classChainCache) { - TclOODeleteChain(callPtr); - } - Tcl_DeleteHashTable(clsPtr->classChainCache); - Tcl_Free(clsPtr->classChainCache); - clsPtr->classChainCache = NULL; - } - - /* - * Squelch our filter list. - */ - - if (clsPtr->filters.num) { - Tcl_Obj *filterObj; - - FOREACH(filterObj, clsPtr->filters) { - TclDecrRefCount(filterObj); - } - Tcl_Free(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); - Tcl_Free(clsPtr->metadataPtr); - clsPtr->metadataPtr = NULL; - } - - if (clsPtr->mixins.num) { - FOREACH(tmpClsPtr, clsPtr->mixins) { - TclOORemoveFromMixinSubs(clsPtr, tmpClsPtr); - TclOODecrRefCount(tmpClsPtr->thisPtr); - } - Tcl_Free(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); - } - Tcl_Free(clsPtr->superclasses.list); - clsPtr->superclasses.num = 0; - clsPtr->superclasses.list = NULL; - } - - FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) { - TclOODelMethodRef(mPtr); - } - Tcl_DeleteHashTable(&clsPtr->classMethods); - TclOODelMethodRef(clsPtr->constructorPtr); - TclOODelMethodRef(clsPtr->destructorPtr); - - FOREACH(variableObj, clsPtr->variables) { - TclDecrRefCount(variableObj); - } - if (i) { - Tcl_Free(clsPtr->variables.list); - } - - FOREACH_STRUCT(privateVariable, clsPtr->privateVariables) { - TclDecrRefCount(privateVariable->variableObj); - TclDecrRefCount(privateVariable->fullNameObj); - } - if (i) { - Tcl_Free(clsPtr->privateVariables.list); - } - - if (IsRootClass(oPtr) && !Destructing(fPtr->objectCls->thisPtr)) { - Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command); - } -} - -/* - * ---------------------------------------------------------------------- - * - * ObjectNamespaceDeleted -- - * - * Callback when the object's namespace is deleted. Used to clean up the - * data structures associated with the object. The complicated bit is - * that this can sometimes happen before the object's command is deleted - * (interpreter teardown is complex!) - * - * ---------------------------------------------------------------------- - */ - -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); - } - - /* - * We do not run destructors on the core class objects when the - * interpreter is being deleted; their incestuous nature causes problems - * in that case when the destructor is partially deleted before the uses - * of it have gone. [Bug 2949397] - */ - - if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) { - CallContext *contextPtr = - TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, NULL); - int result; - Tcl_InterpState state; - - oPtr->flags |= DESTRUCTOR_CALLED; - - if (contextPtr != NULL) { - contextPtr->callPtr->flags |= DESTRUCTOR; - contextPtr->skip = 0; - state = Tcl_SaveInterpState(interp, TCL_OK); - result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, - contextPtr, 0, NULL); - if (result != TCL_OK) { - Tcl_BackgroundException(interp, result); - } - Tcl_RestoreInterpState(interp, state); - TclOODeleteContext(contextPtr); - } - } - - /* - * Instruct everyone to no longer use any allocated fields of the object. - * Also delete the command that refers to the object at this point (if it - * still exists) because otherwise its pointer to the object points into - * freed memory. - */ - - if (((Command *) oPtr->command)->flags && CMD_DYING) { - /* - * Something has already started the command deletion process. We can - * go ahead and clean up the the namespace, - */ - } else { - /* - * The namespace must have been deleted directly. Delete the command - * as well. - */ - - Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); - } - - if (oPtr->myclassCommand) { - Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myclassCommand); - } - if (oPtr->myCommand) { - Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand); - } - - /* - * Splice the object out of its context. After this, we must *not* call - * methods on the object. - */ - - /* TODO: Should this be protected with a !IsRoot() condition? */ - TclOORemoveFromInstances(oPtr, oPtr->selfCls); - - if (oPtr->mixins.num > 0) { - FOREACH(mixinPtr, oPtr->mixins) { - TclOORemoveFromInstances(oPtr, mixinPtr); - TclOODecrRefCount(mixinPtr->thisPtr); - } - if (oPtr->mixins.list != NULL) { - Tcl_Free(oPtr->mixins.list); - } - } - - FOREACH(filterObj, oPtr->filters) { - TclDecrRefCount(filterObj); - } - if (i) { - Tcl_Free(oPtr->filters.list); - } - - if (oPtr->methodsPtr) { - FOREACH_HASH_VALUE(mPtr, oPtr->methodsPtr) { - TclOODelMethodRef(mPtr); - } - Tcl_DeleteHashTable(oPtr->methodsPtr); - Tcl_Free(oPtr->methodsPtr); - } - - FOREACH(variableObj, oPtr->variables) { - TclDecrRefCount(variableObj); - } - if (i) { - Tcl_Free(oPtr->variables.list); - } - - FOREACH_STRUCT(privateVariable, oPtr->privateVariables) { - TclDecrRefCount(privateVariable->variableObj); - TclDecrRefCount(privateVariable->fullNameObj); - } - if (i) { - Tcl_Free(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); - Tcl_Free(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); - } - - /* - * Delete the object structure itself. - */ - - TclNsDecrRefCount((Namespace *)oPtr->namespacePtr); - oPtr->namespacePtr = NULL; - TclOODecrRefCount(oPtr->selfCls->thisPtr); - oPtr->selfCls = NULL; - TclOODecrRefCount(oPtr); - return; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODecrRefCount -- - * - * Decrement the refcount of an object and deallocate storage then object - * is no longer referenced. Returns 1 if storage was deallocated, and 0 - * otherwise. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODecrRefCount( - Object *oPtr) -{ - if (oPtr->refCount-- <= 1) { - - if (oPtr->classPtr != NULL) { - Tcl_Free(oPtr->classPtr); - } - Tcl_Free(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 - * a class. - * - * ---------------------------------------------------------------------- - */ - -int -TclOORemoveFromInstances( - Object *oPtr, /* The instance to remove. */ - Class *clsPtr) /* The class (possibly) containing the - * reference to the instance. */ -{ - int i, res = 0; - Object *instPtr; - - FOREACH(instPtr, clsPtr->instances) { - if (oPtr == instPtr) { - RemoveItem(Object, clsPtr->instances, i); - TclOODecrRefCount(oPtr); - res++; - break; - } - } - return res; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOAddToInstances -- - * - * Utility function to add an object to the list of instances within a - * class. - * - * ---------------------------------------------------------------------- - */ - -void -TclOOAddToInstances( - Object *oPtr, /* The instance to add. */ - Class *clsPtr) /* The class to add the instance to. It is - * assumed that the class is not already - * present as an instance in the class. */ -{ - if (clsPtr->instances.num >= clsPtr->instances.size) { - clsPtr->instances.size += ALLOC_CHUNK; - if (clsPtr->instances.size == ALLOC_CHUNK) { - clsPtr->instances.list = (Object **)Tcl_Alloc(sizeof(Object *) * ALLOC_CHUNK); - } else { - clsPtr->instances.list = (Object **)Tcl_Realloc(clsPtr->instances.list, - sizeof(Object *) * clsPtr->instances.size); - } - } - clsPtr->instances.list[clsPtr->instances.num++] = oPtr; - AddRef(oPtr); -} - -/* - * ---------------------------------------------------------------------- - * - * TclOORemoveFromMixins -- - * - * Utility function to remove a class from the list of mixins within an - * object. - * - * ---------------------------------------------------------------------- - */ - -int -TclOORemoveFromMixins( - Class *mixinPtr, /* The mixin to remove. */ - Object *oPtr) /* The object (possibly) containing the - * reference to the mixin. */ -{ - int i, res = 0; - Class *mixPtr; - - FOREACH(mixPtr, oPtr->mixins) { - if (mixinPtr == mixPtr) { - RemoveItem(Class, oPtr->mixins, i); - TclOODecrRefCount(mixPtr->thisPtr); - res++; - break; - } - } - if (oPtr->mixins.num == 0) { - Tcl_Free(oPtr->mixins.list); - oPtr->mixins.list = NULL; - } - return res; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOORemoveFromSubclasses -- - * - * Utility function to remove a class from the list of subclasses within - * another class. Returns the number of removals performed. - * - * ---------------------------------------------------------------------- - */ - -int -TclOORemoveFromSubclasses( - Class *subPtr, /* The subclass to remove. */ - Class *superPtr) /* The superclass to possibly remove the - * subclass reference from. */ -{ - int i, res = 0; - Class *subclsPtr; - - FOREACH(subclsPtr, superPtr->subclasses) { - if (subPtr == subclsPtr) { - RemoveItem(Class, superPtr->subclasses, i); - TclOODecrRefCount(subPtr->thisPtr); - res++; - } - } - return res; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOAddToSubclasses -- - * - * Utility function to add a class to the list of subclasses within - * another class. - * - * ---------------------------------------------------------------------- - */ - -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 **)Tcl_Alloc(sizeof(Class *) * ALLOC_CHUNK); - } else { - superPtr->subclasses.list = (Class **)Tcl_Realloc(superPtr->subclasses.list, - sizeof(Class *) * superPtr->subclasses.size); - } - } - superPtr->subclasses.list[superPtr->subclasses.num++] = subPtr; - AddRef(subPtr->thisPtr); -} - -/* - * ---------------------------------------------------------------------- - * - * TclOORemoveFromMixinSubs -- - * - * Utility function to remove a class from the list of mixinSubs within - * another class. - * - * ---------------------------------------------------------------------- - */ - -int -TclOORemoveFromMixinSubs( - Class *subPtr, /* The subclass to remove. */ - Class *superPtr) /* The superclass to possibly remove the - * subclass reference from. */ -{ - int i, res = 0; - Class *subclsPtr; - - FOREACH(subclsPtr, superPtr->mixinSubs) { - if (subPtr == subclsPtr) { - RemoveItem(Class, superPtr->mixinSubs, i); - TclOODecrRefCount(subPtr->thisPtr); - res++; - break; - } - } - return res; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOAddToMixinSubs -- - * - * Utility function to add a class to the list of mixinSubs within - * another class. - * - * ---------------------------------------------------------------------- - */ - -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 **)Tcl_Alloc(sizeof(Class *) * ALLOC_CHUNK); - } else { - superPtr->mixinSubs.list = (Class **)Tcl_Realloc(superPtr->mixinSubs.list, - sizeof(Class *) * superPtr->mixinSubs.size); - } - } - superPtr->mixinSubs.list[superPtr->mixinSubs.num++] = subPtr; - AddRef(subPtr->thisPtr); -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOAllocClass -- - * - * Allocate a basic class. Does not add class to its class's instance - * list. - * - * ---------------------------------------------------------------------- - */ - -static inline void -InitClassPath( - Tcl_Interp *interp, - Class *clsPtr) -{ - Foundation *fPtr = GetFoundation(interp); - - if (fPtr->helpersNs != NULL) { - Tcl_Namespace *path[2]; - - path[0] = fPtr->helpersNs; - path[1] = fPtr->ooNs; - TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path); - } else { - TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1, - &fPtr->ooNs); - } -} - -Class * -TclOOAllocClass( - Tcl_Interp *interp, /* Interpreter within which to allocate the - * class. */ - Object *useThisObj) /* Object that is to act as the class - * representation. */ -{ - Foundation *fPtr = GetFoundation(interp); - Class *clsPtr = (Class *)Tcl_Alloc(sizeof(Class)); - - memset(clsPtr, 0, sizeof(Class)); - clsPtr->thisPtr = useThisObj; - - /* - * Configure the namespace path for the class's object. - */ - - InitClassPath(interp, clsPtr); - - /* - * Classes are subclasses of oo::object, i.e. the objects they create are - * objects. - */ - - clsPtr->superclasses.num = 1; - clsPtr->superclasses.list = (Class **)Tcl_Alloc(sizeof(Class *)); - clsPtr->superclasses.list[0] = fPtr->objectCls; - AddRef(fPtr->objectCls->thisPtr); - - /* - * Finish connecting the class structure to the object structure. - */ - - clsPtr->thisPtr->classPtr = clsPtr; - - /* - * That's the complicated bit. Now fill in the rest of the non-zero/NULL - * fields. - */ - - Tcl_InitObjHashTable(&clsPtr->classMethods); - return clsPtr; -} - -/* - * ---------------------------------------------------------------------- - * - * Tcl_NewObjectInstance -- - * - * Allocate a new instance of an object. - * - * ---------------------------------------------------------------------- - */ -Tcl_Object -Tcl_NewObjectInstance( - Tcl_Interp *interp, /* Interpreter context. */ - Tcl_Class cls, /* Class to create an instance of. */ - const char *nameStr, /* Name of object to create, or NULL to ask - * the code to pick its own unique name. */ - const char *nsNameStr, /* Name of namespace to create inside object, - * or NULL to ask the code to pick its own - * unique name. */ - 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; - } - - /* - * Run constructors, except when objc < 0, which is a special flag case - * used for object cloning only. - */ - - if (objc >= 0) { - CallContext *contextPtr = - TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL); - - if (contextPtr != NULL) { - int isRoot, result; - Tcl_InterpState state; - - state = Tcl_SaveInterpState(interp, TCL_OK); - contextPtr->callPtr->flags |= CONSTRUCTOR; - contextPtr->skip = skip; - - /* - * Adjust the ensemble tracking record if necessary. [Bug 3514761] - */ - - isRoot = TclInitRewriteEnsemble(interp, skip, skip, objv); - result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, - objc, objv); - - if (isRoot) { - TclResetRewriteEnsemble(interp, 1); - } - - clientData[0] = contextPtr; - clientData[1] = oPtr; - clientData[2] = state; - clientData[3] = &oPtr; - - result = FinalizeAlloc(clientData, interp, result); - if (result != TCL_OK) { - return NULL; - } - } - } - - return (Tcl_Object) oPtr; -} - -int -TclNRNewObjectInstance( - Tcl_Interp *interp, /* Interpreter context. */ - Tcl_Class cls, /* Class to create an instance of. */ - const char *nameStr, /* Name of object to create, or NULL to ask - * the code to pick its own unique name. */ - const char *nsNameStr, /* Name of namespace to create inside object, - * or NULL to ask the code to pick its own - * unique name. */ - 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. */ - 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; - } - - /* - * Run constructors, except when objc < 0 (a special flag case used for - * object cloning only). If there aren't any constructors, we do nothing. - */ - - if (objc < 0) { - *objectPtr = (Tcl_Object) oPtr; - return TCL_OK; - } - contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL); - if (contextPtr == NULL) { - *objectPtr = (Tcl_Object) oPtr; - return TCL_OK; - } - - state = Tcl_SaveInterpState(interp, TCL_OK); - contextPtr->callPtr->flags |= CONSTRUCTOR; - contextPtr->skip = skip; - - /* - * Adjust the ensemble tracking record if necessary. [Bug 3514761] - */ - - if (TclInitRewriteEnsemble(interp, skip, skip, objv)) { - TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); - } - - /* - * Fire off the constructors non-recursively. - */ - - TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state, - objectPtr); - TclPushTailcallPoint(interp); - return TclOOInvokeContext(contextPtr, interp, objc, objv); -} - -Object * -TclNewObjectInstanceCommon( - Tcl_Interp *interp, - Class *classPtr, - const char *nameStr, - const char *nsNameStr) -{ - Tcl_HashEntry *hPtr; - Foundation *fPtr = GetFoundation(interp); - Object *oPtr; - const char *simpleName = NULL; - Namespace *nsPtr = NULL, *dummy; - Namespace *inNsPtr = (Namespace *) TclGetCurrentNamespace(interp); - - if (nameStr) { - TclGetNamespaceForQualName(interp, nameStr, inNsPtr, - TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy, &dummy, &simpleName); - - /* - * Disallow creation of an object over an existing command. - */ - - hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simpleName); - if (hPtr) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create object \"%s\": command already exists with" - " that name", nameStr)); - Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL); - return NULL; - } - } - - /* - * Create the object. - */ - - oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr); - oPtr->selfCls = classPtr; - AddRef(classPtr->thisPtr); - TclOOAddToInstances(oPtr, classPtr); - - /* - * Check to see if we're really creating a class. If so, allocate the - * class structure as well. - */ - - if (TclOOIsReachable(fPtr->classCls, classPtr)) { - /* - * Is a class, so attach a class structure. Note that the - * TclOOAllocClass function splices the structure into the object, so - * we don't have to. Once that's done, we need to repatch the object - * to have the right class since TclOOAllocClass interferes with that. - */ - - TclOOAllocClass(interp, oPtr); - TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls); - } else { - oPtr->classPtr = NULL; - } - return oPtr; -} - -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. - */ - - TclOODeleteContext(contextPtr); - return TCL_ERROR; - } - Tcl_RestoreInterpState(interp, state); - *objectPtr = (Tcl_Object) oPtr; - - /* - * This decrements the refcount of oPtr. - */ - - TclOODeleteContext(contextPtr); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * Tcl_CopyObjectInstance -- - * - * Creates a copy of an object. Does not copy the backing namespace, - * since the correct way to do that (e.g., shallow/deep) depends on the - * object/class's own policies. - * - * ---------------------------------------------------------------------- - */ - -Tcl_Object -Tcl_CopyObjectInstance( - Tcl_Interp *interp, - Tcl_Object sourceObject, - const char *targetName, - const char *targetNamespaceName) -{ - Object *oPtr = (Object *) sourceObject, *o2Ptr; - FOREACH_HASH_DECLS; - Method *mPtr; - Class *mixinPtr; - CallContext *contextPtr; - Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3]; - PrivateVariableMapping *privateVariable; - int i, result; - - /* - * Sanity check. - */ - - if (IsRootClass(oPtr)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not clone the class of classes", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", NULL); - return NULL; - } - - /* - * Build the instance. Note that this does not run any constructors. - */ - - o2Ptr = (Object *) Tcl_NewObjectInstance(interp, - (Tcl_Class) oPtr->selfCls, targetName, targetNamespaceName, -1, - NULL, -1); - if (o2Ptr == NULL) { - return NULL; - } - - /* - * Copy the object-local methods to the new object. - */ - - if (oPtr->methodsPtr) { - FOREACH_HASH(keyPtr, mPtr, oPtr->methodsPtr) { - if (CloneObjectMethod(interp, o2Ptr, mPtr, keyPtr) != TCL_OK) { - Tcl_DeleteCommandFromToken(interp, o2Ptr->command); - return NULL; - } - } - } - - /* - * Copy the object's mixin references to the new object. - */ - - if (o2Ptr->mixins.num != 0) { - FOREACH(mixinPtr, o2Ptr->mixins) { - if (mixinPtr && mixinPtr != o2Ptr->selfCls) { - TclOORemoveFromInstances(o2Ptr, mixinPtr); - } - TclOODecrRefCount(mixinPtr->thisPtr); - } - Tcl_Free(o2Ptr->mixins.list); - } - DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *); - FOREACH(mixinPtr, o2Ptr->mixins) { - if (mixinPtr && mixinPtr != o2Ptr->selfCls) { - TclOOAddToInstances(o2Ptr, mixinPtr); - } - - /* - * For the reference just created in DUPLICATE. - */ - - AddRef(mixinPtr->thisPtr); - } - - /* - * Copy the object's filter list to the new object. - */ - - DUPLICATE(o2Ptr->filters, oPtr->filters, Tcl_Obj *); - FOREACH(filterObj, o2Ptr->filters) { - Tcl_IncrRefCount(filterObj); - } - - /* - * Copy the object's variable resolution lists to the new object. - */ - - DUPLICATE(o2Ptr->variables, oPtr->variables, Tcl_Obj *); - FOREACH(variableObj, o2Ptr->variables) { - Tcl_IncrRefCount(variableObj); - } - - DUPLICATE(o2Ptr->privateVariables, oPtr->privateVariables, - PrivateVariableMapping); - FOREACH_STRUCT(privateVariable, o2Ptr->privateVariables) { - Tcl_IncrRefCount(privateVariable->variableObj); - Tcl_IncrRefCount(privateVariable->fullNameObj); - } - - /* - * 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; - ClientData value, duplicate; - - FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) { - if (metadataTypePtr->cloneProc == NULL) { - duplicate = value; - } else { - if (metadataTypePtr->cloneProc(interp, value, - &duplicate) != TCL_OK) { - Tcl_DeleteCommandFromToken(interp, o2Ptr->command); - return NULL; - } - } - if (duplicate != NULL) { - Tcl_ObjectSetMetadata((Tcl_Object) o2Ptr, metadataTypePtr, - duplicate); - } - } - } - - /* - * Copy the class, if present. Note that if there is a class present in - * the source object, there must also be one in the copy. - */ - - if (oPtr->classPtr != NULL) { - Class *clsPtr = oPtr->classPtr; - Class *cls2Ptr = o2Ptr->classPtr; - Class *superPtr; - - /* - * Copy the class flags across. - */ - - cls2Ptr->flags = clsPtr->flags; - - /* - * Ensure that the new class's superclass structure is the same as the - * old class's. - */ - - FOREACH(superPtr, cls2Ptr->superclasses) { - TclOORemoveFromSubclasses(cls2Ptr, superPtr); - TclOODecrRefCount(superPtr->thisPtr); - } - if (cls2Ptr->superclasses.num) { - cls2Ptr->superclasses.list = (Class **)Tcl_Realloc(cls2Ptr->superclasses.list, - sizeof(Class *) * clsPtr->superclasses.num); - } else { - cls2Ptr->superclasses.list = - (Class **)Tcl_Alloc(sizeof(Class *) * clsPtr->superclasses.num); - } - memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list, - sizeof(Class *) * clsPtr->superclasses.num); - cls2Ptr->superclasses.num = clsPtr->superclasses.num; - FOREACH(superPtr, cls2Ptr->superclasses) { - TclOOAddToSubclasses(cls2Ptr, superPtr); - - /* - * For the new item in cls2Ptr->superclasses that memcpy just - * created. - */ - - AddRef(superPtr->thisPtr); - } - - /* - * Duplicate the source class's filters. - */ - - DUPLICATE(cls2Ptr->filters, clsPtr->filters, Tcl_Obj *); - FOREACH(filterObj, cls2Ptr->filters) { - Tcl_IncrRefCount(filterObj); - } - - /* - * Copy the source class's variable resolution lists. - */ - - DUPLICATE(cls2Ptr->variables, clsPtr->variables, Tcl_Obj *); - FOREACH(variableObj, cls2Ptr->variables) { - Tcl_IncrRefCount(variableObj); - } - - DUPLICATE(cls2Ptr->privateVariables, clsPtr->privateVariables, - PrivateVariableMapping); - FOREACH_STRUCT(privateVariable, cls2Ptr->privateVariables) { - Tcl_IncrRefCount(privateVariable->variableObj); - Tcl_IncrRefCount(privateVariable->fullNameObj); - } - - /* - * Duplicate the source class's mixins (which cannot be circular - * references to the duplicate). - */ - - if (cls2Ptr->mixins.num != 0) { - FOREACH(mixinPtr, cls2Ptr->mixins) { - TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr); - TclOODecrRefCount(mixinPtr->thisPtr); - } - Tcl_Free(clsPtr->mixins.list); - } - DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *); - FOREACH(mixinPtr, cls2Ptr->mixins) { - TclOOAddToMixinSubs(cls2Ptr, mixinPtr); - - /* - * For the copy just created in DUPLICATE. - */ - - AddRef(mixinPtr->thisPtr); - } - - /* - * Duplicate the source class's methods, constructor and destructor. - */ - - FOREACH_HASH(keyPtr, mPtr, &clsPtr->classMethods) { - if (CloneClassMethod(interp, cls2Ptr, mPtr, keyPtr, - NULL) != TCL_OK) { - Tcl_DeleteCommandFromToken(interp, o2Ptr->command); - return NULL; - } - } - if (clsPtr->constructorPtr) { - if (CloneClassMethod(interp, cls2Ptr, clsPtr->constructorPtr, - NULL, &cls2Ptr->constructorPtr) != TCL_OK) { - Tcl_DeleteCommandFromToken(interp, o2Ptr->command); - return NULL; - } - } - if (clsPtr->destructorPtr) { - if (CloneClassMethod(interp, cls2Ptr, clsPtr->destructorPtr, NULL, - &cls2Ptr->destructorPtr) != TCL_OK) { - Tcl_DeleteCommandFromToken(interp, o2Ptr->command); - return NULL; - } - } - - /* - * Duplicate the class's metadata. - */ - - if (clsPtr->metadataPtr != NULL) { - Tcl_ObjectMetadataType *metadataTypePtr; - ClientData value, duplicate; - - FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) { - if (metadataTypePtr->cloneProc == NULL) { - duplicate = value; - } else { - if (metadataTypePtr->cloneProc(interp, value, - &duplicate) != TCL_OK) { - Tcl_DeleteCommandFromToken(interp, o2Ptr->command); - return NULL; - } - } - if (duplicate != NULL) { - Tcl_ClassSetMetadata((Tcl_Class) cls2Ptr, metadataTypePtr, - duplicate); - } - } - } - } - - TclResetRewriteEnsemble(interp, 1); - contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL, - NULL, NULL); - if (contextPtr) { - args[0] = TclOOObjectName(interp, o2Ptr); - args[1] = oPtr->fPtr->clonedName; - args[2] = TclOOObjectName(interp, oPtr); - Tcl_IncrRefCount(args[0]); - Tcl_IncrRefCount(args[1]); - Tcl_IncrRefCount(args[2]); - result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, 3, - args); - TclDecrRefCount(args[0]); - TclDecrRefCount(args[1]); - TclDecrRefCount(args[2]); - TclOODeleteContext(contextPtr); - if (result == TCL_ERROR) { - Tcl_AddErrorInfo(interp, - "\n (while performing post-copy callback)"); - } - if (result != TCL_OK) { - Tcl_DeleteCommandFromToken(interp, o2Ptr->command); - return NULL; - } - } - - return (Tcl_Object) o2Ptr; -} - -/* - * ---------------------------------------------------------------------- - * - * CloneObjectMethod, CloneClassMethod -- - * - * Helper functions used for cloning methods. They work identically to - * each other, except for the difference between them in how they - * register the cloned method on a successful clone. - * - * ---------------------------------------------------------------------- - */ - -static int -CloneObjectMethod( - Tcl_Interp *interp, - Object *oPtr, - Method *mPtr, - Tcl_Obj *namePtr) -{ - if (mPtr->typePtr == NULL) { - Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr, - mPtr->flags & PUBLIC_METHOD, NULL, NULL); - } else if (mPtr->typePtr->cloneProc) { - ClientData newClientData; - - if (mPtr->typePtr->cloneProc(interp, mPtr->clientData, - &newClientData) != TCL_OK) { - return TCL_ERROR; - } - Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr, - mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, newClientData); - } else { - Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr, - mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, mPtr->clientData); - } - return TCL_OK; -} - -static int -CloneClassMethod( - Tcl_Interp *interp, - Class *clsPtr, - Method *mPtr, - Tcl_Obj *namePtr, - Method **m2PtrPtr) -{ - Method *m2Ptr; - - if (mPtr->typePtr == NULL) { - m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, - namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL); - } else if (mPtr->typePtr->cloneProc) { - ClientData newClientData; - - if (mPtr->typePtr->cloneProc(interp, mPtr->clientData, - &newClientData) != TCL_OK) { - return TCL_ERROR; - } - m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, - namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, - newClientData); - } else { - m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, - namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, - mPtr->clientData); - } - if (m2PtrPtr != NULL) { - *m2PtrPtr = m2Ptr; - } - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * Tcl_ClassGetMetadata, Tcl_ClassSetMetadata, Tcl_ObjectGetMetadata, - * Tcl_ObjectSetMetadata -- - * - * Metadata management API. The metadata system allows code in extensions - * to attach arbitrary non-NULL pointers to objects and classes without - * the different things that might be interested being able to interfere - * with each other. Apart from non-NULL-ness, these routines attach no - * interpretation to the meaning of the metadata pointers. - * - * The Tcl_*GetMetadata routines get the metadata pointer attached that - * has been related with a particular type, or NULL if no metadata - * associated with the given type has been attached. - * - * The Tcl_*SetMetadata routines set or delete the metadata pointer that - * is related to a particular type. The value associated with the type is - * deleted (if present; no-op otherwise) if the value is NULL, and - * attached (replacing the previous value, which is deleted if present) - * otherwise. This means it is impossible to attach a NULL value for any - * metadata type. - * - * ---------------------------------------------------------------------- - */ - -ClientData -Tcl_ClassGetMetadata( - Tcl_Class clazz, - const Tcl_ObjectMetadataType *typePtr) -{ - Class *clsPtr = (Class *) clazz; - Tcl_HashEntry *hPtr; - - /* - * If there's no metadata store attached, the type in question has - * definitely not been attached either! - */ - - if (clsPtr->metadataPtr == NULL) { - return NULL; - } - - /* - * There is a metadata store, so look in it for the given type. - */ - - hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, (char *) typePtr); - - /* - * Return the metadata value if we found it, otherwise NULL. - */ - - if (hPtr == NULL) { - return NULL; - } - return Tcl_GetHashValue(hPtr); -} - -void -Tcl_ClassSetMetadata( - Tcl_Class clazz, - const Tcl_ObjectMetadataType *typePtr, - ClientData metadata) -{ - Class *clsPtr = (Class *) clazz; - Tcl_HashEntry *hPtr; - int isNew; - - /* - * Attach the metadata store if not done already. - */ - - if (clsPtr->metadataPtr == NULL) { - if (metadata == NULL) { - return; - } - clsPtr->metadataPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(clsPtr->metadataPtr, TCL_ONE_WORD_KEYS); - } - - /* - * If the metadata is NULL, we're deleting the metadata for the type. - */ - - if (metadata == NULL) { - hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, (char *) typePtr); - if (hPtr != NULL) { - typePtr->deleteProc(Tcl_GetHashValue(hPtr)); - Tcl_DeleteHashEntry(hPtr); - } - return; - } - - /* - * Otherwise we're attaching the metadata. Note that if there was already - * some metadata attached of this type, we delete that first. - */ - - hPtr = Tcl_CreateHashEntry(clsPtr->metadataPtr, (char *) typePtr, &isNew); - if (!isNew) { - typePtr->deleteProc(Tcl_GetHashValue(hPtr)); - } - Tcl_SetHashValue(hPtr, metadata); -} - -ClientData -Tcl_ObjectGetMetadata( - Tcl_Object object, - const Tcl_ObjectMetadataType *typePtr) -{ - Object *oPtr = (Object *) object; - Tcl_HashEntry *hPtr; - - /* - * If there's no metadata store attached, the type in question has - * definitely not been attached either! - */ - - if (oPtr->metadataPtr == NULL) { - return NULL; - } - - /* - * There is a metadata store, so look in it for the given type. - */ - - hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, (char *) typePtr); - - /* - * Return the metadata value if we found it, otherwise NULL. - */ - - if (hPtr == NULL) { - return NULL; - } - return Tcl_GetHashValue(hPtr); -} - -void -Tcl_ObjectSetMetadata( - Tcl_Object object, - const Tcl_ObjectMetadataType *typePtr, - ClientData metadata) -{ - Object *oPtr = (Object *) object; - Tcl_HashEntry *hPtr; - int isNew; - - /* - * Attach the metadata store if not done already. - */ - - if (oPtr->metadataPtr == NULL) { - if (metadata == NULL) { - return; - } - oPtr->metadataPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(oPtr->metadataPtr, TCL_ONE_WORD_KEYS); - } - - /* - * If the metadata is NULL, we're deleting the metadata for the type. - */ - - if (metadata == NULL) { - hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, (char *) typePtr); - if (hPtr != NULL) { - typePtr->deleteProc(Tcl_GetHashValue(hPtr)); - Tcl_DeleteHashEntry(hPtr); - } - return; - } - - /* - * Otherwise we're attaching the metadata. Note that if there was already - * some metadata attached of this type, we delete that first. - */ - - hPtr = Tcl_CreateHashEntry(oPtr->metadataPtr, (char *) typePtr, &isNew); - if (!isNew) { - typePtr->deleteProc(Tcl_GetHashValue(hPtr)); - } - Tcl_SetHashValue(hPtr, metadata); -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOPublicObjectCmd, TclOOPrivateObjectCmd, TclOOInvokeObject -- - * - * Main entry point for object invocations. The Public* and Private* - * wrapper functions (implementations of both object instance commands - * and [my]) are just thin wrappers round the main TclOOObjectCmdCore - * function. Note that the core is function is NRE-aware. - * - * ---------------------------------------------------------------------- - */ - -int -TclOOPublicObjectCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - return Tcl_NRCallObjProc(interp, PublicNRObjectCmd, clientData,objc,objv); -} - -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. */ - Tcl_Class startCls, /* Where in the class chain to start the - * invoke from, or NULL to traverse the whole - * chain including filters. */ - int publicPrivate, /* Whether this is an invoke from a public - * context (PUBLIC_METHOD), a private context - * (PRIVATE_METHOD), or a *really* private - * context (any other value; conventionally - * 0). */ - int objc, /* Number of arguments. */ - Tcl_Obj *const *objv) /* Array of argument objects. It is assumed - * that the name of the method to invoke will - * be at index 1. */ -{ - switch (publicPrivate) { - case PUBLIC_METHOD: - return TclOOObjectCmdCore((Object *) object, interp, objc, objv, - PUBLIC_METHOD, (Class *) startCls); - case PRIVATE_METHOD: - return TclOOObjectCmdCore((Object *) object, interp, objc, objv, - PRIVATE_METHOD, (Class *) startCls); - default: - return TclOOObjectCmdCore((Object *) object, interp, objc, objv, 0, - (Class *) startCls); - } -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOMyClassObjCmd, MyClassNRObjCmd -- - * - * Special trap door to allow an object to delegate simply to its class. - * - * ---------------------------------------------------------------------- - */ - -int -TclOOMyClassObjCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - return Tcl_NRCallObjProc(interp, MyClassNRObjCmd, clientData, objc, objv); -} - -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); -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOObjectCmdCore, FinalizeObjectCall -- - * - * Main function for object invocations. Does call chain creation, - * management and invocation. The function FinalizeObjectCall exists to - * clean up after the non-recursive processing of TclOOObjectCmdCore. - * - * ---------------------------------------------------------------------- - */ - -int -TclOOObjectCmdCore( - Object *oPtr, /* The object being invoked. */ - Tcl_Interp *interp, /* The interpreter containing the object. */ - int objc, /* How many arguments are being passed in. */ - Tcl_Obj *const *objv, /* The array of arguments. */ - int flags, /* Whether this is an invocation through the - * public or the private command interface. */ - Class *startCls) /* Where to start in the call chain, or NULL - * if we are to start at the front with - * filters and the object's methods (which is - * the normal case). */ -{ - CallContext *contextPtr; - Tcl_Obj *methodNamePtr; - CallFrame *framePtr = ((Interp *) interp)->varFramePtr; - Object *callerObjPtr = NULL; - Class *callerClsPtr = NULL; - int result; - - /* - * If we've no method name, throw this directly into the unknown - * processing. - */ - - if (objc < 2) { - flags |= FORCE_UNKNOWN; - methodNamePtr = NULL; - goto noMapping; - } - - /* - * 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) { - goto noMapping; - } else if (result == TCL_ERROR) { - Tcl_AddErrorInfo(interp, "\n (while mapping method name)"); - } - return result; - } - - /* - * Get the call chain for the remapped name. - */ - - Tcl_IncrRefCount(mappedMethodName); - contextPtr = TclOOGetCallContext(oPtr, mappedMethodName, - flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr, - callerClsPtr, methodNamePtr); - TclDecrRefCount(mappedMethodName); - if (contextPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "impossible to invoke method \"%s\": no defined method or" - " unknown method", TclGetString(methodNamePtr))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD_MAPPED", - TclGetString(methodNamePtr), NULL); - return TCL_ERROR; - } - } else { - /* - * Get the call chain. - */ - - noMapping: - contextPtr = TclOOGetCallContext(oPtr, methodNamePtr, - flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr, - callerClsPtr, NULL); - if (contextPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "impossible to invoke method \"%s\": no defined method or" - " unknown method", TclGetString(methodNamePtr))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(methodNamePtr), NULL); - return TCL_ERROR; - } - } - - /* - * Check to see if we need to apply magical tricks to start part way - * through the call chain. - */ - - if (startCls != NULL) { - for (; contextPtr->index < contextPtr->callPtr->numChain; - contextPtr->index++) { - struct MInvoke *miPtr = - &contextPtr->callPtr->chain[contextPtr->index]; - - if (miPtr->isFilter) { - continue; - } - if (miPtr->mPtr->declaringClassPtr == startCls) { - break; - } - } - if (contextPtr->index >= contextPtr->callPtr->numChain) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "no valid method implementation", -1)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(methodNamePtr), NULL); - TclOODeleteContext(contextPtr); - return TCL_ERROR; - } - } - - /* - * Invoke the call chain, locking the object structure against deletion - * for the duration. - */ - - 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 -- - * - * Invokes the next stage of the call chain described in an object - * context. This is the core of the implementation of the [next] command. - * Does not do management of the call-frame stack. Available in public - * (standard API) and private (NRE-aware) forms. FinalizeNext is a - * private function used to clean up in the NRE case. - * - * ---------------------------------------------------------------------- - */ - -int -Tcl_ObjectContextInvokeNext( - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv, - int skip) -{ - CallContext *contextPtr = (CallContext *) context; - int savedIndex = contextPtr->index; - int savedSkip = contextPtr->skip; - int result; - - 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. - */ - - const char *methodType; - - if (Tcl_InterpDeleted(interp)) { - return TCL_OK; - } - - if (contextPtr->callPtr->flags & CONSTRUCTOR) { - methodType = "constructor"; - } else if (contextPtr->callPtr->flags & DESTRUCTOR) { - methodType = "destructor"; - } else { - methodType = "method"; - } - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "no next %s implementation", methodType)); - Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL); - return TCL_ERROR; - } - - /* - * Advance to the next method implementation in the chain in the method - * call context while we process the body. However, need to adjust the - * argument-skip control because we're guaranteed to have a single prefix - * arg (i.e., 'next') and not the variable amount that can happen because - * method invocations (i.e., '$obj meth' and 'my meth'), constructors - * (i.e., '$cls new' and '$cls create obj') and destructors (no args at - * all) come through the same code. - */ - - contextPtr->index++; - contextPtr->skip = skip; - - /* - * Invoke the (advanced) method call context in the caller context. - */ - - result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, objc, - objv); - - /* - * Restore the call chain context index as we've finished the inner invoke - * and want to operate in the outer context again. - */ - - contextPtr->index = savedIndex; - contextPtr->skip = savedSkip; - - return result; -} - -int -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. - */ - - const char *methodType; - - if (Tcl_InterpDeleted(interp)) { - return TCL_OK; - } - - if (contextPtr->callPtr->flags & CONSTRUCTOR) { - methodType = "constructor"; - } else if (contextPtr->callPtr->flags & DESTRUCTOR) { - methodType = "destructor"; - } else { - methodType = "method"; - } - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "no next %s implementation", methodType)); - Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL); - return TCL_ERROR; - } - - /* - * Advance to the next method implementation in the chain in the method - * call context while we process the body. However, need to adjust the - * argument-skip control because we're guaranteed to have a single prefix - * arg (i.e., 'next') and not the variable amount that can happen because - * method invocations (i.e., '$obj meth' and 'my meth'), constructors - * (i.e., '$cls new' and '$cls create obj') and destructors (no args at - * all) come through the same code. - */ - - TclNRAddCallback(interp, FinalizeNext, contextPtr, - INT2PTR(contextPtr->index), INT2PTR(contextPtr->skip), NULL); - contextPtr->index++; - contextPtr->skip = skip; - - /* - * Invoke the (advanced) method call context in the caller context. - */ - - 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]); - contextPtr->skip = PTR2INT(data[2]); - return result; -} - -/* - * ---------------------------------------------------------------------- - * - * Tcl_GetObjectFromObj -- - * - * Utility function to get an object from a Tcl_Obj containing its name. - * - * ---------------------------------------------------------------------- - */ - -Tcl_Object -Tcl_GetObjectFromObj( - Tcl_Interp *interp, /* Interpreter in which to locate the object. - * Will have an error message placed in it if - * the name does not refer to an object. */ - Tcl_Obj *objPtr) /* The name of the object to look up, which is - * exactly the name of its public command. */ -{ - Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr); - - if (cmdPtr == NULL) { - goto notAnObject; - } - 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; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOIsReachable -- - * - * Utility function that tests whether a class is a subclass (whether - * directly or indirectly) of another class. - * - * ---------------------------------------------------------------------- - */ - -int -TclOOIsReachable( - Class *targetPtr, - Class *startPtr) -{ - int i; - Class *superPtr; - - tailRecurse: - if (startPtr == targetPtr) { - return 1; - } - if (startPtr->superclasses.num == 1 && startPtr->mixins.num == 0) { - startPtr = startPtr->superclasses.list[0]; - goto tailRecurse; - } - FOREACH(superPtr, startPtr->superclasses) { - if (TclOOIsReachable(targetPtr, superPtr)) { - return 1; - } - } - FOREACH(superPtr, startPtr->mixins) { - if (TclOOIsReachable(targetPtr, superPtr)) { - return 1; - } - } - return 0; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOObjectName, Tcl_GetObjectName -- - * - * Utility function that returns the name of the object. Note that this - * simplifies cache management by keeping the code to do it in one place - * and not sprayed all over. The value returned always has a reference - * count of at least one. - * - * ---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclOOObjectName( - Tcl_Interp *interp, - Object *oPtr) -{ - Tcl_Obj *namePtr; - - if (oPtr->cachedNameObj) { - return oPtr->cachedNameObj; - } - TclNewObj(namePtr); - Tcl_GetCommandFullName(interp, oPtr->command, namePtr); - Tcl_IncrRefCount(namePtr); - oPtr->cachedNameObj = namePtr; - return namePtr; -} - -Tcl_Obj * -Tcl_GetObjectName( - Tcl_Interp *interp, - Tcl_Object object) -{ - return TclOOObjectName(interp, (Object *) object); -} - -/* - * ---------------------------------------------------------------------- - * - * assorted trivial 'getter' functions - * - * ---------------------------------------------------------------------- - */ - -Tcl_Method -Tcl_ObjectContextMethod( - Tcl_ObjectContext context) -{ - CallContext *contextPtr = (CallContext *) context; - return (Tcl_Method) contextPtr->callPtr->chain[contextPtr->index].mPtr; -} - -int -Tcl_ObjectContextIsFiltering( - Tcl_ObjectContext context) -{ - CallContext *contextPtr = (CallContext *) context; - return contextPtr->callPtr->chain[contextPtr->index].isFilter; -} - -Tcl_Object -Tcl_ObjectContextObject( - Tcl_ObjectContext context) -{ - return (Tcl_Object) ((CallContext *)context)->oPtr; -} - -int -Tcl_ObjectContextSkippedArgs( - Tcl_ObjectContext context) -{ - return ((CallContext *)context)->skip; -} - -Tcl_Namespace * -Tcl_GetObjectNamespace( - Tcl_Object object) -{ - return ((Object *)object)->namespacePtr; -} - -Tcl_Command -Tcl_GetObjectCommand( - Tcl_Object object) -{ - return ((Object *)object)->command; -} - -Tcl_Class -Tcl_GetObjectAsClass( - Tcl_Object object) -{ - return (Tcl_Class) ((Object *)object)->classPtr; -} - -int -Tcl_ObjectDeleted( - Tcl_Object object) -{ - return ((Object *)object)->command == NULL; -} - -Tcl_Object -Tcl_GetClassAsObject( - Tcl_Class clazz) -{ - return (Tcl_Object) ((Class *)clazz)->thisPtr; -} - -Tcl_ObjectMapMethodNameProc * -Tcl_ObjectGetMethodNameMapper( - Tcl_Object object) -{ - return ((Object *) object)->mapMethodNameProc; -} - -void -Tcl_ObjectSetMethodNameMapper( - Tcl_Object object, - Tcl_ObjectMapMethodNameProc *mapMethodNameProc) -{ - ((Object *) object)->mapMethodNameProc = mapMethodNameProc; -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ DELETED generic/tclOO.decls Index: generic/tclOO.decls ================================================================== --- generic/tclOO.decls +++ /dev/null @@ -1,221 +0,0 @@ -# tclOO.decls -- -# -# This file contains the declarations for all supported public functions -# that are exported by the TclOO package that is embedded within the Tcl -# library via the stubs table. This file is used to generate the -# tclOODecls.h, tclOOIntDecls.h and tclOOStubInit.c files. -# -# Copyright (c) 2008-2013 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. - -library tclOO - -###################################################################### -# Public API, exposed for general users of TclOO. -# - -interface tclOO -hooks tclOOInt -scspec TCLAPI - -declare 0 { - Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, - Tcl_Object sourceObject, const char *targetName, - const char *targetNamespaceName) -} -declare 1 { - Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz) -} -declare 2 { - Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object) -} -declare 3 { - Tcl_Command Tcl_GetObjectCommand(Tcl_Object object) -} -declare 4 { - Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) -} -declare 5 { - Tcl_Namespace *Tcl_GetObjectNamespace(Tcl_Object object) -} -declare 6 { - Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method) -} -declare 7 { - 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, - void **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, - void *clientData) -} -declare 12 { - Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, - Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, - void *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 { - int Tcl_ObjectDeleted(Tcl_Object object) -} -declare 15 { - int Tcl_ObjectContextIsFiltering(Tcl_ObjectContext context) -} -declare 16 { - Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context) -} -declare 17 { - Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context) -} -declare 18 { - int Tcl_ObjectContextSkippedArgs(Tcl_ObjectContext context) -} -declare 19 { - void *Tcl_ClassGetMetadata(Tcl_Class clazz, - const Tcl_ObjectMetadataType *typePtr) -} -declare 20 { - void Tcl_ClassSetMetadata(Tcl_Class clazz, - const Tcl_ObjectMetadataType *typePtr, void *metadata) -} -declare 21 { - void *Tcl_ObjectGetMetadata(Tcl_Object object, - const Tcl_ObjectMetadataType *typePtr) -} -declare 22 { - void Tcl_ObjectSetMetadata(Tcl_Object object, - const Tcl_ObjectMetadataType *typePtr, void *metadata) -} -declare 23 { - int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, - Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, - int skip) -} -declare 24 { - Tcl_ObjectMapMethodNameProc *Tcl_ObjectGetMethodNameMapper( - Tcl_Object object) -} -declare 25 { - void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, - Tcl_ObjectMapMethodNameProc *mapMethodNameProc) -} -declare 26 { - void Tcl_ClassSetConstructor(Tcl_Interp *interp, Tcl_Class clazz, - Tcl_Method method) -} -declare 27 { - void Tcl_ClassSetDestructor(Tcl_Interp *interp, Tcl_Class clazz, - Tcl_Method method) -} -declare 28 { - Tcl_Obj *Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object) -} -declare 29 { - int Tcl_MethodIsPrivate(Tcl_Method method) -} - -###################################################################### -# Private API, exposed to support advanced OO systems that plug in on top of -# TclOO; not intended for general use and does not have any commitment to -# long-term support. -# - -interface tclOOInt - -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, void *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, - void *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 { - Method *TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, - int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, - ProcedureMethod **pmPtrPtr) -} -declare 5 { - int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv, int publicOnly, Class *startCls) -} -declare 6 { - int TclOOIsReachable(Class *targetPtr, Class *startPtr) -} -declare 7 { - Method *TclOONewForwardMethod(Tcl_Interp *interp, Class *clsPtr, - int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj) -} -declare 8 { - 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, - void *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, void *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) -} -declare 12 { - void TclOOObjectSetFilters(Object *oPtr, int numFilters, - Tcl_Obj *const *filters) -} -declare 13 { - void TclOOClassSetFilters(Tcl_Interp *interp, Class *classPtr, - int numFilters, Tcl_Obj *const *filters) -} -declare 14 { - void TclOOObjectSetMixins(Object *oPtr, int numMixins, - Class *const *mixins) -} -declare 15 { - void TclOOClassSetMixins(Tcl_Interp *interp, Class *classPtr, - int numMixins, Class *const *mixins) -} - -return - -# Local Variables: -# mode: tcl -# End: DELETED generic/tclOO.h Index: generic/tclOO.h ================================================================== --- generic/tclOO.h +++ /dev/null @@ -1,156 +0,0 @@ -/* - * tclOO.h -- - * - * This file contains the public API definitions and some of the function - * declarations for the object-system (NB: not Tcl_Obj, but ::oo). - * - * Copyright (c) 2006-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. - */ - -#ifndef TCLOO_H_INCLUDED -#define TCLOO_H_INCLUDED - -/* - * Be careful when it comes to versioning; need to make sure that the - * standalone TclOO version matches. Also make sure that this matches the - * version in the files: - * - * tests/oo.test - * tests/ooNext2.test - * unix/tclooConfig.sh - * win/tclooConfig.sh - */ - -#define TCLOO_VERSION "1.2.0" -#define TCLOO_PATCHLEVEL TCLOO_VERSION - -#include "tcl.h" - -/* - * For C++ compilers, use extern "C" - */ - -#ifdef __cplusplus -extern "C" { -#endif - -extern const char *TclOOInitializeStubs( - Tcl_Interp *, const char *version); -#define Tcl_OOInitStubs(interp) \ - TclOOInitializeStubs((interp), TCLOO_VERSION) -#ifndef USE_TCL_STUBS -# define TclOOInitializeStubs(interp, version) (TCLOO_PATCHLEVEL) -#endif - -/* - * These are opaque types. - */ - -typedef struct Tcl_Class_ *Tcl_Class; -typedef struct Tcl_Method_ *Tcl_Method; -typedef struct Tcl_Object_ *Tcl_Object; -typedef struct Tcl_ObjectContext_ *Tcl_ObjectContext; - -/* - * 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)(void *clientData, Tcl_Interp *interp, - Tcl_ObjectContext objectContext, int objc, Tcl_Obj *const *objv); -typedef void (Tcl_MethodDeleteProc)(void *clientData); -typedef int (Tcl_CloneProc)(Tcl_Interp *interp, void *oldClientData, - void **newClientData); -typedef void (Tcl_ObjectMetadataDeleteProc)(void *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). - */ - -typedef struct { - int version; /* Structure version field. Always to be equal - * to TCL_OO_METHOD_VERSION_CURRENT in - * declarations. */ - const char *name; /* Name of this type of method, mostly for - * debugging purposes. */ - Tcl_MethodCallProc *callProc; - /* How to invoke this method. */ - Tcl_MethodDeleteProc *deleteProc; - /* How to delete this method's type-specific - * data, or NULL if the type-specific data - * does not need deleting. */ - Tcl_CloneProc *cloneProc; /* How to copy this method's type-specific - * data, or NULL if the type-specific data can - * be copied directly. */ -} Tcl_MethodType; - -/* - * The correct value for the version field of the Tcl_MethodType structure. - * This allows new versions of the structure to be introduced without breaking - * binary compatibility. - */ - -#define TCL_OO_METHOD_VERSION_CURRENT 1 - -/* - * Visibility constants for the flags parameter to Tcl_NewMethod and - * Tcl_NewInstanceMethod. - */ - -#define TCL_OO_METHOD_PUBLIC 1 -#define TCL_OO_METHOD_UNEXPORTED 0 -#define TCL_OO_METHOD_PRIVATE 0x20 - -/* - * The type of some object (or class) metadata. This describes how to delete - * the metadata (when the object or class is deleted) and how to create a - * clone of it (when the object or class is copied). - */ - -typedef struct { - int version; /* Structure version field. Always to be equal - * to TCL_OO_METADATA_VERSION_CURRENT in - * declarations. */ - const char *name; - Tcl_ObjectMetadataDeleteProc *deleteProc; - /* How to delete the metadata. This must not - * be NULL. */ - Tcl_CloneProc *cloneProc; /* How to copy the metadata, or NULL if the - * type-specific data can be copied - * directly. */ -} Tcl_ObjectMetadataType; - -/* - * The correct value for the version field of the Tcl_ObjectMetadataType - * structure. This allows new versions of the structure to be introduced - * without breaking binary compatibility. - */ - -#define TCL_OO_METADATA_VERSION_CURRENT 1 - -/* - * Include all the public API, generated from tclOO.decls. - */ - -#include "tclOODecls.h" - -#ifdef __cplusplus -} -#endif -#endif - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ DELETED generic/tclOOBasic.c Index: generic/tclOOBasic.c ================================================================== --- generic/tclOOBasic.c +++ /dev/null @@ -1,1348 +0,0 @@ -/* - * tclOOBasic.c -- - * - * This file contains implementations of the "simple" commands and - * methods from the object-system core. - * - * Copyright (c) 2005-2013 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. - */ - -#ifdef HAVE_CONFIG_H -#include "config.h" -#endif -#include "tclInt.h" -#include "tclOOInt.h" - -static inline Tcl_Object *AddConstructionFinalizer(Tcl_Interp *interp); -static Tcl_NRPostProc AfterNRDestructor; -static Tcl_NRPostProc DecrRefsPostClassConstructor; -static Tcl_NRPostProc FinalizeConstruction; -static Tcl_NRPostProc FinalizeEval; -static Tcl_NRPostProc NextRestoreFrame; - -/* - * ---------------------------------------------------------------------- - * - * AddCreateCallback, FinalizeConstruction -- - * - * Special version of TclNRAddCallback that allows the caller to splice - * the object created later on. Always calls FinalizeConstruction, which - * converts the object into its name and stores that in the interpreter - * result. This is shared by all the construction methods (create, - * createWithNamespace, new). - * - * Note that this is the only code in this file (or, indeed, the whole of - * TclOO) that uses NRE internals; it is the only code that does - * non-standard poking in the NRE guts. - * - * ---------------------------------------------------------------------- - */ - -static inline Tcl_Object * -AddConstructionFinalizer( - Tcl_Interp *interp) -{ - TclNRAddCallback(interp, FinalizeConstruction, NULL, NULL, NULL, NULL); - return (Tcl_Object *) &(TOP_CB(interp)->data[0]); -} - -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; - - if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "?definitionScript?"); - return TCL_ERROR; - } else if (objc == Tcl_ObjectContextSkippedArgs(context)) { - return TCL_OK; - } - - /* - * Make the class definition delegate. This is special; it doesn't reenter - * here (and the class definition delegate doesn't run any constructors). - */ - - nameObj = Tcl_NewStringObj(oPtr->namespacePtr->fullName, -1); - Tcl_AppendToObj(nameObj, ":: oo ::delegate", -1); - Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls, - TclGetString(nameObj), NULL, -1, NULL, -1); - Tcl_DecrRefCount(nameObj); - - /* - * Delegate to [oo::define] to do the work. - */ - - invoke = (Tcl_Obj **)Tcl_Alloc(3 * sizeof(Tcl_Obj *)); - invoke[0] = oPtr->fPtr->defineName; - invoke[1] = TclOOObjectName(interp, oPtr); - invoke[2] = objv[objc-1]; - - /* - * Must add references or errors in configuration script will cause - * trouble. - */ - - Tcl_IncrRefCount(invoke[0]); - Tcl_IncrRefCount(invoke[1]); - Tcl_IncrRefCount(invoke[2]); - TclNRAddCallback(interp, DecrRefsPostClassConstructor, - invoke, oPtr, NULL, NULL); - - /* - * Tricky point: do not want the extra reported level in the Tcl stack - * trace, so use TCL_EVAL_NOERR. - */ - - return TclNREvalObjv(interp, 3, invoke, TCL_EVAL_NOERR, NULL); -} - -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]); - Tcl_Free(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; - size_t len; - - /* - * Sanity check; should not be possible to invoke this method on a - * non-class. - */ - - if (oPtr->classPtr == NULL) { - Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr); - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "object \"%s\" is not a class", TclGetString(cmdnameObj))); - Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL); - return TCL_ERROR; - } - - /* - * Check we have the right number of (sensible) arguments. - */ - - if (objc - Tcl_ObjectContextSkippedArgs(context) < 1) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "objectName ?arg ...?"); - return TCL_ERROR; - } - objName = TclGetStringFromObj( - 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; - } - - /* - * Make the object and return its name. - */ - - return TclNRNewObjectInstance(interp, (Tcl_Class) oPtr->classPtr, - objName, NULL, objc, objv, - Tcl_ObjectContextSkippedArgs(context)+1, - AddConstructionFinalizer(interp)); -} - -/* - * ---------------------------------------------------------------------- - * - * TclOO_Class_CreateNs -- - * - * 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; - size_t len; - - /* - * Sanity check; should not be possible to invoke this method on a - * non-class. - */ - - if (oPtr->classPtr == NULL) { - Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr); - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "object \"%s\" is not a class", TclGetString(cmdnameObj))); - Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL); - return TCL_ERROR; - } - - /* - * Check we have the right number of (sensible) arguments. - */ - - if (objc - Tcl_ObjectContextSkippedArgs(context) < 2) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "objectName namespaceName ?arg ...?"); - return TCL_ERROR; - } - objName = TclGetStringFromObj( - 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 = TclGetStringFromObj( - 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; - } - - /* - * Make the object and return its name. - */ - - return TclNRNewObjectInstance(interp, (Tcl_Class) oPtr->classPtr, - objName, nsName, objc, objv, - Tcl_ObjectContextSkippedArgs(context)+2, - AddConstructionFinalizer(interp)); -} - -/* - * ---------------------------------------------------------------------- - * - * TclOO_Class_New -- - * - * 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); - - /* - * Sanity check; should not be possible to invoke this method on a - * non-class. - */ - - if (oPtr->classPtr == NULL) { - Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr); - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "object \"%s\" is not a class", TclGetString(cmdnameObj))); - Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL); - return TCL_ERROR; - } - - /* - * Make the object and return its name. - */ - - return TclNRNewObjectInstance(interp, (Tcl_Class) oPtr->classPtr, - NULL, NULL, objc, objv, Tcl_ObjectContextSkippedArgs(context), - AddConstructionFinalizer(interp)); -} - -/* - * ---------------------------------------------------------------------- - * - * TclOO_Object_Destroy -- - * - * 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); - CallContext *contextPtr; - - if (objc != Tcl_ObjectContextSkippedArgs(context)) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - NULL); - return TCL_ERROR; - } - if (!(oPtr->flags & DESTRUCTOR_CALLED)) { - oPtr->flags |= DESTRUCTOR_CALLED; - contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, - NULL); - if (contextPtr != NULL) { - contextPtr->callPtr->flags |= DESTRUCTOR; - contextPtr->skip = 0; - TclNRAddCallback(interp, AfterNRDestructor, contextPtr, - NULL, NULL, NULL); - TclPushTailcallPoint(interp); - return TclOOInvokeContext(contextPtr, interp, 0, NULL); - } - } - if (oPtr->command) { - Tcl_DeleteCommandFromToken(interp, oPtr->command); - } - return TCL_OK; -} - -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; - } - - /* - * Make the object's namespace the current namespace and evaluate the - * command(s). - */ - - (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, - Tcl_GetObjectNamespace(object), 0); - framePtr->objc = objc; - framePtr->objv = objv; /* Reference counts do not need to be - * incremented here. */ - - if (!(contextPtr->callPtr->flags & PUBLIC_METHOD)) { - object = NULL; /* Now just for error mesage printing. */ - } - - /* - * Work out what script we are actually going to evaluate. - * - * When there's more than one argument, we concatenate them together with - * spaces between, then evaluate the result. Tcl_EvalObjEx will delete the - * object when it decrements its refcount after eval'ing it. - */ - - if (objc != skip+1) { - scriptPtr = Tcl_ConcatObj(objc-skip, objv+skip); - invoker = NULL; - } else { - scriptPtr = objv[skip]; - invoker = ((Interp *) interp)->cmdFramePtr; - } - - /* - * Evaluate the script now, with FinalizeEval to do the processing after - * the script completes. - */ - - TclNRAddCallback(interp, FinalizeEval, object, NULL, NULL, NULL); - return TclNREvalObjEx(interp, scriptPtr, 0, invoker, skip); -} - -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"; - } - - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (in \"%s eval\" script line %d)", - namePtr, Tcl_GetErrorLine(interp))); - } - - /* - * Restore the previous "current" namespace. - */ - - TclPopStackFrame(interp); - return result; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOO_Object_Unknown -- - * - * Default unknown method handler method (defined in oo::object). This - * 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; - Object *callerObj = NULL; - Class *callerCls = NULL; - Object *oPtr = contextPtr->oPtr; - const char **methodNames; - int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context); - CallFrame *framePtr = ((Interp *) interp)->varFramePtr; - Tcl_Obj *errorMsg; - - /* - * If no method name, generate an error asking for a method name. (Only by - * overriding *this* method can an object handle the absence of a method - * name without an error). - */ - - if (objc < skip+1) { - Tcl_WrongNumArgs(interp, skip, objv, "method ?arg ...?"); - return TCL_ERROR; - } - - /* - * Determine if the calling context should know about extra private - * methods, and if so, which. - */ - - if (framePtr->isProcCallFrame & FRAME_IS_METHOD) { - CallContext *callerContext = (CallContext *)framePtr->clientData; - Method *mPtr = callerContext->callPtr->chain[ - callerContext->index].mPtr; - - if (mPtr->declaringObjectPtr) { - if (oPtr == mPtr->declaringObjectPtr) { - callerObj = mPtr->declaringObjectPtr; - } - } else { - if (TclOOIsReachable(mPtr->declaringClassPtr, oPtr->selfCls)) { - callerCls = mPtr->declaringClassPtr; - } - } - } - - /* - * Get the list of methods that we want to know about. - */ - - numMethodNames = TclOOGetSortedMethodList(oPtr, callerObj, callerCls, - contextPtr->callPtr->flags & PUBLIC_METHOD, &methodNames); - - /* - * Special message when there are no visible methods at all. - */ - - if (numMethodNames == 0) { - Tcl_Obj *tmpBuf = TclOOObjectName(interp, oPtr); - const char *piece; - - if (contextPtr->callPtr->flags & PUBLIC_METHOD) { - piece = "visible methods"; - } else { - piece = "methods"; - } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "object \"%s\" has no %s", TclGetString(tmpBuf), piece)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[skip]), NULL); - return TCL_ERROR; - } - - errorMsg = Tcl_ObjPrintf("unknown method \"%s\": must be ", - TclGetString(objv[skip])); - for (i=0 ; ivariable 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; - Tcl_Object object = Tcl_ObjectContextObject(context); - Namespace *savedNsPtr; - int i; - - if (objc-Tcl_ObjectContextSkippedArgs(context) < 0) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "?varName ...?"); - return TCL_ERROR; - } - - /* - * A sanity check. Shouldn't ever happen. (This is all that remains of a - * more complex check inherited from [global] after we have applied the - * fix for [Bug 2903811]; note that the fix involved *removing* code.) - */ - - if (iPtr->varFramePtr == NULL) { - return TCL_OK; - } - - for (i=Tcl_ObjectContextSkippedArgs(context) ; ivarFramePtr->nsPtr; - iPtr->varFramePtr->nsPtr = (Namespace *) - Tcl_GetObjectNamespace(object); - varPtr = TclObjLookupVar(interp, objv[i], NULL, TCL_NAMESPACE_ONLY, - "define", 1, 0, &aryPtr); - iPtr->varFramePtr->nsPtr = savedNsPtr; - - if (varPtr == NULL || aryPtr != NULL) { - /* - * Variable cannot be an element in an array. If aryPtr is not - * NULL, it is an element, so throw up an error and return. - */ - - TclVarErrMsg(interp, varName, NULL, "define", - "name refers to an element in an array"); - Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL); - return TCL_ERROR; - } - - /* - * Arrange for the lifetime of the variable to be correctly managed. - * This is copied out of Tcl_VariableObjCmd... - */ - - if (!TclIsVarNamespaceVar(varPtr)) { - TclSetVarNamespaceVar(varPtr); - } - - if (TclPtrMakeUpvar(interp, varPtr, varName, 0, -1) != TCL_OK) { - return TCL_ERROR; - } - } - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOO_Object_VarName -- - * - * 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 = TclGetString(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 - * variable and we want the target's name. - */ - - if (arg[0] == ':' && arg[1] == ':') { - varNamePtr = argPtr; - } else { - Tcl_Namespace *namespacePtr = - Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)); - - /* - * Private method handling. [TIP 500] - * - * If we're in a context that can see some private methods of an - * object, we may need to precede a variable name with its prefix. - * This is a little tricky as we need to check through the inheritance - * hierarchy when the method was declared by a class to see if the - * current object is an instance of that class. - */ - - if (framePtr->isProcCallFrame & FRAME_IS_METHOD) { - Object *oPtr = (Object *) 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(TclGetString(pvPtr->variableObj), - TclGetString(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(TclGetString(pvPtr->variableObj), - TclGetString(argPtr))) { - argPtr = pvPtr->fullNameObj; - break; - } - } - } - } - } - - varNamePtr = Tcl_NewStringObj(namespacePtr->fullName, -1); - Tcl_AppendToObj(varNamePtr, "::", 2); - Tcl_AppendObjToObj(varNamePtr, argPtr); - } - Tcl_IncrRefCount(varNamePtr); - varPtr = TclObjLookupVar(interp, varNamePtr, NULL, - TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to", 1, 1, &aryVar); - Tcl_DecrRefCount(varNamePtr); - if (varPtr == NULL) { - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", arg, NULL); - return TCL_ERROR; - } - - /* - * Now that we've pinned down what variable we're really talking about - * (including traversing variable links), convert back to a name. - */ - - TclNewObj(varNamePtr); - if (aryVar != NULL) { - Tcl_GetVariableFullName(interp, (Tcl_Var) aryVar, varNamePtr); - - /* - * WARNING! This code pokes inside the implementation of hash tables! - */ - - Tcl_AppendToObj(varNamePtr, "(", -1); - Tcl_AppendObjToObj(varNamePtr, ((VarInHash *) - varPtr)->entry.key.objPtr); - Tcl_AppendToObj(varNamePtr, ")", -1); - } else { - Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr); - } - Tcl_SetObjResult(interp, varNamePtr); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOONextObjCmd, TclOONextToObjCmd -- - * - * Implementation of the [next] and [nextto] commands. Note that these - * commands are only ever to be used inside the body of a procedure-like - * 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; - - /* - * Start with sanity checks on the calling context to make sure that we - * are invoked from a suitable method context. If so, we can safely - * retrieve the handle to the object call context. - */ - - if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s may only be called from inside a method", - TclGetString(objv[0]))); - 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; - CallContext *contextPtr; - int i; - Tcl_Object object; - const char *methodType; - - /* - * Start with sanity checks on the calling context to make sure that we - * are invoked from a suitable method context. If so, we can safely - * retrieve the handle to the object call context. - */ - - if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s may only be called from inside a method", - TclGetString(objv[0]))); - 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...?"); - return TCL_ERROR; - } - object = Tcl_GetObjectFromObj(interp, objv[1]); - if (object == NULL) { - return TCL_ERROR; - } - classPtr = ((Object *)object)->classPtr; - if (classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" is not a class", TclGetString(objv[1]))); - Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL); - return TCL_ERROR; - } - - /* - * Search for an implementation of a method associated with the current - * call on the call chain past the point where we currently are. Do not - * allow jumping backwards! - */ - - for (i=contextPtr->index+1 ; icallPtr->numChain ; i++) { - struct MInvoke *miPtr = contextPtr->callPtr->chain + i; - - if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) { - /* - * Invoke the (advanced) method call context in the caller - * context. Note that this is like [uplevel 1] and not [eval]. - */ - - TclNRAddCallback(interp, NextRestoreFrame, framePtr, - contextPtr, INT2PTR(contextPtr->index), NULL); - contextPtr->index = i-1; - iPtr->varFramePtr = framePtr->callerVarPtr; - return TclNRObjectContextInvokeNext(interp, - (Tcl_ObjectContext) contextPtr, objc, objv, 2); - } - } - - /* - * Generate an appropriate error message, depending on whether the value - * is on the chain but unreachable, or not on the chain at all. - */ - - if (contextPtr->callPtr->flags & CONSTRUCTOR) { - methodType = "constructor"; - } else if (contextPtr->callPtr->flags & DESTRUCTOR) { - methodType = "destructor"; - } else { - methodType = "method"; - } - - for (i=contextPtr->index ; i>=0 ; i--) { - struct MInvoke *miPtr = contextPtr->callPtr->chain + i; - - if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s implementation by \"%s\" not reachable from here", - methodType, TclGetString(objv[1]))); - Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE", - NULL); - return TCL_ERROR; - } - } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s has no non-filter implementation by \"%s\"", - methodType, TclGetString(objv[1]))); - Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL); - return TCL_ERROR; -} - -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 - }; - enum SelfCmds { - SELF_CALL, SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS, - SELF_NEXT, SELF_OBJECT, SELF_TARGET - }; - Interp *iPtr = (Interp *) interp; - CallFrame *framePtr = iPtr->varFramePtr; - CallContext *contextPtr; - Tcl_Obj *result[3]; - int index; - -#define CurrentlyInvoked(contextPtr) \ - ((contextPtr)->callPtr->chain[(contextPtr)->index]) - - /* - * Start with sanity checks on the calling context and the method context. - */ - - if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s may only be called from inside a method", - TclGetString(objv[0]))); - 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) { - Tcl_WrongNumArgs(interp, 1, objv, "subcommand"); - return TCL_ERROR; - } else if (objc == 1) { - index = SELF_OBJECT; - } else if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "subcommand", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } - - switch ((enum SelfCmds) index) { - case SELF_OBJECT: - Tcl_SetObjResult(interp, TclOOObjectName(interp, contextPtr->oPtr)); - return TCL_OK; - case SELF_NS: - Tcl_SetObjResult(interp, Tcl_NewStringObj( - contextPtr->oPtr->namespacePtr->fullName,-1)); - return TCL_OK; - case SELF_CLASS: { - Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr; - - if (clsPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "method not defined by a class", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL); - return TCL_ERROR; - } - - Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr)); - return TCL_OK; - } - case SELF_METHOD: - if (contextPtr->callPtr->flags & CONSTRUCTOR) { - Tcl_SetObjResult(interp, contextPtr->oPtr->fPtr->constructorName); - } else if (contextPtr->callPtr->flags & DESTRUCTOR) { - Tcl_SetObjResult(interp, contextPtr->oPtr->fPtr->destructorName); - } else { - Tcl_SetObjResult(interp, - CurrentlyInvoked(contextPtr).mPtr->namePtr); - } - return TCL_OK; - case SELF_FILTER: - if (!CurrentlyInvoked(contextPtr).isFilter) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "not inside a filtering context", -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 { - oPtr = contextPtr->oPtr; - type = "object"; - } - - result[0] = TclOOObjectName(interp, oPtr); - result[1] = Tcl_NewStringObj(type, -1); - result[2] = miPtr->mPtr->namePtr; - Tcl_SetObjResult(interp, Tcl_NewListObj(3, result)); - return TCL_OK; - } - case SELF_CALLER: - if ((framePtr->callerVarPtr == NULL) || - !(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)){ - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "caller is not an object", -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; - } else { - /* - * This should be unreachable code. - */ - - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "method without declarer!", -1)); - return TCL_ERROR; - } - - result[0] = TclOOObjectName(interp, declarerPtr); - result[1] = TclOOObjectName(interp, callerPtr->oPtr); - if (callerPtr->callPtr->flags & CONSTRUCTOR) { - result[2] = declarerPtr->fPtr->constructorName; - } else if (callerPtr->callPtr->flags & DESTRUCTOR) { - result[2] = declarerPtr->fPtr->destructorName; - } else { - result[2] = mPtr->namePtr; - } - Tcl_SetObjResult(interp, Tcl_NewListObj(3, result)); - return TCL_OK; - } - case SELF_NEXT: - if (contextPtr->index < contextPtr->callPtr->numChain-1) { - Method *mPtr = - contextPtr->callPtr->chain[contextPtr->index+1].mPtr; - Object *declarerPtr; - - if (mPtr->declaringClassPtr != NULL) { - declarerPtr = mPtr->declaringClassPtr->thisPtr; - } else if (mPtr->declaringObjectPtr != NULL) { - declarerPtr = mPtr->declaringObjectPtr; - } else { - /* - * This should be unreachable code. - */ - - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "method without declarer!", -1)); - return TCL_ERROR; - } - - result[0] = TclOOObjectName(interp, declarerPtr); - if (contextPtr->callPtr->flags & CONSTRUCTOR) { - result[1] = declarerPtr->fPtr->constructorName; - } else if (contextPtr->callPtr->flags & DESTRUCTOR) { - result[1] = declarerPtr->fPtr->destructorName; - } else { - result[1] = mPtr->namePtr; - } - Tcl_SetObjResult(interp, Tcl_NewListObj(2, result)); - } - return TCL_OK; - case SELF_TARGET: - if (!CurrentlyInvoked(contextPtr).isFilter) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "not inside a filtering context", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL); - return TCL_ERROR; - } else { - Method *mPtr; - Object *declarerPtr; - int i; - - for (i=contextPtr->index ; icallPtr->numChain ; i++){ - if (!contextPtr->callPtr->chain[i].isFilter) { - break; - } - } - if (i == contextPtr->callPtr->numChain) { - Tcl_Panic("filtering call chain without terminal non-filter"); - } - mPtr = contextPtr->callPtr->chain[i].mPtr; - if (mPtr->declaringClassPtr != NULL) { - declarerPtr = mPtr->declaringClassPtr->thisPtr; - } else if (mPtr->declaringObjectPtr != NULL) { - declarerPtr = mPtr->declaringObjectPtr; - } else { - /* - * This should be unreachable code. - */ - - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "method without declarer!", -1)); - return TCL_ERROR; - } - result[0] = TclOOObjectName(interp, declarerPtr); - result[1] = mPtr->namePtr; - Tcl_SetObjResult(interp, Tcl_NewListObj(2, result)); - return TCL_OK; - } - case SELF_CALL: - result[0] = TclOORenderCallChain(interp, contextPtr->callPtr); - TclNewIntObj(result[1], contextPtr->index); - Tcl_SetObjResult(interp, Tcl_NewListObj(2, result)); - return TCL_OK; - } - return TCL_ERROR; -} - -/* - * ---------------------------------------------------------------------- - * - * CopyObjectCmd -- - * - * Implementation of the [oo::copy] command, which clones an object (but - * not its namespace). Note that no constructors are called during this - * process. - * - * ---------------------------------------------------------------------- - */ - -int -TclOOCopyObjectCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - Tcl_Object oPtr, o2Ptr; - - if (objc < 2 || objc > 4) { - Tcl_WrongNumArgs(interp, 1, objv, - "sourceName ?targetName? ?targetNamespace?"); - return TCL_ERROR; - } - - oPtr = Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { - return TCL_ERROR; - } - - /* - * Create a cloned object of the correct class. Note that constructors are - * not called. Also note that we must resolve the object name ourselves - * because we do not want to create the object in the current namespace, - * but rather in the context of the namespace of the caller of the overall - * [oo::define] command. - */ - - if (objc == 2) { - o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, NULL, NULL); - } else { - const char *name, *namespaceName; - - name = TclGetString(objv[2]); - if (name[0] == '\0') { - name = NULL; - } - - /* - * Choose a unique namespace name if the user didn't supply one. - */ - - namespaceName = NULL; - if (objc == 4) { - namespaceName = TclGetString(objv[3]); - - if (namespaceName[0] == '\0') { - namespaceName = NULL; - } else if (Tcl_FindNamespace(interp, namespaceName, NULL, - 0) != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s refers to an existing namespace", namespaceName)); - return TCL_ERROR; - } - } - - o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name, namespaceName); - } - - if (o2Ptr == NULL) { - return TCL_ERROR; - } - - /* - * Return the name of the cloned object. - */ - - Tcl_SetObjResult(interp, TclOOObjectName(interp, (Object *) o2Ptr)); - return TCL_OK; -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ DELETED generic/tclOOCall.c Index: generic/tclOOCall.c ================================================================== --- generic/tclOOCall.c +++ /dev/null @@ -1,2111 +0,0 @@ -/* - * tclOOCall.c -- - * - * This file contains the method call chain management code for the - * object-system core. - * - * Copyright (c) 2005-2012 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. - */ - -#ifdef HAVE_CONFIG_H -#include "config.h" -#endif -#include "tclInt.h" -#include "tclOOInt.h" -#include - -/* - * Structure containing a CallContext and any other values needed only during - * the construction of the CallContext. - */ - -struct ChainBuilder { - CallChain *callChainPtr; /* The call chain being built. */ - int filterLength; /* Number of entries in the call chain that - * are due to processing filters and not the - * main call chain. */ - Object *oPtr; /* The object that we are building the chain - * for. */ -}; - -/* - * Structures used for traversing the class hierarchy to find out where - * definitions are supposed to be done. - */ - -typedef struct { - Class *definerCls; - Tcl_Obj *namespaceName; -} DefineEntry; - -typedef struct { - DefineEntry *list; - int num; - int size; -} DefineChain; - -/* - * Extra flags used for call chain management. - */ - -#define DEFINITE_PROTECTED 0x100000 -#define DEFINITE_PUBLIC 0x200000 -#define KNOWN_STATE (DEFINITE_PROTECTED | DEFINITE_PUBLIC) -#define SPECIAL (CONSTRUCTOR | DESTRUCTOR | FORCE_UNKNOWN) -#define BUILDING_MIXINS 0x400000 -#define TRAVERSED_MIXIN 0x800000 -#define OBJECT_MIXIN 0x1000000 -#define MIXIN_CONSISTENT(flags) \ - (((flags) & OBJECT_MIXIN) || \ - !((flags) & BUILDING_MIXINS) == !((flags) & TRAVERSED_MIXIN)) - -/* - * Note that the flag bit PRIVATE_METHOD has a confusing name; it's just for - * Itcl's special type of private. - */ - -#define IS_PUBLIC(mPtr) \ - (((mPtr)->flags & PUBLIC_METHOD) != 0) -#define IS_UNEXPORTED(mPtr) \ - (((mPtr)->flags & SCOPE_FLAGS) == 0) -#define IS_ITCLPRIVATE(mPtr) \ - (((mPtr)->flags & PRIVATE_METHOD) != 0) -#define IS_PRIVATE(mPtr) \ - (((mPtr)->flags & TRUE_PRIVATE_METHOD) != 0) -#define WANT_PUBLIC(flags) \ - (((flags) & PUBLIC_METHOD) != 0) -#define WANT_UNEXPORTED(flags) \ - (((flags) & (PRIVATE_METHOD | TRUE_PRIVATE_METHOD)) == 0) -#define WANT_ITCLPRIVATE(flags) \ - (((flags) & PRIVATE_METHOD) != 0) -#define WANT_PRIVATE(flags) \ - (((flags) & TRUE_PRIVATE_METHOD) != 0) - -/* - * Function declarations for things defined in this file. - */ - -static void AddClassFiltersToCallContext(Object *const oPtr, - Class *clsPtr, struct ChainBuilder *const cbPtr, - Tcl_HashTable *const doneFilters, int flags); -static void AddClassMethodNames(Class *clsPtr, const int flags, - Tcl_HashTable *const namesPtr, - Tcl_HashTable *const examinedClassesPtr); -static inline void AddDefinitionNamespaceToChain(Class *const definerCls, - Tcl_Obj *const namespaceName, - DefineChain *const definePtr, int flags); -static inline void AddMethodToCallChain(Method *const mPtr, - struct ChainBuilder *const cbPtr, - Tcl_HashTable *const doneFilters, - Class *const filterDecl, int flags); -static inline int AddInstancePrivateToCallContext(Object *const oPtr, - Tcl_Obj *const methodNameObj, - struct ChainBuilder *const cbPtr, int flags); -static inline void AddStandardMethodName(int flags, Tcl_Obj *namePtr, - Method *mPtr, Tcl_HashTable *namesPtr); -static inline void AddPrivateMethodNames(Tcl_HashTable *methodsTablePtr, - Tcl_HashTable *namesPtr); -static inline int AddSimpleChainToCallContext(Object *const oPtr, - Class *const contextCls, - Tcl_Obj *const methodNameObj, - struct ChainBuilder *const cbPtr, - Tcl_HashTable *const doneFilters, int flags, - Class *const filterDecl); -static int AddPrivatesFromClassChainToCallContext(Class *classPtr, - Class *const contextCls, - Tcl_Obj *const methodNameObj, - struct ChainBuilder *const cbPtr, - Tcl_HashTable *const doneFilters, int flags, - Class *const filterDecl); -static int AddSimpleClassChainToCallContext(Class *classPtr, - Tcl_Obj *const methodNameObj, - struct ChainBuilder *const cbPtr, - Tcl_HashTable *const doneFilters, int flags, - Class *const filterDecl); -static void AddSimpleClassDefineNamespaces(Class *classPtr, - DefineChain *const definePtr, int flags); -static inline void AddSimpleDefineNamespaces(Object *const oPtr, - DefineChain *const definePtr, int flags); -static int CmpStr(const void *ptr1, const void *ptr2); -static void DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr); -static Tcl_NRPostProc FinalizeMethodRefs; -static void FreeMethodNameRep(Tcl_Obj *objPtr); -static inline int IsStillValid(CallChain *callPtr, Object *oPtr, - int flags, int reuseMask); -static Tcl_NRPostProc ResetFilterFlags; -static Tcl_NRPostProc SetFilterFlags; -static int SortMethodNames(Tcl_HashTable *namesPtr, int flags, - const char ***stringsPtr); -static inline void StashCallChain(Tcl_Obj *objPtr, CallChain *callPtr); - -/* - * Object type used to manage type caches attached to method names. - */ - -static const Tcl_ObjType methodNameType = { - "TclOO method name", - FreeMethodNameRep, - DupMethodNameRep, - NULL, - NULL -}; - - -/* - * ---------------------------------------------------------------------- - * - * TclOODeleteContext -- - * - * Destroys a method call-chain context, which should not be in use. - * - * ---------------------------------------------------------------------- - */ - -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 - */ - - TclOODecrRefCount(oPtr); - } -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODeleteChainCache -- - * - * Destroy the cache of method call-chains. - * - * ---------------------------------------------------------------------- - */ - -void -TclOODeleteChainCache( - Tcl_HashTable *tablePtr) -{ - FOREACH_HASH_DECLS; - CallChain *callPtr; - - FOREACH_HASH_VALUE(callPtr, tablePtr) { - if (callPtr) { - TclOODeleteChain(callPtr); - } - } - Tcl_DeleteHashTable(tablePtr); - Tcl_Free(tablePtr); -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODeleteChain -- - * - * Destroys a method call-chain. - * - * ---------------------------------------------------------------------- - */ - -void -TclOODeleteChain( - CallChain *callPtr) -{ - if (callPtr == NULL || callPtr->refCount-- > 1) { - return; - } - if (callPtr->chain != callPtr->staticChain) { - Tcl_Free(callPtr->chain); - } - Tcl_Free(callPtr); -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOStashContext -- - * - * Saves a reference to a method call context in a Tcl_Obj's internal - * representation. - * - * ---------------------------------------------------------------------- - */ - -static inline void -StashCallChain( - Tcl_Obj *objPtr, - CallChain *callPtr) -{ - Tcl_ObjIntRep ir; - - callPtr->refCount++; - TclGetString(objPtr); - ir.twoPtrValue.ptr1 = callPtr; - Tcl_StoreIntRep(objPtr, &methodNameType, &ir); -} - -void -TclOOStashContext( - Tcl_Obj *objPtr, - CallContext *contextPtr) -{ - StashCallChain(objPtr, contextPtr->callPtr); -} - -/* - * ---------------------------------------------------------------------- - * - * DupMethodNameRep, FreeMethodNameRep -- - * - * Functions to implement the required parts of the Tcl_Obj guts needed - * for caching of method contexts in Tcl_Objs. - * - * ---------------------------------------------------------------------- - */ - -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 -- - * - * Invokes a single step along a method call-chain context. Note that the - * invocation of a step along the chain can cause further steps along the - * chain to be invoked. Note that this function is written to be as light - * in stack usage as possible. - * - * ---------------------------------------------------------------------- - */ - -int -TclOOInvokeContext( - ClientData clientData, /* The method call context. */ - Tcl_Interp *interp, /* Interpreter for error reporting, and many - * other sorts of context handling (e.g., - * commands, variables) depending on method - * implementation. */ - int objc, /* The number of arguments. */ - Tcl_Obj *const objv[]) /* The arguments as actually seen. */ -{ - CallContext *const contextPtr = (CallContext *)clientData; - Method *const mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; - const int isFilter = - contextPtr->callPtr->chain[contextPtr->index].isFilter; - - /* - * If this is the first step along the chain, we preserve the method - * entries in the chain so that they do not get deleted out from under our - * feet. - */ - - if (contextPtr->index == 0) { - int i; - - for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) { - AddRef(contextPtr->callPtr->chain[i].mPtr); - } - - /* - * Ensure that the method name itself is part of the arguments when - * we're doing unknown processing. - */ - - if (contextPtr->callPtr->flags & OO_UNKNOWN_METHOD) { - contextPtr->skip--; - } - - /* - * Add a callback to ensure that method references are dropped once - * this call is finished. - */ - - TclNRAddCallback(interp, FinalizeMethodRefs, contextPtr, NULL, NULL, - NULL); - } - - /* - * Save whether we were in a filter and set up whether we are now. - */ - - if (contextPtr->oPtr->flags & FILTER_HANDLING) { - TclNRAddCallback(interp, SetFilterFlags, contextPtr, NULL,NULL,NULL); - } else { - TclNRAddCallback(interp, ResetFilterFlags,contextPtr,NULL,NULL,NULL); - } - if (isFilter || contextPtr->callPtr->flags & FILTER_HANDLING) { - contextPtr->oPtr->flags |= FILTER_HANDLING; - } else { - contextPtr->oPtr->flags &= ~FILTER_HANDLING; - } - - /* - * Run the method implementation. - */ - - 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; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOGetSortedMethodList, TclOOGetSortedClassMethodList -- - * - * Discovers the list of method names supported by an object or class. - * - * ---------------------------------------------------------------------- - */ - -int -TclOOGetSortedMethodList( - Object *oPtr, /* The object to get the method names for. */ - Object *contextObj, /* From what context object we are inquiring. - * NULL when the context shouldn't see - * object-level private methods. Note that - * flags can override this. */ - Class *contextCls, /* From what context class we are inquiring. - * NULL when the context shouldn't see - * class-level private methods. Note that - * flags can override this. */ - int flags, /* Whether we just want the public method - * names. */ - const char ***stringsPtr) /* Where to write a pointer to the array of - * strings to. */ -{ - Tcl_HashTable names; /* Tcl_Obj* method name to "wanted in list" - * mapping. */ - Tcl_HashTable examinedClasses; - /* Used to track what classes have been looked - * at. Is set-like in nature and keyed by - * pointer to class. */ - FOREACH_HASH_DECLS; - int i, numStrings; - Class *mixinPtr; - Tcl_Obj *namePtr; - Method *mPtr; - - Tcl_InitObjHashTable(&names); - Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS); - - /* - * Name the bits used in the names table values. - */ -#define IN_LIST 1 -#define NO_IMPLEMENTATION 2 - - /* - * Process method names due to the object. - */ - - if (oPtr->methodsPtr) { - FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) { - if (IS_PRIVATE(mPtr)) { - continue; - } - if (IS_UNEXPORTED(mPtr) && !WANT_UNEXPORTED(flags)) { - continue; - } - AddStandardMethodName(flags, namePtr, mPtr, &names); - } - } - - /* - * Process method names due to private methods on the object's class. - */ - - if (WANT_UNEXPORTED(flags)) { - FOREACH_HASH(namePtr, mPtr, &oPtr->selfCls->classMethods) { - if (IS_UNEXPORTED(mPtr)) { - AddStandardMethodName(flags, namePtr, mPtr, &names); - } - } - } - - /* - * Process method names due to private methods on the context's object or - * class. Which must be correct if either are not NULL. - */ - - if (contextObj && contextObj->methodsPtr) { - AddPrivateMethodNames(contextObj->methodsPtr, &names); - } - if (contextCls) { - AddPrivateMethodNames(&contextCls->classMethods, &names); - } - - /* - * Process (normal) method names from the class hierarchy and the mixin - * hierarchy. - */ - - AddClassMethodNames(oPtr->selfCls, flags, &names, &examinedClasses); - FOREACH(mixinPtr, oPtr->mixins) { - AddClassMethodNames(mixinPtr, flags | TRAVERSED_MIXIN, &names, - &examinedClasses); - } - - /* - * Tidy up, sort the names and resolve finally whether we really want - * them (processing export layering). - */ - - Tcl_DeleteHashTable(&examinedClasses); - numStrings = SortMethodNames(&names, flags, stringsPtr); - Tcl_DeleteHashTable(&names); - return numStrings; -} - -int -TclOOGetSortedClassMethodList( - Class *clsPtr, /* The class to get the method names for. */ - int flags, /* Whether we just want the public method - * names. */ - const char ***stringsPtr) /* Where to write a pointer to the array of - * strings to. */ -{ - Tcl_HashTable names; /* Tcl_Obj* method name to "wanted in list" - * mapping. */ - Tcl_HashTable examinedClasses; - /* Used to track what classes have been looked - * at. Is set-like in nature and keyed by - * pointer to class. */ - int numStrings; - - Tcl_InitObjHashTable(&names); - Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS); - - /* - * Process method names from the class hierarchy and the mixin hierarchy. - */ - - AddClassMethodNames(clsPtr, flags, &names, &examinedClasses); - Tcl_DeleteHashTable(&examinedClasses); - - /* - * Process private method names if we should. [TIP 500] - */ - - if (WANT_PRIVATE(flags)) { - AddPrivateMethodNames(&clsPtr->classMethods, &names); - flags &= ~TRUE_PRIVATE_METHOD; - } - - /* - * Tidy up, sort the names and resolve finally whether we really want - * them (processing export layering). - */ - - numStrings = SortMethodNames(&names, flags, stringsPtr); - Tcl_DeleteHashTable(&names); - return numStrings; -} - -/* - * ---------------------------------------------------------------------- - * - * SortMethodNames -- - * - * Shared helper for TclOOGetSortedMethodList etc. that knows the method - * sorting rules. - * - * Returns: - * The length of the sorted list. - * - * ---------------------------------------------------------------------- - */ - -static int -SortMethodNames( - 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. Tcl_Alloced() */ -{ - const char **strings; - FOREACH_HASH_DECLS; - Tcl_Obj *namePtr; - void *isWanted; - size_t 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 **)Tcl_Alloc(sizeof(char *) * namesPtr->numEntries); - FOREACH_HASH(namePtr, isWanted, namesPtr) { - if (!WANT_PUBLIC(flags) || (PTR2INT(isWanted) & IN_LIST)) { - if (PTR2INT(isWanted) & NO_IMPLEMENTATION) { - continue; - } - strings[i++] = TclGetString(namePtr); - } - } - - /* - * Note that 'i' may well be less than names.numEntries when we are - * dealing with public method names. We don't sort unless there's at least - * two method names. - */ - - if (i > 0) { - if (i > 1) { - qsort((void *) strings, i, sizeof(char *), CmpStr); - } - *stringsPtr = strings; - } else { - Tcl_Free((void *)strings); - *stringsPtr = NULL; - } - return i; -} - -/* - * Comparator for SortMethodNames - */ - -static int -CmpStr( - const void *ptr1, - const void *ptr2) -{ - const char **strPtr1 = (const char **) ptr1; - const char **strPtr2 = (const char **) ptr2; - - return TclpUtfNcmp2(*strPtr1, *strPtr2, strlen(*strPtr1) + 1); -} - -/* - * ---------------------------------------------------------------------- - * - * AddClassMethodNames -- - * - * Adds the method names defined by a class (or its superclasses) to the - * collection being built. The collection is built in a hash table to - * ensure that duplicates are excluded. Helper for GetSortedMethodList(). - * - * ---------------------------------------------------------------------- - */ - -static void -AddClassMethodNames( - Class *clsPtr, /* Class to get method names from. */ - const int flags, /* Whether we are interested in just the - * public method names. */ - Tcl_HashTable *const namesPtr, - /* Reference to the hash table to put the - * information in. The hash table maps the - * Tcl_Obj * method name to an integral value - * describing whether the method is wanted. - * This ensures that public/private override - * semantics are handled correctly. */ - Tcl_HashTable *const examinedClassesPtr) - /* Hash table that tracks what classes have - * already been looked at. The keys are the - * pointers to the classes, and the values are - * immaterial. */ -{ - int i; - - /* - * If we've already started looking at this class, stop working on it now - * to prevent repeated work. - */ - - if (Tcl_FindHashEntry(examinedClassesPtr, (char *) clsPtr)) { - return; - } - - /* - * Scope all declarations so that the compiler can stand a good chance of - * making the recursive step highly efficient. We also hand-implement the - * tail-recursive case using a while loop; C compilers typically cannot do - * tail-recursion optimization usefully. - */ - - while (1) { - FOREACH_HASH_DECLS; - Tcl_Obj *namePtr; - Method *mPtr; - int isNew; - - (void) Tcl_CreateHashEntry(examinedClassesPtr, (char *) clsPtr, - &isNew); - if (!isNew) { - break; - } - - if (clsPtr->mixins.num != 0) { - Class *mixinPtr; - - FOREACH(mixinPtr, clsPtr->mixins) { - if (mixinPtr != clsPtr) { - AddClassMethodNames(mixinPtr, flags|TRAVERSED_MIXIN, - namesPtr, examinedClassesPtr); - } - } - } - - FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) { - AddStandardMethodName(flags, namePtr, mPtr, namesPtr); - } - - if (clsPtr->superclasses.num != 1) { - break; - } - clsPtr = clsPtr->superclasses.list[0]; - } - if (clsPtr->superclasses.num != 0) { - Class *superPtr; - - FOREACH(superPtr, clsPtr->superclasses) { - AddClassMethodNames(superPtr, flags, namesPtr, - examinedClassesPtr); - } - } -} - -/* - * ---------------------------------------------------------------------- - * - * AddPrivateMethodNames, AddStandardMethodName -- - * - * Factored-out helpers for the sorted name list production functions. - * - * ---------------------------------------------------------------------- - */ - -static inline void -AddPrivateMethodNames( - Tcl_HashTable *methodsTablePtr, - Tcl_HashTable *namesPtr) -{ - FOREACH_HASH_DECLS; - Method *mPtr; - Tcl_Obj *namePtr; - - FOREACH_HASH(namePtr, mPtr, methodsTablePtr) { - if (IS_PRIVATE(mPtr)) { - int isNew; - - hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew); - Tcl_SetHashValue(hPtr, INT2PTR(IN_LIST)); - } - } -} - -static inline void -AddStandardMethodName( - int flags, - Tcl_Obj *namePtr, - Method *mPtr, - Tcl_HashTable *namesPtr) -{ - if (!IS_PRIVATE(mPtr)) { - int isNew; - Tcl_HashEntry *hPtr = - Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew); - - if (isNew) { - int isWanted = (!WANT_PUBLIC(flags) || IS_PUBLIC(mPtr)) - ? IN_LIST : 0; - - isWanted |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0); - Tcl_SetHashValue(hPtr, INT2PTR(isWanted)); - } else if ((PTR2INT(Tcl_GetHashValue(hPtr)) & NO_IMPLEMENTATION) - && mPtr->typePtr != NULL) { - int isWanted = PTR2INT(Tcl_GetHashValue(hPtr)); - - isWanted &= ~NO_IMPLEMENTATION; - Tcl_SetHashValue(hPtr, INT2PTR(isWanted)); - } - } -} - -#undef IN_LIST -#undef NO_IMPLEMENTATION - -/* - * ---------------------------------------------------------------------- - * - * AddInstancePrivateToCallContext -- - * - * Add private methods from the instance. Called when the calling Tcl - * context is a TclOO method declared by an object that is the same as - * the current object. Returns true iff a private method was actually - * found and added to the call chain (as this suppresses caching). - * - * ---------------------------------------------------------------------- - */ - -static inline int -AddInstancePrivateToCallContext( - Object *const oPtr, /* Object to add call chain entries for. */ - Tcl_Obj *const methodName, /* Name of method to add the call chain - * entries for. */ - struct ChainBuilder *const cbPtr, - /* Where to add the call chain entries. */ - int flags) /* What sort of call chain are we building. */ -{ - Tcl_HashEntry *hPtr; - Method *mPtr; - int donePrivate = 0; - - if (oPtr->methodsPtr) { - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodName); - if (hPtr != NULL) { - mPtr = (Method *)Tcl_GetHashValue(hPtr); - if (IS_PRIVATE(mPtr)) { - AddMethodToCallChain(mPtr, cbPtr, NULL, NULL, flags); - donePrivate = 1; - } - } - } - return donePrivate; -} - -/* - * ---------------------------------------------------------------------- - * - * AddSimpleChainToCallContext -- - * - * The core of the call-chain construction engine, this handles calling a - * particular method on a particular object. Note that filters and - * unknown handling are already handled by the logic that uses this - * function. Returns true if a private method was one of those found. - * - * ---------------------------------------------------------------------- - */ - -static inline int -AddSimpleChainToCallContext( - Object *const oPtr, /* Object to add call chain entries for. */ - Class *const contextCls, /* Context class; the currently considered - * class is equal to this, private methods may - * also be added. [TIP 500] */ - Tcl_Obj *const methodNameObj, - /* Name of method to add the call chain - * entries for. */ - struct ChainBuilder *const cbPtr, - /* Where to add the call chain entries. */ - Tcl_HashTable *const doneFilters, - /* Where to record what call chain entries - * have been processed. */ - int flags, /* What sort of call chain are we building. */ - Class *const filterDecl) /* The class that declared the filter. If - * NULL, either the filter was declared by the - * object or this isn't a filter. */ -{ - int i, foundPrivate = 0, blockedUnexported = 0; - 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; - } - } else { - flags |= DEFINITE_PROTECTED; - } - } - } - } - if (!(flags & SPECIAL)) { - Class *mixinPtr; - - FOREACH(mixinPtr, oPtr->mixins) { - if (contextCls) { - foundPrivate |= AddPrivatesFromClassChainToCallContext( - mixinPtr, contextCls, methodNameObj, cbPtr, - doneFilters, flags|TRAVERSED_MIXIN, filterDecl); - } - 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); - } - } - } - } - if (contextCls) { - foundPrivate |= AddPrivatesFromClassChainToCallContext(oPtr->selfCls, - contextCls, methodNameObj, cbPtr, doneFilters, flags, - filterDecl); - } - if (!blockedUnexported) { - foundPrivate |= AddSimpleClassChainToCallContext(oPtr->selfCls, - methodNameObj, cbPtr, doneFilters, flags, filterDecl); - } - return foundPrivate; -} - -/* - * ---------------------------------------------------------------------- - * - * AddMethodToCallChain -- - * - * Utility method that manages the adding of a particular method - * implementation to a call-chain. - * - * ---------------------------------------------------------------------- - */ - -static inline void -AddMethodToCallChain( - Method *const mPtr, /* Actual method implementation to add to call - * chain (or NULL, a no-op). */ - struct ChainBuilder *const cbPtr, - /* The call chain to add the method - * implementation to. */ - Tcl_HashTable *const doneFilters, - /* Where to record what filters have been - * processed. If NULL, not processing filters. - * Note that this function does not update - * this hashtable. */ - Class *const filterDecl, /* The class that declared the filter. If - * NULL, either the filter was declared by the - * object or this isn't a filter. */ - 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. - * - * This is also where we enforce mixin-consistency. - */ - - if (mPtr == NULL || mPtr->typePtr == NULL || !MIXIN_CONSISTENT(flags)) { - return; - } - - /* - * Enforce real private method handling here. We will skip adding this - * method IF - * 1) we are not allowing private methods, AND - * 2) this is a private method, AND - * 3) this is a class method, AND - * 4) this method was not declared by the class of the current object. - * - * This does mean that only classes really handle private methods. This - * should be sufficient for [incr Tcl] support though. - */ - - if (!WANT_UNEXPORTED(callPtr->flags) - && IS_UNEXPORTED(mPtr) - && (mPtr->declaringClassPtr != NULL) - && (mPtr->declaringClassPtr != cbPtr->oPtr->selfCls)) { - return; - } - - /* - * First test whether the method is already in the call chain. Skip over - * any leading filters. - */ - - for (i = cbPtr->filterLength ; i < callPtr->numChain ; i++) { - if (callPtr->chain[i].mPtr == mPtr && - callPtr->chain[i].isFilter == (doneFilters != NULL)) { - /* - * Call chain semantics states that methods come as *late* in the - * call chain as possible. This is done by copying down the - * following methods. Note that this does not change the number of - * method invocations in the call chain; it just rearranges them. - */ - - Class *declCls = callPtr->chain[i].filterDeclarer; - - for (; i + 1 < callPtr->numChain ; i++) { - callPtr->chain[i] = callPtr->chain[i + 1]; - } - callPtr->chain[i].mPtr = mPtr; - callPtr->chain[i].isFilter = (doneFilters != NULL); - callPtr->chain[i].filterDeclarer = declCls; - return; - } - } - - /* - * 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 *)Tcl_Alloc(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 *)Tcl_Realloc(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++; -} - -/* - * ---------------------------------------------------------------------- - * - * InitCallChain -- - * Encoding of the policy of how to set up a call chain. Doesn't populate - * the chain with the method implementation data. - * - * ---------------------------------------------------------------------- - */ - -static inline void -InitCallChain( - CallChain *callPtr, - Object *oPtr, - int flags) -{ - callPtr->flags = flags & - (PUBLIC_METHOD | PRIVATE_METHOD | SPECIAL | FILTER_HANDLING); - if (oPtr->flags & USE_CLASS_CACHE) { - oPtr = oPtr->selfCls->thisPtr; - callPtr->flags |= USE_CLASS_CACHE; - } - callPtr->epoch = oPtr->fPtr->epoch; - callPtr->objectCreationEpoch = oPtr->creationEpoch; - callPtr->objectEpoch = oPtr->epoch; - callPtr->refCount = 1; - callPtr->numChain = 0; - callPtr->chain = callPtr->staticChain; -} - -/* - * ---------------------------------------------------------------------- - * - * IsStillValid -- - * - * Calculates whether the given call chain can be used for executing a - * method for the given object. The condition on a chain from a cached - * location being reusable is: - * - Refers to the same object (same creation epoch), and - * - Still across the same class structure (same global epoch), and - * - Still across the same object strucutre (same local epoch), and - * - No public/private/filter magic leakage (same flags, modulo the fact - * that a public chain will satisfy a non-public call). - * - * ---------------------------------------------------------------------- - */ - -static inline int -IsStillValid( - CallChain *callPtr, - Object *oPtr, - int flags, - int mask) -{ - if ((oPtr->flags & USE_CLASS_CACHE)) { - oPtr = oPtr->selfCls->thisPtr; - flags |= USE_CLASS_CACHE; - } - return ((callPtr->objectCreationEpoch == oPtr->creationEpoch) - && (callPtr->epoch == oPtr->fPtr->epoch) - && (callPtr->objectEpoch == oPtr->epoch) - && ((callPtr->flags & mask) == (flags & mask))); -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOGetCallContext -- - * - * Responsible for constructing the call context, an ordered list of all - * method implementations to be called as part of a method invocation. - * This method is central to the whole operation of the OO system. - * - * ---------------------------------------------------------------------- - */ - -CallContext * -TclOOGetCallContext( - Object *oPtr, /* The object to get the context for. */ - Tcl_Obj *methodNameObj, /* The name of the method to get the context - * for. NULL when getting a constructor or - * destructor chain. */ - int flags, /* What sort of context are we looking for. - * Only the bits PUBLIC_METHOD, CONSTRUCTOR, - * PRIVATE_METHOD, DESTRUCTOR and - * FILTER_HANDLING are useful. */ - Object *contextObj, /* Context object; when equal to oPtr, it - * means that private methods may also be - * added. [TIP 500] */ - Class *contextCls, /* Context class; the currently considered - * class is equal to this, private methods may - * also be added. [TIP 500] */ - Tcl_Obj *cacheInThisObj) /* What object to cache in, or NULL if it is - * to be in the same object as the - * methodNameObj. */ -{ - CallContext *contextPtr; - CallChain *callPtr; - struct ChainBuilder cb; - int i, count, doFilters, donePrivate = 0; - Tcl_HashEntry *hPtr; - Tcl_HashTable doneFilters; - - if (cacheInThisObj == NULL) { - cacheInThisObj = methodNameObj; - } - if (flags&(SPECIAL|FILTER_HANDLING) || (oPtr->flags&FILTER_HANDLING)) { - hPtr = NULL; - doFilters = 0; - - /* - * Check if we have a cached valid constructor or destructor. - */ - - if (flags & CONSTRUCTOR) { - callPtr = oPtr->selfCls->constructorChainPtr; - if ((callPtr != NULL) - && (callPtr->objectEpoch == oPtr->selfCls->thisPtr->epoch) - && (callPtr->epoch == oPtr->fPtr->epoch)) { - callPtr->refCount++; - goto returnContext; - } - } else if (flags & DESTRUCTOR) { - callPtr = oPtr->selfCls->destructorChainPtr; - if ((oPtr->mixins.num == 0) && (callPtr != NULL) - && (callPtr->objectEpoch == oPtr->selfCls->thisPtr->epoch) - && (callPtr->epoch == oPtr->fPtr->epoch)) { - callPtr->refCount++; - goto returnContext; - } - } - } else { - /* - * Check if we can get the chain out of the Tcl_Obj method name or out - * of the cache. This is made a bit more complex by the fact that - * there are multiple different layers of cache (in the Tcl_Obj, in - * 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); - } - - if (oPtr->flags & USE_CLASS_CACHE) { - if (oPtr->selfCls->classChainCache != NULL) { - hPtr = Tcl_FindHashEntry(oPtr->selfCls->classChainCache, - (char *) methodNameObj); - } else { - hPtr = NULL; - } - } else { - if (oPtr->chainCache != NULL) { - hPtr = Tcl_FindHashEntry(oPtr->chainCache, - (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 *)Tcl_Alloc(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 = 0; - if (callPtr->numChain == 0) { - TclOODeleteChain(callPtr); - return NULL; - } - goto returnContext; - } - - /* - * Add all defined filters (if any, and if we're going to be processing - * them; they're not processed for constructors, destructors or when we're - * in the middle of processing a filter). - */ - - if (doFilters) { - Tcl_Obj *filterObj; - Class *mixinPtr; - - doFilters = 1; - Tcl_InitObjHashTable(&doneFilters); - FOREACH(mixinPtr, oPtr->mixins) { - AddClassFiltersToCallContext(oPtr, mixinPtr, &cb, &doneFilters, - TRAVERSED_MIXIN|BUILDING_MIXINS|OBJECT_MIXIN); - AddClassFiltersToCallContext(oPtr, mixinPtr, &cb, &doneFilters, - OBJECT_MIXIN); - } - FOREACH(filterObj, oPtr->filters) { - donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, - filterObj, &cb, &doneFilters, BUILDING_MIXINS, NULL); - donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, - filterObj, &cb, &doneFilters, 0, NULL); - } - AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters, - BUILDING_MIXINS); - AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters, - 0); - Tcl_DeleteHashTable(&doneFilters); - } - count = cb.filterLength = callPtr->numChain; - - /* - * Add the actual method implementations. We have to do this twice to - * handle class mixins right. - */ - - if (oPtr == contextObj) { - donePrivate |= AddInstancePrivateToCallContext(oPtr, methodNameObj, - &cb, flags); - donePrivate |= (contextObj->flags & HAS_PRIVATE_METHODS); - } - donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, - methodNameObj, &cb, NULL, flags|BUILDING_MIXINS, NULL); - donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, - methodNameObj, &cb, NULL, flags, NULL); - - /* - * Check to see if the method has no implementation. If so, we probably - * need to add in a call to the unknown method. Otherwise, set up the - * cacheing of the method implementation (if relevant). - */ - - if (count == callPtr->numChain) { - /* - * Method does not actually exist. If we're dealing with constructors - * or destructors, this isn't a problem. - */ - - if (flags & SPECIAL) { - TclOODeleteChain(callPtr); - return NULL; - } - 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 = 0; - 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 *)Tcl_Alloc(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 *)Tcl_Alloc(sizeof(Tcl_HashTable)); - - Tcl_InitObjHashTable(oPtr->chainCache); - } - hPtr = Tcl_CreateHashEntry(oPtr->chainCache, - (char *) methodNameObj, &i); - } - } - callPtr->refCount++; - Tcl_SetHashValue(hPtr, callPtr); - StashCallChain(cacheInThisObj, callPtr); - } else if (flags & CONSTRUCTOR) { - if (oPtr->selfCls->constructorChainPtr) { - TclOODeleteChain(oPtr->selfCls->constructorChainPtr); - } - oPtr->selfCls->constructorChainPtr = callPtr; - callPtr->refCount++; - } else if ((flags & DESTRUCTOR) && oPtr->mixins.num == 0) { - if (oPtr->selfCls->destructorChainPtr) { - 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); - contextPtr->callPtr = callPtr; - contextPtr->skip = 2; - contextPtr->index = 0; - return contextPtr; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOGetStereotypeCallChain -- - * - * Construct a call-chain for a method that would be used by a - * stereotypical instance of the given class (i.e., where the object has - * no definitions special to itself). - * - * ---------------------------------------------------------------------- - */ - -CallChain * -TclOOGetStereotypeCallChain( - Class *clsPtr, /* The object to get the context for. */ - Tcl_Obj *methodNameObj, /* The name of the method to get the context - * for. NULL when getting a constructor or - * destructor chain. */ - int flags) /* What sort of context are we looking for. - * Only the bits PUBLIC_METHOD, CONSTRUCTOR, - * PRIVATE_METHOD, DESTRUCTOR and - * FILTER_HANDLING are useful. */ -{ - CallChain *callPtr; - struct ChainBuilder cb; - int i, count; - Foundation *fPtr = clsPtr->thisPtr->fPtr; - Tcl_HashEntry *hPtr; - Tcl_HashTable doneFilters; - Object obj; - - /* - * Synthesize a temporary stereotypical object so that we can use existing - * machinery to produce the stereotypical call chain. - */ - - memset(&obj, 0, sizeof(Object)); - obj.fPtr = fPtr; - obj.selfCls = clsPtr; - obj.refCount = 1; - obj.flags = USE_CLASS_CACHE; - - /* - * Check if we can get the chain out of the Tcl_Obj method name or out of - * the cache. This is made a bit more complex by the fact that there are - * multiple different layers of cache (in the Tcl_Obj, in the object, and - * in the class). - */ - - 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 *)Tcl_Alloc(sizeof(CallChain)); - memset(callPtr, 0, sizeof(CallChain)); - callPtr->flags = flags & (PUBLIC_METHOD|PRIVATE_METHOD|FILTER_HANDLING); - callPtr->epoch = fPtr->epoch; - callPtr->objectCreationEpoch = fPtr->tsdPtr->nsCount; - callPtr->objectEpoch = clsPtr->thisPtr->epoch; - callPtr->refCount = 1; - callPtr->chain = callPtr->staticChain; - - cb.callChainPtr = callPtr; - cb.filterLength = 0; - cb.oPtr = &obj; - - /* - * Add all defined filters (if any, and if we're going to be processing - * them; they're not processed for constructors, destructors or when we're - * in the middle of processing a filter). - */ - - Tcl_InitObjHashTable(&doneFilters); - AddClassFiltersToCallContext(&obj, clsPtr, &cb, &doneFilters, - BUILDING_MIXINS); - AddClassFiltersToCallContext(&obj, clsPtr, &cb, &doneFilters, 0); - Tcl_DeleteHashTable(&doneFilters); - count = cb.filterLength = callPtr->numChain; - - /* - * Add the actual method implementations. - */ - - AddSimpleChainToCallContext(&obj, NULL, methodNameObj, &cb, NULL, - flags|BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(&obj, NULL, methodNameObj, &cb, NULL, flags, - NULL); - - /* - * Check to see if the method has no implementation. If so, we probably - * need to add in a call to the unknown method. Otherwise, set up the - * cacheing of the method implementation (if relevant). - */ - - 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 = 0; - if (count == callPtr->numChain) { - TclOODeleteChain(callPtr); - return NULL; - } - } else { - if (hPtr == NULL) { - if (clsPtr->classChainCache == NULL) { - clsPtr->classChainCache = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); - Tcl_InitObjHashTable(clsPtr->classChainCache); - } - hPtr = Tcl_CreateHashEntry(clsPtr->classChainCache, - (char *) methodNameObj, &i); - } - callPtr->refCount++; - Tcl_SetHashValue(hPtr, callPtr); - StashCallChain(methodNameObj, callPtr); - } - return callPtr; -} - -/* - * ---------------------------------------------------------------------- - * - * AddClassFiltersToCallContext -- - * - * Logic to make extracting all the filters from the class context much - * easier. - * - * ---------------------------------------------------------------------- - */ - -static void -AddClassFiltersToCallContext( - Object *const oPtr, /* Object that the filters operate on. */ - Class *clsPtr, /* Class to get the filters from. */ - struct ChainBuilder *const cbPtr, - /* Context to fill with call chain entries. */ - Tcl_HashTable *const doneFilters, - /* Where to record what filters have been - * processed. Keys are objects, values are - * ignored. */ - int flags) /* Whether we've gone along a mixin link - * yet. */ -{ - int i, clearedFlags = - flags & ~(TRAVERSED_MIXIN|OBJECT_MIXIN|BUILDING_MIXINS); - Class *superPtr, *mixinPtr; - Tcl_Obj *filterObj; - - tailRecurse: - if (clsPtr == NULL) { - return; - } - - /* - * Add all the filters defined by classes mixed into the main class - * hierarchy. - */ - - FOREACH(mixinPtr, clsPtr->mixins) { - AddClassFiltersToCallContext(oPtr, mixinPtr, cbPtr, doneFilters, - flags|TRAVERSED_MIXIN); - } - - /* - * Add all the class filters from the current class. Note that the filters - * are added starting at the object root, as this allows the object to - * override how filters work to extend their behaviour. - */ - - if (MIXIN_CONSISTENT(flags)) { - FOREACH(filterObj, clsPtr->filters) { - int isNew; - - (void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj, - &isNew); - if (isNew) { - AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr, - doneFilters, clearedFlags|BUILDING_MIXINS, clsPtr); - AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr, - doneFilters, clearedFlags, clsPtr); - } - } - } - - /* - * Now process the recursive case. Notice the tail-call optimization. - */ - - switch (clsPtr->superclasses.num) { - case 1: - clsPtr = clsPtr->superclasses.list[0]; - goto tailRecurse; - default: - FOREACH(superPtr, clsPtr->superclasses) { - AddClassFiltersToCallContext(oPtr, superPtr, cbPtr, doneFilters, - flags); - } - case 0: - return; - } -} - -/* - * ---------------------------------------------------------------------- - * - * AddPrivatesFromClassChainToCallContext -- - * - * Helper for AddSimpleChainToCallContext that is used to find private - * methds and add them to the call chain. Returns true when a private - * method is found and added. [TIP 500] - * - * ---------------------------------------------------------------------- - */ - -static int -AddPrivatesFromClassChainToCallContext( - Class *classPtr, /* Class to add the call chain entries for. */ - Class *const contextCls, /* Context class; the currently considered - * class is equal to this, private methods may - * also be added. */ - Tcl_Obj *const methodName, /* Name of method to add the call chain - * entries for. */ - struct ChainBuilder *const cbPtr, - /* Where to add the call chain entries. */ - Tcl_HashTable *const doneFilters, - /* Where to record what call chain entries - * have been processed. */ - int flags, /* What sort of call chain are we building. */ - Class *const filterDecl) /* The class that declared the filter. If - * NULL, either the filter was declared by the - * object or this isn't a filter. */ -{ - int i; - Class *superPtr; - - /* - * We hard-code the tail-recursive form. It's by far the most common case - * *and* it is much more gentle on the stack. - * - * Note that mixins must be processed before the main class hierarchy. - * [Bug 1998221] - */ - - tailRecurse: - FOREACH(superPtr, classPtr->mixins) { - if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls, - methodName, cbPtr, doneFilters, flags|TRAVERSED_MIXIN, - filterDecl)) { - return 1; - } - } - - if (classPtr == contextCls) { - Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods, - methodName); - - if (hPtr != NULL) { - Method *mPtr = (Method *)Tcl_GetHashValue(hPtr); - - if (IS_PRIVATE(mPtr)) { - AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, - flags); - return 1; - } - } - } - - 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; - } -} - -/* - * ---------------------------------------------------------------------- - * - * AddSimpleClassChainToCallContext -- - * - * Construct a call-chain from a class hierarchy. - * - * ---------------------------------------------------------------------- - */ - -static int -AddSimpleClassChainToCallContext( - Class *classPtr, /* Class to add the call chain entries for. */ - Tcl_Obj *const methodNameObj, - /* Name of method to add the call chain - * entries for. */ - struct ChainBuilder *const cbPtr, - /* Where to add the call chain entries. */ - Tcl_HashTable *const doneFilters, - /* Where to record what call chain entries - * have been processed. */ - int flags, /* What sort of call chain are we building. */ - Class *const filterDecl) /* The class that declared the filter. If - * NULL, either the filter was declared by the - * object or this isn't a filter. */ -{ - int i, privateDanger = 0; - Class *superPtr; - - /* - * We hard-code the tail-recursive form. It's by far the most common case - * *and* it is much more gentle on the stack. - * - * Note that mixins must be processed before the main class hierarchy. - * [Bug 1998221] - */ - - tailRecurse: - FOREACH(superPtr, classPtr->mixins) { - privateDanger |= AddSimpleClassChainToCallContext(superPtr, - methodNameObj, cbPtr, doneFilters, flags | TRAVERSED_MIXIN, - filterDecl); - } - - if (flags & CONSTRUCTOR) { - AddMethodToCallChain(classPtr->constructorPtr, cbPtr, doneFilters, - filterDecl, flags); - } else if (flags & DESTRUCTOR) { - AddMethodToCallChain(classPtr->destructorPtr, cbPtr, doneFilters, - filterDecl, flags); - } else { - Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods, - (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; - } - flags |= DEFINITE_PUBLIC; - } else { - flags |= DEFINITE_PROTECTED; - } - } - AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, - flags); - } - } - } - - switch (classPtr->superclasses.num) { - case 1: - 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; - } -} - -/* - * ---------------------------------------------------------------------- - * - * TclOORenderCallChain -- - * - * Create a description of a call chain. Used in [info object call], - * [info class call], and [self call]. - * - * ---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclOORenderCallChain( - Tcl_Interp *interp, - CallChain *callPtr) -{ - Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral, *privateLiteral; - Tcl_Obj *resultObj, *descObjs[4], **objv; - Foundation *fPtr = TclOOGetFoundation(interp); - int i; - - /* - * Allocate the literals (potentially) used in our description. - */ - - TclNewLiteralStringObj(filterLiteral, "filter"); - Tcl_IncrRefCount(filterLiteral); - TclNewLiteralStringObj(methodLiteral, "method"); - Tcl_IncrRefCount(methodLiteral); - TclNewLiteralStringObj(objectLiteral, "object"); - Tcl_IncrRefCount(objectLiteral); - TclNewLiteralStringObj(privateLiteral, "private"); - Tcl_IncrRefCount(privateLiteral); - - /* - * Do the actual construction of the descriptions. They consist of a list - * of triples that describe the details of how a method is understood. For - * each triple, the first word is the type of invocation ("method" is - * normal, "unknown" is special because it adds the method name as an - * extra argument when handled by some method types, and "filter" is - * special because it's a filter method). The second word is the name of - * the method in question (which differs for "unknown" and "filter" types) - * and the third word is the full name of the class that declares the - * method (or "object" if it is declared on the instance). - */ - - objv = (Tcl_Obj **)TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *)); - for (i = 0 ; i < callPtr->numChain ; i++) { - struct MInvoke *miPtr = &callPtr->chain[i]; - - descObjs[0] = - miPtr->isFilter ? filterLiteral : - callPtr->flags & OO_UNKNOWN_METHOD ? fPtr->unknownMethodNameObj : - IS_PRIVATE(miPtr->mPtr) ? privateLiteral : - methodLiteral; - descObjs[1] = - callPtr->flags & CONSTRUCTOR ? fPtr->constructorName : - callPtr->flags & DESTRUCTOR ? fPtr->destructorName : - miPtr->mPtr->namePtr; - descObjs[2] = miPtr->mPtr->declaringClassPtr - ? Tcl_GetObjectName(interp, - (Tcl_Object) miPtr->mPtr->declaringClassPtr->thisPtr) - : objectLiteral; - descObjs[3] = Tcl_NewStringObj(miPtr->mPtr->typePtr->name, -1); - - objv[i] = Tcl_NewListObj(4, descObjs); - } - - /* - * Drop the local references to the literals; if they're actually used, - * they'll live on the description itself. - */ - - Tcl_DecrRefCount(filterLiteral); - Tcl_DecrRefCount(methodLiteral); - Tcl_DecrRefCount(objectLiteral); - Tcl_DecrRefCount(privateLiteral); - - /* - * Finish building the description and return it. - */ - - resultObj = Tcl_NewListObj(callPtr->numChain, objv); - TclStackFree(interp, objv); - return resultObj; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOGetDefineContextNamespace -- - * - * Responsible for determining which namespace to use for definitions. - * This is done by building a define chain, which models (strongly!) the - * way that a call chain works but with a different internal model. - * - * Then it walks the chain to find the first namespace name that actually - * resolves to an existing namespace. - * - * Returns: - * Name of namespace, or NULL if none can be found. Note that this - * function does *not* set an error message in the interpreter on failure. - * - * ---------------------------------------------------------------------- - */ - -#define DEFINE_CHAIN_STATIC_SIZE 4 /* Enough space to store most cases. */ - -Tcl_Namespace * -TclOOGetDefineContextNamespace( - Tcl_Interp *interp, /* In what interpreter should namespace names - * actually be resolved. */ - Object *oPtr, /* The object to get the context for. */ - int forClass) /* What sort of context are we looking for. - * If true, we are going to use this for - * [oo::define], otherwise, we are going to - * use this for [oo::objdefine]. */ -{ - DefineChain define; - DefineEntry staticSpace[DEFINE_CHAIN_STATIC_SIZE]; - DefineEntry *entryPtr; - Tcl_Namespace *nsPtr = NULL; - int i; - - define.list = staticSpace; - define.num = 0; - define.size = DEFINE_CHAIN_STATIC_SIZE; - - /* - * Add the actual define locations. We have to do this twice to handle - * class mixins right. - */ - - AddSimpleDefineNamespaces(oPtr, &define, forClass | BUILDING_MIXINS); - AddSimpleDefineNamespaces(oPtr, &define, forClass); - - /* - * Go through the list until we find a namespace whose name we can - * resolve. - */ - - FOREACH_STRUCT(entryPtr, define) { - if (TclGetNamespaceFromObj(interp, entryPtr->namespaceName, - &nsPtr) == TCL_OK) { - break; - } - Tcl_ResetResult(interp); - } - if (define.list != staticSpace) { - Tcl_Free(define.list); - } - return nsPtr; -} - -/* - * ---------------------------------------------------------------------- - * - * AddSimpleDefineNamespaces -- - * - * Adds to the definition chain all the definitions provided by an - * object's class and its mixins, taking into account everything they - * inherit from. - * - * ---------------------------------------------------------------------- - */ - -static inline void -AddSimpleDefineNamespaces( - Object *const oPtr, /* Object to add define chain entries for. */ - DefineChain *const definePtr, - /* Where to add the define chain entries. */ - int flags) /* What sort of define chain are we - * building. */ -{ - Class *mixinPtr; - int i; - - FOREACH(mixinPtr, oPtr->mixins) { - AddSimpleClassDefineNamespaces(mixinPtr, definePtr, - flags | TRAVERSED_MIXIN); - } - - AddSimpleClassDefineNamespaces(oPtr->selfCls, definePtr, flags); -} - -/* - * ---------------------------------------------------------------------- - * - * AddSimpleClassDefineNamespaces -- - * - * Adds to the definition chain all the definitions provided by a class - * and its superclasses and its class mixins. - * - * ---------------------------------------------------------------------- - */ - -static void -AddSimpleClassDefineNamespaces( - Class *classPtr, /* Class to add the define chain entries for. */ - DefineChain *const definePtr, - /* Where to add the define chain entries. */ - int flags) /* What sort of define chain are we - * building. */ -{ - int i; - Class *superPtr; - - /* - * We hard-code the tail-recursive form. It's by far the most common case - * *and* it is much more gentle on the stack. - */ - - tailRecurse: - FOREACH(superPtr, classPtr->mixins) { - AddSimpleClassDefineNamespaces(superPtr, definePtr, - flags | TRAVERSED_MIXIN); - } - - if (flags & ~(TRAVERSED_MIXIN | BUILDING_MIXINS)) { - AddDefinitionNamespaceToChain(classPtr, classPtr->clsDefinitionNs, - definePtr, flags); - } else { - AddDefinitionNamespaceToChain(classPtr, classPtr->objDefinitionNs, - definePtr, flags); - } - - switch (classPtr->superclasses.num) { - case 1: - classPtr = classPtr->superclasses.list[0]; - goto tailRecurse; - default: - FOREACH(superPtr, classPtr->superclasses) { - AddSimpleClassDefineNamespaces(superPtr, definePtr, flags); - } - case 0: - return; - } -} - -/* - * ---------------------------------------------------------------------- - * - * AddDefinitionNamespaceToChain -- - * - * Adds a single item to the definition chain (if it is meaningful), - * reallocating the space for the chain if necessary. - * - * ---------------------------------------------------------------------- - */ - -static inline void -AddDefinitionNamespaceToChain( - Class *const definerCls, /* What class defines this entry. */ - Tcl_Obj *const namespaceName, /* The name for this entry (or NULL, a - * no-op). */ - DefineChain *const definePtr, - /* The define chain to add the method - * implementation to. */ - int flags) /* Used to check if we're mixin-consistent - * only. Mixin-consistent means that either - * we're looking to add things from a mixin - * and we have passed a mixin, or we're not - * looking to add things from a mixin and have - * not passed a mixin. */ -{ - int i; - - /* - * Return if this entry is blank. This is also where we enforce - * mixin-consistency. - */ - - if (namespaceName == NULL || !MIXIN_CONSISTENT(flags)) { - return; - } - - /* - * First test whether the method is already in the call chain. - */ - - for (i=0 ; inum ; i++) { - if (definePtr->list[i].definerCls == definerCls) { - /* - * Call chain semantics states that methods come as *late* in the - * call chain as possible. This is done by copying down the - * following methods. Note that this does not change the number of - * method invocations in the call chain; it just rearranges them. - * - * We skip changing anything if the place we found was already at - * the end of the list. - */ - - if (i < definePtr->num - 1) { - memmove(&definePtr->list[i], &definePtr->list[i + 1], - sizeof(DefineEntry) * (definePtr->num - i - 1)); - definePtr->list[i].definerCls = definerCls; - definePtr->list[i].namespaceName = namespaceName; - } - return; - } - } - - /* - * Need to really add the define. 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 (definePtr->num == definePtr->size) { - definePtr->size *= 2; - if (definePtr->num == DEFINE_CHAIN_STATIC_SIZE) { - DefineEntry *staticList = definePtr->list; - - definePtr->list = - (DefineEntry *)Tcl_Alloc(sizeof(DefineEntry) * definePtr->size); - memcpy(definePtr->list, staticList, - sizeof(DefineEntry) * definePtr->num); - } else { - definePtr->list = (DefineEntry *)Tcl_Realloc(definePtr->list, - sizeof(DefineEntry) * definePtr->size); - } - } - definePtr->list[i].definerCls = definerCls; - definePtr->list[i].namespaceName = namespaceName; - definePtr->num++; -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ DELETED generic/tclOODecls.h Index: generic/tclOODecls.h ================================================================== --- generic/tclOODecls.h +++ /dev/null @@ -1,239 +0,0 @@ -/* - * This file is (mostly) automatically generated from tclOO.decls. - */ - -#ifndef _TCLOODECLS -#define _TCLOODECLS - -#ifndef TCLAPI -# ifdef BUILD_tcl -# define TCLAPI extern DLLEXPORT -# else -# define TCLAPI extern DLLIMPORT -# endif -#endif - -#ifdef USE_TCL_STUBS -# undef USE_TCLOO_STUBS -# define USE_TCLOO_STUBS -#endif - -/* !BEGIN!: Do not edit below this line. */ - -#ifdef __cplusplus -extern "C" { -#endif - -/* - * Exported function declarations: - */ - -/* 0 */ -TCLAPI Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, - Tcl_Object sourceObject, - const char *targetName, - const char *targetNamespaceName); -/* 1 */ -TCLAPI Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz); -/* 2 */ -TCLAPI Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object); -/* 3 */ -TCLAPI Tcl_Command Tcl_GetObjectCommand(Tcl_Object object); -/* 4 */ -TCLAPI Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr); -/* 5 */ -TCLAPI Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object); -/* 6 */ -TCLAPI Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method); -/* 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, - void **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, - void *clientData); -/* 12 */ -TCLAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, - Tcl_Obj *nameObj, int flags, - const Tcl_MethodType *typePtr, - void *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 void * Tcl_ClassGetMetadata(Tcl_Class clazz, - const Tcl_ObjectMetadataType *typePtr); -/* 20 */ -TCLAPI void Tcl_ClassSetMetadata(Tcl_Class clazz, - const Tcl_ObjectMetadataType *typePtr, - void *metadata); -/* 21 */ -TCLAPI void * Tcl_ObjectGetMetadata(Tcl_Object object, - const Tcl_ObjectMetadataType *typePtr); -/* 22 */ -TCLAPI void Tcl_ObjectSetMetadata(Tcl_Object object, - const Tcl_ObjectMetadataType *typePtr, - void *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); -/* 25 */ -TCLAPI void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, - Tcl_ObjectMapMethodNameProc *mapMethodNameProc); -/* 26 */ -TCLAPI void Tcl_ClassSetConstructor(Tcl_Interp *interp, - Tcl_Class clazz, Tcl_Method method); -/* 27 */ -TCLAPI void Tcl_ClassSetDestructor(Tcl_Interp *interp, - Tcl_Class clazz, Tcl_Method method); -/* 28 */ -TCLAPI Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, - Tcl_Object object); -/* 29 */ -TCLAPI int Tcl_MethodIsPrivate(Tcl_Method method); - -typedef struct { - const struct TclOOIntStubs *tclOOIntStubs; -} TclOOStubHooks; - -typedef struct TclOOStubs { - int magic; - const TclOOStubHooks *hooks; - - Tcl_Object (*tcl_CopyObjectInstance) (Tcl_Interp *interp, Tcl_Object sourceObject, const char *targetName, const char *targetNamespaceName); /* 0 */ - Tcl_Object (*tcl_GetClassAsObject) (Tcl_Class clazz); /* 1 */ - 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, void **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, void *clientData); /* 11 */ - Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, void *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 */ - void * (*tcl_ClassGetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 19 */ - void (*tcl_ClassSetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, void *metadata); /* 20 */ - void * (*tcl_ObjectGetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 21 */ - void (*tcl_ObjectSetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, void *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 */ -} TclOOStubs; - -extern const TclOOStubs *tclOOStubsPtr; - -#ifdef __cplusplus -} -#endif - -#if defined(USE_TCLOO_STUBS) - -/* - * Inline function declarations: - */ - -#define Tcl_CopyObjectInstance \ - (tclOOStubsPtr->tcl_CopyObjectInstance) /* 0 */ -#define Tcl_GetClassAsObject \ - (tclOOStubsPtr->tcl_GetClassAsObject) /* 1 */ -#define Tcl_GetObjectAsClass \ - (tclOOStubsPtr->tcl_GetObjectAsClass) /* 2 */ -#define Tcl_GetObjectCommand \ - (tclOOStubsPtr->tcl_GetObjectCommand) /* 3 */ -#define Tcl_GetObjectFromObj \ - (tclOOStubsPtr->tcl_GetObjectFromObj) /* 4 */ -#define Tcl_GetObjectNamespace \ - (tclOOStubsPtr->tcl_GetObjectNamespace) /* 5 */ -#define Tcl_MethodDeclarerClass \ - (tclOOStubsPtr->tcl_MethodDeclarerClass) /* 6 */ -#define Tcl_MethodDeclarerObject \ - (tclOOStubsPtr->tcl_MethodDeclarerObject) /* 7 */ -#define Tcl_MethodIsPublic \ - (tclOOStubsPtr->tcl_MethodIsPublic) /* 8 */ -#define Tcl_MethodIsType \ - (tclOOStubsPtr->tcl_MethodIsType) /* 9 */ -#define Tcl_MethodName \ - (tclOOStubsPtr->tcl_MethodName) /* 10 */ -#define Tcl_NewInstanceMethod \ - (tclOOStubsPtr->tcl_NewInstanceMethod) /* 11 */ -#define Tcl_NewMethod \ - (tclOOStubsPtr->tcl_NewMethod) /* 12 */ -#define Tcl_NewObjectInstance \ - (tclOOStubsPtr->tcl_NewObjectInstance) /* 13 */ -#define Tcl_ObjectDeleted \ - (tclOOStubsPtr->tcl_ObjectDeleted) /* 14 */ -#define Tcl_ObjectContextIsFiltering \ - (tclOOStubsPtr->tcl_ObjectContextIsFiltering) /* 15 */ -#define Tcl_ObjectContextMethod \ - (tclOOStubsPtr->tcl_ObjectContextMethod) /* 16 */ -#define Tcl_ObjectContextObject \ - (tclOOStubsPtr->tcl_ObjectContextObject) /* 17 */ -#define Tcl_ObjectContextSkippedArgs \ - (tclOOStubsPtr->tcl_ObjectContextSkippedArgs) /* 18 */ -#define Tcl_ClassGetMetadata \ - (tclOOStubsPtr->tcl_ClassGetMetadata) /* 19 */ -#define Tcl_ClassSetMetadata \ - (tclOOStubsPtr->tcl_ClassSetMetadata) /* 20 */ -#define Tcl_ObjectGetMetadata \ - (tclOOStubsPtr->tcl_ObjectGetMetadata) /* 21 */ -#define Tcl_ObjectSetMetadata \ - (tclOOStubsPtr->tcl_ObjectSetMetadata) /* 22 */ -#define Tcl_ObjectContextInvokeNext \ - (tclOOStubsPtr->tcl_ObjectContextInvokeNext) /* 23 */ -#define Tcl_ObjectGetMethodNameMapper \ - (tclOOStubsPtr->tcl_ObjectGetMethodNameMapper) /* 24 */ -#define Tcl_ObjectSetMethodNameMapper \ - (tclOOStubsPtr->tcl_ObjectSetMethodNameMapper) /* 25 */ -#define Tcl_ClassSetConstructor \ - (tclOOStubsPtr->tcl_ClassSetConstructor) /* 26 */ -#define Tcl_ClassSetDestructor \ - (tclOOStubsPtr->tcl_ClassSetDestructor) /* 27 */ -#define Tcl_GetObjectName \ - (tclOOStubsPtr->tcl_GetObjectName) /* 28 */ -#define Tcl_MethodIsPrivate \ - (tclOOStubsPtr->tcl_MethodIsPrivate) /* 29 */ - -#endif /* defined(USE_TCLOO_STUBS) */ - -/* !END!: Do not edit above this line. */ - -#endif /* _TCLOODECLS */ DELETED generic/tclOODefineCmds.c Index: generic/tclOODefineCmds.c ================================================================== --- generic/tclOODefineCmds.c +++ /dev/null @@ -1,3087 +0,0 @@ -/* - * tclOODefineCmds.c -- - * - * This file contains the implementation of the ::oo::define command, - * part of the object-system core (NB: not Tcl_Obj, but ::oo). - * - * Copyright (c) 2006-2013 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. - */ - -#ifdef HAVE_CONFIG_H -#include "config.h" -#endif -#include "tclInt.h" -#include "tclOOInt.h" - -/* - * The actual value used to mark private declaration frames. - */ - -#define PRIVATE_FRAME (FRAME_IS_OO_DEFINE | FRAME_IS_PRIVATE_DEFINE) - -/* - * The maximum length of fully-qualified object name to use in an errorinfo - * message. Longer than this will be curtailed. - */ - -#define OBJNAME_LENGTH_IN_ERRORINFO_LIMIT 30 - -/* - * Some things that make it easier to declare a slot. - */ - -struct DeclaredSlot { - const char *name; - const Tcl_MethodType getterType; - const Tcl_MethodType setterType; - const Tcl_MethodType resolverType; -}; - -#define SLOT(name,getter,setter,resolver) \ - {"::oo::" name, \ - {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \ - getter, NULL, NULL}, \ - {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \ - setter, NULL, NULL}, \ - {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Resolver", \ - resolver, NULL, NULL}} - -/* - * A [string match] pattern used to determine if a method should be exported. - */ - -#define PUBLIC_PATTERN "[a-z]*" - -/* - * Forward declarations. - */ - -static inline void BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr); -static Tcl_Command FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj, - Tcl_Namespace *const namespacePtr); -static inline void GenerateErrorInfo(Tcl_Interp *interp, Object *oPtr, - Tcl_Obj *savedNameObj, const char *typeOfSubject); -static inline int MagicDefinitionInvoke(Tcl_Interp *interp, - Tcl_Namespace *nsPtr, int cmdIndex, - int objc, Tcl_Obj *const *objv); -static inline Class * GetClassInOuterContext(Tcl_Interp *interp, - Tcl_Obj *className, const char *errMsg); -static inline Tcl_Namespace *GetNamespaceInOuterContext(Tcl_Interp *interp, - Tcl_Obj *namespaceName); -static inline int InitDefineContext(Tcl_Interp *interp, - Tcl_Namespace *namespacePtr, Object *oPtr, - int objc, Tcl_Obj *const objv[]); -static inline void RecomputeClassCacheFlag(Object *oPtr); -static int RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr, - int useClass, Tcl_Obj *const fromPtr, - Tcl_Obj *const toPtr); -static int ClassFilterGet(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ClassFilterSet(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ClassMixinGet(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ClassMixinSet(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ClassSuperGet(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ClassSuperSet(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ClassVarsGet(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ClassVarsSet(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ObjFilterGet(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ObjFilterSet(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ObjMixinGet(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ObjMixinSet(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ObjVarsGet(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ObjVarsSet(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ResolveClass(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); - -/* - * Now define the slots used in declarations. - */ - -static const struct DeclaredSlot slots[] = { - SLOT("define::filter", ClassFilterGet, ClassFilterSet, NULL), - SLOT("define::mixin", ClassMixinGet, ClassMixinSet, ResolveClass), - SLOT("define::superclass", ClassSuperGet, ClassSuperSet, ResolveClass), - SLOT("define::variable", ClassVarsGet, ClassVarsSet, NULL), - SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet, NULL), - SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet, ResolveClass), - SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet, NULL), - {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} -}; - -/* - * How to build the in-namespace name of a private variable. This is a pattern - * used with Tcl_ObjPrintf(). - */ - -#define PRIVATE_VARIABLE_PATTERN "%d : %s" - -/* - * ---------------------------------------------------------------------- - * - * IsPrivateDefine -- - * - * Extracts whether the current context is handling private definitions. - * - * ---------------------------------------------------------------------- - */ - -static inline int -IsPrivateDefine( - Tcl_Interp *interp) -{ - Interp *iPtr = (Interp *) interp; - - if (!iPtr->varFramePtr) { - return 0; - } - return iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME; -} - -/* - * ---------------------------------------------------------------------- - * - * BumpGlobalEpoch -- - * - * Utility that ensures that call chains that are invalid will get thrown - * away at an appropriate time. Note that exactly which epoch gets - * advanced will depend on exactly what the class is tangled up in; in - * the worst case, the simplest option is to advance the global epoch, - * causing *everything* to be thrown away on next usage. - * - * ---------------------------------------------------------------------- - */ - -static inline void -BumpGlobalEpoch( - Tcl_Interp *interp, - Class *classPtr) -{ - if (classPtr != NULL - && classPtr->subclasses.num == 0 - && classPtr->instances.num == 0 - && classPtr->mixinSubs.num == 0) { - /* - * If a class has no subclasses or instances, and is not mixed into - * anything, a change to its structure does not require us to - * invalidate any call chains. Note that we still bump our object's - * epoch if it has any mixins; the relation between a class and its - * representative object is special. But it won't hurt. - */ - - if (classPtr->thisPtr->mixins.num > 0) { - classPtr->thisPtr->epoch++; - } - return; - } - - /* - * Either there's no class (?!) or we're reconfiguring something that is - * in use. Force regeneration of call chains. - */ - - TclOOGetFoundation(interp)->epoch++; -} - -/* - * ---------------------------------------------------------------------- - * - * RecomputeClassCacheFlag -- - * - * Determine whether the object is prototypical of its class, and hence - * able to use the class's method chain cache. - * - * ---------------------------------------------------------------------- - */ - -static inline void -RecomputeClassCacheFlag( - Object *oPtr) -{ - if ((oPtr->methodsPtr == NULL || oPtr->methodsPtr->numEntries == 0) - && (oPtr->mixins.num == 0) && (oPtr->filters.num == 0)) { - oPtr->flags |= USE_CLASS_CACHE; - } else { - oPtr->flags &= ~USE_CLASS_CACHE; - } -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOObjectSetFilters -- - * - * Install a list of filter method names into an object. - * - * ---------------------------------------------------------------------- - */ - -void -TclOOObjectSetFilters( - Object *oPtr, - int numFilters, - Tcl_Obj *const *filters) -{ - int i; - - if (oPtr->filters.num) { - Tcl_Obj *filterObj; - - FOREACH(filterObj, oPtr->filters) { - Tcl_DecrRefCount(filterObj); - } - } - - if (numFilters == 0) { - /* - * No list of filters was supplied, so we're deleting filters. - */ - - Tcl_Free(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 **)Tcl_Alloc(size); - } else { - filtersList = (Tcl_Obj **)Tcl_Realloc(oPtr->filters.list, size); - } - for (i = 0 ; i < numFilters ; i++) { - filtersList[i] = filters[i]; - Tcl_IncrRefCount(filters[i]); - } - oPtr->filters.list = filtersList; - oPtr->filters.num = numFilters; - oPtr->flags &= ~USE_CLASS_CACHE; - } - oPtr->epoch++; /* Only this object can be affected. */ -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOClassSetFilters -- - * - * Install a list of filter method names into a class. - * - * ---------------------------------------------------------------------- - */ - -void -TclOOClassSetFilters( - Tcl_Interp *interp, - Class *classPtr, - int numFilters, - Tcl_Obj *const *filters) -{ - int i; - - if (classPtr->filters.num) { - Tcl_Obj *filterObj; - - FOREACH(filterObj, classPtr->filters) { - Tcl_DecrRefCount(filterObj); - } - } - - if (numFilters == 0) { - /* - * No list of filters was supplied, so we're deleting filters. - */ - - Tcl_Free(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 **)Tcl_Alloc(size); - } else { - filtersList = (Tcl_Obj **)Tcl_Realloc(classPtr->filters.list, size); - } - for (i = 0 ; i < numFilters ; i++) { - filtersList[i] = filters[i]; - Tcl_IncrRefCount(filters[i]); - } - classPtr->filters.list = filtersList; - classPtr->filters.num = numFilters; - } - - /* - * There may be many objects affected, so bump the global epoch. - */ - - BumpGlobalEpoch(interp, classPtr); -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOObjectSetMixins -- - * - * Install a list of mixin classes into an object. - * - * ---------------------------------------------------------------------- - */ - -void -TclOOObjectSetMixins( - Object *oPtr, - int numMixins, - Class *const *mixins) -{ - Class *mixinPtr; - int i; - - if (numMixins == 0) { - if (oPtr->mixins.num != 0) { - FOREACH(mixinPtr, oPtr->mixins) { - TclOORemoveFromInstances(oPtr, mixinPtr); - TclOODecrRefCount(mixinPtr->thisPtr); - } - Tcl_Free(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 **)Tcl_Realloc(oPtr->mixins.list, - sizeof(Class *) * numMixins); - } else { - oPtr->mixins.list = (Class **)Tcl_Alloc(sizeof(Class *) * numMixins); - oPtr->flags &= ~USE_CLASS_CACHE; - } - oPtr->mixins.num = numMixins; - memcpy(oPtr->mixins.list, mixins, sizeof(Class *) * numMixins); - FOREACH(mixinPtr, oPtr->mixins) { - if (mixinPtr != oPtr->selfCls) { - TclOOAddToInstances(oPtr, mixinPtr); - - /* - * For the new copy created by memcpy(). - */ - - AddRef(mixinPtr->thisPtr); - } - } - } - oPtr->epoch++; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOClassSetMixins -- - * - * Install a list of mixin classes into a class. - * - * ---------------------------------------------------------------------- - */ - -void -TclOOClassSetMixins( - Tcl_Interp *interp, - Class *classPtr, - int numMixins, - Class *const *mixins) -{ - Class *mixinPtr; - int i; - - if (numMixins == 0) { - if (classPtr->mixins.num != 0) { - FOREACH(mixinPtr, classPtr->mixins) { - TclOORemoveFromMixinSubs(classPtr, mixinPtr); - TclOODecrRefCount(mixinPtr->thisPtr); - } - Tcl_Free(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 **)Tcl_Realloc(classPtr->mixins.list, - sizeof(Class *) * numMixins); - } else { - classPtr->mixins.list = (Class **)Tcl_Alloc(sizeof(Class *) * numMixins); - } - classPtr->mixins.num = numMixins; - memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins); - FOREACH(mixinPtr, classPtr->mixins) { - TclOOAddToMixinSubs(classPtr, mixinPtr); - - /* - * For the new copy created by memcpy. - */ - - AddRef(mixinPtr->thisPtr); - } - } - BumpGlobalEpoch(interp, classPtr); -} - -/* - * ---------------------------------------------------------------------- - * - * InstallStandardVariableMapping, InstallPrivateVariableMapping -- - * - * Helpers for installing standard and private variable maps. - * - * ---------------------------------------------------------------------- - */ -static inline void -InstallStandardVariableMapping( - VariableNameList *vnlPtr, - int varc, - Tcl_Obj *const *varv) -{ - Tcl_Obj *variableObj; - int i, n, created; - Tcl_HashTable uniqueTable; - - for (i=0 ; ilist); - } else if (i) { - vnlPtr->list = (Tcl_Obj **)Tcl_Realloc(vnlPtr->list, sizeof(Tcl_Obj *) * varc); - } else { - vnlPtr->list = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj *) * varc); - } - } - vnlPtr->num = 0; - if (varc > 0) { - Tcl_InitObjHashTable(&uniqueTable); - for (i=n=0 ; ilist[n++] = varv[i]; - } else { - Tcl_DecrRefCount(varv[i]); - } - } - vnlPtr->num = n; - - /* - * Shouldn't be necessary, but maintain num/list invariant. - */ - - if (n != varc) { - vnlPtr->list = (Tcl_Obj **)Tcl_Realloc(vnlPtr->list, sizeof(Tcl_Obj *) * n); - } - Tcl_DeleteHashTable(&uniqueTable); - } -} - -static inline void -InstallPrivateVariableMapping( - PrivateVariableList *pvlPtr, - int varc, - Tcl_Obj *const *varv, - int creationEpoch) -{ - PrivateVariableMapping *privatePtr; - int i, n, created; - Tcl_HashTable uniqueTable; - - for (i=0 ; ivariableObj); - Tcl_DecrRefCount(privatePtr->fullNameObj); - } - if (i != varc) { - if (varc == 0) { - Tcl_Free(pvlPtr->list); - } else if (i) { - pvlPtr->list = (PrivateVariableMapping *)Tcl_Realloc(pvlPtr->list, - sizeof(PrivateVariableMapping) * varc); - } else { - pvlPtr->list = (PrivateVariableMapping *)Tcl_Alloc(sizeof(PrivateVariableMapping) * varc); - } - } - - pvlPtr->num = 0; - if (varc > 0) { - Tcl_InitObjHashTable(&uniqueTable); - for (i=n=0 ; ilist[n++]); - privatePtr->variableObj = varv[i]; - privatePtr->fullNameObj = Tcl_ObjPrintf( - PRIVATE_VARIABLE_PATTERN, - creationEpoch, TclGetString(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 *)Tcl_Realloc(pvlPtr->list, - sizeof(PrivateVariableMapping) * n); - } - Tcl_DeleteHashTable(&uniqueTable); - } -} - -/* - * ---------------------------------------------------------------------- - * - * RenameDeleteMethod -- - * - * Core of the code to rename and delete methods. - * - * ---------------------------------------------------------------------- - */ - -static int -RenameDeleteMethod( - Tcl_Interp *interp, - Object *oPtr, - int useClass, - Tcl_Obj *const fromPtr, - Tcl_Obj *const toPtr) -{ - Tcl_HashEntry *hPtr, *newHPtr = NULL; - Method *mPtr; - int isNew; - - if (!useClass) { - if (!oPtr->methodsPtr) { - noSuchMethod: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "method %s does not exist", TclGetString(fromPtr))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(fromPtr), NULL); - return TCL_ERROR; - } - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) fromPtr); - if (hPtr == NULL) { - goto noSuchMethod; - } - if (toPtr) { - newHPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) toPtr, - &isNew); - if (hPtr == newHPtr) { - renameToSelf: - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot rename method to itself", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_TO_SELF", NULL); - return TCL_ERROR; - } else if (!isNew) { - renameToExisting: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "method called %s already exists", - TclGetString(toPtr))); - Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_OVER", NULL); - return TCL_ERROR; - } - } - } else { - hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, - (char *) fromPtr); - if (hPtr == NULL) { - goto noSuchMethod; - } - if (toPtr) { - newHPtr = Tcl_CreateHashEntry(&oPtr->classPtr->classMethods, - (char *) toPtr, &isNew); - if (hPtr == newHPtr) { - goto renameToSelf; - } else if (!isNew) { - goto renameToExisting; - } - } - } - - /* - * 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) { - RecomputeClassCacheFlag(oPtr); - } - TclOODelMethodRef(mPtr); - } - Tcl_DeleteHashEntry(hPtr); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOUnknownDefinition -- - * - * Handles what happens when an unknown command is encountered during the - * processing of a definition script. Works by finding a command in the - * operating definition namespace that the requested command is a unique - * 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; - size_t 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)); - } - result = Tcl_EvalObjv(interp, objc - 1, newObjv, 0); - Tcl_DecrRefCount(newObjv[0]); - TclStackFree(interp, newObjv); - return result; - } - - noMatch: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid command name \"%s\"", soughtStr)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", soughtStr, NULL); - return TCL_ERROR; -} - -/* - * ---------------------------------------------------------------------- - * - * FindCommand -- - * - * Specialized version of Tcl_FindCommand that handles command prefixes - * and disallows namespace magic. - * - * ---------------------------------------------------------------------- - */ - -static Tcl_Command -FindCommand( - Tcl_Interp *interp, - Tcl_Obj *stringObj, - Tcl_Namespace *const namespacePtr) -{ - size_t 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. - */ - - if (string[0] == '\0' || strstr(string, "::") != NULL) { - return NULL; - } - - /* - * Do the exact lookup first. - */ - - cmd = Tcl_FindCommand(interp, string, namespacePtr, TCL_NAMESPACE_ONLY); - if (cmd != NULL) { - return cmd; - } - - /* - * Bother, need to perform an approximate match. Iterate across the hash - * table of commands in the namespace. - */ - - FOREACH_HASH(nameStr, cmd2, &nsPtr->cmdTable) { - if (strncmp(string, nameStr, length) == 0) { - if (cmd != NULL) { - return NULL; - } - cmd = cmd2; - } - } - - /* - * Either we found one thing or we found nothing. Either way, return it. - */ - - return cmd; -} - -/* - * ---------------------------------------------------------------------- - * - * InitDefineContext -- - * - * Does the magic incantations necessary to push the special stack frame - * used when processing object definitions. It is up to the caller to - * dispose of the frame (with TclPopStackFrame) when finished. - * - * ---------------------------------------------------------------------- - */ - -static inline int -InitDefineContext( - Tcl_Interp *interp, - Tcl_Namespace *namespacePtr, - Object *oPtr, - int objc, - Tcl_Obj *const objv[]) -{ - CallFrame *framePtr, **framePtrPtr = &framePtr; - - if (namespacePtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "no definition namespace available", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } - - /* - * framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules. - */ - - (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, - namespacePtr, FRAME_IS_OO_DEFINE); - framePtr->clientData = oPtr; - framePtr->objc = objc; - framePtr->objv = objv; /* Reference counts do not need to be - * incremented here. */ - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOGetDefineCmdContext -- - * - * Extracts the magic token from the current stack frame, or returns NULL - * (and leaves an error message) otherwise. - * - * ---------------------------------------------------------------------- - */ - -Tcl_Object -TclOOGetDefineCmdContext( - Tcl_Interp *interp) -{ - Interp *iPtr = (Interp *) interp; - Tcl_Object object; - - if ((iPtr->varFramePtr == NULL) - || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE - && iPtr->varFramePtr->isProcCallFrame != PRIVATE_FRAME)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "this command may only be called from within the context of" - " an ::oo::define or ::oo::objdefine command", -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; - } - return object; -} - -/* - * ---------------------------------------------------------------------- - * - * GetClassInOuterContext, GetNamespaceInOuterContext -- - * - * Wrappers round Tcl_GetObjectFromObj and TclGetNamespaceFromObj to - * perform the lookup in the context that called oo::define (or - * equivalent). Note that this may have to go up multiple levels to get - * the level that we started doing definitions at. - * - * ---------------------------------------------------------------------- - */ - -static inline Class * -GetClassInOuterContext( - Tcl_Interp *interp, - Tcl_Obj *className, - const char *errMsg) -{ - Interp *iPtr = (Interp *) interp; - Object *oPtr; - CallFrame *savedFramePtr = iPtr->varFramePtr; - - while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE - || iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME) { - if (iPtr->varFramePtr->callerVarPtr == NULL) { - Tcl_Panic("getting outer context when already in global context"); - } - iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr; - } - oPtr = (Object *) Tcl_GetObjectFromObj(interp, className); - iPtr->varFramePtr = savedFramePtr; - if (oPtr == NULL) { - return NULL; - } - if (oPtr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", - TclGetString(className), NULL); - return NULL; - } - return oPtr->classPtr; -} - -static inline Tcl_Namespace * -GetNamespaceInOuterContext( - Tcl_Interp *interp, - Tcl_Obj *namespaceName) -{ - Interp *iPtr = (Interp *) interp; - Tcl_Namespace *nsPtr; - int result; - CallFrame *savedFramePtr = iPtr->varFramePtr; - - while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE - || iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME) { - if (iPtr->varFramePtr->callerVarPtr == NULL) { - Tcl_Panic("getting outer context when already in global context"); - } - iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr; - } - result = TclGetNamespaceFromObj(interp, namespaceName, &nsPtr); - iPtr->varFramePtr = savedFramePtr; - if (result != TCL_OK) { - return NULL; - } - return nsPtr; -} - -/* - * ---------------------------------------------------------------------- - * - * GenerateErrorInfo -- - * - * Factored out code to generate part of the error trace messages. - * - * ---------------------------------------------------------------------- - */ - -static inline void -GenerateErrorInfo( - Tcl_Interp *interp, /* Where to store the error info trace. */ - Object *oPtr, /* What object (or class) was being configured - * when the error occurred? */ - Tcl_Obj *savedNameObj, /* Name of object saved from before script was - * evaluated, which is needed if the object - * goes away part way through execution. OTOH, - * if the object isn't deleted then its - * 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. */ -{ - size_t length; - Tcl_Obj *realNameObj = Tcl_ObjectDeleted((Tcl_Object) oPtr) - ? savedNameObj : TclOOObjectName(interp, oPtr); - const char *objName = TclGetStringFromObj(realNameObj, &length); - unsigned 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 : (unsigned)length), objName, - (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); -} - -/* - * ---------------------------------------------------------------------- - * - * MagicDefinitionInvoke -- - * - * Part of the implementation of the "oo::define" and "oo::objdefine" - * commands that is used to implement the more-than-one-argument case, - * applying ensemble-like tricks with dispatch so that error messages are - * clearer. Doesn't handle the management of the stack frame. - * - * ---------------------------------------------------------------------- - */ - -static inline int -MagicDefinitionInvoke( - Tcl_Interp *interp, - Tcl_Namespace *nsPtr, - int cmdIndex, - int objc, - Tcl_Obj *const *objv) -{ - Tcl_Obj *objPtr, *obj2Ptr, **objs; - Tcl_Command cmd; - int isRoot, dummy, result, offset = cmdIndex + 1; - - /* - * More than one argument: fire them through the ensemble processing - * engine so that everything appears to be good and proper in error - * messages. Note that we cannot just concatenate and send through - * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we cannot go - * through Tcl_EvalObjv without the extra work to pre-find the command, as - * that finds command names in the wrong namespace at the moment. Ugly! - */ - - isRoot = TclInitRewriteEnsemble(interp, offset, 1, objv); - - /* - * Build the list of arguments using a Tcl_Obj as a workspace. See - * comments above for why these contortions are necessary. - */ - - TclNewObj(objPtr); - TclNewObj(obj2Ptr); - cmd = FindCommand(interp, objv[cmdIndex], nsPtr); - if (cmd == NULL) { - /* - * Punt this case! - */ - - Tcl_AppendObjToObj(obj2Ptr, objv[cmdIndex]); - } else { - Tcl_GetCommandFullName(interp, cmd, obj2Ptr); - } - Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr); - /* TODO: overflow? */ - Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc - offset, objv + offset); - Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs); - - result = Tcl_EvalObjv(interp, objc - cmdIndex, objs, TCL_EVAL_INVOKE); - if (isRoot) { - TclResetRewriteEnsemble(interp, 1); - } - Tcl_DecrRefCount(objPtr); - - return result; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineObjCmd -- - * - * Implementation of the "oo::define" command. Works by effectively doing - * the same as 'namespace eval', but with extra magic applied so that the - * object to be modified is known to the commands in the target - * namespace. Also does ensemble-like tricks with dispatch so that error - * messages are clearer. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - Tcl_Namespace *nsPtr; - Object *oPtr; - int result; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "className arg ?arg ...?"); - return TCL_ERROR; - } - - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (oPtr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s does not refer to a class", TclGetString(objv[1]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", - TclGetString(objv[1]), NULL); - return TCL_ERROR; - } - - /* - * Make the oo::define namespace the current namespace and evaluate the - * command(s). - */ - - nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 1); - if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) { - return TCL_ERROR; - } - - AddRef(oPtr); - if (objc == 3) { - Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr); - - Tcl_IncrRefCount(objNameObj); - result = TclEvalObjEx(interp, objv[2], 0, - ((Interp *)interp)->cmdFramePtr, 2); - if (result == TCL_ERROR) { - GenerateErrorInfo(interp, oPtr, objNameObj, "class"); - } - TclDecrRefCount(objNameObj); - } else { - result = MagicDefinitionInvoke(interp, nsPtr, 2, objc, objv); - } - TclOODecrRefCount(oPtr); - - /* - * Restore the previous "current" namespace. - */ - - TclPopStackFrame(interp); - return result; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOObjDefObjCmd -- - * - * Implementation of the "oo::objdefine" command. Works by effectively - * doing the same as 'namespace eval', but with extra magic applied so - * that the object to be modified is known to the commands in the target - * namespace. Also does ensemble-like tricks with dispatch so that error - * messages are clearer. - * - * ---------------------------------------------------------------------- - */ - -int -TclOOObjDefObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - Tcl_Namespace *nsPtr; - Object *oPtr; - int result; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "objectName arg ?arg ...?"); - return TCL_ERROR; - } - - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { - return TCL_ERROR; - } - - /* - * 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; - } - - AddRef(oPtr); - if (objc == 3) { - Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr); - - Tcl_IncrRefCount(objNameObj); - result = TclEvalObjEx(interp, objv[2], 0, - ((Interp *)interp)->cmdFramePtr, 2); - if (result == TCL_ERROR) { - GenerateErrorInfo(interp, oPtr, objNameObj, "object"); - } - TclDecrRefCount(objNameObj); - } else { - result = MagicDefinitionInvoke(interp, nsPtr, 2, objc, objv); - } - TclOODecrRefCount(oPtr); - - /* - * Restore the previous "current" namespace. - */ - - TclPopStackFrame(interp); - return result; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineSelfObjCmd -- - * - * Implementation of the "self" subcommand of the "oo::define" command. - * Works by effectively doing the same as 'namespace eval', but with - * extra magic applied so that the object to be modified is known to the - * commands in the target namespace. Also does ensemble-like tricks with - * 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); - - Tcl_IncrRefCount(objNameObj); - result = TclEvalObjEx(interp, objv[1], 0, - ((Interp *)interp)->cmdFramePtr, 1); - if (result == TCL_ERROR) { - GenerateErrorInfo(interp, oPtr, objNameObj, "class object"); - } - TclDecrRefCount(objNameObj); - } else { - result = MagicDefinitionInvoke(interp, nsPtr, 1, objc, objv); - } - TclOODecrRefCount(oPtr); - - /* - * Restore the previous "current" namespace. - */ - - TclPopStackFrame(interp); - return result; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineObjSelfObjCmd -- - * - * Implementation of the "self" subcommand of the "oo::objdefine" - * command. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineObjSelfObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr; - - if (objc != 1) { - Tcl_WrongNumArgs(interp, 1, objv, NULL); - return TCL_ERROR; - } - - oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { - return TCL_ERROR; - } - - Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr)); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefinePrivateObjCmd -- - * - * Implementation of the "private" subcommand of the "oo::define" - * and "oo::objdefine" commands. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefinePrivateObjCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - int isInstancePrivate = (clientData != NULL); - /* Just so that we can generate the correct - * error message depending on the context of - * usage of this function. */ - Interp *iPtr = (Interp *) interp; - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int saved; /* The saved flag. We restore it on exit so - * that [private private ...] doesn't make - * things go weird. */ - int result; - - if (oPtr == NULL) { - return TCL_ERROR; - } - if (objc == 1) { - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(IsPrivateDefine(interp))); - return TCL_OK; - } - - /* - * Change the frame type flag while evaluating the body. - */ - - saved = iPtr->varFramePtr->isProcCallFrame; - iPtr->varFramePtr->isProcCallFrame = PRIVATE_FRAME; - - /* - * Evaluate the body; standard pattern. - */ - - AddRef(oPtr); - if (objc == 2) { - Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr); - - Tcl_IncrRefCount(objNameObj); - result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1); - if (result == TCL_ERROR) { - GenerateErrorInfo(interp, oPtr, objNameObj, - isInstancePrivate ? "object" : "class"); - } - TclDecrRefCount(objNameObj); - } else { - result = MagicDefinitionInvoke(interp, TclGetCurrentNamespace(interp), - 1, objc, objv); - } - TclOODecrRefCount(oPtr); - - /* - * Restore the frame type flag to what it was previously. - */ - - iPtr->varFramePtr->isProcCallFrame = saved; - return result; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineClassObjCmd -- - * - * Implementation of the "class" subcommand of the "oo::objdefine" - * command. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineClassObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr; - Class *clsPtr; - Foundation *fPtr = TclOOGetFoundation(interp); - int wasClass, willBeClass; - - /* - * Parse the context to get the object to operate on. - */ - - oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (oPtr->flags & ROOT_OBJECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not modify the class of the root object class", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } - if (oPtr->flags & ROOT_CLASS) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not modify the class of the class of classes", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } - - /* - * Parse the argument to get the class to set the object's class to. - */ - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "className"); - return TCL_ERROR; - } - clsPtr = GetClassInOuterContext(interp, objv[1], - "the class of an object must be a class"); - if (clsPtr == NULL) { - return TCL_ERROR; - } - if (oPtr == clsPtr->thisPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not change classes into an instance of themselves", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } - - /* - * Set the object's class. - */ - - wasClass = (oPtr->classPtr != NULL); - willBeClass = (TclOOIsReachable(fPtr->classCls, clsPtr)); - - if (oPtr->selfCls != clsPtr) { - TclOORemoveFromInstances(oPtr, oPtr->selfCls); - TclOODecrRefCount(oPtr->selfCls->thisPtr); - oPtr->selfCls = clsPtr; - AddRef(oPtr->selfCls->thisPtr); - TclOOAddToInstances(oPtr, oPtr->selfCls); - - /* - * Create or delete the class guts if necessary. - */ - - if (wasClass && !willBeClass) { - /* - * This is the most global of all epochs. Bump it! No cache can be - * trusted! - */ - - TclOORemoveFromMixins(oPtr->classPtr, oPtr); - oPtr->fPtr->epoch++; - oPtr->flags |= DONT_DELETE; - TclOODeleteDescendants(interp, oPtr); - oPtr->flags &= ~DONT_DELETE; - TclOOReleaseClassContents(interp, oPtr); - Tcl_Free(oPtr->classPtr); - oPtr->classPtr = NULL; - } else if (!wasClass && willBeClass) { - TclOOAllocClass(interp, oPtr); - } - - if (oPtr->classPtr != NULL) { - BumpGlobalEpoch(interp, oPtr->classPtr); - } else { - oPtr->epoch++; - } - } - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineConstructorObjCmd -- - * - * Implementation of the "constructor" subcommand of the "oo::define" - * command. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineConstructorObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr; - Class *clsPtr; - Tcl_Method method; - size_t 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; - - (void)TclGetStringFromObj(objv[2], &bodyLength); - if (bodyLength > 0) { - /* - * Create the method structure. - */ - - method = (Tcl_Method) TclOONewProcMethod(interp, clsPtr, - PUBLIC_METHOD, NULL, objv[1], objv[2], NULL); - if (method == NULL) { - return TCL_ERROR; - } - } else { - /* - * Delete the constructor method record and set the field in the - * class record to NULL. - */ - - method = NULL; - } - - /* - * Place the method structure in the class record. Note that we might not - * immediately delete the constructor as this might be being done during - * execution of the constructor itself. - */ - - Tcl_ClassSetConstructor(interp, (Tcl_Class) clsPtr, method); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineDefnNsObjCmd -- - * - * Implementation of the "definitionnamespace" subcommand of the - * "oo::define" command. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineDefnNsObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - static const char *kindList[] = { - "-class", - "-instance", - NULL - }; - int kind = 0; - Object *oPtr; - Tcl_Namespace *nsPtr; - Tcl_Obj *nsNamePtr, **storagePtr; - - oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (!oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } - if (oPtr->flags & (ROOT_OBJECT | ROOT_CLASS)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not modify the definition namespace of the root classes", - -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } - - /* - * Parse the arguments and work out what the user wants to do. - */ - - if (objc != 2 && objc != 3) { - 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 (!TclGetString(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); - Tcl_IncrRefCount(nsNamePtr); - } - - /* - * Update the correct field of the class definition. - */ - - if (kind) { - storagePtr = &oPtr->classPtr->objDefinitionNs; - } else { - storagePtr = &oPtr->classPtr->clsDefinitionNs; - } - if (*storagePtr != NULL) { - Tcl_DecrRefCount(*storagePtr); - } - *storagePtr = nsNamePtr; - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineDeleteMethodObjCmd -- - * - * Implementation of the "deletemethod" subcommand of the "oo::define" - * and "oo::objdefine" commands. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineDeleteMethodObjCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - int isInstanceDeleteMethod = (clientData != NULL); - Object *oPtr; - int i; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); - return TCL_ERROR; - } - - oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (!isInstanceDeleteMethod && !oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } - - for (i = 1; i < objc; i++) { - /* - * Delete the method structure from the appropriate hash table. - */ - - if (RenameDeleteMethod(interp, oPtr, !isInstanceDeleteMethod, - objv[i], NULL) != TCL_OK) { - return TCL_ERROR; - } - } - - if (isInstanceDeleteMethod) { - oPtr->epoch++; - } else { - BumpGlobalEpoch(interp, oPtr->classPtr); - } - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineDestructorObjCmd -- - * - * Implementation of the "destructor" subcommand of the "oo::define" - * command. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineDestructorObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr; - Class *clsPtr; - Tcl_Method method; - size_t 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; - - (void)TclGetStringFromObj(objv[1], &bodyLength); - if (bodyLength > 0) { - /* - * Create the method structure. - */ - - method = (Tcl_Method) TclOONewProcMethod(interp, clsPtr, - PUBLIC_METHOD, NULL, NULL, objv[1], NULL); - if (method == NULL) { - return TCL_ERROR; - } - } else { - /* - * Delete the destructor method record and set the field in the class - * record to NULL. - */ - - method = NULL; - } - - /* - * Place the method structure in the class record. Note that we might not - * immediately delete the destructor as this might be being done during - * execution of the destructor itself. Also note that setting a - * destructor during a destructor is fairly dumb anyway. - */ - - Tcl_ClassSetDestructor(interp, (Tcl_Class) clsPtr, method); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineExportObjCmd -- - * - * Implementation of the "export" subcommand of the "oo::define" and - * "oo::objdefine" commands. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineExportObjCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - int isInstanceExport = (clientData != NULL); - Object *oPtr; - Method *mPtr; - Tcl_HashEntry *hPtr; - Class *clsPtr; - int i, isNew, changed = 0; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); - return TCL_ERROR; - } - - oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { - return TCL_ERROR; - } - clsPtr = oPtr->classPtr; - if (!isInstanceExport && !clsPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } - - for (i = 1; i < objc; i++) { - /* - * Exporting is done by adding the PUBLIC_METHOD flag to the method - * record. If there is no such method in this object or class (i.e. - * the method comes from something inherited from or that we're an - * instance of) then we put in a blank record with that flag; such - * records are skipped over by the call chain engine *except* for - * their flags member. - */ - - if (isInstanceExport) { - if (!oPtr->methodsPtr) { - oPtr->methodsPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); - Tcl_InitObjHashTable(oPtr->methodsPtr); - oPtr->flags &= ~USE_CLASS_CACHE; - } - hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *)objv[i], - &isNew); - } else { - hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char *)objv[i], - &isNew); - } - - if (isNew) { - mPtr = (Method *)Tcl_Alloc(sizeof(Method)); - memset(mPtr, 0, sizeof(Method)); - mPtr->refCount = 1; - mPtr->namePtr = objv[i]; - Tcl_IncrRefCount(objv[i]); - Tcl_SetHashValue(hPtr, mPtr); - } else { - mPtr = (Method *)Tcl_GetHashValue(hPtr); - } - if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) { - mPtr->flags |= PUBLIC_METHOD; - mPtr->flags &= ~TRUE_PRIVATE_METHOD; - changed = 1; - } - } - - /* - * Bump the right epoch if we actually changed anything. - */ - - if (changed) { - if (isInstanceExport) { - oPtr->epoch++; - } else { - BumpGlobalEpoch(interp, clsPtr); - } - } - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineForwardObjCmd -- - * - * Implementation of the "forward" subcommand of the "oo::define" and - * "oo::objdefine" commands. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineForwardObjCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - int isInstanceForward = (clientData != NULL); - Object *oPtr; - Method *mPtr; - int isPublic; - Tcl_Obj *prefixObj; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "name cmdName ?arg ...?"); - return TCL_ERROR; - } - - oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (!isInstanceForward && !oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } - isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN) - ? PUBLIC_METHOD : 0; - if (IsPrivateDefine(interp)) { - isPublic = TRUE_PRIVATE_METHOD; - } - - /* - * Create the method structure. - */ - - prefixObj = Tcl_NewListObj(objc - 2, objv + 2); - if (isInstanceForward) { - mPtr = TclOONewForwardInstanceMethod(interp, oPtr, isPublic, objv[1], - prefixObj); - } else { - mPtr = TclOONewForwardMethod(interp, oPtr->classPtr, isPublic, - objv[1], prefixObj); - } - if (mPtr == NULL) { - Tcl_DecrRefCount(prefixObj); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineMethodObjCmd -- - * - * Implementation of the "method" subcommand of the "oo::define" and - * "oo::objdefine" commands. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineMethodObjCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - /* - * Table of export modes for methods and their corresponding enum. - */ - - static const char *const exportModes[] = { - "-export", - "-private", - "-unexport", - NULL - }; - enum ExportMode { - MODE_EXPORT, - MODE_PRIVATE, - MODE_UNEXPORT - } exportMode; - - int isInstanceMethod = (clientData != NULL); - Object *oPtr; - int isPublic = 0; - - if (objc < 4 || objc > 5) { - Tcl_WrongNumArgs(interp, 1, objv, "name ?option? args body"); - return TCL_ERROR; - } - - oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (!isInstanceMethod && !oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } - if (objc == 5) { - if (Tcl_GetIndexFromObj(interp, objv[2], exportModes, "export flag", - 0, (int *) &exportMode) != TCL_OK) { - return TCL_ERROR; - } - switch (exportMode) { - case MODE_EXPORT: - isPublic = PUBLIC_METHOD; - break; - case MODE_PRIVATE: - isPublic = TRUE_PRIVATE_METHOD; - break; - case MODE_UNEXPORT: - isPublic = 0; - break; - } - } else { - if (IsPrivateDefine(interp)) { - isPublic = TRUE_PRIVATE_METHOD; - } else { - isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN) - ? PUBLIC_METHOD : 0; - } - } - - /* - * Create the method by using the right back-end API. - */ - - if (isInstanceMethod) { - if (TclOONewProcInstanceMethod(interp, oPtr, isPublic, objv[1], - objv[objc - 2], objv[objc - 1], NULL) == NULL) { - return TCL_ERROR; - } - } else { - if (TclOONewProcMethod(interp, oPtr->classPtr, isPublic, objv[1], - objv[objc - 2], objv[objc - 1], NULL) == NULL) { - return TCL_ERROR; - } - } - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineRenameMethodObjCmd -- - * - * Implementation of the "renamemethod" subcommand of the "oo::define" - * and "oo::objdefine" commands. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineRenameMethodObjCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - int isInstanceRenameMethod = (clientData != NULL); - Object *oPtr; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "oldName newName"); - return TCL_ERROR; - } - - oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (!isInstanceRenameMethod && !oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } - - /* - * Delete the method entry from the appropriate hash table, and transfer - * the thing it points to to its new entry. To do this, we first need to - * get the entries from the appropriate hash tables (this can generate a - * range of errors...) - */ - - if (RenameDeleteMethod(interp, oPtr, !isInstanceRenameMethod, - objv[1], objv[2]) != TCL_OK) { - return TCL_ERROR; - } - - if (isInstanceRenameMethod) { - oPtr->epoch++; - } else { - BumpGlobalEpoch(interp, oPtr->classPtr); - } - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineUnexportObjCmd -- - * - * Implementation of the "unexport" subcommand of the "oo::define" and - * "oo::objdefine" commands. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineUnexportObjCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - int isInstanceUnexport = (clientData != NULL); - Object *oPtr; - Method *mPtr; - Tcl_HashEntry *hPtr; - Class *clsPtr; - int i, isNew, changed = 0; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); - return TCL_ERROR; - } - - oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { - return TCL_ERROR; - } - clsPtr = oPtr->classPtr; - if (!isInstanceUnexport && !clsPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } - - for (i = 1; i < objc; i++) { - /* - * Unexporting is done by removing the PUBLIC_METHOD flag from the - * method record. If there is no such method in this object or class - * (i.e. the method comes from something inherited from or that we're - * an instance of) then we put in a blank record without that flag; - * such records are skipped over by the call chain engine *except* for - * their flags member. - */ - - if (isInstanceUnexport) { - if (!oPtr->methodsPtr) { - oPtr->methodsPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); - Tcl_InitObjHashTable(oPtr->methodsPtr); - oPtr->flags &= ~USE_CLASS_CACHE; - } - hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *)objv[i], - &isNew); - } else { - hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char *)objv[i], - &isNew); - } - - if (isNew) { - mPtr = (Method *)Tcl_Alloc(sizeof(Method)); - memset(mPtr, 0, sizeof(Method)); - mPtr->refCount = 1; - mPtr->namePtr = objv[i]; - Tcl_IncrRefCount(objv[i]); - Tcl_SetHashValue(hPtr, mPtr); - } else { - mPtr = (Method *)Tcl_GetHashValue(hPtr); - } - if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { - mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); - changed = 1; - } - } - - /* - * Bump the right epoch if we actually changed anything. - */ - - if (changed) { - if (isInstanceUnexport) { - oPtr->epoch++; - } else { - BumpGlobalEpoch(interp, clsPtr); - } - } - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * Tcl_ClassSetConstructor, Tcl_ClassSetDestructor -- - * - * How to install a constructor or destructor into a class; API to call - * from C. - * - * ---------------------------------------------------------------------- - */ - -void -Tcl_ClassSetConstructor( - Tcl_Interp *interp, - Tcl_Class clazz, - Tcl_Method method) -{ - Class *clsPtr = (Class *) clazz; - - if (method != (Tcl_Method) clsPtr->constructorPtr) { - TclOODelMethodRef(clsPtr->constructorPtr); - clsPtr->constructorPtr = (Method *) method; - - /* - * Remember to invalidate the cached constructor chain for this class. - * [Bug 2531577] - */ - - if (clsPtr->constructorChainPtr) { - TclOODeleteChain(clsPtr->constructorChainPtr); - clsPtr->constructorChainPtr = NULL; - } - BumpGlobalEpoch(interp, clsPtr); - } -} - -void -Tcl_ClassSetDestructor( - Tcl_Interp *interp, - Tcl_Class clazz, - Tcl_Method method) -{ - Class *clsPtr = (Class *) clazz; - - if (method != (Tcl_Method) clsPtr->destructorPtr) { - TclOODelMethodRef(clsPtr->destructorPtr); - clsPtr->destructorPtr = (Method *) method; - if (clsPtr->destructorChainPtr) { - TclOODeleteChain(clsPtr->destructorChainPtr); - clsPtr->destructorChainPtr = NULL; - } - BumpGlobalEpoch(interp, clsPtr); - } -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineSlots -- - * - * Create the "::oo::Slot" class and its standard instances. Class - * definition is empty at the stage (added by scripting). - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineSlots( - Foundation *fPtr) -{ - const struct DeclaredSlot *slotInfoPtr; - Tcl_Obj *getName = Tcl_NewStringObj("Get", -1); - Tcl_Obj *setName = Tcl_NewStringObj("Set", -1); - Tcl_Obj *resolveName = Tcl_NewStringObj("Resolve", -1); - Class *slotCls; - - slotCls = ((Object *) Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class) - fPtr->classCls, "::oo::Slot", NULL, -1, NULL, 0))->classPtr; - if (slotCls == NULL) { - return TCL_ERROR; - } - Tcl_IncrRefCount(getName); - Tcl_IncrRefCount(setName); - Tcl_IncrRefCount(resolveName); - for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) { - Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp, - (Tcl_Class) slotCls, slotInfoPtr->name, NULL, -1, NULL, 0); - - if (slotObject == NULL) { - continue; - } - Tcl_NewInstanceMethod(fPtr->interp, slotObject, getName, 0, - &slotInfoPtr->getterType, NULL); - Tcl_NewInstanceMethod(fPtr->interp, slotObject, setName, 0, - &slotInfoPtr->setterType, NULL); - if (slotInfoPtr->resolverType.callProc) { - Tcl_NewInstanceMethod(fPtr->interp, slotObject, resolveName, 0, - &slotInfoPtr->resolverType, NULL); - } - } - Tcl_DecrRefCount(getName); - Tcl_DecrRefCount(setName); - Tcl_DecrRefCount(resolveName); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * ClassFilterGet, ClassFilterSet -- - * - * Implementation of the "filter" slot accessors of the "oo::define" - * 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; - int i; - - if (Tcl_ObjectContextSkippedArgs(context) != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - NULL); - return TCL_ERROR; - } - if (oPtr == NULL) { - return TCL_ERROR; - } else if (!oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } - - TclNewObj(resultObj); - FOREACH(filterObj, oPtr->classPtr->filters) { - Tcl_ListObjAppendElement(NULL, resultObj, filterObj); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -static int -ClassFilterSet( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int filterc; - Tcl_Obj **filterv; - - if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "filterList"); - return TCL_ERROR; - } - objv += Tcl_ObjectContextSkippedArgs(context); - - if (oPtr == NULL) { - return TCL_ERROR; - } else if (!oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } else if (Tcl_ListObjGetElements(interp, objv[0], &filterc, - &filterv) != TCL_OK) { - return TCL_ERROR; - } - - TclOOClassSetFilters(interp, oPtr->classPtr, filterc, filterv); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * ClassMixinGet, ClassMixinSet -- - * - * Implementation of the "mixin" slot accessors of the "oo::define" - * 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; - Class *mixinPtr; - int i; - - if (Tcl_ObjectContextSkippedArgs(context) != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - NULL); - return TCL_ERROR; - } - if (oPtr == NULL) { - return TCL_ERROR; - } else if (!oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } - - TclNewObj(resultObj); - FOREACH(mixinPtr, oPtr->classPtr->mixins) { - Tcl_ListObjAppendElement(NULL, resultObj, - TclOOObjectName(interp, mixinPtr->thisPtr)); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; - -} - -static int -ClassMixinSet( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int mixinc, i; - Tcl_Obj **mixinv; - Class **mixins; - - if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "mixinList"); - return TCL_ERROR; - } - objv += Tcl_ObjectContextSkippedArgs(context); - - if (oPtr == NULL) { - return TCL_ERROR; - } else if (!oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } 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; - } - if (TclOOIsReachable(oPtr->classPtr, mixins[i])) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not mix a class into itself", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL); - goto freeAndError; - } - } - - TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins); - TclStackFree(interp, mixins); - return TCL_OK; - - freeAndError: - TclStackFree(interp, mixins); - return TCL_ERROR; -} - -/* - * ---------------------------------------------------------------------- - * - * ClassSuperGet, ClassSuperSet -- - * - * Implementation of the "superclass" slot accessors of the "oo::define" - * 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; - Class *superPtr; - int i; - - if (Tcl_ObjectContextSkippedArgs(context) != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - NULL); - return TCL_ERROR; - } - if (oPtr == NULL) { - return TCL_ERROR; - } else if (!oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } - - TclNewObj(resultObj); - FOREACH(superPtr, oPtr->classPtr->superclasses) { - Tcl_ListObjAppendElement(NULL, resultObj, - TclOOObjectName(interp, superPtr->thisPtr)); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -static int -ClassSuperSet( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int superc, i, j; - Tcl_Obj **superv; - Class **superclasses, *superPtr; - - if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "superclassList"); - return TCL_ERROR; - } - objv += Tcl_ObjectContextSkippedArgs(context); - - if (oPtr == NULL) { - return TCL_ERROR; - } else if (!oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } else if (oPtr == oPtr->fPtr->objectCls->thisPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not modify the superclass of the root object", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } else if (Tcl_ListObjGetElements(interp, objv[0], &superc, - &superv) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Allocate some working space. - */ - - superclasses = (Class **) Tcl_Alloc(sizeof(Class *) * superc); - - /* - * Parse the arguments to get the class to use as superclasses. - * - * Note that zero classes is special, as it is equivalent to just the - * class of objects. [Bug 9d61624b3d] - */ - - if (superc == 0) { - superclasses = (Class **)Tcl_Realloc(superclasses, sizeof(Class *)); - if (TclOOIsReachable(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); - } - Tcl_Free(superclasses); - return TCL_ERROR; - } - - /* - * Corresponding TclOODecrRefCount() is near the end of this - * function. - */ - - AddRef(superclasses[i]->thisPtr); - } - } - - /* - * Install the list of superclasses into the class. Note that this also - * involves splicing the class out of the superclasses' subclass list that - * it used to be a member of and splicing it into the new superclasses' - * subclass list. - */ - - if (oPtr->classPtr->superclasses.num != 0) { - FOREACH(superPtr, oPtr->classPtr->superclasses) { - TclOORemoveFromSubclasses(oPtr->classPtr, superPtr); - TclOODecrRefCount(superPtr->thisPtr); - } - Tcl_Free(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); - - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * ClassVarsGet, ClassVarsSet -- - * - * Implementation of the "variable" slot accessors of the "oo::define" - * 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; - int i; - - if (Tcl_ObjectContextSkippedArgs(context) != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - NULL); - return TCL_ERROR; - } - if (oPtr == NULL) { - return TCL_ERROR; - } else if (!oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } - - TclNewObj(resultObj); - if (IsPrivateDefine(interp)) { - PrivateVariableMapping *privatePtr; - - FOREACH_STRUCT(privatePtr, oPtr->classPtr->privateVariables) { - Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj); - } - } else { - Tcl_Obj *variableObj; - - FOREACH(variableObj, oPtr->classPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); - } - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -static int -ClassVarsSet( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int varc; - Tcl_Obj **varv; - int i; - - if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "filterList"); - return TCL_ERROR; - } - objv += Tcl_ObjectContextSkippedArgs(context); - - if (oPtr == NULL) { - return TCL_ERROR; - } else if (!oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } else if (Tcl_ListObjGetElements(interp, objv[0], &varc, - &varv) != TCL_OK) { - return TCL_ERROR; - } - - for (i = 0; i < varc; i++) { - const char *varName = TclGetString(varv[i]); - - if (strstr(varName, "::") != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid declared variable name \"%s\": must not %s", - varName, "contain namespace separators")); - Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL); - return TCL_ERROR; - } - if (Tcl_StringMatch(varName, "*(*)")) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid declared variable name \"%s\": must not %s", - varName, "refer to an array element")); - Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL); - return TCL_ERROR; - } - } - - if (IsPrivateDefine(interp)) { - InstallPrivateVariableMapping(&oPtr->classPtr->privateVariables, - varc, varv, oPtr->classPtr->thisPtr->creationEpoch); - } else { - InstallStandardVariableMapping(&oPtr->classPtr->variables, varc, varv); - } - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * ObjectFilterGet, ObjectFilterSet -- - * - * Implementation of the "filter" slot accessors of the "oo::objdefine" - * command. - * - * ---------------------------------------------------------------------- - */ - -static int -ObjFilterGet( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj, *filterObj; - int i; - - if (Tcl_ObjectContextSkippedArgs(context) != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - NULL); - return TCL_ERROR; - } else if (oPtr == NULL) { - return TCL_ERROR; - } - - TclNewObj(resultObj); - FOREACH(filterObj, oPtr->filters) { - Tcl_ListObjAppendElement(NULL, resultObj, filterObj); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -static int -ObjFilterSet( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int filterc; - Tcl_Obj **filterv; - - if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "filterList"); - return TCL_ERROR; - } else if (oPtr == NULL) { - return TCL_ERROR; - } - objv += Tcl_ObjectContextSkippedArgs(context); - if (Tcl_ListObjGetElements(interp, objv[0], &filterc, - &filterv) != TCL_OK) { - return TCL_ERROR; - } - - TclOOObjectSetFilters(oPtr, filterc, filterv); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * ObjectMixinGet, ObjectMixinSet -- - * - * Implementation of the "mixin" slot accessors of the "oo::objdefine" - * command. - * - * ---------------------------------------------------------------------- - */ - -static int -ObjMixinGet( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj; - Class *mixinPtr; - int i; - - if (Tcl_ObjectContextSkippedArgs(context) != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - NULL); - return TCL_ERROR; - } else if (oPtr == NULL) { - return TCL_ERROR; - } - - TclNewObj(resultObj); - FOREACH(mixinPtr, oPtr->mixins) { - if (mixinPtr) { - Tcl_ListObjAppendElement(NULL, resultObj, - TclOOObjectName(interp, mixinPtr->thisPtr)); - } - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -static int -ObjMixinSet( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int mixinc; - Tcl_Obj **mixinv; - Class **mixins; - int i; - - if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "mixinList"); - return TCL_ERROR; - } else if (oPtr == NULL) { - return TCL_ERROR; - } - objv += Tcl_ObjectContextSkippedArgs(context); - if (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; - } - } - - TclOOObjectSetMixins(oPtr, mixinc, mixins); - TclStackFree(interp, mixins); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * ObjectVarsGet, ObjectVarsSet -- - * - * Implementation of the "variable" slot accessors of the "oo::objdefine" - * command. - * - * ---------------------------------------------------------------------- - */ - -static int -ObjVarsGet( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj; - int i; - - if (Tcl_ObjectContextSkippedArgs(context) != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - NULL); - return TCL_ERROR; - } else if (oPtr == NULL) { - return TCL_ERROR; - } - - TclNewObj(resultObj); - if (IsPrivateDefine(interp)) { - PrivateVariableMapping *privatePtr; - - FOREACH_STRUCT(privatePtr, oPtr->privateVariables) { - Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj); - } - } else { - Tcl_Obj *variableObj; - - FOREACH(variableObj, oPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); - } - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -static int -ObjVarsSet( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int varc, i; - Tcl_Obj **varv; - - if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "variableList"); - return TCL_ERROR; - } else if (oPtr == NULL) { - return TCL_ERROR; - } - objv += Tcl_ObjectContextSkippedArgs(context); - if (Tcl_ListObjGetElements(interp, objv[0], &varc, - &varv) != TCL_OK) { - return TCL_ERROR; - } - - for (i = 0; i < varc; i++) { - const char *varName = TclGetString(varv[i]); - - if (strstr(varName, "::") != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid declared variable name \"%s\": must not %s", - varName, "contain namespace separators")); - Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL); - return TCL_ERROR; - } - if (Tcl_StringMatch(varName, "*(*)")) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid declared variable name \"%s\": must not %s", - varName, "refer to an array element")); - Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL); - return TCL_ERROR; - } - } - - if (IsPrivateDefine(interp)) { - InstallPrivateVariableMapping(&oPtr->privateVariables, varc, varv, - oPtr->creationEpoch); - } else { - InstallStandardVariableMapping(&oPtr->variables, varc, varv); - } - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * ResolveClass -- - * - * Implementation of the "Resolve" support method for some slots (those - * that are slots around a list of classes). This resolves possible class - * 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); - Class *clsPtr; - - /* - * Check if were called wrongly. The definition context isn't used... - * except that GetClassInOuterContext() assumes that it is there. - */ - - if (oPtr == NULL) { - return TCL_ERROR; - } else if (objc != idx + 1) { - Tcl_WrongNumArgs(interp, idx, objv, "slotElement"); - return TCL_ERROR; - } - - /* - * Resolve the class if possible. If not, remove any resolution error and - * return what we've got anyway as the failure might not be fatal overall. - */ - - clsPtr = GetClassInOuterContext(interp, objv[idx], - "USER SHOULD NOT SEE THIS MESSAGE"); - if (clsPtr == NULL) { - Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, objv[idx]); - } else { - Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr)); - } - - return TCL_OK; -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ DELETED generic/tclOOInfo.c Index: generic/tclOOInfo.c ================================================================== --- generic/tclOOInfo.c +++ /dev/null @@ -1,1722 +0,0 @@ -/* - * tclOODefineCmds.c -- - * - * This file contains the implementation of the ::oo-related [info] - * subcommands. - * - * Copyright (c) 2006-2011 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. - */ - -#ifdef HAVE_CONFIG_H -#include "config.h" -#endif -#include "tclInt.h" -#include "tclOOInt.h" - -static inline Class * GetClassFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); -static Tcl_ObjCmdProc InfoObjectCallCmd; -static Tcl_ObjCmdProc InfoObjectClassCmd; -static Tcl_ObjCmdProc InfoObjectDefnCmd; -static Tcl_ObjCmdProc InfoObjectFiltersCmd; -static Tcl_ObjCmdProc InfoObjectForwardCmd; -static Tcl_ObjCmdProc InfoObjectIdCmd; -static Tcl_ObjCmdProc InfoObjectIsACmd; -static Tcl_ObjCmdProc InfoObjectMethodsCmd; -static Tcl_ObjCmdProc InfoObjectMethodTypeCmd; -static Tcl_ObjCmdProc InfoObjectMixinsCmd; -static Tcl_ObjCmdProc InfoObjectNsCmd; -static Tcl_ObjCmdProc InfoObjectVarsCmd; -static Tcl_ObjCmdProc InfoObjectVariablesCmd; -static Tcl_ObjCmdProc InfoClassCallCmd; -static Tcl_ObjCmdProc InfoClassConstrCmd; -static Tcl_ObjCmdProc InfoClassDefnCmd; -static Tcl_ObjCmdProc InfoClassDefnNsCmd; -static Tcl_ObjCmdProc InfoClassDestrCmd; -static Tcl_ObjCmdProc InfoClassFiltersCmd; -static Tcl_ObjCmdProc InfoClassForwardCmd; -static Tcl_ObjCmdProc InfoClassInstancesCmd; -static Tcl_ObjCmdProc InfoClassMethodsCmd; -static Tcl_ObjCmdProc InfoClassMethodTypeCmd; -static Tcl_ObjCmdProc InfoClassMixinsCmd; -static Tcl_ObjCmdProc InfoClassSubsCmd; -static Tcl_ObjCmdProc InfoClassSupersCmd; -static Tcl_ObjCmdProc InfoClassVariablesCmd; - -/* - * List of commands that are used to implement the [info object] subcommands. - */ - -static const EnsembleImplMap infoObjectCmds[] = { - {"call", InfoObjectCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"class", InfoObjectClassCmd, TclCompileInfoObjectClassCmd, NULL, NULL, 0}, - {"creationid", InfoObjectIdCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"definition", InfoObjectDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"filters", InfoObjectFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"forward", InfoObjectForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"isa", InfoObjectIsACmd, TclCompileInfoObjectIsACmd, NULL, NULL, 0}, - {"methods", InfoObjectMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, - {"methodtype", InfoObjectMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"mixins", InfoObjectMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"namespace", InfoObjectNsCmd, TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0}, - {"variables", InfoObjectVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"vars", InfoObjectVarsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {NULL, NULL, NULL, NULL, NULL, 0} -}; - -/* - * List of commands that are used to implement the [info class] subcommands. - */ - -static const EnsembleImplMap infoClassCmds[] = { - {"call", InfoClassCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"constructor", InfoClassConstrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"definition", InfoClassDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"definitionnamespace", InfoClassDefnNsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"destructor", InfoClassDestrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"filters", InfoClassFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"forward", InfoClassForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"instances", InfoClassInstancesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"methods", InfoClassMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, - {"methodtype", InfoClassMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"mixins", InfoClassMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"subclasses", InfoClassSubsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"superclasses", InfoClassSupersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"variables", InfoClassVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {NULL, NULL, NULL, NULL, NULL, 0} -}; - -/* - * ---------------------------------------------------------------------- - * - * TclOOInitInfo -- - * - * Adjusts the Tcl core [info] command to contain subcommands ("object" - * and "class") for introspection of objects and classes. - * - * ---------------------------------------------------------------------- - */ - -void -TclOOInitInfo( - Tcl_Interp *interp) -{ - Tcl_Command infoCmd; - Tcl_Obj *mapDict; - - /* - * Build the ensembles used to implement [info object] and [info class]. - */ - - TclMakeEnsemble(interp, "::oo::InfoObject", infoObjectCmds); - TclMakeEnsemble(interp, "::oo::InfoClass", infoClassCmds); - - /* - * Install into the [info] ensemble. - */ - - infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY); - if (infoCmd) { - Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict); - Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("object", -1), - Tcl_NewStringObj("::oo::InfoObject", -1)); - Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("class", -1), - Tcl_NewStringObj("::oo::InfoClass", -1)); - Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict); - } -} - -/* - * ---------------------------------------------------------------------- - * - * GetClassFromObj -- - * - * How to correctly get a class from a Tcl_Obj. Just a wrapper round - * Tcl_GetObjectFromObj, but this is an idiom that was used heavily. - * - * ---------------------------------------------------------------------- - */ - -static inline Class * -GetClassFromObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr) -{ - Object *oPtr = (Object *) Tcl_GetObjectFromObj(interp, objPtr); - - if (oPtr == NULL) { - return NULL; - } - if (oPtr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" is not a class", TclGetString(objPtr))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", - TclGetString(objPtr), NULL); - return NULL; - } - return oPtr->classPtr; -} - -/* - * ---------------------------------------------------------------------- - * - * InfoObjectClassCmd -- - * - * Implements [info object class $objName ?$className?] - * - * ---------------------------------------------------------------------- - */ - -static int -InfoObjectClassCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Object *oPtr; - - if (objc != 2 && objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "objName ?className?"); - return TCL_ERROR; - } - - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { - return TCL_ERROR; - } - - if (objc == 2) { - Tcl_SetObjResult(interp, - TclOOObjectName(interp, oPtr->selfCls->thisPtr)); - return TCL_OK; - } else { - Class *mixinPtr, *o2clsPtr; - int i; - - o2clsPtr = GetClassFromObj(interp, objv[2]); - if (o2clsPtr == NULL) { - return TCL_ERROR; - } - - FOREACH(mixinPtr, oPtr->mixins) { - if (!mixinPtr) { - continue; - } - if (TclOOIsReachable(o2clsPtr, mixinPtr)) { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1)); - return TCL_OK; - } - } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj( - TclOOIsReachable(o2clsPtr, oPtr->selfCls))); - return TCL_OK; - } -} - -/* - * ---------------------------------------------------------------------- - * - * InfoObjectDefnCmd -- - * - * Implements [info object definition $objName $methodName] - * - * ---------------------------------------------------------------------- - */ - -static int -InfoObjectDefnCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Object *oPtr; - Tcl_HashEntry *hPtr; - Proc *procPtr; - CompiledLocal *localPtr; - Tcl_Obj *resultObjs[2]; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "objName methodName"); - return TCL_ERROR; - } - - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { - return TCL_ERROR; - } - - if (!oPtr->methodsPtr) { - goto unknownMethod; - } - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]); - if (hPtr == NULL) { - unknownMethod: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown method \"%s\"", TclGetString(objv[2]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[2]), NULL); - return TCL_ERROR; - } - procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr)); - if (procPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "definition not available for this kind of method", -1)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[2]), NULL); - return TCL_ERROR; - } - - TclNewObj(resultObjs[0]); - for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL; - localPtr=localPtr->nextPtr) { - if (TclIsVarArgument(localPtr)) { - Tcl_Obj *argObj; - - TclNewObj(argObj); - Tcl_ListObjAppendElement(NULL, argObj, - Tcl_NewStringObj(localPtr->name, -1)); - if (localPtr->defValuePtr != NULL) { - Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); - } - Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj); - } - } - resultObjs[1] = TclOOGetMethodBody((Method *)Tcl_GetHashValue(hPtr)); - Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs)); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * InfoObjectFiltersCmd -- - * - * Implements [info object filters $objName] - * - * ---------------------------------------------------------------------- - */ - -static int -InfoObjectFiltersCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - int i; - Tcl_Obj *filterObj, *resultObj; - Object *oPtr; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "objName"); - return TCL_ERROR; - } - - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { - return TCL_ERROR; - } - TclNewObj(resultObj); - - FOREACH(filterObj, oPtr->filters) { - Tcl_ListObjAppendElement(NULL, resultObj, filterObj); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * InfoObjectForwardCmd -- - * - * Implements [info object forward $objName $methodName] - * - * ---------------------------------------------------------------------- - */ - -static int -InfoObjectForwardCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Object *oPtr; - Tcl_HashEntry *hPtr; - Tcl_Obj *prefixObj; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "objName methodName"); - return TCL_ERROR; - } - - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { - return TCL_ERROR; - } - - if (!oPtr->methodsPtr) { - goto unknownMethod; - } - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]); - if (hPtr == NULL) { - 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; - } - - Tcl_SetObjResult(interp, prefixObj); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * InfoObjectIsACmd -- - * - * Implements [info object isa $category $objName ...] - * - * ---------------------------------------------------------------------- - */ - -static int -InfoObjectIsACmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - static const char *const categories[] = { - "class", "metaclass", "mixin", "object", "typeof", NULL - }; - enum IsACats { - IsClass, IsMetaclass, IsMixin, IsObject, IsType - }; - Object *oPtr, *o2Ptr; - int idx, i, result = 0; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "category objName ?arg ...?"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[1], categories, "category", 0, - &idx) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Now we know what test we are doing, we can check we've got the right - * number of arguments. - */ - - switch ((enum IsACats) idx) { - case IsObject: - case IsClass: - case IsMetaclass: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "objName"); - return TCL_ERROR; - } - break; - case IsMixin: - case IsType: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "objName className"); - return TCL_ERROR; - } - break; - } - - /* - * Perform the check. Note that we can guarantee that we will not fail - * from here on; "failures" result in a false-TCL_OK result. - */ - - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (oPtr == NULL) { - goto failPrecondition; - } - - switch ((enum IsACats) idx) { - case IsObject: - result = 1; - break; - case IsClass: - result = (oPtr->classPtr != NULL); - break; - case IsMetaclass: - if (oPtr->classPtr != NULL) { - result = TclOOIsReachable(TclOOGetFoundation(interp)->classCls, - oPtr->classPtr); - } - break; - case IsMixin: - o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]); - if (o2Ptr == NULL) { - goto failPrecondition; - } - if (o2Ptr->classPtr != NULL) { - Class *mixinPtr; - - FOREACH(mixinPtr, oPtr->mixins) { - if (!mixinPtr) { - continue; - } - if (TclOOIsReachable(o2Ptr->classPtr, mixinPtr)) { - result = 1; - break; - } - } - } - break; - case IsType: - o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]); - if (o2Ptr == NULL) { - goto failPrecondition; - } - if (o2Ptr->classPtr != NULL) { - result = TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls); - } - break; - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); - return TCL_OK; - - failPrecondition: - Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * InfoObjectMethodsCmd -- - * - * Implements [info object methods $objName ?$option ...?] - * - * ---------------------------------------------------------------------- - */ - -static int -InfoObjectMethodsCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Object *oPtr; - int flag = PUBLIC_METHOD, recurse = 0, scope = -1; - FOREACH_HASH_DECLS; - Tcl_Obj *namePtr, *resultObj; - Method *mPtr; - static const char *const options[] = { - "-all", "-localprivate", "-private", "-scope", NULL - }; - enum Options { - OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE - }; - static const char *const scopes[] = { - "private", "public", "unexported" - }; - enum Scopes { - SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED, - SCOPE_LOCALPRIVATE - }; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "objName ?-option value ...?"); - return TCL_ERROR; - } - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (objc != 2) { - int i, idx; - - for (i=2 ; i= objc) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "missing option for -scope")); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", - NULL); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0, - &scope) != TCL_OK) { - return TCL_ERROR; - } - break; - } - } - } - if (scope != -1) { - recurse = 0; - switch (scope) { - case SCOPE_PRIVATE: - flag = TRUE_PRIVATE_METHOD; - break; - case SCOPE_PUBLIC: - flag = PUBLIC_METHOD; - break; - case SCOPE_LOCALPRIVATE: - flag = PRIVATE_METHOD; - break; - case SCOPE_UNEXPORTED: - flag = 0; - break; - } - } - - TclNewObj(resultObj); - if (recurse) { - const char **names; - int i, numNames = TclOOGetSortedMethodList(oPtr, NULL, NULL, flag, - &names); - - for (i=0 ; i 0) { - Tcl_Free((void *)names); - } - } else if (oPtr->methodsPtr) { - FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) { - if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) { - Tcl_ListObjAppendElement(NULL, resultObj, namePtr); - } - } - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * InfoObjectMethodTypeCmd -- - * - * Implements [info object methodtype $objName $methodName] - * - * ---------------------------------------------------------------------- - */ - -static int -InfoObjectMethodTypeCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Object *oPtr; - Tcl_HashEntry *hPtr; - Method *mPtr; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "objName methodName"); - return TCL_ERROR; - } - - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { - return TCL_ERROR; - } - - if (!oPtr->methodsPtr) { - goto unknownMethod; - } - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]); - if (hPtr == NULL) { - 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; - } - - Tcl_SetObjResult(interp, Tcl_NewStringObj(mPtr->typePtr->name, -1)); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * InfoObjectMixinsCmd -- - * - * Implements [info object mixins $objName] - * - * ---------------------------------------------------------------------- - */ - -static int -InfoObjectMixinsCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Class *mixinPtr; - Object *oPtr; - Tcl_Obj *resultObj; - int i; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "objName"); - return TCL_ERROR; - } - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { - return TCL_ERROR; - } - - TclNewObj(resultObj); - FOREACH(mixinPtr, oPtr->mixins) { - if (!mixinPtr) { - continue; - } - Tcl_ListObjAppendElement(NULL, resultObj, - TclOOObjectName(interp, mixinPtr->thisPtr)); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * InfoObjectIdCmd -- - * - * Implements [info object creationid $objName] - * - * ---------------------------------------------------------------------- - */ - -static int -InfoObjectIdCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Object *oPtr; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "objName"); - return TCL_ERROR; - } - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { - return TCL_ERROR; - } - - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(oPtr->creationEpoch)); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * InfoObjectNsCmd -- - * - * Implements [info object namespace $objName] - * - * ---------------------------------------------------------------------- - */ - -static int -InfoObjectNsCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Object *oPtr; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "objName"); - return TCL_ERROR; - } - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { - return TCL_ERROR; - } - - Tcl_SetObjResult(interp, - Tcl_NewStringObj(oPtr->namespacePtr->fullName, -1)); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * InfoObjectVariablesCmd -- - * - * Implements [info object variables $objName ?-private?] - * - * ---------------------------------------------------------------------- - */ - -static int -InfoObjectVariablesCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Object *oPtr; - Tcl_Obj *resultObj; - int i, isPrivate = 0; - - if (objc != 2 && objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "objName ?-private?"); - return TCL_ERROR; - } - if (objc == 3) { - if (strcmp("-private", TclGetString(objv[2])) != 0) { - return TCL_ERROR; - } - isPrivate = 1; - } - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { - return TCL_ERROR; - } - - TclNewObj(resultObj); - if (isPrivate) { - PrivateVariableMapping *privatePtr; - - FOREACH_STRUCT(privatePtr, oPtr->privateVariables) { - Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj); - } - } else { - Tcl_Obj *variableObj; - - FOREACH(variableObj, oPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); - } - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * InfoObjectVarsCmd -- - * - * Implements [info object vars $objName ?$pattern?] - * - * ---------------------------------------------------------------------- - */ - -static int -InfoObjectVarsCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Object *oPtr; - const char *pattern = NULL; - FOREACH_HASH_DECLS; - VarInHash *vihPtr; - Tcl_Obj *nameObj, *resultObj; - - if (objc != 2 && objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "objName ?pattern?"); - return TCL_ERROR; - } - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (objc == 3) { - pattern = TclGetString(objv[2]); - } - TclNewObj(resultObj); - - /* - * Extract the information we need from the object's namespace's table of - * variables. Note that this involves horrific knowledge of the guts of - * tclVar.c, so we can't leverage our hash-iteration macros properly. - */ - - FOREACH_HASH_VALUE(vihPtr, - &((Namespace *) oPtr->namespacePtr)->varTable.table) { - nameObj = vihPtr->entry.key.objPtr; - - if (TclIsVarUndefined(&vihPtr->var) - || !TclIsVarNamespaceVar(&vihPtr->var)) { - continue; - } - if (pattern != NULL - && !Tcl_StringMatch(TclGetString(nameObj), pattern)) { - continue; - } - Tcl_ListObjAppendElement(NULL, resultObj, nameObj); - } - - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * InfoClassConstrCmd -- - * - * Implements [info class constructor $clsName] - * - * ---------------------------------------------------------------------- - */ - -static int -InfoClassConstrCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Proc *procPtr; - CompiledLocal *localPtr; - Tcl_Obj *resultObjs[2]; - Class *clsPtr; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "className"); - return TCL_ERROR; - } - clsPtr = GetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { - return TCL_ERROR; - } - if (clsPtr->constructorPtr == NULL) { - return TCL_OK; - } - procPtr = TclOOGetProcFromMethod(clsPtr->constructorPtr); - if (procPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "definition not available for this kind of method", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL); - return TCL_ERROR; - } - - TclNewObj(resultObjs[0]); - for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL; - localPtr=localPtr->nextPtr) { - if (TclIsVarArgument(localPtr)) { - Tcl_Obj *argObj; - - TclNewObj(argObj); - Tcl_ListObjAppendElement(NULL, argObj, - Tcl_NewStringObj(localPtr->name, -1)); - if (localPtr->defValuePtr != NULL) { - Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); - } - Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj); - } - } - resultObjs[1] = TclOOGetMethodBody(clsPtr->constructorPtr); - Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs)); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * InfoClassDefnCmd -- - * - * Implements [info class definition $clsName $methodName] - * - * ---------------------------------------------------------------------- - */ - -static int -InfoClassDefnCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_HashEntry *hPtr; - Proc *procPtr; - CompiledLocal *localPtr; - Tcl_Obj *resultObjs[2]; - Class *clsPtr; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "className methodName"); - return TCL_ERROR; - } - clsPtr = GetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { - return TCL_ERROR; - } - hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]); - if (hPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown method \"%s\"", TclGetString(objv[2]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[2]), NULL); - return TCL_ERROR; - } - procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr)); - if (procPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "definition not available for this kind of method", -1)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[2]), NULL); - return TCL_ERROR; - } - - TclNewObj(resultObjs[0]); - for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL; - localPtr=localPtr->nextPtr) { - if (TclIsVarArgument(localPtr)) { - Tcl_Obj *argObj; - - TclNewObj(argObj); - Tcl_ListObjAppendElement(NULL, argObj, - Tcl_NewStringObj(localPtr->name, -1)); - if (localPtr->defValuePtr != NULL) { - Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); - } - Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj); - } - } - resultObjs[1] = TclOOGetMethodBody((Method *)Tcl_GetHashValue(hPtr)); - Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs)); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * InfoClassDefnNsCmd -- - * - * Implements [info class definitionnamespace $clsName ?$kind?] - * - * ---------------------------------------------------------------------- - */ - -static int -InfoClassDefnNsCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - static const char *kindList[] = { - "-class", - "-instance", - NULL - }; - int kind = 0; - Tcl_Obj *nsNamePtr; - Class *clsPtr; - - if (objc != 2 && objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "className ?kind?"); - return TCL_ERROR; - } - clsPtr = GetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { - return TCL_ERROR; - } - if (objc == 3 && Tcl_GetIndexFromObj(interp, objv[2], kindList, "kind", 0, - &kind) != TCL_OK) { - return TCL_ERROR; - } - - if (kind) { - nsNamePtr = clsPtr->objDefinitionNs; - } else { - nsNamePtr = clsPtr->clsDefinitionNs; - } - if (nsNamePtr) { - Tcl_SetObjResult(interp, nsNamePtr); - } - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * InfoClassDestrCmd -- - * - * Implements [info class destructor $clsName] - * - * ---------------------------------------------------------------------- - */ - -static int -InfoClassDestrCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Proc *procPtr; - Class *clsPtr; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "className"); - return TCL_ERROR; - } - clsPtr = GetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { - return TCL_ERROR; - } - - if (clsPtr->destructorPtr == NULL) { - return TCL_OK; - } - procPtr = TclOOGetProcFromMethod(clsPtr->destructorPtr); - if (procPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "definition not available for this kind of method", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL); - return TCL_ERROR; - } - - Tcl_SetObjResult(interp, TclOOGetMethodBody(clsPtr->destructorPtr)); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * InfoClassFiltersCmd -- - * - * Implements [info class filters $clsName] - * - * ---------------------------------------------------------------------- - */ - -static int -InfoClassFiltersCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - int i; - Tcl_Obj *filterObj, *resultObj; - Class *clsPtr; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "className"); - return TCL_ERROR; - } - clsPtr = GetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { - return TCL_ERROR; - } - - TclNewObj(resultObj); - FOREACH(filterObj, clsPtr->filters) { - Tcl_ListObjAppendElement(NULL, resultObj, filterObj); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * InfoClassForwardCmd -- - * - * Implements [info class forward $clsName $methodName] - * - * ---------------------------------------------------------------------- - */ - -static int -InfoClassForwardCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_HashEntry *hPtr; - Tcl_Obj *prefixObj; - Class *clsPtr; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "className methodName"); - return TCL_ERROR; - } - clsPtr = GetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { - return TCL_ERROR; - } - hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]); - if (hPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown method \"%s\"", TclGetString(objv[2]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[2]), 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; - } - - Tcl_SetObjResult(interp, prefixObj); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * InfoClassInstancesCmd -- - * - * Implements [info class instances $clsName ?$pattern?] - * - * ---------------------------------------------------------------------- - */ - -static int -InfoClassInstancesCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Object *oPtr; - Class *clsPtr; - int i; - const char *pattern = NULL; - Tcl_Obj *resultObj; - - if (objc != 2 && objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?"); - return TCL_ERROR; - } - clsPtr = GetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { - return TCL_ERROR; - } - if (objc == 3) { - pattern = TclGetString(objv[2]); - } - - TclNewObj(resultObj); - FOREACH(oPtr, clsPtr->instances) { - Tcl_Obj *tmpObj = TclOOObjectName(interp, oPtr); - - if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) { - continue; - } - Tcl_ListObjAppendElement(NULL, resultObj, tmpObj); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * InfoClassMethodsCmd -- - * - * Implements [info class methods $clsName ?options...?] - * - * ---------------------------------------------------------------------- - */ - -static int -InfoClassMethodsCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - int flag = PUBLIC_METHOD, recurse = 0, scope = -1; - Tcl_Obj *namePtr, *resultObj; - Method *mPtr; - Class *clsPtr; - static const char *const options[] = { - "-all", "-localprivate", "-private", "-scope", NULL - }; - enum Options { - OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE - }; - static const char *const scopes[] = { - "private", "public", "unexported" - }; - enum Scopes { - SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED - }; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "className ?-option value ...?"); - return TCL_ERROR; - } - clsPtr = GetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { - return TCL_ERROR; - } - if (objc != 2) { - int i, idx; - - for (i=2 ; i= objc) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "missing option for -scope")); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", - NULL); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0, - &scope) != TCL_OK) { - return TCL_ERROR; - } - break; - } - } - } - if (scope != -1) { - recurse = 0; - switch (scope) { - case SCOPE_PRIVATE: - flag = TRUE_PRIVATE_METHOD; - break; - case SCOPE_PUBLIC: - flag = PUBLIC_METHOD; - break; - case SCOPE_UNEXPORTED: - flag = 0; - break; - } - } - - TclNewObj(resultObj); - if (recurse) { - const char **names; - int i, numNames = TclOOGetSortedClassMethodList(clsPtr, flag, &names); - - for (i=0 ; i 0) { - Tcl_Free((void *)names); - } - } else { - FOREACH_HASH_DECLS; - - FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) { - if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) { - Tcl_ListObjAppendElement(NULL, resultObj, namePtr); - } - } - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * InfoClassMethodTypeCmd -- - * - * Implements [info class methodtype $clsName $methodName] - * - * ---------------------------------------------------------------------- - */ - -static int -InfoClassMethodTypeCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_HashEntry *hPtr; - Method *mPtr; - Class *clsPtr; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "className methodName"); - return TCL_ERROR; - } - clsPtr = GetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { - return TCL_ERROR; - } - - hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]); - if (hPtr == NULL) { - 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; - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(mPtr->typePtr->name, -1)); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * InfoClassMixinsCmd -- - * - * Implements [info class mixins $clsName] - * - * ---------------------------------------------------------------------- - */ - -static int -InfoClassMixinsCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Class *clsPtr, *mixinPtr; - Tcl_Obj *resultObj; - int i; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "className"); - return TCL_ERROR; - } - clsPtr = GetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { - return TCL_ERROR; - } - - TclNewObj(resultObj); - FOREACH(mixinPtr, clsPtr->mixins) { - if (!mixinPtr) { - continue; - } - Tcl_ListObjAppendElement(NULL, resultObj, - TclOOObjectName(interp, mixinPtr->thisPtr)); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * InfoClassSubsCmd -- - * - * Implements [info class subclasses $clsName ?$pattern?] - * - * ---------------------------------------------------------------------- - */ - -static int -InfoClassSubsCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Class *clsPtr, *subclassPtr; - Tcl_Obj *resultObj; - int i; - const char *pattern = NULL; - - if (objc != 2 && objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?"); - return TCL_ERROR; - } - clsPtr = GetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { - return TCL_ERROR; - } - if (objc == 3) { - pattern = TclGetString(objv[2]); - } - - TclNewObj(resultObj); - FOREACH(subclassPtr, clsPtr->subclasses) { - Tcl_Obj *tmpObj = TclOOObjectName(interp, subclassPtr->thisPtr); - - if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) { - continue; - } - Tcl_ListObjAppendElement(NULL, resultObj, tmpObj); - } - FOREACH(subclassPtr, clsPtr->mixinSubs) { - Tcl_Obj *tmpObj = TclOOObjectName(interp, subclassPtr->thisPtr); - - if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) { - continue; - } - Tcl_ListObjAppendElement(NULL, resultObj, tmpObj); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * InfoClassSupersCmd -- - * - * Implements [info class superclasses $clsName] - * - * ---------------------------------------------------------------------- - */ - -static int -InfoClassSupersCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Class *clsPtr, *superPtr; - Tcl_Obj *resultObj; - int i; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "className"); - return TCL_ERROR; - } - clsPtr = GetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { - return TCL_ERROR; - } - - TclNewObj(resultObj); - FOREACH(superPtr, clsPtr->superclasses) { - Tcl_ListObjAppendElement(NULL, resultObj, - TclOOObjectName(interp, superPtr->thisPtr)); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * InfoClassVariablesCmd -- - * - * Implements [info class variables $clsName ?-private?] - * - * ---------------------------------------------------------------------- - */ - -static int -InfoClassVariablesCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Class *clsPtr; - Tcl_Obj *resultObj; - int i, isPrivate = 0; - - if (objc != 2 && objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "className ?-private?"); - return TCL_ERROR; - } - if (objc == 3) { - if (strcmp("-private", TclGetString(objv[2])) != 0) { - return TCL_ERROR; - } - isPrivate = 1; - } - clsPtr = GetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { - return TCL_ERROR; - } - - TclNewObj(resultObj); - if (isPrivate) { - PrivateVariableMapping *privatePtr; - - FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) { - Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj); - } - } else { - Tcl_Obj *variableObj; - - FOREACH(variableObj, clsPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); - } - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * InfoObjectCallCmd -- - * - * Implements [info object call $objName $methodName] - * - * ---------------------------------------------------------------------- - */ - -static int -InfoObjectCallCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Object *oPtr; - CallContext *contextPtr; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "objName methodName"); - return TCL_ERROR; - } - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { - return TCL_ERROR; - } - - /* - * Get the call context and render its call chain. - */ - - contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL, NULL, - NULL); - if (contextPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot construct any call chain", -1)); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, - TclOORenderCallChain(interp, contextPtr->callPtr)); - TclOODeleteContext(contextPtr); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * InfoClassCallCmd -- - * - * Implements [info class call $clsName $methodName] - * - * ---------------------------------------------------------------------- - */ - -static int -InfoClassCallCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Class *clsPtr; - CallChain *callPtr; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "className methodName"); - return TCL_ERROR; - } - clsPtr = GetClassFromObj(interp, objv[1]); - if (clsPtr == NULL) { - return TCL_ERROR; - } - - /* - * Get an render the stereotypical call chain. - */ - - callPtr = TclOOGetStereotypeCallChain(clsPtr, objv[2], PUBLIC_METHOD); - if (callPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot construct any call chain", -1)); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, TclOORenderCallChain(interp, callPtr)); - TclOODeleteChain(callPtr); - return TCL_OK; -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ DELETED generic/tclOOInt.h Index: generic/tclOOInt.h ================================================================== --- generic/tclOOInt.h +++ /dev/null @@ -1,712 +0,0 @@ -/* - * tclOOInt.h -- - * - * This file contains the structure definitions and some of the function - * declarations for the object-system (NB: not Tcl_Obj, but ::oo). - * - * Copyright (c) 2006-2012 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. - */ - -#ifndef TCL_OO_INTERNAL_H -#define TCL_OO_INTERNAL_H 1 - -#include "tclInt.h" -#include "tclOO.h" - -/* - * Hack to make things work with Objective C. Note that ObjC isn't really - * supported, but we don't want to to be actively hostile to it. [Bug 2163447] - */ - -#ifdef __OBJC__ -#define Class TclOOClass -#define Object TclOOObject -#endif /* __OBJC__ */ - -/* - * Forward declarations. - */ - -struct CallChain; -struct Class; -struct Foundation; -struct Object; - -/* - * The data that needs to be stored per method. This record is used to collect - * information about all sorts of methods, including forwards, constructors - * and destructors. - */ - -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. */ - size_t 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)(void *clientData, Tcl_Interp *interp, - Tcl_ObjectContext context, Tcl_CallFrame *framePtr, int *isFinished); -typedef int (TclOO_PostCallProc)(void *clientData, Tcl_Interp *interp, - Tcl_ObjectContext context, Tcl_Namespace *namespacePtr, int result); -typedef void (TclOO_PmCDDeleteProc)(void *clientData); -typedef void *(TclOO_PmCDCloneProc)(void *clientData); - -/* - * Procedure-like methods have the following extra information. - */ - -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. */ - size_t refCount; - void *clientData; - TclOO_PmCDDeleteProc *deleteClientdataProc; - TclOO_PmCDCloneProc *cloneClientdataProc; - ProcErrorProc *errProc; /* Replacement error handler. */ - TclOO_PreCallProc *preCallProc; - /* Callback to allow for additional setup - * before the method executes. */ - TclOO_PostCallProc *postCallProc; - /* Callback to allow for additional cleanup - * after the method executes. */ - GetFrameInfoValueProc *gfivProc; - /* Callback to allow for fine tuning of how - * the method reports itself. */ -} ProcedureMethod; - -#define TCLOO_PROCEDURE_METHOD_VERSION 0 - -/* - * Flags for use in a ProcedureMethod. - * - * When the USE_DECLARER_NS flag is set, the method will use the namespace of - * the object or class that declared it (or the clone of it, if it was from - * such that the implementation of the method came to the particular use) - * instead of the namespace of the object on which the method was invoked. - * This flag must be distinct from all others that are associated with - * methods. - */ - -#define USE_DECLARER_NS 0x80 - -/* - * Forwarded methods have the following extra information. - */ - -typedef struct ForwardMethod { - Tcl_Obj *prefixObj; /* The list of values to use to replace the - * object and method name with. Will be a - * non-empty list. */ -} ForwardMethod; - -/* - * Structure used in private variable mappings. Describes the mapping of a - * single variable from the user's local name to the system's storage name. - * [TIP #500] - */ - -typedef struct { - Tcl_Obj *variableObj; /* Name used within methods. This is the part - * that is properly under user control. */ - Tcl_Obj *fullNameObj; /* Name used at the instance namespace level. */ -} PrivateVariableMapping; - -/* - * Helper definitions that declare a "list" array. The two varieties are - * either optimized for simplicity (in the case that the whole array is - * typically assigned at once) or efficiency (in the case that the array is - * expected to be expanded over time). These lists are designed to be iterated - * over with the help of the FOREACH macro (see later in this file). - * - * The "num" field always counts the number of listType_t elements used in the - * "list" field. When a "size" field exists, it describes how many elements - * are present in the list; when absent, exactly "num" elements are present. - */ - -#define LIST_STATIC(listType_t) \ - struct { int num; listType_t *list; } -#define LIST_DYNAMIC(listType_t) \ - struct { int num, size; listType_t *list; } - -/* - * These types are needed in function arguments. - */ - -typedef LIST_STATIC(Tcl_Obj *) VariableNameList; -typedef LIST_STATIC(PrivateVariableMapping) PrivateVariableList; - -/* - * Now, the definition of what an object actually is. - */ - -typedef struct Object { - struct Foundation *fPtr; /* The basis for the object system. Putting - * this here allows the avoidance of quite a - * lot of hash lookups on the critical path - * for object invocation and creation. */ - Tcl_Namespace *namespacePtr;/* This object's namespace. */ - Tcl_Command command; /* Reference to this object's public - * command. */ - Tcl_Command myCommand; /* Reference to this object's internal - * command. */ - struct Class *selfCls; /* This object's class. */ - Tcl_HashTable *methodsPtr; /* Object-local Tcl_Obj (method name) to - * Method* mapping. */ - 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. */ - size_t 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; - size_t creationEpoch; /* Unique value to make comparisons of objects - * easier. */ - size_t epoch; /* Per-object epoch, incremented when the way - * an object should resolve call chains is - * changed. */ - Tcl_HashTable *metadataPtr; /* Mapping from pointers to metadata type to - * the void *values that are the values - * of each piece of attached metadata. This - * field starts out as NULL and is only - * allocated if metadata is attached. */ - 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. */ -#define USE_CLASS_CACHE 0x4000 /* Flag set to say that the object is a pure - * instance of the class, and has had nothing - * added that changes the dispatch chain (i.e. - * no methods, mixins, or filters. */ -#define ROOT_CLASS 0x8000 /* Flag to say that this object is the root - * class of classes, and should be treated - * specially during teardown (and in a few - * other spots). */ -#define FORCE_UNKNOWN 0x10000 /* States that we are *really* looking up the - * unknown method handler at that point. */ -#define HAS_PRIVATE_METHODS 0x20000 - /* Object/class has (or had) private methods, - * and so shouldn't be cached so - * aggressively. */ -#define DONT_DELETE 0x40000 /* Inhibit deletion of this object. Used - * during fundamental object type mutation to - * make sure that the object actually survives - * to the end of the operation. */ - -/* - * And the definition of a class. Note that every class also has an associated - * object, through which it is manipulated. - */ - -typedef struct Class { - Object *thisPtr; /* Reference to the object associated with - * this class. */ - int flags; /* Assorted flags. */ - LIST_STATIC(struct Class *) superclasses; - /* List of superclasses, used for generation - * of method call chains. */ - LIST_DYNAMIC(struct Class *) subclasses; - /* List of subclasses, used to ensure deletion - * of dependent entities happens properly when - * the class itself is deleted. */ - LIST_DYNAMIC(Object *) instances; - /* List of instances, used to ensure deletion - * of dependent entities happens properly when - * the class itself is deleted. */ - LIST_STATIC(Tcl_Obj *) filters; - /* List of filter names, used for generation - * of method call chains. */ - LIST_STATIC(struct Class *) mixins; - /* List of mixin classes, used for generation - * of method call chains. */ - LIST_DYNAMIC(struct Class *) mixinSubs; - /* List of classes that this class is mixed - * into, used to ensure deletion of dependent - * entities happens properly when the class - * itself is deleted. */ - Tcl_HashTable classMethods; /* Hash table of all methods. Hash maps from - * the (Tcl_Obj*) method name to the (Method*) - * method record. */ - Method *constructorPtr; /* Method record of the class constructor (if - * any). */ - Method *destructorPtr; /* Method record of the class destructor (if - * any). */ - Tcl_HashTable *metadataPtr; /* Mapping from pointers to metadata type to - * the void *values that are the values - * of each piece of attached metadata. This - * field starts out as NULL and is only - * allocated if metadata is attached. */ - struct CallChain *constructorChainPtr; - struct CallChain *destructorChainPtr; - Tcl_HashTable *classChainCache; - /* Places where call chains are stored. For - * constructors, the class chain is always - * used. For destructors and ordinary methods, - * the class chain is only used when the - * object doesn't override with its own mixins - * (and filters and method implementations for - * when getting method chains). */ - VariableNameList variables; - PrivateVariableList privateVariables; - /* Configurations for the variable resolver - * used inside methods. */ - Tcl_Obj *clsDefinitionNs; /* Name of the namespace to use for - * definitions commands of instances of this - * class in when those instances are defined - * as classes. If NULL, use the value from the - * class hierarchy. It's an error at - * [oo::define] call time if this namespace is - * defined but doesn't exist; we also check at - * setting time but don't check between - * times. */ - Tcl_Obj *objDefinitionNs; /* Name of the namespace to use for - * definitions commands of instances of this - * class in when those instances are defined - * as instances. If NULL, use the value from - * the class hierarchy. It's an error at - * [oo::objdefine]/[self] call time if this - * namespace is defined but doesn't exist; we - * also check at setting time but don't check - * between times. */ -} Class; - -/* - * 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 { - size_t nsCount; /* Epoch counter is used for keeping - * the values used in Tcl_Obj internal - * representations sane. Must be thread-local - * because Tcl_Objs can cross interpreter - * boundaries within a thread (objects don't - * generally cross threads). */ -} ThreadLocalData; - -typedef struct Foundation { - Tcl_Interp *interp; - Class *objectCls; /* The root of the object system. */ - Class *classCls; /* The class of all classes. */ - Tcl_Namespace *ooNs; /* ::oo namespace. */ - Tcl_Namespace *defineNs; /* Namespace containing special commands for - * manipulating objects and classes. The - * "oo::define" command acts as a special kind - * of ensemble for this namespace. */ - Tcl_Namespace *objdefNs; /* Namespace containing special commands for - * manipulating objects and classes. The - * "oo::objdefine" command acts as a special - * kind of ensemble for this namespace. */ - Tcl_Namespace *helpersNs; /* Namespace containing the commands that are - * only valid when executing inside a - * procedural method. */ - size_t epoch; /* Used to invalidate method chains when the - * class structure changes. */ - ThreadLocalData *tsdPtr; /* Counter so we can allocate a unique - * namespace to each object. */ - Tcl_Obj *unknownMethodNameObj; - /* Shared object containing the name of the - * unknown method handler method. */ - Tcl_Obj *constructorName; /* Shared object containing the "name" of a - * constructor. */ - Tcl_Obj *destructorName; /* Shared object containing the "name" of a - * destructor. */ - Tcl_Obj *clonedName; /* Shared object containing the name of a - * "" pseudo-constructor. */ - Tcl_Obj *defineName; /* Fully qualified name of oo::define. */ -} Foundation; - -/* - * A call context structure is built when a method is called. It contains the - * chain of method implementations that are to be invoked by a particular - * call, and the process of calling walks the chain, with the [next] command - * proceeding to the next entry in the chain. - */ - -#define CALL_CHAIN_STATIC_SIZE 4 - -struct MInvoke { - Method *mPtr; /* Reference to the method implementation - * record. */ - int isFilter; /* Whether this is a filter invocation. */ - Class *filterDeclarer; /* What class decided to add the filter; if - * NULL, it was added by the object. */ -}; - -typedef struct CallChain { - size_t objectCreationEpoch; /* The object's creation epoch. Note that the - * object reference is not stored in the call - * chain; it is in the call context. */ - size_t objectEpoch; /* Local (object structure) epoch counter - * snapshot. */ - size_t epoch; /* Global (class structure) epoch counter - * snapshot. */ - int flags; /* Assorted flags, see below. */ - size_t 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; - -typedef struct CallContext { - Object *oPtr; /* The object associated with this call. */ - int index; /* Index into the call chain of the currently - * executing method implementation. */ - int skip; /* Current number of arguments to skip; can - * vary depending on whether it is a direct - * method call or a continuation via the - * [next] command. */ - CallChain *callPtr; /* The actual call chain. */ -} CallContext; - -/* - * Bits for the 'flags' field of the call chain. - */ - -#define PUBLIC_METHOD 0x01 /* This is a public (exported) method. */ -#define PRIVATE_METHOD 0x02 /* This is a private (class's direct instances - * only) method. Supports itcl. */ -#define OO_UNKNOWN_METHOD 0x04 /* This is an unknown method. */ -#define CONSTRUCTOR 0x08 /* This is a constructor. */ -#define DESTRUCTOR 0x10 /* This is a destructor. */ -#define TRUE_PRIVATE_METHOD 0x20 - /* This is a private method only accessible - * from other methods defined on this class - * or instance. [TIP #500] */ -#define SCOPE_FLAGS (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD) - -/* - * Structure containing definition information about basic class methods. - */ - -typedef struct { - const char *name; /* Name of the method in question. */ - int isPublic; /* Whether the method is public by default. */ - Tcl_MethodType definition; /* How to call the method. */ -} DeclaredClassMethod; - -/* - *---------------------------------------------------------------- - * Commands relating to OO support. - *---------------------------------------------------------------- - */ - -MODULE_SCOPE int TclOOInit(Tcl_Interp *interp); -MODULE_SCOPE int TclOODefineObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOOObjDefObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineConstructorObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineDeleteMethodObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineDestructorObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineExportObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineForwardObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineMethodObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineRenameMethodObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineUnexportObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineClassObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineSelfObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineObjSelfObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOOUnknownDefinition(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOOCopyObjectCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOONextObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOONextToObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineUnexportObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineClassObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineSelfObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefineObjSelfObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOODefinePrivateObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOOUnknownDefinition(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOOCopyObjectCmd(void *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 TclOONextObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOONextToObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -MODULE_SCOPE int TclOOSelfObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); - -/* - * Method implementations (in tclOOBasic.c). - */ - -MODULE_SCOPE int TclOO_Class_Constructor(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Class_Create(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Class_CreateNs(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Class_New(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_Destroy(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_Eval(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_LinkVar(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_Unknown(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -MODULE_SCOPE int TclOO_Object_VarName(void *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. - */ - -MODULE_SCOPE void TclOOAddToInstances(Object *oPtr, Class *clsPtr); -MODULE_SCOPE void TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr); -MODULE_SCOPE void TclOOAddToSubclasses(Class *subPtr, Class *superPtr); -MODULE_SCOPE Class * TclOOAllocClass(Tcl_Interp *interp, - Object *useThisObj); -MODULE_SCOPE int TclNRNewObjectInstance(Tcl_Interp *interp, - Tcl_Class cls, const char *nameStr, - const char *nsNameStr, int objc, - 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); -MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr, - Tcl_Obj *methodNameObj, int flags, - Object *contextObjPtr, Class *contextClsPtr, - Tcl_Obj *cacheInThisObj); -MODULE_SCOPE Tcl_Namespace *TclOOGetDefineContextNamespace( - Tcl_Interp *interp, Object *oPtr, int forClass); -MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr, - Tcl_Obj *methodNameObj, int flags); -MODULE_SCOPE Foundation *TclOOGetFoundation(Tcl_Interp *interp); -MODULE_SCOPE Tcl_Obj * TclOOGetFwdFromMethod(Method *mPtr); -MODULE_SCOPE Proc * TclOOGetProcFromMethod(Method *mPtr); -MODULE_SCOPE Tcl_Obj * TclOOGetMethodBody(Method *mPtr); -MODULE_SCOPE 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(void *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); -MODULE_SCOPE Tcl_Obj * TclOOObjectName(Tcl_Interp *interp, Object *oPtr); -MODULE_SCOPE void TclOOReleaseClassContents(Tcl_Interp *interp, - Object *oPtr); -MODULE_SCOPE int TclOORemoveFromInstances(Object *oPtr, Class *clsPtr); -MODULE_SCOPE int TclOORemoveFromMixins(Class *mixinPtr, Object *oPtr); -MODULE_SCOPE int TclOORemoveFromMixinSubs(Class *subPtr, - Class *mixinPtr); -MODULE_SCOPE int TclOORemoveFromSubclasses(Class *subPtr, - Class *superPtr); -MODULE_SCOPE Tcl_Obj * TclOORenderCallChain(Tcl_Interp *interp, - CallChain *callPtr); -MODULE_SCOPE void TclOOStashContext(Tcl_Obj *objPtr, - CallContext *contextPtr); -MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); - -/* - * Include all the private API, generated from tclOO.decls. - */ - -#include "tclOOIntDecls.h" - -/* - * Alternatives to Tcl_Preserve/Tcl_EventuallyFree/Tcl_Release. - */ - -#define AddRef(ptr) ((ptr)->refCount++) - -/* - * A convenience macro for iterating through the lists used in the internal - * memory management of objects. - * REQUIRES DECLARATION: int i; - */ - -#define FOREACH(var,ary) \ - for(i=0 ; i<(ary).num; i++) if ((ary).list[i] == NULL) { \ - continue; \ - } else if (var = (ary).list[i], 1) - -/* - * A variation where the array is an array of structs. There's no issue with - * possible NULLs; every element of the array will be iterated over and the - * varable set to a pointer to each of those elements in turn. - * REQUIRES DECLARATION: int i; - */ - -#define FOREACH_STRUCT(var,ary) \ - for(i=0 ; var=&((ary).list[i]), i<(ary).num; i++) - -/* - * Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS - * sets up the declarations needed for the main macro, FOREACH_HASH, which - * does the actual iteration. FOREACH_HASH_VALUE is a restricted version that - * only iterates over values. - * 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*)Tcl_Alloc(len)), (source).list, len); \ - } else { \ - (target).list = NULL; \ - } \ - } while(0) - -#endif /* TCL_OO_INTERNAL_H */ - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ DELETED generic/tclOOIntDecls.h Index: generic/tclOOIntDecls.h ================================================================== --- generic/tclOOIntDecls.h +++ /dev/null @@ -1,166 +0,0 @@ -/* - * This file is (mostly) automatically generated from tclOO.decls. - */ - -#ifndef _TCLOOINTDECLS -#define _TCLOOINTDECLS - -/* !BEGIN!: Do not edit below this line. */ - -#ifdef __cplusplus -extern "C" { -#endif - -/* - * Exported function declarations: - */ - -/* 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, - void *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, - void *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, - int flags, Tcl_Obj *nameObj, - Tcl_Obj *argsObj, Tcl_Obj *bodyObj, - ProcedureMethod **pmPtrPtr); -/* 5 */ -TCLAPI int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, - int objc, Tcl_Obj *const *objv, - int publicOnly, Class *startCls); -/* 6 */ -TCLAPI int TclOOIsReachable(Class *targetPtr, Class *startPtr); -/* 7 */ -TCLAPI Method * TclOONewForwardMethod(Tcl_Interp *interp, - Class *clsPtr, int isPublic, - Tcl_Obj *nameObj, Tcl_Obj *prefixObj); -/* 8 */ -TCLAPI Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp, - 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, void *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, void *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, - Tcl_Obj *const *filters); -/* 13 */ -TCLAPI void TclOOClassSetFilters(Tcl_Interp *interp, - Class *classPtr, int numFilters, - Tcl_Obj *const *filters); -/* 14 */ -TCLAPI void TclOOObjectSetMixins(Object *oPtr, int numMixins, - Class *const *mixins); -/* 15 */ -TCLAPI void TclOOClassSetMixins(Tcl_Interp *interp, - Class *classPtr, int numMixins, - Class *const *mixins); - -typedef struct TclOOIntStubs { - int magic; - void *hooks; - - Tcl_Object (*tclOOGetDefineCmdContext) (Tcl_Interp *interp); /* 0 */ - Tcl_Method (*tclOOMakeProcInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, void *clientData, Proc **procPtrPtr); /* 1 */ - 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, void *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, void *clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 9 */ - Tcl_Method (*tclOONewProcMethodEx) (Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, void *clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 10 */ - int (*tclOOInvokeObject) (Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, 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; - -extern const TclOOIntStubs *tclOOIntStubsPtr; - -#ifdef __cplusplus -} -#endif - -#if defined(USE_TCLOO_STUBS) - -/* - * Inline function declarations: - */ - -#define TclOOGetDefineCmdContext \ - (tclOOIntStubsPtr->tclOOGetDefineCmdContext) /* 0 */ -#define TclOOMakeProcInstanceMethod \ - (tclOOIntStubsPtr->tclOOMakeProcInstanceMethod) /* 1 */ -#define TclOOMakeProcMethod \ - (tclOOIntStubsPtr->tclOOMakeProcMethod) /* 2 */ -#define TclOONewProcInstanceMethod \ - (tclOOIntStubsPtr->tclOONewProcInstanceMethod) /* 3 */ -#define TclOONewProcMethod \ - (tclOOIntStubsPtr->tclOONewProcMethod) /* 4 */ -#define TclOOObjectCmdCore \ - (tclOOIntStubsPtr->tclOOObjectCmdCore) /* 5 */ -#define TclOOIsReachable \ - (tclOOIntStubsPtr->tclOOIsReachable) /* 6 */ -#define TclOONewForwardMethod \ - (tclOOIntStubsPtr->tclOONewForwardMethod) /* 7 */ -#define TclOONewForwardInstanceMethod \ - (tclOOIntStubsPtr->tclOONewForwardInstanceMethod) /* 8 */ -#define TclOONewProcInstanceMethodEx \ - (tclOOIntStubsPtr->tclOONewProcInstanceMethodEx) /* 9 */ -#define TclOONewProcMethodEx \ - (tclOOIntStubsPtr->tclOONewProcMethodEx) /* 10 */ -#define TclOOInvokeObject \ - (tclOOIntStubsPtr->tclOOInvokeObject) /* 11 */ -#define TclOOObjectSetFilters \ - (tclOOIntStubsPtr->tclOOObjectSetFilters) /* 12 */ -#define TclOOClassSetFilters \ - (tclOOIntStubsPtr->tclOOClassSetFilters) /* 13 */ -#define TclOOObjectSetMixins \ - (tclOOIntStubsPtr->tclOOObjectSetMixins) /* 14 */ -#define TclOOClassSetMixins \ - (tclOOIntStubsPtr->tclOOClassSetMixins) /* 15 */ - -#endif /* defined(USE_TCLOO_STUBS) */ - -/* !END!: Do not edit above this line. */ - -#endif /* _TCLOOINTDECLS */ DELETED generic/tclOOMethod.c Index: generic/tclOOMethod.c ================================================================== --- generic/tclOOMethod.c +++ /dev/null @@ -1,1793 +0,0 @@ -/* - * tclOOMethod.c -- - * - * This file contains code to create and manage methods. - * - * Copyright (c) 2005-2011 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. - */ - -#ifdef HAVE_CONFIG_H -#include "config.h" -#endif -#include "tclInt.h" -#include "tclOOInt.h" -#include "tclCompile.h" - -/* - * Structure used to help delay computing names of objects or classes for - * [info frame] until needed, making invokation faster in the normal case. - */ - -struct PNI { - Tcl_Interp *interp; /* Interpreter in which to compute the name of - * a method. */ - Tcl_Method method; /* Method to compute the name of. */ -}; - -/* - * Structure used to contain all the information needed about a call frame - * used in a procedure-like method. - */ - -typedef struct { - CallFrame *framePtr; /* Reference to the call frame itself (it's - * actually allocated on the Tcl stack). */ - ProcErrorProc *errProc; /* The error handler for the body. */ - Tcl_Obj *nameObj; /* The "name" of the command. */ - Command cmd; /* The command structure. Mostly bogus. */ - ExtraFrameInfo efi; /* Extra information used for [info frame]. */ - Command *oldCmdPtr; /* Saved cmdPtr so that we can be safe after a - * recursive call returns. */ - struct PNI pni; /* Specialist information used in the efi - * field for this type of call. */ -} PMFrameData; - -/* - * Structure used to pass information about variable resolution to the - * on-the-ground resolvers used when working with resolved compiled variables. - */ - -typedef struct { - Tcl_ResolvedVarInfo info; /* "Type" information so that the compiled - * variable can be linked to the namespace - * variable at the right time. */ - Tcl_Obj *variableObj; /* The name of the variable. */ - Tcl_Var cachedObjectVar; /* TODO: When to flush this cache? Can class - * variables be cached? */ -} OOResVarInfo; - -/* - * Function declarations for things defined in this file. - */ - -static Tcl_Obj ** InitEnsembleRewrite(Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv, int toRewrite, - int rewriteLength, Tcl_Obj *const *rewriteObjs, - int *lengthPtr); -static int InvokeProcedureMethod(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static Tcl_NRPostProc FinalizeForwardCall; -static Tcl_NRPostProc FinalizePMCall; -static int PushMethodCallFrame(Tcl_Interp *interp, - 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", - InvokeProcedureMethod, DeleteProcedureMethod, CloneProcedureMethod -}; -static const Tcl_MethodType fwdMethodType = { - TCL_OO_METHOD_VERSION_CURRENT, "forward", - InvokeForwardMethod, DeleteForwardMethod, CloneForwardMethod -}; - -/* - * Helper macros (derived from things private to tclVar.c) - */ - -#define TclVarTable(contextNs) \ - ((Tcl_HashTable *) (&((Namespace *) (contextNs))->varTable)) -#define TclVarHashGetValue(hPtr) \ - ((Tcl_Var) ((char *)hPtr - offsetof(VarInHash, entry))) - -/* - * ---------------------------------------------------------------------- - * - * Tcl_NewInstanceMethod -- - * - * Attach a method to an object instance. - * - * ---------------------------------------------------------------------- - */ - -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 *)Tcl_Alloc(sizeof(Method)); - mPtr->namePtr = NULL; - mPtr->refCount = 1; - goto populate; - } - if (!oPtr->methodsPtr) { - oPtr->methodsPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); - Tcl_InitObjHashTable(oPtr->methodsPtr); - oPtr->flags &= ~USE_CLASS_CACHE; - } - hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) nameObj, &isNew); - if (isNew) { - mPtr = (Method *)Tcl_Alloc(sizeof(Method)); - mPtr->namePtr = nameObj; - mPtr->refCount = 1; - Tcl_IncrRefCount(nameObj); - Tcl_SetHashValue(hPtr, mPtr); - } else { - mPtr = (Method *)Tcl_GetHashValue(hPtr); - if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) { - mPtr->typePtr->deleteProc(mPtr->clientData); - } - } - - populate: - mPtr->typePtr = typePtr; - mPtr->clientData = clientData; - mPtr->flags = 0; - mPtr->declaringObjectPtr = oPtr; - mPtr->declaringClassPtr = NULL; - if (flags) { - mPtr->flags |= flags & - (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD); - if (flags & TRUE_PRIVATE_METHOD) { - oPtr->flags |= HAS_PRIVATE_METHODS; - } - } - oPtr->epoch++; - return (Tcl_Method) mPtr; -} - -/* - * ---------------------------------------------------------------------- - * - * Tcl_NewMethod -- - * - * 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 *)Tcl_Alloc(sizeof(Method)); - mPtr->namePtr = NULL; - mPtr->refCount = 1; - goto populate; - } - hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char *)nameObj,&isNew); - if (isNew) { - mPtr = (Method *)Tcl_Alloc(sizeof(Method)); - mPtr->refCount = 1; - mPtr->namePtr = nameObj; - Tcl_IncrRefCount(nameObj); - Tcl_SetHashValue(hPtr, mPtr); - } else { - mPtr = (Method *)Tcl_GetHashValue(hPtr); - if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) { - mPtr->typePtr->deleteProc(mPtr->clientData); - } - } - - populate: - clsPtr->thisPtr->fPtr->epoch++; - mPtr->typePtr = typePtr; - mPtr->clientData = clientData; - mPtr->flags = 0; - mPtr->declaringObjectPtr = NULL; - mPtr->declaringClassPtr = clsPtr; - if (flags) { - mPtr->flags |= flags & - (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD); - if (flags & TRUE_PRIVATE_METHOD) { - clsPtr->flags |= HAS_PRIVATE_METHODS; - } - } - - return (Tcl_Method) mPtr; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODelMethodRef -- - * - * How to delete a method. - * - * ---------------------------------------------------------------------- - */ - -void -TclOODelMethodRef( - Method *mPtr) -{ - if ((mPtr != NULL) && (mPtr->refCount-- <= 1)) { - if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) { - mPtr->typePtr->deleteProc(mPtr->clientData); - } - if (mPtr->namePtr != NULL) { - Tcl_DecrRefCount(mPtr->namePtr); - } - - Tcl_Free(mPtr); - } -} - -/* - * ---------------------------------------------------------------------- - * - * TclOONewBasicMethod -- - * - * Helper that makes it cleaner to create very simple methods during - * basic system initialization. Not suitable for general use. - * - * ---------------------------------------------------------------------- - */ - -void -TclOONewBasicMethod( - Tcl_Interp *interp, - Class *clsPtr, /* Class to attach the method to. */ - const DeclaredClassMethod *dcm) - /* Name of the method, whether it is public, - * and the function to implement it. */ -{ - Tcl_Obj *namePtr = Tcl_NewStringObj(dcm->name, -1); - - Tcl_IncrRefCount(namePtr); - Tcl_NewMethod(interp, (Tcl_Class) clsPtr, namePtr, - (dcm->isPublic ? PUBLIC_METHOD : 0), &dcm->definition, NULL); - Tcl_DecrRefCount(namePtr); -} - -/* - * ---------------------------------------------------------------------- - * - * TclOONewProcInstanceMethod -- - * - * Create a new procedure-like method for an object. - * - * ---------------------------------------------------------------------- - */ - -Method * -TclOONewProcInstanceMethod( - Tcl_Interp *interp, /* The interpreter containing the object. */ - Object *oPtr, /* The object to modify. */ - int flags, /* Whether this is a public method. */ - Tcl_Obj *nameObj, /* The name of the method, which must not be - * NULL. */ - Tcl_Obj *argsObj, /* The formal argument list for the method, - * which must not be NULL. */ - Tcl_Obj *bodyObj, /* The body of the method, which must not be - * NULL. */ - 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 *)Tcl_Alloc(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) { - Tcl_Free(pmPtr); - } else if (pmPtrPtr != NULL) { - *pmPtrPtr = pmPtr; - } - return (Method *) method; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOONewProcMethod -- - * - * Create a new procedure-like method for a class. - * - * ---------------------------------------------------------------------- - */ - -Method * -TclOONewProcMethod( - Tcl_Interp *interp, /* The interpreter containing the class. */ - Class *clsPtr, /* The class to modify. */ - int flags, /* Whether this is a public method. */ - Tcl_Obj *nameObj, /* The name of the method, which may be NULL; - * if so, up to caller to manage storage - * (e.g., because it is a constructor or - * destructor). */ - Tcl_Obj *argsObj, /* The formal argument list for the method, - * which may be NULL; if so, it is equivalent - * to an empty list. */ - Tcl_Obj *bodyObj, /* The body of the method, which must not be - * 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; - TclNewObj(argsObj); - Tcl_IncrRefCount(argsObj); - procName = ""; - } else if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) { - return NULL; - } else { - procName = (nameObj==NULL ? "" : TclGetString(nameObj)); - } - - pmPtr = (ProcedureMethod *)Tcl_Alloc(sizeof(ProcedureMethod)); - memset(pmPtr, 0, sizeof(ProcedureMethod)); - pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION; - pmPtr->flags = flags & USE_DECLARER_NS; - pmPtr->refCount = 1; - - method = TclOOMakeProcMethod(interp, clsPtr, flags, nameObj, procName, - argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr); - - if (argsLen == -1) { - Tcl_DecrRefCount(argsObj); - } - if (method == NULL) { - Tcl_Free(pmPtr); - } else if (pmPtrPtr != NULL) { - *pmPtrPtr = pmPtr; - } - - return (Method *) method; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOMakeProcInstanceMethod -- - * - * The guts of the code to make a procedure-like method for an object. - * Split apart so that it is easier for other extensions to reuse (in - * particular, it frees them from having to pry so deeply into Tcl's - * guts). - * - * ---------------------------------------------------------------------- - */ - -Tcl_Method -TclOOMakeProcInstanceMethod( - Tcl_Interp *interp, /* The interpreter containing the object. */ - Object *oPtr, /* The object to modify. */ - int flags, /* Whether this is a public method. */ - Tcl_Obj *nameObj, /* The name of the method, which _must not_ be - * NULL. */ - Tcl_Obj *argsObj, /* The formal argument list for the method, - * which _must not_ be NULL. */ - Tcl_Obj *bodyObj, /* The body of the method, which _must not_ be - * NULL. */ - const Tcl_MethodType *typePtr, - /* The type of the method to create. */ - void *clientData, /* The per-method type-specific data. */ - Proc **procPtrPtr) /* A pointer to the variable in which to write - * the procedure record reference. Presumably - * inside the structure indicated by the - * pointer in clientData. */ -{ - Interp *iPtr = (Interp *) interp; - Proc *procPtr; - - if (TclCreateProc(interp, NULL, TclGetString(nameObj), argsObj, bodyObj, - procPtrPtr) != TCL_OK) { - return NULL; - } - procPtr = *procPtrPtr; - procPtr->cmdPtr = NULL; - - if (iPtr->cmdFramePtr) { - CmdFrame context = *iPtr->cmdFramePtr; - - if (context.type == TCL_LOCATION_BC) { - /* - * Retrieve source information from the bytecode, if possible. If - * the information is retrieved successfully, context.type will be - * TCL_LOCATION_SOURCE and the reference held by - * context.data.eval.path will be counted. - */ - - TclGetSrcInfoForPc(&context); - } else if (context.type == TCL_LOCATION_SOURCE) { - /* - * The copy into 'context' up above has created another reference - * to 'context.data.eval.path'; account for it. - */ - - Tcl_IncrRefCount(context.data.eval.path); - } - - if (context.type == TCL_LOCATION_SOURCE) { - /* - * We can account for source location within a proc only if the - * proc body was not created by substitution. - * (FIXME: check that this is sane and correct!) - */ - - if (context.line - && (context.nline >= 4) && (context.line[3] >= 0)) { - int isNew; - CmdFrame *cfPtr = (CmdFrame *)Tcl_Alloc(sizeof(CmdFrame)); - Tcl_HashEntry *hPtr; - - cfPtr->level = -1; - cfPtr->type = context.type; - cfPtr->line = (int *)Tcl_Alloc(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); - - cfPtr->cmd = NULL; - cfPtr->len = 0; - - hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, - (char *) procPtr, &isNew); - Tcl_SetHashValue(hPtr, cfPtr); - } - - /* - * 'context' is going out of scope; account for the reference that - * it's holding to the path name. - */ - - Tcl_DecrRefCount(context.data.eval.path); - context.data.eval.path = NULL; - } - } - - return Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags, - typePtr, clientData); -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOMakeProcMethod -- - * - * The guts of the code to make a procedure-like method for a class. - * Split apart so that it is easier for other extensions to reuse (in - * particular, it frees them from having to pry so deeply into Tcl's - * guts). - * - * ---------------------------------------------------------------------- - */ - -Tcl_Method -TclOOMakeProcMethod( - Tcl_Interp *interp, /* The interpreter containing the class. */ - Class *clsPtr, /* The class to modify. */ - int flags, /* Whether this is a public method. */ - Tcl_Obj *nameObj, /* The name of the method, which may be NULL; - * if so, up to caller to manage storage - * (e.g., because it is a constructor or - * destructor). */ - const char *namePtr, /* The name of the method as a string, which - * _must not_ be NULL. */ - Tcl_Obj *argsObj, /* The formal argument list for the method, - * which _must not_ be NULL. */ - Tcl_Obj *bodyObj, /* The body of the method, which _must not_ be - * NULL. */ - const Tcl_MethodType *typePtr, - /* The type of the method to create. */ - void *clientData, /* The per-method type-specific data. */ - Proc **procPtrPtr) /* A pointer to the variable in which to write - * the procedure record reference. Presumably - * inside the structure indicated by the - * pointer in clientData. */ -{ - Interp *iPtr = (Interp *) interp; - Proc *procPtr; - - if (TclCreateProc(interp, NULL, namePtr, argsObj, bodyObj, - procPtrPtr) != TCL_OK) { - return NULL; - } - procPtr = *procPtrPtr; - procPtr->cmdPtr = NULL; - - if (iPtr->cmdFramePtr) { - CmdFrame context = *iPtr->cmdFramePtr; - - if (context.type == TCL_LOCATION_BC) { - /* - * Retrieve source information from the bytecode, if possible. If - * the information is retrieved successfully, context.type will be - * TCL_LOCATION_SOURCE and the reference held by - * context.data.eval.path will be counted. - */ - - TclGetSrcInfoForPc(&context); - } else if (context.type == TCL_LOCATION_SOURCE) { - /* - * The copy into 'context' up above has created another reference - * to 'context.data.eval.path'; account for it. - */ - - Tcl_IncrRefCount(context.data.eval.path); - } - - if (context.type == TCL_LOCATION_SOURCE) { - /* - * We can account for source location within a proc only if the - * proc body was not created by substitution. - * (FIXME: check that this is sane and correct!) - */ - - if (context.line - && (context.nline >= 4) && (context.line[3] >= 0)) { - int isNew; - CmdFrame *cfPtr = (CmdFrame *)Tcl_Alloc(sizeof(CmdFrame)); - Tcl_HashEntry *hPtr; - - cfPtr->level = -1; - cfPtr->type = context.type; - cfPtr->line = (int *)Tcl_Alloc(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); - - cfPtr->cmd = NULL; - cfPtr->len = 0; - - hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, - (char *) procPtr, &isNew); - Tcl_SetHashValue(hPtr, cfPtr); - } - - /* - * 'context' is going out of scope; account for the reference that - * it's holding to the path name. - */ - - Tcl_DecrRefCount(context.data.eval.path); - context.data.eval.path = NULL; - } - } - - return Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, typePtr, - clientData); -} - -/* - * ---------------------------------------------------------------------- - * - * InvokeProcedureMethod, PushMethodCallFrame -- - * - * How to invoke a procedure-like method. - * - * ---------------------------------------------------------------------- - */ - -static int -InvokeProcedureMethod( - void *clientData, /* Pointer to some per-method context. */ - Tcl_Interp *interp, - Tcl_ObjectContext context, /* The method calling context. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const *objv) /* Arguments as actually seen. */ -{ - ProcedureMethod *pmPtr = (ProcedureMethod *)clientData; - int result; - PMFrameData *fdPtr; /* Important data that has to have a lifetime - * matched by this function (or rather, by the - * call frame's lifetime). */ - - /* - * If the object namespace (or interpreter) were deleted, we just skip to - * the next thing in the chain. - */ - - if (TclOOObjectDestroyed(((CallContext *)context)->oPtr) || - Tcl_InterpDeleted(interp) - ) { - return TclNRObjectContextInvokeNext(interp, context, objc, objv, - Tcl_ObjectContextSkippedArgs(context)); - } - - /* - * 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); - if (result != TCL_OK) { - TclStackFree(interp, fdPtr); - return result; - } - pmPtr->refCount++; - - /* - * Give the pre-call callback a chance to do some setup and, possibly, - * veto the call. - */ - - if (pmPtr->preCallProc != NULL) { - int isFinished; - - result = pmPtr->preCallProc(pmPtr->clientData, interp, context, - (Tcl_CallFrame *) fdPtr->framePtr, &isFinished); - if (isFinished || result != TCL_OK) { - /* - * Restore the old cmdPtr so that a subsequent use of [info frame] - * won't crash on us. [Bug 3001438] - */ - - pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr; - - Tcl_PopCallFrame(interp); - TclStackFree(interp, fdPtr->framePtr); - if (pmPtr->refCount-- <= 1) { - DeleteProcedureMethodRecord(pmPtr); - } - TclStackFree(interp, fdPtr); - return result; - } - } - - /* - * Now invoke the body of the method. - */ - - TclNRAddCallback(interp, FinalizePMCall, pmPtr, context, fdPtr, NULL); - return TclNRInterpProcCore(interp, fdPtr->nameObj, - Tcl_ObjectContextSkippedArgs(context), fdPtr->errProc); -} - -static int -FinalizePMCall( - void *data[], - Tcl_Interp *interp, - int result) -{ - ProcedureMethod *pmPtr = (ProcedureMethod *)data[0]; - Tcl_ObjectContext context = (Tcl_ObjectContext)data[1]; - PMFrameData *fdPtr = (PMFrameData *)data[2]; - - /* - * Give the post-call callback a chance to do some cleanup. Note that at - * this point the call frame itself is invalid; it's already been popped. - */ - - if (pmPtr->postCallProc) { - result = pmPtr->postCallProc(pmPtr->clientData, interp, context, - Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)), - result); - } - - /* - * Restore the old cmdPtr so that a subsequent use of [info frame] won't - * crash on us. [Bug 3001438] - */ - - pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr; - - /* - * Scrap the special frame data now that we're done with it. Note that we - * are inlining DeleteProcedureMethod() here; this location is highly - * sensitive when it comes to performance! - */ - - if (pmPtr->refCount-- <= 1) { - DeleteProcedureMethodRecord(pmPtr); - } - TclStackFree(interp, fdPtr); - return result; -} - -static int -PushMethodCallFrame( - Tcl_Interp *interp, /* Current interpreter. */ - CallContext *contextPtr, /* Current method call context. */ - ProcedureMethod *pmPtr, /* Information about this procedure-like - * 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. - */ - - if (contextPtr->callPtr->flags & CONSTRUCTOR) { - namePtr = ""; - fdPtr->nameObj = contextPtr->oPtr->fPtr->constructorName; - fdPtr->errProc = ConstructorErrorHandler; - } else if (contextPtr->callPtr->flags & DESTRUCTOR) { - namePtr = ""; - fdPtr->nameObj = contextPtr->oPtr->fPtr->destructorName; - fdPtr->errProc = DestructorErrorHandler; - } else { - fdPtr->nameObj = Tcl_MethodName( - Tcl_ObjectContextMethod((Tcl_ObjectContext) contextPtr)); - namePtr = TclGetString(fdPtr->nameObj); - fdPtr->errProc = MethodErrorHandler; - } - if (pmPtr->errProc != NULL) { - fdPtr->errProc = pmPtr->errProc; - } - - /* - * Magic to enable things like [incr Tcl], which wants methods to run in - * their class's namespace. - */ - - if (pmPtr->flags & USE_DECLARER_NS) { - Method *mPtr = - contextPtr->callPtr->chain[contextPtr->index].mPtr; - - if (mPtr->declaringClassPtr != NULL) { - nsPtr = (Namespace *) - mPtr->declaringClassPtr->thisPtr->namespacePtr; - } else { - nsPtr = (Namespace *) mPtr->declaringObjectPtr->namespacePtr; - } - } - - /* - * Save the old cmdPtr so that when this recursive call returns, we can - * restore it. To do otherwise causes crashes in [info frame] after we - * return from a recursive call. [Bug 3001438] - */ - - fdPtr->oldCmdPtr = pmPtr->procPtr->cmdPtr; - - /* - * Compile the body. This operation may fail. - */ - - fdPtr->efi.length = 2; - memset(&fdPtr->cmd, 0, sizeof(Command)); - fdPtr->cmd.nsPtr = nsPtr; - fdPtr->cmd.clientData = &fdPtr->efi; - pmPtr->procPtr->cmdPtr = &fdPtr->cmd; - - /* - * [Bug 2037727] Always call TclProcCompileProc so that we check not only - * that we have bytecode, but also that it remains valid. Note that we set - * the namespace of the code here directly; this is a hack, but the - * alternative is *so* slow... - */ - - ByteCodeGetIntRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, codePtr); - if (codePtr) { - codePtr->nsPtr = nsPtr; - } - result = TclProcCompileProc(interp, pmPtr->procPtr, - pmPtr->procPtr->bodyPtr, nsPtr, "body of method", namePtr); - if (result != TCL_OK) { - goto failureReturn; - } - - /* - * Make the stack frame and fill it out with information about this call. - * This operation may fail. - */ - - (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, - (Tcl_Namespace *) nsPtr, FRAME_IS_PROC|FRAME_IS_METHOD); - - fdPtr->framePtr->clientData = contextPtr; - fdPtr->framePtr->objc = objc; - fdPtr->framePtr->objv = objv; - fdPtr->framePtr->procPtr = pmPtr->procPtr; - - /* - * Finish filling out the extra frame info so that [info frame] works. - */ - - fdPtr->efi.fields[0].name = "method"; - 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"; - } - fdPtr->efi.fields[1].proc = RenderDeclarerName; - fdPtr->efi.fields[1].clientData = &fdPtr->pni; - fdPtr->pni.interp = interp; - fdPtr->pni.method = method; - } - - return TCL_OK; - - /* - * Restore the old cmdPtr so that a subsequent use of [info frame] won't - * crash on us. [Bug 3001438] - */ - - failureReturn: - pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr; - return result; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOSetupVariableResolver, etc. -- - * - * Variable resolution engine used to connect declared variables to local - * variables used in methods. The compiled variable resolver is more - * important, but both are needed as it is possible to have a variable - * that is only referred to in ways that aren't compilable and we can't - * force LVT presence. [TIP #320, #500] - * - * ---------------------------------------------------------------------- - */ - -void -TclOOSetupVariableResolver( - Tcl_Namespace *nsPtr) -{ - Tcl_ResolverInfo info; - - Tcl_GetNamespaceResolvers(nsPtr, &info); - if (info.compiledVarResProc == NULL) { - Tcl_SetNamespaceResolvers(nsPtr, NULL, ProcedureMethodVarResolver, - ProcedureMethodCompiledVarResolver); - } -} - -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); - - if (result != TCL_OK) { - return result; - } - - *varPtr = rPtr->fetchProc(interp, rPtr); - - /* - * Must not retain reference to resolved information. [Bug 3105999] - */ - - rPtr->deleteProc(rPtr); - return (*varPtr ? TCL_OK : TCL_CONTINUE); -} - -static Tcl_Var -ProcedureMethodCompiledVarConnect( - Tcl_Interp *interp, - Tcl_ResolvedVarInfo *rPtr) -{ - 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; - size_t 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) { - return infoPtr->cachedObjectVar; - } - - /* - * Check if the variable is one we want to resolve at all (i.e. whether it - * is in the list provided by the user). If not, we mustn't do anything - * either. - */ - - varName = TclGetStringFromObj(infoPtr->variableObj, &varLen); - if (contextPtr->callPtr->chain[contextPtr->index] - .mPtr->declaringClassPtr != NULL) { - FOREACH_STRUCT(privateVar, contextPtr->callPtr->chain[contextPtr->index] - .mPtr->declaringClassPtr->privateVariables) { - match = TclGetStringFromObj(privateVar->variableObj, &len); - if ((len == varLen) && !memcmp(match, varName, len)) { - variableObj = privateVar->fullNameObj; - cacheIt = 0; - goto gotMatch; - } - } - FOREACH(variableObj, contextPtr->callPtr->chain[contextPtr->index] - .mPtr->declaringClassPtr->variables) { - match = TclGetStringFromObj(variableObj, &len); - if ((len == varLen) && !memcmp(match, varName, len)) { - cacheIt = 0; - goto gotMatch; - } - } - } else { - FOREACH_STRUCT(privateVar, contextPtr->oPtr->privateVariables) { - match = TclGetStringFromObj(privateVar->variableObj, &len); - if ((len == varLen) && !memcmp(match, varName, len)) { - variableObj = privateVar->fullNameObj; - cacheIt = 1; - goto gotMatch; - } - } - FOREACH(variableObj, contextPtr->oPtr->variables) { - match = TclGetStringFromObj(variableObj, &len); - if ((len == varLen) && !memcmp(match, varName, len)) { - cacheIt = 1; - goto gotMatch; - } - } - } - return NULL; - - /* - * It is a variable we want to resolve, so resolve it. - */ - - gotMatch: - hPtr = Tcl_CreateHashEntry(TclVarTable(contextPtr->oPtr->namespacePtr), - (char *) variableObj, &isNew); - if (isNew) { - TclSetVarNamespaceVar((Var *) TclVarHashGetValue(hPtr)); - } - if (cacheIt) { - infoPtr->cachedObjectVar = TclVarHashGetValue(hPtr); - - /* - * We must keep a reference to the variable so everything will - * continue to work correctly even if it is unset; being unset does - * not end the life of the variable at this level. [Bug 3185009] - */ - - VarHashRefCount(infoPtr->cachedObjectVar)++; - } - return TclVarHashGetValue(hPtr); -} - -static void -ProcedureMethodCompiledVarDelete( - Tcl_ResolvedVarInfo *rPtr) -{ - OOResVarInfo *infoPtr = (OOResVarInfo *) rPtr; - - /* - * Release the reference to the variable if we were holding it. - */ - - if (infoPtr->cachedObjectVar) { - VarHashRefCount(infoPtr->cachedObjectVar)--; - TclCleanupVar((Var *) infoPtr->cachedObjectVar, NULL); - } - Tcl_DecrRefCount(infoPtr->variableObj); - Tcl_Free(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(TclGetString(variableObj), "::") != NULL || - Tcl_StringMatch(TclGetString(variableObj), "*(*)")) { - Tcl_DecrRefCount(variableObj); - return TCL_CONTINUE; - } - - infoPtr = (OOResVarInfo *)Tcl_Alloc(sizeof(OOResVarInfo)); - infoPtr->info.fetchProc = ProcedureMethodCompiledVarConnect; - infoPtr->info.deleteProc = ProcedureMethodCompiledVarDelete; - infoPtr->cachedObjectVar = NULL; - infoPtr->variableObj = variableObj; - Tcl_IncrRefCount(variableObj); - *rPtrPtr = &infoPtr->info; - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * RenderDeclarerName -- - * - * Returns the name of the entity (object or class) which declared a - * method. Used for producing information for [info frame] in such a way - * that the expensive part of this (generating the object or class name - * itself) isn't done until it is needed. - * - * ---------------------------------------------------------------------- - */ - -static Tcl_Obj * -RenderDeclarerName( - void *clientData) -{ - 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); -} - -/* - * ---------------------------------------------------------------------- - * - * MethodErrorHandler, ConstructorErrorHandler, DestructorErrorHandler -- - * - * How to fill in the stack trace correctly upon error in various forms - * of procedure-like methods. LIMIT is how long the inserted strings in - * the error traces should get before being converted to have ellipses, - * and ELLIPSIFY is a macro to do the conversion (with the help of a - * %.*s%s format field). Note that ELLIPSIFY is only safe for use in - * suitable formatting contexts. - * - * ---------------------------------------------------------------------- - */ - -/* TODO: Check whether Tcl_AppendLimitedToObj() can work here. */ - -#define LIMIT 60 -#define ELLIPSIFY(str,len) \ - ((len) > LIMIT ? LIMIT : (int)(len)), (str), ((len) > LIMIT ? "..." : "") - -static void -MethodErrorHandler( - Tcl_Interp *interp, - TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/) - /* We pull the method name out of context instead of from argument */ -{ - size_t 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 = TclGetStringFromObj(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; - size_t 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 = TclGetStringFromObj(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; - size_t 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 = TclGetStringFromObj(TclOOObjectName(interp, declarerPtr), - &objectNameLen); - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (%s \"%.*s%s\" destructor line %d)", kindName, - ELLIPSIFY(objectName, objectNameLen), Tcl_GetErrorLine(interp))); -} - -/* - * ---------------------------------------------------------------------- - * - * DeleteProcedureMethod, CloneProcedureMethod -- - * - * How to delete and clone procedure-like methods. - * - * ---------------------------------------------------------------------- - */ - -static void -DeleteProcedureMethodRecord( - ProcedureMethod *pmPtr) -{ - TclProcDeleteProc(pmPtr->procPtr); - if (pmPtr->deleteClientdataProc) { - pmPtr->deleteClientdataProc(pmPtr->clientData); - } - Tcl_Free(pmPtr); -} - -static void -DeleteProcedureMethod( - void *clientData) -{ - ProcedureMethod *pmPtr = (ProcedureMethod *)clientData; - - if (pmPtr->refCount-- <= 1) { - DeleteProcedureMethodRecord(pmPtr); - } -} - -static int -CloneProcedureMethod( - Tcl_Interp *interp, - void *clientData, - void **newClientData) -{ - ProcedureMethod *pmPtr = (ProcedureMethod *)clientData; - ProcedureMethod *pm2Ptr; - Tcl_Obj *bodyObj, *argsObj; - CompiledLocal *localPtr; - - /* - * Copy the argument list. - */ - - TclNewObj(argsObj); - for (localPtr=pmPtr->procPtr->firstLocalPtr; localPtr!=NULL; - localPtr=localPtr->nextPtr) { - if (TclIsVarArgument(localPtr)) { - Tcl_Obj *argObj; - - TclNewObj(argObj); - Tcl_ListObjAppendElement(NULL, argObj, - Tcl_NewStringObj(localPtr->name, -1)); - if (localPtr->defValuePtr != NULL) { - Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); - } - Tcl_ListObjAppendElement(NULL, argsObj, argObj); - } - } - - /* - * 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); - TclGetString(bodyObj); - Tcl_StoreIntRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, NULL); - - /* - * Create the actual copy of the method record, manufacturing a new proc - * record. - */ - - pm2Ptr = (ProcedureMethod *)Tcl_Alloc(sizeof(ProcedureMethod)); - memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod)); - pm2Ptr->refCount = 1; - Tcl_IncrRefCount(argsObj); - Tcl_IncrRefCount(bodyObj); - if (TclCreateProc(interp, NULL, "", argsObj, bodyObj, - &pm2Ptr->procPtr) != TCL_OK) { - Tcl_DecrRefCount(argsObj); - Tcl_DecrRefCount(bodyObj); - Tcl_Free(pm2Ptr); - return TCL_ERROR; - } - Tcl_DecrRefCount(argsObj); - Tcl_DecrRefCount(bodyObj); - - if (pmPtr->cloneClientdataProc) { - pm2Ptr->clientData = pmPtr->cloneClientdataProc(pmPtr->clientData); - } - *newClientData = pm2Ptr; - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOONewForwardInstanceMethod -- - * - * Create a forwarded method for an object. - * - * ---------------------------------------------------------------------- - */ - -Method * -TclOONewForwardInstanceMethod( - Tcl_Interp *interp, /* Interpreter for error reporting. */ - 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 *)Tcl_Alloc(sizeof(ForwardMethod)); - fmPtr->prefixObj = prefixObj; - Tcl_IncrRefCount(prefixObj); - return (Method *) Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, - nameObj, flags, &fwdMethodType, fmPtr); -} - -/* - * ---------------------------------------------------------------------- - * - * TclOONewForwardMethod -- - * - * Create a new forwarded method for a class. - * - * ---------------------------------------------------------------------- - */ - -Method * -TclOONewForwardMethod( - Tcl_Interp *interp, /* Interpreter for error reporting. */ - 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 *)Tcl_Alloc(sizeof(ForwardMethod)); - fmPtr->prefixObj = prefixObj; - Tcl_IncrRefCount(prefixObj); - return (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj, - flags, &fwdMethodType, fmPtr); -} - -/* - * ---------------------------------------------------------------------- - * - * InvokeForwardMethod -- - * - * How to invoke a forwarded method. Works by doing some ensemble-like - * command rearranging and then invokes some other Tcl command. - * - * ---------------------------------------------------------------------- - */ - -static int -InvokeForwardMethod( - void *clientData, /* Pointer to some per-method context. */ - Tcl_Interp *interp, - Tcl_ObjectContext context, /* The method calling context. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const *objv) /* Arguments as actually seen. */ -{ - CallContext *contextPtr = (CallContext *) context; - ForwardMethod *fmPtr = (ForwardMethod *)clientData; - Tcl_Obj **argObjs, **prefixObjs; - 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 - * can ignore here. - */ - - Tcl_ListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs); - argObjs = InitEnsembleRewrite(interp, objc, objv, skip, - numPrefixes, prefixObjs, &len); - Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL); - /* - * NOTE: The combination of direct set of iPtr->lookupNsPtr and the use - * of the TCL_EVAL_NOERR flag results in an evaluation configuration - * very much like TCL_EVAL_INVOKE. - */ - ((Interp *)interp)->lookupNsPtr - = (Namespace *) contextPtr->oPtr->namespacePtr; - return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_NOERR, NULL); -} - -static int -FinalizeForwardCall( - void *data[], - Tcl_Interp *interp, - int result) -{ - Tcl_Obj **argObjs = (Tcl_Obj **)data[0]; - - TclStackFree(interp, argObjs); - return result; -} - -/* - * ---------------------------------------------------------------------- - * - * DeleteForwardMethod, CloneForwardMethod -- - * - * How to delete and clone forwarded methods. - * - * ---------------------------------------------------------------------- - */ - -static void -DeleteForwardMethod( - void *clientData) -{ - ForwardMethod *fmPtr = (ForwardMethod *)clientData; - - Tcl_DecrRefCount(fmPtr->prefixObj); - Tcl_Free(fmPtr); -} - -static int -CloneForwardMethod( - TCL_UNUSED(Tcl_Interp *), - void *clientData, - void **newClientData) -{ - ForwardMethod *fmPtr = (ForwardMethod *)clientData; - ForwardMethod *fm2Ptr = (ForwardMethod *)Tcl_Alloc(sizeof(ForwardMethod)); - - fm2Ptr->prefixObj = fmPtr->prefixObj; - Tcl_IncrRefCount(fm2Ptr->prefixObj); - *newClientData = fm2Ptr; - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOGetProcFromMethod, TclOOGetFwdFromMethod -- - * - * Utility functions used for procedure-like and forwarding method - * introspection. - * - * ---------------------------------------------------------------------- - */ - -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; -} - -/* - * ---------------------------------------------------------------------- - * - * InitEnsembleRewrite -- - * - * Utility function that wraps up a lot of the complexity involved in - * doing ensemble-like command forwarding. Here is a picture of memory - * management plan: - * - * <-----------------objc----------------------> - * objv: |=============|===============================| - * <-toRewrite-> | - * \ - * <-rewriteLength-> \ - * rewriteObjs: |=================| \ - * | | - * V V - * argObjs: |=================|===============================| - * <------------------*lengthPtr-------------------> - * - * ---------------------------------------------------------------------- - */ - -static Tcl_Obj ** -InitEnsembleRewrite( - Tcl_Interp *interp, /* Place to log the rewrite info. */ - int objc, /* Number of real arguments. */ - Tcl_Obj *const *objv, /* The real arguments. */ - 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 - * Tcl_WrongNumArgs() can rewrite its result appropriately. The rules for - * how to store the rewrite rules get complex solely because of the case - * where an ensemble rewrites itself out of the picture; when that - * happens, the quality of the error message rewrite falls drastically - * (and unavoidably). - */ - - if (TclInitRewriteEnsemble(interp, toRewrite, rewriteLength, objv)) { - TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); - } - *lengthPtr = len; - return argObjs; -} - -/* - * ---------------------------------------------------------------------- - * - * assorted trivial 'getter' functions - * - * ---------------------------------------------------------------------- - */ - -Tcl_Object -Tcl_MethodDeclarerObject( - Tcl_Method method) -{ - return (Tcl_Object) ((Method *) method)->declaringObjectPtr; -} - -Tcl_Class -Tcl_MethodDeclarerClass( - Tcl_Method method) -{ - return (Tcl_Class) ((Method *) method)->declaringClassPtr; -} - -Tcl_Obj * -Tcl_MethodName( - Tcl_Method method) -{ - return ((Method *) method)->namePtr; -} - -int -Tcl_MethodIsType( - Tcl_Method method, - const Tcl_MethodType *typePtr, - void **clientDataPtr) -{ - Method *mPtr = (Method *) method; - - if (mPtr->typePtr == typePtr) { - if (clientDataPtr != NULL) { - *clientDataPtr = mPtr->clientData; - } - return 1; - } - return 0; -} - -int -Tcl_MethodIsPublic( - Tcl_Method method) -{ - return (((Method *)method)->flags & PUBLIC_METHOD) ? 1 : 0; -} - -int -Tcl_MethodIsPrivate( - Tcl_Method method) -{ - return (((Method *)method)->flags & TRUE_PRIVATE_METHOD) ? 1 : 0; -} - -/* - * Extended method construction for itcl-ng. - */ - -Tcl_Method -TclOONewProcInstanceMethodEx( - Tcl_Interp *interp, /* The interpreter containing the object. */ - Tcl_Object oPtr, /* The object to modify. */ - TclOO_PreCallProc *preCallPtr, - TclOO_PostCallProc *postCallPtr, - ProcErrorProc *errProc, - void *clientData, - Tcl_Obj *nameObj, /* The name of the method, which must not be - * NULL. */ - Tcl_Obj *argsObj, /* The formal argument list for the method, - * which must not be NULL. */ - Tcl_Obj *bodyObj, /* The body of the method, which must not be - * NULL. */ - int flags, /* Whether this is a public method. */ - void **internalTokenPtr) /* If non-NULL, points to a variable that gets - * the reference to the ProcedureMethod - * structure. */ -{ - ProcedureMethod *pmPtr; - Tcl_Method method = (Tcl_Method) TclOONewProcInstanceMethod(interp, - (Object *) oPtr, flags, nameObj, argsObj, bodyObj, &pmPtr); - - if (method == NULL) { - return NULL; - } - pmPtr->flags = flags & USE_DECLARER_NS; - pmPtr->preCallProc = preCallPtr; - pmPtr->postCallProc = postCallPtr; - pmPtr->errProc = errProc; - pmPtr->clientData = clientData; - if (internalTokenPtr != NULL) { - *internalTokenPtr = pmPtr; - } - return method; -} - -Tcl_Method -TclOONewProcMethodEx( - Tcl_Interp *interp, /* The interpreter containing the class. */ - Tcl_Class clsPtr, /* The class to modify. */ - TclOO_PreCallProc *preCallPtr, - TclOO_PostCallProc *postCallPtr, - ProcErrorProc *errProc, - void *clientData, - Tcl_Obj *nameObj, /* The name of the method, which may be NULL; - * if so, up to caller to manage storage - * (e.g., because it is a constructor or - * destructor). */ - Tcl_Obj *argsObj, /* The formal argument list for the method, - * which may be NULL; if so, it is equivalent - * to an empty list. */ - Tcl_Obj *bodyObj, /* The body of the method, which must not be - * NULL. */ - int flags, /* Whether this is a public method. */ - void **internalTokenPtr) /* If non-NULL, points to a variable that gets - * the reference to the ProcedureMethod - * structure. */ -{ - ProcedureMethod *pmPtr; - Tcl_Method method = (Tcl_Method) TclOONewProcMethod(interp, - (Class *) clsPtr, flags, nameObj, argsObj, bodyObj, &pmPtr); - - if (method == NULL) { - return NULL; - } - pmPtr->flags = flags & USE_DECLARER_NS; - pmPtr->preCallProc = preCallPtr; - pmPtr->postCallProc = postCallPtr; - pmPtr->errProc = errProc; - pmPtr->clientData = clientData; - if (internalTokenPtr != NULL) { - *internalTokenPtr = pmPtr; - } - return method; -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ DELETED generic/tclOOScript.h Index: generic/tclOOScript.h ================================================================== --- generic/tclOOScript.h +++ /dev/null @@ -1,263 +0,0 @@ -/* - * 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. - */ - -#ifndef TCL_OO_SCRIPT_H -#define TCL_OO_SCRIPT_H - -/* - * The scripted part of the definitions of TclOO. - * - * Compiled from generic/tclOOScript.tcl by tools/makeHeader.tcl, which - * contains the commented version of everything; *this* file is automatically - * generated. - */ - -static const char *tclOOSetupScript = -/* !BEGIN!: Do not edit below this line. */ -"::namespace eval ::oo {\n" -"\t::namespace path {}\n" -"\tnamespace eval Helpers {\n" -"\t\t::namespace path {}\n" -"\t\tproc callback {method args} {\n" -"\t\t\tlist [uplevel 1 {::namespace which my}] $method {*}$args\n" -"\t\t}\n" -"\t\tnamespace export callback\n" -"\t\tnamespace eval tmp {namespace import ::oo::Helpers::callback}\n" -"\t\tnamespace export -clear\n" -"\t\trename tmp::callback mymethod\n" -"\t\tnamespace delete tmp\n" -"\t\tproc classvariable {name args} {\n" -"\t\t\tset ns [info object namespace [uplevel 1 {self class}]]\n" -"\t\t\tforeach v [list $name {*}$args] {\n" -"\t\t\t\tif {[string match *(*) $v]} {\n" -"\t\t\t\t\tset reason \"can\'t create a scalar variable that looks like an array element\"\n" -"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \\\n" -"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n" -"\t\t\t\t}\n" -"\t\t\t\tif {[string match *::* $v]} {\n" -"\t\t\t\t\tset reason \"can\'t create a local variable with a namespace separator in it\"\n" -"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR INVERTED} \\\n" -"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n" -"\t\t\t\t}\n" -"\t\t\t\tlappend vs $v $v\n" -"\t\t\t}\n" -"\t\t\ttailcall namespace upvar $ns {*}$vs\n" -"\t\t}\n" -"\t\tproc link {args} {\n" -"\t\t\tset ns [uplevel 1 {::namespace current}]\n" -"\t\t\tforeach link $args {\n" -"\t\t\t\tif {[llength $link] == 2} {\n" -"\t\t\t\t\tlassign $link src dst\n" -"\t\t\t\t} elseif {[llength $link] == 1} {\n" -"\t\t\t\t\tlassign $link src\n" -"\t\t\t\t\tset dst $src\n" -"\t\t\t\t} else {\n" -"\t\t\t\t\treturn -code error -errorcode {TCLOO CMDLINK FORMAT} \\\n" -"\t\t\t\t\t\t\"bad link description; must only have one or two elements\"\n" -"\t\t\t\t}\n" -"\t\t\t\tif {![string match ::* $src]} {\n" -"\t\t\t\t\tset src [string cat $ns :: $src]\n" -"\t\t\t\t}\n" -"\t\t\t\tinterp alias {} $src {} ${ns}::my $dst\n" -"\t\t\t\ttrace add command ${ns}::my delete [list \\\n" -"\t\t\t\t\t::oo::UnlinkLinkedCommand $src]\n" -"\t\t\t}\n" -"\t\t\treturn\n" -"\t\t}\n" -"\t}\n" -"\tproc UnlinkLinkedCommand {cmd args} {\n" -"\t\tif {[namespace which $cmd] ne {}} {\n" -"\t\t\trename $cmd {}\n" -"\t\t}\n" -"\t}\n" -"\tproc DelegateName {class} {\n" -"\t\tstring cat [info object namespace $class] {:: oo ::delegate}\n" -"\t}\n" -"\tproc MixinClassDelegates {class} {\n" -"\t\tif {![info object isa class $class]} {\n" -"\t\t\treturn\n" -"\t\t}\n" -"\t\tset delegate [DelegateName $class]\n" -"\t\tif {![info object isa class $delegate]} {\n" -"\t\t\treturn\n" -"\t\t}\n" -"\t\tforeach c [info class superclass $class] {\n" -"\t\t\tset d [DelegateName $c]\n" -"\t\t\tif {![info object isa class $d]} {\n" -"\t\t\t\tcontinue\n" -"\t\t\t}\n" -"\t\t\tdefine $delegate ::oo::define::superclass -append $d\n" -"\t\t}\n" -"\t\tobjdefine $class ::oo::objdefine::mixin -append $delegate\n" -"\t}\n" -"\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n" -"\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" -"\t\t::if {$argc == 3} {\n" -"\t\t\t::return -code error -errorcode {TCL WRONGARGS} [::format \\\n" -"\t\t\t\t{wrong # args: should be \"%s name \?args body\?\"} \\\n" -"\t\t\t\t[::lindex [::info level 0] 0]]\n" -"\t\t}\n" -"\t\t::set cls [::uplevel 1 self]\n" -"\t\t::if {$argc == 4} {\n" -"\t\t\t::oo::define [::oo::DelegateName $cls] method $name $args $body\n" -"\t\t}\n" -"\t\t::tailcall forward $name myclass $name\n" -"\t}\n" -"\tproc define::initialise {body} {\n" -"\t\t::set clsns [::info object namespace [::uplevel 1 self]]\n" -"\t\t::tailcall apply [::list {} $body $clsns]\n" -"\t}\n" -"\tnamespace eval define {\n" -"\t\t::namespace export initialise\n" -"\t\t::namespace eval tmp {::namespace import ::oo::define::initialise}\n" -"\t\t::namespace export -clear\n" -"\t\t::rename tmp::initialise initialize\n" -"\t\t::namespace delete tmp\n" -"\t}\n" -"\tdefine Slot {\n" -"\t\tmethod Get {} {\n" -"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n" -"\t\t}\n" -"\t\tmethod Set list {\n" -"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n" -"\t\t}\n" -"\t\tmethod Resolve list {\n" -"\t\t\treturn $list\n" -"\t\t}\n" -"\t\tmethod -set args {\n" -"\t\t\tset my [namespace which my]\n" -"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" -"\t\t\ttailcall my Set $args\n" -"\t\t}\n" -"\t\tmethod -append args {\n" -"\t\t\tset my [namespace which my]\n" -"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" -"\t\t\tset current [uplevel 1 [list $my Get]]\n" -"\t\t\ttailcall my Set [list {*}$current {*}$args]\n" -"\t\t}\n" -"\t\tmethod -clear {} {tailcall my Set {}}\n" -"\t\tmethod -prepend args {\n" -"\t\t\tset my [namespace which my]\n" -"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" -"\t\t\tset current [uplevel 1 [list $my Get]]\n" -"\t\t\ttailcall my Set [list {*}$args {*}$current]\n" -"\t\t}\n" -"\t\tmethod -remove args {\n" -"\t\t\tset my [namespace which my]\n" -"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" -"\t\t\tset current [uplevel 1 [list $my Get]]\n" -"\t\t\ttailcall my Set [lmap val $current {\n" -"\t\t\t\tif {$val in $args} continue else {set val}\n" -"\t\t\t}]\n" -"\t\t}\n" -"\t\tforward --default-operation my -append\n" -"\t\tmethod unknown {args} {\n" -"\t\t\tset def --default-operation\n" -"\t\t\tif {[llength $args] == 0} {\n" -"\t\t\t\ttailcall my $def\n" -"\t\t\t} elseif {![string match -* [lindex $args 0]]} {\n" -"\t\t\t\ttailcall my $def {*}$args\n" -"\t\t\t}\n" -"\t\t\tnext {*}$args\n" -"\t\t}\n" -"\t\texport -set -append -clear -prepend -remove\n" -"\t\tunexport unknown destroy\n" -"\t}\n" -"\tobjdefine define::superclass forward --default-operation my -set\n" -"\tobjdefine define::mixin forward --default-operation my -set\n" -"\tobjdefine objdefine::mixin forward --default-operation my -set\n" -"\tdefine object method {originObject} {\n" -"\t\tforeach p [info procs [info object namespace $originObject]::*] {\n" -"\t\t\tset args [info args $p]\n" -"\t\t\tset idx -1\n" -"\t\t\tforeach a $args {\n" -"\t\t\t\tif {[info default $p $a d]} {\n" -"\t\t\t\t\tlset args [incr idx] [list $a $d]\n" -"\t\t\t\t} else {\n" -"\t\t\t\t\tlset args [incr idx] [list $a]\n" -"\t\t\t\t}\n" -"\t\t\t}\n" -"\t\t\tset b [info body $p]\n" -"\t\t\tset p [namespace tail $p]\n" -"\t\t\tproc $p $args $b\n" -"\t\t}\n" -"\t\tforeach v [info vars [info object namespace $originObject]::*] {\n" -"\t\t\tupvar 0 $v vOrigin\n" -"\t\t\tnamespace upvar [namespace current] [namespace tail $v] vNew\n" -"\t\t\tif {[info exists vOrigin]} {\n" -"\t\t\t\tif {[array exists vOrigin]} {\n" -"\t\t\t\t\tarray set vNew [array get vOrigin]\n" -"\t\t\t\t} else {\n" -"\t\t\t\t\tset vNew $vOrigin\n" -"\t\t\t\t}\n" -"\t\t\t}\n" -"\t\t}\n" -"\t}\n" -"\tdefine class method {originObject} {\n" -"\t\tnext $originObject\n" -"\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n" -"\t}\n" -"\tclass create singleton {\n" -"\t\tsuperclass class\n" -"\t\tvariable object\n" -"\t\tunexport create createWithNamespace\n" -"\t\tmethod new args {\n" -"\t\t\tif {![info exists object] || ![info object isa object $object]} {\n" -"\t\t\t\tset object [next {*}$args]\n" -"\t\t\t\t::oo::objdefine $object {\n" -"\t\t\t\t\tmethod destroy {} {\n" -"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n" -"\t\t\t\t\t\t\t\"may not destroy a singleton object\"\n" -"\t\t\t\t\t}\n" -"\t\t\t\t\tmethod {originObject} {\n" -"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n" -"\t\t\t\t\t\t\t\"may not clone a singleton object\"\n" -"\t\t\t\t\t}\n" -"\t\t\t\t}\n" -"\t\t\t}\n" -"\t\t\treturn $object\n" -"\t\t}\n" -"\t}\n" -"\tclass create abstract {\n" -"\t\tsuperclass class\n" -"\t\tunexport create createWithNamespace new\n" -"\t}\n" -"}\n" -/* !END!: Do not edit above this line. */ -; - -#endif /* TCL_OO_SCRIPT_H */ - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ DELETED generic/tclOOStubInit.c Index: generic/tclOOStubInit.c ================================================================== --- generic/tclOOStubInit.c +++ /dev/null @@ -1,79 +0,0 @@ -/* - * This file is (mostly) automatically generated from tclOO.decls. - * It is compiled and linked in with the tclOO package proper. - */ - -#ifdef HAVE_CONFIG_H -#include "config.h" -#endif -#include "tclOOInt.h" - -MODULE_SCOPE const TclOOStubs tclOOStubs; - -#ifdef __GNUC__ -#pragma GCC dependency "tclOO.decls" -#endif - -/* !BEGIN!: Do not edit below this line. */ - -static const TclOOIntStubs tclOOIntStubs = { - TCL_STUB_MAGIC, - 0, - TclOOGetDefineCmdContext, /* 0 */ - TclOOMakeProcInstanceMethod, /* 1 */ - TclOOMakeProcMethod, /* 2 */ - TclOONewProcInstanceMethod, /* 3 */ - TclOONewProcMethod, /* 4 */ - TclOOObjectCmdCore, /* 5 */ - TclOOIsReachable, /* 6 */ - TclOONewForwardMethod, /* 7 */ - TclOONewForwardInstanceMethod, /* 8 */ - TclOONewProcInstanceMethodEx, /* 9 */ - TclOONewProcMethodEx, /* 10 */ - TclOOInvokeObject, /* 11 */ - TclOOObjectSetFilters, /* 12 */ - TclOOClassSetFilters, /* 13 */ - TclOOObjectSetMixins, /* 14 */ - TclOOClassSetMixins, /* 15 */ -}; - -static const TclOOStubHooks tclOOStubHooks = { - &tclOOIntStubs -}; - -const TclOOStubs tclOOStubs = { - TCL_STUB_MAGIC, - &tclOOStubHooks, - Tcl_CopyObjectInstance, /* 0 */ - Tcl_GetClassAsObject, /* 1 */ - Tcl_GetObjectAsClass, /* 2 */ - Tcl_GetObjectCommand, /* 3 */ - Tcl_GetObjectFromObj, /* 4 */ - Tcl_GetObjectNamespace, /* 5 */ - Tcl_MethodDeclarerClass, /* 6 */ - Tcl_MethodDeclarerObject, /* 7 */ - Tcl_MethodIsPublic, /* 8 */ - Tcl_MethodIsType, /* 9 */ - Tcl_MethodName, /* 10 */ - Tcl_NewInstanceMethod, /* 11 */ - Tcl_NewMethod, /* 12 */ - Tcl_NewObjectInstance, /* 13 */ - Tcl_ObjectDeleted, /* 14 */ - Tcl_ObjectContextIsFiltering, /* 15 */ - Tcl_ObjectContextMethod, /* 16 */ - Tcl_ObjectContextObject, /* 17 */ - Tcl_ObjectContextSkippedArgs, /* 18 */ - Tcl_ClassGetMetadata, /* 19 */ - Tcl_ClassSetMetadata, /* 20 */ - Tcl_ObjectGetMetadata, /* 21 */ - Tcl_ObjectSetMetadata, /* 22 */ - Tcl_ObjectContextInvokeNext, /* 23 */ - Tcl_ObjectGetMethodNameMapper, /* 24 */ - Tcl_ObjectSetMethodNameMapper, /* 25 */ - Tcl_ClassSetConstructor, /* 26 */ - Tcl_ClassSetDestructor, /* 27 */ - Tcl_GetObjectName, /* 28 */ - Tcl_MethodIsPrivate, /* 29 */ -}; - -/* !END!: Do not edit above this line. */ DELETED generic/tclOOStubLib.c Index: generic/tclOOStubLib.c ================================================================== --- generic/tclOOStubLib.c +++ /dev/null @@ -1,71 +0,0 @@ -/* - * ORIGINAL SOURCE: tk/generic/tkStubLib.c, version 1.9 2004/03/17 - */ - -#include "tclOOInt.h" - -MODULE_SCOPE const TclOOStubs *tclOOStubsPtr; -MODULE_SCOPE const TclOOIntStubs *tclOOIntStubsPtr; - -const TclOOStubs *tclOOStubsPtr = NULL; -const TclOOIntStubs *tclOOIntStubsPtr = NULL; - -/* - *---------------------------------------------------------------------- - * - * TclOOInitializeStubs -- - * Load the tclOO package, initialize stub table pointer. Do not call - * this function directly, use Tcl_OOInitStubs() macro instead. - * - * Results: - * The actual version of the package that satisfies the request, or NULL - * to indicate that an error occurred. - * - * Side effects: - * Sets the stub table pointers. - * - *---------------------------------------------------------------------- - */ - -#undef TclOOInitializeStubs - -MODULE_SCOPE const char * -TclOOInitializeStubs( - Tcl_Interp *interp, - const char *version) -{ - int exact = 0; - const char *packageName = "TclOO"; - const char *errMsg = NULL; - TclOOStubs *stubsPtr = NULL; - const char *actualVersion = tclStubsPtr->tcl_PkgRequireEx(interp, - packageName, version, exact, &stubsPtr); - - if (actualVersion == NULL) { - return NULL; - } - if (stubsPtr == NULL) { - errMsg = "missing stub table pointer"; - } else { - tclOOStubsPtr = stubsPtr; - if (stubsPtr->hooks) { - tclOOIntStubsPtr = stubsPtr->hooks->tclOOIntStubs; - } else { - tclOOIntStubsPtr = NULL; - } - return actualVersion; - } - tclStubsPtr->tcl_ResetResult(interp); - tclStubsPtr->tcl_AppendResult(interp, "Error loading ", packageName, - " (requested version ", version, ", actual version ", - actualVersion, "): ", errMsg, NULL); - return NULL; -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ Index: generic/tclObj.c ================================================================== --- generic/tclObj.c +++ generic/tclObj.c @@ -13,13 +13,13 @@ * 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 "tommath.h" +#include #include -#include /* * Table of all object types. */ @@ -36,11 +36,11 @@ /* * The object allocator is single threaded. This mutex is referenced by the * TclNewObj macro, however, so must be visible. */ -#if TCL_THREADS +#ifdef TCL_THREADS MODULE_SCOPE Tcl_Mutex tclObjMutex; Tcl_Mutex tclObjMutex; #endif /* @@ -48,21 +48,22 @@ * the value of an empty string representation for an object. This value is * shared by all new objects allocated by Tcl_NewObj. */ char tclEmptyString = '\0'; - -#if TCL_THREADS && defined(TCL_MEM_DEBUG) +char *tclEmptyStringRep = &tclEmptyString; + +#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) /* - * 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. + * 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 { +typedef struct ObjData { Tcl_Obj *objPtr; /* The pointer to the allocated Tcl_Obj. */ - const char *file; /* The name of the source file calling this + 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 */ @@ -74,33 +75,38 @@ * * Notice that different structures with the same name appear in other files. * The structure defined below is used in this file only. */ -typedef struct { - Tcl_HashTable *lineCLPtr; /* This table remembers for each Tcl_Obj - * generated by a call to the function - * TclSubstTokens() from a literal text - * where bs+nl sequences occured in it, if - * any. I.e. this table keeps track of - * invisible and stripped continuation lines. - * Its keys are Tcl_Obj pointers, the values - * are ContLineLoc pointers. See the file - * tclCompile.h for the definition of this - * structure, and for references to all - * related places in the core. */ -#if TCL_THREADS && defined(TCL_MEM_DEBUG) - Tcl_HashTable *objThreadMap;/* Thread local table that is used to check - * that a Tcl_Obj was not allocated by some - * other thread. */ +typedef struct ThreadSpecificData { + Tcl_HashTable* lineCLPtr; /* This table remembers for each Tcl_Obj + * generated by a call to the function + * TclSubstTokens() from a literal text + * where bs+nl sequences occured in it, if + * any. I.e. this table keeps track of + * invisible/stripped continuation lines. Its + * keys are Tcl_Obj pointers, the values are + * ContLineLoc pointers. See the file + * tclCompile.h for the definition of this + * structure, and for references to all related + * places in the core. + */ +#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) + /* + * Thread local table that is used to check that a Tcl_Obj was not + * allocated by some other thread. + */ + + Tcl_HashTable *objThreadMap; #endif /* TCL_MEM_DEBUG && TCL_THREADS */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; -static void TclThreadFinalizeContLines(ClientData clientData); -static ThreadSpecificData *TclGetContLineTable(void); +static void ContLineLocFree (char* clientData); +static void TclThreadFinalizeContLines (ClientData clientData); +static ThreadSpecificData* TclGetContLineTable (void); /* * Nested Tcl_Obj deletion management support * * All context references used in the object freeing code are pointers to this @@ -143,62 +149,77 @@ */ #define ObjDeletionLock(contextPtr) ((contextPtr)->deletionCount++) #define ObjDeletionUnlock(contextPtr) ((contextPtr)->deletionCount--) #define ObjDeletePending(contextPtr) ((contextPtr)->deletionCount > 0) #define ObjOnStack(contextPtr) ((contextPtr)->deletionStack != NULL) -#define PushObjToDelete(contextPtr,objPtr) \ +#define PushObjToDelete(contextPtr,objPtr) \ /* The string rep is already invalidated so we can use the bytes value \ - * for our pointer chain: push onto the head of the stack. */ \ - (objPtr)->bytes = (char *) ((contextPtr)->deletionStack); \ + * for our pointer chain: push onto the head of the stack. */ \ + (objPtr)->bytes = (char *) ((contextPtr)->deletionStack); \ (contextPtr)->deletionStack = (objPtr) -#define PopObjToDelete(contextPtr,objPtrVar) \ - (objPtrVar) = (contextPtr)->deletionStack; \ +#define PopObjToDelete(contextPtr,objPtrVar) \ + (objPtrVar) = (contextPtr)->deletionStack; \ (contextPtr)->deletionStack = (Tcl_Obj *) (objPtrVar)->bytes /* * Macro to set up the local reference to the deletion context. */ -#if !TCL_THREADS +#ifndef TCL_THREADS static PendingObjData pendingObjData; #define ObjInitDeletionContext(contextPtr) \ - PendingObjData *const contextPtr = &pendingObjData -#elif defined(HAVE_FAST_TSD) -static __thread PendingObjData pendingObjData; -#define ObjInitDeletionContext(contextPtr) \ - PendingObjData *const contextPtr = &pendingObjData + PendingObjData *CONST contextPtr = &pendingObjData #else static Tcl_ThreadDataKey pendingObjDataKey; #define ObjInitDeletionContext(contextPtr) \ - PendingObjData *const contextPtr = \ - (PendingObjData *)Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData)) + 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 *)Tcl_Alloc(sizeof(mp_int)); \ - *temp = bignum; \ - (objPtr)->internalRep.twoPtrValue.ptr1 = temp; \ - (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(-1); \ - } else if (((bignum).alloc <= 0x7FFF) || (mp_shrink(&(bignum))) == MP_OKAY) { \ - (objPtr)->internalRep.twoPtrValue.ptr1 = (bignum).dp; \ - (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR( ((bignum).sign << 30) \ - | ((bignum).alloc << 15) | ((bignum).used)); \ + if ((bignum).used > 0x7fff) { \ + mp_int *temp = (void *) ckalloc((unsigned) sizeof(mp_int)); \ + *temp = bignum; \ + (objPtr)->internalRep.ptrAndLongRep.ptr = (void*) temp; \ + (objPtr)->internalRep.ptrAndLongRep.value = (unsigned long)(-1); \ + } else { \ + if ((bignum).alloc > 0x7fff) { \ + mp_shrink(&(bignum)); \ + } \ + (objPtr)->internalRep.ptrAndLongRep.ptr = (void*) (bignum).dp; \ + (objPtr)->internalRep.ptrAndLongRep.value = ( (mp_isneg(&bignum) << 30) \ + | ((bignum).alloc << 15) | ((bignum).used)); \ + } + +#define UNPACK_BIGNUM(objPtr, bignum) \ + if ((objPtr)->internalRep.ptrAndLongRep.value == (unsigned long)(-1)) { \ + (bignum) = *((mp_int *) ((objPtr)->internalRep.ptrAndLongRep.ptr)); \ + } else { \ + (bignum).dp = (mp_digit*) (objPtr)->internalRep.ptrAndLongRep.ptr; \ + (bignum).sign = (objPtr)->internalRep.ptrAndLongRep.value >> 30; \ + (bignum).alloc = \ + ((objPtr)->internalRep.ptrAndLongRep.value >> 15) & 0x7fff; \ + (bignum).used = (objPtr)->internalRep.ptrAndLongRep.value & 0x7fff; \ } /* * Prototypes for functions defined later in this file: */ static int ParseBoolean(Tcl_Obj *objPtr); +static int SetBooleanFromAny(Tcl_Interp *interp, 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); +#ifndef NO_WIDE_TYPE +static void UpdateStringOfWideInt(Tcl_Obj *objPtr); +static int SetWideIntFromAny(Tcl_Interp *interp, 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); @@ -223,46 +244,62 @@ * 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 = { - "boolean", /* 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 = { - "int", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - UpdateStringOfInt, /* updateStringProc */ - SetIntFromAny /* setFromAnyProc */ -}; -const Tcl_ObjType tclBignumType = { - "bignum", /* name */ - FreeBignum, /* freeIntRepProc */ - DupBignum, /* dupIntRepProc */ - UpdateStringOfBignum, /* updateStringProc */ - NULL /* setFromAnyProc */ +static Tcl_ObjType oldBooleanType = { + "boolean", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + SetBooleanFromAny /* setFromAnyProc */ +}; +Tcl_ObjType tclBooleanType = { + "booleanString", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + SetBooleanFromAny /* setFromAnyProc */ +}; +Tcl_ObjType tclDoubleType = { + "double", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + UpdateStringOfDouble, /* updateStringProc */ + SetDoubleFromAny /* setFromAnyProc */ +}; +Tcl_ObjType tclIntType = { + "int", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + UpdateStringOfInt, /* updateStringProc */ + SetIntFromAny /* setFromAnyProc */ +}; +#ifndef NO_WIDE_TYPE +Tcl_ObjType tclWideIntType = { + "wideInt", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + UpdateStringOfWideInt, /* updateStringProc */ + SetWideIntFromAny /* setFromAnyProc */ +}; +#endif +Tcl_ObjType tclBignumType = { + "bignum", /* name */ + FreeBignum, /* freeIntRepProc */ + DupBignum, /* dupIntRepProc */ + UpdateStringOfBignum, /* updateStringProc */ + NULL /* setFromAnyProc */ }; /* * The structure below defines the Tcl obj hash key type. */ -const Tcl_HashKeyType tclObjHashKeyType = { +Tcl_HashKeyType tclObjHashKeyType = { TCL_HASH_KEY_TYPE_VERSION, /* version */ - 0, /* flags */ + TCL_HASH_KEY_DIRECT_COMPARE,/* allows compare keys by pointers */ TclHashObjKey, /* hashKeyProc */ TclCompareObjKeys, /* compareKeysProc */ AllocObjEntry, /* allocEntryProc */ TclFreeObjEntry /* freeEntryProc */ }; @@ -278,26 +315,18 @@ * twoPtrValue.ptr1 field, and the twoPtrValue.ptr2 field is unused. You might * think you could use the simpler otherValuePtr field to store the single * ResolvedCmdName pointer, but DO NOT DO THIS. It seems that some extensions * use the second internal pointer field of the twoPtrValue field for their * own purposes. - * - * TRICKY POINT! Some extensions update this structure! (Notably, these - * include TclBlend and TCom). This is highly ill-advised on their part, but - * does allow them to delete a command when references to it are gone, which - * is fragile but useful given their somewhat-OO style. Because of this, this - * structure MUST NOT be const so that the C compiler puts the data in - * writable memory. [Bug 2558422] [Bug 07d13d99b0a9] - * TODO: Provide a better API for those extensions so that they can coexist... */ -Tcl_ObjType tclCmdNameType = { - "cmdName", /* name */ - FreeCmdNameInternalRep, /* freeIntRepProc */ - DupCmdNameInternalRep, /* dupIntRepProc */ - NULL, /* updateStringProc */ - SetCmdNameFromAny /* setFromAnyProc */ +static Tcl_ObjType tclCmdNameType = { + "cmdName", /* name */ + FreeCmdNameInternalRep, /* freeIntRepProc */ + DupCmdNameInternalRep, /* dupIntRepProc */ + NULL, /* updateStringProc */ + SetCmdNameFromAny /* setFromAnyProc */ }; /* * Structure containing a cached pointer to a command that is the result of * resolving the command's name in some namespace. It is the internal @@ -309,27 +338,27 @@ 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.*/ - size_t refNsId; /* refNsPtr's unique namespace id. Used to + 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). */ - size_t refNsCmdEpoch; /* Value of the referencing namespace's + 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. */ - size_t cmdEpoch; /* Value of the command's cmdEpoch when this + 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 + int refCount; /* Reference count: 1 for each cmdName object * that has a pointer to this ResolvedCmdName * structure as its internal rep. This * structure can be freed when refCount * becomes zero. */ } ResolvedCmdName; @@ -360,25 +389,33 @@ Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS); Tcl_MutexUnlock(&tableMutex); Tcl_RegisterObjType(&tclByteArrayType); Tcl_RegisterObjType(&tclDoubleType); + Tcl_RegisterObjType(&tclEndOffsetType); + Tcl_RegisterObjType(&tclIntType); Tcl_RegisterObjType(&tclStringType); Tcl_RegisterObjType(&tclListType); Tcl_RegisterObjType(&tclDictType); Tcl_RegisterObjType(&tclByteCodeType); + Tcl_RegisterObjType(&tclArraySearchType); Tcl_RegisterObjType(&tclCmdNameType); Tcl_RegisterObjType(&tclRegexpType); Tcl_RegisterObjType(&tclProcBodyType); + + /* For backward compatibility only ... */ + Tcl_RegisterObjType(&oldBooleanType); +#ifndef NO_WIDE_TYPE + Tcl_RegisterObjType(&tclWideIntType); +#endif #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); tclObjsAlloced = 0; tclObjsFreed = 0; { int i; - for (i=0 ; iobjThreadMap; if (tablePtr != NULL) { for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr); + ObjData *objData = Tcl_GetHashValue(hPtr); if (objData != NULL) { - Tcl_Free(objData); + ckfree((char *) objData); } } Tcl_DeleteHashTable(tablePtr); - Tcl_Free(tablePtr); + ckfree((char *) tablePtr); tsdPtr->objThreadMap = NULL; } #endif } @@ -482,12 +519,12 @@ * * TIP #280 *---------------------------------------------------------------------- */ -static ThreadSpecificData * -TclGetContLineTable(void) +static ThreadSpecificData* +TclGetContLineTable() { /* * Initialize the hashtable tracking invisible continuation lines. For * the release we use a thread exit handler to ensure that this is done * before TSD blocks are made invalid. The TclFinalizeObjects() which @@ -494,15 +531,14 @@ * 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 *)Tcl_Alloc(sizeof(Tcl_HashTable)); + tsdPtr->lineCLPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS); - Tcl_CreateThreadExitHandler(TclThreadFinalizeContLines,NULL); + Tcl_CreateThreadExitHandler (TclThreadFinalizeContLines,NULL); } return tsdPtr; } /* @@ -521,21 +557,22 @@ * * TIP #280 *---------------------------------------------------------------------- */ -ContLineLoc * -TclContinuationsEnter( - Tcl_Obj *objPtr, - int num, - int *loc) +ContLineLoc* +TclContinuationsEnter(Tcl_Obj* objPtr, + int num, + int* loc) { int newEntry; ThreadSpecificData *tsdPtr = TclGetContLineTable(); - Tcl_HashEntry *hPtr = - Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry); - ContLineLoc *clLocPtr = (ContLineLoc *)Tcl_Alloc(offsetof(ContLineLoc, loc) + (num + 1) *sizeof(int)); + Tcl_HashEntry* hPtr = + Tcl_CreateHashEntry (tsdPtr->lineCLPtr, (char*) 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. @@ -550,22 +587,22 @@ * Note that while reusing the existing entry is possible it requires * the same actions as for a new entry because we have to copy the * incoming num/loc data even so. Because we are called from * 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. + * returning the stored entry and data would rebase them a second + * time, or more, hosing the data. It is easier to simply replace, as + * we are doing. */ - Tcl_Free(Tcl_GetHashValue(hPtr)); + ckfree((char *) Tcl_GetHashValue(hPtr)); } clLocPtr->num = num; - memcpy(&clLocPtr->loc, loc, num*sizeof(int)); - clLocPtr->loc[num] = CLL_END; /* Sentinel */ - Tcl_SetHashValue(hPtr, clLocPtr); + memcpy (&clLocPtr->loc, loc, num*sizeof(int)); + clLocPtr->loc[num] = CLL_END; /* Sentinel */ + Tcl_SetHashValue (hPtr, clLocPtr); return clLocPtr; } /* @@ -586,19 +623,12 @@ * TIP #280 *---------------------------------------------------------------------- */ void -TclContinuationsEnterDerived( - Tcl_Obj *objPtr, - int start, - int *clNext) -{ - size_t length; - int end, num; - int *wordCLLast = clNext; - +TclContinuationsEnterDerived(Tcl_Obj* objPtr, int start, int* 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, @@ -615,39 +645,46 @@ * empty, wrap it into a new table, and save the result into our * thread-global hashtable, as usual. */ /* - * First compute the range of the word within the script. (Is there a - * better way which doesn't shimmer?) + * First compute the range of the word within the script. */ - (void)TclGetStringFromObj(objPtr, &length); - end = start + length; /* First char after the word */ + int length, end, num; + int* wordCLLast = clNext; + + Tcl_GetStringFromObj(objPtr, &length); + /* Is there a better way which doesn't shimmer ? */ + + end = start + length; /* first char after the word */ /* - * Then compute the table slice covering the range of the word. + * Then compute the table slice covering the range of + * the word. */ while (*wordCLLast >= 0 && *wordCLLast < end) { wordCLLast++; } /* - * And generate the table from the slice, if it was not empty. + * And generate the table from the slice, if it was + * not empty. */ num = wordCLLast - clNext; if (num) { int i; - ContLineLoc *clLocPtr = TclContinuationsEnter(objPtr, num, clNext); + ContLineLoc* clLocPtr = + TclContinuationsEnter(objPtr, num, clNext); /* * Re-base the locations. */ - for (i=0 ; iloc[i] -= start; /* * Continuation lines coming before the string and affecting us * should not happen, due to the proper maintenance of clNext @@ -665,13 +702,13 @@ *---------------------------------------------------------------------- * * TclContinuationsCopy -- * * This procedure is a helper which copies the continuation line - * information associated with a Tcl_Obj* to another Tcl_Obj*. It is - * assumed that both contain the same string/script. Use this when a - * script is duplicated because it was shared. + * information associated with a Tcl_Obj* to another Tcl_Obj*. + * It is assumed that both contain the same string/script. Use + * this when a script is duplicated because it was shared. * * Results: * None. * * Side effects: @@ -680,20 +717,17 @@ * TIP #280 *---------------------------------------------------------------------- */ void -TclContinuationsCopy( - Tcl_Obj *objPtr, - Tcl_Obj *originObjPtr) +TclContinuationsCopy(Tcl_Obj* objPtr, Tcl_Obj* originObjPtr) { ThreadSpecificData *tsdPtr = TclGetContLineTable(); - Tcl_HashEntry *hPtr = - Tcl_FindHashEntry(tsdPtr->lineCLPtr, originObjPtr); + Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char*) originObjPtr); if (hPtr) { - ContLineLoc *clLocPtr = (ContLineLoc *)Tcl_GetHashValue(hPtr); + ContLineLoc* clLocPtr = (ContLineLoc*) Tcl_GetHashValue (hPtr); TclContinuationsEnter(objPtr, clLocPtr->num, clLocPtr->loc); } } @@ -704,32 +738,31 @@ * * This procedure is a helper which retrieves the continuation line * information associated with a Tcl_Obj*, if it has any. * * Results: - * A reference to the continuation line location table, or NULL if the - * Tcl_Obj* has no such information associated with it. + * A reference to the continuation line location table, or NULL + * if the Tcl_Obj* has no such information associated with it. * * Side effects: * None. * * TIP #280 *---------------------------------------------------------------------- */ -ContLineLoc * -TclContinuationsGet( - Tcl_Obj *objPtr) +ContLineLoc* +TclContinuationsGet(Tcl_Obj* objPtr) { ThreadSpecificData *tsdPtr = TclGetContLineTable(); - Tcl_HashEntry *hPtr = - Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); + Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char*) objPtr); - if (!hPtr) { - return NULL; + if (hPtr) { + return (ContLineLoc*) Tcl_GetHashValue (hPtr); + } else { + return NULL; } - return (ContLineLoc *)Tcl_GetHashValue(hPtr); } /* *---------------------------------------------------------------------- * @@ -747,12 +780,11 @@ * TIP #280 *---------------------------------------------------------------------- */ static void -TclThreadFinalizeContLines( - TCL_UNUSED(ClientData)) +TclThreadFinalizeContLines (ClientData clientData) { /* * Release the hashtable tracking invisible continuation lines. */ @@ -759,18 +791,48 @@ ThreadSpecificData *tsdPtr = TclGetContLineTable(); Tcl_HashEntry *hPtr; Tcl_HashSearch hSearch; for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - Tcl_Free(Tcl_GetHashValue(hPtr)); - Tcl_DeleteHashEntry(hPtr); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + /* + * We are not using Tcl_EventuallyFree (as in TclFreeObj()) because + * here we can be sure that the compiler will not hold references to + * the data in the hashtable, and using TEF might bork the + * finalization sequence. + */ + ContLineLocFree (Tcl_GetHashValue (hPtr)); + Tcl_DeleteHashEntry (hPtr); } - Tcl_DeleteHashTable(tsdPtr->lineCLPtr); - Tcl_Free(tsdPtr->lineCLPtr); + Tcl_DeleteHashTable (tsdPtr->lineCLPtr); + ckfree((char *) tsdPtr->lineCLPtr); tsdPtr->lineCLPtr = NULL; } + +/* + *---------------------------------------------------------------------- + * + * ContLineLocFree -- + * + * The freProc for continuation line location tables. + * + * Results: + * None. + * + * Side effects: + * Releases memory. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +static void +ContLineLocFree (char* clientData) +{ + ckfree (clientData); +} /* *-------------------------------------------------------------- * * Tcl_RegisterObjType -- @@ -789,11 +851,11 @@ *-------------------------------------------------------------- */ void Tcl_RegisterObjType( - const Tcl_ObjType *typePtr) /* Information about object type; storage must + Tcl_ObjType *typePtr) /* Information about object type; storage must * be statically allocated (must live * forever). */ { int isNew; @@ -832,11 +894,11 @@ 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; + register Tcl_HashEntry *hPtr; Tcl_HashSearch search; int numElems; /* * Get the test for a valid list out of the way first. @@ -853,11 +915,11 @@ 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_NewStringObj(Tcl_GetHashKey(&typeTable, hPtr), -1)); } Tcl_MutexUnlock(&tableMutex); return TCL_OK; } @@ -876,21 +938,21 @@ * None. * *---------------------------------------------------------------------- */ -const Tcl_ObjType * +Tcl_ObjType * Tcl_GetObjType( - const char *typeName) /* Name of Tcl object type to look up. */ + CONST char *typeName) /* Name of Tcl object type to look up. */ { - Tcl_HashEntry *hPtr; - const Tcl_ObjType *typePtr = NULL; + register Tcl_HashEntry *hPtr; + Tcl_ObjType *typePtr = NULL; Tcl_MutexLock(&tableMutex); hPtr = Tcl_FindHashEntry(&typeTable, typeName); if (hPtr != NULL) { - typePtr = (const Tcl_ObjType *)Tcl_GetHashValue(hPtr); + typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr); } Tcl_MutexUnlock(&tableMutex); return typePtr; } @@ -916,11 +978,11 @@ int Tcl_ConvertToType( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr, /* The object to convert. */ - const Tcl_ObjType *typePtr) /* The target type. */ + Tcl_ObjType *typePtr) /* The target type. */ { if (objPtr->typePtr == typePtr) { return TCL_OK; } @@ -957,27 +1019,27 @@ * None. * *-------------------------------------------------------------- */ -#if TCL_THREADS && defined(TCL_MEM_DEBUG) void TclDbDumpActiveObjects( FILE *outFile) { +#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) 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: %" TCL_Z_MODIFIER "u\n", tablePtr->numEntries); + 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); + 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, @@ -986,18 +1048,12 @@ fprintf(outFile, "key = 0x%p\n", Tcl_GetHashKey(tablePtr, hPtr)); } } } -} -#else -void -TclDbDumpActiveObjects( - TCL_UNUSED(FILE *)) -{ -} #endif +} /* *---------------------------------------------------------------------- * * TclDbInitNewObj -- @@ -1016,21 +1072,22 @@ */ #ifdef TCL_MEM_DEBUG void TclDbInitNewObj( - Tcl_Obj *objPtr, - const char *file, /* The name of the source file calling this + register Tcl_Obj *objPtr, + register 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 + register int line) /* Line number in the source file; used for * debugging. */ { objPtr->refCount = 0; + objPtr->bytes = tclEmptyStringRep; + objPtr->length = 0; objPtr->typePtr = NULL; - TclInitStringRep(objPtr, NULL, 0); -#if TCL_THREADS +#ifdef TCL_THREADS /* * Add entry to a thread local map used to check if a Tcl_Obj was * allocated by the currently executing thread. */ @@ -1040,24 +1097,25 @@ int isNew; ObjData *objData; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->objThreadMap == NULL) { - tsdPtr->objThreadMap = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); + 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); + hPtr = Tcl_CreateHashEntry(tablePtr, (char *) objPtr, &isNew); if (!isNew) { Tcl_Panic("expected to create new entry for object map"); } /* * Record the debugging information. */ - objData = (ObjData *)Tcl_Alloc(sizeof(ObjData)); + objData = (ObjData *) ckalloc(sizeof(ObjData)); objData->objPtr = objPtr; objData->file = file; objData->line = line; Tcl_SetHashValue(hPtr, objData); } @@ -1103,11 +1161,11 @@ #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewObj(void) { - Tcl_Obj *objPtr; + register Tcl_Obj *objPtr; /* * Use the macro defined in tclInt.h - it will use the correct allocator. */ @@ -1145,16 +1203,16 @@ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewObj( - const char *file, /* The name of the source file calling this + register 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 + register int line) /* Line number in the source file; used for * debugging. */ { - Tcl_Obj *objPtr; + register Tcl_Obj *objPtr; /* * Use the macro defined in tclInt.h - it will use the correct allocator. */ @@ -1163,12 +1221,14 @@ } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_DbNewObj( - TCL_UNUSED(const char *) /*file*/, - TCL_UNUSED(int) /*line*/) + 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. */ { return Tcl_NewObj(); } #endif /* TCL_MEM_DEBUG */ @@ -1176,11 +1236,11 @@ *---------------------------------------------------------------------- * * TclAllocateFreeObjects -- * * Function to allocate a number of free Tcl_Objs. This is done using a - * single Tcl_Alloc to reduce the overhead for Tcl_Obj allocation. + * single ckalloc to reduce the overhead for Tcl_Obj allocation. * * Assumes mutex is held. * * Results: * None. @@ -1198,28 +1258,28 @@ void TclAllocateFreeObjects(void) { size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * sizeof(Tcl_Obj)); char *basePtr; - Tcl_Obj *prevPtr, *objPtr; - int i; + register Tcl_Obj *prevPtr, *objPtr; + register 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 Tcl_Free() this memory, + * 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 *)Tcl_Alloc(bytesToAlloc); + 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; + objPtr->internalRep.twoPtrValue.ptr1 = (void *) prevPtr; prevPtr = objPtr; objPtr++; } tclFreeObjList = prevPtr; } @@ -1250,21 +1310,21 @@ */ #ifdef TCL_MEM_DEBUG void TclFreeObj( - Tcl_Obj *objPtr) /* The object to be freed. */ + register Tcl_Obj *objPtr) /* The object to be freed. */ { - const Tcl_ObjType *typePtr = objPtr->typePtr; + register Tcl_ObjType *typePtr = objPtr->typePtr; /* * This macro declares a variable, so must come here... */ ObjInitDeletionContext(context); -#if TCL_THREADS +# ifdef TCL_THREADS /* * Check to make sure that the Tcl_Obj was allocated by the current * thread. Don't do this check when shutting down since thread local * storage can be finalized before the last Tcl_Obj is freed. */ @@ -1282,14 +1342,14 @@ if (hPtr) { /* * As the Tcl_Obj is going to be deleted we remove the entry. */ - ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr); + ObjData *objData = Tcl_GetHashValue(hPtr); if (objData != NULL) { - Tcl_Free(objData); + ckfree((char *) objData); } Tcl_DeleteHashEntry(hPtr); } } @@ -1299,28 +1359,26 @@ * 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 == (size_t)-2) { - Tcl_Panic("Reference count for %p was negative", objPtr); + if (objPtr->refCount < -1) { + Tcl_Panic("Reference count for %lx 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 = TCL_INDEX_NONE; + 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 == TCL_INDEX_NONE'. - */ + /* 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 = TCL_INDEX_NONE; + objPtr->length = -1; if (ObjDeletePending(context)) { PushObjToDelete(context, objPtr); } else { TCL_DTRACE_OBJ_FREE(objPtr); @@ -1329,66 +1387,63 @@ typePtr->freeIntRepProc(objPtr); ObjDeletionUnlock(context); } Tcl_MutexLock(&tclObjMutex); - Tcl_Free(objPtr); + ckfree((char *) objPtr); Tcl_MutexUnlock(&tclObjMutex); TclIncrObjsFreed(); ObjDeletionLock(context); while (ObjOnStack(context)) { Tcl_Obj *objToFree; - PopObjToDelete(context, objToFree); + PopObjToDelete(context,objToFree); TCL_DTRACE_OBJ_FREE(objToFree); TclFreeIntRep(objToFree); Tcl_MutexLock(&tclObjMutex); - Tcl_Free(objToFree); + ckfree((char *) objToFree); Tcl_MutexUnlock(&tclObjMutex); TclIncrObjsFreed(); } ObjDeletionUnlock(context); } /* * We cannot use TclGetContinuationTable() here, because that may - * re-initialize the thread-data for calls coming after the finalization. - * We have to access it using the low-level call and then check for - * validity. This function can be called after TclFinalizeThreadData() has - * already killed the thread-global data structures. Performing - * TCL_TSD_INIT will leave us with an un-initialized memory block upon - * which we crash (if we where to access the uninitialized hashtable). + * re-initialize the thread-data for calls coming after the + * finalization. We have to access it using the low-level call and then + * check for validity. This function can be called after + * TclFinalizeThreadData() has already killed the thread-global data + * structures. Performing TCL_TSD_INIT will leave us with an + * un-initialized memory block upon which we crash (if we where to access + * the uninitialized hashtable). */ { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - Tcl_HashEntry *hPtr; - + ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->lineCLPtr) { - hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); + Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char *) objPtr); if (hPtr) { - Tcl_Free(Tcl_GetHashValue(hPtr)); - Tcl_DeleteHashEntry(hPtr); + Tcl_EventuallyFree (Tcl_GetHashValue (hPtr), ContLineLocFree); + Tcl_DeleteHashEntry (hPtr); } } } } #else /* TCL_MEM_DEBUG */ void TclFreeObj( - Tcl_Obj *objPtr) /* The object to be freed. */ + register 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'. - */ + /* 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 = TCL_INDEX_NONE; + 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. @@ -1425,12 +1480,11 @@ TclFreeObjStorage(objPtr); TclIncrObjsFreed(); ObjDeletionLock(context); while (ObjOnStack(context)) { Tcl_Obj *objToFree; - - PopObjToDelete(context, objToFree); + PopObjToDelete(context,objToFree); TCL_DTRACE_OBJ_FREE(objToFree); if ((objToFree->typePtr != NULL) && (objToFree->typePtr->freeIntRepProc != NULL)) { objToFree->typePtr->freeIntRepProc(objToFree); } @@ -1441,32 +1495,31 @@ } } /* * We cannot use TclGetContinuationTable() here, because that may - * re-initialize the thread-data for calls coming after the finalization. - * We have to access it using the low-level call and then check for - * validity. This function can be called after TclFinalizeThreadData() has - * already killed the thread-global data structures. Performing - * TCL_TSD_INIT will leave us with an un-initialized memory block upon - * which we crash (if we where to access the uninitialized hashtable). + * re-initialize the thread-data for calls coming after the + * finalization. We have to access it using the low-level call and then + * check for validity. This function can be called after + * TclFinalizeThreadData() has already killed the thread-global data + * structures. Performing TCL_TSD_INIT will leave us with an + * un-initialized memory block upon which we crash (if we where to access + * the uninitialized hashtable). */ { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - Tcl_HashEntry *hPtr; - + ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->lineCLPtr) { - hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); + Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char *) objPtr); if (hPtr) { - Tcl_Free(Tcl_GetHashValue(hPtr)); - Tcl_DeleteHashEntry(hPtr); + Tcl_EventuallyFree (Tcl_GetHashValue (hPtr), ContLineLocFree); + Tcl_DeleteHashEntry (hPtr); } } } } -#endif /* TCL_MEM_DEBUG */ +#endif /* *---------------------------------------------------------------------- * * TclObjBeingDeleted -- @@ -1486,12 +1539,13 @@ int TclObjBeingDeleted( Tcl_Obj *objPtr) { - return (objPtr->length == TCL_INDEX_NONE); + return (objPtr->length == -1); } + /* *---------------------------------------------------------------------- * * Tcl_DuplicateObj -- @@ -1518,51 +1572,34 @@ * objects will be incremented. * *---------------------------------------------------------------------- */ -#define SetDuplicateObj(dupPtr, objPtr) \ - { \ - const Tcl_ObjType *typePtr = (objPtr)->typePtr; \ - const char *bytes = (objPtr)->bytes; \ - if (bytes) { \ - TclInitStringRep((dupPtr), bytes, (objPtr)->length); \ - } else { \ - (dupPtr)->bytes = NULL; \ - } \ - if (typePtr) { \ - if (typePtr->dupIntRepProc) { \ - typePtr->dupIntRepProc((objPtr), (dupPtr)); \ - } else { \ - (dupPtr)->internalRep = (objPtr)->internalRep; \ - (dupPtr)->typePtr = typePtr; \ - } \ - } \ - } - Tcl_Obj * Tcl_DuplicateObj( - Tcl_Obj *objPtr) /* The object to duplicate. */ + register Tcl_Obj *objPtr) /* The object to duplicate. */ { - Tcl_Obj *dupPtr; + register Tcl_ObjType *typePtr = objPtr->typePtr; + register Tcl_Obj *dupPtr; TclNewObj(dupPtr); - SetDuplicateObj(dupPtr, objPtr); - return dupPtr; -} - -void -TclSetDuplicateObj( - Tcl_Obj *dupPtr, - Tcl_Obj *objPtr) -{ - if (Tcl_IsShared(dupPtr)) { - Tcl_Panic("%s called with shared object", "TclSetDuplicateObj"); - } - TclInvalidateStringRep(dupPtr); - TclFreeIntRep(dupPtr); - SetDuplicateObj(dupPtr, objPtr); + + if (objPtr->bytes == NULL) { + dupPtr->bytes = NULL; + } else if (objPtr->bytes != tclEmptyStringRep) { + TclInitStringRep(dupPtr, objPtr->bytes, objPtr->length); + } + + if (typePtr != NULL) { + if (typePtr->dupIntRepProc == NULL) { + dupPtr->internalRep = objPtr->internalRep; + dupPtr->typePtr = typePtr; + } else { + (*typePtr->dupIntRepProc)(objPtr, dupPtr); + } + } + return dupPtr; } /* *---------------------------------------------------------------------- * @@ -1584,38 +1621,22 @@ *---------------------------------------------------------------------- */ char * Tcl_GetString( - Tcl_Obj *objPtr) /* Object whose string rep byte pointer should + register 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 == TCL_INDEX_NONE - || objPtr->bytes[objPtr->length] != '\0') { - Tcl_Panic("UpdateStringProc for type '%s' " - "failed to create a valid string rep", - objPtr->typePtr->name); - } - } + if (objPtr->bytes != NULL) { + return objPtr->bytes; + } + + if (objPtr->typePtr->updateStringProc == NULL) { + Tcl_Panic("UpdateStringProc should not be invoked for type %s", + objPtr->typePtr->name); + } + (*objPtr->typePtr->updateStringProc)(objPtr); return objPtr->bytes; } /* *---------------------------------------------------------------------- @@ -1640,125 +1661,27 @@ *---------------------------------------------------------------------- */ char * Tcl_GetStringFromObj( - Tcl_Obj *objPtr, /* Object whose string rep byte pointer should + register Tcl_Obj *objPtr, /* Object whose string rep byte pointer should * be returned. */ - int *lengthPtr) /* If non-NULL, the location where the string + register 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 - * 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 == TCL_INDEX_NONE - || objPtr->bytes[objPtr->length] != '\0') { - Tcl_Panic("UpdateStringProc for type '%s' " - "failed to create a valid string rep", - objPtr->typePtr->name); - } - } + (*objPtr->typePtr->updateStringProc)(objPtr); + } + if (lengthPtr != NULL) { - *lengthPtr = (objPtr->length < INT_MAX)? objPtr->length: INT_MAX; - } - 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 == -1) - * Invalid call -- panic! - * - * objPtr->bytes == NULL && bytes == NULL && numBytes != -1 - * 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 != -1 - * 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 != -1 - * 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. - * - * Results: - * A pointer to the string rep of objPtr. - * - * Side effects: - * As described above. - * - *---------------------------------------------------------------------- - */ - -char * -Tcl_InitStringRep( - Tcl_Obj *objPtr, /* Object whose string rep is to be set */ - const char *bytes, - size_t numBytes) -{ - assert(objPtr->bytes == NULL || bytes == NULL); - - /* Allocate */ - if (objPtr->bytes == NULL) { - /* Allocate only as empty - extend later if bytes copied */ - objPtr->length = 0; - if (numBytes) { - objPtr->bytes = (char *)Tcl_AttemptAlloc(numBytes + 1); - if (objPtr->bytes == NULL) { - return NULL; - } - if (bytes) { - /* Copy */ - memcpy(objPtr->bytes, bytes, numBytes); - objPtr->length = numBytes; - } - } else { - TclInitStringRep(objPtr, NULL, 0); - } - } else { - /* objPtr->bytes != NULL bytes == NULL - Truncate */ - objPtr->bytes = (char *)Tcl_Realloc(objPtr->bytes, numBytes + 1); - objPtr->length = numBytes; - } - - /* Terminate */ - objPtr->bytes[objPtr->length] = '\0'; - + *lengthPtr = objPtr->length; + } return objPtr->bytes; } /* *---------------------------------------------------------------------- @@ -1778,125 +1701,153 @@ *---------------------------------------------------------------------- */ void Tcl_InvalidateStringRep( - Tcl_Obj *objPtr) /* Object whose string rep byte pointer should + register Tcl_Obj *objPtr) /* Object whose string rep byte pointer should * be freed. */ { TclInvalidateStringRep(objPtr); } - -/* - *---------------------------------------------------------------------- - * - * Tcl_HasStringRep -- - * - * This function reports whether object has a string representation. - * - * Results: - * Boolean. - *---------------------------------------------------------------------- - */ - -int -Tcl_HasStringRep( - Tcl_Obj *objPtr) /* Object to test */ -{ - return TclHasStringRep(objPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_StoreIntRep -- - * - * This function is called to set the object's internal - * representation to match a particular type. - * - * It is the caller's responsibility to guarantee that - * the value of the submitted IntRep is in agreement with - * the value of any existing string rep. - * - * Results: - * None. - * - * Side effects: - * Calls the freeIntRepProc of the current Tcl_ObjType, if any. - * Sets the internalRep and typePtr fields to the submitted values. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_StoreIntRep( - Tcl_Obj *objPtr, /* Object whose internal rep should be set. */ - const Tcl_ObjType *typePtr, /* New type for the object */ - const Tcl_ObjIntRep *irPtr) /* New IntRep for the object */ -{ - /* Clear out any existing IntRep ( "shimmer" ) */ - TclFreeIntRep(objPtr); - - /* When irPtr == NULL, just leave objPtr with no IntRep for typePtr */ - if (irPtr) { - /* Copy the new IntRep into place */ - objPtr->internalRep = *irPtr; - - /* Set the type to match */ - objPtr->typePtr = typePtr; - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_FetchIntRep -- - * - * This function is called to retrieve the object's internal - * representation matching a requested type, if any. - * - * Results: - * A read-only pointer to the associated Tcl_ObjIntRep, or - * NULL if no such internal representation exists. - * - * Side effects: - * Calls the freeIntRepProc of the current Tcl_ObjType, if any. - * Sets the internalRep and typePtr fields to the submitted values. - * - *---------------------------------------------------------------------- - */ - -Tcl_ObjIntRep * -Tcl_FetchIntRep( - Tcl_Obj *objPtr, /* Object to fetch from. */ - const Tcl_ObjType *typePtr) /* Requested type */ -{ - return TclFetchIntRep(objPtr, typePtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_FreeIntRep -- - * - * This function is called to free an object's internal representation. - * - * Results: - * None. - * - * Side effects: - * Calls the freeIntRepProc of the current Tcl_ObjType, if any. - * Sets typePtr field to NULL. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_FreeIntRep( - Tcl_Obj *objPtr) /* Object whose internal rep should be freed. */ -{ - 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_DbNewBooleanObj. + * + * 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( + register int boolValue) /* Boolean used to initialize new object. */ +{ + return Tcl_DbNewLongObj(boolValue!=0, "unknown", 0); +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_NewBooleanObj( + register int boolValue) /* Boolean used to initialize new object. */ +{ + register 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. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_DbNewBooleanObj +#ifdef TCL_MEM_DEBUG + +Tcl_Obj * +Tcl_DbNewBooleanObj( + register 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. */ +{ + register Tcl_Obj *objPtr; + + TclDbNewObj(objPtr, file, line); + objPtr->bytes = NULL; + + objPtr->internalRep.longValue = (boolValue? 1 : 0); + objPtr->typePtr = &tclIntType; + return objPtr; +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_DbNewBooleanObj( + register 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. */ +{ + 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( + register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ + register 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); } /* *---------------------------------------------------------------------- * @@ -1916,17 +1867,21 @@ *---------------------------------------------------------------------- */ 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. */ + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr, /* The object from which to get boolean. */ + register int *boolPtr) /* Place to store resulting boolean. */ { do { - if (objPtr->typePtr == &tclIntType || objPtr->typePtr == &tclBooleanType) { - *boolPtr = (objPtr->internalRep.wideValue != 0); + if (objPtr->typePtr == &tclIntType) { + *boolPtr = (objPtr->internalRep.longValue != 0); + return TCL_OK; + } + if (objPtr->typePtr == &tclBooleanType) { + *boolPtr = (int) objPtr->internalRep.longValue; return TCL_OK; } if (objPtr->typePtr == &tclDoubleType) { /* * Caution: Don't be tempted to check directly for the "double" @@ -1934,11 +1889,11 @@ * reliable because a "double" Tcl_ObjType can hold the NaN value. * Use the API Tcl_GetDoubleFromObj, which does the checking and * sets the proper error message for us. */ - double d; + double d; if (Tcl_GetDoubleFromObj(interp, objPtr, &d) != TCL_OK) { return TCL_ERROR; } *boolPtr = (d != 0.0); @@ -1946,19 +1901,25 @@ } if (objPtr->typePtr == &tclBignumType) { *boolPtr = 1; return TCL_OK; } +#ifndef NO_WIDE_TYPE + if (objPtr->typePtr == &tclWideIntType) { + *boolPtr = (objPtr->internalRep.wideValue != 0); + return TCL_OK; + } +#endif } while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK == TclParseNumber(interp, objPtr, "boolean value", NULL,-1,NULL,0))); return TCL_ERROR; } /* *---------------------------------------------------------------------- * - * TclSetBooleanFromAny -- + * SetBooleanFromAny -- * * Attempt to generate a boolean internal form for the Tcl object * "objPtr". * * Results: @@ -1966,37 +1927,44 @@ * 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. + * representation and the type of "objPtr" is set to boolean. * *---------------------------------------------------------------------- */ -int -TclSetBooleanFromAny( +static int +SetBooleanFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr) /* The object to convert. */ + register 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. */ if (objPtr->bytes == NULL) { if (objPtr->typePtr == &tclIntType) { - if ((Tcl_WideUInt)objPtr->internalRep.wideValue < 2) { + switch (objPtr->internalRep.longValue) { + case 0L: case 1L: return TCL_OK; } goto badBoolean; } if (objPtr->typePtr == &tclBignumType) { goto badBoolean; } + +#ifndef NO_WIDE_TYPE + if (objPtr->typePtr == &tclWideIntType) { + goto badBoolean; + } +#endif if (objPtr->typePtr == &tclDoubleType) { goto badBoolean; } } @@ -2005,37 +1973,31 @@ return TCL_OK; } badBoolean: if (interp != NULL) { - size_t length; - const char *str = TclGetStringFromObj(objPtr, &length); + int length; + char *str = Tcl_GetStringFromObj(objPtr, &length); Tcl_Obj *msg; TclNewLiteralStringObj(msg, "expected boolean value but got \""); Tcl_AppendLimitedToObj(msg, str, length, 50, ""); Tcl_AppendToObj(msg, "\"", -1); Tcl_SetObjResult(interp, msg); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "BOOLEAN", NULL); } return TCL_ERROR; } static int ParseBoolean( - Tcl_Obj *objPtr) /* The object to parse/convert. */ + register Tcl_Obj *objPtr) /* The object to parse/convert. */ { - int newBool; - char lowerCase[6]; - size_t i, length; - const char *str = TclGetStringFromObj(objPtr, &length); + int i, length, newBool; + char lowerCase[6], *str = TclGetStringFromObj(objPtr, &length); if ((length == 0) || (length > 5)) { - /* - * Longest valid boolean string rep. is "false". - */ - + /* longest valid boolean string rep. is "false" */ return TCL_ERROR; } switch (str[0]) { case '0': @@ -2057,11 +2019,10 @@ * invalid characters at the same time. */ for (i=0; i < length; i++) { char c = str[i]; - switch (c) { case 'A': case 'E': case 'F': case 'L': case 'N': case 'O': case 'R': case 'S': case 'T': case 'U': case 'Y': lowerCase[i] = c + (char) ('a' - 'A'); break; @@ -2077,41 +2038,41 @@ switch (lowerCase[0]) { case 'y': /* * Checking the 'y' is redundant, but makes the code clearer. */ - if (strncmp(lowerCase, "yes", length) == 0) { + if (strncmp(lowerCase, "yes", (size_t) length) == 0) { newBool = 1; goto goodBoolean; } return TCL_ERROR; case 'n': - if (strncmp(lowerCase, "no", length) == 0) { + if (strncmp(lowerCase, "no", (size_t) length) == 0) { newBool = 0; goto goodBoolean; } return TCL_ERROR; case 't': - if (strncmp(lowerCase, "true", length) == 0) { + if (strncmp(lowerCase, "true", (size_t) length) == 0) { newBool = 1; goto goodBoolean; } return TCL_ERROR; case 'f': - if (strncmp(lowerCase, "false", length) == 0) { + if (strncmp(lowerCase, "false", (size_t) length) == 0) { newBool = 0; goto goodBoolean; } return TCL_ERROR; case 'o': if (length < 2) { return TCL_ERROR; } - if (strncmp(lowerCase, "on", length) == 0) { + if (strncmp(lowerCase, "on", (size_t) length) == 0) { newBool = 1; goto goodBoolean; - } else if (strncmp(lowerCase, "off", length) == 0) { + } else if (strncmp(lowerCase, "off", (size_t) length) == 0) { newBool = 0; goto goodBoolean; } return TCL_ERROR; default: @@ -2124,17 +2085,17 @@ * Tcl_GetStringFromObj, to use that old internalRep. */ goodBoolean: TclFreeIntRep(objPtr); - objPtr->internalRep.wideValue = newBool; + objPtr->internalRep.longValue = newBool; objPtr->typePtr = &tclBooleanType; return TCL_OK; numericBoolean: TclFreeIntRep(objPtr); - objPtr->internalRep.wideValue = newBool; + objPtr->internalRep.longValue = newBool; objPtr->typePtr = &tclIntType; return TCL_OK; } /* @@ -2162,22 +2123,22 @@ #ifdef TCL_MEM_DEBUG #undef Tcl_NewDoubleObj Tcl_Obj * Tcl_NewDoubleObj( - double dblValue) /* Double used to initialize the object. */ + register 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. */ + register double dblValue) /* Double used to initialize the object. */ { - Tcl_Obj *objPtr; + register Tcl_Obj *objPtr; TclNewDoubleObj(objPtr, dblValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ @@ -2210,20 +2171,19 @@ #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 + register 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; + register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); - /* Optimized TclInvalidateStringRep() */ objPtr->bytes = NULL; objPtr->internalRep.doubleValue = dblValue; objPtr->typePtr = &tclDoubleType; return objPtr; @@ -2231,13 +2191,15 @@ #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*/) + register 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. */ { return Tcl_NewDoubleObj(dblValue); } #endif /* TCL_MEM_DEBUG */ @@ -2259,12 +2221,12 @@ *---------------------------------------------------------------------- */ void Tcl_SetDoubleObj( - Tcl_Obj *objPtr, /* Object whose internal rep to init. */ - double dblValue) /* Double used to set the object's value. */ + register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ + register double dblValue) /* Double used to set the object's value. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetDoubleObj"); } @@ -2291,39 +2253,42 @@ *---------------------------------------------------------------------- */ int Tcl_GetDoubleFromObj( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr, /* The object from which to get a double. */ - double *dblPtr) /* Place to store resulting double. */ + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr, /* The object from which to get a double. */ + register 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)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DOUBLE", "NAN", - NULL); } return TCL_ERROR; } *dblPtr = (double) objPtr->internalRep.doubleValue; return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - *dblPtr = (double) objPtr->internalRep.wideValue; + *dblPtr = objPtr->internalRep.longValue; return TCL_OK; } if (objPtr->typePtr == &tclBignumType) { mp_int big; - - TclUnpackBignum(objPtr, big); - *dblPtr = TclBignumToDouble(&big); + UNPACK_BIGNUM( objPtr, big ); + *dblPtr = TclBignumToDouble( &big ); + return TCL_OK; + } +#ifndef NO_WIDE_TYPE + if (objPtr->typePtr == &tclWideIntType) { + *dblPtr = (double) objPtr->internalRep.wideValue; return TCL_OK; } +#endif } while (SetDoubleFromAny(interp, objPtr) == TCL_OK); return TCL_ERROR; } /* @@ -2347,11 +2312,11 @@ */ static int SetDoubleFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr) /* The object to convert. */ + register Tcl_Obj *objPtr) /* The object to convert. */ { return TclParseNumber(interp, objPtr, "floating-point number", NULL, -1, NULL, 0); } @@ -2359,11 +2324,12 @@ *---------------------------------------------------------------------- * * UpdateStringOfDouble -- * * Update the string representation for a double-precision floating point - * object. Note: This function does not free an + * 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. @@ -2375,66 +2341,149 @@ *---------------------------------------------------------------------- */ static void UpdateStringOfDouble( - Tcl_Obj *objPtr) /* Double obj with string rep to update. */ -{ - char *dst = Tcl_InitStringRep(objPtr, NULL, TCL_DOUBLE_SPACE); - - TclOOM(dst, (size_t)TCL_DOUBLE_SPACE + 1); - - Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, dst); - (void) Tcl_InitStringRep(objPtr, NULL, strlen(dst)); + register Tcl_Obj *objPtr) /* Double obj with string rep to update. */ +{ + char buffer[TCL_DOUBLE_SPACE]; + register int len; + + Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, buffer); + len = strlen(buffer); + + objPtr->bytes = (char *) ckalloc((unsigned) len + 1); + strcpy(objPtr->bytes, buffer); + objPtr->length = len; +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG +#undef Tcl_NewIntObj + +Tcl_Obj * +Tcl_NewIntObj( + register int intValue) /* Int used to initialize the new object. */ +{ + return Tcl_DbNewLongObj((long)intValue, "unknown", 0); +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_NewIntObj( + register int intValue) /* Int used to initialize the new object. */ +{ + register Tcl_Obj *objPtr; + + TclNewIntObj(objPtr, intValue); + return objPtr; +} +#endif /* if TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetIntObj( + register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ + register 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); } /* *---------------------------------------------------------------------- * * Tcl_GetIntFromObj -- * - * Retrieve the integer value of 'objPtr'. - * - * Value - * - * TCL_OK - * - * Success. - * - * TCL_ERROR - * - * An error occurred during conversion or the integral value can not - * be represented as an integer (it might be too large). An error - * message is left in the interpreter's result if 'interp' is not - * NULL. - * - * Effect - * - * 'objPtr' is converted to an integer if necessary if it is not one - * already. The conversion frees any previously-existing internal - * representation. + * 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. */ + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr, /* The object from which to get a int. */ + register 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) { return TCL_ERROR; } - if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < INT_MIN))) { + if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < -(long)UINT_MAX))) { if (interp != NULL) { - const char *s = + CONST char *s = "integer value too large to represent as non-long integer"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); } return TCL_ERROR; @@ -2463,12 +2512,12 @@ static int SetIntFromAny( Tcl_Interp *interp, /* Tcl interpreter */ Tcl_Obj *objPtr) /* Pointer to the object to convert */ { - Tcl_WideInt w; - return Tcl_GetWideIntFromObj(interp, objPtr, &w); + long l; + return TclGetLongFromObj(interp, objPtr, &l); } /* *---------------------------------------------------------------------- * @@ -2488,17 +2537,174 @@ *---------------------------------------------------------------------- */ static void UpdateStringOfInt( - Tcl_Obj *objPtr) /* Int object whose string rep to update. */ + register Tcl_Obj *objPtr) /* Int object whose string rep to update. */ +{ + char buffer[TCL_INTEGER_SPACE]; + register int len; + + len = TclFormatInt(buffer, objPtr->internalRep.longValue); + + objPtr->bytes = ckalloc((unsigned) len + 1); + strcpy(objPtr->bytes, buffer); + objPtr->length = len; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_NewLongObj -- + * + * If a client is compiled with TCL_MEM_DEBUG defined, calls to + * Tcl_NewLongObj to create a new long 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_NewLongObj result in a call to one of the two + * Tcl_NewLongObj 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. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG +#undef Tcl_NewLongObj + +Tcl_Obj * +Tcl_NewLongObj( + register long longValue) /* Long integer used to initialize the + * new object. */ +{ + return Tcl_DbNewLongObj(longValue, "unknown", 0); +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_NewLongObj( + register long longValue) /* Long integer used to initialize the + * new object. */ +{ + register Tcl_Obj *objPtr; + + TclNewLongObj(objPtr, longValue); + return objPtr; +} +#endif /* if TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbNewLongObj -- + * + * If a client is compiled with TCL_MEM_DEBUG defined, calls to + * Tcl_NewIntObj and Tcl_NewLongObj to create new integer or long integer + * objects end up calling the debugging function Tcl_DbNewLongObj + * instead. We provide two implementations of Tcl_DbNewLongObj so that + * whether the Tcl core is compiled to do memory debugging of the core is + * independent of whether a client requests debugging for itself. + * + * When the core is compiled with TCL_MEM_DEBUG defined, Tcl_DbNewLongObj + * 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 caller's file name and line number when + * reporting objects that haven't been freed. + * + * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined, + * this function just returns the result of calling Tcl_NewLongObj. + * + * Results: + * The newly created long integer object is returned. This object will + * have an invalid string representation. The returned object has ref + * count 0. + * + * Side effects: + * Allocates memory. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG + +Tcl_Obj * +Tcl_DbNewLongObj( + register 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. */ +{ + register Tcl_Obj *objPtr; + + TclDbNewObj(objPtr, file, line); + objPtr->bytes = NULL; + + objPtr->internalRep.longValue = longValue; + objPtr->typePtr = &tclIntType; + return objPtr; +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_DbNewLongObj( + register 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. */ +{ + return Tcl_NewLongObj(longValue); +} +#endif /* TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetLongObj( + register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ + register long longValue) /* Long integer used to initialize the + * object's value. */ { - char *dst = Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE); + if (Tcl_IsShared(objPtr)) { + Tcl_Panic("%s called with shared object", "Tcl_SetLongObj"); + } - TclOOM(dst, (size_t)TCL_INTEGER_SPACE + 1); - (void) Tcl_InitStringRep(objPtr, NULL, - TclFormatInt(dst, objPtr->internalRep.wideValue)); + TclSetLongObj(objPtr, longValue); } /* *---------------------------------------------------------------------- * @@ -2520,82 +2726,78 @@ *---------------------------------------------------------------------- */ int Tcl_GetLongFromObj( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr, /* The object from which to get a long. */ - long *longPtr) /* Place to store resulting long. */ + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr, /* The object from which to get a long. */ + register 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; - } -#else - if (objPtr->typePtr == &tclIntType) { - /* - * We return any integer in the range LONG_MIN to ULONG_MAX + if (objPtr->typePtr == &tclIntType) { + *longPtr = objPtr->internalRep.longValue; + return TCL_OK; + } +#ifndef NO_WIDE_TYPE + if (objPtr->typePtr == &tclWideIntType) { + /* + * We return any integer in the range -ULONG_MAX to ULONG_MAX * converted to a long, ignoring overflow. The rule preserves * existing semantics for conversion of integers on input, but * avoids inadvertent demotion of wide integers to 32-bit ones in * the internal rep. */ Tcl_WideInt w = objPtr->internalRep.wideValue; - - if (w >= (Tcl_WideInt)(LONG_MIN) + if (w >= -(Tcl_WideInt)(ULONG_MAX) && w <= (Tcl_WideInt)(ULONG_MAX)) { - *longPtr = (long) w; + *longPtr = Tcl_WideAsLong(w); return TCL_OK; } goto tooLarge; } #endif - if (objPtr->typePtr == &tclDoubleType) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "expected integer but got \"%s\"", - TclGetString(objPtr))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); + if (objPtr->typePtr == &tclDoubleType) { + if (interp != NULL) { + Tcl_Obj *msg; + + TclNewLiteralStringObj(msg, "expected integer but got \""); + Tcl_AppendObjToObj(msg, objPtr); + Tcl_AppendToObj(msg, "\"", -1); + Tcl_SetObjResult(interp, msg); } return TCL_ERROR; } - if (objPtr->typePtr == &tclBignumType) { + if (objPtr->typePtr == &tclBignumType) { /* * Must check for those bignum values that can fit in a long, even * when auto-narrowing is enabled. Only those values in the signed * long range get auto-narrowed to tclIntType, while all the * values in the unsigned long range will fit in a long. */ - { - 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 + mp_int big; + + UNPACK_BIGNUM(objPtr, big); + if ((size_t)(big.used) <= (CHAR_BIT * sizeof(long) + MP_DIGIT_BIT - 1) + / MP_DIGIT_BIT) { + unsigned long value = 0, numBytes = sizeof(long); + long scratch; + unsigned char *bytes = (unsigned char *)&scratch; + if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) { + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } + if (mp_isneg(&big)) { + *longPtr = - (long) value; + } else { + *longPtr = (long) value; + } + return TCL_OK; + } + } +#ifndef NO_WIDE_TYPE tooLarge: #endif if (interp != NULL) { const char *s = "integer value too large to represent"; Tcl_Obj *msg = Tcl_NewStringObj(s, -1); @@ -2607,10 +2809,53 @@ } } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } +#ifndef NO_WIDE_TYPE + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfWideInt -- + * + * Update the string representation for a wide integer object. 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 + * wideInt-to-string conversion. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfWideInt( + register Tcl_Obj *objPtr) /* Int object whose string rep to update. */ +{ + char buffer[TCL_INTEGER_SPACE+2]; + register unsigned len; + register Tcl_WideInt wideVal = objPtr->internalRep.wideValue; + + /* + * Note that sprintf will generate a compiler warning under Mingw claiming + * %I64 is an unknown format specifier. Just ignore this warning. We can't + * use %L as the format specifier since that gets printed as a 32 bit + * value. + */ + + sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal); + len = strlen(buffer); + objPtr->bytes = ckalloc((unsigned) len + 1); + memcpy(objPtr->bytes, buffer, len + 1); + objPtr->length = len; +} +#endif /* !NO_WIDE_TYPE */ /* *---------------------------------------------------------------------- * * Tcl_NewWideIntObj -- @@ -2638,11 +2883,11 @@ #ifdef TCL_MEM_DEBUG #undef Tcl_NewWideIntObj Tcl_Obj * Tcl_NewWideIntObj( - Tcl_WideInt wideValue) + register Tcl_WideInt wideValue) /* Wide integer used to initialize the new * object. */ { return Tcl_DbNewWideIntObj(wideValue, "unknown", 0); } @@ -2649,18 +2894,18 @@ #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewWideIntObj( - Tcl_WideInt wideValue) + register Tcl_WideInt wideValue) /* Wide integer used to initialize the new * object. */ { - Tcl_Obj *objPtr; + register Tcl_Obj *objPtr; TclNewObj(objPtr); - TclSetIntObj(objPtr, wideValue); + Tcl_SetWideIntObj(objPtr, wideValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ /* @@ -2697,34 +2942,36 @@ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewWideIntObj( - Tcl_WideInt wideValue, + register Tcl_WideInt wideValue, /* Wide integer used to initialize the new * object. */ - const char *file, /* The name of the source file calling this + 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; + register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); - TclSetIntObj(objPtr, wideValue); + Tcl_SetWideIntObj(objPtr, wideValue); return objPtr; } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_DbNewWideIntObj( - Tcl_WideInt wideValue, + register Tcl_WideInt wideValue, /* Long integer used to initialize the new * object. */ - TCL_UNUSED(const char *) /*file*/, - TCL_UNUSED(int) /*line*/) + 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. */ { return Tcl_NewWideIntObj(wideValue); } #endif /* TCL_MEM_DEBUG */ @@ -2746,20 +2993,32 @@ *---------------------------------------------------------------------- */ void Tcl_SetWideIntObj( - Tcl_Obj *objPtr, /* Object w. internal rep to init. */ - Tcl_WideInt wideValue) + register Tcl_Obj *objPtr, /* Object w. internal rep to init. */ + register 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"); } - TclSetIntObj(objPtr, wideValue); + if ((wideValue >= (Tcl_WideInt) LONG_MIN) + && (wideValue <= (Tcl_WideInt) LONG_MAX)) { + TclSetLongObj(objPtr, (long) wideValue); + } else { +#ifndef NO_WIDE_TYPE + TclSetWideIntObj(objPtr, wideValue); +#else + mp_int big; + + TclBNInitBignumFromWideInt(&big, wideValue); + Tcl_SetBignumObj(objPtr, &big); +#endif + } } /* *---------------------------------------------------------------------- * @@ -2781,61 +3040,68 @@ *---------------------------------------------------------------------- */ 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) + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr, /* Object from which to get a wide int. */ + register Tcl_WideInt *wideIntPtr) /* Place to store resulting long. */ { do { - if (objPtr->typePtr == &tclIntType) { +#ifndef NO_WIDE_TYPE + if (objPtr->typePtr == &tclWideIntType) { *wideIntPtr = objPtr->internalRep.wideValue; return TCL_OK; } - if (objPtr->typePtr == &tclDoubleType) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "expected integer but got \"%s\"", - TclGetString(objPtr))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); +#endif + if (objPtr->typePtr == &tclIntType) { + *wideIntPtr = (Tcl_WideInt) objPtr->internalRep.longValue; + return TCL_OK; + } + if (objPtr->typePtr == &tclDoubleType) { + if (interp != NULL) { + Tcl_Obj *msg; + + TclNewLiteralStringObj(msg, "expected integer but got \""); + Tcl_AppendObjToObj(msg, objPtr); + Tcl_AppendToObj(msg, "\"", -1); + Tcl_SetObjResult(interp, msg); } return TCL_ERROR; } - if (objPtr->typePtr == &tclBignumType) { + if (objPtr->typePtr == &tclBignumType) { /* * Must check for those bignum values that can fit in a * Tcl_WideInt, even when auto-narrowing is enabled. */ mp_int big; - Tcl_WideUInt value = 0; - 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) { + + UNPACK_BIGNUM(objPtr, big); + if ((size_t)(big.used) <= (CHAR_BIT * sizeof(Tcl_WideInt) + + MP_DIGIT_BIT - 1) / MP_DIGIT_BIT) { + Tcl_WideUInt value = 0; + unsigned long numBytes = sizeof(Tcl_WideInt); + Tcl_WideInt scratch; + unsigned char *bytes = (unsigned char *) &scratch; + + if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) { + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } + if (mp_isneg(&big)) { *wideIntPtr = - (Tcl_WideInt) value; - return TCL_OK; + } else { + *wideIntPtr = (Tcl_WideInt) value; } - } else { - if (value <= (Tcl_WideUInt)WIDE_MAX) { - *wideIntPtr = (Tcl_WideInt) value; - return TCL_OK; - } + return TCL_OK; } } if (interp != NULL) { const char *s = "integer value too large to represent"; - Tcl_Obj *msg = Tcl_NewStringObj(s, -1); + Tcl_Obj* msg = Tcl_NewStringObj(s, -1); Tcl_SetObjResult(interp, msg); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); } return TCL_ERROR; @@ -2842,80 +3108,37 @@ } } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } +#ifndef NO_WIDE_TYPE /* *---------------------------------------------------------------------- * - * TclGetWideBitsFromObj -- + * SetWideIntFromAny -- * - * Attempt to return a wide integer from the Tcl object "objPtr". If the - * object is not already a int, double or bignum, an attempt will be made - * to convert it to one of these. Out-of-range values don't result in an - * error, but only the least significant 64 bits will be returned. + * Attempts to force the internal representation for a Tcl object to + * tclWideIntType, specifically. * * Results: - * The return value is a standard Tcl object result. If an error occurs + * The return value is a standard object 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 the object is not already an int, double or bignum object, the - * conversion will free any old internal representation. - * *---------------------------------------------------------------------- */ -int -TclGetWideBitsFromObj( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr, /* Object from which to get a wide int. */ - Tcl_WideInt *wideIntPtr) /* Place to store resulting wide integer. */ -{ - do { - if (objPtr->typePtr == &tclIntType) { - *wideIntPtr = objPtr->internalRep.wideValue; - return TCL_OK; - } - if (objPtr->typePtr == &tclDoubleType) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "expected integer but got \"%s\"", - 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; - } - } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, - TCL_PARSE_INTEGER_ONLY)==TCL_OK); - return TCL_ERROR; -} +static int +SetWideIntFromAny( + Tcl_Interp *interp, /* Tcl interpreter */ + Tcl_Obj *objPtr) /* Pointer to the object to convert */ +{ + Tcl_WideInt w; + return Tcl_GetWideIntFromObj(interp, objPtr, &w); +} +#endif /* !NO_WIDE_TYPE */ /* *---------------------------------------------------------------------- * * FreeBignum -- @@ -2932,16 +3155,15 @@ FreeBignum( Tcl_Obj *objPtr) { mp_int toFree; /* Bignum to free */ - TclUnpackBignum(objPtr, toFree); + UNPACK_BIGNUM(objPtr, toFree); mp_clear(&toFree); - if (PTR2INT(objPtr->internalRep.twoPtrValue.ptr2) < 0) { - Tcl_Free(objPtr->internalRep.twoPtrValue.ptr1); + if ((long)(objPtr->internalRep.ptrAndLongRep.value) < 0) { + ckfree((char *)objPtr->internalRep.ptrAndLongRep.ptr); } - objPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * @@ -2965,11 +3187,11 @@ { mp_int bignumVal; mp_int bignumCopy; copyPtr->typePtr = &tclBignumType; - TclUnpackBignum(srcPtr, bignumVal); + UNPACK_BIGNUM(srcPtr, bignumVal); if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) { Tcl_Panic("initialization failure in DupBignum"); } PACK_BIGNUM(bignumCopy, copyPtr); } @@ -2998,14 +3220,16 @@ UpdateStringOfBignum( Tcl_Obj *objPtr) { mp_int bignumVal; int size; - char *stringVal; + int status; + char* stringVal; - TclUnpackBignum(objPtr, bignumVal); - if (MP_OKAY != mp_radix_size(&bignumVal, 10, &size)) { + UNPACK_BIGNUM(objPtr, bignumVal); + status = mp_radix_size(&bignumVal, 10, &size); + if (status != MP_OKAY) { Tcl_Panic("radix size failure in UpdateStringOfBignum"); } if (size < 2) { /* * mp_radix_size() returns < 2 when more than INT_MAX bytes would be @@ -3016,18 +3240,17 @@ * in a packed bignum, this branch will never be taken. */ 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)) { + stringVal = ckalloc((size_t) size); + status = mp_toradix_n(&bignumVal, stringVal, 10, size); + if (status != MP_OKAY) { Tcl_Panic("conversion failure in UpdateStringOfBignum"); } - (void) Tcl_InitStringRep(objPtr, NULL, size - 1); + objPtr->bytes = stringVal; + objPtr->length = size - 1; /* size includes a trailing null byte */ } /* *---------------------------------------------------------------------- * @@ -3047,20 +3270,20 @@ #ifdef TCL_MEM_DEBUG #undef Tcl_NewBignumObj Tcl_Obj * Tcl_NewBignumObj( - void *bignumValue) + mp_int *bignumValue) { return Tcl_DbNewBignumObj(bignumValue, "unknown", 0); } #else Tcl_Obj * Tcl_NewBignumObj( - void *bignumValue) + mp_int *bignumValue) { - Tcl_Obj *objPtr; + Tcl_Obj* objPtr; TclNewObj(objPtr); Tcl_SetBignumObj(objPtr, bignumValue); return objPtr; } @@ -3085,12 +3308,12 @@ */ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewBignumObj( - void *bignumValue, - const char *file, + mp_int *bignumValue, + CONST char *file, int line) { Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); @@ -3098,13 +3321,13 @@ return objPtr; } #else Tcl_Obj * Tcl_DbNewBignumObj( - void *bignumValue, - TCL_UNUSED(const char *) /*file*/, - TCL_UNUSED(int) /*line*/) + mp_int *bignumValue, + CONST char *file, + int line) { return Tcl_NewBignumObj(bignumValue); } #endif @@ -3138,45 +3361,42 @@ { 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; - } + UNPACK_BIGNUM(objPtr, temp); + mp_init_copy(bignumValue, &temp); } else { - TclUnpackBignum(objPtr, *bignumValue); - /* Optimized TclFreeIntRep */ - objPtr->internalRep.twoPtrValue.ptr1 = NULL; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; + UNPACK_BIGNUM(objPtr, *bignumValue); + objPtr->internalRep.ptrAndLongRep.ptr = NULL; + objPtr->internalRep.ptrAndLongRep.value = 0; 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); + TclInitStringRep(objPtr, tclEmptyStringRep, 0); } } return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - if (mp_init_i64(bignumValue, - objPtr->internalRep.wideValue) != MP_OKAY) { - return TCL_ERROR; - } + TclBNInitBignumFromLong(bignumValue, objPtr->internalRep.longValue); + return TCL_OK; + } +#ifndef NO_WIDE_TYPE + if (objPtr->typePtr == &tclWideIntType) { + TclBNInitBignumFromWideInt(bignumValue, + objPtr->internalRep.wideValue); return TCL_OK; } +#endif if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "expected integer but got \"%s\"", - TclGetString(objPtr))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); + Tcl_Obj *msg; + + TclNewLiteralStringObj(msg, "expected integer but got \""); + Tcl_AppendObjToObj(msg, objPtr); + Tcl_AppendToObj(msg, "\"", -1); + Tcl_SetObjResult(interp, msg); } return TCL_ERROR; } } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, TCL_PARSE_INTEGER_ONLY)==TCL_OK); @@ -3210,13 +3430,13 @@ int Tcl_GetBignumFromObj( Tcl_Interp *interp, /* Tcl interpreter for error reporting */ Tcl_Obj *objPtr, /* Object to read */ - void *bignumValue) /* Returned bignum value. */ + mp_int *bignumValue) /* Returned bignum value. */ { - return GetBignumFromObj(interp, objPtr, 1, (mp_int *)bignumValue); + return GetBignumFromObj(interp, objPtr, 1, bignumValue); } /* *---------------------------------------------------------------------- * @@ -3245,13 +3465,13 @@ int Tcl_TakeBignumFromObj( Tcl_Interp *interp, /* Tcl interpreter for error reporting */ Tcl_Obj *objPtr, /* Object to read */ - void *bignumValue) /* Returned bignum value. */ + mp_int *bignumValue) /* Returned bignum value. */ { - return GetBignumFromObj(interp, objPtr, 0, (mp_int *)bignumValue); + return GetBignumFromObj(interp, objPtr, 0, bignumValue); } /* *---------------------------------------------------------------------- * @@ -3270,75 +3490,81 @@ */ 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; - + mp_int *bignumValue) /* Value to store */ +{ 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; - } - if (bignumValue->sign) { - TclSetIntObj(objPtr, -(Tcl_WideInt)value); - } else { - TclSetIntObj(objPtr, (Tcl_WideInt)value); - } - mp_clear(bignumValue); - return; + if ((size_t)(bignumValue->used) + <= (CHAR_BIT * sizeof(long) + MP_DIGIT_BIT - 1) / MP_DIGIT_BIT) { + unsigned long value = 0, numBytes = sizeof(long); + long scratch; + unsigned char *bytes = (unsigned char *)&scratch; + if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) { + goto tooLargeForLong; + } + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } + if (value > (((~(unsigned long)0) >> 1) + mp_isneg(bignumValue))) { + goto tooLargeForLong; + } + if (mp_isneg(bignumValue)) { + TclSetLongObj(objPtr, -(long)value); + } else { + TclSetLongObj(objPtr, (long)value); + } + mp_clear(bignumValue); + return; + } + tooLargeForLong: +#ifndef NO_WIDE_TYPE + if ((size_t)(bignumValue->used) + <= (CHAR_BIT * sizeof(Tcl_WideInt) + MP_DIGIT_BIT - 1) / MP_DIGIT_BIT) { + Tcl_WideUInt value = 0; + unsigned long numBytes = sizeof(Tcl_WideInt); + Tcl_WideInt scratch; + unsigned char *bytes = (unsigned char *)&scratch; + if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) { + goto tooLargeForWide; + } + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } + if (value > (((~(Tcl_WideUInt)0) >> 1) + mp_isneg(bignumValue))) { + goto tooLargeForWide; + } + if (mp_isneg(bignumValue)) { + TclSetWideIntObj(objPtr, -(Tcl_WideInt)value); + } else { + TclSetWideIntObj(objPtr, (Tcl_WideInt)value); + } + mp_clear(bignumValue); + return; + } tooLargeForWide: +#endif TclInvalidateStringRep(objPtr); TclFreeIntRep(objPtr); TclSetBignumIntRep(objPtr, bignumValue); } -/* - *---------------------------------------------------------------------- - * - * TclSetBignumIntRep -- - * - * Install a bignum into the internal representation of an object. - * - * Results: - * None. - * - * Side effects: - * Object internal representation is updated and object type is set. The - * bignum value is cleared, since ownership has transferred to the - * object. - * - *---------------------------------------------------------------------- - */ - void TclSetBignumIntRep( Tcl_Obj *objPtr, - void *big) + mp_int *bignumValue) { - 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 - * packed into the Tcl_Obj. + * Don't call mp_clear() because it would free the digit array + * we just packed into the Tcl_Obj. */ bignumValue->dp = NULL; bignumValue->alloc = bignumValue->used = 0; bignumValue->sign = MP_NEG; @@ -3347,27 +3573,18 @@ /* *---------------------------------------------------------------------- * * TclGetNumberFromObj -- * - * Extracts a number (of any possible numeric type) from an object. - * * Results: - * Whether the extraction worked. The type is stored in the variable - * referred to by the typePtr argument, and a pointer to the - * representation is stored in the variable referred to by the - * clientDataPtr. * * Side effects: - * Can allocate thread-specific data for handling the copy-out space for - * bignums; this space is shared within a thread. * *---------------------------------------------------------------------- */ -int -TclGetNumberFromObj( +int TclGetNumberFromObj( Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientDataPtr, int *typePtr) { @@ -3376,97 +3593,38 @@ if (TclIsNaN(objPtr->internalRep.doubleValue)) { *typePtr = TCL_NUMBER_NAN; } else { *typePtr = TCL_NUMBER_DOUBLE; } - *clientDataPtr = &objPtr->internalRep.doubleValue; + *clientDataPtr = &(objPtr->internalRep.doubleValue); return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - *typePtr = TCL_NUMBER_INT; - *clientDataPtr = &objPtr->internalRep.wideValue; + *typePtr = TCL_NUMBER_LONG; + *clientDataPtr = &(objPtr->internalRep.longValue); + return TCL_OK; + } +#ifndef NO_WIDE_TYPE + if (objPtr->typePtr == &tclWideIntType) { + *typePtr = TCL_NUMBER_WIDE; + *clientDataPtr = &(objPtr->internalRep.wideValue); return TCL_OK; } +#endif if (objPtr->typePtr == &tclBignumType) { static Tcl_ThreadDataKey bignumKey; - mp_int *bigPtr = (mp_int *)Tcl_GetThreadData(&bignumKey, - sizeof(mp_int)); - - TclUnpackBignum(objPtr, *bigPtr); + mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, + (int) sizeof(mp_int)); + UNPACK_BIGNUM( objPtr, *bigPtr ); *typePtr = TCL_NUMBER_BIG; *clientDataPtr = bigPtr; return TCL_OK; } } while (TCL_OK == TclParseNumber(interp, objPtr, "number", NULL, -1, NULL, 0)); return TCL_ERROR; } - -/* - *---------------------------------------------------------------------- - * - * Tcl_IncrRefCount -- - * - * Increments the reference count of the object. - * - * Results: - * None. - * - *---------------------------------------------------------------------- - */ - -#undef Tcl_IncrRefCount -void -Tcl_IncrRefCount( - Tcl_Obj *objPtr) /* The object we are registering a reference to. */ -{ - ++(objPtr)->refCount; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DecrRefCount -- - * - * Decrements the reference count of the object. - * - * Results: - * None. - * - *---------------------------------------------------------------------- - */ - -#undef Tcl_DecrRefCount -void -Tcl_DecrRefCount( - Tcl_Obj *objPtr) /* The object we are releasing a reference to. */ -{ - if (objPtr->refCount-- <= 1) { - TclFreeObj(objPtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_IsShared -- - * - * Tests if the object has a ref count greater than one. - * - * Results: - * Boolean value that is the result of the test. - * - *---------------------------------------------------------------------- - */ - -#undef Tcl_IsShared -int -Tcl_IsShared( - Tcl_Obj *objPtr) /* The object to test for being shared. */ -{ - return ((objPtr)->refCount + 1 > 2); -} /* *---------------------------------------------------------------------- * * Tcl_DbIncrRefCount -- @@ -3485,61 +3643,53 @@ * The object's ref count is incremented. * *---------------------------------------------------------------------- */ -#ifdef TCL_MEM_DEBUG void Tcl_DbIncrRefCount( - Tcl_Obj *objPtr, /* The object we are registering a reference + register Tcl_Obj *objPtr, /* The object we are registering a reference * to. */ - const char *file, /* The name of the source file calling this + CONST char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ { +#ifdef TCL_MEM_DEBUG if (objPtr->refCount == 0x61616161) { fprintf(stderr, "file = %s, line = %d\n", file, line); fflush(stderr); Tcl_Panic("incrementing refCount of previously disposed object"); } -#if TCL_THREADS +# ifdef TCL_THREADS /* * Check to make sure that the Tcl_Obj was allocated by the current * thread. Don't do this check when shutting down since thread local * storage can be finalized before the last Tcl_Obj is freed. */ if (!TclInExit()) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - Tcl_HashTable *tablePtr = tsdPtr->objThreadMap; + Tcl_HashTable *tablePtr; Tcl_HashEntry *hPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + tablePtr = tsdPtr->objThreadMap; if (!tablePtr) { Tcl_Panic("object table not initialized"); } - hPtr = Tcl_FindHashEntry(tablePtr, objPtr); - if (!hPtr) { - Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", - "incr ref count"); - } - } -# endif /* TCL_THREADS */ - ++(objPtr)->refCount; -} -#else /* !TCL_MEM_DEBUG */ -void -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 */ + hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); + if (!hPtr) { + Tcl_Panic("%s%s", + "Trying to incr ref count of " + "Tcl_Obj allocated in another thread"); + } + } +# endif +#endif + ++(objPtr)->refCount; +} /* *---------------------------------------------------------------------- * * Tcl_DbDecrRefCount -- @@ -3558,66 +3708,55 @@ * The object's ref count is incremented. * *---------------------------------------------------------------------- */ -#ifdef TCL_MEM_DEBUG void Tcl_DbDecrRefCount( - Tcl_Obj *objPtr, /* The object we are releasing a reference + register Tcl_Obj *objPtr, /* The object we are releasing a reference * to. */ - const char *file, /* The name of the source file calling this + CONST char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ { +#ifdef TCL_MEM_DEBUG if (objPtr->refCount == 0x61616161) { fprintf(stderr, "file = %s, line = %d\n", file, line); fflush(stderr); Tcl_Panic("decrementing refCount of previously disposed object"); } -#if TCL_THREADS +# ifdef TCL_THREADS /* * Check to make sure that the Tcl_Obj was allocated by the current * thread. Don't do this check when shutting down since thread local * storage can be finalized before the last Tcl_Obj is freed. */ if (!TclInExit()) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - Tcl_HashTable *tablePtr = tsdPtr->objThreadMap; - Tcl_HashEntry *hPtr; - - if (!tablePtr) { - Tcl_Panic("object table not initialized"); - } - hPtr = Tcl_FindHashEntry(tablePtr, objPtr); - if (!hPtr) { - Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", - "decr ref count"); - } - } -# endif /* TCL_THREADS */ - - if (objPtr->refCount-- <= 1) { - TclFreeObj(objPtr); - } -} -#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_HashTable *tablePtr; + Tcl_HashEntry *hPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + tablePtr = tsdPtr->objThreadMap; + if (!tablePtr) { + Tcl_Panic("object table not initialized"); + } + hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); + if (!hPtr) { + Tcl_Panic("%s%s", + "Trying to decr ref count of " + "Tcl_Obj allocated in another thread"); + } + } +# endif +#endif + if (--(objPtr)->refCount <= 0) { + TclFreeObj(objPtr); + } +} /* *---------------------------------------------------------------------- * * Tcl_DbIsShared -- @@ -3638,51 +3777,47 @@ *---------------------------------------------------------------------- */ 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 + register Tcl_Obj *objPtr, /* The object to test for being shared. */ + CONST char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ -#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"); } -#if TCL_THREADS +# ifdef TCL_THREADS /* * Check to make sure that the Tcl_Obj was allocated by the current * thread. Don't do this check when shutting down since thread local * storage can be finalized before the last Tcl_Obj is freed. */ if (!TclInExit()) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - Tcl_HashTable *tablePtr = tsdPtr->objThreadMap; + Tcl_HashTable *tablePtr; Tcl_HashEntry *hPtr; - + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + tablePtr = tsdPtr->objThreadMap; if (!tablePtr) { Tcl_Panic("object table not initialized"); } - hPtr = Tcl_FindHashEntry(tablePtr, objPtr); + hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); if (!hPtr) { - Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", - "check shared status"); + Tcl_Panic("%s%s", + "Trying to check shared status of" + "Tcl_Obj allocated in another thread"); } } -# endif /* TCL_THREADS */ -#endif /* TCL_MEM_DEBUG */ +# endif +#endif #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); if ((objPtr)->refCount <= 1) { tclObjsShared[1]++; @@ -3690,11 +3825,11 @@ tclObjsShared[(objPtr)->refCount]++; } else { tclObjsShared[0]++; } Tcl_MutexUnlock(&tclObjMutex); -#endif /* TCL_COMPILE_STATS */ +#endif return ((objPtr)->refCount > 1); } /* @@ -3715,11 +3850,11 @@ *---------------------------------------------------------------------- */ void Tcl_InitObjHashTable( - Tcl_HashTable *tablePtr) + register Tcl_HashTable *tablePtr) /* Pointer to table record, which is supplied * by the caller. */ { Tcl_InitCustomHashTable(tablePtr, TCL_CUSTOM_PTR_KEYS, &tclObjHashKeyType); @@ -3741,17 +3876,18 @@ *---------------------------------------------------------------------- */ static Tcl_HashEntry * AllocObjEntry( - TCL_UNUSED(Tcl_HashTable *), + Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key to store in the hash table entry. */ { - Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; - Tcl_HashEntry *hPtr = (Tcl_HashEntry *)Tcl_Alloc(sizeof(Tcl_HashEntry)); + Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr; + Tcl_HashEntry *hPtr; - hPtr->key.objPtr = objPtr; + hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry))); + hPtr->key.oneWordValue = (char *) objPtr; Tcl_IncrRefCount(objPtr); hPtr->clientData = NULL; return hPtr; } @@ -3776,14 +3912,14 @@ 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; + Tcl_Obj *objPtr1 = (Tcl_Obj *) keyPtr; + Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue; + register CONST char *p1, *p2; + register int l1, l2; /* * If the object pointers are the same then they match. * OPT: this comparison was moved to the caller @@ -3839,11 +3975,11 @@ Tcl_HashEntry *hPtr) /* Hash entry to free. */ { Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue; Tcl_DecrRefCount(objPtr); - Tcl_Free(hPtr); + ckfree((char *) hPtr); } /* *---------------------------------------------------------------------- * @@ -3860,59 +3996,39 @@ * None. * *---------------------------------------------------------------------- */ -TCL_HASH_TYPE +unsigned int TclHashObjKey( - TCL_UNUSED(Tcl_HashTable *), + Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key from which to compute hash value. */ { - Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; - const char *string = TclGetString(objPtr); - size_t length = objPtr->length; - TCL_HASH_TYPE result = 0; + Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr; + CONST char *string = TclGetString(objPtr); + int length = objPtr->length; + unsigned int result = 0; + int i; /* * 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: * * 1. Multiplying by 10 is perfect for keys that are decimal strings, and - * multiplying by 9 is just about as good. + * multiplying by 9 is just about as good. * 2. Times-9 is (shift-left-3) plus (old). This means that each - * character's bits hang around in the low-order bits of the hash value - * for ever, plus they spread fairly rapidly up to the high-order bits - * to fill out the hash value. This seems works well both for decimal - * and non-decimal strings. - * - * Note that this function is very weak against malicious strings; it's - * very easy to generate multiple keys that have the same hashcode. On the - * other hand, that hardly ever actually occurs and this function *is* - * very cheap, even by comparison with industry-standard hashes like FNV. - * If real strength of hash is required though, use a custom hash based on - * Bob Jenkins's lookup3(), but be aware that it's significantly slower. - * Tcl does not use that level of strength because it typically does not - * need it (and some of the aspects of that strength are genuinely - * unnecessary given the rest of Tcl's hash machinery, and the fact that - * we do not either transfer hashes to another machine, use them as a true - * substitute for equality, or attempt to minimize work in rebuilding the - * hash table). - * - * See also HashStringKey in tclHash.c. - * See also HashString in tclLiteral.c. - * - * See [tcl-Feature Request #2958832] + * character's bits hang around in the low-order bits of the hash value + * for ever, plus they spread fairly rapidly up to the high-order bits + * to fill out the hash value. This seems works well both for decimal + * and *non-decimal strings. */ - if (length) { - result = UCHAR(*string); - while (--length) { - result += (result << 3) + UCHAR(*++string); - } + for (i=0 ; iinternalRep.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); + resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1; + if ((objPtr->typePtr != &tclCmdNameType) + || (resPtr == NULL) + || (cmdPtr = resPtr->cmdPtr, cmdPtr->cmdEpoch != resPtr->cmdEpoch) + || (cmdPtr->flags & CMD_IS_DELETED) + || (interp != cmdPtr->nsPtr->interp) + || (cmdPtr->nsPtr->flags & NS_DYING) + || ((resPtr->refNsPtr != NULL) && + (((refNsPtr = (Namespace *) TclGetCurrentNamespace(interp)) + != resPtr->refNsPtr) + || (resPtr->refNsId != refNsPtr->nsId) + || (resPtr->refNsCmdEpoch != refNsPtr->cmdRefEpoch))) + ) { + + result = tclCmdNameType.setFromAnyProc(interp, objPtr); + + resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1; + if ((result == TCL_OK) && resPtr) { + cmdPtr = resPtr->cmdPtr; + } else { + cmdPtr = NULL; + } + } + + return (Tcl_Command) cmdPtr; } /* *---------------------------------------------------------------------- * @@ -4010,87 +4124,63 @@ * * Side effects: * The object's old internal rep is freed. It's string rep is not * changed. The refcount in the Command structure is incremented to keep * it from being freed if the command is later deleted until - * TclNRExecuteByteCode has a chance to recognize that it was deleted. + * TclExecuteByteCode has a chance to recognize that it was deleted. * *---------------------------------------------------------------------- */ -static void -SetCmdNameObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - Command *cmdPtr, - ResolvedCmdName *resPtr) -{ - Interp *iPtr = (Interp *) interp; - ResolvedCmdName *fillPtr; - const char *name = TclGetString(objPtr); - - if (resPtr) { - fillPtr = resPtr; - } else { - fillPtr = (ResolvedCmdName *)Tcl_Alloc(sizeof(ResolvedCmdName)); - fillPtr->refCount = 1; - } - - fillPtr->cmdPtr = cmdPtr; - cmdPtr->refCount++; - fillPtr->cmdEpoch = cmdPtr->cmdEpoch; - - /* NOTE: relying on NULL termination here. */ - if ((name[0] == ':') && (name[1] == ':')) { - /* - * Fully qualified names always resolve to same thing. No need - * to record resolution context information. - */ - - fillPtr->refNsPtr = NULL; - fillPtr->refNsId = 0; /* Will not be read */ - fillPtr->refNsCmdEpoch = 0; /* Will not be read */ - } else { - /* - * Record current state of current namespace as the resolution - * context of this command name lookup. - */ - Namespace *currNsPtr = iPtr->varFramePtr->nsPtr; - - fillPtr->refNsPtr = currNsPtr; - fillPtr->refNsId = currNsPtr->nsId; - fillPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; - } - - if (resPtr == NULL) { - TclFreeIntRep(objPtr); - - objPtr->internalRep.twoPtrValue.ptr1 = fillPtr; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclCmdNameType; - } -} - 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 + register 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; + Interp *iPtr = (Interp *) interp; + register ResolvedCmdName *resPtr; + register Namespace *currNsPtr; + char *name; if (objPtr->typePtr == &tclCmdNameType) { - resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1; - if (resPtr != NULL && resPtr->cmdPtr == cmdPtr) { - return; - } + return; + } + + cmdPtr->refCount++; + resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); + resPtr->cmdPtr = cmdPtr; + resPtr->cmdEpoch = cmdPtr->cmdEpoch; + resPtr->refCount = 1; + + name = TclGetString(objPtr); + if ((*name++ == ':') && (*name == ':')) { + /* + * The name is fully qualified: set the referring namespace to + * NULL. + */ + + resPtr->refNsPtr = NULL; + } else { + /* + * Get the current namespace. + */ + + currNsPtr = iPtr->varFramePtr->nsPtr; + + resPtr->refNsPtr = currNsPtr; + resPtr->refNsId = currNsPtr->nsId; + resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; } - SetCmdNameObj(interp, objPtr, cmdPtr, NULL); + TclFreeIntRep(objPtr); + objPtr->internalRep.twoPtrValue.ptr1 = (void *) resPtr; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = &tclCmdNameType; } /* *---------------------------------------------------------------------- * @@ -4112,32 +4202,35 @@ *---------------------------------------------------------------------- */ static void FreeCmdNameInternalRep( - Tcl_Obj *objPtr) /* CmdName object with internal + register Tcl_Obj *objPtr) /* CmdName object with internal * representation to free. */ { - ResolvedCmdName *resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1; + register ResolvedCmdName *resPtr = + (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1; + if (resPtr != NULL) { /* * Decrement the reference count of the ResolvedCmdName structure. If * there are no more uses, free the ResolvedCmdName structure. */ - if (resPtr->refCount-- <= 1) { + resPtr->refCount--; + if (resPtr->refCount == 0) { /* * 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); - Tcl_Free(resPtr); + ckfree((char *) resPtr); } + } objPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- @@ -4160,17 +4253,20 @@ */ static void DupCmdNameInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ - Tcl_Obj *copyPtr) /* Object with internal rep to set. */ + register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - ResolvedCmdName *resPtr = (ResolvedCmdName *)srcPtr->internalRep.twoPtrValue.ptr1; + register ResolvedCmdName *resPtr = (ResolvedCmdName *) + srcPtr->internalRep.twoPtrValue.ptr1; - copyPtr->internalRep.twoPtrValue.ptr1 = resPtr; + copyPtr->internalRep.twoPtrValue.ptr1 = (void *) resPtr; copyPtr->internalRep.twoPtrValue.ptr2 = NULL; + if (resPtr != NULL) { resPtr->refCount++; + } copyPtr->typePtr = &tclCmdNameType; } /* *---------------------------------------------------------------------- @@ -4194,15 +4290,17 @@ */ static int SetCmdNameFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr) /* The object to convert. */ + register Tcl_Obj *objPtr) /* The object to convert. */ { - const char *name; - Command *cmdPtr; - ResolvedCmdName *resPtr; + Interp *iPtr = (Interp *) interp; + char *name; + register Command *cmdPtr; + Namespace *currNsPtr; + register ResolvedCmdName *resPtr; if (interp == NULL) { return TCL_ERROR; } @@ -4213,111 +4311,70 @@ * structure. A Command structure will not be deleted as long as it is * referenced from a CmdName object. */ name = TclGetString(objPtr); - cmdPtr = (Command *) - Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0); - - /* - * Stop shimmering and caching nothing when we found nothing. Just - * report the failure to find the command as an error. - */ - - if (cmdPtr == NULL || !TclRoutineHasName(cmdPtr)) { - return TCL_ERROR; - } - - resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1; - if ((objPtr->typePtr == &tclCmdNameType) && (resPtr->refCount == 1)) { - /* - * Re-use existing ResolvedCmdName struct when possible. - * Cleanup the old fields that need it. - */ - - Command *oldCmdPtr = resPtr->cmdPtr; - - if (oldCmdPtr->refCount-- <= 1) { - TclCleanupCommandMacro(oldCmdPtr); - } - } else { - resPtr = NULL; - } - - SetCmdNameObj(interp, objPtr, cmdPtr, resPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_RepresentationCmd -- - * - * Implementation of the "tcl::unsupported::representation" command. - * - * Results: - * Reports the current representation (Tcl_Obj type) of its argument. - * - * Side effects: - * 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 %" TCL_Z_MODIFIER "u," - " 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", - objv[1]->internalRep.doubleValue); - } else { - Tcl_AppendPrintfToObj(descObj, ", internal representation %p:%p", - (void *) objv[1]->internalRep.twoPtrValue.ptr1, - (void *) objv[1]->internalRep.twoPtrValue.ptr2); - } - } - - if (objv[1]->bytes) { - Tcl_AppendToObj(descObj, ", string representation \"", -1); - Tcl_AppendLimitedToObj(descObj, objv[1]->bytes, objv[1]->length, - 16, "..."); - Tcl_AppendToObj(descObj, "\"", -1); - } else { - Tcl_AppendToObj(descObj, ", no string representation", -1); - } - - Tcl_SetObjResult(interp, descObj); + cmdPtr = (Command *) Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0); + + /* + * Free the old internalRep before setting the new one. Do this after + * getting the string rep to allow the conversion code (in particular, + * Tcl_GetStringFromObj) to use that old internalRep. + */ + + if (cmdPtr) { + cmdPtr->refCount++; + resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1; + if ((objPtr->typePtr == &tclCmdNameType) + && resPtr && (resPtr->refCount == 1)) { + /* + * Reuse the old ResolvedCmdName struct instead of freeing it + */ + + Command *oldCmdPtr = resPtr->cmdPtr; + if (--oldCmdPtr->refCount == 0) { + TclCleanupCommandMacro(oldCmdPtr); + } + } else { + TclFreeIntRep(objPtr); + resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); + resPtr->refCount = 1; + objPtr->internalRep.twoPtrValue.ptr1 = (void *) resPtr; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = &tclCmdNameType; + } + resPtr->cmdPtr = cmdPtr; + resPtr->cmdEpoch = cmdPtr->cmdEpoch; + if ((*name++ == ':') && (*name == ':')) { + /* + * The name is fully qualified: set the referring namespace to + * NULL. + */ + + resPtr->refNsPtr = NULL; + } else { + /* + * Get the current namespace. + */ + + currNsPtr = iPtr->varFramePtr->nsPtr; + + resPtr->refNsPtr = currNsPtr; + resPtr->refNsId = currNsPtr->nsId; + resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; + } + } else { + TclFreeIntRep(objPtr); + objPtr->internalRep.twoPtrValue.ptr1 = NULL; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = &tclCmdNameType; + } return TCL_OK; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 - * tab-width: 8 - * indent-tabs-mode: nil * End: */ DELETED generic/tclOptimize.c Index: generic/tclOptimize.c ================================================================== --- generic/tclOptimize.c +++ /dev/null @@ -1,442 +0,0 @@ -/* - * tclOptimize.c -- - * - * This file contains the bytecode optimizer. - * - * Copyright (c) 2013 by Donal Fellows. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include "tclInt.h" -#include "tclCompile.h" -#include - -/* - * Forward declarations. - */ - -static void AdvanceJumps(CompileEnv *envPtr); -static void ConvertZeroEffectToNOP(CompileEnv *envPtr); -static void LocateTargetAddresses(CompileEnv *envPtr, - Tcl_HashTable *tablePtr); -static void TrimUnreachable(CompileEnv *envPtr); - -/* - * Helper macros. - */ - -#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 - * because they're the targets of various kinds of jumps and other - * non-local behavior. - * - * ---------------------------------------------------------------------- - */ - -static void -LocateTargetAddresses( - CompileEnv *envPtr, - Tcl_HashTable *tablePtr) -{ - unsigned char *currentInstPtr, *targetInstPtr; - int isNew, i; - Tcl_HashEntry *hPtr; - Tcl_HashSearch hSearch; - - Tcl_InitHashTable(tablePtr, TCL_ONE_WORD_KEYS); - - /* - * The starts of commands represent target addresses. - */ - - for (i=0 ; inumCommands ; i++) { - DefineTargetAddress(tablePtr, - envPtr->codeStart + envPtr->cmdMapPtr[i].codeOffset); - } - - /* - * Find places where we should be careful about replacing instructions - * because they are the targets of various types of jumps. - */ - - for (currentInstPtr = envPtr->codeStart ; - currentInstPtr < envPtr->codeNext ; - currentInstPtr += AddrLength(currentInstPtr)) { - switch (*currentInstPtr) { - case INST_JUMP1: - case INST_JUMP_TRUE1: - case INST_JUMP_FALSE1: - targetInstPtr = currentInstPtr+TclGetInt1AtPtr(currentInstPtr+1); - goto storeTarget; - case INST_JUMP4: - case INST_JUMP_TRUE4: - case INST_JUMP_FALSE4: - case INST_START_CMD: - targetInstPtr = currentInstPtr+TclGetInt4AtPtr(currentInstPtr+1); - goto storeTarget; - case INST_BEGIN_CATCH4: - targetInstPtr = envPtr->codeStart + envPtr->exceptArrayPtr[ - TclGetUInt4AtPtr(currentInstPtr+1)].codeOffset; - storeTarget: - DefineTargetAddress(tablePtr, targetInstPtr); - break; - case INST_JUMP_TABLE: - hPtr = Tcl_FirstHashEntry( - &JUMPTABLEINFO(envPtr, currentInstPtr+1)->hashTable, - &hSearch); - for (; hPtr ; hPtr = Tcl_NextHashEntry(&hSearch)) { - targetInstPtr = currentInstPtr + - PTR2INT(Tcl_GetHashValue(hPtr)); - DefineTargetAddress(tablePtr, targetInstPtr); - } - break; - case INST_RETURN_CODE_BRANCH: - for (i=TCL_ERROR ; iexceptArrayNext ; i++) { - ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i]; - - if (rangePtr->type == CATCH_EXCEPTION_RANGE) { - targetInstPtr = envPtr->codeStart + rangePtr->catchOffset; - DefineTargetAddress(tablePtr, targetInstPtr); - } else { - targetInstPtr = envPtr->codeStart + rangePtr->breakOffset; - DefineTargetAddress(tablePtr, targetInstPtr); - if (rangePtr->continueOffset >= 0) { - targetInstPtr = envPtr->codeStart + rangePtr->continueOffset; - DefineTargetAddress(tablePtr, targetInstPtr); - } - } - } -} - -/* - * ---------------------------------------------------------------------- - * - * TrimUnreachable -- - * - * Converts code that provably can't be executed into NOPs and reduces - * the overall reported length of the bytecode where that is possible. - * - * ---------------------------------------------------------------------- - */ - -static void -TrimUnreachable( - CompileEnv *envPtr) -{ - unsigned char *currentInstPtr; - Tcl_HashTable targets; - - LocateTargetAddresses(envPtr, &targets); - - for (currentInstPtr = envPtr->codeStart ; - currentInstPtr < envPtr->codeNext-1 ; - currentInstPtr += AddrLength(currentInstPtr)) { - int clear = 0; - - if (*currentInstPtr != INST_DONE) { - continue; - } - - while (!IsTargetAddress(&targets, currentInstPtr + 1 + clear)) { - clear += AddrLength(currentInstPtr + 1 + clear); - } - if (currentInstPtr + 1 + clear == envPtr->codeNext) { - envPtr->codeNext -= clear; - } else { - while (clear --> 0) { - *(currentInstPtr + 1 + clear) = INST_NOP; - } - } - } - - Tcl_DeleteHashTable(&targets); -} - -/* - * ---------------------------------------------------------------------- - * - * ConvertZeroEffectToNOP -- - * - * Replace PUSH/POP sequences (when non-hazardous) with NOPs. Also - * replace PUSH empty/STR_CONCAT and TRY_CVT_NUMERIC (when followed by an - * operation that guarantees the check for arithmeticity) and eliminate - * LNOT when we can invert the following JUMP condition. - * - * ---------------------------------------------------------------------- - */ - -static void -ConvertZeroEffectToNOP( - CompileEnv *envPtr) -{ - unsigned char *currentInstPtr; - int size; - Tcl_HashTable targets; - - LocateTargetAddresses(envPtr, &targets); - for (currentInstPtr = envPtr->codeStart ; - currentInstPtr < envPtr->codeNext ; currentInstPtr += size) { - int blank = 0, i, nextInst; - - size = AddrLength(currentInstPtr); - while ((currentInstPtr + size < envPtr->codeNext) - && *(currentInstPtr+size) == INST_NOP) { - if (IsTargetAddress(&targets, currentInstPtr + size)) { - break; - } - size += InstLength(INST_NOP); - } - if (IsTargetAddress(&targets, currentInstPtr + size)) { - continue; - } - nextInst = *(currentInstPtr + size); - switch (*currentInstPtr) { - case INST_PUSH1: - if (nextInst == INST_POP) { - blank = size + InstLength(nextInst); - } else if (nextInst == INST_STR_CONCAT1 - && TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) { - Tcl_Obj *litPtr = TclFetchLiteral(envPtr, - TclGetUInt1AtPtr(currentInstPtr + 1)); - size_t 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)); - size_t numBytes; - - (void) TclGetStringFromObj(litPtr, &numBytes); - if (numBytes == 0) { - blank = size + InstLength(nextInst); - } - } - break; - - case INST_LNOT: - switch (nextInst) { - case INST_JUMP_TRUE1: - blank = size; - *(currentInstPtr + size) = INST_JUMP_FALSE1; - break; - case INST_JUMP_FALSE1: - blank = size; - *(currentInstPtr + size) = INST_JUMP_TRUE1; - break; - case INST_JUMP_TRUE4: - blank = size; - *(currentInstPtr + size) = INST_JUMP_FALSE4; - break; - case INST_JUMP_FALSE4: - blank = size; - *(currentInstPtr + size) = INST_JUMP_TRUE4; - break; - } - break; - - case INST_TRY_CVT_TO_NUMERIC: - switch (nextInst) { - case INST_JUMP_TRUE1: - case INST_JUMP_TRUE4: - 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: - case INST_LSHIFT: - case INST_RSHIFT: - case INST_BITOR: - case INST_BITXOR: - case INST_BITAND: - case INST_EXPON: - case INST_ADD: - case INST_SUB: - case INST_DIV: - case INST_MULT: - case INST_LNOT: - case INST_BITNOT: - case INST_UMINUS: - case INST_UPLUS: - case INST_TRY_CVT_TO_NUMERIC: - blank = size; - break; - } - break; - } - - if (blank > 0) { - for (i=0 ; icodeStart ; - currentInstPtr < envPtr->codeNext-1 ; - currentInstPtr += AddrLength(currentInstPtr)) { - int offset, delta, isNew; - - switch (*currentInstPtr) { - case INST_JUMP1: - case INST_JUMP_TRUE1: - case INST_JUMP_FALSE1: - offset = TclGetInt1AtPtr(currentInstPtr + 1); - Tcl_InitHashTable(&jumps, TCL_ONE_WORD_KEYS); - for (delta=0 ; offset+delta != 0 ;) { - if (offset + delta < -128 || offset + delta > 127) { - break; - } - Tcl_CreateHashEntry(&jumps, INT2PTR(offset), &isNew); - if (!isNew) { - offset = TclGetInt1AtPtr(currentInstPtr + 1); - break; - } - offset += delta; - switch (*(currentInstPtr + offset)) { - case INST_NOP: - delta = InstLength(INST_NOP); - continue; - case INST_JUMP1: - delta = TclGetInt1AtPtr(currentInstPtr + offset + 1); - continue; - case INST_JUMP4: - delta = TclGetInt4AtPtr(currentInstPtr + offset + 1); - continue; - } - break; - } - Tcl_DeleteHashTable(&jumps); - TclStoreInt1AtPtr(offset, currentInstPtr + 1); - continue; - - case INST_JUMP4: - case INST_JUMP_TRUE4: - case INST_JUMP_FALSE4: - Tcl_InitHashTable(&jumps, TCL_ONE_WORD_KEYS); - Tcl_CreateHashEntry(&jumps, INT2PTR(0), &isNew); - for (offset = TclGetInt4AtPtr(currentInstPtr + 1); offset!=0 ;) { - Tcl_CreateHashEntry(&jumps, INT2PTR(offset), &isNew); - if (!isNew) { - offset = TclGetInt4AtPtr(currentInstPtr + 1); - break; - } - switch (*(currentInstPtr + offset)) { - case INST_NOP: - offset += InstLength(INST_NOP); - continue; - case INST_JUMP1: - offset += TclGetInt1AtPtr(currentInstPtr + offset + 1); - continue; - case INST_JUMP4: - offset += TclGetInt4AtPtr(currentInstPtr + offset + 1); - continue; - } - break; - } - Tcl_DeleteHashTable(&jumps); - TclStoreInt4AtPtr(offset, currentInstPtr + 1); - continue; - } - } -} - -/* - * ---------------------------------------------------------------------- - * - * TclOptimizeBytecode -- - * - * A very simple peephole optimizer for bytecode. - * - * ---------------------------------------------------------------------- - */ - -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: - */ Index: generic/tclPanic.c ================================================================== --- generic/tclPanic.c +++ generic/tclPanic.c @@ -12,20 +12,24 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" -#if defined(_WIN32) || defined(__CYGWIN__) - MODULE_SCOPE void tclWinDebugPanic(const char *format, ...); -#endif /* * The panicProc variable contains a pointer to an application specific panic * procedure. */ -static TCL_NORETURN1 Tcl_PanicProc *panicProc = NULL; +static Tcl_PanicProc *panicProc = NULL; + +/* + * The platformPanicProc variable contains a pointer to a platform specific + * panic procedure, if any. (TclpPanic may be NULL via a macro.) + */ + +static Tcl_PanicProc *CONST platformPanicProc = TclpPanic; /* *---------------------------------------------------------------------- * * Tcl_SetPanicProc -- @@ -41,14 +45,63 @@ *---------------------------------------------------------------------- */ void Tcl_SetPanicProc( - TCL_NORETURN1 Tcl_PanicProc *proc) + Tcl_PanicProc *proc) { 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, *arg4; /* Additional arguments (variable in + * number) to pass to fprintf. */ + char *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) { + (void) (*panicProc)(format, arg1, arg2, arg3, arg4, + arg5, arg6, arg7, arg8); + } else if (platformPanicProc != NULL) { + (void) (*platformPanicProc)(format, arg1, arg2, arg3, arg4, + arg5, arg6, arg7, arg8); + } else { + (void) fprintf(stderr, format, arg1, arg2, arg3, arg4, arg5, arg6, + arg7, arg8); + (void) fprintf(stderr, "\n"); + (void) fflush(stderr); + abort(); + } } /* *---------------------------------------------------------------------- * @@ -63,68 +116,25 @@ * 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] */ + /* ARGSUSED */ void Tcl_Panic( - const char *format, + CONST char *format, ...) { va_list argList; - char *arg1, *arg2, *arg3; /* Additional arguments (variable in number) - * to pass to fprintf. */ - char *arg4, *arg5, *arg6, *arg7, *arg8; - va_start(argList, format); - arg1 = va_arg(argList, char *); - arg2 = va_arg(argList, char *); - arg3 = va_arg(argList, char *); - arg4 = va_arg(argList, char *); - arg5 = va_arg(argList, char *); - arg6 = va_arg(argList, char *); - arg7 = va_arg(argList, char *); - arg8 = va_arg(argList, char *); + Tcl_PanicVA(format, argList); va_end (argList); - - if (panicProc != NULL) { - panicProc(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); - } else { -#if defined(_WIN32) || defined(__CYGWIN__) - tclWinDebugPanic(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); -#else - fprintf(stderr, format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, - arg8); - fprintf(stderr, "\n"); - fflush(stderr); -#endif -# if defined(__GNUC__) - __builtin_trap(); -# elif defined(_WIN64) - __debugbreak(); -# elif defined(_MSC_VER) && defined (_M_IX86) - _asm {int 3} -# elif defined(_WIN32) - DebugBreak(); -# endif -#if defined(_WIN32) - ExitProcess(1); -#else - abort(); -#endif - } } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclParse.c ================================================================== --- generic/tclParse.c +++ generic/tclParse.c @@ -12,16 +12,19 @@ * 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 /* * The following table provides parsing information about each possible 8-bit - * character. The table is designed to be referenced with unsigned characters. + * character. The table is designed to be referenced with either signed or + * unsigned characters, so it has 384 entries. The first 128 entries + * correspond to negative character values, the next 256 correspond to + * positive character values. The last 128 entries are identical to the first + * 128. The table is always indexed with a 128-byte offset (the 128th entry + * corresponds to a character value of 0). * * The macro CHAR_TYPE is used to index into the table and return information * about its character argument. The following return values are defined. * * TYPE_NORMAL - All characters that don't have special significance to @@ -36,11 +39,58 @@ * TYPE_CLOSE_PAREN - Character is a right parenthesis. * TYPE_CLOSE_BRACK - Character is a right square bracket. * TYPE_BRACE - Character is a curly brace (either left or right). */ -const char tclCharTypeTable[] = { +#define TYPE_NORMAL 0 +#define TYPE_SPACE 0x1 +#define TYPE_COMMAND_END 0x2 +#define TYPE_SUBS 0x4 +#define TYPE_QUOTE 0x8 +#define TYPE_CLOSE_PAREN 0x10 +#define TYPE_CLOSE_BRACK 0x20 +#define TYPE_BRACE 0x40 + +#define CHAR_TYPE(c) (charTypeTable+128)[(int)(c)] + +static const char charTypeTable[] = { + /* + * Negative character values, from -128 to -1: + */ + + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, /* * Positive character values, from 0-127: */ @@ -117,20 +167,18 @@ /* * Prototypes for local functions defined in this file: */ -static int CommandComplete(const char *script, size_t numBytes); -static size_t ParseComment(const char *src, size_t numBytes, +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, size_t numBytes, int mask, +static int ParseTokens(const char *src, int numBytes, int mask, int flags, Tcl_Parse *parsePtr); -static size_t ParseWhiteSpace(const char *src, size_t numBytes, +static int ParseWhiteSpace(const char *src, int numBytes, int *incompletePtr, char *typePtr); -static size_t ParseAllWhiteSpace(const char *src, size_t numBytes, - int *incompletePtr); -static int ParseHex(const char *src, size_t numBytes, +static int ParseHex(const char *src, int numBytes, int *resultPtr); /* *---------------------------------------------------------------------- * @@ -149,11 +197,11 @@ void TclParseInit( Tcl_Interp *interp, /* Interpreter to use for error reporting */ const char *start, /* Start of string to be parsed. */ - size_t numBytes, /* Total number of bytes in string. If -1, + 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; @@ -195,41 +243,40 @@ 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. */ - size_t numBytes, /* Total number of bytes in string. If -1, + register 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) + register 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 + register 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. */ - size_t scanned; + int scanned; - if (numBytes == TCL_INDEX_NONE && start) { + 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)); + Tcl_SetResult(interp, "can't parse a NULL pointer", TCL_STATIC); } return TCL_ERROR; } parsePtr->commentStart = NULL; parsePtr->commentSize = 0; @@ -259,56 +306,39 @@ * The following loop parses the words of the command, one word in each * iteration through the loop. */ parsePtr->commandStart = src; - type = CHAR_TYPE(*src); - scanned = 1; /* Can't have missing whitepsace before first word. */ while (1) { int expandWord = 0; - /* Are we at command termination? */ - - if ((numBytes == 0) || (type & terminators) != 0) { - parsePtr->term = src; - parsePtr->commandSize = src + (numBytes != 0) - - parsePtr->commandStart; - return TCL_OK; - } - - /* Are we missing white space after previous word? */ - - if (scanned == 0) { - if (src[-1] == '"') { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "extra characters after close-quote", -1)); - } - parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA; - } else { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "extra characters after close-brace", -1)); - } - parsePtr->errorType = TCL_PARSE_BRACE_EXTRA; - } - parsePtr->term = src; - error: - Tcl_FreeParse(parsePtr); - parsePtr->commandSize = parsePtr->end - parsePtr->commandStart; - return TCL_ERROR; - } - /* * Create the token for the word. */ TclGrowParseTokenArray(parsePtr, 1); wordIndex = parsePtr->numTokens; tokenPtr = &parsePtr->tokenPtr[wordIndex]; tokenPtr->type = TCL_TOKEN_WORD; + /* + * Skip white space before the word. Also skip a backslash-newline + * sequence: it should be treated just like white space. + */ + + scanned = ParseWhiteSpace(src,numBytes, &parsePtr->incomplete, &type); + src += scanned; + numBytes -= scanned; + if (numBytes == 0) { + parsePtr->term = src; + break; + } + if ((type & terminators) != 0) { + parsePtr->term = src; + src++; + break; + } tokenPtr->start = src; parsePtr->numTokens++; parsePtr->numWords++; /* @@ -344,11 +374,11 @@ expPtr = &parsePtr->tokenPtr[expIdx]; if ((0 == expandWord) /* Haven't seen prefix already */ && (1 == parsePtr->numTokens - expIdx) /* Only one token */ - && (((1 == expPtr->size) + && (((1 == (size_t) expPtr->size) /* Same length as prefix */ && (expPtr->start[0] == '*'))) /* Is the prefix */ && (numBytes > 0) && (0 == ParseWhiteSpace(termPtr, numBytes, &parsePtr->incomplete, &type)) @@ -379,12 +409,11 @@ tokenPtr = &parsePtr->tokenPtr[wordIndex]; tokenPtr->size = src - tokenPtr->start; tokenPtr->numComponents = parsePtr->numTokens - (wordIndex + 1); if (expandWord) { - size_t i; - int isLiteral = 1; + 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 @@ -426,11 +455,11 @@ * Step through the literal string, parsing and counting list * elements. */ while (nextElem < listEnd) { - size_t size; + int size; code = TclFindElement(NULL, nextElem, listEnd - nextElem, &elemStart, &nextElem, &size, &literal); if ((code != TCL_OK) || !literal) { break; @@ -525,16 +554,56 @@ } else if ((tokenPtr->numComponents == 1) && (tokenPtr[1].type == TCL_TOKEN_TEXT)) { tokenPtr->type = TCL_TOKEN_SIMPLE_WORD; } - /* Parse the whitespace between words. */ + /* + * Do two additional checks: (a) make sure we're really at the end of + * a word (there might have been garbage left after a quoted or braced + * word), and (b) check for the end of the command. + */ scanned = ParseWhiteSpace(src,numBytes, &parsePtr->incomplete, &type); - src += scanned; - numBytes -= scanned; + if (scanned) { + src += scanned; + numBytes -= scanned; + continue; + } + + if (numBytes == 0) { + parsePtr->term = src; + break; + } + if ((type & terminators) != 0) { + parsePtr->term = src; + src++; + break; + } + if (src[-1] == '"') { + if (interp != NULL) { + Tcl_SetResult(interp, "extra characters after close-quote", + TCL_STATIC); + } + parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA; + } else { + if (interp != NULL) { + Tcl_SetResult(interp, "extra characters after close-brace", + TCL_STATIC); + } + parsePtr->errorType = TCL_PARSE_BRACE_EXTRA; + } + parsePtr->term = src; + goto error; } + + parsePtr->commandSize = src - parsePtr->commandStart; + return TCL_OK; + + error: + Tcl_FreeParse(parsePtr); + parsePtr->commandSize = parsePtr->end - parsePtr->commandStart; + return TCL_ERROR; } /* *---------------------------------------------------------------------- * @@ -552,11 +621,11 @@ *---------------------------------------------------------------------- */ int TclIsSpaceProc( - int byte) + char byte) { return CHAR_TYPE(byte) & (TYPE_SPACE) || byte == '\n'; } /* @@ -581,11 +650,11 @@ *---------------------------------------------------------------------- */ int TclIsBareword( - int byte) + char byte) { if (byte < '0' || byte > 'z') { return 0; } if (byte <= '9' || byte >= 'a') { @@ -618,21 +687,21 @@ * None. * *---------------------------------------------------------------------- */ -static size_t +static int ParseWhiteSpace( const char *src, /* First character to parse. */ - size_t numBytes, /* Max number of bytes to scan. */ + register 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; + register char type = TYPE_NORMAL; + register const char *p = src; while (1) { while (numBytes && ((type = CHAR_TYPE(*p)) & TYPE_SPACE)) { numBytes--; p++; @@ -672,36 +741,27 @@ * Returns the number of bytes recognized as white space. * *---------------------------------------------------------------------- */ -static size_t -ParseAllWhiteSpace( +int +TclParseAllWhiteSpace( const char *src, /* First character to parse. */ - size_t numBytes, /* Max number of byes to scan */ - int *incompletePtr) /* Set true if parse is incomplete. */ + int numBytes) /* Max number of byes to scan */ { + int dummy; char type; const char *p = src; do { - size_t scanned = ParseWhiteSpace(p, numBytes, incompletePtr, &type); + int scanned = ParseWhiteSpace(p, numBytes, &dummy, &type); p += scanned; numBytes -= scanned; } while (numBytes && (*p == '\n') && (p++, --numBytes)); return (p-src); } - -size_t -TclParseAllWhiteSpace( - const char *src, /* First character to parse. */ - size_t numBytes) /* Max number of byes to scan */ -{ - int dummy; - return ParseAllWhiteSpace(src, numBytes, &dummy); -} /* *---------------------------------------------------------------------- * * ParseHex -- @@ -724,17 +784,17 @@ */ int ParseHex( const char *src, /* First character to parse. */ - size_t numBytes, /* Max number of byes to scan */ - int *resultPtr) /* Points to storage provided by caller where + 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; + register const char *p = src; while (numBytes--) { unsigned char digit = UCHAR(*p); if (!isxdigit(digit) || (result > 0x10FFF)) { @@ -780,22 +840,23 @@ int TclParseBackslash( const char *src, /* Points to the backslash character of a a * backslash sequence. */ - size_t numBytes, /* Max number of bytes to scan. */ - size_t *readPtr, /* NULL, or points to storage where the number + 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. */ + * written. At most TCL_UTF_MAX bytes will be + * written there. */ { - const char *p = src+1; + register const char *p = src+1; Tcl_UniChar unichar = 0; int result; - size_t count; - char buf[4] = ""; + int count; + char buf[TCL_UTF_MAX]; if (numBytes == 0) { if (readPtr != NULL) { *readPtr = 0; } @@ -846,11 +907,11 @@ break; case 'v': result = 0xB; break; case 'x': - count += ParseHex(p+1, (numBytes > 3) ? 2 : numBytes-2, &result); + count += ParseHex(p+1, numBytes-2, &result); if (count == 2) { /* * No hexdigits -> This is just "x". */ @@ -857,20 +918,21 @@ result = 'x'; } else { /* * Keep only the last byte (2 hex digits). */ - result = UCHAR(result); + result = (unsigned char) 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'; +#if TCL_UTF_MAX > 3 } 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; @@ -877,12 +939,14 @@ int count2 = ParseHex(p+7, 4, &low); if ((count2 == 4) && ((low & 0xFC00) == 0xDC00)) { result = ((result & 0x3FF)<<10 | (low & 0x3FF)) + 0x10000; count += count2 + 2; } +#endif } break; +#if TCL_UTF_MAX > 3 case 'U': count += ParseHex(p+1, (numBytes > 9) ? 8 : numBytes-2, &result); if (count == 2) { /* * No hexdigits -> This is just "U". @@ -891,10 +955,11 @@ } else if ((result | 0x7FF) == 0xDFFF) { /* Upper or lower surrogate, not allowed in this syntax. */ result = 0xFFFD; } break; +#endif case '\n': count--; do { p++; count++; @@ -909,21 +974,21 @@ /* * Check for an octal number \oo?o? */ if (isdigit(UCHAR(*p)) && (UCHAR(*p) < '8')) { /* INTL: digit */ - result = *p - '0'; + result = UCHAR(*p - '0'); p++; if ((numBytes == 2) || !isdigit(UCHAR(*p)) /* INTL: digit */ || (UCHAR(*p) >= '8')) { break; } count = 3; - result = (result << 3) + (*p - '0'); + result = UCHAR((result << 3) + (*p - '0')); p++; if ((numBytes == 3) || !isdigit(UCHAR(*p)) /* INTL: digit */ - || (UCHAR(*p) >= '8') || (result >= 0x20)) { + || (UCHAR(*p) >= '8')) { break; } count = 4; result = UCHAR((result << 3) + (*p - '0')); break; @@ -935,32 +1000,27 @@ * 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 '\' */ + count = Tcl_UtfToUniChar(p, &unichar) + 1; /* +1 for '\' */ } else { - char utfBytes[4]; + char utfBytes[TCL_UTF_MAX]; - memcpy(utfBytes, p, numBytes - 1); + memcpy(utfBytes, p, (size_t) (numBytes - 1)); utfBytes[numBytes - 1] = '\0'; - count = TclUtfToUniChar(utfBytes, &unichar) + 1; + count = Tcl_UtfToUniChar(utfBytes, &unichar) + 1; } result = unichar; break; } done: if (readPtr != NULL) { *readPtr = count; } - count = Tcl_UniCharToUtf(result, dst); - if ((result >= 0xD800) && (count < 3)) { - /* Special case for handling high surrogates. */ - count += Tcl_UniCharToUtf(-1, dst + count); - } - return count; + return Tcl_UniCharToUtf(result, dst); } /* *---------------------------------------------------------------------- * @@ -977,55 +1037,67 @@ * None. * *---------------------------------------------------------------------- */ -static size_t +static int ParseComment( const char *src, /* First character to parse. */ - size_t numBytes, /* Max number of bytes to scan. */ + register 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; + register const char *p = src; while (numBytes) { - size_t scanned = ParseAllWhiteSpace(p, numBytes, &incomplete); - p += scanned; - numBytes -= scanned; + char type; + int scanned; + + do { + scanned = ParseWhiteSpace(p, numBytes, + &parsePtr->incomplete, &type); + p += scanned; + numBytes -= scanned; + } while (numBytes && (*p == '\n') && (p++,numBytes--)); if ((numBytes == 0) || (*p != '#')) { break; } if (parsePtr->commentStart == NULL) { parsePtr->commentStart = p; } - p++; - numBytes--; - while (numBytes) { - if (*p == '\n') { - p++; - numBytes--; - break; - } - if (*p == '\\') { - p++; - numBytes--; - if (numBytes == 0) { - break; - } - } - incomplete = (*p == '\n'); - p++; - numBytes--; - } - parsePtr->commentSize = p - parsePtr->commentStart; - } - parsePtr->incomplete = incomplete; + while (numBytes) { + if (*p == '\\') { + scanned = ParseWhiteSpace(p, numBytes, &parsePtr->incomplete, + &type); + if (scanned) { + p += scanned; + numBytes -= scanned; + } else { + /* + * General backslash substitution in comments isn't part + * of the formal spec, but test parse-15.47 and history + * indicate that it has been the de facto rule. Don't + * change it now. + */ + + TclParseBackslash(p, numBytes, &scanned, NULL); + p += scanned; + numBytes -= scanned; + } + } else { + p++; + numBytes--; + if (p[-1] == '\n') { + break; + } + } + } + parsePtr->commentSize = p - parsePtr->commentStart; + } return (p - src); } /* *---------------------------------------------------------------------- @@ -1052,12 +1124,12 @@ *---------------------------------------------------------------------- */ static int ParseTokens( - const char *src, /* First character to parse. */ - size_t numBytes, /* Max number of bytes to scan. */ + register const char *src, /* First character to parse. */ + register 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 @@ -1144,11 +1216,12 @@ * parse information. */ src++; numBytes--; - nestedPtr = (Tcl_Parse *)TclStackAlloc(parsePtr->interp, sizeof(Tcl_Parse)); + 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) { @@ -1174,12 +1247,12 @@ && !(nestedPtr->incomplete)) { break; } if (numBytes == 0) { if (parsePtr->interp != NULL) { - Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( - "missing close-bracket", -1)); + Tcl_SetResult(parsePtr->interp, + "missing close-bracket", TCL_STATIC); } parsePtr->errorType = TCL_PARSE_MISSING_BRACKET; parsePtr->term = tokenPtr->start; parsePtr->incomplete = 1; TclStackFree(parsePtr->interp, nestedPtr); @@ -1293,11 +1366,11 @@ Tcl_FreeParse( Tcl_Parse *parsePtr) /* Structure that was filled in by a previous * call to Tcl_ParseCommand. */ { if (parsePtr->tokenPtr != parsePtr->staticTokens) { - Tcl_Free(parsePtr->tokenPtr); + ckfree((char *)parsePtr->tokenPtr); parsePtr->tokenPtr = parsePtr->staticTokens; } } /* @@ -1331,11 +1404,11 @@ 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 "$". */ - size_t numBytes, /* Total number of bytes in string. If -1, + register 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 @@ -1342,15 +1415,15 @@ * information in parsePtr; zero means ignore * existing tokens in parsePtr and * reinitialize it. */ { Tcl_Token *tokenPtr; - const char *src; + register const char *src; int varIndex; unsigned array; - if (numBytes == TCL_INDEX_NONE && start) { + if (numBytes < 0 && start) { numBytes = strlen(start); } if (!append) { TclParseInit(interp, start, numBytes, parsePtr); } @@ -1407,12 +1480,12 @@ numBytes--; src++; } if (numBytes == 0) { if (parsePtr->interp != NULL) { - Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( - "missing close-brace for variable name", -1)); + Tcl_SetResult(parsePtr->interp, + "missing close-brace for variable name", TCL_STATIC); } parsePtr->errorType = TCL_PARSE_MISSING_VAR_BRACE; parsePtr->term = tokenPtr->start-1; parsePtr->incomplete = 1; goto error; @@ -1465,12 +1538,12 @@ TCL_SUBST_ALL, parsePtr)) { goto error; } if ((parsePtr->term == src+numBytes) || (*parsePtr->term != ')')){ if (parsePtr->interp != NULL) { - Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( - "missing )", -1)); + Tcl_SetResult(parsePtr->interp, "missing )", + TCL_STATIC); } parsePtr->errorType = TCL_PARSE_MISSING_PAREN; parsePtr->term = src; parsePtr->incomplete = 1; goto error; @@ -1523,19 +1596,20 @@ */ const char * Tcl_ParseVar( Tcl_Interp *interp, /* Context for looking up variable. */ - const char *start, /* Start of variable substitution. First + register 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; + register Tcl_Obj *objPtr; int code; - Tcl_Parse *parsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse)); + 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; } @@ -1563,17 +1637,20 @@ /* * At this point we should have an object containing the value of a * variable. Just return the string from that object. * - * Since TclSubstTokens above returned TCL_OK, we know that objPtr - * is shared. It is in both the interp result and the value of the - * variable. Returning the string relies on that to be true. + * This should have returned the object for the user to manage, but + * instead we have some weak reference to the string value in the object, + * which is why we make sure the object exists after resetting the result. + * This isn't ideal, but it's the best we can do with the current + * documented interface. -- hobbs */ - assert( Tcl_IsShared(objPtr) ); - + if (!Tcl_IsShared(objPtr)) { + Tcl_IncrRefCount(objPtr); + } Tcl_ResetResult(interp); return TclGetString(objPtr); } /* @@ -1608,14 +1685,14 @@ 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 {'. */ - size_t numBytes, /* Total number of bytes in string. If -1, + register 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, + register 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 @@ -1624,15 +1701,14 @@ * store a pointer to the character just after * the terminating '}' if the parse was * successful. */ { Tcl_Token *tokenPtr; - const char *src; - int startIndex, level; - size_t length; + register const char *src; + int startIndex, level, length; - if (numBytes == TCL_INDEX_NONE && start) { + if (numBytes < 0 && start) { numBytes = strlen(start); } if (!append) { TclParseInit(interp, start, numBytes, parsePtr); } @@ -1739,22 +1815,21 @@ */ goto error; } - Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( - "missing close-brace", -1)); + Tcl_SetResult(parsePtr->interp, "missing close-brace", TCL_STATIC); /* * 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 '#' on the same line. */ { - int openBrace = 0; + register int openBrace = 0; while (--src > start) { switch (*src) { case '{': openBrace = 1; @@ -1762,12 +1837,12 @@ case '\n': openBrace = 0; break; case '#' : if (openBrace && TclIsSpaceProcM(src[-1])) { - Tcl_AppendToObj(Tcl_GetObjResult(parsePtr->interp), - ": possible unbalanced brace in comment", -1); + Tcl_AppendResult(parsePtr->interp, + ": possible unbalanced brace in comment", NULL); goto error; } break; } } @@ -1810,14 +1885,14 @@ 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 '"'. */ - size_t numBytes, /* Total number of bytes in string. If -1, + register 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, + register 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 @@ -1825,11 +1900,11 @@ 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 == TCL_INDEX_NONE && start) { + if (numBytes < 0 && start) { numBytes = strlen(start); } if (!append) { TclParseInit(interp, start, numBytes, parsePtr); } @@ -1841,12 +1916,11 @@ parsePtr)) { goto error; } if (*parsePtr->term != '"') { if (parsePtr->interp != NULL) { - Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( - "missing \"", -1)); + Tcl_SetResult(parsePtr->interp, "missing \"", TCL_STATIC); } parsePtr->errorType = TCL_PARSE_MISSING_QUOTE; parsePtr->term = start; parsePtr->incomplete = 1; goto error; @@ -1862,46 +1936,37 @@ } /* *---------------------------------------------------------------------- * - * TclSubstParse -- + * Tcl_SubstObj -- * - * Token parser used by the [subst] command. Parses the string made up of - * 'numBytes' bytes starting at 'bytes'. Parsing is controlled by the - * flags argument to provide support for the -nobackslashes, -nocommands, - * and -novariables options, as represented by the flag values - * TCL_SUBST_BACKSLASHES, TCL_SUBST_COMMANDS, TCL_SUBST_VARIABLES. + * This function performs the substitutions specified on the given string + * as described in the user documentation for the "subst" Tcl command. * * Results: - * None. + * A Tcl_Obj* containing the substituted string, or NULL to indicate that + * an error occurred. * * Side effects: - * The Tcl_Parse struct '*parsePtr' is filled with parse results. - * The caller is expected to eventually call Tcl_FreeParse() to properly - * cleanup the value written there. - * - * If a parse error occurs, the Tcl_InterpState value '*statePtr' is - * filled with the state created by that error. When *statePtr is written - * to, the caller is expected to make the required calls to either - * Tcl_RestoreInterpState() or Tcl_DiscardInterpState() to dispose of the - * value written there. + * See the user documentation. * *---------------------------------------------------------------------- */ -void -TclSubstParse( - Tcl_Interp *interp, - const char *bytes, - size_t numBytes, - int flags, - Tcl_Parse *parsePtr, - Tcl_InterpState *statePtr) -{ - size_t length = numBytes; - const char *p = bytes; +Tcl_Obj * +Tcl_SubstObj( + Tcl_Interp *interp, /* Interpreter in which substitution occurs */ + Tcl_Obj *objPtr, /* The value to be substituted. */ + int flags) /* What substitutions to do. */ +{ + int length, tokensLeft, code; + Tcl_Token *endTokenPtr; + Tcl_Obj *result, *errMsg = NULL; + const char *p = TclGetStringFromObj(objPtr, &length); + Tcl_Parse *parsePtr = (Tcl_Parse *) + TclStackAlloc(interp, sizeof(Tcl_Parse)); TclParseInit(interp, p, length, parsePtr); /* * First parse the string rep of objPtr, as if it were enclosed as a @@ -1909,15 +1974,16 @@ * inhibit types of substitution. */ if (TCL_OK != ParseTokens(p, length, /* mask */ 0, flags, parsePtr)) { /* - * There was a parse error. Save the interpreter state for possible - * error reporting later. + * There was a parse error. Save the error message for possible + * reporting later. */ - *statePtr = Tcl_SaveInterpState(interp, TCL_ERROR); + errMsg = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(errMsg); /* * We need to re-parse to get the portion of the string we can [subst] * before the parse error. Sadly, all the Tcl_Token's created by the * first parse attempt are gone, freed according to the public spec @@ -1979,14 +2045,14 @@ Tcl_Token *varTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens - 2; if (varTokenPtr->type != TCL_TOKEN_VARIABLE) { - Tcl_Panic("TclSubstParse: programming error"); + Tcl_Panic("Tcl_SubstObj: programming error"); } if (varTokenPtr[1].type != TCL_TOKEN_TEXT) { - Tcl_Panic("TclSubstParse: programming error"); + Tcl_Panic("Tcl_SubstObj: programming error"); } parsePtr->numTokens -= 2; } break; case '[': @@ -2056,12 +2122,68 @@ parsePtr->numTokens++; } break; default: - Tcl_Panic("bad parse in TclSubstParse: %c", p[length]); + Tcl_Panic("bad parse in Tcl_SubstObj: %c", p[length]); + } + } + + /* + * Next, substitute the parsed tokens just as in normal Tcl evaluation. + */ + + endTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens; + tokensLeft = parsePtr->numTokens; + code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft, + &tokensLeft, 1, NULL, NULL); + if (code == TCL_OK) { + Tcl_FreeParse(parsePtr); + TclStackFree(interp, parsePtr); + if (errMsg != NULL) { + Tcl_SetObjResult(interp, errMsg); + Tcl_DecrRefCount(errMsg); + return NULL; + } + return Tcl_GetObjResult(interp); + } + + result = Tcl_NewObj(); + while (1) { + switch (code) { + case TCL_ERROR: + Tcl_FreeParse(parsePtr); + TclStackFree(interp, parsePtr); + Tcl_DecrRefCount(result); + if (errMsg != NULL) { + Tcl_DecrRefCount(errMsg); + } + return NULL; + case TCL_BREAK: + tokensLeft = 0; /* Halt substitution */ + /* FALLTHRU */ + default: + Tcl_AppendObjToObj(result, Tcl_GetObjResult(interp)); + } + + if (tokensLeft == 0) { + Tcl_FreeParse(parsePtr); + TclStackFree(interp, parsePtr); + if (errMsg != NULL) { + if (code != TCL_BREAK) { + Tcl_DecrRefCount(result); + Tcl_SetObjResult(interp, errMsg); + Tcl_DecrRefCount(errMsg); + return NULL; + } + Tcl_DecrRefCount(errMsg); + } + return result; } + + code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft, + &tokensLeft, 1, NULL, NULL); } } /* *---------------------------------------------------------------------- @@ -2096,27 +2218,26 @@ * Must be at least 1. */ int *tokensLeftPtr, /* If not NULL, points to memory where an * integer representing the number of tokens * left to be substituted will be written */ int line, /* The line the script starts on. */ - int *clNextOuter, /* Information about an outer context for */ - const char *outerScript) /* continuation line data. This is set by - * EvalEx() to properly handle [...]-nested - * commands. The 'outerScript' refers to the - * most-outer script containing the embedded - * command, which is refered to by 'script'. - * The 'clNextOuter' refers to the current - * entry in the table of continuation lines in - * this "main script", and the character - * offsets are relative to the 'outerScript' - * as well. - * - * If outerScript == script, then this call is - * for words in the outer-most script or - * command. See Tcl_EvalEx and TclEvalObjEx - * for the places generating arguments for - * which this is true. */ + int* clNextOuter, /* Information about an outer context for */ + CONST char* outerScript) /* continuation line data. This is set by + * EvalEx() to properly handle [...]-nested + * commands. The 'outerScript' refers to the + * most-outer script containing the embedded + * command, which is refered to by 'script'. The + * 'clNextOuter' refers to the current entry in + * the table of continuation lines in this + * "master script", and the character offsets are + * relative to the 'outerScript' as well. + * + * If outerScript == script, then this call is for + * words in the outer-most script/command. See + * Tcl_EvalEx() and TclEvalObjEx() for the places + * generating arguments for which this is true. + */ { Tcl_Obj *result; int code = TCL_OK; #define NUM_STATIC_POS 20 int isLiteral, maxNumCL, numCL, i, adjust; @@ -2153,20 +2274,20 @@ } } if (isLiteral) { maxNumCL = NUM_STATIC_POS; - clPosition = (int *)Tcl_Alloc(maxNumCL * sizeof(int)); + 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; int appendByteLength = 0; - char utfCharBytes[4] = ""; + char utfCharBytes[TCL_UTF_MAX]; switch (tokenPtr->type) { case TCL_TOKEN_TEXT: append = tokenPtr->start; appendByteLength = tokenPtr->size; @@ -2190,35 +2311,36 @@ * account. The good thing is that we do not need a table of * everything, just the number of lines we have to add as * correction. */ - if ((appendByteLength == 1) && (utfCharBytes[0] == ' ') - && (tokenPtr->start[1] == '\n')) { + if ((appendByteLength == 1) && (utfCharBytes[0] == ' ') && + (tokenPtr->start[1] == '\n')) { if (isLiteral) { - size_t clPos; + int clPos; if (result == 0) { clPos = 0; } else { - (void)TclGetStringFromObj(result, &clPos); + Tcl_GetStringFromObj(result, &clPos); } if (numCL >= maxNumCL) { maxNumCL *= 2; - clPosition = (int *)Tcl_Realloc(clPosition, - maxNumCL * sizeof(int)); + clPosition = (int *)ckrealloc ((char*)clPosition, + maxNumCL*sizeof(int)); } clPosition[numCL] = clPos; numCL++; } adjust++; } break; case TCL_TOKEN_COMMAND: { - /* TIP #280: Transfer line information to nested command */ + Interp *iPtr = (Interp *) interp; + iPtr->numLevels++; code = TclInterpReady(interp); if (code == TCL_OK) { /* * Test cases: info-30.{6,8,9} @@ -2227,16 +2349,13 @@ int theline; TclAdvanceContinuations(&line, &clNextOuter, tokenPtr->start - outerScript); theline = line + adjust; + /* TIP #280: Transfer line information to nested command */ code = TclEvalEx(interp, tokenPtr->start+1, tokenPtr->size-2, 0, theline, clNextOuter, outerScript); - - TclAdvanceLines(&line, tokenPtr->start+1, - tokenPtr->start + tokenPtr->size - 1); - /* * Restore flag reset by nested eval for future bracketed * commands and their cmdframe setup */ @@ -2243,11 +2362,10 @@ if (inFile) { iPtr->evalFlags |= TCL_EVAL_FILE; } } iPtr->numLevels--; - TclResetCancellation(interp, 0); appendObj = Tcl_GetObjResult(interp); break; } case TCL_TOKEN_VARIABLE: { @@ -2361,11 +2479,11 @@ * Release the temp table we used to collect the locations of * continuation lines, if any. */ if (maxNumCL) { - Tcl_Free(clPosition); + ckfree((char*) clPosition); } } else { Tcl_ResetResult(interp); } } @@ -2396,14 +2514,14 @@ * None. * *---------------------------------------------------------------------- */ -static int +static inline int CommandComplete( const char *script, /* Script to check. */ - size_t numBytes) /* Number of bytes in script. */ + int numBytes) /* Number of bytes in script. */ { Tcl_Parse parse; const char *p, *end; int result; @@ -2473,12 +2591,12 @@ int TclObjCommandComplete( Tcl_Obj *objPtr) /* Points to object holding script to * check. */ { - size_t length; - const char *script = TclGetStringFromObj(objPtr, &length); + int length; + const char *script = Tcl_GetStringFromObj(objPtr, &length); return CommandComplete(script, length); } /* DELETED generic/tclParse.h Index: generic/tclParse.h ================================================================== --- generic/tclParse.h +++ /dev/null @@ -1,17 +0,0 @@ -/* - * Minimal set of shared macro definitions and declarations so that multiple - * source files can make use of the parsing table in tclParse.c - */ - -#define TYPE_NORMAL 0 -#define TYPE_SPACE 0x1 -#define TYPE_COMMAND_END 0x2 -#define TYPE_SUBS 0x4 -#define TYPE_QUOTE 0x8 -#define TYPE_CLOSE_PAREN 0x10 -#define TYPE_CLOSE_BRACK 0x20 -#define TYPE_BRACE 0x40 - -#define CHAR_TYPE(c) tclCharTypeTable[(unsigned char)(c)] - -MODULE_SCOPE const char tclCharTypeTable[]; Index: generic/tclPathObj.c ================================================================== --- generic/tclPathObj.c +++ generic/tclPathObj.c @@ -11,11 +11,10 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclFileSystem.h" -#include /* * Prototypes for functions defined later in this file. */ @@ -23,22 +22,25 @@ 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 size_t FindSplitPos(const char *path, int separator); +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); +static Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[], + int forceRelative); + /* * Define the 'path' object type, which Tcl uses to represent file paths * internally. */ -static const Tcl_ObjType fsPathType = { +static Tcl_ObjType tclFsPathType = { "path", /* name */ FreeFsPathInternalRep, /* freeIntRepProc */ DupFsPathInternalRep, /* dupIntRepProc */ UpdateStringOfFsPath, /* updateStringProc */ SetFsPathFromAny /* setFromAnyProc */ @@ -45,34 +47,59 @@ }; /* * struct FsPath -- * - * Internal representation of a Tcl_Obj of fsPathType + * Internal representation of a Tcl_Obj of "path" type. This can be used to + * represent relative or absolute paths, and has certain optimisations when + * used to represent paths which are already normalized and absolute. + * + * Note that both 'translatedPathPtr' and 'normPathPtr' can be a circular + * reference to the container Tcl_Obj of this FsPath. + * + * There are two cases, with the first being the most common: + * + * (i) flags == 0, => Ordinary path. + * + * translatedPathPtr contains the translated path (which may be a circular + * reference to the object itself). If it is NULL then the path is pure + * normalized (and the normPathPtr will be a circular reference). cwdPtr is + * null for an absolute path, and non-null for a relative path (unless the cwd + * has never been set, in which case the cwdPtr may also be null for a + * relative path). + * + * (ii) flags != 0, => Special path, see TclNewFSPathObj + * + * Now, this is a path like 'file join $dir $tail' where, cwdPtr is the $dir + * and normPathPtr is the $tail. + * */ -typedef struct { - 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. */ +typedef struct FsPath { + Tcl_Obj *translatedPathPtr; /* Name without any ~user sequences. If this + * is NULL, then this is a pure normalized, + * absolute path object, in which the parent + * Tcl_Obj's string rep is already both + * translated and normalized. */ + Tcl_Obj *normPathPtr; /* Normalized absolute path, without ., .. or + * ~user sequences. If the Tcl_Obj containing + * this FsPath is already normalized, this may + * be a circular reference back to the + * container. If that is NOT the case, we have + * a refCount on the object. */ + Tcl_Obj *cwdPtr; /* If null, path is absolute, else this points + * to the cwd object used for this path. We + * have a refCount on the object. */ int flags; /* Flags to describe interpretation - see * below. */ ClientData nativePathPtr; /* Native representation of this path, which * is filesystem dependent. */ - size_t filesystemEpoch; /* Used to ensure the path representation was + 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 */ + Tcl_Filesystem *fsPtr; /* The Tcl_Filesystem that claims this path */ } FsPath; /* * Flag values for FsPath->flags. */ @@ -83,18 +110,13 @@ /* * Define some macros to give us convenient access to path-object specific * fields. */ -#define PATHOBJ(pathPtr) ((FsPath *) (TclFetchIntRep((pathPtr), &fsPathType)->twoPtrValue.ptr1)) +#define PATHOBJ(pathPtr) ((FsPath *) (pathPtr)->internalRep.twoPtrValue.ptr1) #define SETPATHOBJ(pathPtr,fsPathPtr) \ - do { \ - Tcl_ObjIntRep ir; \ - ir.twoPtrValue.ptr1 = (void *) (fsPathPtr); \ - ir.twoPtrValue.ptr2 = NULL; \ - Tcl_StoreIntRep((pathPtr), &fsPathType, &ir); \ - } while (0) + ((pathPtr)->internalRep.twoPtrValue.ptr1 = (void *) (fsPathPtr)) #define PATHFLAGS(pathPtr) (PATHOBJ(pathPtr)->flags) /* *--------------------------------------------------------------------------- * @@ -113,21 +135,21 @@ * 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. + * The result is returned in a Tcl_Obj with a refCount of 1, which is + * therefore owned by the caller. It must be freed (with + * Tcl_DecrRefCount) by the caller when 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. + * This code was originally based on code from Matt Newman and + * Jean-Claude Wippler, but has since been totally rewritten by Vince + * Darley to deal with symbolic links. * *--------------------------------------------------------------------------- */ Tcl_Obj * @@ -203,18 +225,18 @@ again: if (IsSeparatorOrNull(dirSep[2])) { /* * Need to skip '.' in the path. */ - size_t curLen; + int curLen; if (retVal == NULL) { const char *path = TclGetString(pathPtr); retVal = Tcl_NewStringObj(path, dirSep - path); Tcl_IncrRefCount(retVal); } - (void)TclGetStringFromObj(retVal, &curLen); + (void) Tcl_GetStringFromObj(retVal, &curLen); if (curLen == 0) { Tcl_AppendToObj(retVal, dirSep, 1); } dirSep += 2; oldDirSep = dirSep; @@ -222,12 +244,12 @@ goto again; } continue; } if (dirSep[2] == '.' && IsSeparatorOrNull(dirSep[3])) { - Tcl_Obj *linkObj; - size_t curLen; + Tcl_Obj *link; + int curLen; char *linkStr; /* * Have '..' so need to skip previous directory. */ @@ -236,44 +258,43 @@ const char *path = TclGetString(pathPtr); retVal = Tcl_NewStringObj(path, dirSep - path); Tcl_IncrRefCount(retVal); } - (void)TclGetStringFromObj(retVal, &curLen); + (void) Tcl_GetStringFromObj(retVal, &curLen); if (curLen == 0) { Tcl_AppendToObj(retVal, dirSep, 1); } if (!first || (tclPlatform == TCL_PLATFORM_UNIX)) { - linkObj = Tcl_FSLink(retVal, NULL, 0); + link = Tcl_FSLink(retVal, NULL, 0); /* Safety check in case driver caused sharing */ if (Tcl_IsShared(retVal)) { TclDecrRefCount(retVal); retVal = Tcl_DuplicateObj(retVal); Tcl_IncrRefCount(retVal); } - if (linkObj != NULL) { + if (link != NULL) { /* * Got a link. Need to check if the link is relative * or absolute, for those platforms where relative * links exist. */ - if (tclPlatform != TCL_PLATFORM_WINDOWS - && Tcl_FSGetPathType(linkObj) - == TCL_PATH_RELATIVE) { + if (tclPlatform != TCL_PLATFORM_WINDOWS && + Tcl_FSGetPathType(link) == TCL_PATH_RELATIVE) { /* * We need to follow this link which is relative * to retVal's directory. This means concatenating * the link onto the directory of the path so far. */ const char *path = - TclGetStringFromObj(retVal, &curLen); + Tcl_GetStringFromObj(retVal, &curLen); - while (curLen-- > 0) { + while (--curLen >= 0) { if (IsSeparatorOrNull(path[curLen])) { break; } } @@ -280,51 +301,51 @@ /* * We want the trailing slash. */ Tcl_SetObjLength(retVal, curLen+1); - Tcl_AppendObjToObj(retVal, linkObj); - TclDecrRefCount(linkObj); - linkStr = TclGetStringFromObj(retVal, &curLen); + Tcl_AppendObjToObj(retVal, link); + TclDecrRefCount(link); + linkStr = Tcl_GetStringFromObj(retVal, &curLen); } else { /* * Absolute link. */ TclDecrRefCount(retVal); - if (Tcl_IsShared(linkObj)) { - retVal = Tcl_DuplicateObj(linkObj); - TclDecrRefCount(linkObj); + if (Tcl_IsShared(link)) { + retVal = Tcl_DuplicateObj(link); + TclDecrRefCount(link); } else { - retVal = linkObj; + retVal = link; } - linkStr = TclGetStringFromObj(retVal, &curLen); + linkStr = Tcl_GetStringFromObj(retVal, &curLen); /* * Convert to forward-slashes on windows. */ if (tclPlatform == TCL_PLATFORM_WINDOWS) { - size_t i; + int i; for (i = 0; i < curLen; i++) { if (linkStr[i] == '\\') { linkStr[i] = '/'; } } } } } else { - linkStr = TclGetStringFromObj(retVal, &curLen); + linkStr = Tcl_GetStringFromObj(retVal, &curLen); } /* - * Either way, we now remove the last path element (but - * not the first character of the path). + * Either way, we now remove the last path element. + * (but not the first character of the path) */ - while (curLen-- > 0) { + while (--curLen >= 0) { if (IsSeparatorOrNull(linkStr[curLen])) { if (curLen) { Tcl_SetObjLength(retVal, curLen); } else { Tcl_SetObjLength(retVal, 1); @@ -378,16 +399,16 @@ Tcl_IncrRefCount(retVal); } } /* - * Ensure a windows drive like C:/ has a trailing separator. + * Ensure a windows drive like C:/ has a trailing separator */ if (tclPlatform == TCL_PLATFORM_WINDOWS) { - size_t len; - const char *path = TclGetStringFromObj(retVal, &len); + int len; + const char *path = Tcl_GetStringFromObj(retVal, &len); if (len == 2 && path[0] != 0 && path[1] == ':') { if (Tcl_IsShared(retVal)) { TclDecrRefCount(retVal); retVal = Tcl_DuplicateObj(retVal); @@ -473,11 +494,11 @@ */ Tcl_PathType TclFSGetPathType( Tcl_Obj *pathPtr, - const Tcl_Filesystem **filesystemPtrPtr, + Tcl_Filesystem **filesystemPtrPtr, int *driveNameLengthPtr) { FsPath *fsPathPtr; if (Tcl_FSConvertToPathType(NULL, pathPtr) != TCL_OK) { @@ -491,11 +512,11 @@ NULL); } if (PATHFLAGS(pathPtr) == 0) { /* The path is not absolute... */ -#ifdef _WIN32 +#ifdef __WIN32__ /* ... on Windows we must make another call to determine whether * it's relative or volumerelative [Bug 2571597]. */ return TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, NULL); #else @@ -542,11 +563,11 @@ TclPathPart( Tcl_Interp *interp, /* Used for error reporting */ Tcl_Obj *pathPtr, /* Path to take dirname of */ Tcl_PathPart portion) /* Requested portion of name */ { - if (TclHasIntRep(pathPtr, &fsPathType)) { + if (pathPtr->typePtr == &tclFsPathType) { FsPath *fsPathPtr = PATHOBJ(pathPtr); if (PATHFLAGS(pathPtr) != 0) { switch (portion) { case TCL_PATH_DIRNAME: { @@ -556,12 +577,13 @@ * 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. */ - size_t numBytes; - const char *rest = TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes); + int numBytes; + const char *rest = + Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes); if (strchr(rest, '/') != NULL) { goto standardPath; } /* @@ -593,12 +615,13 @@ * 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. */ - size_t numBytes; - const char *rest = TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes); + int numBytes; + const char *rest = + Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes); if (strchr(rest, '/') != NULL) { goto standardPath; } /* @@ -621,13 +644,13 @@ } case TCL_PATH_EXTENSION: return GetExtension(fsPathPtr->normPathPtr); case TCL_PATH_ROOT: { const char *fileName, *extension; - size_t length; + int length; - fileName = TclGetStringFromObj(fsPathPtr->normPathPtr, + fileName = Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &length); extension = TclGetExtension(fileName); if (extension == NULL) { /* * There is no extension so the root is the same as the @@ -644,11 +667,11 @@ * the tail. */ Tcl_Obj *resultPtr = TclNewFSPathObj(fsPathPtr->cwdPtr, fileName, - length - strlen(extension)); + (int)(length - strlen(extension))); Tcl_IncrRefCount(resultPtr); return resultPtr; } } @@ -672,30 +695,31 @@ standardPath: resultPtr = NULL; if (portion == TCL_PATH_EXTENSION) { return GetExtension(pathPtr); } else if (portion == TCL_PATH_ROOT) { - size_t length; + int length; const char *fileName, *extension; - fileName = TclGetStringFromObj(pathPtr, &length); + fileName = Tcl_GetStringFromObj(pathPtr, &length); extension = TclGetExtension(fileName); if (extension == NULL) { Tcl_IncrRefCount(pathPtr); return pathPtr; } else { Tcl_Obj *root = Tcl_NewStringObj(fileName, - length - strlen(extension)); + (int) (length - strlen(extension))); Tcl_IncrRefCount(root); return root; } } /* + * The behaviour we want here is slightly different to the standard * Tcl_FSSplitPath in the handling of home directories; - * Tcl_FSSplitPath preserves the "~", but this code computes the + * Tcl_FSSplitPath preserves the "~" while this code computes the * actual full path name, if we had just a single component. */ splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements); Tcl_IncrRefCount(splitPtr); @@ -718,11 +742,11 @@ if ((splitElements > 0) && ((splitElements > 1) || (Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE))) { Tcl_ListObjIndex(NULL, splitPtr, splitElements-1, &resultPtr); } else { - TclNewObj(resultPtr); + resultPtr = Tcl_NewObj(); } } else { /* * Return all but the last component. If there is only one * component, return it if the path was non-relative, otherwise @@ -756,11 +780,11 @@ Tcl_Obj *ret; tail = TclGetString(pathPtr); extension = TclGetExtension(tail); if (extension == NULL) { - TclNewObj(ret); + ret = Tcl_NewObj(); } else { ret = Tcl_NewStringObj(extension, -1); } Tcl_IncrRefCount(ret); return ret; @@ -818,67 +842,63 @@ Tcl_ListObjGetElements(NULL, listObj, &objc, &objv); res = TclJoinPath(elements, objv, 0); return res; } -Tcl_Obj * +static Tcl_Obj * TclJoinPath( int elements, /* Number of elements to use (-1 = all) */ Tcl_Obj * const objv[], /* Path elements to join */ int forceRelative) /* If non-zero, assume all more paths are * relative (e. g. simple normalization) */ { - Tcl_Obj *res = NULL; + Tcl_Obj *res = NULL; /* Resulting path object (container of join) */ + Tcl_Obj *elt; /* Path part (result if returns part of path) */ int i; - const Tcl_Filesystem *fsPtr = NULL; - - assert ( elements >= 0 ); - - if (elements == 0) { - return Tcl_NewObj(); - } - - assert ( elements > 0 ); - - if (elements == 2) { - Tcl_Obj *elt = objv[0]; - Tcl_ObjIntRep *eltIr = TclFetchIntRep(elt, &fsPathType); + Tcl_Filesystem *fsPtr = NULL; + + for (i = 0; i < elements; i++) { + int driveNameLength, strEltLen, length; + Tcl_PathType type; + char *strElt, *ptr; + Tcl_Obj *driveName = NULL; + + elt = objv[i]; /* * This is a special case where we can be much more efficient, where * 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. + * + * Bugfix [a47641a0]. TclNewFSPathObj requires first argument + * to be an absolute path. Added a check for that elt is absolute. */ - if ((eltIr) + if ((i == 0) && (elements == 2) + && (elt->typePtr == &tclFsPathType) && !((elt->bytes != NULL) && (elt->bytes[0] == '\0')) - && TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) { - Tcl_Obj *tailObj = objv[1]; - Tcl_PathType type; - + && TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) { + Tcl_Obj *tailObj = objv[i+1]; /* if forceRelative - second path is relative */ type = forceRelative ? TCL_PATH_RELATIVE : TclGetPathType(tailObj, NULL, NULL, NULL); if (type == TCL_PATH_RELATIVE) { const char *str; - size_t len; + int len; - str = TclGetStringFromObj(tailObj, &len); + str = Tcl_GetStringFromObj(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! */ - return elt; + goto partReturn; /* return elt; */ } /* * If it doesn't begin with '.' and is a unix path or it a * windows path without backslashes, then we can be very @@ -895,54 +915,47 @@ * all backslashes to forward slashes, so the base part * cannot have backslashes either. */ if ((tclPlatform != TCL_PLATFORM_WINDOWS) - || (strchr(TclGetString(elt), '\\') == NULL)) { - + || (strchr(Tcl_GetString(elt), '\\') == NULL) + ) { if (PATHFLAGS(elt)) { - return TclNewFSPathObj(elt, str, len); + elt = TclNewFSPathObj(elt, str, len); + goto partReturn; /* return elt; */ } if (TCL_PATH_ABSOLUTE != Tcl_FSGetPathType(elt)) { - return TclNewFSPathObj(elt, str, len); + elt = TclNewFSPathObj(elt, str, len); + goto partReturn; /* return elt; */ } (void) Tcl_FSGetNormalizedPath(NULL, elt); if (elt == PATHOBJ(elt)->normPathPtr) { - return TclNewFSPathObj(elt, str, len); + elt = TclNewFSPathObj(elt, str, len); + goto partReturn; /* return elt; */ } } } /* * Otherwise we don't have an easy join, and we must let the * more general code below handle things. */ } else if (tclPlatform == TCL_PLATFORM_UNIX) { - return tailObj; + elt = tailObj; + goto partReturn; /* return elt; */ } else { const char *str = TclGetString(tailObj); if (tclPlatform == TCL_PLATFORM_WINDOWS) { if (strchr(str, '\\') == NULL) { - return tailObj; + elt = tailObj; + goto partReturn; /* return elt; */ } } } } - } - - assert ( res == NULL ); - - for (i = 0; i < elements; i++) { - int driveNameLength; - size_t strEltLen, length; - Tcl_PathType type; - char *strElt, *ptr; - Tcl_Obj *driveName = NULL; - Tcl_Obj *elt = objv[i]; - - strElt = TclGetStringFromObj(elt, &strEltLen); + strElt = Tcl_GetStringFromObj(elt, &strEltLen); driveNameLength = 0; /* if forceRelative - all paths excepting first one are relative */ type = (forceRelative && (i > 0)) ? TCL_PATH_RELATIVE : TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName); if (type != TCL_PATH_RELATIVE) { @@ -1014,32 +1027,28 @@ goto noQuickReturn; } ptr++; } - if (res != NULL) { - TclDecrRefCount(res); - } - /* * This element is just what we want to return already; no further * manipulation is requred. */ - return elt; + goto partReturn; /* return elt; */ } /* * The path element was not of a suitable form to be returned as is. * We need to perform a more complex operation here. */ noQuickReturn: if (res == NULL) { - TclNewObj(res); + res = Tcl_NewObj(); } - ptr = TclGetStringFromObj(res, &length); + ptr = Tcl_GetStringFromObj(res, &length); /* * Strip off any './' before a tilde, unless this is the beginning of * the path. */ @@ -1080,13 +1089,13 @@ } } if (length > 0 && ptr[length -1] != '/') { Tcl_AppendToObj(res, &separator, 1); - (void)TclGetStringFromObj(res, &length); + Tcl_GetStringFromObj(res, &length); } - Tcl_SetObjLength(res, length + strlen(strElt)); + Tcl_SetObjLength(res, length + (int) strlen(strElt)); ptr = TclGetString(res) + length; for (; *strElt != '\0'; strElt++) { if (*strElt == separator) { while (strElt[1] == separator) { @@ -1104,12 +1113,20 @@ } length = ptr - TclGetString(res); Tcl_SetObjLength(res, length); } } - assert ( res != NULL ); + if (res == NULL) { + res = Tcl_NewObj(); + } return res; + +partReturn: + if (res != NULL) { + TclDecrRefCount(res); + } + return elt; } /* *--------------------------------------------------------------------------- * @@ -1146,20 +1163,43 @@ * object is already of FsPath type, and is a relative path, we do have to * worry about the cwd. If the cwd has changed, we must recompute the * path. */ - if (TclHasIntRep(pathPtr, &fsPathType)) { + if (pathPtr->typePtr == &tclFsPathType) { if (TclFSEpochOk(PATHOBJ(pathPtr)->filesystemEpoch)) { return TCL_OK; } - TclGetString(pathPtr); - Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); + if (pathPtr->bytes == NULL) { + UpdateStringOfFsPath(pathPtr); + } + FreeFsPathInternalRep(pathPtr); } - return SetFsPathFromAny(interp, pathPtr); + return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType); + + /* + * We used to have more complex code here: + * + * FsPath *fsPathPtr = PATHOBJ(pathPtr); + * if (fsPathPtr->cwdPtr == NULL || PATHFLAGS(pathPtr) != 0) { + * return TCL_OK; + * } else { + * if (TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) { + * return TCL_OK; + * } else { + * if (pathPtr->bytes == NULL) { + * UpdateStringOfFsPath(pathPtr); + * } + * FreeFsPathInternalRep(pathPtr); + * return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType); + * } + * } + * + * But we no longer believe this is necessary. + */ } /* * Helper function for normalization. */ @@ -1184,11 +1224,11 @@ * 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 size_t +static int FindSplitPos( const char *path, int separator) { int count = 0; @@ -1238,11 +1278,11 @@ Tcl_Obj * TclNewFSPathObj( Tcl_Obj *dirPtr, const char *addStrRep, - size_t len) + int len) { FsPath *fsPathPtr; Tcl_Obj *pathPtr; const char *p; int state = 0, count = 0; @@ -1269,12 +1309,12 @@ pathPtr = AppendPath(dirPtr, tail); Tcl_DecrRefCount(tail); return pathPtr; } - TclNewObj(pathPtr); - fsPathPtr = (FsPath *)Tcl_Alloc(sizeof(FsPath)); + pathPtr = Tcl_NewObj(); + fsPathPtr = (FsPath *) ckalloc(sizeof(FsPath)); /* * Set up the path. */ @@ -1287,50 +1327,52 @@ fsPathPtr->fsPtr = NULL; fsPathPtr->filesystemEpoch = 0; SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = TCLPATH_APPENDED; - TclInvalidateStringRep(pathPtr); + pathPtr->typePtr = &tclFsPathType; + pathPtr->bytes = NULL; + pathPtr->length = 0; /* * 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. + * 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+1 > 1; p++, len--) { - switch (state) { - case 0: /* So far only "." since last dirsep or start */ - switch (*p) { - case '.': - count = 1; - break; - case '/': - case '\\': - case ':': - if (count) { - PATHFLAGS(pathPtr) |= TCLPATH_NEEDNORM; - len = 0; - } - break; - default: - count = 0; - state = 1; - } - break; - case 1: /* Scanning for next dirsep */ - switch (*p) { - case '/': - case '\\': - case ':': - state = 0; - break; - } - } + 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; + } + break; + default: + count = 0; + state = 1; + } + break; + case 1: /* Scanning for next dirsep */ + switch (*p) { + case '/': + case '\\': + case ':': + state = 0; + break; + } + } } if (len == 0 && count) { - PATHFLAGS(pathPtr) |= TCLPATH_NEEDNORM; + PATHFLAGS(pathPtr) |= TCLPATH_NEEDNORM; } return pathPtr; } @@ -1337,24 +1379,24 @@ static Tcl_Obj * AppendPath( Tcl_Obj *head, Tcl_Obj *tail) { + int numBytes; const char *bytes; Tcl_Obj *copy = Tcl_DuplicateObj(head); - size_t length; /* * 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. + * we need to fix that bug here, it needs fixing in Tcl_FSJoinPath() too. */ - bytes = TclGetStringFromObj(tail, &length); - if (length == 0) { + bytes = Tcl_GetStringFromObj(tail, &numBytes); + if (numBytes == 0) { Tcl_AppendToObj(copy, "/", 1); } else { TclpNativeJoinPath(copy, bytes); } return copy; @@ -1382,23 +1424,86 @@ *--------------------------------------------------------------------------- */ Tcl_Obj * TclFSMakePathRelative( - TCL_UNUSED(Tcl_Interp *), + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *pathPtr, /* The path we have. */ Tcl_Obj *cwdPtr) /* Make it relative to this. */ { - size_t cwdLen, len; + int cwdLen, len; const char *tempStr; - Tcl_ObjIntRep *irPtr = TclFetchIntRep(pathPtr, &fsPathType); - if (irPtr) { + if (pathPtr->typePtr == &tclFsPathType) { FsPath *fsPathPtr = PATHOBJ(pathPtr); - if (PATHFLAGS(pathPtr) != 0 && fsPathPtr->cwdPtr == cwdPtr) { - return fsPathPtr->normPathPtr; + if (PATHFLAGS(pathPtr) != 0 + && fsPathPtr->cwdPtr == cwdPtr) { + pathPtr = fsPathPtr->normPathPtr; + + /* TODO: Determine how much, if any, of this forcing + * the relative path tail into the "path" Tcl_ObjType + * with a recorded cwdPtr context has any actual value. + * + * Nothing is getting cached. Not normPathPtr, not nativePathPtr, + * nor fsPtr, so storing the cwdPtr context against which such + * cached values might later be validated appears to be of no + * value. Take that away, and all this code is just a mildly + * optimized equivalent of a call to SetFsPathFromAny(). That + * optimization may have some value, *if* these value in fact + * get used as "path" values before used as something else. + * If not, though, whatever cost we pay below to convert to + * one of the "path" intreps is just a waste, it seems. The + * usual convention in the core is to delay ObjType conversion + * until it is needed and demanded, and I don't see why this + * section of code should be an exception to that. Leaving it + * in place for the rest of the 8.5.* releases just for sake + * of stability. + */ + + /* + * Free old representation. + */ + + if (pathPtr->typePtr != NULL) { + if (pathPtr->bytes == NULL) { + if (pathPtr->typePtr->updateStringProc == NULL) { + if (interp != NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "can't find object" + "string representation", NULL); + } + return NULL; + } + pathPtr->typePtr->updateStringProc(pathPtr); + } + TclFreeIntRep(pathPtr); + } + + /* + * Now pathPtr is a string object. + */ + + fsPathPtr = (FsPath *) ckalloc(sizeof(FsPath)); + + /* + * Circular reference, by design. + */ + + fsPathPtr->translatedPathPtr = pathPtr; + fsPathPtr->normPathPtr = NULL; + fsPathPtr->cwdPtr = cwdPtr; + Tcl_IncrRefCount(cwdPtr); + fsPathPtr->nativePathPtr = NULL; + fsPathPtr->fsPtr = NULL; + fsPathPtr->filesystemEpoch = 0; + + SETPATHOBJ(pathPtr, fsPathPtr); + PATHFLAGS(pathPtr) = 0; + pathPtr->typePtr = &tclFsPathType; + + return pathPtr; } } /* * We know the cwd is a normalised object which does not end in a @@ -1409,11 +1514,11 @@ * * Note that if we get this wrong, we will strip off either too much or * too little below, leading to wrong answers returned by glob. */ - tempStr = TclGetStringFromObj(cwdPtr, &cwdLen); + tempStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); /* * Should we perhaps use 'Tcl_FSPathSeparator'? But then what about the * Windows special case? Perhaps we should just check if cwd is a root * volume. @@ -1429,11 +1534,11 @@ if (tempStr[cwdLen-1] != '/' && tempStr[cwdLen-1] != '\\') { cwdLen++; } break; } - tempStr = TclGetStringFromObj(pathPtr, &len); + tempStr = Tcl_GetStringFromObj(pathPtr, &len); return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen); } /* @@ -1453,55 +1558,79 @@ *--------------------------------------------------------------------------- */ static int MakePathFromNormalized( - TCL_UNUSED(Tcl_Interp *), + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *pathPtr) /* The object to convert. */ { FsPath *fsPathPtr; - if (TclHasIntRep(pathPtr, &fsPathType)) { + if (pathPtr->typePtr == &tclFsPathType) { return TCL_OK; } - fsPathPtr = (FsPath *)Tcl_Alloc(sizeof(FsPath)); + /* + * Free old representation + */ + + if (pathPtr->typePtr != NULL) { + if (pathPtr->bytes == NULL) { + if (pathPtr->typePtr->updateStringProc == NULL) { + if (interp != NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "can't find object" + "string representation", NULL); + } + return TCL_ERROR; + } + pathPtr->typePtr->updateStringProc(pathPtr); + } + TclFreeIntRep(pathPtr); + } + + fsPathPtr = (FsPath *) ckalloc(sizeof(FsPath)); /* * It's a pure normalized absolute path. */ fsPathPtr->translatedPathPtr = NULL; - Tcl_IncrRefCount(fsPathPtr->normPathPtr = Tcl_DuplicateObj(pathPtr)); + /* + * Circular reference by design. + */ + + fsPathPtr->normPathPtr = pathPtr; fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = NULL; fsPathPtr->fsPtr = NULL; /* Remember the epoch under which we decided pathPtr was normalized */ fsPathPtr->filesystemEpoch = TclFSEpoch(); SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = 0; + pathPtr->typePtr = &tclFsPathType; return TCL_OK; } /* *--------------------------------------------------------------------------- * * Tcl_FSNewNativePath -- * - * Performs the something like the reverse of the usual + * This function 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 - * 'Tcl_Alloc' to allocate clientData, and Tcl_Free to free it. + * 'ckalloc' to allocate clientData, and ckfree to free it. * * Results: * NULL or a valid path object pointer, with refCount zero. * * Side effects: @@ -1510,11 +1639,11 @@ *--------------------------------------------------------------------------- */ Tcl_Obj * Tcl_FSNewNativePath( - const Tcl_Filesystem *fromFilesystem, + Tcl_Filesystem *fromFilesystem, ClientData clientData) { Tcl_Obj *pathPtr = NULL; FsPath *fsPathPtr; @@ -1529,44 +1658,56 @@ /* * Free old representation; shouldn't normally be any, but best to be * safe. */ - Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); - fsPathPtr = (FsPath *)Tcl_Alloc(sizeof(FsPath)); + if (pathPtr->typePtr != NULL) { + if (pathPtr->bytes == NULL) { + if (pathPtr->typePtr->updateStringProc == NULL) { + return NULL; + } + pathPtr->typePtr->updateStringProc(pathPtr); + } + TclFreeIntRep(pathPtr); + } + + fsPathPtr = (FsPath *) ckalloc(sizeof(FsPath)); fsPathPtr->translatedPathPtr = NULL; - Tcl_IncrRefCount(fsPathPtr->normPathPtr = Tcl_DuplicateObj(pathPtr)); + /* + * Circular reference, by design. + */ + + fsPathPtr->normPathPtr = pathPtr; fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = clientData; fsPathPtr->fsPtr = fromFilesystem; fsPathPtr->filesystemEpoch = TclFSEpoch(); SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = 0; + pathPtr->typePtr = &tclFsPathType; return pathPtr; } /* *--------------------------------------------------------------------------- * * Tcl_FSGetTranslatedPath -- * - * Attempts to extract the translated path from the given + * This function 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. + * path), then it is returned. Otherwise NULL will be returned, and an + * error message may be left in the interpreter (if it is non-NULL) * * Results: - * A Tcl_Obj pointer or NULL. + * NULL or a valid Tcl_Obj pointer. * * Side effects: - * pathPtr is converted to fsPathType if necessary. - * - * FsPath members are modified as needed. + * Only those of 'Tcl_FSConvertToPathType' * *--------------------------------------------------------------------------- */ Tcl_Obj * @@ -1580,42 +1721,43 @@ 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 { + if (PATHFLAGS(pathPtr) != 0) { /* * 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. */ Tcl_Obj *translatedCwdPtr = Tcl_FSGetTranslatedPath(interp, srcFsPathPtr->cwdPtr); - Tcl_ObjIntRep *translatedCwdIrPtr; - if (translatedCwdPtr == NULL) { return NULL; } retObj = Tcl_FSJoinToPath(translatedCwdPtr, 1, - &srcFsPathPtr->normPathPtr); - Tcl_IncrRefCount(srcFsPathPtr->translatedPathPtr = retObj); - translatedCwdIrPtr = TclFetchIntRep(translatedCwdPtr, &fsPathType); - if (translatedCwdIrPtr) { + &(srcFsPathPtr->normPathPtr)); + srcFsPathPtr->translatedPathPtr = retObj; + if (translatedCwdPtr->typePtr == &tclFsPathType) { srcFsPathPtr->filesystemEpoch = PATHOBJ(translatedCwdPtr)->filesystemEpoch; } else { srcFsPathPtr->filesystemEpoch = 0; } + Tcl_IncrRefCount(retObj); Tcl_DecrRefCount(translatedCwdPtr); + } else { + /* + * It is a pure absolute, normalized path object. This is + * something like being a 'pure list'. The object's string, + * translatedPath and normalizedPath are all identical. + */ + + retObj = srcFsPathPtr->normPathPtr; } } else { /* * It is an ordinary path object. */ @@ -1654,15 +1796,15 @@ Tcl_Obj *pathPtr) { Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr); if (transPtr != NULL) { - size_t len; - const char *orig = TclGetStringFromObj(transPtr, &len); - char *result = (char *)Tcl_Alloc(len+1); + int len; + const char *orig = Tcl_GetStringFromObj(transPtr, &len); + char *result = (char *) ckalloc((unsigned) len+1); - memcpy(result, orig, len+1); + memcpy(result, orig, (size_t) len+1); TclDecrRefCount(transPtr); return result; } return NULL; @@ -1704,22 +1846,23 @@ * This is a special path object which is the result of something like * 'file join' */ Tcl_Obj *dir, *copy; - size_t tailLen, cwdLen; - int pathType; + 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); + if (pathPtr->bytes == NULL) { + UpdateStringOfFsPath(pathPtr); + } - (void)TclGetStringFromObj(fsPathPtr->normPathPtr, &tailLen); + Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &tailLen); if (tailLen) { copy = AppendPath(dir, fsPathPtr->normPathPtr); } else { copy = Tcl_DuplicateObj(dir); } @@ -1728,35 +1871,35 @@ /* * We now own a reference on both 'dir' and 'copy' */ - (void) TclGetStringFromObj(dir, &cwdLen); + (void) Tcl_GetStringFromObj(dir, &cwdLen); /* Normalize the combined string. */ if (PATHFLAGS(pathPtr) & TCLPATH_NEEDNORM) { /* - * If the "tail" part has components (like /../) that cause the - * combined path to need more complete normalizing, call on the - * more powerful routine to accomplish that so we avoid [Bug - * 2385549] ... + * If the "tail" part has components (like /../) that cause + * the combined path to need more complete normalizing, + * call on the more powerful routine to accomplish that so + * we avoid [Bug 2385549] ... */ Tcl_Obj *newCopy = TclFSNormalizeAbsolutePath(interp, copy); - Tcl_DecrRefCount(copy); copy = newCopy; } else { /* - * ... but in most cases where we join a trouble free tail to a - * normalized head, we can more efficiently normalize the combined - * path by passing over only the unnormalized tail portion. When - * this is sufficient, prior developers claim this should be much - * faster. We use 'cwdLen' so that we are already pointing at - * the dir-separator that we know about. The normalization code - * will actually start off directly after that separator. + * ... but in most cases where we join a trouble free tail + * to a normalized head, we can more efficiently normalize the + * combined path by passing over only the unnormalized tail + * portion. When this is sufficient, prior developers claim + * this should be much faster. We use 'cwdLen' so that we are + * already pointing at the dir-separator that we know about. + * The normalization code will actually start off directly + * after that separator. */ TclFSNormalizeToUniquePath(interp, copy, cwdLen); } @@ -1765,15 +1908,15 @@ if (pathType == TCL_PATH_RELATIVE) { Tcl_Obj *origDir = fsPathPtr->cwdPtr; /* * NOTE: here we are (dangerously?) assuming that origDir points - * to a Tcl_Obj with Tcl_ObjType == &fsPathType. The + * to a Tcl_Obj with Tcl_ObjType == &tclFsPathType . The * pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr); - * above that set the pathType value should have established that, - * but it's far less clear on what basis we know there's been no - * shimmering since then. + * above that set the pathType value should have established + * that, but it's far less clear on what basis we know there's + * been no shimmering since then. */ FsPath *origDirFsPathPtr = PATHOBJ(origDir); fsPathPtr->cwdPtr = origDirFsPathPtr->cwdPtr; @@ -1780,18 +1923,26 @@ Tcl_IncrRefCount(fsPathPtr->cwdPtr); TclDecrRefCount(fsPathPtr->normPathPtr); fsPathPtr->normPathPtr = copy; + /* + * That's our reference to copy used. + */ + TclDecrRefCount(dir); TclDecrRefCount(origDir); } else { TclDecrRefCount(fsPathPtr->cwdPtr); fsPathPtr->cwdPtr = NULL; TclDecrRefCount(fsPathPtr->normPathPtr); fsPathPtr->normPathPtr = copy; + /* + * That's our reference to copy used. + */ + TclDecrRefCount(dir); } PATHFLAGS(pathPtr) = 0; } @@ -1799,24 +1950,26 @@ * 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) { + if (pathPtr->bytes == NULL) { + UpdateStringOfFsPath(pathPtr); + } + FreeFsPathInternalRep(pathPtr); + if (Tcl_ConvertToType(interp, pathPtr, &tclFsPathType) != TCL_OK) { return NULL; } fsPathPtr = PATHOBJ(pathPtr); } else if (fsPathPtr->normPathPtr == NULL) { - size_t cwdLen; + int cwdLen; Tcl_Obj *copy; copy = AppendPath(fsPathPtr->cwdPtr, pathPtr); - (void) TclGetStringFromObj(fsPathPtr->cwdPtr, &cwdLen); - cwdLen += (TclGetString(copy)[cwdLen] == '/'); + (void) Tcl_GetStringFromObj(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! */ @@ -1826,13 +1979,14 @@ Tcl_IncrRefCount(fsPathPtr->normPathPtr); } } if (fsPathPtr->normPathPtr == NULL) { Tcl_Obj *useThisCwd = NULL; + int pureNormalized = 1; /* - * Since normPathPtr is NULL but this is a valid path object, we know + * 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); @@ -1846,15 +2000,15 @@ * might loop back through here. */ if (path[0] == '\0') { /* - * Special handling for the empty string value. This one is very - * weird with [file normalize {}] => {}. (The reasoning supporting - * this is unknown to DGP, but he fears changing it.) Attempt here - * to keep the expectations of other parts of Tcl_Filesystem code - * about state of the FsPath fields satisfied. + * Special handling for the empty string value. This one is + * very weird with [file normalize {}] => {}. (The reasoning + * supporting this is unknown to DGP, but he fears changing it.) + * Attempt here to keep the expectations of other parts of + * Tcl_Filesystem code about state of the FsPath fields satisfied. * * In particular, capture the cwd value and save so it can be * stored in the cwdPtr field below. */ @@ -1875,18 +2029,19 @@ if (useThisCwd == NULL) { return NULL; } + pureNormalized = 0; Tcl_DecrRefCount(absolutePath); absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath); Tcl_IncrRefCount(absolutePath); /* * We have a refCount on the cwd. */ -#ifdef _WIN32 +#ifdef __WIN32__ } else if (type == TCL_PATH_VOLUME_RELATIVE) { /* * Only Windows has volume-relative paths. */ @@ -1894,24 +2049,44 @@ absolutePath = TclWinVolumeRelativeNormalize(interp, path, &useThisCwd); if (absolutePath == NULL) { return NULL; } -#endif /* _WIN32 */ + pureNormalized = 0; +#endif /* __WIN32__ */ } } /* * Already has refCount incremented. */ - if (fsPathPtr->normPathPtr) { - Tcl_DecrRefCount(fsPathPtr->normPathPtr); - } fsPathPtr->normPathPtr = TclFSNormalizeAbsolutePath(interp, absolutePath); + /* + * Check if path is pure normalized (this can only be the case if it + * is an absolute path). + */ + + if (pureNormalized) { + if (!strcmp(TclGetString(fsPathPtr->normPathPtr), + TclGetString(pathPtr))) { + /* + * The path was already normalized. Get rid of the duplicate. + */ + + TclDecrRefCount(fsPathPtr->normPathPtr); + + /* + * We do *not* increment the refCount for this circular + * reference. + */ + + fsPathPtr->normPathPtr = pathPtr; + } + } if (useThisCwd != NULL) { /* * We just need to free an object we allocated above for relative * paths (this was returned by Tcl_FSJoinToPath above), and then * of course store the cwd. @@ -1928,74 +2103,83 @@ /* *--------------------------------------------------------------------------- * * Tcl_FSGetInternalRep -- * - * Produces a native representation of a given path object in the given - * filesystem. + * Extract the internal representation of a given path object, in the + * given filesystem. If the path object belongs to a different + * filesystem, we return NULL. * - * 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. + * If the internal representation is currently NULL, we attempt to + * generate it, by calling the filesystem's + * 'Tcl_FSCreateInternalRepProc'. * * Results: - * - * The native handle for the path, or NULL if the path is not handled by - * the given filesystem + * NULL or a valid internal representation. * * Side effects: - * - * Tcl_FSCreateInternalRepProc if needed to produce the native - * handle, which is then stored in the internal representation of pathPtr. + * An attempt may be made to convert the object. * *--------------------------------------------------------------------------- */ ClientData Tcl_FSGetInternalRep( Tcl_Obj *pathPtr, - const Tcl_Filesystem *fsPtr) + 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). - */ + * We will only return the native representation for the caller's + * filesystem. Otherwise we will simply return NULL. This means that there + * must be a unique bi-directional mapping between paths and filesystems, + * and that this mapping will not allow 'remapped' files -- files which + * are in one filesystem but mapped into another. Another way of putting + * this is that 'stacked' filesystems are not allowed. We recognise that + * this is a potentially useful feature for the future. + * + * 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 easily achievable with the current implementation. + */ + + if (srcFsPathPtr->fsPtr == NULL) { + /* + * This only usually happens in wrappers like TclpStat which create a + * string object and pass it to TclpObjStat. Code which calls the + * Tcl_FS.. functions should always have a filesystem already set. + * Whether this code path is legal or not depends on whether we decide + * to allow external code to call the native filesystem directly. It + * is at least safer to allow this sub-optimal routing. + */ + + Tcl_FSGetFileSystemForPath(pathPtr); + + /* + * If we fail through here, then 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). + */ + + srcFsPathPtr = PATHOBJ(pathPtr); + if (srcFsPathPtr->fsPtr == NULL) { 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. + * There is still one possibility we should consider; if the file belongs + * to a different filesystem, perhaps it is actually linked through to a + * file in our own filesystem which we do care about. The way we can check + * for this is we ask what filesystem this path belongs to. */ if (fsPtr != srcFsPathPtr->fsPtr) { const Tcl_Filesystem *actualFs = Tcl_FSGetFileSystemForPath(pathPtr); @@ -2012,14 +2196,13 @@ proc = srcFsPathPtr->fsPtr->createInternalRepProc; if (proc == NULL) { return NULL; } - nativePathPtr = (char *)proc(pathPtr); + nativePathPtr = (*proc)(pathPtr); srcFsPathPtr = PATHOBJ(pathPtr); srcFsPathPtr->nativePathPtr = nativePathPtr; - srcFsPathPtr->filesystemEpoch = TclFSEpoch(); } return srcFsPathPtr->nativePathPtr; } @@ -2026,55 +2209,61 @@ /* *--------------------------------------------------------------------------- * * TclFSEnsureEpochOk -- * - * Ensure that the path is a valid path, and that it has a - * fsPathType internal representation that is not stale. + * This will ensure the pathPtr is up to date and can be converted into a + * "path" type, and that we are able to generate a complete normalized + * path which is used to determine the filesystem match. * * Results: - * A standard Tcl return code. + * Standard Tcl return code. * * Side effects: - * The internal representation of fsPtrPtr is converted to fsPathType if - * possible. + * An attempt may be made to convert the object. * *--------------------------------------------------------------------------- */ int TclFSEnsureEpochOk( Tcl_Obj *pathPtr, - const Tcl_Filesystem **fsPtrPtr) + Tcl_Filesystem **fsPtrPtr) { FsPath *srcFsPathPtr; - if (!TclHasIntRep(pathPtr, &fsPathType)) { + if (pathPtr->typePtr != &tclFsPathType) { return TCL_OK; } srcFsPathPtr = PATHOBJ(pathPtr); + /* + * Check if the filesystem has changed in some way since this object's + * internal representation was calculated. + */ + 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. + * We have to discard the stale representation and recalculate it. */ - TclGetString(pathPtr); - Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); + if (pathPtr->bytes == NULL) { + UpdateStringOfFsPath(pathPtr); + } + FreeFsPathInternalRep(pathPtr); if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) { return TCL_ERROR; } srcFsPathPtr = PATHOBJ(pathPtr); } + /* + * Check whether the object is already assigned to a fs. + */ + if (srcFsPathPtr->fsPtr != NULL) { - /* - * There is already a filesystem assigned to this path. - */ *fsPtrPtr = srcFsPathPtr->fsPtr; } return TCL_OK; } @@ -2095,20 +2284,20 @@ */ void TclFSSetPathDetails( Tcl_Obj *pathPtr, - const Tcl_Filesystem *fsPtr, + Tcl_Filesystem *fsPtr, ClientData clientData) { FsPath *srcFsPathPtr; /* * Make sure pathPtr is of the correct type. */ - if (!TclHasIntRep(pathPtr, &fsPathType)) { + if (pathPtr->typePtr != &tclFsPathType) { if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) { return; } } @@ -2138,24 +2327,23 @@ int Tcl_FSEqualPaths( Tcl_Obj *firstPtr, Tcl_Obj *secondPtr) { - const char *firstStr, *secondStr; - size_t firstLen, secondLen; - int tempErrno; + char *firstStr, *secondStr; + int firstLen, secondLen, tempErrno; if (firstPtr == secondPtr) { return 1; } if (firstPtr == NULL || secondPtr == NULL) { return 0; } - firstStr = TclGetStringFromObj(firstPtr, &firstLen); - secondStr = TclGetStringFromObj(secondPtr, &secondLen); - if ((firstLen == secondLen) && !memcmp(firstStr, secondStr, firstLen)) { + firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen); + secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen); + if ((firstLen == secondLen) && (strcmp(firstStr, secondStr) == 0)) { return 1; } /* * Try the most thorough, correct method of comparing fully normalized @@ -2169,26 +2357,25 @@ if (firstPtr == NULL || secondPtr == NULL) { return 0; } - firstStr = TclGetStringFromObj(firstPtr, &firstLen); - secondStr = TclGetStringFromObj(secondPtr, &secondLen); - return ((firstLen == secondLen) && !memcmp(firstStr, secondStr, firstLen)); + firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen); + secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen); + return (firstLen == secondLen) && (strcmp(firstStr, secondStr) == 0); } /* *--------------------------------------------------------------------------- * * SetFsPathFromAny -- * - * Attempt to convert the internal representation of pathPtr to - * fsPathType. + * This function tries to convert the given Tcl_Obj to a valid Tcl path + * type. * - * A tilde ("~") character at the beginnig of the filename indicates the - * current user's home directory, and "~" indicates a particular - * user's directory. + * The filename may begin with "~" (to indicate current user's home + * directory) or "~" (to indicate any user's home directory). * * Results: * Standard Tcl error code. * * Side effects: @@ -2200,16 +2387,16 @@ static int SetFsPathFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *pathPtr) /* The object to convert. */ { - size_t len; + int len; FsPath *fsPathPtr; Tcl_Obj *transPtr; - const char *name; + char *name; - if (TclHasIntRep(pathPtr, &fsPathType)) { + if (pathPtr->typePtr == &tclFsPathType) { return TCL_OK; } /* * First step is to translate the filename. This is similar to @@ -2223,19 +2410,20 @@ * However, the split/join routines are quite complex, and one has to make * sure not to break anything on Unix or Win (fCmd.test, fileName.test and * cmdAH.test exercise most of the code). */ - name = TclGetStringFromObj(pathPtr, &len); + name = Tcl_GetStringFromObj(pathPtr, &len); /* * Handle tilde substitutions, if needed. */ if (len && name[0] == '~') { + char *expandedUser; Tcl_DString temp; - size_t split; + int split; char separator = '/'; /* * We have multiple cases '~/foo/bar...', '~user/foo/bar...', etc. * split becomes value 1 for '~/...' as well as for '~'. @@ -2255,49 +2443,46 @@ Tcl_DString dirString; dir = TclGetEnv("HOME", &dirString); if (dir == NULL) { if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "couldn't find HOME environment variable to" - " expand path", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", - "HOMELESS", NULL); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't find HOME environment " + "variable to expand path", NULL); } return TCL_ERROR; } Tcl_DStringInit(&temp); Tcl_JoinPath(1, &dir, &temp); Tcl_DStringFree(&dirString); } else { /* - * There is a '~user' + * We have a user name '~user' */ - const char *expandedUser; Tcl_DString userName; Tcl_DStringInit(&userName); Tcl_DStringAppend(&userName, name+1, split-1); expandedUser = Tcl_DStringValue(&userName); Tcl_DStringInit(&temp); if (TclpGetUserHome(expandedUser, &temp) == NULL) { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "user \"%s\" doesn't exist", expandedUser)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER", - NULL); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "user \"", expandedUser, + "\" doesn't exist", NULL); } Tcl_DStringFree(&userName); Tcl_DStringFree(&temp); return TCL_ERROR; } Tcl_DStringFree(&userName); } - transPtr = TclDStringToObj(&temp); + expandedUser = Tcl_DStringValue(&temp); + transPtr = Tcl_NewStringObj(expandedUser, Tcl_DStringLength(&temp)); if (split != len) { /* * Join up the tilde substitution with the rest. */ @@ -2319,54 +2504,60 @@ * Skip '~'. It's replaced by its expansion. */ objc--; objv++; while (objc--) { - TclpNativeJoinPath(transPtr, TclGetString(*objv)); - objv++; + TclpNativeJoinPath(transPtr, Tcl_GetString(*objv++)); } TclDecrRefCount(parts); } else { Tcl_Obj *pair[2]; pair[0] = transPtr; pair[1] = Tcl_NewStringObj(name+split+1, -1); transPtr = TclJoinPath(2, pair, 1); if (transPtr != pair[0]) { - Tcl_DecrRefCount(pair[0]); + TclDecrRefCount(pair[0]); } if (transPtr != pair[1]) { - Tcl_DecrRefCount(pair[1]); + TclDecrRefCount(pair[1]); } } } + Tcl_DStringFree(&temp); } else { transPtr = TclJoinPath(1, &pathPtr, 1); } /* * Now we have a translated filename in 'transPtr'. This will have forward * slashes on Windows, and will not contain any ~user sequences. */ - fsPathPtr = (FsPath *)Tcl_Alloc(sizeof(FsPath)); + fsPathPtr = (FsPath *) ckalloc(sizeof(FsPath)); - if (transPtr == pathPtr) { - transPtr = Tcl_DuplicateObj(pathPtr); - fsPathPtr->filesystemEpoch = 0; + fsPathPtr->translatedPathPtr = transPtr; + if (transPtr != pathPtr) { + Tcl_IncrRefCount(fsPathPtr->translatedPathPtr); + /* Redo translation when $env(HOME) changes */ + fsPathPtr->filesystemEpoch = TclFSEpoch(); } else { - fsPathPtr->filesystemEpoch = TclFSEpoch(); + fsPathPtr->filesystemEpoch = 0; } - Tcl_IncrRefCount(transPtr); - fsPathPtr->translatedPathPtr = transPtr; fsPathPtr->normPathPtr = NULL; fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = NULL; fsPathPtr->fsPtr = NULL; + /* + * Free old representation before installing our new one. + */ + + TclFreeIntRep(pathPtr); SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = 0; + pathPtr->typePtr = &tclFsPathType; return TCL_OK; } static void FreeFsPathInternalRep( @@ -2385,43 +2576,53 @@ } fsPathPtr->normPathPtr = NULL; } if (fsPathPtr->cwdPtr != NULL) { TclDecrRefCount(fsPathPtr->cwdPtr); - fsPathPtr->cwdPtr = NULL; } if (fsPathPtr->nativePathPtr != NULL && fsPathPtr->fsPtr != NULL) { Tcl_FSFreeInternalRepProc *freeProc = fsPathPtr->fsPtr->freeInternalRepProc; if (freeProc != NULL) { - freeProc(fsPathPtr->nativePathPtr); + (*freeProc)(fsPathPtr->nativePathPtr); fsPathPtr->nativePathPtr = NULL; } } - Tcl_Free(fsPathPtr); + ckfree((char *) fsPathPtr); + pathPtr->typePtr = NULL; } 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 *)Tcl_Alloc(sizeof(FsPath)); + FsPath *copyFsPathPtr = (FsPath *) ckalloc(sizeof(FsPath)); SETPATHOBJ(copyPtr, copyFsPathPtr); - copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr; - if (copyFsPathPtr->translatedPathPtr != NULL) { - Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr); + if (srcFsPathPtr->translatedPathPtr == srcPtr) { + /* Cycle in src -> make cycle in copy. */ + copyFsPathPtr->translatedPathPtr = copyPtr; + } else { + copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr; + if (copyFsPathPtr->translatedPathPtr != NULL) { + Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr); + } } - copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr; - if (copyFsPathPtr->normPathPtr != NULL) { - Tcl_IncrRefCount(copyFsPathPtr->normPathPtr); + if (srcFsPathPtr->normPathPtr == srcPtr) { + /* Cycle in src -> make cycle in copy. */ + copyFsPathPtr->normPathPtr = copyPtr; + } else { + copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr; + if (copyFsPathPtr->normPathPtr != NULL) { + Tcl_IncrRefCount(copyFsPathPtr->normPathPtr); + } } copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr; if (copyFsPathPtr->cwdPtr != NULL) { Tcl_IncrRefCount(copyFsPathPtr->cwdPtr); @@ -2434,19 +2635,21 @@ Tcl_FSDupInternalRepProc *dupProc = srcFsPathPtr->fsPtr->dupInternalRepProc; if (dupProc != NULL) { copyFsPathPtr->nativePathPtr = - dupProc(srcFsPathPtr->nativePathPtr); + (*dupProc)(srcFsPathPtr->nativePathPtr); } else { copyFsPathPtr->nativePathPtr = NULL; } } else { copyFsPathPtr->nativePathPtr = NULL; } copyFsPathPtr->fsPtr = srcFsPathPtr->fsPtr; copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch; + + copyPtr->typePtr = &tclFsPathType; } /* *--------------------------------------------------------------------------- * @@ -2463,30 +2666,26 @@ *--------------------------------------------------------------------------- */ static void UpdateStringOfFsPath( - Tcl_Obj *pathPtr) /* path obj with string rep to update. */ + register Tcl_Obj *pathPtr) /* path obj with string rep to update. */ { FsPath *fsPathPtr = PATHOBJ(pathPtr); - size_t cwdLen; + 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); - if (Tcl_IsShared(copy)) { - copy = Tcl_DuplicateObj(copy); - } - Tcl_IncrRefCount(copy); - /* Steal copy's string rep */ - pathPtr->bytes = TclGetStringFromObj(copy, &cwdLen); + pathPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen); pathPtr->length = cwdLen; - TclInitStringRep(copy, NULL, 0); + copy->bytes = tclEmptyStringRep; + copy->length = 0; TclDecrRefCount(copy); } /* *--------------------------------------------------------------------------- @@ -2510,20 +2709,20 @@ */ int TclNativePathInFilesystem( Tcl_Obj *pathPtr, - TCL_UNUSED(ClientData *)) + ClientData *clientDataPtr) { /* * 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. */ - if (TclHasIntRep(pathPtr, &fsPathType)) { + if (pathPtr->typePtr == &tclFsPathType) { if (pathPtr->bytes != NULL && pathPtr->bytes[0] == '\0') { /* * We reject the empty path "". */ @@ -2534,17 +2733,17 @@ * Otherwise there is no way this path can be empty. */ } 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 + * being of tclFsPathType. However, we do our best to deal with the * situation. */ - size_t len; + int len; - (void) TclGetStringFromObj(pathPtr, &len); + (void) Tcl_GetStringFromObj(pathPtr, &len); if (len == 0) { /* * We reject the empty path "". */ Index: generic/tclPipe.c ================================================================== --- generic/tclPipe.c +++ generic/tclPipe.c @@ -30,12 +30,12 @@ /* * Declarations for local functions defined in this file: */ -static TclFile FileForRedirect(Tcl_Interp *interp, const char *spec, - int atOk, const char *arg, const char *nextArg, +static TclFile FileForRedirect(Tcl_Interp *interp, CONST char *spec, + int atOk, CONST char *arg, CONST char *nextArg, int flags, int *skipPtr, int *closePtr, int *releasePtr); /* *---------------------------------------------------------------------- @@ -58,19 +58,19 @@ *---------------------------------------------------------------------- */ static TclFile FileForRedirect( - Tcl_Interp *interp, /* Interpreter to use for error reporting. */ - const char *spec, /* Points to character just after redirection + Tcl_Interp *interp, /* Intepreter to use for error reporting. */ + CONST char *spec, /* Points to character just after redirection * character. */ int atOK, /* Non-zero means that '@' notation can be * used to specify a channel, zero means that * it isn't. */ - const char *arg, /* Pointer to entire argument containing spec: + CONST char *arg, /* Pointer to entire argument containing spec: * used for error reporting. */ - const char *nextArg, /* Next argument in argc/argv array, if needed + CONST char *nextArg, /* Next argument in argc/argv array, if needed * for file name or channel name. May be * NULL. */ int flags, /* Flags to use for opening file or to specify * mode for channel. */ int *skipPtr, /* Filled with 1 if redirection target was in @@ -92,42 +92,38 @@ if (spec == NULL) { goto badLastArg; } *skipPtr = 2; } - chan = Tcl_GetChannel(interp, spec, NULL); - if (chan == (Tcl_Channel) NULL) { - return NULL; - } + chan = Tcl_GetChannel(interp, spec, NULL); + if (chan == (Tcl_Channel) NULL) { + return NULL; + } file = TclpMakeFile(chan, writing ? TCL_WRITABLE : TCL_READABLE); - if (file == NULL) { - Tcl_Obj *msg; - + if (file == NULL) { + Tcl_Obj* msg; Tcl_GetChannelError(chan, &msg); if (msg) { - Tcl_SetObjResult(interp, msg); + Tcl_SetObjResult (interp, msg); } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "channel \"%s\" wasn't opened for %s", - Tcl_GetChannelName(chan), - ((writing) ? "writing" : "reading"))); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", - "BADCHAN", NULL); - } - return NULL; - } + Tcl_AppendResult(interp, "channel \"", Tcl_GetChannelName(chan), + "\" wasn't opened for ", + ((writing) ? "writing" : "reading"), NULL); + } + return NULL; + } *releasePtr = 1; if (writing) { /* * Be sure to flush output to the file, so that anything written * by the child appears after stuff we've already written. */ - Tcl_Flush(chan); + Tcl_Flush(chan); } } else { - const char *name; + CONST char *name; Tcl_DString nameString; if (*spec == '\0') { spec = nextArg; if (spec == NULL) { @@ -140,24 +136,22 @@ return NULL; } file = TclpOpenFile(name, flags); Tcl_DStringFree(&nameString); if (file == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't %s file \"%s\": %s", - (writing ? "write" : "read"), spec, - Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "couldn't ", + ((writing) ? "write" : "read"), " file \"", spec, "\": ", + Tcl_PosixError(interp), NULL); return NULL; } - *closePtr = 1; + *closePtr = 1; } return file; badLastArg: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't specify \"%s\" as last word in command", arg)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "SYNTAX", NULL); + Tcl_AppendResult(interp, "can't specify \"", arg, + "\" as last word in command", NULL); return NULL; } /* *---------------------------------------------------------------------- @@ -181,16 +175,16 @@ 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; + register Detached *detPtr; int i; Tcl_MutexLock(&pipeMutex); for (i = 0; i < numPids; i++) { - detPtr = (Detached *)Tcl_Alloc(sizeof(Detached)); + detPtr = (Detached *) ckalloc(sizeof(Detached)); detPtr->pid = pidPtr[i]; detPtr->nextPtr = detList; detList = detPtr; } Tcl_MutexUnlock(&pipeMutex); @@ -217,19 +211,19 @@ */ void Tcl_ReapDetachedProcs(void) { - Detached *detPtr; + register Detached *detPtr; Detached *nextPtr, *prevPtr; - int status, code; + int status; + Tcl_Pid pid; 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)) { + pid = Tcl_WaitPid(detPtr->pid, &status, WNOHANG); + if ((pid == 0) || ((pid == (Tcl_Pid) -1) && (errno != ECHILD))) { prevPtr = detPtr; detPtr = detPtr->nextPtr; continue; } nextPtr = detPtr->nextPtr; @@ -236,11 +230,11 @@ if (prevPtr == NULL) { detList = detPtr->nextPtr; } else { prevPtr->nextPtr = detPtr->nextPtr; } - Tcl_Free(detPtr); + ckfree((char *) detPtr); detPtr = nextPtr; } Tcl_MutexUnlock(&pipeMutex); } @@ -275,25 +269,42 @@ * from pipeline. NULL means there isn't any * stderr output. */ { int result = TCL_OK; int i, abnormalExit, anyErrorInfo; - TclProcessWaitStatus waitStatus; - int code; - Tcl_Obj *msg, *error; + Tcl_Pid pid; + WAIT_STATUS_TYPE waitStatus; + CONST char *msg; + unsigned long resolvedPid; abnormalExit = 0; for (i = 0; i < numPids; i++) { - waitStatus = TclProcessWait(pidPtr[i], 0, &code, &msg, &error); - if (waitStatus == TCL_PROCESS_ERROR) { + /* + * We need to get the resolved pid before we wait on it as the windows + * implementation of Tcl_WaitPid deletes the information such that any + * following calls to TclpGetPid fail. + */ + + resolvedPid = TclpGetPid(pidPtr[i]); + pid = Tcl_WaitPid(pidPtr[i], (int *) &waitStatus, 0); + if (pid == (Tcl_Pid) -1) { result = TCL_ERROR; - if (interp != NULL) { - Tcl_SetObjErrorCode(interp, error); - Tcl_SetObjResult(interp, msg); - } - Tcl_DecrRefCount(error); - Tcl_DecrRefCount(msg); + if (interp != NULL) { + msg = Tcl_PosixError(interp); + if (errno == ECHILD) { + /* + * This changeup in message suggested by Mark Diekhans to + * remind people that ECHILD errors can occur on some + * systems if SIGCHLD isn't in its default state. + */ + + msg = + "child process lost (is SIGCHLD ignored or trapped?)"; + } + Tcl_AppendResult(interp, "error waiting for process to exit: ", + msg, NULL); + } continue; } /* * Create error messages for unusual process exits. An extra newline @@ -300,23 +311,43 @@ * gets appended to each error message, but it gets removed below (in * the same fashion that an extra newline in the command's output is * removed). */ - if (waitStatus != TCL_PROCESS_EXITED || code != 0) { + if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) { + char msg1[TCL_INTEGER_SPACE], msg2[TCL_INTEGER_SPACE]; + result = TCL_ERROR; - if (waitStatus == TCL_PROCESS_EXITED) { - if (interp != NULL) { - Tcl_SetObjErrorCode(interp, error); - } + sprintf(msg1, "%lu", resolvedPid); + if (WIFEXITED(waitStatus)) { + if (interp != (Tcl_Interp *) NULL) { + sprintf(msg2, "%lu", + (unsigned long) WEXITSTATUS(waitStatus)); + Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2, NULL); + } abnormalExit = 1; } else if (interp != NULL) { - Tcl_SetObjErrorCode(interp, error); - Tcl_SetObjResult(interp, msg); + CONST char *p; + + if (WIFSIGNALED(waitStatus)) { + p = Tcl_SignalMsg((int) (WTERMSIG(waitStatus))); + Tcl_SetErrorCode(interp, "CHILDKILLED", msg1, + Tcl_SignalId((int) (WTERMSIG(waitStatus))), p, + NULL); + Tcl_AppendResult(interp, "child killed: ", p, "\n", NULL); + } else if (WIFSTOPPED(waitStatus)) { + p = Tcl_SignalMsg((int) (WSTOPSIG(waitStatus))); + Tcl_SetErrorCode(interp, "CHILDSUSP", msg1, + Tcl_SignalId((int) (WSTOPSIG(waitStatus))), p, + NULL); + Tcl_AppendResult(interp, "child suspended: ", p, "\n", + NULL); + } else { + Tcl_AppendResult(interp, + "child wait status didn't make sense\n", NULL); + } } - Tcl_DecrRefCount(error); - Tcl_DecrRefCount(msg); } } /* * Read the standard error file. If there's anything there, then return an @@ -327,43 +358,41 @@ if (errorChan != NULL) { /* * Make sure we start at the beginning of the file. */ - if (interp != NULL) { + if (interp != NULL) { int count; Tcl_Obj *objPtr; - Tcl_Seek(errorChan, 0, SEEK_SET); - TclNewObj(objPtr); + Tcl_Seek(errorChan, (Tcl_WideInt)0, SEEK_SET); + objPtr = Tcl_NewObj(); count = Tcl_ReadChars(errorChan, objPtr, -1, 0); - if (count == -1) { + 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))); + Tcl_AppendResult(interp, "error reading stderr output file: ", + Tcl_PosixError(interp), NULL); } else if (count > 0) { anyErrorInfo = 1; Tcl_SetObjResult(interp, objPtr); result = TCL_ERROR; } else { Tcl_DecrRefCount(objPtr); } } - Tcl_CloseEx(NULL, errorChan, 0); + Tcl_Close(NULL, errorChan); } /* * If a child exited abnormally but didn't output any error information at * all, generate an error message here. */ if ((abnormalExit != 0) && (anyErrorInfo == 0) && (interp != NULL)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "child process exited abnormally", -1)); + Tcl_AppendResult(interp, "child process exited abnormally", NULL); } return result; } /* @@ -397,11 +426,11 @@ int TclCreatePipeline( Tcl_Interp *interp, /* Interpreter to use for error reporting. */ int argc, /* Number of entries in argv. */ - const char **argv, /* Array of strings describing commands in + CONST char **argv, /* Array of strings describing commands in * pipeline plus I/O redirection with <, <<, * >, etc. Argv[argc] must be NULL. */ Tcl_Pid **pidArrayPtr, /* Word at *pidArrayPtr gets filled in with * address of array of pids for processes in * pipeline (first pid is first process in @@ -433,35 +462,35 @@ * pids of child processes. */ int numPids; /* Actual number of processes that exist at * *pidPtr right now. */ int cmdCount; /* Count of number of distinct commands found * in argc/argv. */ - const char *inputLiteral = NULL; + CONST char *inputLiteral = NULL; /* If non-null, then this points to a string * containing input data (specified via <<) to * be piped to the first process in the * pipeline. */ TclFile inputFile = NULL; /* If != NULL, gives file to use as input for * first process in pipeline (specified via < * or <@). */ int inputClose = 0; /* If non-zero, then inputFile should be - * closed when cleaning up. */ + * closed when cleaning up. */ int inputRelease = 0; TclFile outputFile = NULL; /* Writable file for output from last command * in pipeline (could be file or pipe). NULL * means use stdout. */ int outputClose = 0; /* If non-zero, then outputFile should be - * closed when cleaning up. */ + * closed when cleaning up. */ int outputRelease = 0; TclFile errorFile = NULL; /* Writable file for error output from all * commands in pipeline. NULL means use * stderr. */ int errorClose = 0; /* If non-zero, then errorFile should be - * closed when cleaning up. */ + * closed when cleaning up. */ int errorRelease = 0; - const char *p; - const char *nextArg; + CONST char *p; + CONST char *nextArg; int skip, lastBar, lastArg, i, j, atOK, flags, needCmd, errorToOutput = 0; Tcl_DString execBuffer; TclFile pipeIn; TclFile curInFile, curOutFile, curErrFile; Tcl_Channel channel; @@ -508,14 +537,12 @@ if (*p == '&') { p++; } if (*p == '\0') { if ((i == (lastBar + 1)) || (i == (argc - 1))) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "illegal use of | or |& in command", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", - "PIPESYNTAX", NULL); + Tcl_SetResult(interp, "illegal use of | or |& in command", + TCL_STATIC); goto error; } } lastBar = i; cmdCount++; @@ -536,15 +563,12 @@ inputLiteral = p + 1; skip = 1; if (*inputLiteral == '\0') { inputLiteral = ((i + 1) == argc) ? NULL : argv[i + 1]; if (inputLiteral == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't specify \"%s\" as last word in command", - argv[i])); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", - "PIPESYNTAX", NULL); + Tcl_AppendResult(interp, "can't specify \"", argv[i], + "\" as last word in command", NULL); goto error; } skip = 2; } } else { @@ -629,17 +653,11 @@ atOK = 1; flags = O_WRONLY | O_CREAT | O_TRUNC; if (*p == '>') { p++; atOK = 0; - - /* - * Note that the O_APPEND flag only has an effect on POSIX - * platforms. On Windows, we just have to carry on regardless. - */ - - flags = O_WRONLY | O_CREAT | O_APPEND; + flags = O_WRONLY | O_CREAT; } if (errorClose != 0) { errorClose = 0; TclpCloseFile(errorFile); } @@ -653,15 +671,12 @@ * exec/open output pipe as well. This is meant for the end of * the command string, otherwise use |& between commands. */ if (i != argc-1) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "must specify \"%s\" as last word in command", - argv[i])); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", - "PIPESYNTAX", NULL); + Tcl_AppendResult(interp, "must specify \"", argv[i], + "\" as last word in command", NULL); goto error; } errorFile = outputFile; errorToOutput = 2; skip = 1; @@ -674,16 +689,13 @@ } } break; default: - /* - * Got a command word, not a redirection. - */ - - needCmd = 0; - break; + /* Got a command word, not a redirection */ + needCmd = 0; + break; } if (skip != 0) { for (j = i + skip; j < argc; j++) { argv[j - skip] = argv[j]; @@ -692,18 +704,15 @@ i -= 1; } } if (needCmd) { - /* - * We had a bar followed only by redirections. - */ - - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "illegal use of | or |& in command", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "PIPESYNTAX", - NULL); + /* We had a bar followed only by redirections. */ + + Tcl_SetResult(interp, + "illegal use of | or |& in command", + TCL_STATIC); goto error; } if (inputFile == NULL) { if (inputLiteral != NULL) { @@ -713,13 +722,13 @@ * file. */ inputFile = TclpCreateTempFile(inputLiteral); if (inputFile == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't create input file for command: %s", - Tcl_PosixError(interp))); + Tcl_AppendResult(interp, + "couldn't create input file for command: ", + Tcl_PosixError(interp), NULL); goto error; } inputClose = 1; } else if (inPipePtr != NULL) { /* @@ -726,13 +735,13 @@ * The input for the first process in the pipeline is to come from * a pipe that can be written from by the caller. */ if (TclpCreatePipe(&inputFile, inPipePtr) == 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't create input pipe for command: %s", - Tcl_PosixError(interp))); + Tcl_AppendResult(interp, + "couldn't create input pipe for command: ", + Tcl_PosixError(interp), NULL); goto error; } inputClose = 1; } else { /* @@ -755,13 +764,13 @@ * Output from the last process in the pipeline is to go to a pipe * that can be read by the caller. */ if (TclpCreatePipe(outPipePtr, &outputFile) == 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't create output pipe for command: %s", - Tcl_PosixError(interp))); + Tcl_AppendResult(interp, + "couldn't create output pipe for command: ", + Tcl_PosixError(interp), NULL); goto error; } outputClose = 1; } else { /* @@ -795,13 +804,13 @@ * complete because stderr was backed up. */ errorFile = TclpCreateTempFile(NULL); if (errorFile == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't create error file for command: %s", - Tcl_PosixError(interp))); + Tcl_AppendResult(interp, + "couldn't create error file for command: ", + Tcl_PosixError(interp), NULL); goto error; } *errFilePtr = errorFile; } else { /* @@ -822,18 +831,18 @@ * Scan through the argc array, creating a process for each group of * arguments between the "|" characters. */ Tcl_ReapDetachedProcs(); - pidPtr = (Tcl_Pid *)Tcl_Alloc(cmdCount * sizeof(Tcl_Pid)); + pidPtr = (Tcl_Pid *) ckalloc((unsigned) (cmdCount * sizeof(Tcl_Pid))); curInFile = inputFile; for (i = 0; i < argc; i = lastArg + 1) { int result, joinThisError; Tcl_Pid pid; - const char *oldName; + CONST char *oldName; /* * Convert the program name into native form. */ @@ -868,12 +877,12 @@ if (lastArg == argc) { curOutFile = outputFile; } else { argv[lastArg] = NULL; if (TclpCreatePipe(&pipeIn, &curOutFile) == 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't create pipe: %s", Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "couldn't create pipe: ", + Tcl_PosixError(interp), NULL); goto error; } } if (joinThisError != 0) { @@ -897,11 +906,10 @@ } Tcl_DStringFree(&execBuffer); pidPtr[numPids] = pid; numPids++; - TclProcessCreated(pid); /* * Close off our copies of file descriptors that were set up for this * child, then set up the input for the next child. */ @@ -976,11 +984,11 @@ for (i = 0; i < numPids; i++) { if (pidPtr[i] != (Tcl_Pid) -1) { Tcl_DetachPids(1, &pidPtr[i]); } } - Tcl_Free(pidPtr); + ckfree((char *) pidPtr); } numPids = -1; goto cleanup; } @@ -1017,13 +1025,13 @@ */ Tcl_Channel Tcl_OpenCommandChannel( Tcl_Interp *interp, /* Interpreter for error reporting. Can NOT be - * NULL. */ + * NULL. */ int argc, /* How many arguments. */ - const char **argv, /* Array of arguments for command pipe. */ + CONST char **argv, /* Array of arguments for command pipe. */ int flags) /* Or'ed combination of TCL_STDIN, TCL_STDOUT, * TCL_STDERR, and TCL_ENFORCE_MODE. */ { TclFile *inPipePtr, *outPipePtr, *errFilePtr; TclFile inPipe, outPipe, errFile; @@ -1036,11 +1044,11 @@ inPipePtr = (flags & TCL_STDIN) ? &inPipe : NULL; outPipePtr = (flags & TCL_STDOUT) ? &outPipe : NULL; errFilePtr = (flags & TCL_STDERR) ? &errFile : NULL; numPids = TclCreatePipeline(interp, argc, argv, &pidPtr, inPipePtr, - outPipePtr, errFilePtr); + outPipePtr, errFilePtr); if (numPids < 0) { goto error; } @@ -1049,42 +1057,35 @@ * constraints. */ if (flags & TCL_ENFORCE_MODE) { if ((flags & TCL_STDOUT) && (outPipe == NULL)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't read output from command:" - " standard output was redirected", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", - "BADREDIRECT", NULL); + Tcl_AppendResult(interp, "can't read output from command:" + " standard output was redirected", NULL); goto error; } if ((flags & TCL_STDIN) && (inPipe == NULL)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't write input to command:" - " standard input was redirected", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", - "BADREDIRECT", NULL); + Tcl_AppendResult(interp, "can't write input to command:" + " standard input was redirected", NULL); goto error; } } channel = TclpCreateCommandChannel(outPipe, inPipe, errFile, numPids, pidPtr); - if (channel == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "pipe for command could not be created", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "NOPIPE", NULL); + if (channel == (Tcl_Channel) NULL) { + Tcl_AppendResult(interp, "pipe for command could not be created", + NULL); goto error; } return channel; error: if (numPids > 0) { Tcl_DetachPids(numPids, pidPtr); - Tcl_Free(pidPtr); + ckfree((char *) pidPtr); } if (inPipe != NULL) { TclpCloseFile(inPipe); } if (outPipe != NULL) { Index: generic/tclPkg.c ================================================================== --- generic/tclPkg.c +++ generic/tclPkg.c @@ -15,14 +15,10 @@ * package requirements. */ #include "tclInt.h" -MODULE_SCOPE char *tclEmptyStringRep; - -char *tclEmptyStringRep = &tclEmptyString; - /* * Each invocation of the "package ifneeded" command creates a structure of * the following type, which is used to load the package into the interpreter * if it is requested with a "package require" command. */ @@ -30,54 +26,31 @@ typedef struct PkgAvail { char *version; /* Version string; malloc'ed. */ char *script; /* Script to invoke to provide this version of * the package. Malloc'ed and protected by * Tcl_Preserve and Tcl_Release. */ - char *pkgIndex; /* Full file name of pkgIndex file */ struct PkgAvail *nextPtr; /* Next in list of available versions of the * same package. */ } PkgAvail; -typedef struct PkgName { - struct PkgName *nextPtr; /* Next in list of package names being - * initialized. */ - char name[1]; -} PkgName; - -typedef struct PkgFiles { - PkgName *names; /* Package names being initialized. Must be - * first field. */ - Tcl_HashTable table; /* Table which contains files for each - * package. */ -} PkgFiles; - /* * 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 { - Tcl_Obj *version; +typedef struct Package { + char *version; /* Version that has been supplied in this + * interpreter via "package provide" + * (malloc'ed). NULL means the package doesn't + * exist in this interpreter yet. */ PkgAvail *availPtr; /* First in list of all available versions of * this package. */ - const void *clientData; /* Client data. */ + ClientData clientData; /* Client data. */ } Package; -typedef struct Require { - void *clientDataPtr; - const char *name; - Package *pkgPtr; - char *versionToProvide; -} Require; - -typedef struct RequireProcArgs { - const char *name; - void *clientDataPtr; -} RequireProcArgs; - /* * Prototypes for functions defined in this file: */ static int CheckVersionAndConvert(Tcl_Interp *interp, @@ -94,29 +67,23 @@ static void AddRequirementsToResult(Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]); static void AddRequirementsToDString(Tcl_DString *dstring, int reqc, Tcl_Obj *const reqv[]); static Package * FindPackage(Tcl_Interp *interp, const char *name); -static int PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result); -static int PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result); -static int PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result); -static int PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result); -static int PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result); -static int TclNRPkgRequireProc(ClientData clientData, Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]); -static int SelectPackage(ClientData data[], Tcl_Interp *interp, int result); -static int SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result); -static int TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result); +static const char * PkgRequireCore(Tcl_Interp *interp, const char *name, + int reqc, Tcl_Obj *const reqv[], + ClientData *clientDataPtr); /* * Helper macros. */ #define DupBlock(v,s,len) \ - ((v) = (char *)Tcl_Alloc(len), memcpy((v),(s),(len))) + ((v) = ckalloc(len), memcpy((v),(s),(len))) #define DupString(v,s) \ do { \ - size_t local__len = strlen(s) + 1; \ + unsigned local__len = (unsigned) (strlen(s) + 1); \ DupBlock((v),(s),local__len); \ } while (0) /* *---------------------------------------------------------------------- @@ -154,47 +121,44 @@ Tcl_PkgProvideEx( Tcl_Interp *interp, /* Interpreter in which package is now * available. */ const char *name, /* Name of package. */ const char *version, /* Version string for package. */ - const void *clientData) /* clientdata for this package (normally used + ClientData clientData) /* clientdata for this package (normally used * for C callback function table) */ { Package *pkgPtr; char *pvi, *vi; int res; pkgPtr = FindPackage(interp, name); if (pkgPtr->version == NULL) { - pkgPtr->version = Tcl_NewStringObj(version, -1); - Tcl_IncrRefCount(pkgPtr->version); + DupString(pkgPtr->version, version); pkgPtr->clientData = clientData; return TCL_OK; } - if (CheckVersionAndConvert(interp, Tcl_GetString(pkgPtr->version), &pvi, + if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi, NULL) != TCL_OK) { return TCL_ERROR; } else if (CheckVersionAndConvert(interp, version, &vi, NULL) != TCL_OK) { - Tcl_Free(pvi); + ckfree(pvi); return TCL_ERROR; } res = CompareVersions(pvi, vi, NULL); - Tcl_Free(pvi); - Tcl_Free(vi); + ckfree(pvi); + ckfree(vi); if (res == 0) { if (clientData != NULL) { pkgPtr->clientData = clientData; } return TCL_OK; } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "conflicting versions provided for package \"%s\": %s, then %s", - name, Tcl_GetString(pkgPtr->version), version)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL); + Tcl_AppendResult(interp, "conflicting versions provided for package \"", + name, "\": ", pkgPtr->version, ", then ", version, NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- @@ -221,82 +185,10 @@ * invoked to provide the package. * *---------------------------------------------------------------------- */ -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; - Tcl_Free(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); - Tcl_Free(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 *)Tcl_Alloc(sizeof(PkgFiles)); - pkgFiles->names = NULL; - Tcl_InitHashTable(&pkgFiles->table, TCL_STRING_KEYS); - Tcl_SetAssocData(interp, "tclPkgFiles", PkgFilesCleanupProc, pkgFiles); - } - return pkgFiles; -} - -void -TclPkgFileSeen( - Tcl_Interp *interp, - const char *fileName) -{ - PkgFiles *pkgFiles = (PkgFiles *) - Tcl_GetAssocData(interp, "tclPkgFiles", NULL); - - if (pkgFiles && pkgFiles->names) { - const char *name = pkgFiles->names->name; - Tcl_HashTable *table = &pkgFiles->table; - int isNew; - Tcl_HashEntry *entry = (Tcl_HashEntry *)Tcl_CreateHashEntry(table, name, &isNew); - Tcl_Obj *list; - - if (isNew) { - TclNewObj(list); - Tcl_SetHashValue(entry, list); - Tcl_IncrRefCount(list); - } else { - list = (Tcl_Obj *)Tcl_GetHashValue(entry); - } - Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(fileName, -1)); - } -} - #undef Tcl_PkgRequire const char * Tcl_PkgRequire( Tcl_Interp *interp, /* Interpreter in which package is now * available. */ @@ -318,11 +210,11 @@ const char *version, /* Version string for desired version; NULL * means use the latest version available. */ int exact, /* Non-zero means that only the particular * version given is acceptable. Zero means use * the latest compatible version. */ - void *clientDataPtr) /* Used to return the client data for this + ClientData *clientDataPtr) /* Used to return the client data for this * package. If it is NULL then the client data * is not returned. This is unchanged if this * call fails for any reason. */ { Tcl_Obj *ov; @@ -362,16 +254,16 @@ * trouble. We would like to catch that error and report a useful * message back to the user. That's what we're doing. * * Second, how does this work? If we reach this point, then the global * variable tclEmptyStringRep has the value NULL. Compare that with - * the definition of tclEmptyStringRep near the top of this file. It - * clearly should not have the value NULL; it should point to the char - * tclEmptyString. If we see it having the value NULL, then somehow we - * are seeing a Tcl library that isn't completely initialized, and - * that's an indicator for the error condition described above. - * (Further explanation is welcome.) + * the definition of tclEmptyStringRep near the top of the file + * generic/tclObj.c. It clearly should not have the value NULL; it + * should point to the char tclEmptyString. If we see it having the + * value NULL, then somehow we are seeing a Tcl library that isn't + * completely initialized, and that's an indicator for the error + * condition described above. (Further explanation is welcome.) * * Third, so what do we do about it? This situation indicates the * package we just loaded wasn't properly compiled to be stub-enabled, * yet it thinks it is stub-enabled (it called Tcl_InitStubs()). We * want to report that the package just loaded is broken, so we want @@ -379,31 +271,34 @@ * to indicate failure to Tcl_InitStubs() so that it will also fail. * (Further explanation why we don't want to Tcl_Panic() is welcome. * After all, two Tcl libraries can't be a good thing!) * * Trouble is that's going to be tricky. We're now using a Tcl library - * that's not fully initialized. Functions in it may not work - * reliably, so be very careful about adding any other calls here - * without checking how they behave when initialization is incomplete. + * that's not fully initialized. In particular, it doesn't have a + * proper value for tclEmptyStringRep. The Tcl_Obj system heavily + * depends on the value of tclEmptyStringRep and all of Tcl depends + * (increasingly) on the Tcl_Obj system, we need to correct that flaw + * before making the calls to set the interpreter result to the error + * message. That's the only flaw corrected; other problems with + * initialization of the Tcl library are not remedied, so be very + * careful about adding any other calls here without checking how they + * behave when initialization is incomplete. */ - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "Cannot load package \"%s\" in standalone executable:" - " This package is not compiled with stub support", name)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNSTUBBED", NULL); + tclEmptyStringRep = &tclEmptyString; + Tcl_AppendResult(interp, "Cannot load package \"", name, + "\" in standalone executable: This package is not " + "compiled with stub support", NULL); return NULL; } /* * Translate between old and new API, and defer to the new function. */ if (version == NULL) { - if (Tcl_PkgRequireProc(interp, name, 0, NULL, clientDataPtr) == TCL_OK) { - result = Tcl_GetString(Tcl_GetObjResult(interp)); - Tcl_ResetResult(interp); - } + result = PkgRequireCore(interp, name, 0, NULL, clientDataPtr); } else { if (exact && TCL_OK != CheckVersionAndConvert(interp, version, NULL, NULL)) { return NULL; } @@ -410,16 +305,14 @@ ov = Tcl_NewStringObj(version, -1); if (exact) { Tcl_AppendStringsToObj(ov, "-", version, NULL); } Tcl_IncrRefCount(ov); - if (Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr) == TCL_OK) { - result = Tcl_GetString(Tcl_GetObjResult(interp)); - Tcl_ResetResult(interp); - } + result = PkgRequireCore(interp, name, 1, &ov, clientDataPtr); TclDecrRefCount(ov); } + return result; } int Tcl_PkgRequireProc( @@ -428,526 +321,350 @@ const char *name, /* Name of desired package. */ int reqc, /* Requirements constraining the desired * version. */ Tcl_Obj *const reqv[], /* 0 means to use the latest version * available. */ - void *clientDataPtr) -{ - RequireProcArgs args; - - args.name = name; - args.clientDataPtr = clientDataPtr; - return Tcl_NRCallObjProc(interp, - TclNRPkgRequireProc, (void *) &args, reqc, reqv); -} - -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 *)Tcl_Alloc(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. - */ - - if (reqPtr->pkgPtr->version != NULL) { - Tcl_NRAddCallback(interp, - PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); - return TCL_OK; - } - - /* - * The package is not in the database. If there is a "package unknown" - * command, invoke it. - */ - - script = ((Interp *) interp)->packageUnknown; - if (script == NULL) { - /* - * No package unknown script. Move on to finalizing. - */ - - Tcl_NRAddCallback(interp, - PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); - return TCL_OK; - } - - /* - * Invoke the "package unknown" script synchronously. - */ - - Tcl_DStringInit(&command); - Tcl_DStringAppend(&command, script, -1); - Tcl_DStringAppendElement(&command, name); - AddRequirementsToDString(&command, reqc, reqv); - - Tcl_NRAddCallback(interp, - PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *) reqv, NULL); - Tcl_NREvalObj(interp, - Tcl_NewStringObj(Tcl_DStringValue(&command), - Tcl_DStringLength(&command)), - TCL_EVAL_GLOBAL); - Tcl_DStringFree(&command); - return TCL_OK; -} - -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; - } - if (result == TCL_ERROR) { - Tcl_AddErrorInfo(interp, - "\n (\"package unknown\" script)"); - return result; - } - Tcl_ResetResult(interp); - - /* - * 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)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL); - AddRequirementsToResult(interp, reqc, reqv); - return TCL_ERROR; - } - - /* - * Ensure that the provided version meets the current requirements. - */ - - if (reqc != 0) { - CheckVersionAndConvert(interp, Tcl_GetString(reqPtr->pkgPtr->version), - &pkgVersionI, NULL); - satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); - - Tcl_Free(pkgVersionI); - - if (!satisfies) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "version conflict for package \"%s\": have %s, need", - name, Tcl_GetString(reqPtr->pkgPtr->version))); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", - NULL); - AddRequirementsToResult(interp, reqc, reqv); - return TCL_ERROR; - } - } - - if (clientDataPtr) { - const void **ptr = (const void **) clientDataPtr; - - *ptr = reqPtr->pkgPtr->clientData; - } - Tcl_SetObjResult(interp, reqPtr->pkgPtr->version); - return TCL_OK; -} - -static int -PkgRequireCoreCleanup( - ClientData data[], - TCL_UNUSED(Tcl_Interp *), - int result) -{ - Tcl_Free(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). - */ - - if (pkgPtr->clientData != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "circular package dependency:" - " attempt to provide %s %s requires %s", - name, (char *) pkgPtr->clientData, name)); - AddRequirementsToResult(interp, reqc, reqv); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL); - return TCL_ERROR; - } - - /* - * The package isn't yet present. Search the list of available versions - * and invoke the script for the best available version. We are actually - * locating the best, and the best stable version. One of them is then - * chosen based on the selection mode. - */ - - bestPtr = NULL; - bestStablePtr = NULL; - bestVersion = NULL; - bestStableVersion = NULL; - - for (availPtr = pkgPtr->availPtr; availPtr != NULL; - availPtr = availPtr->nextPtr) { - if (CheckVersionAndConvert(interp, availPtr->version, - &availVersion, &availStable) != TCL_OK) { - /* - * The provided version number has invalid syntax. This should not - * happen. This should have been caught by the 'package ifneeded' - * registering the package. - */ - - continue; - } - - /* - * Check satisfaction of requirements before considering the current - * version further. - */ - - if (reqc > 0) { - satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); - if (!satisfies) { - Tcl_Free(availVersion); - availVersion = NULL; - continue; - } + ClientData *clientDataPtr) +{ + const char *result = + PkgRequireCore(interp, name, reqc, reqv, clientDataPtr); + + if (result == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1)); + return TCL_OK; +} + +static const char * +PkgRequireCore( + Tcl_Interp *interp, /* Interpreter in which package is now + * available. */ + const char *name, /* Name of desired package. */ + int reqc, /* Requirements constraining the desired + * version. */ + Tcl_Obj *const reqv[], /* 0 means to use the latest version + * available. */ + ClientData *clientDataPtr) +{ + Interp *iPtr = (Interp *) interp; + Package *pkgPtr; + PkgAvail *availPtr, *bestPtr, *bestStablePtr; + char *availVersion, *bestVersion, *bestStableVersion; + /* Internal rep. of versions */ + int availStable, code, satisfies, pass; + char *script, *pkgVersionI; + Tcl_DString command; + + if (TCL_OK != CheckAllRequirements(interp, reqc, reqv)) { + return NULL; + } + + /* + * It can take up to three passes to find the package: one pass to run the + * "package unknown" script, one to run the "package ifneeded" script for + * a specific version, and a final pass to lookup the package loaded by + * the "package ifneeded" script. + */ + + for (pass=1 ;; pass++) { + pkgPtr = FindPackage(interp, name); + if (pkgPtr->version != NULL) { + break; + } + + /* + * Check whether we're already attempting to load some version of this + * package (circular dependency detection). + */ + + if (pkgPtr->clientData != NULL) { + Tcl_AppendResult(interp, "circular package dependency: " + "attempt to provide ", name, " ", + (char *) pkgPtr->clientData, " requires ", name, NULL); + AddRequirementsToResult(interp, reqc, reqv); + return NULL; + } + + /* + * The package isn't yet present. Search the list of available + * versions and invoke the script for the best available version. We + * are actually locating the best, and the best stable version. One of + * them is then chosen based on the selection mode. + */ + + bestPtr = NULL; + bestStablePtr = NULL; + bestVersion = NULL; + bestStableVersion = NULL; + + for (availPtr = pkgPtr->availPtr; availPtr != NULL; + availPtr = availPtr->nextPtr) { + if (CheckVersionAndConvert(interp, availPtr->version, + &availVersion, &availStable) != TCL_OK) { + /* + * The provided version number has invalid syntax. This + * should not happen. This should have been caught by the + * 'package ifneeded' registering the package. + */ + + continue; + } + + /* 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) { - 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. - */ - - Tcl_Free(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) { - Tcl_Free(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. - */ - - Tcl_Free(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); - } - - Tcl_Free(availVersion); - availVersion = NULL; - } /* end for */ - - /* - * Clean up memorized internal reps, if any. - */ - - if (bestVersion != NULL) { - Tcl_Free(bestVersion); - bestVersion = NULL; - } - - if (bestStableVersion != NULL) { - Tcl_Free(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 *)Tcl_Alloc(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; - Tcl_NRAddCallback(interp, - SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv, - data[3]); - Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1), - TCL_EVAL_GLOBAL); - } - return TCL_OK; -} - -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; - Tcl_Free(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) { - Tcl_Free(pvi); - result = TCL_ERROR; - } else { - int res = CompareVersions(pvi, vi, NULL); - - Tcl_Free(pvi); - Tcl_Free(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))); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", - "WRONGPROVIDE", NULL); - } - } - } - } else if (result != TCL_ERROR) { - Tcl_Obj *codePtr; - - TclNewIntObj(codePtr, result); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "attempt to provide package %s %s failed:" - " bad return code: %s", - name, versionToProvide, TclGetString(codePtr))); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); - TclDecrRefCount(codePtr); - result = TCL_ERROR; - } - - if (result == TCL_ERROR) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"package ifneeded %s %s\" script)", - name, versionToProvide)); - } - Tcl_Release(versionToProvide); - - if (result != TCL_OK) { - /* - * Take a non-TCL_OK code from the script as an indication the package - * wasn't loaded properly, so the package system should not remember - * an improper load. - * - * This is consistent with our returning NULL. If we're not willing to - * tell our caller we got a particular version, we shouldn't store - * that version for telling future callers either. - */ - - if (reqPtr->pkgPtr->version != NULL) { - Tcl_DecrRefCount(reqPtr->pkgPtr->version); - 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; + /* + * 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. + */ + + const char *versionToProvide = bestPtr->version; + script = bestPtr->script; + + pkgPtr->clientData = (ClientData) versionToProvide; + Tcl_Preserve((ClientData) script); + Tcl_Preserve((ClientData) versionToProvide); + code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL); + Tcl_Release((ClientData) script); + + pkgPtr = FindPackage(interp, name); + if (code == TCL_OK) { + Tcl_ResetResult(interp); + if (pkgPtr->version == NULL) { + code = TCL_ERROR; + Tcl_AppendResult(interp, "attempt to provide package ", + name, " ", versionToProvide, + " failed: no version of package ", name, + " provided", NULL); + } else { + char *pvi, *vi; + + if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi, + NULL) != TCL_OK) { + code = TCL_ERROR; + } else if (CheckVersionAndConvert(interp, + versionToProvide, &vi, NULL) != TCL_OK) { + ckfree(pvi); + code = TCL_ERROR; + } else { + int res = CompareVersions(pvi, vi, NULL); + + ckfree(pvi); + ckfree(vi); + if (res != 0) { + code = TCL_ERROR; + Tcl_AppendResult(interp, + "attempt to provide package ", name, " ", + versionToProvide, " failed: package ", + name, " ", pkgPtr->version, + " provided instead", NULL); + } + } + } + } else if (code != TCL_ERROR) { + Tcl_Obj *codePtr = Tcl_NewIntObj(code); + + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "attempt to provide package ", name, + " ", versionToProvide, " failed: bad return code: ", + TclGetString(codePtr), NULL); + TclDecrRefCount(codePtr); + code = TCL_ERROR; + } + + if (code == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"package ifneeded %s %s\" script)", + name, versionToProvide)); + } + Tcl_Release((ClientData) versionToProvide); + + if (code != TCL_OK) { + /* + * Take a non-TCL_OK code from the script as an indication the + * package wasn't loaded properly, so the package system + * should not remember an improper load. + * + * This is consistent with our returning NULL. If we're not + * willing to tell our caller we got a particular version, we + * shouldn't store that version for telling future callers + * either. + */ + + if (pkgPtr->version != NULL) { + ckfree(pkgPtr->version); + pkgPtr->version = NULL; + } + pkgPtr->clientData = NULL; + return NULL; + } + + break; + } + + /* + * The package is not in the database. If there is a "package unknown" + * command, invoke it (but only on the first pass; after that, we + * should not get here in the first place). + */ + + if (pass > 1) { + break; + } + + script = ((Interp *) interp)->packageUnknown; + if (script != NULL) { + Tcl_DStringInit(&command); + Tcl_DStringAppend(&command, script, -1); + Tcl_DStringAppendElement(&command, name); + AddRequirementsToDString(&command, reqc, reqv); + + code = Tcl_EvalEx(interp, Tcl_DStringValue(&command), + Tcl_DStringLength(&command), TCL_EVAL_GLOBAL); + Tcl_DStringFree(&command); + + if ((code != TCL_OK) && (code != TCL_ERROR)) { + Tcl_Obj *codePtr = Tcl_NewIntObj(code); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad return code: ", + TclGetString(codePtr), NULL); + Tcl_DecrRefCount(codePtr); + code = TCL_ERROR; + } + if (code == TCL_ERROR) { + Tcl_AddErrorInfo(interp, + "\n (\"package unknown\" script)"); + return NULL; + } + Tcl_ResetResult(interp); + } + } + + if (pkgPtr->version == NULL) { + Tcl_AppendResult(interp, "can't find package ", name, NULL); + AddRequirementsToResult(interp, reqc, reqv); + return NULL; + } + + /* + * At this point we know that the package is present. Make sure that the + * provided version meets the current requirements. + */ + + if (reqc == 0) { + satisfies = 1; + } else { + CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL); + satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); + + ckfree(pkgVersionI); + } + + if (satisfies) { + if (clientDataPtr) { + *clientDataPtr = pkgPtr->clientData; + } + return pkgPtr->version; + } + + Tcl_AppendResult(interp, "version conflict for package \"", name, + "\": have ", pkgPtr->version, ", need", NULL); + AddRequirementsToResult(interp, reqc, reqv); + return NULL; } /* *---------------------------------------------------------------------- * @@ -992,11 +709,11 @@ const char *version, /* Version string for desired version; NULL * means use the latest version available. */ int exact, /* Non-zero means that only the particular * version given is acceptable. Zero means use * the latest compatible version. */ - void *clientDataPtr) /* Used to return the client data for this + ClientData *clientDataPtr) /* Used to return the client data for this * package. If it is NULL then the client data * is not returned. This is unchanged if this * call fails for any reason. */ { Interp *iPtr = (Interp *) interp; @@ -1003,11 +720,11 @@ Tcl_HashEntry *hPtr; Package *pkgPtr; hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name); if (hPtr) { - pkgPtr = (Package *)Tcl_GetHashValue(hPtr); + pkgPtr = 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. @@ -1023,15 +740,14 @@ return foundVersion; } } if (version != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "package %s %s is not present", name, version)); + Tcl_AppendResult(interp, "package ", name, " ", version, + " is not present", NULL); } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "package %s is not present", name)); + Tcl_AppendResult(interp, "package ", name, " is not present", NULL); } Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, NULL); return NULL; } @@ -1049,120 +765,76 @@ * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ -int -Tcl_PackageObjCmd( - ClientData clientData, - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - return Tcl_NRCallObjProc(interp, TclNRPackageObjCmd, clientData, objc, objv); -} - -int -TclNRPackageObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - static const char *const pkgOptions[] = { - "files", "forget", "ifneeded", "names", "prefer", - "present", "provide", "require", "unknown", "vcompare", - "versions", "vsatisfies", NULL - }; - enum pkgOptionsEnum { - PKG_FILES, PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER, - PKG_PRESENT, PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, - PKG_VERSIONS, PKG_VSATISFIES - }; - Interp *iPtr = (Interp *) interp; - int optionIndex, exact, i, newobjc, satisfies; + + /* ARGSUSED */ +int +Tcl_PackageObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + static const char *pkgOptions[] = { + "forget", "ifneeded", "names", "prefer", "present", + "provide", "require", "unknown", "vcompare", "versions", + "vsatisfies", NULL + }; + enum pkgOptions { + PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER, PKG_PRESENT, + PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, PKG_VERSIONS, + PKG_VSATISFIES + }; + Interp *iPtr = (Interp *) interp; + int optionIndex, exact, i, satisfies; PkgAvail *availPtr, *prevPtr; Package *pkgPtr; Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_HashTable *tablePtr; const char *version; - const char *argv2, *argv3, *argv4; - char *iva = NULL, *ivb = NULL; - Tcl_Obj *objvListPtr, **newObjvPtr; + char *argv2, *argv3, *argv4, *iva = NULL, *ivb = NULL; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], pkgOptions, "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } - switch ((enum pkgOptionsEnum) optionIndex) { - case PKG_FILES: { - PkgFiles *pkgFiles; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "package"); - return TCL_ERROR; - } - pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL); - if (pkgFiles) { - Tcl_HashEntry *entry = Tcl_FindHashEntry(&pkgFiles->table, - TclGetString(objv[2])); - - if (entry) { - Tcl_SetObjResult(interp, (Tcl_Obj *)Tcl_GetHashValue(entry)); - } - } - break; - } + switch ((enum pkgOptions) optionIndex) { case PKG_FORGET: { - const char *keyString; - PkgFiles *pkgFiles = (PkgFiles *) - Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + char *keyString; 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); + pkgPtr = Tcl_GetHashValue(hPtr); Tcl_DeleteHashEntry(hPtr); if (pkgPtr->version != NULL) { - Tcl_DecrRefCount(pkgPtr->version); + ckfree(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; - } - Tcl_Free(availPtr); - } - Tcl_Free(pkgPtr); + Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC); + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); + ckfree((char *) availPtr); + } + ckfree((char *) pkgPtr); } break; } case PKG_IFNEEDED: { - size_t length; - int res; + int length, res; char *argv3i, *avi; if ((objc != 4) && (objc != 5)) { Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?"); return TCL_ERROR; @@ -1173,94 +845,77 @@ } argv2 = TclGetString(objv[2]); if (objc == 4) { hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); if (hPtr == NULL) { - Tcl_Free(argv3i); + ckfree(argv3i); return TCL_OK; } - pkgPtr = (Package *)Tcl_GetHashValue(hPtr); + pkgPtr = Tcl_GetHashValue(hPtr); } else { pkgPtr = FindPackage(interp, argv2); } - argv3 = TclGetStringFromObj(objv[3], &length); + argv3 = Tcl_GetStringFromObj(objv[3], &length); for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL; prevPtr = availPtr, availPtr = availPtr->nextPtr) { if (CheckVersionAndConvert(interp, availPtr->version, &avi, NULL) != TCL_OK) { - Tcl_Free(argv3i); + ckfree(argv3i); return TCL_ERROR; } res = CompareVersions(avi, argv3i, NULL); - Tcl_Free(avi); + ckfree(avi); - if (res == 0) { + if (res == 0){ if (objc == 4) { - Tcl_Free(argv3i); - Tcl_SetObjResult(interp, - Tcl_NewStringObj(availPtr->script, -1)); + ckfree(argv3i); + Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE); return TCL_OK; } - Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); - if (availPtr->pkgIndex) { - Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); - availPtr->pkgIndex = NULL; - } + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); break; } } - Tcl_Free(argv3i); + ckfree(argv3i); if (objc == 4) { return TCL_OK; } if (availPtr == NULL) { - availPtr = (PkgAvail *)Tcl_Alloc(sizeof(PkgAvail)); - availPtr->pkgIndex = NULL; - DupBlock(availPtr->version, argv3, length + 1); + availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail)); + DupBlock(availPtr->version, argv3, (unsigned) length + 1); if (prevPtr == NULL) { availPtr->nextPtr = pkgPtr->availPtr; pkgPtr->availPtr = availPtr; } else { availPtr->nextPtr = prevPtr->nextPtr; prevPtr->nextPtr = availPtr; } } - if (iPtr->scriptFile) { - argv4 = TclGetStringFromObj(iPtr->scriptFile, &length); - DupBlock(availPtr->pkgIndex, argv4, length + 1); - } - argv4 = TclGetStringFromObj(objv[4], &length); - DupBlock(availPtr->script, argv4, length + 1); + argv4 = Tcl_GetStringFromObj(objv[4], &length); + DupBlock(availPtr->script, argv4, (unsigned) length + 1); break; } case PKG_NAMES: if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; - } else { - Tcl_Obj *resultObj; - - TclNewObj(resultObj); - tablePtr = &iPtr->packageTable; - for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { - pkgPtr = (Package *)Tcl_GetHashValue(hPtr); - if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { - Tcl_ListObjAppendElement(NULL,resultObj, Tcl_NewStringObj( - (char *)Tcl_GetHashKey(tablePtr, hPtr), -1)); - } - } - Tcl_SetObjResult(interp, resultObj); + } + tablePtr = &iPtr->packageTable; + for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + pkgPtr = Tcl_GetHashValue(hPtr); + if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { + Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr)); + } } break; case PKG_PRESENT: { const char *name; - if (objc < 3) { goto require; } argv2 = TclGetString(objv[2]); if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { @@ -1274,11 +929,11 @@ name = argv2; } hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name); if (hPtr != NULL) { - pkgPtr = (Package *)Tcl_GetHashValue(hPtr); + pkgPtr = Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { goto require; } } @@ -1309,13 +964,13 @@ } argv2 = TclGetString(objv[2]); if (objc == 3) { hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); if (hPtr != NULL) { - pkgPtr = (Package *)Tcl_GetHashValue(hPtr); + pkgPtr = Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { - Tcl_SetObjResult(interp, pkgPtr->version); + Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE); } } return TCL_OK; } argv3 = TclGetString(objv[3]); @@ -1326,19 +981,20 @@ case PKG_REQUIRE: require: if (objc < 3) { requireSyntax: Tcl_WrongNumArgs(interp, 2, objv, - "?-exact? package ?requirement ...?"); + "?-exact? package ?requirement...?"); return TCL_ERROR; } version = NULL; argv2 = TclGetString(objv[2]); if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { Tcl_Obj *ov; + int res; if (objc != 5) { goto requireSyntax; } @@ -1354,77 +1010,48 @@ ov = Tcl_NewStringObj(version, -1); Tcl_AppendStringsToObj(ov, "-", version, NULL); version = NULL; argv3 = TclGetString(objv[3]); - Tcl_IncrRefCount(objv[3]); - - objvListPtr = Tcl_NewListObj(0, NULL); - Tcl_IncrRefCount(objvListPtr); - Tcl_ListObjAppendElement(interp, objvListPtr, ov); - Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); - - Tcl_NRAddCallback(interp, - TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL,NULL); - Tcl_NRAddCallback(interp, - PkgRequireCore, (void *) argv3, INT2PTR(newobjc), - newObjvPtr, NULL); - return TCL_OK; - } else { - Tcl_Obj *const *newobjv = objv + 3; - - newobjc = objc - 3; + + Tcl_IncrRefCount(ov); + res = Tcl_PkgRequireProc(interp, argv3, 1, &ov, NULL); + TclDecrRefCount(ov); + return res; + } else { if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) { return TCL_ERROR; } - objvListPtr = Tcl_NewListObj(0, NULL); - Tcl_IncrRefCount(objvListPtr); - Tcl_IncrRefCount(objv[2]); - for (i = 0; i < newobjc; i++) { - /* - * Tcl_Obj structures may have come from another interpreter, - * so duplicate them. - */ - - Tcl_ListObjAppendElement(interp, objvListPtr, - Tcl_DuplicateObj(newobjv[i])); - } - Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); - Tcl_NRAddCallback(interp, - TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL,NULL); - Tcl_NRAddCallback(interp, - PkgRequireCore, (void *) argv2, INT2PTR(newobjc), - newObjvPtr, NULL); - return TCL_OK; + + return Tcl_PkgRequireProc(interp, argv2, objc-3, objv+3, NULL); } break; case PKG_UNKNOWN: { - size_t length; + int length; if (objc == 2) { if (iPtr->packageUnknown != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj(iPtr->packageUnknown, -1)); + Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE); } } else if (objc == 3) { if (iPtr->packageUnknown != NULL) { - Tcl_Free(iPtr->packageUnknown); + ckfree(iPtr->packageUnknown); } - argv2 = TclGetStringFromObj(objv[2], &length); + argv2 = Tcl_GetStringFromObj(objv[2], &length); if (argv2[0] == 0) { iPtr->packageUnknown = NULL; } else { - DupBlock(iPtr->packageUnknown, argv2, length+1); + DupBlock(iPtr->packageUnknown, argv2, (unsigned) length+1); } } else { Tcl_WrongNumArgs(interp, 2, objv, "?command?"); return TCL_ERROR; } break; } case PKG_PREFER: { - static const char *const pkgPreferOptions[] = { + static const char *pkgPreferOptions[] = { "latest", "stable", NULL }; /* * See tclInt.h for the enum, just before Interp. @@ -1466,11 +1093,11 @@ 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) { - Tcl_Free(iva); + ckfree(iva); } /* * ivb cannot be set in this branch. */ @@ -1481,73 +1108,57 @@ /* * Comparison is done on the internal representation. */ Tcl_SetObjResult(interp, - Tcl_NewWideIntObj(CompareVersions(iva, ivb, NULL))); - Tcl_Free(iva); - Tcl_Free(ivb); + 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; - - TclNewObj(resultObj); - argv2 = TclGetString(objv[2]); - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); - if (hPtr != NULL) { - pkgPtr = (Package *)Tcl_GetHashValue(hPtr); - for (availPtr = pkgPtr->availPtr; availPtr != NULL; - availPtr = availPtr->nextPtr) { - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewStringObj(availPtr->version, -1)); - } - } - Tcl_SetObjResult(interp, resultObj); + } + argv2 = TclGetString(objv[2]); + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); + if (hPtr != NULL) { + pkgPtr = Tcl_GetHashValue(hPtr); + for (availPtr = pkgPtr->availPtr; availPtr != NULL; + availPtr = availPtr->nextPtr) { + Tcl_AppendElement(interp, availPtr->version); + } } break; case PKG_VSATISFIES: { char *argv2i = NULL; if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "version ?requirement ...?"); + Tcl_WrongNumArgs(interp, 2, objv, + "version requirement requirement..."); 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) { - Tcl_Free(argv2i); + ckfree(argv2i); return TCL_ERROR; } satisfies = SomeRequirementSatisfied(argv2i, objc-3, objv+3); - Tcl_Free(argv2i); + 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; -} /* *---------------------------------------------------------------------- * * FindPackage -- @@ -1575,17 +1186,17 @@ int isNew; Package *pkgPtr; hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &isNew); if (isNew) { - pkgPtr = (Package *)Tcl_Alloc(sizeof(Package)); + pkgPtr = (Package *) ckalloc(sizeof(Package)); pkgPtr->version = NULL; pkgPtr->availPtr = NULL; pkgPtr->clientData = NULL; Tcl_SetHashValue(hPtr, pkgPtr); } else { - pkgPtr = (Package *)Tcl_GetHashValue(hPtr); + pkgPtr = Tcl_GetHashValue(hPtr); } return pkgPtr; } /* @@ -1605,39 +1216,35 @@ *---------------------------------------------------------------------- */ void TclFreePackageInfo( - Interp *iPtr) /* Interpreter that is being deleted. */ + Interp *iPtr) /* Interpereter that is being deleted. */ { 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); + pkgPtr = Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { - Tcl_DecrRefCount(pkgPtr->version); + ckfree(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; - } - Tcl_Free(availPtr); - } - Tcl_Free(pkgPtr); + Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC); + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); + ckfree((char *) availPtr); + } + ckfree((char *) pkgPtr); } Tcl_DeleteHashTable(&iPtr->packageTable); if (iPtr->packageUnknown != NULL) { - Tcl_Free(iPtr->packageUnknown); + ckfree(iPtr->packageUnknown); } } /* *---------------------------------------------------------------------- @@ -1673,11 +1280,11 @@ 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 *)Tcl_Alloc(4 + 4*strlen(string)); + char *ibuf = ckalloc(4 + 4*strlen(string)); char *ip = ibuf; /* * Basic rules * (1) First character has to be a digit. @@ -1741,23 +1348,22 @@ if (prevChar!='.' && prevChar!='a' && prevChar!='b') { *ip = '\0'; if (internal != NULL) { *internal = ibuf; } else { - Tcl_Free(ibuf); + ckfree(ibuf); } if (stable != NULL) { *stable = !hasunstable; } return TCL_OK; } error: - Tcl_Free(ibuf); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "expected version number but got \"%s\"", string)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", NULL); + ckfree(ibuf); + Tcl_AppendResult(interp, "expected version number but got \"", string, + "\"", NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- @@ -2000,11 +1606,11 @@ * = version- */ char *dash = NULL, *buf; - dash = (char *)strchr(string, '-'); + dash = strchr(string, '-'); if (dash == NULL) { /* * No dash found, has to be a simple version. */ @@ -2014,21 +1620,20 @@ if (strchr(dash+1, '-') != NULL) { /* * More dashes found after the first. This is wrong. */ - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "expected versionMin-versionMax but got \"%s\"", string)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSIONRANGE", NULL); + Tcl_AppendResult(interp, "expected versionMin-versionMax but got \"", + string, "\"", NULL); return TCL_ERROR; } /* * Exactly one dash is present. Copy the string, split at the location of * dash and check that both parts are versions. Note that the max part can * be empty. Also note that the string allocated with strdup() must be - * freed with free() and not Tcl_Free(). + * freed with free() and not ckfree(). */ DupString(buf, string); dash = buf + (dash - string); *dash = '\0'; /* buf now <=> min part */ @@ -2035,15 +1640,15 @@ dash++; /* dash now <=> max part */ if ((CheckVersionAndConvert(interp, buf, NULL, NULL) != TCL_OK) || ((*dash != '\0') && (CheckVersionAndConvert(interp, dash, NULL, NULL) != TCL_OK))) { - Tcl_Free(buf); + ckfree(buf); return TCL_ERROR; } - Tcl_Free(buf); + ckfree(buf); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -2067,22 +1672,23 @@ 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; - size_t length; - - for (i = 0; i < reqc; i++) { - const char *v = TclGetStringFromObj(reqv[i], &length); - - if ((length & 0x1) && (v[length/2] == '-') - && (strncmp(v, v+((length+1)/2), length/2) == 0)) { - Tcl_AppendPrintfToObj(result, " exactly %s", v+((length+1)/2)); - } else { - Tcl_AppendPrintfToObj(result, " %s", v); + if (reqc > 0) { + int i; + + for (i = 0; i < reqc; i++) { + int length; + char *v = Tcl_GetStringFromObj(reqv[i], &length); + + if ((length & 0x1) && (v[length/2] == '-') + && (strncmp(v, v+((length+1)/2), length/2) == 0)) { + Tcl_AppendResult(interp, " exactly ", v+((length+1)/2), NULL); + } else { + Tcl_AppendResult(interp, " ", v, NULL); + } } } } /* @@ -2107,19 +1713,19 @@ int reqc, /* Requirements constraining the desired * version. */ Tcl_Obj *const reqv[]) /* 0 means to use the latest version * available. */ { - int i; - if (reqc > 0) { + int i; + for (i = 0; i < reqc; i++) { - TclDStringAppendLiteral(dsPtr, " "); - TclDStringAppendObj(dsPtr, reqv[i]); + Tcl_DStringAppend(dsPtr, " ", 1); + Tcl_DStringAppend(dsPtr, TclGetString(reqv[i]), -1); } } else { - TclDStringAppendLiteral(dsPtr, " 0-"); + Tcl_DStringAppend(dsPtr, " 0-", -1); } } /* *---------------------------------------------------------------------- @@ -2189,11 +1795,11 @@ */ int satisfied, res; char *dash = NULL, *buf, *min, *max; - dash = (char *)strchr(req, '-'); + dash = 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 @@ -2205,11 +1811,11 @@ CheckVersionAndConvert(NULL, req, &reqi, NULL); strcat(reqi, " -2"); res = CompareVersions(havei, reqi, &thisIsMajor); satisfied = (res == 0) || ((res == 1) && !thisIsMajor); - Tcl_Free(reqi); + ckfree(reqi); return satisfied; } /* * Exactly one dash is present (Assumption of valid syntax). Copy the req, @@ -2229,12 +1835,12 @@ */ CheckVersionAndConvert(NULL, buf, &min, NULL); strcat(min, " -2"); satisfied = (CompareVersions(havei, min, NULL) >= 0); - Tcl_Free(min); - Tcl_Free(buf); + ckfree(min); + ckfree(buf); return satisfied; } /* * We have both min and max, and generate their internal reps. When @@ -2252,13 +1858,13 @@ strcat(max, " -2"); satisfied = ((CompareVersions(min, havei, NULL) <= 0) && (CompareVersions(havei, max, NULL) < 0)); } - Tcl_Free(min); - Tcl_Free(max); - Tcl_Free(buf); + ckfree(min); + ckfree(max); + ckfree(buf); return satisfied; } /* *---------------------------------------------------------------------- @@ -2283,27 +1889,27 @@ Tcl_PkgInitStubsCheck( Tcl_Interp *interp, const char * version, int exact) { - const char *actualVersion = Tcl_PkgPresentEx(interp, "Tcl", version, 0, NULL); + const char *actualVersion = Tcl_PkgPresent(interp, "Tcl", version, 0); - if ((exact&1) && actualVersion) { + if (exact && 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_PkgPresentEx(interp, "Tcl", version, 1, NULL); + Tcl_PkgPresent(interp, "Tcl", version, 1); return NULL; } } else { - return Tcl_PkgPresentEx(interp, "Tcl", version, 1, NULL); + return Tcl_PkgPresent(interp, "Tcl", version, 1); } } return actualVersion; } /* Index: generic/tclPkgConfig.c ================================================================== --- generic/tclPkgConfig.c +++ generic/tclPkgConfig.c @@ -33,20 +33,16 @@ * configuration values. */ #include "tclInt.h" -#ifndef TCL_CFGVAL_ENCODING -# define TCL_CFGVAL_ENCODING "utf-8" -#endif - /* * Use C preprocessor statements to define the various values for the embedded * configuration information. */ -#if TCL_THREADS +#ifdef TCL_THREADS # define CFG_THREADED "1" #else # define CFG_THREADED "0" #endif @@ -90,11 +86,11 @@ # define CFG_PROFILED "1" #else # define CFG_PROFILED "0" #endif -static Tcl_Config const cfg[] = { +static Tcl_Config cfg[] = { {"debug", CFG_DEBUG}, {"threaded", CFG_THREADED}, {"profiled", CFG_PROFILED}, {"64bit", CFG_64}, {"optimized", CFG_OPTIMIZED}, @@ -107,12 +103,10 @@ {"libdir,runtime", CFG_RUNTIME_LIBDIR}, {"bindir,runtime", CFG_RUNTIME_BINDIR}, {"scriptdir,runtime", CFG_RUNTIME_SCRDIR}, {"includedir,runtime", CFG_RUNTIME_INCDIR}, {"docdir,runtime", CFG_RUNTIME_DOCDIR}, - {"dllfile,runtime", CFG_RUNTIME_DLLFILE}, - {"zipfile,runtime", CFG_RUNTIME_ZIPFILE}, /* Installation paths to various stuff */ {"libdir,install", CFG_INSTALL_LIBDIR}, {"bindir,install", CFG_INSTALL_BINDIR}, @@ -124,11 +118,11 @@ {NULL, NULL} }; void TclInitEmbeddedConfigurationInformation( - Tcl_Interp *interp) /* Interpreter the configuration command is + Tcl_Interp* interp) /* Interpreter the configuration command is * registered in. */ { Tcl_RegisterConfig(interp, "tcl", cfg, TCL_CFGVAL_ENCODING); } Index: generic/tclPlatDecls.h ================================================================== --- generic/tclPlatDecls.h +++ generic/tclPlatDecls.h @@ -19,16 +19,10 @@ # 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/tcl.decls script. - */ - /* * TCHAR is needed here for win32, so if it is not defined yet do it here. * This way, we don't need to include just for one define. */ #if (defined(_WIN32) || defined(__CYGWIN__)) && !defined(_TCHAR_DEFINED) @@ -48,63 +42,118 @@ /* * Exported function declarations: */ +#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#ifndef Tcl_WinUtfToTChar_TCL_DECLARED +#define Tcl_WinUtfToTChar_TCL_DECLARED +/* 0 */ +EXTERN TCHAR * Tcl_WinUtfToTChar(CONST char *str, int len, + Tcl_DString *dsPtr); +#endif +#ifndef Tcl_WinTCharToUtf_TCL_DECLARED +#define Tcl_WinTCharToUtf_TCL_DECLARED +/* 1 */ +EXTERN char * Tcl_WinTCharToUtf(CONST TCHAR *str, int len, + Tcl_DString *dsPtr); +#endif +/* Slot 2 is reserved */ +#ifndef TclUnusedStubEntry_TCL_DECLARED +#define TclUnusedStubEntry_TCL_DECLARED +/* 3 */ +EXTERN void TclUnusedStubEntry(void); +#endif +#endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ -/* Slot 0 is reserved */ +#ifndef Tcl_MacOSXOpenBundleResources_TCL_DECLARED +#define Tcl_MacOSXOpenBundleResources_TCL_DECLARED +/* 0 */ +EXTERN int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp, + CONST char *bundleName, int hasResourceFile, + int maxPathLen, char *libraryPath); +#endif +#ifndef Tcl_MacOSXOpenVersionedBundleResources_TCL_DECLARED +#define Tcl_MacOSXOpenVersionedBundleResources_TCL_DECLARED /* 1 */ EXTERN int Tcl_MacOSXOpenVersionedBundleResources( - Tcl_Interp *interp, const char *bundleName, - const char *bundleVersion, - int hasResourceFile, size_t maxPathLen, + Tcl_Interp *interp, CONST char *bundleName, + CONST char *bundleVersion, + int hasResourceFile, int maxPathLen, char *libraryPath); +#endif +#ifndef TclUnusedStubEntry_TCL_DECLARED +#define TclUnusedStubEntry_TCL_DECLARED +/* 2 */ +EXTERN void TclUnusedStubEntry(void); +#endif #endif /* MACOSX */ typedef struct TclPlatStubs { int magic; - void *hooks; + struct TclPlatStubHooks *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 */ + VOID *reserved2; + void (*tclUnusedStubEntry) (void); /* 3 */ +#endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ - void (*reserved0)(void); - int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, size_t maxPathLen, char *libraryPath); /* 1 */ + 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 */ + void (*tclUnusedStubEntry) (void); /* 2 */ #endif /* MACOSX */ } TclPlatStubs; -extern const TclPlatStubs *tclPlatStubsPtr; +extern TclPlatStubs *tclPlatStubsPtr; #ifdef __cplusplus } #endif -#if defined(USE_TCL_STUBS) +#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) /* * Inline function declarations: */ +#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#ifndef Tcl_WinUtfToTChar +#define Tcl_WinUtfToTChar \ + (tclPlatStubsPtr->tcl_WinUtfToTChar) /* 0 */ +#endif +#ifndef Tcl_WinTCharToUtf +#define Tcl_WinTCharToUtf \ + (tclPlatStubsPtr->tcl_WinTCharToUtf) /* 1 */ +#endif +/* Slot 2 is reserved */ +#ifndef TclUnusedStubEntry +#define TclUnusedStubEntry \ + (tclPlatStubsPtr->tclUnusedStubEntry) /* 3 */ +#endif +#endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ -/* Slot 0 is reserved */ +#ifndef Tcl_MacOSXOpenBundleResources +#define Tcl_MacOSXOpenBundleResources \ + (tclPlatStubsPtr->tcl_MacOSXOpenBundleResources) /* 0 */ +#endif +#ifndef Tcl_MacOSXOpenVersionedBundleResources #define Tcl_MacOSXOpenVersionedBundleResources \ (tclPlatStubsPtr->tcl_MacOSXOpenVersionedBundleResources) /* 1 */ +#endif +#ifndef TclUnusedStubEntry +#define TclUnusedStubEntry \ + (tclPlatStubsPtr->tclUnusedStubEntry) /* 2 */ +#endif #endif /* MACOSX */ -#endif /* defined(USE_TCL_STUBS) */ +#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ /* !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(TCL_NO_DEPRECATED) -#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 /* _TCLPLATDECLS */ +#endif /* _TCLPLATDECLS */ + + Index: generic/tclPort.h ================================================================== --- generic/tclPort.h +++ generic/tclPort.h @@ -21,10 +21,25 @@ # include "tclWinPort.h" #else # include "tclUnixPort.h" #endif #include "tcl.h" + +#if !defined(LLONG_MIN) +# ifdef TCL_WIDE_INT_IS_LONG +# define LLONG_MIN LONG_MIN +# else +# ifdef LLONG_BIT +# define LLONG_MIN ((Tcl_WideInt)(Tcl_LongAsWide(1)<<(LLONG_BIT-1))) +# else +/* Assume we're on a system with a 64-bit 'long long' type */ +# define LLONG_MIN ((Tcl_WideInt)(Tcl_LongAsWide(1)<<63)) +# endif +# endif +/* Assume that if LLONG_MIN is undefined, then so is LLONG_MAX */ +# define LLONG_MAX (~LLONG_MIN) +#endif #define UWIDE_MAX ((Tcl_WideUInt)-1) #define WIDE_MAX ((Tcl_WideInt)(UWIDE_MAX >> 1)) #define WIDE_MIN ((Tcl_WideInt)((Tcl_WideUInt)WIDE_MAX+1)) Index: generic/tclPosixStr.c ================================================================== --- generic/tclPosixStr.c +++ generic/tclPosixStr.c @@ -29,11 +29,11 @@ * None. * *---------------------------------------------------------------------- */ -const char * +CONST char * Tcl_ErrnoId(void) { switch (errno) { #if defined(E2BIG) && (!defined(EOVERFLOW) || (E2BIG != EOVERFLOW)) case E2BIG: return "E2BIG"; @@ -72,13 +72,10 @@ case EBADFD: return "EBADFD"; #endif #ifdef EBADMSG case EBADMSG: return "EBADMSG"; #endif -#ifdef ECANCELED - case ECANCELED: return "ECANCELED"; -#endif #ifdef EBADR case EBADR: return "EBADR"; #endif #ifdef EBADRPC case EBADRPC: return "EBADRPC"; @@ -201,11 +198,11 @@ case ELIBBAD: return "ELIBBAD"; #endif #ifdef ELIBEXEC case ELIBEXEC: return "ELIBEXEC"; #endif -#if defined(ELIBMAX) && (!defined(ECANCELED) || (ELIBMAX != ECANCELED)) +#ifdef ELIBMAX case ELIBMAX: return "ELIBMAX"; #endif #ifdef ELIBSCN case ELIBSCN: return "ELIBSCN"; #endif @@ -270,11 +267,11 @@ case ENOEXEC: return "ENOEXEC"; #endif #ifdef ENOLCK case ENOLCK: return "ENOLCK"; #endif -#ifdef ENOLINK +#if defined(ENOLINK) && (!defined(ESOCKTNOSUPPORT) || (ESOCKTNOSUPPORT != ENOLINK)) case ENOLINK: return "ENOLINK"; #endif #ifdef ENOMEM case ENOMEM: return "ENOMEM"; #endif @@ -285,11 +282,11 @@ case ENONET: return "ENONET"; #endif #ifdef ENOPKG case ENOPKG: return "ENOPKG"; #endif -#ifdef ENOPROTOOPT +#if defined(ENOPROTOOPT) && (!defined(EPFNOSUPPORT) || (EPFNOSUPPORT != ENOPROTOOPT)) case ENOPROTOOPT: return "ENOPROTOOPT"; #endif #ifdef ENOSPC case ENOSPC: return "ENOSPC"; #endif @@ -309,13 +306,10 @@ case ENOTBLK: return "ENOTBLK"; #endif #ifdef ENOTCONN case ENOTCONN: return "ENOTCONN"; #endif -#ifdef ENOTRECOVERABLE - case ENOTRECOVERABLE: return "ENOTRECOVERABLE"; -#endif #ifdef ENOTDIR case ENOTDIR: return "ENOTDIR"; #endif #if defined(ENOTEMPTY) && (!defined(EEXIST) || (ENOTEMPTY != EEXIST)) case ENOTEMPTY: return "ENOTEMPTY"; @@ -339,19 +333,13 @@ case ENXIO: return "ENXIO"; #endif #if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP)) case EOPNOTSUPP: return "EOPNOTSUPP"; #endif -#ifdef EOTHER - case EOTHER: return "EOTHER"; -#endif #if defined(EOVERFLOW) && (!defined(EFBIG) || (EOVERFLOW != EFBIG)) && (!defined(EINVAL) || (EOVERFLOW != EINVAL)) case EOVERFLOW: return "EOVERFLOW"; #endif -#ifdef EOWNERDEAD - case EOWNERDEAD: return "EOWNERDEAD"; -#endif #ifdef EPERM case EPERM: return "EPERM"; #endif #if defined(EPFNOSUPPORT) && (!defined(ENOLCK) || (ENOLCK != EPFNOSUPPORT)) case EPFNOSUPPORT: return "EPFNOSUPPORT"; @@ -487,11 +475,11 @@ * None. * *---------------------------------------------------------------------- */ -const char * +CONST char * Tcl_ErrnoMsg( int err) /* Error number (such as in errno variable). */ { switch (err) { #if defined(E2BIG) && (!defined(EOVERFLOW) || (E2BIG != EOVERFLOW)) @@ -502,17 +490,17 @@ #endif #ifdef EADDRINUSE case EADDRINUSE: return "address already in use"; #endif #ifdef EADDRNOTAVAIL - case EADDRNOTAVAIL: return "cannot assign requested address"; + case EADDRNOTAVAIL: return "can't assign requested address"; #endif #ifdef EADV case EADV: return "advertise error"; #endif #ifdef EAFNOSUPPORT - case EAFNOSUPPORT: return "address family not supported by protocol"; + case EAFNOSUPPORT: return "address family not supported by protocol family"; #endif #ifdef EAGAIN case EAGAIN: return "resource temporarily unavailable"; #endif #ifdef EALIGN @@ -531,13 +519,10 @@ case EBADFD: return "file descriptor in bad state"; #endif #ifdef EBADMSG case EBADMSG: return "not a data message"; #endif -#ifdef ECANCELED - case ECANCELED: return "operation canceled"; -#endif #ifdef EBADR case EBADR: return "bad request descriptor"; #endif #ifdef EBADRPC case EBADRPC: return "RPC structure is bad"; @@ -652,19 +637,19 @@ #endif #ifdef EL3RST case EL3RST: return "level 3 reset"; #endif #ifdef ELIBACC - case ELIBACC: return "cannot access a needed shared library"; + case ELIBACC: return "can not access a needed shared library"; #endif #ifdef ELIBBAD case ELIBBAD: return "accessing a corrupted shared library"; #endif #ifdef ELIBEXEC - case ELIBEXEC: return "cannot exec a shared library directly"; + case ELIBEXEC: return "can not exec a shared library directly"; #endif -#if defined(ELIBMAX) && (!defined(ECANCELED) || (ELIBMAX != ECANCELED)) +#ifdef ELIBMAX case ELIBMAX: return "attempting to link in more shared libraries than system limit"; #endif #ifdef ELIBSCN case ELIBSCN: return ".lib section in a.out corrupted"; @@ -730,11 +715,11 @@ case ENOEXEC: return "exec format error"; #endif #ifdef ENOLCK case ENOLCK: return "no locks available"; #endif -#ifdef ENOLINK +#if defined(ENOLINK) && (!defined(ESOCKTNOSUPPORT) || (ESOCKTNOSUPPORT != ENOLINK)) case ENOLINK: return "link has been severed"; #endif #ifdef ENOMEM case ENOMEM: return "not enough memory"; #endif @@ -745,11 +730,11 @@ case ENONET: return "machine is not on the network"; #endif #ifdef ENOPKG case ENOPKG: return "package not installed"; #endif -#ifdef ENOPROTOOPT +#if defined(ENOPROTOOPT) && (!defined(EPFNOSUPPORT) || (EPFNOSUPPORT != ENOPROTOOPT)) case ENOPROTOOPT: return "bad protocol option"; #endif #ifdef ENOSPC case ENOSPC: return "no space left on device"; #endif @@ -769,13 +754,10 @@ case ENOTBLK: return "block device required"; #endif #ifdef ENOTCONN case ENOTCONN: return "socket is not connected"; #endif -#ifdef ENOTRECOVERABLE - case ENOTRECOVERABLE: return "state not recoverable"; -#endif #ifdef ENOTDIR case ENOTDIR: return "not a directory"; #endif #if defined(ENOTEMPTY) && (!defined(EEXIST) || (ENOTEMPTY != EEXIST)) case ENOTEMPTY: return "directory not empty"; @@ -799,19 +781,13 @@ case ENXIO: return "no such device or address"; #endif #if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP)) case EOPNOTSUPP: return "operation not supported on socket"; #endif -#ifdef EOTHER - case EOTHER: return "other error"; -#endif #if defined(EOVERFLOW) && (!defined(EFBIG) || (EOVERFLOW != EFBIG)) && (!defined(EINVAL) || (EOVERFLOW != EINVAL)) case EOVERFLOW: return "file too big"; #endif -#ifdef EOWNERDEAD - case EOWNERDEAD: return "owner died"; -#endif #ifdef EPERM case EPERM: return "not owner"; #endif #if defined(EPFNOSUPPORT) && (!defined(ENOLCK) || (ENOLCK != EPFNOSUPPORT)) case EPFNOSUPPORT: return "protocol family not supported"; @@ -869,11 +845,11 @@ #endif #ifdef ERREMOTE case ERREMOTE: return "object is remote"; #endif #ifdef ESHUTDOWN - case ESHUTDOWN: return "cannot send after socket shutdown"; + case ESHUTDOWN: return "can't send after socket shutdown"; #endif #ifdef ESOCKTNOSUPPORT case ESOCKTNOSUPPORT: return "socket type not supported"; #endif #ifdef ESPIPE @@ -896,11 +872,11 @@ #endif #if defined(ETIMEDOUT) && (!defined(ENOSTR) || (ETIMEDOUT != ENOSTR)) case ETIMEDOUT: return "connection timed out"; #endif #ifdef ETOOMANYREFS - case ETOOMANYREFS: return "too many references: cannot splice"; + case ETOOMANYREFS: return "too many references: can't splice"; #endif #ifdef ETXTBSY case ETXTBSY: return "text file or pseudo-device busy"; #endif #ifdef EUCLEAN @@ -949,11 +925,11 @@ * None. * *---------------------------------------------------------------------- */ -const char * +CONST char * Tcl_SignalId( int sig) /* Number of signal. */ { switch (sig) { #ifdef SIGABRT @@ -1083,11 +1059,11 @@ * None. * *---------------------------------------------------------------------- */ -const char * +CONST char * Tcl_SignalMsg( int sig) /* Number of signal. */ { switch (sig) { #ifdef SIGABRT Index: generic/tclPreserve.c ================================================================== --- generic/tclPreserve.c +++ generic/tclPreserve.c @@ -20,11 +20,11 @@ * number of calls in effect. */ typedef struct { ClientData clientData; /* Address of preserved block. */ - size_t refCount; /* Number of Tcl_Preserve calls in effect for + int refCount; /* Number of Tcl_Preserve calls in effect for * block. */ int mustFree; /* Non-zero means Tcl_EventuallyFree was * called while a Tcl_Preserve call was in * effect, so the structure must be freed when * refCount becomes zero. */ @@ -35,13 +35,13 @@ * Global data structures used to hold the list of preserved data references. * These variables are protected by "preserveMutex". */ static Reference *refArray = NULL; /* First in array of references. */ -static size_t spaceAvl = 0; /* Total number of structures available at +static int spaceAvl = 0; /* Total number of structures available at * *firstRefPtr. */ -static size_t inUse = 0; /* Count of structures currently in use in +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 */ @@ -51,21 +51,21 @@ * 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 { +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 * not changed by anyone else. */ #endif - size_t refCount; /* Number of TclHandlePreserve() calls in + int refCount; /* Number of TclHandlePreserve() calls in * effect on this handle. */ } HandleStruct; /* *---------------------------------------------------------------------- @@ -81,19 +81,20 @@ * Frees the storage of the reference array. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ void TclFinalizePreserve(void) { Tcl_MutexLock(&preserveMutex); if (spaceAvl != 0) { - Tcl_Free(refArray); - refArray = NULL; - inUse = 0; - spaceAvl = 0; + ckfree((char *) refArray); + refArray = NULL; + inUse = 0; + spaceAvl = 0; } Tcl_MutexUnlock(&preserveMutex); } /* @@ -118,11 +119,11 @@ void Tcl_Preserve( ClientData clientData) /* Pointer to malloc'ed block of memory. */ { Reference *refPtr; - size_t i; + int i; /* * See if there is already a reference for this pointer. If so, just * increment its reference count. */ @@ -141,11 +142,12 @@ * if it is full. */ if (inUse == spaceAvl) { spaceAvl = spaceAvl ? 2*spaceAvl : INITIAL_SIZE; - refArray = (Reference *)Tcl_Realloc(refArray, spaceAvl * sizeof(Reference)); + refArray = (Reference *) ckrealloc((char *) refArray, + spaceAvl * sizeof(Reference)); } /* * Make a new entry for the new reference. */ @@ -152,11 +154,11 @@ refPtr = &refArray[inUse]; refPtr->clientData = clientData; refPtr->refCount = 1; refPtr->mustFree = 0; - refPtr->freeProc = 0; + refPtr->freeProc = TCL_STATIC; inUse += 1; Tcl_MutexUnlock(&preserveMutex); } /* @@ -181,11 +183,11 @@ void Tcl_Release( ClientData clientData) /* Pointer to malloc'ed block of memory. */ { Reference *refPtr; - size_t i; + int i; Tcl_MutexLock(&preserveMutex); for (i=0, refPtr=refArray ; iclientData != clientData) { continue; } - if (refPtr->refCount-- > 1) { + if (--refPtr->refCount != 0) { Tcl_MutexUnlock(&preserveMutex); return; } /* @@ -221,13 +223,13 @@ */ Tcl_MutexUnlock(&preserveMutex); if (mustFree) { if (freeProc == TCL_DYNAMIC) { - Tcl_Free(clientData); + ckfree((char *) clientData); } else { - freeProc((char *)clientData); + (*freeProc)((char *) clientData); } } return; } Tcl_MutexUnlock(&preserveMutex); @@ -234,11 +236,11 @@ /* * Reference not found. This is a bug in the caller. */ - Tcl_Panic("Tcl_Release couldn't find reference for %p", clientData); + Tcl_Panic("Tcl_Release couldn't find reference for 0x%x", PTR2UINT(clientData)); } /* *---------------------------------------------------------------------- * @@ -261,11 +263,11 @@ Tcl_EventuallyFree( ClientData clientData, /* Pointer to malloc'ed block of memory. */ Tcl_FreeProc *freeProc) /* Function to actually do free. */ { Reference *refPtr; - size_t i; + 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!). */ @@ -274,27 +276,28 @@ for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) { if (refPtr->clientData != clientData) { continue; } if (refPtr->mustFree) { - Tcl_Panic("Tcl_EventuallyFree called twice for %p", clientData); - } - refPtr->mustFree = 1; + Tcl_Panic("Tcl_EventuallyFree called twice for 0x%x", + PTR2UINT(clientData)); + } + refPtr->mustFree = 1; refPtr->freeProc = freeProc; Tcl_MutexUnlock(&preserveMutex); - return; + return; } Tcl_MutexUnlock(&preserveMutex); /* * No reference for this block. Free it now. */ if (freeProc == TCL_DYNAMIC) { - Tcl_Free(clientData); + ckfree((char *) clientData); } else { - freeProc((char *)clientData); + (*freeProc)((char *)clientData); } } /* *--------------------------------------------------------------------------- @@ -324,12 +327,13 @@ TclHandleCreate( void *ptr) /* Pointer to an arbitrary block of memory to * be tracked for deletion. Must not be * NULL. */ { - HandleStruct *handlePtr = (HandleStruct *)Tcl_Alloc(sizeof(HandleStruct)); + HandleStruct *handlePtr; + handlePtr = (HandleStruct *) ckalloc(sizeof(HandleStruct)); handlePtr->ptr = ptr; #ifdef TCL_MEM_DEBUG handlePtr->ptr2 = ptr; #endif handlePtr->refCount = 0; @@ -365,20 +369,20 @@ HandleStruct *handlePtr; handlePtr = (HandleStruct *) handle; #ifdef TCL_MEM_DEBUG if (handlePtr->refCount == 0x61616161) { - Tcl_Panic("using previously disposed TclHandle %p", handlePtr); + Tcl_Panic("using previously disposed TclHandle %x", handlePtr); } if (handlePtr->ptr2 != handlePtr->ptr) { - Tcl_Panic("someone has changed the block referenced by the handle %p\nfrom %p to %p", + Tcl_Panic("someone has changed the block referenced by the handle %x\nfrom %x to %x", handlePtr, handlePtr->ptr2, handlePtr->ptr); } #endif handlePtr->ptr = NULL; if (handlePtr->refCount == 0) { - Tcl_Free(handlePtr); + ckfree((char *) handlePtr); } } /* *--------------------------------------------------------------------------- @@ -408,14 +412,14 @@ HandleStruct *handlePtr; handlePtr = (HandleStruct *) handle; #ifdef TCL_MEM_DEBUG if (handlePtr->refCount == 0x61616161) { - Tcl_Panic("using previously disposed TclHandle %p", handlePtr); + Tcl_Panic("using previously disposed TclHandle %x", handlePtr); } if ((handlePtr->ptr != NULL) && (handlePtr->ptr != handlePtr->ptr2)) { - Tcl_Panic("someone has changed the block referenced by the handle %p\nfrom %p to %p", + Tcl_Panic("someone has changed the block referenced by the handle %x\nfrom %x to %x", handlePtr, handlePtr->ptr2, handlePtr->ptr); } #endif handlePtr->refCount++; @@ -449,19 +453,20 @@ HandleStruct *handlePtr; handlePtr = (HandleStruct *) handle; #ifdef TCL_MEM_DEBUG if (handlePtr->refCount == 0x61616161) { - Tcl_Panic("using previously disposed TclHandle %p", handlePtr); + Tcl_Panic("using previously disposed TclHandle %x", handlePtr); } if ((handlePtr->ptr != NULL) && (handlePtr->ptr != handlePtr->ptr2)) { - Tcl_Panic("someone has changed the block referenced by the handle %p\nfrom %p to %p", + Tcl_Panic("someone has changed the block referenced by the handle %x\nfrom %x to %x", handlePtr, handlePtr->ptr2, handlePtr->ptr); } #endif - if ((handlePtr->refCount-- <= 1) && (handlePtr->ptr == NULL)) { - Tcl_Free(handlePtr); + handlePtr->refCount--; + if ((handlePtr->refCount == 0) && (handlePtr->ptr == NULL)) { + ckfree((char *) handlePtr); } } /* * Local Variables: Index: generic/tclProc.c ================================================================== --- generic/tclProc.c +++ generic/tclProc.c @@ -13,52 +13,45 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclCompile.h" -#include - -/* - * Variables that are part of the [apply] command implementation and which - * have to be passed to the other side of the NRE call. - */ - -typedef struct { - Command cmd; - ExtraFrameInfo efi; -} ApplyExtraData; /* * 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 int InitArgsAndLocals(Tcl_Interp *interp, + Tcl_Obj *procNameObj, int skip); static void InitResolvedLocals(Tcl_Interp *interp, ByteCode *codePtr, Var *defPtr, - Namespace *nsPtr); -static void InitLocalCache(Proc *procPtr); + Namespace *nsPtr); +static void InitLocalCache(Proc *procPtr); +static int PushProcCallFrame(ClientData clientData, + register Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[], int isLambda); static void ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); static void ProcBodyFree(Tcl_Obj *objPtr); -static int ProcWrongNumArgs(Tcl_Interp *interp, int skip); +static int ProcWrongNumArgs(Tcl_Interp *interp, int skip); static void MakeProcError(Tcl_Interp *interp, Tcl_Obj *procNameObj); static void MakeLambdaError(Tcl_Interp *interp, Tcl_Obj *procNameObj); static int SetLambdaFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); - -static Tcl_NRPostProc ApplyNR2; -static Tcl_NRPostProc InterpProcNR2; -static Tcl_NRPostProc Uplevel_Callback; +static int ProcCompileProc(Tcl_Interp *interp, Proc *procPtr, + Tcl_Obj *bodyPtr, Namespace *nsPtr, + CONST char *description, CONST char *procName, + Proc **procPtrPtr); /* * The ProcBodyObjType type */ -const Tcl_ObjType tclProcBodyType = { +Tcl_ObjType tclProcBodyType = { "procbody", /* name for this type */ ProcBodyFree, /* FreeInternalRep function */ ProcBodyDup, /* DupInternalRep function */ NULL, /* UpdateString function; Tcl_GetString and * Tcl_GetStringFromObj should panic @@ -65,35 +58,20 @@ * instead. */ NULL /* SetFromAny function; Tcl_ConvertToType * should panic instead. */ }; -#define ProcSetIntRep(objPtr, procPtr) \ - do { \ - Tcl_ObjIntRep ir; \ - (procPtr)->refCount++; \ - ir.twoPtrValue.ptr1 = (procPtr); \ - ir.twoPtrValue.ptr2 = NULL; \ - 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 # format. + * The [upvar]/[uplevel] level reference type. Uses the twoPtrValue field, + * encoding the type of level reference in ptr1 and the actual parsed out + * offset in ptr2. * * Uses the default behaviour throughout, and never disposes of the string * rep; it's just a cache type. */ -static const Tcl_ObjType levelReferenceType = { +static Tcl_ObjType levelReferenceType = { "levelReference", NULL, NULL, NULL, NULL }; /* @@ -100,38 +78,20 @@ * The type of lambdas. Note that every lambda will *always* have a string * representation. * * Internally, ptr1 is a pointer to a Proc instance that is not bound to a * command name, and ptr2 is a pointer to the namespace that the Proc instance - * will execute within. IF YOU CHANGE THIS, CHECK IN tclDisassemble.c TOO. + * will execute within. */ -static const Tcl_ObjType lambdaType = { +static Tcl_ObjType lambdaType = { "lambdaExpr", /* name */ FreeLambdaInternalRep, /* freeIntRepProc */ DupLambdaInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ SetLambdaFromAny /* setFromAnyProc */ }; - -#define LambdaSetIntRep(objPtr, procPtr, nsObjPtr) \ - do { \ - Tcl_ObjIntRep ir; \ - ir.twoPtrValue.ptr1 = (procPtr); \ - ir.twoPtrValue.ptr2 = (nsObjPtr); \ - Tcl_IncrRefCount((nsObjPtr)); \ - 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 -- @@ -146,23 +106,25 @@ * A new procedure gets created. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_ProcObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { - Interp *iPtr = (Interp *) interp; + register Interp *iPtr = (Interp *) interp; Proc *procPtr; - const char *procName; - const char *simpleName, *procArgs, *procBody; + char *fullName; + CONST char *procName, *procArgs, *procBody; Namespace *nsPtr, *altNsPtr, *cxtNsPtr; Tcl_Command cmd; + Tcl_DString ds; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "name args body"); return TCL_ERROR; } @@ -171,43 +133,62 @@ * Determine the namespace where the procedure should reside. Unless the * command name includes namespace qualifiers, this will be the current * namespace. */ - procName = TclGetString(objv[1]); - TclGetNamespaceForQualName(interp, procName, NULL, 0, - &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName); + fullName = TclGetString(objv[1]); + TclGetNamespaceForQualName(interp, fullName, NULL, 0, + &nsPtr, &altNsPtr, &cxtNsPtr, &procName); if (nsPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create procedure \"%s\": unknown namespace", - procName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); + Tcl_AppendResult(interp, "can't create procedure \"", fullName, + "\": unknown namespace", NULL); + return TCL_ERROR; + } + if (procName == NULL) { + Tcl_AppendResult(interp, "can't create procedure \"", fullName, + "\": bad procedure name", NULL); return TCL_ERROR; } - if (simpleName == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create procedure \"%s\": bad procedure name", - procName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); + if ((nsPtr != iPtr->globalNsPtr) + && (procName != NULL) && (procName[0] == ':')) { + Tcl_AppendResult(interp, "can't create procedure \"", procName, + "\" in non-global namespace with name starting with \":\"", + NULL); 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) { + if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3], + &procPtr) != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (creating proc \""); - Tcl_AddErrorInfo(interp, simpleName); + Tcl_AddErrorInfo(interp, procName); Tcl_AddErrorInfo(interp, "\")"); return TCL_ERROR; } - cmd = TclNRCreateCommandInNs(interp, simpleName, (Tcl_Namespace *) nsPtr, - TclObjInterpProc, TclNRInterpProc, procPtr, TclProcDeleteProc); + /* + * Now create a command for the procedure. This will initially be in the + * current namespace unless the procedure's name included namespace + * qualifiers. To create the new command in the right namespace, we + * generate a fully qualified name for it. + */ + + Tcl_DStringInit(&ds); + if (nsPtr != iPtr->globalNsPtr) { + Tcl_DStringAppend(&ds, nsPtr->fullName, -1); + Tcl_DStringAppend(&ds, "::", 2); + } + Tcl_DStringAppend(&ds, procName, -1); + + cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), + TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc); + + Tcl_DStringFree(&ds); /* * Now initialize the new procedure's cmdPtr field. This will be used * later when the procedure is called to determine what namespace the * procedure will run in. This will be different than the current @@ -222,19 +203,21 @@ * information. This is for the initialization of the byte code compiler * when the body is used for the first time. * * This code is nearly identical to the #280 code in SetLambdaFromAny, see * 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 + * line array of the context, and the lamdba 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)); + CmdFrame *contextPtr; + 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 @@ -258,53 +241,52 @@ */ if (contextPtr->line && (contextPtr->nline >= 4) && (contextPtr->line[3] >= 0)) { int isNew; - Tcl_HashEntry *hePtr; - CmdFrame *cfPtr = (CmdFrame *)Tcl_Alloc(sizeof(CmdFrame)); + Tcl_HashEntry* hePtr; + CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame)); cfPtr->level = -1; cfPtr->type = contextPtr->type; - cfPtr->line = (int *)Tcl_Alloc(sizeof(int)); + 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); - cfPtr->cmd = NULL; - cfPtr->len = 0; + cfPtr->cmd.str.cmd = NULL; + cfPtr->cmd.str.len = 0; - hePtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, - procPtr, &isNew); + hePtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, (char *) procPtr, &isNew); if (!isNew) { /* - * Get the old command frame and release it. See also + * 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); + CmdFrame* cfOldPtr = (CmdFrame *) Tcl_GetHashValue(hePtr); if (cfOldPtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(cfOldPtr->data.eval.path); cfOldPtr->data.eval.path = NULL; } - Tcl_Free(cfOldPtr->line); + ckfree((char *) cfOldPtr->line); cfOldPtr->line = NULL; - Tcl_Free(cfOldPtr); + ckfree((char *) cfOldPtr); } Tcl_SetHashValue(hePtr, cfPtr); } /* - * 'contextPtr' is going out of scope; account for the reference - * that it's holding to the path name. + * 'contextPtr' is going out of scope; account for the reference that + * it's holding to the path name. */ Tcl_DecrRefCount(contextPtr->data.eval.path); contextPtr->data.eval.path = NULL; } @@ -336,11 +318,11 @@ while (*procArgs == ' ') { procArgs++; } if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) { - size_t numBytes; + int numBytes; procArgs +=4; while (*procArgs != '\0') { if (*procArgs != ' ') { goto done; @@ -350,11 +332,11 @@ /* * The argument list is just "args"; check the body */ - procBody = TclGetStringFromObj(objv[3], &numBytes); + procBody = Tcl_GetStringFromObj(objv[3], &numBytes); if (TclParseAllWhiteSpace(procBody, numBytes) < numBytes) { goto done; } /* @@ -393,26 +375,27 @@ */ int TclCreateProc( Tcl_Interp *interp, /* Interpreter containing proc. */ - TCL_UNUSED(Namespace *) /*nsPtr*/, - const char *procName, /* Unqualified name of this proc. */ + Namespace *nsPtr, /* Namespace containing this proc. */ + 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; + CONST char **argArray = NULL; - Proc *procPtr = NULL; - int i, result, numArgs; - CompiledLocal *localPtr = NULL; - Tcl_Obj **argArray; + register Proc *procPtr; + int i, length, result, numArgs; + CONST char *args, *bytes, *p; + register CompiledLocal *localPtr = NULL; + Tcl_Obj *defPtr; int precompiled = 0; - ProcGetIntRep(bodyPtr, procPtr); - if (procPtr != NULL) { + if (bodyPtr->typePtr == &tclProcBodyType) { /* * Because the body is a TclProProcBody, the actual body is already * compiled, and it is not shared with anyone else, so it's OK not to * unshare it (as a matter of fact, it is bad to unshare it, because * there may be no source code). @@ -421,10 +404,11 @@ * rather, we use what is in the body object. We increment the ref * count of the Proc struct since the command (soon to be created) * will be holding a reference to it. */ + procPtr = bodyPtr->internalRep.twoPtrValue.ptr1; procPtr->iPtr = iPtr; procPtr->refCount++; precompiled = 1; } else { /* @@ -441,13 +425,11 @@ * 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; - size_t length; - Tcl_Obj *sharedBodyPtr = bodyPtr; + Tcl_Obj* sharedBodyPtr = bodyPtr; bytes = TclGetStringFromObj(bodyPtr, &length); bodyPtr = Tcl_NewStringObj(bytes, length); /* @@ -454,11 +436,11 @@ * TIP #280. * Ensure that the continuation line data for the original body is * not lost and applies to the new body as well. */ - TclContinuationsCopy(bodyPtr, sharedBodyPtr); + TclContinuationsCopy (bodyPtr, sharedBodyPtr); } /* * Create and initialize a Proc structure for the procedure. We * increment the ref count of the procedure's body object since there @@ -465,11 +447,11 @@ * will be a reference to it in the Proc structure. */ Tcl_IncrRefCount(bodyPtr); - procPtr = (Proc *)Tcl_Alloc(sizeof(Proc)); + 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; @@ -480,13 +462,16 @@ /* * Break up the argument list into argument specifiers, then process each * argument specifier. If the body is precompiled, processing is limited * to checking that the parsed argument is consistent with the one stored * in the Proc. + * + * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULS. */ - result = Tcl_ListObjGetElements(interp , argsPtr ,&numArgs ,&argArray); + args = TclGetStringFromObj(argsPtr, &length); + result = Tcl_SplitList(interp, args, &numArgs, &argArray); if (result != TCL_OK) { goto procError; } if (precompiled) { @@ -493,82 +478,78 @@ if (numArgs > procPtr->numArgs) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "procedure \"%s\": arg list contains %d entries, " "precompiled header expects %d", procName, numArgs, procPtr->numArgs)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "BYTECODELIES", NULL); goto procError; } localPtr = procPtr->firstLocalPtr; } else { procPtr->numArgs = numArgs; procPtr->numCompiledLocals = numArgs; } for (i = 0; i < numArgs; i++) { - const char *argname, *argnamei, *argnamelast; - int fieldCount; - size_t nameLength; - Tcl_Obj **fieldValues; + int fieldCount, nameLength, valueLength; + CONST char **fieldValues; /* * Now divide the specifier up into name and default. */ - result = Tcl_ListObjGetElements(interp, argArray[i], &fieldCount, + result = Tcl_SplitList(interp, argArray[i], &fieldCount, &fieldValues); if (result != TCL_OK) { goto procError; } if (fieldCount > 2) { - Tcl_Obj *errorObj = Tcl_NewStringObj( - "too many fields in argument specifier \"", -1); - Tcl_AppendObjToObj(errorObj, argArray[i]); - Tcl_AppendToObj(errorObj, "\"", -1); - Tcl_SetObjResult(interp, errorObj); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", NULL); + ckfree((char *) fieldValues); + Tcl_AppendResult(interp, + "too many fields in argument specifier \"", + argArray[i], "\"", NULL); goto procError; } - if ((fieldCount == 0) || (fieldValues[0]->length == 0)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "argument with no name", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", NULL); + if ((fieldCount == 0) || (*fieldValues[0] == 0)) { + ckfree((char *) fieldValues); + Tcl_AppendResult(interp, "argument with no name", NULL); goto procError; } - argname = TclGetStringFromObj(fieldValues[0], &nameLength); + nameLength = strlen(fieldValues[0]); + if (fieldCount == 2) { + valueLength = strlen(fieldValues[1]); + } else { + valueLength = 0; + } /* * Check that the formal parameter name is a scalar. */ - argnamei = argname; - argnamelast = (nameLength > 0) ? (argname + nameLength - 1) : argname; - while (argnamei < argnamelast) { - if (*argnamei == '(') { - if (*argnamelast == ')') { /* We have an array element. */ - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "formal parameter \"%s\" is an array element", - TclGetString(fieldValues[0]))); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", 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++; + p = fieldValues[0]; + while (*p != '\0') { + if (*p == '(') { + CONST char *q = p; + do { + q++; + } while (*q != '\0'); + q--; + if (*q == ')') { /* We have an array element. */ + Tcl_AppendResult(interp, "formal parameter \"", + fieldValues[0], + "\" is an array element", NULL); + ckfree((char *) fieldValues); + goto procError; + } + } else if ((*p == ':') && (*(p+1) == ':')) { + Tcl_AppendResult(interp, "formal parameter \"", + fieldValues[0], + "\" is not a simple name", NULL); + ckfree((char *) fieldValues); + goto procError; + } + p++; } if (precompiled) { /* * Compare the parsed argument with the stored one. Note that the @@ -580,43 +561,38 @@ * precompiled procs is VAR_TEMPORARY (also unchanged). It is * needed later when retrieving the variable names. */ if ((localPtr->nameLength != nameLength) - || (memcmp(localPtr->name, argname, nameLength) != 0) + || (strcmp(localPtr->name, fieldValues[0])) || (localPtr->frameIndex != i) || !(localPtr->flags & VAR_ARGUMENT) || (localPtr->defValuePtr == NULL && fieldCount == 2) || (localPtr->defValuePtr != NULL && fieldCount != 2)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "procedure \"%s\": formal parameter %d is " "inconsistent with precompiled body", procName, i)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "BYTECODELIES", NULL); + ckfree((char *) fieldValues); goto procError; } /* * Compare the default value if any. */ if (localPtr->defValuePtr != NULL) { - size_t tmpLength, valueLength; - const char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr, &tmpLength); - const char *value = TclGetStringFromObj(fieldValues[1], &valueLength); - - if ((valueLength != tmpLength) - || memcmp(value, tmpPtr, tmpLength) != 0 - ) { - Tcl_Obj *errorObj = Tcl_ObjPrintf( - "procedure \"%s\": formal parameter \"", procName); - Tcl_AppendObjToObj(errorObj, fieldValues[0]); - Tcl_AppendToObj(errorObj, "\" has " - "default value inconsistent with precompiled body", -1); - Tcl_SetObjResult(interp, errorObj); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "BYTECODELIES", NULL); + int tmpLength; + char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr, + &tmpLength); + + if ((valueLength != tmpLength) || + strncmp(fieldValues[1], tmpPtr, (size_t) tmpLength)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "procedure \"%s\": formal parameter \"%s\" has " + "default value inconsistent with precompiled body", + procName, fieldValues[0])); + ckfree((char *) fieldValues); goto procError; } } if ((i == numArgs - 1) && (localPtr->nameLength == 4) @@ -630,12 +606,13 @@ /* * Allocate an entry in the runtime procedure frame's array of * local variables for the argument. */ - localPtr = (CompiledLocal *)Tcl_Alloc( - offsetof(CompiledLocal, name) + fieldValues[0]->length + 1); + localPtr = (CompiledLocal *) ckalloc((unsigned) + (sizeof(CompiledLocal) - sizeof(localPtr->name) + + nameLength + 1)); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { procPtr->lastLocalPtr->nextPtr = localPtr; procPtr->lastLocalPtr = localPtr; @@ -645,26 +622,30 @@ localPtr->frameIndex = i; localPtr->flags = VAR_ARGUMENT; localPtr->resolveInfo = NULL; if (fieldCount == 2) { - localPtr->defValuePtr = fieldValues[1]; + localPtr->defValuePtr = + Tcl_NewStringObj(fieldValues[1], valueLength); Tcl_IncrRefCount(localPtr->defValuePtr); } else { localPtr->defValuePtr = NULL; } - memcpy(localPtr->name, argname, fieldValues[0]->length + 1); + memcpy(localPtr->name, fieldValues[0], nameLength + 1); if ((i == numArgs - 1) && (localPtr->nameLength == 4) && (localPtr->name[0] == 'a') - && (memcmp(localPtr->name, "args", 4) == 0)) { + && (strcmp(localPtr->name, "args") == 0)) { localPtr->flags |= VAR_IS_ARGS; } } + + ckfree((char *) fieldValues); } *procPtrPtr = procPtr; + ckfree((char *) argArray); return TCL_OK; procError: if (precompiled) { procPtr->refCount--; @@ -672,17 +653,21 @@ Tcl_DecrRefCount(bodyPtr); while (procPtr->firstLocalPtr != NULL) { localPtr = procPtr->firstLocalPtr; procPtr->firstLocalPtr = localPtr->nextPtr; - if (localPtr->defValuePtr != NULL) { - Tcl_DecrRefCount(localPtr->defValuePtr); + defPtr = localPtr->defValuePtr; + if (defPtr != NULL) { + Tcl_DecrRefCount(defPtr); } - Tcl_Free(localPtr); + ckfree((char *) localPtr); } - Tcl_Free(procPtr); + ckfree((char *) procPtr); + } + if (argArray != NULL) { + ckfree((char *) argArray); } return TCL_ERROR; } /* @@ -711,23 +696,64 @@ */ int TclGetFrame( Tcl_Interp *interp, /* Interpreter in which to find frame. */ - const char *name, /* String describing frame. */ + CONST char *name, /* String describing frame. */ CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if * global frame indicated). */ { - int result; - Tcl_Obj obj; - - obj.bytes = (char *) name; - obj.length = strlen(name); - obj.typePtr = NULL; - result = TclObjGetFrame(interp, &obj, framePtrPtr); - TclFreeIntRep(&obj); - return result; + register Interp *iPtr = (Interp *) interp; + int curLevel, level, result; + CallFrame *framePtr; + + /* + * Parse string to figure out which level number to go to. + */ + + result = 1; + curLevel = iPtr->varFramePtr->level; + if (*name== '#') { + if (Tcl_GetInt(NULL, name+1, &level) != TCL_OK || level < 0) { + goto levelError; + } + } else if (isdigit(UCHAR(*name))) { /* INTL: digit */ + if (Tcl_GetInt(NULL, name, &level) != TCL_OK) { + goto levelError; + } + level = curLevel - level; + } else { + /* + * (historical, TODO) If name does not contain a level (#0 or 1), + * TclGetFrame and Tcl_UpVar2 uses current level - 1 + */ + level = curLevel - 1; + result = 0; + name = "1"; /* be more consistent with TclObjGetFrame (error at top - 1) */ + } + + /* + * Figure out which frame to use, and return it to the caller. + */ + + for (framePtr = iPtr->varFramePtr; framePtr != NULL; + framePtr = framePtr->callerVarPtr) { + if (framePtr->level == level) { + break; + } + } + if (framePtr == NULL) { + goto levelError; + } + + *framePtrPtr = framePtr; + return result; + + levelError: + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL); + return -1; } /* *---------------------------------------------------------------------- * @@ -738,11 +764,11 @@ * appropriate level of procedure. * * Results: * The return value is -1 if an error occurred in finding the frame (in * this case an error message is left in the interp's result). 1 is - * returned if objPtr was either an int or an int preceded by "#" and + * returned if objPtr was either a number or a number preceded by "#" and * it specified a valid frame. 0 is returned if objPtr isn't one of the * two things above (in this case, the lookup acts as if objPtr were * "1"). The variable pointed to by framePtrPtr is filled in with the * address of the desired frame (unless an error occurs, in which case it * isn't modified). @@ -758,93 +784,100 @@ 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; + register Interp *iPtr = (Interp *) interp; int curLevel, level, result; - const Tcl_ObjIntRep *irPtr; - const char *name = NULL; - Tcl_WideInt w; + CallFrame *framePtr; + CONST char *name = TclGetString(objPtr); /* * Parse object to figure out which level number to go to. */ - result = 0; + result = 1; curLevel = iPtr->varFramePtr->level; - - /* - * Check for integer first, since that has potential to spare us - * a generation of a stringrep. - */ - - if (objPtr == NULL) { - /* Do nothing */ - } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level)) { - Tcl_GetWideIntFromObj(NULL, objPtr, &w); - if (w < 0 || w > INT_MAX || curLevel > w + INT_MAX) { - result = -1; - } else { - level = curLevel - level; - result = 1; - } - } else if ((irPtr = TclFetchIntRep(objPtr, &levelReferenceType))) { - level = irPtr->wideValue; - result = 1; - } else { - name = TclGetString(objPtr); - if (name[0] == '#') { - if (TCL_OK == Tcl_GetInt(NULL, name+1, &level)) { - if (level < 0 || (level > 0 && name[1] == '-')) { - result = -1; - } else { - Tcl_ObjIntRep ir; - - 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); + if (objPtr->typePtr == &levelReferenceType) { + if (PTR2INT(objPtr->internalRep.twoPtrValue.ptr1)) { + level = curLevel - PTR2INT(objPtr->internalRep.twoPtrValue.ptr2); + } else { + level = PTR2INT(objPtr->internalRep.twoPtrValue.ptr2); + } + if (level < 0) { + goto levelError; + } + /* TODO: Consider skipping the typePtr checks */ + } else if (objPtr->typePtr == &tclIntType +#ifndef NO_WIDE_TYPE + || objPtr->typePtr == &tclWideIntType +#endif + ) { + if (TclGetIntFromObj(NULL, objPtr, &level) != TCL_OK || level < 0) { + goto levelError; + } + level = curLevel - level; + } else if (*name == '#') { + if (Tcl_GetInt(NULL, name+1, &level) != TCL_OK || level < 0) { + goto levelError; + } + + /* + * Cache for future reference. + * + * TODO: Use the new ptrAndLongRep intrep + */ + + TclFreeIntRep(objPtr); + objPtr->typePtr = &levelReferenceType; + objPtr->internalRep.twoPtrValue.ptr1 = (void *) 0; + objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(level); + } else if (isdigit(UCHAR(*name))) { /* INTL: digit */ + if (Tcl_GetInt(interp, name, &level) != TCL_OK) { + return -1; + } + + /* + * Cache for future reference. + * + * TODO: Use the new ptrAndLongRep intrep + */ + + TclFreeIntRep(objPtr); + objPtr->typePtr = &levelReferenceType; + objPtr->internalRep.twoPtrValue.ptr1 = (void *) 1; + objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(level); + level = curLevel - level; + } else { + /* + * Don't cache as the object *isn't* a level reference. + */ + + level = curLevel - 1; + result = 0; + name = "1"; + } + + /* + * Figure out which frame to use, and return it to the caller. + */ + + for (framePtr = iPtr->varFramePtr; framePtr != NULL; + framePtr = framePtr->callerVarPtr) { + if (framePtr->level == level) { + break; + } + } + if (framePtr == NULL) { + goto levelError; + } + *framePtrPtr = framePtr; + return result; + + levelError: + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL); return -1; } /* *---------------------------------------------------------------------- @@ -861,79 +894,26 @@ * See the user documentation. * *---------------------------------------------------------------------- */ -static int -Uplevel_Callback( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - CallFrame *savedVarFramePtr = (CallFrame *)data[0]; - - if (result == TCL_ERROR) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"uplevel\" body line %d)", Tcl_GetErrorLine(interp))); - } - - /* - * Restore the variable frame, and return. - */ - - ((Interp *)interp)->varFramePtr = savedVarFramePtr; - return result; -} - -int -Tcl_UplevelObjCmd( - ClientData clientData, - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - return Tcl_NRCallObjProc(interp, TclNRUplevelObjCmd, clientData, objc, objv); -} - -int -TclNRUplevelObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - - Interp *iPtr = (Interp *) interp; - CmdFrame *invoker = NULL; - int word = 0; - int result; - CallFrame *savedVarFramePtr, *framePtr; - Tcl_Obj *objPtr; - - if (objc < 2) { - /* to do - * simplify things by interpreting the argument as a command when there - * is only one argument. This requires a TIP since currently a single - * argument is interpreted as a level indicator if possible. - */ + /* ARGSUSED */ +int +Tcl_UplevelObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ +{ + register Interp *iPtr = (Interp *) interp; + int result; + CallFrame *savedVarFramePtr, *framePtr; + + if (objc < 2) { uplevelSyntax: Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?"); return TCL_ERROR; - } else if (!TclHasStringRep(objv[1]) && objc == 2) { - int status ,llength; - status = Tcl_ListObjLength(interp, objv[1], &llength); - if (status == TCL_OK && llength > 1) { - /* the first argument can't interpreted as a level. Avoid - * generating a string representation of the script. */ - result = TclGetFrame(interp, "1", &framePtr); - if (result == -1) { - return TCL_ERROR; - } - objc -= 1; - objv += 1; - goto havelevel; - } } /* * Find the level to use for executing the command. */ @@ -940,17 +920,15 @@ result = TclObjGetFrame(interp, objv[1], &framePtr); if (result == -1) { return TCL_ERROR; } - objc -= result + 1; + objc -= (result+1); if (objc == 0) { goto uplevelSyntax; } - objv += result + 1; - - havelevel: + objv += (result+1); /* * Modify the interpreter state to execute in the given frame. */ @@ -961,29 +939,41 @@ * Execute the residual arguments as a command. */ if (objc == 1) { /* - * TIP #280. Make actual argument location available to eval'd script + * TIP #280. Make argument location available to eval'd script */ - TclArgumentGet(interp, objv[0], &invoker, &word); - objPtr = objv[0]; + CmdFrame* invoker = NULL; + int word = 0; + TclArgumentGet (interp, objv[0], &invoker, &word); + result = TclEvalObjEx(interp, objv[0], 0, invoker, word); } else { /* * More than one argument: concatenate them together with spaces * between, then evaluate the result. Tcl_EvalObjEx will delete the * object when it decrements its refcount after eval'ing it. */ + + Tcl_Obj *objPtr; objPtr = Tcl_ConcatObj(objc, objv); + result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); + } + if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"uplevel\" body line %d)", interp->errorLine)); } - TclNRAddCallback(interp, Uplevel_Callback, savedVarFramePtr, NULL, NULL, - NULL); - return TclNREvalObjEx(interp, objPtr, 0, invoker, word); + /* + * Restore the variable frame, and return. + */ + + iPtr->varFramePtr = savedVarFramePtr; + return result; } /* *---------------------------------------------------------------------- * @@ -1008,22 +998,30 @@ */ Proc * TclFindProc( Interp *iPtr, /* Interpreter in which to look. */ - const char *procName) /* Name of desired procedure. */ + CONST char *procName) /* Name of desired procedure. */ { Tcl_Command cmd; + Tcl_Command origCmd; Command *cmdPtr; cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName, NULL, /*flags*/ 0); if (cmd == (Tcl_Command) NULL) { return NULL; } cmdPtr = (Command *) cmd; - return TclIsProc(cmdPtr); + origCmd = TclGetOriginalCommand(cmd); + if (origCmd != NULL) { + cmdPtr = (Command *) origCmd; + } + if (cmdPtr->objProc != TclObjInterpProc) { + return NULL; + } + return (Proc *) cmdPtr->objClientData; } /* *---------------------------------------------------------------------- * @@ -1044,67 +1042,91 @@ Proc * TclIsProc( Command *cmdPtr) /* Command to test. */ { - Tcl_Command origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr); + Tcl_Command origCmd; + origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr); if (origCmd != NULL) { cmdPtr = (Command *) origCmd; } - if (cmdPtr->deleteProc == TclProcDeleteProc) { - return (Proc *)cmdPtr->objClientData; + if (cmdPtr->objProc == TclObjInterpProc) { + return (Proc *) cmdPtr->objClientData; } - return NULL; + return (Proc *) 0; } +/* + *---------------------------------------------------------------------- + * + * InitArgsAndLocals -- + * + * This routine is invoked in order to initialize the arguments and other + * compiled locals table for a new call frame. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Allocates memory on the stack for the compiled local variables, the + * caller is responsible for freeing them. Initialises all variables. May + * invoke various name resolvers in order to determine which variables + * are being referenced at runtime. + * + *---------------------------------------------------------------------- + */ + static int ProcWrongNumArgs( - Tcl_Interp *interp, - int skip) + Tcl_Interp *interp, int skip) { CallFrame *framePtr = ((Interp *)interp)->varFramePtr; - Proc *procPtr = framePtr->procPtr; + register Proc *procPtr = framePtr->procPtr; + register Var *defPtr; 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)); + desiredObjs = (Tcl_Obj **) TclStackAlloc(interp, + (int) sizeof(Tcl_Obj *) * (numArgs+1)); if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) { desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1); } else { + ((Interp *) interp)->ensembleRewrite.numInsertedObjs -= skip - 1; + +#ifdef AVOID_HACKS_FOR_ITCL desiredObjs[0] = framePtr->objv[skip-1]; +#else + desiredObjs[0] = Tcl_NewListObj(skip, framePtr->objv); +#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); - Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), "?", NULL); - } else if (defPtr->flags & VAR_IS_ARGS) { - numArgs--; - final = "?arg ...?"; - break; - } else { - argObj = namePtr; - Tcl_IncrRefCount(namePtr); - } - desiredObjs[i] = argObj; - } + 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); + Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), "?", NULL); + } else if (defPtr->flags & VAR_IS_ARGS) { + numArgs--; + final = "..."; + break; + } else { + argObj = namePtr; + Tcl_IncrRefCount(namePtr); + } + desiredObjs[i] = argObj; } Tcl_ResetResult(interp); Tcl_WrongNumArgs(interp, numArgs+1, desiredObjs, final); @@ -1112,10 +1134,58 @@ Tcl_DecrRefCount(desiredObjs[i]); } TclStackFree(interp, desiredObjs); return TCL_ERROR; } + +/* + *---------------------------------------------------------------------- + * + * TclInitCompiledLocals -- + * + * This routine is invoked in order to initialize the compiled locals + * table for a new call frame. + * + * DEPRECATED: functionality has been inlined elsewhere; this function + * remains to insure binary compatibility with Itcl. + * + + * Results: + * None. + * + * Side effects: + * May invoke various name resolvers in order to determine which + * variables are being referenced at runtime. + * + *---------------------------------------------------------------------- + */ +void +TclInitCompiledLocals( + Tcl_Interp *interp, /* Current interpreter. */ + CallFrame *framePtr, /* Call frame to initialize. */ + Namespace *nsPtr) /* Pointer to current namespace. */ +{ + Var *varPtr = framePtr->compiledLocals; + Tcl_Obj *bodyPtr; + ByteCode *codePtr; + + bodyPtr = framePtr->procPtr->bodyPtr; + if (bodyPtr->typePtr != &tclByteCodeType) { + Tcl_Panic("body object for proc attached to frame is not a byte code type"); + } + codePtr = bodyPtr->internalRep.twoPtrValue.ptr1; + + if (framePtr->numCompiledLocals) { + if (!codePtr->localCachePtr) { + InitLocalCache(framePtr->procPtr) ; + } + framePtr->localCachePtr = codePtr->localCachePtr; + framePtr->localCachePtr->refCount++; + } + + InitResolvedLocals(interp, codePtr, varPtr, nsPtr); +} /* *---------------------------------------------------------------------- * * InitResolvedLocals -- @@ -1155,11 +1225,41 @@ while (varNum--) { localPtr = localPtr->nextPtr; } if (!(haveResolvers && (codePtr->flags & TCL_BYTECODE_RESOLVE_VARS))) { - goto doInitResolvedLocals; + /* + * Initialize the array of local variables stored in the call frame. + * Some variables may have special resolution rules. In that case, we + * call their "resolver" procs to get our hands on the variable, and + * we make the compiled local a link to the real variable. + */ + + doInitResolvedLocals: + for (; localPtr != NULL; varPtr++, localPtr = localPtr->nextPtr) { + varPtr->flags = 0; + varPtr->value.objPtr = NULL; + + /* + * 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; + varPtr->value.linkPtr = resolvedVarPtr; + } + } + } + return; } /* * This is the first run after a recompile, or else the resolver epoch * has changed: update the resolver cache. @@ -1169,11 +1269,11 @@ for (; localPtr != NULL; localPtr = localPtr->nextPtr) { if (localPtr->resolveInfo) { if (localPtr->resolveInfo->deleteProc) { localPtr->resolveInfo->deleteProc(localPtr->resolveInfo); } else { - Tcl_Free(localPtr->resolveInfo); + ckfree((char *) localPtr->resolveInfo); } localPtr->resolveInfo = NULL; } localPtr->flags &= ~VAR_RESOLVED; @@ -1182,20 +1282,20 @@ ResolverScheme *resPtr = iPtr->resolverPtr; Tcl_ResolvedVarInfo *vinfo; int result; if (nsPtr->compiledVarResProc) { - result = nsPtr->compiledVarResProc(nsPtr->interp, + result = (*nsPtr->compiledVarResProc)(nsPtr->interp, localPtr->name, localPtr->nameLength, (Tcl_Namespace *) nsPtr, &vinfo); } else { result = TCL_CONTINUE; } while ((result == TCL_CONTINUE) && resPtr) { if (resPtr->compiledVarResProc) { - result = resPtr->compiledVarResProc(nsPtr->interp, + result = (*resPtr->compiledVarResProc)(nsPtr->interp, localPtr->name, localPtr->nameLength, (Tcl_Namespace *) nsPtr, &vinfo); } resPtr = resPtr->nextPtr; } @@ -1205,44 +1305,13 @@ } } } localPtr = firstLocalPtr; codePtr->flags &= ~TCL_BYTECODE_RESOLVE_VARS; - - /* - * Initialize the array of local variables stored in the call frame. Some - * variables may have special resolution rules. In that case, we call - * their "resolver" procs to get our hands on the variable, and we make - * the compiled local a link to the real variable. - */ - - doInitResolvedLocals: - for (; localPtr != NULL; varPtr++, localPtr = localPtr->nextPtr) { - varPtr->flags = 0; - varPtr->value.objPtr = NULL; - - /* - * 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; - varPtr->value.linkPtr = resolvedVarPtr; - } - } - } -} - + goto doInitResolvedLocals; +} + void TclFreeLocalCache( Tcl_Interp *interp, LocalCache *localCachePtr) { @@ -1249,56 +1318,60 @@ int i; Tcl_Obj **namePtrPtr = &localCachePtr->varName0; for (i = 0; i < localCachePtr->numVars; i++, namePtrPtr++) { Tcl_Obj *objPtr = *namePtrPtr; - + /* + * Note that this can be called with interp==NULL, on interp + * deletion. In that case, the literal table and objects go away + * on their own. + */ if (objPtr) { - /* TclReleaseLiteral calls Tcl_DecrRefCount for us */ - TclReleaseLiteral(interp, objPtr); + if (interp) { + TclReleaseLiteral(interp, objPtr); + } else { + Tcl_DecrRefCount(objPtr); + } } } - Tcl_Free(localCachePtr); + ckfree((char *) localCachePtr); } - + static void -InitLocalCache( - Proc *procPtr) +InitLocalCache(Proc *procPtr) { Interp *iPtr = procPtr->iPtr; - ByteCode *codePtr; + ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; 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); + int new; /* * 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 *)Tcl_Alloc(offsetof(LocalCache, varName0) - + localCt * sizeof(Tcl_Obj *) - + numArgs * sizeof(Var)); + 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 */ -1, - &isNew, /* nsPtr */ NULL, 0, NULL); + localPtr->nameLength, /* hash */ (unsigned int) -1, + &new, /* nsPtr */ NULL, 0, NULL); Tcl_IncrRefCount(*namePtr); } if (i < numArgs) { varPtr->flags = (localPtr->flags & VAR_IS_ARGS); @@ -1305,53 +1378,32 @@ varPtr->value.objPtr = localPtr->defValuePtr; varPtr++; i++; } namePtr++; - localPtr = localPtr->nextPtr; + localPtr=localPtr->nextPtr; } codePtr->localCachePtr = localCachePtr; localCachePtr->refCount = 1; - localCachePtr->numVars = localCt; -} - -/* - *---------------------------------------------------------------------- - * - * InitArgsAndLocals -- - * - * This routine is invoked in order to initialize the arguments and other - * compiled locals table for a new call frame. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Allocates memory on the stack for the compiled local variables, the - * caller is responsible for freeing them. Initialises all variables. May - * invoke various name resolvers in order to determine which variables - * are being referenced at runtime. - * - *---------------------------------------------------------------------- - */ + localCachePtr->numVars = localCt; +} static int InitArgsAndLocals( - Tcl_Interp *interp,/* Interpreter in which procedure was + register 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". */ { CallFrame *framePtr = ((Interp *)interp)->varFramePtr; - Proc *procPtr = framePtr->procPtr; - ByteCode *codePtr; - Var *varPtr, *defPtr; + register Proc *procPtr = framePtr->procPtr; + ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; + register 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 * been initialised properly . */ @@ -1370,11 +1422,11 @@ * 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)); + varPtr = (Var*) TclStackAlloc(interp, (int)(localCt*sizeof(Var))); framePtr->compiledLocals = varPtr; framePtr->numCompiledLocals = localCt; /* * Match and assign the call's actual parameters to the procedure's formal @@ -1393,11 +1445,11 @@ } else { goto correctArgs; } } imax = ((argCt < numArgs-1) ? argCt : numArgs-1); - for (i = 0; i < imax; i++, varPtr++, defPtr ? defPtr++ : defPtr) { + for (i = 0; i < imax; i++, varPtr++, defPtr++) { /* * "Normal" arguments; last formal is special, depends on it being * 'args'. */ @@ -1405,43 +1457,45 @@ varPtr->flags = 0; varPtr->value.objPtr = objPtr; Tcl_IncrRefCount(objPtr); /* Local var is a reference. */ } - for (; i < numArgs-1; i++, varPtr++, defPtr ? defPtr++ : defPtr) { + for (; i < numArgs-1; i++, varPtr++, defPtr++) { /* * This loop is entered if argCt < (numArgs-1). Set default values; * last formal is special. */ - Tcl_Obj *objPtr = defPtr ? defPtr->value.objPtr : NULL; + Tcl_Obj *objPtr = defPtr->value.objPtr; - if (!objPtr) { + if (objPtr) { + varPtr->flags = 0; + varPtr->value.objPtr = objPtr; + Tcl_IncrRefCount(objPtr); /* Local var reference. */ + } else { goto incorrectArgs; } - varPtr->flags = 0; - varPtr->value.objPtr = objPtr; - Tcl_IncrRefCount(objPtr); /* Local var reference. */ } /* * When we get here, the last formal argument remains to be defined: * defPtr and varPtr point to the last argument to be initialized. */ + varPtr->flags = 0; - if (defPtr && defPtr->flags & VAR_IS_ARGS) { + if (defPtr->flags & VAR_IS_ARGS) { Tcl_Obj *listPtr = Tcl_NewListObj(argCt-i, argObjs+i); varPtr->value.objPtr = listPtr; Tcl_IncrRefCount(listPtr); /* Local var is a reference. */ } else if (argCt == numArgs) { Tcl_Obj *objPtr = argObjs[i]; varPtr->value.objPtr = objPtr; Tcl_IncrRefCount(objPtr); /* Local var is a reference. */ - } else if ((argCt < numArgs) && defPtr && defPtr->value.objPtr) { + } else if ((argCt < numArgs) && (defPtr->value.objPtr != NULL)) { Tcl_Obj *objPtr = defPtr->value.objPtr; varPtr->value.objPtr = objPtr; Tcl_IncrRefCount(objPtr); /* Local var is a reference. */ } else { @@ -1454,38 +1508,33 @@ * resolvers, they are undefined local vars: (flags=0, value=NULL). */ correctArgs: if (numArgs < localCt) { - if (!framePtr->nsPtr->compiledVarResProc - && !((Interp *)interp)->resolverPtr) { + if (!framePtr->nsPtr->compiledVarResProc && !((Interp *)interp)->resolverPtr) { memset(varPtr, 0, (localCt - numArgs)*sizeof(Var)); } else { InitResolvedLocals(interp, codePtr, varPtr, framePtr->nsPtr); } } return TCL_OK; + + incorrectArgs: /* * Initialise all compiled locals to avoid problems at DeleteLocalVars. */ - incorrectArgs: - if ((skip != 1) && - TclInitRewriteEnsemble(interp, skip-1, 0, framePtr->objv)) { - TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); - } - memset(varPtr, 0, - ((framePtr->compiledLocals + localCt)-varPtr) * sizeof(Var)); + memset(varPtr, 0, ((framePtr->compiledLocals + localCt)-varPtr)*sizeof(Var)); return ProcWrongNumArgs(interp, skip); } /* *---------------------------------------------------------------------- * - * TclPushProcCallFrame -- + * PushProcCallFrame -- * * Compiles a proc body if necessary, then pushes a CallFrame suitable * for executing it. * * Results: @@ -1496,23 +1545,23 @@ * to be popped by the caller. * *---------------------------------------------------------------------- */ -int -TclPushProcCallFrame( - ClientData clientData, /* Record describing procedure to be +static int +PushProcCallFrame( + ClientData clientData, /* Record describing procedure to be * interpreted. */ - Tcl_Interp *interp,/* Interpreter in which procedure was + register 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. */ + 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; + Proc *procPtr = (Proc *) clientData; Namespace *nsPtr = procPtr->cmdPtr->nsPtr; CallFrame *framePtr, **framePtrPtr; int result; ByteCode *codePtr; @@ -1522,12 +1571,11 @@ * slots for the procedure's non-argument local variables. Note that * compiling the body might increase procPtr->numCompiledLocals if new * local variables are found while compiling. */ - ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); - if (codePtr != NULL) { + if (procPtr->bodyPtr->typePtr == &tclByteCodeType) { Interp *iPtr = (Interp *) interp; /* * When we've got bytecode, this is the check for validity. That is, * the bytecode must be for the right interpreter (no cross-leaks!), @@ -1535,21 +1583,22 @@ * is up-to-date), the namespace must match (so variable handling * is right) and the resolverEpoch must match (so that new shadowed * commands and/or resolver changes are considered). */ - if (((Interp *) *codePtr->interpHandle != iPtr) + codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; + if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != nsPtr) || (codePtr->nsEpoch != nsPtr->resolverEpoch)) { goto doCompilation; } } else { doCompilation: - result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr, + result = ProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr, (isLambda ? "body of lambda term" : "body of proc"), - TclGetString(objv[isLambda])); + TclGetString(objv[isLambda]), &procPtr); if (result != TCL_OK) { return result; } } @@ -1560,13 +1609,16 @@ * its command, which can change if the command is renamed from one * namespace to another. */ framePtrPtr = &framePtr; - (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, + result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, (Tcl_Namespace *) nsPtr, (isLambda? (FRAME_IS_PROC|FRAME_IS_LAMBDA) : FRAME_IS_PROC)); + if (result != TCL_OK) { + return result; + } framePtr->objc = objc; framePtr->objv = objv; framePtr->procPtr = procPtr; @@ -1590,48 +1642,32 @@ *---------------------------------------------------------------------- */ 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); - - if (result != TCL_OK) { - return TCL_ERROR; - } - return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError); -} - -/* - *---------------------------------------------------------------------- - * - * TclNRInterpProcCore -- + ClientData clientData, /* Record describing procedure to be + * interpreted. */ + register 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; + + result = PushProcCallFrame(clientData, interp, objc, objv, /*isLambda*/ 0); + if (result == TCL_OK) { + return TclObjInterpProcCore(interp, objv[0], 1, &MakeProcError); + } else { + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclObjInterpProcCore -- * * When a Tcl procedure, lambda term or anything else that works like a * procedure gets invoked during bytecode evaluation, this object-based * routine gets invoked to interpret the body. * @@ -1643,39 +1679,33 @@ * *---------------------------------------------------------------------- */ int -TclNRInterpProcCore( - Tcl_Interp *interp,/* Interpreter in which procedure was +TclObjInterpProcCore( + register 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 + ProcErrorProc errorProc) /* How to convert results from the script into * results of the overall procedure. */ { Interp *iPtr = (Interp *) interp; - Proc *procPtr = iPtr->varFramePtr->procPtr; + register Proc *procPtr = iPtr->varFramePtr->procPtr; int result; CallFrame *freePtr; - ByteCode *codePtr; - result = InitArgsAndLocals(interp, skip); + result = InitArgsAndLocals(interp, procNameObj, 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; + goto procDone; } #if defined(TCL_COMPILE_DEBUG) if (tclTraceExec >= 1) { - CallFrame *framePtr = iPtr->varFramePtr; - int i; + register CallFrame *framePtr = iPtr->varFramePtr; + register int i; if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) { fprintf(stdout, "Calling lambda "); } else { fprintf(stdout, "Calling proc "); @@ -1689,116 +1719,75 @@ } #endif /*TCL_COMPILE_DEBUG*/ #ifdef USE_DTRACE if (TCL_DTRACE_PROC_ARGS_ENABLED()) { + char *a[10]; + int i = 0; int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; - const char *a[10]; - int i; - for (i = 0 ; i < 10 ; i++) { + while (i < 10) { a[i] = (l < iPtr->varFramePtr->objc ? - TclGetString(iPtr->varFramePtr->objv[l]) : NULL); - l++; + TclGetString(iPtr->varFramePtr->objv[l]) : NULL); i++; l++; } TCL_DTRACE_PROC_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8], a[9]); } if (TCL_DTRACE_PROC_INFO_ENABLED() && iPtr->cmdFramePtr) { Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr); - const char *a[6]; int i[2]; + char *a[4]; int i[2]; TclDTraceInfo(info, a, i); - TCL_DTRACE_PROC_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); + TCL_DTRACE_PROC_INFO(a[0], a[1], a[2], a[3], i[0], i[1]); TclDecrRefCount(info); } - if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { - int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; - - TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ? - TclGetString(iPtr->varFramePtr->objv[l]) : NULL, - iPtr->varFramePtr->objc - l - 1, - (Tcl_Obj **)(iPtr->varFramePtr->objv + l + 1)); - } - if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { - int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; - - TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ? - TclGetString(iPtr->varFramePtr->objv[l]) : NULL, - iPtr->varFramePtr->objc - l - 1, - (Tcl_Obj **)(iPtr->varFramePtr->objv + l + 1)); - } #endif /* USE_DTRACE */ /* * Invoke the commands in the procedure's body. */ procPtr->refCount++; - ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); - - TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc, - NULL, NULL); - return TclNRExecuteByteCode(interp, codePtr); -} - -static int -InterpProcNR2( - 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); - } - if (procPtr->refCount-- <= 1) { + iPtr->numLevels++; + + if (TclInterpReady(interp) == TCL_ERROR) { + result = TCL_ERROR; + } else { + register ByteCode *codePtr = + procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; + + codePtr->refCount++; +#ifdef USE_DTRACE + if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { + int l; + + l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 2 : 1; + TCL_DTRACE_PROC_ENTRY(TclGetString(procNameObj), + iPtr->varFramePtr->objc - l, + (Tcl_Obj **)(iPtr->varFramePtr->objv + l)); + } +#endif /* USE_DTRACE */ + result = TclExecuteByteCode(interp, codePtr); + if (TCL_DTRACE_PROC_RETURN_ENABLED()) { + TCL_DTRACE_PROC_RETURN(TclGetString(procNameObj), result); + } + codePtr->refCount--; + if (codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } + } + + iPtr->numLevels--; + procPtr->refCount--; + if (procPtr->refCount <= 0) { TclProcCleanupProc(procPtr); } /* - * Free the stack-allocated compiled locals and CallFrame. It is important - * to pop the call frame without freeing it first: the compiledLocals - * cannot be freed before the frame is popped, as the local variables must - * be deleted. But the compiledLocals must be freed first, as they were - * allocated later on the stack. - */ - - if (result != TCL_OK) { - goto process; - } - - done: - if (TCL_DTRACE_PROC_RESULT_ENABLED()) { - int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; - Tcl_Obj *r = Tcl_GetObjResult(interp); - - TCL_DTRACE_PROC_RESULT(l < iPtr->varFramePtr->objc ? - TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result, - TclGetString(r), r); - } - - freePtr = iPtr->framePtr; - Tcl_PopCallFrame(interp); /* Pop but do not free. */ - TclStackFree(interp, freePtr->compiledLocals); - /* Free compiledLocals. */ - TclStackFree(interp, freePtr); /* Free CallFrame. */ - return result; - - /* - * Process any non-TCL_OK result code. - */ - - process: + * Process the result code. + */ + switch (result) { case TCL_RETURN: /* * If it is a 'return', do the TIP#90 processing now. */ @@ -1811,14 +1800,14 @@ /* * It's an error to get to this point from a 'break' or 'continue', so * transform to an error now. */ - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invoked \"%s\" outside of a loop", - ((result == TCL_BREAK) ? "break" : "continue"))); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", NULL); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "invoked \"", + ((result == TCL_BREAK) ? "break" : "continue"), + "\" outside of a loop", NULL); result = TCL_ERROR; /* FALLTHRU */ case TCL_ERROR: @@ -1826,13 +1815,52 @@ * 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. */ - errorProc(interp, procNameObj); + (*errorProc)(interp, procNameObj); + + default: + /* + * Process other results (OK and non-standard) by doing nothing + * special, skipping directly to the code afterwards that cleans up + * associated memory. + * + * Non-standard results are processed by passing them through quickly. + * This means they all work as exceptions, unwinding the stack quickly + * and neatly. Who knows how well they are handled by third-party code + * though... + */ + + (void) 0; /* do nothing */ + } + +#ifdef USE_DTRACE + if (TCL_DTRACE_PROC_RESULT_ENABLED()) { + Tcl_Obj *r; + + r = Tcl_GetObjResult(interp); + TCL_DTRACE_PROC_RESULT(TclGetString(procNameObj), result, + TclGetString(r), r); } - goto done; +#endif /* USE_DTRACE */ + + procDone: + /* + * Free the stack-allocated compiled locals and CallFrame. It is important + * to pop the call frame without freeing it first: the compiledLocals + * cannot be freed before the frame is popped, as the local variables must + * be deleted. But the compiledLocals must be freed first, as they were + * allocated later on the stack. + */ + + freePtr = iPtr->framePtr; + Tcl_PopCallFrame(interp); /* Pop but do not free. */ + TclStackFree(interp, freePtr->compiledLocals); + /* Free compiledLocals. */ + TclStackFree(interp, freePtr); /* Free CallFrame. */ + return result; } /* *---------------------------------------------------------------------- * @@ -1856,21 +1884,38 @@ int TclProcCompileProc( Tcl_Interp *interp, /* Interpreter containing procedure. */ Proc *procPtr, /* Data associated with procedure. */ Tcl_Obj *bodyPtr, /* Body of proc. (Usually procPtr->bodyPtr, - * but could be any code fragment compiled in - * the context of this procedure.) */ + * but could be any code fragment compiled in + * the context of this procedure.) */ + Namespace *nsPtr, /* Namespace containing procedure. */ + CONST char *description, /* string describing this body of code. */ + CONST char *procName) /* Name of this procedure. */ +{ + return ProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, + procName, NULL); +} + +static int +ProcCompileProc( + Tcl_Interp *interp, /* Interpreter containing procedure. */ + Proc *procPtr, /* Data associated with procedure. */ + Tcl_Obj *bodyPtr, /* Body of proc. (Usually procPtr->bodyPtr, + * but could be any code fragment compiled in + * the context of this procedure.) */ Namespace *nsPtr, /* Namespace containing procedure. */ - const char *description, /* string describing this body of code. */ - const char *procName) /* Name of this procedure. */ + CONST char *description, /* string describing this body of code. */ + CONST char *procName, /* Name of this procedure. */ + Proc **procPtrPtr) /* Points to storage where a replacement + * (Proc *) value may be written. */ { Interp *iPtr = (Interp *) interp; + int i; Tcl_CallFrame *framePtr; - ByteCode *codePtr; - - ByteCodeGetIntRep(bodyPtr, &tclByteCodeType, codePtr); + ByteCode *codePtr = bodyPtr->internalRep.twoPtrValue.ptr1; + CompiledLocal *localPtr; /* * If necessary, compile the procedure's body. The compiler will allocate * frame slots for the procedure's non-argument local variables. If the * ByteCode already exists, make sure it hasn't been invalidated by @@ -1882,104 +1927,126 @@ * * Precompiled procedure bodies, however, are immutable and therefore they * are not recompiled, even if things have changed. */ - if (codePtr != NULL) { - if (((Interp *) *codePtr->interpHandle == iPtr) + if (bodyPtr->typePtr == &tclByteCodeType) { + if (((Interp *) *codePtr->interpHandle == iPtr) && (codePtr->compileEpoch == iPtr->compileEpoch) && (codePtr->nsPtr == nsPtr) && (codePtr->nsEpoch == nsPtr->resolverEpoch)) { return TCL_OK; - } - - if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { - if ((Interp *) *codePtr->interpHandle != iPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "a precompiled script jumped interps", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "CROSSINTERPBYTECODE", NULL); - return TCL_ERROR; - } - codePtr->compileEpoch = iPtr->compileEpoch; - codePtr->nsPtr = nsPtr; } else { - Tcl_StoreIntRep(bodyPtr, &tclByteCodeType, NULL); - codePtr = NULL; - } + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { + if ((Interp *) *codePtr->interpHandle != iPtr) { + Tcl_AppendResult(interp, + "a precompiled script jumped interps", NULL); + return TCL_ERROR; + } + codePtr->compileEpoch = iPtr->compileEpoch; + codePtr->nsPtr = nsPtr; + } else { + bodyPtr->typePtr->freeIntRepProc(bodyPtr); + bodyPtr->typePtr = NULL; + } + } } - - if (codePtr == NULL) { + if (bodyPtr->typePtr != &tclByteCodeType) { Tcl_HashEntry *hePtr; #ifdef TCL_COMPILE_DEBUG - if (tclTraceCompile >= 1) { - /* - * Display a line summarizing the top level command we are about - * to compile. - */ + if (tclTraceCompile >= 1) { + /* + * Display a line summarizing the top level command we are about + * to compile. + */ Tcl_Obj *message; TclNewLiteralStringObj(message, "Compiling "); Tcl_IncrRefCount(message); Tcl_AppendStringsToObj(message, description, " \"", NULL); Tcl_AppendLimitedToObj(message, procName, -1, 50, NULL); - fprintf(stdout, "%s\"\n", TclGetString(message)); + 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. - * - * TRICKY NOTE: Be careful to push a call frame with the proper - * namespace context, so that the byte codes are compiled in the - * appropriate class context. - */ - - iPtr->compiledProcPtr = procPtr; - - if (procPtr->numCompiledLocals > procPtr->numArgs) { - CompiledLocal *clPtr = procPtr->firstLocalPtr; - CompiledLocal *lastPtr = NULL; - int i, numArgs = procPtr->numArgs; - - for (i = 0; i < numArgs; i++) { - lastPtr = clPtr; - clPtr = clPtr->nextPtr; - } - - if (lastPtr) { - lastPtr->nextPtr = NULL; - } else { - procPtr->firstLocalPtr = NULL; - } - procPtr->lastLocalPtr = lastPtr; - while (clPtr) { - CompiledLocal *toFree = clPtr; - - clPtr = clPtr->nextPtr; - if (toFree->resolveInfo) { - if (toFree->resolveInfo->deleteProc) { - toFree->resolveInfo->deleteProc(toFree->resolveInfo); - } else { - Tcl_Free(toFree->resolveInfo); - } - } - Tcl_Free(toFree); - } - procPtr->numCompiledLocals = procPtr->numArgs; - } - - (void) TclPushStackFrame(interp, &framePtr, (Tcl_Namespace *) nsPtr, - /* isProcCallFrame */ 0); + /* + * 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. + * + * TRICKY NOTE: Be careful to push a call frame with the proper + * namespace context, so that the byte codes are compiled in the + * appropriate class context. + */ + + if (procPtrPtr != NULL && procPtr->refCount > 1) { + Tcl_Command token; + Tcl_CmdInfo info; + Proc *newProc = (Proc *) ckalloc(sizeof(Proc)); + + newProc->iPtr = procPtr->iPtr; + newProc->refCount = 1; + newProc->cmdPtr = procPtr->cmdPtr; + token = (Tcl_Command) newProc->cmdPtr; + newProc->bodyPtr = Tcl_DuplicateObj(bodyPtr); + bodyPtr = newProc->bodyPtr; + Tcl_IncrRefCount(bodyPtr); + newProc->numArgs = procPtr->numArgs; + + newProc->numCompiledLocals = newProc->numArgs; + newProc->firstLocalPtr = NULL; + newProc->lastLocalPtr = NULL; + localPtr = procPtr->firstLocalPtr; + for (i=0; inumArgs; i++, localPtr=localPtr->nextPtr) { + CompiledLocal *copy = (CompiledLocal *) ckalloc((unsigned) + (sizeof(CompiledLocal) - sizeof(localPtr->name) + + localPtr->nameLength + 1)); + + if (newProc->firstLocalPtr == NULL) { + newProc->firstLocalPtr = newProc->lastLocalPtr = copy; + } else { + newProc->lastLocalPtr->nextPtr = copy; + newProc->lastLocalPtr = copy; + } + copy->nextPtr = NULL; + copy->nameLength = localPtr->nameLength; + copy->frameIndex = localPtr->frameIndex; + copy->flags = localPtr->flags; + copy->defValuePtr = localPtr->defValuePtr; + if (copy->defValuePtr) { + Tcl_IncrRefCount(copy->defValuePtr); + } + copy->resolveInfo = localPtr->resolveInfo; + memcpy(copy->name, localPtr->name, localPtr->nameLength + 1); + } + + /* + * Reset the ClientData + */ + + Tcl_GetCommandInfoFromToken(token, &info); + if (info.objClientData == (ClientData) procPtr) { + info.objClientData = (ClientData) newProc; + } + if (info.clientData == (ClientData) procPtr) { + info.clientData = (ClientData) newProc; + } + if (info.deleteData == (ClientData) procPtr) { + info.deleteData = (ClientData) newProc; + } + Tcl_SetCommandInfoFromToken(token, &info); + + procPtr->refCount--; + *procPtrPtr = procPtr = newProc; + } + iPtr->compiledProcPtr = procPtr; + + (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). */ @@ -1989,12 +2056,13 @@ /* * 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 = + (hePtr ? (CmdFrame *) Tcl_GetHashValue(hePtr) : NULL); + (void) tclByteCodeType.setFromAnyProc(interp, bodyPtr); iPtr->invokeCmdFramePtr = NULL; TclPopStackFrame(interp); } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) { /* * The resolver epoch has changed, but we only need to invalidate the @@ -2030,19 +2098,18 @@ 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. */ { - unsigned int overflow, limit = 60; - size_t nameLen; - const char *procName = TclGetStringFromObj(procNameObj, &nameLen); + int overflow, limit = 60, nameLen; + const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); overflow = (nameLen > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (procedure \"%.*s%s\" line %d)", - (int)(overflow ? limit :nameLen), procName, - (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); + (overflow ? limit : nameLen), procName, + (overflow ? "..." : ""), interp->errorLine)); } /* *---------------------------------------------------------------------- * @@ -2065,13 +2132,14 @@ void TclProcDeleteProc( ClientData clientData) /* Procedure to be deleted. */ { - Proc *procPtr = (Proc *)clientData; + Proc *procPtr = (Proc *) clientData; - if (procPtr->refCount-- <= 1) { + procPtr->refCount--; + if (procPtr->refCount <= 0) { TclProcCleanupProc(procPtr); } } /* @@ -2091,13 +2159,13 @@ *---------------------------------------------------------------------- */ void TclProcCleanupProc( - Proc *procPtr) /* Procedure to be deleted. */ + register Proc *procPtr) /* Procedure to be deleted. */ { - CompiledLocal *localPtr; + register CompiledLocal *localPtr; Tcl_Obj *bodyPtr = procPtr->bodyPtr; Tcl_Obj *defPtr; Tcl_ResolvedVarInfo *resVarInfo; Tcl_HashEntry *hePtr = NULL; CmdFrame *cfPtr = NULL; @@ -2110,29 +2178,30 @@ CompiledLocal *nextPtr = localPtr->nextPtr; resVarInfo = localPtr->resolveInfo; if (resVarInfo) { if (resVarInfo->deleteProc) { - resVarInfo->deleteProc(resVarInfo); + (*resVarInfo->deleteProc)(resVarInfo); } else { - Tcl_Free(resVarInfo); + ckfree((char *) resVarInfo); } } if (localPtr->defValuePtr != NULL) { defPtr = localPtr->defValuePtr; Tcl_DecrRefCount(defPtr); } - Tcl_Free(localPtr); + ckfree((char *) localPtr); localPtr = nextPtr; } - Tcl_Free(procPtr); + ckfree((char *) 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. + * procbody structures created by tbcload. See also Tcl_ProcObjCmd(), when + * the same ProcPtr is overwritten with a new CmdFrame. */ if (iPtr == NULL) { return; } @@ -2140,20 +2209,20 @@ hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, (char *) procPtr); if (!hePtr) { return; } - cfPtr = (CmdFrame *)Tcl_GetHashValue(hePtr); + cfPtr = (CmdFrame *) Tcl_GetHashValue(hePtr); if (cfPtr) { if (cfPtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(cfPtr->data.eval.path); cfPtr->data.eval.path = NULL; } - Tcl_Free(cfPtr->line); + ckfree((char *) cfPtr->line); cfPtr->line = NULL; - Tcl_Free(cfPtr); + ckfree((char *) cfPtr); } Tcl_DeleteHashEntry(hePtr); } /* @@ -2259,11 +2328,14 @@ return NULL; } TclNewObj(objPtr); if (objPtr) { - ProcSetIntRep(objPtr, procPtr); + objPtr->typePtr = &tclProcBodyType; + objPtr->internalRep.twoPtrValue.ptr1 = procPtr; + + procPtr->refCount++; } return objPtr; } @@ -2287,14 +2359,15 @@ static void ProcBodyDup( Tcl_Obj *srcPtr, /* Object to copy. */ Tcl_Obj *dupPtr) /* Target object for the duplication. */ { - Proc *procPtr; - ProcGetIntRep(srcPtr, procPtr); + Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1; - ProcSetIntRep(dupPtr, procPtr); + dupPtr->typePtr = &tclProcBodyType; + dupPtr->internalRep.twoPtrValue.ptr1 = procPtr; + procPtr->refCount++; } /* *---------------------------------------------------------------------- * @@ -2316,15 +2389,13 @@ static void ProcBodyFree( Tcl_Obj *objPtr) /* The object to clean up. */ { - Proc *procPtr; + Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; - ProcGetIntRep(objPtr, procPtr); - - if (procPtr->refCount-- <= 1) { + if (procPtr->refCount-- < 2) { TclProcCleanupProc(procPtr); } } /* @@ -2342,48 +2413,47 @@ */ static void DupLambdaInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ - Tcl_Obj *copyPtr) /* Object with internal rep to set. */ + register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - Proc *procPtr; - Tcl_Obj *nsObjPtr; + Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1; + Tcl_Obj *nsObjPtr = srcPtr->internalRep.twoPtrValue.ptr2; - LambdaGetIntRep(srcPtr, procPtr, nsObjPtr); - assert(procPtr != NULL); + copyPtr->internalRep.twoPtrValue.ptr1 = procPtr; + copyPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; procPtr->refCount++; - - LambdaSetIntRep(copyPtr, procPtr, nsObjPtr); + Tcl_IncrRefCount(nsObjPtr); + copyPtr->typePtr = &lambdaType; } static void FreeLambdaInternalRep( - Tcl_Obj *objPtr) /* CmdName object with internal representation + register Tcl_Obj *objPtr) /* CmdName object with internal representation * to free. */ { - Proc *procPtr; - Tcl_Obj *nsObjPtr; + Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; + Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2; - LambdaGetIntRep(objPtr, procPtr, nsObjPtr); - assert(procPtr != NULL); - - if (procPtr->refCount-- <= 1) { + procPtr->refCount--; + if (procPtr->refCount == 0) { TclProcCleanupProc(procPtr); } TclDecrRefCount(nsObjPtr); + objPtr->typePtr = NULL; } static int SetLambdaFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr) /* The object to convert. */ + register Tcl_Obj *objPtr) /* The object to convert. */ { Interp *iPtr = (Interp *) interp; - const char *name; - Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv; + char *name; + Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv, *errPtr; int isNew, objc, result; CmdFrame *cfPtr = NULL; Proc *procPtr; if (interp == NULL) { @@ -2395,14 +2465,14 @@ * 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", - TclGetString(objPtr))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", NULL); + TclNewLiteralStringObj(errPtr, "can't interpret \""); + Tcl_AppendObjToObj(errPtr, objPtr); + Tcl_AppendToObj(errPtr, "\" as a lambda expression", -1); + Tcl_SetObjResult(interp, errPtr); return TCL_ERROR; } argsPtr = objv[0]; bodyPtr = objv[1]; @@ -2447,13 +2517,15 @@ * 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)); + CmdFrame *contextPtr; + 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'. @@ -2483,26 +2555,26 @@ /* * Move from approximation (line of list cmd word) to actual * location (line of 2nd list element). */ - cfPtr = (CmdFrame *)Tcl_Alloc(sizeof(CmdFrame)); + cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame)); TclListLines(objPtr, contextPtr->line[1], 2, buf, NULL); cfPtr->level = -1; cfPtr->type = contextPtr->type; - cfPtr->line = (int *)Tcl_Alloc(sizeof(int)); + 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); - cfPtr->cmd = NULL; - cfPtr->len = 0; + cfPtr->cmd.str.cmd = NULL; + cfPtr->cmd.str.len = 0; } /* * 'contextPtr' is going out of scope. Release the reference that * it's holding to the source file path @@ -2510,11 +2582,11 @@ Tcl_DecrRefCount(contextPtr->data.eval.path); } TclStackFree(interp, contextPtr); } - Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr, procPtr, + Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr, (char *) procPtr, &isNew), cfPtr); /* * Set the namespace for this lambda: given by objv[2] understood as a * global reference, or else global per default. @@ -2521,55 +2593,34 @@ */ if (objc == 2) { TclNewLiteralStringObj(nsObjPtr, "::"); } else { - const char *nsName = TclGetString(objv[2]); + char *nsName = TclGetString(objv[2]); if ((*nsName != ':') || (*(nsName+1) != ':')) { TclNewLiteralStringObj(nsObjPtr, "::"); Tcl_AppendObjToObj(nsObjPtr, objv[2]); } else { nsObjPtr = objv[2]; } } + Tcl_IncrRefCount(nsObjPtr); + /* * Free the list internalrep of objPtr - this will free argsPtr, but * bodyPtr retains a reference from the Proc structure. Then finish the * conversion to lambdaType. */ - LambdaSetIntRep(objPtr, procPtr, nsObjPtr); - return TCL_OK; -} - -Proc * -TclGetLambdaFromObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - Tcl_Obj **nsObjPtrPtr) -{ - Proc *procPtr; - Tcl_Obj *nsObjPtr; - - LambdaGetIntRep(objPtr, procPtr, nsObjPtr); - - if (procPtr == NULL) { - if (SetLambdaFromAny(interp, objPtr) != TCL_OK) { - return NULL; - } - LambdaGetIntRep(objPtr, procPtr, nsObjPtr); - } - - assert(procPtr != NULL); - if (procPtr->iPtr != (Interp *)interp) { - return NULL; - } - - *nsObjPtrPtr = nsObjPtr; - return procPtr; + objPtr->typePtr->freeIntRepProc(objPtr); + + objPtr->internalRep.twoPtrValue.ptr1 = procPtr; + objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; + objPtr->typePtr = &lambdaType; + return TCL_OK; } /* *---------------------------------------------------------------------- * @@ -2587,96 +2638,117 @@ *---------------------------------------------------------------------- */ 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; - Tcl_Namespace *nsPtr; - ApplyExtraData *extraPtr; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "lambdaExpr ?arg ...?"); - return TCL_ERROR; - } - - /* - * Set lambdaPtr, convert it to tclLambdaType in the current interp if - * necessary. - */ - - lambdaPtr = objv[1]; - procPtr = TclGetLambdaFromObj(interp, lambdaPtr, &nsObjPtr); - - if (procPtr == NULL) { - return TCL_ERROR; - } - - /* - * Push a call frame for the lambda namespace. - * Note that TclObjInterpProc() will pop it. - */ - - 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; + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + Proc *procPtr = NULL; + Tcl_Obj *lambdaPtr, *nsObjPtr; + int result, isRootEnsemble; + Command cmd; + Tcl_Namespace *nsPtr; + ExtraFrameInfo efi; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "lambdaExpr ?arg1 arg2 ...?"); + return TCL_ERROR; + } + + /* + * Set lambdaPtr, convert it to lambdaType in the current interp if + * necessary. + */ + + lambdaPtr = objv[1]; + if (lambdaPtr->typePtr == &lambdaType) { + procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; + } + +#define JOE_EXTENSION 0 +#if JOE_EXTENSION + else { + /* + * Joe English's suggestion to allow cmdNames to function as lambdas. + * Also requires making tclCmdNameType non-static in tclObj.c + */ + + Tcl_Obj *elemPtr; + int numElem; + + if ((lambdaPtr->typePtr == &tclCmdNameType) || + (TclListObjGetElements(interp, lambdaPtr, &numElem, + &elemPtr) == TCL_OK && numElem == 1)) { + return Tcl_EvalObjv(interp, objc-1, objv+1, 0); + } + } +#endif + + if ((procPtr == NULL) || (procPtr->iPtr != iPtr)) { + result = SetLambdaFromAny(interp, lambdaPtr); + if (result != TCL_OK) { + return result; + } + procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; + } + + memset(&cmd, 0, sizeof(Command)); + procPtr->cmdPtr = &cmd; /* * TIP#280 (semi-)HACK! * - * Using cmd.clientData to tell [info frame] how to render the lambdaPtr. - * The InfoFrameCmd will detect this case by testing cmd.hPtr for NULL. - * This condition holds here because of the memset() above, and nowhere - * else (in the core). Regular commands always have a valid hPtr, and - * lambda's never. + * Using cmd.clientData to tell [info frame] how to render the + * 'lambdaPtr'. The InfoFrameCmd will detect this case by testing cmd.hPtr + * for NULL. This condition holds here because of the 'memset' above, and + * nowhere else (in the core). Regular commands always have a valid + * 'hPtr', and lambda's never. + */ + + efi.length = 1; + efi.fields[0].name = "lambda"; + efi.fields[0].proc = NULL; + efi.fields[0].clientData = lambdaPtr; + cmd.clientData = &efi; + + /* + * Find the namespace where this lambda should run, and push a call frame + * for that namespace. Note that TclObjInterpProc() will pop it. */ - extraPtr->efi.length = 1; - extraPtr->efi.fields[0].name = "lambda"; - extraPtr->efi.fields[0].proc = NULL; - extraPtr->efi.fields[0].clientData = lambdaPtr; - extraPtr->cmd.clientData = &extraPtr->efi; + nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2; + result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); + if (result != TCL_OK) { + return result; + } + + cmd.nsPtr = (Namespace *) nsPtr; + + isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); + if (isRootEnsemble) { + iPtr->ensembleRewrite.sourceObjs = objv; + iPtr->ensembleRewrite.numRemovedObjs = 1; + iPtr->ensembleRewrite.numInsertedObjs = 0; + } else { + iPtr->ensembleRewrite.numInsertedObjs -= 1; + } - result = TclPushProcCallFrame(procPtr, interp, objc, objv, 1); + result = PushProcCallFrame((ClientData) procPtr, interp, objc, objv, 1); if (result == TCL_OK) { - TclNRAddCallback(interp, ApplyNR2, extraPtr, NULL, NULL, NULL); - result = TclNRInterpProcCore(interp, objv[1], 2, &MakeLambdaError); - } - return result; -} - -static int -ApplyNR2( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - ApplyExtraData *extraPtr = (ApplyExtraData *)data[0]; - - TclStackFree(interp, extraPtr); + result = TclObjInterpProcCore(interp, objv[1], 2, &MakeLambdaError); + } + + if (isRootEnsemble) { + iPtr->ensembleRewrite.sourceObjs = NULL; + iPtr->ensembleRewrite.numRemovedObjs = 0; + iPtr->ensembleRewrite.numInsertedObjs = 0; + } + return result; } /* *---------------------------------------------------------------------- @@ -2701,58 +2773,146 @@ 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. */ { - unsigned int overflow, limit = 60; - size_t nameLen; - const char *procName = TclGetStringFromObj(procNameObj, &nameLen); + int overflow, limit = 60, nameLen; + const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); overflow = (nameLen > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (lambda term \"%.*s%s\" line %d)", - (int)(overflow ? limit : nameLen), procName, - (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); + (overflow ? limit : nameLen), procName, + (overflow ? "..." : ""), interp->errorLine)); } + /* *---------------------------------------------------------------------- * - * TclGetCmdFrameForProcedure -- - * - * How to get the CmdFrame information for a procedure. - * - * Results: - * A pointer to the CmdFrame (only guaranteed to be valid until the next - * Tcl command is processed or the interpreter's state is otherwise - * modified) or a NULL if the information is not available. - * - * Side effects: - * none. + * Tcl_DisassembleObjCmd -- + * + * Implementation of the "::tcl::unsupported::disassemble" command. This + * command is not documented, but will disassemble procedures, lambda + * terms and general scripts. Note that will compile terms if necessary + * in order to disassemble them. * *---------------------------------------------------------------------- */ -CmdFrame * -TclGetCmdFrameForProcedure( - Proc *procPtr) /* The procedure whose cmd-frame is to be - * looked up. */ -{ - Tcl_HashEntry *hePtr; - - if (procPtr == NULL || procPtr->iPtr == NULL) { - return NULL; - } - hePtr = Tcl_FindHashEntry(procPtr->iPtr->linePBodyPtr, procPtr); - if (hePtr == NULL) { - return NULL; - } - return (CmdFrame *) Tcl_GetHashValue(hePtr); +int +Tcl_DisassembleObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ +{ + static const char *types[] = { + "lambda", "proc", "script", NULL + }; + enum Types { + DISAS_LAMBDA, DISAS_PROC, DISAS_SCRIPT + }; + int idx, result; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "type procName|lambdaTerm|script"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], types, "type", 0, &idx)!=TCL_OK){ + return TCL_ERROR; + } + + switch ((enum Types) idx) { + case DISAS_LAMBDA: { + Proc *procPtr = NULL; + Command cmd; + Tcl_Obj *nsObjPtr; + Tcl_Namespace *nsPtr; + + /* + * Compile (if uncompiled) and disassemble a lambda term. + */ + + if (objv[2]->typePtr == &lambdaType) { + procPtr = objv[2]->internalRep.twoPtrValue.ptr1; + } + if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) { + result = SetLambdaFromAny(interp, objv[2]); + if (result != TCL_OK) { + return result; + } + procPtr = objv[2]->internalRep.twoPtrValue.ptr1; + } + + memset(&cmd, 0, sizeof(Command)); + nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2; + result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); + if (result != TCL_OK) { + return result; + } + cmd.nsPtr = (Namespace *) nsPtr; + procPtr->cmdPtr = &cmd; + result = PushProcCallFrame(procPtr, interp, objc, objv, 1); + if (result != TCL_OK) { + return result; + } + TclPopStackFrame(interp); + if (((ByteCode *) procPtr->bodyPtr->internalRep.twoPtrValue.ptr1)->flags + & TCL_BYTECODE_PRECOMPILED) { + Tcl_AppendResult(interp, "may not disassemble prebuilt bytecode", + NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(procPtr->bodyPtr)); + break; + } + case DISAS_PROC: { + Proc *procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); + + if (procPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[2]), + "\" isn't a procedure", NULL); + return TCL_ERROR; + } + + /* + * Compile (if uncompiled) and disassemble a procedure. + */ + + result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1); + if (result != TCL_OK) { + return result; + } + TclPopStackFrame(interp); + if (((ByteCode *) procPtr->bodyPtr->internalRep.twoPtrValue.ptr1)->flags + & TCL_BYTECODE_PRECOMPILED) { + Tcl_AppendResult(interp, "may not disassemble prebuilt bytecode", + NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(procPtr->bodyPtr)); + break; + } + case DISAS_SCRIPT: + /* + * Compile and disassemble a script. + */ + + if (objv[2]->typePtr != &tclByteCodeType) { + if (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK){ + return TCL_ERROR; + } + } + Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(objv[2])); + break; + } + return TCL_OK; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ DELETED generic/tclProcess.c Index: generic/tclProcess.c ================================================================== --- generic/tclProcess.c +++ /dev/null @@ -1,958 +0,0 @@ -/* - * tclProcess.c -- - * - * This file implements the "tcl::process" ensemble for subprocess - * management as defined by TIP #462. - * - * Copyright (c) 2017 Frederic Bonnet. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include "tclInt.h" - -/* - * Autopurge flag. Process-global because of the way Tcl manages child - * processes (see tclPipe.c). - */ - -static int autopurge = 1; /* Autopurge flag. */ - -/* - * Hash tables that keeps track of all child process statuses. Keys are the - * child process ids and resolved pids, values are (ProcessInfo *). - */ - -typedef struct ProcessInfo { - Tcl_Pid pid; /* Process id. */ - int resolvedPid; /* Resolved process id. */ - int purge; /* Purge eventualy. */ - TclProcessWaitStatus status;/* Process status. */ - int code; /* Error code, exit status or signal - number. */ - Tcl_Obj *msg; /* Error message. */ - Tcl_Obj *error; /* Error code. */ -} ProcessInfo; -static Tcl_HashTable infoTablePerPid; -static Tcl_HashTable infoTablePerResolvedPid; -static int infoTablesInitialized = 0; /* 0 means not yet initialized. */ -TCL_DECLARE_MUTEX(infoTablesMutex) - - /* - * Prototypes for functions defined later in this file: - */ - -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, size_t 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, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int ProcessPurgeObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int ProcessAutopurgeObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); - -/* - *---------------------------------------------------------------------- - * - * InitProcessInfo -- - * - * Initializes the ProcessInfo structure. - * - * Results: - * None. - * - * Side effects: - * Memory written. - * - *---------------------------------------------------------------------- - */ - -void -InitProcessInfo( - ProcessInfo *info, /* Structure to initialize. */ - Tcl_Pid pid, /* Process id. */ - int resolvedPid) /* Resolved process id. */ -{ - info->pid = pid; - info->resolvedPid = resolvedPid; - info->purge = 0; - info->status = TCL_PROCESS_UNCHANGED; - info->code = 0; - info->msg = NULL; - info->error = NULL; -} - -/* - *---------------------------------------------------------------------- - * - * FreeProcessInfo -- - * - * Free the ProcessInfo structure. - * - * Results: - * None. - * - * Side effects: - * Memory deallocated, Tcl_Obj refcount decreased. - * - *---------------------------------------------------------------------- - */ - -void -FreeProcessInfo( - ProcessInfo *info) /* Structure to free. */ -{ - /* - * Free stored Tcl_Objs. - */ - - if (info->msg) { - Tcl_DecrRefCount(info->msg); - } - if (info->error) { - Tcl_DecrRefCount(info->error); - } - - /* - * Free allocated structure. - */ - - Tcl_Free(info); -} - -/* - *---------------------------------------------------------------------- - * - * RefreshProcessInfo -- - * - * Refresh process info. - * - * Results: - * Nonzero if state changed, else zero. - * - * Side effects: - * May call WaitProcessStatus, which can block if WNOHANG option is set. - * - *---------------------------------------------------------------------- - */ - -int -RefreshProcessInfo( - ProcessInfo *info, /* Structure to refresh. */ - int options /* Options passed to WaitProcessStatus. */ -) -{ - if (info->status == TCL_PROCESS_UNCHANGED) { - /* - * Refresh & store status. - */ - - info->status = WaitProcessStatus(info->pid, info->resolvedPid, - options, &info->code, &info->msg, &info->error); - if (info->msg) Tcl_IncrRefCount(info->msg); - if (info->error) Tcl_IncrRefCount(info->error); - return (info->status != TCL_PROCESS_UNCHANGED); - } else { - /* - * No change. - */ - - return 0; - } -} - -/* - *---------------------------------------------------------------------- - * - * WaitProcessStatus -- - * - * Wait for process status to change. - * - * Results: - * TclProcessWaitStatus enum value. - * - * Side effects: - * May call WaitProcessStatus, which can block if WNOHANG option is set. - * - *---------------------------------------------------------------------- - */ - -TclProcessWaitStatus -WaitProcessStatus( - Tcl_Pid pid, /* Process id. */ - size_t resolvedPid, /* Resolved process id. */ - int options, /* Options passed to Tcl_WaitPid. */ - int *codePtr, /* If non-NULL, will receive either: - * - 0 for normal exit. - * - errno in case of error. - * - non-zero exit code for abormal exit. - * - signal number if killed or suspended. - * - Tcl_WaitPid status in all other cases. - */ - Tcl_Obj **msgObjPtr, /* If non-NULL, will receive error message. */ - Tcl_Obj **errorObjPtr) /* If non-NULL, will receive error code. */ -{ - int waitStatus; - Tcl_Obj *errorStrings[5]; - const char *msg; - - pid = Tcl_WaitPid(pid, &waitStatus, options); - if (pid == 0) { - /* - * No change. - */ - - return TCL_PROCESS_UNCHANGED; - } - - /* - * Get process status. - */ - - if (pid == (Tcl_Pid)-1) { - /* - * POSIX errName msg - */ - - msg = Tcl_ErrnoMsg(errno); - if (errno == ECHILD) { - /* - * This changeup in message suggested by Mark Diekhans to - * remind people that ECHILD errors can occur on some - * systems if SIGCHLD isn't in its default state. - */ - - msg = "child process lost (is SIGCHLD ignored or trapped?)"; - } - if (codePtr) *codePtr = errno; - if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( - "error waiting for process to exit: %s", msg); - if (errorObjPtr) { - errorStrings[0] = Tcl_NewStringObj("POSIX", -1); - errorStrings[1] = Tcl_NewStringObj(Tcl_ErrnoId(), -1); - errorStrings[2] = Tcl_NewStringObj(msg, -1); - *errorObjPtr = Tcl_NewListObj(3, errorStrings); - } - return TCL_PROCESS_ERROR; - } else if (WIFEXITED(waitStatus)) { - if (codePtr) *codePtr = WEXITSTATUS(waitStatus); - if (!WEXITSTATUS(waitStatus)) { - /* - * Normal exit. - */ - - if (msgObjPtr) *msgObjPtr = NULL; - if (errorObjPtr) *errorObjPtr = NULL; - } else { - /* - * CHILDSTATUS pid code - * - * Child exited with a non-zero exit status. - */ - - if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj( - "child process exited abnormally", -1); - if (errorObjPtr) { - errorStrings[0] = Tcl_NewStringObj("CHILDSTATUS", -1); - TclNewIntObj(errorStrings[1], resolvedPid); - TclNewIntObj(errorStrings[2], WEXITSTATUS(waitStatus)); - *errorObjPtr = Tcl_NewListObj(3, errorStrings); - } - } - return TCL_PROCESS_EXITED; - } else if (WIFSIGNALED(waitStatus)) { - /* - * CHILDKILLED pid sigName msg - * - * Child killed because of a signal. - */ - - msg = Tcl_SignalMsg(WTERMSIG(waitStatus)); - if (codePtr) *codePtr = WTERMSIG(waitStatus); - if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( - "child killed: %s", msg); - if (errorObjPtr) { - errorStrings[0] = Tcl_NewStringObj("CHILDKILLED", -1); - TclNewIntObj(errorStrings[1], resolvedPid); - errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WTERMSIG(waitStatus)), -1); - errorStrings[3] = Tcl_NewStringObj(msg, -1); - *errorObjPtr = Tcl_NewListObj(4, errorStrings); - } - return TCL_PROCESS_SIGNALED; - } else if (WIFSTOPPED(waitStatus)) { - /* - * CHILDSUSP pid sigName msg - * - * Child suspended because of a signal. - */ - - msg = Tcl_SignalMsg(WSTOPSIG(waitStatus)); - if (codePtr) *codePtr = WSTOPSIG(waitStatus); - if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( - "child suspended: %s", msg); - if (errorObjPtr) { - errorStrings[0] = Tcl_NewStringObj("CHILDSUSP", -1); - TclNewIntObj(errorStrings[1], resolvedPid); - errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WSTOPSIG(waitStatus)), -1); - errorStrings[3] = Tcl_NewStringObj(msg, -1); - *errorObjPtr = Tcl_NewListObj(4, errorStrings); - } - return TCL_PROCESS_STOPPED; - } else { - /* - * TCL OPERATION EXEC ODDWAITRESULT - * - * Child wait status didn't make sense. - */ - - if (codePtr) *codePtr = waitStatus; - if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj( - "child wait status didn't make sense\n", -1); - if (errorObjPtr) { - errorStrings[0] = Tcl_NewStringObj("TCL", -1); - errorStrings[1] = Tcl_NewStringObj("OPERATION", -1); - errorStrings[2] = Tcl_NewStringObj("EXEC", -1); - errorStrings[3] = Tcl_NewStringObj("ODDWAITRESULT", -1); - TclNewIntObj(errorStrings[4], resolvedPid); - *errorObjPtr = Tcl_NewListObj(5, errorStrings); - } - return TCL_PROCESS_UNKNOWN_STATUS; - } -} - - -/* - *---------------------------------------------------------------------- - * - * BuildProcessStatusObj -- - * - * Build a list object with process status. The first element is always - * a standard Tcl return value, which can be either TCL_OK or TCL_ERROR. - * In the latter case, the second element is the error message and the - * third element is a Tcl error code (see tclvars). - * - * Results: - * A list object. - * - * Side effects: - * Tcl_Objs are created. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -BuildProcessStatusObj( - ProcessInfo *info) -{ - Tcl_Obj *resultObjs[3]; - - if (info->status == TCL_PROCESS_UNCHANGED) { - /* - * Process still running, return empty obj. - */ - - return Tcl_NewObj(); - } - if (info->status == TCL_PROCESS_EXITED && info->code == 0) { - /* - * Normal exit, return TCL_OK. - */ - - return Tcl_NewWideIntObj(TCL_OK); - } - - /* - * Abnormal exit, return {TCL_ERROR msg error} - */ - - TclNewIntObj(resultObjs[0], TCL_ERROR); - resultObjs[1] = info->msg; - resultObjs[2] = info->error; - return Tcl_NewListObj(3, resultObjs); -} - -/*---------------------------------------------------------------------- - * - * ProcessListObjCmd -- - * - * This function implements the 'tcl::process list' Tcl command. - * Refer to the user documentation for details on what it does. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * 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; - ProcessInfo *info; - - if (objc != 1) { - Tcl_WrongNumArgs(interp, 1, objv, NULL); - return TCL_ERROR; - } - - /* - * Return the list of all chid process ids. - */ - - list = Tcl_NewListObj(0, NULL); - Tcl_MutexLock(&infoTablesMutex); - for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); - entry != NULL; entry = Tcl_NextHashEntry(&search)) { - info = (ProcessInfo *) Tcl_GetHashValue(entry); - Tcl_ListObjAppendElement(interp, list, - Tcl_NewWideIntObj(info->resolvedPid)); - } - Tcl_MutexUnlock(&infoTablesMutex); - Tcl_SetObjResult(interp, list); - return TCL_OK; -} - -/*---------------------------------------------------------------------- - * - * ProcessStatusObjCmd -- - * - * This function implements the 'tcl::process status' Tcl command. - * Refer to the user documentation for details on what it does. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Access to the internal structures is protected by infoTablesMutex. - * Calls RefreshProcessInfo, which can block if -wait switch is given. - * - *---------------------------------------------------------------------- - */ - -static int -ProcessStatusObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Obj *dict; - int index, options = WNOHANG; - Tcl_HashEntry *entry; - Tcl_HashSearch search; - ProcessInfo *info; - int numPids; - Tcl_Obj **pidObjs; - int result; - int i; - int pid; - Tcl_Obj *const *savedobjv = objv; - static const char *const switches[] = { - "-wait", "--", NULL - }; - enum switchesEnum { - STATUS_WAIT, STATUS_LAST - }; - - while (objc > 1) { - if (TclGetString(objv[1])[0] != '-') { - break; - } - if (Tcl_GetIndexFromObj(interp, objv[1], switches, "switches", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } - ++objv; --objc; - if (STATUS_WAIT == (enum switchesEnum) index) { - options = 0; - } else { - break; - } - } - - if (objc != 1 && objc != 2) { - Tcl_WrongNumArgs(interp, 1, savedobjv, "?switches? ?pids?"); - return TCL_ERROR; - } - - if (objc == 1) { - /* - * Return a dict with all child process statuses. - */ - - dict = Tcl_NewDictObj(); - Tcl_MutexLock(&infoTablesMutex); - for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); - entry != NULL; entry = Tcl_NextHashEntry(&search)) { - info = (ProcessInfo *) Tcl_GetHashValue(entry); - RefreshProcessInfo(info, options); - - if (info->purge && autopurge) { - /* - * Purge entry. - */ - - Tcl_DeleteHashEntry(entry); - entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); - Tcl_DeleteHashEntry(entry); - FreeProcessInfo(info); - } else { - /* - * Add to result. - */ - - Tcl_DictObjPut(interp, dict, Tcl_NewWideIntObj(info->resolvedPid), - BuildProcessStatusObj(info)); - } - } - Tcl_MutexUnlock(&infoTablesMutex); - } else { - /* - * Only return statuses of provided processes. - */ - - result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs); - if (result != TCL_OK) { - return result; - } - dict = Tcl_NewDictObj(); - Tcl_MutexLock(&infoTablesMutex); - for (i = 0; i < numPids; i++) { - result = Tcl_GetIntFromObj(interp, pidObjs[i], &pid); - if (result != TCL_OK) { - Tcl_MutexUnlock(&infoTablesMutex); - Tcl_DecrRefCount(dict); - return result; - } - - entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid)); - if (!entry) { - /* - * Skip unknown process. - */ - - continue; - } - - info = (ProcessInfo *) Tcl_GetHashValue(entry); - RefreshProcessInfo(info, options); - - if (info->purge && autopurge) { - /* - * Purge entry. - */ - - Tcl_DeleteHashEntry(entry); - entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); - Tcl_DeleteHashEntry(entry); - FreeProcessInfo(info); - } else { - /* - * Add to result. - */ - - Tcl_DictObjPut(interp, dict, Tcl_NewWideIntObj(info->resolvedPid), - BuildProcessStatusObj(info)); - } - } - Tcl_MutexUnlock(&infoTablesMutex); - } - Tcl_SetObjResult(interp, dict); - return TCL_OK; -} - -/*---------------------------------------------------------------------- - * - * ProcessPurgeObjCmd -- - * - * This function implements the 'tcl::process purge' Tcl command. - * Refer to the user documentation for details on what it does. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * 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; - int numPids; - Tcl_Obj **pidObjs; - int result; - int i; - int pid; - - if (objc != 1 && objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?pids?"); - return TCL_ERROR; - } - - /* - * First reap detached procs so that their purge flag is up-to-date. - */ - - Tcl_ReapDetachedProcs(); - - if (objc == 1) { - /* - * Purge all terminated processes. - */ - - Tcl_MutexLock(&infoTablesMutex); - for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); - entry != NULL; entry = Tcl_NextHashEntry(&search)) { - info = (ProcessInfo *) Tcl_GetHashValue(entry); - if (info->purge) { - Tcl_DeleteHashEntry(entry); - entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); - Tcl_DeleteHashEntry(entry); - FreeProcessInfo(info); - } - } - Tcl_MutexUnlock(&infoTablesMutex); - } else { - /* - * Purge only provided processes. - */ - - result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs); - if (result != TCL_OK) { - return result; - } - Tcl_MutexLock(&infoTablesMutex); - for (i = 0; i < numPids; i++) { - result = Tcl_GetIntFromObj(interp, pidObjs[i], &pid); - if (result != TCL_OK) { - Tcl_MutexUnlock(&infoTablesMutex); - return result; - } - - entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid)); - if (!entry) { - /* - * Skip unknown process. - */ - - continue; - } - - info = (ProcessInfo *) Tcl_GetHashValue(entry); - if (info->purge) { - Tcl_DeleteHashEntry(entry); - entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); - Tcl_DeleteHashEntry(entry); - FreeProcessInfo(info); - } - } - Tcl_MutexUnlock(&infoTablesMutex); - } - - return TCL_OK; -} - -/*---------------------------------------------------------------------- - * - * ProcessAutopurgeObjCmd -- - * - * This function implements the 'tcl::process autopurge' Tcl command. - * Refer to the user documentation for details on what it does. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * 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) { - /* - * Set given value. - */ - - int flag; - int result = Tcl_GetBooleanFromObj(interp, objv[1], &flag); - if (result != TCL_OK) { - return result; - } - - autopurge = !!flag; - } - - /* - * Return current value. - */ - - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(autopurge)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclInitProcessCmd -- - * - * This procedure creates the "tcl::process" Tcl command. See the user - * documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -Tcl_Command -TclInitProcessCmd( - Tcl_Interp *interp) /* Current interpreter. */ -{ - static const EnsembleImplMap processImplMap[] = { - {"list", ProcessListObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1}, - {"status", ProcessStatusObjCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1}, - {"purge", ProcessPurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, - {"autopurge", ProcessAutopurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, - {NULL, NULL, NULL, NULL, NULL, 0} - }; - Tcl_Command processCmd; - - if (infoTablesInitialized == 0) { - Tcl_MutexLock(&infoTablesMutex); - if (infoTablesInitialized == 0) { - Tcl_InitHashTable(&infoTablePerPid, TCL_ONE_WORD_KEYS); - Tcl_InitHashTable(&infoTablePerResolvedPid, TCL_ONE_WORD_KEYS); - infoTablesInitialized = 1; - } - Tcl_MutexUnlock(&infoTablesMutex); - } - - processCmd = TclMakeEnsemble(interp, "::tcl::process", processImplMap); - Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0), - "process", 0); - return processCmd; -} - -/* - *---------------------------------------------------------------------- - * - * TclProcessCreated -- - * - * Called when a child process has been created by Tcl. - * - * Results: - * None. - * - * Side effects: - * Internal structures are updated with a new ProcessInfo. - * - *---------------------------------------------------------------------- - */ - -void -TclProcessCreated( - Tcl_Pid pid) /* Process id. */ -{ - size_t resolvedPid; - Tcl_HashEntry *entry, *entry2; - int isNew; - ProcessInfo *info; - - /* - * Get resolved pid first. - */ - - resolvedPid = TclpGetPid(pid); - - Tcl_MutexLock(&infoTablesMutex); - - /* - * Create entry in pid table. - */ - - entry = Tcl_CreateHashEntry(&infoTablePerPid, pid, &isNew); - if (!isNew) { - /* - * Pid was reused, free old info and reuse structure. - */ - - info = (ProcessInfo *) Tcl_GetHashValue(entry); - entry2 = Tcl_FindHashEntry(&infoTablePerResolvedPid, - INT2PTR(resolvedPid)); - if (entry2) Tcl_DeleteHashEntry(entry2); - FreeProcessInfo(info); - } - - /* - * Allocate and initialize info structure. - */ - - info = (ProcessInfo *)Tcl_Alloc(sizeof(ProcessInfo)); - InitProcessInfo(info, pid, resolvedPid); - - /* - * Add entry to tables. - */ - - Tcl_SetHashValue(entry, info); - entry = Tcl_CreateHashEntry(&infoTablePerResolvedPid, INT2PTR(resolvedPid), - &isNew); - Tcl_SetHashValue(entry, info); - - Tcl_MutexUnlock(&infoTablesMutex); -} - -/* - *---------------------------------------------------------------------- - * - * TclProcessWait -- - * - * Wait for process status to change. - * - * Results: - * TclProcessWaitStatus enum value. - * - * Side effects: - * Completed process info structures are purged immediately (autopurge on) - * or eventually (autopurge off). - * - *---------------------------------------------------------------------- - */ - -TclProcessWaitStatus -TclProcessWait( - Tcl_Pid pid, /* Process id. */ - int options, /* Options passed to WaitProcessStatus. */ - int *codePtr, /* If non-NULL, will receive either: - * - 0 for normal exit. - * - errno in case of error. - * - non-zero exit code for abormal exit. - * - signal number if killed or suspended. - * - Tcl_WaitPid status in all other cases. - */ - Tcl_Obj **msgObjPtr, /* If non-NULL, will receive error message. */ - Tcl_Obj **errorObjPtr) /* If non-NULL, will receive error code. */ -{ - Tcl_HashEntry *entry; - ProcessInfo *info; - TclProcessWaitStatus result; - - /* - * First search for pid in table. - */ - - Tcl_MutexLock(&infoTablesMutex); - entry = Tcl_FindHashEntry(&infoTablePerPid, pid); - if (!entry) { - /* - * Unknown process, just call WaitProcessStatus and return. - */ - - result = WaitProcessStatus(pid, TclpGetPid(pid), options, codePtr, - msgObjPtr, errorObjPtr); - if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr); - if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr); - Tcl_MutexUnlock(&infoTablesMutex); - return result; - } - - info = (ProcessInfo *) Tcl_GetHashValue(entry); - if (info->purge) { - /* - * Process has completed but TclProcessWait has already been called, - * so report no change. - */ - Tcl_MutexUnlock(&infoTablesMutex); - - return TCL_PROCESS_UNCHANGED; - } - - RefreshProcessInfo(info, options); - if (info->status == TCL_PROCESS_UNCHANGED) { - /* - * No change, stop there. - */ - Tcl_MutexUnlock(&infoTablesMutex); - - return TCL_PROCESS_UNCHANGED; - } - - /* - * Set return values. - */ - - result = info->status; - if (codePtr) *codePtr = info->code; - if (msgObjPtr) *msgObjPtr = info->msg; - if (errorObjPtr) *errorObjPtr = info->error; - if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr); - if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr); - - if (autopurge) { - /* - * Purge now. - */ - - Tcl_DeleteHashEntry(entry); - entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, - INT2PTR(info->resolvedPid)); - Tcl_DeleteHashEntry(entry); - FreeProcessInfo(info); - } else { - /* - * Eventually purge. Subsequent calls will return - * TCL_PROCESS_UNCHANGED. - */ - - info->purge = 1; - } - Tcl_MutexUnlock(&infoTablesMutex); - return result; -} Index: generic/tclRegexp.c ================================================================== --- generic/tclRegexp.c +++ generic/tclRegexp.c @@ -11,11 +11,10 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclRegexp.h" -#include /* *---------------------------------------------------------------------- * The routines in this file use Henry Spencer's regular expression package * contained in the following additional source files: @@ -52,27 +51,27 @@ * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * * *** NOTE: this code has been altered slightly for use in Tcl: *** * *** 1. Names have been changed, e.g. from re_comp to *** - * *** TclRegComp, to avoid clashes with other *** - * *** regexp implementations used by applications. *** + * *** TclRegComp, to avoid clashes with other *** + * *** regexp implementations used by applications. *** */ /* * Thread local storage used to maintain a per-thread cache of compiled * regular expressions. */ #define NUM_REGEXPS 30 -typedef struct { +typedef struct ThreadSpecificData { 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. */ - size_t patLengths[NUM_REGEXPS];/* Number of non-null characters in + 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. */ @@ -83,50 +82,33 @@ /* * Declarations for functions used only in this file. */ static TclRegexp * CompileRegexp(Tcl_Interp *interp, const char *pattern, - size_t length, int flags); + 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, size_t numChars, - size_t nmatches, int flags); + 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. */ -const Tcl_ObjType tclRegexpType = { +Tcl_ObjType tclRegexpType = { "regexp", /* name */ FreeRegexpInternalRep, /* freeIntRepProc */ DupRegexpInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ SetRegexpFromAny /* setFromAnyProc */ }; - -#define RegexpSetIntRep(objPtr, rePtr) \ - do { \ - Tcl_ObjIntRep ir; \ - (rePtr)->refCount++; \ - ir.twoPtrValue.ptr1 = (rePtr); \ - ir.twoPtrValue.ptr2 = NULL; \ - 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 -- @@ -188,13 +170,12 @@ 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; - size_t numChars; - TclRegexp *regexp = (TclRegexp *) re; + 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 @@ -249,11 +230,11 @@ void Tcl_RegExpRange( Tcl_RegExp re, /* Compiled regular expression that has been * passed to Tcl_RegExpExec. */ - size_t index, /* 0 means give the range of the entire match, + 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 @@ -260,13 +241,13 @@ * in (sub-)range here. */ { TclRegexp *regexpPtr = (TclRegexp *) re; const char *string; - if (index > regexpPtr->re.re_nsub) { + if ((size_t) index > regexpPtr->re.re_nsub) { *startPtr = *endPtr = NULL; - } else if (regexpPtr->matches[index].rm_so == TCL_INDEX_NONE) { + } else if (regexpPtr->matches[index].rm_so < 0) { *startPtr = *endPtr = NULL; } else { if (regexpPtr->objPtr) { string = TclGetString(regexpPtr->objPtr); } else { @@ -301,25 +282,27 @@ RegExpExecUniChar( Tcl_Interp *interp, /* Interpreter to use for error reporting. */ Tcl_RegExp re, /* Compiled regular expression; returned by a * previous call to Tcl_GetRegExpFromObj */ const Tcl_UniChar *wString, /* String against which to match re. */ - size_t numChars, /* Length of Tcl_UniChar string. */ - size_t nm, /* How many subexpression matches (counting + 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 (nm >= last) { - nm = last; + if (nmatches >= 0 && (size_t) nmatches < nm) { + nm = (size_t) nmatches; } - status = TclReExec(®expPtr->re, wString, numChars, + status = TclReExec(®expPtr->re, wString, (size_t) numChars, ®expPtr->details, nm, regexpPtr->matches, flags); /* * Check for errors. */ @@ -359,27 +342,27 @@ void TclRegExpRangeUniChar( Tcl_RegExp re, /* Compiled regular expression that has been * passed to Tcl_RegExpExec. */ - size_t index, /* 0 means give the range of the entire match, + 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 + * subrange, -1 means the range of the * rm_extend field. */ - size_t *startPtr, /* Store address of first character in + int *startPtr, /* Store address of first character in * (sub-)range here. */ - size_t *endPtr) /* Store address of character just after last + 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)) { + if ((regexpPtr->flags®_EXPECT) && index == -1) { *startPtr = regexpPtr->details.rm_extend.rm_so; *endPtr = regexpPtr->details.rm_extend.rm_eo; - } else if (index + 1 > regexpPtr->re.re_nsub + 1) { - *startPtr = TCL_INDEX_NONE; - *endPtr = TCL_INDEX_NONE; + } else if ((size_t) index > regexpPtr->re.re_nsub) { + *startPtr = -1; + *endPtr = -1; } else { *startPtr = regexpPtr->matches[index].rm_so; *endPtr = regexpPtr->matches[index].rm_eo; } } @@ -406,12 +389,13 @@ Tcl_RegExpMatch( Tcl_Interp *interp, /* Used for error reporting. May be NULL. */ const char *text, /* Text to search for pattern matches. */ const char *pattern) /* Regular expression to match against text. */ { - Tcl_RegExp re = Tcl_RegExpCompile(interp, pattern); + Tcl_RegExp re; + re = Tcl_RegExpCompile(interp, pattern); if (re == NULL) { return -1; } return Tcl_RegExpExec(interp, re, text, text); } @@ -439,23 +423,22 @@ 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. */ - size_t offset, /* Character index that marks where matching + int offset, /* Character index that marks where matching * should begin. */ - size_t nmatches, /* How many subexpression matches (counting + 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; - size_t length; + int length; int reflags = regexpPtr->flags; -#define TCL_REG_GLOBOK_FLAGS \ - (TCL_REG_ADVANCED | TCL_REG_NOSUB | TCL_REG_NOCASE) +#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) * and regexp compile flags. @@ -479,11 +462,11 @@ */ regexpPtr->string = NULL; regexpPtr->objPtr = textObj; - udata = TclGetUnicodeFromObj(textObj, &length); + udata = Tcl_GetUnicodeFromObj(textObj, &length); if (offset > length) { offset = length; } udata += offset; @@ -517,20 +500,13 @@ Tcl_Obj *patternObj) /* Regular expression to match against * string. */ { Tcl_RegExp re; - /* - * For performance reasons, first try compiling the RE without support for - * subexpressions. On failure, try again without TCL_REG_NOSUB in case the - * RE has backreferences in it. Closely related to [Bug 1366683]. If this - * still fails, an error message will be left in the interpreter. - */ - - if (!(re = Tcl_GetRegExpFromObj(interp, patternObj, - TCL_REG_ADVANCED | TCL_REG_NOSUB)) - && !(re = Tcl_GetRegExpFromObj(interp, patternObj, TCL_REG_ADVANCED))) { + re = Tcl_GetRegExpFromObj(interp, patternObj, + TCL_REG_ADVANCED | TCL_REG_NOSUB); + if (re == NULL) { return -1; } return Tcl_RegExpExecObj(interp, re, textObj, 0 /* offset */, 0 /* nmatches */, 0 /* flags */); } @@ -591,25 +567,44 @@ * expression pattern. Internal rep will be * changed to compiled form of this regular * expression. */ int flags) /* Regular expression compilation flags. */ { - size_t length; + int length; TclRegexp *regexpPtr; - const char *pattern; + char *pattern; + + /* + * This is OK because we only actually interpret this value properly as a + * TclRegexp* when the type is tclRegexpType. + */ - RegexpGetIntRep(objPtr, regexpPtr); + regexpPtr = (TclRegexp *) objPtr->internalRep.twoPtrValue.ptr1; - if ((regexpPtr == NULL) || (regexpPtr->flags != flags)) { + if ((objPtr->typePtr != &tclRegexpType) || (regexpPtr->flags != flags)) { pattern = TclGetStringFromObj(objPtr, &length); regexpPtr = CompileRegexp(interp, pattern, length, flags); if (regexpPtr == NULL) { return NULL; } - RegexpSetIntRep(objPtr, regexpPtr); + /* + * Add a reference to the regexp so it will persist even if it is + * pushed out of the current thread's regexp cache. This reference + * will be removed when the object's internal rep is freed. + */ + + regexpPtr->refCount++; + + /* + * Free the old representation and set our type. + */ + + TclFreeIntRep(objPtr); + objPtr->internalRep.twoPtrValue.ptr1 = (void *) regexpPtr; + objPtr->typePtr = &tclRegexpType; } return (Tcl_RegExp) regexpPtr; } /* @@ -657,11 +652,11 @@ {REG_UIMPOSSIBLE, "REG_UIMPOSSIBLE"}, {REG_USHORTEST, "REG_USHORTEST"}, {0, NULL} }; const struct infoname *inf; - Tcl_Obj *infoObj, *resultObj; + Tcl_Obj *infoObj; /* * The reset here guarantees that the interpreter result is empty and * unshared. This means that we can use Tcl_ListObjAppendElement on the * result object quite safely. @@ -673,13 +668,12 @@ * Assume that there will never be more than INT_MAX subexpressions. This * is a pretty reasonable assumption; the RE engine doesn't scale _that_ * well and Tcl has other limits that constrain things as well... */ - TclNewObj(resultObj); - TclNewIndexObj(infoObj, regexpPtr->re.re_nsub); - Tcl_ListObjAppendElement(NULL, resultObj, infoObj); + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), + Tcl_NewIntObj((int) regexpPtr->re.re_nsub)); /* * Now append a list of all the bit-flags set for the RE. */ @@ -688,12 +682,11 @@ if (regexpPtr->re.re_info & inf->bit) { Tcl_ListObjAppendElement(NULL, infoObj, Tcl_NewStringObj(inf->text, -1)); } } - Tcl_ListObjAppendElement(NULL, resultObj, infoObj); - Tcl_SetObjResult(interp, resultObj); + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), infoObj); return 0; } /* @@ -717,21 +710,21 @@ Tcl_Interp *interp, /* Interpreter for error reporting. */ const char *msg, /* Message to prepend to error. */ int status) /* Status code to report. */ { char buf[100]; /* ample in practice */ - char cbuf[TCL_INTEGER_SPACE]; + char cbuf[100]; /* lots in practice */ size_t n; const char *p; Tcl_ResetResult(interp); - n = TclReError(status, buf, sizeof(buf)); + n = TclReError(status, NULL, buf, sizeof(buf)); p = (n > sizeof(buf)) ? "..." : ""; - Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s%s%s", msg, buf, p)); + Tcl_AppendResult(interp, msg, buf, p, NULL); sprintf(cbuf, "%d", status); - (void) TclReError(REG_ITOA, cbuf, sizeof(cbuf)); + (void) TclReError(REG_ITOA, NULL, cbuf, sizeof(cbuf)); Tcl_SetErrorCode(interp, "REGEXP", cbuf, buf, NULL); } /* *---------------------------------------------------------------------- @@ -752,23 +745,20 @@ static void FreeRegexpInternalRep( Tcl_Obj *objPtr) /* Regexp object with internal rep to free. */ { - TclRegexp *regexpRepPtr; - - RegexpGetIntRep(objPtr, regexpRepPtr); - - assert(regexpRepPtr != NULL); + TclRegexp *regexpRepPtr = (TclRegexp *) objPtr->internalRep.twoPtrValue.ptr1; /* * If this is the last reference to the regexp, free it. */ - if (regexpRepPtr->refCount-- <= 1) { + if (--(regexpRepPtr->refCount) <= 0) { FreeRegexp(regexpRepPtr); } + objPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * @@ -789,17 +779,15 @@ static void DupRegexpInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - TclRegexp *regexpPtr; + TclRegexp *regexpPtr = (TclRegexp *) srcPtr->internalRep.twoPtrValue.ptr1; - RegexpGetIntRep(srcPtr, regexpPtr); - - assert(regexpPtr != NULL); - - RegexpSetIntRep(copyPtr, regexpPtr); + regexpPtr->refCount++; + copyPtr->internalRep.twoPtrValue.ptr1 = srcPtr->internalRep.twoPtrValue.ptr1; + copyPtr->typePtr = &tclRegexpType; } /* *---------------------------------------------------------------------- * @@ -855,11 +843,11 @@ static TclRegexp * CompileRegexp( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ const char *string, /* The regexp to compile (UTF-8). */ - size_t length, /* The length of the string in bytes. */ + int length, /* The length of the string in bytes. */ int flags) /* Compilation flags. */ { TclRegexp *regexpPtr; const Tcl_UniChar *uniString; int numChars, status, i, exact; @@ -913,11 +901,11 @@ /* * This is a new expression, so compile it and add it to the cache. */ - regexpPtr = (TclRegexp*)Tcl_Alloc(sizeof(TclRegexp)); + 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; @@ -940,11 +928,11 @@ if (status != REG_OKAY) { /* * Clean up and report errors in the interpreter, if possible. */ - Tcl_Free(regexpPtr); + ckfree((char *)regexpPtr); if (interp) { TclRegError(interp, "couldn't compile regular expression pattern: ", status); } return NULL; @@ -954,25 +942,26 @@ * Convert RE to a glob pattern equivalent, if any, and cache it. If this * is not possible, then globObjPtr will be NULL. This is used by * Tcl_RegExpExecObj to optionally do a fast match (avoids RE engine). */ - if (TclReToGlob(NULL, string, length, &stringBuf, &exact, - NULL) == TCL_OK) { - regexpPtr->globObjPtr = TclDStringToObj(&stringBuf); + if (TclReToGlob(NULL, string, length, &stringBuf, &exact) == TCL_OK) { + regexpPtr->globObjPtr = Tcl_NewStringObj(Tcl_DStringValue(&stringBuf), + Tcl_DStringLength(&stringBuf)); Tcl_IncrRefCount(regexpPtr->globObjPtr); + Tcl_DStringFree(&stringBuf); } else { regexpPtr->globObjPtr = NULL; } /* * Allocate enough space for all of the subexpressions, plus one extra for * the entire pattern. */ - regexpPtr->matches = - (regmatch_t*)Tcl_Alloc(sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1)); + 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. */ @@ -983,23 +972,22 @@ * list for the new regexp. */ if (tsdPtr->patterns[NUM_REGEXPS-1] != NULL) { TclRegexp *oldRegexpPtr = tsdPtr->regexps[NUM_REGEXPS-1]; - - if (oldRegexpPtr->refCount-- <= 1) { + if (--(oldRegexpPtr->refCount) <= 0) { FreeRegexp(oldRegexpPtr); } - Tcl_Free(tsdPtr->patterns[NUM_REGEXPS-1]); + 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 *)Tcl_Alloc(length + 1); - memcpy(tsdPtr->patterns[0], string, length + 1); + tsdPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1)); + strcpy(tsdPtr->patterns[0], string); tsdPtr->patLengths[0] = length; tsdPtr->regexps[0] = regexpPtr; return regexpPtr; } @@ -1027,13 +1015,13 @@ TclReFree(®expPtr->re); if (regexpPtr->globObjPtr) { TclDecrRefCount(regexpPtr->globObjPtr); } if (regexpPtr->matches) { - Tcl_Free(regexpPtr->matches); + ckfree((char *) regexpPtr->matches); } - Tcl_Free(regexpPtr); + ckfree((char *) regexpPtr); } /* *---------------------------------------------------------------------- * @@ -1050,30 +1038,28 @@ *---------------------------------------------------------------------- */ static void FinalizeRegexp( - TCL_UNUSED(ClientData)) + ClientData clientData) /* Not used. */ { 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) { + if (--(regexpPtr->refCount) <= 0) { FreeRegexp(regexpPtr); } - Tcl_Free(tsdPtr->patterns[i]); + ckfree(tsdPtr->patterns[i]); tsdPtr->patterns[i] = NULL; } - /* * We may find ourselves reinitialized if another finalization routine * invokes regexps. */ - tsdPtr->initialized = 0; } /* * Local Variables: Index: generic/tclRegexp.h ================================================================== --- generic/tclRegexp.h +++ generic/tclRegexp.h @@ -26,20 +26,20 @@ typedef struct TclRegexp { int flags; /* Regexp compile flags. */ regex_t re; /* Compiled re, includes number of * subexpressions. */ - const char *string; /* Last string passed to Tcl_RegExpExec. */ + CONST char *string; /* Last string passed to Tcl_RegExpExec. */ Tcl_Obj *objPtr; /* Last object passed to Tcl_RegExpExecObj. */ Tcl_Obj *globObjPtr; /* Glob pattern rep of RE or NULL if none. */ regmatch_t *matches; /* Array of indices into the Tcl_UniChar * representation of the last string matched * with this regexp to indicate the location * of subexpressions. */ rm_detail_t details; /* Detailed information on match (currently * used only for REG_EXPECT). */ - size_t refCount; /* Count of number of references to this + int refCount; /* Count of number of references to this * compiled regexp. */ } TclRegexp; #endif /* _TCLREGEXP */ Index: generic/tclResolve.c ================================================================== --- generic/tclResolve.c +++ generic/tclResolve.c @@ -53,21 +53,20 @@ void Tcl_AddInterpResolvers( Tcl_Interp *interp, /* Interpreter whose name resolution rules are * being modified. */ - const char *name, /* Name of this resolution scheme. */ + CONST char *name, /* Name of this resolution scheme. */ Tcl_ResolveCmdProc *cmdProc,/* New function for command resolution. */ Tcl_ResolveVarProc *varProc,/* Function for variable resolution at * runtime. */ Tcl_ResolveCompiledVarProc *compiledVarProc) /* Function for variable resolution at compile * time. */ { Interp *iPtr = (Interp *) interp; ResolverScheme *resPtr; - unsigned len; /* * Since we're adding a new name resolution scheme, we must force all code * to be recompiled to use the new scheme. If there are new compiled * variable resolution rules, bump the compiler epoch to invalidate @@ -99,14 +98,13 @@ /* * Otherwise, this is a new scheme. Add it to the FRONT of the linked * list, so that it overrides existing schemes. */ - resPtr = (ResolverScheme *)Tcl_Alloc(sizeof(ResolverScheme)); - len = strlen(name) + 1; - resPtr->name = (char *)Tcl_Alloc(len); - memcpy(resPtr->name, name, len); + resPtr = (ResolverScheme *) ckalloc(sizeof(ResolverScheme)); + resPtr->name = (char *) ckalloc((unsigned)(strlen(name) + 1)); + strcpy(resPtr->name, name); resPtr->cmdResProc = cmdProc; resPtr->varResProc = varProc; resPtr->compiledVarResProc = compiledVarProc; resPtr->nextPtr = iPtr->resolverPtr; iPtr->resolverPtr = resPtr; @@ -134,11 +132,11 @@ int Tcl_GetInterpResolvers( Tcl_Interp *interp, /* Interpreter whose name resolution rules are * being queried. */ - const char *name, /* Look for a scheme with this name. */ + CONST char *name, /* Look for a scheme with this name. */ Tcl_ResolverInfo *resInfoPtr) /* Returns pointers to the functions, if * found */ { Interp *iPtr = (Interp *) interp; @@ -186,11 +184,11 @@ int Tcl_RemoveInterpResolvers( Tcl_Interp *interp, /* Interpreter whose name resolution rules are * being modified. */ - const char *name) /* Name of the scheme to be removed. */ + CONST char *name) /* Name of the scheme to be removed. */ { Interp *iPtr = (Interp *) interp; ResolverScheme **prevPtrPtr, *resPtr; /* @@ -223,12 +221,12 @@ if (resPtr->cmdResProc) { BumpCmdRefEpochs(iPtr->globalNsPtr); } *prevPtrPtr = resPtr->nextPtr; - Tcl_Free(resPtr->name); - Tcl_Free(resPtr); + ckfree(resPtr->name); + ckfree((char *) resPtr); return 1; } return 0; } @@ -260,27 +258,15 @@ Tcl_HashEntry *entry; 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)) { - Namespace *childNsPtr = Tcl_GetHashValue(entry); - - BumpCmdRefEpochs(childNsPtr); - } - } -#endif + for (entry = Tcl_FirstHashEntry(&nsPtr->childTable, &search); + entry != NULL; entry = Tcl_NextHashEntry(&search)) { + Namespace *childNsPtr = (Namespace *) Tcl_GetHashValue(entry); + BumpCmdRefEpochs(childNsPtr); + } TclInvalidateNsPath(nsPtr); } /* *---------------------------------------------------------------------- @@ -292,12 +278,12 @@ * This allows extension writers to support different name resolution * schemes, such as those for object-oriented packages. * * Command resolution is handled by a function of the following type: * - * typedef int (Tcl_ResolveCmdProc)(Tcl_Interp *interp, - * const char *name, Tcl_Namespace *context, + * typedef int (*Tcl_ResolveCmdProc)(Tcl_Interp *interp, + * CONST char *name, Tcl_Namespace *context, * int flags, Tcl_Command *rPtr); * * Whenever a command is executed or Tcl_FindCommand is invoked within * the namespace, this function is called to resolve the command name. If * this function is able to resolve the name, it should return the status @@ -307,12 +293,12 @@ * can return TCL_ERROR, and the command will be considered invalid. * * Variable resolution is handled by two functions. The first is called * whenever a variable needs to be resolved at compile time: * - * typedef int (Tcl_ResolveCompiledVarProc)(Tcl_Interp *interp, - * const char *name, Tcl_Namespace *context, + * typedef int (*Tcl_ResolveCompiledVarProc)(Tcl_Interp *interp, + * CONST char *name, Tcl_Namespace *context, * Tcl_ResolvedVarInfo *rPtr); * * If this function is able to resolve the name, it should return the * status code TCL_OK, along with variable resolution info in the rPtr * argument; this info will be used to set up compiled locals in the call @@ -323,12 +309,12 @@ * Another function is used whenever a variable needs to be resolved at * runtime but it is not recognized as a compiled local. (For example, * the variable may be requested via Tcl_FindNamespaceVar.) This function * has the following type: * - * typedef int (Tcl_ResolveVarProc)(Tcl_Interp *interp, - * const char *name, Tcl_Namespace *context, + * typedef int (*Tcl_ResolveVarProc)(Tcl_Interp *interp, + * CONST char *name, Tcl_Namespace *context, * int flags, Tcl_Var *rPtr); * * This function is quite similar to the compile-time version. It returns * the same status codes, but if variable resolution succeeds, this * function returns a Tcl_Var directly via the rPtr argument. Index: generic/tclResult.c ================================================================== --- generic/tclResult.c +++ generic/tclResult.c @@ -15,38 +15,37 @@ * Indices of the standard return options dictionary keys. */ enum returnKeys { KEY_CODE, KEY_ERRORCODE, KEY_ERRORINFO, KEY_ERRORLINE, - KEY_LEVEL, KEY_OPTIONS, KEY_ERRORSTACK, KEY_LAST + KEY_LEVEL, KEY_OPTIONS, KEY_LAST }; /* * Function prototypes for local functions in this file: */ static Tcl_Obj ** GetKeys(void); static void ReleaseKeys(ClientData clientData); static void ResetObjResult(Interp *iPtr); +static void SetupAppendBuffer(Interp *iPtr, int newSpace); /* * 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. */ -typedef struct { +typedef struct InterpState { int status; /* return code status */ int flags; /* Each remaining field saves the */ int returnLevel; /* corresponding field of the Interp */ int returnCode; /* struct. These fields taken together are */ Tcl_Obj *errorInfo; /* the "state" of the interp. */ Tcl_Obj *errorCode; Tcl_Obj *returnOpts; Tcl_Obj *objResult; - Tcl_Obj *errorStack; - int resetErrorStack; } InterpState; /* *---------------------------------------------------------------------- * @@ -71,20 +70,18 @@ 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 *)Tcl_Alloc(sizeof(InterpState)); + 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; - statePtr->resetErrorStack = iPtr->resetErrorStack; if (statePtr->errorInfo) { Tcl_IncrRefCount(statePtr->errorInfo); } statePtr->errorCode = iPtr->errorCode; if (statePtr->errorCode) { @@ -92,13 +89,10 @@ } statePtr->returnOpts = iPtr->returnOpts; if (statePtr->returnOpts) { Tcl_IncrRefCount(statePtr->returnOpts); } - if (statePtr->errorStack) { - Tcl_IncrRefCount(statePtr->errorStack); - } statePtr->objResult = Tcl_GetObjResult(interp); Tcl_IncrRefCount(statePtr->objResult); return (Tcl_InterpState) statePtr; } @@ -123,20 +117,19 @@ int Tcl_RestoreInterpState( Tcl_Interp *interp, /* Interpreter's state to be restored. */ Tcl_InterpState state) /* Saved interpreter state. */ { - Interp *iPtr = (Interp *) interp; - InterpState *statePtr = (InterpState *) state; + Interp *iPtr = (Interp *)interp; + InterpState *statePtr = (InterpState *)state; int status = statePtr->status; iPtr->flags &= ~ERR_ALREADY_LOGGED; iPtr->flags |= (statePtr->flags & ERR_ALREADY_LOGGED); iPtr->returnLevel = statePtr->returnLevel; iPtr->returnCode = statePtr->returnCode; - iPtr->resetErrorStack = statePtr->resetErrorStack; if (iPtr->errorInfo) { Tcl_DecrRefCount(iPtr->errorInfo); } iPtr->errorInfo = statePtr->errorInfo; if (iPtr->errorInfo) { @@ -147,17 +140,10 @@ } iPtr->errorCode = statePtr->errorCode; if (iPtr->errorCode) { Tcl_IncrRefCount(iPtr->errorCode); } - if (iPtr->errorStack) { - Tcl_DecrRefCount(iPtr->errorStack); - } - iPtr->errorStack = statePtr->errorStack; - if (iPtr->errorStack) { - Tcl_IncrRefCount(iPtr->errorStack); - } if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); } iPtr->returnOpts = statePtr->returnOpts; if (iPtr->returnOpts) { @@ -187,11 +173,11 @@ void Tcl_DiscardInterpState( Tcl_InterpState state) /* saved interpreter state */ { - InterpState *statePtr = (InterpState *) state; + InterpState *statePtr = (InterpState *)state; if (statePtr->errorInfo) { Tcl_DecrRefCount(statePtr->errorInfo); } if (statePtr->errorCode) { @@ -198,15 +184,298 @@ Tcl_DecrRefCount(statePtr->errorCode); } if (statePtr->returnOpts) { Tcl_DecrRefCount(statePtr->returnOpts); } - if (statePtr->errorStack) { - Tcl_DecrRefCount(statePtr->errorStack); - } Tcl_DecrRefCount(statePtr->objResult); - Tcl_Free(statePtr); + ckfree((char *) 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. + * + *---------------------------------------------------------------------- + */ + +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. + * + *---------------------------------------------------------------------- + */ + +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((char *) 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. + * + *---------------------------------------------------------------------- + */ + +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) { + if (statePtr->freeProc == TCL_DYNAMIC) { + ckfree(statePtr->result); + } else { + (*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. */ + register 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; + int length; + register 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) { + length = strlen(result); + if (length > TCL_RESULT_SIZE) { + iPtr->result = (char *) ckalloc((unsigned) length+1); + iPtr->freeProc = TCL_DYNAMIC; + } else { + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = 0; + } + strcpy(iPtr->result, result); + } else { + iPtr->result = 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( + register Tcl_Interp *interp)/* Interpreter whose result to return. */ +{ + /* + * If the string result is empty, move the object result to the string + * result, then reset the object result. + */ + + if (*(interp->result) == 0) { + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), + TCL_VOLATILE); + } + return interp->result; } /* *---------------------------------------------------------------------- * @@ -228,15 +497,15 @@ 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 + register 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; + register Interp *iPtr = (Interp *) interp; + register Tcl_Obj *oldObjResult = iPtr->objResultPtr; iPtr->objResultPtr = objPtr; Tcl_IncrRefCount(objPtr); /* since interp result is a reference */ /* @@ -243,10 +512,25 @@ * We wait until the end to release the old object result, in case we are * setting the result to itself. */ TclDecrRefCount(oldObjResult); + + /* + * 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; } /* *---------------------------------------------------------------------- * @@ -270,14 +554,91 @@ Tcl_Obj * Tcl_GetObjResult( Tcl_Interp *interp) /* Interpreter whose result to return. */ { - Interp *iPtr = (Interp *) interp; + register Interp *iPtr = (Interp *) interp; + 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) { + 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->resultSpace[0] = 0; + } 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); + + /* + * Strictly we should call Tcl_GetStringResult(interp) here to make sure + * that interp->result is correct according to the old contract, but that + * makes the performance of much code (e.g. in Tk) absolutely awful. So we + * leave it out; code that really wants interp->result can just insert the + * calls to Tcl_GetStringResult() itself. [Patch 1041072 discussion] + */ + +#ifdef USE_DIRECT_INTERP_RESULT_ACCESS + /* + * Ensure that the interp->result is legal so old Tcl 7.* code still + * works. There's still embarrasingly much of it about... + */ + + (void) Tcl_GetStringResult(interp); +#endif /* USE_DIRECT_INTERP_RESULT_ACCESS */ +} /* *---------------------------------------------------------------------- * * Tcl_AppendResult -- @@ -301,27 +662,13 @@ void Tcl_AppendResult( Tcl_Interp *interp, ...) { va_list argList; - Tcl_Obj *objPtr; va_start(argList, interp); - objPtr = Tcl_GetObjResult(interp); - - if (Tcl_IsShared(objPtr)) { - objPtr = Tcl_DuplicateObj(objPtr); - } - while (1) { - const char *bytes = va_arg(argList, char *); - - if (bytes == NULL) { - break; - } - Tcl_AppendToObj(objPtr, bytes, -1); - } - Tcl_SetObjResult(interp, objPtr); + Tcl_AppendResultVA(interp, argList); va_end(argList); } /* *---------------------------------------------------------------------- @@ -348,28 +695,186 @@ void Tcl_AppendElement( Tcl_Interp *interp, /* Interpreter whose result is to be * extended. */ - const char *element) /* String to convert to list element and add + 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; - size_t length; - - if (Tcl_IsShared(iPtr->objResultPtr)) { - Tcl_SetObjResult(interp, Tcl_DuplicateObj(iPtr->objResultPtr)); - } - bytes = TclGetStringFromObj(iPtr->objResultPtr, &length); - if (TclNeedSpace(bytes, bytes + length)) { - Tcl_AppendToObj(iPtr->objResultPtr, " ", 1); - } - Tcl_AppendObjToObj(iPtr->objResultPtr, listPtr); - Tcl_DecrRefCount(listPtr); + 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); +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +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 *new; + + if (totalSpace < 100) { + totalSpace = 200; + } else { + totalSpace *= 2; + } + new = (char *) ckalloc((unsigned) totalSpace); + strcpy(new, iPtr->result); + if (iPtr->appendResult != NULL) { + ckfree(iPtr->appendResult); + } + iPtr->appendResult = new; + 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( + register Tcl_Interp *interp)/* Interpreter for which to free result. */ +{ + register 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); } /* *---------------------------------------------------------------------- * @@ -389,15 +894,25 @@ *---------------------------------------------------------------------- */ void Tcl_ResetResult( - Tcl_Interp *interp)/* Interpreter for which to clear result. */ + register Tcl_Interp *interp)/* Interpreter for which to clear result. */ { - Interp *iPtr = (Interp *) interp; + register Interp *iPtr = (Interp *) interp; ResetObjResult(iPtr); + 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; if (iPtr->errorCode) { /* Legacy support */ if (iPtr->flags & ERR_LEGACY_COPY) { Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL, iPtr->errorCode, TCL_GLOBAL_ONLY); @@ -412,11 +927,10 @@ iPtr->errorInfo, TCL_GLOBAL_ONLY); } Tcl_DecrRefCount(iPtr->errorInfo); iPtr->errorInfo = NULL; } - iPtr->resetErrorStack = 1; iPtr->returnLevel = 1; iPtr->returnCode = TCL_OK; if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); iPtr->returnOpts = NULL; @@ -442,30 +956,72 @@ *---------------------------------------------------------------------- */ static void ResetObjResult( - Interp *iPtr) /* Points to the interpreter whose result + register Interp *iPtr) /* Points to the interpreter whose result * object should be reset. */ { - Tcl_Obj *objResultPtr = iPtr->objResultPtr; + register 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 != tclEmptyStringRep) { if (objResultPtr->bytes) { - Tcl_Free(objResultPtr->bytes); + ckfree((char *) objResultPtr->bytes); } - objResultPtr->bytes = &tclEmptyString; + objResultPtr->bytes = tclEmptyStringRep; objResultPtr->length = 0; } TclFreeIntRep(objResultPtr); + objResultPtr->typePtr = NULL; + } +} + +/* + *---------------------------------------------------------------------- + * + * 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); } /* *---------------------------------------------------------------------- * @@ -488,34 +1044,18 @@ void Tcl_SetErrorCode( Tcl_Interp *interp, ...) { va_list argList; - Tcl_Obj *errorObj; /* * Scan through the arguments one at a time, appending them to the * errorCode field as list elements. */ va_start(argList, interp); - 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_SetErrorCodeVA(interp, argList); va_end(argList); } /* *---------------------------------------------------------------------- @@ -550,45 +1090,10 @@ } /* *---------------------------------------------------------------------- * - * 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; -} - -/* - *---------------------------------------------------------------------- - * * GetKeys -- * * Returns a Tcl_Obj * array of the standard keys used in the return * options dictionary. * @@ -597,22 +1102,22 @@ * * Results: * A Tcl_Obj * array. * * Side effects: - * First time called in a thread, creates the keys (allocating memory) - * and arranges for their cleanup at thread exit. + * First time called in a thread, creates the keys (allocating memory) + * and arranges for their cleanup at thread exit. * *---------------------------------------------------------------------- */ static Tcl_Obj ** GetKeys(void) { static Tcl_ThreadDataKey returnKeysKey; - Tcl_Obj **keys = (Tcl_Obj **)Tcl_GetThreadData(&returnKeysKey, - KEY_LAST * sizeof(Tcl_Obj *)); + Tcl_Obj **keys = Tcl_GetThreadData(&returnKeysKey, + (int) (KEY_LAST * sizeof(Tcl_Obj *))); if (keys[0] == NULL) { /* * First call in this thread, create the keys... */ @@ -621,11 +1126,10 @@ TclNewLiteralStringObj(keys[KEY_CODE], "-code"); TclNewLiteralStringObj(keys[KEY_ERRORCODE], "-errorcode"); TclNewLiteralStringObj(keys[KEY_ERRORINFO], "-errorinfo"); TclNewLiteralStringObj(keys[KEY_ERRORLINE], "-errorline"); - TclNewLiteralStringObj(keys[KEY_ERRORSTACK],"-errorstack"); TclNewLiteralStringObj(keys[KEY_LEVEL], "-level"); TclNewLiteralStringObj(keys[KEY_OPTIONS], "-options"); for (i = KEY_CODE; i < KEY_LAST; i++) { Tcl_IncrRefCount(keys[i]); @@ -633,11 +1137,11 @@ /* * ... and arrange for their clenaup. */ - Tcl_CreateThreadExitHandler(ReleaseKeys, keys); + Tcl_CreateThreadExitHandler(ReleaseKeys, (ClientData) keys); } return keys; } /* @@ -650,11 +1154,11 @@ * * Results: * None. * * Side effects: - * Frees memory. + * Frees memory. * *---------------------------------------------------------------------- */ static void @@ -683,11 +1187,11 @@ * * Results: * Returns the return code the [return] command should return. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ int @@ -716,66 +1220,29 @@ if (code == TCL_ERROR) { if (iPtr->errorInfo) { Tcl_DecrRefCount(iPtr->errorInfo); iPtr->errorInfo = NULL; } - Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], - &valuePtr); + Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], &valuePtr); if (valuePtr != NULL) { - size_t length; + int infoLen; - (void) TclGetStringFromObj(valuePtr, &length); - if (length) { + (void) TclGetStringFromObj(valuePtr, &infoLen); + if (infoLen) { iPtr->errorInfo = valuePtr; Tcl_IncrRefCount(iPtr->errorInfo); iPtr->flags |= ERR_ALREADY_LOGGED; } } - Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORSTACK], - &valuePtr); - if (valuePtr != NULL) { - int len, valueObjc; - Tcl_Obj **valueObjv; - - if (Tcl_IsShared(iPtr->errorStack)) { - Tcl_Obj *newObj; - - newObj = Tcl_DuplicateObj(iPtr->errorStack); - Tcl_DecrRefCount(iPtr->errorStack); - Tcl_IncrRefCount(newObj); - iPtr->errorStack = newObj; - } - - /* - * List extraction done after duplication to avoid moving the rug - * if someone does [return -errorstack [info errorstack]] - */ - - if (Tcl_ListObjGetElements(interp, valuePtr, &valueObjc, - &valueObjv) == TCL_ERROR) { - return TCL_ERROR; - } - iPtr->resetErrorStack = 0; - Tcl_ListObjLength(interp, iPtr->errorStack, &len); - - /* - * Reset while keeping the list intrep as much as possible. - */ - - Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc, - valueObjv); - } - Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE], - &valuePtr); + Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE], &valuePtr); if (valuePtr != NULL) { Tcl_SetObjErrorCode(interp, valuePtr); } else { Tcl_SetErrorCode(interp, "NONE", NULL); } - Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORLINE], - &valuePtr); + Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORLINE], &valuePtr); if (valuePtr != NULL) { TclGetIntFromObj(NULL, valuePtr, &iPtr->errorLine); } } if (level != 0) { @@ -795,46 +1262,47 @@ * TclMergeReturnOptions -- * * Parses, checks, and stores the options to the [return] command. * * Results: - * Returns TCL_ERROR if any of the option values are invalid. Otherwise, + * Returns TCL_ERROR is any of the option values are invalid. Otherwise, * returns TCL_OK, and writes the returnOpts, code, and level values to * the pointers provided. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ int TclMergeReturnOptions( Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *const objv[], /* Argument objects. */ + Tcl_Obj *CONST objv[], /* Argument objects. */ Tcl_Obj **optionsPtrPtr, /* If not NULL, points to space for a (Tcl_Obj * *) where the pointer to the merged return - * options dictionary should be written. */ + * options dictionary should be written */ int *codePtr, /* If not NULL, points to space where the - * -code value should be written. */ + * -code value should be written */ int *levelPtr) /* If not NULL, points to space where the - * -level value should be written. */ + * -level value should be written */ { - int code = TCL_OK; + int code=TCL_OK; int level = 1; Tcl_Obj *valuePtr; - Tcl_Obj *returnOpts; + Tcl_Obj *returnOpts = Tcl_NewObj(); Tcl_Obj **keys = GetKeys(); - TclNewObj(returnOpts); for (; objc > 1; objv += 2, objc -= 2) { - const char *opt = TclGetString(objv[0]); - const char *compare = TclGetString(keys[KEY_OPTIONS]); + int optLen; + CONST char *opt = TclGetStringFromObj(objv[0], &optLen); + int compareLen; + CONST char *compare = + TclGetStringFromObj(keys[KEY_OPTIONS], &compareLen); - if ((objv[0]->length == keys[KEY_OPTIONS]->length) - && (memcmp(opt, compare, objv[0]->length) == 0)) { + if ((optLen == compareLen) && (strcmp(opt, compare) == 0)) { Tcl_DictSearch search; int done = 0; Tcl_Obj *keyPtr; Tcl_Obj *dict = objv[1]; @@ -843,15 +1311,14 @@ &keyPtr, &valuePtr, &done)) { /* * Value is not a legal dictionary. */ - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad %s value: expected dictionary but got \"%s\"", - compare, TclGetString(objv[1]))); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", - NULL); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad ", compare, + " value: expected dictionary but got \"", + TclGetString(objv[1]), "\"", NULL); goto error; } while (!done) { Tcl_DictObjPut(NULL, returnOpts, keyPtr, valuePtr); @@ -873,15 +1340,31 @@ /* * Check for bogus -code value. */ Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr); - if (valuePtr != NULL) { - if (TclGetCompletionCodeFromObj(interp, valuePtr, - &code) == TCL_ERROR) { + if ((valuePtr != NULL) + && (TCL_ERROR == TclGetIntFromObj(NULL, valuePtr, &code))) { + static CONST char *returnCodes[] = { + "ok", "error", "return", "break", "continue", NULL + }; + + if (TCL_ERROR == Tcl_GetIndexFromObj(NULL, valuePtr, returnCodes, + NULL, TCL_EXACT, &code)) { + /* + * Value is not a legal return code. + */ + + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad completion code \"", + TclGetString(valuePtr), + "\": must be ok, error, return, break, " + "continue, or an integer", NULL); goto error; } + } + if (valuePtr != NULL) { Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_CODE]); } /* * Check for bogus -level value. @@ -893,14 +1376,14 @@ || (level < 0)) { /* * Value is not a legal level. */ - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad -level value: expected non-negative integer but got" - " \"%s\"", TclGetString(valuePtr))); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_LEVEL", NULL); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad -level value: " + "expected non-negative integer but got \"", + TclGetString(valuePtr), "\"", NULL); goto error; } Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_LEVEL]); } @@ -914,52 +1397,16 @@ if (TCL_ERROR == Tcl_ListObjLength(NULL, valuePtr, &length )) { /* * Value is not a list, which is illegal for -errorcode. */ - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad -errorcode value: expected a list but got \"%s\"", - TclGetString(valuePtr))); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_ERRORCODE", - NULL); - goto error; - } - } - - /* - * Check for bogus -errorstack value. - */ - - Tcl_DictObjGet(NULL, returnOpts, keys[KEY_ERRORSTACK], &valuePtr); - if (valuePtr != NULL) { - int length; - - if (TCL_ERROR == Tcl_ListObjLength(NULL, valuePtr, &length )) { - /* - * Value is not a list, which is illegal for -errorstack. - */ - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad -errorstack value: expected a list but got \"%s\"", - TclGetString(valuePtr))); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK", - NULL); - goto error; - } - if (length % 2) { - /* - * Errorstack must always be an even-sized list - */ - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "forbidden odd-sized list for -errorstack: \"%s\"", - TclGetString(valuePtr))); - Tcl_SetErrorCode(interp, "TCL", "RESULT", - "ODDSIZEDLIST_ERRORSTACK", NULL); - goto error; - } + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad -errorcode value: " + "expected a list but got \"", + TclGetString(valuePtr), "\"", NULL); + goto error; + } } /* * Convert [return -code return -level X] to [return -code ok -level X+1] */ @@ -1018,62 +1465,36 @@ Tcl_Obj **keys = GetKeys(); if (iPtr->returnOpts) { options = Tcl_DuplicateObj(iPtr->returnOpts); } else { - TclNewObj(options); + options = Tcl_NewObj(); } if (result == TCL_RETURN) { Tcl_DictObjPut(NULL, options, keys[KEY_CODE], - Tcl_NewWideIntObj(iPtr->returnCode)); + Tcl_NewIntObj(iPtr->returnCode)); Tcl_DictObjPut(NULL, options, keys[KEY_LEVEL], - Tcl_NewWideIntObj(iPtr->returnLevel)); + Tcl_NewIntObj(iPtr->returnLevel)); } else { Tcl_DictObjPut(NULL, options, keys[KEY_CODE], - Tcl_NewWideIntObj(result)); + Tcl_NewIntObj(result)); Tcl_DictObjPut(NULL, options, keys[KEY_LEVEL], - Tcl_NewWideIntObj(0)); + Tcl_NewIntObj(0)); } if (result == TCL_ERROR) { - Tcl_AddErrorInfo(interp, ""); - Tcl_DictObjPut(NULL, options, keys[KEY_ERRORSTACK], iPtr->errorStack); + Tcl_AddObjErrorInfo(interp, "", -1); } if (iPtr->errorCode) { Tcl_DictObjPut(NULL, options, keys[KEY_ERRORCODE], iPtr->errorCode); } if (iPtr->errorInfo) { Tcl_DictObjPut(NULL, options, keys[KEY_ERRORINFO], iPtr->errorInfo); Tcl_DictObjPut(NULL, options, keys[KEY_ERRORLINE], - Tcl_NewWideIntObj(iPtr->errorLine)); - } - return options; -} - -/* - *------------------------------------------------------------------------- - * - * TclNoErrorStack -- - * - * Removes the -errorstack entry from an options dict to avoid reference - * cycles. - * - * Results: - * The (unshared) argument options dict, modified in -place. - * - *------------------------------------------------------------------------- - */ - -Tcl_Obj * -TclNoErrorStack( - Tcl_Interp *interp, - Tcl_Obj *options) -{ - Tcl_Obj **keys = GetKeys(); - - Tcl_DictObjRemove(interp, options, keys[KEY_ERRORSTACK]); + Tcl_NewIntObj(iPtr->errorLine)); + } return options; } /* *------------------------------------------------------------------------- @@ -1104,13 +1525,13 @@ Tcl_Obj **objv, *mergedOpts; Tcl_IncrRefCount(options); if (TCL_ERROR == TclListObjGetElements(interp, options, &objc, &objv) || (objc % 2)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "expected dict but got \"%s\"", TclGetString(options))); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", NULL); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "expected dict but got \"", + TclGetString(options), "\"", NULL); code = TCL_ERROR; } else if (TCL_ERROR == TclMergeReturnOptions(interp, objc, objv, &mergedOpts, &code, &level)) { code = TCL_ERROR; } else { @@ -1122,39 +1543,45 @@ } /* *------------------------------------------------------------------------- * - * Tcl_TransferResult -- + * TclTransferResult -- * - * Transfer the result (and error information) from one interp to another. + * Copy 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. * + * This routine copies the string reps of the result and error + * information. It does not simply increment the refcounts of the result + * and error information objects themselves. It is not legal to exchange + * objects between interps, because an object may be kept alive by one + * interp, but have an internal rep that is only valid while some other + * interp is alive. + * * 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. + * The target interp's result is set to a copy of the source interp's + * result. The source's errorInfo field may be transferred to the + * target's errorInfo field, and the source's errorCode field may be + * transferred to the target's errorCode field. * * Side effects: * None. * *------------------------------------------------------------------------- */ void -Tcl_TransferResult( - Tcl_Interp *sourceInterp, /* Interp whose result and return options +TclTransferResult( + Tcl_Interp *sourceInterp, /* Interp whose result and error information * 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 + int result, /* TCL_OK if just the result should be copied, + * TCL_ERROR if both the result and error + * information should be copied. */ + Tcl_Interp *targetInterp) /* Interp where result and error information * should be stored. If source and target are * the same, nothing is done. */ { Interp *tiPtr = (Interp *) targetInterp; Interp *siPtr = (Interp *) sourceInterp; @@ -1161,11 +1588,11 @@ if (sourceInterp == targetInterp) { return; } - if (code == TCL_OK && siPtr->returnOpts == NULL) { + if (result == TCL_OK && siPtr->returnOpts == NULL) { /* * Special optimization for the common case of normal command return * code and no explicit return options. */ @@ -1173,11 +1600,11 @@ Tcl_DecrRefCount(tiPtr->returnOpts); tiPtr->returnOpts = NULL; } } else { Tcl_SetReturnOptions(targetInterp, - Tcl_GetReturnOptions(sourceInterp, code)); + Tcl_GetReturnOptions(sourceInterp, result)); tiPtr->flags &= ~(ERR_ALREADY_LOGGED); } Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp)); Tcl_ResetResult(sourceInterp); } @@ -1185,9 +1612,7 @@ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 - * tab-width: 8 - * indent-tabs-mode: nil * End: */ Index: generic/tclScan.c ================================================================== --- generic/tclScan.c +++ generic/tclScan.c @@ -8,11 +8,10 @@ * 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. */ @@ -27,31 +26,29 @@ /* * The following structure contains the information associated with a * character set. */ -typedef struct { - Tcl_UniChar start; - Tcl_UniChar end; -} Range; - -typedef struct { +typedef struct CharSet { int exclude; /* 1 if this is an exclusion set. */ int nchars; Tcl_UniChar *chars; int nranges; - Range *ranges; + struct Range { + Tcl_UniChar start; + Tcl_UniChar end; + } *ranges; } CharSet; /* * Declarations for functions used only in this file. */ -static const char * BuildCharSet(CharSet *cset, const char *format); +static char * BuildCharSet(CharSet *cset, char *format); static int CharInSet(CharSet *cset, int ch); static void ReleaseCharSet(CharSet *cset); -static int ValidateFormat(Tcl_Interp *interp, const char *format, +static int ValidateFormat(Tcl_Interp *interp, char *format, int numVars, int *totalVars); /* *---------------------------------------------------------------------- * @@ -68,61 +65,62 @@ * Initializes the charset. * *---------------------------------------------------------------------- */ -static const char * +static char * BuildCharSet( CharSet *cset, - const char *format) /* Points to first char of set. */ + char *format) /* Points to first char of set. */ { - Tcl_UniChar ch = 0, start; + Tcl_UniChar ch, start; int offset, nranges; - const char *end; + char *end; memset(cset, 0, sizeof(CharSet)); - offset = TclUtfToUniChar(format, &ch); + offset = Tcl_UtfToUniChar(format, &ch); if (ch == '^') { cset->exclude = 1; format += offset; - offset = TclUtfToUniChar(format, &ch); + offset = Tcl_UtfToUniChar(format, &ch); } end = format + offset; /* * Find the close bracket so we can overallocate the set. */ if (ch == ']') { - end += TclUtfToUniChar(end, &ch); + end += Tcl_UtfToUniChar(end, &ch); } nranges = 0; while (ch != ']') { if (ch == '-') { nranges++; } - end += TclUtfToUniChar(end, &ch); + end += Tcl_UtfToUniChar(end, &ch); } - cset->chars = (Tcl_UniChar *)Tcl_Alloc(sizeof(Tcl_UniChar) * (end - format - 1)); + cset->chars = (Tcl_UniChar *) + ckalloc(sizeof(Tcl_UniChar) * (end - format - 1)); if (nranges > 0) { - cset->ranges = (Range *)Tcl_Alloc(sizeof(Range) * nranges); + cset->ranges = (struct Range *) ckalloc(sizeof(struct Range)*nranges); } else { cset->ranges = NULL; } /* * Now build the character set. */ cset->nchars = cset->nranges = 0; - format += TclUtfToUniChar(format, &ch); + format += Tcl_UtfToUniChar(format, &ch); start = ch; if (ch == ']' || ch == '-') { cset->chars[cset->nchars++] = ch; - format += TclUtfToUniChar(format, &ch); + format += Tcl_UtfToUniChar(format, &ch); } while (ch != ']') { if (*format == '-') { /* * This may be the first character of a range, so don't add it @@ -135,15 +133,15 @@ * Check to see if this is the last character in the set, in which * case it is not a range and we should add the previous character * as well as the dash. */ - if (*format == ']' || !cset->ranges) { + if (*format == ']') { cset->chars[cset->nchars++] = start; cset->chars[cset->nchars++] = ch; } else { - format += TclUtfToUniChar(format, &ch); + format += Tcl_UtfToUniChar(format, &ch); /* * Check to see if the range is in reverse order. */ @@ -157,11 +155,11 @@ cset->nranges++; } } else { cset->chars[cset->nchars++] = ch; } - format += TclUtfToUniChar(format, &ch); + format += Tcl_UtfToUniChar(format, &ch); } return format; } /* @@ -224,13 +222,13 @@ static void ReleaseCharSet( CharSet *cset) { - Tcl_Free(cset->chars); + ckfree((char *)cset->chars); if (cset->ranges) { - Tcl_Free(cset->ranges); + ckfree((char *)cset->ranges); } } /* *---------------------------------------------------------------------- @@ -250,26 +248,22 @@ */ static int ValidateFormat( Tcl_Interp *interp, /* Current interpreter. */ - const char *format, /* The format string. */ + char *format, /* The format string. */ int numVars, /* The number of variables passed to the scan * command. */ int *totalSubs) /* The number of variables that will be * required. */ { int gotXpg, gotSequential, value, i, flags; char *end; - Tcl_UniChar ch = 0; + Tcl_UniChar ch; 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] = ""; + int *nassign = (int *) TclStackAlloc(interp, nspace * sizeof(int)); + char buf[TCL_UTF_MAX+1]; /* * 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. @@ -280,24 +274,24 @@ } xpgSize = objIndex = gotXpg = gotSequential = 0; while (*format != '\0') { - format += TclUtfToUniChar(format, &ch); + format += Tcl_UtfToUniChar(format, &ch); flags = 0; if (ch != '%') { continue; } - format += TclUtfToUniChar(format, &ch); + format += Tcl_UtfToUniChar(format, &ch); if (ch == '%') { continue; } if (ch == '*') { flags |= SCAN_SUPPRESS; - format += TclUtfToUniChar(format, &ch); + format += Tcl_UtfToUniChar(format, &ch); goto xpgCheckDone; } if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ /* @@ -309,11 +303,11 @@ value = strtoul(format-1, &end, 10); /* INTL: "C" locale. */ if (*end != '$') { goto notXpg; } format = end+1; - format += TclUtfToUniChar(format, &ch); + format += Tcl_UtfToUniChar(format, &ch); gotXpg = 1; if (gotSequential) { goto mixedXPG; } objIndex = value - 1; @@ -333,26 +327,25 @@ notXpg: gotSequential = 1; if (gotXpg) { mixedXPG: - Tcl_SetObjResult(interp, Tcl_NewStringObj( + Tcl_SetResult(interp, "cannot mix \"%\" and \"%n$\" conversion specifiers", - -1)); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", "MIXEDSPECTYPES", NULL); + TCL_STATIC); goto error; } xpgCheckDone: /* * Parse any width specifier. */ if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ - value = strtoul(format-1, (char **) &format, 10); /* INTL: "C" locale. */ + value = strtoul(format-1, &format, 10); /* INTL: "C" locale. */ flags |= SCAN_WIDTH; - format += TclUtfToUniChar(format, &ch); + format += Tcl_UtfToUniChar(format, &ch); } /* * Handle any size specifier. */ @@ -360,19 +353,19 @@ switch (ch) { case 'l': if (*format == 'l') { flags |= SCAN_BIG; format += 1; - format += TclUtfToUniChar(format, &ch); + format += Tcl_UtfToUniChar(format, &ch); break; } /* FALLTHRU */ case 'L': flags |= SCAN_LONGER; /* FALLTHRU */ case 'h': - format += TclUtfToUniChar(format, &ch); + format += Tcl_UtfToUniChar(format, &ch); } if (!(flags & SCAN_SUPPRESS) && numVars && (objIndex >= numVars)) { goto badIndex; } @@ -382,28 +375,24 @@ */ switch (ch) { case 'c': if (flags & SCAN_WIDTH) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( + Tcl_SetResult(interp, "field width may not be specified in %c conversion", - -1)); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADWIDTH", NULL); + TCL_STATIC); goto error; } /* FALLTHRU */ case 'n': case 's': if (flags & (SCAN_LONGER|SCAN_BIG)) { invalidFieldSize: buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; - errorMsg = Tcl_NewStringObj( - "field size modifier may not be specified in %", -1); - Tcl_AppendToObj(errorMsg, buf, -1); - Tcl_AppendToObj(errorMsg, " conversion", -1); - Tcl_SetObjResult(interp, errorMsg); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADSIZE", NULL); + Tcl_AppendResult(interp, + "field size modifier may not be specified in %", buf, + " conversion", NULL); goto error; } /* * Fall through! */ @@ -415,12 +404,17 @@ case 'G': case 'i': case 'o': case 'x': case 'X': - case 'b': + break; case 'u': + if (flags & SCAN_BIG) { + Tcl_SetResult(interp, + "unsigned bignum scans are invalid", TCL_STATIC); + goto error; + } break; /* * Bracket terms need special checking */ case '[': @@ -428,44 +422,43 @@ goto invalidFieldSize; } if (*format == '\0') { goto badSet; } - format += TclUtfToUniChar(format, &ch); + format += Tcl_UtfToUniChar(format, &ch); if (ch == '^') { if (*format == '\0') { goto badSet; } - format += TclUtfToUniChar(format, &ch); + format += Tcl_UtfToUniChar(format, &ch); } if (ch == ']') { if (*format == '\0') { goto badSet; } - format += TclUtfToUniChar(format, &ch); + format += Tcl_UtfToUniChar(format, &ch); } while (ch != ']') { if (*format == '\0') { goto badSet; } - format += TclUtfToUniChar(format, &ch); + format += Tcl_UtfToUniChar(format, &ch); } break; badSet: - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unmatched [ in format string", -1)); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BRACKET", NULL); + Tcl_SetResult(interp, "unmatched [ in format string", + TCL_STATIC); goto error; default: - buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; - errorMsg = Tcl_NewStringObj( - "bad scan conversion character \"", -1); - Tcl_AppendToObj(errorMsg, buf, -1); - Tcl_AppendToObj(errorMsg, "\"", -1); - Tcl_SetObjResult(interp, errorMsg); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL); - goto error; + { + char buf[TCL_UTF_MAX+1]; + + buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; + Tcl_AppendResult(interp, "bad scan conversion character \"", + buf, "\"", NULL); + goto error; + } } if (!(flags & SCAN_SUPPRESS)) { if (objIndex >= nspace) { /* * Expand the nassign buffer. If we are using XPG specifiers, @@ -477,11 +470,11 @@ if (xpgSize) { nspace = xpgSize; } else { nspace += 16; /* formerly STATIC_LIST_SIZE */ } - nassign = (int *)TclStackRealloc(interp, nassign, + nassign = (int *) TclStackRealloc(interp, nassign, nspace * sizeof(int)); for (i = value; i < nspace; i++) { nassign[i] = 0; } } @@ -504,42 +497,38 @@ if (totalSubs) { *totalSubs = numVars; } for (i = 0; i < numVars; i++) { if (nassign[i] > 1) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( + Tcl_SetResult(interp, "variable is assigned by multiple \"%n$\" conversion specifiers", - -1)); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", "POLYASSIGNED", NULL); + TCL_STATIC); goto error; } else if (!xpgSize && (nassign[i] == 0)) { /* * If the space is empty, and xpgSize is 0 (means XPG wasn't used, * and/or numVars != 0), then too many vars were given */ - Tcl_SetObjResult(interp, Tcl_NewStringObj( + Tcl_SetResult(interp, "variable is not assigned by any conversion specifiers", - -1)); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", "UNASSIGNED", NULL); + TCL_STATIC); goto error; } } TclStackFree(interp, nassign); return TCL_OK; badIndex: if (gotXpg) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "\"%n$\" argument index out of range", -1)); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", "INDEXRANGE", NULL); + Tcl_SetResult(interp, "\"%n$\" argument index out of range", + TCL_STATIC); } else { - Tcl_SetObjResult(interp, Tcl_NewStringObj( + Tcl_SetResult(interp, "different numbers of variable names and field specifiers", - -1)); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", "FIELDVARMISMATCH", NULL); + TCL_STATIC); } error: TclStackFree(interp, nassign); return TCL_ERROR; @@ -560,36 +549,40 @@ * See the user documentation. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_ScanObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { - const char *format; + char *format; int numVars, nconversions, totalVars = -1; int objIndex, offset, i, result, code; long value; - const char *string, *end, *baseString; + CONST char *string, *end, *baseString; char op = 0; int width, underflow = 0; Tcl_WideInt wideValue; - Tcl_UniChar ch = 0, sch = 0; + Tcl_UniChar ch, sch; Tcl_Obj **objs = NULL, *objPtr = NULL; int flags; + char buf[513]; /* Temporary buffer to hold scanned number + * strings before they are passed to + * strtoul. */ if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, - "string format ?varName ...?"); + "string format ?varName varName ...?"); return TCL_ERROR; } - format = TclGetString(objv[2]); + format = Tcl_GetStringFromObj(objv[2], NULL); numVars = objc-3; /* * Check for errors in the format string. */ @@ -601,17 +594,17 @@ /* * Allocate space for the result objects. */ if (totalVars > 0) { - objs = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj *) * totalVars); + objs = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj*) * totalVars); for (i = 0; i < totalVars; i++) { objs[i] = NULL; } } - string = TclGetString(objv[1]); + string = Tcl_GetStringFromObj(objv[1], NULL); 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 @@ -620,26 +613,26 @@ objIndex = 0; nconversions = 0; while (*format != '\0') { int parseFlag = TCL_PARSE_NO_WHITESPACE; - format += TclUtfToUniChar(format, &ch); + format += Tcl_UtfToUniChar(format, &ch); flags = 0; /* * If we see whitespace in the format, skip whitespace in the string. */ if (Tcl_UniCharIsSpace(ch)) { - offset = TclUtfToUniChar(string, &sch); + offset = Tcl_UtfToUniChar(string, &sch); while (Tcl_UniCharIsSpace(sch)) { if (*string == '\0') { goto done; } string += offset; - offset = TclUtfToUniChar(string, &sch); + offset = Tcl_UtfToUniChar(string, &sch); } continue; } if (ch != '%') { @@ -646,18 +639,18 @@ literal: if (*string == '\0') { underflow = 1; goto done; } - string += TclUtfToUniChar(string, &sch); + string += Tcl_UtfToUniChar(string, &sch); if (ch != sch) { goto done; } continue; } - format += TclUtfToUniChar(format, &ch); + format += Tcl_UtfToUniChar(format, &ch); if (ch == '%') { goto literal; } /* @@ -665,28 +658,28 @@ * ('%n$'). */ if (ch == '*') { flags |= SCAN_SUPPRESS; - format += TclUtfToUniChar(format, &ch); + format += Tcl_UtfToUniChar(format, &ch); } else if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ char *formatEnd; value = strtoul(format-1, &formatEnd, 10);/* INTL: "C" locale. */ if (*formatEnd == '$') { format = formatEnd+1; - format += TclUtfToUniChar(format, &ch); + format += Tcl_UtfToUniChar(format, &ch); objIndex = (int) value - 1; } } /* * Parse any width specifier. */ if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ - width = (int) strtoul(format-1, (char **) &format, 10);/* INTL: "C" locale. */ - format += TclUtfToUniChar(format, &ch); + width = (int) strtoul(format-1, &format, 10);/* INTL: "C" locale. */ + format += Tcl_UtfToUniChar(format, &ch); } else { width = 0; } /* @@ -696,31 +689,30 @@ switch (ch) { case 'l': if (*format == 'l') { flags |= SCAN_BIG; format += 1; - format += TclUtfToUniChar(format, &ch); + format += Tcl_UtfToUniChar(format, &ch); break; } /* FALLTHRU */ case 'L': flags |= SCAN_LONGER; /* FALLTHRU */ case 'h': - format += TclUtfToUniChar(format, &ch); + format += Tcl_UtfToUniChar(format, &ch); } /* * Handle the various field types. */ switch (ch) { case 'n': if (!(flags & SCAN_SUPPRESS)) { - TclNewIntObj(objPtr, string - baseString); + objPtr = Tcl_NewIntObj(string - baseString); Tcl_IncrRefCount(objPtr); - CLANG_ASSERT(objs); objs[objIndex++] = objPtr; } nconversions++; continue; @@ -739,14 +731,10 @@ case 'x': case 'X': op = 'i'; parseFlag |= TCL_PARSE_HEXADECIMAL_ONLY; break; - case 'b': - op = 'i'; - parseFlag |= TCL_PARSE_BINARY_ONLY; - break; case 'u': op = 'i'; parseFlag |= TCL_PARSE_DECIMAL_ONLY; flags |= SCAN_UNSIGNED; break; @@ -788,11 +776,11 @@ * format suppresses this behavior. */ if (!(flags & SCAN_NOSKIP)) { while (*string != '\0') { - offset = TclUtfToUniChar(string, &sch); + offset = Tcl_UtfToUniChar(string, &sch); if (!Tcl_UniCharIsSpace(sch)) { break; } string += offset; } @@ -815,11 +803,11 @@ if (width == 0) { width = ~0; } end = string; while (*end != '\0') { - offset = TclUtfToUniChar(end, &sch); + offset = Tcl_UtfToUniChar(end, &sch); if (Tcl_UniCharIsSpace(sch)) { break; } end += offset; if (--width == 0) { @@ -827,11 +815,10 @@ } } if (!(flags & SCAN_SUPPRESS)) { objPtr = Tcl_NewStringObj(string, end-string); Tcl_IncrRefCount(objPtr); - CLANG_ASSERT(objs); objs[objIndex++] = objPtr; } string = end; break; @@ -843,11 +830,11 @@ } end = string; format = BuildCharSet(&cset, format); while (*end != '\0') { - offset = TclUtfToUniChar(end, &sch); + offset = Tcl_UtfToUniChar(end, &sch); if (!CharInSet(&cset, (int)sch)) { break; } end += offset; if (--width == 0) { @@ -874,31 +861,29 @@ case 'c': /* * Scan a single Unicode character. */ - offset = TclUtfToUCS4(string, &i); - string += offset; + string += Tcl_UtfToUniChar(string, &sch); if (!(flags & SCAN_SUPPRESS)) { - TclNewIntObj(objPtr, i); + objPtr = Tcl_NewIntObj((int)sch); Tcl_IncrRefCount(objPtr); - CLANG_ASSERT(objs); objs[objIndex++] = objPtr; } break; case 'i': /* * Scan an unsigned or signed integer. */ - TclNewIntObj(objPtr, 0); + objPtr = Tcl_NewLongObj(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)) { + &end, TCL_PARSE_INTEGER_ONLY | parseFlag)) { Tcl_DecrRefCount(objPtr); if (width < 0) { if (*end == '\0') { underflow = 1; } @@ -914,76 +899,35 @@ Tcl_DecrRefCount(objPtr); break; } if (flags & SCAN_LONGER) { if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) { - wideValue = WIDE_MAX; + wideValue = ~(Tcl_WideUInt)0 >> 1; /* WIDE_MAX */ if (TclGetString(objPtr)[0] == '-') { - wideValue = WIDE_MIN; + wideValue++; /* WIDE_MAX + 1 = 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 res = Tcl_GetBignumFromObj(interp, objPtr, &big); - - if (res == TCL_OK) { - if (mp_isneg(&big)) { - res = TCL_ERROR; - } - mp_clear(&big); - } - - if (res == TCL_ERROR) { - if (objs != NULL) { - Tcl_Free(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 { + sprintf(buf, "%" TCL_LL_MODIFIER "u", + (Tcl_WideUInt)wideValue); + Tcl_SetStringObj(objPtr, buf, -1); + } else { + Tcl_SetWideIntObj(objPtr, wideValue); + } + } else if (!(flags & SCAN_BIG)) { 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); + sprintf(buf, "%lu", value); /* INTL: ISO digit */ + Tcl_SetStringObj(objPtr, buf, -1); + } else { + Tcl_SetLongObj(objPtr, value); } } objs[objIndex++] = objPtr; break; @@ -996,11 +940,11 @@ 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)) { + &end, TCL_PARSE_DECIMAL_ONLY | TCL_PARSE_NO_WHITESPACE)) { Tcl_DecrRefCount(objPtr); if (width < 0) { if (*end == '\0') { underflow = 1; } @@ -1015,23 +959,20 @@ string = end; } else { double dvalue; if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) { #ifdef ACCEPT_NAN - const Tcl_ObjIntRep *irPtr - = TclFetchIntRep(objPtr, &tclDoubleType); - if (irPtr) { - dvalue = irPtr->doubleValue; + if (objPtr->typePtr == &tclDoubleType) { + dvalue = objPtr->internalRep.doubleValue; } else #endif { Tcl_DecrRefCount(objPtr); goto done; } } Tcl_SetDoubleObj(objPtr, dvalue); - CLANG_ASSERT(objs); objs[objIndex++] = objPtr; string = end; } } nconversions++; @@ -1049,28 +990,23 @@ for (i = 0; i < totalVars; i++) { if (objs[i] == NULL) { continue; } result++; - - /* - * In case of multiple errors in setting variables, just report - * the first one. - */ - - if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], - (code == TCL_OK) ? TCL_LEAVE_ERR_MSG : 0) == NULL) { + if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], 0) == NULL) { + Tcl_AppendResult(interp, "couldn't set variable \"", + TclGetString(objv[i+3]), "\"", NULL); code = TCL_ERROR; } Tcl_DecrRefCount(objs[i]); } } else { /* * Here no vars were specified, we want a list returned (inline scan) */ - TclNewObj(objPtr); + objPtr = Tcl_NewObj(); for (i = 0; i < totalVars; i++) { if (objs[i] != NULL) { Tcl_ListObjAppendElement(NULL, objPtr, objs[i]); Tcl_DecrRefCount(objs[i]); } else { @@ -1082,25 +1018,25 @@ Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewObj()); } } } if (objs != NULL) { - Tcl_Free(objs); + ckfree((char*) objs); } if (code == TCL_OK) { if (underflow && (nconversions == 0)) { if (numVars) { - TclNewIndexObj(objPtr, TCL_INDEX_NONE); + objPtr = Tcl_NewIntObj(-1); } else { if (objPtr) { Tcl_SetListObj(objPtr, 0, NULL); } else { - TclNewObj(objPtr); + objPtr = Tcl_NewObj(); } } } else if (numVars) { - TclNewIntObj(objPtr, result); + objPtr = Tcl_NewIntObj(result); } Tcl_SetObjResult(interp, objPtr); } return code; } Index: generic/tclStrToD.c ================================================================== --- generic/tclStrToD.c +++ generic/tclStrToD.c @@ -12,18 +12,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 "tclTomMath.h" +#include "tommath.h" #include #include #ifdef _WIN32 #define copysign _copysign #endif +/* + * Define KILL_OCTAL to suppress interpretation of numbers with leading zero + * as octal. (Ceterum censeo: numeros octonarios delendos esse.) + */ + +#undef KILL_OCTAL + /* * 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. */ @@ -296,16 +303,14 @@ 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 void MulPow5(mp_int *, unsigned, mp_int *); static int NormalizeRightward(Tcl_WideUInt *); static int RequiredPrecision(Tcl_WideUInt); static void DoubleToExpAndSig(double, Tcl_WideUInt *, int *, int *); static void TakeAbsoluteValue(Double *, int *); @@ -323,51 +328,49 @@ static char * StrictQuickFormat(double, int, int, double, 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, +static char * ShorteningInt64Conversion(Double *, int, Tcl_WideUInt, int, int, int, int, int, int, int, int, int, int, int, int *, char **); -static char * StrictInt64Conversion(Tcl_WideUInt, +static char * StrictInt64Conversion(Double *, int, 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 *); + int, int, int, mp_int *); static char * ShorteningBignumConversionPowD(Double *dPtr, - Tcl_WideUInt bw, int b2, int b5, + int convType, 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( +static char * StrictBignumConversionPowD(Double *dPtr, int convType, 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, + mp_int *, int, int, mp_int *); +static char * ShorteningBignumConversion(Double *dPtr, int convType, 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( +static char * StrictBignumConversion(Double *dPtr, int convType, 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 BignumToBiasedFrExp(mp_int *big, int *machexp); static double Pow10TimesFrExp(int exponent, double fraction, int *machexp); static double SafeLdExp(double fraction, int exponent); -#ifdef IEEE_FLOATING_POINT static Tcl_WideUInt Nokia770Twiddle(Tcl_WideUInt w); -#endif /* *---------------------------------------------------------------------- * * TclParseNumber -- @@ -392,13 +395,10 @@ * strings that denote floating point values (or accept only the * leading portion of them that are integer values). * - TCL_PARSE_SCAN_PREFIXES: ignore the prefixes 0b and 0o that are * not part of the [scan] command's vocabulary. Use only in * combination with TCL_PARSE_INTEGER_ONLY. - * - TCL_PARSE_BINARY_ONLY: parse only in the binary format, whether - * or not a prefix is present that would lead to binary parsing. - * Use only in combination with TCL_PARSE_INTEGER_ONLY. * - TCL_PARSE_OCTAL_ONLY: parse only in the octal format, whether * or not a prefix is present that would lead to octal parsing. * Use only in combination with TCL_PARSE_INTEGER_ONLY. * - TCL_PARSE_HEXADECIMAL_ONLY: parse only in the hexadecimal format, * whether or not a prefix is present that would lead to @@ -477,20 +477,20 @@ 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. */ - size_t numBytes, /* Maximum number of bytes to scan, see + 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, DECIMAL, + ZERO_O, ZERO_B, 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 @@ -531,37 +531,20 @@ * 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 */ - mp_err err = MP_OKAY; - int under = 0; /* Flag trailing '_' as error if true once - * number is accepted. */ + int explicitOctal = 0; -#define ALL_BITS ((Tcl_WideUInt)-1) -#define MOST_BITS (ALL_BITS >> 1) +#define MOST_BITS (UWIDE_MAX >> 1) /* * Initialize bytes to start of the object's string rep if the caller * didn't pass anything else. */ if (bytes == NULL) { - if (interp == NULL && endPtrPtr == NULL) { - if (TclHasIntRep(objPtr, &tclDictType)) { - /* A dict can never be a (single) number */ - return TCL_ERROR; - } - if (TclHasIntRep(objPtr, &tclListType)) { - int length; - /* A list can only be a (single) number if its length == 1 */ - TclListObjLength(NULL, objPtr, &length); - if (length != 1) { - return TCL_ERROR; - } - } - } bytes = TclGetString(objPtr); } p = bytes; len = numBytes; @@ -605,12 +588,10 @@ state = ZERO; } break; } else if (flags & TCL_PARSE_HEXADECIMAL_ONLY) { goto zerox; - } else if (flags & TCL_PARSE_BINARY_ONLY) { - goto zerob; } else if (flags & TCL_PARSE_OCTAL_ONLY) { goto zeroo; } else if (isdigit(UCHAR(c))) { significandWide = c - '0'; numSigDigs = 1; @@ -642,11 +623,11 @@ acceptState = state; acceptPoint = p; acceptLen = len; if (c == 'x' || c == 'X') { - if (flags & (TCL_PARSE_OCTAL_ONLY|TCL_PARSE_BINARY_ONLY) || under) { + if (flags & TCL_PARSE_OCTAL_ONLY) { goto endgame; } state = ZERO_X; break; } @@ -655,34 +636,25 @@ } if (flags & TCL_PARSE_SCAN_PREFIXES) { goto zeroo; } if (c == 'b' || c == 'B') { - if ((flags & TCL_PARSE_OCTAL_ONLY) || under) { + if (flags & TCL_PARSE_OCTAL_ONLY) { 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 KILL_OCTAL 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 @@ -695,54 +667,54 @@ /* 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. + * Shifting by as many or more bits than are in the + * value being shifted is undefined behavior. Check + * for too large shifts first. */ if ((octalSignificandWide != 0) && (((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt)) || (octalSignificandWide > - ((Tcl_WideUInt)-1 >> shift)))) { + (UWIDE_MAX >> shift)))) { octalSignificandOverflow = 1; - err = mp_init_u64(&octalSignificandBig, + TclBNInitBignumFromWideUInt(&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; + /* + * When the significand is 0, it is possible for the + * amount to be shifted to equal or exceed the width + * of the significand. Do not shift when the + * significand is 0 to avoid undefined behavior. + */ + + if (octalSignificandWide != 0) { + octalSignificandWide <<= shift; + } + octalSignificandWide += c - '0'; + } else { + mp_mul_2d(&octalSignificandBig, shift, + &octalSignificandBig); + mp_add_d(&octalSignificandBig, (mp_digit)(c - '0'), + &octalSignificandBig); } } if (numSigDigs != 0) { numSigDigs += numTrailZeros+1; } else { @@ -749,15 +721,63 @@ 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 KILL_OCTAL + + /* + * Scanned a number with a leading zero that contains an 8, 9, + * radix point or E. This is an invalid octal number, but might + * still be floating point. + */ + + if (c == '0') { + numTrailZeros++; + state = BAD_OCTAL; + break; + } else if (isdigit(UCHAR(c))) { + if (objPtr != NULL) { + significandOverflow = AccumulateDecimalDigit( + (unsigned)(c-'0'), numTrailZeros, + &significandWide, &significandBig, + significandOverflow); + } + if (numSigDigs != 0) { + numSigDigs += (numTrailZeros + 1); + } else { + numSigDigs = 1; + } + numTrailZeros = 0; + state = BAD_OCTAL; + break; + } else if (c == '.') { + state = FRACTION; + break; + } else if (c == 'E' || c == 'e') { + state = EXPONENT_START; + break; + } +#endif goto endgame; /* * Scanned 0x. If state is HEXADECIMAL, scanned at least one * character following the 0x. The only acceptable inputs are @@ -772,144 +792,124 @@ 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. + * Shifting by as many or more bits than are in the + * value being shifted is undefined behavior. Check + * for too large shifts first. */ if (significandWide != 0 && ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || - significandWide > ((Tcl_WideUInt)-1 >> shift))) { + significandWide > (UWIDE_MAX >> shift))) { significandOverflow = 1; - err = mp_init_u64(&significandBig, + TclBNInitBignumFromWideUInt(&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; + /* + * When the significand is 0, it is possible for the + * amount to be shifted to equal or exceed the width + * of the significand. Do not shift when the + * significand is 0 to avoid undefined behavior. + */ + + if (significandWide != 0) { + significandWide <<= shift; + } + significandWide += d; + } else { + mp_mul_2d(&significandBig, shift, &significandBig); + mp_add_d(&significandBig, (mp_digit) d, &significandBig); + } } numTrailZeros = 0; state = HEXADECIMAL; break; case BINARY: acceptState = state; acceptPoint = p; acceptLen = len; - /* FALLTHRU */ + /* 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. + * Shifting by as many or more bits than are in the + * value being shifted is undefined behavior. Check + * for too large shifts first. */ if (significandWide != 0 && ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || - significandWide > ((Tcl_WideUInt)-1 >> shift))) { + significandWide > (UWIDE_MAX >> shift))) { significandOverflow = 1; - err = mp_init_u64(&significandBig, + TclBNInitBignumFromWideUInt(&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; + /* + * When the significand is 0, it is possible for the + * amount to be shifted to equal or exceed the width + * of the significand. Do not shift when the + * significand is 0 to avoid undefined behavior. + */ + + if (significandWide != 0) { + significandWide <<= shift; + } + significandWide += 1; + } else { + mp_mul_2d(&significandBig, shift, &significandBig); + mp_add_d(&significandBig, (mp_digit) 1, &significandBig); + } } 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 KILL_OCTAL 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( @@ -917,25 +917,18 @@ &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; @@ -957,11 +950,10 @@ case LEADING_RADIX_POINT: if (c == '0') { numDigitsAfterDp++; numTrailZeros++; - under = 0; state = FRACTION; break; } else if (isdigit(UCHAR(c))) { numDigitsAfterDp++; if (objPtr != NULL) { @@ -974,17 +966,12 @@ 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: /* @@ -992,16 +979,14 @@ * 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 */ @@ -1011,17 +996,12 @@ * 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: /* @@ -1036,17 +1016,12 @@ 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 @@ -1053,56 +1028,49 @@ * 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; @@ -1110,28 +1078,25 @@ * 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; @@ -1138,18 +1103,16 @@ /* * 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'; @@ -1160,11 +1123,10 @@ } else { goto endgame; } numSigDigs++; significandWide = (significandWide << 4) + d; - under = 0; state = sNANHEX; break; } goto endgame; case sNANFINISH: @@ -1173,11 +1135,10 @@ case sINFINITY: acceptState = state; acceptPoint = p; acceptLen = len; goto endgame; - } p++; len--; } @@ -1192,17 +1153,14 @@ *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; - + p = acceptPoint; + len = acceptLen; if (!(flags & TCL_PARSE_NO_WHITESPACE)) { /* * Accept trailing whitespace. */ @@ -1210,11 +1168,11 @@ p++; len--; } } if (endPtrPtr == NULL) { - if ((len != 0) && ((numBytes + 1 > 1) || (*p != '\0'))) { + if ((len != 0) && ((numBytes > 0) || (*p != '\0'))) { status = TCL_ERROR; } } else { *endPtrPtr = p; } @@ -1226,14 +1184,14 @@ 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: case sI: case sIN: @@ -1253,22 +1211,27 @@ 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); + TclBNInitBignumFromWideUInt(&significandBig, significandWide); } if (shift) { if (!significandOverflow) { - significandWide <<= shift; - } else if (err == MP_OKAY) { - err = mp_mul_2d(&significandBig, shift, &significandBig); + /* + * When the significand is 0, it is possible for the + * amount to be shifted to equal or exceed the width + * of the significand. Do not shift when the + * significand is 0 to avoid undefined behavior. + */ + if (significandWide != 0) { + significandWide <<= shift; + } + } else { + mp_mul_2d(&significandBig, shift, &significandBig); } } - if (err != MP_OKAY) { - return TCL_ERROR; - } goto returnInteger; case HEXADECIMAL: /* * Returning a hex integer. Final scaling step. @@ -1277,22 +1240,27 @@ 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); + TclBNInitBignumFromWideUInt(&significandBig, significandWide); } if (shift) { if (!significandOverflow) { - significandWide <<= shift; - } else if (err == MP_OKAY) { - err = mp_mul_2d(&significandBig, shift, &significandBig); + /* + * When the significand is 0, it is possible for the + * amount to be shifted to equal or exceed the width + * of the significand. Do not shift when the + * significand is 0 to avoid undefined behavior. + */ + if (significandWide != 0) { + significandWide <<= shift; + } + } else { + mp_mul_2d(&significandBig, shift, &significandBig); } } - if (err != MP_OKAY) { - return TCL_ERROR; - } goto returnInteger; case OCTAL: /* * Returning an octal integer. Final scaling step. @@ -1301,82 +1269,112 @@ 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, + TclBNInitBignumFromWideUInt(&octalSignificandBig, octalSignificandWide); } if (shift) { if (!octalSignificandOverflow) { - octalSignificandWide <<= shift; - } else if (err == MP_OKAY) { - err = mp_mul_2d(&octalSignificandBig, shift, + /* + * When the significand is 0, it is possible for the + * amount to be shifted to equal or exceed the width + * of the significand. Do not shift when the + * significand is 0 to avoid undefined behavior. + */ + if (octalSignificandWide != 0) { + octalSignificandWide <<= shift; + } + } else { + mp_mul_2d(&octalSignificandBig, shift, &octalSignificandBig); } } if (!octalSignificandOverflow) { - if ((err == MP_OKAY) && (octalSignificandWide > (MOST_BITS + signum))) { - err = mp_init_u64(&octalSignificandBig, + if (octalSignificandWide > + (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) { +#ifndef NO_WIDE_TYPE + if (octalSignificandWide <= (MOST_BITS + signum)) { + objPtr->typePtr = &tclWideIntType; + if (signum) { + objPtr->internalRep.wideValue = + (Tcl_WideInt) (-octalSignificandWide); + } else { + objPtr->internalRep.wideValue = + (Tcl_WideInt) octalSignificandWide; + } + break; + } +#endif + TclBNInitBignumFromWideUInt(&octalSignificandBig, octalSignificandWide); octalSignificandOverflow = 1; } else { objPtr->typePtr = &tclIntType; if (signum) { - objPtr->internalRep.wideValue = - - (Tcl_WideInt) octalSignificandWide; + objPtr->internalRep.longValue = + (long) (-octalSignificandWide); } else { - objPtr->internalRep.wideValue = - (Tcl_WideInt) octalSignificandWide; + objPtr->internalRep.longValue = + (long) octalSignificandWide; } } } - if ((err == MP_OKAY) && octalSignificandOverflow) { + if (octalSignificandOverflow) { if (signum) { - err = mp_neg(&octalSignificandBig, &octalSignificandBig); + (void)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)) { + if (!significandOverflow && (significandWide > MOST_BITS+signum)) { significandOverflow = 1; - err = mp_init_u64(&significandBig, significandWide); + TclBNInitBignumFromWideUInt(&significandBig, significandWide); } returnInteger: if (!significandOverflow) { - if ((err == MP_OKAY) && (significandWide > MOST_BITS+signum)) { - err = mp_init_u64(&significandBig, + if (significandWide > + (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) { +#ifndef NO_WIDE_TYPE + if (significandWide <= MOST_BITS+signum) { + objPtr->typePtr = &tclWideIntType; + if (signum) { + objPtr->internalRep.wideValue = + (Tcl_WideInt) (-significandWide); + } else { + objPtr->internalRep.wideValue = + (Tcl_WideInt) significandWide; + } + break; + } +#endif + TclBNInitBignumFromWideUInt(&significandBig, significandWide); significandOverflow = 1; } else { objPtr->typePtr = &tclIntType; if (signum) { - objPtr->internalRep.wideValue = - - (Tcl_WideInt) significandWide; + objPtr->internalRep.longValue = + (long) (-significandWide); } else { - objPtr->internalRep.wideValue = - (Tcl_WideInt) significandWide; + objPtr->internalRep.longValue = + (long) significandWide; } } } - if ((err == MP_OKAY) && significandOverflow) { + if (significandOverflow) { if (signum) { - err = mp_neg(&significandBig, &significandBig); + (void)mp_neg(&significandBig, &significandBig); } TclSetBignumIntRep(objPtr, &significandBig); } - if (err != MP_OKAY) { - return TCL_ERROR; - } break; case FRACTION: case EXPONENT: @@ -1459,15 +1457,20 @@ * 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_Obj *msg; + TclNewLiteralStringObj(msg, "expected "); + Tcl_AppendToObj(msg, expected, -1); + Tcl_AppendToObj(msg, " but got \"", -1); 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); } } @@ -1528,19 +1531,17 @@ */ *wideRepPtr = digit; return 0; } else if (numZeros >= maxpow10_wide - || w > ((Tcl_WideUInt)-1-digit)/pow10_wide[numZeros+1]) { + || w > (UWIDE_MAX-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; - } + TclBNInitBignumFromWideUInt(bignumRepPtr, w); } else { /* * Wide multiplication. */ @@ -1556,16 +1557,14 @@ 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; + mp_mul_d(bignumRepPtr, (mp_digit) pow10_wide[numZeros+1], + bignumRepPtr); + mp_add_d(bignumRepPtr, (mp_digit) digit, bignumRepPtr); } 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 @@ -1572,25 +1571,22 @@ * 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) { + mp_mul_d(bignumRepPtr, (mp_digit) pow10_wide[n&0x7], bignumRepPtr); + for (i=3; i<=7; ++i) { if (n & (1 << i)) { - err = mp_mul(bignumRepPtr, pow5+i, bignumRepPtr); + mp_mul(bignumRepPtr, pow5+i, bignumRepPtr); } } - while ((err == MP_OKAY) && (n >= 256)) { - err = mp_mul(bignumRepPtr, pow5+8, bignumRepPtr); + while (n >= 256) { + 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; - } + mp_mul_2d(bignumRepPtr, (int)(numZeros+1)&~0x7, bignumRepPtr); + mp_add_d(bignumRepPtr, (mp_digit) digit, bignumRepPtr); } return 1; } @@ -1618,30 +1614,36 @@ 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. + * ulp, so we need to change rounding mode to 53-bits. We also make + * 'retval' volatile, so that it doesn't get promoted to a register. */ - - TCL_IEEE_DOUBLE_ROUNDING; + volatile double retval; /* Value of the number. */ /* - * Test for the easy cases. + * Test for zero significand, which requires explicit construction + * of -0.0. (Unary minus returns a positive zero.) */ - if (significand == 0) { return copysign(0.0, -signum); } + + /* + * Set the FP control word for 53 bits, WARNING: It must be reset + * before returning. + */ + TCL_IEEE_DOUBLE_ROUNDING; + if (numSigDigs <= QUICK_MAX) { if (exponent >= 0) { if (exponent <= mmaxpow) { /* * The significand is an exact integer, and so is @@ -1687,13 +1689,11 @@ /* * 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; - } + TclBNInitBignumFromWideUInt(&significandBig, significand); retval = MakeHighPrecisionDouble(0, &significandBig, numSigDigs, exponent); mp_clear(&significandBig); /* @@ -1737,31 +1737,41 @@ 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. */ + int machexp; /* 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'. - */ - + * ulp, so we need to change rounding mode to 53-bits. We also make + * 'retval' volatile to make sure that it doesn't get promoted to a + * register. + */ + volatile double retval; + + /* + * A zero significand requires explicit construction of -0.0. + * (Unary minus returns positive zero.) + */ if (mp_iszero(significand)) { return copysign(0.0, -signum); } + + /* + * Set the 53-bit rounding mode. WARNING: It must be reset before + * returning. + */ + TCL_IEEE_DOUBLE_ROUNDING; + + /* + * Make quick checks for over/underflow. Be careful to avoid + * integer overflow when calculating with 'exponent'. + */ if (exponent >= 0 && exponent-1 > maxDigits-numSigDigs) { retval = HUGE_VAL; goto returnValue; } else if (exponent < 0 && numSigDigs+exponent < minDigits+1) { retval = 0.0; @@ -1903,11 +1913,10 @@ * 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. */ @@ -1952,84 +1961,65 @@ * 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; - } + mp_init_size(&twoMv, nDigits); 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; + if (M5 & (1 << i)) { + mp_mul(&twoMv, pow5+i, &twoMv); } } /* * 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) { + mp_init_copy(&twoMd, exactSignificand); + for (i=0; i<=8; ++i) { if ((M5 + exponent) & (1 << i)) { - err = mp_mul(&twoMd, pow5+i, &twoMd); + mp_mul(&twoMd, pow5+i, &twoMd); } } - if (err == MP_OKAY) { - err = mp_mul_2d(&twoMd, M2+exponent+1, &twoMd); - } + 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); - } + 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) { + mp_set(&twoMv, 1); + for (i=0; i<=8; ++i) { if (M5 & (1 << i)) { - err = mp_mul(&twoMv, pow5+i, &twoMv); + 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); + if (multiplier > 0) { + 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; + mp_div_2d(&twoMv, -multiplier, &twoMv, NULL); } /* * Will the eventual correction term be less than, equal to, or * greater than 1/2 ULP? @@ -2074,19 +2064,12 @@ * 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; + mp_div_2d(&twoMv, shift, &twoMv, NULL); + mp_div_2d(&twoMd, shift, &twoMd, NULL); } /* * Convert the numerator and denominator of the corrector term accurately * to floating point numbers. @@ -2121,38 +2104,36 @@ * Stores base*5**n in result. * *---------------------------------------------------------------------- */ -static inline mp_err +static inline void 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); + mp_mul_d(p, dpow5[r], result); p = result; } r = 0; - while ((err == MP_OKAY) && (n13 != 0)) { + while (n13 != 0) { if (n13 & 1) { - err = mp_mul(p, pow5_13+r, result); + mp_mul(p, pow5_13+r, result); p = result; } n13 >>= 1; ++r; } - if ((err == MP_OKAY) && (p != result)) { - err = mp_copy(p, result); + if (p != result) { + mp_copy(p, result); } - return err; } /* *---------------------------------------------------------------------- * @@ -2329,11 +2310,11 @@ * * 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 'Tcl_Free'. + * 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. * @@ -2348,17 +2329,17 @@ { char *retval; *decpt = 9999; if (!(d->w.word1) && !(d->w.word0 & HI_ORDER_SIG_MASK)) { - retval = (char *)Tcl_Alloc(9); + retval = ckalloc(9); strcpy(retval, "Infinity"); if (endPtr) { *endPtr = retval + 8; } } else { - retval = (char *)Tcl_Alloc(4); + retval = ckalloc(4); strcpy(retval, "NaN"); if (endPtr) { *endPtr = retval + 3; } } @@ -2385,11 +2366,11 @@ static inline char * FormatZero( int *decpt, /* Location of the decimal point. */ char **endPtr) /* Pointer to the end of the formatted data */ { - char *retval = (char *)Tcl_Alloc(2); + char *retval = ckalloc(2); strcpy(retval, "0"); if (endPtr) { *endPtr = retval+1; } @@ -2566,22 +2547,29 @@ *---------------------------------------------------------------------- */ static inline void SetPrecisionLimits( - int flags, /* Type of conversion: TCL_DD_SHORTEST, - * TCL_DD_E_FMT, TCL_DD_F_FMT. */ + int convType, /* Type of conversion: TCL_DD_SHORTEST, + * TCL_DD_STEELE0, TCL_DD_E_FMT, + * TCL_DD_F_FMT. */ int k, /* Floor(log10(number to convert)) */ int *ndigitsPtr, /* IN/OUT: Number of digits requested (will be * adjusted if needed). */ int *iPtr, /* OUT: Maximum number of digits to return. */ int *iLimPtr, /* OUT: Number of digits of significance if * the bignum method is used.*/ int *iLim1Ptr) /* OUT: Number of digits of significance if * the quick method is used. */ { - switch (flags & TCL_DD_CONVERSION_TYPE_MASK) { + switch (convType) { + case TCL_DD_SHORTEST0: + case TCL_DD_STEELE0: + *iLimPtr = *iLim1Ptr = -1; + *iPtr = 18; + *ndigitsPtr = 0; + break; case TCL_DD_E_FORMAT: if (*ndigitsPtr <= 0) { *ndigitsPtr = 1; } *iLimPtr = *iLim1Ptr = *iPtr = *ndigitsPtr; @@ -2593,14 +2581,14 @@ if (*iPtr <= 0) { *iPtr = 1; } break; default: - *iLimPtr = *iLim1Ptr = -1; - *iPtr = 18; - *ndigitsPtr = 0; - break; + *iPtr = -1; + *iLimPtr = -1; + *iLim1Ptr = -1; + Tcl_Panic("impossible conversion type in TclDoubleDigits"); } } /* *---------------------------------------------------------------------- @@ -2880,11 +2868,11 @@ 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 */ + * TCL_DD_SHORTEN_FLAG */ 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. */ @@ -2916,11 +2904,11 @@ if (ilim1 < 0) { return NULL; } ilim = ilim1; --k; - d *= 10.0; + d = d * 10.0; ++ieps; } /* * Compute estimated roundoff error. @@ -2931,37 +2919,37 @@ /* * Handle the peculiar case where the result has no significant digits. */ - retval = (char *)Tcl_Alloc(len + 1); + retval = ckalloc(len + 1); if (ilim == 0) { - d -= 5.; + d = d - 5.; if (d > eps.d) { *retval = '1'; *decpt = k; return retval; } else if (d < -eps.d) { *decpt = k; return retval; } else { - Tcl_Free(retval); + ckfree(retval); return NULL; } } /* * Format the digit string. */ - if (flags & TCL_DD_SHORTEST) { + if (flags & TCL_DD_SHORTEN_FLAG) { end = ShorteningQuickFormat(d, k, ilim, eps.d, retval, decpt); } else { end = StrictQuickFormat(d, k, ilim, eps.d, retval, decpt); } if (end == NULL) { - Tcl_Free(retval); + ckfree(retval); return NULL; } *end = '\0'; if (endPtr != NULL) { *endPtr = end; @@ -3026,10 +3014,12 @@ */ static inline char * ShorteningInt64Conversion( Double *dPtr, /* Original number to convert. */ + int convType, /* Type of conversion (shortest, Steele, + * E format, F format). */ Tcl_WideUInt bw, /* Integer significand. */ int b2, int b5, /* Scale factor for the significand in the * numerator. */ int m2plus, int m2minus, int m5, /* Scale factors for 1/2 ulp in the numerator @@ -3042,11 +3032,11 @@ 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 *)Tcl_Alloc(len + 1); + char *retval = ckalloc(len + 1); /* Output buffer. */ Tcl_WideUInt b = (bw * wuipow5[b5]) << b2; /* Numerator of the fraction being * converted. */ Tcl_WideUInt S = wuipow5[s5] << s2; @@ -3092,11 +3082,11 @@ * Does the current digit put us on the low side of the exact value * but within within roundoff of being exact? */ if (b < mplus || (b == mplus - && (dPtr->w.word1 & 1) == 0)) { + && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) { /* * Make sure we shouldn't be rounding *up* instead, in case the * next number above is closer. */ @@ -3121,11 +3111,11 @@ * Does one plus the current digit put us within roundoff of the * number? */ if (b > S - mminus || (b == S - mminus - && (dPtr->w.word1 & 1) == 0)) { + && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) { if (digit == 9) { *s++ = '9'; s = BumpUp(s, retval, &k); break; } @@ -3192,10 +3182,13 @@ *---------------------------------------------------------------------- */ static inline char * StrictInt64Conversion( + Double *dPtr, /* Original number to convert. */ + int convType, /* Type of conversion (shortest, Steele, + * E format, F format). */ 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 @@ -3205,11 +3198,11 @@ 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 *)Tcl_Alloc(len + 1); + char *retval = ckalloc(len + 1); /* Output buffer. */ Tcl_WideUInt b = (bw * wuipow5[b5]) << b2; /* Numerator of the fraction being * converted. */ Tcl_WideUInt S = wuipow5[s5] << s2; @@ -3336,10 +3329,13 @@ 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 convType, /* Conversion type: STEELE defeats + * round-to-even (not sure why one wants to do + * this; I copied it from Gay). FIXME */ int isodd, /* 1 if the integer significand is odd. */ mp_int *temp) /* Work area for the calculation. */ { int i; @@ -3347,11 +3343,12 @@ * 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 */ + mp_add(b, m, temp); + if (temp->used <= sd) { /* Too few digits to be > s */ return 0; } if (temp->used > sd+1 || temp->dp[sd] > 1) { /* >= 2s */ return 1; @@ -3359,10 +3356,14 @@ for (i = sd-1; i >= 0; --i) { /* Check for ==s */ if (temp->dp[i] != 0) { /* > s */ return 1; } + } + if (convType == TCL_DD_STEELE0) { + /* Biased rounding. */ + return 0; } return isodd; } /* @@ -3389,10 +3390,12 @@ */ static inline char * ShorteningBignumConversionPowD( Double *dPtr, /* Original number to convert. */ + int convType, /* Type of conversion (shortest, Steele, + * E format, F format). */ Tcl_WideUInt bw, /* Integer significand. */ int b2, int b5, /* Scale factor for the significand in the * numerator. */ int m2plus, int m2minus, int m5, /* Scale factors for 1/2 ulp in the numerator @@ -3405,45 +3408,37 @@ 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 *)Tcl_Alloc(len + 1); + char *retval = 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); - } + TclBNInitBignumFromWideUInt(&b, bw); + mp_init_set(&mminus, 1); + MulPow5(&b, b5, &b); + 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); + if (b.used <= sd) { + mp_mul_d(&b, 10, &b); ++m2plus; ++m2minus; ++m5; ilim = ilim1; --k; } @@ -3450,25 +3445,17 @@ /* * 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); - } + mp_mul_2d(&mminus, m2minus, &mminus); + MulPow5(&mminus, m5, &mminus); + if (m2plus > m2minus) { + mp_init_copy(&mplus, &mminus); + mp_mul_2d(&mplus, m2plus-m2minus, &mplus); + } + mp_init(&temp); /* * Loop through the digits. Do division and mod by s == 2**(sd*MP_DIGIT_BIT) * by mp_digit extraction. */ @@ -3490,11 +3477,11 @@ * but within within roundoff of being exact? */ r1 = mp_cmp_mag(&b, (m2plus > m2minus)? &mplus : &mminus); if (r1 == MP_LT || (r1 == MP_EQ - && (dPtr->w.word1 & 1) == 0)) { + && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) { /* * Make sure we shouldn't be rounding *up* instead, in case the * next number above is closer. */ @@ -3518,11 +3505,11 @@ /* * Does one plus the current digit put us within roundoff of the * number? */ - if (ShouldBankerRoundUpToNextPowD(&b, &mminus, sd, + if (ShouldBankerRoundUpToNextPowD(&b, &mminus, sd, convType, dPtr->w.word1 & 1, &temp)) { if (digit == 9) { *s++ = '9'; s = BumpUp(s, retval, &k); break; @@ -3546,18 +3533,14 @@ /* * 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); + mp_mul_d(&b, 10, &b); + mp_mul_d(&mminus, 10, &mminus); + if (m2plus > m2minus) { + mp_mul_2d(&mminus, m2plus-m2minus, &mplus); } ++i; } /* @@ -3572,11 +3555,11 @@ *s = '\0'; *decpt = k; if (endPtr) { *endPtr = s; } - return (err == MP_OKAY) ? retval : NULL; + return retval; } /* *---------------------------------------------------------------------- * @@ -3599,10 +3582,13 @@ *---------------------------------------------------------------------- */ static inline char * StrictBignumConversionPowD( + Double *dPtr, /* Original number to convert. */ + int convType, /* Type of conversion (shortest, Steele, + * E format, F format). */ 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 @@ -3612,48 +3598,45 @@ 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 *)Tcl_Alloc(len + 1); + char *retval = 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; + mp_int temp; /* * 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); - } + TclBNInitBignumFromWideUInt(&b, bw); + MulPow5(&b, b5, &b); + 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); + if (b.used <= sd) { + mp_mul_d(&b, 10, &b); ilim = ilim1; --k; } + mp_init(&temp); /* * 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) { + for (;;) { if (b.used <= sd) { digit = 0; } else { digit = b.dp[sd]; if (b.used > sd+1 || digit >= 10) { @@ -3681,20 +3664,20 @@ /* * Advance to the next digit. */ - err = mp_mul_d(&b, 10, &b); + mp_mul_d(&b, 10, &b); ++i; } /* * Endgame - store the location of the decimal point and the end of the * string. */ - mp_clear(&b); + mp_clear_multi(&b, &temp, NULL); *s = '\0'; *decpt = k; if (endPtr) { *endPtr = s; } @@ -3754,29 +3737,33 @@ ShouldBankerRoundUpToNext( mp_int *b, /* Remainder from the division that produced * the last digit. */ mp_int *m, /* Numerator of the rounding tolerance. */ mp_int *S, /* Denominator. */ - int isodd) /* 1 if the integer significand is odd. */ + int convType, /* Conversion type: STEELE0 defeats + * round-to-even. (Not sure why one would want + * this; I coped it from Gay). FIXME */ + int isodd, /* 1 if the integer significand is odd. */ + mp_int *temp) /* Work area needed for the calculation. */ { 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); + mp_add(b, m, temp); + r = mp_cmp_mag(temp, S); switch(r) { case MP_LT: return 0; case MP_EQ: - return isodd; + if (convType == TCL_DD_STEELE0) { + return 0; + } else { + return isodd; + } case MP_GT: return 1; } Tcl_Panic("in ShouldBankerRoundUpToNext, trichotomy fails!"); return 0; @@ -3801,10 +3788,11 @@ */ static inline char * ShorteningBignumConversion( Double *dPtr, /* Original number being converted. */ + int convType, /* Conversion type. */ Tcl_WideUInt bw, /* Integer significand and exponent. */ int b2, /* Scale factor for the significand. */ int m2plus, int m2minus, /* Scale factors for 1/2 ulp in numerator. */ int s2, int s5, /* Scale factors for denominator. */ int k, /* Guessed position of the decimal point. */ @@ -3812,81 +3800,65 @@ 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 *)Tcl_Alloc(len+1); + char *retval = 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. */ + mp_int temp; /* Work area. */ 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); - } + TclBNInitBignumFromWideUInt(&b, bw); + mp_mul_2d(&b, b2, &b); + mp_init_set(&S, 1); + MulPow5(&S, s5, &S); 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); + if (mp_cmp_mag(&b, &S) == MP_LT) { + 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); - } - } + mp_init_set(&mminus, minit); + mp_mul_2d(&mminus, m2minus, &mminus); + if (m2plus > m2minus) { + mp_init_copy(&mplus, &mminus); + mp_mul_2d(&mplus, m2plus-m2minus, &mplus); + } + mp_init(&temp); /* * Loop through the digits. */ - if (err == MP_OKAY) { - err = mp_init(&dig); - } + mp_init(&dig); i = 1; - while (err == MP_OKAY) { - err = mp_div(&b, &S, &dig, &b); + for (;;) { + mp_div(&b, &S, &dig, &b); if (dig.used > 1 || dig.dp[0] >= 10) { Tcl_Panic("wrong digit!"); } digit = dig.dp[0]; @@ -3894,12 +3866,13 @@ * 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 (r1 == MP_LT || (r1 == MP_EQ + && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) { + mp_mul_2d(&b, 1, &b); if (ShouldBankerRoundUp(&b, &S, digit&1)) { ++digit; if (digit == 10) { *s++ = '9'; s = BumpUp(s, retval, &k); @@ -3913,12 +3886,12 @@ /* * Does the current digit leave us with a remainder large enough to * commit to rounding up to the next higher digit? */ - if (ShouldBankerRoundUpToNext(&b, &mminus, &S, - dPtr->w.word1 & 1)) { + if (ShouldBankerRoundUpToNext(&b, &mminus, &S, convType, + dPtr->w.word1 & 1, &temp)) { ++digit; if (digit == 10) { *s++ = '9'; s = BumpUp(s, retval, &k); break; @@ -3930,12 +3903,12 @@ /* * Have we converted all the requested digits? */ *s++ = '0' + digit; - if ((err == MP_OKAY) && (i == ilim)) { - err = mp_mul_2d(&b, 1, &b); + if (i == ilim) { + mp_mul_2d(&b, 1, &b); if (ShouldBankerRoundUp(&b, &S, digit&1)) { s = BumpUp(s, retval, &k); } break; } @@ -3942,25 +3915,21 @@ /* * Advance to the next digit. */ - if ((err == MP_OKAY) && (s5 > 0)) { + if (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); - } + mp_mul_2d(&b, 1, &b); + mp_mul_2d(&mminus, 1, &mminus); + if (m2plus > m2minus) { + mp_mul_2d(&mplus, 1, &mplus); + } + 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 @@ -3986,17 +3955,15 @@ * 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); + } else { + mp_mul_d(&b, 10, &b); + mp_mul_d(&mminus, 10, &mminus); + if (m2plus > m2minus) { + mp_mul_2d(&mplus, 10, &mplus); } } ++i; } @@ -4007,11 +3974,11 @@ */ if (m2plus > m2minus) { mp_clear(&mplus); } - mp_clear_multi(&b, &mminus, &dig, &S, NULL); + mp_clear_multi(&b, &mminus, &temp, &dig, &S, NULL); *s = '\0'; *decpt = k; if (endPtr) { *endPtr = s; } @@ -4036,10 +4003,12 @@ *---------------------------------------------------------------------- */ static inline char * StrictBignumConversion( + Double *dPtr, /* Original number being converted. */ + int convType, /* Conversion type. */ 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. */ @@ -4046,59 +4015,48 @@ 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 *)Tcl_Alloc(len+1); + char *retval = 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. */ + mp_int temp; /* Work area. */ 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); - } - } + mp_init_multi(&temp, &dig, NULL); + TclBNInitBignumFromWideUInt(&b, bw); + mp_mul_2d(&b, b2, &b); + mp_init_set(&S, 1); + MulPow5(&S, s5, &S); 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)) { + if (mp_cmp_mag(&b, &S) == MP_LT) { + mp_mul_d(&b, 10, &b); ilim =ilim1; --k; } /* * Convert the leading digit. */ i = 0; - err = mp_div(&b, &S, &dig, &b); + mp_div(&b, &S, &dig, &b); if (dig.used > 1 || dig.dp[0] >= 10) { Tcl_Panic("wrong digit!"); } digit = dig.dp[0]; @@ -4106,38 +4064,35 @@ * 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)) { + mp_mul_2d(&b, 1, &b); + if (ShouldBankerRoundUp(&b, &S, digit&1)) { s = BumpUp(s, retval, &k); } } else { - while (err == MP_OKAY) { + for (;;) { /* * 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); + 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); - } + mp_div_d(&S, dpow5[s5], &S, NULL); + mp_mul_d(&b, dpow5[g - s5], &b); s5 = 0; } else { - err = mp_mul_d(&b, dpow5[g], &b); + mp_mul_d(&b, dpow5[g], &b); } - if (err == MP_OKAY) { - err = mp_mul_2d(&b, g, &b); - } + 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 @@ -4147,12 +4102,12 @@ * 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)) { + mp_div(&b, &S, &dig, &b); + if (dig.used > 1) { Tcl_Panic("wrong digit!"); } digit = dig.dp[0]; for (j = g-1; j >= 0; --j) { int t = itens[j]; @@ -4165,11 +4120,12 @@ /* * Have we converted all the requested digits? */ if (i == ilim) { - if ((mp_mul_2d(&b, 1, &b) == MP_OKAY) && ShouldBankerRoundUp(&b, &S, digit&1)) { + mp_mul_2d(&b, 1, &b); + if (ShouldBankerRoundUp(&b, &S, digit&1)) { s = BumpUp(s, retval, &k); } break; } } @@ -4182,11 +4138,11 @@ /* * Endgame - store the location of the decimal point and the end of the * string. */ - mp_clear_multi(&b, &S, &dig, NULL); + mp_clear_multi(&b, &S, &temp, &dig, NULL); *s = '\0'; *decpt = k; if (endPtr) { *endPtr = s; } @@ -4212,22 +4168,32 @@ * 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. - * It constructs the shortest string of + * 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_STEELE - This value is not recommended and may be removed in + * the future. It follows the conversion algorithm outlined in + * "How to Print Floating-Point Numbers Accurately" by Guy + * L. Steele, Jr. and Jon L. White [Proc. ACM SIGPLAN '90, + * pp. 112-126]. This rule has the effect of rendering 1e23 as + * 9.9999999999999999e22 - which is a 'better' approximation in + * the sense that it will reconvert correctly even if a + * subsequent input conversion is 'round up' or 'round down' + * rather than 'round to nearest', but is surprising otherwise. * TCL_DD_E_FORMAT - This value is used to prepare numbers for %e format - * conversion. It constructs a string of at most 'ndigits' digits, + * 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 + * TCL_DD_E_FORMAT|TCL_DD_SHORTEN_FLAG 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 @@ -4234,11 +4200,11 @@ * '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 + * TCL_DD_F_FORMAT|TCL_DD_SHORTEN_FLAG 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 @@ -4267,10 +4233,14 @@ int *sign, /* OUTPUT: 1 if the result is negative. */ char **endPtr) /* OUTPUT: If not NULL, receives a pointer to * one character beyond the end of the * returned string. */ { + int convType = (flags & TCL_DD_CONVERSION_TYPE_MASK); + /* Type of conversion being performed: + * TCL_DD_SHORTEST0, TCL_DD_STEELE0, + * TCL_DD_E_FORMAT, or TCL_DD_F_FORMAT. */ Double d; /* Union for deconstructing doubles. */ Tcl_WideUInt bw; /* Integer significand. */ int be; /* Power of 2 by which b must be multiplied */ int bbits; /* Number of bits needed to represent b. */ int denorm; /* Flag == 1 iff the input number was @@ -4334,22 +4304,22 @@ /* * Correct an incorrect caller-supplied 'ndigits'. Also determine: * i = The maximum number of decimal digits that will be returned in the * formatted string. This is k + 1 + ndigits for F format, 18 for - * shortest, and ndigits for E format. + * shortest and Steele, and ndigits for E format. * ilim = The number of significant digits to convert if k has been - * guessed correctly. This is -1 for shortest (which + * guessed correctly. This is -1 for shortest and Steele (which * stop when all significance has been lost), 'ndigits' for E * format, and 'k + 1 + ndigits' for F format. * ilim1 = The minimum number of significant digits to convert if k has - * been guessed 1 too high. This, too, is -1 for shortest, - * and 'ndigits' for E format, but it's 'ndigits-1' for F + * been guessed 1 too high. This, too, is -1 for shortest and + * Steele, and 'ndigits' for E format, but it's 'ndigits-1' for F * format. */ - SetPrecisionLimits(flags, k, &ndigits, &i, &ilim, &ilim1); + SetPrecisionLimits(convType, k, &ndigits, &i, &ilim, &ilim1); /* * Try to do low-precision conversion in floating point rather than * resorting to expensive multiprecision arithmetic. */ @@ -4371,11 +4341,11 @@ * side. * We may need to increase s2 to put m2plus, m2minus, b2 over a common * denominator. */ - if (flags & TCL_DD_SHORTEST) { + if (flags & TCL_DD_SHORTEN_FLAG) { int m2minus = b2; int m2plus; int m5 = b5; int len = i; @@ -4418,11 +4388,11 @@ * 64-bit arithmetic with no need for expensive multiprecision * operations. (This will be true for all numbers in the range * [1.0e-3 .. 1.0e+24]). */ - return ShorteningInt64Conversion(&d, bw, b2, b5, m2plus, + return ShorteningInt64Conversion(&d, convType, 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, @@ -4437,20 +4407,20 @@ b2 += delta; m2plus += delta; m2minus += delta; s2 += delta; } - return ShorteningBignumConversionPowD(&d, bw, b2, b5, + return ShorteningBignumConversionPowD(&d, convType, bw, b2, b5, m2plus, m2minus, m5, s2/MP_DIGIT_BIT, k, len, ilim, ilim1, decpt, endPtr); } else { /* * Alas, there's no helpful special case; use full-up bignum * arithmetic for the conversion. */ - return ShorteningBignumConversion(&d, bw, b2, m2plus, + return ShorteningBignumConversion(&d, convType, bw, b2, m2plus, m2minus, s2, s5, k, len, ilim, ilim1, decpt, endPtr); } } else { /* * Non-shortening conversion. @@ -4474,11 +4444,11 @@ * 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, + return StrictInt64Conversion(&d, convType, 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, @@ -4491,21 +4461,21 @@ int delta = MP_DIGIT_BIT - (s2 % MP_DIGIT_BIT); b2 += delta; s2 += delta; } - return StrictBignumConversionPowD(bw, b2, b5, + return StrictBignumConversionPowD(&d, convType, 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, + return StrictBignumConversion(&d, convType, bw, b2, s2, s5, k, len, ilim, ilim1, decpt, endPtr); } } } @@ -4539,11 +4509,10 @@ 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; @@ -4555,11 +4524,11 @@ */ maxpow10_wide = (int) floor(sizeof(Tcl_WideUInt) * CHAR_BIT * log(2.) / log(10.)); pow10_wide = (Tcl_WideUInt *) - Tcl_Alloc((maxpow10_wide + 1) * sizeof(Tcl_WideUInt)); + ckalloc((maxpow10_wide + 1) * sizeof(Tcl_WideUInt)); u = 1; for (i = 0; i < maxpow10_wide; ++i) { pow10_wide[i] = u; u *= 10; } @@ -4596,23 +4565,20 @@ /* * Initialize a table of large powers of five. */ for (i=0; i<9; ++i) { - err = err || mp_init(pow5 + i); + mp_init(pow5 + i); } - mp_set_u64(pow5, 5); + mp_set(pow5, 5); for (i=0; i<8; ++i) { - err = err || mp_sqr(pow5+i, pow5+i+1); + mp_sqr(pow5+i, pow5+i+1); } - err = err || mp_init_u64(pow5_13, 1220703125); + mp_init_set_int(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"); + mp_init(pow5_13 + i); + mp_sqr(pow5_13 + i - 1, pow5_13 + i); } /* * Determine the number of decimal digits to the left and right of the * decimal point in the largest and smallest double, the smallest double @@ -4665,11 +4631,11 @@ void TclFinalizeDoubleConversion(void) { int i; - Tcl_Free(pow10_wide); + ckfree((char *) pow10_wide); for (i=0; i<9; ++i) { mp_clear(pow5 + i); } for (i=0; i < 5; ++i) { mp_clear(pow5_13 + i); @@ -4696,16 +4662,14 @@ int Tcl_InitBignumFromDouble( Tcl_Interp *interp, /* For error message. */ double d, /* Number to convert. */ - void *big) /* Place to store the result. */ + mp_int *b) /* 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. */ @@ -4717,30 +4681,25 @@ Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); } return TCL_ERROR; } - fract = frexp(d, &expt); + fract = frexp(d,&expt); if (expt <= 0) { - err = mp_init(b); + 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); + TclBNInitBignumFromWideInt(b, w); + if (shift < 0) { + mp_div_2d(b, -shift, b, NULL); } else if (shift > 0) { - err = mp_mul_2d(b, shift, b); + mp_mul_2d(b, shift, b); } } - if (err != MP_OKAY) { - return TCL_ERROR; - } return TCL_OK; } /* *---------------------------------------------------------------------- @@ -4757,17 +4716,15 @@ *---------------------------------------------------------------------- */ double TclBignumToDouble( - const void *big) /* Integer to convert. */ + mp_int *a) /* 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. @@ -4792,60 +4749,53 @@ * 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); + mp_init(&b); + if (shift == 0) { + mp_copy(a, &b); } else if (shift > 0) { - err = mp_mul_2d(a, shift, &b); + 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)) { + mp_div_2d(a, -shift, &b, NULL); + if (mp_isodd(&b)) { if (mp_isneg(&b)) { - err = mp_sub_d(&b, 1, &b); + mp_sub_d(&b, 1, &b); } else { - err = mp_add_d(&b, 1, &b); + 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); + mp_div_2d(a, -1-shift, &b, NULL); + if (mp_isneg(&b)) { + mp_sub_d(&b, 1, &b); } else { - err = mp_add_d(&b, 1, &b); + mp_add_d(&b, 1, &b); } - err = mp_div_2d(&b, 1, &b, NULL); + 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) { + for (i=b.used-1 ; i>=0 ; --i) { r = ldexp(r, MP_DIGIT_BIT) + b.dp[i]; } mp_clear(&b); /* @@ -4879,49 +4829,40 @@ *---------------------------------------------------------------------- */ double TclCeil( - const void *big) /* Integer to convert. */ + mp_int *a) /* 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); + mp_init(&b); + if (mp_cmp_d(a, 0) == MP_LT) { + 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); + if (shift > 0) { + 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); - } + mp_init(&d); + mp_div_2d(a, -shift, &b, &d); exact = mp_iszero(&d); mp_clear(&d); } else { - err = mp_copy(a, &b); + mp_copy(a, &b); } - if ((err == MP_OKAY) && !exact) { - err = mp_add_d(&b, 1, &b); - } - if (err != MP_OKAY) { - return 0.0; + if (!exact) { + mp_add_d(&b, 1, &b); } for (i=b.used-1 ; i>=0 ; --i) { r = ldexp(r, MP_DIGIT_BIT) + b.dp[i]; } r = ldexp(r, bits - mantBits); @@ -4945,20 +4886,18 @@ *---------------------------------------------------------------------- */ double TclFloor( - const void *big) /* Integer to convert. */ + mp_int *a) /* 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); + mp_init(&b); + if (mp_cmp_d(a, 0) == MP_LT) { + mp_neg(a, &b); r = -TclCeil(&b); } else { int bits = mp_count_bits(a); if (bits > DBL_MAX_EXP*log2FLT_RADIX) { @@ -4965,18 +4904,15 @@ r = DBL_MAX; } else { int i, shift = mantBits - bits; if (shift > 0) { - err = mp_mul_2d(a, shift, &b); + mp_mul_2d(a, shift, &b); } else if (shift < 0) { - err = mp_div_2d(a, -shift, &b, NULL); + mp_div_2d(a, -shift, &b, NULL); } else { - err = mp_copy(a, &b); - } - if (err != MP_OKAY) { - return 0.0; + mp_copy(a, &b); } for (i=b.used-1 ; i>=0 ; --i) { r = ldexp(r, MP_DIGIT_BIT) + b.dp[i]; } r = ldexp(r, bits - mantBits); @@ -5006,47 +4942,42 @@ *---------------------------------------------------------------------- */ static double BignumToBiasedFrExp( - const mp_int *a, /* Integer to convert. */ + mp_int *a, /* Integer to convert. */ 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; - } + mp_init(&b); if (shift > 0) { - err = mp_mul_2d(a, shift, &b); + mp_mul_2d(a, shift, &b); } else if (shift < 0) { - err = mp_div_2d(a, -shift, &b, NULL); + mp_div_2d(a, -shift, &b, NULL); } else { - err = mp_copy(a, &b); + 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]; - } + 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. @@ -5090,11 +5021,11 @@ if (exponent > 0) { /* * Multiply by 10**exponent. */ - retval = frexp(retval * pow10vals[exponent & 0xF], &j); + retval = frexp(retval * pow10vals[exponent&0xF], &j); expt += j; for (i=4; i<9; ++i) { if (exponent & (1<> 32) & 0xFFFFFFFF) | (w << 32)); } -#endif /* *---------------------------------------------------------------------- * * TclNokia770Doubles -- Index: generic/tclStringObj.c ================================================================== --- generic/tclStringObj.c +++ generic/tclStringObj.c @@ -33,67 +33,117 @@ * 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 "tommath.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, size_t appendNumChars); + const Tcl_UniChar *unicode, int appendNumChars); static void AppendUnicodeToUtfRep(Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, size_t numChars); + const Tcl_UniChar *unicode, int numChars); static void AppendUtfToUnicodeRep(Tcl_Obj *objPtr, - const char *bytes, size_t numBytes); + const char *bytes, int numBytes); static void AppendUtfToUtfRep(Tcl_Obj *objPtr, - const char *bytes, size_t numBytes); + const char *bytes, int numBytes); static void DupStringInternalRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); -static size_t ExtendStringRepWithUnicode(Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, size_t numChars); -static void ExtendUnicodeRepWithString(Tcl_Obj *objPtr, - const char *bytes, size_t numBytes, - size_t numAppendChars); static void FillUnicodeRep(Tcl_Obj *objPtr); static void FreeStringInternalRep(Tcl_Obj *objPtr); -static void GrowStringBuffer(Tcl_Obj *objPtr, size_t needed, int flag); -static void GrowUnicodeBuffer(Tcl_Obj *objPtr, size_t needed); +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, size_t numChars); -static size_t UnicodeLength(const Tcl_UniChar *unicode); + 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. */ -const Tcl_ObjType tclStringType = { +Tcl_ObjType tclStringType = { "string", /* name */ FreeStringInternalRep, /* freeIntRepPro */ DupStringInternalRep, /* dupIntRepProc */ UpdateStringOfString, /* updateStringProc */ SetStringFromAny /* setFromAnyProc */ }; - + +/* + * 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 String { + 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. */ + size_t allocated; /* The amount of space actually allocated for + * the UTF string (minus 1 byte for the + * termination char). */ + size_t uallocated; /* The amount of space actually allocated for + * the Unicode string (minus 2 bytes for the + * termination char). */ + int hasUnicode; /* Boolean determining whether the string has + * a Unicode representation. */ + Tcl_UniChar unicode[2]; /* The array of Unicode chars. The actual size + * of this field depends on the 'uallocated' + * field above. */ +} String; + +#define STRING_MAXCHARS \ + (1 + (int)(((size_t)UINT_MAX - sizeof(String))/sizeof(Tcl_UniChar))) +#define STRING_UALLOC(numChars) \ + ((numChars) * sizeof(Tcl_UniChar)) +#define STRING_SIZE(ualloc) \ + ((unsigned) ((ualloc != 0) \ + ? (sizeof(String) - sizeof(Tcl_UniChar) + (ualloc)) \ + : sizeof(String))) +#define stringCheckLimits(numChars) \ + if ((numChars) < 0 || (numChars) > STRING_MAXCHARS) { \ + Tcl_Panic("max length for a Tcl unicode value (%d chars) exceeded", \ + STRING_MAXCHARS); \ + } +#define stringRealloc(ptr, numChars) \ + (String *) ckrealloc((char *) ptr, \ + (unsigned) STRING_SIZE(STRING_UALLOC(numChars)) ) +#define stringAttemptRealloc(ptr, numChars) \ + (String *) attemptckrealloc((char *) ptr, \ + (unsigned) STRING_SIZE(STRING_UALLOC(numChars)) ) +#define GET_STRING(objPtr) \ + ((String *) (objPtr)->internalRep.twoPtrValue.ptr1) +#define SET_STRING(objPtr, stringPtr) \ + ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (stringPtr)) + /* * TCL STRING GROWTH ALGORITHM * * When growing strings (during an append, for example), the following growth * algorithm is used: * * Attempt to allocate 2 * (originalLength + appendLength) * On failure: - * attempt to allocate originalLength + 2*appendLength + TCL_MIN_GROWTH + * attempt to allocate originalLength + 2*appendLength + + * TCL_GROWTH_MIN_ALLOC * * This algorithm allows very good performance, as it rapidly increases the * memory allocated for a given string, which minimizes the number of * reallocations that must be performed. However, using only the doubling * algorithm can lead to a significant waste of memory. In particular, it may @@ -102,121 +152,68 @@ * doubling fails (because there is not enough memory available), the * algorithm requests a smaller amount of memory, which is still enough to * cover the request, but which hopefully will be less than the total * available memory. * - * The addition of TCL_MIN_GROWTH allows for efficient handling of very - * small appends. Without this extra slush factor, a sequence of several small - * appends would cause several memory allocations. As long as - * TCL_MIN_GROWTH is a reasonable size, we can avoid that behavior. - * - * The growth algorithm can be tuned by adjusting the following parameters: - * - * TCL_MIN_GROWTH Additional space, in bytes, to allocate when - * the double allocation has failed. Default is - * 1024 (1 kilobyte). See tclInt.h. - */ - -#ifndef TCL_MIN_UNICHAR_GROWTH -#define TCL_MIN_UNICHAR_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_UniChar) -#endif - -static void -GrowStringBuffer( - Tcl_Obj *objPtr, - size_t needed, - int flag) -{ - /* - * Pre-conditions: - * objPtr->typePtr == &tclStringType - * needed > stringPtr->allocated - * flag || objPtr->bytes != NULL - */ - - String *stringPtr = GET_STRING(objPtr); - char *ptr = NULL; - size_t attempt; - - if (objPtr->bytes == &tclEmptyString) { - objPtr->bytes = NULL; - } - if (flag == 0 || stringPtr->allocated > 0) { - attempt = 2 * needed; - ptr = (char *)Tcl_AttemptRealloc(objPtr->bytes, attempt + 1); - if (ptr == NULL) { - /* - * Take care computing the amount of modest growth to avoid - * overflow into invalid argument values for attempt. - */ - - size_t limit = INT_MAX - needed; - size_t extra = needed - objPtr->length + TCL_MIN_GROWTH; - size_t growth = (extra > limit) ? limit : extra; - - attempt = needed + growth; - ptr = (char *)Tcl_AttemptRealloc(objPtr->bytes, attempt + 1); - } - } - if (ptr == NULL) { - /* - * First allocation - just big enough; or last chance fallback. - */ - - attempt = needed; - ptr = (char *)Tcl_Realloc(objPtr->bytes, attempt + 1); - } - objPtr->bytes = ptr; - stringPtr->allocated = attempt; -} - -static void -GrowUnicodeBuffer( - Tcl_Obj *objPtr, - size_t needed) -{ - /* - * Pre-conditions: - * objPtr->typePtr == &tclStringType - * needed > stringPtr->maxChars - */ - - String *ptr = NULL, *stringPtr = GET_STRING(objPtr); - size_t attempt; - - if (stringPtr->maxChars > 0) { - /* - * Subsequent appends - apply the growth algorithm. - */ - - 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. - */ - - size_t extra = needed - stringPtr->numChars - + TCL_MIN_UNICHAR_GROWTH; - - attempt = needed + extra; - ptr = stringAttemptRealloc(stringPtr, attempt); - } - } - if (ptr == NULL) { - /* - * First allocation - just big enough; or last chance fallback. - */ - - attempt = needed; - ptr = stringRealloc(stringPtr, attempt); - } - stringPtr = ptr; - stringPtr->maxChars = attempt; - SET_STRING(objPtr, stringPtr); -} + * The addition of TCL_GROWTH_MIN_ALLOC allows for efficient handling of very + * small appends. Without this extra slush factor, a sequence of several small + * appends would cause several memory allocations. As long as + * TCL_GROWTH_MIN_ALLOC is a reasonable size, we can avoid that behavior. + * + * The growth algorithm can be tuned by adjusting the following parameters: + * + * TCL_GROWTH_MIN_ALLOC Additional space, in bytes, to allocate when + * the double allocation has failed. Default is + * 1024 (1 kilobyte). + */ + +#ifndef TCL_GROWTH_MIN_ALLOC +#define TCL_GROWTH_MIN_ALLOC 1024 +#endif + +static void +GrowUnicodeBuffer( + Tcl_Obj *objPtr, + int needed) +{ + /* Pre-conditions: + * objPtr->typePtr == &tclStringType + * STRING_UALLOC(needed) > stringPtr->uallocated + * needed < STRING_MAXCHARS + */ + String *ptr = NULL, *stringPtr = GET_STRING(objPtr); + int attempt; + + if (stringPtr->uallocated > 0) { + /* Subsequent appends - apply the growth algorithm. */ + attempt = 2 * needed; + if (attempt >= 0 && attempt <= STRING_MAXCHARS) { + 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_GROWTH_MIN_ALLOC/sizeof(Tcl_UniChar); + 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. */ + attempt = needed; + ptr = stringRealloc(stringPtr, attempt); + } + stringPtr = ptr; + stringPtr->uallocated = STRING_UALLOC(attempt); + SET_STRING(objPtr, stringPtr); +} + /* *---------------------------------------------------------------------- * * Tcl_NewStringObj -- @@ -245,11 +242,11 @@ #undef Tcl_NewStringObj Tcl_Obj * Tcl_NewStringObj( const char *bytes, /* Points to the first of the length bytes * used to initialize the new object. */ - size_t length) /* The number of bytes to copy from "bytes" + 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); @@ -257,17 +254,18 @@ #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. */ - size_t length) /* The number of bytes to copy from "bytes" - * when initializing the new object. If -1, - * use bytes up to the first NUL byte. */ + 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; + register Tcl_Obj *objPtr; - if (length == TCL_INDEX_NONE) { + if (length < 0) { length = (bytes? strlen(bytes) : 0); } TclNewStringObj(objPtr, bytes, length); return objPtr; } @@ -305,21 +303,22 @@ #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. */ - size_t length, /* The number of bytes to copy from "bytes" - * when initializing the new object. If -1, - * use bytes up to the first NUL byte. */ + 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; + register Tcl_Obj *objPtr; - if (length == TCL_INDEX_NONE) { + if (length < 0) { length = (bytes? strlen(bytes) : 0); } TclDbNewObj(objPtr, file, line); TclInitStringRep(objPtr, bytes, length); return objPtr; @@ -327,15 +326,18 @@ #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. */ - size_t length, /* The number of bytes to copy from "bytes" - * when initializing the new object. If -1, - * use bytes up to the first NUL byte. */ - TCL_UNUSED(const char *) /*file*/, - TCL_UNUSED(int) /*line*/) + register 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. */ { return Tcl_NewStringObj(bytes, length); } #endif /* TCL_MEM_DEBUG */ @@ -360,11 +362,11 @@ Tcl_Obj * Tcl_NewUnicodeObj( const Tcl_UniChar *unicode, /* The unicode string used to initialize the * new object. */ - size_t numChars) /* Number of characters in the unicode + int numChars) /* Number of characters in the unicode * string. */ { Tcl_Obj *objPtr; TclNewObj(objPtr); @@ -387,112 +389,83 @@ * rep. * *---------------------------------------------------------------------- */ -size_t +int Tcl_GetCharLength( Tcl_Obj *objPtr) /* The String object to get the num chars * of. */ { String *stringPtr; - size_t numChars = 0; - - /* - * Quick, no-shimmer return for short string reps. - */ - - if ((objPtr->bytes) && (objPtr->length < 2)) { - /* 0 bytes -> 0 chars; 1 byte -> 1 char */ - return objPtr->length; - } - - /* - * Optimize the case where we're really dealing with a bytearray object; - * we don't need to convert to a string to perform the get-length operation. - * - * Starting in Tcl 8.7, we check for a "pure" bytearray, because the - * 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)) { - (void) TclGetByteArrayFromObj(objPtr, &numChars); - return numChars; - } - - /* - * 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 == TCL_INDEX_NONE) { - TclNumUtfChars(numChars, objPtr->bytes, objPtr->length); - stringPtr->numChars = numChars; - } - return numChars; -} - -/* - *---------------------------------------------------------------------- - * - * TclCheckEmptyString -- - * - * Determine whether the string value of an object is or would be the - * empty string, without generating a string representation. - * - * Results: - * Returns 1 if empty, 0 if not, and -1 if unknown. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ -int -TclCheckEmptyString( - Tcl_Obj *objPtr) -{ - int length = -1; - - if (objPtr->bytes == &tclEmptyString) { - return TCL_EMPTYSTRING_YES; - } - - if (TclListObjIsCanonical(objPtr)) { - Tcl_ListObjLength(NULL, objPtr, &length); - return length == 0; - } - - if (TclIsPureDict(objPtr)) { - Tcl_DictObjSize(NULL, objPtr, &length); - return length == 0; - } - - if (objPtr->bytes == NULL) { - return TCL_EMPTYSTRING_UNKNOWN; - } - return objPtr->length == 0; + + /* + * If numChars is unknown, then calculate the number of characaters while + * populating the Unicode string. + */ + + if (stringPtr->numChars == -1) { + register int i = objPtr->length; + register unsigned char *str = (unsigned char *) objPtr->bytes; + + /* + * This is a speed sensitive function, so run specially over the + * string to count continuous ascii characters before resorting to the + * Tcl_NumUtfChars call. This is a long form of: + stringPtr->numChars = Tcl_NumUtfChars(objPtr->bytes,objPtr->length); + * + * TODO: Consider macro-izing this. + */ + + while (i && (*str < 0xC0)) { + i--; + str++; + } + stringPtr->numChars = objPtr->length - i; + if (i) { + stringPtr->numChars += Tcl_NumUtfChars(objPtr->bytes + + (objPtr->length - i), i); + } + + if (stringPtr->numChars == objPtr->length) { + /* + * Since we've just calculated the number of chars, and all UTF + * chars are 1-byte long, we don't need to store the unicode + * string. + */ + + stringPtr->hasUnicode = 0; + } else { + /* + * Since we've just calucalated the number of chars, and not all + * UTF chars are 1-byte long, go ahead and populate the unicode + * string. + */ + + FillUnicodeRep(objPtr); + + /* + * We need to fetch the pointer again because we have just + * reallocated the structure to make room for the Unicode data. + */ + + stringPtr = GET_STRING(objPtr); + } + } + return stringPtr->numChars; } /* *---------------------------------------------------------------------- * * Tcl_GetUniChar -- * - * Get the index'th Unicode character from the String object. If index - * is out of range or it references a low surrogate preceded by a high - * surrogate, the result = -1; + * Get the index'th Unicode character from the String object. The index + * is assumed to be in the appropriate range. * * Results: * Returns the index'th Unicode character in the Object. * * Side effects: @@ -499,77 +472,99 @@ * Fills unichar with the index'th Unicode character. * *---------------------------------------------------------------------- */ -int +Tcl_UniChar Tcl_GetUniChar( Tcl_Obj *objPtr, /* The object to get the Unicode charater * from. */ - size_t index) /* Get the index'th Unicode character. */ -{ - String *stringPtr; - int ch; - - /* - * 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)) { - size_t length = 0; - unsigned char *bytes = TclGetByteArrayFromObj(objPtr, &length); - if (index >= length) { - return -1; - } - - return bytes[index]; - } - - /* - * OK, need to work with the object as a string. - */ + int index) /* Get the index'th Unicode character. */ +{ + Tcl_UniChar unichar; + String *stringPtr; SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); + if (stringPtr->numChars == -1) { + /* + * We haven't yet calculated the length, so we don't have the Unicode + * str. We need to know the number of chars before we can do indexing. + */ + + Tcl_GetCharLength(objPtr); + + /* + * We need to fetch the pointer again because we may have just + * reallocated the structure. + */ + + stringPtr = GET_STRING(objPtr); + } if (stringPtr->hasUnicode == 0) { /* - * If numChars is unknown, compute it. + * All of the characters in the Utf string are 1 byte chars, so we + * don't store the unicode char. We get the Utf string and convert the + * index'th byte to a Unicode character. + */ + + unichar = (Tcl_UniChar) objPtr->bytes[index]; + } else { + unichar = stringPtr->unicode[index]; + } + return unichar; +} + +/* + *---------------------------------------------------------------------- + * + * 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 create 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. + * + *---------------------------------------------------------------------- + */ + +Tcl_UniChar * +Tcl_GetUnicode( + Tcl_Obj *objPtr) /* The object to find the unicode string + * for. */ +{ + String *stringPtr; + + SetStringFromAny(NULL, objPtr); + stringPtr = GET_STRING(objPtr); + + if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) { + /* + * We haven't yet calculated the length, or all of the characters in + * the Utf string are 1 byte chars (so we didn't store the unicode + * str). Since this function must return a unicode string, and one has + * not yet been stored, force the Unicode to be calculated and stored + * now. */ - if (stringPtr->numChars == TCL_INDEX_NONE) { - TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); - } - if (stringPtr->numChars == objPtr->length) { - return (Tcl_UniChar) objPtr->bytes[index]; - } FillUnicodeRep(objPtr); + + /* + * We need to fetch the pointer again because we have just reallocated + * the structure to make room for the Unicode data. + */ + 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; + return stringPtr->unicode; } /* *---------------------------------------------------------------------- * @@ -600,12 +595,26 @@ String *stringPtr; SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); - if (stringPtr->hasUnicode == 0) { + if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) { + /* + * We haven't yet calculated the length, or all of the characters in + * the Utf string are 1 byte chars (so we didn't store the unicode + * str). Since this function must return a unicode string, and one has + * not yet been stored, force the Unicode to be calculated and stored + * now. + */ + FillUnicodeRep(objPtr); + + /* + * We need to fetch the pointer again because we have just reallocated + * the structure to make room for the Unicode data. + */ + stringPtr = GET_STRING(objPtr); } if (lengthPtr != NULL) { *lengthPtr = stringPtr->numChars; @@ -633,96 +642,59 @@ */ Tcl_Obj * Tcl_GetRange( Tcl_Obj *objPtr, /* The Tcl object to find the range of. */ - size_t first, /* First index of the range. */ - size_t last) /* Last index of the range. */ + 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; - size_t length = 0; - - if (first == TCL_INDEX_NONE) { - first = TCL_INDEX_START; - } - if (last + 2 <= first + 1) { - return Tcl_NewObj(); - } - - /* - * 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 = TclGetByteArrayFromObj(objPtr, &length); - - if (last >= length) { - last = length - 1; - } - if (last < first) { - return Tcl_NewObj(); - } - return Tcl_NewByteArrayObj(bytes + first, last - first + 1); - } - - /* - * 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 == TCL_INDEX_NONE) { - TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); - } - if (stringPtr->numChars == objPtr->length) { - if (last >= stringPtr->numChars) { - last = stringPtr->numChars - 1; - } - if (last < first) { - return Tcl_NewObj(); - } - newObjPtr = Tcl_NewStringObj(objPtr->bytes + first, last-first+1); - - /* - * Since we know the char length of the result, store it. - */ - - SetStringFromAny(NULL, newObjPtr); - stringPtr = GET_STRING(newObjPtr); - stringPtr->numChars = newObjPtr->length; - return newObjPtr; - } - FillUnicodeRep(objPtr); - stringPtr = GET_STRING(objPtr); - } - if (last > stringPtr->numChars) { - last = stringPtr->numChars; - } - if (last < first) { - return Tcl_NewObj(); - } -#if TCL_UTF_MAX <= 3 - /* See: bug [11ae2be95dac9417] */ - if ((first + 1 > 1) && ((stringPtr->unicode[first] & 0xFC00) == 0xDC00) - && ((stringPtr->unicode[first-1] & 0xFC00) == 0xD800)) { - ++first; - } - if ((last + 2 < stringPtr->numChars + 1) - && ((stringPtr->unicode[last+1] & 0xFC00) == 0xDC00) - && ((stringPtr->unicode[last] & 0xFC00) == 0xD800)) { - ++last; - } -#endif - return Tcl_NewUnicodeObj(stringPtr->unicode + first, last - first + 1); + + SetStringFromAny(NULL, objPtr); + stringPtr = GET_STRING(objPtr); + + if (stringPtr->numChars == -1) { + /* + * We haven't yet calculated the length, so we don't have the Unicode + * str. We need to know the number of chars before we can do indexing. + */ + + Tcl_GetCharLength(objPtr); + + /* + * We need to fetch the pointer again because we may have just + * reallocated the structure. + */ + + stringPtr = GET_STRING(objPtr); + } + + if (objPtr->bytes && (stringPtr->numChars == objPtr->length)) { + char *str = TclGetString(objPtr); + + /* + * All of the characters in the Utf string are 1 byte chars, so we + * don't store the unicode char. Create a new string object containing + * the specified range of chars. + */ + + newObjPtr = Tcl_NewStringObj(&str[first], last-first+1); + + /* + * Since we know the new string only has 1-byte chars, we can set it's + * numChars field. + */ + + SetStringFromAny(NULL, newObjPtr); + stringPtr = GET_STRING(newObjPtr); + stringPtr->numChars = last-first+1; + } else { + newObjPtr = Tcl_NewUnicodeObj(stringPtr->unicode + first, + last-first+1); + } + return newObjPtr; } /* *---------------------------------------------------------------------- * @@ -744,15 +716,15 @@ *---------------------------------------------------------------------- */ void Tcl_SetStringObj( - Tcl_Obj *objPtr, /* Object whose internal rep to init. */ + register 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. */ - size_t length) /* The number of bytes to copy from "bytes" - * when initializing the object. If -1, + register 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"); } @@ -760,18 +732,19 @@ /* * Set the type to NULL and free any internal rep for the old type. */ TclFreeIntRep(objPtr); + objPtr->typePtr = NULL; /* * Free any old string rep, then set the string rep to a copy of the * length bytes starting at "bytes". */ TclInvalidateStringRep(objPtr); - if (length == TCL_INDEX_NONE) { + if (length < 0) { length = (bytes? strlen(bytes) : 0); } TclInitStringRep(objPtr, bytes, length); } @@ -798,73 +771,104 @@ *---------------------------------------------------------------------- */ void Tcl_SetObjLength( - Tcl_Obj *objPtr, /* Pointer to object. This object must not + register Tcl_Obj *objPtr, /* Pointer to object. This object must not * currently be shared. */ - size_t length) /* Number of bytes desired for string + register 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); + + /* + * Check that we're not extending a pure unicode string. + */ + + if ((size_t)length > stringPtr->allocated && + (objPtr->bytes != NULL || stringPtr->hasUnicode == 0)) { + /* + * Not enough space in current string. Reallocate the string space and + * free the old string. + */ + + if (objPtr->bytes != tclEmptyStringRep) { + objPtr->bytes = ckrealloc((char *) objPtr->bytes, + (unsigned) (length + 1)); + } else { + char *newBytes = ckalloc((unsigned) (length+1)); + + if (objPtr->bytes != NULL && objPtr->length != 0) { + memcpy(newBytes, objPtr->bytes, (size_t) objPtr->length); + TclInvalidateStringRep(objPtr); + } + objPtr->bytes = newBytes; + } + stringPtr->allocated = length; + + /* + * Invalidate the unicode data. + */ + + stringPtr->hasUnicode = 0; + } 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 *)Tcl_Alloc(length + 1); - } else { - objPtr->bytes = (char *)Tcl_Realloc(objPtr->bytes, length + 1); - } - stringPtr->allocated = length; - } - objPtr->length = length; - objPtr->bytes[length] = 0; + if (objPtr->bytes != tclEmptyStringRep) { + /* + * Ensure the string is NUL-terminated. + */ + + objPtr->bytes[length] = 0; + } /* * Invalidate the unicode data. */ - stringPtr->numChars = TCL_INDEX_NONE; + stringPtr->numChars = -1; stringPtr->hasUnicode = 0; } else { - if (length > stringPtr->maxChars) { + /* + * Changing length of pure unicode string. + */ + + size_t uallocated = STRING_UALLOC(length); + + stringCheckLimits(length); + if (uallocated > stringPtr->uallocated) { stringPtr = stringRealloc(stringPtr, length); SET_STRING(objPtr, stringPtr); - stringPtr->maxChars = length; + stringPtr->uallocated = uallocated; } - - /* - * Mark the new end of the unicode string - */ - stringPtr->numChars = length; + stringPtr->hasUnicode = (length > 0); + + /* + * Ensure the string is NUL-terminated. + */ + stringPtr->unicode[length] = 0; - stringPtr->hasUnicode = 1; - - /* - * Can only get here when objPtr->bytes == NULL. No need to invalidate - * the string rep. - */ + stringPtr->allocated = 0; + objPtr->length = 0; } } /* *---------------------------------------------------------------------- @@ -889,86 +893,115 @@ *---------------------------------------------------------------------- */ int Tcl_AttemptSetObjLength( - Tcl_Obj *objPtr, /* Pointer to object. This object must not + register Tcl_Obj *objPtr, /* Pointer to object. This object must not * currently be shared. */ - size_t length) /* Number of bytes desired for string + register 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; - } - 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. - */ - - char *newBytes; - - if (objPtr->bytes == &tclEmptyString) { - newBytes = (char *)Tcl_AttemptAlloc(length + 1); - } else { - newBytes = (char *)Tcl_AttemptRealloc(objPtr->bytes, length + 1); - } + /* + * Check that we're not extending a pure unicode string. + */ + + if (length > (int) stringPtr->allocated && + (objPtr->bytes != NULL || stringPtr->hasUnicode == 0)) { + char *newBytes; + + /* + * Not enough space in current string. Reallocate the string space and + * free the old string. + */ + + if (objPtr->bytes != tclEmptyStringRep) { + newBytes = attemptckrealloc(objPtr->bytes, + (unsigned)(length + 1)); + if (newBytes == NULL) { + return 0; + } + } else { + newBytes = attemptckalloc((unsigned) (length + 1)); if (newBytes == NULL) { return 0; } - objPtr->bytes = newBytes; - stringPtr->allocated = length; + if (objPtr->bytes != NULL && objPtr->length != 0) { + memcpy(newBytes, objPtr->bytes, (size_t) objPtr->length); + TclInvalidateStringRep(objPtr); + } } + objPtr->bytes = newBytes; + stringPtr->allocated = length; + /* + * Invalidate the unicode data. + */ + + stringPtr->hasUnicode = 0; + } + + if (objPtr->bytes != NULL) { objPtr->length = length; - objPtr->bytes[length] = 0; + if (objPtr->bytes != tclEmptyStringRep) { + /* + * Ensure the string is NULL-terminated. + */ + + objPtr->bytes[length] = 0; + } /* * Invalidate the unicode data. */ - stringPtr->numChars = TCL_INDEX_NONE; + stringPtr->numChars = -1; stringPtr->hasUnicode = 0; } else { /* * Changing length of pure unicode string. */ - if (length > stringPtr->maxChars) { + size_t uallocated = STRING_UALLOC(length); + if (length > STRING_MAXCHARS) { + return 0; + } + + if (uallocated > stringPtr->uallocated) { stringPtr = stringAttemptRealloc(stringPtr, length); if (stringPtr == NULL) { return 0; } SET_STRING(objPtr, stringPtr); - stringPtr->maxChars = length; + stringPtr->uallocated = uallocated; } + stringPtr->numChars = length; + stringPtr->hasUnicode = (length > 0); /* - * Mark the new end of the unicode string. + * Ensure the string is NUL-terminated. */ stringPtr->unicode[length] = 0; - stringPtr->numChars = length; - stringPtr->hasUnicode = 1; - - /* - * Can only get here when objPtr->bytes == NULL. No need to invalidate - * the string rep. - */ + stringPtr->allocated = 0; + objPtr->length = 0; } return 1; } /* @@ -990,64 +1023,68 @@ 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. */ - size_t numChars) /* Number of characters in the unicode + 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 size_t +static int UnicodeLength( const Tcl_UniChar *unicode) { - size_t numChars = 0; + int numChars = 0; if (unicode) { - while ((numChars != TCL_INDEX_NONE) && (unicode[numChars] != 0)) { + 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. */ - size_t numChars) /* Number of characters in the unicode + int numChars) /* Number of characters in the unicode * string. */ { String *stringPtr; + size_t uallocated; - if (numChars == TCL_INDEX_NONE) { + if (numChars < 0) { numChars = UnicodeLength(unicode); } /* * Allocate enough space for the String structure + Unicode string. */ - stringPtr = stringAlloc(numChars); - SET_STRING(objPtr, stringPtr); - objPtr->typePtr = &tclStringType; + stringCheckLimits(numChars); + uallocated = STRING_UALLOC(numChars); + stringPtr = (String *) ckalloc(STRING_SIZE(uallocated)); - stringPtr->maxChars = numChars; - memcpy(stringPtr->unicode, unicode, numChars * sizeof(Tcl_UniChar)); - stringPtr->unicode[numChars] = 0; stringPtr->numChars = numChars; - stringPtr->hasUnicode = 1; + stringPtr->uallocated = uallocated; + stringPtr->hasUnicode = (numChars > 0); + stringPtr->allocated = 0; + memcpy(stringPtr->unicode, unicode, uallocated); + stringPtr->unicode[numChars] = 0; TclInvalidateStringRep(objPtr); - stringPtr->allocated = 0; + objPtr->typePtr = &tclStringType; + SET_STRING(objPtr, stringPtr); } /* *---------------------------------------------------------------------- * @@ -1066,27 +1103,27 @@ *---------------------------------------------------------------------- */ void Tcl_AppendLimitedToObj( - Tcl_Obj *objPtr, /* Points to the object to append to. */ + register Tcl_Obj *objPtr, /* Points to the object to append to. */ const char *bytes, /* Points to the bytes to append to the * object. */ - size_t length, /* The number of bytes available to be - * appended from "bytes". If -1, then - * all bytes up to a NUL byte are available. */ - size_t limit, /* The maximum number of bytes to append to + register int length, /* The number of bytes available to be + * appended from "bytes". If < 0, then all + * bytes up to a NUL byte are available. */ + register 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; - size_t toCopy = 0; - size_t eLen = 0; + int toCopy = 0; + int eLen = 0; - if (length == TCL_INDEX_NONE) { + if (length < 0) { length = (bytes ? strlen(bytes) : 0); } if (length == 0) { return; } @@ -1118,12 +1155,11 @@ Tcl_Panic("%s called with shared object", "Tcl_AppendLimitedToObj"); } SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); - - if (stringPtr->hasUnicode && (stringPtr->numChars+1) > 1) { + if (stringPtr->hasUnicode != 0) { AppendUtfToUnicodeRep(objPtr, bytes, toCopy); } else { AppendUtfToUtfRep(objPtr, bytes, toCopy); } @@ -1130,11 +1166,11 @@ if (length <= limit) { return; } stringPtr = GET_STRING(objPtr); - if (stringPtr->hasUnicode && (stringPtr->numChars+1) > 1) { + if (stringPtr->hasUnicode != 0) { AppendUtfToUnicodeRep(objPtr, ellipsis, eLen); } else { AppendUtfToUtfRep(objPtr, ellipsis, eLen); } } @@ -1156,24 +1192,24 @@ *---------------------------------------------------------------------- */ void Tcl_AppendToObj( - Tcl_Obj *objPtr, /* Points to the object to append to. */ + register Tcl_Obj *objPtr, /* Points to the object to append to. */ const char *bytes, /* Points to the bytes to append to the * object. */ - size_t length) /* The number of bytes to append from "bytes". - * If -1, then append all bytes up to NUL + register 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, TCL_INDEX_NONE, NULL); + Tcl_AppendLimitedToObj(objPtr, bytes, length, INT_MAX, NULL); } /* *---------------------------------------------------------------------- * - * TclAppendUnicodeToObj -- + * Tcl_AppendUnicodeToObj -- * * This function appends a Unicode string to an object in the most * efficient manner possible. Length must be >= 0. * * Results: @@ -1184,20 +1220,20 @@ * *---------------------------------------------------------------------- */ void -TclAppendUnicodeToObj( - Tcl_Obj *objPtr, /* Points to the object to append to. */ +Tcl_AppendUnicodeToObj( + register Tcl_Obj *objPtr, /* Points to the object to append to. */ const Tcl_UniChar *unicode, /* The unicode string to append to the * object. */ - size_t length) /* Number of chars in "unicode". */ + int length) /* Number of chars in "unicode". */ { String *stringPtr; if (Tcl_IsShared(objPtr)) { - Tcl_Panic("%s called with shared object", "TclAppendUnicodeToObj"); + Tcl_Panic("%s called with shared object", "Tcl_AppendUnicodeToObj"); } if (length == 0) { return; } @@ -1209,11 +1245,11 @@ * If objPtr has a valid Unicode rep, then append the "unicode" to the * objPtr's Unicode rep, otherwise the UTF conversion of "unicode" to * objPtr's string rep. */ - if (stringPtr->hasUnicode) { + if (stringPtr->hasUnicode != 0) { AppendUnicodeToUnicodeRep(objPtr, unicode, length); } else { AppendUnicodeToUtfRep(objPtr, unicode, length); } } @@ -1242,100 +1278,39 @@ Tcl_AppendObjToObj( Tcl_Obj *objPtr, /* Points to the object to append to. */ Tcl_Obj *appendObjPtr) /* Object to append. */ { String *stringPtr; - size_t length = 0, numChars; - size_t appendNumChars = TCL_INDEX_NONE; - const char *bytes; - - /* - * Special case: second object is standard-empty is fast case. We know - * that appending nothing to anything leaves that starting anything... - */ - - if (appendObjPtr->bytes == &tclEmptyString) { - return; - } - - /* - * Handle append of one bytearray object to another as a special case. - * Note that we only do this when the objects are pure so that the - * bytearray faithfully represent the true value; Otherwise appending the - * byte arrays together could lose information; - */ - - if ((TclIsPureByteArray(objPtr) || objPtr->bytes == &tclEmptyString) - && TclIsPureByteArray(appendObjPtr)) { - /* - * You might expect the code here to be - * - * bytes = TclGetByteArrayFromObj(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. - */ - - size_t lengthSrc = 0; - - (void) TclGetByteArrayFromObj(objPtr, &length); - (void) TclGetByteArrayFromObj(appendObjPtr, &lengthSrc); - - /* - * Grow buffer enough for the append. - */ - - TclAppendBytesToByteArray(objPtr, NULL, lengthSrc); - - /* - * Reset objPtr back to the original value. - */ - - Tcl_SetByteArrayLength(objPtr, length); - - /* - * Now do the append knowing that buffer growth cannot cause any - * trouble. - */ - - TclAppendBytesToByteArray(objPtr, - Tcl_GetByteArrayFromObj(appendObjPtr, NULL), lengthSrc); - return; - } - - /* - * Must append as strings. - */ + int length, numChars, allOneByteChars; + char *bytes; SetStringFromAny(NULL, objPtr); - stringPtr = GET_STRING(objPtr); /* * If objPtr has a valid Unicode rep, then get a Unicode string from * appendObjPtr and append it. */ - if (stringPtr->hasUnicode) { + stringPtr = GET_STRING(objPtr); + if (stringPtr->hasUnicode != 0) { /* * If appendObjPtr is not of the "String" type, don't convert it. */ - if (TclHasIntRep(appendObjPtr, &tclStringType)) { - Tcl_UniChar *unicode = - TclGetUnicodeFromObj(appendObjPtr, &numChars); + if (appendObjPtr->typePtr == &tclStringType) { + stringPtr = GET_STRING(appendObjPtr); + if ((stringPtr->numChars == -1) || (stringPtr->hasUnicode == 0)) { + /* + * If appendObjPtr is a string obj with no valid Unicode rep, + * then fill its unicode rep. + */ - AppendUnicodeToUnicodeRep(objPtr, unicode, numChars); + FillUnicodeRep(appendObjPtr); + stringPtr = GET_STRING(appendObjPtr); + } + AppendUnicodeToUnicodeRep(objPtr, stringPtr->unicode, + stringPtr->numChars); } else { bytes = TclGetStringFromObj(appendObjPtr, &length); AppendUtfToUnicodeRep(objPtr, bytes, length); } return; @@ -1347,21 +1322,25 @@ * characters in the final (appended-to) object. */ bytes = TclGetStringFromObj(appendObjPtr, &length); + allOneByteChars = 0; numChars = stringPtr->numChars; - if ((numChars != TCL_INDEX_NONE) && TclHasIntRep(appendObjPtr, &tclStringType)) { - String *appendStringPtr = GET_STRING(appendObjPtr); - - appendNumChars = appendStringPtr->numChars; + if ((numChars >= 0) && (appendObjPtr->typePtr == &tclStringType)) { + stringPtr = GET_STRING(appendObjPtr); + if ((stringPtr->numChars >= 0) && (stringPtr->numChars == length)) { + numChars += stringPtr->numChars; + allOneByteChars = 1; + } } AppendUtfToUtfRep(objPtr, bytes, length); - if ((numChars != TCL_INDEX_NONE) && (appendNumChars != TCL_INDEX_NONE)) { - stringPtr->numChars = numChars + appendNumChars; + if (allOneByteChars) { + stringPtr = GET_STRING(objPtr); + stringPtr->numChars = numChars; } } /* *---------------------------------------------------------------------- @@ -1382,16 +1361,16 @@ static void AppendUnicodeToUnicodeRep( Tcl_Obj *objPtr, /* Points to the object to append to. */ const Tcl_UniChar *unicode, /* String to append. */ - size_t appendNumChars) /* Number of chars of "unicode" to append. */ + int appendNumChars) /* Number of chars of "unicode" to append. */ { String *stringPtr; - size_t numChars; + int numChars; - if (appendNumChars == TCL_INDEX_NONE) { + if (appendNumChars < 0) { appendNumChars = UnicodeLength(unicode); } if (appendNumChars == 0) { return; } @@ -1406,44 +1385,41 @@ * "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) { - size_t index = TCL_INDEX_NONE; - + if (STRING_UALLOC(numChars) > stringPtr->uallocated) { /* * Protect against case where unicode points into the existing - * stringPtr->unicode array. Force it to follow any relocations due to - * the reallocs below. + * stringPtr->unicode array. Force it to follow any relocations + * due to the reallocs below. */ - + int offset = -1; if (unicode && unicode >= stringPtr->unicode - && unicode <= stringPtr->unicode + stringPtr->maxChars) { - index = unicode - stringPtr->unicode; + && unicode <= stringPtr->unicode + + stringPtr->uallocated / sizeof(Tcl_UniChar)) { + offset = unicode - stringPtr->unicode; } GrowUnicodeBuffer(objPtr, numChars); stringPtr = GET_STRING(objPtr); - /* - * Relocate unicode if needed; see above. - */ - - if (index != TCL_INDEX_NONE) { - unicode = stringPtr->unicode + index; + /* 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. */ if (unicode) { - memmove(stringPtr->unicode + stringPtr->numChars, unicode, + memcpy(stringPtr->unicode + stringPtr->numChars, unicode, appendNumChars * sizeof(Tcl_UniChar)); } stringPtr->unicode[numChars] = 0; stringPtr->numChars = numChars; stringPtr->allocated = 0; @@ -1470,29 +1446,36 @@ static void AppendUnicodeToUtfRep( Tcl_Obj *objPtr, /* Points to the object to append to. */ const Tcl_UniChar *unicode, /* String to convert to UTF. */ - size_t numChars) /* Number of chars of "unicode" to convert. */ -{ - String *stringPtr = GET_STRING(objPtr); - - numChars = ExtendStringRepWithUnicode(objPtr, unicode, numChars); - - if (stringPtr->numChars != TCL_INDEX_NONE) { - stringPtr->numChars += numChars; - } + int numChars) /* Number of chars of "unicode" to convert. */ +{ + Tcl_DString dsPtr; + const char *bytes; + + if (numChars < 0) { + numChars = UnicodeLength(unicode); + } + if (numChars == 0) { + return; + } + + Tcl_DStringInit(&dsPtr); + bytes = Tcl_UniCharToUtfDString(unicode, numChars, &dsPtr); + AppendUtfToUtfRep(objPtr, bytes, Tcl_DStringLength(&dsPtr)); + Tcl_DStringFree(&dsPtr); } /* *---------------------------------------------------------------------- * * AppendUtfToUnicodeRep -- * * This function converts the contents of "bytes" to Unicode and appends * the Unicode to the Unicode rep of "objPtr". objPtr must already have a - * valid Unicode rep. numBytes must be non-negative. + * valid Unicode rep. * * Results: * None. * * Side effects: @@ -1503,32 +1486,40 @@ static void AppendUtfToUnicodeRep( Tcl_Obj *objPtr, /* Points to the object to append to. */ const char *bytes, /* String to convert to Unicode. */ - size_t numBytes) /* Number of bytes of "bytes" to convert. */ + int numBytes) /* Number of bytes of "bytes" to convert. */ { - String *stringPtr; + Tcl_DString dsPtr; + int numChars = numBytes; + Tcl_UniChar *unicode = NULL; + if (numBytes < 0) { + numBytes = (bytes ? strlen(bytes) : 0); + } if (numBytes == 0) { return; } - ExtendUnicodeRepWithString(objPtr, bytes, numBytes, -1); - TclInvalidateStringRep(objPtr); - stringPtr = GET_STRING(objPtr); - stringPtr->allocated = 0; + Tcl_DStringInit(&dsPtr); + if (bytes) { + numChars = Tcl_NumUtfChars(bytes, numBytes); + unicode = (Tcl_UniChar *) Tcl_UtfToUniCharDString(bytes, numBytes, + &dsPtr); + } + AppendUnicodeToUnicodeRep(objPtr, unicode, numChars); + Tcl_DStringFree(&dsPtr); } /* *---------------------------------------------------------------------- * * AppendUtfToUtfRep -- * * This function appends "numBytes" bytes of "bytes" to the UTF string * rep of "objPtr". objPtr must already have a valid String rep. - * numBytes must be non-negative. * * Results: * None. * * Side effects: @@ -1539,74 +1530,234 @@ static void AppendUtfToUtfRep( Tcl_Obj *objPtr, /* Points to the object to append to. */ const char *bytes, /* String to append. */ - size_t numBytes) /* Number of bytes of "bytes" to append. */ + int numBytes) /* Number of bytes of "bytes" to append. */ { String *stringPtr; - size_t newLength, oldLength; + int newLength, oldLength; + if (numBytes < 0) { + numBytes = (bytes ? strlen(bytes) : 0); + } 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) { - size_t offset = TCL_INDEX_NONE; - + if (newLength > (int) stringPtr->allocated) { /* * Protect against case where unicode points into the existing - * stringPtr->unicode array. Force it to follow any relocations due to - * the reallocs below. + * stringPtr->unicode array. Force it to follow any relocations + * due to the reallocs below. */ - + int offset = -1; if (bytes && bytes >= objPtr->bytes && bytes <= objPtr->bytes + objPtr->length) { offset = bytes - objPtr->bytes; } /* - * TODO: consider passing flag=1: no overalloc on first append. This - * would make test stringObj-8.1 fail. + * There isn't currently enough space in the string representation so + * allocate additional space. First, try to double the length + * required. If that fails, try a more modest allocation. See the "TCL + * STRING GROWTH ALGORITHM" comment at the top of this file for an + * explanation of this growth algorithm. */ - GrowStringBuffer(objPtr, newLength, 0); + if (Tcl_AttemptSetObjLength(objPtr, 2 * newLength) == 0) { + /* + * Take care computing the amount of modest growth to avoid + * overflow into invalid argument values for Tcl_SetObjLength. + */ + unsigned int limit = INT_MAX - newLength; + unsigned int extra = numBytes + TCL_GROWTH_MIN_ALLOC; + int growth = (int) ((extra > limit) ? limit : extra); - /* - * Relocate bytes if needed; see above. - */ + Tcl_SetObjLength(objPtr, newLength + growth); + } - if (offset != TCL_INDEX_NONE) { + /* Relocate bytes if needed; see above. */ + if (offset >=0) { bytes = objPtr->bytes + offset; } } /* * Invalidate the unicode data. */ - stringPtr->numChars = TCL_INDEX_NONE; + stringPtr->numChars = -1; stringPtr->hasUnicode = 0; if (bytes) { - memmove(objPtr->bytes + oldLength, bytes, numBytes); + memcpy(objPtr->bytes + oldLength, bytes, (size_t) 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. */ +{ +#define STATIC_LIST_SIZE 16 + String *stringPtr; + int newLength, oldLength, attemptLength; + register char *string, *dst; + char *static_list[STATIC_LIST_SIZE]; + char **args = static_list; + int nargs_space = STATIC_LIST_SIZE; + int nargs, i; + + if (Tcl_IsShared(objPtr)) { + Tcl_Panic("%s called with shared object", "Tcl_AppendStringsToObj"); + } + + SetStringFromAny(NULL, objPtr); + + /* + * Force the existence of a string rep. so we avoid crashes operating + * on a pure unicode value. [Bug 2597185] + */ + + (void) Tcl_GetStringFromObj(objPtr, &oldLength); + + /* + * Figure out how much space is needed for all the strings, and expand the + * string representation if it isn't big enough. If no bytes would be + * appended, just return. Note that on some platforms (notably OS/390) the + * argList is an array so we need to use memcpy. + */ + + nargs = 0; + newLength = 0; + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + if (nargs >= nargs_space) { + /* + * Expand the args buffer. + */ + + nargs_space += STATIC_LIST_SIZE; + if (args == static_list) { + args = (void *) ckalloc(nargs_space * sizeof(char *)); + for (i = 0; i < nargs; ++i) { + args[i] = static_list[i]; + } + } else { + args = (void *) ckrealloc((void *) args, + nargs_space * sizeof(char *)); + } + } + newLength += strlen(string); + args[nargs++] = string; + } + if (newLength == 0) { + goto done; + } + + stringPtr = GET_STRING(objPtr); + if (oldLength + newLength > (int) stringPtr->allocated) { + /* + * There isn't currently enough space in the string representation, so + * allocate additional space. If the current string representation + * isn't empty (i.e. it looks like we're doing a series of appends) + * then try to allocate extra space to accomodate future growth: first + * try to double the required memory; if that fails, try a more modest + * allocation. See the "TCL STRING GROWTH ALGORITHM" comment at the + * top of this file for an explanation of this growth algorithm. + * Otherwise, if the current string representation is empty, exactly + * enough memory is allocated. + */ + + if (oldLength == 0) { + Tcl_SetObjLength(objPtr, newLength); + } else { + attemptLength = 2 * (oldLength + newLength); + if (Tcl_AttemptSetObjLength(objPtr, attemptLength) == 0) { + attemptLength = oldLength + (2 * newLength) + + TCL_GROWTH_MIN_ALLOC; + Tcl_SetObjLength(objPtr, attemptLength); + } + } + } + + /* + * Make a second pass through the arguments, appending all the strings to + * the object. + */ + + dst = objPtr->bytes + oldLength; + for (i = 0; i < nargs; ++i) { + string = args[i]; + if (string == NULL) { + break; + } + while (*string != 0) { + *dst = *string; + dst++; + string++; + } + } + + /* + * Add a null byte to terminate the string. However, be careful: it's + * possible that the object is totally empty (if it was empty originally + * and there was nothing to append). In this case dst is NULL; just leave + * everything alone. + */ + + if (dst != NULL) { + *dst = 0; + } + objPtr->length = oldLength + newLength; + + done: + /* + * If we had to allocate a buffer from the heap, free it now. + */ + + if (args != static_list) { + ckfree((void *) args); + } +#undef STATIC_LIST_SIZE +} /* *---------------------------------------------------------------------- * * Tcl_AppendStringsToObj -- @@ -1630,22 +1781,11 @@ ...) { va_list argList; va_start(argList, objPtr); - 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_AppendStringsToObjVA(objPtr, argList); va_end(argList); } /* *---------------------------------------------------------------------- @@ -1673,53 +1813,48 @@ Tcl_Obj *appendObj, const char *format, int objc, Tcl_Obj *const objv[]) { - const char *span = format, *msg, *errCode; - int objIndex = 0, gotXpg = 0, gotSequential = 0; - size_t originalLength, limit, numBytes = 0; - Tcl_UniChar ch = 0; + const char *span = format, *msg; + int numBytes = 0, objIndex = 0, gotXpg = 0, gotSequential = 0; + int originalLength, limit; static const char *mixedXPG = "cannot mix \"%\" and \"%n$\" conversion specifiers"; - static const char *const badIndex[2] = { + static const char *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"); } - (void)TclGetStringFromObj(appendObj, &originalLength); - limit = (size_t)INT_MAX - originalLength; + 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; - size_t segmentNumBytes; + int gotMinus, gotHash, gotZero, gotSpace, gotPlus, sawFlag; + int width, gotPrecision, precision, useShort, useWide, useBig; + int newXpg, numChars, allocSegment = 0, segmentLimit, segmentNumBytes; Tcl_Obj *segment; - int step = TclUtfToUniChar(format, &ch); + Tcl_UniChar ch; + int step = Tcl_UtfToUniChar(format, &ch); format += step; if (ch != '%') { numBytes += step; continue; } if (numBytes) { if (numBytes > limit) { msg = overflow; - errCode = "OVERFLOW"; goto errorMsg; } Tcl_AppendToObj(appendObj, span, numBytes); limit -= numBytes; numBytes = 0; @@ -1729,11 +1864,11 @@ * Saw a % : process the format specifier. * * Step 0. Handle special case of escaped format marker (i.e., %%). */ - step = TclUtfToUniChar(format, &ch); + step = Tcl_UtfToUniChar(format, &ch); if (ch == '%') { span = format; numBytes = step; format += step; continue; @@ -1744,43 +1879,40 @@ */ newXpg = 0; if (isdigit(UCHAR(ch))) { int position = strtoul(format, &end, 10); - if (*end == '$') { newXpg = 1; objIndex = position - 1; format = end + 1; - step = TclUtfToUniChar(format, &ch); + step = Tcl_UtfToUniChar(format, &ch); } } if (newXpg) { if (gotSequential) { msg = mixedXPG; - errCode = "MIXEDSPECTYPES"; goto errorMsg; } gotXpg = 1; } else { if (gotXpg) { msg = mixedXPG; - errCode = "MIXEDSPECTYPES"; goto errorMsg; } gotSequential = 1; } if ((objIndex < 0) || (objIndex >= objc)) { msg = badIndex[gotXpg]; - errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH"; goto errorMsg; } /* * Step 2. Set of flags. */ + gotMinus = gotHash = gotZero = gotSpace = gotPlus = 0; sawFlag = 1; do { switch (ch) { case '-': gotMinus = 1; @@ -1800,11 +1932,11 @@ default: sawFlag = 0; } if (sawFlag) { format += step; - step = TclUtfToUniChar(format, &ch); + step = Tcl_UtfToUniChar(format, &ch); } } while (sawFlag); /* * Step 3. Minimum field width. @@ -1813,19 +1945,17 @@ width = 0; if (isdigit(UCHAR(ch))) { width = strtoul(format, &end, 10); if (width < 0) { msg = overflow; - errCode = "OVERFLOW"; goto errorMsg; } format = end; - step = TclUtfToUniChar(format, &ch); + step = Tcl_UtfToUniChar(format, &ch); } else if (ch == '*') { if (objIndex >= objc - 1) { msg = badIndex[gotXpg]; - errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH"; goto errorMsg; } if (TclGetIntFromObj(interp, objv[objIndex], &width) != TCL_OK) { goto error; } @@ -1833,15 +1963,14 @@ width = -width; gotMinus = 1; } objIndex++; format += step; - step = TclUtfToUniChar(format, &ch); + step = Tcl_UtfToUniChar(format, &ch); } - if (width > (int) limit) { + if (width > limit) { msg = overflow; - errCode = "OVERFLOW"; goto errorMsg; } /* * Step 4. Precision. @@ -1849,20 +1978,19 @@ gotPrecision = precision = 0; if (ch == '.') { gotPrecision = 1; format += step; - step = TclUtfToUniChar(format, &ch); + step = Tcl_UtfToUniChar(format, &ch); } if (isdigit(UCHAR(ch))) { precision = strtoul(format, &end, 10); format = end; - step = TclUtfToUniChar(format, &ch); + step = Tcl_UtfToUniChar(format, &ch); } else if (ch == '*') { if (objIndex >= objc - 1) { msg = badIndex[gotXpg]; - errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH"; goto errorMsg; } if (TclGetIntFromObj(interp, objv[objIndex], &precision) != TCL_OK) { goto error; @@ -1875,52 +2003,34 @@ if (precision < 0) { precision = 0; } objIndex++; format += step; - step = TclUtfToUniChar(format, &ch); + step = Tcl_UtfToUniChar(format, &ch); } /* * Step 5. Length modifier. */ - if (ch == 'h') { - useShort = 1; - format += step; - step = TclUtfToUniChar(format, &ch); - } else if (ch == 'l') { - format += step; - step = TclUtfToUniChar(format, &ch); - if (ch == 'l') { - useBig = 1; - format += step; - step = TclUtfToUniChar(format, &ch); -#ifndef TCL_WIDE_INT_IS_LONG - } else { - useWide = 1; -#endif - } - } else if (ch == 'I') { - if ((format[1] == '6') && (format[2] == '4')) { - format += (step + 2); - step = TclUtfToUniChar(format, &ch); -#ifndef TCL_WIDE_INT_IS_LONG - useWide = 1; -#endif - } else if ((format[1] == '3') && (format[2] == '2')) { - format += (step + 2); - step = TclUtfToUniChar(format, &ch); - } else { - format += step; - step = TclUtfToUniChar(format, &ch); - } - } else if ((ch == 't') || (ch == 'z') || (ch == 'q') || (ch == 'j') - || (ch == 'L')) { - format += step; - step = TclUtfToUniChar(format, &ch); - useBig = 1; + useShort = useWide = useBig = 0; + if (ch == 'h') { + useShort = 1; + format += step; + step = Tcl_UtfToUniChar(format, &ch); + } else if (ch == 'l') { + format += step; + step = Tcl_UtfToUniChar(format, &ch); + if (ch == 'l') { + useBig = 1; + format += step; + step = Tcl_UtfToUniChar(format, &ch); + } else { +#ifndef TCL_WIDE_INT_IS_LONG + useWide = 1; +#endif + } } format += step; span = format; @@ -1934,11 +2044,10 @@ ch = 'd'; } switch (ch) { case '\0': msg = "format string ended in middle of field specifier"; - errCode = "INCOMPLETE"; goto errorMsg; case 's': if (gotPrecision) { numChars = Tcl_GetCharLength(segment); if (precision < numChars) { @@ -1948,142 +2057,126 @@ allocSegment = 1; } } break; case 'c': { - char buf[4] = ""; + char buf[TCL_UTF_MAX]; int code, length; if (TclGetIntFromObj(interp, segment, &code) != TCL_OK) { goto error; } length = Tcl_UniCharToUtf(code, buf); - if ((code >= 0xD800) && (length < 3)) { - /* Special case for handling high surrogates. */ - length += Tcl_UniCharToUtf(-1, buf + length); - } segment = Tcl_NewStringObj(buf, length); Tcl_IncrRefCount(segment); allocSegment = 1; break; } case 'u': + if (useBig) { + msg = "unsigned bignum format is invalid"; + goto errorMsg; + } /* FALLTHRU */ case 'd': case 'o': - case 'p': case 'x': - case 'X': - case 'b': { - short s = 0; /* Silence compiler warning; only defined and + case 'X': { + short int s = 0; /* Silence compiler warning; only defined and * used when useShort is true. */ long l; Tcl_WideInt w; mp_int big; int toAppend, isNegative = 0; -#ifndef TCL_WIDE_INT_IS_LONG - if (ch == 'p') { - useWide = 1; - } -#endif if (useBig) { - int cmpResult; if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) { goto error; } - cmpResult = mp_cmp_d(&big, 0); - isNegative = (cmpResult == MP_LT); - if (cmpResult == MP_EQ) gotHash = 0; - if (ch == 'u') { - if (isNegative) { - mp_clear(&big); - msg = "unsigned bignum format is invalid"; - errCode = "BADUNSIGNED"; - goto errorMsg; - } else { - ch = 'd'; - } - } -#ifndef TCL_WIDE_INT_IS_LONG + isNegative = (mp_cmp_d(&big, 0) == MP_LT); } else if (useWide) { - if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) { - goto error; + if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) { + Tcl_Obj *objPtr; + + if (Tcl_GetBignumFromObj(interp,segment,&big) != TCL_OK) { + goto error; + } + mp_mod_2d(&big, CHAR_BIT*sizeof(Tcl_WideInt), &big); + objPtr = Tcl_NewBignumObj(&big); + Tcl_IncrRefCount(objPtr); + Tcl_GetWideIntFromObj(NULL, objPtr, &w); + Tcl_DecrRefCount(objPtr); } - isNegative = (w < (Tcl_WideInt) 0); - if (w == (Tcl_WideInt) 0) gotHash = 0; -#endif + isNegative = (w < (Tcl_WideInt)0); } else if (TclGetLongFromObj(NULL, segment, &l) != TCL_OK) { - if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) { - goto error; + if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) { + Tcl_Obj *objPtr; + + if (Tcl_GetBignumFromObj(interp,segment,&big) != TCL_OK) { + goto error; + } + mp_mod_2d(&big, CHAR_BIT * sizeof(long), &big); + objPtr = Tcl_NewBignumObj(&big); + Tcl_IncrRefCount(objPtr); + TclGetLongFromObj(NULL, objPtr, &l); + Tcl_DecrRefCount(objPtr); } else { - l = (long) w; + l = Tcl_WideAsLong(w); } if (useShort) { - s = (short) l; - isNegative = (s < (short) 0); - if (s == (short) 0) gotHash = 0; + s = (short int) l; + isNegative = (s < (short int)0); } else { - isNegative = (l < (long) 0); - if (l == (long) 0) gotHash = 0; + isNegative = (l < (long)0); } } else if (useShort) { - s = (short) l; - isNegative = (s < (short) 0); - if (s == (short) 0) gotHash = 0; + s = (short int) l; + isNegative = (s < (short int)0); } else { - isNegative = (l < (long) 0); - if (l == (long) 0) gotHash = 0; + isNegative = (l < (long)0); } - TclNewObj(segment); + segment = Tcl_NewObj(); allocSegment = 1; segmentLimit = INT_MAX; Tcl_IncrRefCount(segment); - if ((isNegative || gotPlus || gotSpace) && (useBig || ch=='d')) { - Tcl_AppendToObj(segment, - (isNegative ? "-" : gotPlus ? "+" : " "), 1); + if ((isNegative || gotPlus || gotSpace) && (useBig || (ch == 'd'))) { + Tcl_AppendToObj(segment, (isNegative ? "-" : gotPlus ? "+" : " "), 1); segmentLimit -= 1; } - if (gotHash || (ch == 'p')) { + if (gotHash) { switch (ch) { case 'o': - Tcl_AppendToObj(segment, "0o", 2); - segmentLimit -= 2; + Tcl_AppendToObj(segment, "0", 1); + segmentLimit -= 1; + precision--; break; - case 'p': case 'x': case 'X': Tcl_AppendToObj(segment, "0x", 2); segmentLimit -= 2; break; - case 'b': - Tcl_AppendToObj(segment, "0b", 2); - segmentLimit -= 2; - break; } } switch (ch) { case 'd': { - size_t length; + int length; Tcl_Obj *pure; const char *bytes; if (useShort) { - TclNewIntObj(pure, s); -#ifndef TCL_WIDE_INT_IS_LONG + pure = Tcl_NewIntObj((int)(s)); } else if (useWide) { - TclNewIntObj(pure, w); -#endif + pure = Tcl_NewWideIntObj(w); } else if (useBig) { pure = Tcl_NewBignumObj(&big); } else { - TclNewIntObj(pure, l); + pure = Tcl_NewLongObj(l); } Tcl_IncrRefCount(pure); bytes = TclGetStringFromObj(pure, &length); /* @@ -2101,96 +2194,88 @@ * entirely of one-byte encoded characters, so "length" is the * number of chars. */ if (gotPrecision) { - if (length < (size_t)precision) { - segmentLimit -= precision - length; + if (length < precision) { + segmentLimit -= (precision - length); } - while (length < (size_t)precision) { + while (length < precision) { Tcl_AppendToObj(segment, "0", 1); length++; } gotZero = 0; } if (gotZero) { length += Tcl_GetCharLength(segment); - if (length < (size_t)width) { - segmentLimit -= width - length; + if (length < width) { + segmentLimit -= (width - length); } - while (length < (size_t)width) { + 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 = 0; - Tcl_WideInt numDigits = 0; - int numBits = 4, base = 16, index = 0, shift = 0; - size_t length; + case 'X': { + Tcl_WideUInt bits = (Tcl_WideUInt)0; + Tcl_WideInt numDigits = (Tcl_WideInt)0; + int length, numBits = 4, base = 16; + int index = 0, shift = 0; Tcl_Obj *pure; char *bytes; if (ch == 'u') { base = 10; - } else if (ch == 'o') { + } + if (ch == 'o') { base = 8; numBits = 3; - } else if (ch == 'b') { - base = 2; - numBits = 1; } if (useShort) { - unsigned short us = (unsigned short) s; + unsigned short int us = (unsigned short int) s; bits = (Tcl_WideUInt) us; while (us) { numDigits++; us /= base; } -#ifndef TCL_WIDE_INT_IS_LONG } else if (useWide) { Tcl_WideUInt uw = (Tcl_WideUInt) w; bits = uw; while (uw) { numDigits++; uw /= base; } -#endif - } else if (useBig && !mp_iszero(&big)) { + } else if (useBig && big.used) { 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); + (((Tcl_WideInt)big.used * MP_DIGIT_BIT) / numBits); while ((mask & big.dp[big.used-1]) == 0) { numDigits--; mask >>= numBits; } if (numDigits > INT_MAX) { msg = overflow; - errCode = "OVERFLOW"; goto errorMsg; } } else if (!useBig) { - unsigned long ul = (unsigned long) l; + unsigned long int ul = (unsigned long int) l; bits = (Tcl_WideUInt) ul; while (ul) { numDigits++; ul /= base; @@ -2199,66 +2284,61 @@ /* * Need to be sure zero becomes "0", not "". */ - if (numDigits == 0) { + if ((numDigits == 0) && !((ch == 'o') && gotHash)) { numDigits = 1; } - TclNewObj(pure); - Tcl_SetObjLength(pure, numDigits); + pure = Tcl_NewObj(); + Tcl_SetObjLength(pure, (int)numDigits); bytes = TclGetString(pure); - toAppend = length = numDigits; + toAppend = length = (int)numDigits; while (numDigits--) { int digitOffset; - if (useBig && !mp_iszero(&big)) { + if (useBig && big.used) { if (index < big.used && (size_t) shift < CHAR_BIT*sizeof(Tcl_WideUInt) - MP_DIGIT_BIT) { - bits |= ((Tcl_WideUInt) big.dp[index++]) << shift; + bits |= (((Tcl_WideUInt)big.dp[index++]) < 9) { - if (ch == 'X') { - bytes[numDigits] = 'A' + digitOffset - 10; - } else { - bytes[numDigits] = 'a' + digitOffset - 10; - } + bytes[numDigits] = 'a' + digitOffset - 10; } else { bytes[numDigits] = '0' + digitOffset; } bits /= base; } if (useBig) { mp_clear(&big); } if (gotPrecision) { - if (length < (size_t)precision) { - segmentLimit -= precision - length; + if (length < precision) { + segmentLimit -= (precision - length); } - while (length < (size_t)precision) { + while (length < precision) { Tcl_AppendToObj(segment, "0", 1); length++; } gotZero = 0; } if (gotZero) { length += Tcl_GetCharLength(segment); - if (length < (size_t)width) { - segmentLimit -= width - length; + if (length < width) { + segmentLimit -= (width - length); } - while (length < (size_t)width) { + while (length < width) { Tcl_AppendToObj(segment, "0", 1); length++; } } if (toAppend > segmentLimit) { msg = overflow; - errCode = "OVERFLOW"; goto errorMsg; } Tcl_AppendObjToObj(segment, pure); Tcl_DecrRefCount(pure); break; @@ -2266,12 +2346,10 @@ } break; } - case 'a': - case 'A': case 'e': case 'E': case 'f': case 'g': case 'G': { @@ -2309,12 +2387,11 @@ } if (gotPrecision) { *p++ = '.'; p += sprintf(p, "%d", precision); if (precision > INT_MAX - length) { - msg = overflow; - errCode = "OVERFLOW"; + msg=overflow; goto errorMsg; } length += precision; } @@ -2323,70 +2400,70 @@ */ *p++ = (char) ch; *p = '\0'; - TclNewObj(segment); + segment = Tcl_NewObj(); allocSegment = 1; if (!Tcl_AttemptSetObjLength(segment, length)) { msg = overflow; - errCode = "OVERFLOW"; goto errorMsg; } bytes = TclGetString(segment); if (!Tcl_AttemptSetObjLength(segment, sprintf(bytes, spec, d))) { msg = overflow; - errCode = "OVERFLOW"; goto errorMsg; } - if (ch == 'A') { - char *q = TclGetString(segment) + 1; - *q = 'x'; - q = strchr(q, 'P'); - if (q) *q = 'p'; - } break; } default: if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad field specifier \"%c\"", ch)); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL); } goto error; } - if (width>0 && numChars<0) { - numChars = Tcl_GetCharLength(segment); - } - if (!gotMinus && width>0) { - if (numChars < width) { - limit -= width - numChars; - } - while (numChars < width) { - Tcl_AppendToObj(appendObj, (gotZero ? "0" : " "), 1); - numChars++; + switch (ch) { + case 'E': + case 'G': + case 'X': { + Tcl_SetObjLength(segment, Tcl_UtfToUpper(TclGetString(segment))); + } + } + + if (width > 0) { + if (numChars < 0) { + numChars = Tcl_GetCharLength(segment); + } + if (!gotMinus) { + if (numChars < width) { + limit -= (width - numChars); + } + while (numChars < width) { + Tcl_AppendToObj(appendObj, (gotZero ? "0" : " "), 1); + numChars++; + } } } - (void)TclGetStringFromObj(segment, &segmentNumBytes); + Tcl_GetStringFromObj(segment, &segmentNumBytes); if (segmentNumBytes > limit) { if (allocSegment) { Tcl_DecrRefCount(segment); } msg = overflow; - errCode = "OVERFLOW"; goto errorMsg; } Tcl_AppendObjToObj(appendObj, segment); limit -= segmentNumBytes; if (allocSegment) { Tcl_DecrRefCount(segment); } if (width > 0) { if (numChars < width) { - limit -= width-numChars; + limit -= (width - numChars); } while (numChars < width) { Tcl_AppendToObj(appendObj, (gotZero ? "0" : " "), 1); numChars++; } @@ -2395,11 +2472,10 @@ objIndex += gotSequential; } if (numBytes) { if (numBytes > limit) { msg = overflow; - errCode = "OVERFLOW"; goto errorMsg; } Tcl_AppendToObj(appendObj, span, numBytes); limit -= numBytes; numBytes = 0; @@ -2408,27 +2484,26 @@ return TCL_OK; errorMsg: if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1)); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", errCode, NULL); } error: Tcl_SetObjLength(appendObj, originalLength); return TCL_ERROR; } /* *--------------------------------------------------------------------------- * - * Tcl_Format -- + * Tcl_Format-- * * Results: * A refcount zero Tcl_Obj. * * Side effects: - * None. + * None. * *--------------------------------------------------------------------------- */ Tcl_Obj * @@ -2437,13 +2512,11 @@ const char *format, int objc, Tcl_Obj *const objv[]) { int result; - Tcl_Obj *objPtr; - - TclNewObj(objPtr); + Tcl_Obj *objPtr = Tcl_NewObj(); result = Tcl_AppendFormatToObj(interp, objPtr, format, objc, objv); if (result != TCL_OK) { Tcl_DecrRefCount(objPtr); return NULL; } @@ -2467,14 +2540,14 @@ Tcl_Obj *objPtr, const char *format, va_list argList) { int code, objc; - Tcl_Obj **objv, *list; + Tcl_Obj **objv, *list = Tcl_NewObj(); const char *p; + char *end; - TclNewObj(list); p = format; Tcl_IncrRefCount(list); while (*p != '\0') { int size = 0, seekingConversion = 1, gotPrecision = 0; int lastNum = -1; @@ -2486,10 +2559,11 @@ p++; continue; } do { switch (*p) { + case '\0': seekingConversion = 0; break; case 's': { const char *q, *end, *bytes = va_arg(argList, char *); @@ -2511,116 +2585,71 @@ * copy only whole characters, and avoid copying any partial * multi-byte characters. */ q = TclUtfPrev(end, bytes); - if (!Tcl_UtfCharComplete(q, (end - q))) { + if (!Tcl_UtfCharComplete(q, (int)(end - q))) { end = q; } - q = bytes + 4; + q = bytes + TCL_UTF_MAX; while ((bytes < end) && (bytes < q) && ((*bytes & 0xC0) == 0x80)) { bytes++; } Tcl_ListObjAppendElement(NULL, list, - Tcl_NewStringObj(bytes , (end - bytes))); + Tcl_NewStringObj(bytes , (int)(end - bytes))); break; } case 'c': case 'i': case 'u': case 'd': case 'o': - case 'p': case 'x': case 'X': seekingConversion = 0; switch (size) { case -1: case 0: - Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj( - va_arg(argList, int))); + Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj( + (long int)va_arg(argList, int))); break; case 1: - Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj( - va_arg(argList, long))); - break; - case 2: - Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj( - va_arg(argList, Tcl_WideInt))); - break; - case 3: - Tcl_ListObjAppendElement(NULL, list, Tcl_NewBignumObj( - va_arg(argList, mp_int *))); + Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj( + va_arg(argList, long int))); break; } break; - case 'a': - case 'A': case 'e': case 'E': case 'f': case 'g': case 'G': - if (size > 0) { Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj( - (double)va_arg(argList, long double))); - } else { - Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj( - va_arg(argList, double))); - } + va_arg(argList, double))); seekingConversion = 0; break; case '*': - lastNum = va_arg(argList, int); - Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj(lastNum)); + lastNum = (int)va_arg(argList, int); + Tcl_ListObjAppendElement(NULL, list, Tcl_NewIntObj(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 = strtoul(p, &end, 10); + case '5': case '6': case '7': case '8': case '9': + lastNum = (int) strtoul(p, &end, 10); p = end; break; - } case '.': gotPrecision = 1; p++; break; + /* TODO: support for wide (and bignum?) arguments */ case 'l': - ++size; - p++; - break; - case 't': - case 'z': - if (sizeof(size_t) == sizeof(Tcl_WideInt)) { - size = 2; - } - p++; - break; - case 'j': - case 'q': - size = 2; - p++; - break; - case 'I': - if (p[1]=='6' && p[2]=='4') { - p += 2; - size = 2; - } else if (p[1]=='3' && p[2]=='2') { - p += 2; - } else if (sizeof(size_t) == sizeof(Tcl_WideInt)) { - size = 2; - } - p++; - break; - case 'L': - size = 3; + size = 1; p++; break; case 'h': size = -1; /* FALLTHRU */ @@ -2632,11 +2661,11 @@ TclListObjGetElements(NULL, list, &objc, &objv); code = Tcl_AppendFormatToObj(NULL, objPtr, format, objc, objv); if (code != TCL_OK) { Tcl_AppendPrintfToObj(objPtr, "Unable to format \"%s\" with supplied arguments: %s", - format, TclGetString(list)); + format, Tcl_GetString(list)); } Tcl_DecrRefCount(list); } /* @@ -2646,11 +2675,11 @@ * * Results: * A standard Tcl result. * * Side effects: - * None. + * None. * *--------------------------------------------------------------------------- */ void @@ -2673,11 +2702,11 @@ * * Results: * A refcount zero Tcl_Obj. * * Side effects: - * None. + * None. * *--------------------------------------------------------------------------- */ Tcl_Obj * @@ -2684,13 +2713,12 @@ Tcl_ObjPrintf( const char *format, ...) { va_list argList; - Tcl_Obj *objPtr; + Tcl_Obj *objPtr = Tcl_NewObj(); - TclNewObj(objPtr); va_start(argList, format); AppendPrintfToObjVA(objPtr, format, argList); va_end(argList); return objPtr; } @@ -2713,1207 +2741,103 @@ */ char * TclGetStringStorage( Tcl_Obj *objPtr, - size_t *sizePtr) + unsigned int *sizePtr) { String *stringPtr; - if (!TclHasIntRep(objPtr, &tclStringType) || objPtr->bytes == NULL) { - return TclGetStringFromObj(objPtr, sizePtr); + if (objPtr->typePtr != &tclStringType || objPtr->bytes == NULL) { + return TclGetStringFromObj(objPtr, (int *)sizePtr); } stringPtr = GET_STRING(objPtr); *sizePtr = stringPtr->allocated; return objPtr->bytes; } - -/* - *--------------------------------------------------------------------------- - * - * TclStringRepeat -- - * - * Performs the [string repeat] function. - * - * Results: - * A (Tcl_Obj *) pointing to the result value, or NULL in case of an - * error. - * - * Side effects: - * On error, when interp is not NULL, error information is left in it. - * - *--------------------------------------------------------------------------- - */ - -Tcl_Obj * -TclStringRepeat( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - size_t count, - int flags) -{ - Tcl_Obj *objResultPtr; - int inPlace = flags & TCL_STRING_IN_PLACE; - size_t 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. - * Produce pure bytearray when possible. - * Error on overflow. - */ - - if (!binary) { - if (TclHasIntRep(objPtr, &tclStringType)) { - String *stringPtr = GET_STRING(objPtr); - if (stringPtr->hasUnicode) { - unichar = 1; - } - } - } - - if (binary) { - /* Result will be pure byte array. Pre-size it */ - (void)TclGetByteArrayFromObj(objPtr, &length); - } else if (unichar) { - /* Result will be pure Tcl_UniChar array. Pre-size it. */ - (void)TclGetUnicodeFromObj(objPtr, &length); - } else { - /* Result will be concat of string reps. Pre-size it. */ - (void)TclGetStringFromObj(objPtr, &length); - } - - if (length == 0) { - /* Any repeats of empty is empty. */ - return objPtr; - } - - if (count > INT_MAX/length) { - 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; - } - - if (binary) { - /* Efficiently produce a pure byte array result */ - objResultPtr = (!inPlace || Tcl_IsShared(objPtr)) ? - Tcl_DuplicateObj(objPtr) : objPtr; - - Tcl_SetByteArrayLength(objResultPtr, count*length); /* PANIC? */ - Tcl_SetByteArrayLength(objResultPtr, length); - while (count - done > done) { - Tcl_AppendObjToObj(objResultPtr, objResultPtr); - done *= 2; - } - TclAppendBytesToByteArray(objResultPtr, - Tcl_GetByteArrayFromObj(objResultPtr, NULL), - (count - done) * length); - } else if (unichar) { - /* - * Efficiently produce a pure Tcl_UniChar array result. - */ - - if (!inPlace || Tcl_IsShared(objPtr)) { - objResultPtr = Tcl_NewUnicodeObj(Tcl_GetUnicode(objPtr), length); - } else { - TclInvalidateStringRep(objPtr); - objResultPtr = objPtr; - } - - if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "string size overflow: unable to alloc %" - TCL_Z_MODIFIER "u bytes", - STRING_SIZE(count*length))); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } - return NULL; - } - Tcl_SetObjLength(objResultPtr, length); - while (count - done > done) { - Tcl_AppendObjToObj(objResultPtr, objResultPtr); - done *= 2; - } - TclAppendUnicodeToObj(objResultPtr, Tcl_GetUnicode(objResultPtr), - (count - done) * length); - } else { - /* - * Efficiently concatenate string reps. - */ - - if (!inPlace || Tcl_IsShared(objPtr)) { - objResultPtr = Tcl_NewStringObj(TclGetString(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 %" TCL_Z_MODIFIER "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, TclGetString(objResultPtr), - (count - done) * length); - } - return objResultPtr; -} - -/* - *--------------------------------------------------------------------------- - * - * TclStringCat -- - * - * Performs the [string cat] function. - * - * Results: - * A (Tcl_Obj *) pointing to the result value, or NULL in case of an - * error. - * - * Side effects: - * On error, when interp is not NULL, error information is left in it. - * - *--------------------------------------------------------------------------- - */ - -Tcl_Obj * -TclStringCat( - Tcl_Interp *interp, - int objc, - Tcl_Obj * const objv[], - int flags) -{ - Tcl_Obj *objResultPtr, * const *ov; - int oc, binary = 1; - size_t length = 0; - 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 ) */ - - if (objc <= 1) { - /* Only one or no objects; return first or empty */ - return objc ? objv[0] : Tcl_NewObj(); - } - - /* assert ( objc >= 2 ) */ - - /* - * Analyze to determine what representation result should be. - * GOALS: Avoid shimmering & string rep generation. - * Produce pure bytearray when possible. - * Error on overflow. - */ - - ov = objv, oc = objc; - do { - Tcl_Obj *objPtr = *ov++; - - if (TclIsPureByteArray(objPtr)) { - allowUniChar = 0; - } else if (objPtr->bytes) { - /* Value has a string rep. */ - if (objPtr->length) { - /* - * Non-empty string rep. Not a pure bytearray, so we won't - * create a pure bytearray. - */ - - binary = 0; - if ((objPtr->typePtr) && (objPtr->typePtr != &tclStringType)) { - /* Prevent shimmer of non-string types. */ - allowUniChar = 0; - } - } - } else { - /* assert (objPtr->typePtr != NULL) -- stork! */ - binary = 0; - if (TclHasIntRep(objPtr, &tclStringType)) { - /* Have a pure Unicode value; ask to preserve it */ - requestUniChar = 1; - } else { - /* Have another type; prevent shimmer */ - allowUniChar = 0; - } - } - } while (--oc && (binary || allowUniChar)); - - if (binary) { - /* - * Result will be pure byte array. Pre-size it - */ - - size_t numBytes = 0; - 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)) { - (void)TclGetByteArrayFromObj(objPtr, &numBytes); /* PANIC? */ - - if (numBytes) { - last = objc - oc; - if (length == 0) { - first = last; - } - 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)) { - size_t numChars; - - (void)TclGetUnicodeFromObj(objPtr, &numChars); /* PANIC? */ - if (numChars) { - last = objc - oc; - if (length == 0) { - first = last; - } - length += numChars; - } - } - } while (--oc); - } else { - /* Result will be concat of string reps. Pre-size it. */ - ov = objv; oc = objc; - do { - Tcl_Obj *pendingPtr = NULL; - - /* - * Loop until a possibly non-empty value is reached. - * Keep string rep generation pending when possible. - */ - - do { - /* assert ( pendingPtr == NULL ) */ - /* assert ( length == 0 ) */ - - Tcl_Obj *objPtr = *ov++; - - if (objPtr->bytes == NULL) { - /* No string rep; Take the chance we can avoid making it */ - pendingPtr = objPtr; - } else { - (void)TclGetStringFromObj(objPtr, &length); /* PANIC? */ - } - } while (--oc && (length == 0) && (pendingPtr == NULL)); - - /* - * Either we found a possibly non-empty value, and we remember - * this index as the first and last such value so far seen, - * or (oc == 0) and all values are known empty, - * so first = last = objc - 1 signals the right quick return. - */ - - first = last = objc - oc - 1; - - if (oc && (length == 0)) { - size_t 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++; - (void)TclGetStringFromObj(objPtr, &numBytes); /* PANIC? */ - } while (--oc && numBytes == 0 && pendingPtr->bytes == NULL); - - if (numBytes) { - last = objc -oc -1; - } - if (oc || numBytes) { - (void)TclGetStringFromObj(pendingPtr, &length); - } - if (length == 0) { - if (numBytes) { - first = last; - } - } else if (numBytes + length > (size_t)INT_MAX) { - goto overflow; - } - length += numBytes; - } - } while (oc && (length == 0)); - - while (oc) { - size_t numBytes; - Tcl_Obj *objPtr = *ov++; - - /* assert ( length > 0 && pendingPtr == NULL ) */ - - TclGetString(objPtr); /* PANIC? */ - numBytes = objPtr->length; - if (numBytes) { - last = objc - oc; - if (numBytes + length > (size_t)INT_MAX) { - goto overflow; - } - length += numBytes; - } - --oc; - } - } - - if (last <= first /*|| length == 0 */) { - /* Only one non-empty value or zero length; return first */ - /* NOTE: (length == 0) implies (last <= first) */ - return objv[first]; - } - - objv += first; objc = (last - first + 1); - - if (binary) { - /* Efficiently produce a pure byte array result */ - unsigned char *dst; - - /* - * 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)) { - size_t start = 0; - - objResultPtr = *objv++; objc--; - (void)TclGetByteArrayFromObj(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)) { - size_t more = 0; - unsigned char *src = TclGetByteArrayFromObj(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)) { - size_t start; - - objResultPtr = *objv++; objc--; - - /* Ugly interface! Force resize of the unicode array. */ - (void)TclGetUnicodeFromObj(objResultPtr, &start); - Tcl_InvalidateStringRep(objResultPtr); - if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "concatenation failed: unable to alloc %" - TCL_Z_MODIFIER "u bytes", - STRING_SIZE(length))); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } - return NULL; - } - dst = Tcl_GetUnicode(objResultPtr) + start; - } else { - Tcl_UniChar ch = 0; - - /* Ugly interface! No scheme to init array size. */ - objResultPtr = Tcl_NewUnicodeObj(&ch, 0); /* PANIC? */ - if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { - Tcl_DecrRefCount(objResultPtr); - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "concatenation failed: unable to alloc %" - TCL_Z_MODIFIER "u bytes", - STRING_SIZE(length))); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } - return NULL; - } - dst = Tcl_GetUnicode(objResultPtr); - } - while (objc--) { - Tcl_Obj *objPtr = *objv++; - - if ((objPtr->bytes == NULL) || (objPtr->length)) { - size_t more; - Tcl_UniChar *src = TclGetUnicodeFromObj(objPtr, &more); - memcpy(dst, src, more * sizeof(Tcl_UniChar)); - dst += more; - } - } - } else { - /* Efficiently concatenate string reps */ - char *dst; - - if (inPlace && !Tcl_IsShared(*objv)) { - size_t start; - - objResultPtr = *objv++; objc--; - - (void)TclGetStringFromObj(objResultPtr, &start); - if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "concatenation failed: unable to alloc %" TCL_Z_MODIFIER "u bytes", - length)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } - return NULL; - } - dst = TclGetString(objResultPtr) + start; - - /* assert ( length > start ) */ - TclFreeIntRep(objResultPtr); - } else { - TclNewObj(objResultPtr); /* PANIC? */ - if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { - Tcl_DecrRefCount(objResultPtr); - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "concatenation failed: unable to alloc %" TCL_Z_MODIFIER "u bytes", - length)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } - return NULL; - } - dst = TclGetString(objResultPtr); - } - while (objc--) { - Tcl_Obj *objPtr = *objv++; - - if ((objPtr->bytes == NULL) || (objPtr->length)) { - size_t more; - char *src = TclGetStringFromObj(objPtr, &more); - - memcpy(dst, src, more); - dst += more; - } - } - /* Must NUL-terminate! */ - *dst = '\0'; - } - return objResultPtr; - - overflow: - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "max size for a Tcl value (%d bytes) exceeded", INT_MAX)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } - return NULL; -} - -/* - *--------------------------------------------------------------------------- - * - * TclStringCmp -- - * Compare two Tcl_Obj values as strings. - * - * Results: - * Like memcmp, return -1, 0, or 1. - * - * Side effects: - * String representations may be generated. Internal representation may - * be changed. - * - *--------------------------------------------------------------------------- - */ - -int -TclStringCmp( - Tcl_Obj *value1Ptr, - Tcl_Obj *value2Ptr, - int checkEq, /* comparison is only for equality */ - int nocase, /* comparison is not case sensitive */ - size_t reqlength) /* requested length */ -{ - char *s1, *s2; - int empty, match; - size_t length, s1len = 0, s2len = 0; - 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 *) TclGetByteArrayFromObj(value1Ptr, &s1len); - s2 = (char *) TclGetByteArrayFromObj(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 *) TclGetUnicodeFromObj(value1Ptr, &s1len); - s2 = (char *) TclGetUnicodeFromObj(value2Ptr, &s2len); - memCmpFn = (memCmpFn_t)TclUniCharNcasecmp; - } else { - s1len = Tcl_GetCharLength(value1Ptr); - s2len = Tcl_GetCharLength(value2Ptr); - if ((s1len == value1Ptr->length) - && (value1Ptr->bytes != NULL) - && (s2len == value2Ptr->length) - && (value2Ptr->bytes != NULL)) { - s1 = value1Ptr->bytes; - s2 = value2Ptr->bytes; - memCmpFn = memcmp; - } else { - s1 = (char *) Tcl_GetUnicode(value1Ptr); - s2 = (char *) Tcl_GetUnicode(value2Ptr); - if ( -#ifdef WORDS_BIGENDIAN - 1 -#else - checkEq -#endif - ) { - memCmpFn = memcmp; - s1len *= sizeof(Tcl_UniChar); - s2len *= sizeof(Tcl_UniChar); - } else { - memCmpFn = (memCmpFn_t) TclUniCharNcmp; - } - } - } - } else { - empty = TclCheckEmptyString(value1Ptr); - if (empty > 0) { - switch (TclCheckEmptyString(value2Ptr)) { - case -1: - s1 = 0; - s1len = 0; - s2 = TclGetStringFromObj(value2Ptr, &s2len); - break; - case 0: - match = -1; - goto matchdone; - case 1: - default: /* avoid warn: `s2` may be used uninitialized */ - match = 0; - goto matchdone; - } - } else if (TclCheckEmptyString(value2Ptr) > 0) { - switch (empty) { - case -1: - s2 = 0; - s2len = 0; - s1 = TclGetStringFromObj(value1Ptr, &s1len); - break; - case 0: - match = 1; - goto matchdone; - case 1: - default: /* avoid warn: `s1` may be used uninitialized */ - match = 0; - goto matchdone; - } - } else { - s1 = TclGetStringFromObj(value1Ptr, &s1len); - s2 = TclGetStringFromObj(value2Ptr, &s2len); - } - if (!nocase && checkEq) { - /* - * When we have equal-length we can check only for - * (in)equality. We can use memcmp in all (n)eq cases because - * we don't need to worry about lexical LE/BE variance. - */ - - memCmpFn = memcmp; - } else { - /* - * 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 == TCL_INDEX_NONE) && !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 == TCL_INDEX_NONE) { - /* - * The requested length is negative, so we ignore it by setting it - * to length + 1 so we correct the match var. - */ - - reqlength = length + 1; - } else if (reqlength > 0 && reqlength < length) { - length = reqlength; - } - - 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, 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, - size_t start) -{ - size_t lh = 0, ln = Tcl_GetCharLength(needle); - size_t value = TCL_INDEX_NONE; - Tcl_UniChar *checkStr, *endStr, *uh, *un; - Tcl_Obj *obj; - - if (start == TCL_INDEX_NONE) { - 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 = TclGetByteArrayFromObj(needle, &ln); - - /* Find bytes in bytes */ - bh = TclGetByteArrayFromObj(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 = TclGetUnicodeFromObj(needle, &ln); - uh = TclGetUnicodeFromObj(haystack, &lh); - if ((lh < ln) || (start > lh - ln)) { - /* Don't start the loop if there cannot be a valid answer */ - goto firstEnd; - } - endStr = uh + lh; - - for (checkStr = uh + start; checkStr + ln <= endStr; checkStr++) { - if ((*checkStr == *un) && (0 == - memcmp(checkStr + 1, un + 1, (ln-1) * sizeof(Tcl_UniChar)))) { - value = (checkStr - uh); - goto firstEnd; - } - } - firstEnd: - TclNewIndexObj(obj, value); - return obj; -} - -/* - *--------------------------------------------------------------------------- - * - * 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, - size_t last) -{ - size_t lh = 0, ln = Tcl_GetCharLength(needle); - size_t value = TCL_INDEX_NONE; - Tcl_UniChar *checkStr, *uh, *un; - Tcl_Obj *obj; - - if (ln == 0) { - /* - * We don't find empty substrings. Bizarre! - * - * TODO: When we one day make this a true substring - * finder, change this to "return last", after limitation. - */ - goto lastEnd; - } - - if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) { - unsigned char *check, *bh = TclGetByteArrayFromObj(haystack, &lh); - unsigned char *bn = TclGetByteArrayFromObj(needle, &ln); - - if (last + 1 >= lh + 1) { - 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 = TclGetUnicodeFromObj(haystack, &lh); - un = TclGetUnicodeFromObj(needle, &ln); - - if (last + 1 >= lh + 1) { - last = lh - 1; - } - if (last + 1 < ln) { - /* Don't start the loop if there cannot be a valid answer */ - goto lastEnd; - } - checkStr = uh + last + 1 - ln; - while (checkStr >= uh) { - if ((*checkStr == un[0]) - && (0 == memcmp(checkStr+1, un+1, (ln-1)*sizeof(Tcl_UniChar)))) { - value = (checkStr - uh); - goto lastEnd; - } - checkStr--; - } - lastEnd: - TclNewIndexObj(obj, value); - return obj; -} - -/* - *--------------------------------------------------------------------------- - * - * TclStringReverse -- +/* + *--------------------------------------------------------------------------- + * + * TclStringObjReverse -- * * Implements the [string reverse] operation. * * Results: - * A Tcl value which is the [string reverse] of the argument supplied. - * When sharing rules permit and the caller requests, the returned value - * might be the argument with modifications done in place. + * An unshared Tcl value which is the [string reverse] of the argument + * supplied. When sharing rules permit, the returned value might be + * the argument with modifications done in place. * * Side effects: * May allocate a new Tcl_Obj. * *--------------------------------------------------------------------------- */ -static void -ReverseBytes( - unsigned char *to, /* Copy bytes into here... */ - unsigned char *from, /* ...from here... */ - size_t count) /* Until this many are copied, */ - /* reversing as you go. */ -{ - unsigned char *src = from + count; - - if (to == from) { - /* Reversing in place */ - while (--src > to) { - unsigned char c = *src; - - *src = *to; - *to++ = c; - } - } else { - while (--src >= from) { - *to++ = *src; - } - } -} - Tcl_Obj * -TclStringReverse( - Tcl_Obj *objPtr, - int flags) +TclStringObjReverse( + Tcl_Obj *objPtr) { String *stringPtr; - Tcl_UniChar ch = 0; - int inPlace = flags & TCL_STRING_IN_PLACE; - - if (TclIsPureByteArray(objPtr)) { - size_t numBytes = 0; - unsigned char *from = TclGetByteArrayFromObj(objPtr, &numBytes); - - if (!inPlace || Tcl_IsShared(objPtr)) { - objPtr = Tcl_NewByteArrayObj(NULL, numBytes); - } - ReverseBytes(Tcl_GetByteArrayFromObj(objPtr, NULL), from, numBytes); + int numChars = Tcl_GetCharLength(objPtr); + int i = 0, lastCharIdx = numChars - 1; + char *bytes; + + if (numChars <= 1) { return objPtr; } - SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); - if (stringPtr->hasUnicode) { - Tcl_UniChar *from = Tcl_GetUnicode(objPtr); - Tcl_UniChar *src = from + stringPtr->numChars; + Tcl_UniChar *source = stringPtr->unicode; - if (!inPlace || Tcl_IsShared(objPtr)) { - Tcl_UniChar *to; + if (Tcl_IsShared(objPtr)) { + Tcl_UniChar *dest, ch = 0; /* * Create a non-empty, pure unicode value, so we can coax * Tcl_SetObjLength into growing the unicode rep buffer. */ - objPtr = Tcl_NewUnicodeObj(&ch, 1); - Tcl_SetObjLength(objPtr, stringPtr->numChars); - to = Tcl_GetUnicode(objPtr); - while (--src >= from) { - *to++ = *src; - } - } else { - /* - * Reversing in place. - */ - - while (--src > from) { - ch = *src; - *src = *from; - *from++ = ch; - } - } - } - - if (objPtr->bytes) { - size_t numChars = stringPtr->numChars; - size_t numBytes = objPtr->length; - char *to, *from = objPtr->bytes; - - if (!inPlace || Tcl_IsShared(objPtr)) { - TclNewObj(objPtr); - Tcl_SetObjLength(objPtr, numBytes); - } - to = objPtr->bytes; - - if ((numChars == TCL_INDEX_NONE) || (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. - */ - - size_t charCount = 0; - size_t 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. - */ - - size_t bytesInChar = TclUtfToUniChar(from, &ch); - - ReverseBytes((unsigned char *)to, (unsigned char *)from, - bytesInChar); - to += bytesInChar; - from += bytesInChar; - bytesLeft -= bytesInChar; - charCount++; - } - - from = to = objPtr->bytes; - stringPtr->numChars = charCount; - } - /* Pass 2. Reverse all the bytes. */ - ReverseBytes((unsigned char *)to, (unsigned char *)from, numBytes); - } - - return objPtr; -} - -/* - *--------------------------------------------------------------------------- - * - * TclStringReplace -- - * - * Implements the inner engine of the [string replace] and - * [string insert] commands. - * - * The result is a concatenation of a prefix from objPtr, characters - * 0 through first-1, the insertPtr string value, and a suffix from - * objPtr, characters from first + count to the end. The effect is as if - * the inner substring of characters first through first+count-1 are - * removed and replaced with insertPtr. If insertPtr is NULL, it is - * treated as an empty string. When passed the flag TCL_STRING_IN_PLACE, - * this routine will try to do the work within objPtr, so long as no - * sharing forbids it. Without that request, or as needed, a new Tcl - * value will be allocated to be the result. - * - * Results: - * A Tcl value that is the result of the substring replacement. May - * return NULL in case of an error. When NULL is returned and interp is - * non-NULL, error information is left in interp - * - *--------------------------------------------------------------------------- - */ - -Tcl_Obj * -TclStringReplace( - Tcl_Interp *interp, /* For error reporting, may be NULL */ - Tcl_Obj *objPtr, /* String to act upon */ - size_t first, /* First index to replace */ - size_t 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; - - /* 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)) { - size_t numBytes = 0; - unsigned char *bytes = TclGetByteArrayFromObj(objPtr, &numBytes); - - if (insertPtr == NULL) { - /* Replace something with nothing. */ - - assert ( first <= numBytes ) ; - assert ( count <= numBytes ) ; - assert ( first + count <= numBytes ) ; - - result = Tcl_NewByteArrayObj(NULL, numBytes - count);/* PANIC? */ - TclAppendBytesToByteArray(result, bytes, first); - TclAppendBytesToByteArray(result, bytes + first + count, - numBytes - count - first); - return result; - } - - /* Replace everything */ - if ((first == 0) && (count == numBytes)) { - return insertPtr; - } - - if (TclIsPureByteArray(insertPtr)) { - size_t newBytes = 0; - unsigned char *iBytes - = TclGetByteArrayFromObj(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 ((size_t)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; - } - result = Tcl_NewByteArrayObj(NULL, numBytes - count + newBytes); - /* PANIC? */ - Tcl_SetByteArrayLength(result, 0); - TclAppendBytesToByteArray(result, bytes, first); - TclAppendBytesToByteArray(result, iBytes, newBytes); - TclAppendBytesToByteArray(result, bytes + first + count, - numBytes - count - first); - return result; - } - - /* Flow through to try other approaches below */ - } - - /* - * 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... */ - { - size_t numChars; - Tcl_UniChar *ustring = TclGetUnicodeFromObj(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 < (size_t)numChars) { - TclAppendUnicodeToObj(result, ustring + first + count, - numChars - first - count); - } - - return result; - } + Tcl_Obj *resultPtr = Tcl_NewUnicodeObj(&ch, 1); + Tcl_SetObjLength(resultPtr, numChars); + dest = Tcl_GetUnicode(resultPtr); + + while (i < numChars) { + dest[i++] = source[lastCharIdx--]; + } + return resultPtr; + } + + while (i < lastCharIdx) { + Tcl_UniChar tmp = source[lastCharIdx]; + source[lastCharIdx--] = source[i]; + source[i++] = tmp; + } + TclInvalidateStringRep(objPtr); + stringPtr->allocated = 0; + return objPtr; + } + + bytes = TclGetString(objPtr); + if (Tcl_IsShared(objPtr)) { + char *dest; + Tcl_Obj *resultPtr = Tcl_NewObj(); + Tcl_SetObjLength(resultPtr, numChars); + dest = TclGetString(resultPtr); + while (i < numChars) { + dest[i++] = bytes[lastCharIdx--]; + } + return resultPtr; + } + + while (i < lastCharIdx) { + char tmp = bytes[lastCharIdx]; + bytes[lastCharIdx--] = bytes[i]; + bytes[i++] = tmp; + } + return objPtr; } /* *--------------------------------------------------------------------------- * @@ -3934,51 +2858,39 @@ static void FillUnicodeRep( Tcl_Obj *objPtr) /* The object in which to fill the unicode * rep. */ { - String *stringPtr = GET_STRING(objPtr); - - ExtendUnicodeRepWithString(objPtr, objPtr->bytes, objPtr->length, - stringPtr->numChars); -} - -static void -ExtendUnicodeRepWithString( - Tcl_Obj *objPtr, - const char *bytes, - size_t numBytes, - size_t numAppendChars) -{ - String *stringPtr = GET_STRING(objPtr); - size_t needed, numOrigChars = 0; - Tcl_UniChar *dst, unichar = 0; - - if (stringPtr->hasUnicode) { - numOrigChars = stringPtr->numChars; - } - if (numAppendChars == TCL_INDEX_NONE) { - TclNumUtfChars(numAppendChars, bytes, numBytes); - } - needed = numOrigChars + numAppendChars; - - if (needed > stringPtr->maxChars) { - GrowUnicodeBuffer(objPtr, needed); + String *stringPtr; + size_t uallocated; + char *srcEnd, *src = objPtr->bytes; + Tcl_UniChar *dst; + + stringPtr = GET_STRING(objPtr); + if (stringPtr->numChars == -1) { + stringPtr->numChars = Tcl_NumUtfChars(src, objPtr->length); + } + stringPtr->hasUnicode = (stringPtr->numChars > 0); + + stringCheckLimits(stringPtr->numChars); + uallocated = STRING_UALLOC(stringPtr->numChars); + if (uallocated > stringPtr->uallocated) { + GrowUnicodeBuffer(objPtr, stringPtr->numChars); stringPtr = GET_STRING(objPtr); } - stringPtr->hasUnicode = 1; - if (bytes) { - stringPtr->numChars = needed; - } else { - numAppendChars = 0; - } - for (dst=stringPtr->unicode + numOrigChars; numAppendChars-- > 0; dst++) { - bytes += TclUtfToUniChar(bytes, &unichar); - *dst = unichar; + /* + * Convert src to Unicode and store the coverted data in "unicode". + */ + + srcEnd = src + objPtr->length; + for (dst = stringPtr->unicode; src < srcEnd; dst++) { + src += TclUtfToUniChar(src, dst); } *dst = 0; + + SET_STRING(objPtr, stringPtr); } /* *---------------------------------------------------------------------- * @@ -3997,60 +2909,48 @@ *---------------------------------------------------------------------- */ static void DupStringInternalRep( - Tcl_Obj *srcPtr, /* Object with internal rep to copy. Must have + register Tcl_Obj *srcPtr, /* Object with internal rep to copy. Must have * an internal rep of type "String". */ - Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not + register 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 == TCL_INDEX_NONE) { - /* - * 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; - } - - if (srcStringPtr->hasUnicode) { - int copyMaxChars; - - if (srcStringPtr->maxChars / 2 >= srcStringPtr->numChars) { - copyMaxChars = 2 * srcStringPtr->numChars; - } else { - copyMaxChars = srcStringPtr->maxChars; - } - copyStringPtr = stringAttemptAlloc(copyMaxChars); - if (copyStringPtr == NULL) { - copyMaxChars = srcStringPtr->numChars; - copyStringPtr = stringAlloc(copyMaxChars); - } - copyStringPtr->maxChars = copyMaxChars; + /* + * If the src obj is a string of 1-byte Utf chars, then copy the string + * rep of the source object and create an "empty" Unicode internal rep for + * the new object. Otherwise, copy Unicode internal rep, and invalidate + * the string rep of the new object. + */ + + if (srcStringPtr->hasUnicode == 0) { + copyStringPtr = (String *) ckalloc(sizeof(String)); + copyStringPtr->uallocated = 0; + } else { + copyStringPtr = (String *) ckalloc( + STRING_SIZE(srcStringPtr->uallocated)); + copyStringPtr->uallocated = srcStringPtr->uallocated; + memcpy(copyStringPtr->unicode, srcStringPtr->unicode, - srcStringPtr->numChars * sizeof(Tcl_UniChar)); + (size_t) srcStringPtr->numChars * sizeof(Tcl_UniChar)); copyStringPtr->unicode[srcStringPtr->numChars] = 0; - } else { - copyStringPtr = stringAlloc(0); - copyStringPtr->maxChars = 0; - copyStringPtr->unicode[0] = 0; } - copyStringPtr->hasUnicode = srcStringPtr->hasUnicode; copyStringPtr->numChars = srcStringPtr->numChars; + copyStringPtr->hasUnicode = srcStringPtr->hasUnicode; + copyStringPtr->allocated = srcStringPtr->allocated; /* * Tricky point: the string value was copied by generic object management * code, so it doesn't contain any extra bytes that might exist in the * source object. */ - copyStringPtr->allocated = copyPtr->bytes ? copyPtr->length : 0; + copyStringPtr->allocated = copyPtr->length; SET_STRING(copyPtr, copyStringPtr); copyPtr->typePtr = &tclStringType; } @@ -4071,34 +2971,48 @@ *---------------------------------------------------------------------- */ 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. - */ - - (void) TclGetString(objPtr); - TclFreeIntRep(objPtr); - - /* - * Create a basic String intrep that just points to the UTF-8 string - * already in place at objPtr->bytes. - */ - - stringPtr->numChars = -1; - stringPtr->allocated = objPtr->length; - stringPtr->maxChars = 0; - stringPtr->hasUnicode = 0; - SET_STRING(objPtr, stringPtr); - objPtr->typePtr = &tclStringType; + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr) /* The object to convert. */ +{ + /* + * The Unicode object is optimized for the case where each UTF char in a + * string is only one byte. In this case, we store the value of numChars, + * but we don't copy the bytes to the unicodeObj->unicode. + */ + + if (objPtr->typePtr != &tclStringType) { + String *stringPtr; + + if (objPtr->typePtr != NULL) { + if (objPtr->bytes == NULL) { + objPtr->typePtr->updateStringProc(objPtr); + } + TclFreeIntRep(objPtr); + } + objPtr->typePtr = &tclStringType; + + /* + * Allocate enough space for the basic String structure. + */ + + stringPtr = (String *) ckalloc(sizeof(String)); + stringPtr->numChars = -1; + stringPtr->uallocated = 0; + stringPtr->hasUnicode = 0; + + if (objPtr->bytes != NULL) { + stringPtr->allocated = objPtr->length; + if (objPtr->bytes != tclEmptyStringRep) { + objPtr->bytes[objPtr->length] = 0; + } + } else { + objPtr->length = 0; + } + SET_STRING(objPtr, stringPtr); } return TCL_OK; } /* @@ -4121,86 +3035,61 @@ static void UpdateStringOfString( Tcl_Obj *objPtr) /* Object with string rep to update. */ { - String *stringPtr = GET_STRING(objPtr); - - /* - * This routine is only called when we need to generate the - * string rep objPtr->bytes because it does not exist -- it is NULL. - * In that circumstance, any lingering claim about the size of - * memory pointed to by that NULL pointer is clearly bogus, and - * needs a reset. - */ - - stringPtr->allocated = 0; - - if (stringPtr->numChars == 0) { - TclInitStringRep(objPtr, NULL, 0); - } else { - (void) ExtendStringRepWithUnicode(objPtr, stringPtr->unicode, - stringPtr->numChars); - } -} - -static size_t -ExtendStringRepWithUnicode( - Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, - size_t numChars) -{ - /* - * Pre-condition: this is the "string" Tcl_ObjType. - */ - - size_t i, origLength, size = 0; - char *dst; - String *stringPtr = GET_STRING(objPtr); - - if (numChars == TCL_INDEX_NONE) { - numChars = UnicodeLength(unicode); - } - - if (numChars == 0) { - return 0; - } - - if (objPtr->bytes == NULL) { - objPtr->length = 0; - } - size = origLength = objPtr->length; - - /* - * Quick cheap check in case we have more than enough room. - */ - - if (numChars <= (INT_MAX - size)/TCL_UTF_MAX - && stringPtr->allocated >= size + numChars * TCL_UTF_MAX) { - goto copyBytes; - } - - for (i = 0; i < numChars; i++) { - size += TclUtfCount(unicode[i]); - } - - /* - * Grow space if needed. - */ - - if (size > stringPtr->allocated) { - GrowStringBuffer(objPtr, size, 1); - } - - copyBytes: - dst = objPtr->bytes + origLength; - for (i = 0; i < numChars; i++) { - dst += Tcl_UniCharToUtf(unicode[i], dst); - } - *dst = '\0'; - objPtr->length = dst - objPtr->bytes; - return numChars; + int i, size; + Tcl_UniChar *unicode; + char dummy[TCL_UTF_MAX]; + char *dst; + String *stringPtr; + + stringPtr = GET_STRING(objPtr); + if ((objPtr->bytes == NULL) || (stringPtr->allocated == 0)) { + if (stringPtr->numChars <= 0) { + /* + * If there is no Unicode rep, or the string has 0 chars, then set + * the string rep to an empty string. + */ + + objPtr->bytes = tclEmptyStringRep; + objPtr->length = 0; + return; + } + + unicode = stringPtr->unicode; + + /* + * Translate the Unicode string to UTF. "size" will hold the amount of + * space the UTF string needs. + */ + + if (stringPtr->numChars <= INT_MAX/TCL_UTF_MAX + && stringPtr->allocated >= stringPtr->numChars * (size_t)TCL_UTF_MAX) { + goto copyBytes; + } + + size = 0; + for (i = 0; i < stringPtr->numChars && size >= 0; i++) { + size += Tcl_UniCharToUtf((int) unicode[i], dummy); + } + if (size < 0) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + + objPtr->bytes = (char *) ckalloc((unsigned) (size + 1)); + objPtr->length = size; + stringPtr->allocated = size; + + copyBytes: + dst = objPtr->bytes; + for (i = 0; i < stringPtr->numChars; i++) { + dst += Tcl_UniCharToUtf(unicode[i], dst); + } + *dst = '\0'; + } + return; } /* *---------------------------------------------------------------------- * @@ -4220,11 +3109,11 @@ static void FreeStringInternalRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { - Tcl_Free(GET_STRING(objPtr)); + ckfree((char *) GET_STRING(objPtr)); objPtr->typePtr = NULL; } /* * Local Variables: DELETED generic/tclStringRep.h Index: generic/tclStringRep.h ================================================================== --- generic/tclStringRep.h +++ /dev/null @@ -1,94 +0,0 @@ -/* - * tclStringRep.h -- - * - * This file contains the definition of the Unicode string internal - * representation and macros to access it. - * - * A Unicode string is an internationalized string. Conceptually, a - * Unicode string is an array of 16-bit quantities organized as a - * sequence of properly formed UTF-8 characters. There is a one-to-one - * map between Unicode and UTF characters. Because Unicode characters - * have a fixed width, operations such as indexing operate on Unicode - * data. The String object is optimized for the case where each UTF char - * in a string is only one byte. In this case, we store the value of - * numChars, but we don't store the Unicode data (unless Tcl_GetUnicode - * is explicitly called). - * - * The String object type stores one or both formats. The default - * behavior is to store UTF. Once Unicode is calculated by a function, it - * is stored in the internal rep for future access (without an additional - * O(n) cost). - * - * To allow many appends to be done to an object without constantly - * reallocating the space for the string or Unicode representation, we - * allocate double the space for the string or Unicode and use the - * internal representation to keep track of how much space is used vs. - * allocated. - * - * Copyright (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. - */ - -#ifndef _TCLSTRINGREP -#define _TCLSTRINGREP - - -/* - * The following structure is the internal rep for a String object. It keeps - * track of how much memory has been used and how much has been allocated for - * the 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 { - size_t numChars; /* The number of chars in the string. -1 means - * this value has not been calculated. Any other - * means that there is a valid Unicode rep, or - * that the number of UTF bytes == the number - * of chars. */ - size_t allocated; /* The amount of space actually allocated for - * the UTF string (minus 1 byte for the - * termination char). */ - size_t maxChars; /* Max number of chars that can fit in the - * space allocated for the unicode array. */ - int hasUnicode; /* Boolean determining whether the string has - * a Unicode representation. */ - Tcl_UniChar unicode[TCLFLEXARRAY]; /* The array of Unicode chars. The actual size - * of this field depends on the 'maxChars' - * field above. */ -} String; - -#define STRING_SIZE(numChars) \ - (offsetof(String, unicode) + ((numChars + 1) * sizeof(Tcl_UniChar))) -#define stringAttemptAlloc(numChars) \ - (String *) Tcl_AttemptAlloc(STRING_SIZE(numChars)) -#define stringAlloc(numChars) \ - (String *) Tcl_Alloc(STRING_SIZE(numChars)) -#define stringRealloc(ptr, numChars) \ - (String *) Tcl_Realloc((ptr), STRING_SIZE(numChars)) -#define stringAttemptRealloc(ptr, numChars) \ - (String *) Tcl_AttemptRealloc((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)) - -#endif /* _TCLSTRINGREP */ -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ DELETED generic/tclStringTrim.h Index: generic/tclStringTrim.h ================================================================== --- generic/tclStringTrim.h +++ /dev/null @@ -1,45 +0,0 @@ -/* - * tclStringTrim.h -- - * - * This file contains the definition of what characters are to be trimmed - * from a string by [string trim] by default. It's only needed by Tcl's - * implementation; it does not form a public or private API at all. - * - * Copyright (c) 1987-1993 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * Copyright (c) 1998-2000 Scriptics Corporation. - * Copyright (c) 2002 ActiveState Corporation. - * Copyright (c) 2003-2013 Donal K. Fellows. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#ifndef TCL_STRING_TRIM_H -#define TCL_STRING_TRIM_H - -/* - * Default set of characters to trim in [string trim] and friends. This is a - * UTF-8 literal string containing all Unicode space characters. [TIP #413] - */ - -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 */ - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ Index: generic/tclStubInit.c ================================================================== --- generic/tclStubInit.c +++ generic/tclStubInit.c @@ -8,22 +8,11 @@ * 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 -#endif - -#ifdef __GNUC__ -#pragma GCC dependency "tcl.decls" -#pragma GCC dependency "tclInt.decls" -#pragma GCC dependency "tclTomMath.decls" -#endif +#include "tommath.h" /* * Remove macros that will interfere with the definitions below. */ @@ -34,142 +23,132 @@ #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_NewUnicodeObj -#undef Tcl_SetUnicodeObj #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 - -#if TCL_UTF_MAX <= 3 -static void uniCodePanic() { - 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 (Tcl_UniChar *(*)(Tcl_Obj *, int *))(void *)uniCodePanic -# define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const Tcl_UniChar *, size_t))(void *)uniCodePanic -# define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, size_t))(void *)uniCodePanic -#endif - -#define TclBN_mp_add mp_add -#define TclBN_mp_add_d mp_add_d -#define TclBN_mp_and mp_and -#define TclBN_mp_clamp mp_clamp -#define TclBN_mp_clear mp_clear -#define TclBN_mp_clear_multi mp_clear_multi -#define TclBN_mp_cmp mp_cmp -#define TclBN_mp_cmp_d mp_cmp_d -#define TclBN_mp_cmp_mag mp_cmp_mag -#define TclBN_mp_cnt_lsb mp_cnt_lsb -#define TclBN_mp_copy mp_copy -#define TclBN_mp_count_bits mp_count_bits -#define TclBN_mp_div mp_div -#define TclBN_mp_div_d mp_div_d -#define TclBN_mp_div_2 mp_div_2 -#define TclBN_mp_div_2d mp_div_2d -#define TclBN_mp_exch mp_exch -#define TclBN_mp_expt_u32 mp_expt_u32 -#define TclBN_mp_get_mag_u64 mp_get_mag_u64 -#define TclBN_mp_grow mp_grow -#define TclBN_mp_init mp_init -#define TclBN_mp_init_copy mp_init_copy -#define TclBN_mp_init_multi mp_init_multi -#define TclBN_mp_init_set mp_init_set -#define TclBN_mp_init_size mp_init_size -#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_d mp_mul_d -#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_sub_d mp_sub_d -#define TclBN_mp_signed_rsh mp_signed_rsh -#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 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 TclStaticPackage Tcl_StaticPackage +#define TclUnusedStubEntry NULL + +/* + * Keep a record of the original Notifier procedures, created in the + * same compilation unit as the stub tables so we can later do reliable, + * portable comparisons to see whether a Tcl_SetNotifier() call swapped + * new routines into the stub table. + */ + +Tcl_NotifierProcs tclOriginalNotifier = { + Tcl_SetTimer, + Tcl_WaitForEvent, +#if !defined(__WIN32__) /* UNIX */ + Tcl_CreateFileHandler, + Tcl_DeleteFileHandler, +#else + NULL, + NULL, +#endif + NULL, + NULL, + NULL, + NULL +}; + +/* See bug 510001: TclSockMinimumBuffers needs plat imp */ +#ifdef _WIN64 +# define TclSockMinimumBuffersOld 0 +#else +int TclSockMinimumBuffersOld(sock, size) + int sock; + int size; +{ + return TclSockMinimumBuffers(INT2PTR(sock), size); +} +#endif + +MODULE_SCOPE TclIntStubs tclIntStubs; +MODULE_SCOPE TclIntPlatStubs tclIntPlatStubs; +MODULE_SCOPE TclPlatStubs tclPlatStubs; +MODULE_SCOPE TclStubs tclStubs; +MODULE_SCOPE TclTomMathStubs tclTomMathStubs; + +#if defined(_WIN32) || defined(__CYGWIN__) +#undef TclWinNToHS +unsigned short TclWinNToHS(unsigned short ns) { + return ntohs(ns); +} +#endif + +#ifdef __WIN32__ +# define TclUnixWaitForFile 0 +# define TclUnixCopyFile 0 # define TclpReaddir 0 # define TclpIsAtty 0 #elif defined(__CYGWIN__) -# define TclpIsAtty isatty -static void -doNothing(void) -{ - /* dummy implementation, no need to do anything */ -} -# define TclWinAddProcess (void (*) (void *, size_t)) doNothing +# define TclpIsAtty TclPlatIsAtty +# define TclWinSetInterfaces (void (*) (int)) doNothing +# define TclWinAddProcess (void (*) (void *, unsigned int)) doNothing # define TclWinFlushDirtyChannels doNothing +# define TclWinResetInterfaces doNothing +# define TclpGetTZName 0 + +static Tcl_Encoding winTCharEncoding; + +static int +TclpIsAtty(int fd) +{ + return isatty(fd); +} + +#define TclWinGetPlatformId winGetPlatformId +static int +TclWinGetPlatformId() +{ + /* Don't bother to determine the real platform on cygwin, + * because VER_PLATFORM_WIN32_NT is the only supported platform */ + return 2; /* VER_PLATFORM_WIN32_NT */; +} + +void *TclWinGetTclInstance() +{ + void *hInstance = NULL; + GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS, + (const char *)&winTCharEncoding, &hInstance); + return hInstance; +} + +#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); +} #define TclWinNoBackslash winNoBackslash static char * TclWinNoBackslash(char *path) { @@ -181,40 +160,87 @@ } } return path; } -void *TclWinGetTclInstance() -{ - void *hInstance = NULL; - GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS, - (const wchar_t *)&TclWinNoBackslash, &hInstance); - return hInstance; -} - -size_t +int TclpGetPid(Tcl_Pid pid) { - return (size_t)pid; + return (int) (size_t) pid; +} + +static void +doNothing(void) +{ + /* dummy implementation, no need to do anything */ +} + +char * +Tcl_WinUtfToTChar( + const char *string, + int len, + Tcl_DString *dsPtr) +{ + if (!winTCharEncoding) { + winTCharEncoding = Tcl_GetEncoding(0, "unicode"); + } + return Tcl_UtfToExternalDString(winTCharEncoding, + string, len, dsPtr); +} + +char * +Tcl_WinTCharToUtf( + const char *string, + int len, + Tcl_DString *dsPtr) +{ + if (!winTCharEncoding) { + winTCharEncoding = Tcl_GetEncoding(0, "unicode"); + } + return Tcl_ExternalToUtfDString(winTCharEncoding, + string, len, dsPtr); } #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. */ +#define Tcl_DbNewLongObj ((Tcl_Obj*(*)(long,const char*,int))dbNewLongObj) +static Tcl_Obj *dbNewLongObj( + int intValue, + const char *file, + int line +) { +#ifdef TCL_MEM_DEBUG + register Tcl_Obj *objPtr; + + TclDbNewObj(objPtr, file, line); + objPtr->bytes = NULL; + + objPtr->internalRep.longValue = (long) intValue; + objPtr->typePtr = &tclIntType; + return objPtr; +#else + return Tcl_NewIntObj(intValue); +#endif +} +#define Tcl_GetLongFromObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetIntFromObj +#define Tcl_NewLongObj (Tcl_Obj*(*)(long))Tcl_NewIntObj +#define Tcl_SetLongObj (void(*)(Tcl_Obj*,long))Tcl_SetIntObj static int exprInt(Tcl_Interp *interp, const char *expr, int *ptr){ long longValue; int result = Tcl_ExprLong(interp, expr, &longValue); if (result == TCL_OK) { - if ((longValue >= (long)(INT_MIN)) + if ((longValue >= -(long)(UINT_MAX)) && (longValue <= (long)(UINT_MAX))) { *ptr = (int)longValue; } else { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "integer value too large to represent as non-long integer", -1)); + Tcl_SetResult(interp, + "integer value too large to represent as non-long integer", + TCL_STATIC); result = TCL_ERROR; } } return result; } @@ -221,199 +247,203 @@ #define Tcl_ExprLong (int(*)(Tcl_Interp*,const char*,long*))exprInt static int exprIntObj(Tcl_Interp *interp, Tcl_Obj*expr, int *ptr){ long longValue; int result = Tcl_ExprLongObj(interp, expr, &longValue); if (result == TCL_OK) { - if ((longValue >= (long)(INT_MIN)) + if ((longValue >= -(long)(UINT_MAX)) && (longValue <= (long)(UINT_MAX))) { *ptr = (int)longValue; } else { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "integer value too large to represent as non-long integer", -1)); + Tcl_SetResult(interp, + "integer value too large to represent as non-long integer", + TCL_STATIC); result = TCL_ERROR; } } return result; } #define Tcl_ExprLongObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))exprIntObj +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))uniCharNcmp 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 +#define Tcl_UtfNcmp (int(*)(const char*,const char*,unsigned long))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 +#define Tcl_UtfNcasecmp (int(*)(const char*,const char*,unsigned long))utfNcasecmp +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))uniCharNcasecmp +static int formatInt(char *buffer, int n){ + return TclFormatInt(buffer, (long)n); +} +#define TclFormatInt (int(*)(char *, long))formatInt -#endif /* TCL_WIDE_INT_IS_LONG */ +#endif -#endif /* __CYGWIN__ */ +#else /* UNIX and MAC */ +# define TclpLocaltime_unix TclpLocaltime +# define TclpGmtime_unix TclpGmtime +#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. */ -MODULE_SCOPE const TclStubs tclStubs; -MODULE_SCOPE const TclTomMathStubs tclTomMathStubs; - -#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 - /* !BEGIN!: Do not edit below this line. */ -static const TclIntStubs tclIntStubs = { +TclIntStubs tclIntStubs = { TCL_STUB_MAGIC, - 0, - 0, /* 0 */ - 0, /* 1 */ - 0, /* 2 */ + NULL, + NULL, /* 0 */ + NULL, /* 1 */ + NULL, /* 2 */ TclAllocateFreeObjects, /* 3 */ - 0, /* 4 */ + NULL, /* 4 */ TclCleanupChildren, /* 5 */ TclCleanupCommand, /* 6 */ TclCopyAndCollapse, /* 7 */ - 0, /* 8 */ + TclCopyChannel, /* 8 */ TclCreatePipeline, /* 9 */ TclCreateProc, /* 10 */ TclDeleteCompiledLocalVars, /* 11 */ TclDeleteVars, /* 12 */ - 0, /* 13 */ + NULL, /* 13 */ TclDumpMemoryInfo, /* 14 */ - 0, /* 15 */ + NULL, /* 15 */ TclExprFloatError, /* 16 */ - 0, /* 17 */ - 0, /* 18 */ - 0, /* 19 */ - 0, /* 20 */ - 0, /* 21 */ + NULL, /* 17 */ + NULL, /* 18 */ + NULL, /* 19 */ + NULL, /* 20 */ + NULL, /* 21 */ TclFindElement, /* 22 */ TclFindProc, /* 23 */ TclFormatInt, /* 24 */ TclFreePackageInfo, /* 25 */ - 0, /* 26 */ - 0, /* 27 */ + NULL, /* 26 */ + NULL, /* 27 */ TclpGetDefaultStdChannel, /* 28 */ - 0, /* 29 */ - 0, /* 30 */ + NULL, /* 29 */ + NULL, /* 30 */ TclGetExtension, /* 31 */ TclGetFrame, /* 32 */ - 0, /* 33 */ - 0, /* 34 */ - 0, /* 35 */ - 0, /* 36 */ + NULL, /* 33 */ + TclGetIntForIndex, /* 34 */ + NULL, /* 35 */ + TclGetLong, /* 36 */ TclGetLoadedPackages, /* 37 */ TclGetNamespaceForQualName, /* 38 */ TclGetObjInterpProc, /* 39 */ TclGetOpenMode, /* 40 */ TclGetOriginalCommand, /* 41 */ TclpGetUserHome, /* 42 */ - 0, /* 43 */ + NULL, /* 43 */ TclGuessPackageName, /* 44 */ TclHideUnsafeCommands, /* 45 */ TclInExit, /* 46 */ - 0, /* 47 */ - 0, /* 48 */ - 0, /* 49 */ - 0, /* 50 */ + NULL, /* 47 */ + NULL, /* 48 */ + NULL, /* 49 */ + TclInitCompiledLocals, /* 50 */ TclInterpInit, /* 51 */ - 0, /* 52 */ + NULL, /* 52 */ TclInvokeObjectCommand, /* 53 */ TclInvokeStringCommand, /* 54 */ TclIsProc, /* 55 */ - 0, /* 56 */ - 0, /* 57 */ + NULL, /* 56 */ + NULL, /* 57 */ TclLookupVar, /* 58 */ - 0, /* 59 */ + NULL, /* 59 */ TclNeedSpace, /* 60 */ TclNewProcBodyObj, /* 61 */ TclObjCommandComplete, /* 62 */ TclObjInterpProc, /* 63 */ TclObjInvoke, /* 64 */ - 0, /* 65 */ - 0, /* 66 */ - 0, /* 67 */ - 0, /* 68 */ + NULL, /* 65 */ + NULL, /* 66 */ + NULL, /* 67 */ + NULL, /* 68 */ TclpAlloc, /* 69 */ - 0, /* 70 */ - 0, /* 71 */ - 0, /* 72 */ - 0, /* 73 */ + NULL, /* 70 */ + NULL, /* 71 */ + NULL, /* 72 */ + NULL, /* 73 */ TclpFree, /* 74 */ TclpGetClicks, /* 75 */ TclpGetSeconds, /* 76 */ - 0, /* 77 */ - 0, /* 78 */ - 0, /* 79 */ - 0, /* 80 */ + TclpGetTime, /* 77 */ + TclpGetTimeZone, /* 78 */ + NULL, /* 79 */ + NULL, /* 80 */ TclpRealloc, /* 81 */ - 0, /* 82 */ - 0, /* 83 */ - 0, /* 84 */ - 0, /* 85 */ - 0, /* 86 */ - 0, /* 87 */ - 0, /* 88 */ + NULL, /* 82 */ + NULL, /* 83 */ + NULL, /* 84 */ + NULL, /* 85 */ + NULL, /* 86 */ + NULL, /* 87 */ + TclPrecTraceProc, /* 88 */ TclPreventAliasLoop, /* 89 */ - 0, /* 90 */ + NULL, /* 90 */ TclProcCleanupProc, /* 91 */ TclProcCompileProc, /* 92 */ TclProcDeleteProc, /* 93 */ - 0, /* 94 */ - 0, /* 95 */ + NULL, /* 94 */ + NULL, /* 95 */ TclRenameCommand, /* 96 */ TclResetShadowedCmdRefs, /* 97 */ TclServiceIdle, /* 98 */ - 0, /* 99 */ - 0, /* 100 */ + NULL, /* 99 */ + NULL, /* 100 */ TclSetPreInitScript, /* 101 */ TclSetupEnv, /* 102 */ TclSockGetPort, /* 103 */ - 0, /* 104 */ - 0, /* 105 */ - 0, /* 106 */ - 0, /* 107 */ + TclSockMinimumBuffersOld, /* 104 */ + NULL, /* 105 */ + NULL, /* 106 */ + NULL, /* 107 */ TclTeardownNamespace, /* 108 */ TclUpdateReturnInfo, /* 109 */ TclSockMinimumBuffers, /* 110 */ Tcl_AddInterpResolvers, /* 111 */ - 0, /* 112 */ - 0, /* 113 */ - 0, /* 114 */ - 0, /* 115 */ - 0, /* 116 */ - 0, /* 117 */ + Tcl_AppendExportList, /* 112 */ + Tcl_CreateNamespace, /* 113 */ + Tcl_DeleteNamespace, /* 114 */ + Tcl_Export, /* 115 */ + Tcl_FindCommand, /* 116 */ + Tcl_FindNamespace, /* 117 */ Tcl_GetInterpResolvers, /* 118 */ Tcl_GetNamespaceResolvers, /* 119 */ Tcl_FindNamespaceVar, /* 120 */ - 0, /* 121 */ - 0, /* 122 */ - 0, /* 123 */ - 0, /* 124 */ - 0, /* 125 */ + Tcl_ForgetImport, /* 121 */ + Tcl_GetCommandFromObj, /* 122 */ + Tcl_GetCommandFullName, /* 123 */ + Tcl_GetCurrentNamespace, /* 124 */ + Tcl_GetGlobalNamespace, /* 125 */ Tcl_GetVariableFullName, /* 126 */ - 0, /* 127 */ + Tcl_Import, /* 127 */ Tcl_PopCallFrame, /* 128 */ Tcl_PushCallFrame, /* 129 */ Tcl_RemoveInterpResolvers, /* 130 */ Tcl_SetNamespaceResolvers, /* 131 */ TclpHasSockets, /* 132 */ - 0, /* 133 */ - 0, /* 134 */ - 0, /* 135 */ - 0, /* 136 */ - 0, /* 137 */ + TclpGetDate, /* 133 */ + NULL, /* 134 */ + NULL, /* 135 */ + NULL, /* 136 */ + NULL, /* 137 */ TclGetEnv, /* 138 */ - 0, /* 139 */ - 0, /* 140 */ + NULL, /* 139 */ + NULL, /* 140 */ TclpGetCwd, /* 141 */ TclSetByteCodeFromAny, /* 142 */ TclAddLiteralObj, /* 143 */ TclHideLiteral, /* 144 */ TclGetAuxDataType, /* 145 */ @@ -423,167 +453,167 @@ TclHandleRelease, /* 149 */ TclRegAbout, /* 150 */ TclRegExpRangeUniChar, /* 151 */ TclSetLibraryPath, /* 152 */ TclGetLibraryPath, /* 153 */ - 0, /* 154 */ - 0, /* 155 */ + NULL, /* 154 */ + NULL, /* 155 */ TclRegError, /* 156 */ TclVarTraceExists, /* 157 */ - 0, /* 158 */ - 0, /* 159 */ - 0, /* 160 */ + TclSetStartupScriptFileName, /* 158 */ + TclGetStartupScriptFileName, /* 159 */ + NULL, /* 160 */ TclChannelTransform, /* 161 */ TclChannelEventScriptInvoker, /* 162 */ TclGetInstructionTable, /* 163 */ TclExpandCodeArray, /* 164 */ TclpSetInitialEncodings, /* 165 */ TclListObjSetElement, /* 166 */ - 0, /* 167 */ - 0, /* 168 */ + TclSetStartupScriptPath, /* 167 */ + TclGetStartupScriptPath, /* 168 */ TclpUtfNcmp2, /* 169 */ TclCheckInterpTraces, /* 170 */ TclCheckExecutionTraces, /* 171 */ TclInThreadExit, /* 172 */ TclUniCharMatch, /* 173 */ - 0, /* 174 */ + NULL, /* 174 */ TclCallVarTraces, /* 175 */ TclCleanupVar, /* 176 */ TclVarErrMsg, /* 177 */ - 0, /* 178 */ - 0, /* 179 */ - 0, /* 180 */ - 0, /* 181 */ - 0, /* 182 */ - 0, /* 183 */ - 0, /* 184 */ - 0, /* 185 */ - 0, /* 186 */ - 0, /* 187 */ - 0, /* 188 */ - 0, /* 189 */ - 0, /* 190 */ - 0, /* 191 */ - 0, /* 192 */ - 0, /* 193 */ - 0, /* 194 */ - 0, /* 195 */ - 0, /* 196 */ - 0, /* 197 */ + Tcl_SetStartupScript, /* 178 */ + Tcl_GetStartupScript, /* 179 */ + NULL, /* 180 */ + NULL, /* 181 */ + TclpLocaltime, /* 182 */ + TclpGmtime, /* 183 */ + NULL, /* 184 */ + NULL, /* 185 */ + NULL, /* 186 */ + NULL, /* 187 */ + NULL, /* 188 */ + NULL, /* 189 */ + NULL, /* 190 */ + NULL, /* 191 */ + NULL, /* 192 */ + NULL, /* 193 */ + NULL, /* 194 */ + NULL, /* 195 */ + NULL, /* 196 */ + NULL, /* 197 */ TclObjGetFrame, /* 198 */ - 0, /* 199 */ + NULL, /* 199 */ TclpObjRemoveDirectory, /* 200 */ TclpObjCopyDirectory, /* 201 */ TclpObjCreateDirectory, /* 202 */ TclpObjDeleteFile, /* 203 */ TclpObjCopyFile, /* 204 */ TclpObjRenameFile, /* 205 */ TclpObjStat, /* 206 */ TclpObjAccess, /* 207 */ TclpOpenFileChannel, /* 208 */ - 0, /* 209 */ - 0, /* 210 */ - 0, /* 211 */ + NULL, /* 209 */ + NULL, /* 210 */ + NULL, /* 211 */ TclpFindExecutable, /* 212 */ TclGetObjNameOfExecutable, /* 213 */ TclSetObjNameOfExecutable, /* 214 */ TclStackAlloc, /* 215 */ TclStackFree, /* 216 */ TclPushStackFrame, /* 217 */ TclPopStackFrame, /* 218 */ - 0, /* 219 */ - 0, /* 220 */ - 0, /* 221 */ - 0, /* 222 */ - 0, /* 223 */ + NULL, /* 219 */ + NULL, /* 220 */ + NULL, /* 221 */ + NULL, /* 222 */ + NULL, /* 223 */ TclGetPlatform, /* 224 */ TclTraceDictPath, /* 225 */ TclObjBeingDeleted, /* 226 */ TclSetNsPath, /* 227 */ - 0, /* 228 */ + TclObjInterpProcCore, /* 228 */ TclPtrMakeUpvar, /* 229 */ TclObjLookupVar, /* 230 */ TclGetNamespaceFromObj, /* 231 */ TclEvalObjEx, /* 232 */ TclGetSrcInfoForPc, /* 233 */ TclVarHashCreateVar, /* 234 */ TclInitVarHashTable, /* 235 */ - 0, /* 236 */ - TclResetCancellation, /* 237 */ - TclNRInterpProc, /* 238 */ - TclNRInterpProcCore, /* 239 */ - TclNRRunCallbacks, /* 240 */ - TclNREvalObjEx, /* 241 */ - TclNREvalObjv, /* 242 */ + TclBackgroundException, /* 236 */ + NULL, /* 237 */ + NULL, /* 238 */ + NULL, /* 239 */ + NULL, /* 240 */ + NULL, /* 241 */ + NULL, /* 242 */ TclDbDumpActiveObjects, /* 243 */ - TclGetNamespaceChildTable, /* 244 */ - TclGetNamespaceCommandTable, /* 245 */ - TclInitRewriteEnsemble, /* 246 */ - TclResetRewriteEnsemble, /* 247 */ - TclCopyChannel, /* 248 */ + NULL, /* 244 */ + NULL, /* 245 */ + NULL, /* 246 */ + NULL, /* 247 */ + NULL, /* 248 */ TclDoubleDigits, /* 249 */ - TclSetChildCancelFlags, /* 250 */ + NULL, /* 250 */ TclRegisterLiteral, /* 251 */ - TclPtrGetVar, /* 252 */ - TclPtrSetVar, /* 253 */ - TclPtrIncrObjVar, /* 254 */ - TclPtrObjMakeUpvar, /* 255 */ - TclPtrUnsetVar, /* 256 */ + NULL, /* 252 */ + NULL, /* 253 */ + NULL, /* 254 */ + NULL, /* 255 */ + NULL, /* 256 */ TclStaticPackage, /* 257 */ - TclpCreateTemporaryDirectory, /* 258 */ - TclAppendUnicodeToObj, /* 259 */ - TclGetBytesFromObj, /* 260 */ + NULL, /* 258 */ + NULL, /* 259 */ + NULL, /* 260 */ + TclUnusedStubEntry, /* 261 */ }; -static const TclIntPlatStubs tclIntPlatStubs = { +TclIntPlatStubs tclIntPlatStubs = { TCL_STUB_MAGIC, - 0, -#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ + NULL, +#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ TclGetAndDetachPids, /* 0 */ TclpCloseFile, /* 1 */ TclpCreateCommandChannel, /* 2 */ TclpCreatePipe, /* 3 */ TclpCreateProcess, /* 4 */ - TclUnixWaitForFile_, /* 5 */ + NULL, /* 5 */ TclpMakeFile, /* 6 */ TclpOpenFile, /* 7 */ TclUnixWaitForFile, /* 8 */ TclpCreateTempFile, /* 9 */ - 0, /* 10 */ - 0, /* 11 */ - 0, /* 12 */ - 0, /* 13 */ + 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 */ + NULL, /* 15 */ + NULL, /* 16 */ + NULL, /* 17 */ + NULL, /* 18 */ + NULL, /* 19 */ + NULL, /* 20 */ + NULL, /* 21 */ + NULL, /* 22 */ + NULL, /* 23 */ + NULL, /* 24 */ + NULL, /* 25 */ + NULL, /* 26 */ + NULL, /* 27 */ + NULL, /* 28 */ TclWinCPUID, /* 29 */ - TclUnixOpenTemporaryFile, /* 30 */ #endif /* UNIX */ -#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ +#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ TclWinConvertError, /* 0 */ - 0, /* 1 */ - 0, /* 2 */ - 0, /* 3 */ + TclWinConvertWSAError, /* 1 */ + TclWinGetServByName, /* 2 */ + TclWinGetSockOpt, /* 3 */ TclWinGetTclInstance, /* 4 */ TclUnixWaitForFile, /* 5 */ - 0, /* 6 */ - 0, /* 7 */ + TclWinNToHS, /* 6 */ + TclWinSetSockOpt, /* 7 */ TclpGetPid, /* 8 */ - 0, /* 9 */ - 0, /* 10 */ + TclWinGetPlatformId, /* 9 */ + TclpReaddir, /* 10 */ TclGetAndDetachPids, /* 11 */ TclpCloseFile, /* 12 */ TclpCreateCommandChannel, /* 13 */ TclpCreatePipe, /* 14 */ TclpCreateProcess, /* 15 */ @@ -590,68 +620,73 @@ TclpIsAtty, /* 16 */ TclUnixCopyFile, /* 17 */ TclpMakeFile, /* 18 */ TclpOpenFile, /* 19 */ TclWinAddProcess, /* 20 */ - 0, /* 21 */ + TclpInetNtoa, /* 21 */ TclpCreateTempFile, /* 22 */ - 0, /* 23 */ + TclpGetTZName, /* 23 */ TclWinNoBackslash, /* 24 */ - 0, /* 25 */ - 0, /* 26 */ + NULL, /* 25 */ + TclWinSetInterfaces, /* 26 */ TclWinFlushDirtyChannels, /* 27 */ - 0, /* 28 */ + 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 */ + NULL, /* 5 */ TclpMakeFile, /* 6 */ TclpOpenFile, /* 7 */ TclUnixWaitForFile, /* 8 */ TclpCreateTempFile, /* 9 */ - 0, /* 10 */ - 0, /* 11 */ - 0, /* 12 */ - 0, /* 13 */ + 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 /* MACOSX */ -}; - -static const TclPlatStubs tclPlatStubs = { - TCL_STUB_MAGIC, - 0, -#ifdef MAC_OSX_TCL /* MACOSX */ - 0, /* 0 */ - Tcl_MacOSXOpenVersionedBundleResources, /* 1 */ -#endif /* MACOSX */ -}; - -const TclTomMathStubs tclTomMathStubs = { - TCL_STUB_MAGIC, - 0, + NULL, /* 20 */ + NULL, /* 21 */ + NULL, /* 22 */ + NULL, /* 23 */ + NULL, /* 24 */ + NULL, /* 25 */ + NULL, /* 26 */ + NULL, /* 27 */ + NULL, /* 28 */ + TclWinCPUID, /* 29 */ +#endif /* MACOSX */ +}; + +TclPlatStubs tclPlatStubs = { + TCL_STUB_MAGIC, + NULL, +#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ + Tcl_WinUtfToTChar, /* 0 */ + Tcl_WinTCharToUtf, /* 1 */ + NULL, /* 2 */ + TclUnusedStubEntry, /* 3 */ +#endif /* WIN */ +#ifdef MAC_OSX_TCL /* MACOSX */ + Tcl_MacOSXOpenBundleResources, /* 0 */ + Tcl_MacOSXOpenVersionedBundleResources, /* 1 */ + TclUnusedStubEntry, /* 2 */ +#endif /* MACOSX */ +}; + +TclTomMathStubs tclTomMathStubs = { + TCL_STUB_MAGIC, + NULL, TclBN_epoch, /* 0 */ TclBN_revision, /* 1 */ TclBN_mp_add, /* 2 */ TclBN_mp_add_d, /* 3 */ TclBN_mp_and, /* 4 */ @@ -665,13 +700,13 @@ TclBN_mp_count_bits, /* 12 */ TclBN_mp_div, /* 13 */ TclBN_mp_div_d, /* 14 */ TclBN_mp_div_2, /* 15 */ TclBN_mp_div_2d, /* 16 */ - 0, /* 17 */ + TclBN_mp_div_3, /* 17 */ TclBN_mp_exch, /* 18 */ - TclBN_mp_expt_u32, /* 19 */ + TclBN_mp_expt_d, /* 19 */ TclBN_mp_grow, /* 20 */ TclBN_mp_init, /* 21 */ TclBN_mp_init_copy, /* 22 */ TclBN_mp_init_multi, /* 23 */ TclBN_mp_init_set, /* 24 */ @@ -687,61 +722,61 @@ TclBN_mp_or, /* 34 */ TclBN_mp_radix_size, /* 35 */ TclBN_mp_read_radix, /* 36 */ TclBN_mp_rshd, /* 37 */ TclBN_mp_shrink, /* 38 */ - 0, /* 39 */ - 0, /* 40 */ + TclBN_mp_set, /* 39 */ + TclBN_mp_sqr, /* 40 */ TclBN_mp_sqrt, /* 41 */ TclBN_mp_sub, /* 42 */ TclBN_mp_sub_d, /* 43 */ - 0, /* 44 */ - 0, /* 45 */ - 0, /* 46 */ - TclBN_mp_ubin_size, /* 47 */ + TclBN_mp_to_unsigned_bin, /* 44 */ + TclBN_mp_to_unsigned_bin_n, /* 45 */ + TclBN_mp_toradix_n, /* 46 */ + TclBN_mp_unsigned_bin_size, /* 47 */ TclBN_mp_xor, /* 48 */ TclBN_mp_zero, /* 49 */ - 0, /* 50 */ - 0, /* 51 */ - 0, /* 52 */ - 0, /* 53 */ - 0, /* 54 */ - 0, /* 55 */ - 0, /* 56 */ - 0, /* 57 */ - 0, /* 58 */ - 0, /* 59 */ - 0, /* 60 */ - 0, /* 61 */ - 0, /* 62 */ + TclBN_reverse, /* 50 */ + TclBN_fast_s_mp_mul_digs, /* 51 */ + TclBN_fast_s_mp_sqr, /* 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_set_int, /* 61 */ + TclBN_mp_set_int, /* 62 */ TclBN_mp_cnt_lsb, /* 63 */ - 0, /* 64 */ - TclBN_mp_init_i64, /* 65 */ - TclBN_mp_init_u64, /* 66 */ - 0, /* 67 */ - TclBN_mp_set_u64, /* 68 */ - TclBN_mp_get_mag_u64, /* 69 */ - TclBN_mp_set_i64, /* 70 */ - 0, /* 71 */ - 0, /* 72 */ - 0, /* 73 */ - 0, /* 74 */ - 0, /* 75 */ - TclBN_mp_signed_rsh, /* 76 */ - 0, /* 77 */ - TclBN_mp_to_ubin, /* 78 */ - 0, /* 79 */ - TclBN_mp_to_radix, /* 80 */ + NULL, /* 64 */ + NULL, /* 65 */ + NULL, /* 66 */ + NULL, /* 67 */ + NULL, /* 68 */ + NULL, /* 69 */ + NULL, /* 70 */ + NULL, /* 71 */ + NULL, /* 72 */ + NULL, /* 73 */ + NULL, /* 74 */ + NULL, /* 75 */ + NULL, /* 76 */ + NULL, /* 77 */ + NULL, /* 78 */ + NULL, /* 79 */ + TclUnusedStubEntry, /* 80 */ }; -static const TclStubHooks tclStubHooks = { +static TclStubHooks tclStubHooks = { &tclPlatStubs, &tclIntStubs, &tclIntPlatStubs }; -const TclStubs tclStubs = { +TclStubs tclStubs = { TCL_STUB_MAGIC, &tclStubHooks, Tcl_PkgProvideEx, /* 0 */ Tcl_PkgRequireEx, /* 1 */ Tcl_Panic, /* 2 */ @@ -749,24 +784,24 @@ Tcl_Free, /* 4 */ Tcl_Realloc, /* 5 */ Tcl_DbCkalloc, /* 6 */ Tcl_DbCkfree, /* 7 */ Tcl_DbCkrealloc, /* 8 */ -#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ Tcl_CreateFileHandler, /* 9 */ #endif /* UNIX */ -#if defined(_WIN32) /* WIN */ - 0, /* 9 */ +#if defined(__WIN32__) /* WIN */ + NULL, /* 9 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ Tcl_CreateFileHandler, /* 9 */ #endif /* MACOSX */ -#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ Tcl_DeleteFileHandler, /* 10 */ #endif /* UNIX */ -#if defined(_WIN32) /* WIN */ - 0, /* 10 */ +#if defined(__WIN32__) /* WIN */ + NULL, /* 10 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ Tcl_DeleteFileHandler, /* 10 */ #endif /* MACOSX */ Tcl_SetTimer, /* 11 */ @@ -778,25 +813,25 @@ Tcl_ConcatObj, /* 17 */ Tcl_ConvertToType, /* 18 */ Tcl_DbDecrRefCount, /* 19 */ Tcl_DbIncrRefCount, /* 20 */ Tcl_DbIsShared, /* 21 */ - 0, /* 22 */ + Tcl_DbNewBooleanObj, /* 22 */ Tcl_DbNewByteArrayObj, /* 23 */ Tcl_DbNewDoubleObj, /* 24 */ Tcl_DbNewListObj, /* 25 */ - 0, /* 26 */ + 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 */ - 0, /* 36 */ + Tcl_GetIndexFromObj, /* 36 */ Tcl_GetInt, /* 37 */ Tcl_GetIntFromObj, /* 38 */ Tcl_GetLongFromObj, /* 39 */ Tcl_GetObjType, /* 40 */ Tcl_GetStringFromObj, /* 41 */ @@ -805,43 +840,43 @@ Tcl_ListObjAppendElement, /* 44 */ Tcl_ListObjGetElements, /* 45 */ Tcl_ListObjIndex, /* 46 */ Tcl_ListObjLength, /* 47 */ Tcl_ListObjReplace, /* 48 */ - 0, /* 49 */ + Tcl_NewBooleanObj, /* 49 */ Tcl_NewByteArrayObj, /* 50 */ Tcl_NewDoubleObj, /* 51 */ - 0, /* 52 */ + Tcl_NewIntObj, /* 52 */ Tcl_NewListObj, /* 53 */ - 0, /* 54 */ + Tcl_NewLongObj, /* 54 */ Tcl_NewObj, /* 55 */ Tcl_NewStringObj, /* 56 */ - 0, /* 57 */ + Tcl_SetBooleanObj, /* 57 */ Tcl_SetByteArrayLength, /* 58 */ Tcl_SetByteArrayObj, /* 59 */ Tcl_SetDoubleObj, /* 60 */ - 0, /* 61 */ + Tcl_SetIntObj, /* 61 */ Tcl_SetListObj, /* 62 */ - 0, /* 63 */ + Tcl_SetLongObj, /* 63 */ Tcl_SetObjLength, /* 64 */ Tcl_SetStringObj, /* 65 */ - 0, /* 66 */ - 0, /* 67 */ + 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 */ - 0, /* 76 */ - 0, /* 77 */ + Tcl_BackgroundError, /* 76 */ + Tcl_Backslash, /* 77 */ Tcl_BadChannelOption, /* 78 */ Tcl_CallWhenDeleted, /* 79 */ Tcl_CancelIdleCall, /* 80 */ - 0, /* 81 */ + Tcl_Close, /* 81 */ Tcl_CommandComplete, /* 82 */ Tcl_Concat, /* 83 */ Tcl_ConvertElement, /* 84 */ Tcl_ConvertCountedElement, /* 85 */ Tcl_CreateAlias, /* 86 */ @@ -851,13 +886,13 @@ Tcl_CreateCloseHandler, /* 90 */ Tcl_CreateCommand, /* 91 */ Tcl_CreateEventSource, /* 92 */ Tcl_CreateExitHandler, /* 93 */ Tcl_CreateInterp, /* 94 */ - 0, /* 95 */ + Tcl_CreateMathFunc, /* 95 */ Tcl_CreateObjCommand, /* 96 */ - Tcl_CreateChild, /* 97 */ + Tcl_CreateSlave, /* 97 */ Tcl_CreateTimerHandler, /* 98 */ Tcl_CreateTrace, /* 99 */ Tcl_DeleteAssocData, /* 100 */ Tcl_DeleteChannelHandler, /* 101 */ Tcl_DeleteCloseHandler, /* 102 */ @@ -885,13 +920,13 @@ Tcl_DStringSetLength, /* 124 */ Tcl_DStringStartSublist, /* 125 */ Tcl_Eof, /* 126 */ Tcl_ErrnoId, /* 127 */ Tcl_ErrnoMsg, /* 128 */ - 0, /* 129 */ + Tcl_Eval, /* 129 */ Tcl_EvalFile, /* 130 */ - 0, /* 131 */ + Tcl_EvalObj, /* 131 */ Tcl_EventuallyFree, /* 132 */ Tcl_Exit, /* 133 */ Tcl_ExposeCommand, /* 134 */ Tcl_ExprBoolean, /* 135 */ Tcl_ExprBooleanObj, /* 136 */ @@ -900,14 +935,14 @@ Tcl_ExprLong, /* 139 */ Tcl_ExprLongObj, /* 140 */ Tcl_ExprObj, /* 141 */ Tcl_ExprString, /* 142 */ Tcl_Finalize, /* 143 */ - 0, /* 144 */ + Tcl_FindExecutable, /* 144 */ Tcl_FirstHashEntry, /* 145 */ Tcl_Flush, /* 146 */ - 0, /* 147 */ + Tcl_FreeResult, /* 147 */ Tcl_GetAlias, /* 148 */ Tcl_GetAliasObj, /* 149 */ Tcl_GetAssocData, /* 150 */ Tcl_GetChannel, /* 151 */ Tcl_GetChannelBufferSize, /* 152 */ @@ -920,43 +955,43 @@ Tcl_GetCommandInfo, /* 159 */ Tcl_GetCommandName, /* 160 */ Tcl_GetErrno, /* 161 */ Tcl_GetHostName, /* 162 */ Tcl_GetInterpPath, /* 163 */ - Tcl_GetParent, /* 164 */ + Tcl_GetMaster, /* 164 */ Tcl_GetNameOfExecutable, /* 165 */ Tcl_GetObjResult, /* 166 */ -#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ Tcl_GetOpenFile, /* 167 */ #endif /* UNIX */ -#if defined(_WIN32) /* WIN */ - 0, /* 167 */ +#if defined(__WIN32__) /* WIN */ + NULL, /* 167 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ Tcl_GetOpenFile, /* 167 */ #endif /* MACOSX */ Tcl_GetPathType, /* 168 */ Tcl_Gets, /* 169 */ Tcl_GetsObj, /* 170 */ Tcl_GetServiceMode, /* 171 */ - Tcl_GetChild, /* 172 */ + Tcl_GetSlave, /* 172 */ Tcl_GetStdChannel, /* 173 */ - 0, /* 174 */ - 0, /* 175 */ + Tcl_GetStringResult, /* 174 */ + Tcl_GetVar, /* 175 */ Tcl_GetVar2, /* 176 */ - 0, /* 177 */ - 0, /* 178 */ + 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 */ Tcl_JoinPath, /* 186 */ Tcl_LinkVar, /* 187 */ - 0, /* 188 */ + NULL, /* 188 */ Tcl_MakeFileChannel, /* 189 */ Tcl_MakeSafe, /* 190 */ Tcl_MakeTcpClientChannel, /* 191 */ Tcl_Merge, /* 192 */ Tcl_NextHashEntry, /* 193 */ @@ -984,81 +1019,81 @@ Tcl_RegExpRange, /* 215 */ Tcl_Release, /* 216 */ Tcl_ResetResult, /* 217 */ Tcl_ScanElement, /* 218 */ Tcl_ScanCountedElement, /* 219 */ - 0, /* 220 */ + 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 */ - 0, /* 230 */ + Tcl_SetPanicProc, /* 230 */ Tcl_SetRecursionLimit, /* 231 */ - 0, /* 232 */ + Tcl_SetResult, /* 232 */ Tcl_SetServiceMode, /* 233 */ Tcl_SetObjErrorCode, /* 234 */ Tcl_SetObjResult, /* 235 */ Tcl_SetStdChannel, /* 236 */ - 0, /* 237 */ + Tcl_SetVar, /* 237 */ Tcl_SetVar2, /* 238 */ Tcl_SignalId, /* 239 */ Tcl_SignalMsg, /* 240 */ Tcl_SourceRCFile, /* 241 */ Tcl_SplitList, /* 242 */ Tcl_SplitPath, /* 243 */ - 0, /* 244 */ - 0, /* 245 */ - 0, /* 246 */ - 0, /* 247 */ + 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 */ - 0, /* 253 */ + Tcl_UnsetVar, /* 253 */ Tcl_UnsetVar2, /* 254 */ - 0, /* 255 */ + Tcl_UntraceVar, /* 255 */ Tcl_UntraceVar2, /* 256 */ Tcl_UpdateLinkedVar, /* 257 */ - 0, /* 258 */ + Tcl_UpVar, /* 258 */ Tcl_UpVar2, /* 259 */ Tcl_VarEval, /* 260 */ - 0, /* 261 */ + Tcl_VarTraceInfo, /* 261 */ Tcl_VarTraceInfo2, /* 262 */ Tcl_Write, /* 263 */ Tcl_WrongNumArgs, /* 264 */ Tcl_DumpActiveMemory, /* 265 */ Tcl_ValidateAllMemory, /* 266 */ - 0, /* 267 */ - 0, /* 268 */ + Tcl_AppendResultVA, /* 267 */ + Tcl_AppendStringsToObjVA, /* 268 */ Tcl_HashStats, /* 269 */ Tcl_ParseVar, /* 270 */ - 0, /* 271 */ + Tcl_PkgPresent, /* 271 */ Tcl_PkgPresentEx, /* 272 */ - 0, /* 273 */ - 0, /* 274 */ - 0, /* 275 */ - 0, /* 276 */ + Tcl_PkgProvide, /* 273 */ + Tcl_PkgRequire, /* 274 */ + Tcl_SetErrorCodeVA, /* 275 */ + Tcl_VarEvalVA, /* 276 */ Tcl_WaitPid, /* 277 */ - 0, /* 278 */ + Tcl_PanicVA, /* 278 */ Tcl_GetVersion, /* 279 */ Tcl_InitMemory, /* 280 */ Tcl_StackChannel, /* 281 */ Tcl_UnstackChannel, /* 282 */ Tcl_GetStackedChannel, /* 283 */ Tcl_SetMainLoop, /* 284 */ - 0, /* 285 */ + NULL, /* 285 */ Tcl_AppendObjToObj, /* 286 */ Tcl_CreateEncoding, /* 287 */ Tcl_CreateThreadExitHandler, /* 288 */ Tcl_DeleteThreadExitHandler, /* 289 */ - 0, /* 290 */ + Tcl_DiscardResult, /* 290 */ Tcl_EvalEx, /* 291 */ Tcl_EvalObjv, /* 292 */ Tcl_EvalObjEx, /* 293 */ Tcl_ExitThread, /* 294 */ Tcl_ExternalToUtf, /* 295 */ @@ -1078,12 +1113,12 @@ Tcl_MutexUnlock, /* 309 */ Tcl_ConditionNotify, /* 310 */ Tcl_ConditionWait, /* 311 */ Tcl_NumUtfChars, /* 312 */ Tcl_ReadChars, /* 313 */ - 0, /* 314 */ - 0, /* 315 */ + Tcl_RestoreResult, /* 314 */ + Tcl_SaveResult, /* 315 */ Tcl_SetSystemEncoding, /* 316 */ Tcl_SetVar2Ex, /* 317 */ Tcl_ThreadAlert, /* 318 */ Tcl_ThreadQueueEvent, /* 319 */ Tcl_UniCharAtIndex, /* 320 */ @@ -1100,32 +1135,32 @@ Tcl_UtfPrev, /* 331 */ Tcl_UtfToExternal, /* 332 */ Tcl_UtfToExternalDString, /* 333 */ Tcl_UtfToLower, /* 334 */ Tcl_UtfToTitle, /* 335 */ - Tcl_UtfToChar16, /* 336 */ + Tcl_UtfToUniChar, /* 336 */ Tcl_UtfToUpper, /* 337 */ Tcl_WriteChars, /* 338 */ Tcl_WriteObj, /* 339 */ Tcl_GetString, /* 340 */ - 0, /* 341 */ - 0, /* 342 */ + 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 */ - 0, /* 352 */ - 0, /* 353 */ - Tcl_Char16ToUtfDString, /* 354 */ - Tcl_UtfToChar16DString, /* 355 */ + Tcl_UniCharLen, /* 352 */ + Tcl_UniCharNcmp, /* 353 */ + Tcl_UniCharToUtfDString, /* 354 */ + Tcl_UtfToUniCharDString, /* 355 */ Tcl_GetRegExpFromObj, /* 356 */ - 0, /* 357 */ + Tcl_EvalTokens, /* 357 */ Tcl_FreeParse, /* 358 */ Tcl_LogCommandInfo, /* 359 */ Tcl_ParseBraces, /* 360 */ Tcl_ParseCommand, /* 361 */ Tcl_ParseExpr, /* 362 */ @@ -1146,13 +1181,13 @@ Tcl_RegExpGetInfo, /* 377 */ Tcl_NewUnicodeObj, /* 378 */ Tcl_SetUnicodeObj, /* 379 */ Tcl_GetCharLength, /* 380 */ Tcl_GetUniChar, /* 381 */ - 0, /* 382 */ + Tcl_GetUnicode, /* 382 */ Tcl_GetRange, /* 383 */ - 0, /* 384 */ + Tcl_AppendUnicodeToObj, /* 384 */ Tcl_RegExpMatchObj, /* 385 */ Tcl_SetNotifier, /* 386 */ Tcl_GetAllocMutex, /* 387 */ Tcl_GetChannelNames, /* 388 */ Tcl_GetChannelNamesEx, /* 389 */ @@ -1165,15 +1200,15 @@ Tcl_GetTopChannel, /* 396 */ Tcl_ChannelBuffered, /* 397 */ Tcl_ChannelName, /* 398 */ Tcl_ChannelVersion, /* 399 */ Tcl_ChannelBlockModeProc, /* 400 */ - 0, /* 401 */ + Tcl_ChannelCloseProc, /* 401 */ Tcl_ChannelClose2Proc, /* 402 */ Tcl_ChannelInputProc, /* 403 */ Tcl_ChannelOutputProc, /* 404 */ - 0, /* 405 */ + Tcl_ChannelSeekProc, /* 405 */ Tcl_ChannelSetOptionProc, /* 406 */ Tcl_ChannelGetOptionProc, /* 407 */ Tcl_ChannelWatchProc, /* 408 */ Tcl_ChannelGetHandleProc, /* 409 */ Tcl_ChannelFlushProc, /* 410 */ @@ -1183,14 +1218,14 @@ Tcl_IsChannelRegistered, /* 414 */ Tcl_CutChannel, /* 415 */ Tcl_SpliceChannel, /* 416 */ Tcl_ClearChannelHandlers, /* 417 */ Tcl_IsChannelExisting, /* 418 */ - 0, /* 419 */ - 0, /* 420 */ - 0, /* 421 */ - 0, /* 422 */ + 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 */ @@ -1199,12 +1234,12 @@ Tcl_AttemptRealloc, /* 430 */ Tcl_AttemptDbCkrealloc, /* 431 */ Tcl_AttemptSetObjLength, /* 432 */ Tcl_GetChannelThread, /* 433 */ Tcl_GetUnicodeFromObj, /* 434 */ - 0, /* 435 */ - 0, /* 436 */ + Tcl_GetMathFuncInfo, /* 435 */ + Tcl_ListMathFuncs, /* 436 */ Tcl_SubstObj, /* 437 */ Tcl_DetachChannel, /* 438 */ Tcl_IsStandardChannel, /* 439 */ Tcl_FSCopyFile, /* 440 */ Tcl_FSCopyDirectory, /* 441 */ @@ -1283,11 +1318,11 @@ Tcl_FindNamespace, /* 514 */ Tcl_FindCommand, /* 515 */ Tcl_GetCommandFromObj, /* 516 */ Tcl_GetCommandFullName, /* 517 */ Tcl_FSEvalFileEx, /* 518 */ - 0, /* 519 */ + Tcl_SetExitProc, /* 519 */ Tcl_LimitAddHandler, /* 520 */ Tcl_LimitRemoveHandler, /* 521 */ Tcl_LimitReady, /* 522 */ Tcl_LimitCheck, /* 523 */ Tcl_LimitExceeded, /* 524 */ @@ -1344,77 +1379,116 @@ Tcl_AppendLimitedToObj, /* 575 */ Tcl_Format, /* 576 */ Tcl_AppendFormatToObj, /* 577 */ Tcl_ObjPrintf, /* 578 */ Tcl_AppendPrintfToObj, /* 579 */ - Tcl_CancelEval, /* 580 */ - Tcl_Canceled, /* 581 */ - Tcl_CreatePipe, /* 582 */ - Tcl_NRCreateCommand, /* 583 */ - Tcl_NREvalObj, /* 584 */ - Tcl_NREvalObjv, /* 585 */ - Tcl_NRCmdSwap, /* 586 */ - Tcl_NRAddCallback, /* 587 */ - Tcl_NRCallObjProc, /* 588 */ - Tcl_GetFSDeviceFromStat, /* 589 */ - Tcl_GetFSInodeFromStat, /* 590 */ - Tcl_GetModeFromStat, /* 591 */ - Tcl_GetLinkCountFromStat, /* 592 */ - Tcl_GetUserIdFromStat, /* 593 */ - Tcl_GetGroupIdFromStat, /* 594 */ - Tcl_GetDeviceTypeFromStat, /* 595 */ - Tcl_GetAccessTimeFromStat, /* 596 */ - Tcl_GetModificationTimeFromStat, /* 597 */ - Tcl_GetChangeTimeFromStat, /* 598 */ - Tcl_GetSizeFromStat, /* 599 */ - Tcl_GetBlocksFromStat, /* 600 */ - Tcl_GetBlockSizeFromStat, /* 601 */ - Tcl_SetEnsembleParameterList, /* 602 */ - Tcl_GetEnsembleParameterList, /* 603 */ - Tcl_ParseArgsObjv, /* 604 */ - Tcl_GetErrorLine, /* 605 */ - Tcl_SetErrorLine, /* 606 */ - Tcl_TransferResult, /* 607 */ - Tcl_InterpActive, /* 608 */ - Tcl_BackgroundException, /* 609 */ - Tcl_ZlibDeflate, /* 610 */ - Tcl_ZlibInflate, /* 611 */ - Tcl_ZlibCRC32, /* 612 */ - Tcl_ZlibAdler32, /* 613 */ - Tcl_ZlibStreamInit, /* 614 */ - Tcl_ZlibStreamGetCommandName, /* 615 */ - Tcl_ZlibStreamEof, /* 616 */ - Tcl_ZlibStreamChecksum, /* 617 */ - Tcl_ZlibStreamPut, /* 618 */ - Tcl_ZlibStreamGet, /* 619 */ - Tcl_ZlibStreamClose, /* 620 */ - Tcl_ZlibStreamReset, /* 621 */ - Tcl_SetStartupScript, /* 622 */ - Tcl_GetStartupScript, /* 623 */ - Tcl_CloseEx, /* 624 */ - Tcl_NRExprObj, /* 625 */ - Tcl_NRSubstObj, /* 626 */ - Tcl_LoadFile, /* 627 */ - Tcl_FindSymbol, /* 628 */ - Tcl_FSUnloadFile, /* 629 */ - Tcl_ZlibStreamSetCompressionDictionary, /* 630 */ - Tcl_OpenTcpServerEx, /* 631 */ - TclZipfs_Mount, /* 632 */ - TclZipfs_Unmount, /* 633 */ - TclZipfs_TclLibrary, /* 634 */ - TclZipfs_MountBuffer, /* 635 */ - Tcl_FreeIntRep, /* 636 */ - Tcl_InitStringRep, /* 637 */ - Tcl_FetchIntRep, /* 638 */ - 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 */ + NULL, /* 580 */ + NULL, /* 581 */ + NULL, /* 582 */ + NULL, /* 583 */ + NULL, /* 584 */ + NULL, /* 585 */ + NULL, /* 586 */ + NULL, /* 587 */ + NULL, /* 588 */ + NULL, /* 589 */ + NULL, /* 590 */ + NULL, /* 591 */ + NULL, /* 592 */ + NULL, /* 593 */ + NULL, /* 594 */ + NULL, /* 595 */ + NULL, /* 596 */ + NULL, /* 597 */ + NULL, /* 598 */ + NULL, /* 599 */ + NULL, /* 600 */ + NULL, /* 601 */ + NULL, /* 602 */ + NULL, /* 603 */ + NULL, /* 604 */ + NULL, /* 605 */ + NULL, /* 606 */ + NULL, /* 607 */ + NULL, /* 608 */ + NULL, /* 609 */ + NULL, /* 610 */ + NULL, /* 611 */ + NULL, /* 612 */ + NULL, /* 613 */ + NULL, /* 614 */ + NULL, /* 615 */ + NULL, /* 616 */ + NULL, /* 617 */ + NULL, /* 618 */ + NULL, /* 619 */ + NULL, /* 620 */ + NULL, /* 621 */ + NULL, /* 622 */ + NULL, /* 623 */ + NULL, /* 624 */ + NULL, /* 625 */ + NULL, /* 626 */ + NULL, /* 627 */ + NULL, /* 628 */ + NULL, /* 629 */ + NULL, /* 630 */ + NULL, /* 631 */ + NULL, /* 632 */ + NULL, /* 633 */ + NULL, /* 634 */ + NULL, /* 635 */ + NULL, /* 636 */ + NULL, /* 637 */ + NULL, /* 638 */ + NULL, /* 639 */ + NULL, /* 640 */ + NULL, /* 641 */ + NULL, /* 642 */ + NULL, /* 643 */ + NULL, /* 644 */ + NULL, /* 645 */ + NULL, /* 646 */ + NULL, /* 647 */ + NULL, /* 648 */ + NULL, /* 649 */ + NULL, /* 650 */ + NULL, /* 651 */ + NULL, /* 652 */ + NULL, /* 653 */ + NULL, /* 654 */ + NULL, /* 655 */ + NULL, /* 656 */ + NULL, /* 657 */ + NULL, /* 658 */ + NULL, /* 659 */ + NULL, /* 660 */ + NULL, /* 661 */ + NULL, /* 662 */ + NULL, /* 663 */ + NULL, /* 664 */ + NULL, /* 665 */ + NULL, /* 666 */ + NULL, /* 667 */ + NULL, /* 668 */ + NULL, /* 669 */ + NULL, /* 670 */ + NULL, /* 671 */ + NULL, /* 672 */ + NULL, /* 673 */ + NULL, /* 674 */ + NULL, /* 675 */ + NULL, /* 676 */ + NULL, /* 677 */ + NULL, /* 678 */ + NULL, /* 679 */ + NULL, /* 680 */ + NULL, /* 681 */ + NULL, /* 682 */ + NULL, /* 683 */ + NULL, /* 684 */ + NULL, /* 685 */ + NULL, /* 686 */ + TclUnusedStubEntry, /* 687 */ }; /* !END!: Do not edit above this line. */ Index: generic/tclStubLib.c ================================================================== --- generic/tclStubLib.c +++ generic/tclStubLib.c @@ -11,19 +11,15 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" -MODULE_SCOPE const TclStubs *tclStubsPtr; -MODULE_SCOPE const TclPlatStubs *tclPlatStubsPtr; -MODULE_SCOPE const TclIntStubs *tclIntStubsPtr; -MODULE_SCOPE const TclIntPlatStubs *tclIntPlatStubsPtr; - -const TclStubs *tclStubsPtr = NULL; -const TclPlatStubs *tclPlatStubsPtr = NULL; -const TclIntStubs *tclIntStubsPtr = NULL; -const TclIntPlatStubs *tclIntPlatStubsPtr = NULL; +TclStubs *tclStubsPtr = NULL; +TclPlatStubs *tclPlatStubsPtr = NULL; +TclIntStubs *tclIntStubsPtr = NULL; +TclIntPlatStubs *tclIntPlatStubsPtr = NULL; +TclTomMathStubs* tclTomMathStubsPtr = NULL; /* * Use our own ISDIGIT to avoid linking to libc on windows */ @@ -45,47 +41,46 @@ * Sets the stub table pointers. * *---------------------------------------------------------------------- */ #undef Tcl_InitStubs -MODULE_SCOPE const char * +CONST char * Tcl_InitStubs( Tcl_Interp *interp, - const char *version, - int exact, - int magic) + CONST char *version, + int exact) { Interp *iPtr = (Interp *) interp; - const char *actualVersion = NULL; + CONST char *actualVersion = NULL; ClientData pkgData = NULL; - const TclStubs *stubsPtr = iPtr->stubTable; + TclStubs *stubsPtr = iPtr->stubTable; /* * 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->legacyResult = "interpreter uses an incompatible stubs mechanism"; - iPtr->legacyFreeProc = 0; /* TCL_STATIC */ + if (!stubsPtr || (stubsPtr->magic != TCL_STUB_MAGIC)) { + iPtr->result = "interpreter uses an incompatible stubs mechanism"; + iPtr->freeProc = TCL_STATIC; return NULL; } actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 0, &pkgData); if (actualVersion == NULL) { return NULL; } - if (exact&1) { - const char *p = version; + if (exact) { + CONST char *p = version; int count = 0; while (*p) { count += !ISDIGIT(*p++); } if (count == 1) { - const char *q = actualVersion; + CONST char *q = actualVersion; p = version; while (*p && (*p == *q)) { p++; q++; } @@ -99,31 +94,82 @@ 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; - tclIntStubsPtr = stubsPtr->hooks->tclIntStubs; - tclIntPlatStubsPtr = stubsPtr->hooks->tclIntPlatStubs; + tclStubsPtr = (TclStubs *)pkgData; + + if (tclStubsPtr->hooks) { + tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs; + tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs; + tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs; } else { tclPlatStubsPtr = NULL; tclIntStubsPtr = NULL; tclIntPlatStubsPtr = NULL; } return actualVersion; } + +/* + *---------------------------------------------------------------------- + * + * TclTomMathInitStubs -- + * + * Initializes the Stubs table for Tcl's subset of libtommath + * + * Results: + * Returns a standard Tcl result. + * + * This procedure should not be called directly, but rather through + * the TclTomMath_InitStubs macro, to insure that the Stubs table + * matches the header files used in compilation. + * + *---------------------------------------------------------------------- + */ + +#undef TclTomMathInitializeStubs + +CONST char* +TclTomMathInitializeStubs( + Tcl_Interp* interp, /* Tcl interpreter */ + CONST char* version, /* Tcl version needed */ + int epoch, /* Stubs table epoch from the header files */ + int revision /* Stubs table revision number from the + * header files */ +) { + int exact = 0; + const char* packageName = "tcl::tommath"; + const char* errMsg = NULL; + ClientData pkgClientData = NULL; + const char* actualVersion = + tclStubsPtr->tcl_PkgRequireEx(interp, packageName, version, exact, &pkgClientData); + TclTomMathStubs* stubsPtr = (TclTomMathStubs*) pkgClientData; + if (actualVersion == NULL) { + return NULL; + } + if (pkgClientData == NULL) { + errMsg = "missing stub table pointer"; + } else if ((stubsPtr->tclBN_epoch)() != epoch) { + errMsg = "epoch number mismatch"; + } else if ((stubsPtr->tclBN_revision)() != revision) { + errMsg = "requires a later revision"; + } else { + tclTomMathStubsPtr = stubsPtr; + return actualVersion; + } + tclStubsPtr->tcl_ResetResult(interp); + tclStubsPtr->tcl_AppendResult(interp, "error loading ", packageName, + " (requested version ", version, + ", actual version ", actualVersion, + "): ", errMsg, NULL); + return NULL; +} /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclTest.c ================================================================== --- generic/tclTest.c +++ generic/tclTest.c @@ -13,38 +13,33 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#undef STATIC_BUILD -#ifndef USE_TCL_STUBS -# define USE_TCL_STUBS -#endif +#define TCL_TEST #include "tclInt.h" -#ifdef TCL_WITH_EXTERNAL_TOMMATH -# include "tommath.h" -#else -# include "tclTomMath.h" -#endif -#include "tclOO.h" + #include /* * Required for Testregexp*Cmd */ #include "tclRegexp.h" +/* + * Required for TestlocaleCmd + */ +#include + /* * 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. */ @@ -64,22 +59,10 @@ * invoked. */ struct TestAsyncHandler *nextPtr; /* Next is list of handlers. */ } TestAsyncHandler; -/* - * Start of the socket driver state structure to acces field testFlags - */ - -typedef struct TcpState TcpState; - -struct TcpState { - Tcl_Channel channel; /* Channel associated with this socket. */ - int testFlags; /* bit field for tests. Is set by testsocket - * test procedure */ -}; - TCL_DECLARE_MUTEX(asyncTestMutex) static TestAsyncHandler *firstHandler = NULL; /* @@ -133,11 +116,11 @@ /* * Event structure used in testing the event queue management procedures. */ -typedef struct { +typedef struct TestEvent { Tcl_Event header; /* Header common to all events */ Tcl_Interp *interp; /* Interpreter that will handle the event */ Tcl_Obj *command; /* Command to evaluate when the event occurs */ Tcl_Obj *tag; /* Tag for this event used to delete it */ } TestEvent; @@ -156,67 +139,90 @@ /* * Forward declarations for procedures defined later in this file: */ -static int AsyncHandlerProc(void *clientData, - Tcl_Interp *interp, int code); -#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(void *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; +int Tcltest_Init(Tcl_Interp *interp); +static int AsyncHandlerProc(ClientData clientData, + Tcl_Interp *interp, int code); +#ifdef TCL_THREADS +static Tcl_ThreadCreateType AsyncThreadProc(ClientData); +#endif +static void CleanupTestSetassocdataTests( + ClientData clientData, Tcl_Interp *interp); +static void CmdDelProc1(ClientData clientData); +static void CmdDelProc2(ClientData clientData); +static Tcl_CmdProc CmdProc1; +static Tcl_CmdProc CmdProc2; +static void CmdTraceDeleteProc( + ClientData clientData, Tcl_Interp *interp, + int level, char *command, Tcl_CmdProc *cmdProc, + ClientData cmdClientData, int argc, + char **argv); +static void CmdTraceProc(ClientData clientData, + Tcl_Interp *interp, int level, char *command, + Tcl_CmdProc *cmdProc, ClientData cmdClientData, + int argc, char **argv); +static Tcl_CmdProc CreatedCommandProc; +static Tcl_CmdProc CreatedCommandProc2; +static void DelCallbackProc(ClientData clientData, + Tcl_Interp *interp); +static Tcl_CmdProc DelCmdProc; +static void DelDeleteProc(ClientData clientData); +static void EncodingFreeProc(ClientData clientData); +static int EncodingToUtfProc(ClientData clientData, + const char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, + int dstLen, int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr); +static int EncodingFromUtfProc(ClientData clientData, + const char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, + int dstLen, int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr); +static void ExitProcEven(ClientData clientData); +static void ExitProcOdd(ClientData clientData); +static Tcl_ObjCmdProc GetTimesObjCmd; +static void MainLoop(void); +static Tcl_CmdProc NoopCmd; +static Tcl_ObjCmdProc NoopObjCmd; +static int ObjTraceProc(ClientData clientData, + Tcl_Interp *interp, int level, const char *command, + Tcl_Command commandToken, int objc, + Tcl_Obj *const objv[]); +static void ObjTraceDeleteProc(ClientData clientData); +static void PrintParse(Tcl_Interp *interp, Tcl_Parse *parsePtr); +static void SpecialFree(char *blockPtr); +static int StaticInitProc(Tcl_Interp *interp); +#undef USE_OBSOLETE_FS_HOOKS +#ifdef USE_OBSOLETE_FS_HOOKS +static Tcl_CmdProc TestaccessprocCmd; +static Tcl_CmdProc TestopenfilechannelprocCmd; +static Tcl_CmdProc TeststatprocCmd; +static int PretendTclpAccess(const char *path, int mode); +static int TestAccessProc1(const char *path, int mode); +static int TestAccessProc2(const char *path, int mode); +static int TestAccessProc3(const char *path, int mode); +static Tcl_Channel PretendTclpOpenFileChannel( + Tcl_Interp *interp, const char *fileName, + const char *modeString, int permissions); +static Tcl_Channel TestOpenFileChannelProc1( + Tcl_Interp *interp, const char *fileName, + const char *modeString, int permissions); +static Tcl_Channel TestOpenFileChannelProc2( + Tcl_Interp *interp, const char *fileName, + const char *modeString, int permissions); +static Tcl_Channel TestOpenFileChannelProc3( + Tcl_Interp *interp, const char *fileName, + const char *modeString, int permissions); +static int PretendTclpStat(const char *path, struct stat *buf); +static int TestStatProc1(const char *path, struct stat *buf); +static int TestStatProc2(const char *path, struct stat *buf); +static int TestStatProc3(const char *path, struct stat *buf); +#endif +static Tcl_CmdProc TestasyncCmd; +static Tcl_ObjCmdProc TestbytestringObjCmd; static Tcl_ObjCmdProc TeststringbytesObjCmd; static Tcl_CmdProc TestcmdinfoCmd; static Tcl_CmdProc TestcmdtokenCmd; static Tcl_CmdProc TestcmdtraceCmd; static Tcl_CmdProc TestconcatobjCmd; @@ -230,11 +236,11 @@ 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); + ClientData clientData); static Tcl_CmdProc TestexithandlerCmd; static Tcl_CmdProc TestexprlongCmd; static Tcl_ObjCmdProc TestexprlongobjCmd; static Tcl_CmdProc TestexprdoubleCmd; static Tcl_ObjCmdProc TestexprdoubleobjCmd; @@ -243,53 +249,52 @@ 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 int TestMathFunc(ClientData clientData, + Tcl_Interp *interp, Tcl_Value *args, + Tcl_Value *resultPtr); +static int TestMathFunc2(ClientData clientData, + Tcl_Interp *interp, Tcl_Value *args, + Tcl_Value *resultPtr); 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, - size_t length, int *cflagsPtr, int *eflagsPtr); + int length, int *cflagsPtr, int *eflagsPtr); static Tcl_ObjCmdProc TestsaveresultCmd; -static void TestsaveresultFree(void *blockPtr); +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_ObjCmdProc TestsizeCmd; 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; @@ -310,11 +315,11 @@ static Tcl_FSUtimeProc TestReportUtime; static Tcl_FSNormalizePathProc TestReportNormalizePath; static Tcl_FSPathInFilesystemProc TestReportInFilesystem; static Tcl_FSFreeInternalRepProc TestReportFreeInternalRep; static Tcl_FSDupInternalRepProc TestReportDupInternalRep; -static Tcl_CmdProc TestServiceModeCmd; + static Tcl_FSStatProc SimpleStat; static Tcl_FSAccessProc SimpleAccess; static Tcl_FSOpenFileChannelProc SimpleOpenFileChannel; static Tcl_FSListVolumesProc SimpleListVolumes; static Tcl_FSPathInFilesystemProc SimplePathInFilesystem; @@ -324,20 +329,15 @@ 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 = { +static Tcl_Filesystem testReportingFilesystem = { "reporting", sizeof(Tcl_Filesystem), TCL_FILESYSTEM_VERSION_1, TestReportInFilesystem, /* path in */ TestReportDupInternalRep, @@ -367,11 +367,11 @@ (Tcl_FSLoadFileProc *) TestReportLoadFile, NULL /* cwd */, TestReportChdir }; -static const Tcl_Filesystem simpleFilesystem = { +static Tcl_Filesystem simpleFilesystem = { "simple", sizeof(Tcl_Filesystem), TCL_FILESYSTEM_VERSION_1, SimplePathInFilesystem, NULL, @@ -415,10 +415,19 @@ NULL, NULL }; +/* + * External (platform specific) initialization routine, these declarations + * explicitly don't use EXTERN since this code does not get compiled into the + * library: + */ + +extern int TclplatformtestInit(Tcl_Interp *interp); +extern int TclThread_Init(Tcl_Interp *interp); + /* *---------------------------------------------------------------------- * * Tcltest_Init -- * @@ -438,31 +447,22 @@ int Tcltest_Init( Tcl_Interp *interp) /* Interpreter for application. */ { + Tcl_ValueType t3ArgTypes[2]; + Tcl_Obj **objv, *objPtr; int objc, index; static const char *const specialOptions[] = { "-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) { + if (Tcl_PkgProvide(interp, "Tcltest", TCL_PATCH_LEVEL) == TCL_ERROR) { return TCL_ERROR; } /* * Create additional commands and math functions for testing Tcl. @@ -469,12 +469,10 @@ */ 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, @@ -481,13 +479,19 @@ NULL, NULL); Tcl_CreateObjCommand(interp, "testsimplefilesystem", TestSimpleFilesystemObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testgetindexfromobjstruct", TestGetIndexFromObjStructObjCmd, NULL, NULL); +#ifdef USE_OBSOLETE_FS_HOOKS + Tcl_CreateCommand(interp, "testaccessproc", TestaccessprocCmd, NULL, + NULL); + Tcl_CreateCommand(interp, "testopenfilechannelproc", + TestopenfilechannelprocCmd, NULL, NULL); + Tcl_CreateCommand(interp, "teststatproc", TeststatprocCmd, NULL, + NULL); +#endif 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, @@ -541,50 +545,40 @@ TestHashSystemHashCmd, NULL, NULL); Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd, NULL, NULL); Tcl_CreateCommand(interp, "testgetint", TestgetintCmd, NULL, NULL); - Tcl_CreateCommand(interp, "testlongsize", TestlongsizeCmd, - NULL, NULL); Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testgetvarfullname", TestgetvarfullnameCmd, NULL, NULL); Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd, NULL, NULL); Tcl_CreateCommand(interp, "testlink", TestlinkCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testlinkarray", TestlinkarrayCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL, NULL); Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL); Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testpreferstable", TestpreferstableObjCmd, - NULL, NULL); - Tcl_CreateObjCommand(interp, "testprint", TestprintObjCmd, - NULL, NULL); Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd, NULL, NULL); - Tcl_CreateCommand(interp, "testservicemode", TestServiceModeCmd, - NULL, NULL); Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd, NULL, NULL); Tcl_CreateCommand(interp, "testseterr", TestsetCmd, - INT2PTR(TCL_LEAVE_ERR_MSG), NULL); + (ClientData) TCL_LEAVE_ERR_MSG, NULL); Tcl_CreateCommand(interp, "testset2", Testset2Cmd, - INT2PTR(TCL_LEAVE_ERR_MSG), NULL); + (ClientData) TCL_LEAVE_ERR_MSG, NULL); Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testsetobjerrorcode", TestsetobjerrorcodeCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testutfnext", @@ -597,17 +591,18 @@ TestFindFirstCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testfindlast", TestFindLastCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd, NULL, NULL); - Tcl_CreateCommand(interp, "testsocket", TestSocketCmd, - NULL, NULL); + Tcl_CreateObjCommand(interp, "testsize", TestsizeCmd, NULL, NULL); Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd, NULL, NULL); Tcl_CreateCommand(interp, "testtranslatefilename", TesttranslatefilenameCmd, NULL, NULL); Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, NULL, NULL); + Tcl_CreateMathFunc(interp, "T1", 0, NULL, TestMathFunc, (ClientData) 123); + Tcl_CreateMathFunc(interp, "T2", 0, NULL, TestMathFunc, (ClientData) 345); Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd, NULL, NULL); Tcl_CreateCommand(interp, "testexitmainloop", TestexitmainloopCmd, @@ -614,28 +609,16 @@ NULL, NULL); #if defined(HAVE_CPUID) || defined(_WIN32) Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd, NULL, NULL); #endif - Tcl_CreateObjCommand(interp, "testnreunwind", TestNREUnwind, - NULL, NULL); - Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels, - NULL, NULL); - Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolverCmd, - NULL, NULL); - Tcl_CreateObjCommand(interp, "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; - } -#if TCL_THREADS + t3ArgTypes[0] = TCL_EITHER; + t3ArgTypes[1] = TCL_EITHER; + Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2, + NULL); + +#ifdef TCL_THREADS if (TclThread_Init(interp) != TCL_OK) { return TCL_ERROR; } #endif @@ -676,39 +659,10 @@ * And finally add any platform specific test commands. */ return TclplatformtestInit(interp); } - -/* - *---------------------------------------------------------------------- - * - * Tcltest_SafeInit -- - * - * This procedure performs application-specific initialization. Most - * applications, especially those that incorporate additional packages, - * will have their own version of this procedure. - * - * Results: - * Returns a standard Tcl completion code, and leaves an error message in - * the interp's result if an error occurs. - * - * Side effects: - * Depends on the startup script. - * - *---------------------------------------------------------------------- - */ - -int -Tcltest_SafeInit( - Tcl_Interp *interp) /* Interpreter for application. */ -{ - if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { - return TCL_ERROR; - } - return Procbodytest_SafeInit(interp); -} /* *---------------------------------------------------------------------- * * TestasyncCmd -- @@ -725,18 +679,19 @@ *---------------------------------------------------------------------- */ static int TestasyncCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ 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; + (void)dummy; if (argc < 2) { wrongNumArgs: Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; @@ -743,12 +698,12 @@ } if (strcmp(argv[1], "create") == 0) { if (argc != 3) { goto wrongNumArgs; } - asyncPtr = (TestAsyncHandler *)Tcl_Alloc(sizeof(TestAsyncHandler)); - asyncPtr->command = (char *)Tcl_Alloc(strlen(argv[2]) + 1); + 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, @@ -762,12 +717,12 @@ Tcl_MutexLock(&asyncTestMutex); while (firstHandler != NULL) { asyncPtr = firstHandler; firstHandler = asyncPtr->nextPtr; Tcl_AsyncDelete(asyncPtr->handler); - Tcl_Free(asyncPtr->command); - Tcl_Free(asyncPtr); + ckfree(asyncPtr->command); + ckfree((char *)asyncPtr); } Tcl_MutexUnlock(&asyncTestMutex); return TCL_OK; } if (argc != 3) { @@ -786,12 +741,12 @@ firstHandler = asyncPtr->nextPtr; } else { prevPtr->nextPtr = asyncPtr->nextPtr; } Tcl_AsyncDelete(asyncPtr->handler); - Tcl_Free(asyncPtr->command); - Tcl_Free(asyncPtr); + ckfree(asyncPtr->command); + ckfree((char *)asyncPtr); break; } Tcl_MutexUnlock(&asyncTestMutex); } else if (strcmp(argv[1], "mark") == 0) { if (argc != 5) { @@ -810,11 +765,11 @@ } } Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], -1)); Tcl_MutexUnlock(&asyncTestMutex); return code; -#if TCL_THREADS +#ifdef TCL_THREADS } else if (strcmp(argv[1], "marklater") == 0) { if (argc != 3) { goto wrongNumArgs; } if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) { @@ -850,20 +805,19 @@ return TCL_OK; } static int AsyncHandlerProc( - void *clientData, /* If of TestAsyncHandler structure. + ClientData clientData, /* If of TestAsyncHandler structure. * in global list. */ Tcl_Interp *interp, /* Interpreter in which command was * executed, or NULL. */ int code) /* Current return code from command. */ { TestAsyncHandler *asyncPtr; int id = PTR2INT(clientData); - const char *listArgv[4]; - char *cmd; + const char *listArgv[4], *cmd; char string[TCL_INTEGER_SPACE]; Tcl_MutexLock(&asyncTestMutex); for (asyncPtr = firstHandler; asyncPtr != NULL; asyncPtr = asyncPtr->nextPtr) { @@ -878,23 +832,23 @@ return TCL_OK; } TclFormatInt(string, code); listArgv[0] = asyncPtr->command; - listArgv[1] = Tcl_GetStringResult(interp); + 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); + code = Tcl_Eval(interp, cmd); } else { /* * this should not happen, but by definition of how async handlers are * invoked, it's possible. Better error checking is needed here. */ } - Tcl_Free(cmd); + ckfree((char *)cmd); return code; } /* *---------------------------------------------------------------------- @@ -910,14 +864,14 @@ * Invokes Tcl_AsyncMark on the handler * *---------------------------------------------------------------------- */ -#if TCL_THREADS +#ifdef TCL_THREADS static Tcl_ThreadCreateType AsyncThreadProc( - void *clientData) /* Parameter is the id of a + ClientData clientData) /* Parameter is the id of a * TestAsyncHandler, defined above. */ { TestAsyncHandler *asyncPtr; int id = PTR2INT(clientData); @@ -933,27 +887,10 @@ Tcl_MutexUnlock(&asyncTestMutex); Tcl_ExitThread(TCL_OK); TCL_THREAD_CREATE_RETURN; } #endif - -static int -TestbumpinterpepochObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Interp *iPtr = (Interp *)interp; - - if (objc != 1) { - Tcl_WrongNumArgs(interp, 1, objv, ""); - return TCL_ERROR; - } - iPtr->compileEpoch++; - return TCL_OK; -} /* *---------------------------------------------------------------------- * * TestcmdinfoCmd -- @@ -968,27 +905,29 @@ * Side effects: * Creates and deletes various commands and modifies their data. * *---------------------------------------------------------------------- */ + static int TestcmdinfoCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { Tcl_CmdInfo info; + (void)dummy; if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " option cmdName\"", NULL); return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { - Tcl_CreateCommand(interp, argv[2], CmdProc1, (void *) "original", + Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original", CmdDelProc1); } else if (strcmp(argv[1], "delete") == 0) { Tcl_DStringInit(&delString); Tcl_DeleteCommand(interp, argv[2]); Tcl_DStringResult(interp, &delString); @@ -1021,15 +960,15 @@ } else { Tcl_AppendResult(interp, " stringProc", NULL); } } else if (strcmp(argv[1], "modify") == 0) { info.proc = CmdProc2; - info.clientData = (void *) "new_command_data"; + info.clientData = (ClientData) "new_command_data"; info.objProc = NULL; info.objClientData = NULL; info.deleteProc = CmdDelProc2; - info.deleteData = (void *) "new_delete_data"; + info.deleteData = (ClientData) "new_delete_data"; if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) { Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); } else { Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); } @@ -1041,42 +980,42 @@ return TCL_OK; } static int CmdProc1( - void *clientData, /* String to return. */ + ClientData clientData, /* String to return. */ Tcl_Interp *interp, /* Current interpreter. */ - TCL_UNUSED(int) /*argc*/, - TCL_UNUSED(const char **) /*argv*/) + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData, NULL); return TCL_OK; } static int CmdProc2( - void *clientData, /* String to return. */ + ClientData clientData, /* String to return. */ Tcl_Interp *interp, /* Current interpreter. */ - TCL_UNUSED(int) /*argc*/, - TCL_UNUSED(const char **) /*argv*/) + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData, NULL); return TCL_OK; } static void CmdDelProc1( - void *clientData) /* String to save. */ + ClientData clientData) /* String to save. */ { Tcl_DStringInit(&delString); Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1); Tcl_DStringAppend(&delString, (char *) clientData, -1); } static void CmdDelProc2( - void *clientData) /* String to save. */ + ClientData clientData) /* String to save. */ { Tcl_DStringInit(&delString); Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1); Tcl_DStringAppend(&delString, (char *) clientData, -1); } @@ -1095,14 +1034,15 @@ * Side effects: * Creates and deletes various commands and modifies their data. * *---------------------------------------------------------------------- */ + static int TestcmdtokenCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { Tcl_Command token; @@ -1114,13 +1054,13 @@ " option arg\"", NULL); return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { token = Tcl_CreateCommand(interp, argv[2], CmdProc1, - (void *) "original", NULL); + (ClientData) "original", NULL); sprintf(buf, "%p", (void *)token); - Tcl_AppendResult(interp, buf, NULL); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if (strcmp(argv[1], "name") == 0) { Tcl_Obj *objPtr; if (sscanf(argv[2], "%p", &l) != 1) { Tcl_AppendResult(interp, "bad command token \"", argv[2], @@ -1158,14 +1098,15 @@ * Creates and deletes a command trace, and tests the invocation of * a procedure by the command trace. * *---------------------------------------------------------------------- */ + static int TestcmdtraceCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { Tcl_DString buffer; @@ -1177,12 +1118,13 @@ return TCL_ERROR; } if (strcmp(argv[1], "tracetest") == 0) { Tcl_DStringInit(&buffer); - cmdTrace = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer); - result = Tcl_EvalEx(interp, argv[2], -1, 0); + cmdTrace = Tcl_CreateTrace(interp, 50000, + (Tcl_CmdTraceProc *) CmdTraceProc, &buffer); + result = Tcl_Eval(interp, argv[2]); if (result == TCL_OK) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); } Tcl_DeleteTrace(interp, cmdTrace); @@ -1190,21 +1132,22 @@ } else if (strcmp(argv[1], "deletetest") == 0) { /* * Create a command trace then eval a script to check whether it is * called. Note that this trace procedure removes itself as a further * check of the robustness of the trace proc calling code in - * TclNRExecuteByteCode. + * TclExecuteByteCode. */ - cmdTrace = Tcl_CreateTrace(interp, 50000, CmdTraceDeleteProc, NULL); - Tcl_EvalEx(interp, argv[2], -1, 0); + cmdTrace = Tcl_CreateTrace(interp, 50000, + (Tcl_CmdTraceProc *) CmdTraceDeleteProc, NULL); + Tcl_Eval(interp, argv[2]); } else if (strcmp(argv[1], "leveltest") == 0) { Interp *iPtr = (Interp *) interp; Tcl_DStringInit(&buffer); - cmdTrace = Tcl_CreateTrace(interp, iPtr->numLevels + 4, CmdTraceProc, - &buffer); - result = Tcl_EvalEx(interp, argv[2], -1, 0); + cmdTrace = Tcl_CreateTrace(interp, iPtr->numLevels + 4, + (Tcl_CmdTraceProc *) CmdTraceProc, &buffer); + result = Tcl_Eval(interp, argv[2]); if (result == TCL_OK) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); } Tcl_DeleteTrace(interp, cmdTrace); @@ -1217,26 +1160,28 @@ static int deleteCalled; deleteCalled = 0; cmdTrace = Tcl_CreateObjTrace(interp, 50000, TCL_ALLOW_INLINE_COMPILATION, ObjTraceProc, - &deleteCalled, ObjTraceDeleteProc); - result = Tcl_EvalEx(interp, argv[2], -1, 0); + (ClientData) &deleteCalled, ObjTraceDeleteProc); + result = Tcl_Eval(interp, argv[2]); Tcl_DeleteTrace(interp, cmdTrace); if (!deleteCalled) { - Tcl_AppendResult(interp, "Delete wasn't called", NULL); + Tcl_SetResult(interp, "Delete wasn't called", TCL_STATIC); return TCL_ERROR; } else { return result; } } else if (strcmp(argv[1], "doubletest") == 0) { Tcl_Trace t1, t2; Tcl_DStringInit(&buffer); - t1 = Tcl_CreateTrace(interp, 1, CmdTraceProc, &buffer); - t2 = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer); - result = Tcl_EvalEx(interp, argv[2], -1, 0); + t1 = Tcl_CreateTrace(interp, 1, + (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer); + t2 = Tcl_CreateTrace(interp, 50000, + (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer); + result = Tcl_Eval(interp, argv[2]); if (result == TCL_OK) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); } Tcl_DeleteTrace(interp, t2); @@ -1250,21 +1195,22 @@ return TCL_OK; } static void CmdTraceProc( - void *clientData, /* Pointer to buffer in which the + ClientData clientData, /* Pointer to buffer in which the * command and arguments are appended. * Accumulates test result. */ - TCL_UNUSED(Tcl_Interp *), - TCL_UNUSED(int) /*level*/, + Tcl_Interp *interp, /* Current interpreter. */ + int level, /* Current trace level. */ char *command, /* The command being traced (after * substitutions). */ - TCL_UNUSED(Tcl_CmdProc *) /*cmdProc*/, - TCL_UNUSED(void *), + Tcl_CmdProc *cmdProc, /* Points to command's command procedure. */ + ClientData cmdClientData, /* Client data associated with command + * procedure. */ int argc, /* Number of arguments. */ - const char *argv[]) /* Argument strings. */ + char **argv) /* Argument strings. */ { Tcl_DString *bufPtr = (Tcl_DString *) clientData; int i; Tcl_DStringAppendElement(bufPtr, command); @@ -1276,37 +1222,39 @@ Tcl_DStringEndSublist(bufPtr); } static void CmdTraceDeleteProc( - TCL_UNUSED(void *), + ClientData clientData, /* Unused. */ Tcl_Interp *interp, /* Current interpreter. */ - TCL_UNUSED(int) /*level*/, - TCL_UNUSED(char *) /*command*/, - TCL_UNUSED(Tcl_CmdProc *), - TCL_UNUSED(void *), - TCL_UNUSED(int) /*argc*/, - TCL_UNUSED(const char **) /*argv*/) + int level, /* Current trace level. */ + char *command, /* The command being traced (after + * substitutions). */ + Tcl_CmdProc *cmdProc, /* Points to command's command procedure. */ + ClientData cmdClientData, /* Client data associated with command + * procedure. */ + int argc, /* Number of arguments. */ + char **argv) /* Argument strings. */ { /* * Remove ourselves to test whether calling Tcl_DeleteTrace within a trace - * callback causes the for loop in TclNRExecuteByteCode that calls traces to + * callback causes the for loop in TclExecuteByteCode that calls traces to * reference freed memory. */ Tcl_DeleteTrace(interp, cmdTrace); } static int ObjTraceProc( - TCL_UNUSED(void *), + ClientData clientData, /* unused */ 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. */ + int level, /* Execution level */ + const char *command, /* Command being executed */ + Tcl_Command token, /* Command information */ + int objc, /* Parameter count */ + Tcl_Obj *const objv[]) /* Parameter list */ { const char *word = Tcl_GetString(objv[0]); if (!strcmp(word, "Error")) { Tcl_SetObjResult(interp, Tcl_NewStringObj(command, -1)); @@ -1324,11 +1272,11 @@ } } static void ObjTraceDeleteProc( - void *clientData) + ClientData clientData) { int *intPtr = (int *) clientData; *intPtr = 1; /* Record that the trace was deleted */ } @@ -1353,11 +1301,11 @@ *---------------------------------------------------------------------- */ static int TestcreatecommandCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { if (argc != 2) { @@ -1383,14 +1331,14 @@ return TCL_OK; } static int CreatedCommandProc( - TCL_UNUSED(void *), + ClientData clientData, /* String to return. */ Tcl_Interp *interp, /* Current interpreter. */ - TCL_UNUSED(int) /*argc*/, - TCL_UNUSED(const char **) /*argv*/) + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { Tcl_CmdInfo info; int found; found = Tcl_GetCommandInfo(interp, "test_ns_basic::createdcommand", @@ -1405,14 +1353,14 @@ return TCL_OK; } static int CreatedCommandProc2( - TCL_UNUSED(void *), + ClientData clientData, /* String to return. */ Tcl_Interp *interp, /* Current interpreter. */ - TCL_UNUSED(int) /*argc*/, - TCL_UNUSED(const char **) /*argv*/) + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { Tcl_CmdInfo info; int found; found = Tcl_GetCommandInfo(interp, "value:at:", &info); @@ -1440,14 +1388,15 @@ * Side effects: * Creates and deletes interpreters. * *---------------------------------------------------------------------- */ + static int TestdcallCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { int i, id; @@ -1458,14 +1407,14 @@ if (Tcl_GetInt(interp, argv[i], &id) != TCL_OK) { return TCL_ERROR; } if (id < 0) { Tcl_DontCallWhenDeleted(delInterp, DelCallbackProc, - INT2PTR(-id)); + (ClientData) INT2PTR(-id)); } else { Tcl_CallWhenDeleted(delInterp, DelCallbackProc, - INT2PTR(id)); + (ClientData) INT2PTR(id)); } } Tcl_DeleteInterp(delInterp); Tcl_DStringResult(interp, &delString); return TCL_OK; @@ -1475,11 +1424,11 @@ * The deletion callback used by TestdcallCmd: */ static void DelCallbackProc( - void *clientData, /* Numerical value to append to delString. */ + ClientData clientData, /* Numerical value to append to delString. */ Tcl_Interp *interp) /* Interpreter being deleted. */ { int id = PTR2INT(clientData); char buffer[TCL_INTEGER_SPACE]; @@ -1504,66 +1453,67 @@ * Side effects: * Creates a command. * *---------------------------------------------------------------------- */ + static int TestdelCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { DelCmd *dPtr; - Tcl_Interp *child; + Tcl_Interp *slave; if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args", NULL); + Tcl_SetResult(interp, "wrong # args", TCL_STATIC); return TCL_ERROR; } - child = Tcl_GetChild(interp, argv[1]); - if (child == NULL) { + slave = Tcl_GetSlave(interp, argv[1]); + if (slave == NULL) { return TCL_ERROR; } - dPtr = (DelCmd *)Tcl_Alloc(sizeof(DelCmd)); + dPtr = (DelCmd *)ckalloc(sizeof(DelCmd)); dPtr->interp = interp; - dPtr->deleteCmd = (char *)Tcl_Alloc(strlen(argv[3]) + 1); + dPtr->deleteCmd = (char *)ckalloc(strlen(argv[3]) + 1); strcpy(dPtr->deleteCmd, argv[3]); - Tcl_CreateCommand(child, argv[2], DelCmdProc, dPtr, + Tcl_CreateCommand(slave, argv[2], DelCmdProc, (ClientData) dPtr, DelDeleteProc); return TCL_OK; } static int DelCmdProc( - void *clientData, /* String result to return. */ + ClientData clientData, /* String result to return. */ Tcl_Interp *interp, /* Current interpreter. */ - TCL_UNUSED(int) /*argc*/, - TCL_UNUSED(const char **) /*argv*/) + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { DelCmd *dPtr = (DelCmd *) clientData; Tcl_AppendResult(interp, dPtr->deleteCmd, NULL); - Tcl_Free(dPtr->deleteCmd); - Tcl_Free(dPtr); + ckfree(dPtr->deleteCmd); + ckfree((char *)dPtr); return TCL_OK; } static void DelDeleteProc( - void *clientData) /* String command to evaluate. */ + ClientData clientData) /* String command to evaluate. */ { DelCmd *dPtr = (DelCmd *)clientData; - Tcl_EvalEx(dPtr->interp, dPtr->deleteCmd, -1, 0); + Tcl_Eval(dPtr->interp, dPtr->deleteCmd); Tcl_ResetResult(dPtr->interp); - Tcl_Free(dPtr->deleteCmd); - Tcl_Free(dPtr); + ckfree(dPtr->deleteCmd); + ckfree((char *)dPtr); } /* *---------------------------------------------------------------------- * @@ -1582,11 +1532,11 @@ *---------------------------------------------------------------------- */ static int TestdelassocdataCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { if (argc != 2) { @@ -1611,31 +1561,36 @@ * testdoubledigits fpval ndigits type ?shorten" * * Parameters: * fpval - Floating-point value to format. * ndigits - Digit count to request from Tcl_DoubleDigits - * type - One of 'shortest', 'e', 'f' + * type - One of 'shortest', 'Steele', 'e', 'f' * shorten - Indicates that the 'shorten' flag should be passed in. * *----------------------------------------------------------------------------- */ static int -TestdoubledigitsObjCmd( - TCL_UNUSED(void *), - Tcl_Interp* interp, /* Tcl interpreter */ - int objc, /* Parameter count */ - Tcl_Obj* const objv[]) /* Parameter vector */ +TestdoubledigitsObjCmd(ClientData unused, + /* NULL */ + Tcl_Interp* interp, + /* Tcl interpreter */ + int objc, + /* Parameter count */ + Tcl_Obj* const objv[]) + /* Parameter vector */ { static const char* options[] = { "shortest", + "Steele", "e", "f", NULL }; static const int types[] = { TCL_DD_SHORTEST, + TCL_DD_STEELE, TCL_DD_E_FORMAT, TCL_DD_F_FORMAT }; const Tcl_ObjType* doubleType; @@ -1655,12 +1610,12 @@ return TCL_ERROR; } status = Tcl_GetDoubleFromObj(interp, objv[1], &d); if (status != TCL_OK) { doubleType = Tcl_GetObjType("double"); - if (Tcl_FetchIntRep(objv[1], doubleType) - && TclIsNaN(objv[1]->internalRep.doubleValue)) { + if (objv[1]->typePtr == doubleType + || TclIsNaN(objv[1]->internalRep.doubleValue)) { status = TCL_OK; memcpy(&d, &(objv[1]->internalRep.doubleValue), sizeof(double)); } } if (status != TCL_OK @@ -1674,15 +1629,15 @@ 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; + type |= TCL_DD_SHORTEN_FLAG; } str = TclDoubleDigits(d, ndigits, type, &decpt, &signum, &endPtr); strObj = Tcl_NewStringObj(str, endPtr-str); - Tcl_Free(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); @@ -1703,23 +1658,24 @@ * Side effects: * Creates, deletes, and invokes handlers. * *---------------------------------------------------------------------- */ + static int TestdstringCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { int count; if (argc < 2) { wrongNumArgs: - Tcl_AppendResult(interp, "wrong # args", NULL); + Tcl_SetResult(interp, "wrong # args", TCL_STATIC); return TCL_ERROR; } if (strcmp(argv[1], "append") == 0) { if (argc != 4) { goto wrongNumArgs; @@ -1751,19 +1707,19 @@ } else if (strcmp(argv[1], "gresult") == 0) { if (argc != 3) { goto wrongNumArgs; } if (strcmp(argv[2], "staticsmall") == 0) { - Tcl_AppendResult(interp, "short", NULL); + Tcl_SetResult(interp, "short", TCL_STATIC); } 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); + Tcl_SetResult(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", TCL_STATIC); } else if (strcmp(argv[2], "free") == 0) { - char *s = (char *)Tcl_Alloc(100); + char *s = 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 *)Tcl_Alloc(100) + 16; + 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", @@ -1807,14 +1763,14 @@ /* * The procedure below is used as a special freeProc to test how well * Tcl_DStringGetResult handles freeProc's other than free. */ -static void SpecialFree( - void *blockPtr /* Block to free. */ -) { - Tcl_Free(((char *)blockPtr) - 16); +static void SpecialFree(blockPtr) + char *blockPtr; /* Block to free. */ +{ + ckfree(blockPtr - 16); } /* *---------------------------------------------------------------------- * @@ -1829,23 +1785,24 @@ * Side effects: * Load encodings. * *---------------------------------------------------------------------- */ + static int TestencodingObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ 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; TclEncoding *encodingPtr; - static const char *const optionStrings[] = { + static const char *optionStrings[] = { "create", "delete", NULL }; enum options { ENC_CREATE, ENC_DELETE }; @@ -1860,55 +1817,52 @@ Tcl_EncodingType type; if (objc != 5) { return TCL_ERROR; } - encodingPtr = (TclEncoding*)Tcl_Alloc(sizeof(TclEncoding)); + encodingPtr = (TclEncoding *)ckalloc(sizeof(TclEncoding)); encodingPtr->interp = interp; string = Tcl_GetStringFromObj(objv[3], &length); - encodingPtr->toUtfCmd = (char *)Tcl_Alloc(length + 1); - memcpy(encodingPtr->toUtfCmd, string, length + 1); + encodingPtr->toUtfCmd = (char *)ckalloc(length + 1); + memcpy(encodingPtr->toUtfCmd, string, (unsigned) length + 1); string = Tcl_GetStringFromObj(objv[4], &length); - encodingPtr->fromUtfCmd = (char *)Tcl_Alloc(length + 1); - memcpy(encodingPtr->fromUtfCmd, string, length + 1); + encodingPtr->fromUtfCmd = (char *)ckalloc(length + 1); + memcpy(encodingPtr->fromUtfCmd, string, (unsigned) (length + 1)); string = Tcl_GetStringFromObj(objv[2], &length); type.encodingName = string; type.toUtfProc = EncodingToUtfProc; type.fromUtfProc = EncodingFromUtfProc; type.freeProc = EncodingFreeProc; - type.clientData = encodingPtr; + type.clientData = (ClientData) encodingPtr; type.nullSize = 1; Tcl_CreateEncoding(&type); break; } case ENC_DELETE: if (objc != 3) { return TCL_ERROR; } - if (TCL_OK != Tcl_GetEncodingFromObj(interp, objv[2], &encoding)) { - return TCL_ERROR; - } - Tcl_FreeEncoding(encoding); /* Free returned reference */ - Tcl_FreeEncoding(encoding); /* Free to match CREATE */ - TclFreeIntRep(objv[2]); /* Free the cached ref */ + encoding = Tcl_GetEncoding(NULL, Tcl_GetString(objv[2])); + Tcl_FreeEncoding(encoding); + Tcl_FreeEncoding(encoding); break; } return TCL_OK; } static int EncodingToUtfProc( - void *clientData, /* TclEncoding structure. */ - TCL_UNUSED(const char *) /*src*/, + ClientData clientData, /* TclEncoding structure. */ + const char *src, /* Source string in specified encoding. */ int srcLen, /* Source string length in bytes. */ - TCL_UNUSED(int) /*flags*/, - TCL_UNUSED(Tcl_EncodingState *), + int flags, /* Conversion control flags. */ + Tcl_EncodingState *statePtr,/* Current state. */ 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. */ @@ -1915,17 +1869,17 @@ { int len; TclEncoding *encodingPtr; encodingPtr = (TclEncoding *) clientData; - Tcl_EvalEx(encodingPtr->interp, encodingPtr->toUtfCmd, -1, TCL_EVAL_GLOBAL); + Tcl_GlobalEval(encodingPtr->interp, encodingPtr->toUtfCmd); len = strlen(Tcl_GetStringResult(encodingPtr->interp)); if (len > dstLen) { len = dstLen; } - memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), len); + memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), (unsigned) len); Tcl_ResetResult(encodingPtr->interp); *srcReadPtr = srcLen; *dstWrotePtr = len; *dstCharsPtr = len; @@ -1932,15 +1886,15 @@ return TCL_OK; } static int EncodingFromUtfProc( - void *clientData, /* TclEncoding structure. */ - TCL_UNUSED(const char *) /*src*/, + ClientData clientData, /* TclEncoding structure. */ + const char *src, /* Source string in specified encoding. */ int srcLen, /* Source string length in bytes. */ - TCL_UNUSED(int) /*flags*/, - TCL_UNUSED(Tcl_EncodingState *), + int flags, /* Conversion control flags. */ + Tcl_EncodingState *statePtr,/* Current state. */ 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. */ @@ -1947,17 +1901,17 @@ { int len; TclEncoding *encodingPtr; encodingPtr = (TclEncoding *) clientData; - Tcl_EvalEx(encodingPtr->interp, encodingPtr->fromUtfCmd, -1, TCL_EVAL_GLOBAL); + Tcl_GlobalEval(encodingPtr->interp, encodingPtr->fromUtfCmd); len = strlen(Tcl_GetStringResult(encodingPtr->interp)); if (len > dstLen) { len = dstLen; } - memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), len); + memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), (unsigned) len); Tcl_ResetResult(encodingPtr->interp); *srcReadPtr = srcLen; *dstWrotePtr = len; *dstCharsPtr = len; @@ -1964,17 +1918,17 @@ return TCL_OK; } static void EncodingFreeProc( - void *clientData) /* ClientData associated with type. */ + ClientData clientData) /* ClientData associated with type. */ { TclEncoding *encodingPtr = (TclEncoding *)clientData; - Tcl_Free(encodingPtr->toUtfCmd); - Tcl_Free(encodingPtr->fromUtfCmd); - Tcl_Free(encodingPtr); + ckfree((char *)encodingPtr->toUtfCmd); + ckfree((char *)encodingPtr->fromUtfCmd); + ckfree((char *)encodingPtr); } /* *---------------------------------------------------------------------- * @@ -1992,11 +1946,11 @@ *---------------------------------------------------------------------- */ static int TestevalexObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int length, flags; @@ -2037,11 +1991,11 @@ *---------------------------------------------------------------------- */ static int TestevalobjvObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int evalGlobal; @@ -2086,20 +2040,20 @@ *---------------------------------------------------------------------- */ static int TesteventObjCmd( - TCL_UNUSED(void *), + ClientData unused, /* Not used */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const objv[]) /* Parameter vector */ { - static const char *const subcommands[] = { /* Possible subcommands */ + static const char *subcommands[] = { /* Possible subcommands */ "queue", "delete", NULL }; int subCmdIndex; /* Index of the chosen subcommand */ - static const char *const positions[] = { /* Possible queue positions */ + static const char *positions[] = { /* Possible queue positions */ "head", "tail", "mark", NULL }; int posIndex; /* Index of the chosen position */ static const Tcl_QueuePosition posNum[] = { /* Interpretation of the chosen position */ @@ -2125,11 +2079,11 @@ } if (Tcl_GetIndexFromObj(interp, objv[3], positions, "position specifier", TCL_EXACT, &posIndex) != TCL_OK) { return TCL_ERROR; } - ev = (TestEvent *)Tcl_Alloc(sizeof(TestEvent)); + ev = (TestEvent *)ckalloc(sizeof(TestEvent)); ev->header.proc = TesteventProc; ev->header.nextPtr = NULL; ev->interp = interp; ev->command = objv[4]; Tcl_IncrRefCount(ev->command); @@ -2171,11 +2125,11 @@ */ static int TesteventProc( Tcl_Event *event, /* Event to deliver */ - TCL_UNUSED(int) /*flags*/) + int flags) /* Current flags for Tcl_ServiceEvent */ { TestEvent *ev = (TestEvent *) event; Tcl_Interp *interp = ev->interp; Tcl_Obj *command = ev->command; int result = Tcl_EvalObjEx(interp, command, @@ -2183,18 +2137,18 @@ int retval; if (result != TCL_OK) { Tcl_AddErrorInfo(interp, " (command bound to \"testevent\" callback)"); - Tcl_BackgroundException(interp, TCL_ERROR); + Tcl_BackgroundError(interp); return 1; /* Avoid looping on errors */ } if (Tcl_GetBooleanFromObj(interp, Tcl_GetObjResult(interp), &retval) != TCL_OK) { Tcl_AddErrorInfo(interp, " (return value from \"testevent\" callback)"); - Tcl_BackgroundException(interp, TCL_ERROR); + Tcl_BackgroundError(interp); return 1; } if (retval) { Tcl_DecrRefCount(ev->tag); Tcl_DecrRefCount(ev->command); @@ -2222,11 +2176,11 @@ */ static int TesteventDeleteProc( Tcl_Event *event, /* Event to examine */ - void *clientData) /* Tcl_Obj containing the name of the event(s) + ClientData clientData) /* Tcl_Obj containing the name of the event(s) * to remove */ { TestEvent *ev; /* Event to examine */ const char *evNameStr; Tcl_Obj *targetName; /* Name of the event(s) to delete */ @@ -2265,11 +2219,11 @@ *---------------------------------------------------------------------- */ static int TestexithandlerCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { int value; @@ -2282,14 +2236,14 @@ if (Tcl_GetInt(interp, argv[2], &value) != TCL_OK) { return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { Tcl_CreateExitHandler((value & 1) ? ExitProcOdd : ExitProcEven, - INT2PTR(value)); + (ClientData) INT2PTR(value)); } else if (strcmp(argv[1], "delete") == 0) { Tcl_DeleteExitHandler((value & 1) ? ExitProcOdd : ExitProcEven, - INT2PTR(value)); + (ClientData) INT2PTR(value)); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": must be create or delete", NULL); return TCL_ERROR; } @@ -2296,11 +2250,11 @@ return TCL_OK; } static void ExitProcOdd( - void *clientData) /* Integer value to print. */ + ClientData clientData) /* Integer value to print. */ { char buf[16 + TCL_INTEGER_SPACE]; int len; sprintf(buf, "odd %d\n", (int)PTR2INT(clientData)); @@ -2310,11 +2264,11 @@ } } static void ExitProcEven( - void *clientData) /* Integer value to print. */ + ClientData clientData) /* Integer value to print. */ { char buf[16 + TCL_INTEGER_SPACE]; int len; sprintf(buf, "even %d\n", (int)PTR2INT(clientData)); @@ -2341,11 +2295,11 @@ *---------------------------------------------------------------------- */ static int TestexprlongCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { long exprResult; @@ -2355,11 +2309,11 @@ if (argc != 2) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], " expression\"", NULL); return TCL_ERROR; } - Tcl_AppendResult(interp, "This is a result", NULL); + Tcl_SetResult(interp, "This is a result", TCL_STATIC); result = Tcl_ExprLong(interp, argv[1], &exprResult); if (result != TCL_OK) { return result; } sprintf(buf, ": %ld", exprResult); @@ -2384,11 +2338,11 @@ *---------------------------------------------------------------------- */ static int TestexprlongobjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument objects. */ { long exprResult; @@ -2397,11 +2351,11 @@ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "expression"); return TCL_ERROR; } - Tcl_AppendResult(interp, "This is a result", NULL); + Tcl_SetResult(interp, "This is a result", TCL_STATIC); result = Tcl_ExprLongObj(interp, objv[1], &exprResult); if (result != TCL_OK) { return result; } sprintf(buf, ": %ld", exprResult); @@ -2426,11 +2380,11 @@ *---------------------------------------------------------------------- */ static int TestexprdoubleCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { double exprResult; @@ -2440,11 +2394,11 @@ if (argc != 2) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], " expression\"", NULL); return TCL_ERROR; } - Tcl_AppendResult(interp, "This is a result", NULL); + Tcl_SetResult(interp, "This is a result", TCL_STATIC); result = Tcl_ExprDouble(interp, argv[1], &exprResult); if (result != TCL_OK) { return result; } strcpy(buf, ": "); @@ -2470,11 +2424,11 @@ *---------------------------------------------------------------------- */ static int TestexprdoubleobjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument objects. */ { double exprResult; @@ -2483,11 +2437,11 @@ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "expression"); return TCL_ERROR; } - Tcl_AppendResult(interp, "This is a result", NULL); + Tcl_SetResult(interp, "This is a result", TCL_STATIC); result = Tcl_ExprDoubleObj(interp, objv[1], &exprResult); if (result != TCL_OK) { return result; } strcpy(buf, ": "); @@ -2512,11 +2466,11 @@ *---------------------------------------------------------------------- */ static int TestexprstringCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { if (argc != 2) { @@ -2544,11 +2498,11 @@ *---------------------------------------------------------------------- */ static int TestfilelinkCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { Tcl_Obj *contents; @@ -2611,11 +2565,11 @@ *---------------------------------------------------------------------- */ static int TestgetassocdataCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { char *res; @@ -2649,16 +2603,16 @@ *---------------------------------------------------------------------- */ static int TestgetplatformCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { - static const char *const platformStrings[] = { "unix", "mac", "windows" }; + static const char *platformStrings[] = { "unix", "mac", "windows" }; TclPlatformType *platform; platform = TclGetPlatform(); if (argc != 1) { @@ -2686,30 +2640,31 @@ * Side effects: * Deletes one or more interpreters. * *---------------------------------------------------------------------- */ + static int TestinterpdeleteCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { - Tcl_Interp *childToDelete; + Tcl_Interp *slaveToDelete; if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " path\"", NULL); return TCL_ERROR; } - childToDelete = Tcl_GetChild(interp, argv[1]); - if (childToDelete == NULL) { + slaveToDelete = Tcl_GetSlave(interp, argv[1]); + if (slaveToDelete == NULL) { return TCL_ERROR; } - Tcl_DeleteInterp(childToDelete); + Tcl_DeleteInterp(slaveToDelete); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -2726,32 +2681,33 @@ * Creates and deletes various variable links, plus returns * values of the linked variables. * *---------------------------------------------------------------------- */ + static int TestlinkCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ 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 Tcl_WideInt wideVar = Tcl_LongAsWide(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 Tcl_WideUInt uwideVar = (Tcl_WideUInt) Tcl_LongAsWide(123); static int created = 0; char buffer[2*TCL_DOUBLE_SPACE]; int writable, flag; Tcl_Obj *tmp; @@ -2788,115 +2744,115 @@ 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, + if (Tcl_LinkVar(interp, "int", (char *) &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, + if (Tcl_LinkVar(interp, "real", (char *) &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, + if (Tcl_LinkVar(interp, "bool", (char *) &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, + if (Tcl_LinkVar(interp, "string", (char *) &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, + if (Tcl_LinkVar(interp, "wide", (char *) &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, + if (Tcl_LinkVar(interp, "char", (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, + if (Tcl_LinkVar(interp, "uchar", (char *) &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, + if (Tcl_LinkVar(interp, "short", (char *) &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, + if (Tcl_LinkVar(interp, "ushort", (char *) &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, + if (Tcl_LinkVar(interp, "uint", (char *) &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, + if (Tcl_LinkVar(interp, "long", (char *) &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, + if (Tcl_LinkVar(interp, "ulong", (char *) &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, + if (Tcl_LinkVar(interp, "float", (char *) &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, + if (Tcl_LinkVar(interp, "uwide", (char *) &uwideVar, TCL_LINK_WIDE_UINT | flag) != TCL_OK) { return TCL_ERROR; } } else if (strcmp(argv[1], "delete") == 0) { @@ -2937,14 +2893,14 @@ Tcl_AppendElement(interp, buffer); TclFormatInt(buffer, (int) ushortVar); Tcl_AppendElement(interp, buffer); TclFormatInt(buffer, (int) uintVar); Tcl_AppendElement(interp, buffer); - tmp = Tcl_NewWideIntObj(longVar); + tmp = Tcl_NewLongObj(longVar); Tcl_AppendElement(interp, Tcl_GetString(tmp)); Tcl_DecrRefCount(tmp); - tmp = Tcl_NewWideIntObj((long)ulongVar); + tmp = Tcl_NewLongObj((long)ulongVar); Tcl_AppendElement(interp, Tcl_GetString(tmp)); Tcl_DecrRefCount(tmp); Tcl_PrintDouble(NULL, (double)floatVar, buffer); Tcl_AppendElement(interp, buffer); tmp = Tcl_NewWideIntObj((Tcl_WideInt)uwideVar); @@ -2976,16 +2932,16 @@ return TCL_ERROR; } } if (argv[5][0] != 0) { if (stringVar != NULL) { - Tcl_Free(stringVar); + ckfree(stringVar); } if (strcmp(argv[5], "-") == 0) { stringVar = NULL; } else { - stringVar = (char *)Tcl_Alloc(strlen(argv[5]) + 1); + stringVar = (char *)ckalloc(strlen(argv[5]) + 1); strcpy(stringVar, argv[5]); } } if (argv[6][0] != 0) { tmp = Tcl_NewStringObj(argv[6], -1); @@ -3083,16 +3039,16 @@ } Tcl_UpdateLinkedVar(interp, "bool"); } if (argv[5][0] != 0) { if (stringVar != NULL) { - Tcl_Free(stringVar); + ckfree(stringVar); } if (strcmp(argv[5], "-") == 0) { stringVar = NULL; } else { - stringVar = (char *)Tcl_Alloc(strlen(argv[5]) + 1); + stringVar = (char *)ckalloc(strlen(argv[5]) + 1); strcpy(stringVar, argv[5]); } Tcl_UpdateLinkedVar(interp, "string"); } if (argv[6][0] != 0) { @@ -3181,128 +3137,10 @@ } /* *---------------------------------------------------------------------- * - * TestlinkarrayCmd -- - * - * This function is invoked to process the "testlinkarray" Tcl command. - * It is used to test the 'Tcl_LinkArray' function. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Creates, deletes, and invokes variable links. - * - *---------------------------------------------------------------------- - */ - -static int -TestlinkarrayCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - static const char *LinkOption[] = { - "update", "remove", "create", NULL - }; - enum LinkOptionEnum { LINK_UPDATE, LINK_REMOVE, LINK_CREATE }; - static const char *LinkType[] = { - "char", "uchar", "short", "ushort", "int", "uint", "long", "ulong", - "wide", "uwide", "float", "double", "string", "char*", "binary", NULL - }; - /* all values after TCL_LINK_CHARS_ARRAY are used as arrays (see below) */ - static int LinkTypes[] = { - TCL_LINK_CHAR, TCL_LINK_UCHAR, - TCL_LINK_SHORT, TCL_LINK_USHORT, TCL_LINK_INT, TCL_LINK_UINT, - TCL_LINK_LONG, TCL_LINK_ULONG, TCL_LINK_WIDE_INT, TCL_LINK_WIDE_UINT, - TCL_LINK_FLOAT, TCL_LINK_DOUBLE, TCL_LINK_STRING, TCL_LINK_CHARS, - TCL_LINK_BINARY - }; - int optionIndex, typeIndex, readonly, i, size, length; - char *name, *arg; - Tcl_WideInt addr; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option args"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[1], LinkOption, "option", 0, - &optionIndex) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum LinkOptionEnum) optionIndex) { - case LINK_UPDATE: - for (i=2; itype = TCL_INT; + resultPtr->intValue = PTR2INT(clientData); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestMathFunc2 -- + * + * This is a user-defined math procedure to test out math procedures + * that do have arguments, in this case 2. + * + * Results: + * A normal Tcl completion code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + +static int +TestMathFunc2( + ClientData clientData, /* Integer value to return. */ + Tcl_Interp *interp, /* Used to report errors. */ + Tcl_Value *args, /* Points to an array of two Tcl_Value structs + * for the two arguments. */ + Tcl_Value *resultPtr) /* Where to store the result. */ +{ + int result = TCL_OK; + + /* + * Return the maximum of the two arguments with the correct type. + */ + + if (args[0].type == TCL_INT) { + int i0 = args[0].intValue; + + if (args[1].type == TCL_INT) { + int i1 = args[1].intValue; + + resultPtr->type = TCL_INT; + resultPtr->intValue = ((i0 > i1)? i0 : i1); + } else if (args[1].type == TCL_DOUBLE) { + double d0 = i0; + double d1 = args[1].doubleValue; + + resultPtr->type = TCL_DOUBLE; + resultPtr->doubleValue = ((d0 > d1)? d0 : d1); + } else if (args[1].type == TCL_WIDE_INT) { + Tcl_WideInt w0 = Tcl_LongAsWide(i0); + Tcl_WideInt w1 = args[1].wideValue; + + resultPtr->type = TCL_WIDE_INT; + resultPtr->wideValue = ((w0 > w1)? w0 : w1); + } else { + Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); + result = TCL_ERROR; + } + } else if (args[0].type == TCL_DOUBLE) { + double d0 = args[0].doubleValue; + + if (args[1].type == TCL_INT) { + double d1 = args[1].intValue; + + resultPtr->type = TCL_DOUBLE; + resultPtr->doubleValue = ((d0 > d1)? d0 : d1); + } else if (args[1].type == TCL_DOUBLE) { + double d1 = args[1].doubleValue; + + resultPtr->type = TCL_DOUBLE; + resultPtr->doubleValue = ((d0 > d1)? d0 : d1); + } else if (args[1].type == TCL_WIDE_INT) { + double d1 = Tcl_WideAsDouble(args[1].wideValue); + + resultPtr->type = TCL_DOUBLE; + resultPtr->doubleValue = ((d0 > d1)? d0 : d1); + } else { + Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); + result = TCL_ERROR; + } + } else if (args[0].type == TCL_WIDE_INT) { + Tcl_WideInt w0 = args[0].wideValue; + + if (args[1].type == TCL_INT) { + Tcl_WideInt w1 = Tcl_LongAsWide(args[1].intValue); + + resultPtr->type = TCL_WIDE_INT; + resultPtr->wideValue = ((w0 > w1)? w0 : w1); + } else if (args[1].type == TCL_DOUBLE) { + double d0 = Tcl_WideAsDouble(w0); + double d1 = args[1].doubleValue; + + resultPtr->type = TCL_DOUBLE; + resultPtr->doubleValue = ((d0 > d1)? d0 : d1); + } else if (args[1].type == TCL_WIDE_INT) { + Tcl_WideInt w1 = args[1].wideValue; + + resultPtr->type = TCL_WIDE_INT; + resultPtr->wideValue = ((w0 > w1)? w0 : w1); + } else { + Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); + result = TCL_ERROR; + } + } else { + Tcl_SetResult(interp, "T3: wrong type for arg 1", TCL_STATIC); + result = TCL_ERROR; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * * CleanupTestSetassocdataTests -- * * This function is called when an interpreter is deleted to clean * up any data left over from running the testsetassocdata command. * @@ -3376,14 +3353,14 @@ *---------------------------------------------------------------------- */ static void CleanupTestSetassocdataTests( - void *clientData, /* Data to be released. */ - TCL_UNUSED(Tcl_Interp *)) + ClientData clientData, /* Data to be released. */ + Tcl_Interp *interp) /* Interpreter being deleted. */ { - Tcl_Free(clientData); + ckfree((char *)clientData); } /* *---------------------------------------------------------------------- * @@ -3401,11 +3378,11 @@ *---------------------------------------------------------------------- */ static int TestparserObjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { const char *script; @@ -3457,11 +3434,11 @@ *---------------------------------------------------------------------- */ static int TestexprparserObjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { const char *script; @@ -3604,11 +3581,11 @@ *---------------------------------------------------------------------- */ static int TestparsevarObjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { const char *value, *name, *termPtr; @@ -3645,11 +3622,11 @@ *---------------------------------------------------------------------- */ static int TestparsevarnameObjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { const char *script; @@ -3691,80 +3668,10 @@ } /* *---------------------------------------------------------------------- * - * TestpreferstableObjCmd -- - * - * This procedure implements the "testpreferstable" command. It is - * used for being able to test the "package" command even when the - * environment variable TCL_PKG_PREFER_LATEST is set in your environment. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestpreferstableObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - TCL_UNUSED(int) /*objc*/, - TCL_UNUSED(Tcl_Obj *const *) /*objv*/) -{ - Interp *iPtr = (Interp *) interp; - - iPtr->packagePrefer = PKG_PREFER_STABLE; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestprintObjCmd -- - * - * This procedure implements the "testprint" command. It is - * used for being able to test the Tcl_ObjPrintf() function. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestprintObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* The argument objects. */ -{ - Tcl_WideInt argv1 = 0; - size_t argv2; - - if (objc < 2 || objc > 3) { - Tcl_WrongNumArgs(interp, 1, objv, "format wideint"); - } - - if (objc > 1) { - Tcl_GetWideIntFromObj(interp, objv[2], &argv1); - } - argv2 = (size_t)argv1; - Tcl_SetObjResult(interp, Tcl_ObjPrintf(Tcl_GetString(objv[1]), argv1, argv2, argv2)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * TestregexpObjCmd -- * * This procedure implements the "testregexp" command. It is used to give * a direct interface for regexp flags. It's identical to * Tcl_RegexpObjCmd except for the -xflags option, and the consequences @@ -3776,32 +3683,32 @@ * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ + static int TestregexpObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int i, indices, stringLength, match, about; - size_t ii; + 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[] = { + static const char *options[] = { "-indices", "-nocase", "-about", "-expanded", "-line", "-linestop", "-lineanchor", "-xflags", "--", NULL }; - enum optionsEnum { + enum options { REGEXP_INDICES, REGEXP_NOCASE, REGEXP_ABOUT, REGEXP_EXPANDED, REGEXP_MULTI, REGEXP_NOCROSS, REGEXP_NEWL, REGEXP_XFLAGS, REGEXP_LAST }; @@ -3822,11 +3729,11 @@ } if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } - switch ((enum optionsEnum) index) { + switch ((enum options) index) { case REGEXP_INDICES: indices = 1; break; case REGEXP_NOCASE: cflags |= REG_ICASE; @@ -3898,17 +3805,17 @@ Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); if (objc > 2 && (cflags®_EXPECT) && indices) { const char *varName; const char *value; - size_t start, end; + int start, end; char resinfo[TCL_INTEGER_SPACE * 2]; varName = Tcl_GetString(objv[2]); TclRegExpRangeUniChar(regExpr, -1, &start, &end); - sprintf(resinfo, "%d %d", (int)start, (int)(end-1)); - value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0); + sprintf(resinfo, "%d %d", start, end-1); + value = Tcl_SetVar(interp, varName, resinfo, 0); if (value == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", varName, "\"", NULL); return TCL_ERROR; } @@ -3917,12 +3824,12 @@ const char *value; char resinfo[TCL_INTEGER_SPACE * 2]; Tcl_RegExpGetInfo(regExpr, &info); varName = Tcl_GetString(objv[2]); - sprintf(resinfo, "%d", (int)info.extendStart); - value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0); + sprintf(resinfo, "%ld", info.extendStart); + value = Tcl_SetVar(interp, varName, resinfo, 0); if (value == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", varName, "\"", NULL); return TCL_ERROR; } @@ -3938,23 +3845,23 @@ objc -= 2; objv += 2; Tcl_RegExpGetInfo(regExpr, &info); for (i = 0; i < objc; i++) { - size_t start, end; + int start, end; Tcl_Obj *newPtr, *varPtr, *valuePtr; varPtr = objv[i]; - ii = ((cflags®_EXPECT) && i == objc-1) ? TCL_INDEX_NONE : (size_t)i; + ii = ((cflags®_EXPECT) && i == objc-1) ? -1 : i; if (indices) { Tcl_Obj *objs[2]; - if (ii == TCL_INDEX_NONE) { + if (ii == -1) { TclRegExpRangeUniChar(regExpr, ii, &start, &end); } else if (ii > info.nsubs) { - start = TCL_INDEX_NONE; - end = TCL_INDEX_NONE; + start = -1; + end = -1; } else { start = info.matches[ii].start; end = info.matches[ii].end; } @@ -3961,31 +3868,33 @@ /* * Adjust index so it refers to the last character in the match * instead of the first character after the match. */ - if (end != TCL_INDEX_NONE) { + if (end >= 0) { end--; } - objs[0] = Tcl_NewIntObj(start); - objs[1] = Tcl_NewIntObj(end); + objs[0] = Tcl_NewLongObj(start); + objs[1] = Tcl_NewLongObj(end); newPtr = Tcl_NewListObj(2, objs); } else { - if (ii == TCL_INDEX_NONE) { + 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); } } - valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, TCL_LEAVE_ERR_MSG); + valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, 0); if (valuePtr == NULL) { + Tcl_AppendResult(interp, "couldn't set variable \"", + Tcl_GetString(varPtr), "\"", NULL); return TCL_ERROR; } } /* @@ -4014,16 +3923,15 @@ */ static void TestregexpXflags( const char *string, /* The string of flags. */ - size_t length, /* The length of the string in bytes. */ + int length, /* The length of the string in bytes. */ int *cflagsPtr, /* compile flags word */ int *eflagsPtr) /* exec flags word */ { - size_t i; - int cflags, eflags; + int i, cflags, eflags; cflags = *cflagsPtr; eflags = *eflagsPtr; for (i = 0; i < length; i++) { switch (string[i]) { @@ -4101,17 +4009,18 @@ * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ + static int TestreturnObjCmd( - TCL_UNUSED(void *), - TCL_UNUSED(Tcl_Interp *), - TCL_UNUSED(int) /*objc*/, - TCL_UNUSED(Tcl_Obj *const *) /*objv*/) + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { return TCL_RETURN; } /* @@ -4132,11 +4041,11 @@ *---------------------------------------------------------------------- */ static int TestsetassocdataCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { char *buf, *oldData; @@ -4146,24 +4055,25 @@ Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], " data_key data_item\"", NULL); return TCL_ERROR; } - buf = (char *)Tcl_Alloc(strlen(argv[2]) + 1); + buf = 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)) { - Tcl_Free(oldData); + ckfree(oldData); } - Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests, buf); + Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests, + (ClientData) buf); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -4183,11 +4093,11 @@ *---------------------------------------------------------------------- */ static int TestsetplatformCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { size_t length; @@ -4211,10 +4121,39 @@ "unix, or windows", NULL); return TCL_ERROR; } return TCL_OK; } + +static int +TestsizeCmd( + ClientData clientData, /* Unused */ + Tcl_Interp* interp, /* Tcl interpreter */ + int objc, /* Parameter count */ + Tcl_Obj *const * objv) /* Parameter vector */ +{ + if (objc != 2) { + goto syntax; + } + if (strcmp(Tcl_GetString(objv[1]), "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; + } + if (strcmp(Tcl_GetString(objv[1]), "unichar") == 0) { + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(sizeof(Tcl_UniChar))); + return TCL_OK; + } + +syntax: + Tcl_WrongNumArgs(interp, 1, objv, "time_t|st_mtime|unichar"); + return TCL_ERROR; +} /* *---------------------------------------------------------------------- * * TeststaticpkgCmd -- @@ -4232,11 +4171,11 @@ *---------------------------------------------------------------------- */ static int TeststaticpkgCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { int safe, loaded; @@ -4250,21 +4189,21 @@ return TCL_ERROR; } if (Tcl_GetInt(interp, argv[3], &loaded) != TCL_OK) { return TCL_ERROR; } - Tcl_StaticPackage((loaded) ? interp : NULL, argv[1], - StaticInitProc, (safe) ? StaticInitProc : NULL); + Tcl_StaticPackage((loaded) ? interp : NULL, argv[1], StaticInitProc, + (safe) ? StaticInitProc : NULL); return TCL_OK; } static int StaticInitProc( Tcl_Interp *interp) /* Interpreter in which package is supposedly * being loaded. */ { - Tcl_SetVar2(interp, "x", NULL, "loaded", TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "x", "loaded", TCL_GLOBAL_ONLY); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -4283,11 +4222,11 @@ *---------------------------------------------------------------------- */ static int TesttranslatefilenameCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { Tcl_DString buffer; @@ -4321,14 +4260,15 @@ * Side effects: * Creates or modifies an "upvar" reference. * *---------------------------------------------------------------------- */ + static int TestupvarCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { int flags = 0; @@ -4343,11 +4283,11 @@ if (strcmp(argv[4], "global") == 0) { flags = TCL_GLOBAL_ONLY; } else if (strcmp(argv[4], "namespace") == 0) { flags = TCL_NAMESPACE_ONLY; } - return Tcl_UpVar2(interp, argv[1], argv[2], NULL, argv[3], flags); + return Tcl_UpVar(interp, argv[1], argv[2], argv[3], flags); } else { if (strcmp(argv[5], "global") == 0) { flags = TCL_GLOBAL_ONLY; } else if (strcmp(argv[5], "namespace") == 0) { flags = TCL_NAMESPACE_ONLY; @@ -4373,20 +4313,21 @@ * Side effects: * None. * *---------------------------------------------------------------------- */ + static int TestseterrorcodeCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ 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); + Tcl_SetResult(interp, "too many args", TCL_STATIC); return TCL_ERROR; } switch (argc) { case 1: Tcl_SetErrorCode(interp, "NONE", NULL); @@ -4425,14 +4366,15 @@ * Side effects: * None. * *---------------------------------------------------------------------- */ + static int TestsetobjerrorcodeCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ 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)); @@ -4453,14 +4395,15 @@ * Side effects: * Creates and deletes interpreters. * *---------------------------------------------------------------------- */ + static int TestfeventCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { static Tcl_Interp *interp2 = NULL; @@ -4477,11 +4420,11 @@ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " cmd script", NULL); return TCL_ERROR; } if (interp2 != NULL) { - code = Tcl_EvalEx(interp2, argv[2], -1, TCL_EVAL_GLOBAL); + code = Tcl_GlobalEval(interp2, argv[2]); Tcl_SetObjResult(interp, Tcl_GetObjResult(interp2)); return code; } else { Tcl_AppendResult(interp, "called \"testfevent code\" before \"testfevent create\"", @@ -4528,30 +4471,32 @@ *---------------------------------------------------------------------- */ static int TestpanicCmd( - TCL_UNUSED(void *), - TCL_UNUSED(Tcl_Interp *), + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { + char *argString; + /* * 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); + argString = Tcl_Merge(argc-1, argv+1); Tcl_Panic("%s", argString); - Tcl_Free(argString); + ckfree(argString); return TCL_OK; } static int TestfileCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ Tcl_Obj *const argv[]) /* The argument objects. */ { int force, i, j, result; @@ -4629,20 +4574,21 @@ *---------------------------------------------------------------------- */ static int TestgetvarfullnameCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ 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; Tcl_CallFrame *framePtr; Tcl_Var variable; + int result; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "name scope"); return TCL_ERROR; } @@ -4666,12 +4612,15 @@ namespacePtr = Tcl_FindNamespace(interp, "::test_ns_var", NULL, TCL_LEAVE_ERR_MSG); if (namespacePtr == NULL) { return TCL_ERROR; } - (void) TclPushStackFrame(interp, &framePtr, namespacePtr, + result = TclPushStackFrame(interp, &framePtr, namespacePtr, /*isProcCallFrame*/ 0); + if (result != TCL_OK) { + return result; + } } variable = Tcl_FindNamespaceVar(interp, name, NULL, (flags | TCL_LEAVE_ERR_MSG)); @@ -4703,50 +4652,52 @@ *---------------------------------------------------------------------- */ static int GetTimesObjCmd( - TCL_UNUSED(void *), + ClientData unused, /* Unused. */ Tcl_Interp *interp, /* The current interpreter. */ - TCL_UNUSED(int) /*cobjc*/, - TCL_UNUSED(Tcl_Obj *const *) /*cobjv*/) + int objc, /* Number of arguments. (not used)*/ + Tcl_Obj *const dummy[]) /* The argument objects (not used). */ { 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]; + (void)objc; + (void)dummy; /* 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 *)Tcl_Alloc(sizeof(Tcl_Obj)); - Tcl_Free(objPtr); + objPtr = (Tcl_Obj *)ckalloc(sizeof(Tcl_Obj)); + ckfree((char *)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 **)Tcl_Alloc(5000 * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **) ckalloc(5000 * sizeof(Tcl_Obj *)); Tcl_GetTime(&start); for (i = 0; i < 5000; i++) { - objv[i] = (Tcl_Obj *)Tcl_Alloc(sizeof(Tcl_Obj)); + 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++) { - Tcl_Free(objv[i]); + ckfree((char *)objv[i]); } Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); fprintf(stderr, " %.3f usec per free\n", timePer/5000); @@ -4768,11 +4719,11 @@ 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); - Tcl_Free(objv); + ckfree((char *)objv); /* TclGetString 100000 times */ fprintf(stderr, "TclGetStringFromObj of \"12345\" 100000 times\n"); objPtr = Tcl_NewStringObj("12345", -1); Tcl_GetTime(&start); @@ -4832,14 +4783,14 @@ timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); fprintf(stderr, " %.3f usec per hashtable lookup of \"gettimes\"\n", timePer/100000); /* Tcl_SetVar 100000 times */ - fprintf(stderr, "Tcl_SetVar2 of \"12345\" 100000 times\n"); + fprintf(stderr, "Tcl_SetVar of \"12345\" 100000 times\n"); Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { - s = Tcl_SetVar2(interp, "a", NULL, "12345", TCL_LEAVE_ERR_MSG); + s = Tcl_SetVar(interp, "a", "12345", TCL_LEAVE_ERR_MSG); if (s == NULL) { return TCL_ERROR; } } Tcl_GetTime(&stop); @@ -4849,11 +4800,11 @@ /* Tcl_GetVar 100000 times */ fprintf(stderr, "Tcl_GetVar of a==\"12345\" 100000 times\n"); Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { - s = Tcl_GetVar2(interp, "a", NULL, TCL_LEAVE_ERR_MSG); + s = Tcl_GetVar(interp, "a", TCL_LEAVE_ERR_MSG); if (s == NULL) { return TCL_ERROR; } } Tcl_GetTime(&stop); @@ -4882,14 +4833,14 @@ *---------------------------------------------------------------------- */ static int NoopCmd( - TCL_UNUSED(void *), - TCL_UNUSED(Tcl_Interp *), - TCL_UNUSED(int) /*argc*/, - TCL_UNUSED(const char **) /*argv*/) + ClientData unused, /* Unused. */ + Tcl_Interp *interp, /* The current interpreter. */ + int argc, /* The number of arguments. */ + const char **argv) /* The argument strings. */ { return TCL_OK; } /* @@ -4909,14 +4860,14 @@ *---------------------------------------------------------------------- */ static int NoopObjCmd( - TCL_UNUSED(void *), - TCL_UNUSED(Tcl_Interp *), - TCL_UNUSED(int) /*objc*/, - TCL_UNUSED(Tcl_Obj *const *) /*objv*/) + ClientData unused, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ { return TCL_OK; } /* @@ -4934,121 +4885,27 @@ *---------------------------------------------------------------------- */ static int TeststringbytesObjCmd( - TCL_UNUSED(void *), + ClientData dummy, Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { int n; const unsigned char *p; + (void)dummy; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "value"); return TCL_ERROR; } p = (const unsigned char *)Tcl_GetStringFromObj(objv[1], &n); Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(p, n)); return TCL_OK; } - -/* - *---------------------------------------------------------------------- - * - * TestpurebytesobjObjCmd -- - * - * This object-based procedure constructs a pure bytes object - * without type and with internal representation containing NULL's. - * - * If no argument supplied it returns empty object with tclEmptyStringRep, - * otherwise it returns this as pure bytes object with bytes value equal - * string. - * - * Results: - * Returns the TCL_OK result code. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestpurebytesobjObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* The argument objects. */ -{ - Tcl_Obj *objPtr; - - if (objc > 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?string?"); - return TCL_ERROR; - } - objPtr = Tcl_NewObj(); - /* - objPtr->internalRep.twoPtrValue.ptr1 = NULL; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - */ - memset(&objPtr->internalRep, 0, sizeof(objPtr->internalRep)); - if (objc == 2) { - const char *s = Tcl_GetString(objv[1]); - objPtr->length = objv[1]->length; - objPtr->bytes = (char *)Tcl_Alloc(objPtr->length + 1); - memcpy(objPtr->bytes, s, objPtr->length); - objPtr->bytes[objPtr->length] = 0; - } - Tcl_SetObjResult(interp, objPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestsetbytearraylengthObjCmd -- - * - * Testing command 'testsetbytearraylength` used to test the public - * interface routine Tcl_SetByteArrayLength(). - * - * Results: - * Returns the TCL_OK result code. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestsetbytearraylengthObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* The argument objects. */ -{ - int n; - Tcl_Obj *obj = NULL; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "value length"); - return TCL_ERROR; - } - if (TCL_OK != Tcl_GetIntFromObj(interp, objv[2], &n)) { - return TCL_ERROR; - } - if (Tcl_IsShared(objv[1])) { - obj = Tcl_DuplicateObj(objv[1]); - } else { - obj = objv[1]; - } - Tcl_SetByteArrayLength(obj, n); - Tcl_SetObjResult(interp, obj); - return TCL_OK; -} /* *---------------------------------------------------------------------- * * TestbytestringObjCmd -- @@ -5065,27 +4922,25 @@ *---------------------------------------------------------------------- */ static int TestbytestringObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { - size_t n = 0; + int n = 0; const char *p; + (void)dummy; 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; - } + p = (const char *)Tcl_GetByteArrayFromObj(objv[1], &n); Tcl_SetObjResult(interp, Tcl_NewStringObj(p, n)); return TCL_OK; } /* @@ -5105,28 +4960,28 @@ *---------------------------------------------------------------------- */ static int TestsetCmd( - void *data, /* Additional flags for Get/SetVar2. */ + ClientData 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) { - Tcl_AppendResult(interp, "before get", NULL); + Tcl_SetResult(interp, "before get", TCL_STATIC); value = Tcl_GetVar2(interp, argv[1], NULL, flags); if (value == NULL) { return TCL_ERROR; } Tcl_AppendElement(interp, value); return TCL_OK; } else if (argc == 3) { - Tcl_AppendResult(interp, "before set", NULL); + Tcl_SetResult(interp, "before set", TCL_STATIC); value = Tcl_SetVar2(interp, argv[1], NULL, argv[2], flags); if (value == NULL) { return TCL_ERROR; } Tcl_AppendElement(interp, value); @@ -5137,28 +4992,28 @@ return TCL_ERROR; } } static int Testset2Cmd( - void *data, /* Additional flags for Get/SetVar2. */ + ClientData 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) { - Tcl_AppendResult(interp, "before get", NULL); + Tcl_SetResult(interp, "before get", TCL_STATIC); value = Tcl_GetVar2(interp, argv[1], argv[2], flags); if (value == NULL) { return TCL_ERROR; } Tcl_AppendElement(interp, value); return TCL_OK; } else if (argc == 4) { - Tcl_AppendResult(interp, "before set", NULL); + Tcl_SetResult(interp, "before set", TCL_STATIC); value = Tcl_SetVar2(interp, argv[1], argv[2], argv[3], flags); if (value == NULL) { return TCL_ERROR; } Tcl_AppendElement(interp, value); @@ -5187,19 +5042,20 @@ *---------------------------------------------------------------------- */ static int TestsaveresultCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ 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[] = { + static const char *optionStrings[] = { "append", "dynamic", "free", "object", "small", NULL }; enum options { RESULT_APPEND, RESULT_DYNAMIC, RESULT_FREE, RESULT_OBJECT, RESULT_SMALL }; @@ -5218,21 +5074,20 @@ } if (Tcl_GetBooleanFromObj(interp, objv[3], &discard) != TCL_OK) { return TCL_ERROR; } - freeCount = 0; objPtr = NULL; /* Lint. */ switch ((enum options) index) { case RESULT_SMALL: - Tcl_AppendResult(interp, "small result", NULL); + Tcl_SetResult(interp, "small result", TCL_VOLATILE); break; case RESULT_APPEND: Tcl_AppendResult(interp, "append result", NULL); break; case RESULT_FREE: { - char *buf = (char *)Tcl_Alloc(200); + char *buf = ckalloc(200); strcpy(buf, "free result"); Tcl_SetResult(interp, buf, TCL_DYNAMIC); break; } @@ -5243,16 +5098,17 @@ objPtr = Tcl_NewStringObj("object result", -1); Tcl_SetObjResult(interp, objPtr); break; } + freeCount = 0; Tcl_SaveResult(interp, &state); if (((enum options) index) == RESULT_OBJECT) { result = Tcl_EvalObjEx(interp, objv[2], 0); } else { - result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), -1, 0); + result = Tcl_Eval(interp, Tcl_GetString(objv[2])); } if (discard) { Tcl_DiscardResult(&state); } else { @@ -5259,13 +5115,18 @@ Tcl_RestoreResult(interp, &state); result = TCL_OK; } switch ((enum options) index) { - case RESULT_DYNAMIC: - Tcl_AppendElement(interp, freeCount ? "freed" : "leak"); + case RESULT_DYNAMIC: { + int present = iPtr->freeProc == TestsaveresultFree; + int called = freeCount; + + Tcl_AppendElement(interp, called ? "called" : "notCalled"); + Tcl_AppendElement(interp, present ? "present" : "missing"); break; + } case RESULT_OBJECT: Tcl_AppendElement(interp, Tcl_GetObjResult(interp) == objPtr ? "same" : "different"); break; default: @@ -5290,14 +5151,209 @@ *---------------------------------------------------------------------- */ static void TestsaveresultFree( - TCL_UNUSED(void *)) + char *blockPtr) { freeCount++; } +#ifdef USE_OBSOLETE_FS_HOOKS + +/* + *---------------------------------------------------------------------- + * + * TeststatprocCmd -- + * + * Implements the "testTclStatProc" cmd that is used to test the + * 'TclStatInsertProc' & 'TclStatDeleteProc' C Apis. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TeststatprocCmd( + ClientData dummy, /* Not used. */ + register Tcl_Interp *interp,/* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ +{ + TclStatProc_ *proc; + int retVal; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option arg\"", NULL); + return TCL_ERROR; + } + + if (strcmp(argv[2], "TclpStat") == 0) { + proc = PretendTclpStat; + } else if (strcmp(argv[2], "TestStatProc1") == 0) { + proc = TestStatProc1; + } else if (strcmp(argv[2], "TestStatProc2") == 0) { + proc = TestStatProc2; + } else if (strcmp(argv[2], "TestStatProc3") == 0) { + proc = TestStatProc3; + } else { + Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": " + "must be TclpStat, " + "TestStatProc1, TestStatProc2, or TestStatProc3", NULL); + return TCL_ERROR; + } + + if (strcmp(argv[1], "insert") == 0) { + if (proc == PretendTclpStat) { + Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": " + "must be " + "TestStatProc1, TestStatProc2, or TestStatProc3", NULL); + return TCL_ERROR; + } + retVal = TclStatInsertProc(proc); + } else if (strcmp(argv[1], "delete") == 0) { + retVal = TclStatDeleteProc(proc); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], "\": " + "must be insert or delete", NULL); + return TCL_ERROR; + } + + if (retVal == TCL_ERROR) { + Tcl_AppendResult(interp, "\"", argv[2], "\": " + "could not be ", argv[1], "ed", NULL); + } + + return retVal; +} + +static int +PretendTclpStat( + const char *path, + struct stat *buf) +{ + int ret; + Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1); +#ifdef TCL_WIDE_INT_IS_LONG + Tcl_IncrRefCount(pathPtr); + ret = TclpObjStat(pathPtr, buf); + Tcl_DecrRefCount(pathPtr); + return ret; +#else /* TCL_WIDE_INT_IS_LONG */ + Tcl_StatBuf realBuf; + Tcl_IncrRefCount(pathPtr); + ret = TclpObjStat(pathPtr, &realBuf); + Tcl_DecrRefCount(pathPtr); + if (ret != -1) { +# define OUT_OF_RANGE(x) \ + (((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \ + ((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX)) +#if defined(__GNUC__) && __GNUC__ >= 2 +/* + * Workaround gcc warning of "comparison is always false due to limited range of + * data type" in this macro by checking max type size, and when necessary ANDing + * with the complement of ULONG_MAX instead of the comparison: + */ +# define OUT_OF_URANGE(x) \ + ((((Tcl_WideUInt)(~ (__typeof__(x)) 0)) > (Tcl_WideUInt)ULONG_MAX) && \ + (((Tcl_WideUInt)(x)) & ~(Tcl_WideUInt)ULONG_MAX)) +#else +# define OUT_OF_URANGE(x) \ + (((Tcl_WideUInt)(x)) > (Tcl_WideUInt)ULONG_MAX) +#endif + + /* + * Perform the result-buffer overflow check manually. + * + * Note that ino_t/ino64_t is unsigned... + */ + + if (OUT_OF_URANGE(realBuf.st_ino) || OUT_OF_RANGE(realBuf.st_size) +# ifdef HAVE_STRUCT_STAT_ST_BLOCKS + || OUT_OF_RANGE(realBuf.st_blocks) +# endif + ) { +# ifdef EOVERFLOW + errno = EOVERFLOW; +# else +# ifdef EFBIG + errno = EFBIG; +# else +# error "what error should be returned for a value out of range?" +# endif +# endif + return -1; + } + +# undef OUT_OF_RANGE +# undef OUT_OF_URANGE + + /* + * Copy across all supported fields, with possible type coercions on + * those fields that change between the normal and lf64 versions of + * the stat structure (on Solaris at least.) This is slow when the + * structure sizes coincide, but that's what you get for mixing + * interfaces... + */ + + buf->st_mode = realBuf.st_mode; + buf->st_ino = (ino_t) realBuf.st_ino; + buf->st_dev = realBuf.st_dev; + buf->st_rdev = realBuf.st_rdev; + buf->st_nlink = realBuf.st_nlink; + buf->st_uid = realBuf.st_uid; + buf->st_gid = realBuf.st_gid; + buf->st_size = (off_t) realBuf.st_size; + buf->st_atime = realBuf.st_atime; + buf->st_mtime = realBuf.st_mtime; + buf->st_ctime = realBuf.st_ctime; +# ifdef HAVE_STRUCT_STAT_ST_BLKSIZE + buf->st_blksize = realBuf.st_blksize; +# endif +# ifdef HAVE_STRUCT_STAT_ST_BLOCKS + buf->st_blocks = (blkcnt_t) realBuf.st_blocks; +# endif + } + return ret; +#endif /* TCL_WIDE_INT_IS_LONG */ +} + +static int +TestStatProc1( + const char *path, + struct stat *buf) +{ + memset(buf, 0, sizeof(struct stat)); + buf->st_size = 1234; + return ((strstr(path, "testStat1%.fil") == NULL) ? -1 : 0); +} + +static int +TestStatProc2( + const char *path, + struct stat *buf) +{ + memset(buf, 0, sizeof(struct stat)); + buf->st_size = 2345; + return ((strstr(path, "testStat2%.fil") == NULL) ? -1 : 0); +} + +static int +TestStatProc3( + const char *path, + struct stat *buf) +{ + memset(buf, 0, sizeof(struct stat)); + buf->st_size = 3456; + return ((strstr(path, "testStat3%.fil") == NULL) ? -1 : 0); +} +#endif /* *---------------------------------------------------------------------- * * TestmainthreadCmd -- @@ -5314,24 +5370,23 @@ *---------------------------------------------------------------------- */ static int TestmainthreadCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp,/* Current interpreter. */ + ClientData dummy, /* Not used. */ + register 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 { - Tcl_AppendResult(interp, "wrong # args", NULL); - return TCL_ERROR; - } + const char **argv) /* Argument strings. */ +{ + if (argc == 1) { + Tcl_Obj *idObj = Tcl_NewLongObj((long)(size_t)Tcl_GetCurrentThread()); + Tcl_SetObjResult(interp, idObj); + return TCL_OK; + } else { + Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + return TCL_ERROR; + } } /* *---------------------------------------------------------------------- * @@ -5375,18 +5430,18 @@ *---------------------------------------------------------------------- */ static int TestsetmainloopCmd( - TCL_UNUSED(void *), - TCL_UNUSED(Tcl_Interp *), - TCL_UNUSED(int) /*argc*/, - TCL_UNUSED(const char **) /*argv*/) -{ - exitMainLoop = 0; - Tcl_SetMainLoop(MainLoop); - return TCL_OK; + ClientData dummy, /* Not used. */ + Tcl_Interp *interp,/* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ +{ + exitMainLoop = 0; + Tcl_SetMainLoop(MainLoop); + return TCL_OK; } /* *---------------------------------------------------------------------- * @@ -5404,18 +5459,321 @@ *---------------------------------------------------------------------- */ static int TestexitmainloopCmd( - TCL_UNUSED(void *), - TCL_UNUSED(Tcl_Interp *), - TCL_UNUSED(int) /*argc*/, - TCL_UNUSED(const char **) /*argv*/) -{ - exitMainLoop = 1; - return TCL_OK; -} + ClientData dummy, /* Not used. */ + Tcl_Interp *interp,/* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ +{ + exitMainLoop = 1; + return TCL_OK; +} +#ifdef USE_OBSOLETE_FS_HOOKS + +/* + *---------------------------------------------------------------------- + * + * TestaccessprocCmd -- + * + * Implements the "testTclAccessProc" cmd that is used to test the + * 'TclAccessInsertProc' & 'TclAccessDeleteProc' C Apis. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestaccessprocCmd( + ClientData dummy, /* Not used. */ + register Tcl_Interp *interp,/* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ +{ + TclAccessProc_ *proc; + int retVal; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option arg\"", NULL); + return TCL_ERROR; + } + + if (strcmp(argv[2], "TclpAccess") == 0) { + proc = PretendTclpAccess; + } else if (strcmp(argv[2], "TestAccessProc1") == 0) { + proc = TestAccessProc1; + } else if (strcmp(argv[2], "TestAccessProc2") == 0) { + proc = TestAccessProc2; + } else if (strcmp(argv[2], "TestAccessProc3") == 0) { + proc = TestAccessProc3; + } else { + Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": " + "must be TclpAccess, " + "TestAccessProc1, TestAccessProc2, or TestAccessProc3", NULL); + return TCL_ERROR; + } + + if (strcmp(argv[1], "insert") == 0) { + if (proc == PretendTclpAccess) { + Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": must be " + "TestAccessProc1, TestAccessProc2, or TestAccessProc3" + NULL); + return TCL_ERROR; + } + retVal = TclAccessInsertProc(proc); + } else if (strcmp(argv[1], "delete") == 0) { + retVal = TclAccessDeleteProc(proc); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], "\": " + "must be insert or delete", NULL); + return TCL_ERROR; + } + + if (retVal == TCL_ERROR) { + Tcl_AppendResult(interp, "\"", argv[2], "\": " + "could not be ", argv[1], "ed", NULL); + } + + return retVal; +} + +static int +PretendTclpAccess( + const char *path, + int mode) +{ + int ret; + Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1); + Tcl_IncrRefCount(pathPtr); + ret = TclpObjAccess(pathPtr, mode); + Tcl_DecrRefCount(pathPtr); + return ret; +} + +static int +TestAccessProc1( + const char *path, + int mode) +{ + return ((strstr(path, "testAccess1%.fil") == NULL) ? -1 : 0); +} + +static int +TestAccessProc2( + const char *path, + int mode) +{ + return ((strstr(path, "testAccess2%.fil") == NULL) ? -1 : 0); +} + +static int +TestAccessProc3( + const char *path, + int mode) +{ + return ((strstr(path, "testAccess3%.fil") == NULL) ? -1 : 0); +} + +/* + *---------------------------------------------------------------------- + * + * TestopenfilechannelprocCmd -- + * + * Implements the "testTclOpenFileChannelProc" cmd that is used to test + * the 'TclOpenFileChannelInsertProc' & 'TclOpenFileChannelDeleteProc' C + * Apis. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestopenfilechannelprocCmd( + ClientData dummy, /* Not used. */ + register Tcl_Interp *interp,/* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ +{ + TclOpenFileChannelProc_ *proc; + int retVal; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option arg\"", NULL); + return TCL_ERROR; + } + + if (strcmp(argv[2], "TclpOpenFileChannel") == 0) { + proc = PretendTclpOpenFileChannel; + } else if (strcmp(argv[2], "TestOpenFileChannelProc1") == 0) { + proc = TestOpenFileChannelProc1; + } else if (strcmp(argv[2], "TestOpenFileChannelProc2") == 0) { + proc = TestOpenFileChannelProc2; + } else if (strcmp(argv[2], "TestOpenFileChannelProc3") == 0) { + proc = TestOpenFileChannelProc3; + } else { + Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": " + "must be TclpOpenFileChannel, " + "TestOpenFileChannelProc1, TestOpenFileChannelProc2, or " + "TestOpenFileChannelProc3", NULL); + return TCL_ERROR; + } + + if (strcmp(argv[1], "insert") == 0) { + if (proc == PretendTclpOpenFileChannel) { + Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": " + "must be " + "TestOpenFileChannelProc1, TestOpenFileChannelProc2, or " + "TestOpenFileChannelProc3", NULL); + return TCL_ERROR; + } + retVal = TclOpenFileChannelInsertProc(proc); + } else if (strcmp(argv[1], "delete") == 0) { + retVal = TclOpenFileChannelDeleteProc(proc); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], "\": " + "must be insert or delete", NULL); + return TCL_ERROR; + } + + if (retVal == TCL_ERROR) { + Tcl_AppendResult(interp, "\"", argv[2], "\": " + "could not be ", argv[1], "ed", NULL); + } + + return retVal; +} + +static Tcl_Channel +PretendTclpOpenFileChannel( + Tcl_Interp *interp, /* Interpreter for error reporting; can be + * NULL. */ + const char *fileName, /* Name of file to open. */ + const char *modeString, /* A list of POSIX open modes or + * a string such as "rw". */ + int permissions) /* If the open involves creating a file, with + * what modes to create it? */ +{ + Tcl_Channel ret; + int mode, seekFlag; + Tcl_Obj *pathPtr; + mode = TclGetOpenMode(interp, modeString, &seekFlag); + if (mode == -1) { + return NULL; + } + pathPtr = Tcl_NewStringObj(fileName, -1); + Tcl_IncrRefCount(pathPtr); + ret = TclpOpenFileChannel(interp, pathPtr, mode, permissions); + Tcl_DecrRefCount(pathPtr); + if (ret != NULL) { + if (seekFlag) { + if (Tcl_Seek(ret, (Tcl_WideInt)0, SEEK_END) < (Tcl_WideInt)0) { + if (interp != NULL) { + Tcl_AppendResult(interp, + "could not seek to end of file while opening \"", + fileName, "\": ", Tcl_PosixError(interp), NULL); + } + Tcl_Close(NULL, ret); + return NULL; + } + } + } + return ret; +} + +static Tcl_Channel +TestOpenFileChannelProc1( + Tcl_Interp *interp, /* Interpreter for error reporting; can be + * NULL. */ + const char *fileName, /* Name of file to open. */ + const char *modeString, /* A list of POSIX open modes or + * a string such as "rw". */ + int permissions) /* If the open involves creating a file, with + * what modes to create it? */ +{ + const char *expectname = "testOpenFileChannel1%.fil"; + Tcl_DString ds; + + Tcl_DStringInit(&ds); + Tcl_JoinPath(1, &expectname, &ds); + + if (!strcmp(Tcl_DStringValue(&ds), fileName)) { + Tcl_DStringFree(&ds); + return (PretendTclpOpenFileChannel(interp, + "__testOpenFileChannel1%__.fil", + modeString, permissions)); + } else { + Tcl_DStringFree(&ds); + return NULL; + } +} + +static Tcl_Channel +TestOpenFileChannelProc2( + Tcl_Interp *interp, /* Interpreter for error reporting; can be + * NULL. */ + const char *fileName, /* Name of file to open. */ + const char *modeString, /* A list of POSIX open modes or + * a string such as "rw". */ + int permissions) /* If the open involves creating a file, with + * what modes to create it? */ +{ + const char *expectname = "testOpenFileChannel2%.fil"; + Tcl_DString ds; + + Tcl_DStringInit(&ds); + Tcl_JoinPath(1, &expectname, &ds); + + if (!strcmp(Tcl_DStringValue(&ds), fileName)) { + Tcl_DStringFree(&ds); + return (PretendTclpOpenFileChannel(interp, + "__testOpenFileChannel2%__.fil", + modeString, permissions)); + } else { + Tcl_DStringFree(&ds); + return (NULL); + } +} + +static Tcl_Channel +TestOpenFileChannelProc3( + Tcl_Interp *interp, /* Interpreter for error reporting; can be + * NULL. */ + const char *fileName, /* Name of file to open. */ + const char *modeString, /* A list of POSIX open modes or a string such + * as "rw". */ + int permissions) /* If the open involves creating a file, with + * what modes to create it? */ +{ + const char *expectname = "testOpenFileChannel3%.fil"; + Tcl_DString ds; + + Tcl_DStringInit(&ds); + Tcl_JoinPath(1, &expectname, &ds); + + if (!strcmp(Tcl_DStringValue(&ds), fileName)) { + Tcl_DStringFree(&ds); + return (PretendTclpOpenFileChannel(interp, "__testOpenFileChannel3%__.fil", + modeString, permissions)); + } else { + Tcl_DStringFree(&ds); + return (NULL); + } +} +#endif /* *---------------------------------------------------------------------- * * TestChannelCmd -- @@ -5429,14 +5787,15 @@ * Side effects: * None. * *---------------------------------------------------------------------- */ + static int TestChannelCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Interpreter for result. */ int argc, /* Count of additional args. */ const char **argv) /* Additional arg strings. */ { const char *cmdName; /* Sub command. */ @@ -5476,11 +5835,11 @@ if (strcmp(argv[2], Tcl_GetChannelName(curPtr->chan)) == 0) { *nextPtrPtr = curPtr->nextPtr; curPtr->nextPtr = NULL; chan = curPtr->chan; - Tcl_Free(curPtr); + ckfree((char *)curPtr); break; } } } else { chan = Tcl_GetChannel(interp, argv[2], &mode); @@ -5545,11 +5904,11 @@ Tcl_CutChannel(chan); /* Remember the channel in the pool of detached channels */ - det = (TestChannel *)Tcl_Alloc(sizeof(TestChannel)); + det = (TestChannel *)ckalloc(sizeof(TestChannel)); det->chan = chan; det->nextPtr = firstDetached; firstDetached = det; return TCL_OK; @@ -5896,14 +6255,15 @@ * Side effects: * Creates, deletes and returns channel event handlers. * *---------------------------------------------------------------------- */ + static int TestChannelEventCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { Tcl_Obj *resultListPtr; @@ -5924,11 +6284,11 @@ } statePtr = chanPtr->state; cmd = argv[2]; len = strlen(cmd); - if ((cmd[0] == 'a') && (strncmp(cmd, "add", len) == 0)) { + if ((cmd[0] == 'a') && (strncmp(cmd, "add", (unsigned) len) == 0)) { if (argc != 5) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " channelName add eventSpec script\"", NULL); return TCL_ERROR; } @@ -5942,11 +6302,12 @@ Tcl_AppendResult(interp, "bad event name \"", argv[3], "\": must be readable, writable, or none", NULL); return TCL_ERROR; } - esPtr = (EventScriptRecord *)Tcl_Alloc(sizeof(EventScriptRecord)); + esPtr = (EventScriptRecord *) ckalloc((unsigned) + sizeof(EventScriptRecord)); esPtr->nextPtr = statePtr->scriptRecordPtr; statePtr->scriptRecordPtr = esPtr; esPtr->chanPtr = chanPtr; esPtr->interp = interp; @@ -5953,16 +6314,16 @@ esPtr->mask = mask; esPtr->scriptPtr = Tcl_NewStringObj(argv[4], -1); Tcl_IncrRefCount(esPtr->scriptPtr); Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, - TclChannelEventScriptInvoker, esPtr); + TclChannelEventScriptInvoker, (ClientData) esPtr); return TCL_OK; } - if ((cmd[0] == 'd') && (strncmp(cmd, "delete", len) == 0)) { + if ((cmd[0] == 'd') && (strncmp(cmd, "delete", (unsigned) len) == 0)) { if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " channelName delete index\"", NULL); return TCL_ERROR; } @@ -5997,18 +6358,18 @@ Tcl_Panic("TestChannelEventCmd: damaged event script list"); } prevEsPtr->nextPtr = esPtr->nextPtr; } Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, - TclChannelEventScriptInvoker, esPtr); + TclChannelEventScriptInvoker, (ClientData) esPtr); Tcl_DecrRefCount(esPtr->scriptPtr); - Tcl_Free(esPtr); + ckfree((char *)esPtr); return TCL_OK; } - if ((cmd[0] == 'l') && (strncmp(cmd, "list", len) == 0)) { + if ((cmd[0] == 'l') && (strncmp(cmd, "list", (unsigned) len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " channelName list\"", NULL); return TCL_ERROR; } @@ -6027,11 +6388,11 @@ } Tcl_SetObjResult(interp, resultListPtr); return TCL_OK; } - if ((cmd[0] == 'r') && (strncmp(cmd, "removeall", len) == 0)) { + if ((cmd[0] == 'r') && (strncmp(cmd, "removeall", (unsigned) len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " channelName removeall\"", NULL); return TCL_ERROR; } @@ -6038,19 +6399,19 @@ for (esPtr = statePtr->scriptRecordPtr; esPtr != NULL; esPtr = nextEsPtr) { nextEsPtr = esPtr->nextPtr; Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, - TclChannelEventScriptInvoker, esPtr); + TclChannelEventScriptInvoker, (ClientData) esPtr); Tcl_DecrRefCount(esPtr->scriptPtr); - Tcl_Free(esPtr); + ckfree((char *)esPtr); } statePtr->scriptRecordPtr = NULL; return TCL_OK; } - if ((cmd[0] == 's') && (strncmp(cmd, "set", len) == 0)) { + if ((cmd[0] == 's') && (strncmp(cmd, "set", (unsigned) len) == 0)) { if (argc != 5) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " channelName delete index event\"", NULL); return TCL_ERROR; } @@ -6084,134 +6445,18 @@ "\": must be readable, writable, or none", NULL); return TCL_ERROR; } esPtr->mask = mask; Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, - TclChannelEventScriptInvoker, esPtr); + TclChannelEventScriptInvoker, (ClientData) esPtr); return TCL_OK; } Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of " "add, delete, list, set, or removeall", NULL); return TCL_ERROR; } -/* - *---------------------------------------------------------------------- - * - * TestSocketCmd -- - * - * Implements the Tcl "testsocket" debugging command and its - * subcommands. This is part of the testing environment. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestSocketCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Interpreter for result. */ - int argc, /* Count of additional args. */ - const char **argv) /* Additional arg strings. */ -{ - const char *cmdName; /* Sub command. */ - size_t len; /* Length of subcommand string. */ - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " subcommand ?additional args..?\"", NULL); - return TCL_ERROR; - } - cmdName = argv[1]; - len = strlen(cmdName); - - if ((cmdName[0] == 't') && (strncmp(cmdName, "testflags", len) == 0)) { - Tcl_Channel hChannel; - int modePtr; - TcpState *statePtr; - /* Set test value in the socket driver - */ - /* Check for argument "channel name" - */ - if (argc < 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " testflags channel flags\"", NULL); - return TCL_ERROR; - } - hChannel = Tcl_GetChannel(interp, argv[2], &modePtr); - if ( NULL == hChannel ) { - Tcl_AppendResult(interp, "unknown channel:", argv[2], NULL); - return TCL_ERROR; - } - statePtr = (TcpState *)Tcl_GetChannelInstanceData(hChannel); - if ( NULL == statePtr) { - Tcl_AppendResult(interp, "No channel instance data:", argv[2], - NULL); - return TCL_ERROR; - } - statePtr->testFlags = atoi(argv[3]); - return TCL_OK; - } - - Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be " - "testflags", NULL); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * TestServiceModeCmd -- - * - * This procedure implements the "testservicemode" command which gets or - * sets the current Tcl ServiceMode. There are several tests which open - * a file and assign various handlers to it. For these tests to be - * deterministic it is important that file events not be processed until - * all of the handlers are in place. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * May change the ServiceMode setting. - * - *---------------------------------------------------------------------- - */ - -static int -TestServiceModeCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - const char **argv) /* Argument strings. */ -{ - int newmode, oldmode; - if (argc > 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ?newmode?\"", NULL); - return TCL_ERROR; - } - oldmode = (Tcl_GetServiceMode() != TCL_SERVICE_NONE); - if (argc == 2) { - if (Tcl_GetInt(interp, argv[1], &newmode) == TCL_ERROR) { - return TCL_ERROR; - } - if (newmode == 0) { - Tcl_SetServiceMode(TCL_SERVICE_NONE); - } else { - Tcl_SetServiceMode(TCL_SERVICE_ALL); - } - } - Tcl_SetObjResult(interp, Tcl_NewIntObj(oldmode)); - return TCL_OK; -} - /* *---------------------------------------------------------------------- * * TestWrongNumArgsObjCmd -- * @@ -6226,11 +6471,11 @@ *---------------------------------------------------------------------- */ static int TestWrongNumArgsObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int i, length; @@ -6239,11 +6484,11 @@ if (objc < 3) { /* * Don't use Tcl_WrongNumArgs here, as that is the function * we want to test! */ - Tcl_AppendResult(interp, "insufficient arguments", NULL); + Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, objv[1], &i) != TCL_OK) { return TCL_ERROR; @@ -6256,11 +6501,11 @@ if (i > objc - 3) { /* * Asked for more arguments than were given. */ - Tcl_AppendResult(interp, "insufficient arguments", NULL); + Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC); return TCL_ERROR; } Tcl_WrongNumArgs(interp, i, &(objv[3]), msg); return TCL_OK; @@ -6282,11 +6527,11 @@ *---------------------------------------------------------------------- */ static int TestGetIndexFromObjStructObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *const ary[] = { @@ -6336,11 +6581,11 @@ *---------------------------------------------------------------------- */ static int TestFilesystemObjCmd( - TCL_UNUSED(void *), + ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { int res, boolVal; @@ -6352,11 +6597,11 @@ } if (Tcl_GetBooleanFromObj(interp, objv[1], &boolVal) != TCL_OK) { return TCL_ERROR; } if (boolVal) { - res = Tcl_FSRegister(interp, &testReportingFilesystem); + res = Tcl_FSRegister((ClientData)interp, &testReportingFilesystem); msg = (res == TCL_OK) ? "registered" : "failed"; } else { res = Tcl_FSUnregister(&testReportingFilesystem); msg = (res == TCL_OK) ? "unregistered" : "failed"; } @@ -6365,11 +6610,11 @@ } static int TestReportInFilesystem( Tcl_Obj *pathPtr, - void **clientDataPtr) + ClientData *clientDataPtr) { static Tcl_Obj *lastPathPtr = NULL; Tcl_Obj *newPathPtr; if (pathPtr == lastPathPtr) { @@ -6387,11 +6632,11 @@ Tcl_DecrRefCount(newPathPtr); lastPathPtr = NULL; return -1; } lastPathPtr = NULL; - *clientDataPtr = newPathPtr; + *clientDataPtr = (ClientData) newPathPtr; return TCL_OK; } /* * Simple helper function to extract the native vfs representation of a path @@ -6405,23 +6650,23 @@ return (Tcl_Obj*) Tcl_FSGetInternalRep(pathPtr, &testReportingFilesystem); } static void TestReportFreeInternalRep( - void *clientData) + ClientData clientData) { Tcl_Obj *nativeRep = (Tcl_Obj *) clientData; if (nativeRep != NULL) { /* Free the path */ Tcl_DecrRefCount(nativeRep); } } -static void * +static ClientData TestReportDupInternalRep( - void *clientData) + ClientData clientData) { Tcl_Obj *original = (Tcl_Obj *) clientData; Tcl_IncrRefCount(original); return clientData; @@ -6436,11 +6681,16 @@ 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; + /* + * No idea why I decided to program this up using the old string-based + * API, but there you go. We should convert it to objects. + */ + + Tcl_SavedResult savedResult; Tcl_DString ds; Tcl_DStringInit(&ds); Tcl_DStringAppend(&ds, "lappend filesystemReport ", -1); Tcl_DStringStartSublist(&ds); @@ -6450,19 +6700,15 @@ } if (arg2 != NULL) { Tcl_DStringAppendElement(&ds, Tcl_GetString(arg2)); } Tcl_DStringEndSublist(&ds); - savedResult = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(savedResult); - Tcl_SetObjResult(interp, Tcl_NewObj()); - Tcl_EvalEx(interp, Tcl_DStringValue(&ds), -1, 0); + Tcl_SaveResult(interp, &savedResult); + Tcl_Eval(interp, Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); - Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, savedResult); - Tcl_DecrRefCount(savedResult); - } + Tcl_RestoreResult(interp, &savedResult); + } } static int TestReportStat( Tcl_Obj *path, /* Path of file to stat (in current CP). */ @@ -6623,11 +6869,11 @@ TestReport("removedirectory", path, NULL); return Tcl_FSRemoveDirectory(TestReportGetNativePath(path), recursive, errorPtr); } -static const char *const * +static const char ** TestReportFileAttrStrings( Tcl_Obj *fileName, Tcl_Obj **objPtrRef) { TestReport("fileattributestrings", fileName, NULL); @@ -6667,11 +6913,11 @@ return Tcl_FSUtime(TestReportGetNativePath(fileName), tval); } static int TestReportNormalizePath( - TCL_UNUSED(Tcl_Interp *), + Tcl_Interp *interp, Tcl_Obj *pathPtr, int nextCheckpoint) { TestReport("normalizepath", pathPtr, NULL); return nextCheckpoint; @@ -6678,11 +6924,11 @@ } static int SimplePathInFilesystem( Tcl_Obj *pathPtr, - TCL_UNUSED(void **)) + ClientData *clientDataPtr) { const char *str = Tcl_GetString(pathPtr); if (strncmp(str, "simplefs:/", 10)) { return -1; @@ -6707,11 +6953,11 @@ * important features. */ static int TestSimpleFilesystemObjCmd( - TCL_UNUSED(void *), + ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { int res, boolVal; @@ -6723,11 +6969,11 @@ } if (Tcl_GetBooleanFromObj(interp, objv[1], &boolVal) != TCL_OK) { return TCL_ERROR; } if (boolVal) { - res = Tcl_FSRegister(interp, &simpleFilesystem); + res = Tcl_FSRegister((ClientData)interp, &simpleFilesystem); msg = (res == TCL_OK) ? "registered" : "failed"; } else { res = Tcl_FSUnregister(&simpleFilesystem); msg = (res == TCL_OK) ? "unregistered" : "failed"; } @@ -6869,55 +7115,81 @@ * Usage: testutfnext -bytestring $bytes */ static int TestUtfNextCmd( - TCL_UNUSED(void *), + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - size_t numBytes; + int numBytes; /* Number of bytes supplied in the test string */ + int offset; /* Number of bytes we are permitted to read */ 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"); + if (objc < 2 || objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "string ?numBytes?"); return TCL_ERROR; } - bytes = Tcl_GetString(objv[1]); - numBytes = objv[1]->length; + + bytes = Tcl_GetStringFromObj(objv[1], &numBytes); + + offset = numBytes +TCL_UTF_MAX -1; /* If no constraint is given, allow + * the terminating NUL to limit + * operations. */ + + if (objc == 3) { + if (TCL_OK != TclGetIntForIndex(interp, objv[2], numBytes, &offset)) { + return TCL_ERROR; + } + if (offset < 0) { + offset = 0; + } + if (offset > numBytes +TCL_UTF_MAX -1) { + offset = numBytes +TCL_UTF_MAX -1; + } + } - if (numBytes > (int)sizeof(buffer) - 4) { + if (numBytes > (int)sizeof(buffer) - 3) { 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); + if (!Tcl_UtfCharComplete(buffer + 1, offset)) { + /* Cannot scan a complete sequence from the data */ + + Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + return TCL_OK; + } + + first = result = TclUtfNext(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); + result = TclUtfNext(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); + result = TclUtfNext(buffer + 1); if (first != result) { - first = buffer; - break; + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "Tcl_UtfNext is not supposed to read src[end]\n" + "Different result when src[end] is %#x", UCHAR(p[-1]))); + return TCL_ERROR; } } Tcl_SetObjResult(interp, Tcl_NewIntObj(first - buffer - 1)); @@ -6929,71 +7201,69 @@ * Usage: testutfprev $bytes $offset */ static int TestUtfPrevCmd( - TCL_UNUSED(void *), + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - size_t numBytes, offset; + 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_GetString(objv[1]); - numBytes = objv[1]->length; + bytes = Tcl_GetStringFromObj(objv[1], &numBytes); if (objc == 3) { - if (TCL_OK != Tcl_GetIntForIndex(interp, objv[2], numBytes, &offset)) { + if (TCL_OK != TclGetIntForIndex(interp, objv[2], numBytes, &offset)) { return TCL_ERROR; } - if (offset == TCL_INDEX_NONE) { + if (offset < 0) { offset = 0; } if (offset > numBytes) { offset = numBytes; } } else { offset = numBytes; } result = TclUtfPrev(bytes + offset, bytes); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result - bytes)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(result - bytes)); return TCL_OK; } /* * Used to check correct string-length determining in Tcl_NumUtfChars */ static int TestNumUtfCharsCmd( - TCL_UNUSED(void *), + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { if (objc > 1) { - size_t len, limit = TCL_INDEX_NONE; - const char *bytes = Tcl_GetString(objv[1]); - size_t numBytes = objv[1]->length; + 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) { + if (TclGetIntForIndex(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_NewWideIntObj(len)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(len)); } return TCL_OK; } /* @@ -7000,11 +7270,11 @@ * Used to check correct operation of Tcl_UtfFindFirst */ static int TestFindFirstCmd( - TCL_UNUSED(void *), + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { if (objc > 1) { @@ -7022,11 +7292,11 @@ * Used to check correct operation of Tcl_UtfFindLast */ static int TestFindLastCmd( - TCL_UNUSED(void *), + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { if (objc > 1) { @@ -7064,34 +7334,34 @@ *---------------------------------------------------------------------- */ static int TestcpuidCmd( - TCL_UNUSED(void *), + ClientData dummy, Tcl_Interp* interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const * objv) /* Parameter vector */ { int status, index, i; - int regs[4]; + unsigned int regs[4]; Tcl_Obj *regsObjs[4]; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "eax"); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, objv[1], &index) != TCL_OK) { return TCL_ERROR; } - status = TclWinCPUID(index, regs); + status = TclWinCPUID((unsigned) index, regs); if (status != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewStringObj("operation not available", -1)); return status; } for (i=0 ; i<4 ; ++i) { - regsObjs[i] = Tcl_NewIntObj(regs[i]); + regsObjs[i] = Tcl_NewIntObj((int) regs[i]); } Tcl_SetObjResult(interp, Tcl_NewListObj(4, regsObjs)); return TCL_OK; } #endif @@ -7100,22 +7370,23 @@ * Used to do basic checks of the TCL_HASH_KEY_SYSTEM_HASH flag */ static int TestHashSystemHashCmd( - TCL_UNUSED(void *), + ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - static const Tcl_HashKeyType hkType = { + static Tcl_HashKeyType hkType = { TCL_HASH_KEY_TYPE_VERSION, TCL_HASH_KEY_SYSTEM_HASH, NULL, NULL, NULL, NULL }; Tcl_HashTable hash; Tcl_HashEntry *hPtr; int i, isNew, limit = 100; + (void)dummy; if (objc>1 && Tcl_GetIntFromObj(interp, objv[1], &limit)!=TCL_OK) { return TCL_ERROR; } @@ -7136,11 +7407,11 @@ return TCL_ERROR; } Tcl_SetHashValue(hPtr, INT2PTR(i+42)); } - if (hash.numEntries != (size_t)limit) { + if (hash.numEntries != limit) { Tcl_AppendResult(interp, "unexpected maximal size", NULL); Tcl_DeleteHashTable(&hash); return TCL_ERROR; } @@ -7176,17 +7447,19 @@ * Used for testing Tcl_GetInt which is no longer used directly by the * core very much. */ static int TestgetintCmd( - TCL_UNUSED(void *), + ClientData dummy, Tcl_Interp *interp, int argc, const char **argv) { + (void)dummy; + if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args", NULL); + Tcl_SetResult(interp, "wrong # args", TCL_STATIC); return TCL_ERROR; } else { int val, i, total=0; for (i=1 ; iexecEnvPtr->callbackPtr; - - if (refDepth == NULL) { - refDepth = &depth; - } - - depth = (refDepth - &depth); - - levels[0] = Tcl_NewIntObj(depth); - levels[1] = Tcl_NewIntObj(iPtr->numLevels); - levels[2] = Tcl_NewIntObj(iPtr->cmdFramePtr->level); - levels[3] = Tcl_NewIntObj(iPtr->varFramePtr->level); - levels[4] = Tcl_NewIntObj(iPtr->execEnvPtr->execStackPtr->tosPtr - - iPtr->execEnvPtr->execStackPtr->stackWords); - - while (cbPtr) { - i++; - cbPtr = cbPtr->nextPtr; - } - levels[5] = Tcl_NewIntObj(i); - - Tcl_SetObjResult(interp, Tcl_NewListObj(6, levels)); - return TCL_OK; -} /* *---------------------------------------------------------------------- * * TestconcatobjCmd -- @@ -7319,14 +7492,14 @@ *---------------------------------------------------------------------- */ static int TestconcatobjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - TCL_UNUSED(int) /*argc*/, - TCL_UNUSED(const char **) /*argv*/) + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { Tcl_Obj *list1Ptr, *list2Ptr, *emptyPtr, *concatPtr, *tmpPtr; int result = TCL_OK, len; Tcl_Obj *objv[3]; @@ -7340,15 +7513,21 @@ emptyPtr = Tcl_NewObj(); list1Ptr = Tcl_NewStringObj("foo bar sum", -1); Tcl_ListObjLength(NULL, list1Ptr, &len); - Tcl_InvalidateStringRep(list1Ptr); + if (list1Ptr->bytes != NULL) { + ckfree((char *)list1Ptr->bytes); + list1Ptr->bytes = NULL; + } list2Ptr = Tcl_NewStringObj("eeny meeny", -1); Tcl_ListObjLength(NULL, list2Ptr, &len); - Tcl_InvalidateStringRep(list2Ptr); + if (list2Ptr->bytes != NULL) { + ckfree((char *)list2Ptr->bytes); + list2Ptr->bytes = NULL; + } /* * Verify that concat'ing a list obj with one or more empty strings does * return a fresh Tcl_Obj (see also [Bug 2055782]). */ @@ -7488,10 +7667,12 @@ result = TCL_ERROR; Tcl_AppendResult(interp, "\n\t* (e) concatObj does not have refCount 0", NULL); } if (concatPtr == tmpPtr) { + int len; + result = TCL_ERROR; Tcl_AppendResult(interp, "\n\t* (e) concatObj is not a new obj ", NULL); (void) Tcl_ListObjLength(NULL, concatPtr, &len); @@ -7518,10 +7699,12 @@ result = TCL_ERROR; Tcl_AppendResult(interp, "\n\t* (f) concatObj does not have refCount 0", NULL); } if (concatPtr == tmpPtr) { + int len; + result = TCL_ERROR; Tcl_AppendResult(interp, "\n\t* (f) concatObj is not a new obj ", NULL); (void) Tcl_ListObjLength(NULL, concatPtr, &len); @@ -7549,10 +7732,12 @@ result = TCL_ERROR; Tcl_AppendResult(interp, "\n\t* (g) concatObj does not have refCount 0", NULL); } if (concatPtr == tmpPtr) { + int len; + result = TCL_ERROR; Tcl_AppendResult(interp, "\n\t* (g) concatObj is not a new obj ", NULL); (void) Tcl_ListObjLength(NULL, concatPtr, &len); @@ -7589,376 +7774,10 @@ if (result == TCL_OK) { Tcl_ResetResult(interp); } 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(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const *objv) /* Argument strings. */ -{ - if (objc != 1) { - Tcl_WrongNumArgs(interp, 1, objv, ""); - return TCL_ERROR; - } - - 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(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const *objv) /* Argument strings. */ -{ - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "defaultDir"); - return TCL_ERROR; - } - - 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(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Arguments. */ -{ - static int foo = 0; - int count = objc; - Tcl_Obj **remObjv, *result[3]; - 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)); - Tcl_Free(remObjv); - return TCL_OK; -} - -/** - * Test harness for command and variable resolvers. - */ - -static int -InterpCmdResolver( - Tcl_Interp *interp, - const char *name, - TCL_UNUSED(Tcl_Namespace *), - TCL_UNUSED(int) /*flags*/, - Tcl_Command *rPtr) -{ - Interp *iPtr = (Interp *) interp; - CallFrame *varFramePtr = iPtr->varFramePtr; - Proc *procPtr = (varFramePtr->isProcCallFrame & FRAME_IS_PROC) ? - varFramePtr->procPtr : NULL; - Namespace *callerNsPtr = varFramePtr->nsPtr; - Tcl_Command resolvedCmdPtr = NULL; - - /* - * Just do something special on a cmd literal "z" in two cases: - * A) when the caller is a proc "x", and the proc is either in "::" or in "::ns2". - * B) the caller's namespace is "ctx1" or "ctx2" - */ - if ( (name[0] == 'z') && (name[1] == '\0') ) { - Namespace *ns2NsPtr = (Namespace *) Tcl_FindNamespace(interp, "::ns2", NULL, 0); - - if (procPtr != NULL - && ((procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr) - || (ns2NsPtr != NULL && procPtr->cmdPtr->nsPtr == ns2NsPtr) - ) - ) { - /* - * Case A) - * - * - The context, in which this resolver becomes active, is - * determined by the name of the caller proc, which has to be - * named "x". - * - * - To determine the name of the caller proc, the proc is taken - * from the topmost stack frame. - * - * - Note that the context is NOT provided during byte-code - * compilation (e.g. in TclProcCompileProc) - * - * When these conditions hold, this function resolves the - * passed-in cmd literal into a cmd "y", which is taken from the - * the global namespace (for simplicity). - */ - - const char *callingCmdName = - Tcl_GetCommandName(interp, (Tcl_Command) procPtr->cmdPtr); - - if ( callingCmdName[0] == 'x' && callingCmdName[1] == '\0' ) { - resolvedCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY); - } - } else if (callerNsPtr != NULL) { - /* - * Case B) - * - * - The context, in which this resolver becomes active, is - * determined by the name of the parent namespace, which has - * to be named "ctx1" or "ctx2". - * - * - To determine the name of the parent namesace, it is taken - * from the 2nd highest stack frame. - * - * - Note that the context can be provided during byte-code - * compilation (e.g. in TclProcCompileProc) - * - * When these conditions hold, this function resolves the - * passed-in cmd literal into a cmd "y" or "Y" depending on the - * context. The resolved procs are taken from the the global - * namespace (for simplicity). - */ - - CallFrame *parentFramePtr = varFramePtr->callerPtr; - const char *context = parentFramePtr != NULL ? parentFramePtr->nsPtr->name : "(NULL)"; - - if (strcmp(context, "ctx1") == 0 && (name[0] == 'z') && (name[1] == '\0')) { - resolvedCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY); - /* fprintf(stderr, "... y ==> %p\n", resolvedCmdPtr);*/ - - } else if (strcmp(context, "ctx2") == 0 && (name[0] == 'z') && (name[1] == '\0')) { - resolvedCmdPtr = Tcl_FindCommand(interp, "Y", NULL, TCL_GLOBAL_ONLY); - /*fprintf(stderr, "... Y ==> %p\n", resolvedCmdPtr);*/ - } - } - - if (resolvedCmdPtr != NULL) { - *rPtr = resolvedCmdPtr; - return TCL_OK; - } - } - return TCL_CONTINUE; -} - -static int -InterpVarResolver( - TCL_UNUSED(Tcl_Interp *), - TCL_UNUSED(const char *), - TCL_UNUSED(Tcl_Namespace *), - TCL_UNUSED(int), - TCL_UNUSED(Tcl_Var *)) -{ - /* - * Don't resolve the variable; use standard rules. - */ - - return TCL_CONTINUE; -} - -typedef struct MyResolvedVarInfo { - Tcl_ResolvedVarInfo vInfo; /* This must be the first element. */ - Tcl_Var var; - Tcl_Obj *nameObj; -} MyResolvedVarInfo; - -static inline void -HashVarFree( - Tcl_Var var) -{ - if (VarHashRefCount(var) < 2) { - Tcl_Free(var); - } else { - VarHashRefCount(var)--; - } -} - -static void -MyCompiledVarFree( - Tcl_ResolvedVarInfo *vInfoPtr) -{ - MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *) vInfoPtr; - - Tcl_DecrRefCount(resVarInfo->nameObj); - if (resVarInfo->var) { - HashVarFree(resVarInfo->var); - } - Tcl_Free(vInfoPtr); -} - -#define TclVarHashGetValue(hPtr) \ - ((Var *) ((char *)hPtr - offsetof(VarInHash, entry))) - -static Tcl_Var -MyCompiledVarFetch( - Tcl_Interp *interp, - Tcl_ResolvedVarInfo *vinfoPtr) -{ - MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *) vinfoPtr; - Tcl_Var var = resVarInfo->var; - int isNewVar; - Interp *iPtr = (Interp *) interp; - Tcl_HashEntry *hPtr; - - if (var != NULL) { - if (!(((Var *) var)->flags & VAR_DEAD_HASH)) { - /* - * The cached variable is valid, return it. - */ - - return var; - } - - /* - * The variable is not valid anymore. Clean it up. - */ - - HashVarFree(var); - } - - hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) &iPtr->globalNsPtr->varTable, - (char *) resVarInfo->nameObj, &isNewVar); - if (hPtr) { - var = (Tcl_Var) TclVarHashGetValue(hPtr); - } else { - var = NULL; - } - resVarInfo->var = var; - - /* - * Increment the reference counter to avoid Tcl_Free() of the variable in - * Tcl's FreeVarEntry(); for cleanup, we provide our own HashVarFree(); - */ - - 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 *)Tcl_Alloc(sizeof(MyResolvedVarInfo)); - - resVarInfo->vInfo.fetchProc = MyCompiledVarFetch; - resVarInfo->vInfo.deleteProc = MyCompiledVarFree; - resVarInfo->var = NULL; - resVarInfo->nameObj = Tcl_NewStringObj(name, -1); - Tcl_IncrRefCount(resVarInfo->nameObj); - *rPtr = &resVarInfo->vInfo; - return TCL_OK; - } - return TCL_CONTINUE; -} - -static int -TestInterpResolverCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - static const char *const table[] = { - "down", "up", NULL - }; - int idx; -#define RESOLVER_KEY "testInterpResolver" - - if ((objc < 2) || (objc > 3)) { - Tcl_WrongNumArgs(interp, 1, objv, "up|down ?interp?"); - return TCL_ERROR; - } - if (objc == 3) { - interp = Tcl_GetChild(interp, Tcl_GetString(objv[2])); - if (interp == NULL) { - Tcl_AppendResult(interp, "provided interpreter not found", NULL); - return TCL_ERROR; - } - } - if (Tcl_GetIndexFromObj(interp, objv[1], table, "operation", TCL_EXACT, - &idx) != TCL_OK) { - return TCL_ERROR; - } - switch (idx) { - case 1: /* up */ - Tcl_AddInterpResolvers(interp, RESOLVER_KEY, InterpCmdResolver, - InterpVarResolver, InterpCompiledVarResolver); - break; - case 0: /*down*/ - if (!Tcl_RemoveInterpResolvers(interp, RESOLVER_KEY)) { - Tcl_AppendResult(interp, "could not remove the resolver scheme", - NULL); - return TCL_ERROR; - } - } - return TCL_OK; -} /* * Local Variables: * mode: c * c-basic-offset: 4 Index: generic/tclTestObj.c ================================================================== --- generic/tclTestObj.c +++ generic/tclTestObj.c @@ -12,59 +12,55 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#ifndef USE_TCL_STUBS -# define USE_TCL_STUBS -#endif #include "tclInt.h" -#ifdef TCL_WITH_EXTERNAL_TOMMATH -# include "tommath.h" -#else -# include "tclTomMath.h" -#endif -#include "tclStringRep.h" +#include "tommath.h" +/* + * 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 *. + */ + +#define NUMBER_OF_OBJECT_VARS 20 +static Tcl_Obj *varPtr[NUMBER_OF_OBJECT_VARS]; /* * Forward declarations for functions defined later in this file: */ -static int CheckIfVarUnset(Tcl_Interp *interp, Tcl_Obj **varPtr, int varIndex); +static int CheckIfVarUnset(Tcl_Interp *interp, 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); - Tcl_Free(varPtr); -} - -static Tcl_Obj **GetVarPtr(Tcl_Interp *interp) -{ - Tcl_InterpDeleteProc *proc; - - return (Tcl_Obj **) Tcl_GetAssocData(interp, VARPTR_KEY, &proc); -} +static void SetVarToObj(int varIndex, Tcl_Obj *objPtr); +int TclObjTest_Init(Tcl_Interp *interp); +static int TestbignumobjCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int TestbooleanobjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int TestdoubleobjCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int TestindexobjCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int TestintobjCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int TestlistobjCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int TestobjCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int TeststringobjCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); + +typedef struct TestString { + int numChars; + size_t allocated; + size_t uallocated; + Tcl_UniChar unicode[2]; +} TestString; /* *---------------------------------------------------------------------- * * TclObjTest_Init -- @@ -84,51 +80,40 @@ 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 **) Tcl_Alloc(NUMBER_OF_OBJECT_VARS *sizeof(varPtr[0])); - if (!varPtr) { - return TCL_ERROR; - } - Tcl_SetAssocData(interp, VARPTR_KEY, VarPtrDeleteProc, varPtr); + register int i; + for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) { - varPtr[i] = NULL; + varPtr[i] = NULL; } Tcl_CreateObjCommand(interp, "testbignumobj", TestbignumobjCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testbooleanobj", TestbooleanobjCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testdoubleobj", TestdoubleobjCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testintobj", TestintobjCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testindexobj", TestindexobjCmd, - NULL, NULL); + (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "testlistobj", TestlistobjCmd, - NULL, NULL); - Tcl_CreateObjCommand(interp, "testobj", TestobjCmd, NULL, NULL); + (ClientData) 0, NULL); + Tcl_CreateObjCommand(interp, "testobj", TestobjCmd, (ClientData) 0, NULL); Tcl_CreateObjCommand(interp, "teststringobj", TeststringobjCmd, - NULL, NULL); + (ClientData) 0, NULL); return TCL_OK; } /* *---------------------------------------------------------------------- * * TestbignumobjCmd -- * - * This function implements the "testbignumobj" command. It is used + * This function implmenets the "testbignumobj" command. It is used * to exercise the bignum Tcl object type implementation. * * Results: * Returns a standard Tcl object result. * @@ -139,29 +124,29 @@ *---------------------------------------------------------------------- */ static int TestbignumobjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* unused */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Argument count */ Tcl_Obj *const objv[]) /* Argument vector */ { - const char *const subcmds[] = { + const char * 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; + char* string; + mp_int bignumValue, newValue; if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg?..."); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "option", 0, &index) != TCL_OK) { return TCL_ERROR; @@ -168,11 +153,10 @@ } string = Tcl_GetString(objv[2]); if (GetVariableIndex(interp, string, &varIndex) != TCL_OK) { return TCL_ERROR; } - varPtr = GetVarPtr(interp); switch (index) { case BIGNUM_SET: if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "var value"); @@ -200,106 +184,106 @@ */ if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { Tcl_SetBignumObj(varPtr[varIndex], &bignumValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&bignumValue)); + SetVarToObj(varIndex, Tcl_NewBignumObj(&bignumValue)); } break; case BIGNUM_GET: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); return TCL_ERROR; } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { + if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } break; case BIGNUM_MULT10: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); return TCL_ERROR; } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { + if (CheckIfVarUnset(interp, 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) { + if (mp_init(&newValue) != MP_OKAY + || (mp_mul_d(&bignumValue, 10, &newValue) != MP_OKAY)) { mp_clear(&bignumValue); + mp_clear(&newValue); Tcl_SetObjResult(interp, Tcl_NewStringObj("error in mp_mul_d", -1)); return TCL_ERROR; } + mp_clear(&bignumValue); if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetBignumObj(varPtr[varIndex], &bignumValue); + Tcl_SetBignumObj(varPtr[varIndex], &newValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&bignumValue)); + SetVarToObj(varIndex, Tcl_NewBignumObj(&newValue)); } break; case BIGNUM_DIV10: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); return TCL_ERROR; } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { + if (CheckIfVarUnset(interp, 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) { + if (mp_init(&newValue) != MP_OKAY + || (mp_div_d(&bignumValue, 10, &newValue, NULL) != MP_OKAY)) { mp_clear(&bignumValue); + mp_clear(&newValue); Tcl_SetObjResult(interp, Tcl_NewStringObj("error in mp_div_d", -1)); return TCL_ERROR; } + mp_clear(&bignumValue); if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetBignumObj(varPtr[varIndex], &bignumValue); + Tcl_SetBignumObj(varPtr[varIndex], &newValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&bignumValue)); + SetVarToObj(varIndex, Tcl_NewBignumObj(&newValue)); } break; case BIGNUM_ISEVEN: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); return TCL_ERROR; } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { + if (CheckIfVarUnset(interp, 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)); + Tcl_SetIntObj(varPtr[varIndex], !mp_isodd(&bignumValue)); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(mp_iszero(&bignumValue))); + SetVarToObj(varIndex, Tcl_NewIntObj(!mp_isodd(&bignumValue))); } mp_clear(&bignumValue); break; case BIGNUM_RADIXSIZE: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); return TCL_ERROR; } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { + if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } if (Tcl_GetBignumFromObj(interp, varPtr[varIndex], &bignumValue) != TCL_OK) { return TCL_ERROR; @@ -308,11 +292,11 @@ return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { Tcl_SetIntObj(varPtr[varIndex], index); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(index)); + SetVarToObj(varIndex, Tcl_NewIntObj(index)); } mp_clear(&bignumValue); break; } @@ -338,18 +322,17 @@ *---------------------------------------------------------------------- */ static int TestbooleanobjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ 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; + char *index, *subCmd; if (objc < 3) { wrongNumArgs: Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); return TCL_ERROR; @@ -358,12 +341,10 @@ index = Tcl_GetString(objv[2]); if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } - varPtr = GetVarPtr(interp); - subCmd = Tcl_GetString(objv[1]); if (strcmp(subCmd, "set") == 0) { if (objc != 4) { goto wrongNumArgs; } @@ -378,38 +359,38 @@ * we must create a new object to modify/set and decrement the old * formerly-shared object's ref count. This is "copy on write". */ if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetWideIntObj(varPtr[varIndex], boolValue != 0); + Tcl_SetBooleanObj(varPtr[varIndex], boolValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(boolValue != 0)); + SetVarToObj(varIndex, Tcl_NewBooleanObj(boolValue)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "get") == 0) { if (objc != 3) { goto wrongNumArgs; } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { + if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "not") == 0) { if (objc != 3) { goto wrongNumArgs; } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { + if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } if (Tcl_GetBooleanFromObj(interp, varPtr[varIndex], &boolValue) != TCL_OK) { return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetWideIntObj(varPtr[varIndex], boolValue == 0); + Tcl_SetBooleanObj(varPtr[varIndex], !boolValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(boolValue == 0)); + SetVarToObj(varIndex, Tcl_NewBooleanObj(!boolValue)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad option \"", Tcl_GetString(objv[1]), @@ -438,28 +419,25 @@ *---------------------------------------------------------------------- */ static int TestdoubleobjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ 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; - Tcl_Obj **varPtr; + char *index, *subCmd, *string; if (objc < 3) { wrongNumArgs: Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); return TCL_ERROR; } - varPtr = GetVarPtr(interp); - index = Tcl_GetString(objv[2]); if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } @@ -482,53 +460,53 @@ */ if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { Tcl_SetDoubleObj(varPtr[varIndex], doubleValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewDoubleObj(doubleValue)); + SetVarToObj(varIndex, Tcl_NewDoubleObj(doubleValue)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "get") == 0) { if (objc != 3) { goto wrongNumArgs; } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { + if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "mult10") == 0) { if (objc != 3) { goto wrongNumArgs; } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { + if (CheckIfVarUnset(interp, varIndex)) { + return TCL_ERROR; + } + if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex], + &doubleValue) != TCL_OK) { + return TCL_ERROR; + } + if (!Tcl_IsShared(varPtr[varIndex])) { + Tcl_SetDoubleObj(varPtr[varIndex], (doubleValue * 10.0)); + } else { + SetVarToObj(varIndex, Tcl_NewDoubleObj( (doubleValue * 10.0) )); + } + Tcl_SetObjResult(interp, varPtr[varIndex]); + } else if (strcmp(subCmd, "div10") == 0) { + if (objc != 3) { + goto wrongNumArgs; + } + if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex], &doubleValue) != TCL_OK) { return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetDoubleObj(varPtr[varIndex], doubleValue * 10.0); - } else { - SetVarToObj(varPtr, varIndex, Tcl_NewDoubleObj(doubleValue * 10.0)); - } - Tcl_SetObjResult(interp, varPtr[varIndex]); - } else if (strcmp(subCmd, "div10") == 0) { - if (objc != 3) { - goto wrongNumArgs; - } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { - return TCL_ERROR; - } - if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex], - &doubleValue) != TCL_OK) { - return TCL_ERROR; - } - if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetDoubleObj(varPtr[varIndex], doubleValue / 10.0); - } else { - SetVarToObj(varPtr, varIndex, Tcl_NewDoubleObj(doubleValue / 10.0)); + Tcl_SetDoubleObj(varPtr[varIndex], (doubleValue / 10.0)); + } else { + SetVarToObj(varIndex, Tcl_NewDoubleObj( (doubleValue / 10.0) )); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad option \"", Tcl_GetString(objv[1]), @@ -556,26 +534,25 @@ *---------------------------------------------------------------------- */ static int TestindexobjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ 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}; - + static const char *tablePtr[] = {"a", "b", "check", NULL}; /* * Keep this structure declaration in sync with tclIndexObj.c */ struct IndexRep { - void *tablePtr; /* Pointer to the table of strings. */ - size_t offset; /* Offset between table entries. */ - size_t index; /* Selected index into table. */ + 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)) { @@ -588,11 +565,11 @@ 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 = (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); @@ -610,20 +587,35 @@ } if (Tcl_GetBooleanFromObj(interp, objv[2], &allowAbbrev) != TCL_OK) { return TCL_ERROR; } - argv = (const char **)Tcl_Alloc((objc-3) * sizeof(char *)); + argv = (const char **) ckalloc((unsigned) ((objc-3) * sizeof(char *))); for (i = 4; i < objc; i++) { argv[i-4] = Tcl_GetString(objv[i]); } argv[objc-4] = NULL; + + /* + * Tcl_GetIndexFromObj assumes that the table is statically-allocated so + * that its address is different for each index object. If we accidently + * allocate a table at the same address as that cached in the index + * object, clear out the object's cached state. + */ + + if ( objv[3]->typePtr != NULL + && !strcmp( "index", objv[3]->typePtr->name ) ) { + indexRep = (struct IndexRep *) objv[3]->internalRep.twoPtrValue.ptr1; + if (indexRep->tablePtr == (VOID *) argv) { + objv[3]->typePtr->freeIntRepProc(objv[3]); + objv[3]->typePtr = NULL; + } + } result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3], - argv, "token", TCL_INDEX_TEMP_TABLE|(allowAbbrev? 0 : TCL_EXACT), - &index); - Tcl_Free((void *)argv); + argv, "token", (allowAbbrev? 0 : TCL_EXACT), &index); + ckfree((char *) argv); if (result == TCL_OK) { Tcl_SetIntObj(Tcl_GetObjResult(interp), index); } return result; } @@ -646,27 +638,25 @@ *---------------------------------------------------------------------- */ static int TestintobjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ 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; - Tcl_Obj **varPtr; + long longValue; + char *index, *subCmd, *string; if (objc < 3) { wrongNumArgs: Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); return TCL_ERROR; } - varPtr = GetVarPtr(interp); index = Tcl_GetString(objv[2]); if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } @@ -690,11 +680,11 @@ */ if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { Tcl_SetIntObj(varPtr[varIndex], intValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue)); + SetVarToObj(varIndex, Tcl_NewIntObj(intValue)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "set2") == 0) { /* doesn't set result */ if (objc != 4) { goto wrongNumArgs; @@ -705,62 +695,62 @@ } intValue = i; if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { Tcl_SetIntObj(varPtr[varIndex], intValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue)); + SetVarToObj(varIndex, Tcl_NewIntObj(intValue)); } - } else if (strcmp(subCmd, "setint") == 0) { + } else if (strcmp(subCmd, "setlong") == 0) { if (objc != 4) { goto wrongNumArgs; } string = Tcl_GetString(objv[3]); if (Tcl_GetInt(interp, string, &i) != TCL_OK) { return TCL_ERROR; } intValue = i; if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetWideIntObj(varPtr[varIndex], intValue); + Tcl_SetLongObj(varPtr[varIndex], intValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(intValue)); + SetVarToObj(varIndex, Tcl_NewLongObj(intValue)); } Tcl_SetObjResult(interp, varPtr[varIndex]); - } else if (strcmp(subCmd, "setmax") == 0) { - Tcl_WideInt maxWide = WIDE_MAX; + } else if (strcmp(subCmd, "setmaxlong") == 0) { + long maxLong = LONG_MAX; if (objc != 3) { goto wrongNumArgs; } if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetWideIntObj(varPtr[varIndex], maxWide); + Tcl_SetLongObj(varPtr[varIndex], maxLong); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(maxWide)); + SetVarToObj(varIndex, Tcl_NewLongObj(maxLong)); } - } else if (strcmp(subCmd, "ismax") == 0) { + } else if (strcmp(subCmd, "ismaxlong") == 0) { if (objc != 3) { goto wrongNumArgs; } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { + if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } - if (Tcl_GetWideIntFromObj(interp, varPtr[varIndex], &wideValue) != TCL_OK) { + if (Tcl_GetLongFromObj(interp, varPtr[varIndex], &longValue) != TCL_OK) { return TCL_ERROR; } Tcl_AppendToObj(Tcl_GetObjResult(interp), - ((wideValue == WIDE_MAX)? "1" : "0"), -1); + ((longValue == LONG_MAX)? "1" : "0"), -1); } else if (strcmp(subCmd, "get") == 0) { if (objc != 3) { goto wrongNumArgs; } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { + if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "get2") == 0) { if (objc != 3) { goto wrongNumArgs; } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { + if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } string = Tcl_GetString(varPtr[varIndex]); Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1); } else if (strcmp(subCmd, "inttoobigtest") == 0) { @@ -776,13 +766,13 @@ } #if (INT_MAX == LONG_MAX) /* int is same size as long int */ Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1); #else if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetWideIntObj(varPtr[varIndex], LONG_MAX); + Tcl_SetLongObj(varPtr[varIndex], LONG_MAX); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(LONG_MAX)); + SetVarToObj(varIndex, Tcl_NewLongObj(LONG_MAX)); } if (Tcl_GetIntFromObj(interp, varPtr[varIndex], &i) != TCL_OK) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1); return TCL_OK; @@ -791,38 +781,38 @@ #endif } else if (strcmp(subCmd, "mult10") == 0) { if (objc != 3) { goto wrongNumArgs; } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { + if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, varPtr[varIndex], - &intValue) != TCL_OK) { + &intValue) != TCL_OK) { return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetIntObj(varPtr[varIndex], intValue * 10); + Tcl_SetIntObj(varPtr[varIndex], (intValue * 10)); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue * 10)); + SetVarToObj(varIndex, Tcl_NewIntObj( (intValue * 10) )); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "div10") == 0) { if (objc != 3) { goto wrongNumArgs; } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { + if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, varPtr[varIndex], - &intValue) != TCL_OK) { + &intValue) != TCL_OK) { return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetIntObj(varPtr[varIndex], intValue / 10); + Tcl_SetIntObj(varPtr[varIndex], (intValue / 10)); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue / 10)); + SetVarToObj(varIndex, Tcl_NewIntObj( (intValue / 10) )); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad option \"", Tcl_GetString(objv[1]), @@ -850,11 +840,11 @@ *----------------------------------------------------------------------------- */ static int TestlistobjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Number of arguments */ Tcl_Obj *const objv[]) /* Argument objects */ { /* Subcommands supported by this command */ @@ -872,17 +862,15 @@ const char* index; /* Argument giving the variable number */ int varIndex; /* Variable number converted to binary */ int cmdIndex; /* Ordinal number of the subcommand */ int first; /* First index in the list */ int count; /* Count of elements in a list */ - Tcl_Obj **varPtr; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg...?"); return TCL_ERROR; } - varPtr = GetVarPtr(interp); index = Tcl_GetString(objv[2]); if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "command", @@ -892,21 +880,21 @@ switch(cmdIndex) { case LISTOBJ_SET: if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { Tcl_SetListObj(varPtr[varIndex], objc-3, objv+3); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewListObj(objc-3, objv+3)); + SetVarToObj(varIndex, Tcl_NewListObj(objc-3, objv+3)); } Tcl_SetObjResult(interp, varPtr[varIndex]); break; case LISTOBJ_GET: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); return TCL_ERROR; } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { + if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } Tcl_SetObjResult(interp, varPtr[varIndex]); break; @@ -919,11 +907,11 @@ if (Tcl_GetIntFromObj(interp, objv[3], &first) != TCL_OK || Tcl_GetIntFromObj(interp, objv[4], &count) != TCL_OK) { return TCL_ERROR; } if (Tcl_IsShared(varPtr[varIndex])) { - SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex])); + SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex])); } Tcl_ResetResult(interp); return Tcl_ListObjReplace(interp, varPtr[varIndex], first, count, objc-5, objv+5); } @@ -947,44 +935,42 @@ *---------------------------------------------------------------------- */ static int TestobjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ 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; - Tcl_Obj **varPtr; + char *index, *subCmd, *string; + Tcl_ObjType *targetType; if (objc < 2) { wrongNumArgs: Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); return TCL_ERROR; } - varPtr = GetVarPtr(interp); subCmd = Tcl_GetString(objv[1]); if (strcmp(subCmd, "assign") == 0) { - if (objc != 4) { - goto wrongNumArgs; - } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { - return TCL_ERROR; - } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { + if (objc != 4) { + goto wrongNumArgs; + } + index = Tcl_GetString(objv[2]); + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } string = Tcl_GetString(objv[3]); - if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) { - return TCL_ERROR; - } - SetVarToObj(varPtr, destIndex, varPtr[varIndex]); + if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) { + return TCL_ERROR; + } + SetVarToObj(destIndex, varPtr[varIndex]); Tcl_SetObjResult(interp, varPtr[destIndex]); } else if (strcmp(subCmd, "bug3598580") == 0) { Tcl_Obj *listObjPtr, *elemObjPtr; if (objc != 2) { goto wrongNumArgs; @@ -993,142 +979,136 @@ listObjPtr = Tcl_NewListObj(1, &elemObjPtr); /* Replace the single list element through itself, nonsense but legal. */ Tcl_ListObjReplace(interp, listObjPtr, 0, 1, 1, &elemObjPtr); Tcl_SetObjResult(interp, listObjPtr); return TCL_OK; - } else if (strcmp(subCmd, "convert") == 0) { - const char *typeName; - - if (objc != 4) { - goto wrongNumArgs; - } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { - return TCL_ERROR; - } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { - return TCL_ERROR; - } - typeName = Tcl_GetString(objv[3]); - if ((targetType = Tcl_GetObjType(typeName)) == NULL) { + } else if (strcmp(subCmd, "convert") == 0) { + char *typeName; + if (objc != 4) { + goto wrongNumArgs; + } + index = Tcl_GetString(objv[2]); + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varIndex)) { + return TCL_ERROR; + } + typeName = Tcl_GetString(objv[3]); + if ((targetType = Tcl_GetObjType(typeName)) == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "no type ", typeName, " found", NULL); - return TCL_ERROR; - } - if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType) - != TCL_OK) { - return TCL_ERROR; - } + return TCL_ERROR; + } + if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType) + != TCL_OK) { + return TCL_ERROR; + } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "duplicate") == 0) { - if (objc != 4) { - goto wrongNumArgs; - } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { - return TCL_ERROR; - } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { + if (objc != 4) { + goto wrongNumArgs; + } + index = Tcl_GetString(objv[2]); + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } string = Tcl_GetString(objv[3]); - if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) { - return TCL_ERROR; - } - SetVarToObj(varPtr, destIndex, Tcl_DuplicateObj(varPtr[varIndex])); - Tcl_SetObjResult(interp, varPtr[destIndex]); - } else if (strcmp(subCmd, "freeallvars") == 0) { - if (objc != 2) { - goto wrongNumArgs; - } - for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) { - if (varPtr[i] != NULL) { - Tcl_DecrRefCount(varPtr[i]); - varPtr[i] = NULL; - } - } - } else if (strcmp(subCmd, "invalidateStringRep") == 0) { - if (objc != 3) { - goto wrongNumArgs; - } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { - return TCL_ERROR; - } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { - return TCL_ERROR; - } - Tcl_InvalidateStringRep(varPtr[varIndex]); - Tcl_SetObjResult(interp, varPtr[varIndex]); - } else if (strcmp(subCmd, "newobj") == 0) { - if (objc != 3) { - goto wrongNumArgs; - } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { - return TCL_ERROR; - } - SetVarToObj(varPtr, varIndex, Tcl_NewObj()); + if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) { + return TCL_ERROR; + } + SetVarToObj(destIndex, Tcl_DuplicateObj(varPtr[varIndex])); + Tcl_SetObjResult(interp, varPtr[destIndex]); + } else if (strcmp(subCmd, "freeallvars") == 0) { + if (objc != 2) { + goto wrongNumArgs; + } + for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) { + if (varPtr[i] != NULL) { + Tcl_DecrRefCount(varPtr[i]); + varPtr[i] = NULL; + } + } + } else if ( strcmp ( subCmd, "invalidateStringRep" ) == 0 ) { + if ( objc != 3 ) { + goto wrongNumArgs; + } + index = Tcl_GetString( objv[2] ); + if ( GetVariableIndex( interp, index, &varIndex ) != TCL_OK ) { + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varIndex)) { + return TCL_ERROR; + } + Tcl_InvalidateStringRep( varPtr[varIndex] ); + Tcl_SetObjResult( interp, varPtr[varIndex] ); + } else if (strcmp(subCmd, "newobj") == 0) { + if (objc != 3) { + goto wrongNumArgs; + } + index = Tcl_GetString(objv[2]); + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + return TCL_ERROR; + } + SetVarToObj(varIndex, Tcl_NewObj()); Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "objtype") == 0) { const char *typeName; /* - * Return an object containing the name of the argument's type of - * internal rep. If none exists, return "none". + * return an object containing the name of the argument's type + * of internal rep. If none exists, return "none". */ - if (objc != 3) { - goto wrongNumArgs; - } + if (objc != 3) { + goto wrongNumArgs; + } if (objv[2]->typePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1)); } else { typeName = objv[2]->typePtr->name; -#ifndef TCL_WIDE_INT_IS_LONG - if (!strcmp(typeName, "wideInt")) typeName = "int"; -#endif Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1)); } } else if (strcmp(subCmd, "refcount") == 0) { - if (objc != 3) { - goto wrongNumArgs; - } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { - return TCL_ERROR; - } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(varPtr[varIndex]->refCount)); - } else if (strcmp(subCmd, "type") == 0) { - if (objc != 3) { - goto wrongNumArgs; - } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { - return TCL_ERROR; - } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { - return TCL_ERROR; - } - if (varPtr[varIndex]->typePtr == NULL) { /* a string! */ - Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1); -#ifndef TCL_WIDE_INT_IS_LONG - } else if (!strcmp(varPtr[varIndex]->typePtr->name, "wideInt")) { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "int", -1); -#endif - } else { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - varPtr[varIndex]->typePtr->name, -1); - } - } else if (strcmp(subCmd, "types") == 0) { - if (objc != 2) { - goto wrongNumArgs; - } + char buf[TCL_INTEGER_SPACE]; + + if (objc != 3) { + goto wrongNumArgs; + } + index = Tcl_GetString(objv[2]); + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varIndex)) { + return TCL_ERROR; + } + TclFormatInt(buf, varPtr[varIndex]->refCount); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + } else if (strcmp(subCmd, "type") == 0) { + if (objc != 3) { + goto wrongNumArgs; + } + index = Tcl_GetString(objv[2]); + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varIndex)) { + return TCL_ERROR; + } + if (varPtr[varIndex]->typePtr == NULL) { /* a string! */ + Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1); + } else { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + varPtr[varIndex]->typePtr->name, -1); + } + } else if (strcmp(subCmd, "types") == 0) { + if (objc != 2) { + goto wrongNumArgs; + } if (Tcl_AppendAllObjTypes(interp, Tcl_GetObjResult(interp)) != TCL_OK) { return TCL_ERROR; } } else { @@ -1159,34 +1139,32 @@ *---------------------------------------------------------------------- */ static int TeststringobjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar *unicode; int varIndex, option, i, length; + Tcl_UniChar *unicode; #define MAX_STRINGS 11 - const char *index, *string, *strings[MAX_STRINGS+1]; - String *strPtr; - Tcl_Obj **varPtr; - static const char *const options[] = { + char *index, *string, *strings[MAX_STRINGS+1]; + TestString *strPtr; + static const char *options[] = { "append", "appendstrings", "get", "get2", "length", "length2", - "set", "set2", "setlength", "maxchars", "appendself", - "appendself2", NULL + "set", "set2", "setlength", "ualloc", "getunicode", + "appendself", "appendself2", NULL }; if (objc < 3) { wrongNumArgs: Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); return TCL_ERROR; } - varPtr = GetVarPtr(interp); index = Tcl_GetString(objv[2]); if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } @@ -1201,20 +1179,20 @@ } if (Tcl_GetIntFromObj(interp, objv[4], &length) != TCL_OK) { return TCL_ERROR; } if (varPtr[varIndex] == NULL) { - SetVarToObj(varPtr, varIndex, Tcl_NewObj()); + SetVarToObj(varIndex, Tcl_NewObj()); } /* * If the object bound to variable "varIndex" is shared, we must * "copy on write" and append to a copy of the object. */ if (Tcl_IsShared(varPtr[varIndex])) { - SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex])); + SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex])); } string = Tcl_GetString(objv[3]); Tcl_AppendToObj(varPtr[varIndex], string, length); Tcl_SetObjResult(interp, varPtr[varIndex]); break; @@ -1221,20 +1199,20 @@ case 1: /* appendstrings */ if (objc > (MAX_STRINGS+3)) { goto wrongNumArgs; } if (varPtr[varIndex] == NULL) { - SetVarToObj(varPtr, varIndex, Tcl_NewObj()); + SetVarToObj(varIndex, Tcl_NewObj()); } /* * If the object bound to variable "varIndex" is shared, we must * "copy on write" and append to a copy of the object. */ if (Tcl_IsShared(varPtr[varIndex])) { - SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex])); + SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex])); } for (i = 3; i < objc; i++) { strings[i-3] = Tcl_GetString(objv[i]); } for ( ; i < 12 + 3; i++) { @@ -1248,40 +1226,39 @@ break; case 2: /* get */ if (objc != 3) { goto wrongNumArgs; } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { + if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } Tcl_SetObjResult(interp, varPtr[varIndex]); break; case 3: /* get2 */ if (objc != 3) { goto wrongNumArgs; } - if (CheckIfVarUnset(interp, varPtr, varIndex)) { + if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } string = Tcl_GetString(varPtr[varIndex]); Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1); break; case 4: /* length */ if (objc != 3) { goto wrongNumArgs; } - Tcl_SetWideIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL) - ? (Tcl_WideInt)varPtr[varIndex]->length : (Tcl_WideInt)-1); + 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; + strPtr = (TestString *) + (varPtr[varIndex])->internalRep.twoPtrValue.ptr1; length = (int) strPtr->allocated; } else { length = -1; } Tcl_SetIntObj(Tcl_GetObjResult(interp), length); @@ -1303,19 +1280,19 @@ string = Tcl_GetStringFromObj(objv[3], &length); if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { Tcl_SetStringObj(varPtr[varIndex], string, length); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewStringObj(string, length)); + SetVarToObj(varIndex, Tcl_NewStringObj(string, length)); } Tcl_SetObjResult(interp, varPtr[varIndex]); break; case 7: /* set2 */ if (objc != 4) { goto wrongNumArgs; } - SetVarToObj(varPtr, varIndex, objv[3]); + SetVarToObj(varIndex, objv[3]); break; case 8: /* setlength */ if (objc != 4) { goto wrongNumArgs; } @@ -1324,39 +1301,44 @@ } if (varPtr[varIndex] != NULL) { Tcl_SetObjLength(varPtr[varIndex], length); } break; - case 9: /* maxchars */ + case 9: /* ualloc */ 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; + strPtr = (TestString *) + (varPtr[varIndex])->internalRep.twoPtrValue.ptr1; + length = (int) strPtr->uallocated; } else { length = -1; } Tcl_SetIntObj(Tcl_GetObjResult(interp), length); break; - case 10: /* appendself */ + case 10: /* getunicode */ + if (objc != 3) { + goto wrongNumArgs; + } + Tcl_GetUnicodeFromObj(varPtr[varIndex], NULL); + break; + case 11: /* appendself */ if (objc != 4) { goto wrongNumArgs; } if (varPtr[varIndex] == NULL) { - SetVarToObj(varPtr, varIndex, Tcl_NewObj()); + SetVarToObj(varIndex, Tcl_NewObj()); } /* * If the object bound to variable "varIndex" is shared, we must * "copy on write" and append to a copy of the object. */ if (Tcl_IsShared(varPtr[varIndex])) { - SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex])); + SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex])); } string = Tcl_GetStringFromObj(varPtr[varIndex], &length); if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) { @@ -1369,25 +1351,25 @@ } Tcl_AppendToObj(varPtr[varIndex], string + i, length - i); Tcl_SetObjResult(interp, varPtr[varIndex]); break; - case 11: /* appendself2 */ + case 12: /* appendself2 */ if (objc != 4) { goto wrongNumArgs; } if (varPtr[varIndex] == NULL) { - SetVarToObj(varPtr, varIndex, Tcl_NewObj()); + SetVarToObj(varIndex, Tcl_NewObj()); } /* * If the object bound to variable "varIndex" is shared, we must * "copy on write" and append to a copy of the object. */ if (Tcl_IsShared(varPtr[varIndex])) { - SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex])); + SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex])); } unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &length); if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) { @@ -1397,11 +1379,11 @@ Tcl_SetObjResult(interp, Tcl_NewStringObj( "index value out of range", -1)); return TCL_ERROR; } - TclAppendUnicodeToObj(varPtr[varIndex], unicode + i, length - i); + Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + i, length - i); Tcl_SetObjResult(interp, varPtr[varIndex]); break; } return TCL_OK; @@ -1426,11 +1408,10 @@ *---------------------------------------------------------------------- */ static void SetVarToObj( - Tcl_Obj **varPtr, int varIndex, /* Designates the assignment variable. */ Tcl_Obj *objPtr) /* Points to object to assign to var. */ { if (varPtr[varIndex] != NULL) { Tcl_DecrRefCount(varPtr[varIndex]); @@ -1499,11 +1480,10 @@ */ static int CheckIfVarUnset( Tcl_Interp *interp, /* Interpreter for error reporting. */ - Tcl_Obj ** varPtr, int varIndex) /* Index of the test variable to check. */ { if (varPtr[varIndex] == NULL) { char buf[32 + TCL_INTEGER_SPACE]; Index: generic/tclTestProcBodyObj.c ================================================================== --- generic/tclTestProcBodyObj.c +++ generic/tclTestProcBodyObj.c @@ -9,154 +9,147 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#ifndef USE_TCL_STUBS -# define USE_TCL_STUBS -#endif #include "tclInt.h" /* * name and version of this package */ static const char packageName[] = "procbodytest"; -static const char packageVersion[] = "1.1"; +static const char packageVersion[] = "1.0"; /* * Name of the commands exported by this package */ static const char procCommand[] = "proc"; -static const char checkCommand[] = "check"; /* * this struct describes an entry in the table of command names and command * procs */ -typedef struct { - const char *cmdName; /* command name */ +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 ProcBodyTestProcObjCmd(ClientData 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); + const char *namespace, const CmdTable *cmdTablePtr); +int Procbodytest_Init(Tcl_Interp * interp); +int Procbodytest_SafeInit(Tcl_Interp * interp); /* * List of commands to create when the package is loaded; must go after the * declarations of the enable command procedure. */ -static const CmdTable commands[] = { +static CONST CmdTable commands[] = { { procCommand, ProcBodyTestProcObjCmd, 1 }, - { checkCommand, ProcBodyTestCheckObjCmd, 1 }, { 0, 0, 0 } }; -static const CmdTable safeCommands[] = { +static CONST CmdTable safeCommands[] = { { procCommand, ProcBodyTestProcObjCmd, 1 }, - { checkCommand, ProcBodyTestCheckObjCmd, 1 }, { 0, 0, 0 } }; /* *---------------------------------------------------------------------- * * Procbodytest_Init -- * - * This function initializes the "procbodytest" package. + * This function initializes the "procbodytest" package. * * Results: - * A standard Tcl result. + * A standard Tcl result. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ int Procbodytest_Init( Tcl_Interp *interp) /* the Tcl interpreter for which the package - * is initialized */ + * is initialized */ { return ProcBodyTestInitInternal(interp, 0); } /* *---------------------------------------------------------------------- * * Procbodytest_SafeInit -- * - * This function initializes the "procbodytest" package. + * This function initializes the "procbodytest" package. * * Results: - * A standard Tcl result. + * A standard Tcl result. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ int Procbodytest_SafeInit( Tcl_Interp *interp) /* the Tcl interpreter for which the package - * is initialized */ + * is initialized */ { return ProcBodyTestInitInternal(interp, 1); } /* *---------------------------------------------------------------------- * * RegisterCommand -- * - * This function registers a command in the context of the given - * namespace. + * This function registers a command in the context of the given namespace. * * Results: - * A standard Tcl result. + * A standard Tcl result. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ -static int -RegisterCommand( - Tcl_Interp* interp, /* the Tcl interpreter for which the operation +static int RegisterCommand(interp, namespace, cmdTablePtr) + Tcl_Interp* interp; /* the Tcl interpreter for which the operation * is performed */ - const char *namesp, /* the namespace in which the command is + const char *namespace; /* the namespace in which the command is * registered */ - const CmdTable *cmdTablePtr)/* the command to register */ + 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, "namespace eval %s { namespace export %s }", + namespace, cmdTablePtr->cmdName); + if (Tcl_Eval(interp, buf) != TCL_OK) + return TCL_ERROR; } - sprintf(buf, "%s::%s", namesp, cmdTablePtr->cmdName); + sprintf(buf, "%s::%s", namespace, cmdTablePtr->cmdName); Tcl_CreateObjCommand(interp, buf, cmdTablePtr->proc, 0, 0); + return TCL_OK; } /* *---------------------------------------------------------------------- @@ -176,23 +169,23 @@ */ static int ProcBodyTestInitInternal( Tcl_Interp *interp, /* the Tcl interpreter for which the package - * is initialized */ + * is initialized */ int isSafe) /* 1 if this is a safe interpreter */ { - const CmdTable *cmdTablePtr; + CONST CmdTable *cmdTablePtr; cmdTablePtr = (isSafe) ? &safeCommands[0] : &commands[0]; for ( ; cmdTablePtr->cmdName ; cmdTablePtr++) { - if (RegisterCommand(interp, packageName, cmdTablePtr) != TCL_OK) { - return TCL_ERROR; - } + if (RegisterCommand(interp, packageName, cmdTablePtr) != TCL_OK) { + return TCL_ERROR; + } } - return Tcl_PkgProvideEx(interp, packageName, packageVersion, NULL); + return Tcl_PkgProvide(interp, packageName, packageVersion); } /* *---------------------------------------------------------------------- * @@ -226,16 +219,16 @@ *---------------------------------------------------------------------- */ static int ProcBodyTestProcObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* context; not used */ Tcl_Interp *interp, /* the current interpreter */ int objc, /* argument count */ Tcl_Obj *const objv[]) /* arguments */ { - const char *fullName; + char *fullName; Tcl_Command procCmd; Command *cmdPtr; Proc *procPtr = NULL; Tcl_Obj *bodyObjPtr; Tcl_Obj *myobjv[5]; @@ -248,107 +241,68 @@ /* * Find the Command pointer to this procedure */ - fullName = Tcl_GetString(objv[3]); + fullName = Tcl_GetStringFromObj(objv[3], NULL); procCmd = Tcl_FindCommand(interp, fullName, NULL, TCL_LEAVE_ERR_MSG); if (procCmd == NULL) { - return TCL_ERROR; + return TCL_ERROR; } cmdPtr = (Command *) procCmd; /* * check that this is a procedure and not a builtin command: - * If a procedure, cmdPtr->objClientData is TclIsProc(cmdPtr). + * If a procedure, cmdPtr->objProc is TclObjInterpProc. */ - if (cmdPtr->objClientData != TclIsProc(cmdPtr)) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + if (cmdPtr->objProc != TclGetObjInterpProc()) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "command \"", fullName, "\" is not a Tcl procedure", NULL); - return TCL_ERROR; + return TCL_ERROR; } /* * it is a Tcl procedure: the client data is the Proc structure */ procPtr = (Proc *) cmdPtr->objClientData; if (procPtr == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "procedure \"", - fullName, "\" does not have a Proc struct!", NULL); - return TCL_ERROR; + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "procedure \"", fullName, + "\" does not have a Proc struct!", NULL); + return TCL_ERROR; } /* * create a new object, initialize our argument vector, call into Tcl */ bodyObjPtr = TclNewProcBodyObj(procPtr); if (bodyObjPtr == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "failed to create a procbody object for procedure \"", - fullName, "\"", NULL); - return TCL_ERROR; + fullName, "\"", NULL); + return TCL_ERROR; } Tcl_IncrRefCount(bodyObjPtr); myobjv[0] = objv[0]; myobjv[1] = objv[1]; myobjv[2] = objv[2]; myobjv[3] = bodyObjPtr; myobjv[4] = NULL; - result = Tcl_ProcObjCmd(NULL, interp, objc, myobjv); + result = Tcl_ProcObjCmd((ClientData) NULL, interp, objc, myobjv); Tcl_DecrRefCount(bodyObjPtr); return result; } - -/* - *---------------------------------------------------------------------- - * - * ProcBodyTestCheckObjCmd -- - * - * Implements the "procbodytest::check" command. Here is the command - * description: - * procbodytest::check - * - * Performs an internal check that the Tcl_PkgPresent() command returns - * the same version number as was registered when the procbodytest package - * was provided. Places a boolean in the interp result indicating the - * test outcome. - * - * Results: - * Returns a standard Tcl code. - * - *---------------------------------------------------------------------- - */ - -static int -ProcBodyTestCheckObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* the current interpreter */ - int objc, /* argument count */ - Tcl_Obj *const objv[]) /* arguments */ -{ - const char *version; - - if (objc != 1) { - Tcl_WrongNumArgs(interp, 1, objv, ""); - return TCL_ERROR; - } - - version = Tcl_PkgPresentEx(interp, packageName, packageVersion, 1, NULL); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj( - strcmp(version, packageVersion) == 0)); - return TCL_OK; -} /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclThread.c ================================================================== --- generic/tclThread.c +++ generic/tclThread.c @@ -3,11 +3,10 @@ * * This file implements Platform independent thread operations. Most of * the real work is done in the platform dependent files. * * Copyright (c) 1998 by Sun Microsystems, Inc. - * Copyright (c) 2008 by George Peter Staplin * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ @@ -38,10 +37,25 @@ static void ForgetSyncObject(void *objPtr, SyncObjRecord *recPtr); static void RememberSyncObject(void *objPtr, SyncObjRecord *recPtr); +/* + * Several functions are #defined to nothing in tcl.h if TCL_THREADS is not + * specified. Here we undo that so the functions are defined in the stubs + * table. + */ + +#ifndef TCL_THREADS +#undef Tcl_MutexLock +#undef Tcl_MutexUnlock +#undef Tcl_MutexFinalize +#undef Tcl_ConditionNotify +#undef Tcl_ConditionWait +#undef Tcl_ConditionFinalize +#endif + /* *---------------------------------------------------------------------- * * Tcl_GetThreadData -- * @@ -59,34 +73,32 @@ */ void * Tcl_GetThreadData( Tcl_ThreadDataKey *keyPtr, /* Identifier for the data chunk */ - size_t size) /* Size of storage block */ + int size) /* Size of storage block */ { void *result; -#if TCL_THREADS +#ifdef TCL_THREADS /* * Initialize the key for this thread. */ - - result = TclThreadStorageKeyGet(keyPtr); + result = TclpThreadDataKeyGet(keyPtr); if (result == NULL) { - result = Tcl_Alloc(size); - memset(result, 0, size); - TclThreadStorageKeySet(keyPtr, result); + result = ckalloc((size_t) size); + memset(result, 0, (size_t) size); + TclpThreadDataKeySet(keyPtr, result); } #else /* TCL_THREADS */ if (*keyPtr == NULL) { - result = Tcl_Alloc(size); - memset(result, 0, size); - *keyPtr = result; + result = ckalloc((size_t) size); + memset(result, 0, (size_t) size); + *keyPtr = (Tcl_ThreadDataKey)result; RememberSyncObject(keyPtr, &keyRecord); - } else { - result = *keyPtr; } + result = * (void **) keyPtr; #endif /* TCL_THREADS */ return result; } /* @@ -106,29 +118,31 @@ *---------------------------------------------------------------------- */ void * TclThreadDataKeyGet( - Tcl_ThreadDataKey *keyPtr) /* Identifier for the data chunk. */ - + Tcl_ThreadDataKey *keyPtr) /* Identifier for the data chunk, really + * (pthread_key_t **) */ { -#if TCL_THREADS - return TclThreadStorageKeyGet(keyPtr); +#ifdef TCL_THREADS + return TclpThreadDataKeyGet(keyPtr); #else /* TCL_THREADS */ - return *keyPtr; + char *result = *(char **) keyPtr; + return result; #endif /* TCL_THREADS */ } + /* *---------------------------------------------------------------------- * * RememberSyncObject * * Keep a list of (mutexes/condition variable/data key) used during * finalization. * - * Assume global lock is held. + * Assume master lock is held. * * Results: * None. * * Side effects: @@ -162,18 +176,18 @@ * pointers to the new list. */ if (recPtr->num >= recPtr->max) { recPtr->max += 8; - newList = (void **)Tcl_Alloc(recPtr->max * sizeof(void *)); + newList = (void **) ckalloc(recPtr->max * sizeof(char *)); for (i=0,j=0 ; inum ; i++) { if (recPtr->list[i] != NULL) { newList[j++] = recPtr->list[i]; } } if (recPtr->list != NULL) { - Tcl_Free(recPtr->list); + ckfree((char *) recPtr->list); } recPtr->list = newList; recPtr->num = j; } @@ -185,11 +199,11 @@ *---------------------------------------------------------------------- * * ForgetSyncObject * * Remove a single object from the list. - * Assume global lock is held. + * Assume master lock is held. * * Results: * None. * * Side effects: @@ -217,11 +231,11 @@ *---------------------------------------------------------------------- * * TclRememberMutex * * Keep a list of mutexes used during finalization. - * Assume global lock is held. + * Assume master lock is held. * * Results: * None. * * Side effects: @@ -252,30 +266,29 @@ * Remove the mutex from the list. * *---------------------------------------------------------------------- */ -#undef Tcl_MutexFinalize void Tcl_MutexFinalize( Tcl_Mutex *mutexPtr) { -#if TCL_THREADS +#ifdef TCL_THREADS TclpFinalizeMutex(mutexPtr); #endif - TclpGlobalLock(); + TclpMasterLock(); ForgetSyncObject(mutexPtr, &mutexRecord); - TclpGlobalUnlock(); + TclpMasterUnlock(); } /* *---------------------------------------------------------------------- * * TclRememberCondition * * Keep a list of condition variables used during finalization. - * Assume global lock is held. + * Assume master lock is held. * * Results: * None. * * Side effects: @@ -306,21 +319,20 @@ * Remove the condition variable from the list. * *---------------------------------------------------------------------- */ -#undef Tcl_ConditionFinalize void Tcl_ConditionFinalize( Tcl_Condition *condPtr) { -#if TCL_THREADS +#ifdef TCL_THREADS TclpFinalizeCondition(condPtr); #endif - TclpGlobalLock(); + TclpMasterLock(); ForgetSyncObject(condPtr, &condRecord); - TclpGlobalUnlock(); + TclpMasterUnlock(); } /* *---------------------------------------------------------------------- * @@ -338,22 +350,15 @@ * *---------------------------------------------------------------------- */ void -TclFinalizeThreadData(int quick) -{ - TclFinalizeThreadDataThread(); -#if TCL_THREADS && defined(USE_THREAD_ALLOC) - if (!quick) { - /* - * Quick exit principle makes it useless to terminate allocators - */ - TclFinalizeThreadAllocThread(); - } -#else - (void)quick; +TclFinalizeThreadData(void) +{ + TclpFinalizeThreadDataThread(); +#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) + TclFinalizeThreadAllocThread(); #endif } /* *---------------------------------------------------------------------- @@ -376,15 +381,15 @@ TclFinalizeSynchronization(void) { int i; void *blockPtr; Tcl_ThreadDataKey *keyPtr; -#if TCL_THREADS +#ifdef TCL_THREADS Tcl_Mutex *mutexPtr; Tcl_Condition *condPtr; - TclpGlobalLock(); + TclpMasterLock(); #endif /* * If we're running unthreaded, the TSD blocks are simply stored inside * their thread data keys. Free them here. @@ -391,22 +396,22 @@ */ if (keyRecord.list != NULL) { for (i=0 ; inextPtr = firstCachePtr; firstCachePtr = cachePtr; Tcl_MutexUnlock(listLockPtr); cachePtr->owner = Tcl_GetCurrentThread(); @@ -244,13 +225,13 @@ void TclFreeAllocCache( void *arg) { - Cache *cachePtr = (Cache*)arg; + Cache *cachePtr = arg; Cache **nextPtrPtr; - unsigned int bucket; + register unsigned int bucket; /* * Flush blocks. */ @@ -263,11 +244,13 @@ /* * Flush objs. */ if (cachePtr->numObjects > 0) { - PutObjs(cachePtr, cachePtr->numObjects); + Tcl_MutexLock(objLockPtr); + MoveObjs(cachePtr, sharedPtr, cachePtr->numObjects); + Tcl_MutexUnlock(objLockPtr); } /* * Remove from pool list. */ @@ -278,11 +261,11 @@ nextPtrPtr = &(*nextPtrPtr)->nextPtr; } *nextPtrPtr = cachePtr->nextPtr; cachePtr->nextPtr = NULL; Tcl_MutexUnlock(listLockPtr); - TclpSysFree(cachePtr); + free(cachePtr); } /* *---------------------------------------------------------------------- * @@ -297,49 +280,65 @@ * May allocate more blocks for a bucket. * *---------------------------------------------------------------------- */ -void * +char * TclpAlloc( - size_t reqSize) + unsigned int reqSize) { Cache *cachePtr; Block *blockPtr; - int bucket; + register int bucket; size_t size; - GETCACHE(cachePtr); +#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 + + cachePtr = TclpGetAllocCache(); + if (cachePtr == NULL) { + cachePtr = GetCache(); + } /* * Increment the requested size to include room for the Block structure. - * Call TclpSysAlloc() directly if the required amount is greater than the + * Call malloc() 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++; + ++size; #endif if (size > MAXALLOC) { bucket = NBUCKETS; - blockPtr = (Block *)TclpSysAlloc(size); + blockPtr = malloc(size); if (blockPtr != NULL) { cachePtr->totalAssigned += reqSize; } } else { bucket = 0; while (bucketInfo[bucket].blockSize < size) { - bucket++; + ++bucket; } if (cachePtr->buckets[bucket].numFree || GetBlocks(cachePtr, bucket)) { blockPtr = cachePtr->buckets[bucket].firstPtr; cachePtr->buckets[bucket].firstPtr = blockPtr->nextBlock; - cachePtr->buckets[bucket].numFree--; - cachePtr->buckets[bucket].numRemoves++; + --cachePtr->buckets[bucket].numFree; + ++cachePtr->buckets[bucket].numRemoves; cachePtr->buckets[bucket].totalAssigned += reqSize; } } if (blockPtr == NULL) { return NULL; @@ -363,21 +362,24 @@ *---------------------------------------------------------------------- */ void TclpFree( - void *ptr) + char *ptr) { Cache *cachePtr; Block *blockPtr; int bucket; if (ptr == NULL) { return; } - GETCACHE(cachePtr); + cachePtr = TclpGetAllocCache(); + if (cachePtr == NULL) { + cachePtr = GetCache(); + } /* * Get the block back from the user pointer and call system free directly * for large blocks. Otherwise, push the block back on the bucket and move * blocks to the shared cache if there are now too many free. @@ -385,22 +387,19 @@ blockPtr = Ptr2Block(ptr); bucket = blockPtr->sourceBucket; if (bucket == NBUCKETS) { cachePtr->totalAssigned -= blockPtr->blockReqSize; - TclpSysFree(blockPtr); + free(blockPtr); return; } cachePtr->buckets[bucket].totalAssigned -= blockPtr->blockReqSize; blockPtr->nextBlock = cachePtr->buckets[bucket].firstPtr; cachePtr->buckets[bucket].firstPtr = blockPtr; - if (cachePtr->buckets[bucket].numFree == 0) { - cachePtr->buckets[bucket].lastPtr = blockPtr; - } - cachePtr->buckets[bucket].numFree++; - cachePtr->buckets[bucket].numInserts++; + ++cachePtr->buckets[bucket].numFree; + ++cachePtr->buckets[bucket].numInserts; if (cachePtr != sharedPtr && cachePtr->buckets[bucket].numFree > bucketInfo[bucket].maxBlocks) { PutBlocks(cachePtr, bucket, bucketInfo[bucket].numMove); } @@ -420,14 +419,14 @@ * Previous memory, if any, may be freed. * *---------------------------------------------------------------------- */ -void * +char * TclpRealloc( - void *ptr, - size_t reqSize) + char *ptr, + unsigned int reqSize) { Cache *cachePtr; Block *blockPtr; void *newPtr; size_t size, min; @@ -435,22 +434,38 @@ if (ptr == NULL) { return TclpAlloc(reqSize); } - GETCACHE(cachePtr); +#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 + + cachePtr = TclpGetAllocCache(); + if (cachePtr == NULL) { + cachePtr = GetCache(); + } /* * 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. + * size would also require a system block, call realloc() directly. */ blockPtr = Ptr2Block(ptr); size = reqSize + sizeof(Block); #if RCHECK - size++; + ++size; #endif bucket = blockPtr->sourceBucket; if (bucket != NBUCKETS) { if (bucket > 0) { min = bucketInfo[bucket-1].blockSize; @@ -463,11 +478,11 @@ return Block2Ptr(blockPtr, bucket, reqSize); } } else if (size > MAXALLOC) { cachePtr->totalAssigned -= blockPtr->blockReqSize; cachePtr->totalAssigned += reqSize; - blockPtr = (Block*)TclpSysRealloc(blockPtr, size); + blockPtr = realloc(blockPtr, size); if (blockPtr == NULL) { return NULL; } return Block2Ptr(blockPtr, NBUCKETS, reqSize); } @@ -499,32 +514,30 @@ * * Side effects: * May move Tcl_Obj's from shared cached or allocate new Tcl_Obj's if * list is empty. * - * Note: - * If this code is updated, the changes need to be reflected in the macro - * TclAllocObjStorageEx() defined in tclInt.h - * *---------------------------------------------------------------------- */ Tcl_Obj * TclThreadAllocObj(void) { - Cache *cachePtr; - Tcl_Obj *objPtr; + register Cache *cachePtr = TclpGetAllocCache(); + register Tcl_Obj *objPtr; - GETCACHE(cachePtr); + if (cachePtr == NULL) { + cachePtr = GetCache(); + } /* * Get this thread's obj list structure and move or allocate new objs if * necessary. */ if (cachePtr->numObjects == 0) { - int numMove; + register int numMove; Tcl_MutexLock(objLockPtr); numMove = sharedPtr->numObjects; if (numMove > 0) { if (numMove > NOBJALLOC) { @@ -535,31 +548,29 @@ Tcl_MutexUnlock(objLockPtr); if (cachePtr->numObjects == 0) { Tcl_Obj *newObjsPtr; cachePtr->numObjects = numMove = NOBJALLOC; - newObjsPtr = (Tcl_Obj *)TclpSysAlloc(sizeof(Tcl_Obj) * numMove); + newObjsPtr = malloc(sizeof(Tcl_Obj) * numMove); 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; + objPtr = &newObjsPtr[numMove]; + objPtr->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr; + cachePtr->firstObjPtr = objPtr; } - cachePtr->firstObjPtr = newObjsPtr; } } /* * Pop the first object. */ objPtr = cachePtr->firstObjPtr; - cachePtr->firstObjPtr = (Tcl_Obj *)objPtr->internalRep.twoPtrValue.ptr1; - cachePtr->numObjects--; + cachePtr->firstObjPtr = objPtr->internalRep.twoPtrValue.ptr1; + --cachePtr->numObjects; return objPtr; } /* *---------------------------------------------------------------------- @@ -572,43 +583,40 @@ * None. * * Side effects: * May move free Tcl_Obj's to shared list upon hitting high water mark. * - * Note: - * If this code is updated, the changes need to be reflected in the macro - * TclAllocObjStorageEx() defined in tclInt.h - * *---------------------------------------------------------------------- */ void TclThreadFreeObj( Tcl_Obj *objPtr) { - Cache *cachePtr; + Cache *cachePtr = TclpGetAllocCache(); - GETCACHE(cachePtr); + if (cachePtr == NULL) { + cachePtr = GetCache(); + } /* * Get this thread's list and push on the free Tcl_Obj. */ objPtr->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr; cachePtr->firstObjPtr = objPtr; - if (cachePtr->numObjects == 0) { - cachePtr->lastPtr = objPtr; - } - cachePtr->numObjects++; + ++cachePtr->numObjects; /* * If the number of free objects has exceeded the high water mark, move * some blocks to the shared list. */ if (cachePtr->numObjects > NOBJHIGH) { - PutObjs(cachePtr, NOBJALLOC); + Tcl_MutexLock(objLockPtr); + MoveObjs(cachePtr, sharedPtr, NOBJALLOC); + Tcl_MutexUnlock(objLockPtr); } } /* *---------------------------------------------------------------------- @@ -643,12 +651,12 @@ } else { sprintf(buf, "thread%p", cachePtr->owner); Tcl_DStringAppendElement(dsPtr, buf); } for (n = 0; n < NBUCKETS; ++n) { - sprintf(buf, "%" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u", - bucketInfo[n].blockSize, + 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, @@ -681,11 +689,11 @@ MoveObjs( Cache *fromPtr, Cache *toPtr, int numMove) { - Tcl_Obj *objPtr = fromPtr->firstObjPtr; + register Tcl_Obj *objPtr = fromPtr->firstObjPtr; Tcl_Obj *fromFirstObjPtr = objPtr; toPtr->numObjects += numMove; fromPtr->numObjects -= numMove; @@ -693,76 +701,22 @@ * 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; + objPtr = objPtr->internalRep.twoPtrValue.ptr1; } - fromPtr->firstObjPtr = (Tcl_Obj *)objPtr->internalRep.twoPtrValue.ptr1; + fromPtr->firstObjPtr = 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; - objPtr->internalRep.twoPtrValue.ptr1 = toPtr->firstObjPtr; /* NULL */ + objPtr->internalRep.twoPtrValue.ptr1 = toPtr->firstObjPtr; toPtr->firstObjPtr = fromFirstObjPtr; } - -/* - *---------------------------------------------------------------------- - * - * PutObjs -- - * - * Move Tcl_Obj's from thread cache to shared cache. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -PutObjs( - Cache *fromPtr, - int numMove) -{ - int keep = fromPtr->numObjects - numMove; - Tcl_Obj *firstPtr, *lastPtr = NULL; - - 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. - */ - - Tcl_MutexLock(objLockPtr); - fromPtr->lastPtr->internalRep.twoPtrValue.ptr1 = sharedPtr->firstObjPtr; - sharedPtr->firstObjPtr = firstPtr; - if (sharedPtr->numObjects == 0) { - sharedPtr->lastPtr = fromPtr->lastPtr; - } - sharedPtr->numObjects += numMove; - Tcl_MutexUnlock(objLockPtr); - - fromPtr->lastPtr = lastPtr; -} /* *---------------------------------------------------------------------- * * Block2Ptr, Ptr2Block -- @@ -776,33 +730,33 @@ * Invalid blocks will abort the server. * *---------------------------------------------------------------------- */ -static void * +static char * Block2Ptr( Block *blockPtr, int bucket, unsigned int reqSize) { - void *ptr; + register 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; + return (char *) ptr; } static Block * Ptr2Block( - void *ptr) + char *ptr) { - Block *blockPtr; + register 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); @@ -837,18 +791,26 @@ static void LockBucket( Cache *cachePtr, int bucket) { +#if 0 + if (Tcl_MutexTryLock(bucketInfo[bucket].lockPtr) != TCL_OK) { + Tcl_MutexLock(bucketInfo[bucket].lockPtr); + ++cachePtr->buckets[bucket].numWaits; + ++sharedPtr->buckets[bucket].numWaits; + } +#else Tcl_MutexLock(bucketInfo[bucket].lockPtr); - cachePtr->buckets[bucket].numLocks++; - sharedPtr->buckets[bucket].numLocks++; +#endif + ++cachePtr->buckets[bucket].numLocks; + ++sharedPtr->buckets[bucket].numLocks; } static void UnlockBucket( - TCL_UNUSED(Cache *), + Cache *cachePtr, int bucket) { Tcl_MutexUnlock(bucketInfo[bucket].lockPtr); } @@ -872,47 +834,35 @@ PutBlocks( Cache *cachePtr, int bucket, int numMove) { + register Block *lastPtr, *firstPtr; + register int n = numMove; + /* - * We have numFree. Want to shed numMove. So compute how many - * Blocks to keep. + * Before acquiring the lock, walk the block list to find the last block + * to be moved. */ - int keep = cachePtr->buckets[bucket].numFree - numMove; - Block *lastPtr = NULL, *firstPtr; - - cachePtr->buckets[bucket].numFree = keep; - firstPtr = cachePtr->buckets[bucket].firstPtr; - if (keep == 0) { - cachePtr->buckets[bucket].firstPtr = NULL; - } else { - do { - lastPtr = firstPtr; - firstPtr = firstPtr->nextBlock; - } while (--keep > 0); - lastPtr->nextBlock = NULL; - } + firstPtr = lastPtr = cachePtr->buckets[bucket].firstPtr; + while (--n > 0) { + lastPtr = lastPtr->nextBlock; + } + cachePtr->buckets[bucket].firstPtr = lastPtr->nextBlock; + cachePtr->buckets[bucket].numFree -= numMove; /* * Aquire the lock and place the list of blocks at the front of the shared * cache bucket. */ LockBucket(cachePtr, bucket); - cachePtr->buckets[bucket].lastPtr->nextBlock - = sharedPtr->buckets[bucket].firstPtr; + lastPtr->nextBlock = sharedPtr->buckets[bucket].firstPtr; sharedPtr->buckets[bucket].firstPtr = firstPtr; - if (sharedPtr->buckets[bucket].numFree == 0) { - sharedPtr->buckets[bucket].lastPtr - = cachePtr->buckets[bucket].lastPtr; - } sharedPtr->buckets[bucket].numFree += numMove; UnlockBucket(cachePtr, bucket); - - cachePtr->buckets[bucket].lastPtr = lastPtr; } /* *---------------------------------------------------------------------- * @@ -932,12 +882,12 @@ static int GetBlocks( Cache *cachePtr, int bucket) { - Block *blockPtr; - size_t n; + register Block *blockPtr; + register 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 @@ -955,12 +905,10 @@ n = bucketInfo[bucket].numMove; if (n >= sharedPtr->buckets[bucket].numFree) { cachePtr->buckets[bucket].firstPtr = sharedPtr->buckets[bucket].firstPtr; - cachePtr->buckets[bucket].lastPtr = - sharedPtr->buckets[bucket].lastPtr; cachePtr->buckets[bucket].numFree = sharedPtr->buckets[bucket].numFree; sharedPtr->buckets[bucket].firstPtr = NULL; sharedPtr->buckets[bucket].numFree = 0; } else { @@ -970,34 +918,33 @@ cachePtr->buckets[bucket].numFree = n; while (--n > 0) { blockPtr = blockPtr->nextBlock; } sharedPtr->buckets[bucket].firstPtr = blockPtr->nextBlock; - cachePtr->buckets[bucket].lastPtr = blockPtr; blockPtr->nextBlock = NULL; } } UnlockBucket(cachePtr, bucket); } if (cachePtr->buckets[bucket].numFree == 0) { - size_t size; + register 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 > (size_t)bucket) { + size = 0; /* lint */ + 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--; + --cachePtr->buckets[n].numFree; break; } } /* @@ -1004,11 +951,11 @@ * Otherwise, allocate a big new block directly. */ if (blockPtr == NULL) { size = MAXALLOC; - blockPtr = (Block*)TclpSysAlloc(size); + blockPtr = malloc(size); if (blockPtr == NULL) { return 0; } } @@ -1022,49 +969,14 @@ while (--n > 0) { blockPtr->nextBlock = (Block *) ((char *) blockPtr + bucketInfo[bucket].blockSize); blockPtr = blockPtr->nextBlock; } - cachePtr->buckets[bucket].lastPtr = blockPtr; blockPtr->nextBlock = NULL; } return 1; } - -/* - *---------------------------------------------------------------------- - * - * 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 = ((size_t)1) << (NBUCKETS - 1 - i); - bucketInfo[i].numMove = i < NBUCKETS - 1 ? - 1 << (NBUCKETS - 2 - i) : 1; - bucketInfo[i].lockPtr = TclpNewAllocMutex(); - } - TclpInitAllocCache(); -} /* *---------------------------------------------------------------------- * * TclFinalizeThreadAlloc -- @@ -1085,12 +997,12 @@ TclFinalizeThreadAlloc(void) { unsigned int i; for (i = 0; i < NBUCKETS; ++i) { - TclpFreeAllocMutex(bucketInfo[i].lockPtr); - bucketInfo[i].lockPtr = NULL; + TclpFreeAllocMutex(bucketInfo[i].lockPtr); + bucketInfo[i].lockPtr = NULL; } TclpFreeAllocMutex(objLockPtr); objLockPtr = NULL; @@ -1103,13 +1015,13 @@ /* *---------------------------------------------------------------------- * * TclFinalizeThreadAllocThread -- * - * This procedure is used to destroy single thread private resources - * defined in this file. Called either during Tcl_FinalizeThread() or - * Tcl_Finalize(). + * This procedure is used to destroy single thread private resources used + * in this file. + * Called in TclpFinalizeThreadData when a thread exits (Tcl_FinalizeThread). * * Results: * None. * * Side effects: @@ -1119,11 +1031,11 @@ */ void TclFinalizeThreadAllocThread(void) { - Cache *cachePtr = (Cache *)TclpGetAllocCache(); + Cache *cachePtr = TclpGetAllocCache(); if (cachePtr != NULL) { TclpFreeAllocCache(cachePtr); } } @@ -1144,11 +1056,11 @@ *---------------------------------------------------------------------- */ void Tcl_GetMemoryInfo( - TCL_UNUSED(Tcl_DString *)) + Tcl_DString *dsPtr) { Tcl_Panic("Tcl_GetMemoryInfo called when threaded memory allocator not in use"); } /* Index: generic/tclThreadJoin.c ================================================================== --- generic/tclThreadJoin.c +++ generic/tclThreadJoin.c @@ -12,11 +12,11 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" -#ifdef _WIN32 +#ifdef WIN32 /* * The information about each joinable thread is remembered in a structure as * defined below. */ @@ -50,11 +50,11 @@ * 'joinMutex'. */ TCL_DECLARE_MUTEX(joinMutex) -static JoinableThread *firstThreadPtr; +static JoinableThread* firstThreadPtr; /* *---------------------------------------------------------------------- * * TclJoinThread -- @@ -199,11 +199,11 @@ *result = threadPtr->result; Tcl_ConditionFinalize(&threadPtr->cond); Tcl_MutexFinalize(&threadPtr->threadMutex); - Tcl_Free(threadPtr); + ckfree((char *) threadPtr); return TCL_OK; } /* @@ -228,11 +228,11 @@ TclRememberJoinableThread( Tcl_ThreadId id) /* The thread to remember as joinable */ { JoinableThread *threadPtr; - threadPtr = (JoinableThread *)Tcl_Alloc(sizeof(JoinableThread)); + threadPtr = (JoinableThread *) ckalloc(sizeof(JoinableThread)); threadPtr->id = id; threadPtr->done = 0; threadPtr->waitedUpon = 0; threadPtr->threadMutex = (Tcl_Mutex) NULL; threadPtr->cond = (Tcl_Condition) NULL; @@ -303,14 +303,14 @@ Tcl_ConditionNotify(&threadPtr->cond); } Tcl_MutexUnlock(&threadPtr->threadMutex); } -#endif /* _WIN32 */ +#endif /* WIN32 */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclThreadStorage.c ================================================================== --- generic/tclThreadStorage.c +++ generic/tclThreadStorage.c @@ -1,351 +1,574 @@ /* * tclThreadStorage.c -- * - * This file implements platform independent thread storage operations to - * work around system limits on the number of thread-specific variables. + * This file implements platform independent thread storage operations. * * Copyright (c) 2003-2004 by Joe Mistachkin - * Copyright (c) 2008 by George Peter Staplin * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" -#if TCL_THREADS -#include - -/* - * IMPLEMENTATION NOTES: - * - * The primary idea is that we create one platform-specific TSD slot, and use - * it for storing a table pointer. Each Tcl_ThreadDataKey has an offset into - * the table of TSD values. We don't use more than 1 platform-specific TSD - * slot, because there is a hard limit on the number of TSD slots. Valid key - * offsets are greater than 0; 0 is for the initialized Tcl_ThreadDataKey. - */ - -/* - * The global collection of information about TSDs. This is shared across the - * whole process, and includes the mutex used to protect it. - */ - -static struct { - void *key; /* Key into the system TSD structure. The - * collection of Tcl TSD values for a - * particular thread will hang off the - * back-end of this. */ - sig_atomic_t counter; /* The number of different Tcl TSDs used - * across *all* threads. This is a strictly - * increasing value. */ - Tcl_Mutex mutex; /* Protection for the rest of this structure, - * which holds per-process data. */ -} tsdGlobal = { NULL, 0, NULL }; - -/* - * The type of the data held per thread in a system TSD. - */ - -typedef struct { - ClientData *tablePtr; /* The table of Tcl TSDs. */ - sig_atomic_t allocated; /* The size of the table in the current - * thread. */ -} TSDTable; - -/* - * The actual type of Tcl_ThreadDataKey. - */ - -typedef union { - volatile sig_atomic_t offset; - /* The type is really an offset into the - * thread-local table of TSDs, which is this - * field. */ - void *ptr; /* For alignment purposes only. Not actually - * accessed through this. */ -} TSDUnion; - -/* - * Forward declarations of functions in this file. - */ - -static TSDTable * TSDTableCreate(void); -static void TSDTableDelete(TSDTable *tsdTablePtr); -static void TSDTableGrow(TSDTable *tsdTablePtr, - sig_atomic_t atLeast); - -/* - * Allocator and deallocator for a TSDTable structure. - */ - -static TSDTable * -TSDTableCreate(void) -{ - TSDTable *tsdTablePtr; - sig_atomic_t i; - - tsdTablePtr = (TSDTable *)TclpSysAlloc(sizeof(TSDTable)); - if (tsdTablePtr == NULL) { - Tcl_Panic("unable to allocate TSDTable"); - } - - tsdTablePtr->allocated = 8; - tsdTablePtr->tablePtr = - (void **)TclpSysAlloc(sizeof(void *) * tsdTablePtr->allocated); - if (tsdTablePtr->tablePtr == NULL) { - Tcl_Panic("unable to allocate TSDTable"); - } - - for (i = 0; i < tsdTablePtr->allocated; ++i) { - tsdTablePtr->tablePtr[i] = NULL; - } - - return tsdTablePtr; -} - -static void -TSDTableDelete( - TSDTable *tsdTablePtr) -{ - sig_atomic_t i; - - for (i=0 ; iallocated ; 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. - */ - - Tcl_Free(tsdTablePtr->tablePtr[i]); - } - } - - TclpSysFree(tsdTablePtr->tablePtr); - TclpSysFree(tsdTablePtr); -} - -/* - *---------------------------------------------------------------------- - * - * TSDTableGrow -- - * - * This procedure makes the passed TSDTable grow to fit the atLeast - * value. +#if defined(TCL_THREADS) + +/* + * This is the thread storage cache array and it's accompanying mutex. The + * elements are pairs of thread Id and an associated hash table pointer; the + * hash table being pointed to contains the thread storage for it's associated + * thread. The purpose of this cache is to minimize the number of hash table + * lookups in the master thread storage hash table. + */ + +static Tcl_Mutex threadStorageLock; + +/* + * This is the struct used for a thread storage cache slot. It contains the + * owning thread Id and the associated hash table pointer. + */ + +typedef struct ThreadStorage { + Tcl_ThreadId id; /* the owning thread id */ + Tcl_HashTable *hashTablePtr;/* the hash table for the thread */ +} ThreadStorage; + +/* + * These are the prototypes for the custom hash table allocation functions + * used by the thread storage subsystem. + */ + +static Tcl_HashEntry * AllocThreadStorageEntry(Tcl_HashTable *tablePtr, + void *keyPtr); +static void FreeThreadStorageEntry(Tcl_HashEntry *hPtr); +static Tcl_HashTable * ThreadStorageGetHashTable(Tcl_ThreadId id); + +/* + * This is the hash key type for thread storage. We MUST use this in + * combination with the new hash key type flag TCL_HASH_KEY_SYSTEM_HASH + * because these hash tables MAY be used by the threaded memory allocator. + */ + +static Tcl_HashKeyType tclThreadStorageHashKeyType = { + TCL_HASH_KEY_TYPE_VERSION, /* version */ + TCL_HASH_KEY_SYSTEM_HASH | TCL_HASH_KEY_RANDOMIZE_HASH, + /* flags */ + NULL, /* hashKeyProc */ + NULL, /* compareKeysProc */ + AllocThreadStorageEntry, /* allocEntryProc */ + FreeThreadStorageEntry /* freeEntryProc */ +}; + +/* + * This is an invalid thread value. + */ + +#define STORAGE_INVALID_THREAD (Tcl_ThreadId)0 + +/* + * This is the value for an invalid thread storage key. + */ + +#define STORAGE_INVALID_KEY 0 + +/* + * This is the first valid key for use by external callers. All the values + * below this are RESERVED for future use. + */ + +#define STORAGE_FIRST_KEY 1 + +/* + * This is the default number of thread storage cache slots. This define may + * need to be fine tuned for maximum performance. + */ + +#define STORAGE_CACHE_SLOTS 97 + +/* + * This is the master thread storage hash table. It is keyed on thread Id and + * contains values that are hash tables for each thread. The thread specific + * hash tables contain the actual thread storage. + */ + +static Tcl_HashTable threadStorageHashTable; + +/* + * This is the next thread data key value to use. We increment this everytime + * we "allocate" one. It is initially set to 1 in TclInitThreadStorage. + */ + +static int nextThreadStorageKey = STORAGE_INVALID_KEY; + +/* + * This is the master thread storage cache. Per Kevin Kenny's idea, this + * prevents unnecessary lookups for threads that use a lot of thread storage. + */ + +static volatile ThreadStorage threadStorageCache[STORAGE_CACHE_SLOTS]; + +/* + *---------------------------------------------------------------------- + * + * AllocThreadStorageEntry -- + * + * Allocate space for a Tcl_HashEntry using TclpSysAlloc (not ckalloc). + * We do this because the threaded memory allocator MAY use the thread + * storage hash tables. + * + * Results: + * The return value is a pointer to the created entry. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashEntry * +AllocThreadStorageEntry( + Tcl_HashTable *tablePtr, /* Hash table. */ + void *keyPtr) /* Key to store in the hash table entry. */ +{ + Tcl_HashEntry *hPtr; + + hPtr = (Tcl_HashEntry *) TclpSysAlloc(sizeof(Tcl_HashEntry), 0); + hPtr->key.oneWordValue = keyPtr; + hPtr->clientData = NULL; + + return hPtr; +} + +/* + *---------------------------------------------------------------------- + * + * FreeThreadStorageEntry -- + * + * Frees space for a Tcl_HashEntry using TclpSysFree (not ckfree). We do + * this because the threaded memory allocator MAY use the thread storage + * hash tables. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +FreeThreadStorageEntry( + Tcl_HashEntry *hPtr) /* Hash entry to free. */ +{ + TclpSysFree((char *) hPtr); +} + +/* + *---------------------------------------------------------------------- + * + * ThreadStorageGetHashTable -- + * + * This procedure returns a hash table pointer to be used for thread + * storage for the specified thread. + * + * Results: + * A hash table pointer for the specified thread, or NULL if the hash + * table has not been created yet. + * + * Side effects: + * May change an entry in the master thread storage cache to point to the + * specified thread and it's associated hash table. + * + * Thread safety: + * This function assumes that integer operations are safe (atomic) + * on all (currently) supported Tcl platforms. Hence there are + * places where shared integer arithmetic is done w/o protective locks. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashTable * +ThreadStorageGetHashTable( + Tcl_ThreadId id) /* Id of thread to get hash table for */ +{ + int index = PTR2UINT(id) % STORAGE_CACHE_SLOTS; + Tcl_HashEntry *hPtr; + int isNew; + Tcl_HashTable *hashTablePtr; + + /* + * It's important that we pick up the hash table pointer BEFORE comparing + * thread Id in case another thread is in the critical region changing + * things out from under you. + * + * Thread safety: threadStorageCache is accessed w/o locks in order to + * avoid serialization of all threads at this hot-spot. It is safe to + * do this here because (threadStorageCache[index].id != id) test below + * should be atomic on all (currently) supported platforms and there + * are no devastatig side effects of the test. + * + * Note Valgrind users: this place will show up as a race-condition in + * helgrind-tool output. To silence this warnings, define VALGRIND + * symbol at compilation time. + */ + +#if !defined(VALGRIND) + hashTablePtr = threadStorageCache[index].hashTablePtr; + if (threadStorageCache[index].id != id) { + Tcl_MutexLock(&threadStorageLock); +#else + Tcl_MutexLock(&threadStorageLock); + hashTablePtr = threadStorageCache[index].hashTablePtr; + if (threadStorageCache[index].id != id) { +#endif + + /* + * It's not in the cache, so we look it up... + */ + + hPtr = Tcl_FindHashEntry(&threadStorageHashTable, (char *) id); + + if (hPtr != NULL) { + /* + * We found it, extract the hash table pointer. + */ + + hashTablePtr = Tcl_GetHashValue(hPtr); + } else { + /* + * The thread specific hash table is not found. + */ + + hashTablePtr = NULL; + } + + if (hashTablePtr == NULL) { + hashTablePtr = (Tcl_HashTable *) + TclpSysAlloc(sizeof(Tcl_HashTable), 0); + + if (hashTablePtr == NULL) { + Tcl_Panic("could not allocate thread specific hash table, " + "TclpSysAlloc failed from ThreadStorageGetHashTable!"); + } + Tcl_InitCustomHashTable(hashTablePtr, TCL_CUSTOM_TYPE_KEYS, + &tclThreadStorageHashKeyType); + + /* + * Add new thread storage hash table to the master hash table. + */ + + hPtr = Tcl_CreateHashEntry(&threadStorageHashTable, (char *) id, + &isNew); + + if (hPtr == NULL) { + Tcl_Panic("Tcl_CreateHashEntry failed from " + "ThreadStorageGetHashTable!"); + } + Tcl_SetHashValue(hPtr, hashTablePtr); + } + + /* + * Now, we put it in the cache since it is highly likely it will be + * needed again shortly. + */ + + threadStorageCache[index].id = id; + threadStorageCache[index].hashTablePtr = hashTablePtr; +#if !defined(VALGRIND) + Tcl_MutexUnlock(&threadStorageLock); + } +#else + } + Tcl_MutexUnlock(&threadStorageLock); +#endif + + return hashTablePtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclInitThreadStorage -- + * + * Initializes the thread storage allocator. * * Results: * None. * * Side effects: - * The table is enlarged. + * This procedure initializes the master hash table that maps thread ID + * onto the individual index tables that map thread data key to thread + * data. It also creates a cache that enables fast lookup of the thread + * data block array for a recently executing thread without using + * spinlocks. + * + * This procedure is called from an extremely early point in Tcl's + * initialization. In particular, it may not use ckalloc/ckfree because they + * may depend on thread-local storage (it uses TclpSysAlloc and TclpSysFree + * instead). It may not depend on synchronization primitives - but no threads + * other than the master thread have yet been launched. * *---------------------------------------------------------------------- */ -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; - } - - tsdTablePtr->allocated = newAllocated; - tsdTablePtr->tablePtr = newTablePtr; +void +TclInitThreadStorage(void) +{ + Tcl_InitCustomHashTable(&threadStorageHashTable, TCL_CUSTOM_TYPE_KEYS, + &tclThreadStorageHashKeyType); + + /* + * We also initialize the cache. + */ + + memset((void*) &threadStorageCache, 0, + sizeof(ThreadStorage) * STORAGE_CACHE_SLOTS); + + /* + * Now, we set the first value to be used for a thread data key. + */ + + nextThreadStorageKey = STORAGE_FIRST_KEY; } /* *---------------------------------------------------------------------- * - * TclThreadStorageKeyGet -- + * TclpThreadDataKeyGet -- * - * This procedure gets the value associated with the passed key. + * This procedure returns a pointer to a block of thread local storage. * * Results: - * A pointer value associated with the Tcl_ThreadDataKey or NULL. + * A thread-specific pointer to the data structure, or NULL if the memory + * has not been assigned to this key for this thread. * * Side effects: * None. * *---------------------------------------------------------------------- */ void * -TclThreadStorageKeyGet( - Tcl_ThreadDataKey *dataKeyPtr) -{ - TSDTable *tsdTablePtr = (TSDTable *)TclpThreadGetGlobalTSD(tsdGlobal.key); - ClientData resultPtr = NULL; - TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr; - sig_atomic_t offset = keyPtr->offset; - - if ((tsdTablePtr != NULL) && (offset > 0) - && (offset < tsdTablePtr->allocated)) { - resultPtr = tsdTablePtr->tablePtr[offset]; - } - return resultPtr; -} - -/* - *---------------------------------------------------------------------- - * - * TclThreadStorageKeySet -- - * - * This procedure set an association of value with the key passed. The - * associated value may be retrieved with TclThreadDataKeyGet(). - * - * Results: - * None. - * - * Side effects: - * The thread-specific table may be created or reallocated. - * - *---------------------------------------------------------------------- - */ - -void -TclThreadStorageKeySet( - Tcl_ThreadDataKey *dataKeyPtr, - void *value) -{ - TSDTable *tsdTablePtr = (TSDTable *)TclpThreadGetGlobalTSD(tsdGlobal.key); - TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr; - - if (tsdTablePtr == NULL) { - tsdTablePtr = TSDTableCreate(); - TclpThreadSetGlobalTSD(tsdGlobal.key, tsdTablePtr); - } - - /* - * Get the lock while we check if this TSD is new or not. Note that this - * is the only place where Tcl_ThreadDataKey values are set. We use a - * double-checked lock to try to avoid having to grab this lock a lot, - * since it is on quite a few critical paths and will only get set once in - * each location. - */ - - if (keyPtr->offset == 0) { - Tcl_MutexLock(&tsdGlobal.mutex); - if (keyPtr->offset == 0) { - /* - * The Tcl_ThreadDataKey hasn't been used yet. Make a new one. - */ - - keyPtr->offset = ++tsdGlobal.counter; - } - Tcl_MutexUnlock(&tsdGlobal.mutex); - } - - /* - * Check if this is the first time this Tcl_ThreadDataKey has been used - * with the current thread. Note that we don't need to hold a lock when - * doing this, as we are *definitely* the only point accessing this - * tsdTablePtr right now; it's thread-local. - */ - - if (keyPtr->offset >= tsdTablePtr->allocated) { - TSDTableGrow(tsdTablePtr, keyPtr->offset); - } - - /* - * Set the value in the Tcl thread-local variable. - */ - - tsdTablePtr->tablePtr[keyPtr->offset] = value; -} - -/* - *---------------------------------------------------------------------- - * - * TclFinalizeThreadDataThread -- - * - * This procedure finalizes the data for a single thread. - * - * Results: - * None. - * - * Side effects: - * The TSDTable is deleted/freed. - * - *---------------------------------------------------------------------- - */ - -void -TclFinalizeThreadDataThread(void) -{ - TSDTable *tsdTablePtr = (TSDTable *)TclpThreadGetGlobalTSD(tsdGlobal.key); - - if (tsdTablePtr != NULL) { - TSDTableDelete(tsdTablePtr); - TclpThreadSetGlobalTSD(tsdGlobal.key, NULL); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclInitializeThreadStorage -- - * - * This procedure initializes the TSD subsystem with per-platform code. - * This should be called before any Tcl threads are created. - * - * Results: - * None. - * - * Side effects: - * Allocates a system TSD. - * - *---------------------------------------------------------------------- - */ - -void -TclInitThreadStorage(void) -{ - tsdGlobal.key = TclpThreadCreateKey(); +TclpThreadDataKeyGet( + Tcl_ThreadDataKey *keyPtr) /* Identifier for the data chunk, really + * (int**) */ +{ + Tcl_HashTable *hashTablePtr = + ThreadStorageGetHashTable(Tcl_GetCurrentThread()); + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(hashTablePtr, (char *) keyPtr); + + if (hPtr == NULL) { + return NULL; + } + return Tcl_GetHashValue(hPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclpThreadDataKeySet -- + * + * This procedure sets the pointer to a block of thread local storage. + * + * Results: + * None. + * + * Side effects: + * Sets up the thread so future calls to TclpThreadDataKeyGet with this + * key will return the data pointer. + * + *---------------------------------------------------------------------- + */ + +void +TclpThreadDataKeySet( + Tcl_ThreadDataKey *keyPtr, /* Identifier for the data chunk, really + * (pthread_key_t **) */ + void *data) /* Thread local storage */ +{ + Tcl_HashTable *hashTablePtr; + Tcl_HashEntry *hPtr; + int dummy; + + hashTablePtr = ThreadStorageGetHashTable(Tcl_GetCurrentThread()); + hPtr = Tcl_CreateHashEntry(hashTablePtr, (char *)keyPtr, &dummy); + + Tcl_SetHashValue(hPtr, data); +} + +/* + *---------------------------------------------------------------------- + * + * TclpFinalizeThreadDataThread -- + * + * This procedure cleans up the thread storage hash table for the + * current thread. + * + * Results: + * None. + * + * Side effects: + * Frees all associated thread storage, all hash table entries for + * the thread's thread storage, and the hash table itself. + * + *---------------------------------------------------------------------- + */ + +void +TclpFinalizeThreadDataThread(void) +{ + Tcl_ThreadId id = Tcl_GetCurrentThread(); + /* Id of the thread to finalize. */ + int index = PTR2UINT(id) % STORAGE_CACHE_SLOTS; + Tcl_HashEntry *hPtr; /* Hash entry for current thread in master + * table. */ + Tcl_HashTable* hashTablePtr;/* Pointer to the hash table holding TSD + * blocks for the current thread*/ + Tcl_HashSearch search; /* Search object to walk the TSD blocks in the + * designated thread */ + Tcl_HashEntry *hPtr2; /* Hash entry for a TSD block in the + * designated thread. */ + + Tcl_MutexLock(&threadStorageLock); + hPtr = Tcl_FindHashEntry(&threadStorageHashTable, (char*)id); + if (hPtr == NULL) { + hashTablePtr = NULL; + } else { + /* + * We found it, extract the hash table pointer. + */ + + hashTablePtr = Tcl_GetHashValue(hPtr); + Tcl_DeleteHashEntry(hPtr); + + /* + * Make sure cache entry for this thread is NULL. + */ + + if (threadStorageCache[index].id == id) { + /* + * We do not step on another thread's cache entry. This is + * especially important if we are creating and exiting a lot of + * threads. + */ + + threadStorageCache[index].id = STORAGE_INVALID_THREAD; + threadStorageCache[index].hashTablePtr = NULL; + } + } + Tcl_MutexUnlock(&threadStorageLock); + + /* + * The thread's hash table has been extracted and removed from the master + * hash table. Now clean up the thread. + */ + + if (hashTablePtr != NULL) { + /* + * Free all TSD + */ + + for (hPtr2 = Tcl_FirstHashEntry(hashTablePtr, &search); hPtr2 != NULL; + hPtr2 = Tcl_NextHashEntry(&search)) { + void *blockPtr = Tcl_GetHashValue(hPtr2); + + if (blockPtr != NULL) { + /* + * The block itself was allocated in Tcl_GetThreadData using + * ckalloc; use ckfree to dispose of it. + */ + + ckfree(blockPtr); + } + } + + /* + * Delete thread specific hash table and free the struct. + */ + + Tcl_DeleteHashTable(hashTablePtr); + TclpSysFree((char *) hashTablePtr); + } } /* *---------------------------------------------------------------------- * * TclFinalizeThreadStorage -- * - * This procedure cleans up the thread storage data key for all threads. - * IMPORTANT: All Tcl threads must be finalized before calling this! + * This procedure cleans up the master thread storage hash table, all + * thread specific hash tables, and the thread storage cache. * * Results: * None. * * Side effects: - * Releases the thread data key. + * The master thread storage hash table and thread storage cache are + * reset to their initial (empty) state. * *---------------------------------------------------------------------- */ void TclFinalizeThreadStorage(void) { - TclpThreadDeleteKey(tsdGlobal.key); - tsdGlobal.key = NULL; + Tcl_HashSearch search; /* We need to hit every thread with this + * search. */ + Tcl_HashEntry *hPtr; /* Hash entry for current thread in master + * table. */ + Tcl_MutexLock(&threadStorageLock); + + /* + * We are going to delete the hash table for every thread now. This hash + * table should be empty at this point, except for one entry for the + * current thread. + */ + + for (hPtr = Tcl_FirstHashEntry(&threadStorageHashTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + Tcl_HashTable *hashTablePtr = Tcl_GetHashValue(hPtr); + + if (hashTablePtr != NULL) { + /* + * Delete thread specific hash table for the thread in question + * and free the struct. + */ + + Tcl_DeleteHashTable(hashTablePtr); + TclpSysFree((char *)hashTablePtr); + } + + /* + * Delete thread specific entry from master hash table. + */ + + Tcl_SetHashValue(hPtr, NULL); + } + + Tcl_DeleteHashTable(&threadStorageHashTable); + + /* + * Clear out the thread storage cache as well. + */ + + memset((void*) &threadStorageCache, 0, + sizeof(ThreadStorage) * STORAGE_CACHE_SLOTS); + + /* + * Reset this to zero, it will be set to STORAGE_FIRST_KEY if the thread + * storage subsystem gets reinitialized + */ + + nextThreadStorageKey = STORAGE_INVALID_KEY; + + Tcl_MutexUnlock(&threadStorageLock); } -#else /* !TCL_THREADS */ +#else /* !defined(TCL_THREADS) */ + /* * Stub functions for non-threaded builds */ void @@ -352,22 +575,23 @@ TclInitThreadStorage(void) { } void -TclFinalizeThreadDataThread(void) +TclpFinalizeThreadDataThread(void) { } void TclFinalizeThreadStorage(void) { } -#endif /* TCL_THREADS */ + +#endif /* defined(TCL_THREADS) && defined(USE_THREAD_STORAGE) */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclThreadTest.c ================================================================== --- generic/tclThreadTest.c +++ generic/tclThreadTest.c @@ -5,22 +5,20 @@ * tclThreadCmd.c * Some of this code is based on work done by Richard Hipp on behalf of * Conservation Through Innovation, Limited, with their permission. * * Copyright (c) 1998 by Sun Microsystems, Inc. - * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#ifndef USE_TCL_STUBS -# define USE_TCL_STUBS -#endif #include "tclInt.h" -#if TCL_THREADS +extern int Tcltest_Init(Tcl_Interp *interp); + +#ifdef TCL_THREADS /* * Each thread has an single instance of the following structure. There is one * instance of this structure per thread even if that thread contains multiple * interpreters. The interpreter identified by this structure is the main * interpreter for the thread. @@ -29,42 +27,39 @@ * a thread. Any thread can send messages but only the main interpreter can * receive them. */ typedef struct ThreadSpecificData { - Tcl_ThreadId threadId; /* Tcl ID for this thread */ - Tcl_Interp *interp; /* Main interpreter for this thread */ - int flags; /* See the TP_ defines below... */ - struct ThreadSpecificData *nextPtr; - /* List for "thread names" */ - struct ThreadSpecificData *prevPtr; - /* List for "thread names" */ + Tcl_ThreadId threadId; /* Tcl ID for this thread */ + Tcl_Interp *interp; /* Main interpreter for this thread */ + int flags; /* See the TP_ defines below... */ + struct ThreadSpecificData *nextPtr; /* List for "thread names" */ + struct ThreadSpecificData *prevPtr; /* List for "thread names" */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* * This list is used to list all threads that have interpreters. This is * protected by threadMutex. */ -static ThreadSpecificData *threadList = NULL; +static struct ThreadSpecificData *threadList; /* * The following bit-values are legal for the "flags" field of the * ThreadSpecificData structure. */ - -#define TP_Dying 0x001 /* This thread is being canceled */ +#define TP_Dying 0x001 /* This thread is being cancelled */ /* * An instance of the following structure contains all information that is * passed into a new thread when the thread is created using either the - * "thread create" Tcl command or the ThreadCreate() C function. + * "thread create" Tcl command or the TclCreateThread() C function. */ typedef struct ThreadCtrl { - const char *script; /* The Tcl command this thread should + const char *script; /* The Tcl command this thread should * execute */ int flags; /* Initial value of the "flags" field in the * ThreadSpecificData structure for the new * thread. Might contain TP_Detached or * TP_TclThread. */ @@ -106,11 +101,10 @@ /* * This is for simple error handling when a thread script exits badly. */ -static Tcl_ThreadId mainThreadId; static Tcl_ThreadId errorThreadId; static char *errorProcString; /* * Access to the list of threads and to the thread send results is guarded by @@ -117,41 +111,45 @@ * this mutex. */ TCL_DECLARE_MUTEX(threadMutex) -static int ThreadObjCmd(void *clientData, +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLEXPORT + +EXTERN int TclThread_Init(Tcl_Interp *interp); +EXTERN int Tcl_ThreadObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int ThreadCreate(Tcl_Interp *interp, const char *script, +EXTERN int TclCreateThread(Tcl_Interp *interp, const char *script, int joinable); -static int ThreadList(Tcl_Interp *interp); -static int ThreadSend(Tcl_Interp *interp, Tcl_ThreadId id, +EXTERN int TclThreadList(Tcl_Interp *interp); +EXTERN int TclThreadSend(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); +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLIMPORT + +Tcl_ThreadCreateType NewTestThread(ClientData 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 void ThreadFreeProc(ClientData clientData); static int ThreadDeleteEvent(Tcl_Event *eventPtr, - void *clientData); -static void ThreadExitProc(void *clientData); -extern int Tcltest_Init(Tcl_Interp *interp); + ClientData clientData); +static void ThreadExitProc(ClientData clientData); /* *---------------------------------------------------------------------- * * TclThread_Init -- * * Initialize the test thread command. * * Results: - * TCL_OK if the package was properly initialized. + * TCL_OK if the package was properly initialized. * * Side effects: * Add the "testthread" command to the interp. * *---------------------------------------------------------------------- @@ -159,38 +157,29 @@ int TclThread_Init( Tcl_Interp *interp) /* The current Tcl interpreter */ { - /* - * If the main thread Id has not been set, do it now. - */ - - Tcl_MutexLock(&threadMutex); - if (mainThreadId == 0) { - mainThreadId = Tcl_GetCurrentThread(); - } - Tcl_MutexUnlock(&threadMutex); - - Tcl_CreateObjCommand(interp, "testthread", ThreadObjCmd, NULL, NULL); + + Tcl_CreateObjCommand(interp, "testthread", Tcl_ThreadObjCmd, + (ClientData) NULL, NULL); return TCL_OK; } + /* *---------------------------------------------------------------------- * - * ThreadObjCmd -- + * Tcl_ThreadObjCmd -- * * This procedure is invoked to process the "testthread" Tcl command. See * the user documentation for details on what it does. * - * thread cancel ?-unwind? id ?result? * thread create ?-joinable? ?script? - * thread send ?-async? id script - * thread event + * thread send id ?-async? script * thread exit - * thread id ?-main? + * thread info id * thread names * thread wait * thread errorproc proc * thread join id * @@ -201,32 +190,31 @@ * See the user documentation. * *---------------------------------------------------------------------- */ -static int -ThreadObjCmd( - TCL_UNUSED(void *), + /* ARGSUSED */ +int +Tcl_ThreadObjCmd( + ClientData dummy, /* Not used. */ 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[] = { - "cancel", "create", "event", "exit", "id", - "join", "names", "send", "wait", "errorproc", - NULL + static const char *threadOptions[] = { + "create", "exit", "id", "join", "names", + "send", "wait", "errorproc", NULL }; enum options { - THREAD_CANCEL, THREAD_CREATE, THREAD_EVENT, THREAD_EXIT, - THREAD_ID, THREAD_JOIN, THREAD_NAMES, THREAD_SEND, - THREAD_WAIT, THREAD_ERRORPROC + THREAD_CREATE, THREAD_EXIT, THREAD_ID, THREAD_JOIN, THREAD_NAMES, + THREAD_SEND, THREAD_WAIT, THREAD_ERRORPROC }; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "option ?args?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], threadOptions, "option", 0, &option) != TCL_OK) { return TCL_ERROR; @@ -243,38 +231,10 @@ Tcl_CreateThreadExitHandler(ThreadExitProc, NULL); Tcl_MutexUnlock(&threadMutex); } switch ((enum options)option) { - case THREAD_CANCEL: { - Tcl_WideInt id; - const char *result; - int flags, arg; - - if ((objc < 3) || (objc > 5)) { - Tcl_WrongNumArgs(interp, 2, objv, "?-unwind? id ?result?"); - return TCL_ERROR; - } - flags = 0; - arg = 2; - if ((objc == 4) || (objc == 5)) { - if (strcmp("-unwind", Tcl_GetString(objv[arg])) == 0) { - flags = TCL_CANCEL_UNWIND; - arg++; - } - } - if (Tcl_GetWideIntFromObj(interp, objv[arg], &id) != TCL_OK) { - return TCL_ERROR; - } - arg++; - if (arg < objc) { - result = Tcl_GetString(objv[arg]); - } else { - result = NULL; - } - return ThreadCancel(interp, (Tcl_ThreadId) (size_t) id, result, flags); - } case THREAD_CREATE: { const char *script; int joinable, len; if (objc == 2) { @@ -290,12 +250,13 @@ * its a script. */ script = Tcl_GetStringFromObj(objv[2], &len); - if ((len > 1) && (script[0] == '-') && (script[1] == 'j') && - (0 == strncmp(script, "-joinable", 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 @@ -307,18 +268,21 @@ /* * Definitely a script available, but is the flag -joinable? */ script = Tcl_GetStringFromObj(objv[2], &len); - joinable = ((len > 1) && (script[0] == '-') && (script[1] == 'j') - && (0 == strncmp(script, "-joinable", len))); + + 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); + return TclCreateThread(interp, script, joinable); } case THREAD_EXIT: if (objc > 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; @@ -325,28 +289,12 @@ } ListRemove(NULL); Tcl_ExitThread(0); return TCL_OK; case THREAD_ID: - if (objc == 2 || objc == 3) { - Tcl_Obj *idObj; - - /* - * Check if they want the main thread id or the current thread id. - */ - - if (objc == 2) { - idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)Tcl_GetCurrentThread()); - } else if (objc == 3 - && strcmp("-main", Tcl_GetString(objv[2])) == 0) { - Tcl_MutexLock(&threadMutex); - idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)mainThreadId); - Tcl_MutexUnlock(&threadMutex); - } else { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; - } + if (objc == 2) { + Tcl_Obj *idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t) Tcl_GetCurrentThread()); Tcl_SetObjResult(interp, idObj); return TCL_OK; } else { Tcl_WrongNumArgs(interp, 2, objv, NULL); @@ -362,15 +310,15 @@ } if (Tcl_GetWideIntFromObj(interp, objv[2], &id) != TCL_OK) { return TCL_ERROR; } - result = Tcl_JoinThread((Tcl_ThreadId)(size_t)id, &status); + result = Tcl_JoinThread ((Tcl_ThreadId)(size_t)id, &status); if (result == TCL_OK) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), status); + Tcl_SetIntObj (Tcl_GetObjResult (interp), status); } else { - char buf[20]; + char buf [20]; sprintf(buf, "%" TCL_LL_MODIFIER "d", id); Tcl_AppendResult(interp, "cannot join thread ", buf, NULL); } return result; @@ -378,11 +326,11 @@ case THREAD_NAMES: if (objc > 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - return ThreadList(interp); + return TclThreadList(interp); case THREAD_SEND: { Tcl_WideInt id; const char *script; int wait, arg; @@ -404,81 +352,46 @@ if (Tcl_GetWideIntFromObj(interp, objv[arg], &id) != TCL_OK) { return TCL_ERROR; } arg++; script = Tcl_GetString(objv[arg]); - return ThreadSend(interp, (Tcl_ThreadId)(size_t)id, script, wait); - } - case THREAD_EVENT: { - if (objc > 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj( - Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT))); - return TCL_OK; + return TclThreadSend(interp, (Tcl_ThreadId)(size_t)id, script, wait); } case THREAD_ERRORPROC: { /* * Arrange for this proc to handle thread death errors. */ - const char *proc; + char *proc; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "proc"); return TCL_ERROR; } Tcl_MutexLock(&threadMutex); errorThreadId = Tcl_GetCurrentThread(); if (errorProcString) { - Tcl_Free(errorProcString); + ckfree(errorProcString); } proc = Tcl_GetString(objv[2]); - errorProcString = (char *)Tcl_Alloc(strlen(proc) + 1); + errorProcString = ckalloc(strlen(proc)+1); strcpy(errorProcString, proc); Tcl_MutexUnlock(&threadMutex); return TCL_OK; } case THREAD_WAIT: - if (objc > 2) { - Tcl_WrongNumArgs(interp, 2, objv, ""); - return TCL_ERROR; - } while (1) { - /* - * If the script has been unwound, bail out immediately. This does - * not follow the recommended guidelines for how extensions should - * handle the script cancellation functionality because this is - * not a "normal" extension. Most extensions do not have a command - * that simply enters an infinite Tcl event loop. Normal - * extensions should not specify the TCL_CANCEL_UNWIND when - * calling Tcl_Canceled to check if the command has been canceled. - */ - - if (Tcl_Canceled(interp, - TCL_LEAVE_ERR_MSG | TCL_CANCEL_UNWIND) == TCL_ERROR) { - break; - } (void) Tcl_DoOneEvent(TCL_ALL_EVENTS); } - - /* - * If we get to this point, we have been canceled by another thread, - * which is considered to be an "error". - */ - - ThreadErrorProc(interp); - return TCL_OK; } return TCL_OK; } /* *---------------------------------------------------------------------- * - * ThreadCreate -- + * TclCreateThread -- * * This procedure is invoked to create a thread containing an interp to * run a script. This returns after the thread has started executing. * * Results: @@ -488,12 +401,13 @@ * Create a thread. * *---------------------------------------------------------------------- */ -static int -ThreadCreate( + /* ARGSUSED */ +int +TclCreateThread( Tcl_Interp *interp, /* Current interpreter. */ const char *script, /* Script to execute */ int joinable) /* Flag, joinable thread or not */ { ThreadCtrl ctrl; @@ -504,14 +418,14 @@ ctrl.flags = 0; joinable = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS; Tcl_MutexLock(&threadMutex); - if (Tcl_CreateThread(&id, NewTestThread, &ctrl, + if (Tcl_CreateThread(&id, NewTestThread, (ClientData) &ctrl, TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) { Tcl_MutexUnlock(&threadMutex); - Tcl_AppendResult(interp, "can't create a new thread", NULL); + Tcl_AppendResult(interp, "can't create a new thread", NULL); return TCL_ERROR; } /* * Wait for the thread to start because it is using something on our stack! @@ -552,36 +466,31 @@ *------------------------------------------------------------------------ */ Tcl_ThreadCreateType NewTestThread( - void *clientData) + ClientData clientData) { - ThreadCtrl *ctrlPtr = (ThreadCtrl *)clientData; + ThreadCtrl *ctrlPtr = (ThreadCtrl*)clientData; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); int result; char *threadEvalScript; /* - * Initialize the interpreter. This should be more general. + * Initialize the interpreter. This should be more general. */ tsdPtr->interp = Tcl_CreateInterp(); result = Tcl_Init(tsdPtr->interp); - if (result != TCL_OK) { - ThreadErrorProc(tsdPtr->interp); - } + result = TclThread_Init(tsdPtr->interp); /* * This is part of the test facility. Initialize _ALL_ test commands for * use by the new thread. */ result = Tcltest_Init(tsdPtr->interp); - if (result != TCL_OK) { - ThreadErrorProc(tsdPtr->interp); - } /* * Update the list of threads. */ @@ -591,14 +500,14 @@ /* * 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 *)Tcl_Alloc(strlen(ctrlPtr->script) + 1); + threadEvalScript = ckalloc(strlen(ctrlPtr->script)+1); strcpy(threadEvalScript, ctrlPtr->script); - Tcl_CreateThreadExitHandler(ThreadExitProc, threadEvalScript); + Tcl_CreateThreadExitHandler(ThreadExitProc, (ClientData) threadEvalScript); /* * Notify the parent we are alive. */ @@ -607,23 +516,23 @@ /* * Run the script. */ - Tcl_Preserve(tsdPtr->interp); - result = Tcl_EvalEx(tsdPtr->interp, threadEvalScript, -1, 0); + Tcl_Preserve((ClientData) tsdPtr->interp); + result = Tcl_Eval(tsdPtr->interp, threadEvalScript); if (result != TCL_OK) { ThreadErrorProc(tsdPtr->interp); } /* * Clean up. */ - Tcl_DeleteInterp(tsdPtr->interp); - Tcl_Release(tsdPtr->interp); ListRemove(tsdPtr); + Tcl_Release((ClientData) tsdPtr->interp); + Tcl_DeleteInterp(tsdPtr->interp); Tcl_ExitThread(result); TCL_THREAD_CREATE_RETURN; } @@ -649,14 +558,13 @@ { Tcl_Channel errChannel; const char *errorInfo, *argv[3]; char *script; char buf[TCL_DOUBLE_SPACE+1]; - - sprintf(buf, "%p", Tcl_GetCurrentThread()); + sprintf(buf, "%" TCL_LL_MODIFIER "d", (Tcl_WideInt)(size_t)Tcl_GetCurrentThread()); - errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY); + errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); if (errorProcString == NULL) { errChannel = Tcl_GetStdChannel(TCL_STDERR); Tcl_WriteChars(errChannel, "Error from thread ", -1); Tcl_WriteChars(errChannel, buf, -1); Tcl_WriteChars(errChannel, "\n", 1); @@ -665,12 +573,12 @@ } else { argv[0] = errorProcString; argv[1] = buf; argv[2] = errorInfo; script = Tcl_Merge(3, argv); - ThreadSend(interp, errorThreadId, script, 0); - Tcl_Free(script); + TclThreadSend(interp, errorThreadId, script, 0); + ckfree(script); } } /* @@ -738,18 +646,17 @@ } if (tsdPtr->nextPtr) { tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; } tsdPtr->nextPtr = tsdPtr->prevPtr = 0; - tsdPtr->interp = NULL; Tcl_MutexUnlock(&threadMutex); } /* *------------------------------------------------------------------------ * - * ThreadList -- + * TclThreadList -- * * Return a list of threads running Tcl interpreters. * * Results: * A standard Tcl result. @@ -757,12 +664,12 @@ * Side effects: * None. * *------------------------------------------------------------------------ */ -static int -ThreadList( +int +TclThreadList( Tcl_Interp *interp) { ThreadSpecificData *tsdPtr; Tcl_Obj *listPtr; @@ -778,11 +685,11 @@ } /* *------------------------------------------------------------------------ * - * ThreadSend -- + * TclThreadSend -- * * Send a script to another thread. * * Results: * A standard Tcl result. @@ -791,12 +698,12 @@ * None. * *------------------------------------------------------------------------ */ -static int -ThreadSend( +int +TclThreadSend( Tcl_Interp *interp, /* The current interpreter. */ Tcl_ThreadId id, /* Thread Id of other interpreter. */ const char *script, /* The script to evaluate. */ int wait) /* If 1, we block for the result. */ { @@ -828,25 +735,25 @@ * Short circut sends to ourself. Ought to do something with -async, like * run in an idle handler. */ if (threadId == Tcl_GetCurrentThread()) { - Tcl_MutexUnlock(&threadMutex); - return Tcl_EvalEx(interp, script,-1,TCL_EVAL_GLOBAL); + Tcl_MutexUnlock(&threadMutex); + return Tcl_GlobalEval(interp, script); } /* * Create the event for its event queue. */ - threadEventPtr = (ThreadEvent*)Tcl_Alloc(sizeof(ThreadEvent)); - threadEventPtr->script = (char *)Tcl_Alloc(strlen(script) + 1); + threadEventPtr = (ThreadEvent *) ckalloc(sizeof(ThreadEvent)); + threadEventPtr->script = ckalloc(strlen(script) + 1); strcpy(threadEventPtr->script, script); if (!wait) { resultPtr = threadEventPtr->resultPtr = NULL; } else { - resultPtr = (ThreadEventResult *)Tcl_Alloc(sizeof(ThreadEventResult)); + resultPtr = (ThreadEventResult *) ckalloc(sizeof(ThreadEventResult)); threadEventPtr->resultPtr = resultPtr; /* * Initialize the result fields. */ @@ -875,11 +782,11 @@ /* * Queue the event and poke the other thread's notifier. */ threadEventPtr->event.proc = ThreadEventProc; - Tcl_ThreadQueueEvent(threadId, (Tcl_Event *) threadEventPtr, + Tcl_ThreadQueueEvent(threadId, (Tcl_Event *)threadEventPtr, TCL_QUEUE_TAIL); Tcl_ThreadAlert(threadId); if (!wait) { Tcl_MutexUnlock(&threadMutex); @@ -890,11 +797,11 @@ * Block on the results and then get them. */ Tcl_ResetResult(interp); while (resultPtr->result == NULL) { - Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL); + Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL); } /* * Unlink result from the result list. */ @@ -914,82 +821,25 @@ Tcl_MutexUnlock(&threadMutex); if (resultPtr->code != TCL_OK) { if (resultPtr->errorCode) { Tcl_SetErrorCode(interp, resultPtr->errorCode, NULL); - Tcl_Free(resultPtr->errorCode); + ckfree(resultPtr->errorCode); } if (resultPtr->errorInfo) { Tcl_AddErrorInfo(interp, resultPtr->errorInfo); - Tcl_Free(resultPtr->errorInfo); + ckfree(resultPtr->errorInfo); } } - Tcl_AppendResult(interp, resultPtr->result, NULL); + Tcl_SetResult(interp, resultPtr->result, TCL_DYNAMIC); Tcl_ConditionFinalize(&resultPtr->done); code = resultPtr->code; - Tcl_Free(resultPtr->result); - Tcl_Free(resultPtr); + ckfree((char *) resultPtr); return code; } - -/* - *------------------------------------------------------------------------ - * - * ThreadCancel -- - * - * Cancels a script in another thread. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------ - */ - -static int -ThreadCancel( - Tcl_Interp *interp, /* The current interpreter. */ - Tcl_ThreadId id, /* Thread Id of other interpreter. */ - const char *result, /* The result or NULL for default. */ - int flags) /* Flags for Tcl_CancelEval. */ -{ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - int found; - Tcl_ThreadId threadId = (Tcl_ThreadId) id; - - /* - * Verify the thread exists. - */ - - Tcl_MutexLock(&threadMutex); - found = 0; - for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) { - if (tsdPtr->threadId == threadId) { - found = 1; - break; - } - } - if (!found) { - Tcl_MutexUnlock(&threadMutex); - Tcl_AppendResult(interp, "invalid thread id", NULL); - return TCL_ERROR; - } - - /* - * Since Tcl_CancelEval can be safely called from any thread, - * we do it now. - */ - - Tcl_MutexUnlock(&threadMutex); - Tcl_ResetResult(interp); - return Tcl_CancelEval(tsdPtr->interp, - (result != NULL) ? Tcl_NewStringObj(result, -1) : NULL, 0, flags); -} /* *------------------------------------------------------------------------ * * ThreadEventProc -- @@ -1006,14 +856,14 @@ */ static int ThreadEventProc( Tcl_Event *evPtr, /* Really ThreadEvent */ - TCL_UNUSED(int) /*mask*/) + int mask) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - ThreadEvent *threadEventPtr = (ThreadEvent *) evPtr; + ThreadEvent *threadEventPtr = (ThreadEvent *)evPtr; ThreadEventResult *resultPtr = threadEventPtr->resultPtr; Tcl_Interp *interp = tsdPtr->interp; int code; const char *result, *errorCode, *errorInfo; @@ -1021,42 +871,44 @@ code = TCL_ERROR; result = "no target interp!"; errorCode = "THREAD"; errorInfo = ""; } else { - Tcl_Preserve(interp); + Tcl_Preserve((ClientData) interp); Tcl_ResetResult(interp); - Tcl_CreateThreadExitHandler(ThreadFreeProc, threadEventPtr->script); - code = Tcl_EvalEx(interp, threadEventPtr->script,-1,TCL_EVAL_GLOBAL); - Tcl_DeleteThreadExitHandler(ThreadFreeProc, threadEventPtr->script); + Tcl_CreateThreadExitHandler(ThreadFreeProc, + (ClientData) threadEventPtr->script); + code = Tcl_GlobalEval(interp, threadEventPtr->script); + Tcl_DeleteThreadExitHandler(ThreadFreeProc, + (ClientData) threadEventPtr->script); if (code != TCL_OK) { - errorCode = Tcl_GetVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY); - errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY); + errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY); + errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); } else { errorCode = errorInfo = NULL; } result = Tcl_GetStringResult(interp); } - Tcl_Free(threadEventPtr->script); + ckfree(threadEventPtr->script); if (resultPtr) { Tcl_MutexLock(&threadMutex); resultPtr->code = code; - resultPtr->result = (char *)Tcl_Alloc(strlen(result) + 1); + resultPtr->result = ckalloc(strlen(result) + 1); strcpy(resultPtr->result, result); if (errorCode != NULL) { - resultPtr->errorCode = (char *)Tcl_Alloc(strlen(errorCode) + 1); + resultPtr->errorCode = ckalloc(strlen(errorCode) + 1); strcpy(resultPtr->errorCode, errorCode); } if (errorInfo != NULL) { - resultPtr->errorInfo = (char *)Tcl_Alloc(strlen(errorInfo) + 1); + resultPtr->errorInfo = ckalloc(strlen(errorInfo) + 1); strcpy(resultPtr->errorInfo, errorInfo); } Tcl_ConditionNotify(&resultPtr->done); Tcl_MutexUnlock(&threadMutex); } if (interp != NULL) { - Tcl_Release(interp); + Tcl_Release((ClientData) interp); } return 1; } /* @@ -1069,21 +921,22 @@ * * Results: * None. * * Side effects: - * Clears up mem specified in clientData + * Clears up mem specified in ClientData * *------------------------------------------------------------------------ */ + /* ARGSUSED */ static void ThreadFreeProc( - void *clientData) + ClientData clientData) { if (clientData) { - Tcl_Free(clientData); + ckfree((char *) clientData); } } /* *------------------------------------------------------------------------ @@ -1100,17 +953,18 @@ * It cleans up our events in the event queue for this thread. * *------------------------------------------------------------------------ */ + /* ARGSUSED */ static int ThreadDeleteEvent( Tcl_Event *eventPtr, /* Really ThreadEvent */ - TCL_UNUSED(void *)) + ClientData clientData) /* dummy */ { if (eventPtr->proc == ThreadEventProc) { - Tcl_Free(((ThreadEvent *) eventPtr)->script); + ckfree((char *) ((ThreadEvent *) eventPtr)->script); return 1; } /* * If it was NULL, we were in the middle of servicing the event and it @@ -1135,38 +989,26 @@ * up any events in the event queue for this thread. * *------------------------------------------------------------------------ */ + /* ARGSUSED */ static void ThreadExitProc( - void *clientData) + ClientData clientData) { - char *threadEvalScript = (char *)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 */ - Tcl_Free(errorProcString); - errorProcString = NULL; - } - errorThreadId = 0; - } - if (threadEvalScript) { - Tcl_Free(threadEvalScript); + ckfree((char *) threadEvalScript); threadEvalScript = NULL; } - Tcl_DeleteEvents((Tcl_EventDeleteProc *) ThreadDeleteEvent, NULL); + Tcl_DeleteEvents((Tcl_EventDeleteProc *)ThreadDeleteEvent, NULL); for (resultPtr = resultList ; resultPtr ; resultPtr = nextPtr) { nextPtr = resultPtr->nextPtr; if (resultPtr->srcThreadId == self) { /* @@ -1182,21 +1024,21 @@ if (resultPtr->nextPtr) { resultPtr->nextPtr->prevPtr = resultPtr->prevPtr; } resultPtr->nextPtr = resultPtr->prevPtr = 0; resultPtr->eventPtr->resultPtr = NULL; - Tcl_Free(resultPtr); + ckfree((char *) 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 *)Tcl_Alloc(strlen(msg) + 1); + resultPtr->result = ckalloc(strlen(msg)+1); strcpy(resultPtr->result, msg); resultPtr->code = TCL_ERROR; Tcl_ConditionNotify(&resultPtr->done); } } Index: generic/tclTimer.c ================================================================== --- generic/tclTimer.c +++ generic/tclTimer.c @@ -70,11 +70,11 @@ * in a call to Tcl_DoWhenIdle. All of the currently-active handlers are * linked together into a list. */ typedef struct IdleHandler { - Tcl_IdleProc *proc; /* Function to call. */ + Tcl_IdleProc (*proc); /* Function to call. */ ClientData clientData; /* Value to pass to proc. */ int generation; /* Used to distinguish older handlers from * recently-created ones. */ struct IdleHandler *nextPtr;/* Next in list of active handlers. */ } IdleHandler; @@ -89,11 +89,11 @@ * * Notice that different structures with the same name appear in other files. * The structure defined below is used in this file only. */ -typedef struct { +typedef struct ThreadSpecificData { TimerHandler *firstTimerHandlerPtr; /* First event in queue. */ int lastTimerId; /* Timer identifier of most recently created * timer. */ int timerPending; /* 1 if a timer event is in the queue. */ IdleHandler *idleList; /* First in list of all idle handlers. */ @@ -125,29 +125,10 @@ #define TCL_TIME_DIFF_MS(t1, t2) \ (1000*((Tcl_WideInt)(t1).sec - (Tcl_WideInt)(t2).sec) + \ ((long)(t1).usec - (long)(t2).usec)/1000) -#define TCL_TIME_DIFF_MS_CEILING(t1, t2) \ - (1000*((Tcl_WideInt)(t1).sec - (Tcl_WideInt)(t2).sec) + \ - ((long)(t1).usec - (long)(t2).usec + 999)/1000) - -/* - * Sleeps under that number of milliseconds don't get double-checked - * and are done in exactly one Tcl_Sleep(). This to limit gettimeofday()s. - */ - -#define SLEEP_OFFLOAD_GETTIMEOFDAY 20 - -/* - * The maximum number of milliseconds for each Tcl_Sleep call in AfterDelay. - * This is used to limit the maximum lag between interp limit and script - * cancellation checks. - */ - -#define TCL_TIME_MAXIMUM_SLICE 500 - /* * Prototypes for functions referenced only in this file: */ static void AfterCleanupProc(ClientData clientData, @@ -180,11 +161,12 @@ */ static ThreadSpecificData * InitTimer(void) { - ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) + TclThreadDataKeyGet(&dataKey); if (tsdPtr == NULL) { tsdPtr = TCL_TSD_INIT(&dataKey); Tcl_CreateEventSource(TimerSetupProc, TimerCheckProc, NULL); Tcl_CreateThreadExitHandler(TimerExitProc, NULL); @@ -209,22 +191,23 @@ *---------------------------------------------------------------------- */ static void TimerExitProc( - TCL_UNUSED(ClientData)) + ClientData clientData) /* Not used. */ { - ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) + TclThreadDataKeyGet(&dataKey); Tcl_DeleteEventSource(TimerSetupProc, TimerCheckProc, NULL); if (tsdPtr != NULL) { - TimerHandler *timerHandlerPtr; + register TimerHandler *timerHandlerPtr; timerHandlerPtr = tsdPtr->firstTimerHandlerPtr; while (timerHandlerPtr != NULL) { tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr; - Tcl_Free(timerHandlerPtr); + ckfree((char *) timerHandlerPtr); timerHandlerPtr = tsdPtr->firstTimerHandlerPtr; } } } @@ -292,28 +275,29 @@ TclCreateAbsoluteTimerHandler( Tcl_Time *timePtr, Tcl_TimerProc *proc, ClientData clientData) { - TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr; - ThreadSpecificData *tsdPtr = InitTimer(); + register TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr; + ThreadSpecificData *tsdPtr; - timerHandlerPtr = (TimerHandler *)Tcl_Alloc(sizeof(TimerHandler)); + tsdPtr = InitTimer(); + timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler)); /* * Fill in fields for the event. */ - memcpy(&timerHandlerPtr->time, timePtr, sizeof(Tcl_Time)); + memcpy((void *)&timerHandlerPtr->time, (void *)timePtr, sizeof(Tcl_Time)); timerHandlerPtr->proc = proc; timerHandlerPtr->clientData = clientData; tsdPtr->lastTimerId++; timerHandlerPtr->token = (Tcl_TimerToken) INT2PTR(tsdPtr->lastTimerId); /* - * Add the event to the queue in the correct position (ordered by event - * firing time). + * Add the event to the queue in the correct position + * (ordered by event firing time). */ for (tPtr2 = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL; prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) { if (TCL_TIME_BEFORE(timerHandlerPtr->time, tPtr2->time)) { @@ -353,11 +337,11 @@ void Tcl_DeleteTimerHandler( Tcl_TimerToken token) /* Result previously returned by * Tcl_DeleteTimerHandler. */ { - TimerHandler *timerHandlerPtr, *prevPtr; + register TimerHandler *timerHandlerPtr, *prevPtr; ThreadSpecificData *tsdPtr = InitTimer(); if (token == NULL) { return; } @@ -371,11 +355,11 @@ if (prevPtr == NULL) { tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr; } else { prevPtr->nextPtr = timerHandlerPtr->nextPtr; } - Tcl_Free(timerHandlerPtr); + ckfree((char *) timerHandlerPtr); return; } } /* @@ -396,11 +380,11 @@ *---------------------------------------------------------------------- */ static void TimerSetupProc( - TCL_UNUSED(ClientData), + ClientData data, /* Not used. */ int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { Tcl_Time blockTime; ThreadSpecificData *tsdPtr = InitTimer(); @@ -410,10 +394,11 @@ * There is an idle handler or a pending timer event, so just poll. */ blockTime.sec = 0; blockTime.usec = 0; + } else if ((flags & TCL_TIMER_EVENTS) && tsdPtr->firstTimerHandlerPtr) { /* * Compute the timeout for the next timer on the list. */ @@ -454,11 +439,11 @@ *---------------------------------------------------------------------- */ static void TimerCheckProc( - TCL_UNUSED(ClientData), + ClientData data, /* Not used. */ int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { Tcl_Event *timerEvPtr; Tcl_Time blockTime; ThreadSpecificData *tsdPtr = InitTimer(); @@ -486,11 +471,11 @@ */ if (blockTime.sec == 0 && blockTime.usec == 0 && !tsdPtr->timerPending) { tsdPtr->timerPending = 1; - timerEvPtr = (Tcl_Event *)Tcl_Alloc(sizeof(Tcl_Event)); + timerEvPtr = (Tcl_Event *) ckalloc(sizeof(Tcl_Event)); timerEvPtr->proc = TimerHandlerEventProc; Tcl_QueueEvent(timerEvPtr, TCL_QUEUE_TAIL); } } } @@ -516,11 +501,11 @@ *---------------------------------------------------------------------- */ static int TimerHandlerEventProc( - TCL_UNUSED(Tcl_Event *), + Tcl_Event *evPtr, /* Event to service. */ int flags) /* Flags that indicate what events to handle, * such as TCL_FILE_EVENTS. */ { TimerHandler *timerHandlerPtr, **nextPtrPtr; Tcl_Time time; @@ -587,13 +572,13 @@ /* * Remove the handler from the queue before invoking it, to avoid * potential reentrancy problems. */ - *nextPtrPtr = timerHandlerPtr->nextPtr; - timerHandlerPtr->proc(timerHandlerPtr->clientData); - Tcl_Free(timerHandlerPtr); + (*nextPtrPtr) = timerHandlerPtr->nextPtr; + (*timerHandlerPtr->proc)(timerHandlerPtr->clientData); + ckfree((char *) timerHandlerPtr); } TimerSetupProc(NULL, TCL_TIMER_EVENTS); return 1; } @@ -619,15 +604,15 @@ void Tcl_DoWhenIdle( Tcl_IdleProc *proc, /* Function to invoke. */ ClientData clientData) /* Arbitrary value to pass to proc. */ { - IdleHandler *idlePtr; + register IdleHandler *idlePtr; Tcl_Time blockTime; ThreadSpecificData *tsdPtr = InitTimer(); - idlePtr = (IdleHandler *)Tcl_Alloc(sizeof(IdleHandler)); + idlePtr = (IdleHandler *) ckalloc(sizeof(IdleHandler)); idlePtr->proc = proc; idlePtr->clientData = clientData; idlePtr->generation = tsdPtr->idleGeneration; idlePtr->nextPtr = NULL; if (tsdPtr->lastIdlePtr == NULL) { @@ -663,20 +648,20 @@ void Tcl_CancelIdleCall( Tcl_IdleProc *proc, /* Function that was previously registered. */ ClientData clientData) /* Arbitrary value to pass to proc. */ { - IdleHandler *idlePtr, *prevPtr; + register 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; - Tcl_Free(idlePtr); + ckfree((char *) idlePtr); idlePtr = nextPtr; if (prevPtr == NULL) { tsdPtr->idleList = idlePtr; } else { prevPtr->nextPtr = idlePtr; @@ -746,12 +731,12 @@ idlePtr = tsdPtr->idleList) { tsdPtr->idleList = idlePtr->nextPtr; if (tsdPtr->idleList == NULL) { tsdPtr->lastIdlePtr = NULL; } - idlePtr->proc(idlePtr->clientData); - Tcl_Free(idlePtr); + (*idlePtr->proc)(idlePtr->clientData); + ckfree((char *) idlePtr); } if (tsdPtr->idleList) { blockTime.sec = 0; blockTime.usec = 0; Tcl_SetMaxBlockTime(&blockTime); @@ -774,66 +759,72 @@ * See the user documentation. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_AfterObjCmd( - TCL_UNUSED(ClientData), + ClientData clientData, /* Unused */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { - Tcl_WideInt ms = 0; /* Number of milliseconds to wait */ + Tcl_WideInt ms; /* Number of milliseconds to wait */ Tcl_Time wakeup; AfterInfo *afterPtr; AfterAssocData *assocPtr; - size_t length; - int index = -1; - static const char *const afterSubCmds[] = { + int length; + int index; + char buf[16 + TCL_INTEGER_SPACE]; + static CONST char *afterSubCmds[] = { "cancel", "idle", "info", NULL }; - enum afterSubCmdsEnum {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO}; + enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO}; ThreadSpecificData *tsdPtr = InitTimer(); if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg 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); + assocPtr = Tcl_GetAssocData(interp, "tclAfter", NULL); if (assocPtr == NULL) { - assocPtr = (AfterAssocData *)Tcl_Alloc(sizeof(AfterAssocData)); + assocPtr = (AfterAssocData *) ckalloc(sizeof(AfterAssocData)); assocPtr->interp = interp; assocPtr->firstAfterPtr = NULL; - Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, assocPtr); + Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, + (ClientData) 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 = TclGetString(objv[1]); - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad argument \"%s\": must be" - " cancel, idle, info, or an integer", arg)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument", - arg, NULL); + if (objv[1]->typePtr == &tclIntType +#ifndef NO_WIDE_TYPE + || objv[1]->typePtr == &tclWideIntType +#endif + || objv[1]->typePtr == &tclBignumType + || ( Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, + &index) != TCL_OK )) { + index = -1; + if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) { + Tcl_AppendResult(interp, "bad argument \"", + Tcl_GetString(objv[1]), + "\": must be cancel, idle, info, or an integer", + NULL); return TCL_ERROR; } } - /* + /* * At this point, either index = -1 and ms contains the number of ms * to wait, or else index is the index of a subcommand. */ switch (index) { @@ -842,16 +833,16 @@ ms = 0; } if (objc == 2) { return AfterDelay(interp, ms); } - afterPtr = (AfterInfo *)Tcl_Alloc(sizeof(AfterInfo)); + afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo))); afterPtr->assocPtr = assocPtr; if (objc == 3) { afterPtr->commandPtr = objv[2]; } else { - afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2); + afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2); } Tcl_IncrRefCount(afterPtr->commandPtr); /* * The variable below is used to generate unique identifiers for after @@ -870,21 +861,21 @@ wakeup.usec += ((long)(ms % 1000)) * 1000; if (wakeup.usec > 1000000) { wakeup.sec++; wakeup.usec -= 1000000; } - afterPtr->token = TclCreateAbsoluteTimerHandler(&wakeup, - AfterProc, afterPtr); + afterPtr->token = TclCreateAbsoluteTimerHandler(&wakeup, AfterProc, + (ClientData) afterPtr); afterPtr->nextPtr = assocPtr->firstAfterPtr; 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; - size_t tempLength; + char *command, *tempCommand; + int tempLength; if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "id|command"); return TCL_ERROR; } @@ -891,17 +882,18 @@ if (objc == 3) { commandPtr = objv[2]; } else { commandPtr = Tcl_ConcatObj(objc-2, objv+2); } - command = TclGetStringFromObj(commandPtr, &length); + command = Tcl_GetStringFromObj(commandPtr, &length); for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; afterPtr = afterPtr->nextPtr) { - tempCommand = TclGetStringFromObj(afterPtr->commandPtr, + tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr, &tempLength); if ((length == tempLength) - && !memcmp(command, tempCommand, length)) { + && (memcmp((void*) command, (void*) tempCommand, + (unsigned) length) == 0)) { break; } } if (afterPtr == NULL) { afterPtr = GetAfterEvent(assocPtr, commandPtr); @@ -911,22 +903,22 @@ } if (afterPtr != NULL) { if (afterPtr->token != NULL) { Tcl_DeleteTimerHandler(afterPtr->token); } else { - Tcl_CancelIdleCall(AfterProc, afterPtr); + Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr); } FreeAfterPtr(afterPtr); } break; } case AFTER_IDLE: if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "script ?script ...?"); + Tcl_WrongNumArgs(interp, 2, objv, "script script ..."); return TCL_ERROR; } - afterPtr = (AfterInfo *)Tcl_Alloc(sizeof(AfterInfo)); + afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo))); afterPtr->assocPtr = assocPtr; if (objc == 3) { afterPtr->commandPtr = objv[2]; } else { afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2); @@ -935,51 +927,43 @@ afterPtr->id = tsdPtr->afterId; tsdPtr->afterId += 1; afterPtr->token = NULL; afterPtr->nextPtr = assocPtr->firstAfterPtr; assocPtr->firstAfterPtr = afterPtr; - Tcl_DoWhenIdle(AfterProc, afterPtr); + Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr); Tcl_SetObjResult(interp, Tcl_ObjPrintf("after#%d", afterPtr->id)); break; - case AFTER_INFO: - if (objc == 2) { - Tcl_Obj *resultObj; + case AFTER_INFO: { + Tcl_Obj *resultListPtr; - TclNewObj(resultObj); + if (objc == 2) { for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; afterPtr = afterPtr->nextPtr) { if (assocPtr->interp == interp) { - Tcl_ListObjAppendElement(NULL, resultObj, Tcl_ObjPrintf( - "after#%d", afterPtr->id)); + sprintf(buf, "after#%d", afterPtr->id); + Tcl_AppendElement(interp, buf); } } - Tcl_SetObjResult(interp, resultObj); return TCL_OK; } if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "?id?"); return TCL_ERROR; } afterPtr = GetAfterEvent(assocPtr, objv[2]); if (afterPtr == NULL) { - const char *eventStr = TclGetString(objv[2]); - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "event \"%s\" doesn't exist", eventStr)); - Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, NULL); + Tcl_AppendResult(interp, "event \"", TclGetString(objv[2]), + "\" doesn't exist", NULL); return TCL_ERROR; - } else { - Tcl_Obj *resultListPtr; - - TclNewObj(resultListPtr); - Tcl_ListObjAppendElement(interp, resultListPtr, - afterPtr->commandPtr); - Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj( - (afterPtr->token == NULL) ? "idle" : "timer", -1)); - Tcl_SetObjResult(interp, resultListPtr); - } + } + resultListPtr = Tcl_NewObj(); + Tcl_ListObjAppendElement(interp, resultListPtr, afterPtr->commandPtr); + Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj( + (afterPtr->token == NULL) ? "idle" : "timer", -1)); + Tcl_SetObjResult(interp, resultListPtr); break; + } default: Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds"); } return TCL_OK; } @@ -992,11 +976,11 @@ * Implements the blocking delay behaviour of [after $time]. Tricky * because it has to take into account any time limit that has been set. * * Results: * Standard Tcl result code (with error set if an error occurred due to a - * time limit being exceeded or being canceled). + * time limit being exceeded). * * Side effects: * May adjust the time limit granularity marker. * *---------------------------------------------------------------------- @@ -1010,73 +994,52 @@ Interp *iPtr = (Interp *) interp; Tcl_Time endTime, now; Tcl_WideInt diff; - Tcl_GetTime(&now); - endTime = now; - endTime.sec += (long)(ms / 1000); - endTime.usec += ((int)(ms % 1000)) * 1000; + Tcl_GetTime(&endTime); + endTime.sec += (long)(ms/1000); + endTime.usec += ((int)(ms%1000))*1000; if (endTime.usec >= 1000000) { endTime.sec++; endTime.usec -= 1000000; } do { - if (Tcl_AsyncReady()) { - if (Tcl_AsyncInvoke(interp, TCL_OK) != TCL_OK) { - return TCL_ERROR; - } - } - if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { - return TCL_ERROR; - } + Tcl_GetTime(&now); if (iPtr->limit.timeEvent != NULL - && TCL_TIME_BEFORE(iPtr->limit.time, now)) { + && TCL_TIME_BEFORE(iPtr->limit.time, now)) { iPtr->limit.granularityTicker = 0; if (Tcl_LimitCheck(interp) != TCL_OK) { return TCL_ERROR; } } if (iPtr->limit.timeEvent == NULL - || TCL_TIME_BEFORE(endTime, iPtr->limit.time)) { - diff = TCL_TIME_DIFF_MS_CEILING(endTime, now); - if (diff > TCL_TIME_MAXIMUM_SLICE) { - diff = TCL_TIME_MAXIMUM_SLICE; - } - if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) { - diff = 1; - } + || TCL_TIME_BEFORE(endTime, iPtr->limit.time)) { + diff = TCL_TIME_DIFF_MS(endTime, now); +#ifndef TCL_WIDE_INT_IS_LONG + if (diff > LONG_MAX) { + diff = LONG_MAX; + } +#endif if (diff > 0) { - Tcl_Sleep((long) diff); - if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) { - break; - } - } else { - break; - } + Tcl_Sleep((long)diff); + } } else { diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now); - if (diff > TCL_TIME_MAXIMUM_SLICE) { - diff = TCL_TIME_MAXIMUM_SLICE; - } - if (diff > 0) { - Tcl_Sleep((int) diff); - } - if (Tcl_AsyncReady()) { - if (Tcl_AsyncInvoke(interp, TCL_OK) != TCL_OK) { - return TCL_ERROR; - } - } - if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { - return TCL_ERROR; +#ifndef TCL_WIDE_INT_IS_LONG + if (diff > LONG_MAX) { + diff = LONG_MAX; + } +#endif + if (diff > 0) { + Tcl_Sleep((long)diff); } if (Tcl_LimitCheck(interp) != TCL_OK) { return TCL_ERROR; } } - Tcl_GetTime(&now); } while (TCL_TIME_BEFORE(now, endTime)); return TCL_OK; } /* @@ -1102,11 +1065,11 @@ GetAfterEvent( AfterAssocData *assocPtr, /* Points to "after"-related information for * this interpreter. */ Tcl_Obj *commandPtr) { - const char *cmdString; /* Textual identifier for after event, such as + char *cmdString; /* Textual identifier for after event, such as * "after#6". */ AfterInfo *afterPtr; int id; char *end; @@ -1149,11 +1112,11 @@ static void AfterProc( ClientData clientData) /* Describes command to execute. */ { - AfterInfo *afterPtr = (AfterInfo *)clientData; + AfterInfo *afterPtr = (AfterInfo *) clientData; AfterAssocData *assocPtr = afterPtr->assocPtr; AfterInfo *prevPtr; int result; Tcl_Interp *interp; @@ -1176,24 +1139,24 @@ /* * Execute the callback. */ interp = assocPtr->interp; - Tcl_Preserve(interp); + Tcl_Preserve((ClientData) interp); result = Tcl_EvalObjEx(interp, afterPtr->commandPtr, TCL_EVAL_GLOBAL); if (result != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (\"after\" script)"); - Tcl_BackgroundException(interp, result); + TclBackgroundException(interp, result); } - Tcl_Release(interp); + Tcl_Release((ClientData) interp); /* * Free the memory for the callback. */ Tcl_DecrRefCount(afterPtr->commandPtr); - Tcl_Free(afterPtr); + ckfree((char *) afterPtr); } /* *---------------------------------------------------------------------- * @@ -1227,11 +1190,11 @@ /* Empty loop body. */ } prevPtr->nextPtr = afterPtr->nextPtr; } Tcl_DecrRefCount(afterPtr->commandPtr); - Tcl_Free(afterPtr); + ckfree((char *) afterPtr); } /* *---------------------------------------------------------------------- * @@ -1247,37 +1210,36 @@ * After commands are removed. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ static void AfterCleanupProc( ClientData clientData, /* Points to AfterAssocData for the * interpreter. */ - TCL_UNUSED(Tcl_Interp *)) + Tcl_Interp *interp) /* Interpreter that is being deleted. */ { - AfterAssocData *assocPtr = (AfterAssocData *)clientData; + 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_CancelIdleCall(AfterProc, (ClientData) afterPtr); } Tcl_DecrRefCount(afterPtr->commandPtr); - Tcl_Free(afterPtr); + ckfree((char *) afterPtr); } - Tcl_Free(assocPtr); + ckfree((char *) assocPtr); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 - * tab-width: 8 - * indent-tabs-mode: nil * End: */ Index: generic/tclTomMath.decls ================================================================== --- generic/tclTomMath.decls +++ generic/tclTomMath.decls @@ -15,30 +15,29 @@ library tcl # Define the unsupported generic interfaces. interface tclTomMath -# hooks {tclTomMathInt} scspec EXTERN # Declare each of the functions in the Tcl tommath interface declare 0 { - int MP_WUR TclBN_epoch(void) + int TclBN_epoch(void) } declare 1 { - int MP_WUR TclBN_revision(void) + int TclBN_revision(void) } declare 2 { - mp_err MP_WUR TclBN_mp_add(const mp_int *a, const mp_int *b, mp_int *c) + int TclBN_mp_add(mp_int *a, mp_int *b, mp_int *c) } declare 3 { - mp_err MP_WUR TclBN_mp_add_d(const mp_int *a, mp_digit b, mp_int *c) + int TclBN_mp_add_d(mp_int *a, mp_digit b, mp_int *c) } declare 4 { - mp_err MP_WUR TclBN_mp_and(const mp_int *a, const mp_int *b, mp_int *c) + int 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 { @@ -46,207 +45,185 @@ } 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) + int 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, mp_digit b) + int TclBN_mp_cmp_d(const mp_int *a, mp_digit b) } declare 10 { - mp_ord MP_WUR TclBN_mp_cmp_mag(const mp_int *a, const mp_int *b) + int 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) + int TclBN_mp_copy(mp_int *a, mp_int *b) } declare 12 { - int MP_WUR TclBN_mp_count_bits(const mp_int *a) + int TclBN_mp_count_bits(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) + int TclBN_mp_div(mp_int *a, mp_int *b, mp_int *q, mp_int *r) } declare 14 { - mp_err MP_WUR TclBN_mp_div_d(const mp_int *a, mp_digit b, mp_int *q, mp_digit *r) + int TclBN_mp_div_d(mp_int *a, mp_digit b, mp_int *q, mp_digit *r) } declare 15 { - mp_err MP_WUR TclBN_mp_div_2(const mp_int *a, mp_int *q) + int TclBN_mp_div_2(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) + int TclBN_mp_div_2d(mp_int *a, int b, mp_int *q, mp_int *r) } -# Removed in 9.0 -#declare 17 {deprecated {is private function in libtommath}} { -# mp_err TclBN_mp_div_3(const mp_int *a, mp_int *q, mp_digit *r) -#} +declare 17 { + int TclBN_mp_div_3(mp_int *a, mp_int *q, mp_digit *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, uint32_t b, mp_int *c) + int TclBN_mp_expt_d(mp_int *a, mp_digit b, mp_int *c) } declare 20 { - mp_err MP_WUR TclBN_mp_grow(mp_int *a, int size) + int TclBN_mp_grow(mp_int *a, int size) } declare 21 { - mp_err MP_WUR TclBN_mp_init(mp_int *a) + int TclBN_mp_init(mp_int *a) } declare 22 { - mp_err MP_WUR TclBN_mp_init_copy(mp_int *a, const mp_int *b) + int TclBN_mp_init_copy(mp_int *a, mp_int *b) } declare 23 { - mp_err MP_WUR TclBN_mp_init_multi(mp_int *a, ...) + int TclBN_mp_init_multi(mp_int *a, ...) } declare 24 { - mp_err MP_WUR TclBN_mp_init_set(mp_int *a, mp_digit b) + int TclBN_mp_init_set(mp_int *a, mp_digit b) } declare 25 { - mp_err MP_WUR TclBN_mp_init_size(mp_int *a, int size) + int TclBN_mp_init_size(mp_int *a, int size) } declare 26 { - mp_err MP_WUR TclBN_mp_lshd(mp_int *a, int shift) + int 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) + int TclBN_mp_mod(mp_int *a, 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) + int TclBN_mp_mod_2d(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) + int TclBN_mp_mul(mp_int *a, mp_int *b, mp_int *p) } declare 30 { - mp_err MP_WUR TclBN_mp_mul_d(const mp_int *a, mp_digit b, mp_int *p) + int TclBN_mp_mul_d(mp_int *a, mp_digit b, mp_int *p) } declare 31 { - mp_err MP_WUR TclBN_mp_mul_2(const mp_int *a, mp_int *p) + int TclBN_mp_mul_2(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) + int TclBN_mp_mul_2d(mp_int *a, int d, mp_int *p) } declare 33 { - mp_err MP_WUR TclBN_mp_neg(const mp_int *a, mp_int *b) + int TclBN_mp_neg(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) + int 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) + int TclBN_mp_radix_size(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) + int 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) -} -# Removed in 9.0 -#declare 39 {deprecated {macro calling mp_set_u64}} { -# void TclBN_mp_set(mp_int *a, unsigned int b) -#} -# Removed in 9.0 -#declare 40 {nostub {is private function in libtommath}} { -# mp_err TclBN_mp_sqr(const mp_int *a, mp_int *b) -#} + int TclBN_mp_shrink(mp_int *a) +} +declare 39 { + void TclBN_mp_set(mp_int *a, mp_digit b) +} +declare 40 { + int TclBN_mp_sqr(mp_int *a, mp_int *b) +} declare 41 { - mp_err MP_WUR TclBN_mp_sqrt(const mp_int *a, mp_int *b) + int TclBN_mp_sqrt(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) + int TclBN_mp_sub(mp_int *a, mp_int *b, mp_int *c) } declare 43 { - mp_err MP_WUR TclBN_mp_sub_d(const mp_int *a, mp_digit b, mp_int *c) -} -# Removed in 9.0 -#declare 44 { -# mp_err TclBN_mp_to_unsigned_bin(const mp_int *a, unsigned char *b) -#} -# Removed in 9.0 -#declare 45 { -# mp_err TclBN_mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, -# unsigned long *outlen) -#} -# Removed in 9.0 -#declare 46 { -# mp_err TclBN_mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen) -#} + int TclBN_mp_sub_d(mp_int *a, mp_digit b, mp_int *c) +} +declare 44 { + int TclBN_mp_to_unsigned_bin(mp_int *a, unsigned char *b) +} +declare 45 { + int TclBN_mp_to_unsigned_bin_n(mp_int *a, unsigned char *b, + unsigned long *outlen) +} +declare 46 { + int TclBN_mp_toradix_n(mp_int *a, char *str, int radix, int maxlen) +} declare 47 { - size_t MP_WUR TclBN_mp_ubin_size(const mp_int *a) + int TclBN_mp_unsigned_bin_size(mp_int *a) } declare 48 { - mp_err MP_WUR TclBN_mp_xor(const mp_int *a, const mp_int *b, mp_int *c) + int TclBN_mp_xor(const mp_int *a, const mp_int *b, mp_int *c) } declare 49 { void TclBN_mp_zero(mp_int *a) } -# Removed in 9.0 -#declare 61 {deprecated {macro calling mp_init_u64}} { -# mp_err TclBN_mp_init_ul(mp_int *a, unsigned long i) -#} -# Removed in 9.0 -#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) -} -# Removed in 9.0 -#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) -} - -# Removed in 9.0 -#declare 67 { -# mp_err TclBN_mp_expt_d_ex(const mp_int *a, mp_digit 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 -# No longer in use: replaced by mp_and() -#declare 73 { -# int TclBN_mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c) -#} -# No longer in use: replaced by mp_or() -#declare 74 { -# int TclBN_mp_tc_or(const mp_int *a, const mp_int *b, mp_int *c) -#} -# No longer in use: replaced by mp_xor() -#declare 75 { -# int 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) -} -# Removed in 9.0 -#declare 79 { -# mp_err MP_WUR TclBN_mp_div_ld(const mp_int *a, mp_digit b, mp_int *q, mp_digit *r) -#} -declare 80 { - int MP_WUR TclBN_mp_to_radix(const mp_int *a, char *str, size_t maxlen, size_t *written, int radix) + +# internal routines to libtommath - should not be called but must be +# exported to accommodate the "tommath" extension + +declare 50 { + void TclBN_reverse(unsigned char *s, int len) +} +declare 51 { + int TclBN_fast_s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs) +} +declare 52 { + int TclBN_fast_s_mp_sqr(mp_int *a, mp_int *b) +} +declare 53 { + int TclBN_mp_karatsuba_mul(mp_int *a, mp_int *b, mp_int *c) +} +declare 54 { + int TclBN_mp_karatsuba_sqr(mp_int *a, mp_int *b) +} +declare 55 { + int TclBN_mp_toom_mul(mp_int *a, mp_int *b, mp_int *c) +} +declare 56 { + int TclBN_mp_toom_sqr(mp_int *a, mp_int *b) +} +declare 57 { + int TclBN_s_mp_add(mp_int *a, mp_int *b, mp_int *c) +} +declare 58 { + int TclBN_s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs) +} +declare 59 { + int TclBN_s_mp_sqr(mp_int *a, mp_int *b) +} +declare 60 { + int TclBN_s_mp_sub(mp_int *a, mp_int *b, mp_int *c) +} +declare 61 { + int TclBN_mp_init_set_int(mp_int *a, unsigned long i) +} +declare 62 { + int TclBN_mp_set_int(mp_int *a, unsigned long i) +} +declare 63 { + int TclBN_mp_cnt_lsb(mp_int *a) +} +declare 80 { + void TclUnusedStubEntry(void) } # Local Variables: # mode: tcl # End: Index: generic/tclTomMath.h ================================================================== --- generic/tclTomMath.h +++ generic/tclTomMath.h @@ -1,47 +1,873 @@ -#ifndef BN_TCL_H_ -#define BN_TCL_H_ - -#ifdef MP_NO_STDINT -# ifdef HAVE_STDINT_H -# include -#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" +/* LibTomMath, multiple-precision integer library -- Tom St Denis */ +/* SPDX-License-Identifier: Unlicense */ + +#ifndef BN_H_ +#define BN_H_ + +#include +#ifndef MODULE_SCOPE +#define MODULE_SCOPE extern +#endif + +#include +#include +#include +#include +#include + +#ifndef MIN + #define MIN(x,y) ((x)<(y)?(x):(y)) +#endif + +#ifndef MAX + #define MAX(x,y) ((x)>(y)?(x):(y)) +#endif + +#ifdef __cplusplus +extern "C" { + +/* C++ compilers don't like assigning void * to mp_digit * */ +#define OPT_CAST(x) (x *) + +#else + +/* C on the other hand doesn't care */ +#define OPT_CAST(x) + +#endif + + +/* detect 64-bit mode if possible */ +#if defined(NEVER) /* 128-bit ints fail in too many places */ + #if !(defined(MP_64BIT) && defined(MP_16BIT) && defined(MP_8BIT)) + #define MP_64BIT + #endif +#endif + +/* some default configurations. + * + * A "mp_digit" must be able to hold DIGIT_BIT + 1 bits + * A "mp_word" must be able to hold 2*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 +#ifndef MP_DIGIT_DECLARED + typedef unsigned char mp_digit; +#define MP_DIGIT_DECLARED +#endif + typedef unsigned short mp_word; +#elif defined(MP_16BIT) +#ifndef MP_DIGIT_DECLARED + typedef unsigned short mp_digit; +#define MP_DIGIT_DECLARED +#endif + typedef unsigned long mp_word; +#elif defined(MP_64BIT) + /* for GCC only on supported platforms */ +#ifndef CRYPT + typedef unsigned long long ulong64; + typedef signed long long long64; +#endif + +#ifndef MP_DIGIT_DECLARED + typedef unsigned long mp_digit; +#define MP_DIGIT_DECLARED +#endif + typedef unsigned long mp_word __attribute__ ((mode(TI))); + + #define DIGIT_BIT 60 +#else + /* this is the default case, 28-bit digits */ + + /* this is to make porting into LibTomCrypt easier :-) */ +#ifndef CRYPT + #if defined(_MSC_VER) || defined(__BORLANDC__) + typedef unsigned __int64 ulong64; + typedef signed __int64 long64; + #else + typedef unsigned long long ulong64; + typedef signed long long long64; + #endif +#endif + +#ifndef MP_DIGIT_DECLARED + typedef unsigned int mp_digit; +#define MP_DIGIT_DECLARED +#endif + typedef ulong64 mp_word; + +#ifdef MP_31BIT + /* this is an extension that uses 31-bit digits */ + #define DIGIT_BIT 31 +#else + /* default case is 28-bit digits, defines MP_28BIT as a handy macro to test */ + #define DIGIT_BIT 28 + #define MP_28BIT +#endif +#endif + +/* define heap macros */ +#if 0 /* these are macros in tclTomMathDecls.h */ +#ifndef CRYPT + /* default to libc stuff */ + #ifndef XMALLOC + #define XMALLOC malloc + #define XFREE free + #define XREALLOC realloc + #define XCALLOC calloc + #else + /* prototypes for our heap functions */ + extern void *XMALLOC(size_t n); + extern void *XREALLOC(void *p, size_t n); + extern void *XCALLOC(size_t n, size_t s); + extern void XFREE(void *p); + #endif +#endif +#endif + + +/* otherwise the bits per digit is calculated automatically from the size of a mp_digit */ +#ifndef DIGIT_BIT + #define DIGIT_BIT ((int)((CHAR_BIT * sizeof(mp_digit) - 1))) /* bits per digit */ +#endif + +#define MP_DIGIT_BIT DIGIT_BIT +#define MP_MASK ((((mp_digit)1)<<((mp_digit)DIGIT_BIT))-((mp_digit)1)) +#define MP_DIGIT_MAX MP_MASK + +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 /* yes response */ +#define MP_NO 0 /* no response */ +typedef int mp_err; +#define MP_OKAY 0 /* ok result */ +#define MP_ERR -1 /* unknown error */ +#define MP_MEM -2 /* out of mem */ +#define MP_VAL -3 /* invalid input */ +#define MP_RANGE MP_VAL +#define MP_ITER -4 /* Max. iterations reached */ + +/* Primality generation flags */ +#define LTM_PRIME_BBS 0x0001 /* BBS style prime */ +#define LTM_PRIME_SAFE 0x0002 /* Safe prime (p-1)/2 == prime */ +#define LTM_PRIME_2MSB_ON 0x0008 /* force 2nd MSB to 1 */ + +/* tunable cutoffs */ + +#if defined(BUILD_tcl) || !defined(_WIN32) +MODULE_SCOPE 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 MP_PREC 32 /* default digits of precision */ +# elif defined(MP_8BIT) +# define MP_PREC 16 /* default digits of precision */ +# else +# define MP_PREC 8 /* default digits of precision */ +# endif +#endif + +/* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */ +#define MP_WARRAY (1 << (sizeof(mp_word) * CHAR_BIT - 2 * DIGIT_BIT + 1)) + +/* + * 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__ >= 301) +# define MP_DEPRECATED(x) __attribute__((deprecated("replaced by " #x))) +# define PRIVATE_MP_DEPRECATED_PRAGMA(s) _Pragma(#s) +# define MP_DEPRECATED_PRAGMA(s) PRIVATE_MP_DEPRECATED_PRAGMA(GCC warning s) +#elif defined(_MSC_VER) && _MSC_VER >= 1500 +# define MP_DEPRECATED(x) __declspec(deprecated("replaced by " #x)) +# define MP_DEPRECATED_PRAGMA(s) __pragma(message(s)) +#else +# define MP_DEPRECATED +# define MP_DEPRECATED_PRAGMA(s) +#endif + +#define USED(m) ((m)->used) +#define DIGIT(m,k) ((m)->dp[(k)]) +#define SIGN(m) ((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, sign; + mp_digit *dp; +}; + +/* callback for mp_prime_random, should fill dst with random bytes and return how many read [upto len] */ +typedef int ltm_prime_callback(unsigned char *dst, int len, void *dat); + + +/* error code to char* string */ +/* +const char *mp_error_to_string(mp_err code); +*/ + +/* ---> init and deinit bignum functions <--- */ +/* init a bignum */ +/* +mp_err mp_init(mp_int *a); +*/ + +/* free a bignum */ +/* +void mp_clear(mp_int *a); +*/ + +/* init a null terminated series of arguments */ +/* +mp_err mp_init_multi(mp_int *mp, ...); +*/ + +/* clear a null terminated series of arguments */ +/* +void mp_clear_multi(mp_int *mp, ...); +*/ + +/* 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); +*/ + +/* grow an int to a given size */ +/* +mp_err mp_grow(mp_int *a, int size); +*/ + +/* init to a given number of digits */ +/* +mp_err mp_init_size(mp_int *a, int size); +*/ + +/* ---> Basic Manipulations <--- */ +#define mp_iszero(a) (((a)->used == 0) ? MP_YES : MP_NO) +#define mp_iseven(a) (((a)->used == 0 || (((a)->dp[0] & 1) == 0)) ? MP_YES : MP_NO) +#define mp_isodd(a) (((a)->used > 0 && (((a)->dp[0] & 1) == 1)) ? MP_YES : MP_NO) +#define mp_isneg(a) (((a)->sign != MP_ZPOS) ? MP_YES : MP_NO) + +/* set to zero */ +/* +void mp_zero(mp_int *a); +*/ + +/* set to a digit */ +/* +void mp_set(mp_int *a, mp_digit b); +*/ + +/* set a 32-bit const */ +/* +int mp_set_int(mp_int *a, unsigned long b); +*/ + +/* set a platform dependent unsigned long value */ +/* +int mp_set_long(mp_int *a, unsigned long b); +*/ + +/* set a platform dependent unsigned long long value */ +/* +int mp_set_long_long(mp_int *a, unsigned long long b); +*/ + +/* get a 32-bit value */ +unsigned long mp_get_int(mp_int * a); + +/* initialize and set a digit */ +/* +int mp_init_set (mp_int * a, mp_digit b); +*/ + +/* initialize and set 32-bit value */ +/* +int mp_init_set_int (mp_int * a, unsigned long b); +*/ + +/* copy, b = a */ +/* +int mp_copy(mp_int *a, mp_int *b); +*/ + +/* inits and copies, a = b */ +/* +int mp_init_copy(mp_int *a, mp_int *b); +*/ + +/* trim unused digits */ +/* +void mp_clamp(mp_int *a); +*/ + +/* ---> digit manipulation <--- */ + +/* right shift by "b" digits */ +/* +void mp_rshd(mp_int *a, int b); +*/ + +/* left shift by "b" digits */ +/* +int mp_lshd(mp_int *a, int b); +*/ + +/* c = a / 2**b */ +/* +int mp_div_2d(mp_int *a, int b, mp_int *c, mp_int *d); +*/ + +/* b = a/2 */ +/* +int mp_div_2(mp_int *a, mp_int *b); +*/ + +/* c = a * 2**b */ +/* +int mp_mul_2d(mp_int *a, int b, mp_int *c); +*/ + +/* b = a*2 */ +/* +int mp_mul_2(mp_int *a, mp_int *b); +*/ + +/* c = a mod 2**d */ +/* +int mp_mod_2d(mp_int *a, int b, mp_int *c); +*/ + +/* computes a = 2**b */ +/* +int mp_2expt(mp_int *a, int b); +*/ + +/* Counts the number of lsbs which are zero before the first zero bit */ +/* +int mp_cnt_lsb(mp_int *a); +*/ + +/* I Love Earth! */ + +/* makes a pseudo-random int of a given size */ +/* +int mp_rand(mp_int *a, int digits); +*/ + +/* ---> binary operations <--- */ +/* c = a XOR b */ +/* +int mp_xor(mp_int *a, mp_int *b, mp_int *c); +*/ + +/* c = a OR b */ +/* +int mp_or(mp_int *a, mp_int *b, mp_int *c); +*/ + +/* c = a AND b */ +/* +int mp_and(mp_int *a, mp_int *b, mp_int *c); +*/ + +/* ---> Basic arithmetic <--- */ + +/* b = -a */ +/* +int mp_neg(mp_int *a, mp_int *b); +*/ + +/* b = |a| */ +/* +int mp_abs(mp_int *a, mp_int *b); +*/ + +/* compare a to b */ +/* +int mp_cmp(mp_int *a, mp_int *b); +*/ + +/* compare |a| to |b| */ +/* +int mp_cmp_mag(mp_int *a, mp_int *b); +*/ + +/* c = a + b */ +/* +int mp_add(mp_int *a, mp_int *b, mp_int *c); +*/ + +/* c = a - b */ +/* +int mp_sub(mp_int *a, mp_int *b, mp_int *c); +*/ + +/* c = a * b */ +/* +int mp_mul(mp_int *a, mp_int *b, mp_int *c); +*/ + +/* b = a*a */ +/* +int mp_sqr(mp_int *a, mp_int *b); +*/ + +/* a/b => cb + d == a */ +/* +int mp_div(mp_int *a, mp_int *b, mp_int *c, mp_int *d); +*/ + +/* c = a mod b, 0 <= c < b */ +/* +int mp_mod(mp_int *a, mp_int *b, mp_int *c); +*/ + +/* ---> single digit functions <--- */ + +/* compare against a single digit */ +/* +int mp_cmp_d(mp_int *a, mp_digit b); +*/ + +/* c = a + b */ +/* +int mp_add_d(mp_int *a, mp_digit b, mp_int *c); +*/ + +/* c = a - b */ +/* +int mp_sub_d(mp_int *a, mp_digit b, mp_int *c); +*/ + +/* c = a * b */ +/* +int mp_mul_d(mp_int *a, mp_digit b, mp_int *c); +*/ + +/* a/b => cb + d == a */ +/* +int mp_div_d(mp_int *a, mp_digit b, mp_int *c, mp_digit *d); +*/ + +/* a/3 => 3c + d == a */ +/* +int mp_div_3(mp_int *a, mp_int *c, mp_digit *d); +*/ + +/* c = a**b */ +/* +int mp_expt_d(mp_int *a, mp_digit b, mp_int *c); +*/ + +/* c = a mod b, 0 <= c < b */ +/* +int mp_mod_d(mp_int *a, mp_digit b, mp_digit *c); +*/ + +/* ---> number theory <--- */ + +/* d = a + b (mod c) */ +/* +int mp_addmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); +*/ + +/* d = a - b (mod c) */ +/* +int mp_submod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); +*/ + +/* d = a * b (mod c) */ +/* +int mp_mulmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); +*/ + +/* c = a * a (mod b) */ +/* +int mp_sqrmod(mp_int *a, mp_int *b, mp_int *c); +*/ + +/* c = 1/a (mod b) */ +/* +int mp_invmod(mp_int *a, mp_int *b, mp_int *c); +*/ + +/* c = (a, b) */ +/* +int mp_gcd(mp_int *a, mp_int *b, mp_int *c); +*/ + +/* produces value such that U1*a + U2*b = U3 */ +/* +int mp_exteuclid(mp_int *a, mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3); +*/ + +/* c = [a, b] or (a*b)/(a, b) */ +/* +int mp_lcm(mp_int *a, mp_int *b, mp_int *c); +*/ + +/* finds one of the b'th root of a, such that |c|**b <= |a| + * + * returns error if a < 0 and b is even + */ +/* +int mp_n_root(mp_int *a, mp_digit b, mp_int *c); +*/ + +/* special sqrt algo */ +/* +int mp_sqrt(mp_int *arg, mp_int *ret); +*/ + +/* is number a square? */ +/* +int mp_is_square(mp_int *arg, int *ret); +*/ + +/* computes the jacobi c = (a | n) (or Legendre if b is prime) */ +/* +int mp_jacobi(mp_int *a, mp_int *n, int *c); +*/ + +/* used to setup the Barrett reduction for a given modulus b */ +/* +int mp_reduce_setup(mp_int *a, mp_int *b); +*/ + +/* Barrett Reduction, computes a (mod b) with a precomputed value c + * + * Assumes that 0 < a <= b*b, note if 0 > a > -(b*b) then you can merely + * compute the reduction as -1 * mp_reduce(mp_abs(a)) [pseudo code]. + */ +/* +int mp_reduce(mp_int *a, mp_int *b, mp_int *c); +*/ + +/* setups the montgomery reduction */ +/* +int mp_montgomery_setup(mp_int *a, mp_digit *mp); +*/ + +/* computes a = B**n mod b without division or multiplication useful for + * normalizing numbers in a Montgomery system. + */ +/* +int mp_montgomery_calc_normalization(mp_int *a, mp_int *b); +*/ + +/* computes x/R == x (mod N) via Montgomery Reduction */ +/* +int mp_montgomery_reduce(mp_int *a, mp_int *m, mp_digit mp); +*/ + +/* returns 1 if a is a valid DR modulus */ +/* +int mp_dr_is_modulus(mp_int *a); +*/ + +/* sets the value of "d" required for mp_dr_reduce */ +/* +void mp_dr_setup(mp_int *a, mp_digit *d); +*/ + +/* reduces a modulo b using the Diminished Radix method */ +/* +int mp_dr_reduce(mp_int *a, mp_int *b, mp_digit mp); +*/ + +/* returns true if a can be reduced with mp_reduce_2k */ +/* +int mp_reduce_is_2k(mp_int *a); +*/ + +/* determines k value for 2k reduction */ +/* +int mp_reduce_2k_setup(mp_int *a, mp_digit *d); +*/ + +/* reduces a modulo b where b is of the form 2**p - k [0 <= a] */ +/* +int mp_reduce_2k(mp_int *a, mp_int *n, mp_digit d); +*/ + +/* returns true if a can be reduced with mp_reduce_2k_l */ +/* +int mp_reduce_is_2k_l(mp_int *a); +*/ + +/* determines k value for 2k reduction */ +/* +int mp_reduce_2k_setup_l(mp_int *a, mp_int *d); +*/ + +/* reduces a modulo b where b is of the form 2**p - k [0 <= a] */ +/* +int mp_reduce_2k_l(mp_int *a, mp_int *n, mp_int *d); +*/ + +/* d = a**b (mod c) */ +/* +int mp_exptmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); +*/ + +/* ---> Primes <--- */ + +/* number of primes */ +#ifdef MP_8BIT + #define PRIME_SIZE 31 +#else + #define PRIME_SIZE 256 +#endif + +/* table of first PRIME_SIZE primes */ +#if defined(BUILD_tcl) || !defined(_WIN32) +MODULE_SCOPE const mp_digit ltm_prime_tab[]; +#endif + +/* result=1 if a is divisible by one of the first PRIME_SIZE primes */ +/* +int mp_prime_is_divisible(mp_int *a, int *result); +*/ + +/* 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); +*/ + +/* 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); +*/ + +/* 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); +*/ + +/* performs t rounds of Miller-Rabin on "a" using the first + * t prime bases. Also performs an initial sieve of trial + * division. Determines if "a" is prime with probability + * of error no more than (1/4)**t. + * + * Sets result to 1 if probably prime, 0 otherwise + */ +/* +mp_err mp_prime_is_prime(const mp_int *a, int t, mp_bool *result); +*/ + +/* 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); +*/ + +/* 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_prime_random_ex(a, t, ((size) * 8) + 1, (bbs==1)?LTM_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 + * + */ +/* +int mp_prime_random_ex(mp_int *a, int t, int size, int flags, ltm_prime_callback cb, void *dat); +*/ + +/* ---> radix conversion <--- */ +/* +int mp_count_bits(mp_int *a); +*/ + +/* +int mp_unsigned_bin_size(mp_int *a); +*/ +/* +int mp_read_unsigned_bin(mp_int *a, const unsigned char *b, int c); +*/ +/* +int mp_to_unsigned_bin(mp_int *a, unsigned char *b); +*/ +/* +int mp_to_unsigned_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen); +*/ + +/* +int mp_signed_bin_size(mp_int *a); +*/ +/* +int mp_read_signed_bin(mp_int *a, const unsigned char *b, int c); +*/ +/* +int mp_to_signed_bin(mp_int *a, unsigned char *b); +*/ +/* +int mp_to_signed_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen); +*/ + +/* +int mp_read_radix(mp_int *a, const char *str, int radix); +*/ +/* +int mp_toradix(mp_int *a, char *str, int radix); +*/ +/* +int mp_toradix_n(mp_int * a, char *str, int radix, int maxlen); +*/ +/* +int mp_radix_size(mp_int *a, int radix, int *size); +*/ + +/* +int mp_fread(mp_int *a, int radix, FILE *stream); +*/ +/* +int mp_fwrite(mp_int *a, int radix, FILE *stream); +*/ + +#define mp_read_raw(mp, str, len) mp_read_signed_bin((mp), (str), (len)) +#define mp_raw_size(mp) mp_signed_bin_size(mp) +#define mp_toraw(mp, str) mp_to_signed_bin((mp), (str)) +#define mp_read_mag(mp, str, len) mp_read_unsigned_bin((mp), (str), (len)) +#define mp_mag_size(mp) mp_unsigned_bin_size(mp) +#define mp_tomag(mp, str) mp_to_unsigned_bin((mp), (str)) + +#define mp_tobinary(M, S) mp_toradix((M), (S), 2) +#define mp_tooctal(M, S) mp_toradix((M), (S), 8) +#define mp_todecimal(M, S) mp_toradix((M), (S), 10) +#define mp_tohex(M, S) mp_toradix((M), (S), 16) + +/* lowlevel functions, do not call! */ +/* +int s_mp_add(mp_int *a, mp_int *b, mp_int *c); +*/ +/* +int s_mp_sub(mp_int *a, mp_int *b, mp_int *c); +*/ +#define s_mp_mul(a, b, c) s_mp_mul_digs(a, b, c, (a)->used + (b)->used + 1) +/* +int fast_s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs); +*/ +/* +int s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs); +*/ +/* +int fast_s_mp_mul_high_digs(mp_int *a, mp_int *b, mp_int *c, int digs); +*/ +/* +int s_mp_mul_high_digs(mp_int *a, mp_int *b, mp_int *c, int digs); +*/ +/* +int fast_s_mp_sqr(mp_int *a, mp_int *b); +*/ +/* +int s_mp_sqr(mp_int *a, mp_int *b); +*/ +/* +int mp_karatsuba_mul(mp_int *a, mp_int *b, mp_int *c); +*/ +/* +int mp_toom_mul(mp_int *a, mp_int *b, mp_int *c); +*/ +/* +int mp_karatsuba_sqr(mp_int *a, mp_int *b); +*/ +/* +int mp_toom_sqr(mp_int *a, mp_int *b); +*/ +/* +int fast_mp_invmod(mp_int *a, mp_int *b, mp_int *c); +*/ +/* +int mp_invmod_slow (mp_int * a, mp_int * b, mp_int * c); +*/ +/* +int fast_mp_montgomery_reduce(mp_int *a, mp_int *m, mp_digit mp); +*/ +/* +int mp_exptmod_fast(mp_int *G, mp_int *X, mp_int *P, mp_int *Y, int mode); +*/ +/* +int s_mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y, int mode); +*/ +/* +void bn_reverse(unsigned char *s, int len); +*/ + +#if defined(BUILD_tcl) || !defined(_WIN32) +MODULE_SCOPE const char *mp_s_rmap; +#endif + +#ifdef __cplusplus +} +#endif #endif Index: generic/tclTomMathDecls.h ================================================================== --- generic/tclTomMathDecls.h +++ generic/tclTomMathDecls.h @@ -14,14 +14,10 @@ #ifndef _TCLTOMMATHDECLS #define _TCLTOMMATHDECLS #include "tcl.h" -#include -#ifndef BN_H_ -#include "tclTomMath.h" -#endif /* * Define the version of the Stubs table that's exported for tommath */ @@ -33,44 +29,29 @@ TCLTOMMATH_EPOCH,TCLTOMMATH_REVISION)) /* Define custom memory allocation for libtommath */ /* MODULE_SCOPE void* TclBNAlloc( size_t ); */ -#define TclBNAlloc(s) ((void*)Tcl_Alloc(s)) -/* MODULE_SCOPE void* TclBNCalloc( size_t, size_t ); */ -#define TclBNCalloc(m,s) memset(Tcl_Alloc((size_t)(m)*(size_t)(s)),0,(size_t)(m)*(size_t)(s)) +#define TclBNAlloc(s) ((void*)ckalloc((size_t)(s))) /* MODULE_SCOPE void* TclBNRealloc( void*, size_t ); */ -#define TclBNRealloc(x,s) ((void*)Tcl_Realloc((char*)(x),(size_t)(s))) +#define TclBNRealloc(x,s) ((void*)ckrealloc((char*)(x),(size_t)(s))) /* MODULE_SCOPE void TclBNFree( void* ); */ -#define TclBNFree(x) (Tcl_Free((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_mp_sqr(const mp_int *a, mp_int *b); -MODULE_SCOPE mp_err TclBN_mp_div_3(const mp_int *a, mp_int *q, mp_digit *r); -#ifdef __cplusplus -} -#endif - -/* Rename the global symbols in libtommath to avoid linkage conflicts */ - -#ifndef TCL_WITH_EXTERNAL_TOMMATH +#define TclBNFree(x) (ckfree((char*)(x))) +/* MODULE_SCOPE void* TclBNCalloc( size_t, size_t ); */ +/* unused - no macro */ + +#define XMALLOC(x) TclBNAlloc(x) +#define XFREE(x) TclBNFree(x) +#define XREALLOC(x,n) TclBNRealloc(x,n) +#define XCALLOC(n,x) TclBNCalloc(n,x) + #define bn_reverse TclBN_reverse +#define s_mp_reverse TclBN_reverse +#define fast_s_mp_mul_digs TclBN_fast_s_mp_mul_digs +#define s_mp_mul_digs_fast TclBN_fast_s_mp_mul_digs +#define fast_s_mp_sqr TclBN_fast_s_mp_sqr +#define s_mp_sqr_fast TclBN_fast_s_mp_sqr #define mp_add TclBN_mp_add #define mp_add_d TclBN_mp_add_d #define mp_and TclBN_mp_and #define mp_clamp TclBN_mp_clamp #define mp_clear TclBN_mp_clear @@ -80,76 +61,61 @@ #define mp_cmp_mag TclBN_mp_cmp_mag #define mp_cnt_lsb TclBN_mp_cnt_lsb #define mp_copy TclBN_mp_copy #define mp_count_bits TclBN_mp_count_bits #define mp_div TclBN_mp_div -#define mp_div_d TclBN_mp_div_d #define mp_div_2 TclBN_mp_div_2 +#define mp_div_2d TclBN_mp_div_2d #define mp_div_3 TclBN_mp_div_3 -#define mp_div_2d TclBN_mp_div_2d +#define mp_div_d TclBN_mp_div_d #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_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_mp_init_set +#define mp_init_set_int TclBN_mp_init_set_int #define mp_init_size TclBN_mp_init_size -#define mp_init_u64 TclBN_mp_init_u64 +#define mp_karatsuba_mul TclBN_mp_karatsuba_mul +#define s_mp_karatsuba_mul TclBN_mp_karatsuba_mul +#define mp_karatsuba_sqr TclBN_mp_karatsuba_sqr +#define s_mp_karatsuba_sqr TclBN_mp_karatsuba_sqr #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_mp_mul_d #define mp_mul_2 TclBN_mp_mul_2 #define mp_mul_2d TclBN_mp_mul_2d +#define mp_mul_d TclBN_mp_mul_d #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_s_rmap TclBNMpSRmap +#define mp_set TclBN_mp_set +#define mp_set_int TclBN_mp_set_int #define mp_shrink TclBN_mp_shrink #define mp_sqr TclBN_mp_sqr #define mp_sqrt TclBN_mp_sqrt #define mp_sub TclBN_mp_sub #define mp_sub_d TclBN_mp_sub_d -#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_toom_mul TclBN_mp_toom_mul +#define s_mp_toom_mul TclBN_mp_toom_mul +#define mp_toom_sqr TclBN_mp_toom_sqr +#define s_mp_toom_sqr TclBN_mp_toom_sqr #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_unsigned_bin_size TclBN_mp_unsigned_bin_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 */ #undef TCL_STORAGE_CLASS #ifdef BUILD_tcl # define TCL_STORAGE_CLASS DLLEXPORT #else @@ -174,430 +140,743 @@ /* * Exported function declarations: */ +#ifndef TclBN_epoch_TCL_DECLARED +#define TclBN_epoch_TCL_DECLARED /* 0 */ -EXTERN int TclBN_epoch(void) MP_WUR; +EXTERN int TclBN_epoch(void); +#endif +#ifndef TclBN_revision_TCL_DECLARED +#define TclBN_revision_TCL_DECLARED /* 1 */ -EXTERN int TclBN_revision(void) MP_WUR; +EXTERN int TclBN_revision(void); +#endif +#ifndef TclBN_mp_add_TCL_DECLARED +#define TclBN_mp_add_TCL_DECLARED /* 2 */ -EXTERN mp_err TclBN_mp_add(const mp_int *a, const mp_int *b, - mp_int *c) MP_WUR; +EXTERN int TclBN_mp_add(mp_int *a, mp_int *b, mp_int *c); +#endif +#ifndef TclBN_mp_add_d_TCL_DECLARED +#define TclBN_mp_add_d_TCL_DECLARED /* 3 */ -EXTERN mp_err TclBN_mp_add_d(const mp_int *a, mp_digit b, - mp_int *c) MP_WUR; +EXTERN int TclBN_mp_add_d(mp_int *a, mp_digit b, mp_int *c); +#endif +#ifndef TclBN_mp_and_TCL_DECLARED +#define TclBN_mp_and_TCL_DECLARED /* 4 */ -EXTERN mp_err TclBN_mp_and(const mp_int *a, const mp_int *b, - mp_int *c) MP_WUR; +EXTERN int TclBN_mp_and(CONST mp_int *a, CONST mp_int *b, + mp_int *c); +#endif +#ifndef TclBN_mp_clamp_TCL_DECLARED +#define TclBN_mp_clamp_TCL_DECLARED /* 5 */ EXTERN void TclBN_mp_clamp(mp_int *a); +#endif +#ifndef TclBN_mp_clear_TCL_DECLARED +#define TclBN_mp_clear_TCL_DECLARED /* 6 */ EXTERN void TclBN_mp_clear(mp_int *a); +#endif +#ifndef TclBN_mp_clear_multi_TCL_DECLARED +#define TclBN_mp_clear_multi_TCL_DECLARED /* 7 */ EXTERN void TclBN_mp_clear_multi(mp_int *a, ...); +#endif +#ifndef TclBN_mp_cmp_TCL_DECLARED +#define TclBN_mp_cmp_TCL_DECLARED /* 8 */ -EXTERN mp_ord TclBN_mp_cmp(const mp_int *a, const mp_int *b) MP_WUR; +EXTERN int TclBN_mp_cmp(CONST mp_int *a, CONST mp_int *b); +#endif +#ifndef TclBN_mp_cmp_d_TCL_DECLARED +#define TclBN_mp_cmp_d_TCL_DECLARED /* 9 */ -EXTERN mp_ord TclBN_mp_cmp_d(const mp_int *a, mp_digit b) MP_WUR; +EXTERN int TclBN_mp_cmp_d(CONST mp_int *a, mp_digit b); +#endif +#ifndef TclBN_mp_cmp_mag_TCL_DECLARED +#define TclBN_mp_cmp_mag_TCL_DECLARED /* 10 */ -EXTERN mp_ord TclBN_mp_cmp_mag(const mp_int *a, const mp_int *b) MP_WUR; +EXTERN int TclBN_mp_cmp_mag(CONST mp_int *a, CONST mp_int *b); +#endif +#ifndef TclBN_mp_copy_TCL_DECLARED +#define TclBN_mp_copy_TCL_DECLARED /* 11 */ -EXTERN mp_err TclBN_mp_copy(const mp_int *a, mp_int *b) MP_WUR; +EXTERN int TclBN_mp_copy(mp_int *a, mp_int *b); +#endif +#ifndef TclBN_mp_count_bits_TCL_DECLARED +#define TclBN_mp_count_bits_TCL_DECLARED /* 12 */ -EXTERN int TclBN_mp_count_bits(const mp_int *a) MP_WUR; +EXTERN int TclBN_mp_count_bits(mp_int *a); +#endif +#ifndef TclBN_mp_div_TCL_DECLARED +#define TclBN_mp_div_TCL_DECLARED /* 13 */ -EXTERN mp_err TclBN_mp_div(const mp_int *a, const mp_int *b, - mp_int *q, mp_int *r) MP_WUR; +EXTERN int TclBN_mp_div(mp_int *a, mp_int *b, mp_int *q, + mp_int *r); +#endif +#ifndef TclBN_mp_div_d_TCL_DECLARED +#define TclBN_mp_div_d_TCL_DECLARED /* 14 */ -EXTERN mp_err TclBN_mp_div_d(const mp_int *a, mp_digit b, - mp_int *q, mp_digit *r) MP_WUR; +EXTERN int TclBN_mp_div_d(mp_int *a, mp_digit b, mp_int *q, + mp_digit *r); +#endif +#ifndef TclBN_mp_div_2_TCL_DECLARED +#define TclBN_mp_div_2_TCL_DECLARED /* 15 */ -EXTERN mp_err TclBN_mp_div_2(const mp_int *a, mp_int *q) MP_WUR; +EXTERN int TclBN_mp_div_2(mp_int *a, mp_int *q); +#endif +#ifndef TclBN_mp_div_2d_TCL_DECLARED +#define TclBN_mp_div_2d_TCL_DECLARED /* 16 */ -EXTERN mp_err TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q, - mp_int *r) MP_WUR; -/* Slot 17 is reserved */ +EXTERN int TclBN_mp_div_2d(mp_int *a, int b, mp_int *q, + mp_int *r); +#endif +#ifndef TclBN_mp_div_3_TCL_DECLARED +#define TclBN_mp_div_3_TCL_DECLARED +/* 17 */ +EXTERN int TclBN_mp_div_3(mp_int *a, mp_int *q, mp_digit *r); +#endif +#ifndef TclBN_mp_exch_TCL_DECLARED +#define TclBN_mp_exch_TCL_DECLARED /* 18 */ EXTERN void TclBN_mp_exch(mp_int *a, mp_int *b); +#endif +#ifndef TclBN_mp_expt_d_TCL_DECLARED +#define TclBN_mp_expt_d_TCL_DECLARED /* 19 */ -EXTERN mp_err TclBN_mp_expt_u32(const mp_int *a, uint32_t b, - mp_int *c) MP_WUR; +EXTERN int TclBN_mp_expt_d(mp_int *a, mp_digit b, mp_int *c); +#endif +#ifndef TclBN_mp_grow_TCL_DECLARED +#define TclBN_mp_grow_TCL_DECLARED /* 20 */ -EXTERN mp_err TclBN_mp_grow(mp_int *a, int size) MP_WUR; +EXTERN int TclBN_mp_grow(mp_int *a, int size); +#endif +#ifndef TclBN_mp_init_TCL_DECLARED +#define TclBN_mp_init_TCL_DECLARED /* 21 */ -EXTERN mp_err TclBN_mp_init(mp_int *a) MP_WUR; +EXTERN int TclBN_mp_init(mp_int *a); +#endif +#ifndef TclBN_mp_init_copy_TCL_DECLARED +#define TclBN_mp_init_copy_TCL_DECLARED /* 22 */ -EXTERN mp_err TclBN_mp_init_copy(mp_int *a, const mp_int *b) MP_WUR; +EXTERN int TclBN_mp_init_copy(mp_int *a, mp_int *b); +#endif +#ifndef TclBN_mp_init_multi_TCL_DECLARED +#define TclBN_mp_init_multi_TCL_DECLARED /* 23 */ -EXTERN mp_err TclBN_mp_init_multi(mp_int *a, ...) MP_WUR; +EXTERN int TclBN_mp_init_multi(mp_int *a, ...); +#endif +#ifndef TclBN_mp_init_set_TCL_DECLARED +#define TclBN_mp_init_set_TCL_DECLARED /* 24 */ -EXTERN mp_err TclBN_mp_init_set(mp_int *a, mp_digit b) MP_WUR; +EXTERN int TclBN_mp_init_set(mp_int *a, mp_digit b); +#endif +#ifndef TclBN_mp_init_size_TCL_DECLARED +#define TclBN_mp_init_size_TCL_DECLARED /* 25 */ -EXTERN mp_err TclBN_mp_init_size(mp_int *a, int size) MP_WUR; +EXTERN int TclBN_mp_init_size(mp_int *a, int size); +#endif +#ifndef TclBN_mp_lshd_TCL_DECLARED +#define TclBN_mp_lshd_TCL_DECLARED /* 26 */ -EXTERN mp_err TclBN_mp_lshd(mp_int *a, int shift) MP_WUR; +EXTERN int TclBN_mp_lshd(mp_int *a, int shift); +#endif +#ifndef TclBN_mp_mod_TCL_DECLARED +#define TclBN_mp_mod_TCL_DECLARED /* 27 */ -EXTERN mp_err TclBN_mp_mod(const mp_int *a, const mp_int *b, - mp_int *r) MP_WUR; +EXTERN int TclBN_mp_mod(mp_int *a, mp_int *b, mp_int *r); +#endif +#ifndef TclBN_mp_mod_2d_TCL_DECLARED +#define TclBN_mp_mod_2d_TCL_DECLARED /* 28 */ -EXTERN mp_err TclBN_mp_mod_2d(const mp_int *a, int b, mp_int *r) MP_WUR; +EXTERN int TclBN_mp_mod_2d(mp_int *a, int b, mp_int *r); +#endif +#ifndef TclBN_mp_mul_TCL_DECLARED +#define TclBN_mp_mul_TCL_DECLARED /* 29 */ -EXTERN mp_err TclBN_mp_mul(const mp_int *a, const mp_int *b, - mp_int *p) MP_WUR; +EXTERN int TclBN_mp_mul(mp_int *a, mp_int *b, mp_int *p); +#endif +#ifndef TclBN_mp_mul_d_TCL_DECLARED +#define TclBN_mp_mul_d_TCL_DECLARED /* 30 */ -EXTERN mp_err TclBN_mp_mul_d(const mp_int *a, mp_digit b, - mp_int *p) MP_WUR; +EXTERN int TclBN_mp_mul_d(mp_int *a, mp_digit b, mp_int *p); +#endif +#ifndef TclBN_mp_mul_2_TCL_DECLARED +#define TclBN_mp_mul_2_TCL_DECLARED /* 31 */ -EXTERN mp_err TclBN_mp_mul_2(const mp_int *a, mp_int *p) MP_WUR; +EXTERN int TclBN_mp_mul_2(mp_int *a, mp_int *p); +#endif +#ifndef TclBN_mp_mul_2d_TCL_DECLARED +#define TclBN_mp_mul_2d_TCL_DECLARED /* 32 */ -EXTERN mp_err TclBN_mp_mul_2d(const mp_int *a, int d, mp_int *p) MP_WUR; +EXTERN int TclBN_mp_mul_2d(mp_int *a, int d, mp_int *p); +#endif +#ifndef TclBN_mp_neg_TCL_DECLARED +#define TclBN_mp_neg_TCL_DECLARED /* 33 */ -EXTERN mp_err TclBN_mp_neg(const mp_int *a, mp_int *b) MP_WUR; +EXTERN int TclBN_mp_neg(mp_int *a, mp_int *b); +#endif +#ifndef TclBN_mp_or_TCL_DECLARED +#define TclBN_mp_or_TCL_DECLARED /* 34 */ -EXTERN mp_err TclBN_mp_or(const mp_int *a, const mp_int *b, - mp_int *c) MP_WUR; +EXTERN int TclBN_mp_or(CONST mp_int *a, CONST mp_int *b, + mp_int *c); +#endif +#ifndef TclBN_mp_radix_size_TCL_DECLARED +#define TclBN_mp_radix_size_TCL_DECLARED /* 35 */ -EXTERN mp_err TclBN_mp_radix_size(const mp_int *a, int radix, - int *size) MP_WUR; +EXTERN int TclBN_mp_radix_size(mp_int *a, int radix, int *size); +#endif +#ifndef TclBN_mp_read_radix_TCL_DECLARED +#define TclBN_mp_read_radix_TCL_DECLARED /* 36 */ -EXTERN mp_err TclBN_mp_read_radix(mp_int *a, const char *str, - int radix) MP_WUR; +EXTERN int TclBN_mp_read_radix(mp_int *a, CONST char *str, + int radix); +#endif +#ifndef TclBN_mp_rshd_TCL_DECLARED +#define TclBN_mp_rshd_TCL_DECLARED /* 37 */ EXTERN void TclBN_mp_rshd(mp_int *a, int shift); +#endif +#ifndef TclBN_mp_shrink_TCL_DECLARED +#define TclBN_mp_shrink_TCL_DECLARED /* 38 */ -EXTERN mp_err TclBN_mp_shrink(mp_int *a) MP_WUR; -/* Slot 39 is reserved */ -/* Slot 40 is reserved */ +EXTERN int TclBN_mp_shrink(mp_int *a); +#endif +#ifndef TclBN_mp_set_TCL_DECLARED +#define TclBN_mp_set_TCL_DECLARED +/* 39 */ +EXTERN void TclBN_mp_set(mp_int *a, mp_digit b); +#endif +#ifndef TclBN_mp_sqr_TCL_DECLARED +#define TclBN_mp_sqr_TCL_DECLARED +/* 40 */ +EXTERN int TclBN_mp_sqr(mp_int *a, mp_int *b); +#endif +#ifndef TclBN_mp_sqrt_TCL_DECLARED +#define TclBN_mp_sqrt_TCL_DECLARED /* 41 */ -EXTERN mp_err TclBN_mp_sqrt(const mp_int *a, mp_int *b) MP_WUR; +EXTERN int TclBN_mp_sqrt(mp_int *a, mp_int *b); +#endif +#ifndef TclBN_mp_sub_TCL_DECLARED +#define TclBN_mp_sub_TCL_DECLARED /* 42 */ -EXTERN mp_err TclBN_mp_sub(const mp_int *a, const mp_int *b, - mp_int *c) MP_WUR; +EXTERN int TclBN_mp_sub(mp_int *a, mp_int *b, mp_int *c); +#endif +#ifndef TclBN_mp_sub_d_TCL_DECLARED +#define TclBN_mp_sub_d_TCL_DECLARED /* 43 */ -EXTERN mp_err TclBN_mp_sub_d(const mp_int *a, mp_digit b, - mp_int *c) MP_WUR; -/* Slot 44 is reserved */ -/* Slot 45 is reserved */ -/* Slot 46 is reserved */ +EXTERN int TclBN_mp_sub_d(mp_int *a, mp_digit b, mp_int *c); +#endif +#ifndef TclBN_mp_to_unsigned_bin_TCL_DECLARED +#define TclBN_mp_to_unsigned_bin_TCL_DECLARED +/* 44 */ +EXTERN int TclBN_mp_to_unsigned_bin(mp_int *a, unsigned char *b); +#endif +#ifndef TclBN_mp_to_unsigned_bin_n_TCL_DECLARED +#define TclBN_mp_to_unsigned_bin_n_TCL_DECLARED +/* 45 */ +EXTERN int TclBN_mp_to_unsigned_bin_n(mp_int *a, + unsigned char *b, unsigned long *outlen); +#endif +#ifndef TclBN_mp_toradix_n_TCL_DECLARED +#define TclBN_mp_toradix_n_TCL_DECLARED +/* 46 */ +EXTERN int TclBN_mp_toradix_n(mp_int *a, char *str, int radix, + int maxlen); +#endif +#ifndef TclBN_mp_unsigned_bin_size_TCL_DECLARED +#define TclBN_mp_unsigned_bin_size_TCL_DECLARED /* 47 */ -EXTERN size_t TclBN_mp_ubin_size(const mp_int *a) MP_WUR; +EXTERN int TclBN_mp_unsigned_bin_size(mp_int *a); +#endif +#ifndef TclBN_mp_xor_TCL_DECLARED +#define TclBN_mp_xor_TCL_DECLARED /* 48 */ -EXTERN mp_err TclBN_mp_xor(const mp_int *a, const mp_int *b, - mp_int *c) MP_WUR; +EXTERN int TclBN_mp_xor(CONST mp_int *a, CONST mp_int *b, + mp_int *c); +#endif +#ifndef TclBN_mp_zero_TCL_DECLARED +#define TclBN_mp_zero_TCL_DECLARED /* 49 */ EXTERN void TclBN_mp_zero(mp_int *a); -/* Slot 50 is reserved */ -/* Slot 51 is reserved */ -/* Slot 52 is reserved */ -/* Slot 53 is reserved */ -/* Slot 54 is reserved */ -/* Slot 55 is reserved */ -/* Slot 56 is reserved */ -/* Slot 57 is reserved */ -/* Slot 58 is reserved */ -/* Slot 59 is reserved */ -/* Slot 60 is reserved */ -/* Slot 61 is reserved */ -/* Slot 62 is reserved */ +#endif +#ifndef TclBN_reverse_TCL_DECLARED +#define TclBN_reverse_TCL_DECLARED +/* 50 */ +EXTERN void TclBN_reverse(unsigned char *s, int len); +#endif +#ifndef TclBN_fast_s_mp_mul_digs_TCL_DECLARED +#define TclBN_fast_s_mp_mul_digs_TCL_DECLARED +/* 51 */ +EXTERN int TclBN_fast_s_mp_mul_digs(mp_int *a, mp_int *b, + mp_int *c, int digs); +#endif +#ifndef TclBN_fast_s_mp_sqr_TCL_DECLARED +#define TclBN_fast_s_mp_sqr_TCL_DECLARED +/* 52 */ +EXTERN int TclBN_fast_s_mp_sqr(mp_int *a, mp_int *b); +#endif +#ifndef TclBN_mp_karatsuba_mul_TCL_DECLARED +#define TclBN_mp_karatsuba_mul_TCL_DECLARED +/* 53 */ +EXTERN int TclBN_mp_karatsuba_mul(mp_int *a, mp_int *b, + mp_int *c); +#endif +#ifndef TclBN_mp_karatsuba_sqr_TCL_DECLARED +#define TclBN_mp_karatsuba_sqr_TCL_DECLARED +/* 54 */ +EXTERN int TclBN_mp_karatsuba_sqr(mp_int *a, mp_int *b); +#endif +#ifndef TclBN_mp_toom_mul_TCL_DECLARED +#define TclBN_mp_toom_mul_TCL_DECLARED +/* 55 */ +EXTERN int TclBN_mp_toom_mul(mp_int *a, mp_int *b, mp_int *c); +#endif +#ifndef TclBN_mp_toom_sqr_TCL_DECLARED +#define TclBN_mp_toom_sqr_TCL_DECLARED +/* 56 */ +EXTERN int TclBN_mp_toom_sqr(mp_int *a, mp_int *b); +#endif +#ifndef TclBN_s_mp_add_TCL_DECLARED +#define TclBN_s_mp_add_TCL_DECLARED +/* 57 */ +EXTERN int TclBN_s_mp_add(mp_int *a, mp_int *b, mp_int *c); +#endif +#ifndef TclBN_s_mp_mul_digs_TCL_DECLARED +#define TclBN_s_mp_mul_digs_TCL_DECLARED +/* 58 */ +EXTERN int TclBN_s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, + int digs); +#endif +#ifndef TclBN_s_mp_sqr_TCL_DECLARED +#define TclBN_s_mp_sqr_TCL_DECLARED +/* 59 */ +EXTERN int TclBN_s_mp_sqr(mp_int *a, mp_int *b); +#endif +#ifndef TclBN_s_mp_sub_TCL_DECLARED +#define TclBN_s_mp_sub_TCL_DECLARED +/* 60 */ +EXTERN int TclBN_s_mp_sub(mp_int *a, mp_int *b, mp_int *c); +#endif +#ifndef TclBN_mp_init_set_int_TCL_DECLARED +#define TclBN_mp_init_set_int_TCL_DECLARED +/* 61 */ +EXTERN int TclBN_mp_init_set_int(mp_int *a, unsigned long i); +#endif +#ifndef TclBN_mp_set_int_TCL_DECLARED +#define TclBN_mp_set_int_TCL_DECLARED +/* 62 */ +EXTERN int TclBN_mp_set_int(mp_int *a, unsigned long i); +#endif +#ifndef TclBN_mp_cnt_lsb_TCL_DECLARED +#define TclBN_mp_cnt_lsb_TCL_DECLARED /* 63 */ -EXTERN int TclBN_mp_cnt_lsb(const mp_int *a) MP_WUR; +EXTERN int TclBN_mp_cnt_lsb(mp_int *a); +#endif /* Slot 64 is reserved */ -/* 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; +/* Slot 65 is reserved */ +/* Slot 66 is reserved */ /* Slot 67 is reserved */ -/* 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 68 is reserved */ +/* Slot 69 is reserved */ +/* Slot 70 is reserved */ /* Slot 71 is reserved */ /* Slot 72 is reserved */ /* Slot 73 is reserved */ /* Slot 74 is reserved */ /* Slot 75 is reserved */ -/* 76 */ -EXTERN mp_err TclBN_mp_signed_rsh(const mp_int *a, int b, - mp_int *c) MP_WUR; +/* Slot 76 is reserved */ /* 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; +/* Slot 78 is reserved */ /* Slot 79 is reserved */ +#ifndef TclUnusedStubEntry_TCL_DECLARED +#define TclUnusedStubEntry_TCL_DECLARED /* 80 */ -EXTERN int TclBN_mp_to_radix(const mp_int *a, char *str, - size_t maxlen, size_t *written, int radix) MP_WUR; +EXTERN void TclUnusedStubEntry(void); +#endif typedef struct TclTomMathStubs { int magic; - void *hooks; + struct TclTomMathStubHooks *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, mp_digit 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 */ + int (*tclBN_epoch) (void); /* 0 */ + int (*tclBN_revision) (void); /* 1 */ + int (*tclBN_mp_add) (mp_int *a, mp_int *b, mp_int *c); /* 2 */ + int (*tclBN_mp_add_d) (mp_int *a, mp_digit b, mp_int *c); /* 3 */ + int (*tclBN_mp_and) (CONST mp_int *a, CONST mp_int *b, mp_int *c); /* 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, mp_digit 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, mp_digit b, mp_int *q, mp_digit *r) MP_WUR; /* 14 */ - mp_err (*tclBN_mp_div_2) (const mp_int *a, mp_int *q) MP_WUR; /* 15 */ - mp_err (*tclBN_mp_div_2d) (const mp_int *a, int b, mp_int *q, mp_int *r) MP_WUR; /* 16 */ - void (*reserved17)(void); + int (*tclBN_mp_cmp) (CONST mp_int *a, CONST mp_int *b); /* 8 */ + int (*tclBN_mp_cmp_d) (CONST mp_int *a, mp_digit b); /* 9 */ + int (*tclBN_mp_cmp_mag) (CONST mp_int *a, CONST mp_int *b); /* 10 */ + int (*tclBN_mp_copy) (mp_int *a, mp_int *b); /* 11 */ + int (*tclBN_mp_count_bits) (mp_int *a); /* 12 */ + int (*tclBN_mp_div) (mp_int *a, mp_int *b, mp_int *q, mp_int *r); /* 13 */ + int (*tclBN_mp_div_d) (mp_int *a, mp_digit b, mp_int *q, mp_digit *r); /* 14 */ + int (*tclBN_mp_div_2) (mp_int *a, mp_int *q); /* 15 */ + int (*tclBN_mp_div_2d) (mp_int *a, int b, mp_int *q, mp_int *r); /* 16 */ + int (*tclBN_mp_div_3) (mp_int *a, mp_int *q, mp_digit *r); /* 17 */ void (*tclBN_mp_exch) (mp_int *a, mp_int *b); /* 18 */ - mp_err (*tclBN_mp_expt_u32) (const mp_int *a, uint32_t b, mp_int *c) MP_WUR; /* 19 */ - mp_err (*tclBN_mp_grow) (mp_int *a, int size) MP_WUR; /* 20 */ - mp_err (*tclBN_mp_init) (mp_int *a) MP_WUR; /* 21 */ - mp_err (*tclBN_mp_init_copy) (mp_int *a, const mp_int *b) MP_WUR; /* 22 */ - mp_err (*tclBN_mp_init_multi) (mp_int *a, ...) MP_WUR; /* 23 */ - mp_err (*tclBN_mp_init_set) (mp_int *a, mp_digit b) MP_WUR; /* 24 */ - mp_err (*tclBN_mp_init_size) (mp_int *a, int size) MP_WUR; /* 25 */ - mp_err (*tclBN_mp_lshd) (mp_int *a, int shift) MP_WUR; /* 26 */ - 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, mp_digit 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 */ + int (*tclBN_mp_expt_d) (mp_int *a, mp_digit b, mp_int *c); /* 19 */ + int (*tclBN_mp_grow) (mp_int *a, int size); /* 20 */ + int (*tclBN_mp_init) (mp_int *a); /* 21 */ + int (*tclBN_mp_init_copy) (mp_int *a, mp_int *b); /* 22 */ + int (*tclBN_mp_init_multi) (mp_int *a, ...); /* 23 */ + int (*tclBN_mp_init_set) (mp_int *a, mp_digit b); /* 24 */ + int (*tclBN_mp_init_size) (mp_int *a, int size); /* 25 */ + int (*tclBN_mp_lshd) (mp_int *a, int shift); /* 26 */ + int (*tclBN_mp_mod) (mp_int *a, mp_int *b, mp_int *r); /* 27 */ + int (*tclBN_mp_mod_2d) (mp_int *a, int b, mp_int *r); /* 28 */ + int (*tclBN_mp_mul) (mp_int *a, mp_int *b, mp_int *p); /* 29 */ + int (*tclBN_mp_mul_d) (mp_int *a, mp_digit b, mp_int *p); /* 30 */ + int (*tclBN_mp_mul_2) (mp_int *a, mp_int *p); /* 31 */ + int (*tclBN_mp_mul_2d) (mp_int *a, int d, mp_int *p); /* 32 */ + int (*tclBN_mp_neg) (mp_int *a, mp_int *b); /* 33 */ + int (*tclBN_mp_or) (CONST mp_int *a, CONST mp_int *b, mp_int *c); /* 34 */ + int (*tclBN_mp_radix_size) (mp_int *a, int radix, int *size); /* 35 */ + int (*tclBN_mp_read_radix) (mp_int *a, CONST char *str, int radix); /* 36 */ void (*tclBN_mp_rshd) (mp_int *a, int shift); /* 37 */ - mp_err (*tclBN_mp_shrink) (mp_int *a) MP_WUR; /* 38 */ - void (*reserved39)(void); - void (*reserved40)(void); - 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, mp_digit b, mp_int *c) MP_WUR; /* 43 */ - void (*reserved44)(void); - void (*reserved45)(void); - void (*reserved46)(void); - size_t (*tclBN_mp_ubin_size) (const mp_int *a) MP_WUR; /* 47 */ - mp_err (*tclBN_mp_xor) (const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 48 */ + int (*tclBN_mp_shrink) (mp_int *a); /* 38 */ + void (*tclBN_mp_set) (mp_int *a, mp_digit b); /* 39 */ + int (*tclBN_mp_sqr) (mp_int *a, mp_int *b); /* 40 */ + int (*tclBN_mp_sqrt) (mp_int *a, mp_int *b); /* 41 */ + int (*tclBN_mp_sub) (mp_int *a, mp_int *b, mp_int *c); /* 42 */ + int (*tclBN_mp_sub_d) (mp_int *a, mp_digit b, mp_int *c); /* 43 */ + int (*tclBN_mp_to_unsigned_bin) (mp_int *a, unsigned char *b); /* 44 */ + int (*tclBN_mp_to_unsigned_bin_n) (mp_int *a, unsigned char *b, unsigned long *outlen); /* 45 */ + int (*tclBN_mp_toradix_n) (mp_int *a, char *str, int radix, int maxlen); /* 46 */ + int (*tclBN_mp_unsigned_bin_size) (mp_int *a); /* 47 */ + int (*tclBN_mp_xor) (CONST mp_int *a, CONST mp_int *b, mp_int *c); /* 48 */ void (*tclBN_mp_zero) (mp_int *a); /* 49 */ - void (*reserved50)(void); - void (*reserved51)(void); - void (*reserved52)(void); - void (*reserved53)(void); - void (*reserved54)(void); - void (*reserved55)(void); - void (*reserved56)(void); - void (*reserved57)(void); - void (*reserved58)(void); - void (*reserved59)(void); - void (*reserved60)(void); - void (*reserved61)(void); - void (*reserved62)(void); - int (*tclBN_mp_cnt_lsb) (const mp_int *a) MP_WUR; /* 63 */ - void (*reserved64)(void); - 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 */ - void (*reserved67)(void); - 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); - void (*reserved73)(void); - void (*reserved74)(void); - void (*reserved75)(void); - 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 */ - void (*reserved79)(void); - int (*tclBN_mp_to_radix) (const mp_int *a, char *str, size_t maxlen, size_t *written, int radix) MP_WUR; /* 80 */ + void (*tclBN_reverse) (unsigned char *s, int len); /* 50 */ + int (*tclBN_fast_s_mp_mul_digs) (mp_int *a, mp_int *b, mp_int *c, int digs); /* 51 */ + int (*tclBN_fast_s_mp_sqr) (mp_int *a, mp_int *b); /* 52 */ + int (*tclBN_mp_karatsuba_mul) (mp_int *a, mp_int *b, mp_int *c); /* 53 */ + int (*tclBN_mp_karatsuba_sqr) (mp_int *a, mp_int *b); /* 54 */ + int (*tclBN_mp_toom_mul) (mp_int *a, mp_int *b, mp_int *c); /* 55 */ + int (*tclBN_mp_toom_sqr) (mp_int *a, mp_int *b); /* 56 */ + int (*tclBN_s_mp_add) (mp_int *a, mp_int *b, mp_int *c); /* 57 */ + int (*tclBN_s_mp_mul_digs) (mp_int *a, mp_int *b, mp_int *c, int digs); /* 58 */ + int (*tclBN_s_mp_sqr) (mp_int *a, mp_int *b); /* 59 */ + int (*tclBN_s_mp_sub) (mp_int *a, mp_int *b, mp_int *c); /* 60 */ + int (*tclBN_mp_init_set_int) (mp_int *a, unsigned long i); /* 61 */ + int (*tclBN_mp_set_int) (mp_int *a, unsigned long i); /* 62 */ + int (*tclBN_mp_cnt_lsb) (mp_int *a); /* 63 */ + VOID *reserved64; + VOID *reserved65; + VOID *reserved66; + VOID *reserved67; + VOID *reserved68; + VOID *reserved69; + VOID *reserved70; + VOID *reserved71; + VOID *reserved72; + VOID *reserved73; + VOID *reserved74; + VOID *reserved75; + VOID *reserved76; + VOID *reserved77; + VOID *reserved78; + VOID *reserved79; + void (*tclUnusedStubEntry) (void); /* 80 */ } TclTomMathStubs; -extern const TclTomMathStubs *tclTomMathStubsPtr; +extern TclTomMathStubs *tclTomMathStubsPtr; #ifdef __cplusplus } #endif -#if defined(USE_TCL_STUBS) +#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) /* * Inline function declarations: */ +#ifndef TclBN_epoch #define TclBN_epoch \ (tclTomMathStubsPtr->tclBN_epoch) /* 0 */ +#endif +#ifndef TclBN_revision #define TclBN_revision \ (tclTomMathStubsPtr->tclBN_revision) /* 1 */ +#endif +#ifndef TclBN_mp_add #define TclBN_mp_add \ (tclTomMathStubsPtr->tclBN_mp_add) /* 2 */ +#endif +#ifndef TclBN_mp_add_d #define TclBN_mp_add_d \ (tclTomMathStubsPtr->tclBN_mp_add_d) /* 3 */ +#endif +#ifndef TclBN_mp_and #define TclBN_mp_and \ (tclTomMathStubsPtr->tclBN_mp_and) /* 4 */ +#endif +#ifndef TclBN_mp_clamp #define TclBN_mp_clamp \ (tclTomMathStubsPtr->tclBN_mp_clamp) /* 5 */ +#endif +#ifndef TclBN_mp_clear #define TclBN_mp_clear \ (tclTomMathStubsPtr->tclBN_mp_clear) /* 6 */ +#endif +#ifndef TclBN_mp_clear_multi #define TclBN_mp_clear_multi \ (tclTomMathStubsPtr->tclBN_mp_clear_multi) /* 7 */ +#endif +#ifndef TclBN_mp_cmp #define TclBN_mp_cmp \ (tclTomMathStubsPtr->tclBN_mp_cmp) /* 8 */ +#endif +#ifndef TclBN_mp_cmp_d #define TclBN_mp_cmp_d \ (tclTomMathStubsPtr->tclBN_mp_cmp_d) /* 9 */ +#endif +#ifndef TclBN_mp_cmp_mag #define TclBN_mp_cmp_mag \ (tclTomMathStubsPtr->tclBN_mp_cmp_mag) /* 10 */ +#endif +#ifndef TclBN_mp_copy #define TclBN_mp_copy \ (tclTomMathStubsPtr->tclBN_mp_copy) /* 11 */ +#endif +#ifndef TclBN_mp_count_bits #define TclBN_mp_count_bits \ (tclTomMathStubsPtr->tclBN_mp_count_bits) /* 12 */ +#endif +#ifndef TclBN_mp_div #define TclBN_mp_div \ (tclTomMathStubsPtr->tclBN_mp_div) /* 13 */ +#endif +#ifndef TclBN_mp_div_d #define TclBN_mp_div_d \ (tclTomMathStubsPtr->tclBN_mp_div_d) /* 14 */ +#endif +#ifndef TclBN_mp_div_2 #define TclBN_mp_div_2 \ (tclTomMathStubsPtr->tclBN_mp_div_2) /* 15 */ +#endif +#ifndef TclBN_mp_div_2d #define TclBN_mp_div_2d \ (tclTomMathStubsPtr->tclBN_mp_div_2d) /* 16 */ -/* Slot 17 is reserved */ +#endif +#ifndef TclBN_mp_div_3 +#define TclBN_mp_div_3 \ + (tclTomMathStubsPtr->tclBN_mp_div_3) /* 17 */ +#endif +#ifndef TclBN_mp_exch #define TclBN_mp_exch \ (tclTomMathStubsPtr->tclBN_mp_exch) /* 18 */ -#define TclBN_mp_expt_u32 \ - (tclTomMathStubsPtr->tclBN_mp_expt_u32) /* 19 */ +#endif +#ifndef TclBN_mp_expt_d +#define TclBN_mp_expt_d \ + (tclTomMathStubsPtr->tclBN_mp_expt_d) /* 19 */ +#endif +#ifndef TclBN_mp_grow #define TclBN_mp_grow \ (tclTomMathStubsPtr->tclBN_mp_grow) /* 20 */ +#endif +#ifndef TclBN_mp_init #define TclBN_mp_init \ (tclTomMathStubsPtr->tclBN_mp_init) /* 21 */ +#endif +#ifndef TclBN_mp_init_copy #define TclBN_mp_init_copy \ (tclTomMathStubsPtr->tclBN_mp_init_copy) /* 22 */ +#endif +#ifndef TclBN_mp_init_multi #define TclBN_mp_init_multi \ (tclTomMathStubsPtr->tclBN_mp_init_multi) /* 23 */ +#endif +#ifndef TclBN_mp_init_set #define TclBN_mp_init_set \ (tclTomMathStubsPtr->tclBN_mp_init_set) /* 24 */ +#endif +#ifndef TclBN_mp_init_size #define TclBN_mp_init_size \ (tclTomMathStubsPtr->tclBN_mp_init_size) /* 25 */ +#endif +#ifndef TclBN_mp_lshd #define TclBN_mp_lshd \ (tclTomMathStubsPtr->tclBN_mp_lshd) /* 26 */ +#endif +#ifndef TclBN_mp_mod #define TclBN_mp_mod \ (tclTomMathStubsPtr->tclBN_mp_mod) /* 27 */ +#endif +#ifndef TclBN_mp_mod_2d #define TclBN_mp_mod_2d \ (tclTomMathStubsPtr->tclBN_mp_mod_2d) /* 28 */ +#endif +#ifndef TclBN_mp_mul #define TclBN_mp_mul \ (tclTomMathStubsPtr->tclBN_mp_mul) /* 29 */ +#endif +#ifndef TclBN_mp_mul_d #define TclBN_mp_mul_d \ (tclTomMathStubsPtr->tclBN_mp_mul_d) /* 30 */ +#endif +#ifndef TclBN_mp_mul_2 #define TclBN_mp_mul_2 \ (tclTomMathStubsPtr->tclBN_mp_mul_2) /* 31 */ +#endif +#ifndef TclBN_mp_mul_2d #define TclBN_mp_mul_2d \ (tclTomMathStubsPtr->tclBN_mp_mul_2d) /* 32 */ +#endif +#ifndef TclBN_mp_neg #define TclBN_mp_neg \ (tclTomMathStubsPtr->tclBN_mp_neg) /* 33 */ +#endif +#ifndef TclBN_mp_or #define TclBN_mp_or \ (tclTomMathStubsPtr->tclBN_mp_or) /* 34 */ +#endif +#ifndef TclBN_mp_radix_size #define TclBN_mp_radix_size \ (tclTomMathStubsPtr->tclBN_mp_radix_size) /* 35 */ +#endif +#ifndef TclBN_mp_read_radix #define TclBN_mp_read_radix \ (tclTomMathStubsPtr->tclBN_mp_read_radix) /* 36 */ +#endif +#ifndef TclBN_mp_rshd #define TclBN_mp_rshd \ (tclTomMathStubsPtr->tclBN_mp_rshd) /* 37 */ +#endif +#ifndef TclBN_mp_shrink #define TclBN_mp_shrink \ (tclTomMathStubsPtr->tclBN_mp_shrink) /* 38 */ -/* Slot 39 is reserved */ -/* Slot 40 is reserved */ +#endif +#ifndef TclBN_mp_set +#define TclBN_mp_set \ + (tclTomMathStubsPtr->tclBN_mp_set) /* 39 */ +#endif +#ifndef TclBN_mp_sqr +#define TclBN_mp_sqr \ + (tclTomMathStubsPtr->tclBN_mp_sqr) /* 40 */ +#endif +#ifndef TclBN_mp_sqrt #define TclBN_mp_sqrt \ (tclTomMathStubsPtr->tclBN_mp_sqrt) /* 41 */ +#endif +#ifndef TclBN_mp_sub #define TclBN_mp_sub \ (tclTomMathStubsPtr->tclBN_mp_sub) /* 42 */ +#endif +#ifndef TclBN_mp_sub_d #define TclBN_mp_sub_d \ (tclTomMathStubsPtr->tclBN_mp_sub_d) /* 43 */ -/* Slot 44 is reserved */ -/* Slot 45 is reserved */ -/* Slot 46 is reserved */ -#define TclBN_mp_ubin_size \ - (tclTomMathStubsPtr->tclBN_mp_ubin_size) /* 47 */ +#endif +#ifndef TclBN_mp_to_unsigned_bin +#define TclBN_mp_to_unsigned_bin \ + (tclTomMathStubsPtr->tclBN_mp_to_unsigned_bin) /* 44 */ +#endif +#ifndef TclBN_mp_to_unsigned_bin_n +#define TclBN_mp_to_unsigned_bin_n \ + (tclTomMathStubsPtr->tclBN_mp_to_unsigned_bin_n) /* 45 */ +#endif +#ifndef TclBN_mp_toradix_n +#define TclBN_mp_toradix_n \ + (tclTomMathStubsPtr->tclBN_mp_toradix_n) /* 46 */ +#endif +#ifndef TclBN_mp_unsigned_bin_size +#define TclBN_mp_unsigned_bin_size \ + (tclTomMathStubsPtr->tclBN_mp_unsigned_bin_size) /* 47 */ +#endif +#ifndef TclBN_mp_xor #define TclBN_mp_xor \ (tclTomMathStubsPtr->tclBN_mp_xor) /* 48 */ +#endif +#ifndef TclBN_mp_zero #define TclBN_mp_zero \ (tclTomMathStubsPtr->tclBN_mp_zero) /* 49 */ -/* Slot 50 is reserved */ -/* Slot 51 is reserved */ -/* Slot 52 is reserved */ -/* Slot 53 is reserved */ -/* Slot 54 is reserved */ -/* Slot 55 is reserved */ -/* Slot 56 is reserved */ -/* Slot 57 is reserved */ -/* Slot 58 is reserved */ -/* Slot 59 is reserved */ -/* Slot 60 is reserved */ -/* Slot 61 is reserved */ -/* Slot 62 is reserved */ +#endif +#ifndef TclBN_reverse +#define TclBN_reverse \ + (tclTomMathStubsPtr->tclBN_reverse) /* 50 */ +#endif +#ifndef TclBN_fast_s_mp_mul_digs +#define TclBN_fast_s_mp_mul_digs \ + (tclTomMathStubsPtr->tclBN_fast_s_mp_mul_digs) /* 51 */ +#endif +#ifndef TclBN_fast_s_mp_sqr +#define TclBN_fast_s_mp_sqr \ + (tclTomMathStubsPtr->tclBN_fast_s_mp_sqr) /* 52 */ +#endif +#ifndef TclBN_mp_karatsuba_mul +#define TclBN_mp_karatsuba_mul \ + (tclTomMathStubsPtr->tclBN_mp_karatsuba_mul) /* 53 */ +#endif +#ifndef TclBN_mp_karatsuba_sqr +#define TclBN_mp_karatsuba_sqr \ + (tclTomMathStubsPtr->tclBN_mp_karatsuba_sqr) /* 54 */ +#endif +#ifndef TclBN_mp_toom_mul +#define TclBN_mp_toom_mul \ + (tclTomMathStubsPtr->tclBN_mp_toom_mul) /* 55 */ +#endif +#ifndef TclBN_mp_toom_sqr +#define TclBN_mp_toom_sqr \ + (tclTomMathStubsPtr->tclBN_mp_toom_sqr) /* 56 */ +#endif +#ifndef TclBN_s_mp_add +#define TclBN_s_mp_add \ + (tclTomMathStubsPtr->tclBN_s_mp_add) /* 57 */ +#endif +#ifndef TclBN_s_mp_mul_digs +#define TclBN_s_mp_mul_digs \ + (tclTomMathStubsPtr->tclBN_s_mp_mul_digs) /* 58 */ +#endif +#ifndef TclBN_s_mp_sqr +#define TclBN_s_mp_sqr \ + (tclTomMathStubsPtr->tclBN_s_mp_sqr) /* 59 */ +#endif +#ifndef TclBN_s_mp_sub +#define TclBN_s_mp_sub \ + (tclTomMathStubsPtr->tclBN_s_mp_sub) /* 60 */ +#endif +#ifndef TclBN_mp_init_set_int +#define TclBN_mp_init_set_int \ + (tclTomMathStubsPtr->tclBN_mp_init_set_int) /* 61 */ +#endif +#ifndef TclBN_mp_set_int +#define TclBN_mp_set_int \ + (tclTomMathStubsPtr->tclBN_mp_set_int) /* 62 */ +#endif +#ifndef TclBN_mp_cnt_lsb #define TclBN_mp_cnt_lsb \ (tclTomMathStubsPtr->tclBN_mp_cnt_lsb) /* 63 */ +#endif /* Slot 64 is reserved */ -#define TclBN_mp_init_i64 \ - (tclTomMathStubsPtr->tclBN_mp_init_i64) /* 65 */ -#define TclBN_mp_init_u64 \ - (tclTomMathStubsPtr->tclBN_mp_init_u64) /* 66 */ +/* Slot 65 is reserved */ +/* Slot 66 is reserved */ /* Slot 67 is reserved */ -#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 68 is reserved */ +/* Slot 69 is reserved */ +/* Slot 70 is reserved */ /* Slot 71 is reserved */ /* Slot 72 is reserved */ /* Slot 73 is reserved */ /* Slot 74 is reserved */ /* Slot 75 is reserved */ -#define TclBN_mp_signed_rsh \ - (tclTomMathStubsPtr->tclBN_mp_signed_rsh) /* 76 */ +/* Slot 76 is reserved */ /* Slot 77 is reserved */ -#define TclBN_mp_to_ubin \ - (tclTomMathStubsPtr->tclBN_mp_to_ubin) /* 78 */ +/* Slot 78 is reserved */ /* Slot 79 is reserved */ -#define TclBN_mp_to_radix \ - (tclTomMathStubsPtr->tclBN_mp_to_radix) /* 80 */ +#ifndef TclUnusedStubEntry +#define TclUnusedStubEntry \ + (tclTomMathStubsPtr->tclUnusedStubEntry) /* 80 */ +#endif -#endif /* defined(USE_TCL_STUBS) */ +#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ /* !END!: Do not edit above this line. */ -#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 */ Index: generic/tclTomMathInt.h ================================================================== --- generic/tclTomMathInt.h +++ generic/tclTomMathInt.h @@ -1,3 +1,2 @@ -#include "tclInt.h" #include "tclTomMath.h" #include "tommath_class.h" Index: generic/tclTomMathInterface.c ================================================================== --- generic/tclTomMathInterface.c +++ generic/tclTomMathInterface.c @@ -11,13 +11,14 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" -#include "tclTomMath.h" +#include "tommath.h" +#include -MODULE_SCOPE const TclTomMathStubs tclTomMathStubs; +extern TclTomMathStubs tclTomMathStubs; /* *---------------------------------------------------------------------- * * TclTommath_Init -- @@ -35,16 +36,16 @@ *---------------------------------------------------------------------- */ int TclTommath_Init( - Tcl_Interp *interp) /* Tcl interpreter */ -{ + Tcl_Interp* interp /* Tcl interpreter */ +) { /* TIP #268: Full patchlevel instead of just major.minor */ if (Tcl_PkgProvideEx(interp, "tcl::tommath", TCL_PATCH_LEVEL, - &tclTomMathStubs) != TCL_OK) { + (ClientData)&tclTomMathStubs) != TCL_OK) { return TCL_ERROR; } return TCL_OK; } @@ -87,13 +88,224 @@ int TclBN_revision(void) { return TCLTOMMATH_REVISION; } +#if 0 + +/* + *---------------------------------------------------------------------- + * + * TclBNAlloc -- + * + * Allocate memory for libtommath. + * + * Results: + * Returns a pointer to the allocated block. + * + * This procedure is a wrapper around Tcl_Alloc, needed because of a + * mismatched type signature between Tcl_Alloc and malloc. + * + *---------------------------------------------------------------------- + */ + +extern void * +TclBNAlloc( + size_t x) +{ + return (void *) ckalloc((unsigned int) x); +} + +/* + *---------------------------------------------------------------------- + * + * TclBNRealloc -- + * + * Change the size of an allocated block of memory in libtommath + * + * Results: + * Returns a pointer to the allocated block. + * + * This procedure is a wrapper around Tcl_Realloc, needed because of a + * mismatched type signature between Tcl_Realloc and realloc. + * + *---------------------------------------------------------------------- + */ + +void * +TclBNRealloc( + void *p, + size_t s) +{ + return (void *) ckrealloc((char *) p, (unsigned int) s); +} + +/* + *---------------------------------------------------------------------- + * + * TclBNFree -- + * + * Free allocated memory in libtommath. + * + * Results: + * None. + * + * Side effects: + * Memory is freed. + * + * This function is simply a wrapper around Tcl_Free, needed in libtommath + * because of a type mismatch between free and Tcl_Free. + * + *---------------------------------------------------------------------- + */ + +extern void +TclBNFree( + void *p) +{ + ckfree((char *) p); +} +#endif + +/* + *---------------------------------------------------------------------- + * + * TclBNInitBignumFromLong -- + * + * Allocate and initialize a 'bignum' from a native 'long'. + * + * Results: + * None. + * + * Side effects: + * The 'bignum' is constructed. + * + *---------------------------------------------------------------------- + */ + +extern void +TclBNInitBignumFromLong( + mp_int *a, + long initVal) +{ + int status; + unsigned long v; + mp_digit* p; + + /* + * Allocate enough memory to hold the largest possible long + */ + + status = mp_init_size(a, + (CHAR_BIT * sizeof(long) + MP_DIGIT_BIT - 1) / MP_DIGIT_BIT); + if (status != MP_OKAY) { + Tcl_Panic("initialization failure in TclBNInitBignumFromLong"); + } + + /* + * Convert arg to sign and magnitude. + */ + + if (initVal < 0) { + a->sign = MP_NEG; + v = -initVal; + } else { + a->sign = MP_ZPOS; + v = initVal; + } + + /* + * Store the magnitude in the bignum. + */ + + p = a->dp; + while (v) { + *p++ = (mp_digit) (v & MP_MASK); + v >>= MP_DIGIT_BIT; + } + a->used = p - a->dp; +} + +/* + *---------------------------------------------------------------------- + * + * TclBNInitBignumFromWideInt -- + * + * Allocate and initialize a 'bignum' from a Tcl_WideInt + * + * Results: + * None. + * + * Side effects: + * The 'bignum' is constructed. + * + *---------------------------------------------------------------------- + */ + +extern void +TclBNInitBignumFromWideInt( + mp_int *a, /* Bignum to initialize */ + Tcl_WideInt v) /* Initial value */ +{ + if (v < (Tcl_WideInt)0) { + TclBNInitBignumFromWideUInt(a, (Tcl_WideUInt)(-v)); + mp_neg(a, a); + } else { + TclBNInitBignumFromWideUInt(a, (Tcl_WideUInt)v); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclBNInitBignumFromWideUInt -- + * + * Allocate and initialize a 'bignum' from a Tcl_WideUInt + * + * Results: + * None. + * + * Side effects: + * The 'bignum' is constructed. + * + *---------------------------------------------------------------------- + */ + +extern void +TclBNInitBignumFromWideUInt( + mp_int *a, /* Bignum to initialize */ + Tcl_WideUInt v) /* Initial value */ +{ + int status; + mp_digit *p; + + /* + * Allocate enough memory to hold the largest possible Tcl_WideUInt. + */ + + status = mp_init_size(a, + (CHAR_BIT * sizeof(Tcl_WideUInt) + MP_DIGIT_BIT - 1) / MP_DIGIT_BIT); + if (status != MP_OKAY) { + Tcl_Panic("initialization failure in TclBNInitBignumFromWideUInt"); + } + + a->sign = MP_ZPOS; + + /* + * Store the magnitude in the bignum. + */ + + p = a->dp; + while (v) { + *p++ = (mp_digit) (v & MP_MASK); + v >>= MP_DIGIT_BIT; + } + a->used = p - a->dp; +} /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ DELETED generic/tclTomMathStubLib.c Index: generic/tclTomMathStubLib.c ================================================================== --- generic/tclTomMathStubLib.c +++ /dev/null @@ -1,80 +0,0 @@ -/* - * tclTomMathStubLib.c -- - * - * Stub object that will be statically linked into extensions that want - * to access Tcl. - * - * Copyright (c) 1998-1999 by Scriptics Corporation. - * 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; - - -/* - *---------------------------------------------------------------------- - * - * TclTomMathInitStubs -- - * - * Initializes the Stubs table for Tcl's subset of libtommath - * - * Results: - * Returns a standard Tcl result. - * - * This procedure should not be called directly, but rather through - * the TclTomMath_InitStubs macro, to insure that the Stubs table - * matches the header files used in compilation. - * - *---------------------------------------------------------------------- - */ - -MODULE_SCOPE const char * -TclTomMathInitializeStubs( - Tcl_Interp *interp, /* Tcl interpreter */ - const char *version, /* Tcl version needed */ - int epoch, /* Stubs table epoch from the header files */ - int revision) /* Stubs table revision number from the - * header files */ -{ - int exact = 0; - const char *packageName = "tcl::tommath"; - const char *errMsg = NULL; - TclTomMathStubs *stubsPtr = NULL; - const char *actualVersion = tclStubsPtr->tcl_PkgRequireEx(interp, - packageName, version, exact, &stubsPtr); - - if (actualVersion == NULL) { - return NULL; - } - if (stubsPtr == NULL) { - errMsg = "missing stub table pointer"; - } else if (stubsPtr->tclBN_epoch() != epoch) { - errMsg = "epoch number mismatch"; - } else if (stubsPtr->tclBN_revision() != revision) { - errMsg = "requires a later revision"; - } else { - tclTomMathStubsPtr = stubsPtr; - return actualVersion; - } - tclStubsPtr->tcl_ResetResult(interp); - tclStubsPtr->tcl_AppendResult(interp, "Error loading ", packageName, - " (requested version ", version, ", actual version ", - actualVersion, "): ", errMsg, NULL); - return NULL; -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ Index: generic/tclTrace.c ================================================================== --- generic/tclTrace.c +++ generic/tclTrace.c @@ -20,15 +20,15 @@ typedef struct { int flags; /* Operations for which Tcl command is to be * invoked. */ size_t length; /* Number of non-NUL chars. in command. */ - char command[1]; /* Space for Tcl command to invoke. Actual + char command[4]; /* Space for Tcl command to invoke. Actual * size will be as large as necessary to hold * command. This field must be the last in the - * structure, so that it can be larger than 1 - * byte. */ + * structure, so that it can be larger than 4 + * bytes. */ } TraceVarInfo; typedef struct { VarTrace traceInfo; TraceVarInfo traceCmdInfo; @@ -50,19 +50,19 @@ char *startCmd; /* Used for bookkeeping with step execution * traces, store the command name which * invoked step trace */ int curFlags; /* Trace flags for the current command */ int curCode; /* Return code for the current command */ - size_t refCount; /* Used to ensure this structure is not + 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. */ - char command[1]; /* Space for Tcl command to invoke. Actual + char command[4]; /* Space for Tcl command to invoke. Actual * size will be as large as necessary to hold * command. This field must be the last in the - * structure, so that it can be larger than 1 - * byte. */ + * structure, so that it can be larger than 4 + * bytes. */ } TraceCommandInfo; /* * Used by command execution traces. Note that we assume in the code that * TCL_TRACE_ENTER_DURING_EXEC == 4 * TCL_TRACE_ENTER_EXEC and that @@ -77,11 +77,12 @@ * 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. + * The flags 'TCL_TRACE_DESTROYED' and 'TCL_INTERP_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 @@ -104,11 +105,11 @@ * 'execution', 'command' and 'variable' are the only types supported. These * three arrays MUST be kept in sync! In the future we may provide an API to * add to the list of supported trace types. */ -static const char *const traceTypeOptions[] = { +static const char *traceTypeOptions[] = { "execution", "command", "variable", NULL }; static Tcl_TraceTypeObjCmd *const traceSubCmds[] = { TraceExecutionObjCmd, TraceCommandObjCmd, @@ -118,11 +119,11 @@ /* * Declarations for local functions to this file: */ static int CallTraceFunction(Tcl_Interp *interp, Trace *tracePtr, - Command *cmdPtr, const char *command, size_t numChars, + 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, @@ -133,36 +134,21 @@ 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); + const char *part2, register VarTrace *tracePtr); /* * The following structure holds the client data for string-based * trace procs */ -typedef struct { +typedef struct StringTraceData { ClientData clientData; /* Client data from Tcl_CreateTrace */ Tcl_CmdTraceProc *proc; /* Trace function from Tcl_CreateTrace */ } StringTraceData; - -/* - * Convenience macros for iterating over the list of traces. Note that each of - * these *must* be treated as a command, and *must* have a block following it. - */ - -#define FOREACH_VAR_TRACE(interp, name, clientData) \ - (clientData) = NULL; \ - while (((clientData) = Tcl_VarTraceInfo2((interp), (name), NULL, \ - 0, TraceVarProc, (clientData))) != NULL) - -#define FOREACH_COMMAND_TRACE(interp, name, clientData) \ - (clientData) = NULL; \ - while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, \ - TraceCommandProc, clientData)) != NULL) /* *---------------------------------------------------------------------- * * Tcl_TraceObjCmd -- @@ -179,48 +165,48 @@ * Side effects: * See the user documentation. *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_TraceObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int optionIndex; #ifndef TCL_REMOVE_OBSOLETE_TRACES - const char *name; - const char *flagOps, *p; + char *name, *flagOps, *p; #endif /* Main sub commands to 'trace' */ - static const char *const traceOptions[] = { + static const char *traceOptions[] = { "add", "info", "remove", #ifndef TCL_REMOVE_OBSOLETE_TRACES "variable", "vdelete", "vinfo", #endif NULL }; /* 'OLD' options are pre-Tcl-8.4 style */ - enum traceOptionsEnum { + enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE, #ifndef TCL_REMOVE_OBSOLETE_TRACES TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO #endif }; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions, "option", 0, - &optionIndex) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions, + "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } - switch ((enum traceOptionsEnum) optionIndex) { + switch ((enum traceOptions) optionIndex) { case TRACE_ADD: case TRACE_REMOVE: { /* * All sub commands of trace add/remove must take at least one more * argument. Beyond that we let the subcommand itself control the @@ -228,18 +214,18 @@ */ int typeIndex; if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "type ?arg ...?"); + Tcl_WrongNumArgs(interp, 2, objv, "type ?arg arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions, "option", 0, &typeIndex) != TCL_OK) { return TCL_ERROR; } - return traceSubCmds[typeIndex](interp, optionIndex, objc, objv); + return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv); } case TRACE_INFO: { /* * All sub commands of trace info must take exactly two more arguments * which name the type of thing being traced and the name of the thing @@ -258,30 +244,29 @@ } if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions, "option", 0, &typeIndex) != TCL_OK) { return TCL_ERROR; } - return traceSubCmds[typeIndex](interp, optionIndex, objc, objv); + return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv); break; } #ifndef TCL_REMOVE_OBSOLETE_TRACES case TRACE_OLD_VARIABLE: case TRACE_OLD_VDELETE: { Tcl_Obj *copyObjv[6]; Tcl_Obj *opsList; - int code; - size_t numFlags; + int code, numFlags; if (objc != 5) { Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); return TCL_ERROR; } - TclNewObj(opsList); + opsList = Tcl_NewObj(); Tcl_IncrRefCount(opsList); - flagOps = TclGetStringFromObj(objv[3], &numFlags); + flagOps = Tcl_GetStringFromObj(objv[3], &numFlags); if (numFlags == 0) { Tcl_DecrRefCount(opsList); goto badVarOps; } for (p = flagOps; *p != 0; p++) { @@ -303,13 +288,13 @@ } copyObjv[0] = NULL; memcpy(copyObjv+1, objv, objc*sizeof(Tcl_Obj *)); copyObjv[4] = opsList; if (optionIndex == TRACE_OLD_VARIABLE) { - code = traceSubCmds[2](interp, TRACE_ADD, objc+1, copyObjv); + code = (traceSubCmds[2])(interp, TRACE_ADD, objc+1, copyObjv); } else { - code = traceSubCmds[2](interp, TRACE_REMOVE, objc+1, copyObjv); + code = (traceSubCmds[2])(interp, TRACE_REMOVE, objc+1, copyObjv); } Tcl_DecrRefCount(opsList); return code; } case TRACE_OLD_VINFO: { @@ -319,34 +304,37 @@ if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "name"); return TCL_ERROR; } - TclNewObj(resultListPtr); - name = TclGetString(objv[2]); - FOREACH_VAR_TRACE(interp, name, clientData) { - TraceVarInfo *tvarPtr = (TraceVarInfo *)clientData; - char *q = ops; + resultListPtr = Tcl_NewObj(); + clientData = 0; + name = Tcl_GetString(objv[2]); + while ((clientData = Tcl_VarTraceInfo(interp, name, 0, + TraceVarProc, clientData)) != 0) { + + TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; pairObjPtr = Tcl_NewListObj(0, NULL); + p = ops; if (tvarPtr->flags & TCL_TRACE_READS) { - *q = 'r'; - q++; + *p = 'r'; + p++; } if (tvarPtr->flags & TCL_TRACE_WRITES) { - *q = 'w'; - q++; + *p = 'w'; + p++; } if (tvarPtr->flags & TCL_TRACE_UNSETS) { - *q = 'u'; - q++; + *p = 'u'; + p++; } if (tvarPtr->flags & TCL_TRACE_ARRAY) { - *q = 'a'; - q++; + *p = 'a'; + p++; } - *q = '\0'; + *p = '\0'; /* * Build a pair (2-item list) with the ops string as the first obj * element and the tvarPtr->command string as the second obj * element. Append the pair (as an element) to the end of the @@ -366,14 +354,12 @@ } return TCL_OK; #ifndef TCL_REMOVE_OBSOLETE_TRACES badVarOps: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad operations \"%s\": should be one or more of rwua", - flagOps)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "BADOPS", NULL); + Tcl_AppendResult(interp, "bad operations \"", flagOps, + "\": should be one or more of rwua", NULL); return TCL_ERROR; #endif } /* @@ -400,17 +386,17 @@ Tcl_Interp *interp, /* Current interpreter. */ int optionIndex, /* Add, info or remove */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int index; - const char *name, *command; - size_t commandLength, length; + int commandLength, index; + char *name, *command; + size_t length; enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; - static const char *const opStrings[] = { + static const char *opStrings[] = { "enter", "leave", "enterstep", "leavestep", NULL }; enum operations { TRACE_EXEC_ENTER, TRACE_EXEC_LEAVE, TRACE_EXEC_ENTER_STEP, TRACE_EXEC_LEAVE_STEP @@ -436,15 +422,13 @@ result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs); if (result != TCL_OK) { return result; } if (listLen == 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "bad operation list \"\": must be one or more of" - " enter, leave, enterstep, or leavestep", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS", - NULL); + Tcl_SetResult(interp, "bad operation list \"\": must be " + "one or more of enter, leave, enterstep, or leavestep", + TCL_STATIC); return TCL_ERROR; } for (i = 0; i < listLen; i++) { if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, "operation", TCL_EXACT, &index) != TCL_OK) { @@ -463,16 +447,18 @@ case TRACE_EXEC_LEAVE_STEP: flags |= TCL_TRACE_LEAVE_DURING_EXEC; break; } } - command = TclGetStringFromObj(objv[5], &commandLength); - length = commandLength; + command = Tcl_GetStringFromObj(objv[5], &commandLength); + length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { - TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)Tcl_Alloc( - offsetof(TraceCommandInfo, command) + 1 + length); + TraceCommandInfo *tcmdPtr; + tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned) + (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command) + + length + 1)); tcmdPtr->flags = flags; tcmdPtr->stepTrace = NULL; tcmdPtr->startLevel = 0; tcmdPtr->startCmd = NULL; tcmdPtr->length = length; @@ -481,36 +467,38 @@ 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 = TclGetString(objv[3]); + name = Tcl_GetString(objv[3]); if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, - tcmdPtr) != TCL_OK) { - Tcl_Free(tcmdPtr); + (ClientData) tcmdPtr) != TCL_OK) { + ckfree((char *) 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; + TraceCommandInfo *tcmdPtr; + ClientData clientData = NULL; + name = Tcl_GetString(objv[3]); /* * First ensure the name given is valid. */ - name = TclGetString(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; + while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, + TraceCommandProc, clientData)) != NULL) { + 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. @@ -518,11 +506,11 @@ if ((tcmdPtr->length == length) && ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC | TCL_TRACE_RENAME | TCL_TRACE_DELETE)) == flags) && (strncmp(command, tcmdPtr->command, - length) == 0)) { + (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); } @@ -534,38 +522,41 @@ * we created to allow 'step' traces. */ Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; - Tcl_Free(tcmdPtr->startCmd); + if (tcmdPtr->startCmd != NULL) { + ckfree((char *) tcmdPtr->startCmd); + } } if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { /* * Postpone deletion. */ tcmdPtr->flags = 0; } - if (tcmdPtr->refCount-- <= 1) { - Tcl_Free(tcmdPtr); + if ((--tcmdPtr->refCount) <= 0) { + ckfree((char *) tcmdPtr); } break; } } } break; } case TRACE_INFO: { ClientData clientData; - Tcl_Obj *resultListPtr; + Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; if (objc != 4) { Tcl_WrongNumArgs(interp, 3, objv, "name"); return TCL_ERROR; } - name = TclGetString(objv[3]); + clientData = NULL; + name = Tcl_GetString(objv[3]); /* * First ensure the name given is valid. */ @@ -572,14 +563,15 @@ 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) { + while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, + TraceCommandProc, clientData)) != NULL) { int numOps = 0; - Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr; - TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData; + Tcl_Obj *opObj; + 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,15 +640,15 @@ Tcl_Interp *interp, /* Current interpreter. */ int optionIndex, /* Add, info or remove */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int index; - const char *name, *command; - size_t commandLength, length; + int commandLength, index; + char *name, *command; + size_t length; enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; - static const char *const opStrings[] = { "delete", "rename", NULL }; + static const char *opStrings[] = { "delete", "rename", NULL }; enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME }; switch ((enum traceOptions) optionIndex) { case TRACE_ADD: case TRACE_REMOVE: { @@ -677,15 +669,12 @@ result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs); if (result != TCL_OK) { return result; } if (listLen == 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "bad operation list \"\": must be one or more of" - " delete or rename", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS", - NULL); + Tcl_SetResult(interp, "bad operation list \"\": must be " + "one or more of delete or rename", TCL_STATIC); return TCL_ERROR; } for (i = 0; i < listLen; i++) { if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, @@ -700,89 +689,96 @@ flags |= TCL_TRACE_DELETE; break; } } - command = TclGetStringFromObj(objv[5], &commandLength); - length = commandLength; + command = Tcl_GetStringFromObj(objv[5], &commandLength); + length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { - TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)Tcl_Alloc( - offsetof(TraceCommandInfo, command) + 1 + length); + TraceCommandInfo *tcmdPtr; + tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned) + (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command) + + length + 1)); 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 = TclGetString(objv[3]); + name = Tcl_GetString(objv[3]); if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, - tcmdPtr) != TCL_OK) { - Tcl_Free(tcmdPtr); + (ClientData) tcmdPtr) != TCL_OK) { + ckfree((char *) 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; + TraceCommandInfo *tcmdPtr; + ClientData clientData = NULL; + name = Tcl_GetString(objv[3]); /* * First ensure the name given is valid. */ - name = TclGetString(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) + while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, + TraceCommandProc, clientData)) != NULL) { + tcmdPtr = (TraceCommandInfo *) clientData; + if ((tcmdPtr->length == length) + && (tcmdPtr->flags == flags) && (strncmp(command, tcmdPtr->command, - length) == 0)) { + (size_t) length) == 0)) { Tcl_UntraceCommand(interp, name, flags | TCL_TRACE_DELETE, TraceCommandProc, clientData); tcmdPtr->flags |= TCL_TRACE_DESTROYED; - if (tcmdPtr->refCount-- <= 1) { - Tcl_Free(tcmdPtr); + if ((--tcmdPtr->refCount) <= 0) { + ckfree((char *) tcmdPtr); } break; } } } break; } case TRACE_INFO: { ClientData clientData; - Tcl_Obj *resultListPtr; + Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; if (objc != 4) { Tcl_WrongNumArgs(interp, 3, objv, "name"); return TCL_ERROR; } + clientData = NULL; + name = Tcl_GetString(objv[3]); + /* * First ensure the name given is valid. */ - name = TclGetString(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) { + while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, + TraceCommandProc, clientData)) != NULL) { int numOps = 0; - Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr; - TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData; + Tcl_Obj *opObj; + 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,16 +838,15 @@ Tcl_Interp *interp, /* Current interpreter. */ int optionIndex, /* Add, info or remove */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int index; - const char *name, *command; - size_t commandLength, length; - ClientData clientData; + int commandLength, index; + char *name, *command; + size_t length; enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; - static const char *const opStrings[] = { + static const char *opStrings[] = { "array", "read", "unset", "write", NULL }; enum operations { TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET, TRACE_VAR_WRITE }; @@ -876,15 +871,12 @@ result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs); if (result != TCL_OK) { return result; } if (listLen == 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "bad operation list \"\": must be one or more of" - " array, read, unset, or write", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS", - NULL); + Tcl_SetResult(interp, "bad operation list \"\": must be " + "one or more of array, read, unset, or write", TCL_STATIC); return TCL_ERROR; } for (i = 0; i < listLen ; i++) { if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, "operation", TCL_EXACT, &index) != TCL_OK) { @@ -903,17 +895,18 @@ case TRACE_VAR_WRITE: flags |= TCL_TRACE_WRITES; break; } } - command = TclGetStringFromObj(objv[5], &commandLength); - length = commandLength; + command = Tcl_GetStringFromObj(objv[5], &commandLength); + length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { - CombinedTraceVarInfo *ctvarPtr = (CombinedTraceVarInfo *)Tcl_Alloc( - offsetof(CombinedTraceVarInfo, traceCmdInfo.command) - + 1 + length); + CombinedTraceVarInfo *ctvarPtr; + ctvarPtr = (CombinedTraceVarInfo *) ckalloc((unsigned) + (sizeof(CombinedTraceVarInfo) + length + 1 + - sizeof(ctvarPtr->traceCmdInfo.command))); ctvarPtr->traceCmdInfo.flags = flags; #ifndef TCL_REMOVE_OBSOLETE_TRACES if (objv[0] == NULL) { ctvarPtr->traceCmdInfo.flags |= TCL_TRACE_OLD_STYLE; } @@ -920,37 +913,39 @@ #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.clientData = (ClientData) + &ctvarPtr->traceCmdInfo; ctvarPtr->traceInfo.flags = flags; - name = TclGetString(objv[3]); - if (TraceVarEx(interp, name, NULL, (VarTrace *) ctvarPtr) - != TCL_OK) { - Tcl_Free(ctvarPtr); + name = Tcl_GetString(objv[3]); + if (TraceVarEx(interp,name,NULL,(VarTrace*)ctvarPtr) != TCL_OK) { + ckfree((char *) 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 = TclGetString(objv[3]); - FOREACH_VAR_TRACE(interp, name, clientData) { - TraceVarInfo *tvarPtr = (TraceVarInfo *)clientData; - + TraceVarInfo *tvarPtr; + ClientData clientData = 0; + name = Tcl_GetString(objv[3]); + while ((clientData = Tcl_VarTraceInfo(interp, name, 0, + TraceVarProc, clientData)) != 0) { + tvarPtr = (TraceVarInfo *) clientData; if ((tvarPtr->length == length) && ((tvarPtr->flags #ifndef TCL_REMOVE_OBSOLETE_TRACES & ~TCL_TRACE_OLD_STYLE #endif )==flags) && (strncmp(command, tvarPtr->command, - length) == 0)) { + (size_t) length) == 0)) { Tcl_UntraceVar2(interp, name, NULL, flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT, TraceVarProc, clientData); break; } @@ -957,45 +952,48 @@ } } break; } case TRACE_INFO: { - Tcl_Obj *resultListPtr; + ClientData clientData; + Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; if (objc != 4) { Tcl_WrongNumArgs(interp, 3, objv, "name"); return TCL_ERROR; } - TclNewObj(resultListPtr); - name = TclGetString(objv[3]); - FOREACH_VAR_TRACE(interp, name, clientData) { - Tcl_Obj *opObjPtr, *eachTraceObjPtr, *elemObjPtr; - TraceVarInfo *tvarPtr = (TraceVarInfo *)clientData; + resultListPtr = Tcl_NewObj(); + clientData = 0; + name = Tcl_GetString(objv[3]); + while ((clientData = Tcl_VarTraceInfo(interp, name, 0, TraceVarProc, + clientData)) != 0) { + Tcl_Obj *opObj; + 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. */ elemObjPtr = Tcl_NewListObj(0, NULL); if (tvarPtr->flags & TCL_TRACE_ARRAY) { - TclNewLiteralStringObj(opObjPtr, "array"); - Tcl_ListObjAppendElement(NULL, elemObjPtr, opObjPtr); + TclNewLiteralStringObj(opObj, "array"); + Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); } if (tvarPtr->flags & TCL_TRACE_READS) { - TclNewLiteralStringObj(opObjPtr, "read"); - Tcl_ListObjAppendElement(NULL, elemObjPtr, opObjPtr); + TclNewLiteralStringObj(opObj, "read"); + Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); } if (tvarPtr->flags & TCL_TRACE_WRITES) { - TclNewLiteralStringObj(opObjPtr, "write"); - Tcl_ListObjAppendElement(NULL, elemObjPtr, opObjPtr); + TclNewLiteralStringObj(opObj, "write"); + Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); } if (tvarPtr->flags & TCL_TRACE_UNSETS) { - TclNewLiteralStringObj(opObjPtr, "unset"); - Tcl_ListObjAppendElement(NULL, elemObjPtr, opObjPtr); + TclNewLiteralStringObj(opObj, "unset"); + Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); } eachTraceObjPtr = Tcl_NewListObj(0, NULL); Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); @@ -1037,19 +1035,20 @@ ClientData Tcl_CommandTraceInfo( Tcl_Interp *interp, /* Interpreter containing command. */ const char *cmdName, /* Name of command. */ - TCL_UNUSED(int) /*flags*/, + int flags, /* OR-ed combo or TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY (can be 0). */ 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; + register CommandTrace *tracePtr; cmdPtr = (Command *) Tcl_FindCommand(interp, cmdName, NULL, TCL_LEAVE_ERR_MSG); if (cmdPtr == NULL) { return NULL; @@ -1110,11 +1109,11 @@ 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; + register CommandTrace *tracePtr; cmdPtr = (Command *) Tcl_FindCommand(interp, cmdName, NULL, TCL_LEAVE_ERR_MSG); if (cmdPtr == NULL) { return TCL_ERROR; @@ -1122,11 +1121,11 @@ /* * Set up trace information. */ - tracePtr = (CommandTrace *)Tcl_Alloc(sizeof(CommandTrace)); + 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; @@ -1134,19 +1133,19 @@ cmdPtr->tracePtr = tracePtr; if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { /* * Bug 3484621: up the interp's epoch if this is a BC'ed command */ - + if ((cmdPtr->compileProc != NULL) && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)){ Interp *iPtr = (Interp *) interp; iPtr->compileEpoch++; } cmdPtr->flags |= CMD_HAS_EXEC_TRACES; } - + return TCL_OK; } /* *---------------------------------------------------------------------- @@ -1173,14 +1172,14 @@ * 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; + register CommandTrace *tracePtr; CommandTrace *prevPtr; Command *cmdPtr; - Interp *iPtr = (Interp *)interp; + Interp *iPtr = (Interp *) interp; ActiveCommandTrace *activePtr; int hasExecTraces = 0; cmdPtr = (Command *) Tcl_FindCommand(interp, cmdName, NULL, TCL_LEAVE_ERR_MSG); @@ -1227,12 +1226,12 @@ } else { prevPtr->nextPtr = tracePtr->nextPtr; } tracePtr->flags = 0; - if (tracePtr->refCount-- <= 1) { - Tcl_Free(tracePtr); + if ((--tracePtr->refCount) <= 0) { + ckfree((char *) tracePtr); } if (hasExecTraces) { for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; tracePtr != NULL ; prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { @@ -1249,12 +1248,13 @@ cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES; /* * Bug 3484621: up the interp's epoch if this is a BC'ed command */ - + if (cmdPtr->compileProc != NULL) { + Interp *iPtr = (Interp *) interp; iPtr->compileEpoch++; } } } @@ -1274,10 +1274,11 @@ * Depends on the command associated with the trace. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ static void TraceCommandProc( ClientData clientData, /* Information about the command trace. */ Tcl_Interp *interp, /* Interpreter containing command. */ const char *oldName, /* Name of command being changed. */ @@ -1285,11 +1286,11 @@ * means command is being deleted (renamed to * ""). */ int flags) /* OR-ed bits giving operation and other * information. */ { - TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData; + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; int code; Tcl_DString cmd; tcmdPtr->refCount++; @@ -1299,17 +1300,17 @@ * 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, tcmdPtr->length); + 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"); + Tcl_DStringAppend(&cmd, " rename", 7); } else if (flags & TCL_TRACE_DELETE) { - TclDStringAppendLiteral(&cmd, " delete"); + Tcl_DStringAppend(&cmd, " delete", 7); } /* * Execute the command. We discard any object result the command * returns. @@ -1324,11 +1325,11 @@ } code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), Tcl_DStringLength(&cmd), 0); if (code != TCL_OK) { /* We ignore errors in these traced commands */ - /*** QUESTION: Use Tcl_BackgroundException(interp, code); instead? ***/ + /*** QUESTION: Use Tcl_BackgroundError(interp); instead? ***/ } Tcl_DStringFree(&cmd); } /* @@ -1341,11 +1342,13 @@ Tcl_InterpState state; if (tcmdPtr->stepTrace != NULL) { Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; - Tcl_Free(tcmdPtr->startCmd); + if (tcmdPtr->startCmd != NULL) { + ckfree((char *) tcmdPtr->startCmd); + } } if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { /* * Postpone deletion, until exec trace returns. */ @@ -1379,15 +1382,15 @@ */ state = Tcl_SaveInterpState(interp, TCL_OK); Tcl_UntraceCommand(interp, oldName, untraceFlags, TraceCommandProc, clientData); - Tcl_RestoreInterpState(interp, state); + (void) Tcl_RestoreInterpState(interp, state); tcmdPtr->refCount--; } - if (tcmdPtr->refCount-- <= 1) { - Tcl_Free(tcmdPtr); + if ((--tcmdPtr->refCount) <= 0) { + ckfree((char *) tcmdPtr); } } /* *---------------------------------------------------------------------- @@ -1417,11 +1420,12 @@ int TclCheckExecutionTraces( Tcl_Interp *interp, /* The current interpreter. */ const char *command, /* Pointer to beginning of the current command * string. */ - TCL_UNUSED(size_t) /*numChars*/, + 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. */ @@ -1462,23 +1466,24 @@ } else { active.reverseScan = 0; active.nextTracePtr = tracePtr->nextPtr; } if (tracePtr->traceProc == TraceCommandProc) { - TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)tracePtr->clientData; + 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) { - Tcl_Free(tcmdPtr); + traceCode = TraceExecutionProc((ClientData) tcmdPtr, interp, + curLevel, command, (Tcl_Command) cmdPtr, objc, objv); + if ((--tcmdPtr->refCount) <= 0) { + ckfree((char *) tcmdPtr); } } } if (active.nextTracePtr) { lastTracePtr = active.nextTracePtr->nextPtr; @@ -1491,11 +1496,11 @@ } else { Tcl_DiscardInterpState(state); } } - return traceCode; + return(traceCode); } /* *---------------------------------------------------------------------- * @@ -1522,11 +1527,11 @@ int TclCheckInterpTraces( Tcl_Interp *interp, /* The current interpreter. */ const char *command, /* Pointer to beginning of the current command * string. */ - size_t numChars, /* The number of characters in 'command' which + 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. */ @@ -1589,11 +1594,11 @@ * end of this if section, so we use Tcl_Preserve() and * Tcl_Release() to be sure it is not freed while we still need * it. */ - Tcl_Preserve(tracePtr); + Tcl_Preserve((ClientData) tracePtr); tracePtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; if (state == NULL) { state = Tcl_SaveInterpState(interp, code); } @@ -1603,18 +1608,19 @@ * New style trace. */ if (tracePtr->flags & traceFlags) { if (tracePtr->proc == TraceExecutionProc) { - TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)tracePtr->clientData; + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) + tracePtr->clientData; tcmdPtr->curFlags = traceFlags; tcmdPtr->curCode = code; } - traceCode = tracePtr->proc(tracePtr->clientData, interp, - curLevel, command, (Tcl_Command) cmdPtr, objc, - objv); + traceCode = (tracePtr->proc)(tracePtr->clientData, + interp, curLevel, command, (Tcl_Command) cmdPtr, + objc, objv); } } else { /* * Old-style trace. */ @@ -1628,23 +1634,23 @@ traceCode = CallTraceFunction(interp, tracePtr, cmdPtr, command, numChars, objc, objv); } } tracePtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; - Tcl_Release(tracePtr); + Tcl_Release((ClientData) tracePtr); } } iPtr->activeInterpTracePtr = active.nextPtr; if (state) { if (traceCode == TCL_OK) { - Tcl_RestoreInterpState(interp, state); + (void) Tcl_RestoreInterpState(interp, state); } else { Tcl_DiscardInterpState(state); } } - return traceCode; + return(traceCode); } /* *---------------------------------------------------------------------- * @@ -1665,17 +1671,17 @@ */ static int CallTraceFunction( Tcl_Interp *interp, /* The current interpreter. */ - Trace *tracePtr, /* Describes the trace function to call. */ + register 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. */ - size_t numChars, /* The number of characters in the command's + int numChars, /* The number of characters in the command's * source. */ - int objc, /* Number of arguments for the command. */ + register 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; @@ -1682,19 +1688,19 @@ /* * Copy the command characters into a new string. */ - commandCopy = (char *)TclStackAlloc(interp, numChars + 1); - memcpy(commandCopy, command, numChars); + commandCopy = TclStackAlloc(interp, (unsigned) (numChars + 1)); + memcpy(commandCopy, command, (size_t) numChars); commandCopy[numChars] = '\0'; /* * Call the trace function then free allocated storage. */ - traceCode = tracePtr->proc(tracePtr->clientData, (Tcl_Interp *) iPtr, + traceCode = (tracePtr->proc)(tracePtr->clientData, (Tcl_Interp *) iPtr, iPtr->numLevels, commandCopy, (Tcl_Command) cmdPtr, objc, objv); TclStackFree(interp, commandCopy); return traceCode; } @@ -1718,14 +1724,14 @@ static void CommandObjTraceDeleted( ClientData clientData) { - TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData; + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; - if (tcmdPtr->refCount-- <= 1) { - Tcl_Free(tcmdPtr); + if ((--tcmdPtr->refCount) <= 0) { + ckfree((char *) tcmdPtr); } } /* *---------------------------------------------------------------------- @@ -1756,17 +1762,17 @@ TraceExecutionProc( ClientData clientData, Tcl_Interp *interp, int level, const char *command, - TCL_UNUSED(Tcl_Command), + Tcl_Command cmdInfo, int objc, struct Tcl_Obj *const objv[]) { int call = 0; Interp *iPtr = (Interp *) interp; - TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData; + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; int flags = tcmdPtr->curFlags; int code = tcmdPtr->curCode; int traceCode = TCL_OK; if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { @@ -1803,31 +1809,34 @@ 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; - Tcl_Free(tcmdPtr->startCmd); + if (tcmdPtr->startCmd != NULL) { + ckfree((char *) tcmdPtr->startCmd); + } } /* * Second, create the tcl callback, if required. */ if (call) { - Tcl_DString cmd, sub; + Tcl_DString cmd; + Tcl_DString sub; int i, saveInterpFlags; Tcl_DStringInit(&cmd); - Tcl_DStringAppend(&cmd, tcmdPtr->command, tcmdPtr->length); + Tcl_DStringAppend(&cmd, tcmdPtr->command, (int)tcmdPtr->length); /* * Append command with arguments. */ Tcl_DStringInit(&sub); for (i = 0; i < objc; i++) { - Tcl_DStringAppendElement(&sub, TclGetString(objv[i])); + Tcl_DStringAppendElement(&sub, Tcl_GetString(objv[i])); } Tcl_DStringAppendElement(&cmd, Tcl_DStringValue(&sub)); Tcl_DStringFree(&sub); if (flags & TCL_TRACE_ENTER_EXEC) { @@ -1840,18 +1849,18 @@ } else { Tcl_DStringAppendElement(&cmd, "enterstep"); } } else if (flags & TCL_TRACE_LEAVE_EXEC) { Tcl_Obj *resultCode; - const char *resultCodeStr; + char *resultCodeStr; /* * Append result code. */ - TclNewIntObj(resultCode, code); - resultCodeStr = TclGetString(resultCode); + resultCode = Tcl_NewIntObj(code); + resultCodeStr = Tcl_GetString(resultCode); Tcl_DStringAppendElement(&cmd, resultCodeStr); Tcl_DecrRefCount(resultCode); /* * Append result string. @@ -1886,12 +1895,11 @@ * This line can have quite arbitrary side-effects, including * deleting the trace, the command being traced, or even the * interpreter. */ - traceCode = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), - Tcl_DStringLength(&cmd), 0); + traceCode = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); tcmdPtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; /* * Restore the interp tracing flag to prevent cmd traces from * affecting interp traces. @@ -1913,31 +1921,34 @@ */ 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; + register unsigned len = strlen(command) + 1; tcmdPtr->startLevel = level; - tcmdPtr->startCmd = (char *)Tcl_Alloc(len); + tcmdPtr->startCmd = 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); + TraceExecutionProc, (ClientData)tcmdPtr, + CommandObjTraceDeleted); } } if (flags & TCL_TRACE_DESTROYED) { if (tcmdPtr->stepTrace != NULL) { Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; - Tcl_Free(tcmdPtr->startCmd); + if (tcmdPtr->startCmd != NULL) { + ckfree(tcmdPtr->startCmd); + } } } if (call) { - if (tcmdPtr->refCount-- <= 1) { - Tcl_Free(tcmdPtr); + if ((--tcmdPtr->refCount) <= 0) { + ckfree((char *) tcmdPtr); } } return traceCode; } @@ -1957,10 +1968,11 @@ * Depends on the command associated with the trace. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ static char * TraceVarProc( ClientData clientData, /* Information about the variable trace. */ Tcl_Interp *interp, /* Interpreter containing variable. */ const char *name1, /* Name of variable or array. */ @@ -1967,57 +1979,56 @@ 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; + TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; char *result; int code, destroy = 0; Tcl_DString cmd; - int rewind = ((Interp *)interp)->execEnvPtr->rewind; /* - * We might call Tcl_EvalEx() below, and that might evaluate [trace vdelete] + * 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) { + 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, tvarPtr->length); + 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"); + Tcl_DStringAppend(&cmd, " a", 2); } else if (flags & TCL_TRACE_READS) { - TclDStringAppendLiteral(&cmd, " r"); + Tcl_DStringAppend(&cmd, " r", 2); } else if (flags & TCL_TRACE_WRITES) { - TclDStringAppendLiteral(&cmd, " w"); + Tcl_DStringAppend(&cmd, " w", 2); } else if (flags & TCL_TRACE_UNSETS) { - TclDStringAppendLiteral(&cmd, " u"); + Tcl_DStringAppend(&cmd, " u", 2); } } else { #endif if (flags & TCL_TRACE_ARRAY) { - TclDStringAppendLiteral(&cmd, " array"); + Tcl_DStringAppend(&cmd, " array", 6); } else if (flags & TCL_TRACE_READS) { - TclDStringAppendLiteral(&cmd, " read"); + Tcl_DStringAppend(&cmd, " read", 5); } else if (flags & TCL_TRACE_WRITES) { - TclDStringAppendLiteral(&cmd, " write"); + Tcl_DStringAppend(&cmd, " write", 6); } else if (flags & TCL_TRACE_UNSETS) { - TclDStringAppendLiteral(&cmd, " unset"); + Tcl_DStringAppend(&cmd, " unset", 6); } #ifndef TCL_REMOVE_OBSOLETE_TRACES } #endif @@ -2033,35 +2044,22 @@ if ((flags & TCL_TRACE_DESTROYED) && !(tvarPtr->flags & TCL_TRACE_DESTROYED)) { destroy = 1; tvarPtr->flags |= TCL_TRACE_DESTROYED; } - - /* - * Make sure that unset traces are rune even if the execEnv is - * rewinding (coroutine deletion, [Bug 2093947] - */ - - if (rewind && (flags & TCL_TRACE_UNSETS)) { - ((Interp *)interp)->execEnvPtr->rewind = 0; - } code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), Tcl_DStringLength(&cmd), 0); - if (rewind) { - ((Interp *)interp)->execEnvPtr->rewind = rewind; - } if (code != TCL_OK) { /* copy error msg to result */ Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(errMsgObj); result = (char *) errMsgObj; } Tcl_DStringFree(&cmd); } } if (destroy && result != NULL) { - Tcl_Obj *errMsgObj = (Tcl_Obj *) result; + register Tcl_Obj *errMsgObj = (Tcl_Obj *) result; Tcl_DecrRefCount(errMsgObj); result = NULL; } return result; @@ -2134,12 +2132,12 @@ 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; + register Trace *tracePtr; + register Interp *iPtr = (Interp *) interp; /* * Test if this trace allows inline compilation of commands. */ @@ -2159,11 +2157,11 @@ iPtr->flags |= DONT_COMPILE_CMDS_INLINE; } iPtr->tracesForbiddingInline++; } - tracePtr = (Trace *)Tcl_Alloc(sizeof(Trace)); + tracePtr = (Trace *) ckalloc(sizeof(Trace)); tracePtr->level = level; tracePtr->proc = proc; tracePtr->clientData = clientData; tracePtr->delProc = delProc; tracePtr->nextPtr = iPtr->tracePtr; @@ -2222,16 +2220,17 @@ * 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 *)Tcl_Alloc(sizeof(StringTraceData)); + StringTraceData *data = (StringTraceData *) + ckalloc(sizeof(StringTraceData)); data->clientData = clientData; data->proc = proc; return Tcl_CreateObjTrace(interp, level, 0, StringTraceProc, - data, StringTraceDeleteProc); + (ClientData) data, StringTraceDeleteProc); } /* *---------------------------------------------------------------------- * @@ -2256,11 +2255,11 @@ const char *command, Tcl_Command commandInfo, int objc, Tcl_Obj *const *objv) { - StringTraceData *data = (StringTraceData *)clientData; + StringTraceData *data = (StringTraceData *) clientData; Command *cmdPtr = (Command *) commandInfo; const char **argv; /* Args to pass to string trace proc */ int i; /* @@ -2267,23 +2266,23 @@ * 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 *)); + (unsigned) ((objc + 1) * sizeof(const char *))); for (i = 0; i < objc; i++) { - argv[i] = TclGetString(objv[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. */ - data->proc(data->clientData, interp, level, (char *) command, + (data->proc)(data->clientData, interp, level, (char *) command, cmdPtr->proc, cmdPtr->clientData, objc, argv); TclStackFree(interp, (void *) argv); return TCL_OK; } @@ -2306,11 +2305,11 @@ static void StringTraceDeleteProc( ClientData clientData) { - Tcl_Free(clientData); + ckfree((char *) clientData); } /* *---------------------------------------------------------------------- * @@ -2334,27 +2333,27 @@ Tcl_Trace trace) /* Token for trace (returned previously by * Tcl_CreateTrace). */ { Interp *iPtr = (Interp *) interp; Trace *prevPtr, *tracePtr = (Trace *) trace; - Trace **tracePtr2 = &iPtr->tracePtr; + register Trace **tracePtr2 = &(iPtr->tracePtr); ActiveInterpTrace *activePtr; /* * Locate the trace entry in the interpreter's trace list, and remove it * from the list. */ prevPtr = NULL; - while (*tracePtr2 != NULL && *tracePtr2 != tracePtr) { + while ((*tracePtr2) != NULL && (*tracePtr2) != tracePtr) { prevPtr = *tracePtr2; - tracePtr2 = &prevPtr->nextPtr; + tracePtr2 = &((*tracePtr2)->nextPtr); } if (*tracePtr2 == NULL) { return; } - *tracePtr2 = (*tracePtr2)->nextPtr; + (*tracePtr2) = (*tracePtr2)->nextPtr; /* * The code below makes it possible to delete traces while traces are * active: it makes sure that the deleted trace won't be processed by * TclCheckInterpTraces. @@ -2389,11 +2388,11 @@ /* * Execute any delete callback. */ if (tracePtr->delProc != NULL) { - tracePtr->delProc(tracePtr->clientData); + (tracePtr->delProc)(tracePtr->clientData); } /* * Delete the trace object. */ @@ -2422,11 +2421,12 @@ Var * TclVarTraceExists( Tcl_Interp *interp, /* The interpreter */ const char *varName) /* The variable name */ { - Var *varPtr, *arrayPtr; + Var *varPtr; + Var *arrayPtr; /* * The choice of "create" flag values is delicate here, and matches the * semantics of GetVar. Things are still not perfect, however, because if * you do "info exists x" you get a varPtr and therefore trigger traces. @@ -2442,11 +2442,11 @@ return NULL; } if ((varPtr->flags & VAR_TRACED_READ) || (arrayPtr && (arrayPtr->flags & VAR_TRACED_READ))) { - TclCallVarTraces((Interp *) interp, arrayPtr, varPtr, varName, NULL, + TclCallVarTraces((Interp *)interp, arrayPtr, varPtr, varName, NULL, TCL_TRACE_READS, /* leaveErrMsg */ 0); } /* * If the variable doesn't exist anymore and no-one's using it, then free @@ -2458,51 +2458,10 @@ return NULL; } return varPtr; } - -/* - *---------------------------------------------------------------------- - * - * TclCheckArrayTraces -- - * - * This function is invoked to when we operate on an array variable, - * to allow any array traces to fire. - * - * Results: - * Returns TCL_OK to indicate normal operation. Returns TCL_ERROR if - * invocation of a trace function indicated an error. When TCL_ERROR is - * returned, then error information is left in interp. - * - * Side effects: - * Almost anything can happen, depending on trace; this function itself - * doesn't have any side effects. - * - *---------------------------------------------------------------------- - */ - -int -TclCheckArrayTraces( - Tcl_Interp *interp, - Var *varPtr, - Var *arrayPtr, - Tcl_Obj *name, - int index) -{ - int code = TCL_OK; - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - Interp *iPtr = (Interp *)interp; - - code = TclObjCallVarTraces(iPtr, arrayPtr, varPtr, name, NULL, - (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| TCL_TRACE_ARRAY), - /* leaveErrMsg */ 1, index); - } - return code; -} /* *---------------------------------------------------------------------- * * TclCallVarTraces -- @@ -2526,11 +2485,11 @@ */ int TclObjCallVarTraces( Interp *iPtr, /* Interpreter containing variable. */ - Var *arrayPtr, /* Pointer to array variable that contains the + register 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. */ @@ -2542,18 +2501,15 @@ * stack trace information in *iPTr. */ int index) /* Index into the local variable table of the * variable, or -1. Only used when part1Ptr is * NULL. */ { - const char *part1, *part2; + char *part1, *part2; if (!part1Ptr) { part1Ptr = localName(iPtr->varFramePtr, index); } - if (!part1Ptr) { - Tcl_Panic("Cannot trace a variable with no name"); - } part1 = TclGetString(part1Ptr); part2 = part2Ptr? TclGetString(part2Ptr) : NULL; return TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg); @@ -2560,11 +2516,11 @@ } int TclCallVarTraces( Interp *iPtr, /* Interpreter containing variable. */ - Var *arrayPtr, /* Pointer to array variable that contains the + register 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. */ @@ -2573,11 +2529,11 @@ * 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; + register VarTrace *tracePtr; ActiveVarTrace active; char *result; const char *openParen, *p; Tcl_DString nameCopy; int copiedName; @@ -2623,11 +2579,11 @@ if (*p == ')') { int offset = (openParen - part1); char *newPart1; Tcl_DStringInit(&nameCopy); - Tcl_DStringAppend(&nameCopy, part1, p-part1); + Tcl_DStringAppend(&nameCopy, part1, (p-part1)); newPart1 = Tcl_DStringValue(&nameCopy); newPart1[offset] = 0; part1 = newPart1; part2 = newPart1 + offset + 1; copiedName = 1; @@ -2635,33 +2591,43 @@ break; } } } + /* + * Ignore any caller-provided TCL_INTERP_DESTROYED flag. Only we can + * set it correctly. + */ + + flags &= ~TCL_INTERP_DESTROYED; + /* * Invoke traces on the array containing the variable, if relevant. */ result = NULL; active.nextPtr = iPtr->activeVarTracePtr; iPtr->activeVarTracePtr = &active; - Tcl_Preserve(iPtr); + Tcl_Preserve((ClientData) 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) { + for (tracePtr = (VarTrace *) Tcl_GetHashValue(hPtr); + tracePtr != NULL; tracePtr = active.nextTracePtr) { active.nextTracePtr = tracePtr->nextPtr; if (!(tracePtr->flags & flags)) { continue; } - Tcl_Preserve(tracePtr); + Tcl_Preserve((ClientData) tracePtr); if (state == NULL) { - state = Tcl_SaveInterpState((Tcl_Interp *) iPtr, code); + state = Tcl_SaveInterpState((Tcl_Interp *)iPtr, code); + } + if (Tcl_InterpDeleted((Tcl_Interp *)iPtr)) { + flags |= TCL_INTERP_DESTROYED; } - result = tracePtr->traceProc(tracePtr->clientData, + result = (*tracePtr->traceProc)(tracePtr->clientData, (Tcl_Interp *) iPtr, part1, part2, flags); if (result != NULL) { if (flags & TCL_TRACE_UNSETS) { /* * Ignore errors in unset traces. @@ -2671,11 +2637,11 @@ } else { disposeFlags = tracePtr->flags; code = TCL_ERROR; } } - Tcl_Release(tracePtr); + Tcl_Release((ClientData) tracePtr); if (code == TCL_ERROR) { goto done; } } } @@ -2688,21 +2654,24 @@ 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) { + for (tracePtr = (VarTrace *) Tcl_GetHashValue(hPtr); + tracePtr != NULL; tracePtr = active.nextTracePtr) { active.nextTracePtr = tracePtr->nextPtr; if (!(tracePtr->flags & flags)) { continue; } - Tcl_Preserve(tracePtr); + Tcl_Preserve((ClientData) tracePtr); if (state == NULL) { - state = Tcl_SaveInterpState((Tcl_Interp *) iPtr, code); + state = Tcl_SaveInterpState((Tcl_Interp *)iPtr, code); + } + if (Tcl_InterpDeleted((Tcl_Interp *)iPtr)) { + flags |= TCL_INTERP_DESTROYED; } - result = tracePtr->traceProc(tracePtr->clientData, + result = (*tracePtr->traceProc)(tracePtr->clientData, (Tcl_Interp *) iPtr, part1, part2, flags); if (result != NULL) { if (flags & TCL_TRACE_UNSETS) { /* * Ignore errors in unset traces. @@ -2712,11 +2681,11 @@ } else { disposeFlags = tracePtr->flags; code = TCL_ERROR; } } - Tcl_Release(tracePtr); + Tcl_Release((ClientData) tracePtr); if (code == TCL_ERROR) { goto done; } } } @@ -2748,34 +2717,33 @@ } if (disposeFlags & TCL_TRACE_RESULT_OBJECT) { Tcl_SetObjResult((Tcl_Interp *)iPtr, (Tcl_Obj *) result); } else { - Tcl_SetObjResult((Tcl_Interp *)iPtr, - Tcl_NewStringObj(result, -1)); + Tcl_SetResult((Tcl_Interp *)iPtr, result, TCL_STATIC); } Tcl_AddErrorInfo((Tcl_Interp *)iPtr, ""); 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, - TclGetString((Tcl_Obj *) result)); + 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); + (void) Tcl_RestoreInterpState((Tcl_Interp *)iPtr, state); } DisposeTraceResult(disposeFlags,result); } else if (state) { if (code == TCL_OK) { - code = Tcl_RestoreInterpState((Tcl_Interp *) iPtr, state); + code = Tcl_RestoreInterpState((Tcl_Interp *)iPtr, state); } else { Tcl_DiscardInterpState(state); } } @@ -2788,11 +2756,11 @@ TclClearVarTraceActive(varPtr); if (TclIsVarInHash(varPtr)) { VarHashRefCount(varPtr)--; } iPtr->activeVarTracePtr = active.nextPtr; - Tcl_Release(iPtr); + Tcl_Release((ClientData) iPtr); return code; } /* *---------------------------------------------------------------------- @@ -2818,15 +2786,48 @@ * proper disposal method. */ char *result) /* The result returned from a trace function * to be disposed. */ { if (flags & TCL_TRACE_RESULT_DYNAMIC) { - Tcl_Free(result); + 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. + * + *---------------------------------------------------------------------- + */ + +#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); +} /* *---------------------------------------------------------------------- * * Tcl_UntraceVar2 -- @@ -2855,11 +2856,11 @@ * 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; + register VarTrace *tracePtr; VarTrace *prevPtr, *nextPtr; Var *varPtr, *arrayPtr; Interp *iPtr = (Interp *) interp; ActiveVarTrace *activePtr; int flagMask, allFlags = 0; @@ -2887,12 +2888,13 @@ #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; ; + 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) @@ -2933,11 +2935,11 @@ } } else { prevPtr->nextPtr = nextPtr; } tracePtr->nextPtr = NULL; - Tcl_EventuallyFree(tracePtr, TCL_DYNAMIC); + Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); for (tracePtr = nextPtr; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { allFlags |= tracePtr->flags; } @@ -2953,10 +2955,51 @@ */ 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. + * + *---------------------------------------------------------------------- + */ + +#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); +} /* *---------------------------------------------------------------------- * * Tcl_VarTraceInfo2 -- @@ -2987,10 +3030,11 @@ * this function, so this call will return the * next trace after that one. If NULL, this * call will return the first trace. */ { Interp *iPtr = (Interp *) interp; + register VarTrace *tracePtr; Var *varPtr, *arrayPtr; Tcl_HashEntry *hPtr; varPtr = TclLookupVar(interp, part1, part2, flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY), /*msg*/ NULL, @@ -3001,32 +3045,72 @@ /* * Find the relevant trace, if any, and return its clientData. */ - hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr); + hPtr = Tcl_FindHashEntry(&iPtr->varTraces, + (char *) varPtr); if (hPtr) { - VarTrace *tracePtr = (VarTrace *)Tcl_GetHashValue(hPtr); + tracePtr = Tcl_GetHashValue(hPtr); if (prevClientData != NULL) { - for (; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { + for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { if ((tracePtr->clientData == prevClientData) && (tracePtr->traceProc == proc)) { tracePtr = tracePtr->nextPtr; break; } } } - for (; tracePtr != NULL ; tracePtr = tracePtr->nextPtr) { + 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. + * + *---------------------------------------------------------------------- + */ + +#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); +} /* *---------------------------------------------------------------------- * * Tcl_TraceVar2 -- @@ -3061,22 +3145,22 @@ * 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; + register VarTrace *tracePtr; int result; - tracePtr = (VarTrace *)Tcl_Alloc(sizeof(VarTrace)); + tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace)); tracePtr->traceProc = proc; tracePtr->clientData = clientData; tracePtr->flags = flags; result = TraceVarEx(interp, part1, part2, tracePtr); if (result != TCL_OK) { - Tcl_Free(tracePtr); + ckfree((char *) tracePtr); } return result; } /* @@ -3106,13 +3190,13 @@ * 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 + register VarTrace *tracePtr)/* Structure containing flags, traceProc and * clientData fields. Others should be left - * blank. Will be Tcl_Free()d (eventually) if + * 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; @@ -3138,12 +3222,12 @@ /* * Check for a nonsense flag combination. Note that this is a Tcl_Panic() * because there should be no code path that ever sets both flags. */ - if ((tracePtr->flags & TCL_TRACE_RESULT_DYNAMIC) - && (tracePtr->flags & TCL_TRACE_RESULT_OBJECT)) { + if ((tracePtr->flags&TCL_TRACE_RESULT_DYNAMIC) + && (tracePtr->flags&TCL_TRACE_RESULT_OBJECT)) { Tcl_Panic("bad result flag combination"); } /* * Set up trace information. @@ -3154,17 +3238,17 @@ #ifndef TCL_REMOVE_OBSOLETE_TRACES flagMask |= TCL_TRACE_OLD_STYLE; #endif tracePtr->flags = tracePtr->flags & flagMask; - hPtr = Tcl_CreateHashEntry(&iPtr->varTraces, varPtr, &isNew); + hPtr = Tcl_CreateHashEntry(&iPtr->varTraces, (char *) varPtr, &isNew); if (isNew) { tracePtr->nextPtr = NULL; } else { - tracePtr->nextPtr = (VarTrace *)Tcl_GetHashValue(hPtr); + tracePtr->nextPtr = (VarTrace *) Tcl_GetHashValue(hPtr); } - Tcl_SetHashValue(hPtr, tracePtr); + Tcl_SetHashValue(hPtr, (char *) tracePtr); /* * Mark the variable as traced so we know to call them. */ Index: generic/tclUniData.c ================================================================== --- generic/tclUniData.c +++ generic/tclUniData.c @@ -27,39 +27,39 @@ 0, 32, 64, 96, 0, 128, 160, 192, 224, 256, 288, 320, 352, 384, 416, 448, 224, 480, 512, 544, 576, 608, 640, 672, 704, 704, 736, 768, 800, 832, 864, 896, 928, 960, 992, 224, 1024, 224, 1056, 224, 224, 1088, 1120, 1152, 1184, 1216, 1248, 1280, 1312, 1344, 1376, 1408, 1344, 1344, 1440, 1472, 1504, 1536, 1568, 1344, 1344, 1600, 1632, 1664, 1696, 1728, - 1760, 1792, 1824, 1856, 1888, 1920, 1952, 1984, 2016, 2048, 2080, 2112, - 2144, 2176, 2208, 2240, 2272, 2304, 2336, 2368, 2400, 2432, 2464, 2496, - 2528, 2560, 2592, 2624, 2656, 2688, 2720, 2752, 2784, 2816, 2848, 2880, - 2912, 2944, 2976, 3008, 3040, 3072, 3104, 3136, 3168, 3200, 3232, 3264, - 3296, 1824, 3328, 3360, 3392, 1824, 3424, 3456, 3488, 3520, 3552, 3584, - 3616, 1824, 1344, 3648, 3680, 3712, 3744, 3776, 3808, 3840, 1344, 1344, + 1760, 1792, 1824, 1344, 1856, 1888, 1920, 1952, 1984, 2016, 2048, 2080, + 2112, 2144, 2176, 2208, 2240, 2272, 2304, 2336, 2368, 2400, 2432, 2464, + 2496, 2528, 2560, 2592, 2624, 2656, 2688, 2720, 2752, 2784, 2816, 2848, + 2880, 2912, 2944, 2976, 3008, 3040, 3072, 3104, 3136, 3168, 3200, 3232, + 3264, 3296, 3328, 3360, 3392, 3296, 3424, 3456, 3488, 3520, 3552, 3584, + 3616, 3296, 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, + 4992, 5024, 5056, 5088, 5120, 3296, 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, + 5664, 5696, 5728, 5664, 704, 704, 224, 224, 224, 224, 5760, 224, 224, + 224, 5792, 5824, 5856, 5888, 5920, 5952, 5984, 6016, 6048, 6080, 6112, + 6144, 6176, 6208, 6240, 6272, 6304, 6336, 6368, 6400, 6432, 6464, 6496, + 6528, 6560, 6560, 6560, 6560, 6560, 6560, 6560, 6560, 6592, 6624, 4928, + 6656, 6688, 6720, 6752, 6784, 4928, 6816, 6848, 6880, 6912, 6944, 6976, + 7008, 4928, 4928, 4928, 4928, 4928, 7040, 7072, 7104, 4928, 4928, 4928, + 7136, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 7168, 7200, 4928, 7232, + 7264, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 6560, 6560, 6560, + 6560, 7296, 6560, 7328, 7360, 6560, 6560, 6560, 6560, 6560, 6560, 6560, + 6560, 4928, 7392, 7424, 7456, 7488, 4928, 4928, 4928, 7520, 7552, 7584, + 7616, 224, 224, 224, 7648, 7680, 7712, 1344, 7744, 7776, 7808, 7808, + 704, 7840, 7872, 7904, 3296, 7936, 4928, 4928, 7968, 4928, 4928, 4928, + 4928, 4928, 4928, 8000, 8032, 8064, 8096, 3200, 1344, 8128, 4192, 1344, + 8160, 8192, 8224, 1344, 1344, 8256, 1344, 4928, 8288, 8320, 8352, 8384, + 4928, 8352, 8416, 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, @@ -128,19 +128,19 @@ 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 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, 8448, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 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, 8480, 4928, 8512, 5440, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 8544, 8576, 224, 8608, 8640, 1344, 1344, 8672, 8704, 8736, 224, + 8768, 8800, 8832, 8864, 8896, 8928, 8960, 1344, 8992, 9024, 9056, 9088, + 9120, 1632, 9152, 9184, 9216, 1920, 9248, 9280, 9312, 1344, 9344, 9376, + 9408, 1344, 9440, 9472, 9504, 9536, 9568, 9600, 9632, 9664, 9664, 1344, + 9696, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, @@ -165,400 +165,412 @@ 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 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, + 1344, 1344, 9728, 9760, 9792, 9824, 9824, 9824, 9824, 9824, 9824, 9824, + 9824, 9824, 9824, 9824, 9824, 9824, 9824, 9824, 9824, 9824, 9824, 9824, + 9824, 9824, 9824, 9824, 9824, 9824, 9824, 9824, 9824, 9824, 9824, 9824, + 9824, 9824, 9824, 9824, 9824, 9824, 9824, 9824, 9824, 9824, 9824, 9824, + 9824, 9824, 9824, 9824, 9824, 9824, 9824, 9824, 9824, 9824, 9824, 9824, + 9824, 9824, 9824, 9824, 9824, 9824, 9824, 9824, 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, 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, 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, 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 + 9856, 9856, 9856, 9856, 9856, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 9888, 1344, 1344, 9920, 3296, 9952, 9984, 10016, + 1344, 1344, 10048, 10080, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 10112, 10144, 1344, 10176, 1344, 10208, 10240, 10272, + 10304, 10336, 10368, 1344, 1344, 1344, 10400, 10432, 64, 10464, 10496, + 10528, 4736, 10560, 10592 #if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6 - ,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, + ,10624, 10656, 10688, 3296, 1344, 1344, 1344, 10720, 10752, 10784, + 10816, 10848, 10880, 10912, 10944, 10976, 3296, 3296, 3296, 3296, 9216, + 1344, 11008, 11040, 1344, 11072, 11104, 11136, 11168, 1344, 11200, + 3296, 11232, 11264, 11296, 1344, 11328, 11360, 11392, 11424, 1344, + 11456, 1344, 11488, 11520, 11552, 3296, 3296, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 7776, 4704, 11584, 11616, 11648, 3296, + 3296, 11680, 11712, 11744, 11776, 4736, 11808, 3296, 11840, 11872, + 11904, 3296, 3296, 1344, 11936, 11968, 6880, 12000, 12032, 12064, 12096, + 12128, 3296, 12160, 12192, 1344, 12224, 12256, 12288, 12320, 12352, + 3296, 3296, 1344, 1344, 12384, 3296, 12416, 12448, 12480, 12512, 1344, + 12544, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 12576, + 1344, 12608, 3296, 12640, 12128, 12672, 12704, 12736, 12768, 12736, + 12800, 7776, 12832, 12864, 12896, 12928, 5280, 12960, 12992, 13024, + 13056, 13088, 13120, 13152, 5280, 13184, 13216, 13248, 13280, 13312, + 13344, 3296, 13376, 13408, 13440, 13472, 13504, 13536, 13568, 13600, + 3296, 3296, 3296, 3296, 1344, 13632, 13664, 13696, 1344, 13728, 13760, + 3296, 3296, 3296, 3296, 3296, 1344, 13792, 13824, 3296, 1344, 13856, + 13888, 13920, 1344, 13952, 13984, 3296, 4032, 14016, 14048, 3296, 3296, + 3296, 3296, 3296, 1344, 14080, 3296, 3296, 3296, 14112, 14144, 14176, + 14208, 14240, 14272, 3296, 3296, 14304, 14336, 14368, 14400, 14432, + 14464, 1344, 14496, 14528, 1344, 4608, 14560, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 14592, 14624, 14656, 14688, 14720, 14752, 3296, 3296, + 14784, 14816, 14848, 14880, 14912, 13984, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 14944, 14976, 15008, 15040, 3296, 3296, 15072, + 15104, 15136, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 9920, 3296, 3296, 3296, 10816, + 10816, 10816, 15168, 1344, 1344, 1344, 1344, 1344, 1344, 15200, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 12736, 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, 15264, + 15296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 14048, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 4608, 4736, 15328, 1344, 4736, 15360, 15392, 1344, 15424, 15456, + 15488, 15520, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 14112, 14144, 15552, 3296, 3296, 3296, 1344, 1344, 15584, 15616, 15648, + 3296, 3296, 15680, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 15712, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 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, 3296, 12384, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 15744, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 15776, 15808, 15840, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 9792, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 1344, 1344, 1344, 15872, 15904, 15936, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 704, 15968, 16000, 4928, 4928, 4928, 16032, 3296, 4928, 4928, + 4928, 4928, 4928, 4928, 4928, 8000, 4928, 16064, 4928, 16096, 16128, + 16160, 4928, 6848, 4928, 4928, 16192, 3296, 3296, 3296, 16224, 16224, + 4928, 4928, 16256, 16288, 3296, 3296, 3296, 3296, 16320, 16352, 16384, + 16416, 16448, 16480, 16512, 16544, 16576, 16608, 16640, 16672, 16704, + 16320, 16352, 16736, 16416, 16768, 16800, 16832, 16544, 16864, 16896, + 16928, 16960, 16992, 17024, 17056, 17088, 17120, 17152, 17184, 4928, + 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, + 4928, 4928, 4928, 704, 17216, 704, 17248, 17280, 17312, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 17344, 17376, 3296, + 3296, 3296, 3296, 3296, 3296, 17408, 17440, 5664, 17472, 17504, 3296, + 3296, 3296, 1344, 17536, 17568, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 12736, 17600, 1344, 17632, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 12736, + 17664, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 17696, 1344, 1344, 1344, 1344, 1344, 1344, 17728, 3296, 17760, + 17792, 17824, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 17856, 6880, 17888, 3296, 3296, 17920, 17952, 3296, + 3296, 3296, 3296, 3296, 3296, 17984, 18016, 18048, 18080, 18112, 18144, + 3296, 18176, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 4928, + 18208, 4928, 4928, 7968, 18240, 18272, 8000, 18304, 4928, 4928, 4928, + 4928, 18336, 3296, 18368, 18400, 18432, 18464, 18496, 3296, 3296, 3296, + 3296, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 18528, 4928, 4928, 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, + 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 18560, 18592, 4928, + 4928, 4928, 18624, 4928, 4928, 18656, 18688, 18208, 4928, 18720, 4928, + 18752, 18784, 3296, 3296, 4928, 4928, 4928, 4928, 4928, 4928, 4928, + 4928, 4928, 4928, 7968, 18816, 18848, 18880, 18912, 18944, 4928, 4928, + 4928, 4928, 18976, 4928, 6848, 19008, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 3296, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 9920, 1344, 1344, 1344, 1344, 1344, 1344, 11328, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 19040, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 19072, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 11328, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, 3296, + 3296, 3296, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1792, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 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 + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 15520 + #endif /* TCL_UTF_MAX > 3 */ }; /* * The groupMap is indexed by combining the alternate page number with @@ -643,11 +655,11 @@ 93, 93, 93, 93, 93, 93, 8, 93, 3, 93, 93, 3, 93, 93, 3, 93, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 15, 15, 15, 15, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 17, 7, 7, 7, 3, 3, 4, 3, 3, 14, 14, 93, 93, 93, 93, 93, 93, - 93, 93, 93, 93, 93, 3, 17, 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, + 93, 93, 93, 93, 93, 3, 17, 3, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 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, 93, 93, 93, 93, 93, 93, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 15, 15, 93, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, @@ -669,507 +681,506 @@ 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 92, 93, 93, 93, 93, 93, 93, 93, 93, 93, 92, 93, 93, 93, 92, 93, 93, 93, 93, 93, 0, 0, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 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, + 15, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 11, 15, 15, 15, 15, + 15, 15, 0, 17, 17, 0, 0, 0, 0, 0, 0, 93, 93, 93, 93, 93, 93, 93, 93, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 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, 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, + 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, 93, 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, 15, 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, 15, 15, 0, 15, 15, 93, 93, + 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 15, 15, 125, 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, 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, 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, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 0, 15, 0, 15, 15, 15, 15, 15, + 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 0, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 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, 93, 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, 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, + 15, 15, 15, 15, 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, 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, + 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, 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, + 126, 126, 126, 126, 126, 126, 0, 126, 0, 0, 0, 0, 0, 126, 0, 0, 127, + 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, - 127, 127, 127, 127, 127, 127, 127, 3, 92, 127, 127, 127, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, - 15, 15, 0, 15, 0, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 0, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, - 15, 15, 15, 0, 15, 0, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 0, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 93, 93, 93, 3, 3, 3, 3, 3, 3, - 3, 3, 3, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, - 0, 0, 0, 0, 0, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, + 3, 92, 127, 127, 127, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, + 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 0, 15, 15, 15, 15, + 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 0, 0, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, + 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 0, 15, 15, + 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 0, 0, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 0, 0, 93, 93, 93, 3, 3, 3, 3, 3, 3, 3, 3, 3, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 128, 128, 128, 128, + 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, - 128, 128, 128, 128, 128, 128, 128, 128, 128, 105, 105, 105, 105, 105, - 105, 0, 0, 111, 111, 111, 111, 111, 111, 0, 0, 8, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 14, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 2, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 5, 6, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 3, 3, 3, - 129, 129, 129, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, - 15, 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, 93, 93, 93, 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, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, - 15, 15, 0, 93, 93, 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, - 93, 93, 125, 93, 93, 93, 93, 93, 93, 93, 125, 125, 125, 125, 125, 125, - 125, 125, 93, 125, 125, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, - 3, 3, 3, 92, 3, 3, 3, 4, 15, 93, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, - 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, - 0, 0, 0, 3, 3, 3, 3, 3, 3, 8, 3, 3, 3, 3, 93, 93, 93, 17, 0, 9, 9, - 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 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, + 128, 128, 105, 105, 105, 105, 105, 105, 0, 0, 111, 111, 111, 111, 111, + 111, 0, 0, 8, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 14, 3, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 2, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 5, 6, 0, 0, 0, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 3, 3, 3, 129, 129, 129, 15, 15, 15, 15, 15, + 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 125, 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, 93, 93, 125, 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, + 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 0, 93, 93, 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, 93, 93, 125, 93, 93, 93, 93, 93, 93, + 93, 125, 125, 125, 125, 125, 125, 125, 125, 93, 125, 125, 93, 93, 93, + 93, 93, 93, 93, 93, 93, 93, 93, 3, 3, 3, 92, 3, 3, 3, 4, 15, 93, 0, + 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 8, 3, 3, + 3, 3, 93, 93, 93, 17, 93, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, + 0, 0, 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, 15, + 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, + 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, 93, 15, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, - 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 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, 93, 15, 0, 0, 0, 0, 0, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 0, 93, 93, 93, 125, 125, 125, 125, - 93, 93, 125, 125, 125, 0, 0, 0, 0, 125, 125, 93, 125, 125, 125, 125, - 125, 125, 93, 93, 93, 0, 0, 0, 0, 14, 0, 0, 0, 3, 3, 9, 9, 9, 9, 9, - 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 0, 0, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, - 18, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 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, + 93, 93, 93, 125, 125, 125, 125, 93, 93, 125, 125, 125, 0, 0, 0, 0, + 125, 125, 93, 125, 125, 125, 125, 125, 125, 93, 93, 93, 0, 0, 0, 0, + 14, 0, 0, 0, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, + 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 0, 0, 0, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 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, 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, 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, 15, 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, 3, 3, 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, 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, + 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, 21, 21, 21, 21, 21, 21, 21, 92, 92, 92, 92, 92, + 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, - 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, + 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, 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, 4, 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, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 5, 6, 5, 6, 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, 7, 7, 14, 14, 14, 14, 14, 14, 14, 5, 6, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 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, 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, + 14, 14, 14, 14, 14, 14, 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, 123, 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, 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, + 124, 124, 124, 124, 124, 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, 3, 3, 5, 6, 5, 6, 5, 6, 5, 6, 8, 0, 0, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 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, 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, 23, 24, 23, 24, 195, 196, 197, 23, + 24, 23, 24, 0, 0, 0, 0, 0, 23, 24, 0, 21, 0, 21, 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, + 92, 92, 92, 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, 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, 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, 11, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 6, 5, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 0, 0, 0, 0, 0, 0, 0, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 4, 14, 14, 14, 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, @@ -1219,12 +1230,22 @@ 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, + 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 204, 204, 204, + 204, 204, 204, 204, 204, 204, 204, 204, 0, 204, 204, 204, 204, 204, + 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 0, 204, 204, 204, + 204, 204, 204, 204, 0, 204, 204, 0, 205, 205, 205, 205, 205, 205, 205, + 205, 205, 205, 205, 0, 205, 205, 205, 205, 205, 205, 205, 205, 205, + 205, 205, 205, 205, 205, 205, 0, 205, 205, 205, 205, 205, 205, 205, + 0, 205, 205, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 92, 92, 92, + 92, 92, 92, 0, 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, 0, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 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, @@ -1273,44 +1294,50 @@ 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, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 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, + 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, 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, 93, 93, 93, 93, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 18, 18, + 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 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, 93, 15, 15, 93, 93, 15, 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, 93, 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, 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, 125, 125, 125, 93, 93, 93, 125, 125, 93, 125, 93, 93, + 3, 3, 3, 3, 3, 3, 93, 15, 15, 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, 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, @@ -1339,45 +1366,48 @@ 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, + 93, 93, 93, 125, 93, 15, 3, 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, + 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 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, 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, + 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, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 15, 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, @@ -1390,61 +1420,77 @@ 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, + 0, 0, 0, 0, 0, 0, 93, 93, 15, 125, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 125, 125, 93, 93, 93, 93, 93, 0, 0, 0, 125, + 125, 93, 125, 93, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 15, 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, 15, 15, 3, 3, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 93, 15, 15, 15, 15, 15, 15, 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, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 3, 3, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 9, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 0, 0, 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, 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, + 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, 92, 92, 92, + 92, 0, 92, 92, 92, 92, 92, 92, 92, 0, 92, 92, 0, 15, 15, 15, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, + 15, 15, 0, 0, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, + 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, + 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 14, 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, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, + 93, 93, 93, 93, 0, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, + 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 0, 0, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 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, 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, @@ -1509,96 +1555,107 @@ 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, + 93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 15, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 0, 0, 0, 0, 0, + 0, 21, 21, 21, 21, 21, 21, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 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, 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, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 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, 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, 15, 15, 93, + 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, 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, 15, 15, 15, 15, 15, + 15, 92, 93, 93, 93, 93, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, + 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 0, 15, 15, 0, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, + 15, 15, 15, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 93, 93, 93, 93, + 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 206, 206, 206, 206, 206, 206, + 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, + 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, + 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, + 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, + 207, 207, 207, 207, 207, 207, 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, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, + 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, + 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, + 0, 0, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, + 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 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 + 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, 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, 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, 14, 0, 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, 0, 0, 0, 0, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 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, 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 */ }; /* * Each group represents a unique set of character attributes. The attributes @@ -1640,15 +1697,15 @@ -1924287, -2145983, -2115007, 7233, 7298, 4170, 4234, 6749, 6813, -2750143, -976319, -2746047, 2763650, 2762882, -2759615, -2751679, -2760383, -2760127, -2768575, 1859714, -9044927, -10823615, -12158, -10830783, -10833599, -10832575, -10830015, -10817983, -10824127, -10818751, 237633, -12223, -10830527, -9058239, 237698, 9949314, - 18, 17, 10305, 10370, 8769, 8834 + 18, 17, 10305, 10370, 10049, 10114, 8769, 8834 }; #if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6 -# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1FFFFF) >= 0x31360) +# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1FFFFF) >= 0x323C0) #else # define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1F0000) != 0) #endif /* Index: generic/tclUtf.c ================================================================== --- generic/tclUtf.c +++ generic/tclUtf.c @@ -53,33 +53,32 @@ */ #define UNICODE_SELF 0x80 /* - * The following structures are used when mapping between Unicode and + * The following structures are used when mapping between Unicode (UCS-2) 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" */ + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 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 }; - + +#if TCL_UTF_MAX > 3 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, @@ -86,29 +85,27 @@ /* 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, + 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,4,4,4,4,4,1,1,1,1,1,1,1,1,1,1,1 +}; #else - 3,3,3,3,3, +# define complete totalBytes #endif - 1,1,1,1,1,1,1,1,1,1,1 -}; /* * Functions used only in this module. */ +static int UtfCount(int ch); static int Invalid(const char *src); /* *--------------------------------------------------------------------------- * - * TclUtfCount -- + * UtfCount -- * * Find the number of bytes in the Utf character "ch". * * Results: * The return values is the number of bytes in the Utf character "ch". @@ -117,23 +114,25 @@ * None. * *--------------------------------------------------------------------------- */ -size_t -TclUtfCount( +static INLINE int +UtfCount( int ch) /* The Unicode character whose size is returned. */ { if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) { return 1; } if (ch <= 0x7FF) { return 2; } +#if TCL_UTF_MAX > 3 if (((unsigned)(ch - 0x10000) <= 0xFFFFF)) { return 4; } +#endif return 3; } /* *--------------------------------------------------------------------------- @@ -167,15 +166,20 @@ 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 */ +#if TCL_UTF_MAX > 3 0x90, 0xBF, /* \xF0\x80 through \xF0\x8F are invalid prefixes */ 0x80, 0x8F /* \xF4\x90 and higher are invalid prefixes */ +#else + 0xC0, 0xBF, /* Not used, but reject all again for safety. */ + 0xC0, 0xBF /* Not used, but reject all again for safety. */ +#endif }; -static int +static INLINE int Invalid( const char *src) /* Points to lead byte of a UTF-8 byte sequence */ { unsigned char byte = UCHAR(*src); int index; @@ -197,23 +201,10 @@ * Tcl_UniCharToUtf -- * * Store the given Tcl_UniChar as a sequence of UTF-8 bytes in the * provided buffer. Equivalent to Plan 9 runetochar(). * - * Special handling of Surrogate pairs is handled as follows: - * When this function is called for ch being a high surrogate, - * the first byte of the 4-byte UTF-8 sequence is produced and - * the function returns 1. Calling the function again with a - * low surrogate, the remaining 3 bytes of the 4-byte UTF-8 - * sequence is produced, and the function returns 3. The buffer - * is used to remember the high surrogate between the two calls. - * - * If no low surrogate follows the high surrogate (which is actually - * illegal), this can be handled reasonably by calling Tcl_UniCharToUtf - * again with ch = -1. This will produce a 3-byte UTF-8 sequence - * representing the high surrogate. - * * Results: * The return values is the number of bytes in the buffer that were * consumed. * * Side effects: @@ -220,18 +211,18 @@ * None. * *--------------------------------------------------------------------------- */ -int +INLINE int Tcl_UniCharToUtf( int ch, /* The Tcl_UniChar to be stored in the * buffer. */ char *buf) /* Buffer in which the UTF-8 representation of * the Tcl_UniChar is stored. Buffer must be * large enough to hold the UTF-8 character - * (at most 4 bytes). */ + * (at most TCL_UTF_MAX bytes). */ { if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) { buf[0] = (char) ch; return 1; } @@ -240,50 +231,22 @@ buf[1] = (char) ((ch | 0x80) & 0xBF); buf[0] = (char) ((ch >> 6) | 0xC0); return 2; } if (ch <= 0xFFFF) { - if ((ch & 0xF800) == 0xD800) { - if (ch & 0x0400) { - /* Low surrogate */ - if (((buf[0] & 0xC0) == 0x80) && ((buf[1] & 0xCF) == 0)) { - /* Previous Tcl_UniChar was a high surrogate, so combine */ - buf[2] = (char) ((ch & 0x3F) | 0x80); - buf[1] |= (char) (((ch >> 6) & 0x0F) | 0x80); - return 3; - } - /* Previous Tcl_UniChar was not a high surrogate, so just output */ - } else { - /* High surrogate */ - ch += 0x40; - /* Fill buffer with specific 3-byte (invalid) byte combination, - so following low surrogate can recognize it and combine */ - buf[2] = (char) ((ch << 4) & 0x30); - buf[1] = (char) (((ch >> 2) & 0x3F) | 0x80); - buf[0] = (char) (((ch >> 8) & 0x07) | 0xF0); - return 1; - } - } goto three; } + +#if TCL_UTF_MAX > 3 if (ch <= 0x10FFFF) { buf[3] = (char) ((ch | 0x80) & 0xBF); buf[2] = (char) (((ch >> 6) | 0x80) & 0xBF); buf[1] = (char) (((ch >> 12) | 0x80) & 0xBF); buf[0] = (char) ((ch >> 18) | 0xF0); return 4; } - } else if (ch == -1) { - if (((buf[0] & 0xC0) == 0x80) && ((buf[1] & 0xCF) == 0) - && ((buf[-1] & 0xF8) == 0xF0)) { - ch = 0xD7C0 + ((buf[-1] & 0x07) << 8) + ((buf[0] & 0x3F) << 2) - + ((buf[1] & 0x30) >> 4); - buf[1] = (char) ((ch | 0x80) & 0xBF); - buf[0] = (char) (((ch >> 6) | 0x80) & 0xBF); - buf[-1] = (char) ((ch >> 12) | 0xE0); - return 2; - } +#endif } ch = 0xFFFD; three: buf[2] = (char) ((ch | 0x80) & 0xBF); @@ -308,39 +271,29 @@ * None. * *--------------------------------------------------------------------------- */ -#undef Tcl_UniCharToUtfDString char * Tcl_UniCharToUtfDString( - const int *uniStr, /* Unicode string to convert to UTF-8. */ - size_t uniLength, /* Length of Unicode string. */ + const Tcl_UniChar *uniStr, /* Unicode string to convert to UTF-8. */ + int uniLength, /* Length of Unicode string in Tcl_UniChars + * (must be >= 0). */ Tcl_DString *dsPtr) /* UTF-8 representation of string is appended * to this previously initialized DString. */ { - const int *w, *wEnd; + const Tcl_UniChar *w, *wEnd; char *p, *string; - size_t oldLength; + int oldLength; /* - * UTF-8 string length in bytes will be <= Unicode string length * 4. + * UTF-8 string length in bytes will be <= Unicode string length * + * TCL_UTF_MAX. */ - if (uniStr == NULL) { - return NULL; - } - if (uniLength == TCL_INDEX_NONE) { - uniLength = 0; - w = uniStr; - while (*w != '\0') { - uniLength++; - w++; - } - } oldLength = Tcl_DStringLength(dsPtr); - Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * 4); + Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * TCL_UTF_MAX); string = Tcl_DStringValue(dsPtr) + oldLength; p = string; wEnd = uniStr + uniLength; for (w = uniStr; w < wEnd; ) { @@ -350,64 +303,10 @@ Tcl_DStringSetLength(dsPtr, oldLength + (p - string)); return string; } -char * -Tcl_Char16ToUtfDString( - const unsigned short *uniStr,/* Utf-16 string to convert to UTF-8. */ - size_t 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; - size_t oldLength; - int len = 1; - - /* - * UTF-8 string length in bytes will be <= Utf16 string length * 3. - */ - - if (uniStr == NULL) { - return NULL; - } - if (uniLength == TCL_INDEX_NONE) { - - 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. */ - p += Tcl_UniCharToUtf(-1, p); - } - len = Tcl_UniCharToUtf(*w, p); - p += len; - if ((*w >= 0xD800) && (len < 3)) { - len = 0; /* Indication that high surrogate was found */ - } - w++; - } - if (!len) { - /* Special case for handling high surrogates. */ - p += Tcl_UniCharToUtf(-1, p); - } - Tcl_DStringSetLength(dsPtr, oldLength + (p - string)); - - return string; -} /* *--------------------------------------------------------------------------- * * Tcl_UtfToUniChar -- * @@ -420,19 +319,10 @@ * 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 <= 3, 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: @@ -439,45 +329,31 @@ * 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 + Tcl_UniChar *chPtr)/* Filled with the Tcl_UniChar represented by * the UTF-8 string. */ { - int byte; + Tcl_UniChar byte; /* - * Unroll 1 to 4 byte UTF-8 sequences. + * Unroll 1 to 3 (or 4) byte UTF-8 sequences. */ - byte = *((unsigned char *) src); + 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: - * Also treats \0 and other naked trail bytes 0xA0 to 0xBF as valid + * Also treats \0 and naked trail bytes 0x80 to 0xBF as valid * characters representing themselves. */ - if ((unsigned)(byte-0x80) < (unsigned)0x20) { - *chPtr = cp1252[byte-0x80]; - } else { - *chPtr = byte; - } + *chPtr = byte; return 1; } else if (byte < 0xE0) { if ((src[1] & 0xC0) == 0x80) { /* * Two-byte-character lead-byte followed by a trail-byte. @@ -509,10 +385,11 @@ /* * A three-byte-character lead-byte not followed by two trail-bytes * represents itself. */ } +#if TCL_UTF_MAX > 3 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. */ @@ -526,110 +403,11 @@ /* * 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: - * 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; - } - return 1; - } else if (byte < 0xE0) { - if ((src[1] & 0xC0) == 0x80) { - /* - * Two-byte-character lead-byte followed by a trail-byte. - */ - - *chPtr = (((byte & 0x1F) << 6) | (src[1] & 0x3F)); - if ((unsigned)(*chPtr - 1) >= (UNICODE_SELF - 1)) { - return 2; - } - } - - /* - * A two-byte-character lead-byte not followed by trail-byte - * represents itself. - */ - } else if (byte < 0xF0) { - if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80)) { - /* - * Three-byte-character lead byte followed by two trail bytes. - */ - - *chPtr = (((byte & 0x0F) << 12) - | ((src[1] & 0x3F) << 6) | (src[2] & 0x3F)); - if (*chPtr > 0x7FF) { - return 3; - } - } - - /* - * 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. - */ - } +#endif *chPtr = byte; return 1; } @@ -649,32 +427,28 @@ * None. * *--------------------------------------------------------------------------- */ -#undef Tcl_UtfToUniCharDString -int * +Tcl_UniChar * Tcl_UtfToUniCharDString( const char *src, /* UTF-8 string to convert to Unicode. */ - size_t length, /* Length of UTF-8 string in bytes, or -1 for + 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; + Tcl_UniChar *w, *wString; const char *p; - size_t oldLength; + int oldLength; /* Pointer to the end of string. Never read endPtr[0] */ - const char *endPtr = src + length; + const char *endPtr; /* Pointer to last byte where optimization still can be used */ - const char *optPtr = endPtr - TCL_UTF_MAX; + const char *optPtr; - if (src == NULL) { - return NULL; - } - if (length == TCL_INDEX_NONE) { + if (length < 0) { length = strlen(src); } /* * Unicode string length in Tcl_UniChars will be <= UTF-8 string length in @@ -682,82 +456,25 @@ */ 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. */ - size_t 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; - size_t 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 == TCL_INDEX_NONE) { - length = strlen(src); - } - - /* - * Unicode string length in WCHARs 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; + oldLength + ((length + 1) * sizeof(Tcl_UniChar))); + wString = (Tcl_UniChar *) (Tcl_DStringValue(dsPtr) + oldLength); + + w = wString; + p = src; + endPtr = src + length; + optPtr = endPtr - ((TCL_UTF_MAX > 3) ? 4 : 3) ; + while (p <= optPtr) { + p += TclUtfToUniChar(p, w); + w++; + } + while (p < endPtr) { + if (Tcl_UtfCharComplete(p, endPtr-p)) { + p += TclUtfToUniChar(p, w); + w++; } else { *w++ = UCHAR(*p++); } } *w = '\0'; @@ -788,11 +505,11 @@ int Tcl_UtfCharComplete( const char *src, /* String to check if first few bytes contain * a complete UTF-8 character. */ - size_t length) /* Length of above string in bytes. */ + int length) /* Length of above string in bytes. */ { return length >= complete[UCHAR(*src)]; } /* @@ -811,32 +528,32 @@ * None. * *--------------------------------------------------------------------------- */ -size_t +int Tcl_NumUtfChars( const char *src, /* The UTF-8 string to measure. */ - size_t length) /* The length of the string in bytes, or - * TCL_INDEX_NONE for strlen(src). */ + int length) /* The length of the string in bytes, or -1 + * for strlen(string). */ { - Tcl_UniChar ch = 0; - size_t i = 0; + Tcl_UniChar ch; + int i = 0; - if (length == TCL_INDEX_NONE) { + if (length < 0) { /* string is NUL-terminated, so TclUtfToUniChar calls are safe. */ - while (*src != '\0') { + 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; + const char *optPtr = endPtr - ((TCL_UTF_MAX > 3) ? 4 : 3); /* * Optimize away the call in this loop. Justified because... * when (src <= optPtr), (endPtr - src) >= (endPtr - optPtr) * By initialization above (endPtr - optPtr) = TCL_UTF_MAX @@ -885,15 +602,15 @@ */ const char * Tcl_UtfFindFirst( const char *src, /* The UTF-8 string to be searched. */ - int ch) /* The Unicode character to search for. */ + int ch) /* The Tcl_UniChar to search for. */ { while (1) { - int find, len = TclUtfToUCS4(src, &find); - + Tcl_UniChar find; + int len = TclUtfToUniChar(src, &find); if (find == ch) { return src; } if (*src == '\0') { return NULL; @@ -905,11 +622,11 @@ /* *--------------------------------------------------------------------------- * * Tcl_UtfFindLast -- * - * Returns a pointer to the last occurrence of the given Unicode character + * Returns a pointer to the last occurance 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 @@ -927,11 +644,12 @@ int ch) /* The Unicode character to search for. */ { const char *last = NULL; while (1) { - int find, len = TclUtfToUCS4(src, &find); + Tcl_UniChar find; + int len = TclUtfToUniChar(src, &find); if (find == ch) { last = src; } if (*src == '\0') { @@ -965,19 +683,25 @@ const char * Tcl_UtfNext( const char *src) /* The current location in the string. */ { - size_t left; + int left; const char *next; +#if TCL_UTF_MAX > 3 if (((*src) & 0xC0) == 0x80) { + /* Continuation byte, so we start 'inside' a (possible valid) UTF-8 + * sequence. Since we are not allowed to access src[-1], we cannot + * check if the sequence is actually valid, the best we can do is + * just assume it is valid and locate the end. */ if ((((*++src) & 0xC0) == 0x80) && (((*++src) & 0xC0) == 0x80)) { ++src; } return src; } +#endif left = totalBytes[UCHAR(*src)]; next = src + 1; while (--left) { if ((*next & 0xC0) != 0x80) { @@ -1063,11 +787,11 @@ * 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])) { + || (trailBytesSeen >= totalBytes[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 @@ -1104,31 +828,26 @@ return fallback; } /* Continue the search backwards... */ look--; - } while (trailBytesSeen < TCL_UTF_MAX); + } while (trailBytesSeen < (TCL_UTF_MAX < 4 ? 3 : 4)); /* - * We've seen TCL_UTF_MAX trail bytes, so we know there will not be a + * We've seen 3 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. + * accepting the fallback. */ -#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 + * Returns the Tcl_UniChar represented at the specified character * (not byte) position in the UTF-8 string. * * Results: * As above. * @@ -1136,44 +855,28 @@ * None. * *--------------------------------------------------------------------------- */ -int +Tcl_UniChar Tcl_UniCharAtIndex( const char *src, /* The UTF-8 string to dereference. */ - size_t index) /* The position of the desired character. */ -{ - Tcl_UniChar ch = 0; - int i = 0; - - if (index == TCL_INDEX_NONE) { - return -1; - } - while (index--) { - 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; + int index) /* The position of the desired character. */ +{ + Tcl_UniChar ch; + + TclUtfToUniChar(Tcl_UtfAtIndex(src, index), &ch); + return ch; } /* *--------------------------------------------------------------------------- * * 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. + * the UTF-8 string. * * Results: * As above. * * Side effects: @@ -1183,31 +886,16 @@ */ const char * Tcl_UtfAtIndex( const char *src, /* The UTF-8 string. */ - size_t index) /* The position of the desired character. */ -{ - Tcl_UniChar ch = 0; -#if TCL_UTF_MAX <= 3 - size_t len = 0; -#endif - - if (index != TCL_INDEX_NONE) { - while (index--) { -#if TCL_UTF_MAX <= 3 - src += (len = TclUtfToUniChar(src, &ch)); -#else - src += TclUtfToUniChar(src, &ch); -#endif - } -#if TCL_UTF_MAX <= 3 - if ((ch >= 0xD800) && (len < 3)) { - /* Index points at character following high Surrogate */ - src += TclUtfToUniChar(src, &ch); - } -#endif + int index) /* The position of the desired character. */ +{ + Tcl_UniChar ch; + + while (index-- > 0) { + src += TclUtfToUniChar(src, &ch); } return src; } /* @@ -1217,11 +905,11 @@ * * 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 + * returns the number of bytes written to dst. At most TCL_UTF_MAX 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: @@ -1234,21 +922,22 @@ * buffer overruns should occur. * *--------------------------------------------------------------------------- */ -size_t +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 - size_t numRead, result; + 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() @@ -1282,30 +971,30 @@ int Tcl_UtfToUpper( char *str) /* String to convert in place. */ { - int ch, upChar; + Tcl_UniChar ch, upChar; char *src, *dst; - size_t len; + int len; /* * Iterate over the string until we hit the terminating null. */ src = dst = str; while (*src) { - len = TclUtfToUCS4(src, &ch); + len = TclUtfToUniChar(src, &ch); upChar = Tcl_UniCharToUpper(ch); /* * To keep badly formed Utf strings from getting inflated by the * conversion (thereby causing a segfault), only copy the upper case * char to dst if its size is <= the original char. */ - if ((len < TclUtfCount(upChar)) || ((upChar & ~0x7FF) == 0xD800)) { + if (len < UtfCount(upChar)) { memmove(dst, src, len); dst += len; } else { dst += Tcl_UniCharToUtf(upChar, dst); } @@ -1335,30 +1024,30 @@ int Tcl_UtfToLower( char *str) /* String to convert in place. */ { - int ch, lowChar; + Tcl_UniChar ch, lowChar; char *src, *dst; - size_t len; + int len; /* * Iterate over the string until we hit the terminating null. */ src = dst = str; while (*src) { - len = TclUtfToUCS4(src, &ch); + len = TclUtfToUniChar(src, &ch); lowChar = Tcl_UniCharToLower(ch); /* * To keep badly formed Utf strings from getting inflated by the * conversion (thereby causing a segfault), only copy the lower case * char to dst if its size is <= the original char. */ - if ((len < TclUtfCount(lowChar)) || ((lowChar & ~0x7FF) == 0xD800)) { + if (len < UtfCount(lowChar)) { memmove(dst, src, len); dst += len; } else { dst += Tcl_UniCharToUtf(lowChar, dst); } @@ -1389,42 +1078,42 @@ int Tcl_UtfToTitle( char *str) /* String to convert in place. */ { - int ch, titleChar, lowChar; + Tcl_UniChar ch, titleChar, lowChar; char *src, *dst; - size_t len; + 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); + len = TclUtfToUniChar(src, &ch); titleChar = Tcl_UniCharToTitle(ch); - if ((len < TclUtfCount(titleChar)) || ((titleChar & ~0x7FF) == 0xD800)) { + if (len < UtfCount(titleChar)) { memmove(dst, src, len); dst += len; } else { dst += Tcl_UniCharToUtf(titleChar, dst); } src += len; } while (*src) { - len = TclUtfToUCS4(src, &ch); + len = TclUtfToUniChar(src, &ch); lowChar = ch; /* Special exception for Georgian Asomtavruli chars, no titlecase. */ if ((unsigned)(lowChar - 0x1C90) >= 0x30) { lowChar = Tcl_UniCharToLower(lowChar); } - if ((len < TclUtfCount(lowChar)) || ((lowChar & ~0x7FF) == 0xD800)) { + if (len < UtfCount(lowChar)) { memmove(dst, src, len); dst += len; } else { dst += Tcl_UniCharToUtf(lowChar, dst); } @@ -1453,11 +1142,11 @@ int TclpUtfNcmp2( const char *cs, /* UTF string to compare to ct. */ const char *ct, /* UTF string cs is compared to. */ - size_t numBytes) /* Number of *bytes* to compare. */ + 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. @@ -1500,13 +1189,13 @@ int Tcl_UtfNcmp( const char *cs, /* UTF string to compare to ct. */ const char *ct, /* UTF string cs is compared to. */ - size_t numChars) /* Number of UTF chars to compare. */ + unsigned long numChars) /* Number of UTF chars to compare. */ { - Tcl_UniChar ch1 = 0, ch2 = 0; + Tcl_UniChar ch1, ch2; /* * 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.) @@ -1520,20 +1209,10 @@ */ 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; - } -#endif return (ch1 - ch2); } } return 0; } @@ -1558,88 +1237,31 @@ int Tcl_UtfNcasecmp( const char *cs, /* UTF string to compare to ct. */ const char *ct, /* UTF string cs is compared to. */ - size_t numChars) /* Number of UTF chars to compare. */ + unsigned long numChars) /* Number of UTF chars to compare. */ { - Tcl_UniChar ch1 = 0, ch2 = 0; - + Tcl_UniChar ch1, ch2; 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; - } -#endif ch1 = Tcl_UniCharToLower(ch1); ch2 = Tcl_UniCharToLower(ch2); if (ch1 != ch2) { return (ch1 - ch2); } } } return 0; } - -/* - *---------------------------------------------------------------------- - * - * Tcl_UtfCmp -- - * - * Compare UTF chars of string cs to string ct case sensitively. - * Replacement for strcmp in Tcl core, in places where UTF-8 should - * be handled. - * - * Results: - * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclUtfCmp( - const char *cs, /* UTF string to compare to ct. */ - const char *ct) /* UTF string cs is compared to. */ -{ - 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; - } -#endif - return ch1 - ch2; - } - } - return UCHAR(*cs) - UCHAR(*ct); -} - /* *---------------------------------------------------------------------- * * TclUtfCasecmp -- @@ -1660,26 +1282,16 @@ int TclUtfCasecmp( const char *cs, /* UTF string to compare to ct. */ const char *ct) /* UTF string cs is compared to. */ { - Tcl_UniChar ch1 = 0, ch2 = 0; + Tcl_UniChar ch1, ch2; 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; - } -#endif ch1 = Tcl_UniCharToLower(ch1); ch2 = Tcl_UniCharToLower(ch2); if (ch1 != ch2) { return ch1 - ch2; } @@ -1703,23 +1315,28 @@ * None. * *---------------------------------------------------------------------- */ -int +Tcl_UniChar Tcl_UniCharToUpper( int ch) /* Unicode character to convert. */ { +#if TCL_UTF_MAX > 3 if (!UNICODE_OUT_OF_RANGE(ch)) { +#endif int info = GetUniCharInfo(ch); if (GetCaseType(info) & 0x04) { ch -= GetDelta(info); } +#if TCL_UTF_MAX > 3 } /* Clear away extension bits, if any */ - return ch & 0x1FFFFF; + ch &= 0x1FFFFF; +#endif + return (Tcl_UniChar) ch; } /* *---------------------------------------------------------------------- * @@ -1734,24 +1351,29 @@ * None. * *---------------------------------------------------------------------- */ -int +Tcl_UniChar Tcl_UniCharToLower( int ch) /* Unicode character to convert. */ { +#if TCL_UTF_MAX > 3 if (!UNICODE_OUT_OF_RANGE(ch)) { +#endif int info = GetUniCharInfo(ch); int mode = GetCaseType(info); if ((mode & 0x02) && (mode != 0x7)) { ch += GetDelta(info); } +#if TCL_UTF_MAX > 3 } /* Clear away extension bits, if any */ - return ch & 0x1FFFFF; + ch &= 0x1FFFFF; +#endif + return (Tcl_UniChar) ch; } /* *---------------------------------------------------------------------- * @@ -1766,15 +1388,17 @@ * None. * *---------------------------------------------------------------------- */ -int +Tcl_UniChar Tcl_UniCharToTitle( int ch) /* Unicode character to convert. */ { +#if TCL_UTF_MAX > 3 if (!UNICODE_OUT_OF_RANGE(ch)) { +#endif int info = GetUniCharInfo(ch); int mode = GetCaseType(info); if (mode & 0x1) { /* @@ -1785,19 +1409,22 @@ ch += ((mode & 0x4) ? -1 : 1); } } else if (mode == 0x4) { ch -= GetDelta(info); } +#if TCL_UTF_MAX > 3 } /* Clear away extension bits, if any */ - return ch & 0x1FFFFF; + ch &= 0x1FFFFF; +#endif + return (Tcl_UniChar) ch; } /* *---------------------------------------------------------------------- * - * TclUniCharLen -- + * Tcl_UniCharLen -- * * Find the length of a UniChar string. The str input must be null * terminated. * * Results: @@ -1807,15 +1434,15 @@ * None. * *---------------------------------------------------------------------- */ -size_t -TclUniCharLen( +int +Tcl_UniCharLen( const Tcl_UniChar *uniStr) /* Unicode string to find length of. */ { - size_t len = 0; + int len = 0; while (*uniStr != '\0') { len++; uniStr++; } @@ -1823,11 +1450,11 @@ } /* *---------------------------------------------------------------------- * - * TclUniCharNcmp -- + * Tcl_UniCharNcmp -- * * Compare at most numChars unichars of string ucs to string uct. * Both ucs and uct are assumed to be at least numChars unichars long. * * Results: @@ -1838,14 +1465,14 @@ * *---------------------------------------------------------------------- */ int -TclUniCharNcmp( +Tcl_UniCharNcmp( const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */ const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */ - size_t numChars) /* Number of unichars to compare. */ + unsigned long numChars) /* Number of unichars to compare. */ { #ifdef WORDS_BIGENDIAN /* * We are definitely on a big-endian machine; memcmp() is safe */ @@ -1867,11 +1494,11 @@ } /* *---------------------------------------------------------------------- * - * TclUniCharNcasecmp -- + * Tcl_UniCharNcasecmp -- * * Compare at most numChars unichars of string ucs to string uct case * insensitive. Both ucs and uct are assumed to be at least numChars * unichars long. * @@ -1883,14 +1510,14 @@ * *---------------------------------------------------------------------- */ int -TclUniCharNcasecmp( +Tcl_UniCharNcasecmp( const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */ const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */ - size_t numChars) /* Number of unichars to compare. */ + 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); @@ -1921,13 +1548,15 @@ int Tcl_UniCharIsAlnum( int ch) /* Unicode character to test. */ { +#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return 0; } +#endif return (((ALPHA_BITS | DIGIT_BITS) >> GetCategory(ch)) & 1); } /* *---------------------------------------------------------------------- @@ -1947,13 +1576,15 @@ int Tcl_UniCharIsAlpha( int ch) /* Unicode character to test. */ { +#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return 0; } +#endif return ((ALPHA_BITS >> GetCategory(ch)) & 1); } /* *---------------------------------------------------------------------- @@ -1973,10 +1604,11 @@ int Tcl_UniCharIsControl( int ch) /* Unicode character to test. */ { +#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { /* Clear away extension bits, if any */ ch &= 0x1FFFFF; if ((ch == 0xE0001) || ((ch >= 0xE0020) && (ch <= 0xE007F))) { return 1; @@ -1984,10 +1616,11 @@ if ((ch >= 0xF0000) && ((ch & 0xFFFF) <= 0xFFFD)) { return 1; } return 0; } +#endif return ((CONTROL_BITS >> GetCategory(ch)) & 1); } /* *---------------------------------------------------------------------- @@ -2007,13 +1640,15 @@ int Tcl_UniCharIsDigit( int ch) /* Unicode character to test. */ { +#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return 0; } +#endif return (GetCategory(ch) == DECIMAL_DIGIT_NUMBER); } /* *---------------------------------------------------------------------- @@ -2033,13 +1668,15 @@ int Tcl_UniCharIsGraph( int ch) /* Unicode character to test. */ { +#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return ((unsigned)((ch & 0x1FFFFF) - 0xE0100) <= 0xEF); } +#endif return ((GRAPH_BITS >> GetCategory(ch)) & 1); } /* *---------------------------------------------------------------------- @@ -2059,13 +1696,15 @@ int Tcl_UniCharIsLower( int ch) /* Unicode character to test. */ { +#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return 0; } +#endif return (GetCategory(ch) == LOWERCASE_LETTER); } /* *---------------------------------------------------------------------- @@ -2085,13 +1724,15 @@ int Tcl_UniCharIsPrint( int ch) /* Unicode character to test. */ { +#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return ((unsigned)((ch & 0x1FFFFF) - 0xE0100) <= 0xEF); } +#endif return (((GRAPH_BITS|SPACE_BITS) >> GetCategory(ch)) & 1); } /* *---------------------------------------------------------------------- @@ -2111,13 +1752,15 @@ int Tcl_UniCharIsPunct( int ch) /* Unicode character to test. */ { +#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return 0; } +#endif return ((PUNCT_BITS >> GetCategory(ch)) & 1); } /* *---------------------------------------------------------------------- @@ -2137,24 +1780,30 @@ int Tcl_UniCharIsSpace( int ch) /* Unicode character to test. */ { +#if TCL_UTF_MAX > 3 /* Ignore upper 11 bits. */ ch &= 0x1FFFFF; +#else + /* Ignore upper 16 bits. */ + ch &= 0xFFFF; +#endif /* * 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); +#if TCL_UTF_MAX > 3 } else if (UNICODE_OUT_OF_RANGE(ch)) { return 0; - } else if (ch == 0x0085 || ch == 0x180E || ch == 0x200B - || ch == 0x202F || ch == 0x2060 || ch == 0xFEFF) { +#endif + } else if (ch == 0x180E || ch == 0x202F) { return 1; } else { return ((SPACE_BITS >> GetCategory(ch)) & 1); } } @@ -2177,13 +1826,15 @@ int Tcl_UniCharIsUpper( int ch) /* Unicode character to test. */ { +#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return 0; } +#endif return (GetCategory(ch) == UPPERCASE_LETTER); } /* *---------------------------------------------------------------------- @@ -2203,20 +1854,22 @@ int Tcl_UniCharIsWordChar( int ch) /* Unicode character to test. */ { +#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return 0; } +#endif return ((WORD_BITS >> GetCategory(ch)) & 1); } /* *---------------------------------------------------------------------- * - * TclUniCharCaseMatch -- + * Tcl_UniCharCaseMatch -- * * See if a particular Unicode string matches a particular pattern. * Allows case insensitivity. This is the Unicode equivalent of the char* * Tcl_StringCaseMatch. The UniChar strings must be NULL-terminated. * This has no provision for counted UniChar strings, thus should not be @@ -2233,18 +1886,18 @@ * *---------------------------------------------------------------------- */ int -TclUniCharCaseMatch( +Tcl_UniCharCaseMatch( const Tcl_UniChar *uniStr, /* Unicode String. */ const Tcl_UniChar *uniPattern, /* Pattern, which may contain special * characters. */ int nocase) /* 0 for case sensitive, 1 for insensitive */ { - Tcl_UniChar ch1 = 0, p; + Tcl_UniChar ch1, p; while (1) { p = *uniPattern; /* @@ -2300,11 +1953,11 @@ while (*uniStr && (p != *uniStr)) { uniStr++; } } } - if (TclUniCharCaseMatch(uniStr, uniPattern, nocase)) { + if (Tcl_UniCharCaseMatch(uniStr, uniPattern, nocase)) { return 1; } if (*uniStr == 0) { return 0; } @@ -2406,11 +2059,11 @@ * * TclUniCharMatch -- * * See if a particular Unicode string matches a particular pattern. * Allows case insensitivity. This is the Unicode equivalent of the char* - * Tcl_StringCaseMatch. This variant of TclUniCharCaseMatch uses counted + * Tcl_StringCaseMatch. This variant of Tcl_UniCharCaseMatch uses counted * Strings, so embedded NULLs are allowed. * * Results: * The return value is 1 if string matches pattern, and 0 otherwise. The * matching operation permits the following special characters in the @@ -2423,14 +2076,14 @@ */ int TclUniCharMatch( const Tcl_UniChar *string, /* Unicode String. */ - size_t strLen, /* Length of String */ + int strLen, /* Length of String */ const Tcl_UniChar *pattern, /* Pattern, which may contain special * characters. */ - size_t ptnLen, /* Length of Pattern */ + int ptnLen, /* Length of Pattern */ int nocase) /* 0 for case sensitive, 1 for insensitive */ { const Tcl_UniChar *stringEnd, *patternEnd; Tcl_UniChar p; @@ -2590,64 +2243,12 @@ 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: */ Index: generic/tclUtil.c ================================================================== --- generic/tclUtil.c +++ generic/tclUtil.c @@ -11,13 +11,11 @@ * 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 #include /* * The absolute pathname of the executable in which this Tcl library is * running. @@ -26,13 +24,13 @@ static ProcessGlobalValue executableName = { 0, 0, NULL, NULL, NULL, NULL, NULL }; /* - * The following values are used in the flags arguments of Tcl*Scan*Element - * and Tcl*Convert*Element. The values TCL_DONT_USE_BRACES and - * TCL_DONT_QUOTE_HASH are defined in tcl.h, like so: + * The following values are used in the flags arguments of Tcl*Scan*Element and + * Tcl*Convert*Element. The values TCL_DONT_USE_BRACES and TCL_DONT_QUOTE_HASH + * are defined in tcl.h, like so: * #define TCL_DONT_USE_BRACES 1 #define TCL_DONT_QUOTE_HASH 8 * * Those are public flag bits which callers of the public routines @@ -40,46 +38,46 @@ * * TCL_DONT_USE_BRACES - 1 means the caller is insisting that brace * quoting not be used when converting the list * element. * TCL_DONT_QUOTE_HASH - 1 means the caller insists that a leading hash - * character ('#') should *not* be quoted. This - * is appropriate when the caller can guarantee - * the element is not the first element of a - * list, so [eval] cannot mis-parse the element - * as a comment. + * character ('#') should *not* be quoted. This + * is appropriate when the caller can guarantee + * the element is not the first element of a + * list, so [eval] cannot mis-parse the element + * as a comment. * * The remaining values which can be carried by the flags of these routines * are for internal use only. Make sure they do not overlap with the public * values above. * * The Tcl*Scan*Element() routines make a determination which of 4 modes of * conversion is most appropriate for Tcl*Convert*Element() to perform, and * sets two bits of the flags value to indicate the mode selected. * - * CONVERT_NONE The element needs no quoting. Its literal string is - * suitable as is. + * CONVERT_NONE The element needs no quoting. Its literal string + * is suitable as is. * CONVERT_BRACE The conversion should be enclosing the literal string * in braces. * CONVERT_ESCAPE The conversion should be using backslashes to escape * any characters in the string that require it. * CONVERT_MASK A mask value used to extract the conversion mode from * the flags argument. * Also indicates a strange conversion mode where all * special characters are escaped with backslashes - * *except for braces*. This is a strange and unnecessary + * *except for braces*. This is a strange and unnecessary * case, but it's part of the historical way in which - * lists have been formatted in Tcl. To experiment with + * lists have been formatted in Tcl. To experiment with * removing this case, set the value of COMPAT to 0. * - * One last flag value is used only by callers of TclScanElement(). The flag + * One last flag value is used only by callers of TclScanElement(). The flag * value produced by a call to Tcl*Scan*Element() will never leave this bit * set. * - * CONVERT_ANY The caller of TclScanElement() declares it can make no - * promise about what public flags will be passed to the - * matching call of TclConvertElement(). As such, + * CONVERT_ANY The caller of TclScanElement() declares it can make + * no promise about what public flags will be passed to + * the matching call of TclConvertElement(). As such, * TclScanElement() has to determine the worst case * destination buffer length over all possibilities, and * in other cases this means an overestimate of the * required size. * @@ -92,60 +90,58 @@ #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, size_t *sizePtr, - int *literalPtr); +static int SetEndOffsetFromAny(Tcl_Interp* interp, + Tcl_Obj* objPtr); +static void UpdateStringOfEndOffset(Tcl_Obj* objPtr); + /* * 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 - * around. This type is only created from a pre-existing string, so an - * updateStringProc will never be called and need not exist. The type - * is unregistered, so has no need of a setFromAnyProc either. + * performance optimization in TclGetIntForIndex. The internal rep is an + * integer, so no memory management is required for it. */ -static const Tcl_ObjType endOffsetType = { +Tcl_ObjType tclEndOffsetType = { "end-offset", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ - NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ + UpdateStringOfEndOffset, /* updateStringProc */ + SetEndOffsetFromAny }; /* * * STRING REPRESENTATION OF LISTS * * * * - * The next several routines implement the conversions of strings to and from - * Tcl lists. To understand their operation, the rules of parsing and - * generating the string representation of lists must be known. Here we - * describe them in one place. - * - * A list is made up of zero or more elements. Any string is a list if it is - * made up of alternating substrings of element-separating ASCII whitespace - * and properly formatted elements. - * - * The ASCII characters which can make up the whitespace between list elements - * are: + * The next several routines implement the conversions of strings to and + * from Tcl lists. To understand their operation, the rules of parsing + * and generating the string representation of lists must be known. Here + * we describe them in one place. + * + * A list is made up of zero or more elements. Any string is a list if + * it is made up of alternating substrings of element-separating ASCII + * whitespace and properly formatted elements. + * + * The ASCII characters which can make up the whitespace between list + * elements are: * * \u0009 \t TAB * \u000A \n NEWLINE * \u000B \v VERTICAL TAB * \u000C \f FORM FEED @@ -160,72 +156,73 @@ * importance here. * * * Unlike command parsing, the BACKSLASH NEWLINE sequence is not * considered to be a whitespace character. * - * * Other Unicode whitespace characters (recognized by [string is space] - * or Tcl_UniCharIsSpace()) do not play any role as element separators - * in Tcl lists. + * * Other Unicode whitespace characters (recognized by + * [string is space] or Tcl_UniCharIsSpace()) do not play any role + * as element separators in Tcl lists. * * * The NUL byte ought not appear, as it is not in strings properly * encoded for Tcl, but if it is present, it is not treated as - * separating whitespace, or a string terminator. It is just another - * character in a list element. - * - * The interpretation of a formatted substring as a list element follows rules - * similar to the parsing of the words of a command in a Tcl script. Backslash - * substitution plays a key role, and is defined exactly as it is in command - * parsing. The same routine, TclParseBackslash() is used in both command - * parsing and list parsing. - * - * NOTE: This means that if and when backslash substitution rules ever change - * for command parsing, the interpretation of strings as lists also changes. + * separating whitespace, or a string terminator. It is just + * another character in a list element. + * + * The interpretation of a formatted substring as a list element follows + * rules similar to the parsing of the words of a command in a Tcl script. + * Backslash substitution plays a key role, and is defined exactly as it is + * in command parsing. The same routine, TclParseBackslash() is used in both + * command parsing and list parsing. + * + * NOTE: This means that if and when backslash substitution rules ever + * change for command parsing, the interpretation of strings as lists also + * changes. * * Backslash substitution replaces an "escape sequence" of one or more * characters starting with * \u005c \ BACKSLASH - * with a single character. The one character escape sequence case happens only - * when BACKSLASH is the last character in the string. In all other cases, the - * escape sequence is at least two characters long. + * with a single character. The one character escape sequence case happens + * only when BACKSLASH is the last character in the string. In all other + * cases, the escape sequence is at least two characters long. * - * The formatted substrings are interpreted as element values according to the - * following cases: + * The formatted substrings are interpreted as element values according to + * the following cases: * * * If the first character of a formatted substring is * \u007b { OPEN BRACE * then the end of the substring is the matching * \u007d } CLOSE BRACE - * character, where matching is determined by counting nesting levels, and - * not including any brace characters that are contained within a backslash - * escape sequence in the nesting count. Having found the matching brace, - * all characters between the braces are the string value of the element. - * If no matching close brace is found before the end of the string, the - * string is not a Tcl list. If the character following the close brace is - * not an element separating whitespace character, or the end of the string, - * then the string is not a Tcl list. - * - * NOTE: this differs from a brace-quoted word in the parsing of a Tcl - * command only in its treatment of the backslash-newline sequence. In a - * list element, the literal characters in the backslash-newline sequence - * become part of the element value. In a script word, conversion to a - * single SPACE character is done. + * character, where matching is determined by counting nesting levels, + * and not including any brace characters that are contained within a + * backslash escape sequence in the nesting count. Having found the + * matching brace, all characters between the braces are the string + * value of the element. If no matching close brace is found before the + * end of the string, the string is not a Tcl list. If the character + * following the close brace is not an element separating whitespace + * character, or the end of the string, then the string is not a Tcl list. + * + * NOTE: this differs from a brace-quoted word in the parsing of a + * Tcl command only in its treatment of the backslash-newline sequence. + * In a list element, the literal characters in the backslash-newline + * sequence become part of the element value. In a script word, + * conversion to a single SPACE character is done. * * NOTE: Most list element values can be represented by a formatted - * substring using brace quoting. The exceptions are any element value that - * includes an unbalanced brace not in a backslash escape sequence, and any - * value that ends with a backslash not itself in a backslash escape - * sequence. + * substring using brace quoting. The exceptions are any element value + * that includes an unbalanced brace not in a backslash escape sequence, + * and any value that ends with a backslash not itself in a backslash + * escape sequence. * * * If the first character of a formatted substring is * \u0022 " QUOTE * then the end of the substring is the next QUOTE character, not counting * any QUOTE characters that are contained within a backslash escape - * sequence. If no next QUOTE is found before the end of the string, the - * string is not a Tcl list. If the character following the closing QUOTE is - * not an element separating whitespace character, or the end of the string, - * then the string is not a Tcl list. Having found the limits of the - * substring, the element value is produced by performing backslash + * sequence. If no next QUOTE is found before the end of the string, the + * string is not a Tcl list. If the character following the closing QUOTE + * is not an element separating whitespace character, or the end of the + * string, then the string is not a Tcl list. Having found the limits + * of the substring, the element value is produced by performing backslash * substitution on the character sequence between the open and close QUOTEs. * * NOTE: Any element value can be represented by this style of formatting, * given suitable choice of backslash escape sequences. * @@ -232,57 +229,58 @@ * * All other formatted substrings are terminated by the next element * separating whitespace character in the string. Having found the limits * of the substring, the element value is produced by performing backslash * substitution on it. * - * NOTE: Any element value can be represented by this style of formatting, + * NOTE: Any element value can be represented by this style of formatting, * given suitable choice of backslash escape sequences, with one exception. * The empty string cannot be represented as a list element without the use * of either braces or quotes to delimit it. * * This collection of parsing rules is implemented in the routine - * FindElement(). - * - * In order to produce lists that can be parsed by these rules, we need the - * ability to distinguish between characters that are part of a list element - * value from characters providing syntax that define the structure of the - * list. This means that our code that generates lists must at a minimum be - * able to produce escape sequences for the 10 characters identified above - * that have significance to a list parser. + * TclFindElement(). + * + * In order to produce lists that can be parsed by these rules, we need + * the ability to distinguish between characters that are part of a list + * element value from characters providing syntax that define the structure + * of the list. This means that our code that generates lists must at a + * minimum be able to produce escape sequences for the 10 characters + * identified above that have significance to a list parser. * * * * CANONICAL LISTS * * * * * * * In addition to the basic rules for parsing strings into Tcl lists, there * are additional properties to be met by the set of list values that are * generated by Tcl. Such list values are often said to be in "canonical * form": * - * * When any canonical list is evaluated as a Tcl script, it is a script of - * either zero commands (an empty list) or exactly one command. The command - * word is exactly the first element of the list, and each argument word is - * exactly one of the following elements of the list. This means that any - * characters that have special meaning during script evaluation need - * special treatment when canonical lists are produced: + * * When any canonical list is evaluated as a Tcl script, it is a script + * of either zero commands (an empty list) or exactly one command. The + * command word is exactly the first element of the list, and each argument + * word is exactly one of the following elements of the list. This means + * that any characters that have special meaning during script evaluation + * need special treatment when canonical lists are produced: * * * Whitespace between elements may not include NEWLINE. * * The command terminating character, * \u003b ; SEMICOLON - * must be BRACEd, QUOTEd, or escaped so that it does not terminate the - * command prematurely. + * must be BRACEd, QUOTEd, or escaped so that it does not terminate + * the command prematurely. * * Any of the characters that begin substitutions in scripts, * \u0024 $ DOLLAR * \u005b [ OPEN BRACKET * \u005c \ BACKSLASH * need to be BRACEd or escaped. * * In any list where the first character of the first element is * \u0023 # HASH * that HASH character must be BRACEd, QUOTEd, or escaped so that it * does not convert the command into a comment. - * * Any list element that contains the character sequence BACKSLASH - * NEWLINE cannot be formatted with BRACEs. The BACKSLASH character - * must be represented by an escape sequence, and unless QUOTEs are - * used, the NEWLINE must be as well. + * * Any list element that contains the character sequence + * BACKSLASH NEWLINE cannot be formatted with BRACEs. The + * BACKSLASH character must be represented by an escape + * sequence, and unless QUOTEs are used, the NEWLINE must + * be as well. * * * It is also guaranteed that one can use a canonical list as a building * block of a larger script within command substitution, as in this example: * set script "puts \[[list $cmd $arg]]"; eval $script * To support this usage, any appearance of the character @@ -289,70 +287,70 @@ * \u005d ] CLOSE BRACKET * in a list element must be BRACEd, QUOTEd, or escaped. * * * Finally it is guaranteed that enclosing a canonical list in braces * produces a new value that is also a canonical list. This new list has - * length 1, and its only element is the original canonical list. This same - * guarantee also makes it possible to construct scripts where an argument - * word is given a list value by enclosing the canonical form of that list - * in braces: + * length 1, and its only element is the original canonical list. This + * same guarantee also makes it possible to construct scripts where an + * argument word is given a list value by enclosing the canonical form + * of that list in braces: * set script "puts {[list $one $two $three]}"; eval $script * This sort of coding was once fairly common, though it's become more * idiomatic to see the following instead: * set script [list puts [list $one $two $three]]; eval $script * In order to support this guarantee, every canonical list must have * balance when counting those braces that are not in escape sequences. * * Within these constraints, the canonical list generation routines - * TclScanElement() and TclConvertElement() attempt to generate the string for - * any list that is easiest to read. When an element value is itself + * TclScanElement() and TclConvertElement() attempt to generate the string + * for any list that is easiest to read. When an element value is itself * acceptable as the formatted substring, it is usually used (CONVERT_NONE). - * When some quoting or escaping is required, use of BRACEs (CONVERT_BRACE) is - * usually preferred over the use of escape sequences (CONVERT_ESCAPE). There - * are some exceptions to both of these preferences for reasons of code - * simplicity, efficiency, and continuation of historical habits. Canonical - * lists never use the QUOTE formatting to delimit their elements because that - * form of quoting does not nest, which makes construction of nested lists far - * too much trouble. Canonical lists always use only a single SPACE character - * for element-separating whitespace. + * When some quoting or escaping is required, use of BRACEs (CONVERT_BRACE) + * is usually preferred over the use of escape sequences (CONVERT_ESCAPE). + * There are some exceptions to both of these preferences for reasons of + * code simplicity, efficiency, and continuation of historical habits. + * Canonical lists never use the QUOTE formatting to delimit their elements + * because that form of quoting does not nest, which makes construction of + * nested lists far too much trouble. Canonical lists always use only a + * single SPACE character for element-separating whitespace. * * * * FUTURE CONSIDERATIONS * * * * * When a list element requires quoting or escaping due to a CLOSE BRACKET * character or an internal QUOTE character, a strange formatting mode is - * recommended. For example, if the value "a{b]c}d" is converted by the usual - * modes: + * recommended. For example, if the value "a{b]c}d" is converted by the + * usual modes: * * CONVERT_BRACE: a{b]c}d => {a{b]c}d} * CONVERT_ESCAPE: a{b]c}d => a\{b\]c\}d * - * we get perfectly usable formatted list elements. However, this is not what - * Tcl releases have been producing. Instead, we have: + * we get perfectly usable formatted list elements. However, this is not + * what Tcl releases have been producing. Instead, we have: * * CONVERT_MASK: a{b]c}d => a{b\]c}d * - * where the CLOSE BRACKET is escaped, but the BRACEs are not. The same effect - * can be seen replacing ] with " in this example. There does not appear to be - * any functional or aesthetic purpose for this strange additional mode. The - * sole purpose I can see for preserving it is to keep generating the same - * formatted lists programmers have become accustomed to, and perhaps written - * tests to expect. That is, compatibility only. The additional code - * complexity required to support this mode is significant. The lines of code - * supporting it are delimited in the routines below with #if COMPAT - * directives. This makes it easy to experiment with eliminating this - * formatting mode simply with "#define COMPAT 0" above. I believe this is - * worth considering. - * - * Another consideration is the treatment of QUOTE characters in list - * elements. TclConvertElement() must have the ability to produce the escape - * sequence \" so that when a list element begins with a QUOTE we do not - * confuse that first character with a QUOTE used as list syntax to define - * list structure. However, that is the only place where QUOTE characters need - * quoting. In this way, handling QUOTE could really be much more like the way - * we handle HASH which also needs quoting and escaping only in particular - * situations. Following up this could increase the set of list elements that - * can use the CONVERT_NONE formatting mode. + * where the CLOSE BRACKET is escaped, but the BRACEs are not. The same + * effect can be seen replacing ] with " in this example. There does not + * appear to be any functional or aesthetic purpose for this strange + * additional mode. The sole purpose I can see for preserving it is to + * keep generating the same formatted lists programmers have become accustomed + * to, and perhaps written tests to expect. That is, compatibility only. + * The additional code complexity required to support this mode is significant. + * The lines of code supporting it are delimited in the routines below with + * #if COMPAT directives. This makes it easy to experiment with eliminating + * this formatting mode simply with "#define COMPAT 0" above. I believe + * this is worth considering. + * + * Another consideration is the treatment of QUOTE characters in list elements. + * TclConvertElement() must have the ability to produce the escape sequence + * \" so that when a list element begins with a QUOTE we do not confuse + * that first character with a QUOTE used as list syntax to define list + * structure. However, that is the only place where QUOTE characters need + * quoting. In this way, handling QUOTE could really be much more like + * the way we handle HASH which also needs quoting and escaping only in + * particular situations. Following up this could increase the set of + * list elements that can use the CONVERT_NONE formatting mode. * * More speculative is that the demands of canonical list form require brace * balance for the list as a whole, while the current implementation achieves * this by establishing brace balance for every element. * @@ -366,82 +364,67 @@ * * TclMaxListLength -- * * Given 'bytes' pointing to 'numBytes' bytes, scan through them and * count the number of whitespace runs that could be list element - * separators. If 'numBytes' is -1, scan to the terminating '\0'. Not a - * full list parser. Typically used to get a quick and dirty overestimate - * of length size in order to allocate space for an actual list parser to - * operate with. + * separators. If 'numBytes' is -1, scan to the terminating '\0'. + * Not a full list parser. Typically used to get a quick and dirty + * overestimate of length size in order to allocate space for an + * actual list parser to operate with. * * Results: - * Returns the largest number of list elements that could possibly be in - * this string, interpreted as a Tcl list. If 'endPtr' is not NULL, - * writes a pointer to the end of the string scanned there. + * Returns the largest number of list elements that could possibly + * be in this string, interpreted as a Tcl list. If 'endPtr' is not + * NULL, writes a pointer to the end of the string scanned there. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclMaxListLength( - const char *bytes, - size_t numBytes, - const char **endPtr) + CONST char *bytes, + int numBytes, + CONST char **endPtr) { - size_t count = 0; + int count = 0; - if ((numBytes == 0) || ((numBytes == TCL_INDEX_NONE) && (*bytes == '\0'))) { + if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) { /* Empty string case - quick exit */ goto done; } - /* - * No list element before leading white space. - */ - + /* No list element before leading white space */ count += 1 - TclIsSpaceProcM(*bytes); - /* - * Count white space runs as potential element separators. - */ - + /* Count white space runs as potential element separators */ while (numBytes) { - if ((numBytes == TCL_INDEX_NONE) && (*bytes == '\0')) { + if ((numBytes == -1) && (*bytes == '\0')) { break; } if (TclIsSpaceProcM(*bytes)) { - /* - * Space run started; bump count. - */ - + /* Space run started; bump count */ count++; do { bytes++; - numBytes -= (numBytes != TCL_INDEX_NONE); + numBytes -= (numBytes != -1); } while (numBytes && TclIsSpaceProcM(*bytes)); - if ((numBytes == 0) || ((numBytes == TCL_INDEX_NONE) && (*bytes == '\0'))) { + if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) { break; } - - /* - * (*bytes) is non-space; return to counting state. - */ + /* (*bytes) is non-space; return to counting state */ } bytes++; - numBytes -= (numBytes != TCL_INDEX_NONE); + numBytes -= (numBytes != -1); } - /* - * No list element following trailing white space. - */ - + /* No list element following trailing white space */ count -= TclIsSpaceProcM(bytes[-1]); - done: + done: if (endPtr) { *endPtr = bytes; } return count; } @@ -464,22 +447,22 @@ * first element of list, and *nextPtr will be set to point to the * character just after any white space following the last character * that's part of the element. If this is the last argument in the list, * then *nextPtr will point just after the last character in the list * (i.e., at the character at list+listLength). If sizePtr is non-NULL, - * *sizePtr is filled in with the number of bytes in the element. If the - * element is in braces, then *elementPtr will point to the character + * *sizePtr is filled in with the number of bytes in the element. If + * the element is in braces, then *elementPtr will point to the character * after the opening brace and *sizePtr will not include either of the * braces. If there isn't an element in the list, *sizePtr will be zero, * and both *elementPtr and *nextPtr will point just after the last * character in the list. If literalPtr is non-NULL, *literalPtr is set - * to a boolean value indicating whether the substring returned as the - * values of **elementPtr and *sizePtr is the literal value of a list - * element. If not, a call to TclCopyAndCollapse() is needed to produce - * the actual value of the list element. Note: this function does NOT - * collapse backslash sequences, but uses *literalPtr to tell callers - * when it is required for them to do so. + * to a boolean value indicating whether the substring returned as + * the values of **elementPtr and *sizePtr is the literal value of + * a list element. If not, a call to TclCopyAndCollapse() is needed + * to produce the actual value of the list element. Note: this function + * does NOT collapse backslash sequences, but uses *literalPtr to tell + * callers when it is required for them to do so. * * Side effects: * None. * *---------------------------------------------------------------------- @@ -488,106 +471,45 @@ int TclFindElement( Tcl_Interp *interp, /* Interpreter to use for error reporting. If * NULL, then no error message is left after * errors. */ - const char *list, /* Points to the first byte of a string + CONST char *list, /* Points to the first byte of a string * containing a Tcl list with zero or more * elements (possibly in braces). */ int listLength, /* Number of bytes in the list's string. */ - const char **elementPtr, /* Where to put address of first significant + 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 + CONST char **nextPtr, /* Fill in with location of character just * after all white space following end of * argument (next arg or end of list). */ - size_t *sizePtr, /* If non-zero, fill in with size of + 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. */ { - return FindElement(interp, list, listLength, "list", "LIST", elementPtr, - nextPtr, sizePtr, literalPtr); -} - -int -TclFindDictElement( - Tcl_Interp *interp, /* Interpreter to use for error reporting. If - * NULL, then no error message is left after - * errors. */ - const char *dict, /* Points to the first byte of a string - * containing a Tcl dictionary with zero or - * more keys and values (possibly in - * braces). */ - 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). */ - size_t *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. */ -{ - return FindElement(interp, dict, dictLength, "dict", "DICTIONARY", - elementPtr, nextPtr, sizePtr, literalPtr); -} - -static int -FindElement( - Tcl_Interp *interp, /* Interpreter to use for error reporting. If - * NULL, then no error message is left after - * errors. */ - const char *string, /* Points to the first byte of a string - * containing a Tcl list or dictionary with - * zero or more elements (possibly in - * braces). */ - int stringLength, /* Number of bytes in the string. */ - const char *typeStr, /* The name of the type of thing we are - * parsing, for error messages. */ - 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). */ - size_t *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. */ + CONST char *p = list; + CONST char *elemStart; /* Points to first byte of first element. */ + CONST char *limit; /* Points just after list's last byte. */ int openBraces = 0; /* Brace nesting level during parse. */ int inQuotes = 0; - int size = 0; - size_t numChars; + int size = 0; /* lint. */ + int numChars; int literal = 1; - const char *p2; + 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). + * We treat embedded NULLs in the list as bytes belonging to a list + * element. */ - limit = (string + stringLength); + limit = (list + listLength); while ((p < limit) && (TclIsSpaceProcM(*p))) { p++; } if (p == limit) { /* no element found */ elemStart = limit; @@ -644,14 +566,12 @@ 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", - NULL); + "list element in braces followed by \"%.*s\" " + "instead of space", (int) (p2-p), p)); } return TCL_ERROR; } break; @@ -663,14 +583,13 @@ case '\\': if (openBraces == 0) { /* * A backslash sequence not within a brace quoted element * means the value of the element is different from the - * substring we are parsing. A call to TclCopyAndCollapse() is - * needed to produce the element value. Inform the caller. + * substring we are parsing. A call to TclCopyAndCollapse() + * is needed to produce the element value. Inform the caller. */ - literal = 0; } TclParseBackslash(p, limit - p, &numChars, NULL); p += (numChars - 1); break; @@ -696,14 +615,12 @@ 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); + "list element in quotes followed by \"%.*s\" " + "instead of space", (int) (p2-p), p)); } return TCL_ERROR; } break; @@ -723,28 +640,24 @@ } p++; } /* - * End of list/dict: terminate element. + * End of list: terminate element. */ if (p == limit) { if (openBraces != 0) { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unmatched open brace in %s", typeStr)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "BRACE", - NULL); + Tcl_SetResult(interp, "unmatched open brace in list", + TCL_STATIC); } return TCL_ERROR; } else if (inQuotes) { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unmatched open quote in %s", typeStr)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "QUOTE", - NULL); + Tcl_SetResult(interp, "unmatched open quote in list", + TCL_STATIC); } return TCL_ERROR; } size = (p - elemStart); } @@ -771,34 +684,33 @@ * * Copy a string and substitute all backslash escape sequences * * Results: * Count bytes get copied from src to dst. Along the way, backslash - * sequences are substituted in the copy. After scanning count bytes from - * src, a null character is placed at the end of dst. Returns the number - * of bytes that got written to dst. + * sequences are substituted in the copy. After scanning count bytes + * from src, a null character is placed at the end of dst. Returns + * the number of bytes that got written to dst. * * Side effects: * None. * *---------------------------------------------------------------------- */ -size_t +int TclCopyAndCollapse( - size_t count, /* Number of byte to copy from src. */ - const char *src, /* Copy from here... */ + int count, /* Number of byte to copy from src. */ + CONST char *src, /* Copy from here... */ char *dst) /* ... to here. */ { - size_t newCount = 0; + int newCount = 0; while (count > 0) { char c = *src; - if (c == '\\') { - size_t numRead; - size_t backslashCount = TclParseBackslash(src, count, &numRead, dst); + int numRead; + int backslashCount = TclParseBackslash(src, count, &numRead, dst); dst += backslashCount; newCount += backslashCount; src += numRead; count -= numRead; @@ -844,61 +756,60 @@ int Tcl_SplitList( Tcl_Interp *interp, /* Interpreter to use for error reporting. If * NULL, no error message is left. */ - const char *list, /* Pointer to string with list structure. */ + CONST char *list, /* Pointer to string with list structure. */ 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 + CONST char ***argvPtr) /* Pointer to place to store pointer to array * of pointers to list elements. */ { - const char **argv, *end, *element; + CONST char **argv, *end, *element; char *p; - int length, size, i, result; - size_t elSize; + 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. + * 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 **)Tcl_Alloc((size * sizeof(char *)) + length + 1); + argv = (CONST char **) ckalloc((unsigned) + ((size * sizeof(char *)) + length + 1)); for (i = 0, p = ((char *) argv) + size*sizeof(char *); *list != 0; i++) { - const char *prevList = list; + CONST char *prevList = list; int literal; result = TclFindElement(interp, list, length, &element, &list, &elSize, &literal); length -= (list - prevList); if (result != TCL_OK) { - Tcl_Free((void *)argv); + ckfree((char *) argv); return result; } if (*element == 0) { break; } if (i >= size) { - Tcl_Free((void *)argv); + ckfree((char *) argv); if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "internal error in Tcl_SplitList", -1)); - Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList", - NULL); + Tcl_SetResult(interp, "internal error in Tcl_SplitList", + TCL_STATIC); } return TCL_ERROR; } argv[i] = p; if (literal) { - memcpy(p, element, elSize); + memcpy(p, element, (size_t) elSize); p += elSize; *p = 0; p++; } else { p += 1 + TclCopyAndCollapse(elSize, element, p); @@ -919,26 +830,26 @@ * This function is a companion function to Tcl_ConvertElement. It scans * a string to see what needs to be done to it (e.g. add backslashes or * enclosing braces) to make the string into a valid Tcl list element. * * Results: - * The return value is an overestimate of the number of bytes that will - * be needed by Tcl_ConvertElement to produce a valid list element from - * src. The word at *flagPtr is filled in with a value needed by + * The return value is an overestimate of the number of bytes that + * will be needed by Tcl_ConvertElement to produce a valid list element + * from src. The word at *flagPtr is filled in with a value needed by * Tcl_ConvertElement when doing the actual conversion. * * Side effects: * None. * *---------------------------------------------------------------------- */ -size_t +int Tcl_ScanElement( - const char *src, /* String to convert to list element. */ - int *flagPtr) /* Where to store information to guide - * Tcl_ConvertCountedElement. */ + register CONST char *src, /* String to convert to list element. */ + register int *flagPtr) /* Where to store information to guide + * Tcl_ConvertCountedElement. */ { return Tcl_ScanCountedElement(src, -1, flagPtr); } /* @@ -951,29 +862,29 @@ * backslashes or enclosing braces) to make the string into a valid Tcl * list element. If length is -1, then the string is scanned from src up * to the first null byte. * * Results: - * The return value is an overestimate of the number of bytes that will - * be needed by Tcl_ConvertCountedElement to produce a valid list element - * from src. The word at *flagPtr is filled in with a value needed by - * Tcl_ConvertCountedElement when doing the actual conversion. + * The return value is an overestimate of the number of bytes that + * will be needed by Tcl_ConvertCountedElement to produce a valid list + * element from src. The word at *flagPtr is filled in with a value + * needed by Tcl_ConvertCountedElement when doing the actual conversion. * * Side effects: * None. * *---------------------------------------------------------------------- */ -size_t +int Tcl_ScanCountedElement( - const char *src, /* String to convert to Tcl list element. */ - size_t length, /* Number of bytes in src, or -1. */ + 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 flags = CONVERT_ANY; int numBytes = TclScanElement(src, length, &flags); *flagPtr = flags; return numBytes; } @@ -981,64 +892,61 @@ /* *---------------------------------------------------------------------- * * TclScanElement -- * - * This function is a companion function to TclConvertElement. It scans a - * string to see what needs to be done to it (e.g. add backslashes or - * enclosing braces) to make the string into a valid Tcl list element. If - * length is -1, then the string is scanned from src up to the first null - * byte. A NULL value for src is treated as an empty string. The incoming - * value of *flagPtr is a report from the caller what additional flags it - * will pass to TclConvertElement(). + * This function is a companion function to TclConvertElement. It + * scans a string to see what needs to be done to it (e.g. add + * backslashes or enclosing braces) to make the string into a valid Tcl + * list element. If length is -1, then the string is scanned from src up + * to the first null byte. A NULL value for src is treated as an + * empty string. The incoming value of *flagPtr is a report from the + * caller what additional flags it will pass to TclConvertElement(). * * Results: - * The recommended formatting mode for the element is determined and a - * value is written to *flagPtr indicating that recommendation. This + * The recommended formatting mode for the element is determined and + * a value is written to *flagPtr indicating that recommendation. This * recommendation is combined with the incoming flag values in *flagPtr * set by the caller to determine how many bytes will be needed by * TclConvertElement() in which to write the formatted element following - * the recommendation modified by the flag values. This number of bytes - * is the return value of the routine. In some situations it may be an - * overestimate, but so long as the caller passes the same flags to - * TclConvertElement(), it will be large enough. + * the recommendation modified by the flag values. This number of bytes + * is the return value of the routine. In some situations it may be + * an overestimate, but so long as the caller passes the same flags + * to TclConvertElement(), it will be large enough. * * Side effects: * None. * *---------------------------------------------------------------------- */ -size_t +int TclScanElement( - const char *src, /* String to convert to Tcl list element. */ - size_t length, /* Number of bytes in src, or -1. */ - char *flagPtr) /* Where to store information to guide + 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. */ { - const char *p = src; + CONST char *p = src; int nestingLevel = 0; /* Brace nesting count */ int forbidNone = 0; /* Do not permit CONVERT_NONE mode. Something - * needs protection or escape. */ + 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. */ - size_t bytesNeeded; /* Buffer length computed to complete the + 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 */ +#endif - if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == TCL_INDEX_NONE))) { - /* - * Empty string element must be brace quoted. - */ - + if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == -1))) { + /* Empty string element must be brace quoted. */ *flagPtr = CONVERT_BRACE; return 2; } #if COMPAT @@ -1061,77 +969,65 @@ if ((*p == '{') || (*p == '"')) { /* * Must escape or protect so leading character of value is not * misinterpreted as list element delimiting syntax. */ - forbidNone = 1; #if COMPAT preferBrace = 1; -#endif /* COMPAT */ +#endif } while (length) { - if (CHAR_TYPE(*p) != TYPE_NORMAL) { switch (*p) { - case '{': /* TYPE_BRACE */ + case '{': #if COMPAT braceCount++; -#endif /* COMPAT */ +#endif extra++; /* Escape '{' => '\{' */ nestingLevel++; break; - case '}': /* TYPE_BRACE */ + case '}': #if COMPAT braceCount++; -#endif /* COMPAT */ +#endif extra++; /* Escape '}' => '\}' */ nestingLevel--; if (nestingLevel < 0) { - /* - * Unbalanced braces! Cannot format with brace quoting. - */ - + /* Unbalanced braces! Cannot format with brace quoting. */ requireEscape = 1; } break; - case ']': /* TYPE_CLOSE_BRACK */ - case '"': /* TYPE_SPACE */ + case ']': + case '"': #if COMPAT forbidNone = 1; extra++; /* Escapes all just prepend a backslash */ preferEscape = 1; break; #else /* FLOW THROUGH */ -#endif /* COMPAT */ - case '[': /* TYPE_SUBS */ - case '$': /* TYPE_SUBS */ - case ';': /* TYPE_COMMAND_END */ +#endif + case '[': + case '$': + case ';': forbidNone = 1; extra++; /* Escape sequences all one byte longer. */ #if COMPAT preferBrace = 1; -#endif /* COMPAT */ +#endif break; - case '\\': /* TYPE_SUBS */ + case '\\': extra++; /* Escape '\' => '\\' */ - if ((length == 1) || ((length == TCL_INDEX_NONE) && (p[1] == '\0'))) { - /* - * Final backslash. Cannot format with brace quoting. - */ - + if ((length == 1) || ((length == -1) && (p[1] == '\0'))) { + /* Final backslash. Cannot format with brace quoting. */ requireEscape = 1; break; } if (p[1] == '\n') { extra++; /* Escape newline => '\n', one byte longer */ - - /* - * Backslash newline sequence. Brace quoting not permitted. - */ - + /* Backslash newline sequence. Brace quoting not permitted. */ requireEscape = 1; length -= (length > 0); p++; break; } @@ -1141,14 +1037,14 @@ p++; } forbidNone = 1; #if COMPAT preferBrace = 1; -#endif /* COMPAT */ +#endif break; - case '\0': /* TYPE_SUBS */ - if (length == TCL_INDEX_NONE) { + case '\0': + if (length == -1) { goto endOfString; } /* TODO: Panic on improper encoding? */ break; default: @@ -1159,135 +1055,108 @@ preferBrace = 1; #endif } break; } - } - length -= (length+1 > 1); + length -= (length > 0); p++; } - endOfString: + endOfString: if (nestingLevel != 0) { - /* - * Unbalanced braces! Cannot format with brace quoting. - */ - + /* Unbalanced braces! Cannot format with brace quoting. */ requireEscape = 1; } - /* - * We need at least as many bytes as are in the element value... - */ - + /* We need at least as many bytes as are in the element value... */ bytesNeeded = p - src; if (requireEscape) { /* - * We must use escape sequences. Add all the extra bytes needed to - * have room to create them. + * We must use escape sequences. Add all the extra bytes needed + * to have room to create them. */ - bytesNeeded += extra; - - /* - * Make room to escape leading #, if needed. - */ - + /* Make room to escape leading #, if needed. */ if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { bytesNeeded++; } *flagPtr = CONVERT_ESCAPE; - return bytesNeeded; + 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 - * don't request too small a buffer in those edge cases where that's - * not true. + * TclConvertElement() so compute the max size we might need for + * any possible choice. Normally the formatting using escape + * sequences is the longer one, and a minimum "extra" value of 2 + * makes sure we don't request too small a buffer in those edge + * cases where that's not true. */ - if (extra < 2) { extra = 2; } *flagPtr &= ~CONVERT_ANY; *flagPtr |= TCL_DONT_USE_BRACES; } if (forbidNone) { - /* - * We must request some form of quoting of escaping... - */ - + /* We must request some form of quoting of escaping... */ #if COMPAT if (preferEscape && !preferBrace) { /* - * If we are quoting solely due to ] or internal " characters use - * the CONVERT_MASK mode where we escape all special characters - * except for braces. "extra" counted space needed to escape - * braces too, so substract "braceCount" to get our actual needs. + * If we are quoting solely due to ] or internal " characters + * use the CONVERT_MASK mode where we escape all special + * characters except for braces. "extra" counted space needed + * to escape braces too, so substract "braceCount" to get our + * actual needs. */ - bytesNeeded += (extra - braceCount); /* Make room to escape leading #, if needed. */ if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { bytesNeeded++; } - /* * If the caller reports it will direct TclConvertElement() to * use full escapes on the element, add back the bytes needed to * escape the braces. */ - if (*flagPtr & TCL_DONT_USE_BRACES) { bytesNeeded += braceCount; } *flagPtr = CONVERT_MASK; - return bytesNeeded; + goto overflowCheck; } -#endif /* COMPAT */ +#endif 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. */ - bytesNeeded += extra; - - /* - * Make room to escape leading #, if needed. - */ - + /* Make room to escape leading #, if needed. */ if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { bytesNeeded++; } } else { - /* - * Add 2 bytes for room for the enclosing braces. - */ - + /* Add 2 bytes for room for the enclosing braces. */ bytesNeeded += 2; } *flagPtr = CONVERT_BRACE; - return bytesNeeded; + goto overflowCheck; } - /* - * So far, no need to quote or escape anything. - */ - + /* 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. - */ - + /* 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; } /* *---------------------------------------------------------------------- @@ -1308,15 +1177,15 @@ * None. * *---------------------------------------------------------------------- */ -size_t +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. */ + register CONST char *src, /* Source information for list element. */ + register char *dst, /* Place to put list-ified element. */ + register int flags) /* Flags produced by Tcl_ScanElement. */ { return Tcl_ConvertCountedElement(src, -1, dst, flags); } /* @@ -1338,30 +1207,30 @@ * None. * *---------------------------------------------------------------------- */ -size_t +int Tcl_ConvertCountedElement( - const char *src, /* Source information for list element. */ - size_t length, /* Number of bytes in src, or -1. */ + register 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. */ { - size_t numBytes = TclConvertElement(src, length, dst, flags); + int numBytes = TclConvertElement(src, length, dst, flags); dst[numBytes] = '\0'; return numBytes; } /* *---------------------------------------------------------------------- * * TclConvertElement -- * - * This is a companion function to TclScanElement. Given the information - * produced by TclScanElement, this function converts a string to a list - * element equal to that string. + * This is a companion function to TclScanElement. Given the + * information produced by TclScanElement, this function converts + * a string to a list element equal to that string. * * Results: * Information is copied to *dst in the form of a list element identical * to src (i.e. if Tcl_SplitList is applied to dst it will produce a * string identical to src). The return value is a count of the number of @@ -1371,60 +1240,47 @@ * None. * *---------------------------------------------------------------------- */ -size_t -TclConvertElement( - const char *src, /* Source information for list element. */ - size_t length, /* Number of bytes in src, or -1. */ +int TclConvertElement( + register 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. - */ - + /* 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 == TCL_INDEX_NONE)) { - p[0] = '{'; - p[1] = '}'; - return 2; + /* No matter what the caller demands, empty string must be braced! */ + if ((src == NULL) || (length == 0) || ((*src == '\0') && (length == -1))) { + src = tclEmptyStringRep; + length = 0; + conversion = CONVERT_BRACE; } - /* - * Escape leading hash as needed and requested. - */ - + /* 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+1 > 1); + length -= (length > 0); } else { conversion = CONVERT_BRACE; } } - /* - * No escape or quoting needed. Copy the literal string value. - */ - + /* No escape or quoting needed. Copy the literal string value. */ if (conversion == CONVERT_NONE) { - if (length == TCL_INDEX_NONE) { + if (length == -1) { /* TODO: INT_MAX overflow? */ while (*src) { *p++ = *src++; } return p - dst; @@ -1432,18 +1288,15 @@ memcpy(dst, src, length); return length; } } - /* - * Formatted string is original string enclosed in braces. - */ - + /* Formatted string is original string enclosed in braces. */ if (conversion == CONVERT_BRACE) { *p = '{'; p++; - if (length == TCL_INDEX_NONE) { + if (length == -1) { /* TODO: INT_MAX overflow? */ while (*src) { *p++ = *src++; } } else { @@ -1450,20 +1303,17 @@ memcpy(p, src, length); p += length; } *p = '}'; p++; - return (size_t)(p - dst); + return p - dst; } /* conversion == CONVERT_ESCAPE or CONVERT_MASK */ - /* - * Formatted string is original string converted to escape sequences. - */ - - for ( ; length; src++, length -= (length+1 > 1)) { + /* Formatted string is original string converted to escape sequences. */ + for ( ; length; src++, length -= (length > 0)) { switch (*src) { case ']': case '[': case '$': case ';': @@ -1474,16 +1324,17 @@ p++; break; case '{': case '}': #if COMPAT - if (conversion == CONVERT_ESCAPE) -#endif /* COMPAT */ - { + if (conversion == CONVERT_ESCAPE) { +#endif *p = '\\'; p++; +#if COMPAT } +#endif break; case '\f': *p = '\\'; p++; *p = 'f'; @@ -1512,28 +1363,26 @@ p++; *p = 'v'; p++; continue; case '\0': - if (length == TCL_INDEX_NONE) { - return (size_t)(p - dst); + 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(). + * 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 (size_t)(p - dst); + return p - dst; } /* *---------------------------------------------------------------------- * @@ -1555,25 +1404,24 @@ */ char * Tcl_Merge( int argc, /* How many strings to merge. */ - const char *const *argv) /* Array of string values. */ + CONST char * CONST *argv) /* Array of string values. */ { -#define LOCAL_SIZE 64 - char localFlags[LOCAL_SIZE], *flagPtr = NULL; - int i; - size_t bytesNeeded = 0; +# define LOCAL_SIZE 20 + int 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. - */ + const int maxFlags = UINT_MAX / sizeof(int); if (argc == 0) { - result = (char *)Tcl_Alloc(1); + /* + * Handle empty list case first, so logic of the general case + * can be simpler. + */ + result = ckalloc(1); result[0] = '\0'; return result; } /* @@ -1580,24 +1428,44 @@ * Pass 1: estimate space, gather flags. */ if (argc <= LOCAL_SIZE) { flagPtr = localFlags; + } else if (argc > maxFlags) { + /* + * We cannot allocate a large enough flag array to format this + * list in one pass. We could imagine converting this routine + * to a multi-pass implementation, but for sizeof(int) == 4, + * the limit is a max of 2^30 list elements and since each element + * is at least one byte formatted, and requires one byte space + * between it and the next one, that a minimum space requirement + * of 2^31 bytes, which is already INT_MAX. If we tried to format + * a list of > maxFlags elements, we're just going to overflow + * the size limits on the formatted string anyway, so just issue + * that same panic early. + */ + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } else { - flagPtr = (char *)Tcl_Alloc(argc); + flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int)); } 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 *)Tcl_Alloc(bytesNeeded); + result = ckalloc((unsigned) 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 = ' '; @@ -1604,14 +1472,48 @@ dst++; } dst[-1] = 0; if (flagPtr != localFlags) { - Tcl_Free(flagPtr); + ckfree((char *) flagPtr); } return result; } + +/* + *---------------------------------------------------------------------- + * + * 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[TCL_UTF_MAX]; + Tcl_UniChar ch; + + Tcl_UtfBackslash(src, readPtr, buf); + TclUtfToUniChar(buf, &ch); + return (char) ch; +} /* *---------------------------------------------------------------------- * * TclTrimRight -- @@ -1626,49 +1528,44 @@ * None. * *---------------------------------------------------------------------- */ -size_t +int TclTrimRight( const char *bytes, /* String to be trimmed... */ - size_t numBytes, /* ...and its length in bytes */ + 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... */ - size_t numTrim) /* ...and its length in bytes */ + 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. - */ - + /* Outer loop: iterate over string to be trimmed */ do { + Tcl_UniChar ch1; const char *q = trim; - size_t pInc = 0, bytesLeft = numTrim; + int pInc = 0, bytesLeft = numTrim; pp = TclUtfPrev(p, bytes); do { pp += pInc; - pInc = TclUtfToUCS4(pp, &ch1); + pInc = TclUtfToUniChar(pp, &ch1); } while (pp + pInc < p); - /* - * Inner loop: scan trim string for match to current character. - */ - + /* Inner loop: scan trim string for match to current character */ do { - size_t qInc = TclUtfToUCS4(q, &ch2); + Tcl_UniChar ch2; + int qInc = TclUtfToUniChar(q, &ch2); if (ch1 == ch2) { break; } @@ -1675,14 +1572,11 @@ q += qInc; bytesLeft -= qInc; } while (bytesLeft); if (bytesLeft == 0) { - /* - * No match; trim task done; *p is last non-trimmed char. - */ - + /* No match; trim task done; *p is last non-trimmed char */ break; } p = pp; } while (p > bytes); @@ -1691,11 +1585,10 @@ /* *---------------------------------------------------------------------- * * 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: @@ -1705,44 +1598,39 @@ * None. * *---------------------------------------------------------------------- */ -size_t +int TclTrimLeft( const char *bytes, /* String to be trimmed... */ - size_t numBytes, /* ...and its length in bytes */ + 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... */ - size_t numTrim) /* ...and its length in bytes */ + 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. - */ - + /* Outer loop: iterate over string to be trimmed */ do { - size_t pInc = TclUtfToUCS4(p, &ch1); + Tcl_UniChar ch1; + int pInc = TclUtfToUniChar(p, &ch1); const char *q = trim; - size_t bytesLeft = numTrim; + int bytesLeft = numTrim; - /* - * Inner loop: scan trim string for match to current character. - */ - + /* Inner loop: scan trim string for match to current character */ do { - size_t qInc = TclUtfToUCS4(q, &ch2); + Tcl_UniChar ch2; + int qInc = TclUtfToUniChar(q, &ch2); if (ch1 == ch2) { break; } @@ -1749,14 +1637,11 @@ q += qInc; bytesLeft -= qInc; } while (bytesLeft); if (bytesLeft == 0) { - /* - * No match; trim task done; *p is first non-trimmed char. - */ - + /* No match; trim task done; *p is first non-trimmed char */ break; } p += pInc; numBytes -= pInc; @@ -1779,23 +1664,23 @@ * None. * *---------------------------------------------------------------------- */ -size_t +int TclTrim( const char *bytes, /* String to be trimmed... */ - size_t numBytes, /* ...and its length in bytes */ + int numBytes, /* ...and its length in bytes */ /* Calls in this routine * rely on (bytes[numBytes] == '\0'). */ const char *trim, /* String of trim characters... */ - size_t numTrim, /* ...and its length in bytes */ + int numTrim, /* ...and its length in bytes */ /* Calls in this routine * rely on (trim[numTrim] == '\0'). */ - size_t *trimRightPtr) /* Offset from the end of the string. */ + int *trimRightPtr) /* Offset from the end of the string. */ { - size_t trimLeft = 0, trimRight = 0; + int trimLeft = 0, trimRight = 0; /* Empty strings -> nothing to do */ if ((numBytes > 0) && (numTrim > 0)) { /* When bytes is NUL-terminated, returns 0 <= trimLeft <= numBytes */ @@ -1803,13 +1688,12 @@ 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); + bytes = TclUtfNext(first); numBytes -= (bytes - first); if (numBytes > 0) { /* When bytes is NUL-terminated, returns * 0 <= trimRight <= numBytes */ @@ -1839,77 +1723,70 @@ * *---------------------------------------------------------------------- */ /* The whitespace characters trimmed during [concat] operations */ -#define CONCAT_WS_SIZE (sizeof(CONCAT_TRIM_SET "") - 1) +/* TODO: Find a reasonable way to guarantee in sync with TclIsSpaceProc() */ +#define CONCAT_WS " \f\v\r\t\n" +#define CONCAT_WS_SIZE (int) (sizeof(CONCAT_WS "") - 1) char * Tcl_Concat( int argc, /* Number of strings to concatenate. */ - const char *const *argv) /* Array of strings to concatenate. */ + CONST char * CONST *argv) /* Array of strings to concatenate. */ { - int i; - size_t needSpace = 0, bytesNeeded = 0; + int i, needSpace = 0, bytesNeeded = 0; char *result, *p; - /* - * Dispose of the empty result corner case first to simplify later code. - */ - + /* Dispose of the empty result corner case first to simplify later code */ if (argc == 0) { - result = (char *) Tcl_Alloc(1); + result = (char *) ckalloc(1); result[0] = '\0'; return result; } - /* - * First allocate the result buffer at the size required. - */ - + /* 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 *)Tcl_Alloc(bytesNeeded + argc); + /* All element bytes + (argc - 1) spaces + 1 terminating NULL */ + result = (char *) ckalloc((unsigned) (bytesNeeded + argc)); for (p = result, i = 0; i < argc; i++) { - size_t triml, trimr, elemLength; + 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, - CONCAT_WS_SIZE, &trimr); + triml = TclTrim(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE, &trimr); element += triml; elemLength -= triml + trimr; - /* Do not permit trimming to expose a final backslash character. */ elemLength += trimr && (element[elemLength - 1] == '\\'); - /* - * If we're left with empty element after trimming, do nothing. - */ - + /* If we're left with empty element after trimming, do nothing */ if (elemLength == 0) { continue; } - /* - * Append to the result with space if needed. - */ - + /* Append to the result with space if needed */ if (needSpace) { *p++ = ' '; } - memcpy(p, element, elemLength); + memcpy(p, element, (size_t) elemLength); p += elemLength; needSpace = 1; } *p = '\0'; return result; @@ -1934,14 +1811,13 @@ */ Tcl_Obj * Tcl_ConcatObj( int objc, /* Number of objects to concatenate. */ - Tcl_Obj *const objv[]) /* Array of objects to concatenate. */ + Tcl_Obj *CONST objv[]) /* Array of objects to concatenate. */ { - int i, needSpace = 0; - size_t bytesNeeded = 0, elemLength; + 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, @@ -1948,101 +1824,137 @@ * 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++) { - size_t length; + int length; objPtr = objv[i]; if (TclListObjIsCanonical(objPtr)) { continue; } - (void)TclGetStringFromObj(objPtr, &length); + Tcl_GetStringFromObj(objPtr, &length); if (length > 0) { break; } } if (i == objc) { + Tcl_Obj **listv; + int listc; + resPtr = NULL; for (i = 0; i < objc; i++) { + /* + * Tcl_ListObjAppendList could be used here, but this saves us a + * bit of type checking (since we've already done it). Use of + * INT_MAX tells us to always put the new stuff on the end. It + * will be set right in Tcl_ListObjReplace. + * Note that all objs at this point are either lists or have an + * empty string rep. + */ + objPtr = objv[i]; - if (!TclListObjIsCanonical(objPtr)) { + if (objPtr->bytes && objPtr->length == 0) { continue; } - if (resPtr) { - if (TCL_OK != Tcl_ListObjAppendList(NULL, resPtr, objPtr)) { - /* Abandon ship! */ - Tcl_DecrRefCount(resPtr); - goto slow; - } - } else { - resPtr = TclListObjCopy(NULL, objPtr); + TclListObjGetElements(NULL, objPtr, &listc, &listv); + if (listc) { + if (resPtr) { + if (Tcl_GetString(listv[0])[0] == '#' + || TCL_OK != Tcl_ListObjReplace(NULL, resPtr, + INT_MAX, 0, listc, listv)) { + /* Abandon ship! */ + Tcl_DecrRefCount(resPtr); + goto slow; + } + } else { + resPtr = TclListObjCopy(NULL, objPtr); + } } } if (!resPtr) { - TclNewObj(resPtr); + resPtr = Tcl_NewObj(); } return resPtr; } - slow: /* * Something cannot be determined to be safe, so build the concatenation * the slow way, using the string representations. - * - * First try to pre-allocate the size required. */ + slow: + /* 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. + * 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_AttemptSetObjLength(resPtr, bytesNeeded + objc - 1); Tcl_SetObjLength(resPtr, 0); for (i = 0; i < objc; i++) { - size_t triml, trimr; + 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); + triml = TclTrim(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE, &trimr); element += triml; elemLength -= triml + trimr; - /* Do not permit trimming to expose a final backslash character. */ elemLength += trimr && (element[elemLength - 1] == '\\'); - /* - * If we're left with empty element after trimming, do nothing. - */ - + /* If we're left with empty element after trimming, do nothing */ if (elemLength == 0) { continue; } - /* - * Append to the result with space if needed. - */ - + /* Append to the result with space if needed */ if (needSpace) { Tcl_AppendToObj(resPtr, " ", 1); } Tcl_AppendToObj(resPtr, element, elemLength); needSpace = 1; } return resPtr; } + +/* + *---------------------------------------------------------------------- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_StringMatch( + CONST char *str, /* String. */ + CONST char *pattern) /* Pattern, which may contain special + * characters. */ +{ + return Tcl_StringCaseMatch(str, pattern, 0); +} /* *---------------------------------------------------------------------- * * Tcl_StringCaseMatch -- @@ -2061,17 +1973,17 @@ *---------------------------------------------------------------------- */ int Tcl_StringCaseMatch( - const char *str, /* String. */ - const char *pattern, /* Pattern, which may contain special + 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; + Tcl_UniChar ch1, ch2; while (1) { p = *pattern; /* @@ -2108,14 +2020,14 @@ /* * This is a special case optimization for single-byte utf. */ if (UCHAR(*pattern) < 0x80) { - ch2 = (int) + ch2 = (Tcl_UniChar) (nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern)); } else { - TclUtfToUCS4(pattern, &ch2); + Tcl_UtfToUniChar(pattern, &ch2); if (nocase) { ch2 = Tcl_UniCharToLower(ch2); } } @@ -2127,11 +2039,11 @@ */ if ((p != '[') && (p != '?') && (p != '\\')) { if (nocase) { while (*str) { - charLen = TclUtfToUCS4(str, &ch1); + charLen = TclUtfToUniChar(str, &ch1); if (ch2==ch1 || ch2==Tcl_UniCharToLower(ch1)) { break; } str += charLen; } @@ -2141,11 +2053,11 @@ * shorter, as the number of bytes you want to compare * each time is non-constant. */ while (*str) { - charLen = TclUtfToUCS4(str, &ch1); + charLen = TclUtfToUniChar(str, &ch1); if (ch2 == ch1) { break; } str += charLen; } @@ -2155,11 +2067,11 @@ return 1; } if (*str == '\0') { return 0; } - str += TclUtfToUCS4(str, &ch1); + str += TclUtfToUniChar(str, &ch1); } } /* * Check for a "?" as the next pattern character. It matches any @@ -2166,11 +2078,11 @@ * single character. */ if (p == '?') { pattern++; - str += TclUtfToUCS4(str, &ch1); + str += TclUtfToUniChar(str, &ch1); continue; } /* * Check for a "[" as the next pattern character. It is followed by a @@ -2177,33 +2089,33 @@ * list of characters that are acceptable, or by a range (two * characters separated by "-"). */ if (p == '[') { - int startChar = 0, endChar = 0; + Tcl_UniChar startChar, endChar; pattern++; if (UCHAR(*str) < 0x80) { - ch1 = (int) + ch1 = (Tcl_UniChar) (nocase ? tolower(UCHAR(*str)) : UCHAR(*str)); str++; } else { - str += TclUtfToUCS4(str, &ch1); + str += Tcl_UtfToUniChar(str, &ch1); if (nocase) { ch1 = Tcl_UniCharToLower(ch1); } } while (1) { if ((*pattern == ']') || (*pattern == '\0')) { return 0; } if (UCHAR(*pattern) < 0x80) { - startChar = (int) (nocase + startChar = (Tcl_UniChar) (nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern)); pattern++; } else { - pattern += TclUtfToUCS4(pattern, &startChar); + pattern += Tcl_UtfToUniChar(pattern, &startChar); if (nocase) { startChar = Tcl_UniCharToLower(startChar); } } if (*pattern == '-') { @@ -2210,15 +2122,15 @@ pattern++; if (*pattern == '\0') { return 0; } if (UCHAR(*pattern) < 0x80) { - endChar = (int) (nocase + endChar = (Tcl_UniChar) (nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern)); pattern++; } else { - pattern += TclUtfToUCS4(pattern, &endChar); + pattern += Tcl_UtfToUniChar(pattern, &endChar); if (nocase) { endChar = Tcl_UniCharToLower(endChar); } } if (((startChar <= ch1) && (ch1 <= endChar)) @@ -2262,12 +2174,12 @@ /* * There's no special character. Just make sure that the next bytes of * each string match. */ - str += TclUtfToUCS4(str, &ch1); - pattern += TclUtfToUCS4(pattern, &ch2); + str += TclUtfToUniChar(str, &ch1); + pattern += TclUtfToUniChar(pattern, &ch2); if (nocase) { if (Tcl_UniCharToLower(ch1) != Tcl_UniCharToLower(ch2)) { return 0; } } else if (ch1 != ch2) { @@ -2296,17 +2208,16 @@ *---------------------------------------------------------------------- */ int TclByteArrayMatch( - const unsigned char *string,/* String. */ - size_t strLen, /* Length of String */ - const unsigned char *pattern, - /* Pattern, which may contain special - * characters. */ - size_t ptnLen, /* Length of Pattern */ - TCL_UNUSED(int) /*flags*/) + 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 */ + int flags) { const unsigned char *stringEnd, *patternEnd; unsigned char p; stringEnd = string + strLen; @@ -2409,11 +2320,10 @@ if (((startChar <= ch1) && (ch1 <= endChar)) || ((endChar <= ch1) && (ch1 <= startChar))) { /* * Matches ranges of form [a-z] or [z-a]. */ - break; } } else if (startChar == ch1) { break; } @@ -2456,13 +2366,13 @@ /* *---------------------------------------------------------------------- * * TclStringMatchObj -- * - * See if a particular string matches a particular pattern. Allows case - * insensitivity. This is the generic multi-type handler for the various - * matching algorithms. + * See if a particular string matches a particular pattern. + * Allows case insensitivity. This is the generic multi-type handler + * for the various matching algorithms. * * 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). @@ -2473,37 +2383,35 @@ *---------------------------------------------------------------------- */ int TclStringMatchObj( - Tcl_Obj *strObj, /* string object. */ - Tcl_Obj *ptnObj, /* pattern object. */ - int flags) /* Only TCL_MATCH_NOCASE should be passed, or - * 0. */ + Tcl_Obj *strObj, /* string object. */ + Tcl_Obj *ptnObj, /* pattern object. */ + int flags) /* Only TCL_MATCH_NOCASE should be passed or 0. */ { - int match; - size_t length = 0, plen = 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)) { + if (strObj->typePtr == &tclStringType) { Tcl_UniChar *udata, *uptn; - udata = TclGetUnicodeFromObj(strObj, &length); - uptn = TclGetUnicodeFromObj(ptnObj, &plen); + 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 = TclGetByteArrayFromObj(strObj, &length); - ptn = TclGetByteArrayFromObj(ptnObj, &plen); + 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); } @@ -2557,19 +2465,21 @@ */ char * Tcl_DStringAppend( Tcl_DString *dsPtr, /* Structure describing dynamic string. */ - const char *bytes, /* String to append. If length is - * TCL_INDEX_NONE then this must be null-terminated. */ - size_t length) /* Number of bytes from "bytes" to append. If - * TCL_INDEX_NONE, then append all of bytes, up to null + 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. */ { - size_t newSize; + int newSize; + char *dst; + CONST char *end; - if (length == TCL_INDEX_NONE) { + if (length < 0) { length = strlen(bytes); } newSize = length + dsPtr->length; /* @@ -2579,71 +2489,44 @@ */ if (newSize >= dsPtr->spaceAvl) { dsPtr->spaceAvl = newSize * 2; if (dsPtr->string == dsPtr->staticSpace) { - char *newString = (char *)Tcl_Alloc(dsPtr->spaceAvl); + char *newString = ckalloc((unsigned) dsPtr->spaceAvl); - memcpy(newString, dsPtr->string, dsPtr->length); + memcpy(newString, dsPtr->string, (size_t) dsPtr->length); dsPtr->string = newString; } else { - size_t index = TCL_INDEX_NONE; + int offset = -1; /* See [16896d49fd] */ if (bytes >= dsPtr->string && bytes <= dsPtr->string + dsPtr->length) { - index = bytes - dsPtr->string; + offset = bytes - dsPtr->string; } - dsPtr->string = (char *)Tcl_Realloc(dsPtr->string, dsPtr->spaceAvl); + dsPtr->string = ckrealloc((void *) dsPtr->string, + (size_t) dsPtr->spaceAvl); - if (index != TCL_INDEX_NONE) { - bytes = dsPtr->string + index; + if (offset >= 0) { + bytes = dsPtr->string + offset; } } } /* * Copy the new string into the buffer at the end of the old one. */ - memcpy(dsPtr->string + dsPtr->length, bytes, length); + for (dst = dsPtr->string + dsPtr->length, end = bytes+length; + bytes < end; bytes++, dst++) { + *dst = *bytes; + } + *dst = '\0'; dsPtr->length += length; - dsPtr->string[dsPtr->length] = '\0'; return dsPtr->string; } - -/* - *---------------------------------------------------------------------- - * - * TclDStringAppendObj, TclDStringAppendDString -- - * - * Simple wrappers round Tcl_DStringAppend that make it easier to append - * from particular sources of strings. - * - *---------------------------------------------------------------------- - */ - -char * -TclDStringAppendObj( - Tcl_DString *dsPtr, - Tcl_Obj *objPtr) -{ - size_t length; - const char *bytes = TclGetStringFromObj(objPtr, &length); - - return Tcl_DStringAppend(dsPtr, bytes, length); -} - -char * -TclDStringAppendDString( - Tcl_DString *dsPtr, - Tcl_DString *toAppendPtr) -{ - return Tcl_DStringAppend(dsPtr, Tcl_DStringValue(toAppendPtr), - Tcl_DStringLength(toAppendPtr)); -} /* *---------------------------------------------------------------------- * * Tcl_DStringAppendElement -- @@ -2662,18 +2545,16 @@ */ char * Tcl_DStringAppendElement( Tcl_DString *dsPtr, /* Structure describing dynamic string. */ - const char *element) /* String to append. Must be + 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; - size_t newSize; + int flags = 0, 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 @@ -2711,13 +2592,13 @@ */ if (newSize >= dsPtr->spaceAvl) { dsPtr->spaceAvl = newSize * 2; if (dsPtr->string == dsPtr->staticSpace) { - char *newString = (char *)Tcl_Alloc(dsPtr->spaceAvl); + char *newString = ckalloc((unsigned) dsPtr->spaceAvl); - memcpy(newString, dsPtr->string, dsPtr->length); + memcpy(newString, dsPtr->string, (size_t) dsPtr->length); dsPtr->string = newString; } else { int offset = -1; /* See [16896d49fd] */ @@ -2724,11 +2605,12 @@ if (element >= dsPtr->string && element <= dsPtr->string + dsPtr->length) { offset = element - dsPtr->string; } - dsPtr->string = (char *)Tcl_Realloc(dsPtr->string, dsPtr->spaceAvl); + dsPtr->string = (char *) ckrealloc((void *) dsPtr->string, + (size_t) dsPtr->spaceAvl); if (offset >= 0) { element = dsPtr->string + offset; } } @@ -2762,22 +2644,26 @@ * Results: * None. * * Side effects: * The length of dsPtr is changed to length and a null byte is stored at - * that position in the string. + * 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. */ - size_t length) /* New length for dynamic string. */ + int length) /* New length for dynamic string. */ { - size_t newsize; + 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 @@ -2794,16 +2680,17 @@ dsPtr->spaceAvl = newsize; } else { dsPtr->spaceAvl = length + 1; } if (dsPtr->string == dsPtr->staticSpace) { - char *newString = (char *)Tcl_Alloc(dsPtr->spaceAvl); + char *newString = ckalloc((unsigned) dsPtr->spaceAvl); - memcpy(newString, dsPtr->string, dsPtr->length); + memcpy(newString, dsPtr->string, (size_t) dsPtr->length); dsPtr->string = newString; } else { - dsPtr->string = (char *)Tcl_Realloc(dsPtr->string, dsPtr->spaceAvl); + dsPtr->string = (char *) ckrealloc((void *) dsPtr->string, + (size_t) dsPtr->spaceAvl); } } dsPtr->length = length; dsPtr->string[length] = 0; } @@ -2829,11 +2716,11 @@ void Tcl_DStringFree( Tcl_DString *dsPtr) /* Structure describing dynamic string. */ { if (dsPtr->string != dsPtr->staticSpace) { - Tcl_Free(dsPtr->string); + ckfree(dsPtr->string); } dsPtr->string = dsPtr->staticSpace; dsPtr->length = 0; dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; dsPtr->staticSpace[0] = '\0'; @@ -2862,11 +2749,26 @@ Tcl_DStringResult( Tcl_Interp *interp, /* Interpreter whose result is to be reset. */ Tcl_DString *dsPtr) /* Dynamic string that is to become the * result of interp. */ { - Tcl_SetObjResult(interp, TclDStringToObj(dsPtr)); + Tcl_ResetResult(interp); + + if (dsPtr->string != dsPtr->staticSpace) { + interp->result = dsPtr->string; + interp->freeProc = TCL_DYNAMIC; + } else if (dsPtr->length < TCL_RESULT_SIZE) { + interp->result = ((Interp *) interp)->resultSpace; + strcpy(interp->result, dsPtr->string); + } else { + Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE); + } + + dsPtr->string = dsPtr->staticSpace; + dsPtr->length = 0; + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; + dsPtr->staticSpace[0] = '\0'; } /* *---------------------------------------------------------------------- * @@ -2891,76 +2793,48 @@ 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); - char *bytes = TclGetString(obj); - - Tcl_DStringFree(dsPtr); - Tcl_DStringAppend(dsPtr, bytes, obj->length); - Tcl_ResetResult(interp); -} - -/* - *---------------------------------------------------------------------- - * - * TclDStringToObj -- - * - * This function moves a dynamic string's contents to a new Tcl_Obj. Be - * aware that this function does *not* check that the encoding of the - * contents of the dynamic string is correct; this is the caller's - * responsibility to enforce. - * - * Results: - * The newly-allocated untyped (i.e., typePtr==NULL) Tcl_Obj with a - * reference count of zero. - * - * Side effects: - * The string is "moved" to the object. dsPtr is reinitialized to an - * empty string; it does not need to be Tcl_DStringFree'd after this if - * not used further. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclDStringToObj( - Tcl_DString *dsPtr) -{ - Tcl_Obj *result; - - if (dsPtr->string == dsPtr->staticSpace) { - if (dsPtr->length == 0) { - TclNewObj(result); - } else { - /* - * Static buffer, so must copy. - */ - - TclNewStringObj(result, dsPtr->string, dsPtr->length); - } - } else { - /* - * Dynamic buffer, so transfer ownership and reset. - */ - - TclNewObj(result); - result->bytes = dsPtr->string; - result->length = dsPtr->length; - } - - /* - * Re-establish the DString as empty with no buffer allocated. - */ - - dsPtr->string = dsPtr->staticSpace; - dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; - dsPtr->length = 0; - dsPtr->staticSpace[0] = '\0'; - - return result; + Interp *iPtr = (Interp *) interp; + + if (dsPtr->string != dsPtr->staticSpace) { + ckfree(dsPtr->string); + } + + /* + * 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((unsigned) (dsPtr->length+1)); + memcpy(dsPtr->string, iPtr->result, (unsigned) 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((unsigned) (dsPtr->length + 1)); + dsPtr->spaceAvl = dsPtr->length + 1; + } + memcpy(dsPtr->string, iPtr->result, (unsigned) dsPtr->length+1); + } + + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; } /* *---------------------------------------------------------------------- * @@ -2982,13 +2856,13 @@ void Tcl_DStringStartSublist( Tcl_DString *dsPtr) /* Dynamic string. */ { if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) { - TclDStringAppendLiteral(dsPtr, " {"); + Tcl_DStringAppend(dsPtr, " {", -1); } else { - TclDStringAppendLiteral(dsPtr, "{"); + Tcl_DStringAppend(dsPtr, "{", -1); } } /* *---------------------------------------------------------------------- @@ -3010,11 +2884,11 @@ void Tcl_DStringEndSublist( Tcl_DString *dsPtr) /* Dynamic string. */ { - TclDStringAppendLiteral(dsPtr, "}"); + Tcl_DStringAppend(dsPtr, "}", -1); } /* *---------------------------------------------------------------------- * @@ -3022,68 +2896,118 @@ * * 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 guaranteed - * to contain a decimal point or exponent, so that it looks like a - * floating-point value and not an integer. + * 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 *), + Tcl_Interp *interp, /* Interpreter whose tcl_precision variable + * used to be used to control printing. It's + * ignored now. */ 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; - - /* - * Handle NaN. - */ - - if (TclIsNaN(value)) { - TclFormatNaN(value, dst); - return; - } - - /* - * Handle infinities. - */ - - if (TclIsInfinite(value)) { + char* digits; + char* end; + + int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int)sizeof(int)); + + /* + * Handle NaN. + */ + + if (TclIsNaN(value)) { + TclFormatNaN(value, dst); + return; + } + + /* + * Handle infinities. + */ + + if (TclIsInfinite(value)) { /* * Remember to copy the terminating NUL too. */ - if (value < 0) { + if (value < 0) { memcpy(dst, "-Inf", 5); - } else { + } else { memcpy(dst, "Inf", 4); - } - return; - } - - /* - * Ordinary (normal and denormal) values. - */ - - digits = TclDoubleDigits(value, -1, TCL_DD_SHORTEST, - &exponent, &signum, &end); - if (signum) { - *dst++ = '-'; - } + } + 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_SHORTEN_FLAG 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_SHORTEN_FLAG */, + &exponent, &signum, &end); + } + if (signum) { + *dst++ = '-'; + } p = digits; if (exponent < -4 || exponent > 16) { /* * E format for numbers < 1e-3 or >= 1e17. */ @@ -3095,12 +3019,19 @@ while (c != '\0') { *dst++ = c; c = *++p; } } - - sprintf(dst, "e%+d", exponent); + /* + * 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. */ @@ -3128,11 +3059,89 @@ c = *++p; } } *dst++ = '\0'; } - Tcl_Free(digits); + 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. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +char * +TclPrecTraceProc( + ClientData clientData, /* Not used. */ + 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; + int prec; + int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int) 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_NewIntObj(*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 "can't modify precision from a safe interpreter"; + } + value = Tcl_GetVar2Ex(interp, name1, name2, flags & TCL_GLOBAL_ONLY); + if (value == NULL + || Tcl_GetIntFromObj((Tcl_Interp*) NULL, value, &prec) != TCL_OK + || prec < 0 || prec > TCL_MAX_PREC) { + return "improper value for precision"; + } + *precisionPtr = prec; + return NULL; } /* *---------------------------------------------------------------------- * @@ -3150,12 +3159,12 @@ *---------------------------------------------------------------------- */ int TclNeedSpace( - const char *start, /* First character in string. */ - const char *end) /* End of string (place where space will be + 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 @@ -3232,571 +3241,395 @@ * TclFormatInt -- * * This procedure formats an integer into a sequence of decimal digit * characters in a buffer. If the integer is negative, a minus sign is * inserted at the start of the buffer. A null character is inserted at - * the end of the formatted characters. It is the caller's responsibility - * to ensure that enough storage is available. This procedure has the - * effect of sprintf(buffer, "%ld", n) but is faster as proven in - * benchmarks. This is key to UpdateStringOfInt, which is a common path - * for a lot of code (e.g. int-indexed arrays). + * the end of the formatted characters. It is the caller's + * responsibility to ensure that enough storage is available. This + * procedure has the effect of sprintf(buffer, "%ld", n) but is faster + * as proven in benchmarks. This is key to UpdateStringOfInt, which + * is a common path for a lot of code (e.g. int-indexed arrays). * * Results: * An integer representing the number of characters formatted, not * including the terminating \0. * * Side effects: - * The formatted characters are written into the storage pointer to by - * the "buffer" argument. + * The formatted characters are written into the storage pointer to + * by the "buffer" argument. * *---------------------------------------------------------------------- */ -size_t -TclFormatInt( - char *buffer, /* Points to the storage into which the +int +TclFormatInt(buffer, n) + char *buffer; /* Points to the storage into which the * formatted characters are written. */ - Tcl_WideInt n) /* The integer to format. */ + long n; /* The integer to format. */ { - Tcl_WideUInt intVal; - size_t i = 0, numFormatted, j; + unsigned long intVal; + int i; + int numFormatted, j; static const char digits[] = "0123456789"; + + /* + * Check first whether "n" is zero. + */ + + if (n == 0) { + buffer[0] = '0'; + buffer[1] = 0; + return 1; + } /* * Generate the characters of the result backwards in the buffer. */ - intVal = (n < 0 ? -(Tcl_WideUInt)n : (Tcl_WideUInt)n); + intVal = (n < 0 ? -(unsigned long)n : (unsigned long)n); + i = 0; + buffer[0] = '\0'; do { - buffer[i++] = digits[intVal % 10]; + i++; + buffer[i] = digits[intVal % 10]; intVal = intVal / 10; } while (intVal > 0); if (n < 0) { - buffer[i++] = '-'; + i++; + buffer[i] = '-'; } - buffer[i] = '\0'; - numFormatted = i--; + numFormatted = i; /* * Now reverse the characters. */ for (j = 0; j < i; j++, i--) { char tmp = buffer[i]; - buffer[i] = buffer[j]; buffer[j] = tmp; } return numFormatted; } /* *---------------------------------------------------------------------- * - * GetWideForIndex -- - * - * This function produces a wide integer value corresponding to the - * index value held in *objPtr. The parsing supports all values - * recognized as any size of integer, and the syntaxes end[-+]$integer - * and $integer[-+]$integer. The argument endValue is used to give - * the meaning of the literal index value "end". Index arithmetic - * on arguments outside the wide integer range are only accepted - * when interp is a working interpreter, not NULL. + * TclGetIntForIndex -- + * + * 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: - * When parsing of *objPtr successfully recognizes an index value, - * TCL_OK is returned, and the wide integer value corresponding to - * the recognized index value is written to *widePtr. When parsing - * fails, TCL_ERROR is returned and error information is written to - * interp, if non-NULL. + * 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 type of *objPtr may change. - * - *---------------------------------------------------------------------- - */ - -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 -- - * - * Provides an integer corresponding to the list index held in a Tcl - * object. The string value 'objPtr' is expected have the format - * integer([+-]integer)? or end([+-]integer)?. - * - * Value - * TCL_OK - * - * The index is stored at the address given by by 'indexPtr'. If - * 'objPtr' has the value "end", the value stored is 'endValue'. - * - * TCL_ERROR - * - * The value of 'objPtr' does not have one of the expected formats. If - * 'interp' is non-NULL, an error message is left in the interpreter's - * result object. - * - * Effect - * - * The object referenced by 'objPtr' is converted, as needed, to an - * integer, wide integer, or end-based-index object. + * The object referenced by "objPtr" might be converted to an integer, + * wide integer, or end-based-index object. * *---------------------------------------------------------------------- */ int -Tcl_GetIntForIndex( +TclGetIntForIndex( 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. */ - size_t endValue, /* The value to be stored at "indexPtr" if - * "objPtr" holds "end". */ - size_t *indexPtr) /* Location filled in with an integer - * representing an index. */ -{ - Tcl_WideInt wide; - - /* Use platform-related size_t to wide-int to consider negative value - * TCL_INDEX_NONE if wide-int and size_t have different dimensions. */ - if (GetWideForIndex(interp, objPtr, endValue, &wide) == TCL_ERROR) { - return TCL_ERROR; - } - if (indexPtr != NULL) { - if ((wide < 0) && (endValue != TCL_INDEX_END)) { - *indexPtr = TCL_INDEX_NONE; - } else if ((Tcl_WideUInt)wide > TCL_INDEX_END) { - *indexPtr = TCL_INDEX_END; - } else { - *indexPtr = (size_t) 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; - size_t length; - const char *bytes = TclGetStringFromObj(objPtr, &length); - - if (*bytes != 'e') { - int numType; - const char *opPtr; - int len, t1 = 0, t2 = 0; - - /* Value doesn't start with "e" */ - - /* If we reach here, the string rep of objPtr exists. */ - - /* - * The valid index syntax does not include any value that is - * a list of more than one element. This is necessary so that - * lists of index values can be reliably distinguished from any - * single index value. - */ - - /* - * Quick scan to see if multi-value list is even possible. - * This relies on TclGetString() returning a NUL-terminated string. - */ - if ((TclMaxListLength(bytes, -1, NULL) > 1) - - /* If it's possible, do the full list parse. */ - && (TCL_OK == Tcl_ListObjLength(NULL, objPtr, &len)) - && (len > 1)) { - goto parseError; - } - - /* Passed the list screen, so parse for index arithmetic expression */ - if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, NULL, -1, &opPtr, - TCL_PARSE_INTEGER_ONLY)) { - Tcl_WideInt w1=0, w2=0; - - /* value starts with valid integer... */ - - if ((*opPtr == '-') || (*opPtr == '+')) { - /* ... value continues with [-+] ... */ - - /* Save first integer as wide if possible */ - TclGetNumberFromObj(NULL, objPtr, &cd, &t1); - if (t1 == TCL_NUMBER_INT) { - w1 = (*(Tcl_WideInt *)cd); - } - - if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, opPtr + 1, - -1, NULL, TCL_PARSE_INTEGER_ONLY)) { - /* ... value concludes with second valid integer */ - - /* Save second integer as wide if possible */ - TclGetNumberFromObj(NULL, objPtr, &cd, &t2); - if (t2 == TCL_NUMBER_INT) { - w2 = (*(Tcl_WideInt *)cd); - } - } - } - /* Clear invalid intreps left by TclParseNumber */ - TclFreeIntRep(objPtr); - - if (t1 && t2) { - /* We have both integer values */ - if ((t1 == TCL_NUMBER_INT) && (t2 == TCL_NUMBER_INT)) { - /* Both are wide, do wide-integer math */ - if (*opPtr == '-') { - if (w2 == WIDE_MIN) { - goto extreme; - } - w2 = -w2; - } - - if ((w1 ^ w2) < 0) { - /* Different signs, sum cannot overflow */ - offset = w1 + w2; - } else if (w1 >= 0) { - if (w1 < WIDE_MAX - w2) { - offset = w1 + w2; - } else { - offset = WIDE_MAX; - } - } else { - if (w1 > WIDE_MIN - w2) { - offset = w1 + w2; - } else { - offset = WIDE_MIN; - } - } - } else { - /* - * At least one is big, do bignum math. Little reason to - * value performance here. Re-use code. Parse has verified - * objPtr is an expression. Compute it. - */ - - Tcl_Obj *sum; - - extreme: - if (interp) { - Tcl_ExprObj(interp, objPtr, &sum); - } else { - Tcl_Interp *compute = Tcl_CreateInterp(); - Tcl_ExprObj(compute, objPtr, &sum); - Tcl_DeleteInterp(compute); - } - TclGetNumberFromObj(NULL, sum, &cd, &numType); - - if (numType == TCL_NUMBER_INT) { - /* sum holds an integer in the signed wide range */ - offset = *(Tcl_WideInt *)cd; - } else { - /* sum holds an integer outside the signed wide range */ - /* Truncate to the signed wide range. */ - if (mp_isneg((mp_int *)cd)) { - offset = WIDE_MIN; - } else { - offset = WIDE_MAX; - } - } - Tcl_DecrRefCount(sum); - } - if (offset < 0) { - offset = (offset == -1) ? WIDE_MIN : WIDE_MIN+1; - } - goto parseOK; - } - } - goto parseError; - } - - if ((length < 3) || (length == 4) || (strncmp(bytes, "end", 3) != 0)) { - /* Doesn't start with "end" */ - goto parseError; - } - if (length > 4) { - int t; - - /* Parse for the "end-..." or "end+..." formats */ - - if ((bytes[3] != '-') && (bytes[3] != '+')) { - /* No operator where we need one */ - goto parseError; - } - if (TclIsSpaceProc(bytes[4])) { - /* Space after + or - not permitted. */ - goto parseError; - } - - /* Parse the integer offset */ - if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, - bytes+4, length-4, NULL, TCL_PARSE_INTEGER_ONLY)) { - /* Not a recognized integer format */ - goto parseError; - } - - /* Got an integer offset; pull it from where parser left it. */ - TclGetNumberFromObj(NULL, objPtr, &cd, &t); - - if (t == TCL_NUMBER_BIG) { - /* Truncate to the signed wide range. */ - if (mp_isneg((mp_int *)cd)) { - offset = (bytes[3] == '-') ? WIDE_MAX : WIDE_MIN; - } else { - offset = (bytes[3] == '-') ? WIDE_MIN : WIDE_MAX; - } - } else { - /* assert (t == TCL_NUMBER_INT); */ - offset = (*(Tcl_WideInt *)cd); - if (bytes[3] == '-') { - offset = (offset == WIDE_MIN) ? WIDE_MAX : -offset; - } - if (offset == 1) { - offset = WIDE_MAX; /* "end+1" */ - } else if (offset > 1) { - offset = WIDE_MAX - 1; /* "end+n", out of range */ - } else if (offset != WIDE_MIN) { - offset--; - } - } - } - - parseOK: - /* Success. Store the new internal rep. */ - ir.wideValue = offset; - Tcl_StoreIntRep(objPtr, &endOffsetType, &ir); - } - - offset = irPtr->wideValue; - - if (offset == WIDE_MAX) { - *widePtr = endValue + 1; - } else if (offset == WIDE_MIN) { - *widePtr = -1; - } else if (endValue == (size_t)-1) { - *widePtr = offset; - } else if (offset < 0) { - /* Different signs, sum cannot overflow */ - *widePtr = endValue + offset + 1; - } else if (offset < WIDE_MAX) { - *widePtr = offset; - } else { - *widePtr = WIDE_MAX; - } - return TCL_OK; - - /* Report a parse error. */ - parseError: - if (interp != NULL) { - char * bytes = TclGetString(objPtr); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad index \"%s\": must be integer?[+-]integer? or" - " end?[+-]integer?", bytes)); - if (!strncmp(bytes, "end-", 4)) { - bytes += 4; - } - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); + int endValue, /* The value to be stored at "indexPtr" if + * "objPtr" holds "end". */ + int *indexPtr) /* Location filled in with an integer + * representing an index. */ +{ + int length; + char *opPtr, *bytes; + + if (TclGetIntFromObj(NULL, objPtr, indexPtr) == TCL_OK) { + return TCL_OK; + } + + if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) { + /* + * If the object is already an offset from the end of the list, or can + * be converted to one, use it. + */ + + *indexPtr = endValue + objPtr->internalRep.longValue; + return TCL_OK; + } + + bytes = TclGetStringFromObj(objPtr, &length); + + /* + * Leading whitespace is acceptable in an index. + */ + + while (length && TclIsSpaceProcM(*bytes)) { + bytes++; + length--; + } + + if (TclParseNumber(NULL, NULL, NULL, bytes, length, (const char **)&opPtr, + TCL_PARSE_INTEGER_ONLY | TCL_PARSE_NO_WHITESPACE) == TCL_OK) { + int code, first, second; + char savedOp = *opPtr; + + if ((savedOp != '+') && (savedOp != '-')) { + goto parseError; + } + if (TclIsSpaceProcM(opPtr[1])) { + goto parseError; + } + *opPtr = '\0'; + code = Tcl_GetInt(interp, bytes, &first); + *opPtr = savedOp; + if (code == TCL_ERROR) { + goto parseError; + } + if (TCL_ERROR == Tcl_GetInt(interp, opPtr+1, &second)) { + goto parseError; + } + if (savedOp == '+') { + *indexPtr = first + second; + } else { + *indexPtr = first - second; + } + return TCL_OK; + } + + /* + * Report a parse error. + */ + + parseError: + if (interp != NULL) { + char *bytes = Tcl_GetString(objPtr); + + /* + * The result might not be empty; this resets it which should be both + * a cheap operation, and of little problem because this is an + * error-generation path anyway. + */ + + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad index \"", bytes, + "\": must be integer?[+-]integer? or end?[+-]integer?", NULL); + if (!strncmp(bytes, "end-", 4)) { + bytes += 4; + } + TclCheckBadOctal(interp, bytes); } return TCL_ERROR; } /* *---------------------------------------------------------------------- * - * TclIndexEncode -- - * - * Parse objPtr to determine if it is an index value. Two cases - * are possible. The value objPtr might be parsed as an absolute - * index value in the C signed int range. Note that this includes - * index values that are integers as presented and it includes index - * arithmetic expressions. The absolute index values that can be - * directly meaningful as an index into either a list or a string are - * those integer values >= TCL_INDEX_START (0) - * and < INT_MAX. - * The largest string supported in Tcl 8 has bytelength INT_MAX. - * This means the largest supported character length is also INT_MAX, - * and the index of the last character in a string of length INT_MAX - * is INT_MAX-1. - * - * Any absolute index value parsed outside that range is encoded - * using the before and after values passed in by the - * caller as the encoding to use for indices that are either - * less than or greater than the usable index range. TCL_INDEX_NONE - * is available as a good choice for most callers to use for - * after. Likewise, the value TCL_INDEX_NONE is good for - * most callers to use for before. Other values are possible - * when the caller knows it is helpful in producing its own behavior - * for indices before and after the indexed item. - * - * 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 */ - size_t before, /* Value to return for index before beginning */ - size_t 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 : -1)) { - /* 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; + * UpdateStringOfEndOffset -- + * + * Update the string rep of a Tcl object holding an "end-offset" + * expression. + * + * Results: + * None. + * + * Side effects: + * Stores a valid string in the object's string rep. + * + * This function does NOT free any earlier string rep. If it is called on an + * object that already has a valid string rep, it will leak memory. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfEndOffset( + register Tcl_Obj* objPtr) +{ + char buffer[TCL_INTEGER_SPACE + sizeof("end") + 1]; + register int len; + + strcpy(buffer, "end"); + len = sizeof("end") - 1; + if (objPtr->internalRep.longValue != 0) { + buffer[len++] = '-'; + len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue)); + } + objPtr->bytes = ckalloc((unsigned) len+1); + memcpy(objPtr->bytes, buffer, (unsigned) len+1); + objPtr->length = len; +} + +/* + *---------------------------------------------------------------------- + * + * SetEndOffsetFromAny -- + * + * Look for a string of the form "end[+-]offset" and convert it to an + * internal representation holding the offset. + * + * Results: + * Returns TCL_OK if ok, TCL_ERROR if the string was badly formed. + * + * Side effects: + * If interp is not NULL, stores an error message in the interpreter + * result. + * + *---------------------------------------------------------------------- + */ + +static int +SetEndOffsetFromAny( + Tcl_Interp *interp, /* Tcl interpreter or NULL */ + Tcl_Obj *objPtr) /* Pointer to the object to parse */ +{ + int offset; /* Offset in the "end-offset" expression */ + register char* bytes; /* String rep of the object */ + int length; /* Length of the object's string rep */ + + /* + * If it's already the right type, we're fine. + */ + + if (objPtr->typePtr == &tclEndOffsetType) { + return TCL_OK; + } + + /* + * Check for a string rep of the right form. + */ + + bytes = TclGetStringFromObj(objPtr, &length); + if ((*bytes != 'e') || (strncmp(bytes, "end", + (size_t)((length > 3) ? 3 : length)) != 0)) { + if (interp != NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad index \"", bytes, + "\": must be end?[+-]integer?", NULL); + } + return TCL_ERROR; + } + + /* + * Convert the string rep. + */ + + if (length <= 3) { + offset = 0; + } else if ((length > 4) && ((bytes[3] == '-') || (bytes[3] == '+'))) { + /* + * This is our limited string expression evaluator. Pass everything + * after "end-" to Tcl_GetInt, then reverse for offset. + */ + + if (TclIsSpaceProcM(bytes[4])) { + return TCL_ERROR; + } + if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) { + return TCL_ERROR; + } + if (bytes[3] == '-') { + offset = -offset; + } + } else { + /* + * Conversion failed. Report the error. + */ + + if (interp != NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad index \"", bytes, + "\": must be end?[+-]integer?", NULL); + } + return TCL_ERROR; + } + + /* + * The conversion succeeded. Free the old internal rep and set the new + * one. + */ + + TclFreeIntRep(objPtr); + objPtr->internalRep.longValue = offset; + objPtr->typePtr = &tclEndOffsetType; + return TCL_OK; } /* *---------------------------------------------------------------------- * - * TclIndexDecode -- + * TclCheckBadOctal -- * - * Decodes a value previously encoded by TclIndexEncode. The argument - * endValue indicates what value of "end" should be used in the - * decoding. + * This function checks for a bad octal value and appends a meaningful + * error to the interp's result. * * Results: - * The decoded index value. + * 1 if the argument was a bad octal, else 0. + * + * Side effects: + * The interpreter's result is modified. * *---------------------------------------------------------------------- */ -size_t -TclIndexDecode( - int encoded, /* Value to decode */ - size_t endValue) /* Meaning of "end" to use, > TCL_INDEX_END */ -{ - if (encoded > (int)TCL_INDEX_END) { - return encoded; - } - if (endValue >= TCL_INDEX_END - encoded) { - return endValue + encoded - TCL_INDEX_END; - } - return TCL_INDEX_NONE; +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. */ +{ + register 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_AppendResult(interp, " (looks like invalid octal number)", + NULL); + } + return 1; + } + } + return 0; } /* *---------------------------------------------------------------------- * @@ -3814,12 +3647,11 @@ 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_Obj *objPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); Tcl_DecrRefCount(objPtr); Tcl_DeleteHashEntry(hPtr); } } @@ -3843,16 +3675,16 @@ static Tcl_HashTable * GetThreadHash( Tcl_ThreadDataKey *keyPtr) { - Tcl_HashTable **tablePtrPtr = - (Tcl_HashTable **)Tcl_GetThreadData(keyPtr, sizeof(Tcl_HashTable *)); + Tcl_HashTable **tablePtrPtr = (Tcl_HashTable **) + Tcl_GetThreadData(keyPtr, (int) sizeof(Tcl_HashTable *)); if (NULL == *tablePtrPtr) { - *tablePtrPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); - Tcl_CreateThreadExitHandler(FreeThreadHash, *tablePtrPtr); + *tablePtrPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + Tcl_CreateThreadExitHandler(FreeThreadHash, (ClientData)*tablePtrPtr); Tcl_InitHashTable(*tablePtrPtr, TCL_ONE_WORD_KEYS); } return *tablePtrPtr; } @@ -3872,15 +3704,15 @@ static void FreeThreadHash( ClientData clientData) { - Tcl_HashTable *tablePtr = (Tcl_HashTable *)clientData; + Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientData; ClearHash(tablePtr); Tcl_DeleteHashTable(tablePtr); - Tcl_Free(tablePtr); + ckfree((char *) tablePtr); } /* *---------------------------------------------------------------------- * @@ -3894,15 +3726,15 @@ static void FreeProcessGlobalValue( ClientData clientData) { - ProcessGlobalValue *pgvPtr = (ProcessGlobalValue *)clientData; + ProcessGlobalValue *pgvPtr = (ProcessGlobalValue *) clientData; pgvPtr->epoch++; pgvPtr->numBytes = 0; - Tcl_Free(pgvPtr->value); + ckfree(pgvPtr->value); pgvPtr->value = NULL; if (pgvPtr->encoding) { Tcl_FreeEncoding(pgvPtr->encoding); pgvPtr->encoding = NULL; } @@ -3924,11 +3756,11 @@ TclSetProcessGlobalValue( ProcessGlobalValue *pgvPtr, Tcl_Obj *newValue, Tcl_Encoding encoding) { - const char *bytes; + CONST char *bytes; Tcl_HashTable *cacheMap; Tcl_HashEntry *hPtr; int dummy; Tcl_MutexLock(&pgvPtr->mutex); @@ -3937,18 +3769,17 @@ * Fill the global string value. */ pgvPtr->epoch++; if (NULL != pgvPtr->value) { - Tcl_Free(pgvPtr->value); + ckfree(pgvPtr->value); } else { - Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr); + Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData) pgvPtr); } - bytes = TclGetString(newValue); - pgvPtr->numBytes = newValue->length; - pgvPtr->value = (char *)Tcl_Alloc(pgvPtr->numBytes + 1); - memcpy(pgvPtr->value, bytes, pgvPtr->numBytes + 1); + bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes); + pgvPtr->value = ckalloc((unsigned) pgvPtr->numBytes + 1); + memcpy(pgvPtr->value, bytes, (unsigned) pgvPtr->numBytes + 1); if (pgvPtr->encoding) { Tcl_FreeEncoding(pgvPtr->encoding); } pgvPtr->encoding = encoding; @@ -3959,12 +3790,13 @@ */ Tcl_IncrRefCount(newValue); cacheMap = GetThreadHash(&pgvPtr->key); ClearHash(cacheMap); - hPtr = Tcl_CreateHashEntry(cacheMap, INT2PTR(pgvPtr->epoch), &dummy); - Tcl_SetHashValue(hPtr, newValue); + hPtr = Tcl_CreateHashEntry(cacheMap, + (char *) INT2PTR(pgvPtr->epoch), &dummy); + Tcl_SetHashValue(hPtr, (ClientData) newValue); Tcl_MutexUnlock(&pgvPtr->mutex); } /* *---------------------------------------------------------------------- @@ -3985,45 +3817,47 @@ ProcessGlobalValue *pgvPtr) { Tcl_Obj *value = NULL; Tcl_HashTable *cacheMap; Tcl_HashEntry *hPtr; - size_t epoch = pgvPtr->epoch; + int epoch = pgvPtr->epoch; if (pgvPtr->encoding) { Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL); if (pgvPtr->encoding != current) { /* - * The system encoding has changed since the global string value - * was saved. Convert the global value to be based on the new + * 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; + pgvPtr->epoch++; + 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); - Tcl_Free(pgvPtr->value); - pgvPtr->value = (char *)Tcl_Alloc(Tcl_DStringLength(&newValue) + 1); + ckfree(pgvPtr->value); + pgvPtr->value = ckalloc((unsigned int) + Tcl_DStringLength(&newValue) + 1); memcpy(pgvPtr->value, Tcl_DStringValue(&newValue), - Tcl_DStringLength(&newValue) + 1); + (size_t) 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)); + hPtr = Tcl_FindHashEntry(cacheMap, (char *) INT2PTR(epoch)); if (NULL == hPtr) { int dummy; /* * No cache for the current epoch - must be a new one. @@ -4039,29 +3873,30 @@ */ Tcl_MutexLock(&pgvPtr->mutex); if ((NULL == pgvPtr->value) && (pgvPtr->proc)) { pgvPtr->epoch++; - pgvPtr->proc(&pgvPtr->value,&pgvPtr->numBytes,&pgvPtr->encoding); + (*(pgvPtr->proc))(&pgvPtr->value, &pgvPtr->numBytes, + &pgvPtr->encoding); if (pgvPtr->value == NULL) { Tcl_Panic("PGV Initializer did not initialize"); } - Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr); + Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData)pgvPtr); } /* * 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); + (char *) INT2PTR(pgvPtr->epoch), &dummy); Tcl_MutexUnlock(&pgvPtr->mutex); - Tcl_SetHashValue(hPtr, value); + Tcl_SetHashValue(hPtr, (ClientData) value); Tcl_IncrRefCount(value); } - return (Tcl_Obj *)Tcl_GetHashValue(hPtr); + return (Tcl_Obj *) Tcl_GetHashValue(hPtr); } /* *---------------------------------------------------------------------- * @@ -4069,11 +3904,11 @@ * * This function stores the absolute pathname of the executable file * (normally as computed by TclpFindExecutable). * * Results: - * None. + * None. * * Side effects: * Stores the executable name. * *---------------------------------------------------------------------- @@ -4100,11 +3935,11 @@ * Results: * A pointer to an "fsPath" Tcl_Obj, or to an empty Tcl_Obj if the * pathname of the application is unknown. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ Tcl_Obj * @@ -4119,33 +3954,59 @@ * Tcl_GetNameOfExecutable -- * * This function retrieves the absolute pathname of the application in * which the Tcl library is running, and returns it in string form. * - * The returned string belongs to Tcl and should be copied if the caller - * plans to keep it, to guard against it becoming invalid. + * The returned string belongs to Tcl and should be copied if the caller + * plans to keep it, to guard against it becoming invalid. * * Results: * A pointer to the internal string or NULL if the internal full path * name has not been computed or unknown. * * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +CONST char * +Tcl_GetNameOfExecutable(void) +{ + int numBytes; + const char *bytes = + Tcl_GetStringFromObj(TclGetObjNameOfExecutable(), &numBytes); + + if (numBytes == 0) { + return NULL; + } + 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" + * *---------------------------------------------------------------------- */ -const char * -Tcl_GetNameOfExecutable(void) -{ - Tcl_Obj *obj = TclGetObjNameOfExecutable(); - const char *bytes = TclGetString(obj); - - if (obj->length == 0) { - return NULL; - } - return bytes; +void +TclpGetTime( + Tcl_Time *timePtr) +{ + Tcl_GetTime(timePtr); } /* *---------------------------------------------------------------------- * @@ -4191,36 +4052,31 @@ int TclReToGlob( Tcl_Interp *interp, const char *reStr, - size_t reStrLen, + int reStrLen, Tcl_DString *dsPtr, - int *exactPtr, - int *quantifiersFoundPtr) + int *exactPtr) { int anchorLeft, anchorRight, lastIsStar, numStars; - char *dsStr, *dsStrStart; - const char *msg, *p, *strEnd, *code; + char *dsStr, *dsStrStart, *msg; + const char *p, *strEnd; strEnd = reStr + reStrLen; Tcl_DStringInit(dsPtr); - if (quantifiersFoundPtr != NULL) { - *quantifiersFoundPtr = 0; - } /* * "***=xxx" == "*xxx*", watch for glob-sensitive chars. */ if ((reStrLen >= 4) && (memcmp("***=", reStr, 4) == 0)) { /* - * At most, the glob pattern has length 2*reStrLen + 2 to backslash - * escape every character and have * at each end. + * At most, the glob pattern has length 2*reStrLen + 2 to + * backslash escape every character and have * at each end. */ - - Tcl_DStringSetLength(dsPtr, reStrLen + 2); + Tcl_DStringSetLength(dsPtr, 2*reStrLen + 2); dsStr = dsStrStart = Tcl_DStringValue(dsPtr); *dsStr++ = '*'; for (p = reStr + 4; p < strEnd; p++) { switch (*p) { case '\\': case '*': case '[': case ']': case '?': @@ -4239,27 +4095,27 @@ } return TCL_OK; } /* - * At most, the glob pattern has length reStrLen + 2 to account for - * possible * at each end. + * At most, the glob pattern has length reStrLen + 2 to account + * for possible * at each end. */ Tcl_DStringSetLength(dsPtr, reStrLen + 2); dsStr = dsStrStart = Tcl_DStringValue(dsPtr); /* * Check for anchored REs (ie ^foo$), so we can use string equal if * possible. Do not alter the start of str so we can free it correctly. * - * Keep track of the last char being an unescaped star to prevent multiple - * instances. Simpler than checking that the last star may be escaped. + * Keep track of the last char being an unescaped star to prevent + * multiple instances. Simpler than checking that the last star + * may be escaped. */ msg = NULL; - code = NULL; p = reStr; anchorRight = 0; lastIsStar = 0; numStars = 0; @@ -4312,18 +4168,14 @@ case '.': case '|': case '^': case '$': *dsStr++ = *p; break; default: msg = "invalid escape sequence"; - code = "BADESCAPE"; goto invalidGlob; } break; case '.': - if (quantifiersFoundPtr != NULL) { - *quantifiersFoundPtr = 1; - } anchorLeft = 0; /* prevent exact match */ if (p+1 < strEnd) { if (p[1] == '*') { p++; if (!lastIsStar) { @@ -4344,20 +4196,19 @@ *dsStr++ = '?'; break; case '$': if (p+1 != strEnd) { msg = "$ not anchor"; - code = "NONANCHOR"; goto invalidGlob; } anchorRight = 1; break; case '*': case '+': case '?': case '|': case '^': case '{': case '}': case '(': case ')': case '[': case ']': msg = "unhandled RE special char"; - code = "UNHANDLED"; goto invalidGlob; + break; default: *dsStr++ = *p; break; } lastIsStar = 0; @@ -4365,13 +4216,11 @@ if (numStars > 1) { /* * Heuristic: if >1 non-anchoring *, the risk is large that glob * matching is slower than the RE engine, so report invalid. */ - msg = "excessive recursive glob backtrack potential"; - code = "OVERCOMPLEX"; goto invalidGlob; } if (!anchorRight && !lastIsStar) { *dsStr++ = '*'; @@ -4380,16 +4229,26 @@ if (exactPtr) { *exactPtr = (anchorLeft && anchorRight); } +#if 0 + fprintf(stderr, "INPUT RE '%.*s' OUTPUT GLOB '%s' anchor %d:%d \n", + reStrLen, reStr, + Tcl_DStringValue(dsPtr), anchorLeft, anchorRight); + fflush(stderr); +#endif return TCL_OK; invalidGlob: +#if 0 + fprintf(stderr, "INPUT RE '%.*s' NO OUTPUT GLOB %s (%c)\n", + reStrLen, reStr, msg, *p); + fflush(stderr); +#endif if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1)); - Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, NULL); + Tcl_AppendResult(interp, msg, NULL); } Tcl_DStringFree(dsPtr); return TCL_ERROR; } Index: generic/tclVar.c ================================================================== --- generic/tclVar.c +++ generic/tclVar.c @@ -16,24 +16,24 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" -#include "tclOOInt.h" /* * Prototypes for the variable hash key methods. */ static Tcl_HashEntry * AllocVarEntry(Tcl_HashTable *tablePtr, void *keyPtr); static void FreeVarEntry(Tcl_HashEntry *hPtr); static int CompareVarKeys(void *keyPtr, Tcl_HashEntry *hPtr); +static unsigned int HashVarKey(Tcl_HashTable *tablePtr, void *keyPtr); -static const Tcl_HashKeyType tclVarHashKeyType = { +static Tcl_HashKeyType tclVarHashKeyType = { TCL_HASH_KEY_TYPE_VERSION, /* version */ - 0, /* flags */ - TclHashObjKey, /* hashKeyProc */ + TCL_HASH_KEY_DIRECT_COMPARE,/* allows compare keys by pointers */ + HashVarKey, /* hashKeyProc */ CompareVarKeys, /* compareKeysProc */ AllocVarEntry, /* allocEntryProc */ FreeVarEntry /* freeEntryProc */ }; @@ -43,11 +43,11 @@ Tcl_HashSearch *searchPtr); static inline Var * VarHashNextVar(Tcl_HashSearch *searchPtr); static inline void CleanupVar(Var *varPtr, Var *arrayPtr); #define VarHashGetValue(hPtr) \ - ((Var *) ((char *)hPtr - offsetof(VarInHash, entry))) + ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry))) /* * NOTE: VarHashCreateVar increments the recount of its key argument. * All callers that will call Tcl_DecrRefCount on that argument must * call Tcl_IncrRefCount on it before passing it in. This requirement @@ -58,29 +58,29 @@ VarHashCreateVar( TclVarHashTable *tablePtr, Tcl_Obj *key, int *newPtr) { - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table, key, newPtr); + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) tablePtr, + (char *) key, newPtr); - if (!hPtr) { + if (hPtr) { + return VarHashGetValue(hPtr); + } else { return NULL; } - return VarHashGetValue(hPtr); } #define VarHashFindVar(tablePtr, key) \ VarHashCreateVar((tablePtr), (key), NULL) - #define VarHashInvalidateEntry(varPtr) \ ((varPtr)->flags |= VAR_DEAD_HASH) - #define VarHashDeleteEntry(varPtr) \ Tcl_DeleteHashEntry(&(((VarInHash *) varPtr)->entry)) #define VarHashFirstEntry(tablePtr, searchPtr) \ - Tcl_FirstHashEntry(&(tablePtr)->table, (searchPtr)) + Tcl_FirstHashEntry((Tcl_HashTable *) (tablePtr), (searchPtr)) #define VarHashNextEntry(searchPtr) \ Tcl_NextHashEntry((searchPtr)) static inline Var * @@ -88,50 +88,52 @@ TclVarHashTable *tablePtr, Tcl_HashSearch *searchPtr) { Tcl_HashEntry *hPtr = VarHashFirstEntry(tablePtr, searchPtr); - if (!hPtr) { + if (hPtr) { + return VarHashGetValue(hPtr); + } else { return NULL; } - return VarHashGetValue(hPtr); } static inline Var * VarHashNextVar( Tcl_HashSearch *searchPtr) { Tcl_HashEntry *hPtr = VarHashNextEntry(searchPtr); - if (!hPtr) { + if (hPtr) { + return VarHashGetValue(hPtr); + } else { return NULL; } - return VarHashGetValue(hPtr); } #define VarHashGetKey(varPtr) \ (((VarInHash *)(varPtr))->entry.key.objPtr) #define VarHashDeleteTable(tablePtr) \ - Tcl_DeleteHashTable(&(tablePtr)->table) + Tcl_DeleteHashTable((Tcl_HashTable *) (tablePtr)) /* * The strings below are used to indicate what went wrong when a variable * access is denied. */ -static const char NOSUCHVAR[] = "no such variable"; -static const char ISARRAY[] = "variable is array"; -static const char NEEDARRAY[] = "variable isn't array"; -static const char NOSUCHELEMENT[] = "no such element in array"; -static const char DANGLINGELEMENT[] = +static const char *noSuchVar = "no such variable"; +static const char *isArray = "variable is array"; +static const char *needArray = "variable isn't array"; +static const char *noSuchElement = "no such element in array"; +static const char *danglingElement = "upvar refers to element in deleted array"; -static const char DANGLINGVAR[] = +static const char *danglingVar = "upvar refers to variable in deleted namespace"; -static const char BADNAMESPACE[] = "parent namespace doesn't exist"; -static const char MISSINGNAME[] = "missing variable name"; -static const char ISARRAYELEMENT[] = +static const char *badNamespace = "parent namespace doesn't exist"; +static const char *missingName = "missing variable name"; +static const char *isArrayElement = "name refers to an element in an array"; /* * A test to see if we are in a call frame that has local variables. This is * true if we are inside a procedure body. @@ -143,11 +145,10 @@ * The following structure describes an enumerative search in progress on an * array variable; this are invoked with options to the "array" command. */ typedef struct ArraySearch { - Tcl_Obj *name; /* Name of this search */ int id; /* Integer id used to distinguish among * multiple concurrent searches for the same * array. */ struct Var *varPtr; /* Pointer to array variable that's being * searched. */ @@ -162,42 +163,20 @@ struct ArraySearch *nextPtr;/* Next in list of all active searches for * this variable, or NULL if this is the last * one. */ } ArraySearch; -/* - * TIP #508: [array default] - * - * The following structure extends the regular TclVarHashTable used by array - * variables to store their optional default value. - */ - -typedef struct ArrayVarHashTable { - TclVarHashTable table; - Tcl_Obj *defaultObj; -} ArrayVarHashTable; - /* * Forward references to functions defined later in this file: */ static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr, 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, + Var *varPtr, int flags); +static Tcl_Var ObjFindNamespaceVar(Tcl_Interp *interp, Tcl_Obj *namePtr, Tcl_Namespace *contextNsPtr, int flags); static int ObjMakeUpvar(Tcl_Interp *interp, CallFrame *framePtr, Tcl_Obj *otherP1Ptr, const char *otherP2, const int otherFlags, @@ -204,21 +183,13 @@ Tcl_Obj *myNamePtr, int myFlags, int index); static ArraySearch * ParseSearchId(Tcl_Interp *interp, const Var *varPtr, Tcl_Obj *varNamePtr, Tcl_Obj *handleObj); static void UnsetVarStruct(Var *varPtr, Var *arrayPtr, Interp *iPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, int flags, int index); - -/* - * TIP #508: [array default] - */ - -static int ArrayDefaultCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static void DeleteArrayVar(Var *arrayPtr); -static void SetArrayDefault(Var *arrayPtr, Tcl_Obj *defaultObj); + Tcl_Obj *part2Ptr, int flags); +static int SetArraySearchObj(Tcl_Interp *interp, + Tcl_Obj *objPtr); /* * Functions defined in this file that may be exported in the future for use * by the bytecode compiler and engine or to the public interface. */ @@ -227,77 +198,83 @@ Tcl_Obj *varNamePtr, int flags, const int create, const char **errMsgPtr, int *indexPtr); static Tcl_DupInternalRepProc DupLocalVarName; static Tcl_FreeInternalRepProc FreeLocalVarName; +static Tcl_UpdateStringProc PanicOnUpdateVarName; static Tcl_FreeInternalRepProc FreeParsedVarName; static Tcl_DupInternalRepProc DupParsedVarName; +static Tcl_UpdateStringProc UpdateParsedVarName; + +static Tcl_UpdateStringProc PanicOnUpdateVarName; +static Tcl_SetFromAnyProc PanicOnSetVarName; /* * Types of Tcl_Objs used to cache variable lookups. * * localVarName - INTERNALREP DEFINITION: - * twoPtrValue.ptr1: pointer to name obj in varFramePtr->localCache - * or NULL if it is this same obj - * twoPtrValue.ptr2: index into locals table + * ptrAndLongRep.ptr: pointer to name obj in varFramePtr->localCache + * or NULL if it is this same obj + * ptrAndLongRep.value: index into locals table + * + * nsVarName - INTERNALREP DEFINITION: + * twoPtrValue.ptr1: pointer to the namespace containing the reference + * twoPtrValue.ptr2: pointer to the corresponding Var * * parsedVarName - INTERNALREP DEFINITION: * twoPtrValue.ptr1: pointer to the array name Tcl_Obj, or NULL if it is a * scalar variable * twoPtrValue.ptr2: pointer to the element name string (owned by this * Tcl_Obj), or NULL if it is a scalar variable */ -static const Tcl_ObjType localVarNameType = { - "localVarName", - FreeLocalVarName, DupLocalVarName, NULL, NULL -}; - -#define LocalSetIntRep(objPtr, index, namePtr) \ - do { \ - Tcl_ObjIntRep ir; \ - Tcl_Obj *ptr = (namePtr); \ - if (ptr) {Tcl_IncrRefCount(ptr);} \ - ir.twoPtrValue.ptr1 = ptr; \ - ir.twoPtrValue.ptr2 = INT2PTR(index); \ - 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 -}; - -#define ParsedSetIntRep(objPtr, arrayPtr, elem) \ - do { \ - Tcl_ObjIntRep ir; \ - Tcl_Obj *ptr1 = (arrayPtr); \ - Tcl_Obj *ptr2 = (elem); \ - if (ptr1) {Tcl_IncrRefCount(ptr1);} \ - if (ptr2) {Tcl_IncrRefCount(ptr2);} \ - ir.twoPtrValue.ptr1 = ptr1; \ - ir.twoPtrValue.ptr2 = ptr2; \ - Tcl_StoreIntRep((objPtr), &parsedVarNameType, &ir); \ - } 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) +static Tcl_ObjType localVarNameType = { + "localVarName", + FreeLocalVarName, DupLocalVarName, PanicOnUpdateVarName, PanicOnSetVarName +}; + +/* + * Caching of namespace variables disabled: no simple way was found to avoid + * interfering with the resolver's idea of variable existence. A cached + * varName may keep a variable's name in the namespace's hash table, which is + * the resolver's criterion for existence (see test namespace-17.10). + */ + +#define ENABLE_NS_VARNAME_CACHING 0 + +#if ENABLE_NS_VARNAME_CACHING +static Tcl_FreeInternalRepProc FreeNsVarName; +static Tcl_DupInternalRepProc DupNsVarName; + +static Tcl_ObjType tclNsVarNameType = { + "namespaceVarName", + FreeNsVarName, DupNsVarName, PanicOnUpdateVarName, PanicOnSetVarName +}; +#endif + +static Tcl_ObjType tclParsedVarNameType = { + "parsedVarName", + FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, PanicOnSetVarName +}; + +/* + * Type of Tcl_Objs used to speed up array searches. + * + * INTERNALREP DEFINITION: + * twoPtrValue.ptr1: searchIdNumber (cast to pointer) + * twoPtrValue.ptr2: variableNameStartInString (cast to pointer) + * + * Note that the value stored in ptr2 is the offset into the string of the + * start of the variable name and not the address of the variable name itself, + * as this can be safely copied. + */ + +Tcl_ObjType tclArraySearchType = { + "array search", + NULL, NULL, NULL, SetArraySearchObj +}; Var * TclVarHashCreateVar( TclVarHashTable *tablePtr, const char *key, @@ -311,46 +288,10 @@ varPtr = VarHashCreateVar(tablePtr, keyPtr, newPtr); Tcl_DecrRefCount(keyPtr); return varPtr; } - -static int -LocateArray( - Tcl_Interp *interp, - Tcl_Obj *name, - Var **varPtrPtr, - int *isArrayPtr) -{ - Var *arrayPtr, *varPtr = TclObjLookupVarEx(interp, name, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - if (TclCheckArrayTraces(interp, varPtr, arrayPtr, name, -1) == TCL_ERROR) { - return TCL_ERROR; - } - if (varPtrPtr) { - *varPtrPtr = varPtr; - } - if (isArrayPtr) { - *isArrayPtr = varPtr && !TclIsVarUndefined(varPtr) - && TclIsVarArray(varPtr); - } - return TCL_OK; -} - -static int -NotArrayError( - Tcl_Interp *interp, - Tcl_Obj *name) -{ - const char *nameStr = TclGetString(name); - - Tcl_SetObjResult(interp, - Tcl_ObjPrintf("\"%s\" isn't an array", nameStr)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", nameStr, NULL); - return TCL_ERROR; -} /* *---------------------------------------------------------------------- * * TclCleanupVar -- @@ -379,24 +320,22 @@ Var *arrayPtr) /* Array that contains the variable, or NULL * if this variable isn't an array element. */ { if (TclIsVarUndefined(varPtr) && TclIsVarInHash(varPtr) && !TclIsVarTraced(varPtr) - && (VarHashRefCount(varPtr) == (unsigned) - !TclIsVarDeadHash(varPtr))) { + && (VarHashRefCount(varPtr) == !TclIsVarDeadHash(varPtr))) { if (VarHashRefCount(varPtr) == 0) { - Tcl_Free(varPtr); + ckfree((char *) varPtr); } else { VarHashDeleteEntry(varPtr); } } if (arrayPtr != NULL && TclIsVarUndefined(arrayPtr) && TclIsVarInHash(arrayPtr) && !TclIsVarTraced(arrayPtr) && - (VarHashRefCount(arrayPtr) == (unsigned) - !TclIsVarDeadHash(arrayPtr))) { + (VarHashRefCount(arrayPtr) == !TclIsVarDeadHash(arrayPtr))) { if (VarHashRefCount(arrayPtr) == 0) { - Tcl_Free(arrayPtr); + ckfree((char *) arrayPtr); } else { VarHashDeleteEntry(arrayPtr); } } } @@ -518,22 +457,23 @@ * a variable that has been unset but it only being kept in existence (if * VAR_UNDEFINED) by a trace. * * Side effects: * New hashtable entries may be created if createPart1 or createPart2 - * are 1. The object part1Ptr is converted to one of localVarNameType - * or parsedVarNameType and caches as much of the lookup as it can. + * are 1. The object part1Ptr is converted to one of localVarNameType, + * tclNsVarNameType or tclParsedVarNameType and caches as much of the + * lookup as it can. * When createPart1 is 1, callers must IncrRefCount part1Ptr if they * plan to DecrRefCount it. * *---------------------------------------------------------------------- */ Var * TclObjLookupVar( Tcl_Interp *interp, /* Interpreter to use for lookup. */ - Tcl_Obj *part1Ptr, /* If part2 isn't NULL, this is the name of an + register 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, @@ -601,95 +541,200 @@ * 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 + register Var *varPtr; /* Points to the variable's in-frame Var * structure. */ + char *part1; + int index, len1, len2; + int parsed = 0; + Tcl_Obj *objPtr; + const Tcl_ObjType *typePtr = part1Ptr->typePtr; const char *errMsg = NULL; - int index, parsed = 0; - - int localIndex; - Tcl_Obj *namePtr, *arrayPtr, *elem; + CallFrame *varFramePtr = iPtr->varFramePtr; +#if ENABLE_NS_VARNAME_CACHING + Namespace *nsPtr; +#endif + char *part2 = part2Ptr? TclGetString(part2Ptr):NULL; + char *newPart2 = NULL; *arrayPtrPtr = NULL; - restart: - LocalGetIntRep(part1Ptr, localIndex, namePtr); - if (localIndex >= 0) { +#if ENABLE_NS_VARNAME_CACHING + if (varFramePtr) { + nsPtr = varFramePtr->nsPtr; + } else { + /* + * Some variables in the global ns have to be initialized before the + * root call frame is in place. + */ + + nsPtr = NULL; + } +#endif + + if (typePtr == &localVarNameType) { + int localIndex; + + localVarNameTypeHandling: + localIndex = (int) part1Ptr->internalRep.ptrAndLongRep.value; if (HasLocalVars(varFramePtr) && !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) && (localIndex < varFramePtr->numCompiledLocals)) { /* * Use the cached index if the names coincide. */ - Tcl_Obj *checkNamePtr = localName(varFramePtr, localIndex); + Tcl_Obj *namePtr = (Tcl_Obj *) + part1Ptr->internalRep.ptrAndLongRep.ptr; + Tcl_Obj *checkNamePtr = localName(iPtr->varFramePtr, localIndex); if ((!namePtr && (checkNamePtr == part1Ptr)) || (namePtr && (checkNamePtr == namePtr))) { varPtr = (Var *) &(varFramePtr->compiledLocals[localIndex]); goto donePart1; } } goto doneParsing; +#if ENABLE_NS_VARNAME_CACHING + } else if (typePtr == &tclNsVarNameType) { + int useGlobal, useReference; + Namespace *cachedNsPtr = part1Ptr->internalRep.twoPtrValue.ptr1; + varPtr = part1Ptr->internalRep.twoPtrValue.ptr2; + + useGlobal = (cachedNsPtr == iPtr->globalNsPtr) && ( + (flags & TCL_GLOBAL_ONLY) || + (part1[0]==':' && part1[1]==':') || + (!HasLocalVars(varFramePtr) && (nsPtr==iPtr->globalNsPtr))); + + useReference = useGlobal || ((cachedNsPtr == nsPtr) && ( + (flags & TCL_NAMESPACE_ONLY) || + (!HasLocalVars(varFramePtr) && !(flags & TCL_GLOBAL_ONLY) && + /* + * Careful: an undefined ns variable could be hiding a valid + * global reference. + */ + !TclIsVarUndefined(varPtr)))); + + if (useReference && !TclIsVarDeadHash(varPtr)) { + /* + * A straight global or namespace reference, use it. It isn't so + * simple to deal with 'implicit' namespace references, i.e., + * those where the reference could be to either a namespace or a + * global variable. Those we lookup again. + * + * If TclIsVarDeadHash(varPtr), this might be a reference to a + * variable in a deleted namespace, kept alive by e.g. part1Ptr. + * We could conceivably be so unlucky that a new namespace was + * created at the same address as the deleted one, so to be safe + * we test for a valid hPtr. + */ + + goto donePart1; + } + goto doneParsing; +#endif } /* - * If part1Ptr is a parsedVarNameType, retrieve the pre-parsed parts. + * If part1Ptr is a tclParsedVarNameType, separate it into the pre-parsed + * parts. */ - ParsedGetIntRep(part1Ptr, parsed, arrayPtr, elem); - if (parsed && arrayPtr) { + if (typePtr == &tclParsedVarNameType) { + if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) { if (part2Ptr != NULL) { /* * ERROR: part1Ptr is already an array element, cannot specify * a part2. */ if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, - NOSUCHVAR, -1); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "VARNAME", NULL); + noSuchVar, -1); } return NULL; } - part2Ptr = elem; - part1Ptr = arrayPtr; - goto restart; + part2 = newPart2 = part1Ptr->internalRep.twoPtrValue.ptr2; + if (newPart2) { + part2Ptr = Tcl_NewStringObj(newPart2, -1); + if (createPart2) { + Tcl_IncrRefCount(part2Ptr); + } + } + part1Ptr = part1Ptr->internalRep.twoPtrValue.ptr1; + typePtr = part1Ptr->typePtr; + if (typePtr == &localVarNameType) { + goto localVarNameTypeHandling; + } + } + parsed = 1; } + part1 = TclGetStringFromObj(part1Ptr, &len1); - if (!parsed) { + if (!parsed && len1 && (*(part1 + len1 - 1) == ')')) { /* * part1Ptr is possibly an unparsed array element. */ - size_t len; - const char *part1 = TclGetStringFromObj(part1Ptr, &len); + register int i; - if ((len > 1) && (part1[len - 1] == ')')) { - const char *part2 = strchr(part1, '('); - - if (part2) { + len2 = -1; + for (i = 0; i < len1; i++) { + if (*(part1 + i) == '(') { if (part2Ptr != NULL) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, - NEEDARRAY, -1); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "VARNAME", - NULL); + needArray, -1); } return NULL; } - arrayPtr = Tcl_NewStringObj(part1, (part2 - part1)); - part2Ptr = Tcl_NewStringObj(part2 + 1, - len - (part2 - part1) - 2); + /* + * part1Ptr points to an array element; first copy the element + * name to a new string part2. + */ - ParsedSetIntRep(part1Ptr, arrayPtr, part2Ptr); + part2 = part1 + i + 1; + len2 = len1 - i - 2; + len1 = i; - part1Ptr = arrayPtr; + newPart2 = ckalloc((unsigned int) (len2+1)); + memcpy(newPart2, part2, (unsigned int) len2); + *(newPart2+len2) = '\0'; + part2 = newPart2; + part2Ptr = Tcl_NewStringObj(newPart2, -1); + if (createPart2) { + Tcl_IncrRefCount(part2Ptr); + } + + /* + * Free the internal rep of the original part1Ptr, now renamed + * objPtr, and set it to tclParsedVarNameType. + */ + + objPtr = part1Ptr; + TclFreeIntRep(objPtr); + objPtr->typePtr = &tclParsedVarNameType; + + /* + * Define a new string object to hold the new part1Ptr, i.e., + * the array name. Set the internal rep of objPtr, reset + * typePtr and part1 to contain the references to the array + * name. + */ + + TclNewStringObj(part1Ptr, part1, len1); + Tcl_IncrRefCount(part1Ptr); + + objPtr->internalRep.twoPtrValue.ptr1 = part1Ptr; + objPtr->internalRep.twoPtrValue.ptr2 = (void *) part2; + + typePtr = part1Ptr->typePtr; + part1 = TclGetString(part1Ptr); + break; } } } doneParsing: @@ -696,17 +741,21 @@ /* * part1Ptr is not an array element; look it up, and convert it to one of * the cached types if possible. */ + TclFreeIntRep(part1Ptr); + part1Ptr->typePtr = NULL; + varPtr = TclLookupSimpleVar(interp, part1Ptr, flags, createPart1, &errMsg, &index); if (varPtr == NULL) { if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, errMsg, -1); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", - TclGetString(part1Ptr), NULL); + } + if (newPart2) { + Tcl_DecrRefCount(part2Ptr); } return NULL; } /* @@ -716,52 +765,55 @@ if (index >= 0) { /* * An indexed local variable. */ - Tcl_Obj *cachedNamePtr = localName(varFramePtr, index); - - if (part1Ptr == cachedNamePtr) { - LocalSetIntRep(part1Ptr, index, NULL); + part1Ptr->typePtr = &localVarNameType; + if (part1Ptr != localName(iPtr->varFramePtr, index)) { + part1Ptr->internalRep.ptrAndLongRep.ptr = + localName(iPtr->varFramePtr, index); + Tcl_IncrRefCount((Tcl_Obj *) + part1Ptr->internalRep.ptrAndLongRep.ptr); } else { - /* - * [80304238ac] Trickiness here. We will store and incr the - * refcount on cachedNamePtr. Trouble is that it's possible - * (see test var-22.1) for cachedNamePtr to have an intrep - * that contains a stored and refcounted part1Ptr. This - * would be a reference cycle which leads to a memory leak. - * - * The solution here is to wipe away all intrep(s) in - * cachedNamePtr and leave it as string only. This is - * radical and destructive, so a better idea would be welcome. - */ - - /* - * Firstly set cached local var reference (avoid free before set, - * see [45b9faf103f2]) - */ - LocalSetIntRep(part1Ptr, index, cachedNamePtr); - - /* Then wipe it */ - TclFreeIntRep(cachedNamePtr); - - /* - * Now go ahead and convert it the the "localVarName" type, - * since we suspect at least some use of the value as a - * varname and we want to resolve it quickly. - */ - LocalSetIntRep(cachedNamePtr, index, NULL); - } + part1Ptr->internalRep.ptrAndLongRep.ptr = NULL; + } + part1Ptr->internalRep.ptrAndLongRep.value = (long) index; +#if ENABLE_NS_VARNAME_CACHING + } else if (index > -3) { + /* + * A cacheable namespace or global variable. + */ + + Namespace *nsPtr; + + nsPtr = ((index == -1) ? iPtr->globalNsPtr : varFramePtr->nsPtr); + varPtr->refCount++; + part1Ptr->typePtr = &tclNsVarNameType; + part1Ptr->internalRep.twoPtrValue.ptr1 = nsPtr; + part1Ptr->internalRep.twoPtrValue.ptr2 = varPtr; +#endif } else { /* * At least mark part1Ptr as already parsed. */ - ParsedSetIntRep(part1Ptr, NULL, NULL); + part1Ptr->typePtr = &tclParsedVarNameType; + part1Ptr->internalRep.twoPtrValue.ptr1 = NULL; + part1Ptr->internalRep.twoPtrValue.ptr2 = NULL; } donePart1: +#if 0 + if (varPtr == NULL) { + if (flags & TCL_LEAVE_ERR_MSG) { + part1 = TclGetString(part1Ptr); + TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, + "Cached variable reference is NULL.", -1); + } + return NULL; + } +#endif while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } if (part2Ptr != NULL) { @@ -770,14 +822,32 @@ */ *arrayPtrPtr = varPtr; varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, flags, msg, createPart1, createPart2, varPtr, -1); + if (newPart2) { + Tcl_DecrRefCount(part2Ptr); + } } return varPtr; } +/* + * 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 AVOID_RESOLVERS 0x40000 + /* *---------------------------------------------------------------------- * * TclLookupSimpleVar -- * @@ -823,12 +893,12 @@ TclLookupSimpleVar( Tcl_Interp *interp, /* Interpreter to use for lookup. */ Tcl_Obj *varNamePtr, /* This is a simple variable name that could * represent a scalar or an array. */ int flags, /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, - * TCL_AVOID_RESOLVERS and TCL_LEAVE_ERR_MSG - * bits matter. */ + * AVOID_RESOLVERS and TCL_LEAVE_ERR_MSG bits + * matter. */ const int create, /* If 1, create hash table entry for varname, * if it doesn't already exist. If 0, return * error if it doesn't exist. */ const char **errMsgPtr, int *indexPtr) @@ -844,13 +914,12 @@ 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; - size_t varLen; - const char *varName = TclGetStringFromObj(varNamePtr, &varLen); + int isNew; + const char *varName = TclGetString(varNamePtr); varPtr = NULL; varNsPtr = NULL; /* Set non-NULL if a nonlocal variable. */ *indexPtr = -3; @@ -865,22 +934,24 @@ * the variable resolution. It may return a Tcl_Var value, it may signal * to continue onward, or it may signal an error. */ if ((cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) - && !(flags & TCL_AVOID_RESOLVERS)) { + && !(flags & AVOID_RESOLVERS)) { + int result; + resPtr = iPtr->resolverPtr; if (cxtNsPtr->varResProc) { - result = cxtNsPtr->varResProc(interp, varName, + result = (*cxtNsPtr->varResProc)(interp, varName, (Tcl_Namespace *) cxtNsPtr, flags, &var); } else { result = TCL_CONTINUE; } while (result == TCL_CONTINUE && resPtr) { if (resPtr->varResProc) { - result = resPtr->varResProc(interp, varName, + result = (*resPtr->varResProc)(interp, varName, (Tcl_Namespace *) cxtNsPtr, flags, &var); } resPtr = resPtr->nextPtr; } @@ -918,87 +989,86 @@ if (lookGlobal) { *indexPtr = -1; flags = (flags | TCL_GLOBAL_ONLY) & ~TCL_NAMESPACE_ONLY; } else { - flags = (flags | TCL_NAMESPACE_ONLY); - *indexPtr = -2; + if (flags & 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! */ varPtr = (Var *) ObjFindNamespaceVar(interp, varNamePtr, (Tcl_Namespace *) cxtNsPtr, - (flags | TCL_AVOID_RESOLVERS) & ~TCL_LEAVE_ERR_MSG); + (flags | AVOID_RESOLVERS) & ~TCL_LEAVE_ERR_MSG); if (varPtr == NULL) { - Tcl_Obj *tailPtr; - - if (!create) { /* Var wasn't found and not to create it. */ - *errMsgPtr = NOSUCHVAR; - return NULL; - } - - /* - * Var wasn't found so create it. - */ - - TclGetNamespaceForQualName(interp, varName, cxtNsPtr, flags, - &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail); - if (varNsPtr == NULL) { - *errMsgPtr = BADNAMESPACE; - return NULL; - } else if (tail == NULL) { - *errMsgPtr = MISSINGNAME; - return NULL; - } - if (tail != varName) { - tailPtr = Tcl_NewStringObj(tail, -1); - } else { - tailPtr = varNamePtr; - } - varPtr = VarHashCreateVar(&varNsPtr->varTable, tailPtr, &isNew); - if (lookGlobal) { - /* - * The variable was created starting from the global - * namespace: a global reference is returned even if it wasn't - * explicitly requested. - */ - - *indexPtr = -1; - } else { - *indexPtr = -2; + + if (create) { /* Var wasn't found so create it. */ + Tcl_Obj *tailPtr; + + TclGetNamespaceForQualName(interp, varName, cxtNsPtr, + flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail); + if (varNsPtr == NULL) { + *errMsgPtr = badNamespace; + return NULL; + } else if (tail == NULL) { + *errMsgPtr = missingName; + return NULL; + } + if (tail != varName) { + tailPtr = Tcl_NewStringObj(tail, -1); + } else { + tailPtr = varNamePtr; + } + varPtr = VarHashCreateVar(&varNsPtr->varTable, tailPtr, + &isNew); + if (lookGlobal) { + /* + * The variable was created starting from the global + * namespace: a global reference is returned even if it + * wasn't explicitly requested. + */ + + *indexPtr = -1; + } else { + *indexPtr = -2; + } + } else { /* Var wasn't found and not to create it. */ + *errMsgPtr = noSuchVar; + return NULL; } } } else { /* Local var: look in frame varFramePtr. */ int localCt = varFramePtr->numCompiledLocals; - - if (localCt > 0) { - Tcl_Obj **objPtrPtr = &varFramePtr->localCachePtr->varName0; - const char *localNameStr; - size_t localLen; - - for (i=0 ; icompiledLocals[i]; - } + Tcl_Obj **objPtrPtr = &varFramePtr->localCachePtr->varName0; + int i; + + for (i=0 ; icompiledLocals[i]; } } } tablePtr = varFramePtr->varTablePtr; if (create) { if (tablePtr == NULL) { - tablePtr = (TclVarHashTable *)Tcl_Alloc(sizeof(TclVarHashTable)); + tablePtr = (TclVarHashTable *) + ckalloc(sizeof(TclVarHashTable)); TclInitVarHashTable(tablePtr, NULL); varFramePtr->varTablePtr = tablePtr; } varPtr = VarHashCreateVar(tablePtr, varNamePtr, &isNew); } else { @@ -1005,11 +1075,11 @@ varPtr = NULL; if (tablePtr != NULL) { varPtr = VarHashFindVar(tablePtr, varNamePtr); } if (varPtr == NULL) { - *errMsgPtr = NOSUCHVAR; + *errMsgPtr = noSuchVar; } } } return varPtr; } @@ -1073,23 +1143,24 @@ Var *arrayPtr, /* Pointer to the array's Var structure. */ int index) /* If >=0, the index of the local array. */ { int isNew; Var *varPtr; + TclVarHashTable *tablePtr; /* * We're dealing with an array element. Make sure the variable is an array * and look up the element (create the element if desired). */ if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) { + Namespace *nsPtr; + if (!createArray) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, - NOSUCHVAR, index); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", - arrayNamePtr?TclGetString(arrayNamePtr):NULL, NULL); + noSuchVar, index); } return NULL; } /* @@ -1098,24 +1169,29 @@ */ if (TclIsVarDeadHash(arrayPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, - DANGLINGVAR, index); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", - arrayNamePtr?TclGetString(arrayNamePtr):NULL, NULL); + danglingVar, index); } return NULL; } - TclInitArrayVar(arrayPtr); + TclSetVarArray(arrayPtr); + tablePtr = (TclVarHashTable *) ckalloc(sizeof(TclVarHashTable)); + arrayPtr->value.tablePtr = tablePtr; + + if (TclIsVarInHash(arrayPtr) && TclGetVarNsPtr(arrayPtr)) { + nsPtr = TclGetVarNsPtr(arrayPtr); + } else { + nsPtr = NULL; + } + TclInitVarHashTable(arrayPtr->value.tablePtr, nsPtr); } else if (!TclIsVarArray(arrayPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { - TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, NEEDARRAY, + TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, needArray, index); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", - arrayNamePtr?TclGetString(arrayNamePtr):NULL, NULL); } return NULL; } if (createElem) { @@ -1130,18 +1206,53 @@ } else { varPtr = VarHashFindVar(arrayPtr->value.tablePtr, elNamePtr); if (varPtr == NULL) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, - NOSUCHELEMENT, index); + noSuchElement, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ELEMENT", TclGetString(elNamePtr), NULL); } } } 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. + * + *---------------------------------------------------------------------- + */ + +#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. */ +{ + return Tcl_GetVar2(interp, varName, NULL, flags); +} /* *---------------------------------------------------------------------- * * Tcl_GetVar2 -- @@ -1174,28 +1285,17 @@ * in the array part1. */ int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY and TCL_LEAVE_ERR_MSG * * bits. */ { - Tcl_Obj *resultPtr; - Tcl_Obj *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1); - - if (part2) { - part2Ptr = Tcl_NewStringObj(part2, -1); - Tcl_IncrRefCount(part2Ptr); - } - - resultPtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags); - - Tcl_DecrRefCount(part1Ptr); - if (part2Ptr) { - Tcl_DecrRefCount(part2Ptr); - } - if (resultPtr == NULL) { + Tcl_Obj *objPtr; + + objPtr = Tcl_GetVar2Ex(interp, part1, part2, flags); + if (objPtr == NULL) { return NULL; } - return TclGetString(resultPtr); + return TclGetString(objPtr); } /* *---------------------------------------------------------------------- * @@ -1274,14 +1374,14 @@ 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 + register 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 + register 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. */ { @@ -1296,11 +1396,11 @@ /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { return NULL; } - return TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, + return TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, flags, -1); } /* *---------------------------------------------------------------------- @@ -1326,57 +1426,11 @@ Tcl_Obj * TclPtrGetVar( Tcl_Interp *interp, /* Command interpreter in which variable is to * be looked up. */ - Tcl_Var varPtr, /* The variable to be read.*/ - Tcl_Var arrayPtr, /* NULL for scalar variables, pointer to the - * containing array otherwise. */ - Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or - * the name of a variable. */ - Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element - * in the array part1. */ - const int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and - * TCL_LEAVE_ERR_MSG bits. */ -{ - if (varPtr == NULL) { - Tcl_Panic("varPtr must not be NULL"); - } - if (part1Ptr == NULL) { - Tcl_Panic("part1Ptr must not be NULL"); - } - return TclPtrGetVarIdx(interp, (Var *) varPtr, (Var *) arrayPtr, - part1Ptr, part2Ptr, flags, -1); -} - -/* - *---------------------------------------------------------------------- - * - * TclPtrGetVarIdx -- - * - * Return the value of a Tcl variable as a Tcl object, given the pointers - * to the variable's (and possibly containing array's) VAR structure. - * - * Results: - * The return value points to the current object value of the variable - * given by varPtr. If the specified variable doesn't exist, or if there - * is a clash in array usage, then NULL is returned and a message will be - * left in the interpreter's result if the TCL_LEAVE_ERR_MSG flag is set. - * - * Side effects: - * The ref count for the returned object is _not_ incremented to reflect - * the returned reference; if you want to keep a reference to the object - * you must increment its ref count yourself. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclPtrGetVarIdx( - Tcl_Interp *interp, /* Command interpreter in which variable is to - * be looked up. */ - Var *varPtr, /* The variable to be read.*/ + register 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 @@ -1410,40 +1464,18 @@ if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) { return varPtr->value.objPtr; } - /* - * Return the array default value if any. - */ - - if (arrayPtr && TclIsVarArray(arrayPtr) && TclGetArrayDefault(arrayPtr)) { - return TclGetArrayDefault(arrayPtr); - } - if (TclIsVarArrayElement(varPtr) && !arrayPtr) { - /* - * UGLY! Peek inside the implementation of things. This lets us get - * the default of an array even when we've been [upvar]ed to just an - * element of the array. - */ - - ArrayVarHashTable *avhtPtr = (ArrayVarHashTable *) - ((VarInHash *) varPtr)->entry.tablePtr; - - if (avhtPtr->defaultObj) { - return avhtPtr->defaultObj; - } - } - if (flags & TCL_LEAVE_ERR_MSG) { if (TclIsVarUndefined(varPtr) && arrayPtr && !TclIsVarUndefined(arrayPtr)) { - msg = NOSUCHELEMENT; + msg = noSuchElement; } else if (TclIsVarArray(varPtr)) { - msg = ISARRAY; + msg = isArray; } else { - msg = NOSUCHVAR; + msg = noSuchVar; } TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "read", msg, index); } /* @@ -1450,11 +1482,10 @@ * An error. If the variable doesn't exist anymore and no-one's using it, * then free up the relevant structures and hash table entries. */ errorReturn: - Tcl_SetErrorCode(interp, "TCL", "READ", "VARNAME", NULL); if (TclIsVarUndefined(varPtr)) { TclCleanupVar(varPtr, arrayPtr); } return NULL; } @@ -1474,14 +1505,15 @@ * A variable's value may be changed. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_SetObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp,/* Current interpreter. */ + ClientData dummy, /* Not used. */ + register Tcl_Interp *interp,/* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *varValueObj; @@ -1503,10 +1535,49 @@ } 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. + * + *---------------------------------------------------------------------- + */ + +#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. */ +{ + return Tcl_SetVar2(interp, varName, NULL, newValue, flags); +} /* *---------------------------------------------------------------------- * * Tcl_SetVar2 -- @@ -1654,14 +1725,14 @@ 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 + register 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 + register 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, @@ -1683,11 +1754,11 @@ Tcl_DecrRefCount(newValuePtr); } return NULL; } - return TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, + return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, newValuePtr, flags, -1); } /* *---------------------------------------------------------------------- @@ -1716,189 +1787,11 @@ Tcl_Obj * TclPtrSetVar( Tcl_Interp *interp, /* Command interpreter in which variable is to * be looked up. */ - Tcl_Var varPtr, /* Reference to the variable to set. */ - Tcl_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. */ - Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element - * in the array part1. */ - Tcl_Obj *newValuePtr, /* New value for variable. */ - const int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and - * TCL_LEAVE_ERR_MSG bits. */ -{ - if (varPtr == NULL) { - Tcl_Panic("varPtr must not be NULL"); - } - if (part1Ptr == NULL) { - Tcl_Panic("part1Ptr must not be NULL"); - } - if (newValuePtr == NULL) { - Tcl_Panic("newValuePtr must not be NULL"); - } - return TclPtrSetVarIdx(interp, (Var *) varPtr, (Var *) arrayPtr, - part1Ptr, part2Ptr, newValuePtr, flags, -1); -} - -/* - *---------------------------------------------------------------------- - * - * ListAppendInVar, StringAppendInVar -- - * - * Support functions for TclPtrSetVarIdx that implement various types of - * appending operations. - * - * Results: - * ListAppendInVar returns a Tcl result code (from the core list append - * operation). StringAppendInVar has no return value. - * - * Side effects: - * The variable or element of the array is updated. This may make the - * variable/element exist. Reference counts of values may be updated. - * - *---------------------------------------------------------------------- - */ - -static inline int -ListAppendInVar( - Tcl_Interp *interp, - Var *varPtr, - Var *arrayPtr, - Tcl_Obj *oldValuePtr, - Tcl_Obj *newValuePtr) -{ - if (oldValuePtr == NULL) { - /* - * No previous value. Check for defaults if there's an array we can - * ask this of. - */ - - if (arrayPtr) { - Tcl_Obj *defValuePtr = TclGetArrayDefault(arrayPtr); - - if (defValuePtr) { - oldValuePtr = Tcl_DuplicateObj(defValuePtr); - } - } - - if (oldValuePtr == NULL) { - /* - * No default. [lappend] semantics say this is like being an empty - * string. - */ - - TclNewObj(oldValuePtr); - } - varPtr->value.objPtr = oldValuePtr; - Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */ - } else if (Tcl_IsShared(oldValuePtr)) { - varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); - TclDecrRefCount(oldValuePtr); - oldValuePtr = varPtr->value.objPtr; - Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */ - } - - return Tcl_ListObjAppendElement(interp, oldValuePtr, newValuePtr); -} - -static inline void -StringAppendInVar( - Var *varPtr, - Var *arrayPtr, - Tcl_Obj *oldValuePtr, - Tcl_Obj *newValuePtr) -{ - /* - * If there was no previous value, either we use the array's default (if - * this is an array with a default at all) or we treat this as a simple - * set. - */ - - if (oldValuePtr == NULL) { - if (arrayPtr) { - Tcl_Obj *defValuePtr = TclGetArrayDefault(arrayPtr); - - if (defValuePtr) { - /* - * This is *almost* the same as the shared path below, except - * that the original value reference in defValuePtr is not - * decremented. - */ - - Tcl_Obj *valuePtr = Tcl_DuplicateObj(defValuePtr); - - varPtr->value.objPtr = valuePtr; - TclContinuationsCopy(valuePtr, defValuePtr); - Tcl_IncrRefCount(valuePtr); - Tcl_AppendObjToObj(valuePtr, newValuePtr); - if (newValuePtr->refCount == 0) { - Tcl_DecrRefCount(newValuePtr); - } - return; - } - } - varPtr->value.objPtr = newValuePtr; - Tcl_IncrRefCount(newValuePtr); - return; - } - - /* - * We append newValuePtr's bytes but don't change its ref count. Unless - * the reference is shared, when we have to duplicate in order to be safe - * to modify at all. - */ - - if (Tcl_IsShared(oldValuePtr)) { /* Append to copy. */ - varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); - - TclContinuationsCopy(varPtr->value.objPtr, oldValuePtr); - - TclDecrRefCount(oldValuePtr); - oldValuePtr = varPtr->value.objPtr; - Tcl_IncrRefCount(oldValuePtr); /* Since var is ref */ - } - - Tcl_AppendObjToObj(oldValuePtr, newValuePtr); - if (newValuePtr->refCount == 0) { - Tcl_DecrRefCount(newValuePtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclPtrSetVarIdx -- - * - * This function is the same as Tcl_SetVar2Ex above, except that it - * requires pointers to the variable's Var structs in addition to the - * variable names. - * - * Results: - * Returns a pointer to the Tcl_Obj holding the new value of the - * variable. If the write operation was disallowed because an array was - * expected but not found (or vice versa), then NULL is returned; if the - * TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will be - * left in the interpreter's result. Note that the returned object may - * not be the same one referenced by newValuePtr; this is because - * variable traces may modify the variable's value. - * - * Side effects: - * The value of the given variable is set. If either the array or the - * entry didn't exist then a new variable is created. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclPtrSetVarIdx( - Tcl_Interp *interp, /* Command interpreter in which variable is to - * be looked up. */ - Var *varPtr, /* Reference to the variable to set. */ + register 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' @@ -1913,11 +1806,10 @@ { Interp *iPtr = (Interp *) interp; Tcl_Obj *oldValuePtr; Tcl_Obj *resultPtr = NULL; int result; - int cleanupOnEarlyError = (newValuePtr->refCount == 0); /* * If the variable is in a hashtable and its hPtr field is NULL, then we * may have an upvar to an array element where the array was deleted or an * upvar to a namespace variable whose namespace was deleted. Generate an @@ -1927,16 +1819,14 @@ if (TclIsVarDeadHash(varPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { if (TclIsVarArrayElement(varPtr)) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", - DANGLINGELEMENT, index); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ELEMENT", NULL); + danglingElement, index); } else { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", - DANGLINGVAR, index); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", NULL); + danglingVar, index); } } goto earlyError; } @@ -1944,22 +1834,21 @@ * It's an error to try to set an array variable itself. */ if (TclIsVarArray(varPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { - TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", ISARRAY,index); - Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); + TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", isArray,index); } goto earlyError; } /* * Invoke any read traces that have been set for the variable if it is * requested. This was done for INST_LAPPEND_* but that was inconsistent * with the non-bc instruction, and would cause failures trying to * lappend to any non-existing ::env var, which is inconsistent with - * documented behavior. [Bug #3057639]. + * documented behavior. [Bug #3057639] */ if ((flags & TCL_TRACE_READS) && ((varPtr->flags & VAR_TRACED_READ) || (arrayPtr && (arrayPtr->flags & VAR_TRACED_READ)))) { if (TCL_ERROR == TclObjCallVarTraces(iPtr, arrayPtr, varPtr, @@ -1979,18 +1868,65 @@ oldValuePtr = varPtr->value.objPtr; if (flags & TCL_LIST_ELEMENT && !(flags & TCL_APPEND_VALUE)) { varPtr->value.objPtr = NULL; } if (flags & (TCL_APPEND_VALUE|TCL_LIST_ELEMENT)) { +#if 0 + /* + * Can't happen now! + */ + + if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) { + TclDecrRefCount(oldValuePtr); /* Discard old value. */ + varPtr->value.objPtr = NULL; + oldValuePtr = NULL; + } +#endif if (flags & TCL_LIST_ELEMENT) { /* Append list element. */ - result = ListAppendInVar(interp, varPtr, arrayPtr, oldValuePtr, + if (oldValuePtr == NULL) { + TclNewObj(oldValuePtr); + varPtr->value.objPtr = oldValuePtr; + Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */ + } else if (Tcl_IsShared(oldValuePtr)) { + varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); + TclDecrRefCount(oldValuePtr); + oldValuePtr = varPtr->value.objPtr; + Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */ + } + result = Tcl_ListObjAppendElement(interp, oldValuePtr, newValuePtr); if (result != TCL_OK) { goto earlyError; } } else { /* Append string. */ - StringAppendInVar(varPtr, arrayPtr, oldValuePtr, newValuePtr); + /* + * We append newValuePtr's bytes but don't change its ref count. + */ + + if (oldValuePtr == NULL) { + varPtr->value.objPtr = newValuePtr; + Tcl_IncrRefCount(newValuePtr); + } else { + if (Tcl_IsShared(oldValuePtr)) { /* Append to copy. */ + varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); + + /* + * TIP #280. + * Ensure that the continuation line data for the string + * is not lost and applies to the extended script as well. + */ + TclContinuationsCopy (varPtr->value.objPtr, oldValuePtr); + + TclDecrRefCount(oldValuePtr); + oldValuePtr = varPtr->value.objPtr; + Tcl_IncrRefCount(oldValuePtr); /* Since var is ref */ + } + Tcl_AppendObjToObj(oldValuePtr, newValuePtr); + if (newValuePtr->refCount == 0) { + Tcl_DecrRefCount(newValuePtr); + } + } } } else if (newValuePtr != oldValuePtr) { /* * In this case we are replacing the value, so we don't need to do * more than swap the objects. @@ -2037,20 +1973,17 @@ * If the variable doesn't exist anymore and no-one's using it, then free * up the relevant structures and hash table entries. */ cleanup: - if (resultPtr == NULL) { - Tcl_SetErrorCode(interp, "TCL", "WRITE", "VARNAME", NULL); - } if (TclIsVarUndefined(varPtr)) { TclCleanupVar(varPtr, arrayPtr); } return resultPtr; earlyError: - if (cleanupOnEarlyError) { + if (newValuePtr->refCount == 0) { Tcl_DecrRefCount(newValuePtr); } goto cleanup; } @@ -2101,15 +2034,15 @@ Var *varPtr, *arrayPtr; varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, flags, "read", 1, 1, &arrayPtr); if (varPtr == NULL) { - Tcl_AddErrorInfo(interp, - "\n (reading value of variable to increment)"); + Tcl_AddObjErrorInfo(interp, + "\n (reading value of variable to increment)", -1); return NULL; } - return TclPtrIncrObjVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, + return TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, incrPtr, flags, -1); } /* *---------------------------------------------------------------------- @@ -2138,66 +2071,10 @@ Tcl_Obj * TclPtrIncrObjVar( Tcl_Interp *interp, /* Command interpreter in which variable is to * be found. */ - Tcl_Var varPtr, /* Reference to the variable to set. */ - Tcl_Var arrayPtr, /* Reference to the array containing the - * variable, or NULL if the variable is a - * scalar. */ - 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 *incrPtr, /* Increment value. */ -/* TODO: Which of these flag values really make sense? */ - const int flags) /* Various flags that tell how to incr value: - * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, - * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, - * TCL_LEAVE_ERR_MSG. */ -{ - if (varPtr == NULL) { - Tcl_Panic("varPtr must not be NULL"); - } - if (part1Ptr == NULL) { - Tcl_Panic("part1Ptr must not be NULL"); - } - return TclPtrIncrObjVarIdx(interp, (Var *) varPtr, (Var *) arrayPtr, - part1Ptr, part2Ptr, incrPtr, flags, -1); -} - -/* - *---------------------------------------------------------------------- - * - * TclPtrIncrObjVarIdx -- - * - * Given the pointers to a variable and possible containing array, - * increment the Tcl object value of the variable by a Tcl_Obj increment. - * - * Results: - * Returns a pointer to the Tcl_Obj holding the new value of the - * variable. If the specified variable doesn't exist, or there is a clash - * in array usage, or an error occurs while executing variable traces, - * then NULL is returned and a message will be left in the interpreter's - * result. - * - * Side effects: - * The value of the given variable is incremented by the specified - * amount. If either the array or the entry didn't exist then a new - * variable is created. The ref count for the returned object is _not_ - * incremented to reflect the returned reference; if you want to keep a - * reference to the object you must increment its ref count yourself. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclPtrIncrObjVarIdx( - Tcl_Interp *interp, /* Command interpreter in which variable is to - * be found. */ 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, /* Points to an object holding the name of an @@ -2214,51 +2091,87 @@ * 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; + register Tcl_Obj *varValuePtr; if (TclIsVarInHash(varPtr)) { VarHashRefCount(varPtr)++; } - varValuePtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr, - part2Ptr, flags, index); + varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, + flags, index); if (TclIsVarInHash(varPtr)) { VarHashRefCount(varPtr)--; } if (varValuePtr == NULL) { - TclNewIntObj(varValuePtr, 0); + varValuePtr = Tcl_NewIntObj(0); } if (Tcl_IsShared(varValuePtr)) { /* Copy on write */ varValuePtr = Tcl_DuplicateObj(varValuePtr); if (TCL_OK == TclIncrObj(interp, varValuePtr, incrPtr)) { - return TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, - part2Ptr, varValuePtr, flags, index); + return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, + varValuePtr, flags, index); } else { Tcl_DecrRefCount(varValuePtr); return NULL; } } else { /* Unshared - can Incr in place */ if (TCL_OK == TclIncrObj(interp, varValuePtr, incrPtr)) { + /* * This seems dumb to write the incremeted value into the var * after we just adjusted the value in place, but the spec for * [incr] requires that write traces fire, and making this call * is the way to make that happen. */ - return TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, - part2Ptr, varValuePtr, flags, index); + return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, 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. + * + *---------------------------------------------------------------------- + */ + +#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. */ +{ + return Tcl_UnsetVar2(interp, varName, NULL, flags); +} /* *---------------------------------------------------------------------- * * Tcl_UnsetVar2 -- @@ -2339,111 +2252,22 @@ Tcl_Obj *part2Ptr, /* Name of element within array or NULL. */ int flags) /* OR-ed combination of any of * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_LEAVE_ERR_MSG. */ { - Var *varPtr, *arrayPtr; + Var *varPtr; + Interp *iPtr = (Interp *) interp; + Var *arrayPtr; + int result; varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, flags, "unset", /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); if (varPtr == NULL) { return TCL_ERROR; } - return TclPtrUnsetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, - flags, -1); -} - -/* - *---------------------------------------------------------------------- - * - * TclPtrUnsetVar -- - * - * Delete a variable, given the pointers to the variable's (and possibly - * containing array's) VAR structure. - * - * 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 varPtr and arrayPtr indicate a local or global variable in interp, - * it is deleted. If varPtr is an array reference and part2Ptr is NULL, - * then the whole array is deleted. - * - *---------------------------------------------------------------------- - */ - -int -TclPtrUnsetVar( - Tcl_Interp *interp, /* Command interpreter in which varName is to - * be looked up. */ - Tcl_Var varPtr, /* The variable to be unset. */ - Tcl_Var arrayPtr, /* NULL for scalar variables, pointer to the - * containing array otherwise. */ - Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or - * the name of a variable. */ - Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element - * in the array part1. */ - const int flags) /* OR-ed combination of any of - * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, - * TCL_LEAVE_ERR_MSG. */ -{ - if (varPtr == NULL) { - Tcl_Panic("varPtr must not be NULL"); - } - if (part1Ptr == NULL) { - Tcl_Panic("part1Ptr must not be NULL"); - } - return TclPtrUnsetVarIdx(interp, (Var *) varPtr, (Var *) arrayPtr, - part1Ptr, part2Ptr, flags, -1); -} - -/* - *---------------------------------------------------------------------- - * - * TclPtrUnsetVarIdx -- - * - * Delete a variable, given the pointers to the variable's (and possibly - * containing array's) VAR structure. - * - * 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 varPtr and arrayPtr indicate a local or global variable in interp, - * it is deleted. If varPtr is an array reference and part2Ptr is NULL, - * then the whole array is deleted. - * - *---------------------------------------------------------------------- - */ - -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 - * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, - * TCL_LEAVE_ERR_MSG. */ - int index) /* Index into the local variable table of the - * variable, or -1. Only used when part1Ptr is - * NULL. */ -{ - Interp *iPtr = (Interp *) interp; - int result = (TclIsVarUndefined(varPtr)? TCL_ERROR : TCL_OK); + result = (TclIsVarUndefined(varPtr)? TCL_ERROR : TCL_OK); /* * Keep the variable alive until we're done with it. We used to * increase/decrease the refCount for each operation, making it hard to * find [Bug 735335] - caused by unsetting the variable whose value was @@ -2452,23 +2276,35 @@ if (TclIsVarInHash(varPtr)) { VarHashRefCount(varPtr)++; } - UnsetVarStruct(varPtr, arrayPtr, iPtr, part1Ptr, part2Ptr, flags, index); + UnsetVarStruct(varPtr, arrayPtr, iPtr, part1Ptr, part2Ptr, flags); /* * It's an error to unset an undefined variable. */ if (result != TCL_OK) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset", - ((arrayPtr == NULL) ? NOSUCHVAR : NOSUCHELEMENT), index); - Tcl_SetErrorCode(interp, "TCL", "UNSET", "VARNAME", NULL); + ((arrayPtr == NULL) ? noSuchVar : noSuchElement), -1); } } + +#if ENABLE_NS_VARNAME_CACHING + /* + * Try to avoid keeping the Var struct allocated due to a tclNsVarNameType + * keeping a reference. This removes some additional exteriorisations of + * [Bug 736729], but may be a good thing independently of the bug. + */ + + if (part1Ptr->typePtr == &tclNsVarNameType) { + TclFreeIntRep(part1Ptr); + part1Ptr->typePtr = NULL; + } +#endif /* * Finally, if the variable is truly not in use then free up its Var * structure and remove it from its hash table, if any. The ref count of * its value object, if any, was decremented above. @@ -2505,12 +2341,11 @@ Var *varPtr, Var *arrayPtr, Interp *iPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - int flags, - int index) + int flags) { Var dummyVar; int traced = TclIsVarTraced(varPtr) || (arrayPtr && (arrayPtr->flags & VAR_TRACED_UNSET)); @@ -2546,51 +2381,56 @@ * unset traces even if other traces are pending. */ if (traced) { VarTrace *tracePtr = NULL; - Tcl_HashEntry *tPtr; if (TclIsVarTraced(&dummyVar)) { /* * Transfer any existing traces on var, IF there are unset traces. * Otherwise just delete them. */ int isNew; + Tcl_HashEntry *tPtr = + Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr); - tPtr = Tcl_FindHashEntry(&iPtr->varTraces, varPtr); - tracePtr = (VarTrace *)Tcl_GetHashValue(tPtr); + tracePtr = Tcl_GetHashValue(tPtr); varPtr->flags &= ~VAR_ALL_TRACES; Tcl_DeleteHashEntry(tPtr); if (dummyVar.flags & VAR_TRACED_UNSET) { tPtr = Tcl_CreateHashEntry(&iPtr->varTraces, - &dummyVar, &isNew); + (char *) &dummyVar, &isNew); Tcl_SetHashValue(tPtr, tracePtr); + } else { + tPtr = NULL; } } if ((dummyVar.flags & VAR_TRACED_UNSET) || (arrayPtr && (arrayPtr->flags & VAR_TRACED_UNSET))) { + Tcl_HashEntry *tPtr = NULL; + dummyVar.flags &= ~VAR_TRACE_ACTIVE; TclObjCallVarTraces(iPtr, arrayPtr, &dummyVar, part1Ptr, part2Ptr, (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS, - /* leaveErrMsg */ 0, index); + /* leaveErrMsg */ 0, -1); /* * The traces that we just called may have triggered a change in - * the set of traces. If so, reload the traces to manipulate. + * the set of traces. [Bug 2629338] */ tracePtr = NULL; if (TclIsVarTraced(&dummyVar)) { - tPtr = Tcl_FindHashEntry(&iPtr->varTraces, &dummyVar); - if (tPtr) { - tracePtr = (VarTrace *)Tcl_GetHashValue(tPtr); - Tcl_DeleteHashEntry(tPtr); - } + tPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) &dummyVar); + tracePtr = Tcl_GetHashValue(tPtr); + } + + if (tPtr) { + Tcl_DeleteHashEntry(tPtr); } } if (tracePtr) { ActiveVarTrace *activePtr; @@ -2598,11 +2438,11 @@ while (tracePtr) { VarTrace *prevPtr = tracePtr; tracePtr = tracePtr->nextPtr; prevPtr->nextPtr = NULL; - Tcl_EventuallyFree(prevPtr, TCL_DYNAMIC); + Tcl_EventuallyFree((ClientData) prevPtr, TCL_DYNAMIC); } for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { if (activePtr->varPtr == varPtr) { activePtr->nextTracePtr = NULL; @@ -2628,12 +2468,11 @@ * present and is required for a trace on some element, it will be * computed at DeleteArray. */ DeleteArray(iPtr, part1Ptr, (Var *) &dummyVar, (flags - & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS, - index); + & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS); } else if (TclIsVarLink(&dummyVar)) { /* * For global/upvar variables referenced in procedures, decrement the * reference count on the variable referred to, and free the * referenced variable if it's no longer needed. @@ -2670,19 +2509,20 @@ * See the user documentation. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_UnsetObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ 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; + register int i, flags = TCL_LEAVE_ERR_MSG; + register char *name; if (objc == 1) { /* * Do nothing if no arguments supplied, so as to match command * documentation. @@ -2737,47 +2577,49 @@ * A variable's value may be changed. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_AppendObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Var *varPtr, *arrayPtr; - Tcl_Obj *varValuePtr = NULL; + register Tcl_Obj *varValuePtr = NULL; /* Initialized to avoid compiler warning. */ - int i; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "varName ?value ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?"); return TCL_ERROR; } if (objc == 2) { varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL,TCL_LEAVE_ERR_MSG); if (varValuePtr == NULL) { return TCL_ERROR; } } else { + Var *arrayPtr, *varPtr; + int i; + varPtr = TclObjLookupVarEx(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG, "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { return TCL_ERROR; } for (i=2 ; iemptyObjPtr)) { return TCL_ERROR; } @@ -2802,24 +2644,24 @@ * A variable's value may be changed. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_LappendObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ 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; + int numElems; int result; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "varName ?value ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?"); return TCL_ERROR; } if (objc == 2) { newValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0); if (newValuePtr == NULL) { @@ -2839,10 +2681,13 @@ if (result != TCL_OK) { return result; } } } else { + Var *varPtr, *arrayPtr; + int createdNewObj = 0; + /* * We have arguments to append. We used to call Tcl_SetVar2 to append * each argument one at a time to ensure that traces were run for each * append step. We now append the arguments all at once because it's * faster. Note that a read trace and a write trace for the variable @@ -2849,14 +2694,12 @@ * will now each only be called once. Also, if the variable's old * value is unshared we modify it directly, otherwise we create a new * copy to modify: this is "copy on write". */ - createdNewObj = 0; - /* - * Protect the variable pointers around the TclPtrGetVarIdx call + * Protect the variable pointers around the TclPtrGetVar call * to insure that they remain valid even if the variable was undefined * and unused. */ varPtr = TclObjLookupVarEx(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG, @@ -2868,11 +2711,11 @@ VarHashRefCount(varPtr)++; } if (arrayPtr && TclIsVarInHash(arrayPtr)) { VarHashRefCount(arrayPtr)++; } - varValuePtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, objv[1], NULL, + varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, objv[1], NULL, TCL_LEAVE_ERR_MSG, -1); if (TclIsVarInHash(varPtr)) { VarHashRefCount(varPtr)--; } if (arrayPtr && TclIsVarInHash(arrayPtr)) { @@ -2909,11 +2752,11 @@ * Now store the list object back into the variable. If there is an * error setting the new value, decrement its ref count if it was new * and we didn't create the variable. */ - newValuePtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, objv[1], NULL, + newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, objv[1], NULL, varValuePtr, TCL_LEAVE_ERR_MSG, -1); if (newValuePtr == NULL) { return TCL_ERROR; } } @@ -2928,671 +2771,13 @@ } /* *---------------------------------------------------------------------- * - * ArrayForObjCmd, ArrayForNRCmd, ArrayForLoopCallback, ArrayObjNext -- - * - * These functions implement the "array for" Tcl command. - * array for {k v} a {} - * The array for command iterates over the array, setting the the - * specified loop variables, and executing the body each iteration. - * - * ArrayForObjCmd() is the standard wrapper around ArrayForNRCmd(). - * - * ArrayForNRCmd() sets up the ArraySearch structure, sets arrayNamePtr - * inside the structure and calls VarHashFirstEntry to start the hash - * iteration. - * - * ArrayForNRCmd() does not execute the body or set the loop variables, - * it only initializes the iterator. - * - * ArrayForLoopCallback() iterates over the entire array, executing the - * body each time. - * - *---------------------------------------------------------------------- - */ - -static int -ArrayObjNext( - Tcl_Interp *interp, - Tcl_Obj *arrayNameObj, /* array */ - Var *varPtr, /* array */ - ArraySearch *searchPtr, - Tcl_Obj **keyPtrPtr, /* Pointer to a variable to have the key - * written into, or NULL. */ - Tcl_Obj **valuePtrPtr) /* Pointer to a variable to have the - * value written into, or NULL.*/ -{ - Tcl_Obj *keyObj; - Tcl_Obj *valueObj = NULL; - int gotValue; - int donerc; - - donerc = TCL_BREAK; - - if ((varPtr->flags & VAR_SEARCH_ACTIVE) != VAR_SEARCH_ACTIVE) { - donerc = TCL_ERROR; - return donerc; - } - - gotValue = 0; - while (1) { - Tcl_HashEntry *hPtr = searchPtr->nextEntry; - - if (hPtr != NULL) { - searchPtr->nextEntry = NULL; - } else { - hPtr = Tcl_NextHashEntry(&searchPtr->search); - if (hPtr == NULL) { - gotValue = 0; - break; - } - } - varPtr = VarHashGetValue(hPtr); - if (!TclIsVarUndefined(varPtr)) { - gotValue = 1; - break; - } - } - - if (!gotValue) { - return donerc; - } - - donerc = TCL_CONTINUE; - - keyObj = VarHashGetKey(varPtr); - *keyPtrPtr = keyObj; - valueObj = Tcl_ObjGetVar2(interp, arrayNameObj, keyObj, - TCL_LEAVE_ERR_MSG); - *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; - int isArray, numVars; - - /* - * array for {k v} a body - */ - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "{key value} arrayName script"); - return TCL_ERROR; - } - - /* - * Parse arguments. - */ - - if (Tcl_ListObjLength(interp, objv[1], &numVars) != TCL_OK) { - return TCL_ERROR; - } - - if (numVars != 2) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "must have two variable names", -1)); - Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "array", "for", NULL); - return TCL_ERROR; - } - - arrayNameObj = objv[2]; - - if (TCL_ERROR == LocateArray(interp, arrayNameObj, &varPtr, &isArray)) { - return TCL_ERROR; - } - - if (!isArray) { - return NotArrayError(interp, arrayNameObj); - } - - /* - * Make a new array search, put it on the stack. - */ - - searchPtr = (ArraySearch *)Tcl_Alloc(sizeof(ArraySearch)); - ArrayPopulateSearch(interp, arrayNameObj, varPtr, searchPtr); - - /* - * Make sure that these objects (which we need throughout the body of the - * loop) don't vanish. - */ - - varListObj = TclListObjCopy(NULL, objv[1]); - scriptObj = objv[3]; - Tcl_IncrRefCount(scriptObj); - - /* - * Run the script. - */ - - TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, varListObj, - arrayNameObj, scriptObj); - return TCL_OK; -} - -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; - - /* - * Process the result from the previous execution of the script body. - */ - - done = TCL_ERROR; - - if (result == TCL_CONTINUE) { - result = TCL_OK; - } else if (result != TCL_OK) { - if (result == TCL_BREAK) { - Tcl_ResetResult(interp); - result = TCL_OK; - } else if (result == TCL_ERROR) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"array for\" body line %d)", - Tcl_GetErrorLine(interp))); - } - goto arrayfordone; - } - - /* - * Get the next mapping from the array. - */ - - keyObj = NULL; - valueObj = NULL; - varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - if (varPtr == NULL) { - done = TCL_ERROR; - } else { - done = ArrayObjNext(interp, arrayNameObj, varPtr, searchPtr, &keyObj, - &valueObj); - } - - result = TCL_OK; - if (done != TCL_CONTINUE) { - Tcl_ResetResult(interp); - if (done == TCL_ERROR) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "array changed during iteration", -1)); - Tcl_SetErrorCode(interp, "TCL", "READ", "array", "for", NULL); - varPtr->flags |= TCL_LEAVE_ERR_MSG; - result = done; - } - goto arrayfordone; - } - - Tcl_ListObjGetElements(NULL, varListObj, &varc, &varv); - if (Tcl_ObjSetVar2(interp, varv[0], NULL, keyObj, - TCL_LEAVE_ERR_MSG) == NULL) { - result = TCL_ERROR; - goto arrayfordone; - } - if (valueObj != NULL) { - if (Tcl_ObjSetVar2(interp, varv[1], NULL, valueObj, - TCL_LEAVE_ERR_MSG) == NULL) { - result = TCL_ERROR; - goto arrayfordone; - } - } - - /* - * Run the script. - */ - - TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, varListObj, - arrayNameObj, scriptObj); - return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3); - - /* - * For unwinding everything once the iterating is done. - */ - - arrayfordone: - if (done != TCL_ERROR) { - /* - * 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); - Tcl_Free(searchPtr); - } - - TclDecrRefCount(varListObj); - TclDecrRefCount(scriptObj); - return result; -} - -/* - * ArrayPopulateSearch - */ - -static void -ArrayPopulateSearch( - Tcl_Interp *interp, - Tcl_Obj *arrayNameObj, - Var *varPtr, - ArraySearch *searchPtr) -{ - Interp *iPtr = (Interp *) interp; - Tcl_HashEntry *hPtr; - int isNew; - - 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)); - Tcl_IncrRefCount(searchPtr->name); -} -/* - *---------------------------------------------------------------------- - * - * ArrayStartSearchCmd -- - * - * This object-based function is invoked to process the "array - * startsearch" 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 -ArrayStartSearchCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Var *varPtr; - int isArray; - ArraySearch *searchPtr; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); - return TCL_ERROR; - } - - if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr, &isArray)) { - return TCL_ERROR; - } - - if (!isArray) { - return NotArrayError(interp, objv[1]); - } - - /* - * Make a new array search with a free name. - */ - - searchPtr = (ArraySearch *)Tcl_Alloc(sizeof(ArraySearch)); - ArrayPopulateSearch(interp, objv[1], varPtr, searchPtr); - Tcl_SetObjResult(interp, searchPtr->name); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ArrayDoneSearch -- - * - * Removes the search from the hash of active searches. - * - *---------------------------------------------------------------------- - */ -static void -ArrayDoneSearch( - Interp *iPtr, - Var *varPtr, - ArraySearch *searchPtr) -{ - Tcl_HashEntry *hPtr; - ArraySearch *prevPtr; - - /* - * Unhook the search from the list of searches associated with the - * variable. - */ - - hPtr = Tcl_FindHashEntry(&iPtr->varSearches, varPtr); - if (hPtr == NULL) { - return; - } - if (searchPtr == Tcl_GetHashValue(hPtr)) { - 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; - } - } - } -} - -/* - *---------------------------------------------------------------------- - * - * ArrayAnyMoreCmd -- - * - * This object-based function is invoked to process the "array anymore" - * 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 -ArrayAnyMoreCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Interp *iPtr = (Interp *) interp; - Var *varPtr; - Tcl_Obj *varNameObj, *searchObj; - int gotValue, isArray; - ArraySearch *searchPtr; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId"); - return TCL_ERROR; - } - varNameObj = objv[1]; - searchObj = objv[2]; - - if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) { - return TCL_ERROR; - } - - if (!isArray) { - return NotArrayError(interp, varNameObj); - } - - /* - * Get the search. - */ - - searchPtr = ParseSearchId(interp, varPtr, varNameObj, searchObj); - if (searchPtr == NULL) { - return TCL_ERROR; - } - - /* - * Scan forward to find if there are any further elements in the array - * that are defined. - */ - - while (1) { - if (searchPtr->nextEntry != NULL) { - varPtr = VarHashGetValue(searchPtr->nextEntry); - if (!TclIsVarUndefined(varPtr)) { - gotValue = 1; - break; - } - } - searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search); - if (searchPtr->nextEntry == NULL) { - gotValue = 0; - break; - } - } - Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[gotValue]); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ArrayNextElementCmd -- - * - * This object-based function is invoked to process the "array - * nextelement" 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 -ArrayNextElementCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Var *varPtr; - Tcl_Obj *varNameObj, *searchObj; - ArraySearch *searchPtr; - int isArray; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId"); - return TCL_ERROR; - } - varNameObj = objv[1]; - searchObj = objv[2]; - - if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) { - return TCL_ERROR; - } - - if (!isArray) { - return NotArrayError(interp, varNameObj); - } - - /* - * Get the search. - */ - - searchPtr = ParseSearchId(interp, varPtr, varNameObj, searchObj); - if (searchPtr == NULL) { - return TCL_ERROR; - } - - /* - * Get the next element from the search, or the empty string on - * exhaustion. Note that the [array anymore] command may well have already - * pulled a value from the hash enumeration, so we have to check the cache - * there first. - */ - - while (1) { - Tcl_HashEntry *hPtr = searchPtr->nextEntry; - - if (hPtr == NULL) { - hPtr = Tcl_NextHashEntry(&searchPtr->search); - if (hPtr == NULL) { - return TCL_OK; - } - } else { - searchPtr->nextEntry = NULL; - } - varPtr = VarHashGetValue(hPtr); - if (!TclIsVarUndefined(varPtr)) { - Tcl_SetObjResult(interp, VarHashGetKey(varPtr)); - return TCL_OK; - } - } -} - -/* - *---------------------------------------------------------------------- - * - * ArrayDoneSearchCmd -- - * - * This object-based function is invoked to process the "array - * donesearch" 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 -ArrayDoneSearchCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Interp *iPtr = (Interp *) interp; - Var *varPtr; - Tcl_Obj *varNameObj, *searchObj; - ArraySearch *searchPtr; - int isArray; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId"); - return TCL_ERROR; - } - varNameObj = objv[1]; - searchObj = objv[2]; - - if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) { - return TCL_ERROR; - } - - if (!isArray) { - return NotArrayError(interp, varNameObj); - } - - /* - * Get the search. - */ - - searchPtr = ParseSearchId(interp, varPtr, varNameObj, searchObj); - if (searchPtr == NULL) { - return TCL_ERROR; - } - - ArrayDoneSearch(iPtr, varPtr, searchPtr); - Tcl_DecrRefCount(searchPtr->name); - Tcl_Free(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; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); - return TCL_ERROR; - } - - if (TCL_ERROR == LocateArray(interp, objv[1], NULL, &isArray)) { - return TCL_ERROR; - } - - Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[isArray]); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ArrayGetCmd -- - * - * This object-based function is invoked to process the "array get" Tcl + * Tcl_ArrayObjCmd -- + * + * This object-based function is invoked to process the "array" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl result object. * @@ -3600,378 +2785,635 @@ * 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; - Tcl_HashSearch search; - const char *pattern; - int i, count, result, isArray; - - switch (objc) { - case 2: - varNameObj = objv[1]; - patternObj = NULL; - break; - case 3: - varNameObj = objv[1]; - patternObj = objv[2]; - break; - default: - Tcl_WrongNumArgs(interp, 1, objv, "arrayName ?pattern?"); - return TCL_ERROR; - } - - if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) { - return TCL_ERROR; - } - - /* If not an array, it's an empty result. */ - if (!isArray) { - return TCL_OK; - } - - pattern = (patternObj ? TclGetString(patternObj) : NULL); - - /* - * Store the array names in a new object. - */ - - TclNewObj(nameLstObj); - Tcl_IncrRefCount(nameLstObj); - if ((patternObj != NULL) && TclMatchIsTrivial(pattern)) { - varPtr2 = VarHashFindVar(varPtr->value.tablePtr, patternObj); - if (varPtr2 == NULL) { - goto searchDone; - } - if (TclIsVarUndefined(varPtr2)) { - goto searchDone; - } - result = Tcl_ListObjAppendElement(interp, nameLstObj, - VarHashGetKey(varPtr2)); - if (result != TCL_OK) { - TclDecrRefCount(nameLstObj); - return result; - } - goto searchDone; - } - - for (varPtr2 = VarHashFirstVar(varPtr->value.tablePtr, &search); - varPtr2; varPtr2 = VarHashNextVar(&search)) { - if (TclIsVarUndefined(varPtr2)) { - continue; - } - nameObj = VarHashGetKey(varPtr2); - if (patternObj && !Tcl_StringMatch(TclGetString(nameObj), pattern)) { - continue; /* Element name doesn't match pattern. */ - } - - result = Tcl_ListObjAppendElement(interp, nameLstObj, nameObj); - if (result != TCL_OK) { - TclDecrRefCount(nameLstObj); - return result; - } - } - - /* - * Make sure the Var structure of the array is not removed by a trace - * while we're working. - */ - - searchDone: - if (TclIsVarInHash(varPtr)) { - VarHashRefCount(varPtr)++; - } - - /* - * Get the array values corresponding to each element name. - */ - - TclNewObj(tmpResObj); - result = Tcl_ListObjGetElements(interp, nameLstObj, &count, &nameObjPtr); - if (result != TCL_OK) { - goto errorInArrayGet; - } - - for (i=0 ; i 4)) { - Tcl_WrongNumArgs(interp, 1, objv, "arrayName ?mode? ?pattern?"); - return TCL_ERROR; - } - patternObj = (objc > 2 ? objv[objc-1] : NULL); - - if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr, &isArray)) { - return TCL_ERROR; - } - - /* - * Finish parsing the arguments. - */ - - if ((objc == 4) && Tcl_GetIndexFromObj(interp, objv[2], options, "option", - 0, &mode) != TCL_OK) { - return TCL_ERROR; - } - - /* If not an array, the result is empty. */ - - if (!isArray) { - return TCL_OK; - } - - /* - * Check for the trivial cases where we can use a direct lookup. - */ - - TclNewObj(resultObj); - if (patternObj) { - pattern = TclGetString(patternObj); - } - if ((mode==OPT_GLOB && patternObj && TclMatchIsTrivial(pattern)) - || (mode==OPT_EXACT)) { - varPtr2 = VarHashFindVar(varPtr->value.tablePtr, patternObj); - if ((varPtr2 != NULL) && !TclIsVarUndefined(varPtr2)) { - /* - * This can't fail; lappending to an empty object always works. - */ - - Tcl_ListObjAppendElement(NULL, resultObj, VarHashGetKey(varPtr2)); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; - } - - /* - * Must scan the array to select the elements. - */ - - for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search); - varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) { - if (TclIsVarUndefined(varPtr2)) { - continue; - } - nameObj = VarHashGetKey(varPtr2); - if (patternObj) { - const char *name = TclGetString(nameObj); - int matched = 0; - - switch ((enum arrayNamesOptionsEnum) mode) { - case OPT_EXACT: - Tcl_Panic("exact matching shouldn't get here"); - case OPT_GLOB: - matched = Tcl_StringMatch(name, pattern); - break; - case OPT_REGEXP: - matched = Tcl_RegExpMatchObj(interp, nameObj, patternObj); - if (matched < 0) { - TclDecrRefCount(resultObj); - return TCL_ERROR; - } - break; - } - if (matched == 0) { - continue; - } - } - - Tcl_ListObjAppendElement(NULL, resultObj, nameObj); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclFindArrayPtrElements -- - * - * Fill out a hash table (which *must* use Tcl_Obj* keys) with an entry - * for each existing element of the given array. The provided hash table - * is assumed to be initially empty. - * - * Result: - * none - * - * Side effects: - * The keys of the array gain an extra reference. The supplied hash table - * has elements added to it. - * - *---------------------------------------------------------------------- - */ - -void -TclFindArrayPtrElements( - Var *arrayPtr, - Tcl_HashTable *tablePtr) -{ - Var *varPtr; - Tcl_HashSearch search; - - if ((arrayPtr == NULL) || !TclIsVarArray(arrayPtr) - || TclIsVarUndefined(arrayPtr)) { - return; - } - - for (varPtr=VarHashFirstVar(arrayPtr->value.tablePtr, &search); - varPtr!=NULL ; varPtr=VarHashNextVar(&search)) { - Tcl_HashEntry *hPtr; - Tcl_Obj *nameObj; - int dummy; - - if (TclIsVarUndefined(varPtr)) { - continue; - } - nameObj = VarHashGetKey(varPtr); - hPtr = Tcl_CreateHashEntry(tablePtr, (char *) nameObj, &dummy); - Tcl_SetHashValue(hPtr, nameObj); - } -} - -/* - *---------------------------------------------------------------------- - * - * ArraySetCmd -- - * - * This object-based function is invoked to process the "array set" 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 -ArraySetCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Obj *arrayNameObj; - Tcl_Obj *arrayElemObj; - Var *varPtr, *arrayPtr; - int result, i; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "arrayName list"); - return TCL_ERROR; - } - - if (TCL_ERROR == LocateArray(interp, objv[1], NULL, NULL)) { - return TCL_ERROR; - } - - arrayNameObj = objv[1]; + /* ARGSUSED */ +int +Tcl_ArrayObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + /* + * The list of constants below should match the arrayOptions string array + * below. + */ + + enum { + ARRAY_ANYMORE, ARRAY_DONESEARCH, ARRAY_EXISTS, ARRAY_GET, + ARRAY_NAMES, ARRAY_NEXTELEMENT, ARRAY_SET, ARRAY_SIZE, + ARRAY_STARTSEARCH, ARRAY_STATISTICS, ARRAY_UNSET + }; + static const char *arrayOptions[] = { + "anymore", "donesearch", "exists", "get", "names", "nextelement", + "set", "size", "startsearch", "statistics", "unset", NULL + }; + + Interp *iPtr = (Interp *) interp; + Var *varPtr, *arrayPtr; + Tcl_HashEntry *hPtr; + Tcl_Obj *varNamePtr; + int notArray; + int index, result; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "option arrayName ?arg ...?"); + return TCL_ERROR; + } + + if (Tcl_GetIndexFromObj(interp, objv[1], arrayOptions, "option", + 0, &index) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Locate the array variable + */ + + varNamePtr = objv[2]; + varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, /*flags*/ 0, + /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + + /* + * Special array trace used to keep the env array in sync for array names, + * array get, etc. + */ + + if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) + && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { + if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNamePtr, NULL, + (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| + TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { + return TCL_ERROR; + } + } + + /* + * Verify that it is indeed an array variable. This test comes after the + * traces - the variable may actually become an array as an effect of said + * traces. + */ + + notArray = 0; + if ((varPtr == NULL) || !TclIsVarArray(varPtr) + || TclIsVarUndefined(varPtr)) { + notArray = 1; + } + + switch (index) { + case ARRAY_ANYMORE: { + ArraySearch *searchPtr; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId"); + return TCL_ERROR; + } + if (notArray) { + goto error; + } + searchPtr = ParseSearchId(interp, varPtr, varNamePtr, objv[3]); + if (searchPtr == NULL) { + return TCL_ERROR; + } + while (1) { + if (searchPtr->nextEntry != NULL) { + Var *varPtr2 = VarHashGetValue(searchPtr->nextEntry); + if (!TclIsVarUndefined(varPtr2)) { + break; + } + } + searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search); + if (searchPtr->nextEntry == NULL) { + Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[0]); + return TCL_OK; + } + } + Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[1]); + break; + } + case ARRAY_DONESEARCH: { + ArraySearch *searchPtr, *prevPtr; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId"); + return TCL_ERROR; + } + if (notArray) { + goto error; + } + searchPtr = ParseSearchId(interp, varPtr, varNamePtr, objv[3]); + if (searchPtr == NULL) { + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&iPtr->varSearches,(char *) varPtr); + if (searchPtr == Tcl_GetHashValue(hPtr)) { + if (searchPtr->nextPtr) { + Tcl_SetHashValue(hPtr, searchPtr->nextPtr); + } else { + varPtr->flags &= ~VAR_SEARCH_ACTIVE; + Tcl_DeleteHashEntry(hPtr); + } + } else { + for (prevPtr=Tcl_GetHashValue(hPtr) ;; prevPtr=prevPtr->nextPtr) { + if (prevPtr->nextPtr == searchPtr) { + prevPtr->nextPtr = searchPtr->nextPtr; + break; + } + } + } + ckfree((char *) searchPtr); + break; + } + case ARRAY_NEXTELEMENT: { + ArraySearch *searchPtr; + Tcl_HashEntry *hPtr; + Var *varPtr2; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId"); + return TCL_ERROR; + } + if (notArray) { + goto error; + } + searchPtr = ParseSearchId(interp, varPtr, varNamePtr, objv[3]); + if (searchPtr == NULL) { + return TCL_ERROR; + } + while (1) { + hPtr = searchPtr->nextEntry; + if (hPtr == NULL) { + hPtr = Tcl_NextHashEntry(&searchPtr->search); + if (hPtr == NULL) { + return TCL_OK; + } + } else { + searchPtr->nextEntry = NULL; + } + varPtr2 = VarHashGetValue(hPtr); + if (!TclIsVarUndefined(varPtr2)) { + break; + } + } + Tcl_SetObjResult(interp, VarHashGetKey(varPtr2)); + break; + } + case ARRAY_STARTSEARCH: { + ArraySearch *searchPtr; + int isNew; + char *varName = TclGetString(varNamePtr); + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); + return TCL_ERROR; + } + if (notArray) { + goto error; + } + searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch)); + hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, + (char *) varPtr, &isNew); + if (isNew) { + searchPtr->id = 1; + Tcl_AppendResult(interp, "s-1-", varName, NULL); + varPtr->flags |= VAR_SEARCH_ACTIVE; + searchPtr->nextPtr = NULL; + } else { + char string[TCL_INTEGER_SPACE]; + + searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1; + TclFormatInt(string, searchPtr->id); + Tcl_AppendResult(interp, "s-", string, "-", varName, NULL); + searchPtr->nextPtr = Tcl_GetHashValue(hPtr); + } + searchPtr->varPtr = varPtr; + searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr, + &searchPtr->search); + Tcl_SetHashValue(hPtr, searchPtr); + break; + } + + case ARRAY_EXISTS: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[!notArray]); + break; + case ARRAY_GET: { + Tcl_HashSearch search; + Var *varPtr2; + char *pattern = NULL; + char *name; + Tcl_Obj *namePtr, *valuePtr, *nameLstPtr, *tmpResPtr, **namePtrPtr; + int i, count; + + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?"); + return TCL_ERROR; + } + if (notArray) { + return TCL_OK; + } + if (objc == 4) { + pattern = TclGetString(objv[3]); + } + + /* + * Store the array names in a new object. + */ + + TclNewObj(nameLstPtr); + Tcl_IncrRefCount(nameLstPtr); + if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { + varPtr2 = VarHashFindVar(varPtr->value.tablePtr, objv[3]); + if (varPtr2 == NULL) { + goto searchDone; + } + if (TclIsVarUndefined(varPtr2)) { + goto searchDone; + } + result = Tcl_ListObjAppendElement(interp, nameLstPtr, + VarHashGetKey(varPtr2)); + if (result != TCL_OK) { + TclDecrRefCount(nameLstPtr); + return result; + } + goto searchDone; + } + for (varPtr2 = VarHashFirstVar(varPtr->value.tablePtr, &search); + varPtr2; varPtr2 = VarHashNextVar(&search)) { + if (TclIsVarUndefined(varPtr2)) { + continue; + } + namePtr = VarHashGetKey(varPtr2); + name = TclGetString(namePtr); + if ((objc == 4) && !Tcl_StringMatch(name, pattern)) { + continue; /* Element name doesn't match pattern. */ + } + + result = Tcl_ListObjAppendElement(interp, nameLstPtr, namePtr); + if (result != TCL_OK) { + TclDecrRefCount(nameLstPtr); + return result; + } + } + + searchDone: + /* + * Make sure the Var structure of the array is not removed by a trace + * while we're working. + */ + + if (TclIsVarInHash(varPtr)) { + VarHashRefCount(varPtr)++; + } + + /* + * Get the array values corresponding to each element name. + */ + + TclNewObj(tmpResPtr); + result = Tcl_ListObjGetElements(interp, nameLstPtr, &count, + &namePtrPtr); + if (result != TCL_OK) { + goto errorInArrayGet; + } + + for (i=0 ; i 5)) { + Tcl_WrongNumArgs(interp, 2,objv, "arrayName ?mode? ?pattern?"); + return TCL_ERROR; + } + if (notArray) { + return TCL_OK; + } + if (objc == 4) { + patternPtr = objv[3]; + pattern = TclGetString(patternPtr); + } else if (objc == 5) { + patternPtr = objv[4]; + pattern = TclGetString(patternPtr); + if (Tcl_GetIndexFromObj(interp, objv[3], options, "option", 0, + &mode) != TCL_OK) { + return TCL_ERROR; + } + } else { + patternPtr = NULL; + pattern = NULL; + } + TclNewObj(resultPtr); + if (((enum options) mode)==OPT_GLOB && pattern!=NULL && + TclMatchIsTrivial(pattern)) { + varPtr2 = VarHashFindVar(varPtr->value.tablePtr, patternPtr); + if ((varPtr2 != NULL) && !TclIsVarUndefined(varPtr2)) { + result = Tcl_ListObjAppendElement(interp, resultPtr, + VarHashGetKey(varPtr2)); + if (result != TCL_OK) { + TclDecrRefCount(resultPtr); + return result; + } + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search); + varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) { + if (TclIsVarUndefined(varPtr2)) { + continue; + } + namePtr = VarHashGetKey(varPtr2); + name = TclGetString(namePtr); + if (objc > 3) { + switch ((enum options) mode) { + case OPT_EXACT: + matched = (strcmp(name, pattern) == 0); + break; + case OPT_GLOB: + matched = Tcl_StringMatch(name, pattern); + break; + case OPT_REGEXP: + matched = Tcl_RegExpMatch(interp, name, pattern); + if (matched < 0) { + TclDecrRefCount(resultPtr); + return TCL_ERROR; + } + break; + } + if (matched == 0) { + continue; + } + } + + result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr); + if (result != TCL_OK) { + TclDecrRefCount(namePtr); /* Free unneeded name obj. */ + return result; + } + } + Tcl_SetObjResult(interp, resultPtr); + break; + } + case ARRAY_SET: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName list"); + return TCL_ERROR; + } + return TclArraySet(interp, objv[2], objv[3]); + case ARRAY_UNSET: + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?"); + return TCL_ERROR; + } + if (notArray) { + return TCL_OK; + } + if (objc == 3) { + /* + * When no pattern is given, just unset the whole array. + */ + + return TclObjUnsetVar2(interp, varNamePtr, NULL, 0); + } else { + Tcl_HashSearch search; + Var *varPtr2, *protectedVarPtr; + const char *pattern = TclGetString(objv[3]); + + /* + * With a trivial pattern, we can just unset. + */ + + if (TclMatchIsTrivial(pattern)) { + varPtr2 = VarHashFindVar(varPtr->value.tablePtr, objv[3]); + if (varPtr2 != NULL && !TclIsVarUndefined(varPtr2)) { + return TclObjUnsetVar2(interp, varNamePtr, objv[3], 0); + } + return TCL_OK; + } + + /* + * Non-trivial case (well, deeply tricky really). We peek inside + * the hash iterator in order to allow us to guarantee that the + * following element in the array will not be scrubbed until we + * have dealt with it. This stops the overall iterator from ending + * up pointing into deallocated memory. [Bug 2939073] + */ + + protectedVarPtr = NULL; + for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search); + varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) { + /* + * Drop the extra ref immediately. We don't need to free it at + * this point though; we'll be unsetting it if necessary soon. + */ + + if (varPtr2 == protectedVarPtr) { + VarHashRefCount(varPtr2)--; + } + + /* + * Guard the next item in the search chain by incrementing its + * refcount. This guarantees that the hash table iterator + * won't be dangling on the next time through the loop. + */ + + if (search.nextEntryPtr != NULL) { + protectedVarPtr = VarHashGetValue(search.nextEntryPtr); + VarHashRefCount(protectedVarPtr)++; + } else { + protectedVarPtr = NULL; + } + + if (!TclIsVarUndefined(varPtr2)) { + Tcl_Obj *namePtr = VarHashGetKey(varPtr2); + + if (Tcl_StringMatch(TclGetString(namePtr), pattern) + && TclObjUnsetVar2(interp, varNamePtr, namePtr, + 0) != TCL_OK) { + /* + * If we incremented a refcount, we must decrement it + * here as we will not be coming back properly due to + * the error. + */ + + if (protectedVarPtr) { + VarHashRefCount(protectedVarPtr)--; + CleanupVar(protectedVarPtr, varPtr); + } + return TCL_ERROR; + } + } else { + CleanupVar(varPtr2, varPtr); + } + } + break; + } + + case ARRAY_SIZE: { + Tcl_HashSearch search; + int size; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); + return TCL_ERROR; + } + size = 0; + + /* + * Must iterate in order to get chance to check for present but + * "undefined" entries. + */ + + if (!notArray) { + Var *varPtr2; + + for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search); + varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) { + if (TclIsVarUndefined(varPtr2)) { + continue; + } + size++; + } + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(size)); + break; + } + + case ARRAY_STATISTICS: { + const char *stats; + + if (notArray) { + goto error; + } + + stats = Tcl_HashStats((Tcl_HashTable *) varPtr->value.tablePtr); + if (stats != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj(stats, -1)); + ckfree((void *)stats); + } else { + Tcl_SetResult(interp,"error reading array statistics",TCL_STATIC); + return TCL_ERROR; + } + break; + } + } + return TCL_OK; + + error: + Tcl_AppendResult(interp, "\"", TclGetString(varNamePtr), + "\" isn't an array", NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * TclArraySet -- + * + * Set the elements of an array. If there are no elements to set, create + * an empty array. This routine is used by the Tcl_ArrayObjCmd and by the + * TclSetupEnv routine. + * + * Results: + * A standard Tcl result object. + * + * Side effects: + * A variable will be created if one does not already exist. + * Callers must Incr arrayNameObj if they pland to Decr it. + * + *---------------------------------------------------------------------- + */ + +int +TclArraySet( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Obj *arrayNameObj, /* The array name. */ + Tcl_Obj *arrayElemObj) /* The array elements list or dict. If this is + * NULL, create an empty array. */ +{ + Var *varPtr, *arrayPtr; + int result, i; + varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { return TCL_ERROR; } if (arrayPtr) { CleanupVar(varPtr, arrayPtr); - TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", NEEDARRAY, -1); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", - TclGetString(arrayNameObj), NULL); + TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", needArray, -1); return TCL_ERROR; } + + if (arrayElemObj == NULL) { + goto ensureArray; + } /* * Install the contents of the dictionary or list into the array. */ - arrayElemObj = objv[2]; - if (TclHasIntRep(arrayElemObj, &tclDictType) && arrayElemObj->bytes == NULL) { + if (arrayElemObj->typePtr == &tclDictType && arrayElemObj->bytes == NULL) { Tcl_Obj *keyPtr, *valuePtr; Tcl_DictSearch search; int done; if (Tcl_DictObjSize(interp, arrayElemObj, &done) != TCL_OK) { @@ -4001,11 +3443,11 @@ Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj, keyPtr, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1); if ((elemVarPtr == NULL) || - (TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj, + (TclPtrSetVar(interp, elemVarPtr, varPtr, arrayNameObj, keyPtr, valuePtr, TCL_LEAVE_ERR_MSG, -1) == NULL)) { Tcl_DictObjDone(&search); return TCL_ERROR; } } @@ -4025,32 +3467,30 @@ return result; } if (elemLen & 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "list must have an even number of elements", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "FORMAT", NULL); return TCL_ERROR; } if (elemLen == 0) { goto ensureArray; } /* * We needn't worry about traces invalidating arrayPtr: should that be - * the case, TclPtrSetVarIdx will return NULL so that we break out of - * the loop and return an error. + * the case, TclPtrSetVar will return NULL so that we break out of the + * loop and return an error. */ copyListObj = TclListObjCopy(NULL, arrayElemObj); for (i=0 ; ivalue.tablePtr, &search); - varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) { - if (!TclIsVarUndefined(varPtr2)) { - size++; - } - } - } - - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(size)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ArrayStatsCmd -- - * - * This object-based function is invoked to process the "array - * statistics" 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 -ArrayStatsCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Var *varPtr; - Tcl_Obj *varNameObj; - char *stats; - int isArray; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); - return TCL_ERROR; - } - varNameObj = objv[1]; - - if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) { - return TCL_ERROR; - } - - if (!isArray) { - return NotArrayError(interp, varNameObj); - } - - 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)); - Tcl_Free(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; - const char *pattern; - const int unsetFlags = 0; /* Should this be TCL_LEAVE_ERR_MSG? */ - int isArray; - - switch (objc) { - case 2: - varNameObj = objv[1]; - patternObj = NULL; - break; - case 3: - varNameObj = objv[1]; - patternObj = objv[2]; - break; - default: - Tcl_WrongNumArgs(interp, 1, objv, "arrayName ?pattern?"); - return TCL_ERROR; - } - - if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) { - return TCL_ERROR; - } - - if (!isArray) { - return TCL_OK; - } - - if (!patternObj) { - /* - * When no pattern is given, just unset the whole array. - */ - - return TclObjUnsetVar2(interp, varNameObj, NULL, 0); - } - - /* - * With a trivial pattern, we can just unset. - */ - - pattern = TclGetString(patternObj); - if (TclMatchIsTrivial(pattern)) { - varPtr2 = VarHashFindVar(varPtr->value.tablePtr, patternObj); - if (!varPtr2 || TclIsVarUndefined(varPtr2)) { - return TCL_OK; - } - return TclPtrUnsetVarIdx(interp, varPtr2, varPtr, varNameObj, - patternObj, unsetFlags, -1); - } - - /* - * Non-trivial case (well, deeply tricky really). We peek inside the hash - * iterator in order to allow us to guarantee that the following element - * in the array will not be scrubbed until we have dealt with it. This - * stops the overall iterator from ending up pointing into deallocated - * memory. [Bug 2939073] - */ - - protectedVarPtr = NULL; - for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search); - varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) { - /* - * Drop the extra ref immediately. We don't need to free it at this - * point though; we'll be unsetting it if necessary soon. - */ - - if (varPtr2 == protectedVarPtr) { - VarHashRefCount(varPtr2)--; - } - - /* - * Guard the next (peeked) item in the search chain by incrementing - * its refcount. This guarantees that the hash table iterator won't be - * dangling on the next time through the loop. - */ - - if (search.nextEntryPtr != NULL) { - protectedVarPtr = VarHashGetValue(search.nextEntryPtr); - VarHashRefCount(protectedVarPtr)++; - } else { - protectedVarPtr = NULL; - } - - /* - * If the variable is undefined, clean it out as it has been hit by - * something else (i.e., an unset trace). - */ - - if (TclIsVarUndefined(varPtr2)) { - CleanupVar(varPtr2, varPtr); - continue; - } - - nameObj = VarHashGetKey(varPtr2); - if (Tcl_StringMatch(TclGetString(nameObj), pattern) - && TclPtrUnsetVarIdx(interp, varPtr2, varPtr, varNameObj, - nameObj, unsetFlags, -1) != TCL_OK) { - /* - * If we incremented a refcount, we must decrement it here as we - * will not be coming back properly due to the error. - */ - - if (protectedVarPtr) { - VarHashRefCount(protectedVarPtr)--; - CleanupVar(protectedVarPtr, varPtr); - } - return TCL_ERROR; - } - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclInitArrayCmd -- - * - * This creates the ensemble for the "array" command. - * - * Results: - * The handle for the created ensemble. - * - * 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}, - {"donesearch", ArrayDoneSearchCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"exists", ArrayExistsCmd, TclCompileArrayExistsCmd, NULL, NULL, 0}, - {"for", ArrayForObjCmd, TclCompileBasic3ArgCmd, ArrayForNRCmd, NULL, 0}, - {"get", ArrayGetCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"names", ArrayNamesCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, - {"nextelement", ArrayNextElementCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"set", ArraySetCmd, TclCompileArraySetCmd, NULL, NULL, 0}, - {"size", ArraySizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"startsearch", ArrayStartSearchCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"statistics", ArrayStatsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"unset", ArrayUnsetCmd, TclCompileArrayUnsetCmd, NULL, NULL, 0}, - {NULL, NULL, NULL, NULL, NULL, 0} - }; - - return TclMakeEnsemble(interp, "array", arrayImplMap); + needArray, -1); + return TCL_ERROR; + } + } + TclSetVarArray(varPtr); + varPtr->value.tablePtr = (TclVarHashTable *) + ckalloc(sizeof(TclVarHashTable)); + TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr)); + return TCL_OK; } /* *---------------------------------------------------------------------- * @@ -4384,11 +3536,11 @@ * This function does all of the work of the "global" and "upvar" * commands. * * Results: * A standard Tcl completion code. If an error occurs then an error - * message is left in interp. + * message is left in iPtr->result. * * Side effects: * The variable given by myName is linked to the variable in framePtr * given by otherP1 and otherP2, so that references to myName are * redirected to the other variable like a symbolic link. @@ -4456,20 +3608,18 @@ : (TclIsVarInHash(otherPtr) && TclGetVarNsPtr(otherPtr))) && ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) || (varFramePtr == NULL) || !HasLocalVars(varFramePtr) || (strstr(TclGetString(myNamePtr), "::") != NULL))) { - Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf( - "bad variable name \"%s\": can't create namespace " - "variable that refers to procedure variable", - TclGetString(myNamePtr))); - Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", NULL); + Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", + TclGetString(myNamePtr), "\": can't create namespace " + "variable that refers to procedure variable", NULL); return TCL_ERROR; } } - return TclPtrObjMakeUpvarIdx(interp, otherPtr, myNamePtr, myFlags, index); + return TclPtrObjMakeUpvar(interp, otherPtr, myNamePtr, myFlags, index); } /* *---------------------------------------------------------------------- * @@ -4478,11 +3628,11 @@ * This procedure does all of the work of the "global" and "upvar" * commands. * * Results: * A standard Tcl completion code. If an error occurs then an error - * message is left in interp. + * message is left in iPtr->result. * * Side effects: * The variable given by myName is linked to the variable in framePtr * given by otherP1 and otherP2, so that references to myName are * redirected to the other variable like a symbolic link. @@ -4507,36 +3657,21 @@ if (myName) { myNamePtr = Tcl_NewStringObj(myName, -1); Tcl_IncrRefCount(myNamePtr); } - result = TclPtrObjMakeUpvarIdx(interp, otherPtr, myNamePtr, myFlags, - index); + result = TclPtrObjMakeUpvar(interp, otherPtr, myNamePtr, myFlags, index); if (myNamePtr) { Tcl_DecrRefCount(myNamePtr); } return result; } -int -TclPtrObjMakeUpvar( - Tcl_Interp *interp, /* Interpreter containing variables. Used for - * error messages, too. */ - Tcl_Var otherPtr, /* Pointer to the variable being linked-to. */ - Tcl_Obj *myNamePtr, /* Name of variable which will refer to - * otherP1/otherP2. Must be a scalar. */ - int myFlags) /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: - * indicates scope of myName. */ -{ - return TclPtrObjMakeUpvarIdx(interp, (Var *) otherPtr, myNamePtr, myFlags, - -1); -} - /* Callers must Incr myNamePtr if they plan to Decr it. */ int -TclPtrObjMakeUpvarIdx( +TclPtrObjMakeUpvar( Tcl_Interp *interp, /* Interpreter containing variables. Used for * error messages, too. */ Var *otherPtr, /* Pointer to the variable being linked-to. */ Tcl_Obj *myNamePtr, /* Name of variable which will refer to * otherP1/otherP2. Must be a scalar. */ @@ -4545,11 +3680,11 @@ int index) /* If the variable to be linked is an indexed * scalar, this is its index. Otherwise, -1 */ { Interp *iPtr = (Interp *) interp; CallFrame *varFramePtr = iPtr->varFramePtr; - const char *errMsg, *p, *myName; + const char *errMsg, *myName; Var *varPtr; if (index >= 0) { if (!HasLocalVars(varFramePtr)) { Tcl_Panic("ObjMakeUpvar called with an index outside from a proc"); @@ -4556,10 +3691,11 @@ } varPtr = (Var *) &(varFramePtr->compiledLocals[index]); myNamePtr = localName(iPtr->varFramePtr, index); myName = myNamePtr? TclGetString(myNamePtr) : NULL; } else { + const char *p; /* * Do not permit the new variable to look like an array reference, as * it will not be reachable in that case [Bug 600812, TIP 184]. The * "definition" of what "looks like an array reference" is consistent * (and must remain consistent) with the code in TclObjLookupVar(). @@ -4572,85 +3708,113 @@ if (*p == ')') { /* * myName looks like an array reference. */ - Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf( - "bad variable name \"%s\": can't create a scalar " - "variable that looks like an array element", myName)); - Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", - NULL); + Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", + myName, "\": can't create a scalar variable that " + "looks like an array element", NULL); return TCL_ERROR; } } /* * Lookup and eventually create the new variable. Set the flag bit - * TCL_AVOID_RESOLVERS to indicate the special resolution rules for - * upvar purposes: + * AVOID_RESOLVERS to indicate the special resolution rules for upvar + * purposes: * - Bug #696893 - variable is either proc-local or in the current * namespace; never follow the second (global) resolution path. * - Bug #631741 - do not use special namespace or interp resolvers. */ varPtr = TclLookupSimpleVar(interp, myNamePtr, - myFlags|TCL_AVOID_RESOLVERS, /* create */ 1, &errMsg, &index); + myFlags|AVOID_RESOLVERS, /* create */ 1, &errMsg, &index); if (varPtr == NULL) { TclObjVarErrMsg(interp, myNamePtr, NULL, "create", errMsg, -1); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", - TclGetString(myNamePtr), NULL); return TCL_ERROR; } } if (varPtr == otherPtr) { - Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_NewStringObj( - "can't upvar from variable to itself", -1)); - Tcl_SetErrorCode(interp, "TCL", "UPVAR", "SELF", NULL); + Tcl_SetResult((Tcl_Interp *) iPtr, + "can't upvar from variable to itself", TCL_STATIC); return TCL_ERROR; } if (TclIsVarTraced(varPtr)) { - Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf( - "variable \"%s\" has traces: can't use for upvar", myName)); - Tcl_SetErrorCode(interp, "TCL", "UPVAR", "TRACED", NULL); + Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, + "\" has traces: can't use for upvar", NULL); return TCL_ERROR; } else if (!TclIsVarUndefined(varPtr)) { - Var *linkPtr; - /* * The variable already existed. Make sure this variable "varPtr" * isn't the same as "otherPtr" (avoid circular links). Also, if it's * not an upvar then it's an error. If it is an upvar, then just * disconnect it from the thing it currently refers to. */ - if (!TclIsVarLink(varPtr)) { - Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf( - "variable \"%s\" already exists", myName)); - Tcl_SetErrorCode(interp, "TCL", "UPVAR", "EXISTS", NULL); - return TCL_ERROR; - } - - linkPtr = varPtr->value.linkPtr; - if (linkPtr == otherPtr) { - return TCL_OK; - } - if (TclIsVarInHash(linkPtr)) { - VarHashRefCount(linkPtr)--; - if (TclIsVarUndefined(linkPtr)) { - CleanupVar(linkPtr, NULL); - } + if (TclIsVarLink(varPtr)) { + Var *linkPtr = varPtr->value.linkPtr; + if (linkPtr == otherPtr) { + return TCL_OK; + } + if (TclIsVarInHash(linkPtr)) { + VarHashRefCount(linkPtr)--; + if (TclIsVarUndefined(linkPtr)) { + CleanupVar(linkPtr, NULL); + } + } + } else { + Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, + "\" already exists", NULL); + return TCL_ERROR; } } TclSetVarLink(varPtr); varPtr->value.linkPtr = otherPtr; if (TclIsVarInHash(otherPtr)) { VarHashRefCount(otherPtr)++; } 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 localName, so that references to localName + * are redirected to the other variable like a symbolic link. + * + *---------------------------------------------------------------------- + */ + +#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 *localName, /* Name of link variable. */ + int flags) /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: + * indicates scope of localName. */ +{ + return Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags); +} /* *---------------------------------------------------------------------- * * Tcl_UpVar2 -- @@ -4662,13 +3826,12 @@ * 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 part1 and part2 - * becomes accessible under the name localNameStr, so that references to - * localNameStr are redirected to the other variable like a symbolic - * link. + * becomes accessible under the name localName, so that references to + * localName are redirected to the other variable like a symbolic link. * *---------------------------------------------------------------------- */ int @@ -4678,13 +3841,13 @@ const char *frameName, /* Name of the frame containing the source * variable, such as "1" or "#0". */ const char *part1, const char *part2, /* Two parts of source variable name to link * to. */ - const char *localNameStr, /* Name of link variable. */ + const char *localName, /* Name of link variable. */ int flags) /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: - * indicates scope of localNameStr. */ + * indicates scope of localName. */ { int result; CallFrame *framePtr; Tcl_Obj *part1Ptr, *localNamePtr; @@ -4692,11 +3855,11 @@ return TCL_ERROR; } part1Ptr = Tcl_NewStringObj(part1, -1); Tcl_IncrRefCount(part1Ptr); - localNamePtr = Tcl_NewStringObj(localNameStr, -1); + localNamePtr = Tcl_NewStringObj(localName, -1); Tcl_IncrRefCount(localNamePtr); result = ObjMakeUpvar(interp, framePtr, part1Ptr, part2, 0, localNamePtr, flags, -1); Tcl_DecrRefCount(part1Ptr); @@ -4730,41 +3893,43 @@ * 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; - } + register Var *varPtr = (Var *) variable; /* * Add the full name of the containing namespace (if any), followed by the * "::" separator, then the variable name. */ - nsPtr = TclGetVarNsPtr(varPtr); - if (nsPtr) { - Tcl_AppendToObj(objPtr, nsPtr->fullName, -1); - if (nsPtr != iPtr->globalNsPtr) { - Tcl_AppendToObj(objPtr, "::", 2); - } - } - if (TclIsVarInHash(varPtr)) { - if (!TclIsVarDeadHash(varPtr)) { - namePtr = VarHashGetKey(varPtr); - Tcl_AppendObjToObj(objPtr, namePtr); - } - } else if (iPtr->varFramePtr->procPtr) { - int index = varPtr - iPtr->varFramePtr->compiledLocals; - - if (index >= 0 && index < iPtr->varFramePtr->numCompiledLocals) { - namePtr = localName(iPtr->varFramePtr, index); - Tcl_AppendObjToObj(objPtr, namePtr); + if (varPtr) { + if (!TclIsVarArrayElement(varPtr)) { + Tcl_Obj *namePtr; + Namespace *nsPtr; + + nsPtr = TclGetVarNsPtr(varPtr); + if (nsPtr) { + Tcl_AppendToObj(objPtr, nsPtr->fullName, -1); + if (nsPtr != iPtr->globalNsPtr) { + Tcl_AppendToObj(objPtr, "::", 2); + } + } + if (TclIsVarInHash(varPtr)) { + if (!TclIsVarDeadHash(varPtr)) { + namePtr = VarHashGetKey(varPtr); + Tcl_AppendObjToObj(objPtr, namePtr); + } + } else if (iPtr->varFramePtr->procPtr) { + int index = varPtr - iPtr->varFramePtr->compiledLocals; + + if (index >= 0 + && index < iPtr->varFramePtr->numCompiledLocals) { + namePtr = localName(iPtr->varFramePtr, index); + Tcl_AppendObjToObj(objPtr, namePtr); + } + } } } } /* @@ -4784,20 +3949,25 @@ *---------------------------------------------------------------------- */ int Tcl_GlobalObjCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ 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; + register Tcl_Obj *objPtr, *tailPtr; + char *varName; + register char *tail; + int i; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "varName ?varName ...?"); + return TCL_ERROR; + } /* * If we are not executing inside a Tcl procedure, just return. */ @@ -4804,10 +3974,12 @@ if (!HasLocalVars(iPtr->varFramePtr)) { return TCL_OK; } for (i=1 ; itypePtr = &tclArraySearchType; + objPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(id); + objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(offset); + return TCL_OK; + + syntax: + Tcl_AppendResult(interp, "illegal search identifier \"",string,"\"",NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * * ParseSearchId -- * * This function translates from a tcl object to a pointer to an active * array search (if there is one that matches the string). * * Results: * The return value is a pointer to the array search indicated by string, * or NULL if there isn't one. If NULL is returned, the interp's result * contains an error message. + * + * Side effects: + * The tcl object might have its internal type and representation + * modified. * *---------------------------------------------------------------------- */ static ArraySearch * @@ -5126,47 +4343,74 @@ * form "search-num-var" where "num" is a * decimal number and "var" is a variable * name. */ { Interp *iPtr = (Interp *) interp; - ArraySearch *searchPtr; - const char *handle = TclGetString(handleObj); - 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] != '-') - || (strtoul(handle + 2, &end, 10), end == (handle + 2)) - || (*end != '-')) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "illegal search identifier \"%s\"", handle)); - } else if (strcmp(end + 1, TclGetString(varNamePtr)) != 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "search identifier \"%s\" isn't for variable \"%s\"", - handle, TclGetString(varNamePtr))); - } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't find search \"%s\"", handle)); - } - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", handle, NULL); + register char *string; + register size_t offset; + int id; + ArraySearch *searchPtr; + char *varName = TclGetString(varNamePtr); + + /* + * Parse the id. + */ + + if (Tcl_ConvertToType(interp, handleObj, &tclArraySearchType) != TCL_OK) { + return NULL; + } + + /* + * Extract the information out of the Tcl_Obj. + */ + +#if 1 + id = PTR2INT(handleObj->internalRep.twoPtrValue.ptr1); + string = TclGetString(handleObj); + offset = PTR2INT(handleObj->internalRep.twoPtrValue.ptr2); +#else + id = (int)(((char *) handleObj->internalRep.twoPtrValue.ptr1) - + ((char *) NULL)); + string = TclGetString(handleObj); + offset = (((char *) handleObj->internalRep.twoPtrValue.ptr2) - + ((char *) NULL)); +#endif + + /* + * This test cannot be placed inside the Tcl_Obj machinery, since it is + * dependent on the variable context. + */ + + if (strcmp(string+offset, varName) != 0) { + Tcl_AppendResult(interp, "search identifier \"", string, + "\" isn't for variable \"", varName, "\"", NULL); + goto badLookup; + } + + /* + * Search through the list of active searches on the interpreter to see if + * the desired one exists. + * + * Note that we cannot store the searchPtr directly in the Tcl_Obj as that + * would run into trouble when DeleteSearches() was called so we must scan + * this list every time. + */ + + if (varPtr->flags & VAR_SEARCH_ACTIVE) { + Tcl_HashEntry *hPtr = + Tcl_FindHashEntry(&iPtr->varSearches, (char *) varPtr); + + for (searchPtr = (ArraySearch *) Tcl_GetHashValue(hPtr); + searchPtr != NULL; searchPtr = searchPtr->nextPtr) { + if (searchPtr->id == id) { + return searchPtr; + } + } + } + Tcl_AppendResult(interp, "couldn't find search \"", string, "\"", NULL); + badLookup: + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL); return NULL; } /* *---------------------------------------------------------------------- @@ -5186,23 +4430,22 @@ */ static void DeleteSearches( Interp *iPtr, - Var *arrayVarPtr) /* Variable whose searches are to be + register 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) { + ArraySearch *searchPtr, *nextPtr; + Tcl_HashEntry *sPtr; + + sPtr = Tcl_FindHashEntry(&iPtr->varSearches, (char *) arrayVarPtr); + for (searchPtr = (ArraySearch *) Tcl_GetHashValue(sPtr); + searchPtr != NULL; searchPtr = nextPtr) { nextPtr = searchPtr->nextPtr; - Tcl_DecrRefCount(searchPtr->name); - Tcl_Free(searchPtr); + ckfree((char *) searchPtr); } arrayVarPtr->flags &= ~VAR_SEARCH_ACTIVE; Tcl_DeleteHashEntry(sPtr); } } @@ -5246,17 +4489,17 @@ flags = TCL_NAMESPACE_ONLY; } for (varPtr = VarHashFirstVar(tablePtr, &search); varPtr != NULL; varPtr = VarHashFirstVar(tablePtr, &search)) { - Tcl_Obj *objPtr; - TclNewObj(objPtr); + Tcl_Obj *objPtr = Tcl_NewObj(); + VarHashRefCount(varPtr)++; /* Make sure we get to remove from * hash. */ Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr); UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ objPtr, - NULL, flags, -1); + NULL, flags); /* * We just unset the variable. However, an unset trace might * have re-set it, or might have re-established traces on it. * This namespace and its vartable are going away unconditionally, @@ -5264,20 +4507,21 @@ * * First we destroy all traces. ... */ if (TclIsVarTraced(varPtr)) { - Tcl_HashEntry *tPtr = Tcl_FindHashEntry(&iPtr->varTraces, varPtr); - VarTrace *tracePtr = (VarTrace *)Tcl_GetHashValue(tPtr); ActiveVarTrace *activePtr; + Tcl_HashEntry *tPtr = Tcl_FindHashEntry(&iPtr->varTraces, + (char *) varPtr); + VarTrace *tracePtr = (VarTrace *) Tcl_GetHashValue(tPtr); while (tracePtr) { VarTrace *prevPtr = tracePtr; tracePtr = tracePtr->nextPtr; prevPtr->nextPtr = NULL; - Tcl_EventuallyFree(prevPtr, TCL_DYNAMIC); + Tcl_EventuallyFree((ClientData) prevPtr, TCL_DYNAMIC); } Tcl_DeleteHashEntry(tPtr); varPtr->flags &= ~VAR_ALL_TRACES; for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { @@ -5292,11 +4536,11 @@ * again. This time with no traces left, we're sure it goes away. */ if (!TclIsVarUndefined(varPtr)) { UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ objPtr, - NULL, flags, -1); + NULL, flags); } Tcl_DecrRefCount(objPtr); /* free no longer needed obj */ VarHashRefCount(varPtr)--; VarHashDeleteEntry(varPtr); } @@ -5329,11 +4573,11 @@ TclVarHashTable *tablePtr) /* Hash table containing variables to * delete. */ { Tcl_Interp *interp = (Tcl_Interp *) iPtr; Tcl_HashSearch search; - Var *varPtr; + register Var *varPtr; int flags; Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); /* * Determine what flags to pass to the trace callback functions. @@ -5345,13 +4589,13 @@ } else if (tablePtr == &currNsPtr->varTable) { flags |= TCL_NAMESPACE_ONLY; } for (varPtr = VarHashFirstVar(tablePtr, &search); varPtr != NULL; - varPtr = VarHashFirstVar(tablePtr, &search)) { - UnsetVarStruct(varPtr, NULL, iPtr, VarHashGetKey(varPtr), NULL, flags, - -1); + varPtr = VarHashFirstVar(tablePtr, &search)) { + + UnsetVarStruct(varPtr, NULL, iPtr, VarHashGetKey(varPtr), NULL, flags); VarHashDeleteEntry(varPtr); } VarHashDeleteTable(tablePtr); } @@ -5381,20 +4625,20 @@ TclDeleteCompiledLocalVars( Interp *iPtr, /* Interpreter to which variables belong. */ CallFrame *framePtr) /* Procedure call frame containing compiler- * assigned local variables to delete. */ { - Var *varPtr; + register Var *varPtr; int numLocals, i; Tcl_Obj **namePtrPtr; numLocals = framePtr->numCompiledLocals; varPtr = framePtr->compiledLocals; namePtrPtr = &localName(framePtr, 0); for (i=0 ; inumCompiledLocals = 0; } /* @@ -5423,22 +4667,24 @@ Interp *iPtr, /* Interpreter containing array. */ Tcl_Obj *arrayNamePtr, /* Name of array (used for trace callbacks), * or NULL if it is to be computed on * demand. */ Var *varPtr, /* Pointer to variable structure. */ - int flags, /* Flags to pass to TclCallVarTraces: + 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; + register Var *elPtr; ActiveVarTrace *activePtr; Tcl_Obj *objPtr; VarTrace *tracePtr; + if (varPtr->flags & VAR_SEARCH_ACTIVE) { + DeleteSearches(iPtr, varPtr); + } for (elPtr = VarHashFirstVar(varPtr->value.tablePtr, &search); elPtr != NULL; elPtr = VarHashNextVar(&search)) { if (TclIsVarScalar(elPtr) && (elPtr->value.objPtr != NULL)) { objPtr = elPtr->value.objPtr; TclDecrRefCount(objPtr); @@ -5459,20 +4705,19 @@ if (elPtr->flags & VAR_TRACED_UNSET) { Tcl_Obj *elNamePtr = VarHashGetKey(elPtr); elPtr->flags &= ~VAR_TRACE_ACTIVE; TclObjCallVarTraces(iPtr, NULL, elPtr, arrayNamePtr, - elNamePtr, flags,/* leaveErrMsg */ 0, index); + elNamePtr, flags,/* leaveErrMsg */ 0, -1); } - tPtr = Tcl_FindHashEntry(&iPtr->varTraces, elPtr); - tracePtr = (VarTrace *)Tcl_GetHashValue(tPtr); + tPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) elPtr); + tracePtr = (VarTrace *) Tcl_GetHashValue(tPtr); while (tracePtr) { VarTrace *prevPtr = tracePtr; tracePtr = tracePtr->nextPtr; - prevPtr->nextPtr = NULL; - Tcl_EventuallyFree(prevPtr, TCL_DYNAMIC); + Tcl_EventuallyFree((ClientData) prevPtr, TCL_DYNAMIC); } Tcl_DeleteHashEntry(tPtr); elPtr->flags &= ~VAR_ALL_TRACES; for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { @@ -5490,17 +4735,18 @@ * the corresponding Var struct, and is otherwise harmless. */ TclClearVarNamespaceVar(elPtr); } - DeleteArrayVar(varPtr); + VarHashDeleteTable(varPtr->value.tablePtr); + ckfree((char *) varPtr->value.tablePtr); } /* *---------------------------------------------------------------------- * - * TclObjVarErrMsg -- + * TclTclObjVarErrMsg -- * * Generate a reasonable error message describing why a variable * operation failed. * * Results: @@ -5548,13 +4794,10 @@ int index) /* Index into the local variable table of the * variable, or -1. Only used when part1Ptr is * NULL. */ { if (!part1Ptr) { - if (index == -1) { - Tcl_Panic("invalid part1Ptr and invalid index together"); - } part1Ptr = localName(((Interp *)interp)->varFramePtr, index); } Tcl_SetObjResult(interp, Tcl_ObjPrintf("can't %s \"%s%s%s%s\": %s", operation, TclGetString(part1Ptr), (part2Ptr ? "(" : ""), (part2Ptr ? TclGetString(part2Ptr) : ""), (part2Ptr ? ")" : ""), @@ -5566,49 +4809,111 @@ * * Internal functions for variable name object types -- * *---------------------------------------------------------------------- */ + +/* + * Panic functions that should never be called in normal operation. + */ + +static void +PanicOnUpdateVarName( + Tcl_Obj *objPtr) +{ + Tcl_Panic("%s of type %s should not be called", "updateStringProc", + objPtr->typePtr->name); +} + +static int +PanicOnSetVarName( + Tcl_Interp *interp, + Tcl_Obj *objPtr) +{ + Tcl_Panic("%s of type %s should not be called", "setFromAnyProc", + objPtr->typePtr->name); + return TCL_ERROR; +} /* * localVarName - * * INTERNALREP DEFINITION: - * twoPtrValue.ptr1: pointer to name obj in varFramePtr->localCache - * or NULL if it is this same obj - * twoPtrValue.ptr2: index into locals table + * ptrAndLongRep.ptr: pointer to name obj in varFramePtr->localCache + * or NULL if it is this same obj + * ptrAndLongRep.value: index into locals table */ static void FreeLocalVarName( Tcl_Obj *objPtr) { - int index; - Tcl_Obj *namePtr; - - LocalGetIntRep(objPtr, index, namePtr); - - index++; /* Compiler warning bait. */ + Tcl_Obj *namePtr = (Tcl_Obj *) objPtr->internalRep.ptrAndLongRep.ptr; if (namePtr) { Tcl_DecrRefCount(namePtr); } + objPtr->typePtr = NULL; } static void DupLocalVarName( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - int index; - Tcl_Obj *namePtr; + Tcl_Obj *namePtr = srcPtr->internalRep.ptrAndLongRep.ptr; - LocalGetIntRep(srcPtr, index, namePtr); if (!namePtr) { namePtr = srcPtr; } - LocalSetIntRep(dupPtr, index, namePtr); + dupPtr->internalRep.ptrAndLongRep.ptr = namePtr; + Tcl_IncrRefCount(namePtr); + + dupPtr->internalRep.ptrAndLongRep.value = + srcPtr->internalRep.ptrAndLongRep.value; + dupPtr->typePtr = &localVarNameType; +} + +#if ENABLE_NS_VARNAME_CACHING +/* + * nsVarName - + * + * INTERNALREP DEFINITION: + * twoPtrValue.ptr1: pointer to the namespace containing the reference. + * twoPtrValue.ptr2: pointer to the corresponding Var + */ + +static void +FreeNsVarName( + Tcl_Obj *objPtr) +{ + register Var *varPtr = objPtr->internalRep.twoPtrValue.ptr2; + + if (TclIsVarInHash(varPtr)) { + varPtr->refCount--; + if (TclIsVarUndefined(varPtr) && (varPtr->refCount == 0)) { + CleanupVar(varPtr, NULL); + } + } + objPtr->typePtr = NULL; +} + +static void +DupNsVarName( + Tcl_Obj *srcPtr, + Tcl_Obj *dupPtr) +{ + Namespace *nsPtr = srcPtr->internalRep.twoPtrValue.ptr1; + register Var *varPtr = srcPtr->internalRep.twoPtrValue.ptr2; + + dupPtr->internalRep.twoPtrValue.ptr1 = nsPtr; + dupPtr->internalRep.twoPtrValue.ptr2 = varPtr; + if (TclIsVarInHash(varPtr)) { + varPtr->refCount++; + } + dupPtr->typePtr = &tclNsVarNameType; } +#endif /* * parsedVarName - * * INTERNALREP DEFINITION: @@ -5619,34 +4924,77 @@ static void FreeParsedVarName( Tcl_Obj *objPtr) { - Tcl_Obj *arrayPtr, *elem; - int parsed; + register Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1; + register char *elem = objPtr->internalRep.twoPtrValue.ptr2; - ParsedGetIntRep(objPtr, parsed, arrayPtr, elem); - - parsed++; /* Silence compiler. */ if (arrayPtr != NULL) { TclDecrRefCount(arrayPtr); - TclDecrRefCount(elem); + ckfree(elem); } + objPtr->typePtr = NULL; } static void DupParsedVarName( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - Tcl_Obj *arrayPtr, *elem; - int parsed; + register Tcl_Obj *arrayPtr = srcPtr->internalRep.twoPtrValue.ptr1; + register char *elem = srcPtr->internalRep.twoPtrValue.ptr2; + char *elemCopy; - ParsedGetIntRep(srcPtr, parsed, arrayPtr, elem); + if (arrayPtr != NULL) { + unsigned int elemLen; - parsed++; /* Silence compiler. */ - ParsedSetIntRep(dupPtr, arrayPtr, elem); + Tcl_IncrRefCount(arrayPtr); + elemLen = strlen(elem); + elemCopy = ckalloc(elemLen+1); + memcpy(elemCopy, elem, elemLen); + *(elemCopy + elemLen) = '\0'; + elem = elemCopy; + } + + dupPtr->internalRep.twoPtrValue.ptr1 = arrayPtr; + dupPtr->internalRep.twoPtrValue.ptr2 = elem; + dupPtr->typePtr = &tclParsedVarNameType; +} + +static void +UpdateParsedVarName( + Tcl_Obj *objPtr) +{ + Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1; + char *part2 = objPtr->internalRep.twoPtrValue.ptr2; + char *part1, *p; + int len1, len2, totalLen; + + if (arrayPtr == NULL) { + /* + * This is a parsed scalar name: what is it doing here? + */ + + Tcl_Panic("scalar parsedVarName without a string rep"); + } + + part1 = TclGetStringFromObj(arrayPtr, &len1); + len2 = strlen(part2); + + totalLen = len1 + len2 + 2; + p = ckalloc((unsigned int) totalLen + 1); + objPtr->bytes = p; + objPtr->length = totalLen; + + memcpy(p, part1, (unsigned int) len1); + p += len1; + *p++ = '('; + memcpy(p, part2, (unsigned int) len2); + p += len2; + *p++ = ')'; + *p = '\0'; } /* *---------------------------------------------------------------------- * @@ -5679,16 +5027,15 @@ * NULL), then in global namespace. */ Tcl_Namespace *contextNsPtr,/* Ignored if TCL_GLOBAL_ONLY flag set. * Otherwise, points to namespace in which to * resolve name. If NULL, look up name in the * current namespace. */ - int flags) /* An OR'd combination of: - * TCL_AVOID_RESOLVERS, TCL_GLOBAL_ONLY (look - * up name only in global namespace), - * TCL_NAMESPACE_ONLY (look up only in - * contextNsPtr, or the current namespace if - * contextNsPtr is NULL), and + int flags) /* An OR'd combination of: AVOID_RESOLVERS, + * TCL_GLOBAL_ONLY (look up name only in + * global namespace), TCL_NAMESPACE_ONLY (look + * up only in contextNsPtr, or the current + * 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. */ { Tcl_Obj *namePtr = Tcl_NewStringObj(name, -1); @@ -5710,30 +5057,28 @@ * NULL), then in global namespace. */ Tcl_Namespace *contextNsPtr,/* Ignored if TCL_GLOBAL_ONLY flag set. * Otherwise, points to namespace in which to * resolve name. If NULL, look up name in the * current namespace. */ - int flags) /* An OR'd combination of: - * TCL_AVOID_RESOLVERS, TCL_GLOBAL_ONLY (look - * up name only in global namespace), - * TCL_NAMESPACE_ONLY (look up only in - * contextNsPtr, or the current namespace if - * contextNsPtr is NULL), and + int flags) /* An OR'd combination of: AVOID_RESOLVERS, + * TCL_GLOBAL_ONLY (look up name only in + * global namespace), TCL_NAMESPACE_ONLY (look + * up only in contextNsPtr, or the current + * 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; ResolverScheme *resPtr; Namespace *nsPtr[2], *cxtNsPtr; const char *simpleName; Var *varPtr; - int search; - int result; + register int search; Tcl_Var var; Tcl_Obj *simpleNamePtr; - const char *name = TclGetString(namePtr); + char *name = TclGetString(namePtr); /* * If this namespace has a variable resolver, then give it first crack at * the variable resolution. It may return a Tcl_Var value, it may signal * to continue onward, or it may signal an error. @@ -5745,44 +5090,42 @@ cxtNsPtr = (Namespace *) contextNsPtr; } else { cxtNsPtr = (Namespace *) TclGetCurrentNamespace(interp); } - if (!(flags & TCL_AVOID_RESOLVERS) && + if (!(flags & AVOID_RESOLVERS) && (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL)) { + int result; + resPtr = iPtr->resolverPtr; if (cxtNsPtr->varResProc) { - result = cxtNsPtr->varResProc(interp, name, + result = (*cxtNsPtr->varResProc)(interp, name, (Tcl_Namespace *) cxtNsPtr, flags, &var); } else { result = TCL_CONTINUE; } while (result == TCL_CONTINUE && resPtr) { if (resPtr->varResProc) { - result = resPtr->varResProc(interp, name, + result = (*resPtr->varResProc)(interp, name, (Tcl_Namespace *) cxtNsPtr, flags, &var); } resPtr = resPtr->nextPtr; } if (result == TCL_OK) { return var; } else if (result != TCL_CONTINUE) { - return NULL; + return (Tcl_Var) NULL; } } /* * Find the namespace(s) that contain the variable. */ - if (!(flags & TCL_GLOBAL_ONLY)) { - flags |= TCL_NAMESPACE_ONLY; - } - 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 @@ -5804,12 +5147,12 @@ } if (simpleName != name) { Tcl_DecrRefCount(simpleNamePtr); } if ((varPtr == NULL) && (flags & TCL_LEAVE_ERR_MSG)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown variable \"%s\"", name)); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "unknown variable \"", name, "\"", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", name, NULL); } return (Tcl_Var) varPtr; } @@ -5837,25 +5180,25 @@ *---------------------------------------------------------------------- */ int TclInfoVarsCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ 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; + char *pattern; + const char *simplePattern; Tcl_HashSearch search; - Var *varPtr; Namespace *nsPtr; Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); - Tcl_Obj *listPtr, *elemObjPtr, *varNamePtr; + Tcl_Obj *listPtr; int specificNsInPattern = 0;/* Init. to avoid compiler warning. */ - Tcl_Obj *simplePatternPtr = NULL; + Tcl_Obj *simplePatternPtr = NULL, *varNamePtr; /* * Get the pattern and find the "effective namespace" in which to list * variables. We only use this effective namespace if there's no active * Tcl procedure frame. @@ -5875,12 +5218,13 @@ */ Namespace *dummy1NsPtr, *dummy2NsPtr; pattern = TclGetString(objv[1]); - TclGetNamespaceForQualName(interp, pattern, NULL, /*flags*/ 0, - &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); + TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, + /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, + &simplePattern); if (nsPtr != NULL) { /* We successfully found the pattern's ns. */ specificNsInPattern = (strcmp(simplePattern, pattern) != 0); if (simplePattern == pattern) { simplePatternPtr = objv[1]; @@ -5902,11 +5246,15 @@ return TCL_OK; } listPtr = Tcl_NewListObj(0, NULL); - if (!HasLocalVars(iPtr->varFramePtr) || specificNsInPattern) { + if (!(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC) + || specificNsInPattern) { + Var *varPtr; + Tcl_Obj *elemObjPtr; + /* * There is no frame pointer, the frame pointer was pushed only to * activate a namespace, or we are in a procedure call frame but a * specific namespace was specified. Create a list containing only the * variables in the effective namespace's variable table. @@ -5920,11 +5268,11 @@ varPtr = VarHashFindVar(&nsPtr->varTable, simplePatternPtr); if (varPtr) { if (!TclIsVarUndefined(varPtr) || TclIsVarNamespaceVar(varPtr)) { if (specificNsInPattern) { - TclNewObj(elemObjPtr); + elemObjPtr = Tcl_NewObj(); Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, elemObjPtr); } else { elemObjPtr = VarHashGetKey(varPtr); } @@ -5943,21 +5291,23 @@ } } else { /* * Have to scan the tables of variables. */ + char *varName; varPtr = VarHashFirstVar(&nsPtr->varTable, &search); while (varPtr) { + if (!TclIsVarUndefined(varPtr) || TclIsVarNamespaceVar(varPtr)) { varNamePtr = VarHashGetKey(varPtr); varName = TclGetString(varNamePtr); if ((simplePattern == NULL) || Tcl_StringMatch(varName, simplePattern)) { if (specificNsInPattern) { - TclNewObj(elemObjPtr); + elemObjPtr = Tcl_NewObj(); Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, elemObjPtr); } else { elemObjPtr = varNamePtr; } @@ -5975,11 +5325,11 @@ * only those variables that aren't hidden by a variable in the * effective namespace. */ if ((nsPtr != globalNsPtr) && !specificNsInPattern) { - varPtr = VarHashFirstVar(&globalNsPtr->varTable, &search); + varPtr = VarHashFirstVar(&globalNsPtr->varTable,&search); while (varPtr) { if (!TclIsVarUndefined(varPtr) || TclIsVarNamespaceVar(varPtr)) { varNamePtr = VarHashGetKey(varPtr); varName = TclGetString(varNamePtr); @@ -5994,11 +5344,11 @@ } varPtr = VarHashNextVar(&search); } } } - } else if (iPtr->varFramePtr->procPtr != NULL) { + } else if (((Interp *)interp)->varFramePtr->procPtr != NULL) { AppendLocals(interp, listPtr, simplePatternPtr, 1); } if (simplePatternPtr) { Tcl_DecrRefCount(simplePatternPtr); @@ -6028,20 +5378,20 @@ *---------------------------------------------------------------------- */ int TclInfoGlobalsCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *varName, *pattern; + char *pattern; Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); Tcl_HashSearch search; Var *varPtr; - Tcl_Obj *listPtr, *varNamePtr, *patternPtr; + Tcl_Obj *listPtr, *patternPtr; if (objc == 1) { pattern = NULL; } else if (objc == 2) { pattern = TclGetString(objv[1]); @@ -6084,10 +5434,13 @@ Tcl_DecrRefCount(patternPtr); } else { for (varPtr = VarHashFirstVar(&globalNsPtr->varTable, &search); varPtr != NULL; varPtr = VarHashNextVar(&search)) { + char *varName; + Tcl_Obj *varNamePtr; + if (TclIsVarUndefined(varPtr)) { continue; } varNamePtr = VarHashGetKey(varPtr); varName = TclGetString(varNamePtr); @@ -6121,17 +5474,18 @@ *---------------------------------------------------------------------- */ int TclInfoLocalsCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - Tcl_Obj *patternPtr, *listPtr; + Tcl_Obj *patternPtr; + Tcl_Obj *listPtr; if (objc == 1) { patternPtr = NULL; } else if (objc == 2) { patternPtr = objv[1]; @@ -6138,11 +5492,11 @@ } else { Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); return TCL_ERROR; } - if (!HasLocalVars(iPtr->varFramePtr)) { + if (!(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC )) { return TCL_OK; } /* * Return a list containing names of first the compiled locals (i.e. the @@ -6180,53 +5534,44 @@ Tcl_Obj *patternPtr, /* Pattern to match against. */ int includeLinks) /* 1 if upvars should be included, else 0. */ { Interp *iPtr = (Interp *) interp; Var *varPtr; - int i, localVarCt, added; - Tcl_Obj *objNamePtr; - const char *varName; + int i, localVarCt; + Tcl_Obj **varNamePtr; + char *varName; TclVarHashTable *localVarTablePtr; Tcl_HashSearch search; - Tcl_HashTable addedTable; const char *pattern = patternPtr? TclGetString(patternPtr) : NULL; + Tcl_Obj *objNamePtr; localVarCt = iPtr->varFramePtr->numCompiledLocals; varPtr = iPtr->varFramePtr->compiledLocals; localVarTablePtr = iPtr->varFramePtr->varTablePtr; - if (includeLinks) { - Tcl_InitObjHashTable(&addedTable); - } - - if (localVarCt > 0) { - Tcl_Obj **varNamePtr = &iPtr->varFramePtr->localCachePtr->varName0; - - for (i = 0; i < localVarCt; i++, varNamePtr++) { - /* - * Skip nameless (temporary) variables and undefined variables. - */ - - if (*varNamePtr && !TclIsVarUndefined(varPtr) + varNamePtr = &iPtr->varFramePtr->localCachePtr->varName0; + + for (i = 0; i < localVarCt; i++, varNamePtr++) { + /* + * Skip nameless (temporary) variables and undefined variables. + */ + + if (*varNamePtr && !TclIsVarUndefined(varPtr) && (includeLinks || !TclIsVarLink(varPtr))) { - varName = TclGetString(*varNamePtr); - if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { - Tcl_ListObjAppendElement(interp, listPtr, *varNamePtr); - if (includeLinks) { - Tcl_CreateHashEntry(&addedTable, *varNamePtr, &added); - } - } - } - varPtr++; - } + varName = TclGetString(*varNamePtr); + if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, *varNamePtr); + } + } + varPtr++; } /* * Do nothing if no local variables. */ if (localVarTablePtr == NULL) { - goto objectVars; + return; } /* * Check for the simple and fast case. */ @@ -6236,17 +5581,13 @@ if (varPtr != NULL) { if (!TclIsVarUndefined(varPtr) && (includeLinks || !TclIsVarLink(varPtr))) { Tcl_ListObjAppendElement(interp, listPtr, VarHashGetKey(varPtr)); - if (includeLinks) { - Tcl_CreateHashEntry(&addedTable, VarHashGetKey(varPtr), - &added); - } } } - goto objectVars; + return; } /* * Scan over and process all local variables. */ @@ -6258,70 +5599,13 @@ && (includeLinks || !TclIsVarLink(varPtr))) { objNamePtr = VarHashGetKey(varPtr); varName = TclGetString(objNamePtr); if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); - if (includeLinks) { - Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); - } - } - } - } - - 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); - if (added && (!pattern || - Tcl_StringMatch(TclGetString(objNamePtr), pattern))) { - Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); - } - } - FOREACH_STRUCT(privatePtr, oPtr->privateVariables) { - Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj, - &added); - if (added && (!pattern || - Tcl_StringMatch(TclGetString(privatePtr->variableObj), - pattern))) { - Tcl_ListObjAppendElement(interp, listPtr, - privatePtr->variableObj); - } - } - } else { - Class *clsPtr = mPtr->declaringClassPtr; - - FOREACH(objNamePtr, clsPtr->variables) { - Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); - if (added && (!pattern || - Tcl_StringMatch(TclGetString(objNamePtr), pattern))) { - Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); - } - } - FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) { - Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj, - &added); - if (added && (!pattern || - Tcl_StringMatch(TclGetString(privatePtr->variableObj), - pattern))) { - Tcl_ListObjAppendElement(interp, listPtr, - privatePtr->variableObj); - } - } - } - } - Tcl_DeleteHashTable(&addedTable); + } + } + } } /* * Hash table implementation - first, just copy and adapt the obj key stuff */ @@ -6336,23 +5620,23 @@ tablePtr->nsPtr = nsPtr; } static Tcl_HashEntry * AllocVarEntry( - TCL_UNUSED(Tcl_HashTable *), + Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key to store in the hash table entry. */ { - Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; + Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr; Tcl_HashEntry *hPtr; Var *varPtr; - varPtr = (Var *)Tcl_Alloc(sizeof(VarInHash)); + varPtr = (Var *) ckalloc(sizeof(VarInHash)); varPtr->flags = VAR_IN_HASHTABLE; varPtr->value.objPtr = NULL; VarHashRefCount(varPtr) = 1; - hPtr = &(((VarInHash *) varPtr)->entry); + hPtr = &(((VarInHash *)varPtr)->entry); Tcl_SetHashValue(hPtr, varPtr); hPtr->key.objPtr = objPtr; Tcl_IncrRefCount(objPtr); return hPtr; @@ -6365,11 +5649,11 @@ Var *varPtr = VarHashGetValue(hPtr); Tcl_Obj *objPtr = hPtr->key.objPtr; if (TclIsVarUndefined(varPtr) && !TclIsVarTraced(varPtr) && (VarHashRefCount(varPtr) == 1)) { - Tcl_Free(varPtr); + ckfree((char *) varPtr); } else { VarHashInvalidateEntry(varPtr); TclSetVarUndefined(varPtr); VarHashRefCount(varPtr)--; } @@ -6376,24 +5660,25 @@ Tcl_DecrRefCount(objPtr); } static int CompareVarKeys( - void *keyPtr, /* New key to compare. */ + void *keyPtr, /* New key to compare. */ Tcl_HashEntry *hPtr) /* Existing key to compare. */ { - Tcl_Obj *objPtr1 = (Tcl_Obj *)keyPtr; + Tcl_Obj *objPtr1 = (Tcl_Obj *) keyPtr; Tcl_Obj *objPtr2 = hPtr->key.objPtr; - const char *p1, *p2; - size_t l1, l2; + register const char *p1, *p2; + register 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; */ + + if (objPtr1 == objPtr2) { + return 1; + } /* * Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being in a * register. */ @@ -6402,275 +5687,62 @@ l1 = objPtr1->length; p2 = TclGetString(objPtr2); l2 = objPtr2->length; /* - * Only compare string representations of the same length. - */ - - return ((l1 == l2) && !memcmp(p1, p2, l1)); -} - -/*---------------------------------------------------------------------- - * - * ArrayDefaultCmd -- - * - * This function implements the 'array default' Tcl command. - * Refer to the user documentation for details on what it does. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -static int -ArrayDefaultCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - static const char *const options[] = { - "get", "set", "exists", "unset", NULL - }; - enum arrayDefaultOptionsEnum { OPT_GET, OPT_SET, OPT_EXISTS, OPT_UNSET }; - Tcl_Obj *arrayNameObj, *defaultValueObj; - Var *varPtr, *arrayPtr; - int isArray, option; - - /* - * Parse arguments. - */ - - if (objc != 3 && objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "option arrayName ?value?"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", - 0, &option) != TCL_OK) { - return TCL_ERROR; - } - - arrayNameObj = objv[2]; - - if (TCL_ERROR == LocateArray(interp, arrayNameObj, &varPtr, &isArray)) { - return TCL_ERROR; - } - - switch ((enum arrayDefaultOptionsEnum)option) { - case OPT_GET: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); - return TCL_ERROR; - } - if (!varPtr || TclIsVarUndefined(varPtr) || !isArray) { - return NotArrayError(interp, arrayNameObj); - } - - defaultValueObj = TclGetArrayDefault(varPtr); - if (!defaultValueObj) { - /* Array default must exist. */ - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "array has no default value", -1)); - Tcl_SetErrorCode(interp, "TCL", "READ", "ARRAY", "DEFAULT", NULL); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, defaultValueObj); - return TCL_OK; - - case OPT_SET: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "arrayName value"); - return TCL_ERROR; - } - - /* - * Attempt to create array if needed. - */ - varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, - /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "array default set", - /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); - if (varPtr == NULL) { - return TCL_ERROR; - } - if (arrayPtr) { - /* - * Not a valid array name. - */ - - CleanupVar(varPtr, arrayPtr); - TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set", - NEEDARRAY, -1); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", - TclGetString(arrayNameObj), NULL); - return TCL_ERROR; - } - if (!TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { - /* - * Not an array. - */ - - TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set", - NEEDARRAY, -1); - Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); - return TCL_ERROR; - } - - if (!TclIsVarArray(varPtr)) { - TclInitArrayVar(varPtr); - } - defaultValueObj = objv[3]; - SetArrayDefault(varPtr, defaultValueObj); - return TCL_OK; - - case OPT_EXISTS: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); - return TCL_ERROR; - } - - /* - * Undefined variables (whether or not they have storage allocated) do - * not have defaults, and this is not an error case. - */ - - if (!varPtr || TclIsVarUndefined(varPtr)) { - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); - } else if (!isArray) { - return NotArrayError(interp, arrayNameObj); - } else { - defaultValueObj = TclGetArrayDefault(varPtr); - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(!!defaultValueObj)); - } - return TCL_OK; - - case OPT_UNSET: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); - return TCL_ERROR; - } - - if (varPtr && !TclIsVarUndefined(varPtr)) { - if (!isArray) { - return NotArrayError(interp, arrayNameObj); - } - SetArrayDefault(varPtr, NULL); - } - return TCL_OK; - } - - /* Unreached */ - return TCL_ERROR; -} - -/* - * Initialize array variable. - */ - -void -TclInitArrayVar( - Var *arrayPtr) -{ - ArrayVarHashTable *tablePtr = (ArrayVarHashTable *)Tcl_Alloc(sizeof(ArrayVarHashTable)); - - /* - * Mark the variable as an array. - */ - - TclSetVarArray(arrayPtr); - - /* - * Regular TclVarHashTable initialization. - */ - - arrayPtr->value.tablePtr = (TclVarHashTable *) tablePtr; - TclInitVarHashTable(arrayPtr->value.tablePtr, TclGetVarNsPtr(arrayPtr)); - - /* - * Default value initialization. - */ - - tablePtr->defaultObj = NULL; -} - -/* - * Cleanup array variable. - */ - -static void -DeleteArrayVar( - Var *arrayPtr) -{ - ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) - arrayPtr->value.tablePtr; - - /* - * Default value cleanup. - */ - - SetArrayDefault(arrayPtr, NULL); - - /* - * Regular TclVarHashTable cleanup. - */ - - VarHashDeleteTable(arrayPtr->value.tablePtr); - Tcl_Free(tablePtr); -} - -/* - * Get array default value if any. - */ - -Tcl_Obj * -TclGetArrayDefault( - Var *arrayPtr) -{ - ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) - arrayPtr->value.tablePtr; - - return tablePtr->defaultObj; -} - -/* - * Set/replace/unset array default value. - */ - -static void -SetArrayDefault( - Var *arrayPtr, - Tcl_Obj *defaultObj) -{ - ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) - arrayPtr->value.tablePtr; - - /* - * Increment/decrement refcount twice to ensure that the object is shared, - * so that it doesn't get modified accidentally by the folling code: - * - * array default set v 1 - * lappend v(a) 2; # returns a new object {1 2} - * set v(b); # returns the original default object "1" - */ - - if (tablePtr->defaultObj) { - Tcl_DecrRefCount(tablePtr->defaultObj); - Tcl_DecrRefCount(tablePtr->defaultObj); - } - tablePtr->defaultObj = defaultObj; - if (tablePtr->defaultObj) { - Tcl_IncrRefCount(tablePtr->defaultObj); - Tcl_IncrRefCount(tablePtr->defaultObj); - } + * Only compare if the string representations are of the same length. + */ + + if (l1 == l2) { + for (;; p1++, p2++, l1--) { + if (*p1 != *p2) { + break; + } + if (l1 == 0) { + return 1; + } + } + } + + return 0; +} + +static unsigned int +HashVarKey( + Tcl_HashTable *tablePtr, /* Hash table. */ + void *keyPtr) /* Key from which to compute hash value. */ +{ + Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr; + const char *string = TclGetString(objPtr); + int length = objPtr->length; + unsigned int result = 0; + int i; + + /* + * 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: + * + * 1. Multiplying by 10 is perfect for keys that are decimal strings, and + * multiplying by 9 is just about as good. + * 2. Times-9 is (shift-left-3) plus (old). This means that each + * character's bits hang around in the low-order bits of the hash value + * for ever, plus they spread fairly rapidly up to the high-order bits + * to fill out the hash value. This seems works well both for decimal + * and non-decimal strings. + */ + + for (i=0 ; i - * Copyright (c) 2013-2015 Christian Werner - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * This file is distributed in two ways: - * generic/tclZipfs.c file in the TIP430-enabled Tcl cores. - * compat/tclZipfs.c file in the tclconfig (TEA) file system, for pre-tip430 - * projects. - */ - -#include "tclInt.h" -#include "tclFileSystem.h" - -#ifndef _WIN32 -#include -#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 -*/ - -#define ZIPFS_VOLUME "//zipfs:/" -#define ZIPFS_VOLUME_LEN 9 -#define ZIPFS_APP_MOUNT "//zipfs:/app" -#define ZIPFS_ZIP_MOUNT "//zipfs:/lib/tcl" - -#else /* !CFG_RUNTIME_DLLFILE */ - -/* -** We are compiling from the /compat folder of tclconfig -** Pre TIP430 style zipfs prefix -** //zipfs:/ doesn't work straight out of the box on either windows or Unix -** without other changes made to tip 430 -*/ - -#define ZIPFS_VOLUME "zipfs:/" -#define ZIPFS_VOLUME_LEN 7 -#define ZIPFS_APP_MOUNT "zipfs:/app" -#define ZIPFS_ZIP_MOUNT "zipfs:/lib/tcl" - -#endif /* CFG_RUNTIME_DLLFILE */ - -/* - * Various constants and offsets found in ZIP archive files - */ - -#define ZIP_SIG_LEN 4 - -/* - * Local header of ZIP archive member (at very beginning of each member). - */ - -#define ZIP_LOCAL_HEADER_SIG 0x04034b50 -#define ZIP_LOCAL_HEADER_LEN 30 -#define ZIP_LOCAL_SIG_OFFS 0 -#define ZIP_LOCAL_VERSION_OFFS 4 -#define ZIP_LOCAL_FLAGS_OFFS 6 -#define ZIP_LOCAL_COMPMETH_OFFS 8 -#define ZIP_LOCAL_MTIME_OFFS 10 -#define ZIP_LOCAL_MDATE_OFFS 12 -#define ZIP_LOCAL_CRC32_OFFS 14 -#define ZIP_LOCAL_COMPLEN_OFFS 18 -#define ZIP_LOCAL_UNCOMPLEN_OFFS 22 -#define ZIP_LOCAL_PATHLEN_OFFS 26 -#define ZIP_LOCAL_EXTRALEN_OFFS 28 - -/* - * Central header of ZIP archive member at end of ZIP file. - */ - -#define ZIP_CENTRAL_HEADER_SIG 0x02014b50 -#define ZIP_CENTRAL_HEADER_LEN 46 -#define ZIP_CENTRAL_SIG_OFFS 0 -#define ZIP_CENTRAL_VERSIONMADE_OFFS 4 -#define ZIP_CENTRAL_VERSION_OFFS 6 -#define ZIP_CENTRAL_FLAGS_OFFS 8 -#define ZIP_CENTRAL_COMPMETH_OFFS 10 -#define ZIP_CENTRAL_MTIME_OFFS 12 -#define ZIP_CENTRAL_MDATE_OFFS 14 -#define ZIP_CENTRAL_CRC32_OFFS 16 -#define ZIP_CENTRAL_COMPLEN_OFFS 20 -#define ZIP_CENTRAL_UNCOMPLEN_OFFS 24 -#define ZIP_CENTRAL_PATHLEN_OFFS 28 -#define ZIP_CENTRAL_EXTRALEN_OFFS 30 -#define ZIP_CENTRAL_FCOMMENTLEN_OFFS 32 -#define ZIP_CENTRAL_DISKFILE_OFFS 34 -#define ZIP_CENTRAL_IATTR_OFFS 36 -#define ZIP_CENTRAL_EATTR_OFFS 38 -#define ZIP_CENTRAL_LOCALHDR_OFFS 42 - -/* - * Central end signature at very end of ZIP file. - */ - -#define ZIP_CENTRAL_END_SIG 0x06054b50 -#define ZIP_CENTRAL_END_LEN 22 -#define ZIP_CENTRAL_END_SIG_OFFS 0 -#define ZIP_CENTRAL_DISKNO_OFFS 4 -#define ZIP_CENTRAL_DISKDIR_OFFS 6 -#define ZIP_CENTRAL_ENTS_OFFS 8 -#define ZIP_CENTRAL_TOTALENTS_OFFS 10 -#define ZIP_CENTRAL_DIRSIZE_OFFS 12 -#define ZIP_CENTRAL_DIRSTART_OFFS 16 -#define ZIP_CENTRAL_COMMENTLEN_OFFS 20 - -#define ZIP_MIN_VERSION 20 -#define ZIP_COMPMETH_STORED 0 -#define ZIP_COMPMETH_DEFLATED 8 - -#define ZIP_PASSWORD_END_SIG 0x5a5a4b50 - -#define DEFAULT_WRITE_MAX_SIZE (2 * 1024 * 1024) - -/* - * Macros to report errors only if an interp is present. - */ - -#define ZIPFS_ERROR(interp,errstr) \ - do { \ - if (interp) { \ - Tcl_SetObjResult(interp, Tcl_NewStringObj(errstr, -1)); \ - } \ - } while (0) -#define ZIPFS_POSIX_ERROR(interp,errstr) \ - do { \ - if (interp) { \ - Tcl_SetObjResult(interp, Tcl_ObjPrintf( \ - "%s: %s", errstr, Tcl_PosixError(interp))); \ - } \ - } while (0) - -/* - * Macros to read and write 16 and 32 bit integers from/to ZIP archives. - */ - -#define ZipReadInt(p) \ - ((p)[0] | ((p)[1] << 8) | ((p)[2] << 16) | ((p)[3] << 24)) -#define ZipReadShort(p) \ - ((p)[0] | ((p)[1] << 8)) - -#define ZipWriteInt(p, v) \ - do { \ - (p)[0] = (v) & 0xff; \ - (p)[1] = ((v) >> 8) & 0xff; \ - (p)[2] = ((v) >> 16) & 0xff; \ - (p)[3] = ((v) >> 24) & 0xff; \ - } while (0) -#define ZipWriteShort(p, v) \ - do { \ - (p)[0] = (v) & 0xff; \ - (p)[1] = ((v) >> 8) & 0xff; \ - } while (0) - -/* - * Windows drive letters. - */ - -#ifdef _WIN32 -static const char drvletters[] = - "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"; -#endif /* _WIN32 */ - -/* - * Mutex to protect localtime(3) when no reentrant version available. - */ - -#if !defined(_WIN32) && !defined(HAVE_LOCALTIME_R) && TCL_THREADS -TCL_DECLARE_MUTEX(localtimeMutex) -#endif /* !_WIN32 && !HAVE_LOCALTIME_R && TCL_THREADS */ - -/* - * In-core description of mounted ZIP archive file. - */ - -typedef struct ZipFile { - char *name; /* Archive name */ - size_t nameLength; /* Length of archive name */ - char isMemBuffer; /* When true, not a file but a memory buffer */ - Tcl_Channel chan; /* Channel handle or NULL */ - unsigned char *data; /* Memory mapped or malloc'ed file */ - size_t length; /* Length of memory mapped file */ - void *ptrToFree; /* Non-NULL if malloc'ed file */ - size_t numFiles; /* Number of files in archive */ - size_t baseOffset; /* Archive start */ - size_t passOffset; /* Password start */ - size_t directoryOffset; /* Archive directory start */ - unsigned char passBuf[264]; /* Password buffer */ - size_t numOpen; /* Number of open files on archive */ - struct ZipEntry *entries; /* List of files in archive */ - struct ZipEntry *topEnts; /* List of top-level dirs in archive */ - char *mountPoint; /* Mount point name */ - size_t mountPointLen; /* Length of mount point name */ -#ifdef _WIN32 - HANDLE mountHandle; /* Handle used for direct file access. */ -#endif /* _WIN32 */ -} ZipFile; - -/* - * In-core description of file contained in mounted ZIP archive. - */ - -typedef struct ZipEntry { - char *name; /* The full pathname of the virtual file */ - ZipFile *zipFilePtr; /* The ZIP file holding this virtual file */ - Tcl_WideInt offset; /* Data offset into memory mapped ZIP file */ - int numBytes; /* Uncompressed size of the virtual file */ - int numCompressedBytes; /* Compressed size of the virtual file */ - int compressMethod; /* Compress method */ - int isDirectory; /* Set to 1 if directory, or -1 if root */ - int depth; /* Number of slashes in path. */ - int crc32; /* CRC-32 */ - int timestamp; /* Modification time */ - int isEncrypted; /* True if data is encrypted */ - unsigned char *data; /* File data if written */ - struct ZipEntry *next; /* Next file in the same archive */ - struct ZipEntry *tnext; /* Next top-level dir in archive */ -} ZipEntry; - -/* - * File channel for file contained in mounted ZIP archive. - */ - -typedef struct ZipChannel { - ZipFile *zipFilePtr; /* The ZIP file holding this channel */ - ZipEntry *zipEntryPtr; /* Pointer back to virtual file */ - size_t maxWrite; /* Maximum size for write */ - size_t numBytes; /* Number of bytes of uncompressed data */ - size_t numRead; /* Position of next byte to be read from the - * channel */ - unsigned char *ubuf; /* Pointer to the uncompressed data */ - int iscompr; /* True if data is compressed */ - int isDirectory; /* Set to 1 if directory, or -1 if root */ - int isEncrypted; /* True if data is encrypted */ - int isWriting; /* True if open for writing */ - unsigned long keys[3]; /* Key for decryption */ -} ZipChannel; - -/* - * Global variables. - * - * Most are kept in single ZipFS struct. When build with threading support - * this struct is protected by the ZipFSMutex (see below). - * - * The "fileHash" component is the process wide global table of all known ZIP - * archive members in all mounted ZIP archives. - * - * The "zipHash" components is the process wide global table of all mounted - * ZIP archive files. - */ - -static struct { - int initialized; /* True when initialized */ - int lock; /* RW lock, see below */ - 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); -static int ZipfsAppHookFindTclInit(const char *archive); -static int ZipFSPathInFilesystemProc(Tcl_Obj *pathPtr, - void **clientDataPtr); -static Tcl_Obj * ZipFSFilesystemPathTypeProc(Tcl_Obj *pathPtr); -static Tcl_Obj * ZipFSFilesystemSeparatorProc(Tcl_Obj *pathPtr); -static int ZipFSStatProc(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); -static int ZipFSAccessProc(Tcl_Obj *pathPtr, int mode); -static Tcl_Channel ZipFSOpenFileChannelProc(Tcl_Interp *interp, - Tcl_Obj *pathPtr, int mode, int permissions); -static int ZipFSMatchInDirectoryProc(Tcl_Interp *interp, - Tcl_Obj *result, Tcl_Obj *pathPtr, - const char *pattern, Tcl_GlobTypeData *types); -static Tcl_Obj * ZipFSListVolumesProc(void); -static const char *const *ZipFSFileAttrStringsProc(Tcl_Obj *pathPtr, - Tcl_Obj **objPtrRef); -static int ZipFSFileAttrsGetProc(Tcl_Interp *interp, int index, - Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); -static int ZipFSFileAttrsSetProc(Tcl_Interp *interp, int index, - 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); -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 */ - NULL, /* createInternalRepProc */ - NULL, /* normalizePathProc */ - ZipFSFilesystemPathTypeProc, - ZipFSFilesystemSeparatorProc, - ZipFSStatProc, - ZipFSAccessProc, - ZipFSOpenFileChannelProc, - ZipFSMatchInDirectoryProc, - NULL, /* utimeProc */ - NULL, /* linkProc */ - ZipFSListVolumesProc, - ZipFSFileAttrStringsProc, - ZipFSFileAttrsGetProc, - ZipFSFileAttrsSetProc, - 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, - NULL, /* Close channel, clean instance data */ - ZipChannelRead, /* Handle read request */ - ZipChannelWrite, /* Handle write request */ - NULL, /* Move location of access point, NULL'able */ - 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 */ -}; - -/* - *------------------------------------------------------------------------- - * - * ReadLock, WriteLock, Unlock -- - * - * POSIX like rwlock functions to support multiple readers and single - * writer on internal structs. - * - * Limitations: - * - a read lock cannot be promoted to a write lock - * - a write lock may not be nested - * - *------------------------------------------------------------------------- - */ - -TCL_DECLARE_MUTEX(ZipFSMutex) - -#if TCL_THREADS - -static Tcl_Condition ZipFSCond; - -static void -ReadLock(void) -{ - Tcl_MutexLock(&ZipFSMutex); - while (ZipFS.lock < 0) { - ZipFS.waiters++; - Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, NULL); - ZipFS.waiters--; - } - ZipFS.lock++; - Tcl_MutexUnlock(&ZipFSMutex); -} - -static void -WriteLock(void) -{ - Tcl_MutexLock(&ZipFSMutex); - while (ZipFS.lock != 0) { - ZipFS.waiters++; - Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, NULL); - ZipFS.waiters--; - } - ZipFS.lock = -1; - Tcl_MutexUnlock(&ZipFSMutex); -} - -static void -Unlock(void) -{ - Tcl_MutexLock(&ZipFSMutex); - if (ZipFS.lock > 0) { - --ZipFS.lock; - } else if (ZipFS.lock < 0) { - ZipFS.lock = 0; - } - if ((ZipFS.lock == 0) && (ZipFS.waiters > 0)) { - Tcl_ConditionNotify(&ZipFSCond); - } - Tcl_MutexUnlock(&ZipFSMutex); -} - -#else /* !TCL_THREADS */ -#define ReadLock() do {} while (0) -#define WriteLock() do {} while (0) -#define Unlock() do {} while (0) -#endif /* TCL_THREADS */ - -/* - *------------------------------------------------------------------------- - * - * DosTimeDate, ToDosTime, ToDosDate -- - * - * Functions to perform conversions between DOS time stamps and POSIX - * time_t. - * - *------------------------------------------------------------------------- - */ - -static time_t -DosTimeDate( - int dosDate, - int dosTime) -{ - struct tm tm; - time_t ret; - - memset(&tm, 0, sizeof(tm)); - tm.tm_isdst = -1; /* let mktime() deal with DST */ - tm.tm_year = ((dosDate & 0xfe00) >> 9) + 80; - tm.tm_mon = ((dosDate & 0x1e0) >> 5) - 1; - tm.tm_mday = dosDate & 0x1f; - tm.tm_hour = (dosTime & 0xf800) >> 11; - tm.tm_min = (dosTime & 0x7e0) >> 5; - tm.tm_sec = (dosTime & 0x1f) << 1; - ret = mktime(&tm); - if (ret == (time_t) -1) { - /* fallback to 1980-01-01T00:00:00+00:00 (DOS epoch) */ - ret = (time_t) 315532800; - } - return ret; -} - -static int -ToDosTime( - time_t when) -{ - struct tm *tmp, tm; - -#if !TCL_THREADS || defined(_WIN32) - /* Not threaded, or on Win32 which uses thread local storage */ - tmp = localtime(&when); - tm = *tmp; -#elif defined(HAVE_LOCALTIME_R) - /* Threaded, have reentrant API */ - tmp = &tm; - localtime_r(&when, tmp); -#else /* TCL_THREADS && !_WIN32 && !HAVE_LOCALTIME_R */ - /* Only using a mutex is safe. */ - Tcl_MutexLock(&localtimeMutex); - tmp = localtime(&when); - tm = *tmp; - Tcl_MutexUnlock(&localtimeMutex); -#endif - return (tm.tm_hour << 11) | (tm.tm_min << 5) | (tm.tm_sec >> 1); -} - -static int -ToDosDate( - time_t when) -{ - struct tm *tmp, tm; - -#if !TCL_THREADS || defined(_WIN32) - /* Not threaded, or on Win32 which uses thread local storage */ - tmp = localtime(&when); - tm = *tmp; -#elif /* TCL_THREADS && !_WIN32 && */ defined(HAVE_LOCALTIME_R) - /* Threaded, have reentrant API */ - tmp = &tm; - localtime_r(&when, tmp); -#else /* TCL_THREADS && !_WIN32 && !HAVE_LOCALTIME_R */ - /* Only using a mutex is safe. */ - Tcl_MutexLock(&localtimeMutex); - tmp = localtime(&when); - tm = *tmp; - Tcl_MutexUnlock(&localtimeMutex); -#endif - return ((tm.tm_year - 80) << 9) | ((tm.tm_mon + 1) << 5) | tm.tm_mday; -} - -/* - *------------------------------------------------------------------------- - * - * CountSlashes -- - * - * This function counts the number of slashes in a pathname string. - * - * Results: - * Number of slashes found in string. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -CountSlashes( - const char *string) -{ - int count = 0; - const char *p = string; - - while (*p != '\0') { - if (*p == '/') { - count++; - } - p++; - } - return count; -} - -/* - *------------------------------------------------------------------------- - * - * CanonicalPath -- - * - * This function computes the canonical path from a directory and file - * name components into the specified Tcl_DString. - * - * Results: - * Returns the pointer to the canonical path contained in the specified - * Tcl_DString. - * - * Side effects: - * Modifies the specified Tcl_DString. - * - *------------------------------------------------------------------------- - */ - -static char * -CanonicalPath( - const char *root, - const char *tail, - Tcl_DString *dsPtr, - int inZipfs) -{ - char *path; - int i, j, c, isUNC = 0, isVfs = 0, n = 0; - int haveZipfsPath = 1; - -#ifdef _WIN32 - if (tail[0] != '\0' && strchr(drvletters, tail[0]) && tail[1] == ':') { - tail += 2; - haveZipfsPath = 0; - } - /* UNC style path */ - if (tail[0] == '\\') { - root = ""; - ++tail; - haveZipfsPath = 0; - } - if (tail[0] == '\\') { - root = "/"; - ++tail; - haveZipfsPath = 0; - } -#endif /* _WIN32 */ - - if (haveZipfsPath) { - /* UNC style path */ - if (root && strncmp(root, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) == 0) { - isVfs = 1; - } else if (tail && - strncmp(tail, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) == 0) { - isVfs = 2; - } - if (isVfs != 1 && (root[0] == '/') && (root[1] == '/')) { - isUNC = 1; - } - } - - if (isVfs != 2) { - if (tail[0] == '/') { - if (isVfs != 1) { - root = ""; - } - ++tail; - isUNC = 0; - } - if (tail[0] == '/') { - if (isVfs != 1) { - root = "/"; - } - ++tail; - isUNC = 1; - } - } - i = strlen(root); - j = strlen(tail); - - switch (isVfs) { - case 1: - if (i > ZIPFS_VOLUME_LEN) { - Tcl_DStringSetLength(dsPtr, i + j + 1); - path = Tcl_DStringValue(dsPtr); - memcpy(path, root, i); - path[i++] = '/'; - memcpy(path + i, tail, j); - } else { - Tcl_DStringSetLength(dsPtr, i + j); - path = Tcl_DStringValue(dsPtr); - memcpy(path, root, i); - memcpy(path + i, tail, j); - } - break; - case 2: - Tcl_DStringSetLength(dsPtr, j); - path = Tcl_DStringValue(dsPtr); - memcpy(path, tail, j); - break; - default: - if (inZipfs) { - Tcl_DStringSetLength(dsPtr, i + j + ZIPFS_VOLUME_LEN); - path = Tcl_DStringValue(dsPtr); - memcpy(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN); - memcpy(path + ZIPFS_VOLUME_LEN + i , tail, j); - } else { - Tcl_DStringSetLength(dsPtr, i + j + 1); - path = Tcl_DStringValue(dsPtr); - memcpy(path, root, i); - path[i++] = '/'; - memcpy(path + i, tail, j); - } - break; - } - -#ifdef _WIN32 - for (i = 0; path[i] != '\0'; i++) { - if (path[i] == '\\') { - path[i] = '/'; - } - } -#endif /* _WIN32 */ - - if (inZipfs) { - n = ZIPFS_VOLUME_LEN; - } else { - n = 0; - } - - for (i = j = n; (c = path[i]) != '\0'; i++) { - if (c == '/') { - int c2 = path[i + 1]; - - if (c2 == '\0' || c2 == '/') { - continue; - } - if (c2 == '.') { - int c3 = path[i + 2]; - - if ((c3 == '/') || (c3 == '\0')) { - i++; - continue; - } - if ((c3 == '.') - && ((path[i + 3] == '/') || (path[i + 3] == '\0'))) { - i += 2; - while ((j > 0) && (path[j - 1] != '/')) { - j--; - } - if (j > isUNC) { - --j; - while ((j > 1 + isUNC) && (path[j - 2] == '/')) { - j--; - } - } - continue; - } - } - } - path[j++] = c; - } - if (j == 0) { - path[j++] = '/'; - } - path[j] = 0; - Tcl_DStringSetLength(dsPtr, j); - return Tcl_DStringValue(dsPtr); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSLookup -- - * - * This function returns the ZIP entry struct corresponding to the ZIP - * archive member of the given file name. Caller must hold the right - * lock. - * - * Results: - * Returns the pointer to ZIP entry struct or NULL if the the given file - * name could not be found in the global list of ZIP archive members. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static ZipEntry * -ZipFSLookup( - char *filename) -{ - Tcl_HashEntry *hPtr; - ZipEntry *z = NULL; - - hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, filename); - if (hPtr) { - z = (ZipEntry *)Tcl_GetHashValue(hPtr); - } - return z; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSLookupMount -- - * - * This function returns an indication if the given file name corresponds - * to a mounted ZIP archive file. - * - * Results: - * Returns true, if the given file name is a mounted ZIP archive file. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -#ifdef NEVER_USED -static int -ZipFSLookupMount( - char *filename) -{ - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - - for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; - hPtr = Tcl_NextHashEntry(&search)) { - ZipFile *zf = Tcl_GetHashValue(hPtr); - - if (strcmp(zf->mountPoint, filename) == 0) { - return 1; - } - } - return 0; -} -#endif /* NEVER_USED */ - -/* - *------------------------------------------------------------------------- - * - * ZipFSCloseArchive -- - * - * This function closes a mounted ZIP archive file. - * - * Results: - * None. - * - * Side effects: - * A memory mapped ZIP archive is unmapped, allocated memory is released. - * The ZipFile pointer is *NOT* deallocated by this function. - * - *------------------------------------------------------------------------- - */ - -static void -ZipFSCloseArchive( - Tcl_Interp *interp, /* Current interpreter. */ - ZipFile *zf) -{ - if (zf->nameLength) { - Tcl_Free(zf->name); - } - if (zf->isMemBuffer) { - /* Pointer to memory */ - if (zf->ptrToFree) { - Tcl_Free(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) { - Tcl_Free(zf->ptrToFree); - zf->ptrToFree = NULL; - } - if (zf->chan) { - Tcl_CloseEx(interp, zf->chan, 0); - zf->chan = NULL; - } -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSFindTOC -- - * - * This function takes a memory mapped zip file and indexes the contents. - * When "needZip" is zero an embedded ZIP archive in an executable file - * is accepted. - * - * Results: - * TCL_OK on success, TCL_ERROR otherwise with an error message placed - * into the given "interp" if it is not NULL. - * - * Side effects: - * The given ZipFile struct is filled with information about the ZIP - * archive file. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSFindTOC( - Tcl_Interp *interp, /* Current interpreter. NULLable. */ - int needZip, - ZipFile *zf) -{ - size_t i; - unsigned char *p, *q; - - p = zf->data + zf->length - ZIP_CENTRAL_END_LEN; - while (p >= zf->data) { - if (*p == (ZIP_CENTRAL_END_SIG & 0xFF)) { - if (ZipReadInt(p) == ZIP_CENTRAL_END_SIG) { - break; - } - p -= ZIP_SIG_LEN; - } else { - --p; - } - } - if (p < zf->data) { - if (!needZip) { - zf->baseOffset = zf->passOffset = zf->length; - return TCL_OK; - } - ZIPFS_ERROR(interp, "wrong end signature"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "END_SIG", NULL); - } - goto error; - } - zf->numFiles = ZipReadShort(p + ZIP_CENTRAL_ENTS_OFFS); - if (zf->numFiles == 0) { - if (!needZip) { - zf->baseOffset = zf->passOffset = zf->length; - return TCL_OK; - } - ZIPFS_ERROR(interp, "empty archive"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "EMPTY", NULL); - } - goto error; - } - q = zf->data + ZipReadInt(p + ZIP_CENTRAL_DIRSTART_OFFS); - p -= ZipReadInt(p + ZIP_CENTRAL_DIRSIZE_OFFS); - if ((p < zf->data) || (p > zf->data + zf->length) - || (q < zf->data) || (q > zf->data + zf->length)) { - if (!needZip) { - zf->baseOffset = zf->passOffset = zf->length; - return TCL_OK; - } - ZIPFS_ERROR(interp, "archive directory not found"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_DIR", NULL); - } - goto error; - } - zf->baseOffset = zf->passOffset = p - q; - zf->directoryOffset = p - zf->data; - q = p; - for (i = 0; i < zf->numFiles; i++) { - int pathlen, comlen, extra; - - if (q + ZIP_CENTRAL_HEADER_LEN > zf->data + zf->length) { - ZIPFS_ERROR(interp, "wrong header length"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "HDR_LEN", NULL); - } - goto error; - } - if (ZipReadInt(q) != ZIP_CENTRAL_HEADER_SIG) { - ZIPFS_ERROR(interp, "wrong header signature"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "HDR_SIG", NULL); - } - goto error; - } - pathlen = ZipReadShort(q + ZIP_CENTRAL_PATHLEN_OFFS); - comlen = ZipReadShort(q + ZIP_CENTRAL_FCOMMENTLEN_OFFS); - extra = ZipReadShort(q + ZIP_CENTRAL_EXTRALEN_OFFS); - q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN; - } - q = zf->data + zf->baseOffset; - if ((zf->baseOffset >= 6) && (ZipReadInt(q - 4) == ZIP_PASSWORD_END_SIG)) { - i = q[-5]; - if (q - 5 - i > zf->data) { - zf->passBuf[0] = i; - memcpy(zf->passBuf + 1, q - 5 - i, i); - zf->passOffset -= i ? (5 + i) : 0; - } - } - return TCL_OK; - - error: - ZipFSCloseArchive(interp, zf); - return TCL_ERROR; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSOpenArchive -- - * - * This function opens a ZIP archive file for reading. An attempt is made - * to memory map that file. Otherwise it is read into an allocated memory - * buffer. The ZIP archive header is verified and must be valid for the - * function to succeed. When "needZip" is zero an embedded ZIP archive in - * an executable file is accepted. - * - * Results: - * TCL_OK on success, TCL_ERROR otherwise with an error message placed - * into the given "interp" if it is not NULL. - * - * Side effects: - * ZIP archive is memory mapped or read into allocated memory, the given - * ZipFile struct is filled with information about the ZIP archive file. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSOpenArchive( - Tcl_Interp *interp, /* Current interpreter. NULLable. */ - const char *zipname, /* Path to ZIP file to open. */ - int needZip, - ZipFile *zf) -{ - size_t i; - void *handle; - - 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 == TCL_IO_FAILURE) { - 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 *)Tcl_AttemptAlloc(zf->length); - if (!zf->ptrToFree) { - ZIPFS_ERROR(interp, "out of memory"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); - } - goto error; - } - i = Tcl_Read(zf->chan, (char *) zf->data, zf->length); - if (i != zf->length) { - ZIPFS_POSIX_ERROR(interp, "file read error"); - goto error; - } - Tcl_CloseEx(interp, zf->chan, 0); - zf->chan = NULL; - } else { -#ifdef _WIN32 - int readSuccessful; -# ifdef _WIN64 - i = GetFileSizeEx((HANDLE) handle, (PLARGE_INTEGER) &zf->length); - readSuccessful = (i != 0); -# else /* !_WIN64 */ - 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 == TCL_IO_FAILURE || 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) { - ZIPFS_POSIX_ERROR(interp, "file mapping failed"); - goto error; - } -#endif /* _WIN32 */ - } - return ZipFSFindTOC(interp, needZip, zf); - - error: - ZipFSCloseArchive(interp, zf); - return TCL_ERROR; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSRootNode -- - * - * This function generates the root node for a ZIPFS filesystem. - * - * Results: - * TCL_OK on success, TCL_ERROR otherwise with an error message placed - * into the given "interp" if it is not NULL. - * - * Side effects: - * ... - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSCatalogFilesystem( - Tcl_Interp *interp, /* Current interpreter. NULLable. */ - ZipFile *zf0, - const char *mountPoint, /* Mount point path. */ - const char *passwd, /* Password for opening the ZIP, or NULL if - * the ZIP is unprotected. */ - const char *zipname) /* Path to ZIP file to build a catalog of. */ -{ - int pwlen, isNew; - size_t i; - ZipFile *zf; - ZipEntry *z; - Tcl_HashEntry *hPtr; - Tcl_DString ds, dsm, fpBuf; - unsigned char *q; - - /* - * Basic verification of the password for sanity. - */ - - pwlen = 0; - if (passwd) { - pwlen = strlen(passwd); - if ((pwlen > 255) || strchr(passwd, 0xff)) { - if (interp) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("illegal password", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL); - } - return TCL_ERROR; - } - } - - WriteLock(); - - /* - * Mount point sometimes is a relative or otherwise denormalized path. - * But an absolute name is needed as mount point here. - */ - - Tcl_DStringInit(&ds); - Tcl_DStringInit(&dsm); - if (strcmp(mountPoint, "/") == 0) { - 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 *)Tcl_AttemptAlloc(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 *)Tcl_Alloc(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 *)Tcl_Alloc(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++) { - int extra, isdir = 0, dosTime, dosDate, nbcompr; - size_t offs, pathlen, comlen; - unsigned char *lq, *gq = NULL; - char *fullpath, *path; - - pathlen = ZipReadShort(q + ZIP_CENTRAL_PATHLEN_OFFS); - comlen = ZipReadShort(q + ZIP_CENTRAL_FCOMMENTLEN_OFFS); - extra = ZipReadShort(q + ZIP_CENTRAL_EXTRALEN_OFFS); - Tcl_DStringSetLength(&ds, 0); - Tcl_DStringAppend(&ds, (char *) q + ZIP_CENTRAL_HEADER_LEN, pathlen); - path = Tcl_DStringValue(&ds); - if ((pathlen > 0) && (path[pathlen - 1] == '/')) { - Tcl_DStringSetLength(&ds, pathlen - 1); - path = Tcl_DStringValue(&ds); - isdir = 1; - } - if ((strcmp(path, ".") == 0) || (strcmp(path, "..") == 0)) { - goto nextent; - } - lq = zf->data + zf->baseOffset - + ZipReadInt(q + ZIP_CENTRAL_LOCALHDR_OFFS); - if ((lq < zf->data) || (lq > zf->data + zf->length)) { - goto nextent; - } - nbcompr = ZipReadInt(lq + ZIP_LOCAL_COMPLEN_OFFS); - if (!isdir && (nbcompr == 0) - && (ZipReadInt(lq + ZIP_LOCAL_UNCOMPLEN_OFFS) == 0) - && (ZipReadInt(lq + ZIP_LOCAL_CRC32_OFFS) == 0)) { - gq = q; - nbcompr = ZipReadInt(gq + ZIP_CENTRAL_COMPLEN_OFFS); - } - offs = (lq - zf->data) - + ZIP_LOCAL_HEADER_LEN - + ZipReadShort(lq + ZIP_LOCAL_PATHLEN_OFFS) - + ZipReadShort(lq + ZIP_LOCAL_EXTRALEN_OFFS); - if (offs + nbcompr > zf->length) { - goto nextent; - } - if (!isdir && (mountPoint[0] == '\0') && !CountSlashes(path)) { -#ifdef ANDROID - /* - * When mounting the ZIP archive on the root directory try to - * remap top level regular files of the archive to - * /assets/.root/... since this directory should not be in a valid - * APK due to the leading dot in the file name component. This - * trick should make the files AndroidManifest.xml, - * resources.arsc, and classes.dex visible to Tcl. - */ - Tcl_DString ds2; - - Tcl_DStringInit(&ds2); - Tcl_DStringAppend(&ds2, "assets/.root/", -1); - Tcl_DStringAppend(&ds2, path, -1); - hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, Tcl_DStringValue(&ds2)); - if (hPtr) { - /* should not happen but skip it anyway */ - Tcl_DStringFree(&ds2); - goto nextent; - } - Tcl_DStringSetLength(&ds, 0); - Tcl_DStringAppend(&ds, Tcl_DStringValue(&ds2), - Tcl_DStringLength(&ds2)); - path = Tcl_DStringValue(&ds); - Tcl_DStringFree(&ds2); -#else /* !ANDROID */ - /* - * Regular files skipped when mounting on root. - */ - goto nextent; -#endif /* ANDROID */ - } - Tcl_DStringSetLength(&fpBuf, 0); - fullpath = CanonicalPath(mountPoint, path, &fpBuf, 1); - z = (ZipEntry *)Tcl_Alloc(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); - z->offset = offs; - if (gq) { - z->crc32 = ZipReadInt(gq + ZIP_CENTRAL_CRC32_OFFS); - dosDate = ZipReadShort(gq + ZIP_CENTRAL_MDATE_OFFS); - dosTime = ZipReadShort(gq + ZIP_CENTRAL_MTIME_OFFS); - z->timestamp = DosTimeDate(dosDate, dosTime); - z->numBytes = ZipReadInt(gq + ZIP_CENTRAL_UNCOMPLEN_OFFS); - z->compressMethod = ZipReadShort(gq + ZIP_CENTRAL_COMPMETH_OFFS); - } else { - z->crc32 = ZipReadInt(lq + ZIP_LOCAL_CRC32_OFFS); - dosDate = ZipReadShort(lq + ZIP_LOCAL_MDATE_OFFS); - dosTime = ZipReadShort(lq + ZIP_LOCAL_MTIME_OFFS); - z->timestamp = DosTimeDate(dosDate, dosTime); - z->numBytes = ZipReadInt(lq + ZIP_LOCAL_UNCOMPLEN_OFFS); - 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 */ - Tcl_Free(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)) { - char *dir, *end; - ZipEntry *zd; - - Tcl_DStringSetLength(&ds, strlen(z->name) + 8); - Tcl_DStringSetLength(&ds, 0); - Tcl_DStringAppend(&ds, z->name, -1); - dir = Tcl_DStringValue(&ds); - 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 *)Tcl_Alloc(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; - } - } - } - } - nextent: - q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN; - } - Tcl_DStringFree(&fpBuf); - Tcl_DStringFree(&ds); - Tcl_FSMountsChanged(NULL); - Unlock(); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipfsSetup -- - * - * Common initialisation code. ZipFS.initialized must *not* be set prior - * to the call. - * - *------------------------------------------------------------------------- - */ - -static void -ZipfsSetup(void) -{ -#if TCL_THREADS - static const Tcl_Time t = { 0, 0 }; - - /* - * Inflate condition variable. - */ - - Tcl_MutexLock(&ZipFSMutex); - Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, &t); - Tcl_MutexUnlock(&ZipFSMutex); -#endif /* TCL_THREADS */ - - Tcl_FSRegister(NULL, &zipfsFilesystem); - Tcl_InitHashTable(&ZipFS.fileHash, TCL_STRING_KEYS); - Tcl_InitHashTable(&ZipFS.zipHash, TCL_STRING_KEYS); - ZipFS.idCount = 1; - ZipFS.wrmax = DEFAULT_WRITE_MAX_SIZE; - ZipFS.initialized = 1; -} - -/* - *------------------------------------------------------------------------- - * - * ListMountPoints -- - * - * This procedure lists the mount points and what's mounted there, or - * reports whether there are any mounts (if there's no interpreter). The - * read lock must be held by the caller. - * - * Results: - * A standard Tcl result. TCL_OK (or TCL_BREAK if no mounts and no - * interpreter). - * - * Side effects: - * Interpreter result may be updated. - * - *------------------------------------------------------------------------- - */ - -static inline int -ListMountPoints( - Tcl_Interp *interp) -{ - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - 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); -} - -/* - *------------------------------------------------------------------------- - * - * DescribeMounted -- - * - * This procedure describes what is mounted at the given the mount point. - * The interpreter result is not updated if there is nothing mounted at - * the given point. The read lock must be held by the caller. - * - * Results: - * A standard Tcl result. TCL_OK (or TCL_BREAK if nothing mounted there - * and no interpreter). - * - * Side effects: - * Interpreter result may be updated. - * - *------------------------------------------------------------------------- - */ - -static inline int -DescribeMounted( - Tcl_Interp *interp, - const char *mountPoint) -{ - 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); -} - -/* - *------------------------------------------------------------------------- - * - * TclZipfs_Mount -- - * - * This procedure is invoked to mount a given ZIP archive file on a given - * mountpoint with optional ZIP password. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * A ZIP archive file is read, analyzed and mounted, resources are - * allocated. - * - *------------------------------------------------------------------------- - */ - -int -TclZipfs_Mount( - Tcl_Interp *interp, /* Current interpreter. NULLable. */ - const char *mountPoint, /* Mount point path. */ - const char *zipname, /* Path to ZIP file to mount. */ - const char *passwd) /* Password for opening the ZIP, or NULL if - * the ZIP is unprotected. */ -{ - ZipFile *zf; - - ReadLock(); - if (!ZipFS.initialized) { - ZipfsSetup(); - } - - /* - * No mount point, so list all mount points and what is mounted there. - */ - - if (!mountPoint) { - int ret = ListMountPoints(interp); - Unlock(); - return ret; - } - - /* - * Mount point but no file, so describe what is mounted at that mount - * point. - */ - - if (!zipname) { - DescribeMounted(interp, mountPoint); - Unlock(); - return TCL_OK; - } - Unlock(); - - /* - * Have both a mount point and a file (name) to mount there. - */ - - if (passwd) { - if ((strlen(passwd) > 255) || strchr(passwd, 0xff)) { - if (interp) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("illegal password", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL); - } - return TCL_ERROR; - } - } - zf = (ZipFile *)Tcl_AttemptAlloc(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) { - Tcl_Free(zf); - return TCL_ERROR; - } - if (ZipFSCatalogFilesystem(interp, zf, mountPoint, passwd, zipname) - != TCL_OK) { - Tcl_Free(zf); - return TCL_ERROR; - } - Tcl_Free(zf); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * TclZipfs_MountBuffer -- - * - * This procedure is invoked to mount a given ZIP archive file on a given - * mountpoint with optional ZIP password. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * A ZIP archive file is read, analyzed and mounted, resources are - * allocated. - * - *------------------------------------------------------------------------- - */ - -int -TclZipfs_MountBuffer( - Tcl_Interp *interp, /* Current interpreter. NULLable. */ - const char *mountPoint, /* Mount point path. */ - unsigned char *data, - size_t datalen, - int copy) -{ - ZipFile *zf; - int result; - - ReadLock(); - if (!ZipFS.initialized) { - ZipfsSetup(); - } - - /* - * No mount point, so list all mount points and what is mounted there. - */ - - if (!mountPoint) { - int ret = ListMountPoints(interp); - Unlock(); - return ret; - } - - /* - * Mount point but no data, so describe what is mounted at that mount - * point. - */ - - if (!data) { - DescribeMounted(interp, mountPoint); - Unlock(); - return TCL_OK; - } - Unlock(); - - /* - * Have both a mount point and data to mount there. - */ - - zf = (ZipFile *)Tcl_AttemptAlloc(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 *)Tcl_AttemptAlloc(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"); - Tcl_Free(zf); - return result; -} - -/* - *------------------------------------------------------------------------- - * - * TclZipfs_Unmount -- - * - * This procedure is invoked to unmount a given ZIP archive. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * A mounted ZIP archive file is unmounted, resources are free'd. - * - *------------------------------------------------------------------------- - */ - -int -TclZipfs_Unmount( - Tcl_Interp *interp, /* Current interpreter. NULLable. */ - const char *mountPoint) /* Mount point path. */ -{ - ZipFile *zf; - ZipEntry *z, *znext; - Tcl_HashEntry *hPtr; - Tcl_DString dsm; - int ret = TCL_OK, unmounted = 0; - - WriteLock(); - if (!ZipFS.initialized) { - goto done; - } - - /* - * Mount point sometimes is a relative or otherwise denormalized path. - * But an absolute name is needed as mount point here. - */ - - Tcl_DStringInit(&dsm); - mountPoint = CanonicalPath("", mountPoint, &dsm, 1); - - 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) { - Tcl_Free(z->data); - } - Tcl_Free(z); - } - ZipFSCloseArchive(interp, zf); - Tcl_DeleteExitHandler(ZipfsExitHandler, zf); - Tcl_Free(zf); - unmounted = 1; - done: - Unlock(); - if (unmounted) { - Tcl_FSMountsChanged(NULL); - } - return ret; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSMountObjCmd -- - * - * This procedure is invoked to process the [zipfs mount] command. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * 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) ? TclGetString(objv[1]) : NULL, - (objc > 2) ? TclGetString(objv[2]) : NULL, - (objc > 3) ? TclGetString(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; - size_t length = 0; - - 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 = TclGetString(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 -- - * - * This procedure is invoked to process the [zipfs root] command. It - * returns the root that all zipfs file systems are mounted under. - * - * Results: - * A standard Tcl result. - * - * 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; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSUnmountObjCmd -- - * - * This procedure is invoked to process the [zipfs unmount] command. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * 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, TclGetString(objv[1])); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSMkKeyObjCmd -- - * - * This procedure is invoked to process the [zipfs mkkey] command. It - * produces a rotated password to be embedded into an image file. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * 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 = TclGetString(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; - } - while (len > 0) { - int ch = pw[len - 1]; - - passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; - i++; - len--; - } - passBuf[i] = i; - ++i; - passBuf[i++] = (char) ZIP_PASSWORD_END_SIG; - passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 8); - passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 16); - passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 24); - passBuf[i] = '\0'; - Tcl_AppendResult(interp, passBuf, (char *) NULL); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipAddFile -- - * - * This procedure is used by ZipFSMkZipOrImgCmd() to add a single file to - * the output ZIP archive file being written. A ZipEntry struct about the - * input file is added to the given fileHash table for later creation of - * the central ZIP directory. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Input file is read and (compressed and) written to the output ZIP - * archive file. - * - *------------------------------------------------------------------------- - */ - -static int -ZipAddFile( - Tcl_Interp *interp, /* Current interpreter. */ - const char *path, - const char *name, - Tcl_Channel out, - const char *passwd, /* Password for encoding the file, or NULL if - * the file is to be unprotected. */ - char *buf, - int bufsize, - Tcl_HashTable *fileHash) -{ - Tcl_Channel in; - Tcl_HashEntry *hPtr; - ZipEntry *z; - z_stream stream; - const char *zpath; - int crc, flush, zpathlen; - size_t nbyte, nbytecompr, len, olen, align = 0; - Tcl_WideInt pos[3]; - int mtime = 0, isNew, compMeth; - unsigned long keys[3], keys0[3]; - char obuf[4096]; - - /* - * Trim leading '/' characters. If this results in an empty string, we've - * nothing to do. - */ - - zpath = name; - while (zpath && zpath[0] == '/') { - zpath++; - } - if (!zpath || (zpath[0] == '\0')) { - return TCL_OK; - } - - zpathlen = strlen(zpath); - if (zpathlen + ZIP_CENTRAL_HEADER_LEN > bufsize) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "path too long for \"%s\"", path)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "PATH_LEN", NULL); - return TCL_ERROR; - } - in = Tcl_OpenFileChannel(interp, path, "rb", 0); - if (!in) { -#ifdef _WIN32 - /* hopefully a directory */ - if (strcmp("permission denied", Tcl_PosixError(interp)) == 0) { - Tcl_CloseEx(interp, in, 0); - return TCL_OK; - } -#endif /* _WIN32 */ - Tcl_CloseEx(interp, in, 0); - return TCL_ERROR; - } else { - Tcl_Obj *pathObj = Tcl_NewStringObj(path, -1); - Tcl_StatBuf statBuf; - - Tcl_IncrRefCount(pathObj); - if (Tcl_FSStat(pathObj, &statBuf) != -1) { - mtime = statBuf.st_mtime; - } - Tcl_DecrRefCount(pathObj); - } - Tcl_ResetResult(interp); - crc = 0; - nbyte = nbytecompr = 0; - while (1) { - len = Tcl_Read(in, buf, bufsize); - if (len == TCL_IO_FAILURE) { - if (nbyte == 0 && errno == EISDIR) { - Tcl_CloseEx(interp, in, 0); - return TCL_OK; - } - Tcl_SetObjResult(interp, Tcl_ObjPrintf("read error on \"%s\": %s", - path, Tcl_PosixError(interp))); - Tcl_CloseEx(interp, in, 0); - return TCL_ERROR; - } - if (len == 0) { - break; - } - crc = crc32(crc, (unsigned char *) buf, len); - nbyte += len; - } - if (Tcl_Seek(in, 0, SEEK_SET) == -1) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf("seek error on \"%s\": %s", - path, Tcl_PosixError(interp))); - Tcl_CloseEx(interp, in, 0); - 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 (Tcl_Write(out, buf, len) != len) { - wrerr: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "write error on %s: %s", path, Tcl_PosixError(interp))); - Tcl_CloseEx(interp, in, 0); - 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 (Tcl_Write(out, (const char *) abuf, align) != align) { - goto wrerr; - } - } - if (passwd) { - int i, ch, tmp; - unsigned char kvbuf[24]; - Tcl_Obj *ret; - - init_keys(passwd, keys, crc32tab); - for (i = 0; i < 12 - 2; i++) { - double r; - - if (Tcl_EvalEx(interp, "::tcl::mathfunc::rand", -1, 0) != TCL_OK) { - Tcl_Obj *eiPtr = Tcl_ObjPrintf( - "\n (evaluating PRNG step %d for password encoding)", - i); - - Tcl_AppendObjToErrorInfo(interp, eiPtr); - Tcl_CloseEx(interp, in, 0); - return TCL_ERROR; - } - ret = Tcl_GetObjResult(interp); - if (Tcl_GetDoubleFromObj(interp, ret, &r) != TCL_OK) { - Tcl_Obj *eiPtr = Tcl_ObjPrintf( - "\n (evaluating PRNG step %d for password encoding)", - i); - - Tcl_AppendObjToErrorInfo(interp, eiPtr); - Tcl_CloseEx(interp, in, 0); - 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_CloseEx(interp, in, 0); - return TCL_ERROR; - } - memcpy(keys0, keys, sizeof(keys0)); - nbytecompr += 12; - } - Tcl_Flush(out); - pos[2] = Tcl_Tell(out); - compMeth = ZIP_COMPMETH_DEFLATED; - memset(&stream, 0, sizeof(z_stream)); - stream.zalloc = Z_NULL; - stream.zfree = Z_NULL; - stream.opaque = Z_NULL; - if (deflateInit2(&stream, 9, Z_DEFLATED, -15, 8, - Z_DEFAULT_STRATEGY) != Z_OK) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "compression init error on \"%s\"", path)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DEFLATE_INIT", NULL); - Tcl_CloseEx(interp, in, 0); - return TCL_ERROR; - } - do { - len = Tcl_Read(in, buf, bufsize); - if (len == TCL_IO_FAILURE) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "read error on %s: %s", path, Tcl_PosixError(interp))); - deflateEnd(&stream); - Tcl_CloseEx(interp, in, 0); - return TCL_ERROR; - } - stream.avail_in = len; - stream.next_in = (unsigned char *) buf; - flush = Tcl_Eof(in) ? Z_FINISH : Z_NO_FLUSH; - do { - stream.avail_out = sizeof(obuf); - stream.next_out = (unsigned char *) obuf; - len = deflate(&stream, flush); - if (len == (size_t) Z_STREAM_ERROR) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "deflate error on %s", path)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DEFLATE", NULL); - deflateEnd(&stream); - Tcl_CloseEx(interp, in, 0); - return TCL_ERROR; - } - olen = sizeof(obuf) - stream.avail_out; - if (passwd) { - size_t i; - int tmp; - - for (i = 0; i < olen; i++) { - obuf[i] = (char) zencode(keys, crc32tab, obuf[i], tmp); - } - } - if (olen && (Tcl_Write(out, obuf, olen) != olen)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "write error: %s", Tcl_PosixError(interp))); - deflateEnd(&stream); - Tcl_CloseEx(interp, in, 0); - return TCL_ERROR; - } - nbytecompr += olen; - } while (stream.avail_out == 0); - } while (flush != Z_FINISH); - deflateEnd(&stream); - Tcl_Flush(out); - pos[1] = Tcl_Tell(out); - if (nbyte - nbytecompr <= 0) { - /* - * Compressed file larger than input, write it again uncompressed. - */ - if (Tcl_Seek(in, 0, SEEK_SET) != 0) { - goto seekErr; - } - if (Tcl_Seek(out, pos[2], SEEK_SET) != pos[2]) { - seekErr: - Tcl_CloseEx(interp, in, 0); - 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 == TCL_IO_FAILURE) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "read error on \"%s\": %s", - path, Tcl_PosixError(interp))); - Tcl_CloseEx(interp, in, 0); - 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 (Tcl_Write(out, buf, len) != len) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "write error: %s", Tcl_PosixError(interp))); - Tcl_CloseEx(interp, in, 0); - return TCL_ERROR; - } - nbytecompr += len; - } - compMeth = ZIP_COMPMETH_STORED; - Tcl_Flush(out); - pos[1] = Tcl_Tell(out); - Tcl_TruncateChannel(out, pos[1]); - } - Tcl_CloseEx(interp, in, 0); - - hPtr = Tcl_CreateHashEntry(fileHash, zpath, &isNew); - 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 *)Tcl_Alloc(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); - Tcl_Free(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); - Tcl_Free(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); - Tcl_Free(z); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "seek error: %s", Tcl_PosixError(interp))); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSMkZipOrImgObjCmd -- - * - * This procedure is creates a new ZIP archive file or image file given - * output filename, input directory of files to be archived, optional - * password, and optional image to be prepended to the output ZIP archive - * file. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * A new ZIP archive file or image file is written. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSMkZipOrImgObjCmd( - Tcl_Interp *interp, /* Current interpreter. */ - int isImg, - int isList, - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Channel out; - int pwlen = 0, count, ret = TCL_ERROR, lobjc; - size_t len, slen = 0, i = 0; - Tcl_WideInt pos[3]; - Tcl_Obj **lobjv, *list = NULL; - ZipEntry *z; - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - Tcl_HashTable fileHash; - char *strip = NULL, *pw = NULL, passBuf[264], buf[4096]; - - /* - * Caller has verified that the number of arguments is correct. - */ - - passBuf[0] = 0; - if (objc > (isList ? 3 : 4)) { - pw = TclGetString(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; - } - } - if (isList) { - list = objv[2]; - Tcl_IncrRefCount(list); - } else { - Tcl_Obj *cmd[3]; - - cmd[1] = Tcl_NewStringObj("::tcl::zipfs::find", -1); - cmd[2] = objv[2]; - cmd[0] = Tcl_NewListObj(2, cmd + 1); - Tcl_IncrRefCount(cmd[0]); - if (Tcl_EvalObjEx(interp, cmd[0], TCL_EVAL_DIRECT) != TCL_OK) { - Tcl_DecrRefCount(cmd[0]); - return TCL_ERROR; - } - Tcl_DecrRefCount(cmd[0]); - list = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(list); - } - if (Tcl_ListObjGetElements(interp, list, &lobjc, &lobjv) != TCL_OK) { - Tcl_DecrRefCount(list); - return TCL_ERROR; - } - if (isList && (lobjc % 2)) { - Tcl_DecrRefCount(list); - Tcl_SetObjResult(interp, - Tcl_NewStringObj("need even number of elements", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "LIST_LENGTH", NULL); - return TCL_ERROR; - } - 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, TclGetString(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) ? TclGetString(objv[4]) : - Tcl_GetNameOfExecutable(); - } else { - imgName = (objc > 5) ? TclGetString(objv[5]) : - Tcl_GetNameOfExecutable(); - } - if (pwlen) { - i = 0; - for (len = pwlen; len-- > 0;) { - int ch = pw[len]; - - passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; - i++; - } - passBuf[i] = i; - ++i; - passBuf[i++] = (char) ZIP_PASSWORD_END_SIG; - passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 8); - passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 16); - passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 24); - passBuf[i] = '\0'; - } - - /* - * 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 (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_CloseEx(interp, out, 0); - if (zf == &zf0) { - ZipFSCloseArchive(interp, zf); - } else { - WriteLock(); - zf->numOpen--; - Unlock(); - } - return TCL_ERROR; - } - if (zf == &zf0) { - ZipFSCloseArchive(interp, zf); - } else { - WriteLock(); - zf->numOpen--; - Unlock(); - } - } else { - size_t k; - int m, n; - Tcl_Channel in; - const char *errMsg = "seek error"; - - /* - * Fall back to read it as plain file which hopefully is a static - * tclsh or wish binary with proper zipfs infrastructure built in. - */ - - Tcl_ResetResult(interp); - in = Tcl_OpenFileChannel(interp, imgName, "rb", 0644); - if (!in) { - memset(passBuf, 0, sizeof(passBuf)); - Tcl_DecrRefCount(list); - Tcl_CloseEx(interp, out, 0); - return TCL_ERROR; - } - i = Tcl_Seek(in, 0, SEEK_END); - if (i == TCL_IO_FAILURE) { - cperr: - memset(passBuf, 0, sizeof(passBuf)); - Tcl_DecrRefCount(list); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s: %s", errMsg, Tcl_PosixError(interp))); - Tcl_CloseEx(interp, out, 0); - Tcl_CloseEx(interp, in, 0); - return TCL_ERROR; - } - Tcl_Seek(in, 0, SEEK_SET); - for (k = 0; k < i; k += m) { - m = i - k; - if (m > (int) sizeof(buf)) { - m = (int) sizeof(buf); - } - n = Tcl_Read(in, buf, m); - if (n == -1) { - errMsg = "read error"; - goto cperr; - } else if (n == 0) { - break; - } - m = Tcl_Write(out, buf, n); - if (m != n) { - errMsg = "write error"; - goto cperr; - } - } - Tcl_CloseEx(interp, in, 0); - } - len = strlen(passBuf); - if (len > 0) { - i = Tcl_Write(out, passBuf, len); - if (i != len) { - Tcl_DecrRefCount(list); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "write error: %s", Tcl_PosixError(interp))); - Tcl_CloseEx(interp, out, 0); - return TCL_ERROR; - } - } - memset(passBuf, 0, sizeof(passBuf)); - Tcl_Flush(out); - } - Tcl_InitHashTable(&fileHash, TCL_STRING_KEYS); - pos[0] = Tcl_Tell(out); - if (!isList && (objc > 3)) { - strip = TclGetString(objv[3]); - slen = strlen(strip); - } - for (i = 0; i < (size_t) lobjc; i += (isList ? 2 : 1)) { - const char *path, *name; - - path = TclGetString(lobjv[i]); - if (isList) { - name = TclGetString(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; - } - if (ZipAddFile(interp, path, name, out, pw, buf, sizeof(buf), - &fileHash) != TCL_OK) { - goto done; - } - } - pos[1] = Tcl_Tell(out); - count = 0; - for (i = 0; i < (size_t) lobjc; i += (isList ? 2 : 1)) { - const char *path, *name; - - path = TclGetString(lobjv[i]); - if (isList) { - name = TclGetString(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) - || (Tcl_Write(out, z->name, len) != len)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "write error: %s", Tcl_PosixError(interp))); - goto done; - } - count++; - } - Tcl_Flush(out); - pos[2] = Tcl_Tell(out); - ZipWriteInt(buf + ZIP_CENTRAL_END_SIG_OFFS, ZIP_CENTRAL_END_SIG); - ZipWriteShort(buf + ZIP_CENTRAL_DISKNO_OFFS, 0); - ZipWriteShort(buf + ZIP_CENTRAL_DISKDIR_OFFS, 0); - ZipWriteShort(buf + ZIP_CENTRAL_ENTS_OFFS, count); - ZipWriteShort(buf + ZIP_CENTRAL_TOTALENTS_OFFS, count); - ZipWriteInt(buf + ZIP_CENTRAL_DIRSIZE_OFFS, pos[2] - pos[1]); - ZipWriteInt(buf + ZIP_CENTRAL_DIRSTART_OFFS, pos[1] - pos[0]); - ZipWriteShort(buf + ZIP_CENTRAL_COMMENTLEN_OFFS, 0); - if (Tcl_Write(out, buf, ZIP_CENTRAL_END_LEN) != ZIP_CENTRAL_END_LEN) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "write error: %s", Tcl_PosixError(interp))); - goto done; - } - Tcl_Flush(out); - ret = TCL_OK; - - done: - if (ret == TCL_OK) { - ret = Tcl_CloseEx(interp, out, 0); - } else { - Tcl_CloseEx(interp, out, 0); - } - Tcl_DecrRefCount(list); - for (hPtr = Tcl_FirstHashEntry(&fileHash, &search); hPtr; - hPtr = Tcl_NextHashEntry(&search)) { - z = (ZipEntry *)Tcl_GetHashValue(hPtr); - Tcl_Free(z); - Tcl_DeleteHashEntry(hPtr); - } - Tcl_DeleteHashTable(&fileHash); - return ret; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSMkZipObjCmd, ZipFSLMkZipObjCmd -- - * - * These procedures are invoked to process the [zipfs mkzip] and [zipfs - * lmkzip] commands. See description of ZipFSMkZipOrImgCmd(). - * - * Results: - * A standard Tcl result. - * - * Side effects: - * 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; - } - 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, 1, objc, objv); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSMkImgObjCmd, ZipFSLMkImgObjCmd -- - * - * These procedures are invoked to process the [zipfs mkimg] and [zipfs - * lmkimg] commands. See description of ZipFSMkZipOrImgCmd(). - * - * Results: - * A standard Tcl result. - * - * Side effects: - * 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; - } - 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, 1, objc, objv); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSCanonicalObjCmd -- - * - * This procedure is invoked to process the [zipfs canonical] command. - * It returns the canonical name for a file within zipfs - * - * Results: - * Always TCL_OK provided the right number of arguments are supplied. - * - * Side effects: - * 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 = TclGetString(objv[1]); - result = CanonicalPath("", filename, &dPath, 1); - } else if (objc == 3) { - mntpoint = TclGetString(objv[1]); - filename = TclGetString(objv[2]); - result = CanonicalPath(mntpoint, filename, &dPath, 1); - } else { - int zipfs = 0; - - if (Tcl_GetBooleanFromObj(interp, objv[3], &zipfs)) { - return TCL_ERROR; - } - mntpoint = TclGetString(objv[1]); - filename = TclGetString(objv[2]); - result = CanonicalPath(mntpoint, filename, &dPath, zipfs); - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1)); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSExistsObjCmd -- - * - * This procedure is invoked to process the [zipfs exists] command. It - * tests for the existence of a file in the ZIP filesystem and places a - * boolean into the interp's result. - * - * Results: - * Always TCL_OK provided the right number of arguments are supplied. - * - * Side effects: - * 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 = TclGetString(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; - Unlock(); - - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists)); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSInfoObjCmd -- - * - * This procedure is invoked to process the [zipfs info] command. On - * success, it returns a Tcl list made up of name of ZIP archive file, - * size uncompressed, size compressed, and archive offset of a file in - * the ZIP filesystem. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * 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 = TclGetString(objv[1]); - ReadLock(); - z = ZipFSLookup(filename); - if (z) { - Tcl_Obj *result = Tcl_GetObjResult(interp); - - Tcl_ListObjAppendElement(interp, result, - Tcl_NewStringObj(z->zipFilePtr->name, -1)); - Tcl_ListObjAppendElement(interp, result, - Tcl_NewWideIntObj(z->numBytes)); - Tcl_ListObjAppendElement(interp, result, - Tcl_NewWideIntObj(z->numCompressedBytes)); - Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(z->offset)); - } - Unlock(); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSListObjCmd -- - * - * This procedure is invoked to process the [zipfs list] command. On - * success, it returns a Tcl list of files of the ZIP filesystem which - * match a search pattern (glob or regexp). - * - * Results: - * A standard Tcl result. - * - * Side effects: - * 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) { - size_t n; - char *what = TclGetStringFromObj(objv[1], &n); - - if ((n >= 2) && (strncmp(what, "-glob", n) == 0)) { - pattern = TclGetString(objv[2]); - } else if ((n >= 2) && (strncmp(what, "-regexp", n) == 0)) { - regexp = Tcl_RegExpCompile(interp, TclGetString(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 = TclGetString(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; -} - -/* - *------------------------------------------------------------------------- - * - * TclZipfs_TclLibrary -- - * - * This procedure gets (and possibly finds) the root that Tcl's library - * files are mounted under. - * - * Results: - * A Tcl object holding the location (with zero refcount), or NULL if no - * Tcl library can be found. - * - * Side effects: - * May initialise the cache of where such library files are to be found. - * This cache is never cleared. - * - *------------------------------------------------------------------------- - */ - -#ifdef _WIN32 -#define LIBRARY_SIZE 64 -#endif /* _WIN32 */ - -Tcl_Obj * -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. - */ - - if (zipfs_literal_tcl_library) { - return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); - } - - /* - * Look for the library file system within the executable. - */ - - vfsInitScript = Tcl_NewStringObj(ZIPFS_APP_MOUNT "/tcl_library/init.tcl", - -1); - Tcl_IncrRefCount(vfsInitScript); - found = Tcl_FSAccess(vfsInitScript, F_OK); - Tcl_DecrRefCount(vfsInitScript); - if (found == TCL_OK) { - zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library"; - return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); - } - - /* - * Look for the library file system within the DLL/shared library. Note - * that we must mount the zip file and dll before releasing to search. - */ - -#if defined(_WIN32) - hModule = (HMODULE)TclWinGetTclInstance(); - GetModuleFileNameW(hModule, wName, MAX_PATH); - WideCharToMultiByte(CP_UTF8, 0, wName, -1, dllName, sizeof(dllName), NULL, NULL); - - if (ZipfsAppHookFindTclInit(dllName) == TCL_OK) { - return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); - } -#elif /* !_WIN32 && */ defined(CFG_RUNTIME_DLLFILE) - if (ZipfsAppHookFindTclInit( - CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE) == TCL_OK) { - return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); - } -#endif /* _WIN32 || CFG_RUNTIME_DLLFILE */ - - /* - * If we're configured to know about a ZIP archive we should use, do that. - */ - -#ifdef CFG_RUNTIME_ZIPFILE - if (ZipfsAppHookFindTclInit( - CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_ZIPFILE) == TCL_OK) { - return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); - } - if (ZipfsAppHookFindTclInit( - CFG_RUNTIME_SCRDIR "/" CFG_RUNTIME_ZIPFILE) == TCL_OK) { - return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); - } - if (ZipfsAppHookFindTclInit(CFG_RUNTIME_ZIPFILE) == TCL_OK) { - return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); - } -#endif /* CFG_RUNTIME_ZIPFILE */ - - /* - * If anything set the cache (but subsequently failed) go with that - * anyway. - */ - - if (zipfs_literal_tcl_library) { - return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); - } - return NULL; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSTclLibraryObjCmd -- - * - * This procedure is invoked to process the - * [::tcl::zipfs::tcl_library_init] command, usually called during the - * execution of Tcl's interpreter startup. It returns the root that Tcl's - * library files are mounted under. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * May initialise the cache of where such library files are to be found. - * This cache is never cleared. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSTclLibraryObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, /* Current interpreter. */ - TCL_UNUSED(int) /*objc*/, - TCL_UNUSED(Tcl_Obj *const *)) /*objv*/ -{ - if (!Tcl_IsSafe(interp)) { - Tcl_Obj *pResult = TclZipfs_TclLibrary(); - - if (!pResult) { - TclNewObj(pResult); - } - Tcl_SetObjResult(interp, pResult); - } - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipChannelClose -- - * - * This function is called to close a channel. - * - * Results: - * Always TCL_OK. - * - * Side effects: - * Resources are free'd. - * - *------------------------------------------------------------------------- - */ - -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) { - Tcl_Free(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 *)Tcl_AttemptRealloc(info->ubuf, info->numRead); - - if (newdata) { - if (z->data) { - Tcl_Free(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 { - Tcl_Free(info->ubuf); - } - } - WriteLock(); - info->zipFilePtr->numOpen--; - Unlock(); - Tcl_Free(info); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipChannelRead -- - * - * This function is called to read data from channel. - * - * Results: - * Number of bytes read or -1 on error with error number set. - * - * Side effects: - * Data is read and file pointer is advanced. - * - *------------------------------------------------------------------------- - */ - -static int -ZipChannelRead( - void *instanceData, - char *buf, - int toRead, - int *errloc) -{ - ZipChannel *info = (ZipChannel *) instanceData; - unsigned long nextpos; - - if (info->isDirectory < 0) { - /* - * Special case: when executable combined with ZIP archive file read - * data in front of ZIP, i.e. the executable itself. - */ - - nextpos = info->numRead + toRead; - if (nextpos > info->zipFilePtr->baseOffset) { - toRead = info->zipFilePtr->baseOffset - info->numRead; - nextpos = info->zipFilePtr->baseOffset; - } - if (toRead == 0) { - return 0; - } - memcpy(buf, info->zipFilePtr->data, toRead); - info->numRead = nextpos; - *errloc = 0; - return toRead; - } - if (info->isDirectory) { - *errloc = EISDIR; - return -1; - } - nextpos = info->numRead + toRead; - if (nextpos > info->numBytes) { - toRead = info->numBytes - info->numRead; - nextpos = info->numBytes; - } - if (toRead == 0) { - return 0; - } - if (info->isEncrypted) { - int i; - - for (i = 0; i < toRead; i++) { - int ch = info->ubuf[i + info->numRead]; - - buf[i] = zdecode(info->keys, crc32tab, ch); - } - } else { - memcpy(buf, info->ubuf + info->numRead, toRead); - } - info->numRead = nextpos; - *errloc = 0; - return toRead; -} - -/* - *------------------------------------------------------------------------- - * - * ZipChannelWrite -- - * - * This function is called to write data into channel. - * - * Results: - * Number of bytes written or -1 on error with error number set. - * - * Side effects: - * Data is written and file pointer is advanced. - * - *------------------------------------------------------------------------- - */ - -static int -ZipChannelWrite( - void *instanceData, - const char *buf, - int toWrite, - int *errloc) -{ - ZipChannel *info = (ZipChannel *) instanceData; - unsigned long nextpos; - - if (!info->isWriting) { - *errloc = EINVAL; - return -1; - } - nextpos = info->numRead + toWrite; - if (nextpos > info->maxWrite) { - toWrite = info->maxWrite - info->numRead; - nextpos = info->maxWrite; - } - if (toWrite == 0) { - return 0; - } - memcpy(info->ubuf + info->numRead, buf, toWrite); - info->numRead = nextpos; - if (info->numRead > info->numBytes) { - info->numBytes = info->numRead; - } - *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; - } else if (info->isDirectory) { - *errloc = EINVAL; - return -1; - } else { - end = info->numBytes; - } - switch (mode) { - case SEEK_CUR: - offset += info->numRead; - break; - case SEEK_END: - offset += end; - break; - case SEEK_SET: - break; - default: - *errloc = EINVAL; - 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; -} - -/* - *------------------------------------------------------------------------- - * - * 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; -} - -/* - *------------------------------------------------------------------------- - * - * ZipChannelGetFile -- - * - * This function is called to retrieve OS handle for channel. - * - * Results: - * Always TCL_ERROR since there's never an OS handle for a file within a - * ZIP archive. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -ZipChannelGetFile( - TCL_UNUSED(ClientData), - TCL_UNUSED(int) /*direction*/, - TCL_UNUSED(ClientData *) /*handlePtr*/) -{ - return TCL_ERROR; -} - -/* - *------------------------------------------------------------------------- - * - * ZipChannelOpen -- - * - * This function opens a Tcl_Channel on a file from a mounted ZIP archive - * according to given open mode. - * - * Results: - * Tcl_Channel on success, or NULL on error. - * - * Side effects: - * Memory is allocated, the file from the ZIP archive is uncompressed. - * - *------------------------------------------------------------------------- - */ - -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) - || ((ZipFS.wrmax <= 0) && (mode & (O_WRONLY | O_RDWR)))) { - if (interp) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("unsupported open mode", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_MODE", NULL); - } - return NULL; - } - WriteLock(); - z = ZipFSLookup(filename); - if (!z) { - Tcl_SetErrno(ENOENT); - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "file not found \"%s\": %s", filename, - Tcl_PosixError(interp))); - } - goto error; - } - trunc = (mode & O_TRUNC) != 0; - wr = (mode & (O_WRONLY | O_RDWR)) != 0; - if ((z->compressMethod != ZIP_COMPMETH_STORED) - && (z->compressMethod != ZIP_COMPMETH_DEFLATED)) { - ZIPFS_ERROR(interp, "unsupported compression method"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "COMP_METHOD", NULL); - } - goto error; - } - if (wr && z->isDirectory) { - ZIPFS_ERROR(interp, "unsupported file type"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "FILE_TYPE", NULL); - } - goto error; - } - if (!trunc) { - flags |= TCL_READABLE; - if (z->isEncrypted && (z->zipFilePtr->passBuf[0] == 0)) { - ZIPFS_ERROR(interp, "decryption failed"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DECRYPT", NULL); - } - goto error; - } else if (wr && !z->data && (z->numBytes > ZipFS.wrmax)) { - ZIPFS_ERROR(interp, "file too large"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "FILE_SIZE", NULL); - } - goto error; - } - } else { - flags = TCL_WRITABLE; - } - info = (ZipChannel *)Tcl_AttemptAlloc(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 *)Tcl_AttemptAlloc(info->maxWrite); - if (!info->ubuf) { - merror0: - if (info->ubuf) { - Tcl_Free(info->ubuf); - } - Tcl_Free(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) { - size_t j = z->numBytes; - - if (j > info->maxWrite) { - j = info->maxWrite; - } - memcpy(info->ubuf, z->data, j); - info->numBytes = j; - } else { - unsigned char *zbuf = z->zipFilePtr->data + z->offset; - - if (z->isEncrypted) { - int len = z->zipFilePtr->passBuf[0] & 0xFF; - char passBuf[260]; - - for (i = 0; i < len; i++) { - ch = z->zipFilePtr->passBuf[len - i]; - passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; - } - passBuf[i] = '\0'; - init_keys(passBuf, info->keys, crc32tab); - memset(passBuf, 0, sizeof(passBuf)); - for (i = 0; i < 12; i++) { - ch = info->ubuf[i]; - zdecode(info->keys, crc32tab, ch); - } - zbuf += i; - } - if (z->compressMethod == ZIP_COMPMETH_DEFLATED) { - z_stream stream; - int err; - unsigned char *cbuf = NULL; - - 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) { - size_t j; - - stream.avail_in -= 12; - cbuf = (unsigned char *)Tcl_AttemptAlloc(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); - } - stream.next_in = cbuf; - } else { - stream.next_in = zbuf; - } - stream.next_out = info->ubuf; - stream.avail_out = info->maxWrite; - if (inflateInit2(&stream, -15) != Z_OK) { - goto cerror0; - } - 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)); - Tcl_Free(cbuf); - } - goto wrapchan; - } - cerror0: - if (cbuf) { - memset(info->keys, 0, sizeof(info->keys)); - Tcl_Free(cbuf); - } - if (info->ubuf) { - Tcl_Free(info->ubuf); - } - Tcl_Free(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++) { - ch = zbuf[i]; - info->ubuf[i] = zdecode(info->keys, crc32tab, ch); - } - } else { - memcpy(info->ubuf, zbuf, z->numBytes); - } - memset(info->keys, 0, sizeof(info->keys)); - goto wrapchan; - } - } else if (z->data) { - flags |= TCL_READABLE; - info->isWriting = 0; - info->iscompr = 0; - info->isDirectory = 0; - info->isEncrypted = 0; - info->numBytes = z->numBytes; - info->maxWrite = 0; - info->ubuf = z->data; - } else { - flags |= TCL_READABLE; - info->isWriting = 0; - info->iscompr = (z->compressMethod == ZIP_COMPMETH_DEFLATED); - info->ubuf = z->zipFilePtr->data + z->offset; - info->isDirectory = z->isDirectory; - info->isEncrypted = z->isEncrypted; - info->numBytes = z->numBytes; - info->maxWrite = 0; - if (info->isEncrypted) { - int len = z->zipFilePtr->passBuf[0] & 0xFF; - char passBuf[260]; - - for (i = 0; i < len; i++) { - ch = z->zipFilePtr->passBuf[len - i]; - passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; - } - passBuf[i] = '\0'; - init_keys(passBuf, info->keys, crc32tab); - memset(passBuf, 0, sizeof(passBuf)); - for (i = 0; i < 12; i++) { - ch = info->ubuf[i]; - zdecode(info->keys, crc32tab, ch); - } - info->ubuf += i; - } - if (info->iscompr) { - z_stream stream; - int err; - unsigned char *ubuf = NULL; - size_t 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 *)Tcl_AttemptAlloc(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 *)Tcl_AttemptAlloc(info->numBytes); - if (!info->ubuf) { - merror: - if (ubuf) { - info->isEncrypted = 0; - memset(info->keys, 0, sizeof(info->keys)); - Tcl_Free(ubuf); - } - Tcl_Free(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)); - Tcl_Free(ubuf); - } - goto wrapchan; - } - cerror: - if (ubuf) { - info->isEncrypted = 0; - memset(info->keys, 0, sizeof(info->keys)); - Tcl_Free(ubuf); - } - if (info->ubuf) { - Tcl_Free(info->ubuf); - } - Tcl_Free(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; - size_t 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 *) Tcl_AttemptAlloc(len); - if (ubuf == NULL) { - Tcl_Free((char *) info); - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("out of memory", -1)); - } - goto error; - } - for (j = 0; j < len; j++) { - ch = info->ubuf[j]; - ubuf[j] = zdecode(info->keys, crc32tab, ch); - } - info->ubuf = ubuf; - info->isEncrypted = 0; - } - } - - wrapchan: - sprintf(cname, "zipfs_%" TCL_LL_MODIFIER "x_%d", z->offset, - ZipFS.idCount++); - z->zipFilePtr->numOpen++; - Unlock(); - return Tcl_CreateChannel(&ZipChannelType, cname, info, flags); - - error: - Unlock(); - return NULL; -} - -/* - *------------------------------------------------------------------------- - * - * ZipEntryStat -- - * - * This function implements the ZIP filesystem specific version of the - * library version of stat. - * - * Results: - * See stat documentation. - * - * Side effects: - * See stat documentation. - * - *------------------------------------------------------------------------- - */ - -static int -ZipEntryStat( - char *path, - Tcl_StatBuf *buf) -{ - ZipEntry *z; - int ret = -1; - - ReadLock(); - z = ZipFSLookup(path); - if (z) { - memset(buf, 0, sizeof(Tcl_StatBuf)); - if (z->isDirectory) { - buf->st_mode = S_IFDIR | 0555; - } else { - buf->st_mode = S_IFREG | 0555; - } - buf->st_size = z->numBytes; - buf->st_mtime = z->timestamp; - buf->st_ctime = z->timestamp; - buf->st_atime = z->timestamp; - ret = 0; - } - Unlock(); - return ret; -} - -/* - *------------------------------------------------------------------------- - * - * ZipEntryAccess -- - * - * This function implements the ZIP filesystem specific version of the - * library version of access. - * - * Results: - * See access documentation. - * - * Side effects: - * See access documentation. - * - *------------------------------------------------------------------------- - */ - -static int -ZipEntryAccess( - char *path, - int mode) -{ - ZipEntry *z; - - if (mode & 3) { - return -1; - } - ReadLock(); - z = ZipFSLookup(path); - Unlock(); - return (z ? 0 : -1); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSOpenFileChannelProc -- - * - * Results: - * - * Side effects: - * - *------------------------------------------------------------------------- - */ - -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; - } - return ZipChannelOpen(interp, TclGetString(pathPtr), mode, - permissions); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSStatProc -- - * - * This function implements the ZIP filesystem specific version of the - * library version of stat. - * - * Results: - * See stat documentation. - * - * Side effects: - * See stat documentation. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSStatProc( - Tcl_Obj *pathPtr, - Tcl_StatBuf *buf) -{ - - pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); - if (!pathPtr) { - return -1; - } - return ZipEntryStat(TclGetString(pathPtr), buf); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSAccessProc -- - * - * This function implements the ZIP filesystem specific version of the - * library version of access. - * - * Results: - * See access documentation. - * - * Side effects: - * See access documentation. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSAccessProc( - Tcl_Obj *pathPtr, - int mode) -{ - pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); - if (!pathPtr) { - return -1; - } - return ZipEntryAccess(TclGetString(pathPtr), mode); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSFilesystemSeparatorProc -- - * - * This function returns the separator to be used for a given path. The - * object returned should have a refCount of zero - * - * Results: - * A Tcl object, with a refCount of zero. If the caller needs to retain a - * reference to the object, it should call Tcl_IncrRefCount, and should - * otherwise free the object. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static Tcl_Obj * -ZipFSFilesystemSeparatorProc( - TCL_UNUSED(Tcl_Obj *) /*pathPtr*/) -{ - return Tcl_NewStringObj("/", -1); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSMatchInDirectoryProc -- - * - * This routine is used by the globbing code to search a directory for - * all files which match a given pattern. - * - * Results: - * The return value is a standard Tcl result indicating whether an error - * occurred in globbing. Errors are left in interp, good results are - * lappend'ed to resultPtr (which must be a valid object). - * - * Side effects: - * 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, strip = 0; - size_t len, prefixLen; - 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 = TclGetStringFromObj(pathPtr, &prefixLen); - - /* - * The (normalized) path we're searching. - */ - - path = TclGetStringFromObj(normPathPtr, &len); - - Tcl_DStringInit(&dsPref); - Tcl_DStringAppend(&dsPref, prefix, prefixLen); - - if (strcmp(prefix, path) == 0) { - prefix = NULL; - } else { - strip = len + 1; - } - if (prefix) { - Tcl_DStringAppend(&dsPref, "/", 1); - prefixLen++; - prefix = Tcl_DStringValue(&dsPref); - } - ReadLock(); - if (types && (types->type == TCL_GLOB_TYPE_MOUNT)) { - l = CountSlashes(path); - if (path[len - 1] == '/') { - len--; - } else { - 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); - - if ((lenz > len + 1) && (strncmp(z->name, path, len) == 0) - && (z->name[len] == '/') - && (CountSlashes(z->name) == l) - && Tcl_StringCaseMatch(z->name + len + 1, pattern, - 0)) { - if (prefix) { - Tcl_DStringAppend(&dsPref, z->name, lenz); - 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, lenz)); - } - } - } - } else if ((zf->mountPointLen > len + 1) - && (strncmp(zf->mountPoint, path, len) == 0) - && (zf->mountPoint[len] == '/') - && (CountSlashes(zf->mountPoint) == l) - && Tcl_StringCaseMatch(zf->mountPoint + len + 1, - pattern, 0)) { - if (prefix) { - Tcl_DStringAppend(&dsPref, zf->mountPoint, - zf->mountPointLen); - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(Tcl_DStringValue(&dsPref), - Tcl_DStringLength(&dsPref))); - Tcl_DStringSetLength(&dsPref, prefixLen); - } else { - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(zf->mountPoint, - zf->mountPointLen)); - } - } - } - 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 *)Tcl_Alloc(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)); - } - } - } - Tcl_Free(pat); - - end: - Unlock(); - Tcl_DStringFree(&dsPref); - return TCL_OK; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSPathInFilesystemProc -- - * - * This function determines if the given path object is in the ZIP - * filesystem. - * - * Results: - * TCL_OK when the path object is in the ZIP filesystem, -1 otherwise. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -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 = TclGetStringFromObj(pathPtr, &len); - if (strncmp(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) != 0) { - return -1; - } - - 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); - - if ((len >= lenz) && (strncmp(path, z->name, lenz) == 0)) { - ret = TCL_OK; - goto endloop; - } - } - } else if ((len >= zf->mountPointLen) && - (strncmp(path, zf->mountPoint, zf->mountPointLen) == 0)) { - ret = TCL_OK; - break; - } - } - - endloop: - Unlock(); - return ret; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSListVolumesProc -- - * - * Lists the currently mounted ZIP filesystem volumes. - * - * Results: - * The list of volumes. - * - * Side effects: - * None - * - *------------------------------------------------------------------------- - */ - -static Tcl_Obj * -ZipFSListVolumesProc(void) -{ - return Tcl_NewStringObj(ZIPFS_VOLUME, -1); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSFileAttrStringsProc -- - * - * This function implements the ZIP filesystem dependent 'file - * attributes' subcommand, for listing the set of possible attribute - * strings. - * - * Results: - * An array of strings - * - * Side effects: - * 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 -- - * - * This function implements the ZIP filesystem specific 'file attributes' - * subcommand, for 'get' operations. - * - * Results: - * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK - * was returned) is likely to have a refCount of zero. Either way we must - * either store it somewhere (e.g. the Tcl result), or Incr/Decr its - * refCount to ensure it is properly freed. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSFileAttrsGetProc( - Tcl_Interp *interp, /* Current interpreter. */ - int index, - Tcl_Obj *pathPtr, - Tcl_Obj **objPtrRef) -{ - int ret = TCL_OK; - char *path; - ZipEntry *z; - - pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); - if (!pathPtr) { - return -1; - } - path = TclGetString(pathPtr); - ReadLock(); - z = ZipFSLookup(path); - if (!z) { - Tcl_SetErrno(ENOENT); - ZIPFS_POSIX_ERROR(interp, "file not found"); - ret = TCL_ERROR; - goto done; - } - switch (index) { - case 0: - TclNewIntObj(*objPtrRef, z->numBytes); - break; - case 1: - TclNewIntObj(*objPtrRef, z->numCompressedBytes); - break; - case 2: - TclNewIntObj(*objPtrRef, z->offset); - break; - case 3: - *objPtrRef = Tcl_NewStringObj(z->zipFilePtr->mountPoint, - z->zipFilePtr->mountPointLen); - break; - case 4: - *objPtrRef = Tcl_NewStringObj(z->zipFilePtr->name, -1); - break; - case 5: - *objPtrRef = Tcl_NewStringObj("0o555", -1); - break; - default: - ZIPFS_ERROR(interp, "unknown attribute"); - ret = TCL_ERROR; - } - - done: - Unlock(); - return ret; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSFileAttrsSetProc -- - * - * This function implements the ZIP filesystem specific 'file attributes' - * subcommand, for 'set' operations. - * - * Results: - * Standard Tcl return code. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -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; -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSFilesystemPathTypeProc -- - * - * Results: - * - * Side effects: - * - *------------------------------------------------------------------------- - */ - -static Tcl_Obj * -ZipFSFilesystemPathTypeProc( - TCL_UNUSED(Tcl_Obj *) /*pathPtr*/) -{ - return Tcl_NewStringObj("zip", -1); -} - -/* - *------------------------------------------------------------------------- - * - * ZipFSLoadFile -- - * - * This functions deals with loading native object code. If the given - * path object refers to a file within the ZIP filesystem, an approriate - * error code is returned to delegate loading to the caller (by copying - * the file to temp store and loading from there). As fallback when the - * file refers to the ZIP file system but is not present, it is looked up - * relative to the executable and loaded from there when available. - * - * Results: - * TCL_OK on success, TCL_ERROR otherwise with error message left. - * - * Side effects: - * Loads native code into the process address space. - * - *------------------------------------------------------------------------- - */ - -static int -ZipFSLoadFile( - Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Obj *path, - Tcl_LoadHandle *loadHandle, - Tcl_FSUnloadFileProc **unloadProcPtr, - int flags) -{ - Tcl_FSLoadFileProc2 *loadFileProc; -#ifdef ANDROID - /* - * Force loadFileProc to native implementation since the package manager - * already extracted the shared libraries from the APK at install time. - */ - - loadFileProc = (Tcl_FSLoadFileProc2 *) tclNativeFilesystem.loadFileProc; - if (loadFileProc) { - return loadFileProc(interp, path, loadHandle, unloadProcPtr, flags); - } - Tcl_SetErrno(ENOENT); - ZIPFS_ERROR(interp, Tcl_PosixError(interp)); - return TCL_ERROR; -#else /* !ANDROID */ - Tcl_Obj *altPath = NULL; - int ret = TCL_ERROR; - Tcl_Obj *objs[2] = { NULL, NULL }; - - if (Tcl_FSAccess(path, R_OK) == 0) { - /* - * EXDEV should trigger loading by copying to temp store. - */ - - Tcl_SetErrno(EXDEV); - ZIPFS_ERROR(interp, Tcl_PosixError(interp)); - return ret; - } - - objs[1] = TclPathPart(interp, path, TCL_PATH_DIRNAME); - if (objs[1] && (ZipFSAccessProc(objs[1], R_OK) == 0)) { - const char *execName = Tcl_GetNameOfExecutable(); - - /* - * Shared object is not in ZIP but its path prefix is, thus try to - * load from directory where the executable came from. - */ - - TclDecrRefCount(objs[1]); - objs[1] = TclPathPart(interp, path, TCL_PATH_TAIL); - - /* - * Get directory name of executable manually to deal with cases where - * [file dirname [info nameofexecutable]] is equal to [info - * nameofexecutable] due to VFS effects. - */ - - if (execName) { - const char *p = strrchr(execName, '/'); - - if (p > execName + 1) { - --p; - objs[0] = Tcl_NewStringObj(execName, p - execName); - } - } - if (!objs[0]) { - objs[0] = TclPathPart(interp, TclGetObjNameOfExecutable(), - TCL_PATH_DIRNAME); - } - if (objs[0]) { - altPath = TclJoinPath(2, objs, 0); - if (altPath) { - Tcl_IncrRefCount(altPath); - if (Tcl_FSAccess(altPath, R_OK) == 0) { - path = altPath; - } - } - } - } - 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) { - Tcl_DecrRefCount(altPath); - } - return ret; -#endif /* ANDROID */ -} - -#endif /* HAVE_ZLIB */ - -/* - *------------------------------------------------------------------------- - * - * TclZipfs_Init -- - * - * Perform per interpreter initialization of this module. - * - * Results: - * The return value is a standard Tcl result. - * - * 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}, - {"lmkimg", ZipFSLMkImgObjCmd, NULL, NULL, NULL, 1}, - {"lmkzip", ZipFSLMkZipObjCmd, NULL, NULL, NULL, 1}, - /* The 4 entries above are not available in safe interpreters */ - {"mount", ZipFSMountObjCmd, NULL, NULL, NULL, 1}, - {"mount_data", ZipFSMountBufferObjCmd, NULL, NULL, NULL, 1}, - {"unmount", ZipFSUnmountObjCmd, NULL, NULL, NULL, 1}, - {"mkkey", ZipFSMkKeyObjCmd, NULL, NULL, NULL, 1}, - {"exists", ZipFSExistsObjCmd, NULL, NULL, NULL, 0}, - {"info", ZipFSInfoObjCmd, NULL, NULL, NULL, 0}, - {"list", ZipFSListObjCmd, NULL, NULL, NULL, 0}, - {"canonical", ZipFSCanonicalObjCmd, NULL, NULL, NULL, 0}, - {"root", ZipFSRootObjCmd, NULL, NULL, NULL, 0}, - {NULL, NULL, NULL, NULL, NULL, 0} - }; - static const char findproc[] = - "namespace eval ::tcl::zipfs {}\n" - "proc ::tcl::zipfs::Find dir {\n" - " set result {}\n" - " if {[catch {glob -directory $dir -nocomplain * .*} list]} {\n" - " return $result\n" - " }\n" - " foreach file $list {\n" - " if {[file tail $file] in {. ..}} {\n" - " continue\n" - " }\n" - " lappend result $file {*}[Find $file]\n" - " }\n" - " return $result\n" - "}\n" - "proc ::tcl::zipfs::find {directoryName} {\n" - " return [lsort [Find $directoryName]]\n" - "}\n"; - - /* - * One-time initialization. - */ - - WriteLock(); - if (!ZipFS.initialized) { - ZipfsSetup(); - } - Unlock(); - - if (interp) { - Tcl_Command ensemble; - Tcl_Obj *mapObj; - - Tcl_EvalEx(interp, findproc, -1, TCL_EVAL_GLOBAL); - Tcl_LinkVar(interp, "::tcl::zipfs::wrmax", (char *) &ZipFS.wrmax, - TCL_LINK_INT); - ensemble = TclMakeEnsemble(interp, "zipfs", - Tcl_IsSafe(interp) ? (initMap + 4) : initMap); - - /* - * Add the [zipfs find] subcommand. - */ - - 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_PkgProvideEx(interp, "zipfs", "2.0", NULL); - } - 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 */ -} - -static int -ZipfsAppHookFindTclInit( - const char *archive) -{ - Tcl_Obj *vfsInitScript; - int found; - - if (zipfs_literal_tcl_library) { - return TCL_ERROR; - } - if (TclZipfs_Mount(NULL, ZIPFS_ZIP_MOUNT, archive, NULL)) { - /* Either the file doesn't exist or it is not a zip archive */ - return TCL_ERROR; - } - - TclNewLiteralStringObj(vfsInitScript, ZIPFS_ZIP_MOUNT "/init.tcl"); - Tcl_IncrRefCount(vfsInitScript); - found = Tcl_FSAccess(vfsInitScript, F_OK); - Tcl_DecrRefCount(vfsInitScript); - if (found == 0) { - zipfs_literal_tcl_library = ZIPFS_ZIP_MOUNT; - return TCL_OK; - } - - TclNewLiteralStringObj(vfsInitScript, - ZIPFS_ZIP_MOUNT "/tcl_library/init.tcl"); - Tcl_IncrRefCount(vfsInitScript); - found = Tcl_FSAccess(vfsInitScript, F_OK); - Tcl_DecrRefCount(vfsInitScript); - if (found == 0) { - zipfs_literal_tcl_library = ZIPFS_ZIP_MOUNT "/tcl_library"; - return TCL_OK; - } - - return TCL_ERROR; -} - -static void -ZipfsExitHandler( - ClientData clientData) -{ - ZipFile *zf = (ZipFile *)clientData; - - if (TCL_OK != TclZipfs_Unmount(NULL, zf->mountPoint)) { - Tcl_Panic("tried to unmount busy filesystem"); - } -} - -/* - *------------------------------------------------------------------------- - * - * TclZipfs_AppHook -- - * - * 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. - */ - - if (!TclZipfs_Mount(NULL, ZIPFS_APP_MOUNT, archive, NULL)) { - int found; - Tcl_Obj *vfsInitScript; - - TclNewLiteralStringObj(vfsInitScript, ZIPFS_APP_MOUNT "/main.tcl"); - Tcl_IncrRefCount(vfsInitScript); - if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) { - /* - * Startup script should be set before calling Tcl_AppInit - */ - - Tcl_SetStartupScript(vfsInitScript, NULL); - } else { - Tcl_DecrRefCount(vfsInitScript); - } - - /* - * Set Tcl Encodings - */ - - if (!zipfs_literal_tcl_library) { - TclNewLiteralStringObj(vfsInitScript, - ZIPFS_APP_MOUNT "/tcl_library/init.tcl"); - Tcl_IncrRefCount(vfsInitScript); - found = Tcl_FSAccess(vfsInitScript, F_OK); - Tcl_DecrRefCount(vfsInitScript); - if (found == TCL_OK) { - zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library"; - return TCL_OK; - } - } -#ifdef SUPPORT_BUILTIN_ZIP_INSTALL - } else if (*argcPtr > 1) { - /* - * 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; - - /* - * Run this now to ensure the file is present by the time Tcl_Main - * wants it. - */ - - TclZipfs_TclLibrary(); - TclNewLiteralStringObj(vfsInitScript, - ZIPFS_ZIP_MOUNT "/tcl_library/install.tcl"); - Tcl_IncrRefCount(vfsInitScript); - if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) { - Tcl_SetStartupScript(vfsInitScript, NULL); - } - return TCL_OK; - } else if (!TclZipfs_Mount(NULL, ZIPFS_APP_MOUNT, archive, NULL)) { - int found; - Tcl_Obj *vfsInitScript; - - TclNewLiteralStringObj(vfsInitScript, ZIPFS_APP_MOUNT "/main.tcl"); - Tcl_IncrRefCount(vfsInitScript); - if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) { - /* - * Startup script should be set before calling Tcl_AppInit - */ - - Tcl_SetStartupScript(vfsInitScript, NULL); - } else { - Tcl_DecrRefCount(vfsInitScript); - } - /* Set Tcl Encodings */ - TclNewLiteralStringObj(vfsInitScript, - ZIPFS_APP_MOUNT "/tcl_library/init.tcl"); - Tcl_IncrRefCount(vfsInitScript); - found = Tcl_FSAccess(vfsInitScript, F_OK); - Tcl_DecrRefCount(vfsInitScript); - if (found == TCL_OK) { - zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library"; - return TCL_OK; - } - } -#ifdef _WIN32 - Tcl_DStringFree(&ds); -#endif /* _WIN32 */ -#endif /* SUPPORT_BUILTIN_ZIP_INSTALL */ - } - return TCL_OK; -} - -#ifndef HAVE_ZLIB - -/* - *------------------------------------------------------------------------- - * - * TclZipfs_Mount, TclZipfs_MountBuffer, TclZipfs_Unmount -- - * - * Dummy version when no ZLIB support available. - * - *------------------------------------------------------------------------- - */ - -int -TclZipfs_Mount( - Tcl_Interp *interp, /* Current interpreter. */ - const char *mountPoint, /* Mount point path. */ - const char *zipname, /* Path to ZIP file to mount. */ - const char *passwd) /* Password for opening the ZIP, or NULL if - * the ZIP is unprotected. */ -{ - ZIPFS_ERROR(interp, "no zlib available"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL); - } - return TCL_ERROR; -} - -int -TclZipfs_MountBuffer( - Tcl_Interp *interp, /* Current interpreter. NULLable. */ - const char *mountPoint, /* Mount point path. */ - unsigned char *data, - size_t datalen, - int copy) -{ - ZIPFS_ERROR(interp, "no zlib available"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL); - } - return TCL_ERROR; -} - -int -TclZipfs_Unmount( - Tcl_Interp *interp, /* Current interpreter. */ - const char *mountPoint) /* Mount point path. */ -{ - ZIPFS_ERROR(interp, "no zlib available"); - if (interp) { - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL); - } - return TCL_ERROR; -} -#endif /* !HAVE_ZLIB */ - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ DELETED generic/tclZlib.c Index: generic/tclZlib.c ================================================================== --- generic/tclZlib.c +++ /dev/null @@ -1,4115 +0,0 @@ -/* - * tclZlib.c -- - * - * This file provides the interface to the Zlib library. - * - * Copyright (C) 2004-2005 Pascal Scheffers - * Copyright (C) 2005 Unitas Software B.V. - * Copyright (c) 2008-2012 Donal K. Fellows - * - * Parts written by Jean-Claude Wippler, as part of Tclkit, placed in the - * public domain March 2003. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include "tclInt.h" -#ifdef HAVE_ZLIB -#include -#include "tclIO.h" - -/* - * The version of the zlib "package" that this implements. Note that this - * thoroughly supersedes the versions included with tclkit, which are "1.1", - * so this is at least "2.0" (there's no general *commitment* to have the same - * interface, even if that is mostly true). - */ - -#define TCL_ZLIB_VERSION "2.0.1" - -/* - * Magic flags used with wbits fields to indicate that we're handling the gzip - * format or automatic detection of format. Putting it here is slightly less - * gross! - */ - -#define WBITS_RAW (-MAX_WBITS) -#define WBITS_ZLIB (MAX_WBITS) -#define WBITS_GZIP (MAX_WBITS | 16) -#define WBITS_AUTODETECT (MAX_WBITS | 32) - -/* - * Structure used for handling gzip headers that are generated from a - * dictionary. It comprises the header structure itself plus some working - * space that it is very convenient to have attached. - */ - -#define MAX_COMMENT_LEN 256 - -typedef struct { - gz_header header; - char nativeFilenameBuf[MAXPATHLEN]; - char nativeCommentBuf[MAX_COMMENT_LEN]; -} GzipHeader; - -/* - * Structure used for the Tcl_ZlibStream* commands and [zlib stream ...] - */ - -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. */ - size_t 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 - * restart the stream if necessary. */ - Tcl_Command cmd; /* Token for the associated Tcl command. */ - Tcl_Obj *compDictObj; /* Byte-array object containing compression - * dictionary (not dictObj!) to use if - * necessary. */ - int flags; /* Miscellaneous flag bits. */ - GzipHeader *gzHeaderPtr; /* If we've allocated a gzip header - * structure. */ -} ZlibStreamHandle; - -#define DICT_TO_SET 0x1 /* If we need to set a compression dictionary - * in the low-level engine at the next - * opportunity. */ - -/* - * Macros to make it clearer in some of the twiddlier accesses what is - * happening. - */ - -#define IsRawStream(zshPtr) ((zshPtr)->format == TCL_ZLIB_FORMAT_RAW) -#define HaveDictToSet(zshPtr) ((zshPtr)->flags & DICT_TO_SET) -#define DictWasSet(zshPtr) ((zshPtr)->flags |= ~DICT_TO_SET) - -/* - * Structure used for stacked channel compression and decompression. - */ - -typedef struct { - Tcl_Channel chan; /* Reference to the channel itself. */ - Tcl_Channel parent; /* The underlying source and sink of bytes. */ - int flags; /* General flag bits, see below... */ - int mode; /* Either the value TCL_ZLIB_STREAM_DEFLATE - * for compression on output, or - * TCL_ZLIB_STREAM_INFLATE for decompression - * on input. */ - int format; /* What format of data is going on the wire. - * Needed so that the correct [fconfigure] - * options can be enabled. */ - unsigned int readAheadLimit;/* The maximum number of bytes to read from - * the underlying stream in one go. */ - z_stream inStream; /* Structure used by zlib for decompression of - * input. */ - z_stream outStream; /* Structure used by zlib for compression of - * output. */ - char *inBuffer, *outBuffer; /* Working buffers. */ - size_t inAllocated, outAllocated; - /* Sizes of working buffers. */ - GzipHeader inHeader; /* Header read from input stream, when - * decompressing a gzip stream. */ - GzipHeader outHeader; /* Header to write to an output stream, when - * compressing a gzip stream. */ - Tcl_TimerToken timer; /* Timer used for keeping events fresh. */ - Tcl_Obj *compDictObj; /* Byte-array object containing compression - * dictionary (not dictObj!) to use if - * necessary. */ -} ZlibChannelData; - -/* - * Value bits for the flags field. Definitions are: - * ASYNC - Whether this is an asynchronous channel. - * IN_HEADER - Whether the inHeader field has been registered with - * the input compressor. - * OUT_HEADER - Whether the outputHeader field has been registered - * with the output decompressor. - * STREAM_DECOMPRESS - Signal decompress pending data. - * STREAM_DONE - Flag to signal stream end up to transform input. - */ - -#define ASYNC 0x01 -#define IN_HEADER 0x02 -#define OUT_HEADER 0x04 -#define STREAM_DECOMPRESS 0x08 -#define STREAM_DONE 0x10 - -/* - * Size of buffers allocated by default, and the range it can be set to. The - * same sorts of values apply to streams, except with different limits (they - * permit byte-level activity). Channels always use bytes unless told to use - * larger buffers. - */ - -#define DEFAULT_BUFFER_SIZE 4096 -#define MIN_NONSTREAM_BUFFER_SIZE 16 -#define MAX_BUFFER_SIZE 65536 - -/* - * Prototypes for private procedures defined later in this file: - */ - -static Tcl_CmdDeleteProc ZlibStreamCmdDelete; -static Tcl_DriverBlockModeProc ZlibTransformBlockMode; -static Tcl_DriverClose2Proc ZlibTransformClose; -static Tcl_DriverGetHandleProc ZlibTransformGetHandle; -static Tcl_DriverGetOptionProc ZlibTransformGetOption; -static Tcl_DriverHandlerProc ZlibTransformEventHandler; -static Tcl_DriverInputProc ZlibTransformInput; -static Tcl_DriverOutputProc ZlibTransformOutput; -static Tcl_DriverSetOptionProc ZlibTransformSetOption; -static Tcl_DriverWatchProc ZlibTransformWatch; -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, - size_t bufferSize, int flush, size_t *writtenPtr); -static void ExtractHeader(gz_header *headerPtr, Tcl_Obj *dictObj); -static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj, - GzipHeader *headerPtr, int *extraSizePtr); -static int ZlibPushSubcmd(Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int ResultDecompress(ZlibChannelData *cd, char *buf, - int toRead, int flush, int *errorCodePtr); -static Tcl_Channel ZlibStackChannelTransform(Tcl_Interp *interp, - int mode, int format, int level, int limit, - Tcl_Channel channel, Tcl_Obj *gzipHeaderDictPtr, - Tcl_Obj *compDictObj); -static void ZlibStreamCleanup(ZlibStreamHandle *zshPtr); -static int ZlibStreamSubcmd(Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static inline void ZlibTransformEventTimerKill(ZlibChannelData *cd); -static void ZlibTransformTimerRun(void *clientData); - -/* - * Type of zlib-based compressing and decompressing channels. - */ - -static const Tcl_ChannelType zlibChannelType = { - "zlib", - TCL_CHANNEL_VERSION_5, - NULL, - ZlibTransformInput, - ZlibTransformOutput, - NULL, /* seekProc */ - ZlibTransformSetOption, - ZlibTransformGetOption, - ZlibTransformWatch, - ZlibTransformGetHandle, - ZlibTransformClose, /* close2Proc */ - ZlibTransformBlockMode, - NULL, /* flushProc */ - ZlibTransformEventHandler, - NULL, /* wideSeekProc */ - NULL, - NULL -}; - -/* - *---------------------------------------------------------------------- - * - * ConvertError -- - * - * Utility function for converting a zlib error into a Tcl error. - * - * Results: - * None. - * - * Side effects: - * Updates the interpreter result and errorcode. - * - *---------------------------------------------------------------------- - */ - -static void -ConvertError( - Tcl_Interp *interp, /* Interpreter to store the error in. May be - * NULL, in which case nothing happens. */ - int code, /* The zlib error code. */ - uLong adler) /* The checksum expected (for Z_NEED_DICT) */ -{ - const char *codeStr, *codeStr2 = NULL; - char codeStrBuf[TCL_INTEGER_SPACE]; - - if (interp == NULL) { - return; - } - - switch (code) { - /* - * Firstly, the case that is *different* because it's really coming - * from the OS and is just being reported via zlib. It should be - * really uncommon because Tcl handles all I/O rather than delegating - * it to zlib, but proving it can't happen is hard. - */ - - case Z_ERRNO: - Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_PosixError(interp),-1)); - return; - - /* - * Normal errors/conditions, some of which have additional detail and - * some which don't. (This is not defined by array lookup because zlib - * error codes are sometimes negative.) - */ - - case Z_STREAM_ERROR: - codeStr = "STREAM"; - break; - case Z_DATA_ERROR: - codeStr = "DATA"; - break; - case Z_MEM_ERROR: - codeStr = "MEM"; - break; - case Z_BUF_ERROR: - codeStr = "BUF"; - break; - case Z_VERSION_ERROR: - codeStr = "VERSION"; - break; - case Z_NEED_DICT: - codeStr = "NEED_DICT"; - codeStr2 = codeStrBuf; - sprintf(codeStrBuf, "%lu", adler); - break; - - /* - * These should _not_ happen! This function is for dealing with error - * cases, not non-errors! - */ - - case Z_OK: - Tcl_Panic("unexpected zlib result in error handler: Z_OK"); - case Z_STREAM_END: - Tcl_Panic("unexpected zlib result in error handler: Z_STREAM_END"); - - /* - * Anything else is bad news; it's unexpected. Convert to generic - * error. - */ - - default: - codeStr = "UNKNOWN"; - codeStr2 = codeStrBuf; - sprintf(codeStrBuf, "%d", code); - break; - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(zError(code), -1)); - - /* - * Tricky point! We might pass NULL twice here (and will when the error - * type is known). - */ - - Tcl_SetErrorCode(interp, "TCL", "ZLIB", codeStr, codeStr2, NULL); -} - -static Tcl_Obj * -ConvertErrorToList( - int code, /* The zlib error code. */ - uLong adler) /* The checksum expected (for Z_NEED_DICT) */ -{ - Tcl_Obj *objv[4]; - - TclNewLiteralStringObj(objv[0], "TCL"); - TclNewLiteralStringObj(objv[1], "ZLIB"); - switch (code) { - case Z_STREAM_ERROR: - TclNewLiteralStringObj(objv[2], "STREAM"); - return Tcl_NewListObj(3, objv); - case Z_DATA_ERROR: - TclNewLiteralStringObj(objv[2], "DATA"); - return Tcl_NewListObj(3, objv); - case Z_MEM_ERROR: - TclNewLiteralStringObj(objv[2], "MEM"); - return Tcl_NewListObj(3, objv); - case Z_BUF_ERROR: - TclNewLiteralStringObj(objv[2], "BUF"); - return Tcl_NewListObj(3, objv); - case Z_VERSION_ERROR: - TclNewLiteralStringObj(objv[2], "VERSION"); - return Tcl_NewListObj(3, objv); - case Z_ERRNO: - TclNewLiteralStringObj(objv[2], "POSIX"); - objv[3] = Tcl_NewStringObj(Tcl_ErrnoId(), -1); - return Tcl_NewListObj(4, objv); - case Z_NEED_DICT: - TclNewLiteralStringObj(objv[2], "NEED_DICT"); - TclNewIntObj(objv[3], (Tcl_WideInt)adler); - return Tcl_NewListObj(4, objv); - - /* - * These should _not_ happen! This function is for dealing with error - * cases, not non-errors! - */ - - case Z_OK: - Tcl_Panic("unexpected zlib result in error handler: Z_OK"); - case Z_STREAM_END: - Tcl_Panic("unexpected zlib result in error handler: Z_STREAM_END"); - - /* - * Catch-all. Should be unreachable because all cases are already - * listed above. - */ - - default: - TclNewLiteralStringObj(objv[2], "UNKNOWN"); - TclNewIntObj(objv[3], code); - return Tcl_NewListObj(4, objv); - } -} - -/* - *---------------------------------------------------------------------- - * - * GenerateHeader -- - * - * Function for creating a gzip header from the contents of a dictionary - * (as described in the documentation). GetValue is a helper function. - * - * Results: - * A Tcl result code. - * - * Side effects: - * Updates the fields of the given gz_header structure. Adds amount of - * extra space required for the header to the variable referenced by the - * extraSizePtr argument. - * - *---------------------------------------------------------------------- - */ - -static inline int -GetValue( - Tcl_Interp *interp, - Tcl_Obj *dictObj, - const char *nameStr, - Tcl_Obj **valuePtrPtr) -{ - Tcl_Obj *name = Tcl_NewStringObj(nameStr, -1); - int result = Tcl_DictObjGet(interp, dictObj, name, valuePtrPtr); - - TclDecrRefCount(name); - return result; -} - -static int -GenerateHeader( - Tcl_Interp *interp, /* Where to put error messages. */ - Tcl_Obj *dictObj, /* The dictionary whose contents are to be - * parsed. */ - GzipHeader *headerPtr, /* Where to store the parsed-out values. */ - int *extraSizePtr) /* Variable to add the length of header - * strings (filename, comment) to. */ -{ - Tcl_Obj *value; - int len, result = TCL_ERROR; - size_t length; - 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, &length); - Tcl_UtfToExternal(NULL, latin1enc, valueStr, length, 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, &length); - Tcl_UtfToExternal(NULL, latin1enc, valueStr, length, 0, NULL, - headerPtr->nativeFilenameBuf, MAXPATHLEN-1, NULL, &len, NULL); - headerPtr->nativeFilenameBuf[len] = '\0'; - headerPtr->header.name = (Bytef *) headerPtr->nativeFilenameBuf; - if (extraSizePtr != NULL) { - *extraSizePtr += len; - } - } - - if (GetValue(interp, dictObj, "os", &value) != TCL_OK) { - goto error; - } else if (value != NULL && Tcl_GetIntFromObj(interp, value, - &headerPtr->header.os) != TCL_OK) { - goto error; - } - - /* - * Ignore the 'size' field, since that is controlled by the size of the - * input data. - */ - - if (GetValue(interp, dictObj, "time", &value) != TCL_OK) { - goto error; - } else if (value != NULL && Tcl_GetWideIntFromObj(interp, value, - &wideValue) != TCL_OK) { - goto error; - } - headerPtr->header.time = wideValue; - - if (GetValue(interp, dictObj, "type", &value) != TCL_OK) { - goto error; - } else if (value != NULL && Tcl_GetIndexFromObj(interp, value, types, - "type", TCL_EXACT, &headerPtr->header.text) != TCL_OK) { - goto error; - } - - result = TCL_OK; - error: - Tcl_FreeEncoding(latin1enc); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * ExtractHeader -- - * - * Take the values out of a gzip header and store them in a dictionary. - * SetValue is a helper macro. - * - * Results: - * None. - * - * Side effects: - * Updates the dictionary, which must be writable (i.e. refCount < 2). - * - *---------------------------------------------------------------------- - */ - -#define SetValue(dictObj, key, value) \ - Tcl_DictObjPut(NULL, (dictObj), Tcl_NewStringObj((key), -1), (value)) - -static void -ExtractHeader( - gz_header *headerPtr, /* The gzip header to extract from. */ - Tcl_Obj *dictObj) /* The dictionary to store in. */ -{ - Tcl_Encoding latin1enc = NULL; - Tcl_DString tmp; - - if (headerPtr->comment != Z_NULL) { - if (latin1enc == NULL) { - /* - * 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"); - } - } - - Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->comment, -1, - &tmp); - SetValue(dictObj, "comment", TclDStringToObj(&tmp)); - } - SetValue(dictObj, "crc", Tcl_NewBooleanObj(headerPtr->hcrc)); - if (headerPtr->name != Z_NULL) { - if (latin1enc == NULL) { - /* - * 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"); - } - } - - Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->name, -1, - &tmp); - SetValue(dictObj, "filename", TclDStringToObj(&tmp)); - } - if (headerPtr->os != 255) { - SetValue(dictObj, "os", Tcl_NewWideIntObj(headerPtr->os)); - } - if (headerPtr->time != 0 /* magic - no time */) { - SetValue(dictObj, "time", Tcl_NewWideIntObj(headerPtr->time)); - } - if (headerPtr->text != Z_UNKNOWN) { - SetValue(dictObj, "type", - Tcl_NewStringObj(headerPtr->text ? "text" : "binary", -1)); - } - - if (latin1enc != NULL) { - Tcl_FreeEncoding(latin1enc); - } -} - -/* - * Disentangle the worst of how the zlib API is used. - */ - -static int -SetInflateDictionary( - z_streamp strm, - Tcl_Obj *compDictObj) -{ - if (compDictObj != NULL) { - size_t length = 0; - unsigned char *bytes = TclGetByteArrayFromObj(compDictObj, &length); - - return inflateSetDictionary(strm, bytes, length); - } - return Z_OK; -} - -static int -SetDeflateDictionary( - z_streamp strm, - Tcl_Obj *compDictObj) -{ - if (compDictObj != NULL) { - size_t length = 0; - unsigned char *bytes = TclGetByteArrayFromObj(compDictObj, &length); - - return deflateSetDictionary(strm, bytes, length); - } - return Z_OK; -} - -static inline int -Deflate( - z_streamp strm, - void *bufferPtr, - size_t bufferSize, - int flush, - size_t *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, - size_t size) -{ - if (size > 0) { - Tcl_Obj *baObj = Tcl_NewByteArrayObj((unsigned char *) buffer, size); - - Tcl_ListObjAppendElement(NULL, listObj, baObj); - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ZlibStreamInit -- - * - * This command initializes a (de)compression context/handle for - * (de)compressing data in chunks. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * The variable pointed to by zshandlePtr is initialised and memory - * allocated for internal state. Additionally, if interp is not null, a - * Tcl command is created and its name placed in the interp result obj. - * - * Note: - * At least one of interp and zshandlePtr should be non-NULL or the - * reference to the stream will be completely lost. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_ZlibStreamInit( - Tcl_Interp *interp, - int mode, /* Either TCL_ZLIB_STREAM_INFLATE or - * TCL_ZLIB_STREAM_DEFLATE. */ - int format, /* Flags from the TCL_ZLIB_FORMAT_* set. */ - int level, /* 0-9 or TCL_ZLIB_COMPRESS_DEFAULT. */ - Tcl_Obj *dictObj, /* Dictionary containing headers for gzip. */ - Tcl_ZlibStream *zshandlePtr) -{ - int wbits = 0; - int e; - ZlibStreamHandle *zshPtr = NULL; - Tcl_DString cmdname; - GzipHeader *gzHeaderPtr = NULL; - - switch (mode) { - case TCL_ZLIB_STREAM_DEFLATE: - /* - * Compressed format is specified by the wbits parameter. See zlib.h - * for details. - */ - - switch (format) { - case TCL_ZLIB_FORMAT_RAW: - wbits = WBITS_RAW; - break; - case TCL_ZLIB_FORMAT_GZIP: - wbits = WBITS_GZIP; - if (dictObj) { - gzHeaderPtr = (GzipHeader *)Tcl_Alloc(sizeof(GzipHeader)); - memset(gzHeaderPtr, 0, sizeof(GzipHeader)); - if (GenerateHeader(interp, dictObj, gzHeaderPtr, - NULL) != TCL_OK) { - Tcl_Free(gzHeaderPtr); - return TCL_ERROR; - } - } - break; - case TCL_ZLIB_FORMAT_ZLIB: - wbits = WBITS_ZLIB; - break; - default: - Tcl_Panic("incorrect zlib data format, must be " - "TCL_ZLIB_FORMAT_ZLIB, TCL_ZLIB_FORMAT_GZIP or " - "TCL_ZLIB_FORMAT_RAW"); - } - if (level < -1 || level > 9) { - Tcl_Panic("compression level should be between 0 (no compression)" - " and 9 (best compression) or -1 for default compression " - "level"); - } - break; - case TCL_ZLIB_STREAM_INFLATE: - /* - * wbits are the same as DEFLATE, but FORMAT_AUTO is valid too. - */ - - switch (format) { - case TCL_ZLIB_FORMAT_RAW: - wbits = WBITS_RAW; - break; - case TCL_ZLIB_FORMAT_GZIP: - wbits = WBITS_GZIP; - gzHeaderPtr = (GzipHeader *)Tcl_Alloc(sizeof(GzipHeader)); - memset(gzHeaderPtr, 0, sizeof(GzipHeader)); - gzHeaderPtr->header.name = (Bytef *) - gzHeaderPtr->nativeFilenameBuf; - gzHeaderPtr->header.name_max = MAXPATHLEN - 1; - gzHeaderPtr->header.comment = (Bytef *) - gzHeaderPtr->nativeCommentBuf; - gzHeaderPtr->header.name_max = MAX_COMMENT_LEN - 1; - break; - case TCL_ZLIB_FORMAT_ZLIB: - wbits = WBITS_ZLIB; - break; - case TCL_ZLIB_FORMAT_AUTO: - wbits = WBITS_AUTODETECT; - break; - default: - Tcl_Panic("incorrect zlib data format, must be " - "TCL_ZLIB_FORMAT_ZLIB, TCL_ZLIB_FORMAT_GZIP, " - "TCL_ZLIB_FORMAT_RAW or TCL_ZLIB_FORMAT_AUTO"); - } - break; - default: - Tcl_Panic("bad mode, must be TCL_ZLIB_STREAM_DEFLATE or" - " TCL_ZLIB_STREAM_INFLATE"); - } - - zshPtr = (ZlibStreamHandle *)Tcl_Alloc(sizeof(ZlibStreamHandle)); - zshPtr->interp = interp; - zshPtr->mode = mode; - zshPtr->format = format; - zshPtr->level = level; - zshPtr->wbits = wbits; - zshPtr->currentInput = NULL; - zshPtr->streamEnd = 0; - zshPtr->compDictObj = NULL; - zshPtr->flags = 0; - zshPtr->gzHeaderPtr = gzHeaderPtr; - memset(&zshPtr->stream, 0, sizeof(z_stream)); - zshPtr->stream.adler = 1; - - /* - * No output buffer available yet - */ - - if (mode == TCL_ZLIB_STREAM_DEFLATE) { - e = deflateInit2(&zshPtr->stream, level, Z_DEFLATED, wbits, - MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY); - if (e == Z_OK && zshPtr->gzHeaderPtr) { - e = deflateSetHeader(&zshPtr->stream, - &zshPtr->gzHeaderPtr->header); - } - } else { - e = inflateInit2(&zshPtr->stream, wbits); - if (e == Z_OK && zshPtr->gzHeaderPtr) { - e = inflateGetHeader(&zshPtr->stream, - &zshPtr->gzHeaderPtr->header); - } - } - - if (e != Z_OK) { - ConvertError(interp, e, zshPtr->stream.adler); - goto error; - } - - /* - * I could do all this in C, but this is easier. - */ - - if (interp != NULL) { - if (Tcl_EvalEx(interp, "::incr ::tcl::zlib::cmdcounter", -1, 0) != TCL_OK) { - goto error; - } - Tcl_DStringInit(&cmdname); - TclDStringAppendLiteral(&cmdname, "::tcl::zlib::streamcmd_"); - TclDStringAppendObj(&cmdname, Tcl_GetObjResult(interp)); - if (Tcl_FindCommand(interp, Tcl_DStringValue(&cmdname), - NULL, 0) != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "BUG: Stream command name already exists", -1)); - Tcl_SetErrorCode(interp, "TCL", "BUG", "EXISTING_CMD", NULL); - Tcl_DStringFree(&cmdname); - goto error; - } - Tcl_ResetResult(interp); - - /* - * Create the command. - */ - - zshPtr->cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&cmdname), - ZlibStreamCmd, zshPtr, ZlibStreamCmdDelete); - Tcl_DStringFree(&cmdname); - if (zshPtr->cmd == NULL) { - goto error; - } - } else { - zshPtr->cmd = NULL; - } - - /* - * Prepare the buffers for use. - */ - - zshPtr->inData = Tcl_NewListObj(0, NULL); - Tcl_IncrRefCount(zshPtr->inData); - zshPtr->outData = Tcl_NewListObj(0, NULL); - Tcl_IncrRefCount(zshPtr->outData); - - zshPtr->outPos = 0; - - /* - * Now set the variable pointed to by *zshandlePtr to the pointer to the - * zsh struct. - */ - - if (zshandlePtr) { - *zshandlePtr = (Tcl_ZlibStream) zshPtr; - } - - return TCL_OK; - - error: - if (zshPtr->compDictObj) { - Tcl_DecrRefCount(zshPtr->compDictObj); - } - if (zshPtr->gzHeaderPtr) { - Tcl_Free(zshPtr->gzHeaderPtr); - } - Tcl_Free(zshPtr); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * ZlibStreamCmdDelete -- - * - * This is the delete command which Tcl invokes when a zlibstream command - * is deleted from the interpreter (on stream close, usually). - * - * Results: - * None - * - * Side effects: - * Invalidates the zlib stream handle as obtained from Tcl_ZlibStreamInit - * - *---------------------------------------------------------------------- - */ - -static void -ZlibStreamCmdDelete( - void *cd) -{ - ZlibStreamHandle *zshPtr = (ZlibStreamHandle *)cd; - - zshPtr->cmd = NULL; - ZlibStreamCleanup(zshPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ZlibStreamClose -- - * - * This procedure must be called after (de)compression is done to ensure - * memory is freed and the command is deleted from the interpreter (if - * any). - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Invalidates the zlib stream handle as obtained from Tcl_ZlibStreamInit - * - *---------------------------------------------------------------------- - */ - -int -Tcl_ZlibStreamClose( - Tcl_ZlibStream zshandle) /* As obtained from Tcl_ZlibStreamInit. */ -{ - ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; - - /* - * If the interp is set, deleting the command will trigger - * ZlibStreamCleanup in ZlibStreamCmdDelete. If no interp is set, call - * ZlibStreamCleanup directly. - */ - - if (zshPtr->interp && zshPtr->cmd) { - Tcl_DeleteCommandFromToken(zshPtr->interp, zshPtr->cmd); - } else { - ZlibStreamCleanup(zshPtr); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ZlibStreamCleanup -- - * - * This procedure is called by either Tcl_ZlibStreamClose or - * ZlibStreamCmdDelete to cleanup the stream context. - * - * Results: - * None - * - * Side effects: - * Invalidates the zlib stream handle. - * - *---------------------------------------------------------------------- - */ - -void -ZlibStreamCleanup( - ZlibStreamHandle *zshPtr) -{ - if (!zshPtr->streamEnd) { - if (zshPtr->mode == TCL_ZLIB_STREAM_DEFLATE) { - deflateEnd(&zshPtr->stream); - } else { - inflateEnd(&zshPtr->stream); - } - } - - if (zshPtr->inData) { - Tcl_DecrRefCount(zshPtr->inData); - } - if (zshPtr->outData) { - Tcl_DecrRefCount(zshPtr->outData); - } - if (zshPtr->currentInput) { - Tcl_DecrRefCount(zshPtr->currentInput); - } - if (zshPtr->compDictObj) { - Tcl_DecrRefCount(zshPtr->compDictObj); - } - if (zshPtr->gzHeaderPtr) { - Tcl_Free(zshPtr->gzHeaderPtr); - } - - Tcl_Free(zshPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ZlibStreamReset -- - * - * This procedure will reinitialize an existing stream handle. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Any data left in the (de)compression buffer is lost. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_ZlibStreamReset( - Tcl_ZlibStream zshandle) /* As obtained from Tcl_ZlibStreamInit */ -{ - ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; - int e; - - if (!zshPtr->streamEnd) { - if (zshPtr->mode == TCL_ZLIB_STREAM_DEFLATE) { - deflateEnd(&zshPtr->stream); - } else { - inflateEnd(&zshPtr->stream); - } - } - Tcl_SetByteArrayLength(zshPtr->inData, 0); - Tcl_SetByteArrayLength(zshPtr->outData, 0); - if (zshPtr->currentInput) { - Tcl_DecrRefCount(zshPtr->currentInput); - zshPtr->currentInput = NULL; - } - - zshPtr->outPos = 0; - zshPtr->streamEnd = 0; - memset(&zshPtr->stream, 0, sizeof(z_stream)); - - /* - * No output buffer available yet. - */ - - if (zshPtr->mode == TCL_ZLIB_STREAM_DEFLATE) { - e = deflateInit2(&zshPtr->stream, zshPtr->level, Z_DEFLATED, - zshPtr->wbits, MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY); - if (e == Z_OK && HaveDictToSet(zshPtr)) { - e = SetDeflateDictionary(&zshPtr->stream, zshPtr->compDictObj); - if (e == Z_OK) { - DictWasSet(zshPtr); - } - } - } else { - e = inflateInit2(&zshPtr->stream, zshPtr->wbits); - if (IsRawStream(zshPtr) && HaveDictToSet(zshPtr) && e == Z_OK) { - e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj); - if (e == Z_OK) { - DictWasSet(zshPtr); - } - } - } - - if (e != Z_OK) { - ConvertError(zshPtr->interp, e, zshPtr->stream.adler); - /* TODO:cleanup */ - return TCL_ERROR; - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ZlibStreamGetCommandName -- - * - * This procedure will return the command name associated with the - * stream. - * - * Results: - * A Tcl_Obj with the name of the Tcl command or NULL if no command is - * associated with the stream. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -Tcl_ZlibStreamGetCommandName( - Tcl_ZlibStream zshandle) /* As obtained from Tcl_ZlibStreamInit */ -{ - ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; - Tcl_Obj *objPtr; - - if (!zshPtr->interp) { - return NULL; - } - - TclNewObj(objPtr); - Tcl_GetCommandFullName(zshPtr->interp, zshPtr->cmd, objPtr); - return objPtr; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ZlibStreamEof -- - * - * This procedure This function returns 0 or 1 depending on the state of - * the (de)compressor. For decompression, eof is reached when the entire - * compressed stream has been decompressed. For compression, eof is - * reached when the stream has been flushed with TCL_ZLIB_FINALIZE. - * - * Results: - * Integer. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_ZlibStreamEof( - Tcl_ZlibStream zshandle) /* As obtained from Tcl_ZlibStreamInit */ -{ - ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; - - return zshPtr->streamEnd; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ZlibStreamChecksum -- - * - * Return the checksum of the uncompressed data seen so far by the - * stream. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_ZlibStreamChecksum( - Tcl_ZlibStream zshandle) /* As obtained from Tcl_ZlibStreamInit */ -{ - ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; - - return zshPtr->stream.adler; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ZlibStreamSetCompressionDictionary -- - * - * Sets the compression dictionary for a stream. This will be used as - * appropriate for the next compression or decompression action performed - * on the stream. - * - *---------------------------------------------------------------------- - */ - -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; - } else { - zshPtr->flags &= ~DICT_TO_SET; - } - if (zshPtr->compDictObj != NULL) { - Tcl_DecrRefCount(zshPtr->compDictObj); - } - zshPtr->compDictObj = compressionDictionaryObj; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ZlibStreamPut -- - * - * Add data to the stream for compression or decompression from a - * bytearray Tcl_Obj. - * - *---------------------------------------------------------------------- - */ - -#define BUFFER_SIZE_LIMIT 0xFFFF - -int -Tcl_ZlibStreamPut( - 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_t size = 0, 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) { - return TCL_OK; - } - - if (HaveDictToSet(zshPtr)) { - e = SetDeflateDictionary(&zshPtr->stream, zshPtr->compDictObj); - if (e != Z_OK) { - ConvertError(zshPtr->interp, e, zshPtr->stream.adler); - return TCL_ERROR; - } - DictWasSet(zshPtr); - } - - /* - * deflateBound() doesn't seem to take various header sizes into - * account, so we add 100 extra bytes. However, we can also loop - * around again so we also set an upper bound on the output buffer - * size. - */ - - outSize = deflateBound(&zshPtr->stream, size) + 100; - if (outSize > BUFFER_SIZE_LIMIT) { - outSize = BUFFER_SIZE_LIMIT; - } - dataTmp = (char *)Tcl_Alloc(outSize); - - while (1) { - e = Deflate(&zshPtr->stream, dataTmp, outSize, flush, &toStore); - - /* - * Test if we've filled the buffer up and have to ask deflate() to - * give us some more. Note that the condition for needing to - * repeat a buffer transfer when the result is Z_OK is whether - * there is no more space in the buffer we provided; the zlib - * library does not necessarily return a different code in that - * case. [Bug b26e38a3e4] [Tk Bug 10f2e7872b] - */ - - if ((e != Z_BUF_ERROR) && (e != Z_OK || toStore < outSize)) { - if ((e == Z_OK) || (flush == Z_FINISH && e == Z_STREAM_END)) { - break; - } - ConvertError(zshPtr->interp, e, zshPtr->stream.adler); - return TCL_ERROR; - } - - /* - * Output buffer too small to hold the data being generated or we - * are doing the end-of-stream flush (which can spit out masses of - * data). This means we need to put a new buffer into place after - * saving the old generated data to the outData list. - */ - - AppendByteArray(zshPtr->outData, dataTmp, outSize); - - if (outSize < BUFFER_SIZE_LIMIT) { - outSize = BUFFER_SIZE_LIMIT; - /* There may be *lots* of data left to output... */ - dataTmp = (char *)Tcl_Realloc(dataTmp, outSize); - } - } - - /* - * And append the final data block to the outData list. - */ - - AppendByteArray(zshPtr->outData, dataTmp, toStore); - Tcl_Free(dataTmp); - } else { - /* - * This is easy. Just append to the inData list. - */ - - Tcl_ListObjAppendElement(NULL, zshPtr->inData, data); - - /* - * and we'll need the flush parameter for the Inflate call. - */ - - zshPtr->flush = flush; - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ZlibStreamGet -- - * - * Retrieve data (now compressed or decompressed) from the stream into a - * bytearray Tcl_Obj. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_ZlibStreamGet( - Tcl_ZlibStream zshandle, /* As obtained from Tcl_ZlibStreamInit */ - Tcl_Obj *data, /* A place to append the data. */ - size_t count) /* Number of bytes to grab as a maximum, you - * may get less! */ -{ - ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; - int e, i, listLen; - size_t itemLen = 0, dataPos = 0; - Tcl_Obj *itemObj; - unsigned char *dataPtr, *itemPtr; - size_t existing = 0; - - /* - * 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 == TCL_INDEX_NONE) { - /* - * 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; - } - - /* - * Prepare the place to store the data. - */ - - dataPtr = Tcl_SetByteArrayLength(data, existing+count); - dataPtr += existing; - - zshPtr->stream.next_out = dataPtr; - zshPtr->stream.avail_out = count; - if (zshPtr->stream.avail_in == 0) { - /* - * zlib will probably need more data to decompress. - */ - - if (zshPtr->currentInput) { - Tcl_DecrRefCount(zshPtr->currentInput); - zshPtr->currentInput = NULL; - } - Tcl_ListObjLength(NULL, zshPtr->inData, &listLen); - if (listLen > 0) { - /* - * There is more input available, get it from the list and - * give it to zlib. At this point, the data must not be shared - * since we require the bytearray representation to not vanish - * under our feet. [Bug 3081008] - */ - - Tcl_ListObjIndex(NULL, zshPtr->inData, 0, &itemObj); - if (Tcl_IsShared(itemObj)) { - itemObj = Tcl_DuplicateObj(itemObj); - } - itemPtr = TclGetByteArrayFromObj(itemObj, &itemLen); - Tcl_IncrRefCount(itemObj); - zshPtr->currentInput = itemObj; - zshPtr->stream.next_in = itemPtr; - zshPtr->stream.avail_in = itemLen; - - /* - * And remove it from the list - */ - - Tcl_ListObjReplace(NULL, zshPtr->inData, 0, 1, 0, NULL); - } - } - - /* - * When dealing with a raw stream, we set the dictionary here, once. - * (You can't do it in response to getting Z_NEED_DATA as raw streams - * don't ever issue that.) - */ - - if (IsRawStream(zshPtr) && HaveDictToSet(zshPtr)) { - e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj); - if (e != Z_OK) { - ConvertError(zshPtr->interp, e, zshPtr->stream.adler); - return TCL_ERROR; - } - DictWasSet(zshPtr); - } - e = inflate(&zshPtr->stream, zshPtr->flush); - if (e == Z_NEED_DICT && HaveDictToSet(zshPtr)) { - e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj); - if (e == Z_OK) { - DictWasSet(zshPtr); - e = inflate(&zshPtr->stream, zshPtr->flush); - } - }; - Tcl_ListObjLength(NULL, zshPtr->inData, &listLen); - - while ((zshPtr->stream.avail_out > 0) - && (e == Z_OK || e == Z_BUF_ERROR) && (listLen > 0)) { - /* - * State: We have not satisfied the request yet and there may be - * more to inflate. - */ - - if (zshPtr->stream.avail_in > 0) { - if (zshPtr->interp) { - Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj( - "unexpected zlib internal state during" - " decompression", -1)); - Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "STATE", - NULL); - } - Tcl_SetByteArrayLength(data, existing); - return TCL_ERROR; - } - - if (zshPtr->currentInput) { - Tcl_DecrRefCount(zshPtr->currentInput); - zshPtr->currentInput = 0; - } - - /* - * Get the next block of data to go to inflate. At this point, the - * data must not be shared since we require the bytearray - * 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 = TclGetByteArrayFromObj(itemObj, &itemLen); - Tcl_IncrRefCount(itemObj); - zshPtr->currentInput = itemObj; - zshPtr->stream.next_in = itemPtr; - zshPtr->stream.avail_in = itemLen; - - /* - * Remove it from the list. - */ - - Tcl_ListObjReplace(NULL, zshPtr->inData, 0, 1, 0, NULL); - listLen--; - - /* - * And call inflate again. - */ - - do { - e = inflate(&zshPtr->stream, zshPtr->flush); - if (e != Z_NEED_DICT || !HaveDictToSet(zshPtr)) { - break; - } - e = SetInflateDictionary(&zshPtr->stream,zshPtr->compDictObj); - DictWasSet(zshPtr); - } while (e == Z_OK); - } - if (zshPtr->stream.avail_out > 0) { - Tcl_SetByteArrayLength(data, - existing + count - zshPtr->stream.avail_out); - } - if (!(e==Z_OK || e==Z_STREAM_END || e==Z_BUF_ERROR)) { - Tcl_SetByteArrayLength(data, existing); - ConvertError(zshPtr->interp, e, zshPtr->stream.adler); - return TCL_ERROR; - } - if (e == Z_STREAM_END) { - zshPtr->streamEnd = 1; - if (zshPtr->currentInput) { - Tcl_DecrRefCount(zshPtr->currentInput); - zshPtr->currentInput = 0; - } - inflateEnd(&zshPtr->stream); - } - } else { - Tcl_ListObjLength(NULL, zshPtr->outData, &listLen); - if (count == TCL_INDEX_NONE) { - count = 0; - for (i=0; ioutData, i, &itemObj); - (void) TclGetByteArrayFromObj(itemObj, &itemLen); - if (i == 0) { - count += itemLen - zshPtr->outPos; - } else { - count += itemLen; - } - } - } - - /* - * Prepare the place to store the data. - */ - - dataPtr = Tcl_SetByteArrayLength(data, existing + count); - dataPtr += existing; - - while ((count > dataPos) && - (Tcl_ListObjLength(NULL, zshPtr->outData, &listLen) == TCL_OK) - && (listLen > 0)) { - /* - * Get the next chunk off our list of chunks and grab the data out - * of it. - */ - - Tcl_ListObjIndex(NULL, zshPtr->outData, 0, &itemObj); - itemPtr = TclGetByteArrayFromObj(itemObj, &itemLen); - if (itemLen-zshPtr->outPos + dataPos >= count) { - size_t len = count - dataPos; - - memcpy(dataPtr + dataPos, itemPtr + zshPtr->outPos, len); - zshPtr->outPos += len; - dataPos += len; - if (zshPtr->outPos == itemLen) { - zshPtr->outPos = 0; - } - } else { - size_t len = itemLen - zshPtr->outPos; - - memcpy(dataPtr + dataPos, itemPtr + zshPtr->outPos, len); - dataPos += len; - zshPtr->outPos = 0; - } - if (zshPtr->outPos == 0) { - Tcl_ListObjReplace(NULL, zshPtr->outData, 0, 1, 0, NULL); - listLen--; - } - } - Tcl_SetByteArrayLength(data, existing + dataPos); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ZlibDeflate -- - * - * Compress the contents of Tcl_Obj *data with compression level in - * output format, producing the compressed data in the interpreter - * result. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_ZlibDeflate( - Tcl_Interp *interp, - int format, - Tcl_Obj *data, - int level, - Tcl_Obj *gzipHeaderDictObj) -{ - int wbits = 0, e = 0, extraSize = 0; - size_t inLen = 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) { - wbits = WBITS_RAW; - } else if (format == TCL_ZLIB_FORMAT_GZIP) { - wbits = WBITS_GZIP; - - /* - * Need to allocate extra space for the gzip header and footer. The - * amount of space is (a bit less than) 32 bytes, plus a byte for each - * byte of string that we add. Note that over-allocation is not a - * problem. [Bug 2419061] - */ - - extraSize = 32; - if (gzipHeaderDictObj) { - headerPtr = &header.header; - memset(headerPtr, 0, sizeof(gz_header)); - if (GenerateHeader(interp, gzipHeaderDictObj, &header, - &extraSize) != TCL_OK) { - return TCL_ERROR; - } - } - } else if (format == TCL_ZLIB_FORMAT_ZLIB) { - wbits = WBITS_ZLIB; - } else { - Tcl_Panic("incorrect zlib data format, must be TCL_ZLIB_FORMAT_ZLIB, " - "TCL_ZLIB_FORMAT_GZIP or TCL_ZLIB_FORMAT_ZLIB"); - } - - if (level < -1 || level > 9) { - Tcl_Panic("compression level should be between 0 (uncompressed) and " - "9 (best compression) or -1 for default compression level"); - } - - /* - * Allocate some space to store the output. - */ - - TclNewObj(obj); - - memset(&stream, 0, sizeof(z_stream)); - stream.avail_in = inLen; - stream.next_in = inData; - - /* - * No output buffer available yet, will alloc after deflateInit2. - */ - - e = deflateInit2(&stream, level, Z_DEFLATED, wbits, MAX_MEM_LEVEL, - Z_DEFAULT_STRATEGY); - if (e != Z_OK) { - goto error; - } - - if (headerPtr != NULL) { - e = deflateSetHeader(&stream, headerPtr); - if (e != Z_OK) { - goto error; - } - } - - /* - * Allocate the output buffer from the value of deflateBound(). This is - * probably too much space. Before returning to the caller, we will reduce - * it back to the actual compressed size. - */ - - stream.avail_out = deflateBound(&stream, inLen) + extraSize; - stream.next_out = Tcl_SetByteArrayLength(obj, stream.avail_out); - - /* - * Perform the compression, Z_FINISH means do it in one go. - */ - - e = deflate(&stream, Z_FINISH); - - if (e != Z_STREAM_END) { - e = deflateEnd(&stream); - - /* - * deflateEnd() returns Z_OK when there are bytes left to compress, at - * this point we consider that an error, although we could continue by - * allocating more memory and calling deflate() again. - */ - - if (e == Z_OK) { - e = Z_BUF_ERROR; - } - } else { - e = deflateEnd(&stream); - } - - if (e != Z_OK) { - goto error; - } - - /* - * Reduce the bytearray length to the actual data length produced by - * deflate. - */ - - Tcl_SetByteArrayLength(obj, stream.total_out); - Tcl_SetObjResult(interp, obj); - return TCL_OK; - - error: - ConvertError(interp, e, stream.adler); - TclDecrRefCount(obj); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ZlibInflate -- - * - * Decompress data in an object into the interpreter result. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_ZlibInflate( - Tcl_Interp *interp, - int format, - Tcl_Obj *data, - size_t bufferSize, - Tcl_Obj *gzipHeaderDictObj) -{ - int wbits = 0, e = 0; - size_t inLen = 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) { - case TCL_ZLIB_FORMAT_RAW: - wbits = WBITS_RAW; - gzipHeaderDictObj = NULL; - break; - case TCL_ZLIB_FORMAT_ZLIB: - wbits = WBITS_ZLIB; - gzipHeaderDictObj = NULL; - break; - case TCL_ZLIB_FORMAT_GZIP: - wbits = WBITS_GZIP; - break; - case TCL_ZLIB_FORMAT_AUTO: - wbits = WBITS_AUTODETECT; - break; - default: - Tcl_Panic("incorrect zlib data format, must be TCL_ZLIB_FORMAT_ZLIB, " - "TCL_ZLIB_FORMAT_GZIP, TCL_ZLIB_FORMAT_RAW or " - "TCL_ZLIB_FORMAT_AUTO"); - } - - if (gzipHeaderDictObj) { - headerPtr = &header; - memset(headerPtr, 0, sizeof(gz_header)); - nameBuf = (char *)Tcl_Alloc(MAXPATHLEN); - header.name = (Bytef *) nameBuf; - header.name_max = MAXPATHLEN - 1; - commentBuf = (char *)Tcl_Alloc(MAX_COMMENT_LEN); - header.comment = (Bytef *) commentBuf; - header.comm_max = MAX_COMMENT_LEN - 1; - } - - if (bufferSize < 1) { - /* - * Start with a buffer (up to) 3 times the size of the input data. - */ - - if (inLen < 32*1024*1024) { - bufferSize = 3*inLen; - } else if (inLen < 256*1024*1024) { - bufferSize = 2*inLen; - } else { - bufferSize = inLen; - } - } - - TclNewObj(obj); - outData = Tcl_SetByteArrayLength(obj, bufferSize); - memset(&stream, 0, sizeof(z_stream)); - stream.avail_in = inLen+1; /* +1 because zlib can "over-request" - * input (but ignore it!) */ - stream.next_in = inData; - stream.avail_out = bufferSize; - stream.next_out = outData; - - /* - * Initialize zlib for decompression. - */ - - e = inflateInit2(&stream, wbits); - if (e != Z_OK) { - goto error; - } - if (headerPtr) { - e = inflateGetHeader(&stream, headerPtr); - if (e != Z_OK) { - inflateEnd(&stream); - goto error; - } - } - - /* - * Start the decompression cycle. - */ - - while (1) { - e = inflate(&stream, Z_FINISH); - if (e != Z_BUF_ERROR) { - break; - } - - /* - * Not enough room in the output buffer. Increase it by five times the - * bytes still in the input buffer. (Because 3 times didn't do the - * trick before, 5 times is what we do next.) Further optimization - * should be done by the user, specify the decompressed size! - */ - - if ((stream.avail_in == 0) && (stream.avail_out > 0)) { - e = Z_STREAM_ERROR; - break; - } - newBufferSize = bufferSize + 5 * stream.avail_in; - if (newBufferSize == bufferSize) { - newBufferSize = bufferSize+1000; - } - newOutData = Tcl_SetByteArrayLength(obj, newBufferSize); - - /* - * Set next out to the same offset in the new location. - */ - - stream.next_out = newOutData + stream.total_out; - - /* - * And increase avail_out with the number of new bytes allocated. - */ - - stream.avail_out += newBufferSize - bufferSize; - outData = newOutData; - bufferSize = newBufferSize; - } - - if (e != Z_STREAM_END) { - inflateEnd(&stream); - goto error; - } - - e = inflateEnd(&stream); - if (e != Z_OK) { - goto error; - } - - /* - * Reduce the BA length to the actual data length produced by deflate. - */ - - Tcl_SetByteArrayLength(obj, stream.total_out); - if (headerPtr != NULL) { - ExtractHeader(&header, gzipHeaderDictObj); - SetValue(gzipHeaderDictObj, "size", - Tcl_NewWideIntObj(stream.total_out)); - Tcl_Free(nameBuf); - Tcl_Free(commentBuf); - } - Tcl_SetObjResult(interp, obj); - return TCL_OK; - - error: - TclDecrRefCount(obj); - ConvertError(interp, e, stream.adler); - if (nameBuf) { - Tcl_Free(nameBuf); - } - if (commentBuf) { - Tcl_Free(commentBuf); - } - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ZlibCRC32, Tcl_ZlibAdler32 -- - * - * Access to the checksumming engines. - * - *---------------------------------------------------------------------- - */ - -unsigned int -Tcl_ZlibCRC32( - unsigned int crc, - const unsigned char *buf, - size_t 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, - size_t 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, i, option, level = -1; - size_t dlen = 0, start, buffersize = 0; - Tcl_WideInt wideLen; - 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 - }; - enum zlibCommands { - CMD_ADLER, CMD_COMPRESS, CMD_CRC, CMD_DECOMPRESS, CMD_DEFLATE, - CMD_GUNZIP, CMD_GZIP, CMD_INFLATE, CMD_PUSH, CMD_STREAM - }; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "command arg ?...?"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[1], commands, "command", 0, - &command) != TCL_OK) { - return TCL_ERROR; - } - - 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?"); - return TCL_ERROR; - } - if (objc > 3) { - if (Tcl_GetIntFromObj(interp, objv[3], &level) != TCL_OK) { - return TCL_ERROR; - } - if (level < 0 || level > 9) { - goto badLevel; - } - } - return Tcl_ZlibDeflate(interp, TCL_ZLIB_FORMAT_RAW, objv[2], level, - NULL); - case CMD_COMPRESS: /* compress data ?level? - * -> zlibCompressedData */ - if (objc < 3 || objc > 4) { - Tcl_WrongNumArgs(interp, 2, objv, "data ?level?"); - return TCL_ERROR; - } - if (objc > 3) { - if (Tcl_GetIntFromObj(interp, objv[3], &level) != TCL_OK) { - return TCL_ERROR; - } - if (level < 0 || level > 9) { - goto badLevel; - } - } - return Tcl_ZlibDeflate(interp, TCL_ZLIB_FORMAT_ZLIB, objv[2], level, - NULL); - case CMD_GZIP: /* gzip data ?level? - * -> gzippedCompressedData */ - headerDictObj = NULL; - - /* - * Legacy argument format support. - */ - - if (objc == 4 - && Tcl_GetIntFromObj(interp, objv[3], &level) == TCL_OK) { - if (level < 0 || level > 9) { - extraInfoStr = "\n (in -level option)"; - goto badLevel; - } - return Tcl_ZlibDeflate(interp, TCL_ZLIB_FORMAT_GZIP, objv[2], - level, NULL); - } - - if (objc < 3 || objc > 7 || ((objc & 1) == 0)) { - Tcl_WrongNumArgs(interp, 2, objv, - "data ?-level level? ?-header header?"); - return TCL_ERROR; - } - for (i=3 ; i 9) { - extraInfoStr = "\n (in -level option)"; - goto badLevel; - } - break; - } - } - return Tcl_ZlibDeflate(interp, TCL_ZLIB_FORMAT_GZIP, objv[2], level, - headerDictObj); - case CMD_INFLATE: /* inflate rawcomprdata ?bufferSize? - * -> decompressedData */ - if (objc < 3 || objc > 4) { - Tcl_WrongNumArgs(interp, 2, objv, "data ?bufferSize?"); - return TCL_ERROR; - } - if (objc > 3) { - if (Tcl_GetWideIntFromObj(interp, objv[3], - &wideLen) != TCL_OK) { - return TCL_ERROR; - } - if (wideLen < MIN_NONSTREAM_BUFFER_SIZE - || wideLen > MAX_BUFFER_SIZE) { - goto badBuffer; - } - buffersize = wideLen; - } - return Tcl_ZlibInflate(interp, TCL_ZLIB_FORMAT_RAW, objv[2], - buffersize, NULL); - case CMD_DECOMPRESS: /* decompress zlibcomprdata \ - * ?bufferSize? - * -> decompressedData */ - if (objc < 3 || objc > 4) { - Tcl_WrongNumArgs(interp, 2, objv, "data ?bufferSize?"); - return TCL_ERROR; - } - if (objc > 3) { - if (Tcl_GetWideIntFromObj(interp, objv[3], - &wideLen) != TCL_OK) { - return TCL_ERROR; - } - if (wideLen < MIN_NONSTREAM_BUFFER_SIZE - || wideLen > MAX_BUFFER_SIZE) { - goto badBuffer; - } - buffersize = wideLen; - } - return Tcl_ZlibInflate(interp, TCL_ZLIB_FORMAT_ZLIB, objv[2], - buffersize, NULL); - case CMD_GUNZIP: { /* gunzip gzippeddata ?bufferSize? - * -> decompressedData */ - Tcl_Obj *headerVarObj; - - if (objc < 3 || objc > 5 || ((objc & 1) == 0)) { - Tcl_WrongNumArgs(interp, 2, objv, "data ?-headerVar varName?"); - return TCL_ERROR; - } - headerDictObj = headerVarObj = NULL; - for (i=3 ; i MAX_BUFFER_SIZE) { - goto badBuffer; - } - buffersize = wideLen; - break; - case 1: - headerVarObj = objv[i+1]; - TclNewObj(headerDictObj); - break; - } - } - if (Tcl_ZlibInflate(interp, TCL_ZLIB_FORMAT_GZIP, objv[2], - buffersize, headerDictObj) != TCL_OK) { - if (headerDictObj) { - TclDecrRefCount(headerDictObj); - } - return TCL_ERROR; - } - if (headerVarObj != NULL && Tcl_ObjSetVar2(interp, headerVarObj, NULL, - headerDictObj, TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; - } - return TCL_OK; - } - case CMD_STREAM: /* stream deflate/inflate/...gunzip \ - * ?options...? - * -> handleCmd */ - return ZlibStreamSubcmd(interp, objc, objv); - case CMD_PUSH: /* push mode channel options... - * -> channel */ - return ZlibPushSubcmd(interp, objc, objv); - }; - - return TCL_ERROR; - - badLevel: - Tcl_SetObjResult(interp, Tcl_NewStringObj("level must be 0 to 9", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL); - if (extraInfoStr) { - Tcl_AddErrorInfo(interp, extraInfoStr); - } - return TCL_ERROR; - badBuffer: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "buffer size must be %d to %d", - MIN_NONSTREAM_BUFFER_SIZE, MAX_BUFFER_SIZE)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * ZlibStreamSubcmd -- - * - * Implementation of the [zlib stream] subcommand. - * - *---------------------------------------------------------------------- - */ - -static int -ZlibStreamSubcmd( - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - static const char *const stream_formats[] = { - "compress", "decompress", "deflate", "gunzip", "gzip", "inflate", - NULL - }; - enum zlibFormats { - FMT_COMPRESS, FMT_DECOMPRESS, FMT_DEFLATE, FMT_GUNZIP, FMT_GZIP, - FMT_INFLATE - }; - int i, format, mode = 0, option, level; - enum objIndices { - OPT_COMPRESSION_DICTIONARY = 0, - OPT_GZIP_HEADER = 1, - OPT_COMPRESSION_LEVEL = 2, - OPT_END = -1 - }; - Tcl_Obj *obj[3] = { NULL, NULL, NULL }; -#define compDictObj obj[OPT_COMPRESSION_DICTIONARY] -#define gzipHeaderObj obj[OPT_GZIP_HEADER] -#define levelObj obj[OPT_COMPRESSION_LEVEL] - typedef struct { - const char *name; - enum objIndices offset; - } OptDescriptor; - static const OptDescriptor compressionOpts[] = { - { "-dictionary", OPT_COMPRESSION_DICTIONARY }, - { "-level", OPT_COMPRESSION_LEVEL }, - { NULL, OPT_END } - }; - static const OptDescriptor gzipOpts[] = { - { "-header", OPT_GZIP_HEADER }, - { "-level", OPT_COMPRESSION_LEVEL }, - { NULL, OPT_END } - }; - static const OptDescriptor expansionOpts[] = { - { "-dictionary", OPT_COMPRESSION_DICTIONARY }, - { NULL, OPT_END } - }; - static const OptDescriptor gunzipOpts[] = { - { NULL, OPT_END } - }; - const OptDescriptor *desc = NULL; - Tcl_ZlibStream zh; - - if (objc < 3 || !(objc & 1)) { - Tcl_WrongNumArgs(interp, 2, objv, "mode ?-option value...?"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0, - &format) != TCL_OK) { - return TCL_ERROR; - } - - /* - * The format determines the compression mode and the options that may be - * specified. - */ - - switch ((enum zlibFormats) format) { - case FMT_DEFLATE: - desc = compressionOpts; - mode = TCL_ZLIB_STREAM_DEFLATE; - format = TCL_ZLIB_FORMAT_RAW; - break; - case FMT_INFLATE: - desc = expansionOpts; - mode = TCL_ZLIB_STREAM_INFLATE; - format = TCL_ZLIB_FORMAT_RAW; - break; - case FMT_COMPRESS: - desc = compressionOpts; - mode = TCL_ZLIB_STREAM_DEFLATE; - format = TCL_ZLIB_FORMAT_ZLIB; - break; - case FMT_DECOMPRESS: - desc = expansionOpts; - mode = TCL_ZLIB_STREAM_INFLATE; - format = TCL_ZLIB_FORMAT_ZLIB; - break; - case FMT_GZIP: - desc = gzipOpts; - mode = TCL_ZLIB_STREAM_DEFLATE; - format = TCL_ZLIB_FORMAT_GZIP; - break; - case FMT_GUNZIP: - desc = gunzipOpts; - mode = TCL_ZLIB_STREAM_INFLATE; - format = TCL_ZLIB_FORMAT_GZIP; - break; - default: - Tcl_Panic("should be unreachable"); - } - - /* - * Parse the options. - */ - - for (i=3 ; i 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) { - return TCL_ERROR; - } - if (compDictObj != NULL) { - Tcl_ZlibStreamSetCompressionDictionary(zh, compDictObj); - } - Tcl_SetObjResult(interp, Tcl_ZlibStreamGetCommandName(zh)); - return TCL_OK; -#undef compDictObj -#undef gzipHeaderObj -#undef levelObj -} - -/* - *---------------------------------------------------------------------- - * - * ZlibPushSubcmd -- - * - * Implementation of the [zlib push] subcommand. - * - *---------------------------------------------------------------------- - */ - -static int -ZlibPushSubcmd( - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - static const char *const stream_formats[] = { - "compress", "decompress", "deflate", "gunzip", "gzip", "inflate", - NULL - }; - enum zlibFormats { - FMT_COMPRESS, FMT_DECOMPRESS, FMT_DEFLATE, FMT_GUNZIP, FMT_GZIP, - FMT_INFLATE - }; - Tcl_Channel chan; - int chanMode, format, mode = 0, level, i, option; - static const char *const pushCompressOptions[] = { - "-dictionary", "-header", "-level", NULL - }; - static const char *const pushDecompressOptions[] = { - "-dictionary", "-header", "-level", "-limit", NULL - }; - const char *const *pushOptions = pushDecompressOptions; - enum pushOptionsEnum {poDictionary, poHeader, poLevel, poLimit}; - Tcl_Obj *headerObj = NULL, *compDictObj = NULL; - int limit = DEFAULT_BUFFER_SIZE, dummy; - - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "mode channel ?options...?"); - return TCL_ERROR; - } - - if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0, - &format) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum zlibFormats) format) { - case FMT_DEFLATE: - mode = TCL_ZLIB_STREAM_DEFLATE; - format = TCL_ZLIB_FORMAT_RAW; - pushOptions = pushCompressOptions; - break; - case FMT_INFLATE: - mode = TCL_ZLIB_STREAM_INFLATE; - format = TCL_ZLIB_FORMAT_RAW; - break; - case FMT_COMPRESS: - mode = TCL_ZLIB_STREAM_DEFLATE; - format = TCL_ZLIB_FORMAT_ZLIB; - pushOptions = pushCompressOptions; - break; - case FMT_DECOMPRESS: - mode = TCL_ZLIB_STREAM_INFLATE; - format = TCL_ZLIB_FORMAT_ZLIB; - break; - case FMT_GZIP: - mode = TCL_ZLIB_STREAM_DEFLATE; - format = TCL_ZLIB_FORMAT_GZIP; - pushOptions = pushCompressOptions; - break; - case FMT_GUNZIP: - mode = TCL_ZLIB_STREAM_INFLATE; - format = TCL_ZLIB_FORMAT_GZIP; - break; - default: - Tcl_Panic("should be unreachable"); - } - - if (TclGetChannelFromObj(interp, objv[3], &chan, &chanMode, 0) != TCL_OK){ - return TCL_ERROR; - } - - /* - * Sanity checks. - */ - - if (mode == TCL_ZLIB_STREAM_DEFLATE && !(chanMode & TCL_WRITABLE)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "compression may only be applied to writable channels", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNWRITABLE", NULL); - return TCL_ERROR; - } - if (mode == TCL_ZLIB_STREAM_INFLATE && !(chanMode & TCL_READABLE)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "decompression may only be applied to readable channels",-1)); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNREADABLE", NULL); - return TCL_ERROR; - } - - /* - * Parse options. - */ - - level = Z_DEFAULT_COMPRESSION; - for (i=4 ; i objc-1) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "value missing for %s option", pushOptions[option])); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); - return TCL_ERROR; - } - switch ((enum pushOptionsEnum) option) { - case poHeader: - headerObj = objv[i]; - if (Tcl_DictObjSize(interp, headerObj, &dummy) != TCL_OK) { - goto genericOptionError; - } - break; - case poLevel: - if (Tcl_GetIntFromObj(interp, objv[i], (int*) &level) != TCL_OK) { - goto genericOptionError; - } - if (level < 0 || level > 9) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "level must be 0 to 9", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", - NULL); - goto genericOptionError; - } - break; - case poLimit: - if (Tcl_GetIntFromObj(interp, objv[i], (int*) &limit) != TCL_OK) { - goto genericOptionError; - } - if (limit < 1 || limit > MAX_BUFFER_SIZE) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "read ahead limit must be 1 to %d", - MAX_BUFFER_SIZE)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL); - goto genericOptionError; - } - break; - case poDictionary: - if (format == TCL_ZLIB_FORMAT_GZIP) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "a compression dictionary may not be set in the " - "gzip format", -1)); - 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; - - genericOptionError: - Tcl_AddErrorInfo(interp, "\n (in "); - Tcl_AddErrorInfo(interp, pushOptions[option]); - Tcl_AddErrorInfo(interp, " option)"); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * ZlibStreamCmd -- - * - * Implementation of the commands returned by [zlib stream]. - * - *---------------------------------------------------------------------- - */ - -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 - }; - enum zlibStreamCommands { - zs_add, zs_checksum, zs_close, zs_eof, zs_finalize, zs_flush, - zs_fullflush, zs_get, zs_header, zs_put, zs_reset - }; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option data ?...?"); - return TCL_ERROR; - } - - if (Tcl_GetIndexFromObj(interp, objv[1], cmds, "option", 0, - &command) != TCL_OK) { - return TCL_ERROR; - } - - switch ((enum zlibStreamCommands) command) { - case zs_add: /* $strm add ?$flushopt? $data */ - return ZlibStreamAddCmd(zstream, interp, objc, objv); - case zs_header: /* $strm header */ - return ZlibStreamHeaderCmd(zstream, interp, objc, objv); - case zs_put: /* $strm put ?$flushopt? $data */ - return ZlibStreamPutCmd(zstream, interp, objc, objv); - - case zs_get: /* $strm get ?count? */ - if (objc > 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?count?"); - return TCL_ERROR; - } - - count = -1; - if (objc >= 3) { - if (Tcl_GetIntFromObj(interp, objv[2], &count) != TCL_OK) { - return TCL_ERROR; - } - } - TclNewObj(obj); - code = Tcl_ZlibStreamGet(zstream, obj, count); - if (code == TCL_OK) { - Tcl_SetObjResult(interp, obj); - } else { - TclDecrRefCount(obj); - } - return code; - case zs_flush: /* $strm flush */ - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; - } - TclNewObj(obj); - Tcl_IncrRefCount(obj); - code = Tcl_ZlibStreamPut(zstream, obj, Z_SYNC_FLUSH); - TclDecrRefCount(obj); - return code; - case zs_fullflush: /* $strm fullflush */ - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; - } - TclNewObj(obj); - Tcl_IncrRefCount(obj); - code = Tcl_ZlibStreamPut(zstream, obj, Z_FULL_FLUSH); - TclDecrRefCount(obj); - return code; - case zs_finalize: /* $strm finalize */ - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; - } - - /* - * The flush commands slightly abuse the empty result obj as input - * data. - */ - - TclNewObj(obj); - Tcl_IncrRefCount(obj); - code = Tcl_ZlibStreamPut(zstream, obj, Z_FINISH); - TclDecrRefCount(obj); - return code; - case zs_close: /* $strm close */ - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; - } - return Tcl_ZlibStreamClose(zstream); - case zs_eof: /* $strm eof */ - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_ZlibStreamEof(zstream))); - return TCL_OK; - case zs_checksum: /* $strm checksum */ - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) - (uLong) Tcl_ZlibStreamChecksum(zstream))); - return TCL_OK; - case zs_reset: /* $strm reset */ - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; - } - return Tcl_ZlibStreamReset(zstream); - } - - return TCL_OK; -} - -static int -ZlibStreamAddCmd( - void *cd, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_ZlibStream zstream = (Tcl_ZlibStream)cd; - int index, code, buffersize = -1, flush = -1, i; - Tcl_Obj *obj, *compDictObj = NULL; - static const char *const add_options[] = { - "-buffer", "-dictionary", "-finalize", "-flush", "-fullflush", NULL - }; - enum addOptions { - ao_buffer, ao_dictionary, ao_finalize, ao_flush, ao_fullflush - }; - - for (i=2; i= 0) { - flush = -2; - } else { - flush = Z_SYNC_FLUSH; - } - break; - case ao_fullflush: /* -fullflush */ - if (flush >= 0) { - flush = -2; - } else { - flush = Z_FULL_FLUSH; - } - break; - case ao_finalize: /* -finalize */ - if (flush >= 0) { - flush = -2; - } else { - flush = Z_FINISH; - } - break; - case ao_buffer: /* -buffer */ - if (i == objc-2) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "\"-buffer\" option must be followed by integer " - "decompression buffersize", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); - return TCL_ERROR; - } - if (Tcl_GetIntFromObj(interp, objv[++i], &buffersize) != TCL_OK) { - return TCL_ERROR; - } - if (buffersize < 1 || buffersize > MAX_BUFFER_SIZE) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "buffer size must be 1 to %d", - MAX_BUFFER_SIZE)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL); - return TCL_ERROR; - } - break; - case ao_dictionary: - if (i == objc-2) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "\"-dictionary\" option must be followed by" - " compression dictionary bytes", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); - return TCL_ERROR; - } - compDictObj = objv[++i]; - break; - } - - if (flush == -2) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "\"-flush\", \"-fullflush\" and \"-finalize\" options" - " are mutually exclusive", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL); - return TCL_ERROR; - } - } - if (flush == -1) { - flush = 0; - } - - /* - * Set the compression dictionary if requested. - */ - - if (compDictObj != NULL) { - size_t len = 0; - - 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. - */ - - if (Tcl_ZlibStreamPut(zstream, objv[objc-1], flush) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Get such data out as we can (up to the requested length). - */ - - TclNewObj(obj); - code = Tcl_ZlibStreamGet(zstream, obj, buffersize); - if (code == TCL_OK) { - Tcl_SetObjResult(interp, obj); - } else { - TclDecrRefCount(obj); - } - return code; -} - -static int -ZlibStreamPutCmd( - void *cd, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_ZlibStream zstream = (Tcl_ZlibStream)cd; - int index, flush = -1, i; - Tcl_Obj *compDictObj = NULL; - static const char *const put_options[] = { - "-dictionary", "-finalize", "-flush", "-fullflush", NULL - }; - enum putOptions { - po_dictionary, po_finalize, po_flush, po_fullflush - }; - - for (i=2; i= 0) { - flush = -2; - } else { - flush = Z_SYNC_FLUSH; - } - break; - case po_fullflush: /* -fullflush */ - if (flush >= 0) { - flush = -2; - } else { - flush = Z_FULL_FLUSH; - } - break; - case po_finalize: /* -finalize */ - if (flush >= 0) { - flush = -2; - } else { - flush = Z_FINISH; - } - break; - case po_dictionary: - if (i == objc-2) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "\"-dictionary\" option must be followed by" - " compression dictionary bytes", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL); - return TCL_ERROR; - } - compDictObj = objv[++i]; - break; - } - if (flush == -2) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "\"-flush\", \"-fullflush\" and \"-finalize\" options" - " are mutually exclusive", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL); - return TCL_ERROR; - } - } - if (flush == -1) { - flush = 0; - } - - /* - * Set the compression dictionary if requested. - */ - - if (compDictObj != NULL) { - size_t len = 0; - - 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) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "only gunzip streams can produce header information", -1)); - Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOP", NULL); - return TCL_ERROR; - } - - TclNewObj(resultObj); - ExtractHeader(&zshPtr->gzHeaderPtr->header, resultObj); - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * Set of functions to support channel stacking. - *---------------------------------------------------------------------- - * - * ZlibTransformClose -- - * - * How to shut down a stacked compressing/decompressing transform. - * - *---------------------------------------------------------------------- - */ - -static int -ZlibTransformClose( - void *instanceData, - Tcl_Interp *interp, - int flags) -{ - ZlibChannelData *cd = (ZlibChannelData *)instanceData; - int e, result = TCL_OK; - size_t written; - - if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) { - return EINVAL; - } - - /* - * Delete the support timer. - */ - - ZlibTransformEventTimerKill(cd); - - /* - * Flush any data waiting to be compressed. - */ - - if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) { - cd->outStream.avail_in = 0; - do { - e = Deflate(&cd->outStream, cd->outBuffer, cd->outAllocated, - Z_FINISH, &written); - - /* - * Can't be sure that deflate() won't declare the buffer to be - * full (with Z_BUF_ERROR) so handle that case. - */ - - if (e == Z_BUF_ERROR) { - e = Z_OK; - written = cd->outAllocated; - } - if (e != Z_OK && e != Z_STREAM_END) { - /* TODO: is this the right way to do errors on close? */ - if (!TclInThreadExit()) { - ConvertError(interp, e, cd->outStream.adler); - } - result = TCL_ERROR; - break; - } - if (written && Tcl_WriteRaw(cd->parent, cd->outBuffer, written) == TCL_IO_FAILURE) { - /* TODO: is this the right way to do errors on close? - * Note: when close is called from FinalizeIOSubsystem then - * interp may be NULL */ - if (!TclInThreadExit() && interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "error while finalizing file: %s", - Tcl_PosixError(interp))); - } - result = TCL_ERROR; - break; - } - } while (e != Z_STREAM_END); - (void) deflateEnd(&cd->outStream); - } else { - /* - * If we have unused bytes from the read input (overshot by - * Z_STREAM_END or on possible error), unget them back to the parent - * channel, so that they appear as not being read yet. - */ - if (cd->inStream.avail_in) { - Tcl_Ungets (cd->parent, (char *)cd->inStream.next_in, cd->inStream.avail_in, 0); - } - - (void) inflateEnd(&cd->inStream); - } - - /* - * Release all memory. - */ - - if (cd->compDictObj) { - Tcl_DecrRefCount(cd->compDictObj); - cd->compDictObj = NULL; - } - - if (cd->inBuffer) { - Tcl_Free(cd->inBuffer); - cd->inBuffer = NULL; - } - if (cd->outBuffer) { - Tcl_Free(cd->outBuffer); - cd->outBuffer = NULL; - } - Tcl_Free(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; - - if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) { - return inProc(Tcl_GetChannelInstanceData(cd->parent), buf, toRead, - errorCodePtr); - } - - gotBytes = 0; - readBytes = cd->inStream.avail_in; /* how many bytes in buffer now */ - while (!(cd->flags & STREAM_DONE) && toRead > 0) { - unsigned int n; int decBytes; - - /* if starting from scratch or continuation after full decompression */ - if (!cd->inStream.avail_in) { - /* buffer to start, we can read to whole available buffer */ - cd->inStream.next_in = (Bytef *) cd->inBuffer; - } - /* - * If done - no read needed anymore, check we have to copy rest of - * decompressed data, otherwise return with size (or 0 for Eof) - */ - if (cd->flags & STREAM_DECOMPRESS) { - goto copyDecompressed; - } - /* - * The buffer is exhausted, but the caller wants even more. We now - * have to go to the underlying channel, get more bytes and then - * transform them for delivery. We may not get what we want (full EOF - * or temporarily out of data). - */ - - /* Check free buffer size and adjust size of next chunk to read. */ - n = cd->inAllocated - ((char *)cd->inStream.next_in - cd->inBuffer); - if (n <= 0) { - /* Normally unreachable: not enough input buffer to uncompress. - * Todo: firstly try to realloc inBuffer upto MAX_BUFFER_SIZE. - */ - *errorCodePtr = ENOBUFS; - return -1; - } - if (n > cd->readAheadLimit) { - n = cd->readAheadLimit; - } - readBytes = Tcl_ReadRaw(cd->parent, (char *)cd->inStream.next_in, n); - - /* - * Three cases here: - * 1. Got some data from the underlying channel (readBytes > 0) so - * it should be fed through the decompression engine. - * 2. Got an error (readBytes == -1) which we should report up except - * for the case where we can convert it to a short read. - * 3. Got an end-of-data from EOF or blocking (readBytes == 0). If - * it is EOF, try flushing the data out of the decompressor. - */ - - if (readBytes == -1) { - - /* See ReflectInput() in tclIORTrans.c */ - if (Tcl_InputBlocked(cd->parent) && (gotBytes > 0)) { - break; - } - - *errorCodePtr = Tcl_GetErrno(); - return -1; - } - - /* more bytes (or Eof if readBytes == 0) */ - cd->inStream.avail_in += readBytes; - -copyDecompressed: - - /* - * Transform the read chunk, if not empty. Anything we get - * back is a transformation result to be put into our buffers, and - * the next iteration will put it into the result. - * For the case readBytes is 0 which signaling Eof in parent, the - * partial data waiting is converted and returned. - */ - - decBytes = ResultDecompress(cd, buf, toRead, - (readBytes != 0) ? Z_NO_FLUSH : Z_SYNC_FLUSH, - errorCodePtr); - if (decBytes == -1) { - return -1; - } - gotBytes += decBytes; - buf += decBytes; - toRead -= decBytes; - - if (((decBytes == 0) || (cd->flags & STREAM_DECOMPRESS))) { - /* - * The drain delivered nothing (or buffer too small to decompress). - * Time to deliver what we've got. - */ - if (!gotBytes && !(cd->flags & STREAM_DONE)) { - /* if no-data, but not ready - avoid signaling Eof, - * continue in blocking mode, otherwise EAGAIN */ - if (Tcl_InputBlocked(cd->parent)) { - continue; - } - *errorCodePtr = EAGAIN; - return -1; - } - break; - } - - /* - * Loop until the request is satisfied (or no data available from - * above, possibly EOF). - */ - } - - return gotBytes; -} - -/* - *---------------------------------------------------------------------- - * - * ZlibTransformOutput -- - * - * Writer filter that does compression. - * - *---------------------------------------------------------------------- - */ - -static int -ZlibTransformOutput( - void *instanceData, - const char *buf, - int toWrite, - int *errorCodePtr) -{ - ZlibChannelData *cd = (ZlibChannelData *)instanceData; - Tcl_DriverOutputProc *outProc = - Tcl_ChannelOutputProc(Tcl_GetChannelType(cd->parent)); - int e; - size_t produced; - Tcl_Obj *errObj; - - if (cd->mode == TCL_ZLIB_STREAM_INFLATE) { - return outProc(Tcl_GetChannelInstanceData(cd->parent), buf, toWrite, - errorCodePtr); - } - - /* - * No zero-length writes. Flushes must be explicit. - */ - - if (toWrite == 0) { - return 0; - } - - cd->outStream.next_in = (Bytef *) buf; - cd->outStream.avail_in = toWrite; - while (cd->outStream.avail_in > 0) { - e = Deflate(&cd->outStream, cd->outBuffer, cd->outAllocated, - Z_NO_FLUSH, &produced); - if (e != Z_OK || produced == 0) { - break; - } - - if (Tcl_WriteRaw(cd->parent, cd->outBuffer, produced) == TCL_IO_FAILURE) { - *errorCodePtr = Tcl_GetErrno(); - return -1; - } - } - - if (e == Z_OK) { - return toWrite - cd->outStream.avail_in; - } - - errObj = Tcl_NewListObj(0, NULL); - Tcl_ListObjAppendElement(NULL, errObj, Tcl_NewStringObj("-errorcode",-1)); - Tcl_ListObjAppendElement(NULL, errObj, - ConvertErrorToList(e, cd->outStream.adler)); - Tcl_ListObjAppendElement(NULL, errObj, - Tcl_NewStringObj(cd->outStream.msg, -1)); - Tcl_SetChannelError(cd->parent, errObj); - *errorCodePtr = EINVAL; - return -1; -} - -/* - *---------------------------------------------------------------------- - * - * ZlibTransformFlush -- - * - * How to perform a flush of a compressing transform. - * - *---------------------------------------------------------------------- - */ - -static int -ZlibTransformFlush( - Tcl_Interp *interp, - ZlibChannelData *cd, - int flushType) -{ - int e; - size_t len; - - cd->outStream.avail_in = 0; - do { - /* - * Get the bytes to go out of the compression engine. - */ - - e = Deflate(&cd->outStream, cd->outBuffer, cd->outAllocated, - flushType, &len); - if (e != Z_OK && e != Z_BUF_ERROR) { - ConvertError(interp, e, cd->outStream.adler); - return TCL_ERROR; - } - - /* - * Write the bytes we've received to the next layer. - */ - - if (len > 0 && Tcl_WriteRaw(cd->parent, cd->outBuffer, len) == TCL_IO_FAILURE) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "problem flushing channel: %s", - Tcl_PosixError(interp))); - return TCL_ERROR; - } - - /* - * If we get to this point, either we're in the Z_OK or the - * Z_BUF_ERROR state. In the former case, we're done. In the latter - * case, it's because there's more bytes to go than would fit in the - * buffer we provided, and we need to go round again to get some more. - * - * We also stop the loop if we would have done a zero-length write. - * Those can cause problems at the OS level. - */ - } while (len > 0 && e == Z_BUF_ERROR); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ZlibTransformSetOption -- - * - * Writing side of [fconfigure] on our channel. - * - *---------------------------------------------------------------------- - */ - -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); - if (code != Z_OK) { - ConvertError(interp, code, cd->outStream.adler); - return TCL_ERROR; - } - } else if (cd->format == TCL_ZLIB_FORMAT_RAW) { - code = SetInflateDictionary(&cd->inStream, compDictObj); - if (code != Z_OK) { - ConvertError(interp, code, cd->inStream.adler); - return TCL_ERROR; - } - } - return TCL_OK; - } - - if (haveFlushOpt) { - if (optionName && strcmp(optionName, "-flush") == 0) { - int flushType; - - if (value[0] == 'f' && strcmp(value, "full") == 0) { - flushType = Z_FULL_FLUSH; - } else if (value[0] == 's' && strcmp(value, "sync") == 0) { - flushType = Z_SYNC_FLUSH; - } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown -flush type \"%s\": must be full or sync", - value)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "FLUSH", NULL); - return TCL_ERROR; - } - - /* - * Try to actually do the flush now. - */ - - return ZlibTransformFlush(interp, cd, flushType); - } - } else { - if (optionName && strcmp(optionName, "-limit") == 0) { - int newLimit; - - if (Tcl_GetInt(interp, value, &newLimit) != TCL_OK) { - return TCL_ERROR; - } else if (newLimit < 1 || newLimit > MAX_BUFFER_SIZE) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "-limit must be between 1 and 65536", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "READLIMIT", NULL); - return TCL_ERROR; - } - } - } - - if (setOptionProc == NULL) { - if (cd->format == TCL_ZLIB_FORMAT_GZIP) { - return Tcl_BadChannelOption(interp, optionName, - (cd->mode == TCL_ZLIB_STREAM_DEFLATE) - ? gzipChanOptions : gunzipChanOptions); - } else { - return Tcl_BadChannelOption(interp, optionName, - (cd->mode == TCL_ZLIB_STREAM_DEFLATE) - ? compressChanOptions : decompressChanOptions); - } - } - - /* - * Pass all unknown options down, to deeper transforms and/or the base - * channel. - */ - - return setOptionProc(Tcl_GetChannelInstanceData(cd->parent), interp, - optionName, value); -} - -/* - *---------------------------------------------------------------------- - * - * ZlibTransformGetOption -- - * - * Reading side of [fconfigure] on our channel. - * - *---------------------------------------------------------------------- - */ - -static int -ZlibTransformGetOption( - void *instanceData, - Tcl_Interp *interp, - const char *optionName, - Tcl_DString *dsPtr) -{ - ZlibChannelData *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"; - - /* - * The "crc" option reports the current CRC (calculated with the Adler32 - * or CRC32 algorithm according to the format) given the data that has - * been processed so far. - */ - - if (optionName == NULL || strcmp(optionName, "-checksum") == 0) { - uLong crc; - char buf[12]; - - if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) { - crc = cd->outStream.adler; - } else { - crc = cd->inStream.adler; - } - - sprintf(buf, "%lu", crc); - if (optionName == NULL) { - Tcl_DStringAppendElement(dsPtr, "-checksum"); - Tcl_DStringAppendElement(dsPtr, buf); - } else { - Tcl_DStringAppend(dsPtr, buf, -1); - return TCL_OK; - } - } - - if ((cd->format != TCL_ZLIB_FORMAT_GZIP) && - (optionName == NULL || strcmp(optionName, "-dictionary") == 0)) { - /* - * Embedded NUL bytes are ok; they'll be C080-encoded. - */ - - if (optionName == NULL) { - Tcl_DStringAppendElement(dsPtr, "-dictionary"); - if (cd->compDictObj) { - Tcl_DStringAppendElement(dsPtr, - TclGetString(cd->compDictObj)); - } else { - Tcl_DStringAppendElement(dsPtr, ""); - } - } else { - if (cd->compDictObj) { - size_t length; - const char *str = TclGetStringFromObj(cd->compDictObj, &length); - - Tcl_DStringAppend(dsPtr, str, length); - } - return TCL_OK; - } - } - - /* - * The "header" option, which is only valid on inflating gzip channels, - * reports the header that has been read from the start of the stream. - */ - - if ((cd->flags & IN_HEADER) && ((optionName == NULL) || - (strcmp(optionName, "-header") == 0))) { - Tcl_Obj *tmpObj; - - TclNewObj(tmpObj); - ExtractHeader(&cd->inHeader.header, tmpObj); - if (optionName == NULL) { - Tcl_DStringAppendElement(dsPtr, "-header"); - Tcl_DStringAppendElement(dsPtr, TclGetString(tmpObj)); - Tcl_DecrRefCount(tmpObj); - } else { - TclDStringAppendObj(dsPtr, tmpObj); - Tcl_DecrRefCount(tmpObj); - return TCL_OK; - } - } - - /* - * Now we do the standard processing of the stream we wrapped. - */ - - if (getOptionProc) { - return getOptionProc(Tcl_GetChannelInstanceData(cd->parent), - interp, optionName, dsPtr); - } - if (optionName == NULL) { - return TCL_OK; - } - if (cd->format == TCL_ZLIB_FORMAT_GZIP) { - return Tcl_BadChannelOption(interp, optionName, - (cd->mode == TCL_ZLIB_STREAM_DEFLATE) - ? gzipChanOptions : gunzipChanOptions); - } else { - return Tcl_BadChannelOption(interp, optionName, - (cd->mode == TCL_ZLIB_STREAM_DEFLATE) - ? compressChanOptions : decompressChanOptions); - } -} - -/* - *---------------------------------------------------------------------- - * - * ZlibTransformWatch, ZlibTransformEventHandler -- - * - * If we have data pending, trigger a readable event after a short time - * (in order to allow a real event to catch up). - * - *---------------------------------------------------------------------- - */ - -static void -ZlibTransformWatch( - void *instanceData, - int mask) -{ - ZlibChannelData *cd = (ZlibChannelData *)instanceData; - Tcl_DriverWatchProc *watchProc; - - /* - * This code is based on the code in tclIORTrans.c - */ - - watchProc = Tcl_ChannelWatchProc(Tcl_GetChannelType(cd->parent)); - watchProc(Tcl_GetChannelInstanceData(cd->parent), mask); - - if (!(mask & TCL_READABLE) || !(cd->flags & STREAM_DECOMPRESS)) { - ZlibTransformEventTimerKill(cd); - } else if (cd->timer == NULL) { - cd->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, - ZlibTransformTimerRun, cd); - } -} - -static int -ZlibTransformEventHandler( - void *instanceData, - int interestMask) -{ - ZlibChannelData *cd = (ZlibChannelData *)instanceData; - - ZlibTransformEventTimerKill(cd); - return interestMask; -} - -static inline void -ZlibTransformEventTimerKill( - ZlibChannelData *cd) -{ - if (cd->timer != NULL) { - Tcl_DeleteTimerHandler(cd->timer); - cd->timer = NULL; - } -} - -static void -ZlibTransformTimerRun( - void *clientData) -{ - ZlibChannelData *cd = (ZlibChannelData *)clientData; - - cd->timer = NULL; - Tcl_NotifyChannel(cd->chan, TCL_READABLE); -} - -/* - *---------------------------------------------------------------------- - * - * ZlibTransformGetHandle -- - * - * Anything that needs the OS handle is told to get it from what we are - * stacked on top of. - * - *---------------------------------------------------------------------- - */ - -static int -ZlibTransformGetHandle( - void *instanceData, - int direction, - void **handlePtr) -{ - ZlibChannelData *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; -} - -/* - *---------------------------------------------------------------------- - * - * ZlibStackChannelTransform -- - * - * Stacks either compression or decompression onto a channel. - * - * Results: - * The stacked channel, or NULL if there was an error. - * - *---------------------------------------------------------------------- - */ - -static Tcl_Channel -ZlibStackChannelTransform( - Tcl_Interp *interp, /* Where to write error messages. */ - int mode, /* Whether this is a compressing transform - * (TCL_ZLIB_STREAM_DEFLATE) or a - * decompressing transform - * (TCL_ZLIB_STREAM_INFLATE). Note that - * compressing transforms require that the - * channel is writable, and decompressing - * transforms require that the channel is - * readable. */ - int format, /* One of the TCL_ZLIB_FORMAT_* values that - * indicates what compressed format to allow. - * TCL_ZLIB_FORMAT_AUTO is only supported for - * decompressing transforms. */ - int level, /* What compression level to use. Ignored for - * decompressing transforms. */ - int limit, /* The limit on the number of bytes to read - * ahead; always at least 1. */ - Tcl_Channel channel, /* The channel to attach to. */ - 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 *)Tcl_Alloc(sizeof(ZlibChannelData)); - Tcl_Channel chan; - int wbits = 0; - - if (mode != TCL_ZLIB_STREAM_DEFLATE && mode != TCL_ZLIB_STREAM_INFLATE) { - Tcl_Panic("unknown mode: %d", mode); - } - - memset(cd, 0, sizeof(ZlibChannelData)); - cd->mode = mode; - cd->format = format; - cd->readAheadLimit = limit; - - if (format == TCL_ZLIB_FORMAT_GZIP || format == TCL_ZLIB_FORMAT_AUTO) { - if (mode == TCL_ZLIB_STREAM_DEFLATE) { - if (gzipHeaderDictPtr) { - cd->flags |= OUT_HEADER; - if (GenerateHeader(interp, gzipHeaderDictPtr, &cd->outHeader, - NULL) != TCL_OK) { - goto error; - } - } - } else { - cd->flags |= IN_HEADER; - cd->inHeader.header.name = (Bytef *) - &cd->inHeader.nativeFilenameBuf; - cd->inHeader.header.name_max = MAXPATHLEN - 1; - cd->inHeader.header.comment = (Bytef *) - &cd->inHeader.nativeCommentBuf; - cd->inHeader.header.comm_max = MAX_COMMENT_LEN - 1; - } - } - - if (compDictObj != NULL) { - cd->compDictObj = Tcl_DuplicateObj(compDictObj); - Tcl_IncrRefCount(cd->compDictObj); - Tcl_GetByteArrayFromObj(cd->compDictObj, NULL); - } - - if (format == TCL_ZLIB_FORMAT_RAW) { - wbits = WBITS_RAW; - } else if (format == TCL_ZLIB_FORMAT_ZLIB) { - wbits = WBITS_ZLIB; - } else if (format == TCL_ZLIB_FORMAT_GZIP) { - wbits = WBITS_GZIP; - } else if (format == TCL_ZLIB_FORMAT_AUTO) { - wbits = WBITS_AUTODETECT; - } else { - Tcl_Panic("bad format: %d", format); - } - - /* - * Initialize input inflater or the output deflater. - */ - - if (mode == TCL_ZLIB_STREAM_INFLATE) { - if (inflateInit2(&cd->inStream, wbits) != Z_OK) { - goto error; - } - cd->inAllocated = DEFAULT_BUFFER_SIZE; - if (cd->inAllocated < cd->readAheadLimit) { - cd->inAllocated = cd->readAheadLimit; - } - cd->inBuffer = (char *)Tcl_Alloc(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 *)Tcl_Alloc(cd->outAllocated); - if (cd->flags & OUT_HEADER) { - if (deflateSetHeader(&cd->outStream, &cd->outHeader.header) != Z_OK) { - goto error; - } - } - if (cd->compDictObj) { - if (SetDeflateDictionary(&cd->outStream, cd->compDictObj) != Z_OK) { - goto error; - } - } - } - - chan = Tcl_StackChannel(interp, &zlibChannelType, cd, - Tcl_GetChannelMode(channel), channel); - if (chan == NULL) { - goto error; - } - cd->chan = chan; - cd->parent = Tcl_GetStackedChannel(chan); - Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1)); - return chan; - - error: - if (cd->inBuffer) { - Tcl_Free(cd->inBuffer); - inflateEnd(&cd->inStream); - } - if (cd->outBuffer) { - Tcl_Free(cd->outBuffer); - deflateEnd(&cd->outStream); - } - if (cd->compDictObj) { - Tcl_DecrRefCount(cd->compDictObj); - } - Tcl_Free(cd); - return NULL; -} - -/* - *---------------------------------------------------------------------- - * - * ResultDecompress -- - * - * Extract uncompressed bytes from the compression engine and store them - * in our buffer (buf) up to toRead bytes. - * - * Result: - * Number of bytes decompressed or -1 if error (with *errorCodePtr updated with reason). - * - * Side effects: - * After execution it updates cd->inStream (next_in, avail_in) to reflect - * the data that has been decompressed. - * - *---------------------------------------------------------------------- - */ - -static int -ResultDecompress( - ZlibChannelData *cd, - char *buf, - int toRead, - int flush, - int *errorCodePtr) -{ - int e, written, resBytes = 0; - Tcl_Obj *errObj; - - - cd->flags &= ~STREAM_DECOMPRESS; - cd->inStream.next_out = (Bytef *) buf; - cd->inStream.avail_out = toRead; - while (cd->inStream.avail_out > 0) { - - e = inflate(&cd->inStream, flush); - if (e == Z_NEED_DICT && cd->compDictObj) { - e = SetInflateDictionary(&cd->inStream, cd->compDictObj); - if (e == Z_OK) { - /* - * A repetition of Z_NEED_DICT is just an error. - */ - e = inflate(&cd->inStream, flush); - } - } - - /* - * avail_out is now the left over space in the output. Therefore - * "toRead - avail_out" is the amount of bytes generated. - */ - - written = toRead - cd->inStream.avail_out; - - /* - * The cases where we're definitely done. - */ - - if (e == Z_STREAM_END) { - cd->flags |= STREAM_DONE; - resBytes += written; - break; - } - if (e == Z_OK) { - if (written == 0) { - break; - } - resBytes += written; - } - - if ((flush == Z_SYNC_FLUSH) && (e == Z_BUF_ERROR)) { - break; - } - - /* - * Z_BUF_ERROR can be ignored as per http://www.zlib.net/zlib_how.html - * - * Just indicates that the zlib couldn't consume input/produce output, - * and is fixed by supplying more input. - * - * Otherwise, we've got errors and need to report to higher-up. - */ - - if ((e != Z_OK) && (e != Z_BUF_ERROR)) { - goto handleError; - } - - /* - * Check if the inflate stopped early. - */ - - if (cd->inStream.avail_in <= 0 && flush != Z_SYNC_FLUSH) { - break; - } - } - - if (!(cd->flags & STREAM_DONE)) { - /* if we have pending input data, but no available output buffer */ - if (cd->inStream.avail_in && !cd->inStream.avail_out) { - /* next time try to decompress it got readable (new output buffer) */ - cd->flags |= STREAM_DECOMPRESS; - } - } - - return resBytes; - - handleError: - errObj = Tcl_NewListObj(0, NULL); - Tcl_ListObjAppendElement(NULL, errObj, Tcl_NewStringObj("-errorcode",-1)); - Tcl_ListObjAppendElement(NULL, errObj, - ConvertErrorToList(e, cd->inStream.adler)); - Tcl_ListObjAppendElement(NULL, errObj, - Tcl_NewStringObj(cd->inStream.msg, -1)); - Tcl_SetChannelError(cd->parent, errObj); - *errorCodePtr = EINVAL; - return -1; -} - -/* - *---------------------------------------------------------------------- - * Finally, the TclZlibInit function. Used to install the zlib API. - *---------------------------------------------------------------------- - */ - -int -TclZlibInit( - Tcl_Interp *interp) -{ - Tcl_Config cfg[2]; - - /* - * This does two things. It creates a counter used in the creation of - * stream commands, and it creates the namespace that will contain those - * commands. - */ - - Tcl_EvalEx(interp, "namespace eval ::tcl::zlib {variable cmdcounter 0}", -1, 0); - - /* - * Create the public scripted interface to this file's functionality. - */ - - Tcl_CreateObjCommand(interp, "zlib", ZlibCmd, 0, 0); - - /* - * Store the underlying configuration information. - * - * TODO: Describe whether we're using the system version of the library or - * a compatibility version built into Tcl? - */ - - cfg[0].key = "zlibVersion"; - cfg[0].value = zlibVersion(); - cfg[1].key = NULL; - Tcl_RegisterConfig(interp, "zlib", cfg, "utf-8"); - - /* - * Allow command type introspection to do something sensible with streams. - */ - - TclRegisterCommandTypeName(ZlibStreamCmd, "zlibStream"); - - /* - * Formally provide the package as a Tcl built-in. - */ - - return Tcl_PkgProvideEx(interp, "zlib", TCL_ZLIB_VERSION, NULL); -} - -/* - *---------------------------------------------------------------------- - * Stubs used when a suitable zlib installation was not found during - * configure. - *---------------------------------------------------------------------- - */ - -#else /* !HAVE_ZLIB */ -int -Tcl_ZlibStreamInit( - Tcl_Interp *interp, - int mode, - int format, - int level, - Tcl_Obj *dictObj, - Tcl_ZlibStream *zshandle) -{ - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1)); - Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL); - } - return TCL_ERROR; -} - -int -Tcl_ZlibStreamClose( - Tcl_ZlibStream zshandle) -{ - return TCL_OK; -} - -int -Tcl_ZlibStreamReset( - Tcl_ZlibStream zshandle) -{ - return TCL_OK; -} - -Tcl_Obj * -Tcl_ZlibStreamGetCommandName( - Tcl_ZlibStream zshandle) -{ - return NULL; -} - -int -Tcl_ZlibStreamEof( - Tcl_ZlibStream zshandle) -{ - return 1; -} - -int -Tcl_ZlibStreamChecksum( - Tcl_ZlibStream zshandle) -{ - return 0; -} - -int -Tcl_ZlibStreamPut( - Tcl_ZlibStream zshandle, - Tcl_Obj *data, - int flush) -{ - return TCL_OK; -} - -int -Tcl_ZlibStreamGet( - Tcl_ZlibStream zshandle, - Tcl_Obj *data, - size_t count) -{ - return TCL_OK; -} - -int -Tcl_ZlibDeflate( - Tcl_Interp *interp, - int format, - Tcl_Obj *data, - int level, - Tcl_Obj *gzipHeaderDictObj) -{ - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1)); - Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL); - } - return TCL_ERROR; -} - -int -Tcl_ZlibInflate( - Tcl_Interp *interp, - int format, - Tcl_Obj *data, - size_t 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 unsigned char *buf, - size_t len) -{ - return 0; -} - -unsigned int -Tcl_ZlibAdler32( - unsigned int adler, - const unsigned char *buf, - size_t len) -{ - return 0; -} - -void -Tcl_ZlibStreamSetCompressionDictionary( - Tcl_ZlibStream zshandle, - Tcl_Obj *compressionDictionaryObj) -{ - /* Do nothing. */ -} -#endif /* HAVE_ZLIB */ - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ ADDED generic/tommath.h Index: generic/tommath.h ================================================================== --- /dev/null +++ generic/tommath.h @@ -0,0 +1,1 @@ +#include "tclTomMathInt.h" Index: library/auto.tcl ================================================================== --- library/auto.tcl +++ library/auto.tcl @@ -68,70 +68,21 @@ # 1. From an environment variable, if it exists. Placing this first # gives the end-user ultimate control to work-around any bugs, or # to customize. - if {[info exists env($enVarName)]} { - lappend dirs $env($enVarName) - } - - catch { - set found 0 - set root [zipfs root] - set mountpoint [file join $root lib [string tolower $basename]] - lappend dirs [file join $root app ${basename}_library] - lappend dirs [file join $root lib $mountpoint ${basename}_library] - lappend dirs [file join $root lib $mountpoint] - if {![zipfs exists [file join $root app ${basename}_library]] \ - && ![zipfs exists $mountpoint]} { - set found 0 - foreach pkgdat [info loaded] { - lassign $pkgdat dllfile dllpkg - if {[string tolower $dllpkg] ne [string tolower $basename]} continue - if {$dllfile eq {}} { - # Loaded statically - break - } - set found 1 - zipfs mount $mountpoint $dllfile - break - } - if {!$found} { - set paths {} - lappend paths [file join $root app] - lappend paths [::${basename}::pkgconfig get libdir,runtime] - lappend paths [::${basename}::pkgconfig get bindir,runtime] - if {[catch {::${basename}::pkgconfig get zipfile,runtime} zipfile]} { - set zipfile [string tolower \ - "lib${basename}_[join [list {*}[split $version .] {*}$patch] _].zip"] - } - lappend paths [file dirname [file join [pwd] [info nameofexecutable]]] - foreach path $paths { - set archive [file join $path $zipfile] - if {![file exists $archive]} continue - zipfs mount $mountpoint $archive - if {[zipfs exists [file join $mountpoint ${basename}_library $initScript]]} { - lappend dirs [file join $mountpoint ${basename}_library] - set found 1 - break - } elseif {[zipfs exists [file join $mountpoint $initScript]]} { - lappend dirs [file join $mountpoint $initScript] - set found 1 - break - } else { - catch {zipfs unmount $archive} - } - } - } - } - } + if {[info exists env($enVarName)]} { + lappend dirs $env($enVarName) + } # 2. In the package script directory registered within the # configuration of the package itself. - catch { - lappend dirs [::${basename}::pkgconfig get scriptdir,runtime] + if {[catch { + ::${basename}::pkgconfig get scriptdir,runtime + } value] == 0} { + lappend dirs $value } # 3. Relative to auto_path directories. This checks relative to the # Tcl library as well as allowing loading of libraries added to the # auto_path that is not relative to the core library or binary paths. @@ -156,15 +107,15 @@ # ../../foo1.0.1/library # (From unix directory in parallel build hierarchy) # ../../../foo1.0.1/library # (From unix/arch directory in parallel build hierarchy) - set parentDir [file dirname [file dirname [info nameofexecutable]]] - set grandParentDir [file dirname $parentDir] - lappend dirs [file join $parentDir lib $basename$version] - lappend dirs [file join $grandParentDir lib $basename$version] - lappend dirs [file join $parentDir library] + set parentDir [file dirname [file dirname [info nameofexecutable]]] + set grandParentDir [file dirname $parentDir] + lappend dirs [file join $parentDir lib $basename$version] + lappend dirs [file join $grandParentDir lib $basename$version] + lappend dirs [file join $parentDir library] if {0} { lappend dirs [file join $grandParentDir library] lappend dirs [file join $grandParentDir $basename$patch library] lappend dirs [file join [file dirname $grandParentDir] \ $basename$patch library] @@ -171,35 +122,42 @@ } } # uniquify $dirs in order array set seen {} foreach i $dirs { - # Make sure $i is unique under normalization. Avoid repeated [source]. + # Take note that the [file normalize] below has been noted to + # cause difficulties for the freewrap utility. See Bug 1072136. + # Until freewrap resolves the matter, one might work around the + # problem by disabling that branch. if {[interp issafe]} { - # Safe interps have no [file normalize]. set norm $i } else { set norm [file normalize $i] } if {[info exists seen($norm)]} { continue } set seen($norm) {} - set the_library $i - set file [file join $i $initScript] - - # source everything when in a safe interpreter because we have a - # source command, but no file exists command - - if {[interp issafe] || [file exists $file]} { - if {![catch {uplevel #0 [list source $file]} msg opts]} { - return - } - append errors "$file: $msg\n" - append errors [dict get $opts -errorinfo]\n - } + lappend uniqdirs $i + } + set dirs $uniqdirs + foreach i $dirs { + set the_library $i + set file [file join $i $initScript] + + # source everything when in a safe interpreter because + # we have a source command, but no file exists command + + if {[interp issafe] || [file exists $file]} { + if {![catch {uplevel #0 [list source $file]} msg opts]} { + return + } else { + append errors "$file: $msg\n" + append errors [dict get $opts -errorinfo]\n + } + } } unset -nocomplain the_library set msg "Can't find a usable $initScript in the following directories: \n" append msg " $dirs\n\n" append msg "$errors\n\n" @@ -234,15 +192,16 @@ # within dir. If no additional are given auto_mkindex will look # for *.tcl. proc auto_mkindex {dir args} { if {[interp issafe]} { - error "can't generate index within safe interpreter" + error "can't generate index within safe interpreter" } set oldDir [pwd] cd $dir + set dir [pwd] append index "# Tcl autoload index file, version 2.0\n" append index "# This file is generated by the \"auto_mkindex\" command\n" append index "# and sourced to set up indexing information for one or\n" append index "# more commands. Typically each line is a command that\n" @@ -253,21 +212,20 @@ set args *.tcl } auto_mkindex_parser::init foreach file [lsort [glob -- {*}$args]] { - try { - append index [auto_mkindex_parser::mkindex $file] - } on error {msg opts} { + if {[catch {auto_mkindex_parser::mkindex $file} msg opts] == 0} { + append index $msg + } else { cd $oldDir return -options $opts $msg } } auto_mkindex_parser::cleanup set fid [open "tclIndex" w] - fconfigure $fid -encoding utf-8 -translation lf puts -nonewline $fid $index close $fid cd $oldDir } @@ -290,11 +248,11 @@ } foreach file [lsort [glob -- {*}$args]] { set f "" set error [catch { set f [open $file] - fconfigure $f -encoding utf-8 -eofchar \032 + fconfigure $f -eofchar "\032 {}" while {[gets $f line] >= 0} { if {[regexp {^proc[ ]+([^ ]*)} $line match procName]} { set procName [lindex [auto_qualify $procName "::"] 0] append index "set [list auto_index($procName)]" append index " \[list source \[file join \$dir [list $file]\]\]\n" @@ -309,11 +267,10 @@ } } set f "" set error [catch { set f [open tclIndex w] - fconfigure $f -encoding utf-8 -translation lf puts -nonewline $f $index close $f cd $oldDir } msg opts] if {$error} { @@ -350,18 +307,11 @@ $parser hide rename $parser hide proc $parser hide namespace $parser hide eval $parser hide puts - foreach ns [$parser invokehidden namespace children ::] { - # MUST NOT DELETE "::tcl" OR BAD THINGS HAPPEN! - if {$ns eq "::tcl"} continue - $parser invokehidden namespace delete $ns - } - foreach cmd [$parser invokehidden info commands ::*] { - $parser invokehidden rename $cmd {} - } + $parser invokehidden namespace delete :: $parser invokehidden proc unknown {args} {} # We'll need access to the "namespace" command within the # interp. Put it back, but move it out of the way. @@ -402,11 +352,11 @@ variable imports set scriptFile $file set fid [open $file] - fconfigure $fid -encoding utf-8 -eofchar \032 + fconfigure $fid -eofchar "\032 {}" set contents [read $fid] close $fid # There is one problem with sourcing files into the safe interpreter: # references like "$x" will fail since code is not really being executed @@ -422,38 +372,38 @@ set imports "" $parser eval $contents foreach name $imports { - catch {$parser eval [list _%@namespace forget $name]} + catch {$parser eval [list _%@namespace forget $name]} } return $index } # auto_mkindex_parser::hook command # -# Registers a Tcl command to evaluate when initializing the child interpreter -# used by the mkindex parser. The command is evaluated in the parent +# Registers a Tcl command to evaluate when initializing the slave interpreter +# used by the mkindex parser. The command is evaluated in the master # interpreter, and can use the variable auto_mkindex_parser::parser to get to -# the child +# the slave proc auto_mkindex_parser::hook {cmd} { variable initCommands lappend initCommands $cmd } -# auto_mkindex_parser::childhook command +# auto_mkindex_parser::slavehook command # -# Registers a Tcl command to evaluate when initializing the child interpreter -# used by the mkindex parser. The command is evaluated in the child +# Registers a Tcl command to evaluate when initializing the slave interpreter +# used by the mkindex parser. The command is evaluated in the slave # interpreter. -proc auto_mkindex_parser::childhook {cmd} { +proc auto_mkindex_parser::slavehook {cmd} { variable initCommands - # The $parser variable is defined to be the name of the child interpreter + # The $parser variable is defined to be the name of the slave interpreter # when this command is used later. lappend initCommands "\$parser eval [list $cmd]" } @@ -492,23 +442,23 @@ variable parser set ns [namespace qualifiers $name] set tail [namespace tail $name] if {$ns eq ""} { - set fakeName [namespace current]::_%@fake_$tail + set fakeName [namespace current]::_%@fake_$tail } else { - set fakeName [namespace current]::[string map {:: _} _%@fake_$name] + set fakeName [namespace current]::[string map {:: _} _%@fake_$name] } proc $fakeName $arglist $body # YUK! Tcl won't let us alias fully qualified command names, so we can't # handle names like "::itcl::class". Instead, we have to build procs with # the fully qualified names, and have the procs point to the aliases. if {[string match *::* $name]} { - set exportCmd [list _%@namespace export [namespace tail $name]] - $parser eval [list _%@namespace eval $ns $exportCmd] + set exportCmd [list _%@namespace export [namespace tail $name]] + $parser eval [list _%@namespace eval $ns $exportCmd] # The following proc definition does not work if you want to tolerate # space or something else diabolical in the procedure name, (i.e., # space in $alias). The following does not work: # "_%@eval {$alias} \$args" @@ -516,15 +466,15 @@ # because $cmd is somehow undefined # "set cmd {$alias} \; _%@eval {\$cmd} \$args" # A gold star to someone that can make test autoMkindex-3.3 work # properly - set alias [namespace tail $fakeName] - $parser invokehidden proc $name {args} "_%@eval {$alias} \$args" - $parser alias $alias $fakeName + set alias [namespace tail $fakeName] + $parser invokehidden proc $name {args} "_%@eval {$alias} \$args" + $parser alias $alias $fakeName } else { - $parser alias $name $fakeName + $parser alias $name $fakeName } return } # auto_mkindex_parser::fullname -- @@ -542,83 +492,61 @@ proc auto_mkindex_parser::fullname {name} { variable contextStack if {![string match ::* $name]} { - foreach ns $contextStack { - set name "${ns}::$name" - if {[string match ::* $name]} { - break - } - } + foreach ns $contextStack { + set name "${ns}::$name" + if {[string match ::* $name]} { + break + } + } } if {[namespace qualifiers $name] eq ""} { - set name [namespace tail $name] + set name [namespace tail $name] } elseif {![string match ::* $name]} { - set name "::$name" + set name "::$name" } # Earlier, mkindex replaced all $'s with \0. Now, we have to reverse that # replacement. return [string map [list \0 \$] $name] } -# auto_mkindex_parser::indexEntry -- -# -# Used by commands like "proc" within the auto_mkindex parser to add a -# correctly-quoted entry to the index. This is shared code so it is done -# *right*, in one place. -# -# Arguments: -# name - Name that is being added to index. - -proc auto_mkindex_parser::indexEntry {name} { - variable index - variable scriptFile - - # We convert all metacharacters to their backslashed form, and pre-split - # the file name that we know about (which will be a proper list, and so - # correctly quoted). - - set name [string range [list \}[fullname $name]] 2 end] - set filenameParts [file split $scriptFile] - - append index [format \ - {set auto_index(%s) [list source [file join $dir %s]]%s} \ - $name $filenameParts \n] - return -} - if {[llength $::auto_mkindex_parser::initCommands]} { return } -# Register all of the procedures for the auto_mkindex parser that will build -# the "tclIndex" file. +# Register all of the procedures for the auto_mkindex parser that +# will build the "tclIndex" file. # AUTO MKINDEX: proc name arglist body # Adds an entry to the auto index list for the given procedure name. auto_mkindex_parser::command proc {name args} { - indexEntry $name + variable index + variable scriptFile + # Do some fancy reformatting on the "source" call to handle platform + # differences with respect to pathnames. Use format just so that the + # command is a little easier to read (otherwise it'd be full of + # backslashed dollar signs, etc. + append index [list set auto_index([fullname $name])] \ + [format { [list source [file join $dir %s]]} \ + [file split $scriptFile]] "\n" } # Conditionally add support for Tcl byte code files. There are some tricky # details here. First, we need to get the tbcload library initialized in the -# current interpreter. We cannot load tbcload into the child until we have +# current interpreter. We cannot load tbcload into the slave until we have # done so because it needs access to the tcl_patchLevel variable. Second, # because the package index file may defer loading the library until we invoke # a command, we need to explicitly invoke auto_load to force it to be loaded. # This should be a noop if the package has already been loaded auto_mkindex_parser::hook { - try { - package require tbcload - } on error {} { - # OK, don't have it so do nothing - } on ok {} { + if {![catch {package require tbcload}]} { if {[namespace which -command tbcload::bcproc] eq ""} { auto_load tbcload::bcproc } load {} tbcload $auto_mkindex_parser::parser @@ -625,11 +553,18 @@ # AUTO MKINDEX: tbcload::bcproc name arglist body # Adds an entry to the auto index list for the given pre-compiled # procedure name. auto_mkindex_parser::commandInit tbcload::bcproc {name args} { - indexEntry $name + variable index + variable scriptFile + # Do some nice reformatting of the "source" call, to get around + # path differences on different platforms. We use the format + # command just so that the code is a little easier to read. + append index [list set auto_index([fullname $name])] \ + [format { [list source [file join $dir %s]]} \ + [file split $scriptFile]] "\n" } } } # AUTO MKINDEX: namespace eval name command ?arg arg...? @@ -643,59 +578,39 @@ # then say "class ...". This procedure does the import operation, but keeps # track of imported patterns so we can remove the imports later. auto_mkindex_parser::command namespace {op args} { switch -- $op { - eval { - variable parser - variable contextStack - - set name [lindex $args 0] - set args [lrange $args 1 end] - - set contextStack [linsert $contextStack 0 $name] + eval { + variable parser + variable contextStack + + set name [lindex $args 0] + set args [lrange $args 1 end] + + set contextStack [linsert $contextStack 0 $name] $parser eval [list _%@namespace eval $name] $args - set contextStack [lrange $contextStack 1 end] - } - import { - variable parser - variable imports - foreach pattern $args { - if {$pattern ne "-force"} { - lappend imports $pattern - } - } - catch {$parser eval "_%@namespace import $args"} - } + set contextStack [lrange $contextStack 1 end] + } + import { + variable parser + variable imports + foreach pattern $args { + if {$pattern ne "-force"} { + lappend imports $pattern + } + } + catch {$parser eval "_%@namespace import $args"} + } ensemble { variable parser variable contextStack if {[lindex $args 0] eq "create"} { set name ::[join [lreverse $contextStack] ::] - catch { - set name [dict get [lrange $args 1 end] -command] - if {![string match ::* $name]} { - set name ::[join [lreverse $contextStack] ::]$name - } - regsub -all ::+ $name :: name - } # create artifical proc to force an entry in the tclIndex $parser eval [list ::proc $name {} {}] } } } } -# AUTO MKINDEX: oo::class create name ?definition? -# Adds an entry to the auto index list for the given class name. -auto_mkindex_parser::command oo::class {op name {body ""}} { - if {$op eq "create"} { - indexEntry $name - } -} -auto_mkindex_parser::command class {op name {body ""}} { - if {$op eq "create"} { - indexEntry $name - } -} - return Index: library/clock.tcl ================================================================== --- library/clock.tcl +++ library/clock.tcl @@ -1,12 +1,12 @@ #---------------------------------------------------------------------- # # clock.tcl -- # -# This file implements the portions of the [clock] ensemble that are -# coded in Tcl. Refer to the users' manual to see the description of -# the [clock] command and its subcommands. +# This file implements the portions of the [clock] ensemble that +# are coded in Tcl. Refer to the users' manual to see the description +# of the [clock] command and its subcommands. # # #---------------------------------------------------------------------- # # Copyright (c) 2004,2005,2006,2007 by Kevin B. Kenny @@ -13,24 +13,25 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # #---------------------------------------------------------------------- -# We must have message catalogs that support the root locale, and we need -# access to the Registry on Windows systems. +# We must have message catalogs that support the root locale, and +# we need access to the Registry on Windows systems. uplevel \#0 { - package require msgcat 1.6 + package require msgcat 1.4 if { $::tcl_platform(platform) eq {windows} } { if { [catch { package require registry 1.1 }] } { namespace eval ::tcl::clock [list variable NoRegistry {}] } } } -# Put the library directory into the namespace for the ensemble so that the -# library code can find message catalogs and time zone definition files. +# Put the library directory into the namespace for the ensemble +# so that the library code can find message catalogs and time zone +# definition files. namespace eval ::tcl::clock \ [list variable LibDir [file dirname [info script]]] #---------------------------------------------------------------------- @@ -37,12 +38,12 @@ # # clock -- # # Manipulate times. # -# The 'clock' command manipulates time. Refer to the user documentation for -# the available subcommands and what they do. +# The 'clock' command manipulates time. Refer to the user documentation +# for the available subcommands and what they do. # #---------------------------------------------------------------------- namespace eval ::tcl::clock { @@ -58,12 +59,10 @@ # Import the message catalog commands that we use. namespace import ::msgcat::mcload namespace import ::msgcat::mclocale - namespace import ::msgcat::mc - namespace import ::msgcat::mcpackagelocale } #---------------------------------------------------------------------- # @@ -75,15 +74,15 @@ # None. # # Side effects: # Namespace variable in the 'clock' subsystem are initialized. # -# The '::tcl::clock::Initialize' procedure initializes the namespace variables -# and root locale message catalog for the 'clock' subsystem. It is broken -# into a procedure rather than simply evaluated as a script so that it will be -# able to use local variables, avoiding the dangers of 'creative writing' as -# in Bug 1185933. +# The '::tcl::clock::Initialize' procedure initializes the namespace +# variables and root locale message catalog for the 'clock' subsystem. +# It is broken into a procedure rather than simply evaluated as a script +# so that it will be able to use local variables, avoiding the dangers +# of 'creative writing' as in Bug 1185933. # #---------------------------------------------------------------------- proc ::tcl::clock::Initialize {} { @@ -106,15 +105,10 @@ set TZData(:UTC) $TZData(:Etc/UTC) set TZData(:localtime) {} } InitTZData - mcpackagelocale set {} - ::msgcat::mcpackageconfig set mcfolder [file join $LibDir msgs] - ::msgcat::mcpackageconfig set unknowncmd "" - ::msgcat::mcpackageconfig set changecmd ChangeCurrentLocale - # Define the message catalog for the root locale. ::msgcat::mcmset {} { AM {am} BCE {B.C.E.} @@ -176,12 +170,12 @@ # France, Austria ::msgcat::mcset fr GREGORIAN_CHANGE_DATE 2299227 - # For Belgium, we follow Southern Netherlands; Liege Diocese changed - # several weeks later. + # For Belgium, we follow Southern Netherlands; Liege Diocese + # changed several weeks later. ::msgcat::mcset fr_BE GREGORIAN_CHANGE_DATE 2299238 ::msgcat::mcset nl_BE GREGORIAN_CHANGE_DATE 2299238 # Austria @@ -198,12 +192,12 @@ ::msgcat::mcset nb GREGORIAN_CHANGE_DATE 2342032 ::msgcat::mcset nn GREGORIAN_CHANGE_DATE 2342032 ::msgcat::mcset no GREGORIAN_CHANGE_DATE 2342032 ::msgcat::mcset da GREGORIAN_CHANGE_DATE 2342032 - # Holland (Brabant, Gelderland, Flanders, Friesland, etc. changed at - # various times) + # Holland (Brabant, Gelderland, Flanders, Friesland, etc. changed + # at various times) ::msgcat::mcset nl GREGORIAN_CHANGE_DATE 2342165 # Protestant Switzerland (Catholic cantons changed earlier) @@ -221,12 +215,12 @@ # Russia ::msgcat::mcset ru GREGORIAN_CHANGE_DATE 2421639 - # Romania (Transylvania changed earler - perhaps de_RO should show the - # earlier date?) + # Romania (Transylvania changed earler - perhaps de_RO should show + # the earlier date?) ::msgcat::mcset ro GREGORIAN_CHANGE_DATE 2422063 # Greece @@ -236,12 +230,12 @@ # # CONSTANTS # #------------------------------------------------------------------ - # Paths at which binary time zone data for the Olson libraries are known - # to reside on various operating systems + # Paths at which binary time zone data for the Olson libraries + # are known to reside on various operating systems variable ZoneinfoPaths {} foreach path { /usr/share/zoneinfo /usr/share/lib/zoneinfo @@ -254,10 +248,11 @@ } # Define the directories for time zone data and message catalogs. variable DataDir [file join $LibDir tzdata] + variable MsgDir [file join $LibDir msgs] # Number of days in the months, in common years and leap years. variable DaysInRomanMonthInCommonYear \ { 31 28 31 30 31 30 31 31 30 31 30 31 } @@ -285,14 +280,14 @@ # Day before Leap Day variable FEB_28 58 - # Translation table to map Windows TZI onto cities, so that the Olson - # rules can apply. In some cases the mapping is ambiguous, so it's wise - # to specify $::env(TCL_TZ) rather than simply depending on the system - # time zone. + # Translation table to map Windows TZI onto cities, so that + # the Olson rules can apply. In some cases the mapping is ambiguous, + # so it's wise to specify $::env(TCL_TZ) rather than simply depending + # on the system time zone. # The keys are long lists of values obtained from the time zone # information in the Registry. In order, the list elements are: # Bias StandardBias DaylightBias # StandardDate.wYear StandardDate.wMonth StandardDate.wDayOfWeek @@ -299,14 +294,14 @@ # StandardDate.wDay StandardDate.wHour StandardDate.wMinute # StandardDate.wSecond StandardDate.wMilliseconds # DaylightDate.wYear DaylightDate.wMonth DaylightDate.wDayOfWeek # DaylightDate.wDay DaylightDate.wHour DaylightDate.wMinute # DaylightDate.wSecond DaylightDate.wMilliseconds - # The values are the names of time zones where those rules apply. There - # is considerable ambiguity in certain zones; an attempt has been made to - # make a reasonable guess, but this table needs to be taken with a grain - # of salt. + # The values are the names of time zones where those rules apply. + # There is considerable ambiguity in certain zones; an attempt has + # been made to make a reasonable guess, but this table needs to be + # taken with a grain of salt. variable WinZoneInfo [dict create {*}{ {-43200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Kwajalein {-39600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Midway {-36000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Honolulu @@ -381,14 +376,14 @@ {43200 0 3600 0 3 0 3 3 0 0 0 0 10 0 1 2 0 0 0} :Pacific/Auckland {43200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Fiji {46800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Tongatapu }] - # Groups of fields that specify the date, priorities, and code bursts that - # determine Julian Day Number given those groups. The code in [clock - # scan] will choose the highest priority (lowest numbered) set of fields - # that determines the date. + # Groups of fields that specify the date, priorities, and + # code bursts that determine Julian Day Number given those groups. + # The code in [clock scan] will choose the highest priority + # (lowest numbered) set of fields that determines the date. variable DateParseActions { { seconds } 0 {} @@ -488,12 +483,12 @@ set date [AssignBaseJulianDay $date[set date {}] \ $baseTime $timeZone $changeover] } } - # Groups of fields that specify time of day, priorities, and code that - # processes them + # Groups of fields that specify time of day, priorities, + # and code that processes them variable TimeParseActions { seconds 1 {} @@ -627,10 +622,15 @@ # names and whose values are pairs # comprising regexes matching numerals # in the given locales and dictionaries # mapping the numerals to their numeric # values. + variable McLoaded {}; # Dictionary whose keys are locales + # in which [mcload] has been executed + # and whose values are second-level + # dictionaries indexed by message + # name and giving message text. # variable CachedSystemTimeZone; # If 'CachedSystemTimeZone' exists, # it contains the value of the # system time zone, as determined from # the environment. variable TimeZoneBad {}; # Dictionary whose keys are time zone @@ -650,14 +650,15 @@ #---------------------------------------------------------------------- # # clock format -- # -# Formats a count of seconds since the Posix Epoch as a time of day. +# Formats a count of seconds since the Posix Epoch as a time +# of day. # -# The 'clock format' command formats times of day for output. Refer to the -# user documentation to see what it does. +# The 'clock format' command formats times of day for output. +# Refer to the user documentation to see what it does. # #---------------------------------------------------------------------- proc ::tcl::clock::format { args } { @@ -678,13 +679,13 @@ dict unset opts -errorinfo return -options $opts $retval } } - # Build a procedure to format the result. Cache the built procedure's name - # in the 'FormatProc' array to avoid losing its internal representation, - # which contains the name resolution. + # Build a procedure to format the result. Cache the built procedure's + # name in the 'FormatProc' array to avoid losing its internal + # representation, which contains the name resolution. set procName formatproc'$format'$locale set procName [namespace current]::[string map {: {\:} \\ {\\}} $procName] if {[info exists FormatProc($procName)]} { set procName $FormatProc($procName) @@ -718,23 +719,42 @@ return $procName } # Map away the locale-dependent composite format groups - EnterLocale $locale + EnterLocale $locale oldLocale # Change locale if a fresh locale has been given on the command line. - try { - return [ParseClockFormatFormat2 $format $locale $procName] - } trap CLOCK {result opts} { - dict unset opts -errorinfo - return -options $opts $result + set status [catch { + + ParseClockFormatFormat2 $format $locale $procName + + } result opts] + + # Restore the locale + + if { [info exists oldLocale] } { + mclocale $oldLocale } + + # Return either the error or the proc name + + if { $status == 1 } { + if { [lindex [dict get $opts -errorcode] 0] eq {clock} } { + return -code error $result + } else { + return -options $opts $result + } + } else { + return $result + } + } proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { + set didLocaleEra 0 set didLocaleNumerals 0 set preFormatCode \ [string map [list @GREGORIAN_CHANGE_DATE@ \ [mc GREGORIAN_CHANGE_DATE]] \ @@ -1169,14 +1189,15 @@ #---------------------------------------------------------------------- # # clock scan -- # -# Inputs a count of seconds since the Posix Epoch as a time of day. +# Inputs a count of seconds since the Posix Epoch as a time +# of day. # -# The 'clock format' command scans times of day on input. Refer to the user -# documentation to see what it does. +# The 'clock format' command scans times of day on input. +# Refer to the user documentation to see what it does. # #---------------------------------------------------------------------- proc ::tcl::clock::scan { args } { @@ -1224,12 +1245,12 @@ -t - -ti - -tim - -time - -timez - -timezo - -timezon - -timezone { set timezone $value } default { return -code error \ - -errorcode [list CLOCK badOption $flag] \ - "bad option \"$flag\",\ + -errorcode [list CLOCK badSwitch $flag] \ + "bad switch \"$flag\",\ must be -base, -format, -gmt, -locale or -timezone" } } } @@ -1239,21 +1260,25 @@ return -code error \ -errorcode [list CLOCK gmtWithTimezone] \ "cannot use -gmt and -timezone in same call" } if { [catch { expr { wide($base) } } result] } { - return -code error "expected integer but got \"$base\"" + return -code error \ + "expected integer but got \"$base\"" } - if { ![string is boolean -strict $gmt] } { - return -code error "expected boolean value but got \"$gmt\"" - } elseif { $gmt } { - set timezone :GMT + if { ![string is boolean $gmt] } { + return -code error \ + "expected boolean value but got \"$gmt\"" + } else { + if { $gmt } { + set timezone :GMT + } } if { ![info exists saw(-format)] } { - # Perhaps someday we'll localize the legacy code. Right now, it's not - # localized. + # Perhaps someday we'll localize the legacy code. Right now, + # it's not localized. if { [info exists saw(-locale)] } { return -code error \ -errorcode [list CLOCK flagWithLegacyFormat] \ "legacy \[clock scan\] does not support -locale" @@ -1261,22 +1286,37 @@ return [FreeScan $string $base $timezone $locale] } # Change locale if a fresh locale has been given on the command line. - EnterLocale $locale + EnterLocale $locale oldLocale - try { + set status [catch { + # Map away the locale-dependent composite format groups set scanner [ParseClockScanFormat $format $locale] - return [$scanner $string $base $timezone] - } trap CLOCK {result opts} { - # Conceal location of generation of expected errors - dict unset opts -errorinfo - return -options $opts $result + $scanner $string $base $timezone + + } result opts] + + # Restore the locale + + if { [info exists oldLocale] } { + mclocale $oldLocale } + + if { $status == 1 } { + if { [lindex [dict get $opts -errorcode] 0] eq {clock} } { + return -code error $result + } else { + return -options $opts $result + } + } else { + return $result + } + } #---------------------------------------------------------------------- # # FreeScan -- @@ -1288,55 +1328,56 @@ # base - Base time, expressed in seconds from the Epoch # timezone - Default time zone in which the time will be expressed # locale - (Unused) Name of the locale where the time will be scanned. # # Results: -# Returns the date and time extracted from the string in seconds from -# the epoch +# Returns the date and time extracted from the string in seconds +# from the epoch # #---------------------------------------------------------------------- proc ::tcl::clock::FreeScan { string base timezone locale } { variable TZData # Get the data for time changes in the given zone - try { - SetupTimeZone $timezone - } on error {retval opts} { + if {[catch {SetupTimeZone $timezone} retval opts]} { dict unset opts -errorinfo return -options $opts $retval } - # Extract year, month and day from the base time for the parser to use as - # defaults - - set date [GetDateFields $base $TZData($timezone) 2361222] - dict set date secondOfDay [expr { - [dict get $date localSeconds] % 86400 - }] - - # Parse the date. The parser will return a list comprising date, time, - # time zone, relative month/day/seconds, relative weekday, ordinal month. - - try { - set scanned [Oldscan $string \ - [dict get $date year] \ - [dict get $date month] \ - [dict get $date dayOfMonth]] - lassign $scanned \ - parseDate parseTime parseZone parseRel \ - parseWeekday parseOrdinalMonth - } on error message { - return -code error \ - "unable to convert date-time string \"$string\": $message" - } - - # If the caller supplied a date in the string, update the 'date' dict with - # the value. If the caller didn't specify a time with the date, default to - # midnight. + # Extract year, month and day from the base time for the + # parser to use as defaults + + set date [GetDateFields \ + $base \ + $TZData($timezone) \ + 2361222] + dict set date secondOfDay [expr { [dict get $date localSeconds] + % 86400 }] + + # Parse the date. The parser will return a list comprising + # date, time, time zone, relative month/day/seconds, relative + # weekday, ordinal month. + + set status [catch { + Oldscan $string \ + [dict get $date year] \ + [dict get $date month] \ + [dict get $date dayOfMonth] + } result] + if { $status != 0 } { + return -code error "unable to convert date-time string \"$string\": $result" + } + + lassign $result parseDate parseTime parseZone parseRel \ + parseWeekday parseOrdinalMonth + + # If the caller supplied a date in the string, update the 'date' dict + # with the value. If the caller didn't specify a time with the date, + # default to midnight. if { [llength $parseDate] > 0 } { lassign $parseDate y m d if { $y < 100 } { if { $y >= 39 } { @@ -1352,15 +1393,15 @@ if { $parseTime eq {} } { set parseTime 0 } } - # If the caller supplied a time zone in the string, it comes back as a - # two-element list; the first element is the number of minutes east of - # Greenwich, and the second is a Daylight Saving Time indicator (1 == yes, - # 0 == no, -1 == unknown). We make it into a time zone indicator of - # +-hhmm. + # If the caller supplied a time zone in the string, it comes back + # as a two-element list; the first element is the number of minutes + # east of Greenwich, and the second is a Daylight Saving Time + # indicator ( 1 == yes, 0 == no, -1 == unknown ). We make it into + # a time zone indicator of +-hhmm. if { [llength $parseZone] > 0 } { lassign $parseZone minEast dstFlag set timezone [FormatNumericTimeZone \ [expr { 60 * $minEast + 3600 * $dstFlag }]] @@ -1379,15 +1420,14 @@ && ( [lindex $parseRel 0] != 0 || [lindex $parseRel 1] != 0 ) ) } { dict set date secondOfDay 0 } - dict set date localSeconds [expr { - -210866803200 - + ( 86400 * wide([dict get $date julianDay]) ) - + [dict get $date secondOfDay] - }] + dict set date localSeconds \ + [expr { -210866803200 + + ( 86400 * wide([dict get $date julianDay]) ) + + [dict get $date secondOfDay] }] dict set date tzName $timezone set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) 2361222] set seconds [dict get $date seconds] # Do relative times @@ -1400,28 +1440,28 @@ } # Do relative weekday if { [llength $parseWeekday] > 0 } { + lassign $parseWeekday dayOrdinal dayOfWeek set date2 [GetDateFields $seconds $TZData($timezone) 2361222] dict set date2 era CE - set jdwkday [WeekdayOnOrBefore $dayOfWeek [expr { - [dict get $date2 julianDay] + 6 - }]] + set jdwkday [WeekdayOnOrBefore $dayOfWeek \ + [expr { [dict get $date2 julianDay] + + 6 }]] incr jdwkday [expr { 7 * $dayOrdinal }] if { $dayOrdinal > 0 } { incr jdwkday -7 } dict set date2 secondOfDay \ [expr { [dict get $date2 localSeconds] % 86400 }] dict set date2 julianDay $jdwkday - dict set date2 localSeconds [expr { - -210866803200 - + ( 86400 * wide([dict get $date2 julianDay]) ) - + [dict get $date secondOfDay] - }] + dict set date2 localSeconds \ + [expr { -210866803200 + + ( 86400 * wide([dict get $date2 julianDay]) ) + + [dict get $date secondOfDay] }] dict set date2 tzName $timezone set date2 [ConvertLocalToUTC $date2[set date2 {}] $TZData($timezone) \ 2361222] set seconds [dict get $date2 seconds] @@ -1428,10 +1468,11 @@ } # Do relative month if { [llength $parseOrdinalMonth] > 0 } { + lassign $parseOrdinalMonth monthOrdinal monthNumber if { $monthOrdinal > 0 } { set monthDiff [expr { $monthNumber - [dict get $date month] }] if { $monthDiff <= 0 } { incr monthDiff 12 @@ -1444,10 +1485,11 @@ } incr monthOrdinal } set seconds [add $seconds $monthOrdinal years $monthDiff months \ -timezone $timezone -locale $locale] + } return $seconds } @@ -1461,31 +1503,34 @@ # Parameters: # formatString - The format being parsed # locale - The current locale # # Results: -# Constructs and returns a procedure that accepts the string being -# scanned, the base time, and the time zone. The procedure will either -# return the scanned time or else throw an error that should be rethrown -# to the caller of [clock scan] +# Constructs and returns a procedure that accepts the +# string being scanned, the base time, and the time zone. +# The procedure will either return the scanned time or +# else throw an error that should be rethrown to the caller +# of [clock scan] # # Side effects: -# The given procedure is defined in the ::tcl::clock namespace. Scan -# procedures are not deleted once installed. -# -# Why do we parse dates by defining a procedure to parse them? The reason is -# that by doing so, we have one convenient place to cache all the information: -# the regular expressions that match the patterns (which will be compiled), -# the code that assembles the date information, everything lands in one place. -# In this way, when a given format is reused at run time, all the information +# The given procedure is defined in the ::tcl::clock +# namespace. Scan procedures are not deleted once installed. +# +# Why do we parse dates by defining a procedure to parse them? +# The reason is that by doing so, we have one convenient place to +# cache all the information: the regular expressions that match the +# patterns (which will be compiled), the code that assembles the +# date information, everything lands in one place. In this way, +# when a given format is reused at run time, all the information # of how to apply it is available in a single place. # #---------------------------------------------------------------------- proc ::tcl::clock::ParseClockScanFormat {formatString locale} { - # Check whether the format has been parsed previously, and return the - # existing recognizer if it has. + + # Check whether the format has been parsed previously, and return + # the existing recognizer if it has. set procName scanproc'$formatString'$locale set procName [namespace current]::[string map {: {\:} \\ {\\}} $procName] if { [namespace which $procName] != {} } { return $procName @@ -1525,12 +1570,12 @@ set state % } elseif { $c eq " " } { append re {[[:space:]]+} } else { if { ! [string is alnum $c] } { - append re "\\" - } + append re \\ + } append re $c } } % { set state {} @@ -1643,11 +1688,11 @@ dict set fieldSet julianDay [incr fieldCount] append postcode "dict set date julianDay \[" \ "::scan \$field" [incr captureCount] " %ld" \ "\]\n" } - m - N { # Month number + m - N { # Month number append re \\s*(\\d\\d?) dict set fieldSet month [incr fieldCount] append postcode "dict set date month \[" \ "::scan \$field" [incr captureCount] " %d" \ "\]\n" @@ -1686,13 +1731,14 @@ { $field} [incr captureCount] \ { $field} [incr captureCount] \ \] \n } s { # Seconds from Posix Epoch - # This next case is insanely difficult, because it's - # problematic to determine whether the field is - # actually within the range of a wide integer. + # This next case is insanely difficult, + # because it's problematic to determine + # whether the field is actually within + # the range of a wide integer. append re {\s*([-+]?\d+)} dict set fieldSet seconds [incr fieldCount] append postcode {dict set date seconds } \[ \ {ScanWide $field} [incr captureCount] \] \n } @@ -1721,13 +1767,14 @@ "day of week is greater than 7" } dict set date dayOfWeek $dow } } - U { # Week of year. The first Sunday of - # the year is the first day of week - # 01. No scan rule uses this group. + U { # Week of year. The + # first Sunday of the year is the + # first day of week 01. No scan rule + # uses this group. append re \\s*\\d\\d? } V { # Week of ISO8601 year append re \\s*(\\d\\d?) @@ -1945,15 +1992,14 @@ append procBody "set date \[dict create\]" \n append procBody {dict set date tzName $timeZone} \n append procBody $postcode append procBody [list set changeover [mc GREGORIAN_CHANGE_DATE]] \n - # Set up the time zone before doing anything with a default base date - # that might need a timezone to interpret it. + # Get time zone if needed if { ![dict exists $fieldSet seconds] - && ![dict exists $fieldSet starDate] } { + && ![dict exists $fieldSet starDate] } { if { [dict exists $fieldSet tzName] } { append procBody { set timeZone [dict get $date tzName] } } @@ -1968,33 +2014,28 @@ # Get time of day append procBody [MakeParseCodeFromFields $fieldSet $TimeParseActions] - # Assemble seconds from the Julian day and second of the day. - # Convert to local time unless epoch seconds or stardate are - # being processed - they're always absolute + # Assemble seconds, and convert local nominal time to UTC. if { ![dict exists $fieldSet seconds] && ![dict exists $fieldSet starDate] } { append procBody { if { [dict get $date julianDay] > 5373484 } { return -code error -errorcode [list CLOCK dateTooLarge] \ "requested date too large to represent" } - dict set date localSeconds [expr { - -210866803200 - + ( 86400 * wide([dict get $date julianDay]) ) - + [dict get $date secondOfDay] - }] - } - - # Finally, convert the date to local time - + dict set date localSeconds \ + [expr { -210866803200 + + ( 86400 * wide([dict get $date julianDay]) ) + + [dict get $date secondOfDay] }] + } append procBody { set date [::tcl::clock::ConvertLocalToUTC $date[set date {}] \ - $TZData($timeZone) $changeover] + $TZData($timeZone) \ + $changeover] } } # Return result @@ -2009,25 +2050,27 @@ #---------------------------------------------------------------------- # # LocaleNumeralMatcher -- # -# Composes a regexp that captures the numerals in the given locale, and -# a dictionary to map them to conventional numerals. +# Composes a regexp that captures the numerals in the given +# locale, and a dictionary to map them to conventional numerals. # # Parameters: # locale - Name of the current locale # # Results: -# Returns a two-element list comprising the regexp and the dictionary. +# Returns a two-element list comprising the regexp and the +# dictionary. # # Side effects: # Caches the result. # #---------------------------------------------------------------------- proc ::tcl::clock::LocaleNumeralMatcher {l} { + variable LocaleNumeralCache if { ![dict exists $LocaleNumeralCache $l] } { set d {} set i 0 @@ -2049,42 +2092,44 @@ #---------------------------------------------------------------------- # # UniquePrefixRegexp -- # -# Composes a regexp that performs unique-prefix matching. The RE -# matches one of a supplied set of strings, or any unique prefix -# thereof. +# Composes a regexp that performs unique-prefix matching. The +# RE matches one of a supplied set of strings, or any unique +# prefix thereof. # # Parameters: # data - List of alternating match-strings and values. # Match-strings with distinct values are considered # distinct. # # Results: -# Returns a two-element list. The first is a regexp that matches any -# unique prefix of any of the strings. The second is a dictionary whose -# keys are match values from the regexp and whose values are the -# corresponding values from 'data'. +# Returns a two-element list. The first is a regexp that +# matches any unique prefix of any of the strings. The second +# is a dictionary whose keys are match values from the regexp +# and whose values are the corresponding values from 'data'. # # Side effects: # None. # #---------------------------------------------------------------------- proc ::tcl::clock::UniquePrefixRegexp { data } { - # The 'successors' dictionary will contain, for each string that is a - # prefix of any key, all characters that may follow that prefix. The - # 'prefixMapping' dictionary will have keys that are prefixes of keys and - # values that correspond to the keys. + + # The 'successors' dictionary will contain, for each string that + # is a prefix of any key, all characters that may follow that + # prefix. The 'prefixMapping' dictionary will have keys that + # are prefixes of keys and values that correspond to the keys. set prefixMapping [dict create] set successors [dict create {} {}] # Walk the key-value pairs foreach { key value } $data { + # Construct all prefixes of the key; set prefix {} foreach char [split $key {}] { set oldPrefix $prefix @@ -2099,12 +2144,12 @@ dict set successors $prefix {} } } } - # Identify those prefixes that designate unique values, and those that are - # the full keys + # Identify those prefixes that designate unique values, and + # those that are the full keys set uniquePrefixMapping {} dict for { key valueList } $prefixMapping { if { [llength $valueList] == 1 } { dict set uniquePrefixMapping $key [lindex $valueList 0] @@ -2123,12 +2168,12 @@ #---------------------------------------------------------------------- # # MakeUniquePrefixRegexp -- # -# Service procedure for 'UniquePrefixRegexp' that constructs a regular -# expresison that matches the unique prefixes. +# Service procedure for 'UniquePrefixRegexp' that constructs +# a regular expresison that matches the unique prefixes. # # Parameters: # successors - Dictionary whose keys are all prefixes # of keys passed to 'UniquePrefixRegexp' and whose # values are dictionaries whose keys are the characters @@ -2136,12 +2181,12 @@ # uniquePrefixMapping - Dictionary whose keys are the unique # prefixes and whose values are not examined. # prefixString - Current prefix being processed. # # Results: -# Returns a constructed regular expression that matches the set of -# unique prefixes beginning with the 'prefixString'. +# Returns a constructed regular expression that matches the set +# of unique prefixes beginning with the 'prefixString'. # # Side effects: # None. # #---------------------------------------------------------------------- @@ -2155,19 +2200,17 @@ set schars [lsort -ascii [dict keys [dict get $successors $prefixString]]] if { [llength $schars] == 0 } { return {} } - # If there is more than one successor character, or if the current prefix - # is a unique prefix, surround the generated re with non-capturing + # If there is more than one successor character, or if the current + # prefix is a unique prefix, surround the generated re with non-capturing # parentheses. set re {} - if { - [dict exists $uniquePrefixMapping $prefixString] - || [llength $schars] > 1 - } then { + if { [dict exists $uniquePrefixMapping $prefixString] + || [llength $schars] > 1 } { append re "(?:" } # Generate a regexp that matches the successors. @@ -2185,11 +2228,11 @@ # optional. Otherwise, if there is more than one successor character, # close the non-capturing parentheses. if { [dict exists $uniquePrefixMapping $prefixString] } { append re ")?" - } elseif { [llength $schars] > 1 } { + } elseif { [llength $schars] > 1 } { append re ")" } return $re } @@ -2196,12 +2239,12 @@ #---------------------------------------------------------------------- # # MakeParseCodeFromFields -- # -# Composes Tcl code to extract the Julian Day Number from a dictionary -# containing date fields. +# Composes Tcl code to extract the Julian Day Number from a +# dictionary containing date fields. # # Parameters: # dateFields -- Dictionary whose keys are fields of the date, # and whose values are the rightmost positions # at which those fields appear. @@ -2208,12 +2251,12 @@ # parseActions -- List of triples: field set, priority, and # code to emit. Smaller priorities are better, and # the list must be in ascending order by priority # # Results: -# Returns a burst of code that extracts the day number from the given -# date. +# Returns a burst of code that extracts the day number from the +# given date. # # Side effects: # None. # #---------------------------------------------------------------------- @@ -2225,19 +2268,20 @@ set currCodeBurst { error "in ::tcl::clock::MakeParseCodeFromFields: can't happen" } foreach { fieldSet prio parseAction } $parseActions { - # If we've found an answer that's better than any that follow, quit - # now. + + # If we've found an answer that's better than any that follow, + # quit now. if { $prio > $currPrio } { break } - # Accumulate the field positions that are used in the current field - # grouping. + # Accumulate the field positions that are used in the current + # field grouping. set fieldPos [list] set ok true foreach field $fieldSet { if { ! [dict exists $dateFields $field] } { @@ -2256,15 +2300,13 @@ set fPos [lsort -integer -decreasing $fieldPos] if { $prio == $currPrio } { foreach currPos $currFieldPos newPos $fPos { - if { - ![string is integer $newPos] - || ![string is integer $currPos] - || $newPos > $currPos - } then { + if { ![string is integer $newPos] + || ![string is integer $currPos] + || $newPos > $currPos } { break } if { $newPos < $currPos } { set ok 0 break @@ -2278,13 +2320,15 @@ # Remember the best possibility for extracting date information set currPrio $prio set currFieldPos $fPos set currCodeBurst $parseAction + } return $currCodeBurst + } #---------------------------------------------------------------------- # # EnterLocale -- @@ -2291,56 +2335,82 @@ # # Switch [mclocale] to a given locale if necessary # # Parameters: # locale -- Desired locale +# oldLocaleVar -- Name of a variable in caller's scope that +# tracks the previous locale name. # # Results: # Returns the locale that was previously current. # # Side effects: -# Does [mclocale]. If necessary, loades the designated locale's files. +# Does [mclocale]. If necessary, uses [mcload] to load the +# designated locale's files, and tracks that it has done so +# in the 'McLoaded' variable. # #---------------------------------------------------------------------- -proc ::tcl::clock::EnterLocale { locale } { +proc ::tcl::clock::EnterLocale { locale oldLocaleVar } { + + upvar 1 $oldLocaleVar oldLocale + + variable MsgDir + variable McLoaded + + set oldLocale [mclocale] if { $locale eq {system} } { + if { $::tcl_platform(platform) ne {windows} } { - # On a non-windows platform, the 'system' locale is the same as - # the 'current' locale + + # On a non-windows platform, the 'system' locale is + # the same as the 'current' locale set locale current } else { - # On a windows platform, the 'system' locale is adapted from the - # 'current' locale by applying the date and time formats from the - # Control Panel. First, load the 'current' locale if it's not yet - # loaded - - mcpackagelocale set [mclocale] - - # Make a new locale string for the system locale, and get the - # Control Panel information - - set locale [mclocale]_windows - if { ! [mcpackagelocale present $locale] } { + + # On a windows platform, the 'system' locale is + # adapted from the 'current' locale by applying the + # date and time formats from the Control Panel. + # First, load the 'current' locale if it's not yet loaded + + if {![dict exists $McLoaded $oldLocale] } { + mcload $MsgDir + dict set McLoaded $oldLocale {} + } + + # Make a new locale string for the system locale, and + # get the Control Panel information + + set locale ${oldLocale}_windows + if { ![dict exists $McLoaded $locale] } { LoadWindowsDateTimeFormats $locale + dict set McLoaded $locale {} } } } if { $locale eq {current}} { - set locale [mclocale] + set locale $oldLocale + unset oldLocale + } elseif { $locale eq $oldLocale } { + unset oldLocale + } else { + mclocale $locale } - # Eventually load the locale - mcpackagelocale set $locale + if { ![dict exists $McLoaded $locale] } { + mcload $MsgDir + dict set McLoaded $locale {} + } + } #---------------------------------------------------------------------- # # LoadWindowsDateTimeFormats -- # -# Load the date/time formats from the Control Panel in Windows and -# convert them so that they're usable by Tcl. +# Load the date/time formats from the Control Panel in Windows +# and convert them so that they're usable by Tcl. # # Parameters: # locale - Name of the locale in whose message catalog # the converted formats are to be stored. # @@ -2348,16 +2418,18 @@ # None. # # Side effects: # Updates the given message catalog with the locale strings. # -# Presumes that on entry, [mclocale] is set to the current locale, so that -# default strings can be obtained if the Registry query fails. +# Presumes that on entry, [mclocale] is set to the current locale, +# so that default strings can be obtained if the Registry query +# fails. # #---------------------------------------------------------------------- proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } { + # Bail out if we can't find the Registry variable NoRegistry if { [info exists NoRegistry] } return @@ -2470,26 +2542,27 @@ # locale -- Current [mclocale] locale, supplied to avoid # an extra call # format -- Format supplied to [clock scan] or [clock format] # # Results: -# Returns the string with locale-dependent composite format groups -# substituted out. +# Returns the string with locale-dependent composite format +# groups substituted out. # # Side effects: # None. # #---------------------------------------------------------------------- proc ::tcl::clock::LocalizeFormat { locale format } { - # message catalog key to cache this format - set key FORMAT_$format + variable McLoaded - if { [::msgcat::mcexists -exactlocale -exactnamespace $key] } { - return [mc $key] + if { [dict exists $McLoaded $locale FORMAT $format] } { + return [dict get $McLoaded $locale FORMAT $format] } + set inFormat $format + # Handle locale-dependent format groups by mapping them out of the format # string. Note that the order of the [string map] operations is # significant because later formats can refer to later ones; for example # %c can refer to %X, which in turn can refer to %T. @@ -2508,11 +2581,11 @@ lappend list %Ex [string map $list [mc LOCALE_DATE_FORMAT]] lappend list %c [string map $list [mc DATE_TIME_FORMAT]] lappend list %Ec [string map $list [mc LOCALE_DATE_TIME_FORMAT]] set format [string map $list $format] - ::msgcat::mcset $locale $key $format + dict set McLoaded $locale FORMAT $inFormat $format return $format } #---------------------------------------------------------------------- # @@ -2530,10 +2603,11 @@ # None. # #---------------------------------------------------------------------- proc ::tcl::clock::FormatNumericTimeZone { z } { + if { $z < 0 } { set z [expr { - $z }] set retval - } else { set retval + @@ -2544,10 +2618,11 @@ set z [expr { $z % 60 }] if { $z != 0 } { append retval [::format %02d $z] } return $retval + } #---------------------------------------------------------------------- # # FormatStarDate -- @@ -2568,10 +2643,11 @@ # "Enterprise ready." Now we're stuck with it. # #---------------------------------------------------------------------- proc ::tcl::clock::FormatStarDate { date } { + variable Roddenberry # Get day of year, zero based set doy [expr { [dict get $date dayOfYear] - 1 }] @@ -2618,10 +2694,11 @@ # "Enterprise ready." Now we're stuck with it. # #---------------------------------------------------------------------- proc ::tcl::clock::ParseStarDate { year fractYear fractDay } { + variable Roddenberry # Build a tentative date from year and fraction. set date [dict create \ @@ -2633,12 +2710,12 @@ # Determine whether the given year is a leap year set lp [IsGregorianLeapYear $date] - # Reconvert the fractional year according to whether the given year is a - # leap year + # Reconvert the fractional year according to whether the given + # year is a leap year if { $lp } { dict set date dayOfYear \ [expr { $fractYear * 366 / 1000 + 1 }] } else { @@ -2647,15 +2724,14 @@ } dict unset date julianDay dict unset date gregorian set date [GetJulianDayFromGregorianEraYearDay $date[set date {}]] - return [expr { - 86400 * [dict get $date julianDay] - - 210866803200 - + ( 86400 / 10 ) * $fractDay - }] + return [expr { 86400 * [dict get $date julianDay] + - 210866803200 + + ( 86400 / 10 ) * $fractDay }] + } #---------------------------------------------------------------------- # # ScanWide -- @@ -2664,12 +2740,12 @@ # # Parameters: # str - String containing a decimal wide integer # # Results: -# Returns the string as a pure wide integer. Throws an error if the -# string is misformatted or out of range. +# Returns the string as a pure wide integer. Throws an error if +# the string is misformatted or out of range. # #---------------------------------------------------------------------- proc ::tcl::clock::ScanWide { str } { set count [::scan $str {%ld %c} result junk] @@ -2686,12 +2762,12 @@ #---------------------------------------------------------------------- # # InterpretTwoDigitYear -- # -# Given a date that contains only the year of the century, determines -# the target value of a two-digit year. +# Given a date that contains only the year of the century, +# determines the target value of a two-digit year. # # Parameters: # date - Dictionary containing fields of the date. # baseTime - Base time relative to which the date is expressed. # twoDigitField - Name of the field that stores the two-digit year. @@ -2704,28 +2780,30 @@ # the given key. # # Side effects: # None. # -# The current rule for interpreting a two-digit year is that the year shall be -# between 1937 and 2037, thus staying within the range of a 32-bit signed -# value for time. This rule may change to a sliding window in future -# versions, so the 'baseTime' parameter (which is currently ignored) is -# provided in the procedure signature. +# The current rule for interpreting a two-digit year is that the year +# shall be between 1937 and 2037, thus staying within the range of a +# 32-bit signed value for time. This rule may change to a sliding +# window in future versions, so the 'baseTime' parameter (which is +# currently ignored) is provided in the procedure signature. # #---------------------------------------------------------------------- proc ::tcl::clock::InterpretTwoDigitYear { date baseTime { twoDigitField yearOfCentury } { fourDigitField year } } { + set yr [dict get $date $twoDigitField] if { $yr <= 37 } { dict set date $fourDigitField [expr { $yr + 2000 }] } else { dict set date $fourDigitField [expr { $yr + 1900 }] } return $date + } #---------------------------------------------------------------------- # # AssignBaseYear -- @@ -2747,10 +2825,11 @@ # None. # #---------------------------------------------------------------------- proc ::tcl::clock::AssignBaseYear { date baseTime timezone changeover } { + variable TZData # Find the Julian Day Number corresponding to the base time, and # find the Gregorian year corresponding to that Julian Day. @@ -2760,10 +2839,11 @@ dict set date era [dict get $date2 era] dict set date year [dict get $date2 year] return $date + } #---------------------------------------------------------------------- # # AssignBaseIso8601Year -- @@ -2786,10 +2866,11 @@ # None. # #---------------------------------------------------------------------- proc ::tcl::clock::AssignBaseIso8601Year {date baseTime timeZone changeover} { + variable TZData # Find the Julian Day Number corresponding to the base time set date2 [GetDateFields $baseTime $TZData($timeZone) $changeover] @@ -2822,19 +2903,21 @@ # None. # #---------------------------------------------------------------------- proc ::tcl::clock::AssignBaseMonth {date baseTime timezone changeover} { + variable TZData # Find the year and month corresponding to the base time set date2 [GetDateFields $baseTime $TZData($timezone) $changeover] dict set date era [dict get $date2 era] dict set date year [dict get $date2 year] dict set date month [dict get $date2 month] return $date + } #---------------------------------------------------------------------- # # AssignBaseWeek -- @@ -2856,10 +2939,11 @@ # None. # #---------------------------------------------------------------------- proc ::tcl::clock::AssignBaseWeek {date baseTime timeZone changeover} { + variable TZData # Find the Julian Day Number corresponding to the base time set date2 [GetDateFields $baseTime $TZData($timeZone) $changeover] @@ -2892,10 +2976,11 @@ # None. # #---------------------------------------------------------------------- proc ::tcl::clock::AssignBaseJulianDay { date baseTime timeZone changeover } { + variable TZData # Find the Julian Day Number corresponding to the base time set date2 [GetDateFields $baseTime $TZData($timeZone) $changeover] @@ -2921,19 +3006,21 @@ # None. # #---------------------------------------------------------------------- proc ::tcl::clock::InterpretHMSP { date } { + set hr [dict get $date hourAMPM] if { $hr == 12 } { set hr 0 } if { [dict get $date amPmIndicator] } { incr hr 12 } dict set date hour $hr return [InterpretHMS $date[set date {}]] + } #---------------------------------------------------------------------- # # InterpretHMS -- @@ -2952,15 +3039,15 @@ # None. # #---------------------------------------------------------------------- proc ::tcl::clock::InterpretHMS { date } { - return [expr { - ( [dict get $date hour] * 60 - + [dict get $date minute] ) * 60 - + [dict get $date second] - }] + + return [expr { ( [dict get $date hour] * 60 + + [dict get $date minute] ) * 60 + + [dict get $date second] }] + } #---------------------------------------------------------------------- # # GetSystemTimeZone -- @@ -2979,10 +3066,11 @@ # variable, since determining it may be an expensive process. # #---------------------------------------------------------------------- proc ::tcl::clock::GetSystemTimeZone {} { + variable CachedSystemTimeZone variable TimeZoneBad if {[set result [getenv TCL_TZ]] ne {}} { set timezone $result @@ -3011,73 +3099,80 @@ if { [dict get $TimeZoneBad $timezone] } { return :localtime } else { return $timezone } + } #---------------------------------------------------------------------- # # ConvertLegacyTimeZone -- # -# Given an alphanumeric time zone identifier and the system time zone, -# convert the alphanumeric identifier to an unambiguous time zone. +# Given an alphanumeric time zone identifier and the system +# time zone, convert the alphanumeric identifier to an +# unambiguous time zone. # # Parameters: # tzname - Name of the time zone to convert # # Results: -# Returns a time zone name corresponding to tzname, but in an -# unambiguous form, generally +hhmm. +# Returns a time zone name corresponding to tzname, but +# in an unambiguous form, generally +hhmm. # -# This procedure is implemented primarily to allow the parsing of RFC822 -# date/time strings. Processing a time zone name on input is not recommended -# practice, because there is considerable room for ambiguity; for instance, is -# BST Brazilian Standard Time, or British Summer Time? +# This procedure is implemented primarily to allow the parsing of +# RFC822 date/time strings. Processing a time zone name on input +# is not recommended practice, because there is considerable room +# for ambiguity; for instance, is BST Brazilian Standard Time, or +# British Summer Time? # #---------------------------------------------------------------------- proc ::tcl::clock::ConvertLegacyTimeZone { tzname } { + variable LegacyTimeZone set tzname [string tolower $tzname] if { ![dict exists $LegacyTimeZone $tzname] } { return -code error -errorcode [list CLOCK badTZName $tzname] \ "time zone \"$tzname\" not found" + } else { + return [dict get $LegacyTimeZone $tzname] } - return [dict get $LegacyTimeZone $tzname] + } #---------------------------------------------------------------------- # # SetupTimeZone -- # -# Given the name or specification of a time zone, sets up its in-memory -# data. +# Given the name or specification of a time zone, sets up +# its in-memory data. # # Parameters: # tzname - Name of a time zone # # Results: -# Unless the time zone is ':localtime', sets the TZData array to contain -# the lookup table for local<->UTC conversion. Returns an error if the -# time zone cannot be parsed. +# Unless the time zone is ':localtime', sets the TZData array +# to contain the lookup table for local<->UTC conversion. +# Returns an error if the time zone cannot be parsed. # #---------------------------------------------------------------------- proc ::tcl::clock::SetupTimeZone { timezone } { + variable TZData if {! [info exists TZData($timezone)] } { variable MINWIDE if { $timezone eq {:localtime} } { + # Nothing to do, we'll convert using the localtime function - } elseif { - [regexp {^([-+])(\d\d)(?::?(\d\d)(?::?(\d\d))?)?} $timezone \ - -> s hh mm ss] - } then { + } elseif { [regexp {^([-+])(\d\d)(?::?(\d\d)(?::?(\d\d))?)?} $timezone \ + -> s hh mm ss] } { + # Make a fixed offset ::scan $hh %d hh if { $mm eq {} } { set mm 0 @@ -3094,24 +3189,28 @@ set offset [expr { - $offset }] } set TZData($timezone) [list [list $MINWIDE $offset -1 $timezone]] } elseif { [string index $timezone 0] eq {:} } { + # Convert using a time zone file if { [catch { LoadTimeZoneFile [string range $timezone 1 end] - }] && [catch { + }] + && [catch { LoadZoneinfoFile [string range $timezone 1 end] }] - } then { + } { return -code error \ -errorcode [list CLOCK badTimeZone $timezone] \ "time zone \"$timezone\" not found" } + } elseif { ![catch {ParsePosixTimeZone $timezone} tzfields] } { + # This looks like a POSIX time zone - try to process it if { [catch {ProcessPosixTimeZone $tzfields} data opts] } { if { [lindex [dict get $opts -errorcode] 0] eq {CLOCK} } { dict unset opts -errorinfo @@ -3120,12 +3219,13 @@ } else { set TZData($timezone) $data } } else { - # We couldn't parse this as a POSIX time zone. Try again with a - # time zone file - this time without a colon + + # We couldn't parse this as a POSIX time zone. Try + # again with a time zone file - this time without a colon if { [catch { LoadTimeZoneFile $timezone }] && [catch { LoadZoneinfoFile $timezone } - opts] } { dict unset opts -errorinfo return -options $opts "time zone $timezone not found" @@ -3145,26 +3245,29 @@ # # Parameters: # None. # # Results: -# Returns a time zone specifier that corresponds to the system time zone -# information found in the Registry. +# Returns a time zone specifier that corresponds to the system +# time zone information found in the Registry. # # Bugs: -# Fixed dates for DST change are unimplemented at present, because no -# time zone information supplied with Windows actually uses them! -# -# On a Windows system where neither $env(TCL_TZ) nor $env(TZ) is specified, -# GuessWindowsTimeZone looks in the Registry for the system time zone -# information. It then attempts to find an entry in WinZoneInfo for a time -# zone that uses the same rules. If it finds one, it returns it; otherwise, -# it constructs a Posix-style time zone string and returns that. +# Fixed dates for DST change are unimplemented at present, because +# no time zone information supplied with Windows actually uses +# them! +# +# On a Windows system where neither $env(TCL_TZ) nor $env(TZ) is +# specified, GuessWindowsTimeZone looks in the Registry for the +# system time zone information. It then attempts to find an entry +# in WinZoneInfo for a time zone that uses the same rules. If +# it finds one, it returns it; otherwise, it constructs a Posix-style +# time zone string and returns that. # #---------------------------------------------------------------------- proc ::tcl::clock::GuessWindowsTimeZone {} { + variable WinZoneInfo variable NoRegistry variable TimeZoneBad if { [info exists NoRegistry] } { @@ -3191,18 +3294,20 @@ foreach ind {0 2 14 4 6 8 10 12} { binary scan $daytzi @${ind}s val lappend data $val } }] } { + # Missing values in the Registry - bail out return :localtime } - # Make up a Posix time zone specifier if we can't find one. Check here - # that the tzdata file exists, in case we're running in an environment - # (e.g. starpack) where tzdata is incomplete. (Bug 1237907) + # Make up a Posix time zone specifier if we can't find one. + # Check here that the tzdata file exists, in case we're running + # in an environment (e.g. starpack) where tzdata is incomplete. + # (Bug 1237907) if { [dict exists $WinZoneInfo $data] } { set tzname [dict get $WinZoneInfo $data] if { ! [dict exists $TimeZoneBad $tzname] } { dict set TimeZoneBad $tzname [catch {SetupTimeZone $tzname}] @@ -3246,28 +3351,28 @@ set ss [::format %02d [expr { $dstDelta % 60 }]] append tzname < $dispDstSignum $hh $mm > $dstSignum $hh : $mm : $ss if { $dstYear == 0 } { append tzname ,M $dstMonth . $dstDayOfMonth . $dstDayOfWeek } else { - # I have not been able to find any locale on which Windows - # converts time zone on a fixed day of the year, hence don't - # know how to interpret the fields. If someone can inform me, - # I'd be glad to code it up. For right now, we bail out in - # such a case. + # I have not been able to find any locale on which + # Windows converts time zone on a fixed day of the year, + # hence don't know how to interpret the fields. + # If someone can inform me, I'd be glad to code it up. + # For right now, we bail out in such a case. return :localtime } append tzname / [::format %02d $dstHour] \ : [::format %02d $dstMinute] \ : [::format %02d $dstSecond] if { $stdYear == 0 } { append tzname ,M $stdMonth . $stdDayOfMonth . $stdDayOfWeek } else { - # I have not been able to find any locale on which Windows - # converts time zone on a fixed day of the year, hence don't - # know how to interpret the fields. If someone can inform me, - # I'd be glad to code it up. For right now, we bail out in - # such a case. + # I have not been able to find any locale on which + # Windows converts time zone on a fixed day of the year, + # hence don't know how to interpret the fields. + # If someone can inform me, I'd be glad to code it up. + # For right now, we bail out in such a case. return :localtime } append tzname / [::format %02d $stdHour] \ : [::format %02d $stdMinute] \ : [::format %02d $stdSecond] @@ -3274,10 +3379,11 @@ } dict set WinZoneInfo $data $tzname } return [dict get $WinZoneInfo $data] + } #---------------------------------------------------------------------- # # LoadTimeZoneFile -- @@ -3302,22 +3408,22 @@ if { [info exists TZData($fileName)] } { return } - # Since an unsafe interp uses the [clock] command in the parent, this code - # is security sensitive. Make sure that the path name cannot escape the - # given directory. + # Since an unsafe interp uses the [clock] command in the master, + # this code is security sensitive. Make sure that the path name + # cannot escape the given directory. if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } { return -code error \ -errorcode [list CLOCK badTimeZone $:fileName] \ "time zone \":$fileName\" not valid" } - try { - source [file join $DataDir $fileName] - } on error {} { + if { [catch { + source -encoding utf-8 [file join $DataDir $fileName] + }] } { return -code error \ -errorcode [list CLOCK badTimeZone :$fileName] \ "time zone \":$fileName\" not found" } return @@ -3331,24 +3437,25 @@ # # Parameters: # fileName - Relative path name of the file to load. # # Results: -# Returns an empty result normally; returns an error if no Olson file -# was found or the file was malformed in some way. +# Returns an empty result normally; returns an error if no +# Olson file was found or the file was malformed in some way. # # Side effects: # TZData(:fileName) contains the time zone data # #---------------------------------------------------------------------- proc ::tcl::clock::LoadZoneinfoFile { fileName } { + variable ZoneinfoPaths - # Since an unsafe interp uses the [clock] command in the parent, this code - # is security sensitive. Make sure that the path name cannot escape the - # given directory. + # Since an unsafe interp uses the [clock] command in the master, + # this code is security sensitive. Make sure that the path name + # cannot escape the given directory. if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } { return -code error \ -errorcode [list CLOCK badTimeZone $:fileName] \ "time zone \":$fileName\" not valid" @@ -3373,17 +3480,18 @@ # fileName - Name of the time zone (relative path name of the # file). # fname - Absolute path name of the file. # # Results: -# Returns an empty result normally; returns an error if no Olson file -# was found or the file was malformed in some way. +# Returns an empty result normally; returns an error if no +# Olson file was found or the file was malformed in some way. # # Side effects: # TZData(:fileName) contains the time zone data # #---------------------------------------------------------------------- + proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { variable MINWIDE variable TZData if { ![file exists $fname] } { @@ -3399,12 +3507,12 @@ set f [open $fname r] fconfigure $f -translation binary set d [read $f] close $f - # The file begins with a magic number, sixteen reserved bytes, and then - # six 4-byte integers giving counts of fileds in the file. + # The file begins with a magic number, sixteen reserved bytes, + # and then six 4-byte integers giving counts of fileds in the file. binary scan $d a4a1x15IIIIII \ magic version nIsGMT nIsStd nLeap nTime nType nChar set seek 44 set ilen 4 @@ -3418,23 +3526,22 @@ # Accept only Posix-style zoneinfo. Sorry, 'leaps' bigots. if { $nLeap != 0 } { return -code error "$fileName contains leap seconds" } - # In a version 2 file, we use the second part of the file, which contains - # 64-bit transition times. + # In a version 2 file, we use the second part of the file, which + # contains 64-bit transition times. if {$version eq "2"} { - set seek [expr { - 44 - + 5 * $nTime - + 6 * $nType - + 4 * $nLeap - + $nIsStd - + $nIsGMT - + $nChar - }] + set seek [expr {44 + + 5 * $nTime + + 6 * $nType + + 4 * $nLeap + + $nIsStd + + $nIsGMT + + $nChar + }] binary scan $d @${seek}a4a1x15IIIIII \ magic version nIsGMT nIsStd nLeap nTime nType nChar if {$magic ne {TZif}} { return -code error "seek address $seek miscomputed, magic = $magic" } @@ -3454,24 +3561,24 @@ 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. + # 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. for { set i 0 } { $i < $nType } { incr i } { binary scan $d @${seek}Icc gmtOff isDst abbrInd lappend types [list $gmtOff $isDst $abbrInd] incr seek 6 } - # Next come $nChar characters of time zone name abbreviations, which are - # null-terminated. - # We build them up into a dictionary indexed by character index, because - # that's what's in the indices above. + # Next come $nChar characters of time zone name abbreviations, + # which are null-terminated. + # We build them up into a dictionary indexed by character index, + # because that's what's in the indices above. binary scan $d @${seek}a${nChar} abbrs incr seek ${nChar} set abbrList [split $abbrs \0] set i 0 @@ -3497,12 +3604,12 @@ set abbrev [dict get $abbrevs $abbrInd] lappend r [list $t $gmtoff $isDst $abbrev] } # In a version 2 file, there is also a POSIX-style time zone description - # at the very end of the file. To get to it, skip over nLeap leap second - # values (8 bytes each), + # at the very end of the file. To get to it, skip over + # nLeap leap second values (8 bytes each), # nIsStd standard/DST indicators and nIsGMT UTC/local indicators. if {$version eq {2}} { set seek [expr {$seek + 8 * $nLeap + $nIsStd + $nIsGMT + 1}] set last [string first \n $d $seek] @@ -3531,12 +3638,12 @@ # # Parameters: # tz Time zone specifier to be interpreted # # Results: -# Returns a dictionary whose values contain the various pieces of the -# time zone specification. +# Returns a dictionary whose values contain the various pieces of +# the time zone specification. # # Side effects: # None. # # Errors: @@ -3589,16 +3696,17 @@ # endDayOfYear, endJ, endMonth, endWeekOfMonth, endDayOfWeek, # endHours, endMinutes, endSeconds - # Specify the end of DST in the same way that the start* fields # specify the beginning of DST. # -# This procedure serves only to break the time specifier into fields. No -# attempt is made to canonicalize the fields or supply default values. +# This procedure serves only to break the time specifier into fields. +# No attempt is made to canonicalize the fields or supply default values. # #---------------------------------------------------------------------- proc ::tcl::clock::ParsePosixTimeZone { tz } { + if {[regexp -expanded -nocase -- { ^ # 1 - Standard time zone name ([[:alpha:]]+ | <[-+[:alnum:]]+>) # 2 - Standard time zone offset, signum @@ -3686,25 +3794,31 @@ x(startMonth) x(startWeekOfMonth) x(startDayOfWeek) \ x(startHours) x(startMinutes) x(startSeconds) \ x(endJ) x(endDayOfYear) \ x(endMonth) x(endWeekOfMonth) x(endDayOfWeek) \ x(endHours) x(endMinutes) x(endSeconds)] } { + # it's a good timezone return [array get x] + + } else { + + return -code error\ + -errorcode [list CLOCK badTimeZone $tz] \ + "unable to parse time zone specification \"$tz\"" + } - return -code error\ - -errorcode [list CLOCK badTimeZone $tz] \ - "unable to parse time zone specification \"$tz\"" } #---------------------------------------------------------------------- # # ProcessPosixTimeZone -- # -# Handle a Posix time zone after it's been broken out into fields. +# Handle a Posix time zone after it's been broken out into +# fields. # # Parameters: # z - Dictionary returned from 'ParsePosixTimeZone' # # Results: @@ -3714,10 +3828,11 @@ # None. # #---------------------------------------------------------------------- proc ::tcl::clock::ProcessPosixTimeZone { z } { + variable MINWIDE variable TZData # Determine the standard time zone name and seconds east of Greenwich @@ -3739,13 +3854,13 @@ if { [dict get $z stdSeconds] ne {} } { set stdSeconds [lindex [::scan [dict get $z stdSeconds] %d] 0] } else { set stdSeconds 0 } - set stdOffset [expr { - (($stdHours * 60 + $stdMinutes) * 60 + $stdSeconds) * $stdSignum - }] + set stdOffset [expr { ( ( $stdHours * 60 + $stdMinutes ) + * 60 + $stdSeconds ) + * $stdSignum }] set data [list [list $MINWIDE $stdOffset 0 $stdName]] # If there's no daylight zone, we're done set dstName [dict get $z dstName] @@ -3775,25 +3890,23 @@ if { [dict get $z dstSeconds] ne {} } { set dstSeconds [lindex [::scan [dict get $z dstSeconds] %d] 0] } else { set dstSeconds 0 } - set dstOffset [expr { - (($dstHours*60 + $dstMinutes) * 60 + $dstSeconds) * $dstSignum - }] + set dstOffset [expr { ( ( $dstHours * 60 + $dstMinutes ) + * 60 + $dstSeconds ) + * $dstSignum }] } # Fill in defaults for European or US DST rules # US start time is the second Sunday in March # EU start time is the last Sunday in March # US end time is the first Sunday in November. # EU end time is the last Sunday in October - if { - [dict get $z startDayOfYear] eq {} - && [dict get $z startMonth] eq {} - } then { + if { [dict get $z startDayOfYear] eq {} + && [dict get $z startMonth] eq {} } { if {($stdSignum * $stdHours>=0) && ($stdSignum * $stdHours<=12)} { # EU dict set z startWeekOfMonth 5 if {$stdHours>2} { dict set z startHours 2 @@ -3808,14 +3921,12 @@ dict set z startMonth 3 dict set z startDayOfWeek 0 dict set z startMinutes 0 dict set z startSeconds 0 } - if { - [dict get $z endDayOfYear] eq {} - && [dict get $z endMonth] eq {} - } then { + if { [dict get $z endDayOfYear] eq {} + && [dict get $z endMonth] eq {} } { if {($stdSignum * $stdHours>=0) && ($stdSignum * $stdHours<=12)} { # EU dict set z endMonth 10 dict set z endWeekOfMonth 5 if {$stdHours>2} { @@ -3851,29 +3962,30 @@ [list $startTime $dstOffset 1 $dstName] } } return $data + } #---------------------------------------------------------------------- # # DeterminePosixDSTTime -- # -# Determines the time that Daylight Saving Time starts or ends from a -# Posix time zone specification. +# Determines the time that Daylight Saving Time starts or ends +# from a Posix time zone specification. # # Parameters: # z - Time zone data returned from ParsePosixTimeZone. # Missing fields are expected to be filled in with # default values. # bound - The word 'start' or 'end' # y - The year for which the transition time is to be determined. # # Results: -# Returns the transition time as a count of seconds from the epoch. The -# time is relative to the wall clock, not UTC. +# Returns the transition time as a count of seconds from +# the epoch. The time is relative to the wall clock, not UTC. # #---------------------------------------------------------------------- proc ::tcl::clock::DeterminePosixDSTTime { z bound y } { @@ -3893,10 +4005,11 @@ incr doy } dict set date dayOfYear $doy set date [GetJulianDayFromEraYearDay $date[set date {}] 2361222] } else { + # Time was specified as a day of the week within a month dict set date month [dict get $z ${bound}Month] dict set date dayOfWeek [dict get $z ${bound}DayOfWeek] set dowim [dict get $z ${bound}WeekOfMonth] @@ -3907,13 +4020,12 @@ set date [GetJulianDayFromEraYearMonthWeekDay $date[set date {}] 2361222] } set jd [dict get $date julianDay] - set seconds [expr { - wide($jd) * wide(86400) - wide(210866803200) - }] + set seconds [expr { wide($jd) * wide(86400) + - wide(210866803200) }] set h [dict get $z ${bound}Hours] if { $h eq {} } { set h 2 } else { @@ -3931,10 +4043,11 @@ } else { set s [lindex [::scan $s %d] 0] } set tod [expr { ( $h * 60 + $m ) * 60 + $s }] return [expr { $seconds + $tod }] + } #---------------------------------------------------------------------- # # GetLocaleEra -- @@ -3948,30 +4061,30 @@ # and 'year', whose value is the Gregorian year. # etable - Value of the LOCALE_ERAS key in the message catalogue # for the target locale. # # Results: -# Returns the dictionary, augmented with the keys, 'localeEra' and -# 'localeYear'. +# Returns the dictionary, augmented with the keys, 'localeEra' +# and 'localeYear'. # #---------------------------------------------------------------------- proc ::tcl::clock::GetLocaleEra { date etable } { + set index [BSearch $etable [dict get $date localSeconds]] if { $index < 0} { dict set date localeEra \ [::format %02d [expr { [dict get $date year] / 100 }]] - dict set date localeYear [expr { - [dict get $date year] % 100 - }] + dict set date localeYear \ + [expr { [dict get $date year] % 100 }] } else { dict set date localeEra [lindex $etable $index 1] - dict set date localeYear [expr { - [dict get $date year] - [lindex $etable $index 2] - }] + dict set date localeYear [expr { [dict get $date year] + - [lindex $etable $index 2] }] } return $date + } #---------------------------------------------------------------------- # # GetJulianDayFromEraYearDay -- @@ -3985,13 +4098,14 @@ # is determined by the date itself relative to: # changeover -- Julian day on which the Gregorian calendar was # adopted in the current locale. # # Results: -# Returns the given dictionary augmented with a 'julianDay' key whose -# value is the desired Julian Day Number, and a 'gregorian' key that -# specifies whether the calendar is Gregorian (1) or Julian (0). +# Returns the given dictionary augmented with a 'julianDay' key +# whose value is the desired Julian Day Number, and a 'gregorian' +# key that specifies whether the calendar is Gregorian (1) or +# Julian (0). # # Side effects: # None. # # Bugs: @@ -3998,10 +4112,11 @@ # This code needs to be moved to the C layer. # #---------------------------------------------------------------------- proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} { + # Get absolute year number from the civil year switch -exact -- [dict get $date era] { BCE { set year [expr { 1 - [dict get $date year] }] @@ -4013,29 +4128,25 @@ set ym1 [expr { $year - 1 }] # Try the Gregorian calendar first. dict set date gregorian 1 - set jd [expr { - 1721425 - + [dict get $date dayOfYear] - + ( 365 * $ym1 ) - + ( $ym1 / 4 ) - - ( $ym1 / 100 ) - + ( $ym1 / 400 ) - }] + set jd [expr { 1721425 + + [dict get $date dayOfYear] + + ( 365 * $ym1 ) + + ( $ym1 / 4 ) + - ( $ym1 / 100 ) + + ( $ym1 / 400 ) }] # If the date is before the Gregorian change, use the Julian calendar. if { $jd < $changeover } { dict set date gregorian 0 - set jd [expr { - 1721423 - + [dict get $date dayOfYear] - + ( 365 * $ym1 ) - + ( $ym1 / 4 ) - }] + set jd [expr { 1721423 + + [dict get $date dayOfYear] + + ( 365 * $ym1 ) + + ( $ym1 / 4 ) }] } dict set date julianDay $jd return $date } @@ -4042,12 +4153,12 @@ #---------------------------------------------------------------------- # # GetJulianDayFromEraYearMonthWeekDay -- # -# Determines the Julian Day number corresponding to the nth given -# day-of-the-week in a given month. +# Determines the Julian Day number corresponding to the nth +# given day-of-the-week in a given month. # # Parameters: # date - Dictionary containing the keys, 'era', 'year', 'month' # 'weekOfMonth', 'dayOfWeek', and 'dayOfWeekInMonth'. # changeover - Julian Day of adoption of the Gregorian calendar @@ -4062,13 +4173,14 @@ # This code needs to be moved to the C layer. # #---------------------------------------------------------------------- proc ::tcl::clock::GetJulianDayFromEraYearMonthWeekDay {date changeover} { - # Come up with a reference day; either the zeroeth day of the given month - # (dayOfWeekInMonth >= 0) or the seventh day of the following month - # (dayOfWeekInMonth < 0) + + # Come up with a reference day; either the zeroeth day of the + # given month (dayOfWeekInMonth >= 0) or the seventh day of the + # following month (dayOfWeekInMonth < 0) set date2 $date set week [dict get $date dayOfWeekInMonth] if { $week >= 0 } { dict set date2 dayOfMonth 0 @@ -4080,10 +4192,11 @@ $changeover] set wd0 [WeekdayOnOrBefore [dict get $date dayOfWeek] \ [dict get $date2 julianDay]] dict set date julianDay [expr { $wd0 + 7 * $week }] return $date + } #---------------------------------------------------------------------- # # IsGregorianLeapYear -- @@ -4102,10 +4215,11 @@ # None. # #---------------------------------------------------------------------- proc ::tcl::clock::IsGregorianLeapYear { date } { + switch -exact -- [dict get $date era] { BCE { set year [expr { 1 - [dict get $date year]}] } CE { @@ -4121,18 +4235,19 @@ } elseif { $year % 100 == 0 } { return 0 } else { return 1 } + } #---------------------------------------------------------------------- # # WeekdayOnOrBefore -- # -# Determine the nearest day of week (given by the 'weekday' parameter, -# Sunday==0) on or before a given Julian Day. +# Determine the nearest day of week (given by the 'weekday' +# parameter, Sunday==0) on or before a given Julian Day. # # Parameters: # weekday -- Day of the week # j -- Julian Day number # @@ -4143,36 +4258,39 @@ # None. # #---------------------------------------------------------------------- proc ::tcl::clock::WeekdayOnOrBefore { weekday j } { + set k [expr { ( $weekday + 6 ) % 7 }] return [expr { $j - ( $j - $k ) % 7 }] + } #---------------------------------------------------------------------- # # BSearch -- # -# Service procedure that does binary search in several places inside the -# 'clock' command. +# Service procedure that does binary search in several places +# inside the 'clock' command. # # Parameters: # list - List of lists, sorted in ascending order by the # first elements # key - Value to search for # # Results: -# Returns the index of the greatest element in $list that is less than -# or equal to $key. +# Returns the index of the greatest element in $list that is less +# than or equal to $key. # # Side effects: # None. # #---------------------------------------------------------------------- proc ::tcl::clock::BSearch { list key } { + if {[llength $list] == 0} { return -1 } if { $key < [lindex $list 0 0] } { return -1 @@ -4180,16 +4298,17 @@ set l 0 set u [expr { [llength $list] - 1 }] while { $l < $u } { + # At this point, we know that # $k >= [lindex $list $l 0] # Either $u == [llength $list] or else $k < [lindex $list $u+1 0] # We find the midpoint of the interval {l,u} rounded UP, compare - # against it, and set l or u to maintain the invariant. Note that the - # interval shrinks at each step, guaranteeing convergence. + # against it, and set l or u to maintain the invariant. Note + # that the interval shrinks at each step, guaranteeing convergence. set m [expr { ( $l + $u + 1 ) / 2 }] if { $key >= [lindex $list $m 0] } { set l $m } else { @@ -4229,18 +4348,19 @@ # Results: # Returns the given time adjusted by the given offset(s) in # order. # # Notes: -# It is possible that adding a number of months or years will adjust the -# day of the month as well. For instance, the time at one month after -# 31 January is either 28 or 29 February, because February has fewer -# than 31 days. +# It is possible that adding a number of months or years will adjust +# the day of the month as well. For instance, the time at +# one month after 31 January is either 28 or 29 February, because +# February has fewer than 31 days. # #---------------------------------------------------------------------- proc ::tcl::clock::add { clockval args } { + if { [llength $args] % 2 != 0 } { set cmdName "clock add" return -code error \ -errorcode [list CLOCK wrongNumArgs] \ "wrong \# args: should be\ @@ -4255,14 +4375,19 @@ set gmt 0 set locale c set timezone [GetSystemTimeZone] foreach { a b } $args { + if { [string is integer -strict $a] } { + lappend offsets $a $b + } else { + switch -exact -- $a { + -g - -gm - -gmt { set gmt $b } -l - -lo - -loc - -loca - -local - -locale { set locale [string tolower $b] @@ -4270,12 +4395,13 @@ -t - -ti - -tim - -time - -timez - -timezo - -timezon - -timezone { set timezone $b } default { - throw [list CLOCK badOption $a] \ - "bad option \"$a\",\ + return -code error \ + -errorcode [list CLOCK badSwitch $a] \ + "bad switch \"$a\",\ must be -gmt, -locale or -timezone" } } } } @@ -4286,46 +4412,54 @@ return -code error \ -errorcode [list CLOCK gmtWithTimezone] \ "cannot use -gmt and -timezone in same call" } if { [catch { expr { wide($clockval) } } result] } { - return -code error "expected integer but got \"$clockval\"" + return -code error \ + "expected integer but got \"$clockval\"" } - if { ![string is boolean -strict $gmt] } { - return -code error "expected boolean value but got \"$gmt\"" - } elseif { $gmt } { - set timezone :GMT + if { ![string is boolean $gmt] } { + return -code error \ + "expected boolean value but got \"$gmt\"" + } else { + if { $gmt } { + set timezone :GMT + } } - EnterLocale $locale + EnterLocale $locale oldLocale set changeover [mc GREGORIAN_CHANGE_DATE] if {[catch {SetupTimeZone $timezone} retval opts]} { dict unset opts -errorinfo return -options $opts $retval } - try { + set status [catch { + foreach { quantity unit } $offsets { + switch -exact -- $unit { + years - year { - set clockval [AddMonths [expr { 12 * $quantity }] \ - $clockval $timezone $changeover] + set clockval \ + [AddMonths [expr { 12 * $quantity }] \ + $clockval $timezone $changeover] } months - month { set clockval [AddMonths $quantity $clockval $timezone \ - $changeover] + $changeover] } weeks - week { set clockval [AddDays [expr { 7 * $quantity }] \ - $clockval $timezone $changeover] + $clockval $timezone $changeover] } days - day { set clockval [AddDays $quantity $clockval $timezone \ - $changeover] + $changeover] } hours - hour { set clockval [expr { 3600 * $quantity + $clockval }] } @@ -4335,22 +4469,35 @@ seconds - second { set clockval [expr { $quantity + $clockval }] } default { - throw [list CLOCK badUnit $unit] \ - "unknown unit \"$unit\", must be \ - years, months, weeks, days, hours, minutes or seconds" + error "unknown unit \"$unit\", must be \ + years, months, weeks, days, hours, minutes or seconds" \ + "unknown unit \"$unit\", must be \ + years, months, weeks, days, hours, minutes or seconds" \ + [list CLOCK badUnit $unit] } } } - return $clockval - } trap CLOCK {result opts} { - # Conceal the innards of [clock] when it's an expected error - dict unset opts -errorinfo + } result opts] + + # Restore the locale + + if { [info exists oldLocale] } { + mclocale $oldLocale + } + + if { $status == 1 } { + if { [lindex [dict get $opts -errorcode] 0] eq {CLOCK} } { + dict unset opts -errorinfo + } return -options $opts $result + } else { + return $clockval } + } #---------------------------------------------------------------------- # # AddMonths -- @@ -4371,20 +4518,20 @@ # None. # #---------------------------------------------------------------------- proc ::tcl::clock::AddMonths { months clockval timezone changeover } { + variable DaysInRomanMonthInCommonYear variable DaysInRomanMonthInLeapYear variable TZData # Convert the time to year, month, day, and fraction of day. set date [GetDateFields $clockval $TZData($timezone) $changeover] - dict set date secondOfDay [expr { - [dict get $date localSeconds] % 86400 - }] + dict set date secondOfDay [expr { [dict get $date localSeconds] + % 86400 }] dict set date tzName $timezone # Add the requisite number of months set m [dict get $date month] @@ -4409,15 +4556,14 @@ # Reconvert to a number of seconds set date [GetJulianDayFromEraYearMonthDay \ $date[set date {}]\ $changeover] - dict set date localSeconds [expr { - -210866803200 - + ( 86400 * wide([dict get $date julianDay]) ) - + [dict get $date secondOfDay] - }] + dict set date localSeconds \ + [expr { -210866803200 + + ( 86400 * wide([dict get $date julianDay]) ) + + [dict get $date secondOfDay] }] set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) \ $changeover] return [dict get $date seconds] @@ -4425,90 +4571,88 @@ #---------------------------------------------------------------------- # # AddDays -- # -# Add a given number of days to a given clock value in a given time -# zone. +# Add a given number of days to a given clock value in a given +# time zone. # # Parameters: # days - Number of days to add (may be negative) # clockval - Seconds since the epoch before the operation # timezone - Time zone in which the operation is to be performed # changeover - Julian Day on which the Gregorian calendar was adopted # in the target locale. # # Results: -# Returns the new clock value as a number of seconds since the epoch. +# Returns the new clock value as a number of seconds since +# the epoch. # # Side effects: # None. # #---------------------------------------------------------------------- proc ::tcl::clock::AddDays { days clockval timezone changeover } { + variable TZData # Convert the time to Julian Day set date [GetDateFields $clockval $TZData($timezone) $changeover] - dict set date secondOfDay [expr { - [dict get $date localSeconds] % 86400 - }] + dict set date secondOfDay [expr { [dict get $date localSeconds] + % 86400 }] dict set date tzName $timezone # Add the requisite number of days dict incr date julianDay $days # Reconvert to a number of seconds - dict set date localSeconds [expr { - -210866803200 - + ( 86400 * wide([dict get $date julianDay]) ) - + [dict get $date secondOfDay] - }] + dict set date localSeconds \ + [expr { -210866803200 + + ( 86400 * wide([dict get $date julianDay]) ) + + [dict get $date secondOfDay] }] set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) \ $changeover] return [dict get $date seconds] } #---------------------------------------------------------------------- # -# ChangeCurrentLocale -- +# mc -- # -# The global locale was changed within msgcat. -# Clears the buffered parse functions of the current locale. +# Wrapper around ::msgcat::mc that caches the result according +# to the locale. # # Parameters: -# loclist (ignored) +# Accepts the name of the message to retrieve. # # Results: -# None. +# Returns the message text. # # Side effects: -# Buffered parse functions are cleared. +# Caches the message text. +# +# Notes: +# Only the single-argument version of [mc] is supported. # #---------------------------------------------------------------------- -proc ::tcl::clock::ChangeCurrentLocale {args} { - variable FormatProc - variable LocaleNumeralCache - variable CachedSystemTimeZone - variable TimeZoneBad - - foreach p [info procs [namespace current]::scanproc'*'current] { - rename $p {} - } - foreach p [info procs [namespace current]::formatproc'*'current] { - rename $p {} - } - - catch {array unset FormatProc *'current} - set LocaleNumeralCache {} +proc ::tcl::clock::mc { name } { + variable McLoaded + set Locale [mclocale] + if { [dict exists $McLoaded $Locale $name] } { + return [dict get $McLoaded $Locale $name] + } else { + set val [::msgcat::mc $name] + dict set McLoaded $Locale $name $val + return $val + } } #---------------------------------------------------------------------- # # ClearCaches -- @@ -4525,12 +4669,14 @@ # Caches are cleared. # #---------------------------------------------------------------------- proc ::tcl::clock::ClearCaches {} { + variable FormatProc variable LocaleNumeralCache + variable McLoaded variable CachedSystemTimeZone variable TimeZoneBad foreach p [info procs [namespace current]::scanproc'*] { rename $p {} @@ -4539,9 +4685,11 @@ rename $p {} } catch {unset FormatProc} set LocaleNumeralCache {} + set McLoaded {} catch {unset CachedSystemTimeZone} set TimeZoneBad {} InitTZData + } DELETED library/cookiejar/cookiejar.tcl Index: library/cookiejar/cookiejar.tcl ================================================================== --- library/cookiejar/cookiejar.tcl +++ /dev/null @@ -1,746 +0,0 @@ -# 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: DELETED library/cookiejar/effective_tld_names.txt.gz Index: library/cookiejar/effective_tld_names.txt.gz ================================================================== --- library/cookiejar/effective_tld_names.txt.gz +++ /dev/null cannot compute difference between binary files DELETED library/cookiejar/idna.tcl Index: library/cookiejar/idna.tcl ================================================================== --- library/cookiejar/idna.tcl +++ /dev/null @@ -1,292 +0,0 @@ -# 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 state to - # , 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: DELETED library/cookiejar/pkgIndex.tcl Index: library/cookiejar/pkgIndex.tcl ================================================================== --- library/cookiejar/pkgIndex.tcl +++ /dev/null @@ -1,3 +0,0 @@ -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]] Index: library/dde/pkgIndex.tcl ================================================================== --- library/dde/pkgIndex.tcl +++ library/dde/pkgIndex.tcl @@ -1,3 +1,7 @@ -if {![package vsatisfies [package provide Tcl] 8.5-]} return +if {![package vsatisfies [package provide Tcl] 8.5]} return if {[info sharedlibextension] != ".dll"} return -package ifneeded dde 1.4.3 [list load [file join $dir tcldde14.dll] dde] +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] +} ADDED library/encoding/cns11643.enc Index: library/encoding/cns11643.enc ================================================================== --- /dev/null +++ library/encoding/cns11643.enc @@ -0,0 +1,1584 @@ +# Encoding file: cns11643, double-byte +D +2134 0 93 +21 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00004E284E364E3F4E854E054E04518251965338536953B64E2A4E874E4951E2 +4E464E8F4EBC4EBE516651E35204529C53B95902590A5B805DDB5E7A5E7F5EF4 +5F505F515F61961D4E3C4E634E624EA351854EC54ECF4ECE4ECC518451865722 +572351E45205529E529D52FD5300533A5C735346535D538653B7620953CC6C15 +53CE57216C3F5E005F0C623762386534653565E04F0E738D4E974EE04F144EF1 +4EE74EF74EE64F1D4F024F054F2256D8518B518C519951E55213520B52A60000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +22 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +000053225304530353075407531E535F536D538953BA53D0598053F653F753F9 +597E53F4597F5B565724590459185932593059345DDF59755E845B825BF95C14 +5FD55FD45FCF625C625E626462615E815E835F0D5F52625A5FCA5FC7623965EE +624F65E7672F6B7A6C39673F673C6C376C446C45738C75927676909390926C4B +6C4C4E214E204E224E684E894E984EF94EEF7F5182784EF84F064F034EFC4EEE +4F1690994F284F1C4F074F1A4EFA4F17514A962351724F3B51B451B351B20000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +23 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00004F6451E84F675214520F5215521852A84F33534B534F518F5350521C538B +522153BE52AE53D2541653FF538E540054305405541354155445541956E35735 +57365731573258EE59054E545447593656E756E55741597A574C5986574B5752 +5B865F535C1859985C3D5C78598E59A25990598F5C8059A15E085B925C285C2A +5C8D5EF55F0E5C8B5C895C925FD35FDA5C935FDB5DE0620F625D625F62676257 +9F505E8D65EB65EA5F7867375FD2673267366B226BCE5FEE6C586C516C770000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +24 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00006C3C5FFA6C5A5FF76C53706F7072706E6283628C707372B172B26287738F +627B627A6270793C6288808D808E6272827B65F08D718FB99096909A67454E24 +4E7167554E9C4F454F4A4F394F37674B4F324F426C1A4F444F4B6C6B4F404F35 +4F3151516C6F5150514E6C6D6C87519D6C9C51B551B851EC522352275226521F +522B522052B452B372C65325533B537473957397739373947392544D75397594 +543A7681793D5444544C5423541A5432544B5421828F54345449545054220000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +25 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000543F5451545A542F8FC956E956F256F356EF56ED56EC56E6574896285744 +573F573C575357564F85575F5743575857574F744F894F8457464F4C573D4F6A +57425754575558F158F258F0590B9EA656F1593D4F955994598C519E599C51BE +5235599F5233599B52315989599A530B658853925B8D54875BFE5BFF5BFD5C2B +54885C845C8E5C9C5465546C5C855DF55E09546F54615E0B54985E925E905F03 +56F75F1E5F6357725FE75FFE5FE65FDC5FCE57805FFC5FDF5FEC5FF657620000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +26 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00005FF25FF05FF95945621359BA59CF623B623C628259C159B659BC6278628B +59B1629E62A5629B629C6299628D6285629D62755C445C475CAE65F65CA05CB5 +5CAF66F5675B5C9F675467525CA267586744674A67615CB66C7F6C916C9E5E14 +6C6E6C7C6C9F6C755F246C566CA26C795F7D6CA15FE56CAA6CA0601970797077 +707E600A7075707B7264601E72BB72BC72C772B972BE72B66011600C7398601C +6214623D62AD7593768062BE768376C076C162AE62B377F477F562A97ACC0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +27 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00007ACD7CFA809F80918097809466048286828C65FB8295660B866C66058FB5 +8FBE8FC766F68FC190A990A4678E6792677690A896279626962B963396349629 +4E3D679F4E9D4F934F8A677D67814F6D4F8E4FA04FA24FA14F9F4FA36C1D4F72 +6CEC4F8C51566CD96CB651906CAD6CE76CB751ED51FE522F6CC3523C52345239 +52B952B552BF53556C9D5376537A53936D3053C153C253D554856CCF545F5493 +548954799EFE548F5469546D70915494546A548A708356FD56FB56F872D80000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +28 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +000056FC56F6576557815763576772D1576E5778577F73A673A258F3594B594C +74DD74E8753F59AD753E59C4759859C259B076F176F076F577F859BF77F959C9 +59B859AC7942793F79C559B759D77AFB5B607CFD5B965B9E5B945B9F5B9D80B5 +5C005C1982A082C05C495C4A82985CBB5CC182A782AE82BC5CB95C9E5CB45CBA +5DF65E135E125E7782C35E9882A25E995E9D5EF8866E5EF98FD25F065F218FCD +5F255F558FD790B290B45F845F8360306007963D6036963A96434FCD5FE90000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +29 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000603D60084FC94FCB62BA62B24FDC62B762E462A74FDB4FC74FD662D562E1 +62DD62A662C162C562C062DF62E062DE53976589539965A665BA54A165FF54A5 +66176618660165FE54AE670C54B6676B67966782678A54BC67A354BE67A2678F +54B067F967806B266B276B686B69579D6B816BB46BD1578F57996C1C579A5795 +58F4590D59536C976C6C6CDF5A006CEA59DD6CE46CD86CB26CCE6CC859F2708B +70887090708F59F570877089708D70815BA8708C5CD05CD872405CD75CCB0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +2A +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00007265726672685CC95CC772CD72D372DB5CD472CF73A773A3739E5CDF73AF +5DF95E2173AA739C5E2075427544753B75415E9B759B759E5F0779C479C379C6 +6037603979C7607279CA604560537ACF7C767C747CFF7CFC6042605F7F5980A8 +6058606680B0624280B362CF80A480B680A780AC630380A65367820E82C4833E +829C63006313631462FA631582AA62F082C9654365AA82A682B2662166326635 +8FCC8FD98FCA8FD88FCF90B7661D90AD90B99637670F9641963E96B697510000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +2B +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +000097634E574E794EB24EB04EAF4EB14FD24FD567E44FBE4FB84FB04FB14FC8 +67F667EE4FC64FCC4FE54FE34FB4516A67B2519F67C651C167CC51C251C35245 +524867C967CA524F67EA67CB52C552CA52C453275358537D6BE053DD53DC53DA +53D954B96D1F54D054B454CA6D0A54A354DA54A46D1954B2549E549F54B56D1D +6D4254CD6D1854CC6D03570057AC5791578E578D579257A1579057A657A8709F +579C579657A770A170B470B570A958F572495909590872705952726E72CA0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +2C +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +000059DF72E859EB59EF59F059D55A0D5A0459F95A0259F859E259D959E75B6A +73B473EB5BAB73C75C1B5C2F73C6663C73CB74EC74EE5CD15CDC5CE65CE15CCD +76795CE25CDD5CE55DFB5DFA5E1E76F75EA176FA77E75EFC5EFB5F2F78127805 +5F66780F780E7809605C7813604E6051794B794560236031607C605279D66060 +604A60617AD162187B017C7A7C787C797C7F7C807C81631F631762EA63216304 +63057FBE6531654465408014654265BE80C76629661B80C86623662C661A0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +2D +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00006630663B661E6637663880C9670E80D780E667E867D6822167C767BC6852 +67BF67D567FE836367FB833A67B168016805680067D782F26B2A6B6B82FB82F6 +82F082EA6BE182E082FA6D236CFF6D146D056D136D066D21884E6D156CAF6CF4 +6D026D458A076D268FE36D448FEE6D2470A590BD70A390D570A270BB70A070AA +90C891D470A870B670B270A79653964A70B9722E5005723C5013726D5030501B +72E772ED503372EC72E572E24FF773C473BD73CF73C973C173D0503173CE0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +2E +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +000074ED74EB519374EF754975507546754A5261754D75A6525E525F525575A8 +52CD530E76C776FF54E276FD77E6780A54F37804780B78075504781578085511 +79D379D479D079D77A7C54F854E07A7D7A837A8257017AD47AD57AD37AD07AD2 +7AFE7AFC7C777C7C7C7B57B657BF57C757D057B957C1590E594A7F8F80D35A2D +80CB80D25A0F810980E280DF80C65B6C822482F782D882DD5C565C5482F882FC +5CEE5CF182E95D0082EE5E2982D0830E82E2830B82FD517986765F6786780000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +2F +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000605A60678675867D6088884288666081898C8A0560958A0660978C9F609C +8FF18FE78FE98FEF90C290BC632C90C690C06336634390CD90C9634B90C4633C +958163419CEC50324FF9501D4FFF50044FF05003635150024FFC4FF250245008 +5036502E65C35010503850394FFD50564FFB51A351A651A1681A684951C751C9 +5260526452595265526752575263682B5253682F52CF684452CE52D052D152CC +68266828682E550D54F46825551354EF54F554F9550255006B6D808255180000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +30 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +000054F054F66BE86BE355196BE7570557C96D6357B757CD6D0D6D616D9257BE +57BB6D6D57DB57C857C457C557D157CA57C06D676D605A215A2A6D7C5A1D6D82 +5A0B6D2F6D686D8B6D7E5A226D846D165A246D7B5A145A316D905A2F5A1A5A12 +70DD70CB5A2670E270D75BBC5BBB5BB75C055C065C525C5370C770DA5CFA5CEB +72425CF35CF55CE95CEF72FA5E2A5E305E2E5E2C5E2F5EAF5EA973D95EFD5F32 +5F8E5F935F8F604F609973D2607E73D46074604B6073607573E874DE60560000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +31 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +000060A9608B60A6755B609360AE609E60A7624575C075BF632E75BA63526330 +635B771B6319631B77126331635D6337633563537722635C633F654B78227835 +658B7828659A66506646664E6640782A664B6648795B66606644664D79526837 +682479EC79E0681B683679EA682C681968566847683E681E7A8B681568226827 +685968586855683068236B2E6B2B6B306B6C7B096B8B7C846BE96BEA6BE56D6B +7C8D7C856D736D577D117D0E6D5D6D566D8F6D5B6D1C6D9A6D9B6D997F610000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +32 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00006D816D717F5D7F5B6D726D5C6D9670C470DB70CC70D070E370DF80F270D6 +70EE70D580FB81008201822F727A833372F573028319835173E273EC73D573F9 +73DF73E683228342834E831B73E473E174F3834D831683248320755675557558 +7557755E75C38353831E75B4834B75B18348865376CB76CC772A86967716770F +869E8687773F772B770E772486857721771877DD86A7869578247836869D7958 +79598843796279DA79D9887679E179E579E879DB886F79E279F08874887C0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +33 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00008A128C477ADA7ADD8CA47ADB7ADC8D788DB57B0D7B0B7B147C8E7C868FF5 +7C877C837C8B90048FFC8FF690D67D2490D990DA90E37D257F627F937F997F97 +90DC90E47FC47FC6800A91D591E28040803C803B80F680FF80EE810481038107 +506A506180F750605053822D505D82278229831F8357505B504A506250158321 +505F506983188358506450465040506E50738684869F869B868986A68692868F +86A0884F8878887A886E887B88848873555055348A0D8A0B8A19553655350000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +34 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000553055525545550C8FF990099008553990DE9151553B554091DB91DF91DE +91D691E095859660965957F4965657ED57FD96BD57F8580B5042505958075044 +50665052505450715050507B507C505857E758015079506C507851A851D151CF +5268527652D45A5553A053C45A385558554C55685A5F55495A6C5A53555D5529 +5A43555455535A44555A5A48553A553F552B57EA5A4C57EF5A695A4757DD57FE +5A4257DE57E65B6E57E857FF580358F768A6591F5D1A595B595D595E5D0D0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +35 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00005D265A2B5D0F5A3B5D125D235A615A3A5A6E5A4B5A6B5EB45EB95A455A4E +5A685A3D5A715A3F5A6F5A7560905A735A2C5A595A545A4F5A6360CF60E45BC8 +60DD5BC360B15C5B5C6160CA5D215D0A5D0960C05D2C5D08638A63825D2A5D15 +639E5D105D1363975D2F5D18636F5DE35E395E355E3A5E32639C636D63AE637C +5EBB5EBA5F345F39638563816391638D6098655360D066656661665B60D760AA +666260A160A4688760EE689C60E7686E68AE60DE6956686F637E638B68A90000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +36 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000687563796386639368776373636A686B636C68AA637F687163B263BA6896 +688B6366637468A4655A687B654E654D658D658E65AD6B3365C765CA6B9165C9 +6B8D65E366576C2A66636667671A671967166DAC6DE9689E68B6689868736E00 +689A688E68B768DB68A5686C68C168846DDB6DF46895687A68996DF068B868B9 +68706DCF6B356DD06B906BBB6BED6DD76DCD6DE36DC16DC36DCE70F771176DAD +6E0470F06DB970F36DE770FC6E086E0671136E0A6DB070F66DF86E0C710E0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +37 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00006DB1727B6E026E076E096E016E176DFF6E12730A730871037107710170F5 +70F1710870F2710F740170FE7407740073FA731A7310730E740273F374087564 +73FB75CE75D275CF751B752375617568768F756775D37739772F769077317732 +76D576D776D67730773B7726784877407849771E784A784C782678477850784B +7851784F78427846796B796E796C79F279F879F179F579F379F97A907B357B3B +7A9A7A937A917AE17B247B337B217B1C7B167B177B367B1F7B2F7C937C990000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +38 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00007C9A7C9C7C947D497C967D347D377D3D7D2D7D367D4C7D457D2C7D487D41 +7D477F3B7D3F7D4A7D3B7D288008801A7F9C801D7F9B8049804580447C9B7FD1 +7FC7812A812E801F801E81318047811A8134811781258119811B831D83718384 +8380837283A18127837983918211839F83AD823A8234832382748385839C83B7 +8658865A8373865786B2838F86AE8395839983758845889C889488A3888F88A5 +88A988A6888A88A0889089928991899483B08A268A328A2883AE83768A1C0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +39 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +000086568A2B8A2086C28A2986C586BA86B08A218C3A86B38C5B8C588C7C86BB +8CA68CAE8CAD8D6588528D7E88958D7C8D7F8D7A8DBD889188A18DC08DBB8EAD +8EAF8ED6889788A488AC888C88938ED9898289D69012900E90258A27901390EE +8C3990AB90F78C5D9159915491F291F091E591F68DC28DB995878DC1965A8EDE +8EDD966E8ED78EE08EE19679900B98E198E6900C9EC49ED24E8090F04E81508F +50975088508990EC90E950815160915A91535E4251D391F491F151D251D60000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +3A +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000527391F9527091EB91F791E853A853A653C5559755DE966D966B559655B4 +96BF55859804559B55A0509B555950945586508B50A355AF557A508E509D5068 +559E509255A9570F570E581A5312581F53A4583C5818583E582655AD583A5645 +5822559358FB5963596455815AA85AA35A825A885AA15A855A9855955A99558E +5A895A815A965A80581E58275A91582857F5584858255ACF581B5833583F5836 +582E58395A875AA0582C5A7959615A865AAB5AAA5AA45A8D5A7E5A785BD50000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +3B +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00005A7C5AA55AAC5C1E5C5F5C5E5D445D3E5A975D485D1C5AA95D5B5D4D5A8C +5A9C5D575A935D535D4F5BCD5D3B5D465BD15BCA5E465E475C305E485EC05EBD +5EBF5D4B5F115D355F3E5F3B5D555F3A5D3A5D525D3D5FA75D5960EA5D396107 +6122610C5D325D3660B360D660D25E4160E360E560E95FAB60C9611160FD60E2 +60CE611E61206121621E611663E263DE63E660F860FC60FE60C163F8611863FE +63C163BF63F763D1655F6560656163B063CE65D163E863EF667D666B667F0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +3C +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +000063CA63E066736681666D6669646163DF671E68ED63DC63C463D863D36903 +63C768FE68E5691E690263D763D9690968CA690065646901691868E268CF659D +692E68C568FF65D2691C68C3667B6B6F66716B6E666A6BBE67016BF46C2D6904 +6DB66E756E1E68EA6E18690F6E4868F76E4F68E46E426E6A6E706DFE68E16907 +6E6D69086E7B6E7E6E5968EF6E5769146E806E5068FD6E296E766E2A6E4C712A +68CE7135712C7137711D68F468D1713868D47134712B7133712771246B3B0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +3D +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000712D7232728372827287730673247338732A732C732B6DFC732F73287417 +6E496E88741974386E45741F7414743C73F7741C74157418743974F975246E51 +6E3B6E03756E756D7571758E6E6175E56E286E606E716E6B769476B36E3076D9 +6E657748774977436E776E55774277DF6E66786378766E5A785F786679667971 +712E713179767984797579FF7A0771287A0E7A09724B725A7288728972867285 +7AE77AE27B55733073227B437B577B6C7B427B5373267B417335730C7CA70000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +3E +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00007CA07CA67CA47D74741A7D59742D7D607D577D6C7D7E7D6474207D5A7D5D +752F756F756C7D767D4D7D7575E67FD37FD675E475D78060804E8145813B7747 +814881428149814081148141774C81EF81F68203786483ED785C83DA841883D2 +8408787084007868785E786284178346841483D38405841F8402841683CD83E6 +7AE6865D86D586E17B447B487B4C7B4E86EE884788467CA27C9E88BB7CA188BF +88B47D6388B57D56899A8A437D4F7D6D8A5A7D6B7D527D548A358A388A420000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +3F +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00008A498A5D8A4B8A3D7F667FA27FA07FA18C608C5E8C7F8C7E8C8380D48CB1 +8D878152814F8D888D83814D813A8D868D8B8D828DCA8DD28204823C8DD48DC9 +8EB0833B83CF83F98EF28EE48EF38EEA83E78EFD83FC8F9D902B902A83C89028 +9029902C840183DD903A90309037903B83CB910A83D683F583C991FE922083DE +920B84069218922283D5921B920883D1920E9213839A83C3959583EE83C483FB +968C967B967F968183FE968286E286E686D386E386DA96EE96ED86EB96EC0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +40 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000975F976F86D7976D86D188488856885588BA88D798F088B888C088BE9AA9 +88BC88B79AE04EB7890188C950CC50BC899750AA50B989DB50AB50C350CD517E +527E52798A588A4452E152E052E7538053AB53AA53A953E055EA8C8055D78CBE +8CB055C157158D84586C8D89585C58505861586A5869585658605866585F5923 +596659688EEF8EF75ACE8EF95AC55AC38EE58EF55AD08EE88EF68EEB8EF18EEC +8EF45B745B765BDC5BD75BDA5BDB91045C205D6D5D6690F95D645D6E91000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +41 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00005D605F425F5A5F6E9164915F6130613A612A614361196131921A613D920F +920C92006408643264389206643192276419921C6411921992176429641D957B +958D958C643C96876446644796899683643A640796C8656B96F16570656D9770 +65E4669398A998EB9CE69EF9668F4E844EB6669250BF668E50AE694650CA50B4 +50C850C250B050C150BA693150CB50C9693E50B8697C694352786973527C6955 +55DB55CC6985694D69506947696769366964696155BF697D6B446B406B710000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +42 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00006B736B9C55C855F255CD6BC155C26BFA6C316C325864584F6EB86EA8586F +6E916EBB585D6E9A5865585B6EA9586358716EB56E6C6EE85ACB6EDD6EDA6EE6 +6EAC5AB05ABF5AC86ED96EE36EE96EDB5ACA716F5AB65ACD71485A90714A716B +5BD9714F715771745D635D4A5D6571457151716D5D6872517250724E5E4F7341 +5E4A732E73465EC574275EC674487453743D5FAF745D74566149741E74477443 +74587449612E744C7445743E61297501751E91686223757A75EE760276970000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +43 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00007698641064126409775D77647753775878827890788A6439787A787D6423 +788B787864306428788D788878927881797E798364256427640B7980641B642E +64217A0F656F65927A1D66867AA17AA466907AE97AEA66997B627B6B67207B5E +695F7B79694E69627B6F7B686945696A7CAE6942695769597CB069487D906935 +7D8A69337D8B7D997D9569787D877D787D977D897D986976695869417FA3694C +693B694B7FDD8057694F8163816A816C692F697B693C815D81756B43815F0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +44 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00006B48817D816D6BFB6BFC8241844F84846E9B847F6EC88448842A847B8472 +8464842E845C84536EC6844184C86EC184628480843E848384716EA6844A8455 +84586EC36EDC6ED886FC86FD87156E8D871686FF6EBF6EB36ED0885888CF88E0 +6EA371477154715289E78A6A8A80715D8A6F8A6571788A788A7D8A8871587143 +8A648A7E715F8A678C638C88714D8CCD724F8CC9728C8DED7290728E733C7342 +733B733A73408EB1734974448F048F9E8FA090439046904890459040904C0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +45 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +000074427446910C9113911574FF916B9167925D9255923569839259922F923C +928F925C926A9262925F926B926E923B92449241959A7699959976DD7755775F +968F77529696775A7769776796F496FC776D9755788797797894788F788497EE +97F57886980B788398F37899788098F798FF98F5798298EC98F17A117A18999A +7A129AE29B3D9B5D9CE87A1B9CEB9CEF9CEE9E819F1450D050D950DC50D87B69 +50E150EB7B737B7150F450E250DE7B767B637CB251F47CAF7D887D8652ED0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +46 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +000052EA7D7F53327D7A53AE53B07D8355FB5603560B7D8456077D9255F87F6B +5628561E7F6C5618561156515605571758928164588C817758785884587358AD +58975895587758725896588D59108161596C82495AE782405AE4824584F15AEF +5626847684795AF05D7B84655D83844084865D8B5D8C844D5D785E5284598474 +5ED05ECF85075FB35FB4843A8434847A617B8478616F6181613C614261386133 +844261606169617D6186622C62288452644C84C56457647C8447843664550000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +47 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +000064626471646A6456643B6481846E644F647E646486F7870C86FA86D686F5 +657186F8870E66A5669A669C870D66A688D666A4698F69C569C8699269B288CC +88D0898569E369C069D669D1699F69A269D289DC89E68A7669E169D5699D8A3F +8A7769988A846B746BA18A816EF06EF38C3C8C4B6F1B6F0C6F1D6F346F286F17 +8C856F446F426F046F116EFA6F4A7191718E8D93718B718D717F718C717E717C +71838DEE71888DE98DE372948DE773557353734F7354746C7465746674610000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +48 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000746B746874768F0B7460903F74747506760E91107607910F911176B99114 +76B776E2916E7774777777767775923A777877719265777A715B777B78A678AE +78B8926C924F926078B178AF923679897987923192547A2992507A2A924E7A2D +7A2C92567A32959F7AEC7AF07B817B9E7B8396917B9296CE7BA37B9F7B9396F5 +7B867CB87CB79772980F980D980E98AC7DC87DB699AF7DD199B07DA87DAB9AAB +7DB37DCD9CED7DCF7DA49EFD50E67F417F6F7F7150F350DB50EA50DD50E40000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +49 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +000050D38023805B50EF8061805F818152805281818482135330824A824C5615 +560C561284BD8495561C849284C35602849684A584B584B384A384E484D884D5 +589884B784AD84DA84938736587A58875891873D872B87478739587B8745871D +58FE88FF88EA5AEE88F55AD5890088ED890388E95AF35AE289EA5ADB8A9B8A8E +8AA25AD98A9C8A948A908AA98AAC5C638A9F5D805D7D8A9D5D7A8C675D775D8A +8CD08CD68CD48D988D9A8D975D7F5E585E598E0B8E088E018EB48EB35EDC0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +4A +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00008FA18FA25ED2905A5F449061905F5FB6612C9125917B9176917C61739289 +92F692B192AD929292819284617A92AE9290929E616A6161615695A295A7622B +642B644D645B645D96A0969D969F96D0647D96D1646664A6975964829764645C +644B64539819645098149815981A646B645964656477990665A098F89901669F +99BE99BC99B799B699C069C999B869CE699669B099C469BC99BF69999ADA9AE4 +9AE99AE89AEA9AE569BF9B2669BD69A49B4069B969CA699A69CF69B369930000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +4B +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +000069AA9EBD699E69D969976990510E69B550F769C650FC510D510151DA51D9 +51DB5286528E52EE533353B16EF15647562D56546F37564B5652563156445656 +5650562B6F18564D5637564F58A258B76F7358B26EEE58AA58B558B06F3C58B4 +58A458A76F0E59265AFE6EFD5B046F395AFC6EFC5B065B0A5AFA5B0D5B005B0E +7187719071895D9171855D8F5D905D985DA45D9B5DA35D965DE45E5A72957293 +5E5E734D5FB86157615C61A661956188747261A3618F75006164750361590000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +4C +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00006178761661856187619E7611760A6198619C7781777C622F6480649B648E +648D649464C678B264A8648378AD64B9648664B464AF649178A064AA64A164A7 +66B666B3798B66BC66AC799466AD6A0E79886A1C6A1A7A2B7A4A6A0B7A2F69EF +6A0C69F06A227AAC69D87B886A1269FA7B916A2A7B966A107B8C7B9B6A2969F9 +69EA6A2C6A247BA469E96B526B4F6B537CBA7DA76F106F656F757DAA7DC17DC0 +7DC56FD07DCE6F5C6F3D6F717DCC6F916F0B6F796F816F8F7DA66F596F740000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +4D +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00007DA171AE7F7371A371AD7FE57FDE71AB71A671A2818952F2725772557299 +734B747A8215849784A4748C748484BA84CE74827493747B84AB750984B484C1 +84CD84AA849A84B1778A849D779084BB78C678D378C078D278C778C284AF799F +799D799E84B67A4184A07A387A3A7A4284DB84B07A3E7AB07BAE7BB38728876B +7BBF872E871E7BCD87197BB28743872C8741873E8746872087327CC47CCD7CC2 +7CC67CC37CC97CC787427DF887277DED7DE2871A873087117DDC7E027E010000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +4E +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +000088F27DD688FE7DE47DFE88F67E007DFC7DFD88EB7DF57DFF899F7DEB7DE5 +7F787FAE7FE78A998065806A80668068806B819481A18192819681938D968E09 +85018DFF84F88DFD84F58E0385048E068E058DFE8E00851B85038533853484ED +9123911C853591228505911D911A91249121877D917A91729179877192A5885C +88E6890F891B92A089A989A589EE8AB1929A8ACC8ACE92978AB792A38AB58AE9 +8AB492958AB38AC18AAF8ACA8AD09286928C92998C8E927E92878CE98CDB0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +4F +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000928B8CEB8DA496A18DA28D9D977D977A977E97838E2A8E28977B97848EB8 +8EB68EB98EB78F228F2B8F278F198FA499078FB3999C9071906A99BB99BA9188 +918C92BF92B892BE92DC92E59B3F9B6092D492D69CF192DA92ED92F392DB5103 +92B992E292EB95AF50F695B295B3510C50FD510A96A396A552F152EF56485642 +970A563597879789978C97EF982A98225640981F563D9919563E99CA99DA563A +571A58AB99DE99C899E058A39AB69AB558A59AF458FF9B6B9B699B729B630000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +50 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00005AF69D0D5AF89D019D0C5B019CF85B055B0F9CFE9D029E845D9F9EAB9EAA +511D51165DA0512B511E511B5290529453145E605E5C56675EDB567B5EE1565F +5661618B6183617961B161B061A2618958C358CA58BB58C058C459015B1F5B18 +5B115B1561B35B125B1C64705B225B795DA664975DB35DAB5EEA648A5F5B64A3 +649F61B761CE61B961BD61CF61C06199619765B361BB61D061C4623166B764D3 +64C06A006A066A1769E564DC64D164C869E464D566C369EC69E266BF66C50000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +51 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +000069FE66CD66C167066A1467246A636A426A5269E66A436A3369FC6A6C6A57 +6A046A4C6A6E6A0F69F66A266A0769F46A376B516A716A4A6A366BA66A536C00 +6A456A706F416F266A5C6B586B576F926F8D6F896F8C6F626F4F6FBB6F5A6F96 +6FBE6F6C6F826F556FB56FD36F9F6F576FB76FF571B76F0071BB6F6B71D16F67 +71BA6F5371B671CC6F7F6F9571D3749B6F6A6F7B749674A2749D750A750E719A +7581762C76377636763B71A476A171AA719C779871B37796729A735873520000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +52 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +000078D678EB736078DC735B79A579A998347A537A4574897A4F74867ABD7ABB +7AF17488747C7BEC7BED7507757E7CD3761E7CE1761D7E197623761A76287E27 +7E26769D769E806E81AF778F778981AD78CD81AA821878CC78D178CE78D4856F +854C78C48542799A855C8570855F79A2855A854B853F878A7AB4878B87A1878E +7BBE7BAC8799885E885F892489A78AEA8AFD8AF98AE38AE57DDB7DEA8AEC7DD7 +7DE17E037DFA8CF27DF68CEF7DF08DA67DDF7F767FAC8E3B8E437FED8E320000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +53 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00008F318F307FE68F2D8F3C8FA78FA5819F819E819591379195918E82169196 +82539345930A824E825192FD9317931C930793319332932C9330930393058527 +95C284FB95B884FA95C1850C84F4852A96AB96B784F784EB97159714851284EA +970C971784FE9793851D97D2850284FD983698319833983C982E983A84F0983D +84F998B5992299239920991C991D866299A0876399EF99E899EB877387588754 +99E199E68761875A9AF89AF5876D876A9B839B949B84875D9B8B9B8F877A0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +54 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00009B8C875C9B89874F9B8E8775876287679D249D0F89059D139D0A890B8917 +891889199D2A9D1A89119D279D169D2189A49E859EAC9EC69EC59ED79F538AB8 +5128512751DF8AD5533553B38ABE568A567D56898AC358CD58D08AD95B2B5B33 +5B295B355B315B375C365DBE8CDD5DB98DA05DBB8DA161E261DB61DD61DC61DA +8E2E61D98E1B8E1664DF8E198E2664E18E1464EE8E1865B566D466D58E1A66D0 +66D166CE66D78F208F236A7D6A8A90736AA7906F6A996A826A88912B91290000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +55 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00006A8691326A986A9D918591866A8F91816AAA91846B5D92D06C0A92C46FD7 +6FD66FE592CF92F192DF6FD96FDA6FEA92DD6FF692EF92C271E392CA71E992CE +71EB71EF71F371EA92E092DE92E792D192D3737192E174AE92C674B3957C74AC +95AB95AE75837645764E764476A376A577A677A4978A77A977AF97D097CF981E +78F078F878F198287A49981B982798B27AC27AF27AF37BFA99167BF67BFC7C18 +7C087C1299D399D47CDB7CDA99D699D899CB7E2C7E4D9AB39AEC7F467FF60000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +56 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000802B807481B881C89B679B749B71859285939B75857F85AB85979B6C9CFC +85AC9CFD9CFF9CF787CE9D0087CD9CFB9D0887C187B187C79ED389409F10893F +893951178943511151DE533489AB56708B1F8B098B0C566656638C4056728C96 +56778CF68CF758C88E468E4F58BF58BA58C28F3D8F4193669378935D93699374 +937D936E93729373936293489353935F93685DB1937F936B5DB595C45DAE96AF +96AD96B25DAD5DAF971A971B5E685E665E6F5EE9979B979F5EE85EE55F4B0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +57 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00005FBC5FBB619D61A86196984061B4984761C198B761BA61BF61B8618C64D7 +99A264D064CF9A0099F3648964C399F564F364D99ABD9B009B0265A29B349B49 +9B9F66CA9BA39BCD9B999B9D66BA66CC9D396A349D446A496A679D356A686A3E +9EAF6A6D512F6A5B6A519F8E6A5A569F569B569E5696569456A06A4F5B3B6A6F +6A695B3A5DC15F4D5F5D61F36A4D6A4E6A466B5564F664E564EA64E765056BC8 +64F96C046C036C066AAB6AED6AB26AB06AB56ABE6AC16AC86FC46AC06ABC0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +58 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00006AB16AC46ABF6FA56FAE700870036FFD7010700270136FA271FA720074B9 +74BC6FB2765B7651764F76EB77B871D677B977C177C077BE790B71C77907790A +790871BC790D7906791579AF729E736973667AF5736C73657C2E736A7C1B749A +7C1A7C24749274957CE67CE37580762F7E5D7E4F7E667E5B7F477FB476327630 +76BB7FFA802E779D77A181CE779B77A282197795779985CC85B278E985BB85C1 +78DE78E378DB87E987EE87F087D6880E87DA8948894A894E894D89B189B00000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +59 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +000089B37AB78B388B327BE78B2D7BD58B347BDA8B298C747BD47BEA8D037BDC +7BEB8DA98E587CD27CD48EBF8EC18F4A8FAC7E219089913D913C91A993A07E0E +93907E159393938B93AD93BB93B87E0D7E14939C95D895D77F7B7F7C7F7A975D +97A997DA8029806C81B181A6985481B99855984B81B0983F98B981B281B781A7 +81F29938993699408556993B993999A4855385619A089A0C85469A1085419B07 +85449BD285479BC29BBB9BCC9BCB854E856E9D4D9D639D4E85609D509D550000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +5A +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000855D9D5E85659E909EB29EB186649ECA9F029F279F26879356AF58E058DC +87965B39877987875B7C5BF3879087915C6B5DC4650B6508650A8789891E65DC +8930892D66E166DF6ACE6AD46AE36AD76AE2892C891F89F18AE06AD86AD56AD2 +8AF58ADD701E702C70256FF37204720872158AE874C474C974C774C876A977C6 +77C57918791A79208CF37A667A647A6A8DA78E338E3E8E388E408E457C357C34 +8E3D8E417E6C8E3F7E6E7E718F2E81D481D6821A82628265827685DB85D60000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +5B +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000908685E79133913585F4919387FD87D58807918F880F87F89308931F8987 +930F89B589F5933C8B3F8B438B4C93018D0B8E6B8E688E708E758E7792FA8EC3 +92F993E993EA93CB93C593C6932993ED93D3932A93E5930C930B93DB93EB93E0 +93C1931695BC95DD95BE95B995BA95B695BF95B595BD96A996D497B297B497B1 +97B597F2979497F097F89856982F98329924994499279A269A1F9A189A219A17 +99E49B0999E399EA9BC59BDF9AB99BE39AB49BE99BEE9AFA9AF99D669D7A0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +5C +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00009B809D6E9D919D839D769D7E9D6D9B939E959EE39B7A9B959F039F049D25 +9F179D2051369D1453369D1D5B429D229D105B445B465B7E5DCA5DC85DCC5EF0 +9ED5658566E566E79F3D512651256AF451246AE9512952F45693568C568D703D +56847036567E7216567F7212720F72177211720B5B2D5B2574CD74D074CC74CE +74D15B2F75895B7B7A6F7C4B7C445E6C5E6A5FBE61C361B57E7F8B7161E0802F +807A807B807C64EF64E964E385FC861086026581658085EE860366D2860D0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +5D +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +000086138608860F881888126A9B6AA18967896589BB8B698B626A838B6E6AA4 +8B616A7F8B648B4D8C516A8C6A928E838EC66C09941F6FA99404941794089405 +6FED93F3941E9402941A941B9427941C71E196B571E871F2973371F097349731 +97B897BA749797FC74AB749098C374AD994D74A59A2F7510751175129AC97584 +9AC89AC49B2A9B389B5076E99C0A9BFB9C049BFC9BFE77B477B177A89C029BF6 +9C1B9BF99C159C109BFF9C009C0C78F978FE9D959DA579A87A5C7A5B7A560000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +5E +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00009E989EC17A5A9F5A516456BB7C0558E65B495BF77BFF7BFB5DD07BF45FC2 +7BF365117C096AFF6AFE6AFD7BFD6B017BF07BF1704B704D704774D376687667 +7E33984877D179307932792E7E479F9D7AC97AC87E3B7C567C517E3A7F457F7F +7E857E897E8E7E84802C826A862B862F862881C586168615861D881A825A825C +858389BC8B758B7C85958D118D128F5C91BB85A493F4859E8577942D858985A1 +96E497379736976797BE97BD97E29868986698C898CA98C798DC8585994F0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +5F +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +000099A99A3C85909A3B9ACE87BE9B149B5387C59C2E87AC9C1F87B587BC87AE +87C99DB09DBD87CC87B79DAE9DC49E7B87B487B69E9E87B89F0587DE9F699FA1 +56C7571D5B4A5DD389525F72620289AD62356527651E651F8B1E8B186B076B06 +8B058B0B7054721C72207AF88B077C5D7C588B067E927F4E8B1A8C4F8C708827 +8C718B818B838C948C448D6F8E4E8E4D8E539442944D9454944E8F409443907E +9138973C974097C09199919F91A1919D995A9A5193839ADD936493569C380000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +60 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000937C9C459C3A93769C359350935193609EF1938F9F93529A937993578641 +5DD7934F65289377937B936170537059936772219359766F793779B57C627C5E +7CF596AE96B0863D9720882D89898B8D8B878B908D1A8E99979E979D97D5945F +97F1984194569461945B945A945C9465992B9741992A9933986E986C986D9931 +99AA9A5C9A589ADE9A029C4F9C5199F79C5399F899F699FB9DFC9F3999FC513E +9ABE56D29AFD5B4F6B149B487A727A739B9E9B9B9BA68B919BA59BA491BF0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +61 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00009BA2946C9BAF9D3396E697459D3697C897E4995D9D389B219D459B2C9B57 +9D3E9D379C5D9C619C659E089E8A9E899E8D9EB09EC89F459EFB9EFF620566EF +6B1B6B1D722572247C6D512E8642864956978978898A8B9759708C9B8D1C5C6A +8EA25E6D5E6E61D861DF61ED61EE61F161EA9C6C61EB9C6F61E99E0E65049F08 +9F1D9FA3650364FC5F606B1C66DA66DB66D87CF36AB98B9B8EA791C46ABA947A +6AB76AC79A619A639AD79C766C0B9FA5700C7067700172AB864A897D8B9D0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +62 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00008C538F65947B6FFC98CD98DD72019B309E16720371FD737674B874C096E7 +9E189EA274B69F7C74C27E9E9484765C9E1C76597C7197CA7657765A76A69EA3 +76EC9C7B9F97790C7913975079097910791257275C1379AC7A5F7C1C7C297C19 +7C205FC87C2D7C1D7C267C287C2267657C307E5C52BD7E565B667E5865F96788 +6CE66CCB7E574FBD5F8D7FB36018604880756B2970A681D07706825E85B485C6 +5A105CFC5CFE85B385B585BD85C785C485BF70C985CE85C885C585B185B60000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +63 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +000085D28624957985B796BA866987E787E687E287DB87EB87EA7B29812887F3 +8A2E87D487DC87D39AD987D8582B584587D963FA87F487E887DD6E86894B894F +894C89468950586789495BDD656E8B238B338B308C878B4750D250DF8B3E8B31 +8B258B3769BA8B366B9D8B2480598B3D8B3A8C428C758C998C988C978CFE8D04 +8D028D008E5C6F8A8E608E577BC37BC28E658E678E5B8E5A90F68E5D98238E54 +8F468F478F488F4B71CD7499913B913E91A891A591A7984291AA93B5938C0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +64 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +000093927F84939B939D938993A7938E8D0E939E9861939593888B73939F9C27 +938D945877D69B2D93A493A893B493A395D295D395D196B396D796DA5DC296DF +96D896DD97239722972597AC97AE97A84F664F684FE7503F97A550A6510F523E +53245365539B517F54CB55735571556B55F456225620569256BA569156B05759 +578A580F581258135847589B5900594D5AD15AD35B675C575C775CD55D755D8E +5DA55DB65DBF5E655ECD5EED5F945F9A5FBA6125615062A36360636463B60000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +65 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000640364B6651A7A255C2166E2670267A467AC68106806685E685A692C6929 +6A2D6A776A7A6ACA6AE66AF56B0D6B0E6BDC6BDD6BF66C1E6C636DA56E0F6E8A +6E846E8B6E7C6F4C6F486F496F9D6F996FF8702E702D705C79CC70BF70EA70E5 +71117112713F7139713B713D71777175717671717196719371B471DD71DE720E +591172187347734873EF7412743B74A4748D74B47673767776BC7819781B783D +78537854785878B778D878EE7922794D7986799979A379BC7AA77B377B590000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +66 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00007BD07C2F7C327C427C4E7C687CA97CED7DD07E077DD37E647F40791E8041 +806380BB6711672582488310836283128421841E84E284DE84E1857385D485F5 +863786458672874A87A987A587F5883488508887895489848B038C528CD88D0C +8D188DB08EBC8ED58FAA909C85E8915C922B9221927392F492F5933F93429386 +93BE93BC93BD93F193F293EF94229423942494679466959795CE95E7973B974D +98E499429B1D9B9889629D4964495E715E8561D3990E8002781E898889B70000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +67 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00005528557255BA55F055EE56B856B956C4805392B08B558B518B428B528B57 +8C438C778C768C9A8D068D078D098DAC8DAA8DAD8DAB8E6D8E788E738E6A8E6F +8E7B8EC28F528F518F4F8F508F538FB49140913F91B091AD93DE93C793CF93C2 +93DA93D093F993EC93CC93D993A993E693CA93D493EE93E393D593C493CE93C0 +93D293A593E7957D95DA95DB96E19729972B972C9728972697B397B797B697DD +97DE97DF985C9859985D985798BF98BD98BB98BE99489947994399A699A70000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +68 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00009A1A9A159A259A1D9A249A1B9A229A209A279A239A1E9A1C9A149AC29B0B +9B0A9B0E9B0C9B379BEA9BEB9BE09BDE9BE49BE69BE29BF09BD49BD79BEC9BDC +9BD99BE59BD59BE19BDA9D779D819D8A9D849D889D719D809D789D869D8B9D8C +9D7D9D6B9D749D759D709D699D859D739D7B9D829D6F9D799D7F9D879D689E94 +9E919EC09EFC9F2D9F409F419F4D9F569F579F58533756B256B556B358E35B45 +5DC65DC75EEE5EEF5FC05FC161F9651765166515651365DF66E866E366E40000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +69 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00006AF36AF06AEA6AE86AF96AF16AEE6AEF703C7035702F7037703470317042 +7038703F703A7039702A7040703B703370417213721472A8737D737C74BA76AB +76AA76BE76ED77CC77CE77CF77CD77F279257923792779287924792979B27A6E +7A6C7A6D7AF77C497C487C4A7C477C457CEE7E7B7E7E7E817E807FBA7FFF8079 +81DB81D982688269862285FF860185FE861B860085F6860486098605860C85FD +8819881088118817881388168963896689B989F78B608B6A8B5D8B688B630000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +6A +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00008B658B678B6D8DAE8E868E888E848F598F568F578F558F588F5A908D9143 +914191B791B591B291B3940B941393FB9420940F941493FE9415941094289419 +940D93F5940093F79407940E9416941293FA940993F8943C940A93FF93FC940C +93F69411940695DE95E095DF972E972F97B997BB97FD97FE986098629863985F +98C198C29950994E9959994C994B99539A329A349A319A2C9A2A9A369A299A2E +9A389A2D9AC79ACA9AC69B109B129B119C0B9C089BF79C059C129BF89C400000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +6B +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00009C079C0E9C069C179C149C099D9F9D999DA49D9D9D929D989D909D9B9DA0 +9D949D9C9DAA9D979DA19D9A9DA29DA89D9E9DA39DBF9DA99D969DA69DA79E99 +9E9B9E9A9EE59EE49EE79EE69F309F2E9F5B9F609F5E9F5D9F599F91513A5139 +5298529756C356BD56BE5B485B475DCB5DCF5EF161FD651B6B026AFC6B036AF8 +6B0070437044704A7048704970457046721D721A7219737E7517766A77D0792D +7931792F7C547C537CF27E8A7E877E887E8B7E867E8D7F4D7FBB803081DD0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +6C +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00008618862A8626861F8623861C86198627862E862186208629861E86258829 +881D881B88208824881C882B884A896D8969896E896B89FA8B798B788B458B7A +8B7B8D108D148DAF8E8E8E8C8F5E8F5B8F5D91469144914591B9943F943B9436 +9429943D94309439942A9437942C9440943195E595E495E39735973A97BF97E1 +986498C998C698C0995899569A399A3D9A469A449A429A419A3A9A3F9ACD9B15 +9B179B189B169B3A9B529C2B9C1D9C1C9C2C9C239C289C299C249C219DB70000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +6D +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00009DB69DBC9DC19DC79DCA9DCF9DBE9DC59DC39DBB9DB59DCE9DB99DBA9DAC +9DC89DB19DAD9DCC9DB39DCD9DB29E7A9E9C9EEB9EEE9EED9F1B9F189F1A9F31 +9F4E9F659F649F924EB956C656C556CB59715B4B5B4C5DD55DD15EF265216520 +652665226B0B6B086B096C0D7055705670577052721E721F72A9737F74D874D5 +74D974D7766D76AD793579B47A707A717C577C5C7C597C5B7C5A7CF47CF17E91 +7F4F7F8781DE826B863486358633862C86328636882C88288826882A88250000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +6E +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000897189BF89BE89FB8B7E8B848B828B868B858B7F8D158E958E948E9A8E92 +8E908E968E978F608F629147944C9450944A944B944F94479445944894499446 +973F97E3986A986998CB9954995B9A4E9A539A549A4C9A4F9A489A4A9A499A52 +9A509AD09B199B2B9B3B9B569B559C469C489C3F9C449C399C339C419C3C9C37 +9C349C329C3D9C369DDB9DD29DDE9DDA9DCB9DD09DDC9DD19DDF9DE99DD99DD8 +9DD69DF59DD59DDD9EB69EF09F359F339F329F429F6B9F959FA2513D52990000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +6F +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +000058E858E759725B4D5DD8882F5F4F62016203620465296525659666EB6B11 +6B126B0F6BCA705B705A7222738273817383767077D47C677C667E95826C863A +86408639863C8631863B863E88308832882E883389768974897389FE8B8C8B8E +8B8B8B888C458D198E988F648F6391BC94629455945D9457945E97C497C59800 +9A569A599B1E9B1F9B209C529C589C509C4A9C4D9C4B9C559C599C4C9C4E9DFB +9DF79DEF9DE39DEB9DF89DE49DF69DE19DEE9DE69DF29DF09DE29DEC9DF40000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +70 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00009DF39DE89DED9EC29ED09EF29EF39F069F1C9F389F379F369F439F4F9F71 +9F709F6E9F6F56D356CD5B4E5C6D652D66ED66EE6B13705F7061705D70607223 +74DB74E577D5793879B779B67C6A7E977F89826D8643883888378835884B8B94 +8B958E9E8E9F8EA08E9D91BE91BD91C2946B9468946996E597469743974797C7 +97E59A5E9AD59B599C639C679C669C629C5E9C609E029DFE9E079E039E069E05 +9E009E019E099DFF9DFD9E049EA09F1E9F469F749F759F7656D4652E65B80000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +71 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00006B186B196B176B1A7062722672AA77D877D979397C697C6B7CF67E9A7E98 +7E9B7E9981E081E18646864786488979897A897C897B89FF8B988B998EA58EA4 +8EA3946E946D946F9471947397499872995F9C689C6E9C6D9E0B9E0D9E109E0F +9E129E119EA19EF59F099F479F789F7B9F7A9F79571E70667C6F883C8DB28EA6 +91C394749478947694759A609B2E9C749C739C719C759E149E139EF69F0A9FA4 +706870657CF7866A883E883D883F8B9E8C9C8EA98EC9974B9873987498CC0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +72 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000996199AB9A649A669A679B249E159E179F4862076B1E7227864C8EA89482 +948094819A699A689E19864B8B9F94839C799EB776759A6B9C7A9E1D7069706A +72299EA49F7E9F499F988AF68AFC8C6B8C6D8C938CF48E448E318E348E428E39 +8E358F3B8F2F8F388F338FA88FA69075907490789072907C907A913491929320 +933692F89333932F932292FC932B9304931A9310932693219315932E931995BB +96A796A896AA96D5970E97119716970D9713970F975B975C9766979898300000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +73 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00009838983B9837982D9839982499109928991E991B9921991A99ED99E299F1 +9AB89ABC9AFB9AED9B289B919D159D239D269D289D129D1B9ED89ED49F8D9F9C +512A511F5121513252F5568E5680569056855687568F58D558D358D158CE5B30 +5B2A5B245B7A5C375C685DBC5DBA5DBD5DB85E6B5F4C5FBD61C961C261C761E6 +61CB6232623464CE64CA64D864E064F064E664EC64F164E264ED6582658366D9 +66D66A806A946A846AA26A9C6ADB6AA36A7E6A976A906AA06B5C6BAE6BDA0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +74 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00006C086FD86FF16FDF6FE06FDB6FE46FEB6FEF6F806FEC6FE16FE96FD56FEE +6FF071E771DF71EE71E671E571ED71EC71F471E0723572467370737274A974B0 +74A674A876467642764C76EA77B377AA77B077AC77A777AD77EF78F778FA78F4 +78EF790179A779AA7A577ABF7C077C0D7BFE7BF77C0C7BE07CE07CDC7CDE7CE2 +7CDF7CD97CDD7E2E7E3E7E467E377E327E437E2B7E3D7E317E457E417E347E39 +7E487E357E3F7E2F7F447FF37FFC807180728070806F807381C681C381BA0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +75 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +000081C281C081BF81BD81C981BE81E88209827185AA8584857E859C85918594 +85AF859B858785A8858A85A6866787C087D187B387D287C687AB87BB87BA87C8 +87CB893B893689448938893D89AC8B0E8B178B198B1B8B0A8B208B1D8B048B10 +8C418C3F8C738CFA8CFD8CFC8CF88CFB8DA88E498E4B8E488E4A8F448F3E8F42 +8F458F3F907F907D9084908190829080913991A3919E919C934D938293289375 +934A9365934B9318937E936C935B9370935A935495CA95CB95CC95C895C60000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +76 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +000096B196B896D6971C971E97A097D3984698B699359A0199FF9BAE9BAB9BAA +9BAD9D3B9D3F9E8B9ECF9EDE9EDC9EDD9EDB9F3E9F4B53E2569556AE58D958D8 +5B385F5E61E3623364F464F264FE650664FA64FB64F765B766DC67266AB36AAC +6AC36ABB6AB86AC26AAE6AAF6B5F6B786BAF7009700B6FFE70066FFA7011700F +71FB71FC71FE71F87377737574A774BF751576567658765277BD77BF77BB77BC +790E79AE7A617A627A607AC47AC57C2B7C277C2A7C1E7C237C217CE77E540000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +77 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00007E557E5E7E5A7E617E527E597F487FF97FFB8077807681CD81CF820A85CF +85A985CD85D085C985B085BA85B987EF87EC87F287E0898689B289F48B288B39 +8B2C8B2B8C508D058E598E638E668E648E5F8E558EC08F498F4D908790839088 +91AB91AC91D09394938A939693A293B393AE93AC93B09398939A939795D495D6 +95D095D596E296DC96D996DB96DE972497A397A697AD97F9984D984F984C984E +985398BA993E993F993D992E99A59A0E9AC19B039B069B4F9B4E9B4D9BCA0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +78 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00009BC99BFD9BC89BC09D519D5D9D609EE09F159F2C513356A556A858DE58DF +58E25BF59F905EEC61F261F761F661F56500650F66E066DD6AE56ADD6ADA6AD3 +701B701F7028701A701D701570187206720D725872A27378737A74BD74CA74E3 +75877586765F766177C7791979B17A6B7A697C3E7C3F7C387C3D7C377C407E6B +7E6D7E797E697E6A7E737F857FB67FB97FB881D885E985DD85EA85D585E485E5 +85F787FB8805880D87F987FE8960895F8956895E8B418B5C8B588B498B5A0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +79 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00008B4E8B4F8B468B598D088D0A8E7C8E728E878E768E6C8E7A8E748F548F4E +8FAD908A908B91B191AE93E193D193DF93C393C893DC93DD93D693E293CD93D8 +93E493D793E895DC96B496E3972A9727976197DC97FB985E9858985B98BC9945 +99499A169A199B0D9BE89BE79BD69BDB9D899D619D729D6A9D6C9E929E979E93 +9EB452F856B756B656B456BC58E45B405B435B7D5BF65DC961F861FA65186514 +651966E667276AEC703E703070327210737B74CF766276657926792A792C0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +7A +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000792B7AC77AF67C4C7C437C4D7CEF7CF08FAE7E7D7E7C7E827F4C800081DA +826685FB85F9861185FA8606860B8607860A88148815896489BA89F88B708B6C +8B668B6F8B5F8B6B8D0F8D0D8E898E818E858E8291B491CB9418940393FD95E1 +973098C49952995199A89A2B9A309A379A359C139C0D9E799EB59EE89F2F9F5F +9F639F615137513856C156C056C259145C6C5DCD61FC61FE651D651C659566E9 +6AFB6B046AFA6BB2704C721B72A774D674D4766977D37C507E8F7E8C7FBC0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +7B +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00008617862D861A882388228821881F896A896C89BD8B748B778B7D8D138E8A +8E8D8E8B8F5F8FAF91BA942E94339435943A94389432942B95E2973897399732 +97FF9867986599579A459A439A409A3E9ACF9B549B519C2D9C259DAF9DB49DC2 +9DB89E9D9EEF9F199F5C9F669F67513C513B56C856CA56C95B7F5DD45DD25F4E +61FF65246B0A6B6170517058738074E4758A766E766C79B37C607C5F807E807D +81DF8972896F89FC8B808D168D178E918E938F619148944494519452973D0000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +7C +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000973E97C397C1986B99559A559A4D9AD29B1A9C499C319C3E9C3B9DD39DD7 +9F349F6C9F6A9F9456CC5DD662006523652B652A66EC6B1074DA7ACA7C647C63 +7C657E937E967E9481E28638863F88318B8A9090908F9463946094649768986F +995C9A5A9A5B9A579AD39AD49AD19C549C579C569DE59E9F9EF456D158E9652C +705E7671767277D77F507F888836883988628B938B928B9682778D1B91C0946A +97429748974497C698709A5F9B229B589C5F9DF99DFA9E7C9E7D9F079F770000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +7D +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +00009F725EF36B1670637C6C7C6E883B89C08EA191C1947294709871995E9AD6 +9B239ECC706477DA8B9A947797C99A629A657E9C8B9C8EAA91C5947D947E947C +9C779C789EF78C54947F9E1A72289A6A9B319E1B9E1E7C720000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 ADDED library/encoding/iso8859-11.enc Index: library/encoding/iso8859-11.enc ================================================================== --- /dev/null +++ library/encoding/iso8859-11.enc @@ -0,0 +1,20 @@ +# Encoding file: iso8859-11, single-byte +S +003F 0 1 +00 +0000000100020003000400050006000700080009000A000B000C000D000E000F +0010001100120013001400150016001700180019001A001B001C001D001E001F +0020002100220023002400250026002700280029002A002B002C002D002E002F +0030003100320033003400350036003700380039003A003B003C003D003E003F +0040004100420043004400450046004700480049004A004B004C004D004E004F +0050005100520053005400550056005700580059005A005B005C005D005E005F +0060006100620063006400650066006700680069006A006B006C006D006E006F +0070007100720073007400750076007700780079007A007B007C007D007E007F +0080008100820083008400850086008700880089008A008B008C008D008E008F +0090009100920093009400950096009700980099009A009B009C009D009E009F +00A00E010E020E030E040E050E060E070E080E090E0A0E0B0E0C0E0D0E0E0E0F +0E100E110E120E130E140E150E160E170E180E190E1A0E1B0E1C0E1D0E1E0E1F +0E200E210E220E230E240E250E260E270E280E290E2A0E2B0E2C0E2D0E2E0E2F +0E300E310E320E330E340E350E360E370E380E390E3A00000000000000000E3F +0E400E410E420E430E440E450E460E470E480E490E4A0E4B0E4C0E4D0E4E0E4F +0E500E510E520E530E540E550E560E570E580E590E5A0E5B0000000000000000 Index: library/encoding/iso8859-7.enc ================================================================== --- library/encoding/iso8859-7.enc +++ library/encoding/iso8859-7.enc @@ -10,11 +10,11 @@ 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F 0070007100720073007400750076007700780079007A007B007C007D007E007F 0080008100820083008400850086008700880089008A008B008C008D008E008F 0090009100920093009400950096009700980099009A009B009C009D009E009F -00A02018201900A30000000000A600A700A800A9000000AB00AC00AD00002015 +00A02018201900A320AC20AF00A600A700A800A9037A00AB00AC00AD00002015 00B000B100B200B303840385038600B703880389038A00BB038C00BD038E038F 0390039103920393039403950396039703980399039A039B039C039D039E039F 03A003A1000003A303A403A503A603A703A803A903AA03AB03AC03AD03AE03AF 03B003B103B203B303B403B503B603B703B803B903BA03BB03BC03BD03BE03BF 03C003C103C203C303C403C503C603C703C803C903CA03CB03CC03CD03CE0000 Index: library/history.tcl ================================================================== --- library/history.tcl +++ library/history.tcl @@ -2,126 +2,187 @@ # # Implementation of the history command. # # 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. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. # - -# The tcl::history array holds the history list and some additional -# bookkeeping variables. + +# The tcl::history array holds the history list and +# some additional bookkeeping variables. # # nextid the index used for the next history list item. # keep the max size of the history list # oldest the index of the oldest item in the history. -namespace eval ::tcl { +namespace eval tcl { variable history if {![info exists history]} { array set history { nextid 0 keep 20 oldest -20 } } - - namespace ensemble create -command ::tcl::history -map { - add ::tcl::HistAdd - change ::tcl::HistChange - clear ::tcl::HistClear - event ::tcl::HistEvent - info ::tcl::HistInfo - keep ::tcl::HistKeep - nextid ::tcl::HistNextID - redo ::tcl::HistRedo - } -} - +} + # history -- # # This is the main history command. See the man page for its interface. -# This does some argument checking and calls the helper ensemble in the -# tcl namespace. - -proc ::history {args} { - # If no command given, we're doing 'history info'. Can't be done with an - # ensemble unknown handler, as those don't fire when no subcommand is - # given at all. - - if {![llength $args]} { - set args info - } - - # Tricky stuff needed to make stack and errors come out right! - tailcall apply {arglist {tailcall history {*}$arglist} ::tcl} $args -} - -# (unnamed) -- -# -# Callback when [::history] is destroyed. Destroys the implementation. -# -# Parameters: -# oldName what the command was called. -# newName what the command is now called (an empty string). -# op the operation (= delete). -# -# Results: -# none -# -# Side Effects: -# The implementation of the [::history] command ceases to exist. - -trace add command ::history delete [list apply {{oldName newName op} { - variable history - unset -nocomplain history - foreach c [info procs ::tcl::Hist*] { - rename $c {} - } - rename ::tcl::history {} -} ::tcl}] - +# This does argument checking and calls helper procedures in the +# history namespace. + +proc history {args} { + set len [llength $args] + if {$len == 0} { + return [tcl::HistInfo] + } + set key [lindex $args 0] + set options "add, change, clear, event, info, keep, nextid, or redo" + switch -glob -- $key { + a* { # history add + + if {$len > 3} { + return -code error "wrong # args: should be \"history add event ?exec?\"" + } + if {![string match $key* add]} { + return -code error "bad option \"$key\": must be $options" + } + if {$len == 3} { + set arg [lindex $args 2] + if {! ([string match e* $arg] && [string match $arg* exec])} { + return -code error "bad argument \"$arg\": should be \"exec\"" + } + } + return [tcl::HistAdd [lindex $args 1] [lindex $args 2]] + } + ch* { # history change + + if {($len > 3) || ($len < 2)} { + return -code error "wrong # args: should be \"history change newValue ?event?\"" + } + if {![string match $key* change]} { + return -code error "bad option \"$key\": must be $options" + } + if {$len == 2} { + set event 0 + } else { + set event [lindex $args 2] + } + + return [tcl::HistChange [lindex $args 1] $event] + } + cl* { # history clear + + if {($len > 1)} { + return -code error "wrong # args: should be \"history clear\"" + } + if {![string match $key* clear]} { + return -code error "bad option \"$key\": must be $options" + } + return [tcl::HistClear] + } + e* { # history event + + if {$len > 2} { + return -code error "wrong # args: should be \"history event ?event?\"" + } + if {![string match $key* event]} { + return -code error "bad option \"$key\": must be $options" + } + if {$len == 1} { + set event -1 + } else { + set event [lindex $args 1] + } + return [tcl::HistEvent $event] + } + i* { # history info + + if {$len > 2} { + return -code error "wrong # args: should be \"history info ?count?\"" + } + if {![string match $key* info]} { + return -code error "bad option \"$key\": must be $options" + } + return [tcl::HistInfo [lindex $args 1]] + } + k* { # history keep + + if {$len > 2} { + return -code error "wrong # args: should be \"history keep ?count?\"" + } + if {$len == 1} { + return [tcl::HistKeep] + } else { + set limit [lindex $args 1] + if {[catch {expr {~$limit}}] || ($limit < 0)} { + return -code error "illegal keep count \"$limit\"" + } + return [tcl::HistKeep $limit] + } + } + n* { # history nextid + + if {$len > 1} { + return -code error "wrong # args: should be \"history nextid\"" + } + if {![string match $key* nextid]} { + return -code error "bad option \"$key\": must be $options" + } + return [expr {$tcl::history(nextid) + 1}] + } + r* { # history redo + + if {$len > 2} { + return -code error "wrong # args: should be \"history redo ?event?\"" + } + if {![string match $key* redo]} { + return -code error "bad option \"$key\": must be $options" + } + return [tcl::HistRedo [lindex $args 1]] + } + default { + return -code error "bad option \"$key\": must be $options" + } + } +} + # tcl::HistAdd -- # # Add an item to the history, and optionally eval it at the global scope # # Parameters: -# event the command to add -# exec (optional) a substring of "exec" causes the command to -# be evaled. +# command the command to add +# exec (optional) a substring of "exec" causes the +# command to be evaled. # Results: # If executing, then the results of the command are returned # # Side Effects: # Adds to the history list -proc ::tcl::HistAdd {event {exec {}}} { - variable history - - if { - [prefix longest {exec {}} $exec] eq "" - && [llength [info level 0]] == 3 - } then { - return -code error "bad argument \"$exec\": should be \"exec\"" - } - - # Do not add empty commands to the history - if {[string trim $event] eq ""} { - return "" - } - - # Maintain the history - set history([incr history(nextid)]) $event - unset -nocomplain history([incr history(oldest)]) - - # Only execute if 'exec' (or non-empty prefix of it) given - if {$exec eq ""} { - return "" - } - tailcall eval $event -} - + proc tcl::HistAdd {command {exec {}}} { + variable history + + # Do not add empty commands to the history + if {[string trim $command] eq ""} { + return "" + } + + set i [incr history(nextid)] + set history($i) $command + set j [incr history(oldest)] + unset -nocomplain history($j) + if {[string match e* $exec]} { + return [uplevel #0 $command] + } else { + return {} + } +} + # tcl::HistKeep -- # # Set or query the limit on the length of the history list # # Parameters: @@ -131,26 +192,24 @@ # If no limit is specified, the current limit is returned # # Side Effects: # Updates history(keep) if a limit is specified -proc ::tcl::HistKeep {{count {}}} { + proc tcl::HistKeep {{limit {}}} { variable history - if {[llength [info level 0]] == 1} { + if {$limit eq ""} { return $history(keep) - } - if {![string is integer -strict $count] || ($count < 0)} { - return -code error "illegal keep count \"$count\"" - } - set oldold $history(oldest) - set history(oldest) [expr {$history(nextid) - $count}] - for {} {$oldold <= $history(oldest)} {incr oldold} { - unset -nocomplain history($oldold) - } - set history(keep) $count -} - + } else { + set oldold $history(oldest) + set history(oldest) [expr {$history(nextid) - $limit}] + for {} {$oldold <= $history(oldest)} {incr oldold} { + unset -nocomplain history($oldold) + } + set history(keep) $limit + } +} + # tcl::HistClear -- # # Erase the history list # # Parameters: @@ -160,21 +219,21 @@ # none # # Side Effects: # Resets the history array, except for the keep limit -proc ::tcl::HistClear {} { + proc tcl::HistClear {} { variable history set keep $history(keep) unset history array set history [list \ nextid 0 \ keep $keep \ oldest -$keep \ ] } - + # tcl::HistInfo -- # # Return a pretty-printed version of the history list # # Parameters: @@ -181,20 +240,18 @@ # num (optional) the length of the history list to return # # Results: # A formatted history list -proc ::tcl::HistInfo {{count {}}} { + proc tcl::HistInfo {{num {}}} { variable history - if {[llength [info level 0]] == 1} { - set count [expr {$history(keep) + 1}] - } elseif {![string is integer -strict $count]} { - return -code error "bad integer \"$count\"" + if {$num eq ""} { + set num [expr {$history(keep) + 1}] } set result {} set newline "" - for {set i [expr {$history(nextid) - $count + 1}]} \ + for {set i [expr {$history(nextid) - $num + 1}]} \ {$i <= $history(nextid)} {incr i} { if {![info exists history($i)]} { continue } set cmd [string map [list \n \n\t] [string trimright $history($i) \ \n]] @@ -201,15 +258,15 @@ append result $newline[format "%6d %s" $i $cmd] set newline \n } return $result } - + # tcl::HistRedo -- # -# Fetch the previous or specified event, execute it, and then replace -# the current history item with that event. +# Fetch the previous or specified event, execute it, and then +# replace the current history item with that event. # # Parameters: # event (optional) index of history item to redo. Defaults to -1, # which means the previous event. # @@ -217,47 +274,49 @@ # Those of the command being redone. # # Side Effects: # Replaces the current history list item with the one being redone. -proc ::tcl::HistRedo {{event -1}} { + proc tcl::HistRedo {{event -1}} { variable history - + if {$event eq ""} { + set event -1 + } set i [HistIndex $event] if {$i == $history(nextid)} { return -code error "cannot redo the current event" } set cmd $history($i) HistChange $cmd 0 - tailcall eval $cmd + uplevel #0 $cmd } - + # tcl::HistIndex -- # # Map from an event specifier to an index in the history list. # # Parameters: # event index of history item to redo. # If this is a positive number, it is used directly. # If it is a negative number, then it counts back to a previous # event, where -1 is the most recent event. -# A string can be matched, either by being the prefix of a -# command or by matching a command with string match. +# A string can be matched, either by being the prefix of +# a command or by matching a command with string match. # # Results: # The index into history, or an error if the index didn't match. -proc ::tcl::HistIndex {event} { + proc tcl::HistIndex {event} { variable history - if {![string is integer -strict $event]} { + if {[catch {expr {~$event}}]} { for {set i [expr {$history(nextid)-1}]} {[info exists history($i)]} \ {incr i -1} { if {[string match $event* $history($i)]} { - return $i + return $i; } if {[string match $event $history($i)]} { - return $i + return $i; } } return -code error "no event matches \"$event\"" } elseif {$event <= 0} { set i [expr {$history(nextid) + $event}] @@ -270,66 +329,45 @@ if {$i > $history(nextid)} { return -code error "event \"$event\" hasn't occured yet" } return $i } - + # tcl::HistEvent -- # # Map from an event specifier to the value in the history list. # # Parameters: -# event index of history item to redo. See index for a description of -# possible event patterns. +# event index of history item to redo. See index for a +# description of possible event patterns. # # Results: # The value from the history list. -proc ::tcl::HistEvent {{event -1}} { + proc tcl::HistEvent {event} { variable history set i [HistIndex $event] - if {![info exists history($i)]} { - return "" + if {[info exists history($i)]} { + return [string trimright $history($i) \ \n] + } else { + return ""; } - return [string trimright $history($i) \ \n] } - + # tcl::HistChange -- # # Replace a value in the history list. # # Parameters: -# newValue The new value to put into the history list. -# event (optional) index of history item to redo. See index for a -# description of possible event patterns. This defaults to 0, -# which specifies the current event. +# cmd The new value to put into the history list. +# event (optional) index of history item to redo. See index for a +# description of possible event patterns. This defaults +# to 0, which specifies the current event. # # Side Effects: # Changes the history list. -proc ::tcl::HistChange {newValue {event 0}} { + proc tcl::HistChange {cmd {event 0}} { variable history set i [HistIndex $event] - set history($i) $newValue -} - -# tcl::HistNextID -- -# -# Returns the number of the next history event. -# -# Parameters: -# None. -# -# Side Effects: -# None. - -proc ::tcl::HistNextID {} { - variable history - return [expr {$history(nextid) + 1}] -} - -return - -# Local Variables: -# mode: tcl -# fill-column: 78 -# End: + set history($i) $cmd +} Index: library/http/http.tcl ================================================================== --- library/http/http.tcl +++ library/http/http.tcl @@ -6,48 +6,28 @@ # 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- +package require Tcl 8.4 # Keep this in sync with pkgIndex.tcl and with the install directories in # Makefiles -package provide http 2.10.0a1 +package provide http 2.7.15 namespace eval http { # Allow resourcing to not clobber existing data variable http if {![info exists http]} { array set http { -accept */* - -cookiejar {} - -pipeline 1 - -postfresh 0 -proxyhost {} -proxyport {} -proxyfilter http::ProxyRequired - -repost 0 -urlencoding utf-8 - -zip 1 - } - # We need a useragent string of this style or various servers will - # refuse to send us compressed content even when we ask for it. This - # follows the de-facto layout of user-agent strings in current browsers. - # Safe interpreters do not have ::tcl_platform(os) or - # ::tcl_platform(osVersion). - if {[interp issafe]} { - set http(-useragent) "Mozilla/5.0\ - (Windows; U;\ - Windows NT 10.0)\ - http/[package provide http] Tcl/[package provide Tcl]" - } else { - set http(-useragent) "Mozilla/5.0\ - ([string totitle $::tcl_platform(platform)]; U;\ - $::tcl_platform(os) $::tcl_platform(osVersion))\ - http/[package provide http] Tcl/[package provide Tcl]" - } + } + set http(-useragent) "Tcl http client package [package provide http]" } proc init {} { # Set up the map for quoting chars. RFC3986 Section 2.3 say percent # encode all except: "... percent-encoded octets in the ranges of @@ -63,46 +43,18 @@ # These are handled specially set map(\n) %0D%0A variable formMap [array get map] # Create a map for HTTP/1.1 open sockets - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketClosing - variable socketPlayCmd - if {[info exists socketMapping]} { - # Close open sockets on re-init. Do not permit retries. - foreach {url sock} [array get socketMapping] { - unset -nocomplain socketClosing($url) - unset -nocomplain socketPlayCmd($url) - CloseSocket $sock - } - } - - # CloseSocket should have unset the socket* arrays, one element at - # a time. Now unset anything that was overlooked. - # Traces on "unset socketRdState(*)" will call CancelReadPipeline and - # cancel any queued responses. - # Traces on "unset socketWrState(*)" will call CancelWritePipeline and - # cancel any queued requests. - array unset socketMapping - array unset socketRdState - array unset socketWrState - array unset socketRdQueue - array unset socketWrQueue - array unset socketClosing - array unset socketPlayCmd - array set socketMapping {} - array set socketRdState {} - array set socketWrState {} - array set socketRdQueue {} - array set socketWrQueue {} - array set socketClosing {} - array set socketPlayCmd {} + variable socketmap + if {[info exists socketmap]} { + # Close but don't remove open sockets on re-init + foreach {url sock} [array get socketmap] { + catch {close $sock} + } + } + array set socketmap {} } init variable urlTypes if {![info exists urlTypes]} { @@ -126,29 +78,12 @@ variable defaultKeepalive if {![info exists defaultKeepalive]} { set defaultKeepalive 0 } - # Regular expression used to parse cookies - variable CookieRE {(?x) # EXPANDED SYNTAX - \s* # Ignore leading spaces - ([^][\u0000- ()<>@,;:\\""/?={}\u007f-\uffff]+) # Match the name - = # LITERAL: Equal sign - ([!\u0023-+\u002D-:<-\u005B\u005D-~]*) # Match the value - (?: - \s* ; \s* # LITERAL: semicolon - ([^\u0000]+) # Match the options - )? - } - - namespace export geturl config reset wait formatQuery quoteString - namespace export register unregister registerError - # - Useful, but not exported: data, size, status, code, cleanup, error, - # meta, ncode, mapReply, init. Comments suggest that "init" can be used - # for re-initialisation, although the command is undocumented. - # - Not exported, probably should be upper-case initial letter as part - # of the internals: getTextLine, make-transformation-chunked. + namespace export geturl config reset wait formatQuery register unregister + # Useful, but not exported: data size status code } # http::Log -- # # Debugging output -- define this to observe HTTP/1.1 socket usage. @@ -155,11 +90,11 @@ # Should echo any args received. # # Arguments: # msg Message to output # -if {[info command http::Log] eq {}} {proc http::Log {args} {}} +proc http::Log {args} {} # http::register -- # # See documentation for details. # @@ -238,419 +173,86 @@ # Clean up the socket and eval close time callbacks # # Arguments: # token Connection token. # errormsg (optional) If set, forces status to error. -# skipCB (optional) If set, don't call the -command callback. This +# skipCB (optional) If set, don't call the -command callback. This # is useful when geturl wants to throw an exception instead # of calling the callback. That way, the same error isn't # reported to two places. # # Side Effects: -# May close the socket. +# Closes the socket proc http::Finish {token {errormsg ""} {skipCB 0}} { - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketClosing - variable socketPlayCmd - variable $token upvar 0 $token state global errorInfo errorCode - set closeQueue 0 if {$errormsg ne ""} { set state(error) [list $errormsg $errorInfo $errorCode] set state(status) "error" } - if {[info commands ${token}EventCoroutine] ne {}} { - rename ${token}EventCoroutine {} - } - if { ($state(status) eq "timeout") - || ($state(status) eq "error") - || ($state(status) eq "eof") - || ([info exists state(-keepalive)] && !$state(-keepalive)) - || ([info exists state(connection)] && ($state(connection) eq "close")) - } { - set closeQueue 1 - set connId $state(socketinfo) - set sock $state(sock) - CloseSocket $state(sock) $token - } elseif { - ([info exists state(-keepalive)] && $state(-keepalive)) - && ([info exists state(connection)] && ($state(connection) ne "close")) - } { - KeepSocket $token + if { + ($state(status) eq "timeout") || ($state(status) eq "error") || + ([info exists state(connection)] && ($state(connection) eq "close")) + } then { + CloseSocket $state(sock) $token } if {[info exists state(after)]} { after cancel $state(after) - unset state(after) } - if {[info exists state(-command)] && (!$skipCB) - && (![info exists state(done-command-cb)])} { + if {[info exists state(-command)] && !$skipCB + && ![info exists state(done-command-cb)]} { set state(done-command-cb) yes if {[catch {eval $state(-command) {$token}} err] && $errormsg eq ""} { set state(error) [list $err $errorInfo $errorCode] set state(status) error } } - - if { $closeQueue - && [info exists socketMapping($connId)] - && ($socketMapping($connId) eq $sock) - } { - http::CloseQueuedQueries $connId $token - } -} - -# http::KeepSocket - -# -# Keep a socket in the persistent sockets table and connect it to its next -# queued task if possible. Otherwise leave it idle and ready for its next -# use. -# -# If $socketClosing(*), then ($state(connection) eq "close") and therefore -# this command will not be called by Finish. -# -# Arguments: -# token Connection token. - -proc http::KeepSocket {token} { - variable http - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketClosing - variable socketPlayCmd - - variable $token - upvar 0 $token state - set tk [namespace tail $token] - - # Keep this socket open for another request ("Keep-Alive"). - # React if the server half-closes the socket. - # Discussion is in http::geturl. - catch {fileevent $state(sock) readable [list http::CheckEof $state(sock)]} - - # The line below should not be changed in production code. - # It is edited by the test suite. - set TEST_EOF 0 - if {$TEST_EOF} { - # ONLY for testing reaction to server eof. - # No server timeouts will be caught. - catch {fileevent $state(sock) readable {}} - } - - if { [info exists state(socketinfo)] - && [info exists socketMapping($state(socketinfo))] - } { - set connId $state(socketinfo) - # The value "Rready" is set only here. - set socketRdState($connId) Rready - - if { $state(-pipeline) - && [info exists socketRdQueue($connId)] - && [llength $socketRdQueue($connId)] - } { - # The usual case for pipelined responses - if another response is - # queued, arrange to read it. - set token3 [lindex $socketRdQueue($connId) 0] - set socketRdQueue($connId) [lrange $socketRdQueue($connId) 1 end] - variable $token3 - upvar 0 $token3 state3 - set tk2 [namespace tail $token3] - - #Log pipelined, GRANT read access to $token3 in KeepSocket - set socketRdState($connId) $token3 - ReceiveResponse $token3 - - # Other pipelined cases. - # - The test above ensures that, for the pipelined cases in the two - # tests below, the read queue is empty. - # - In those two tests, check whether the next write will be - # nonpipeline. - } elseif { - $state(-pipeline) - && [info exists socketWrState($connId)] - && ($socketWrState($connId) eq "peNding") - - && [info exists socketWrQueue($connId)] - && [llength $socketWrQueue($connId)] - && (![set token3 [lindex $socketWrQueue($connId) 0] - set ${token3}(-pipeline) - ] - ) - } { - # This case: - # - Now it the time to run the "pending" request. - # - The next token in the write queue is nonpipeline, and - # socketWrState has been marked "pending" (in - # http::NextPipelinedWrite or http::geturl) so a new pipelined - # request cannot jump the queue. - # - # Tests: - # - In this case the read queue (tested above) is empty and this - # "pending" write token is in front of the rest of the write - # queue. - # - The write state is not Wready and therefore appears to be busy, - # but because it is "pending" we know that it is reserved for the - # first item in the write queue, a non-pipelined request that is - # waiting for the read queue to empty. That has now happened: so - # give that request read and write access. - variable $token3 - set conn [set ${token3}(tmpConnArgs)] - #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket - set socketRdState($connId) $token3 - set socketWrState($connId) $token3 - set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] - # Connect does its own fconfigure. - fileevent $state(sock) writable [list http::Connect $token3 {*}$conn] - #Log ---- $state(sock) << conn to $token3 for HTTP request (c) - - } elseif { - $state(-pipeline) - && [info exists socketWrState($connId)] - && ($socketWrState($connId) eq "peNding") - - } { - # Should not come here. The second block in the previous "elseif" - # test should be tautologous (but was needed in an earlier - # implementation) and will be removed after testing. - # If we get here, the value "pending" was assigned in error. - # This error would block the queue for ever. - Log ^X$tk <<<<< Error in queueing of requests >>>>> - token $token - - } elseif { - $state(-pipeline) - && [info exists socketWrState($connId)] - && ($socketWrState($connId) eq "Wready") - - && [info exists socketWrQueue($connId)] - && [llength $socketWrQueue($connId)] - && (![set token3 [lindex $socketWrQueue($connId) 0] - set ${token3}(-pipeline) - ] - ) - } { - # This case: - # - The next token in the write queue is nonpipeline, and - # socketWrState is Wready. Get the next event from socketWrQueue. - # Tests: - # - In this case the read state (tested above) is Rready and the - # write state (tested here) is Wready - there is no "pending" - # request. - # Code: - # - The code is the same as the code below for the nonpipelined - # case with a queued request. - variable $token3 - set conn [set ${token3}(tmpConnArgs)] - #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket - set socketRdState($connId) $token3 - set socketWrState($connId) $token3 - set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] - # Connect does its own fconfigure. - fileevent $state(sock) writable [list http::Connect $token3 {*}$conn] - #Log ---- $state(sock) << conn to $token3 for HTTP request (c) - - } elseif { - (!$state(-pipeline)) - && [info exists socketWrQueue($connId)] - && [llength $socketWrQueue($connId)] - && ($state(connection) ne "close") - } { - # If not pipelined, (socketRdState eq Rready) tells us that we are - # ready for the next write - there is no need to check - # socketWrState. Write the next request, if one is waiting. - # If the next request is pipelined, it receives premature read - # access to the socket. This is not a problem. - set token3 [lindex $socketWrQueue($connId) 0] - variable $token3 - set conn [set ${token3}(tmpConnArgs)] - #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket - set socketRdState($connId) $token3 - set socketWrState($connId) $token3 - set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] - # Connect does its own fconfigure. - fileevent $state(sock) writable [list http::Connect $token3 {*}$conn] - #Log ---- $state(sock) << conn to $token3 for HTTP request (d) - - } elseif {(!$state(-pipeline))} { - set socketWrState($connId) Wready - # Rready and Wready and idle: nothing to do. - } - - } else { - CloseSocket $state(sock) $token - # There is no socketMapping($state(socketinfo)), so it does not matter - # that CloseQueuedQueries is not called. - } -} - -# http::CheckEof - -# -# Read from a socket and close it if eof. -# The command is bound to "fileevent readable" on an idle socket, and -# "eof" is the only event that should trigger the binding, occurring when -# the server times out and half-closes the socket. -# -# A read is necessary so that [eof] gives a meaningful result. -# Any bytes sent are junk (or a bug). - -proc http::CheckEof {sock} { - set junk [read $sock] - set n [string length $junk] - if {$n} { - Log "WARNING: $n bytes received but no HTTP request sent" - } - - if {[catch {eof $sock} res] || $res} { - # The server has half-closed the socket. - # If a new write has started, its transaction will fail and - # will then be error-handled. - CloseSocket $sock - } } # http::CloseSocket - # # Close a socket and remove it from the persistent sockets table. If # possible an http token is included here but when we are called from a # fileevent on remote closure we need to find the correct entry - hence -# the "else" block of the first "if" command. - -proc http::CloseSocket {s {token {}}} { - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketClosing - variable socketPlayCmd - - set tk [namespace tail $token] - +# the second section. + +proc ::http::CloseSocket {s {token {}}} { + variable socketmap catch {fileevent $s readable {}} - set connId {} + set conn_id {} if {$token ne ""} { - variable $token - upvar 0 $token state - if {[info exists state(socketinfo)]} { - set connId $state(socketinfo) - } + variable $token + upvar 0 $token state + if {[info exists state(socketinfo)]} { + set conn_id $state(socketinfo) + } } else { - set map [array get socketMapping] - set ndx [lsearch -exact $map $s] - if {$ndx >= 0} { + set map [array get socketmap] + set ndx [lsearch -exact $map $s] + if {$ndx != -1} { incr ndx -1 - set connId [lindex $map $ndx] - } - } - if { ($connId ne {}) - && [info exists socketMapping($connId)] - && ($socketMapping($connId) eq $s) - } { - Log "Closing connection $connId (sock $socketMapping($connId))" - if {[catch {close $socketMapping($connId)} err]} { - Log "Error closing connection: $err" - } - if {$token eq {}} { - # Cases with a non-empty token are handled by Finish, so the tokens - # are finished in connection order. - http::CloseQueuedQueries $connId - } - } else { - Log "Closing socket $s (no connection info)" - if {[catch {close $s} err]} { - Log "Error closing socket: $err" - } - } -} - -# http::CloseQueuedQueries -# -# connId - identifier "domain:port" for the connection -# token - (optional) used only for logging -# -# Called from http::CloseSocket and http::Finish, after a connection is closed, -# to clear the read and write queues if this has not already been done. - -proc http::CloseQueuedQueries {connId {token {}}} { - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketClosing - variable socketPlayCmd - - if {![info exists socketMapping($connId)]} { - # Command has already been called. - # Don't come here again - especially recursively. - return - } - - # Used only for logging. - if {$token eq {}} { - set tk {} - } else { - set tk [namespace tail $token] - } - - if { [info exists socketPlayCmd($connId)] - && ($socketPlayCmd($connId) ne {ReplayIfClose Wready {} {}}) - } { - # Before unsetting, there is some unfinished business. - # - If the server sent "Connection: close", we have stored the command - # for retrying any queued requests in socketPlayCmd, so copy that - # value for execution below. socketClosing(*) was also set. - # - Also clear the queues to prevent calls to Finish that would set the - # state for the requests that will be retried to "finished with error - # status". - set unfinished $socketPlayCmd($connId) - set socketRdQueue($connId) {} - set socketWrQueue($connId) {} - } else { - set unfinished {} - } - - Unset $connId - - if {$unfinished ne {}} { - Log ^R$tk Any unfinished transactions (excluding $token) failed \ - - token $token - {*}$unfinished - } -} - -# http::Unset -# -# The trace on "unset socketRdState(*)" will call CancelReadPipeline -# and cancel any queued responses. -# The trace on "unset socketWrState(*)" will call CancelWritePipeline -# and cancel any queued requests. - -proc http::Unset {connId} { - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketClosing - variable socketPlayCmd - - unset socketMapping($connId) - unset socketRdState($connId) - unset socketWrState($connId) - unset -nocomplain socketRdQueue($connId) - unset -nocomplain socketWrQueue($connId) - unset -nocomplain socketClosing($connId) - unset -nocomplain socketPlayCmd($connId) + set conn_id [lindex $map $ndx] + } + } + if {$conn_id eq {} || ![info exists socketmap($conn_id)]} { + Log "Closing socket $s (no connection info)" + if {[catch {close $s} err]} { + Log "Error: $err" + } + } else { + if {[info exists socketmap($conn_id)]} { + Log "Closing connection $conn_id (sock $socketmap($conn_id))" + if {[catch {close $socketmap($conn_id)} err]} { + Log "Error: $err" + } + unset socketmap($conn_id) + } else { + Log "Cannot close connection $conn_id - no socket in socket map" + } + } } # http::reset -- # # See documentation for details. @@ -658,11 +260,11 @@ # Arguments: # token Connection token. # why Status info. # # Side Effects: -# See Finish +# See Finish proc http::reset {token {why reset}} { variable $token upvar 0 $token state set state(status) $why @@ -679,12 +281,12 @@ # http::geturl -- # # Establishes a connection to a remote url via http. # # Arguments: -# url The http URL to goget. -# args Option value pairs. Valid options include: +# url The http URL to goget. +# args Option value pairs. Valid options include: # -blocksize, -validate, -headers, -timeout # Results: # Returns a token for this connection. This token is the name of an # array that the caller should unset to garbage collect the state. @@ -700,16 +302,13 @@ if {![info exists http(uid)]} { set http(uid) 0 } set token [namespace current]::[incr http(uid)] - ##Log Starting http::geturl - token $token variable $token upvar 0 $token state - set tk [namespace tail $token] reset $token - Log ^A$tk URL $url - token $token # Process command options. array set state { -binary false @@ -720,23 +319,22 @@ -timeout 0 -type application/x-www-form-urlencoded -queryprogress {} -protocol 1.1 binary 0 - state created + state connecting meta {} - method {} coding {} currentsize 0 totalsize 0 querylength 0 queryoffset 0 type text/html body {} status "" http "" - connection keep-alive + connection close } set state(-keepalive) $defaultKeepalive set state(-strict) $strict # These flags have their types verified [Bug 811170] array set type { @@ -744,11 +342,10 @@ -blocksize integer -queryblocksize integer -strict boolean -timeout integer -validate boolean - -headers dict } set state(charset) $defaultCharset set options { -binary -blocksize -channel -command -handler -headers -keepalive -method -myaddr -progress -protocol -query -queryblocksize @@ -758,13 +355,14 @@ set options [string map {- ""} $options] set pat ^-(?:[join $options |])$ foreach {flag value} $args { if {[regexp -- $pat $flag]} { # Validate numbers - if {($flag eq "-headers") ? [catch {dict size $value}] : - ([info exists type($flag)] && ![string is $type($flag) -strict $value]) - } { + if { + [info exists type($flag)] && + ![string is $type($flag) -strict $value] + } then { unset $token return -code error \ "Bad value for $flag ($value), must be $type($flag)" } set state($flag) $value @@ -815,10 +413,11 @@ # "/foo/bar.tml", the query is "q=foo", and the fragment is "changes". # # Note that the RE actually combines the user and password parts, as # recommended in RFC 3986. Indeed, that RFC states that putting passwords # in URLs is a Really Bad Idea, something with which I would agree utterly. + # Also note that we do not currently support IPv6 addresses. # # From a validation perspective, we need to ensure that the parts of the # URL that are going to the server are correctly encoded. This is only # done if $state(-strict) is true (inherited from $::http::strict). @@ -829,14 +428,11 @@ (?: ( [^@/\#?]+ # ) @ )? - ( # - [^/:\#?]+ | # host name or IPv4 address - \[ [^/\#?]+ \] # IPv6 address in square brackets - ) + ( [^/:\#?]+ ) # (?: : (\d+) )? # )? ( [/\?] [^\#]*)? # (including query) (?: \# (.*) )? # $ @@ -846,11 +442,10 @@ if {![regexp -- $URLmatcher $url -> proto user host port srvurl]} { unset $token return -code error "Unsupported URL: $url" } # Phase two: validate - set host [string trim $host {[]}]; # strip square brackets from IPv6 address if {$host eq ""} { # Caller has to provide a host name; we do not have a "default host" # that would enable us to handle relative URLs. unset $token return -code error "Missing host part: $url" @@ -903,16 +498,12 @@ return -code error \ "Illegal encoding character usage \"$bad\" in URL path" } return -code error "Illegal characters in URL path" } - if {![regexp {^[^?#]+} $srvurl state(path)]} { - set state(path) / - } } else { set srvurl / - set state(path) / } if {$proto eq ""} { set proto http } set lower [string tolower $proto] @@ -943,11 +534,18 @@ } append url $srvurl # Don't append the fragment! set state(url) $url + # If a timeout is specified we set up the after event and arrange for an + # asynchronous socket connection. + set sockopts [list -async] + if {$state(-timeout) > 0} { + set state(after) [after $state(-timeout) \ + [list http::reset $token timeout]] + } # If we are using the proxy, we must pass in the full URL that includes # the server name. if {[info exists phost] && ($phost ne "")} { @@ -957,315 +555,55 @@ set targetAddr [list $host $port] } # Proxy connections aren't shared among different hosts. set state(socketinfo) $host:$port - # Save the accept types at this point to prevent a race condition. [Bug - # c11a51c482] - set state(accept-types) $http(-accept) - - if {$isQuery || $isQueryChannel} { - # It's a POST. - # A client wishing to send a non-idempotent request SHOULD wait to send - # that request until it has received the response status for the - # previous request. - if {$http(-postfresh)} { - # Override -keepalive for a POST. Use a new connection, and thus - # avoid the small risk of a race against server timeout. - set state(-keepalive) 0 - } else { - # Allow -keepalive but do not -pipeline - wait for the previous - # transaction to finish. - # There is a small risk of a race against server timeout. - set state(-pipeline) 0 - } - } else { - # It's a GET or HEAD. - set state(-pipeline) $http(-pipeline) - } - - # We cannot handle chunked encodings with -handler, so force HTTP/1.0 - # until we can manage this. - if {[info exists state(-handler)]} { - set state(-protocol) 1.0 - } - - # RFC 7320 A.1 - HTTP/1.0 Keep-Alive is problematic. We do not support it. - if {$state(-protocol) eq "1.0"} { - set state(connection) close - set state(-keepalive) 0 - } - # See if we are supposed to use a previously opened channel. - # - In principle, ANY call to http::geturl could use a previously opened - # channel if it is available - the "Connection: keep-alive" header is a - # request to leave the channel open AFTER completion of this call. - # - In fact, we try to use an existing channel only if -keepalive 1 -- this - # means that at most one channel is left open for each value of - # $state(socketinfo). This property simplifies the mapping of open - # channels. - set reusing 0 - set alreadyQueued 0 if {$state(-keepalive)} { - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketClosing - variable socketPlayCmd - - if {[info exists socketMapping($state(socketinfo))]} { - # - If the connection is idle, it has a "fileevent readable" binding - # to http::CheckEof, in case the server times out and half-closes - # the socket (http::CheckEof closes the other half). - # - We leave this binding in place until just before the last - # puts+flush in http::Connected (GET/HEAD) or http::Write (POST), - # after which the HTTP response might be generated. - - if { [info exists socketClosing($state(socketinfo))] - && $socketClosing($state(socketinfo)) - } { - # socketClosing(*) is set because the server has sent a - # "Connection: close" header. - # Do not use the persistent socket again. - # Since we have only one persistent socket per server, and the - # old socket is not yet dead, add the request to the write queue - # of the dying socket, which will be replayed by ReplayIfClose. - # Also add it to socketWrQueue(*) which is used only if an error - # causes a call to Finish. - set reusing 1 - set sock $socketMapping($state(socketinfo)) - Log "reusing socket $sock for $state(socketinfo) - token $token" - - set alreadyQueued 1 - lassign $socketPlayCmd($state(socketinfo)) com0 com1 com2 com3 - lappend com3 $token - set socketPlayCmd($state(socketinfo)) [list $com0 $com1 $com2 $com3] - lappend socketWrQueue($state(socketinfo)) $token - } elseif {[catch {fconfigure $socketMapping($state(socketinfo))}]} { - # FIXME Is it still possible for this code to be executed? If - # so, this could be another place to call TestForReplay, - # rather than discarding the queued transactions. - Log "WARNING: socket for $state(socketinfo) was closed\ - - token $token" - Log "WARNING - if testing, pay special attention to this\ - case (GH) which is seldom executed - token $token" - - # This will call CancelReadPipeline, CancelWritePipeline, and - # cancel any queued requests, responses. - Unset $state(socketinfo) + variable socketmap + if {[info exists socketmap($state(socketinfo))]} { + if {[catch {fconfigure $socketmap($state(socketinfo))}]} { + Log "WARNING: socket for $state(socketinfo) was closed" + unset socketmap($state(socketinfo)) } else { - # Use the persistent socket. - # The socket may not be ready to write: an earlier request might - # still be still writing (in the pipelined case) or - # writing/reading (in the nonpipeline case). This possibility - # is handled by socketWrQueue later in this command. - set reusing 1 - set sock $socketMapping($state(socketinfo)) - Log "reusing socket $sock for $state(socketinfo) - token $token" - - } - # Do not automatically close the connection socket. - set state(connection) keep-alive - } - } - - if {$reusing} { - # Define state(tmpState) and state(tmpOpenCmd) for use - # by http::ReplayIfDead if the persistent connection has died. - set state(tmpState) [array get state] - - # Pass -myaddr directly to the socket command - if {[info exists state(-myaddr)]} { - lappend sockopts -myaddr $state(-myaddr) - } - - set state(tmpOpenCmd) [list {*}$defcmd {*}$sockopts {*}$targetAddr] - } - - set state(reusing) $reusing - # Excluding ReplayIfDead and the decision whether to call it, there are four - # places outside http::geturl where state(reusing) is used: - # - Connected - if reusing and not pipelined, start the state(-timeout) - # timeout (when writing). - # - DoneRequest - if reusing and pipelined, send the next pipelined write - # - Event - if reusing and pipelined, start the state(-timeout) - # timeout (when reading). - # - Event - if (not reusing) and pipelined, send the next pipelined - # write - - # See comments above re the start of this timeout in other cases. - if {(!$state(reusing)) && ($state(-timeout) > 0)} { - set state(after) [after $state(-timeout) \ - [list http::reset $token timeout]] - } - + set sock $socketmap($state(socketinfo)) + Log "reusing socket $sock for $state(socketinfo)" + catch {fileevent $sock writable {}} + catch {fileevent $sock readable {}} + } + } + # don't automatically close this connection socket + set state(connection) {} + } if {![info exists sock]} { # Pass -myaddr directly to the socket command if {[info exists state(-myaddr)]} { lappend sockopts -myaddr $state(-myaddr) } - set pre [clock milliseconds] - ##Log pre socket opened, - token $token - ##Log [concat $defcmd $sockopts $targetAddr] - token $token - if {[catch {eval $defcmd $sockopts $targetAddr} sock errdict]} { - # Something went wrong while trying to establish the connection. + if {[catch {eval $defcmd $sockopts $targetAddr} sock]} { + # something went wrong while trying to establish the connection. # Clean up after events and such, but DON'T call the command # callback (if available) because we're going to throw an # exception from here instead. - set state(sock) NONE - Finish $token $sock 1 + set state(sock) $sock + Finish $token "" 1 cleanup $token - dict unset errdict -level - return -options $errdict $sock - } else { - # Initialisation of a new socket. - ##Log post socket opened, - token $token - ##Log socket opened, now fconfigure - token $token - set delay [expr {[clock milliseconds] - $pre}] - if {$delay > 3000} { - Log socket delay $delay - token $token - } - fconfigure $sock -translation {auto crlf} \ - -buffersize $state(-blocksize) - ##Log socket opened, DONE fconfigure - token $token - } - } - # Command [socket] is called with -async, but takes 5s to 5.1s to return, - # with probability of order 1 in 10,000. This may be a bizarre scheduling - # issue with my (KJN's) system (Fedora Linux). - # This does not cause a problem (unless the request times out when this - # command returns). - + return -code error $sock + } + } set state(sock) $sock - Log "Using $sock for $state(socketinfo) - token $token" \ - [expr {$state(-keepalive)?"keepalive":""}] - - if { $state(-keepalive) - && (![info exists socketMapping($state(socketinfo))]) - } { - # Freshly-opened socket that we would like to become persistent. - set socketMapping($state(socketinfo)) $sock - - if {![info exists socketRdState($state(socketinfo))]} { - set socketRdState($state(socketinfo)) {} - set varName ::http::socketRdState($state(socketinfo)) - trace add variable $varName unset ::http::CancelReadPipeline - } - if {![info exists socketWrState($state(socketinfo))]} { - set socketWrState($state(socketinfo)) {} - set varName ::http::socketWrState($state(socketinfo)) - trace add variable $varName unset ::http::CancelWritePipeline - } - - if {$state(-pipeline)} { - #Log new, init for pipelined, GRANT write access to $token in geturl - # Also grant premature read access to the socket. This is OK. - set socketRdState($state(socketinfo)) $token - set socketWrState($state(socketinfo)) $token - } else { - # socketWrState is not used by this non-pipelined transaction. - # We cannot leave it as "Wready" because the next call to - # http::geturl with a pipelined transaction would conclude that the - # socket is available for writing. - #Log new, init for nonpipeline, GRANT r/w access to $token in geturl - set socketRdState($state(socketinfo)) $token - set socketWrState($state(socketinfo)) $token - } - - set socketRdQueue($state(socketinfo)) {} - set socketWrQueue($state(socketinfo)) {} - set socketClosing($state(socketinfo)) 0 - set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}} + Log "Using $sock for $state(socketinfo)" \ + [expr {$state(-keepalive)?"keepalive":""}] + if {$state(-keepalive)} { + set socketmap($state(socketinfo)) $sock } if {![info exists phost]} { set phost "" } - if {$reusing} { - # For use by http::ReplayIfDead if the persistent connection has died. - # Also used by NextPipelinedWrite. - set state(tmpConnArgs) [list $proto $phost $srvurl] - } - - # The element socketWrState($connId) has a value which is either the name of - # the token that is permitted to write to the socket, or "Wready" if no - # token is permitted to write. - # - # The code that sets the value to Wready immediately calls - # http::NextPipelinedWrite, which examines socketWrQueue($connId) and - # processes the next request in the queue, if there is one. The value - # Wready is not found when the interpreter is in the event loop unless the - # socket is idle. - # - # The element socketRdState($connId) has a value which is either the name of - # the token that is permitted to read from the socket, or "Rready" if no - # token is permitted to read. - # - # The code that sets the value to Rready then examines - # socketRdQueue($connId) and processes the next request in the queue, if - # there is one. The value Rready is not found when the interpreter is in - # the event loop unless the socket is idle. - - if {$alreadyQueued} { - # A write may or may not be in progress. There is no need to set - # socketWrState to prevent another call stealing write access - all - # subsequent calls on this socket will come here because the socket - # will close after the current read, and its - # socketClosing($connId) is 1. - ##Log "HTTP request for token $token is queued" - - } elseif { $reusing - && $state(-pipeline) - && ($socketWrState($state(socketinfo)) ne "Wready") - } { - ##Log "HTTP request for token $token is queued for pipelined use" - lappend socketWrQueue($state(socketinfo)) $token - - } elseif { $reusing - && (!$state(-pipeline)) - && ($socketWrState($state(socketinfo)) ne "Wready") - } { - # A write is queued or in progress. Lappend to the write queue. - ##Log "HTTP request for token $token is queued for nonpipeline use" - lappend socketWrQueue($state(socketinfo)) $token - - } elseif { $reusing - && (!$state(-pipeline)) - && ($socketWrState($state(socketinfo)) eq "Wready") - && ($socketRdState($state(socketinfo)) ne "Rready") - } { - # A read is queued or in progress, but not a write. Cannot start the - # nonpipeline transaction, but must set socketWrState to prevent a - # pipelined request jumping the queue. - ##Log "HTTP request for token $token is queued for nonpipeline use" - #Log re-use nonpipeline, GRANT delayed write access to $token in geturl - - set socketWrState($state(socketinfo)) peNding - lappend socketWrQueue($state(socketinfo)) $token - - } else { - if {$reusing && $state(-pipeline)} { - #Log re-use pipelined, GRANT write access to $token in geturl - set socketWrState($state(socketinfo)) $token - - } elseif {$reusing} { - # Cf tests above - both are ready. - #Log re-use nonpipeline, GRANT r/w access to $token in geturl - set socketRdState($state(socketinfo)) $token - set socketWrState($state(socketinfo)) $token - } - - # All (!$reusing) cases come here, and also some $reusing cases if the - # connection is ready. - #Log ---- $state(socketinfo) << conn to $token for HTTP request (a) - # Connect does its own fconfigure. - fileevent $sock writable \ - [list http::Connect $token $proto $phost $srvurl] - } + fileevent $sock writable [list http::Connect $token $proto $phost $srvurl] # Wait for the connection to complete. if {![info exists state(-command)]} { # geturl does EVERYTHING asynchronously, so if the user # calls it synchronously, we just do a wait here. @@ -1284,63 +622,35 @@ set err [lindex $state(error) 0] cleanup $token return -code error $err } } - ##Log Leaving http::geturl - token $token + return $token } -# http::Connected -- -# -# Callback used when the connection to the HTTP server is actually -# established. -# -# Arguments: -# token State token. -# proto What protocol (http, https, etc.) was used to connect. -# phost Are we using keep-alive? Non-empty if yes. -# srvurl Service-local URL that we're requesting -# Results: -# None. - -proc http::Connected {token proto phost srvurl} { + +proc http::Connected { token proto phost srvurl} { variable http variable urlTypes - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketClosing - variable socketPlayCmd variable $token upvar 0 $token state - set tk [namespace tail $token] - - if {$state(reusing) && (!$state(-pipeline)) && ($state(-timeout) > 0)} { - set state(after) [after $state(-timeout) \ - [list http::reset $token timeout]] - } - - # Set back the variables needed here. + + # Set back the variables needed here set sock $state(sock) set isQueryChannel [info exists state(-querychannel)] set isQuery [info exists state(-query)] set host [lindex [split $state(socketinfo) :] 0] set port [lindex [split $state(socketinfo) :] 1] set lower [string tolower $proto] set defport [lindex $urlTypes($lower) 0] - # Send data in cr-lf format, but accept any line terminators. - # Initialisation to {auto *} now done in geturl, KeepSocket and DoneRequest. - # We are concerned here with the request (write) not the response (read). - lassign [fconfigure $sock -translation] trRead trWrite - fconfigure $sock -translation [list $trRead crlf] \ - -buffersize $state(-blocksize) + # Send data in cr-lf format, but accept any line terminators + + fconfigure $sock -translation {auto crlf} -buffersize $state(-blocksize) # The following is disallowed in safe interpreters, but the socket is # already in non-blocking mode in that case. catch {fconfigure $sock -blocking off} @@ -1362,91 +672,71 @@ # 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 "")} { + if {[info exists state(-method)] && $state(-method) ne ""} { set how $state(-method) } - set accept_types_seen 0 - - Log ^B$tk begin sending request - token $token if {[catch { - set state(method) $how puts $sock "$how $srvurl HTTP/$state(-protocol)" - if {[dict exists $state(-headers) Host]} { + puts $sock "Accept: $http(-accept)" + array set hdrs $state(-headers) + if {[info exists hdrs(Host)]} { # Allow Host spoofing. [Bug 928154] - set hostHdr [dict get $state(-headers) Host] - regexp {^[^:]+} $hostHdr state(host) - puts $sock "Host: $hostHdr" + puts $sock "Host: $hdrs(Host)" } elseif {$port == $defport} { # Don't add port in this case, to handle broken servers. [Bug # #504508] - set state(host) $host puts $sock "Host: $host" } else { - set state(host) $host puts $sock "Host: $host:$port" } + unset hdrs puts $sock "User-Agent: $http(-useragent)" - if {($state(-protocol) > 1.0) && $state(-keepalive)} { - # Send this header, because a 1.1 server is not compelled to treat - # this as the default. + if {$state(-protocol) == 1.0 && $state(-keepalive)} { puts $sock "Connection: keep-alive" - } - if {($state(-protocol) > 1.0) && !$state(-keepalive)} { + } + if {$state(-protocol) > 1.0 && !$state(-keepalive)} { puts $sock "Connection: close" ;# RFC2616 sec 8.1.2.1 - } - if {($state(-protocol) < 1.1)} { - # RFC7230 A.1 - # Some server implementations of HTTP/1.0 have a faulty - # implementation of RFC 2068 Keep-Alive. - # Don't leave this to chance. - # For HTTP/1.0 we have already "set state(connection) close" - # and "state(-keepalive) 0". - puts $sock "Connection: close" - } - # RFC7230 A.1 - "clients are encouraged not to send the - # Proxy-Connection header field in any requests" - set accept_encoding_seen 0 + } + if {[info exists phost] && ($phost ne "") && $state(-keepalive)} { + puts $sock "Proxy-Connection: Keep-Alive" + } + set accept_encoding_seen 0 set content_type_seen 0 - dict for {key value} $state(-headers) { - set value [string map [list \n "" \r ""] $value] - set key [string map {" " -} [string trim $key]] + foreach {key value} $state(-headers) { if {[string equal -nocase $key "host"]} { continue } if {[string equal -nocase $key "accept-encoding"]} { set accept_encoding_seen 1 } - if {[string equal -nocase $key "accept"]} { - set accept_types_seen 1 - } if {[string equal -nocase $key "content-type"]} { set content_type_seen 1 } + set value [string map [list \n "" \r ""] $value] + set key [string trim $key] if {[string equal -nocase $key "content-length"]} { set contDone 1 set state(querylength) $value } if {[string length $key]} { puts $sock "$key: $value" } } - # Allow overriding the Accept header on a per-connection basis. Useful - # for working with REST services. [Bug c11a51c482] - if {!$accept_types_seen} { - puts $sock "Accept: $state(accept-types)" - } - if { (!$accept_encoding_seen) - && (![info exists state(-handler)]) - && $http(-zip) - } { - puts $sock "Accept-Encoding: gzip,deflate,compress" - } - if {$isQueryChannel && ($state(querylength) == 0)} { + # Soft zlib dependency check - no package require + if { + !$accept_encoding_seen && + ([package vsatisfies [package provide Tcl] 8.6] + || [llength [package provide zlib]]) && + !([info exists state(-channel)] || [info exists state(-handler)]) + } then { + puts $sock "Accept-Encoding: gzip, identity, *;q=0.1" + } + if {$isQueryChannel && $state(querylength) == 0} { # Try to determine size of data in channel. If we cannot seek, the # surrounding catch will trap us set start [tell $state(-querychannel)] seek $state(-querychannel) 0 end @@ -1453,26 +743,10 @@ set state(querylength) \ [expr {[tell $state(-querychannel)] - $start}] seek $state(-querychannel) $start } - # Note that we don't do Cookie2; that's much nastier and not normally - # observed in practice either. It also doesn't fix the multitude of - # bugs in the basic cookie spec. - if {$http(-cookiejar) ne ""} { - set cookies "" - set separator "" - foreach {key value} [{*}$http(-cookiejar) \ - getCookies $proto $host $state(path)] { - append cookies $separator $key = $value - set separator "; " - } - if {$cookies ne ""} { - puts $sock "Cookie: $cookies" - } - } - # Flush the request header and set up the fileevent that will either # push the POST data or read the response. # # fileevent note: # @@ -1480,814 +754,48 @@ # this point. The only scenario it seems to affect is a server that # closes the connection without reading the POST data. (e.g., early # versions TclHttpd in various error cases). Depending on the # platform, the client may or may not be able to get the response from # the server because of the error it will get trying to write the post - # data. Having both fileevents active changes the timing and the + # data. Having both fileevents active changes the timing and the # behavior, but no two platforms (among Solaris, Linux, and NT) behave # the same, and none behave all that well in any case. Servers should # always read their POST data if they expect the client to read their # response. if {$isQuery || $isQueryChannel} { - # POST method. if {!$content_type_seen} { puts $sock "Content-Type: $state(-type)" } if {!$contDone} { puts $sock "Content-Length: $state(querylength)" } puts $sock "" - flush $sock - # Flush flushes the error in the https case with a bad handshake: - # else the socket never becomes writable again, and hangs until - # timeout (if any). - - lassign [fconfigure $sock -translation] trRead trWrite - fconfigure $sock -translation [list $trRead binary] + fconfigure $sock -translation {auto binary} fileevent $sock writable [list http::Write $token] - # The http::Write command decides when to make the socket readable, - # using the same test as the GET/HEAD case below. } else { - # GET or HEAD method. - if { (![catch {fileevent $sock readable} binding]) - && ($binding eq [list http::CheckEof $sock]) - } { - # Remove the "fileevent readable" binding of an idle persistent - # socket to http::CheckEof. We can no longer treat bytes - # received as junk. The server might still time out and - # half-close the socket if it has not yet received the first - # "puts". - fileevent $sock readable {} - } puts $sock "" flush $sock - Log ^C$tk end sending request - token $token - # End of writing (GET/HEAD methods). The request has been sent. - - DoneRequest $token - } - - } err]} { - # The socket probably was never connected, OR the connection dropped - # later, OR https handshake error, which may be discovered as late as - # the "flush" command above... - Log "WARNING - if testing, pay special attention to this\ - case (GI) which is seldom executed - token $token" - if {[info exists state(reusing)] && $state(reusing)} { - # The socket was closed at the server end, and closed at - # this end by http::CheckEof. - if {[TestForReplay $token write $err a]} { - return - } else { - Finish $token {failed to re-use socket} - } - - # else: - # This is NOT a persistent socket that has been closed since its - # last use. - # If any other requests are in flight or pipelined/queued, they will - # be discarded. - } elseif {$state(status) eq ""} { - # ...https handshake errors come here. - set msg [registerError $sock] - registerError $sock {} - if {$msg eq {}} { - set msg {failed to use socket} - } - Finish $token $msg - } elseif {$state(status) ne "error"} { + fileevent $sock readable [list http::Event $sock $token] + } + + } err]} then { + # The socket probably was never connected, or the connection dropped + # later. + + # if state(status) is error, it means someone's already called Finish + # to do the above-described clean up. + if {$state(status) ne "error"} { Finish $token $err } } -} - -# http::registerError -# -# Called (for example when processing TclTLS activity) to register -# an error for a connection on a specific socket. This helps -# http::Connected to deliver meaningful error messages, e.g. when a TLS -# certificate fails verification. -# -# Usage: http::registerError socket ?newValue? -# -# "set" semantics, except that a "get" (a call without a new value) for a -# non-existent socket returns {}, not an error. - -proc http::registerError {sock args} { - variable registeredErrors - - if { ([llength $args] == 0) - && (![info exists registeredErrors($sock)]) - } { - return - } elseif { ([llength $args] == 1) - && ([lindex $args 0] eq {}) - } { - unset -nocomplain registeredErrors($sock) - return - } - set registeredErrors($sock) {*}$args -} - -# http::DoneRequest -- -# -# Command called when a request has been sent. It will arrange the -# next request and/or response as appropriate. -# -# If this command is called when $socketClosing(*), the request $token -# that calls it must be pipelined and destined to fail. - -proc http::DoneRequest {token} { - variable http - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketClosing - variable socketPlayCmd - - variable $token - upvar 0 $token state - set tk [namespace tail $token] - set sock $state(sock) - - # If pipelined, connect the next HTTP request to the socket. - if {$state(reusing) && $state(-pipeline)} { - # Enable next token (if any) to write. - # The value "Wready" is set only here, and - # in http::Event after reading the response-headers of a - # non-reusing transaction. - # Previous value is $token. It cannot be pending. - set socketWrState($state(socketinfo)) Wready - - # Now ready to write the next pipelined request (if any). - http::NextPipelinedWrite $token - } else { - # If pipelined, this is the first transaction on this socket. We wait - # for the response headers to discover whether the connection is - # persistent. (If this is not done and the connection is not - # persistent, we SHOULD retry and then MUST NOT pipeline before knowing - # that we have a persistent connection - # (rfc2616 8.1.2.2)). - } - - # Connect to receive the response, unless the socket is pipelined - # and another response is being sent. - # This code block is separate from the code below because there are - # cases where socketRdState already has the value $token. - if { $state(-keepalive) - && $state(-pipeline) - && [info exists socketRdState($state(socketinfo))] - && ($socketRdState($state(socketinfo)) eq "Rready") - } { - #Log pipelined, GRANT read access to $token in Connected - set socketRdState($state(socketinfo)) $token - } - - if { $state(-keepalive) - && $state(-pipeline) - && [info exists socketRdState($state(socketinfo))] - && ($socketRdState($state(socketinfo)) ne $token) - } { - # Do not read from the socket until it is ready. - ##Log "HTTP response for token $token is queued for pipelined use" - # If $socketClosing(*), then the caller will be a pipelined write and - # execution will come here. - # This token has already been recorded as "in flight" for writing. - # When the socket is closed, the read queue will be cleared in - # CloseQueuedQueries and so the "lappend" here has no effect. - lappend socketRdQueue($state(socketinfo)) $token - } else { - # In the pipelined case, connection for reading depends on the - # value of socketRdState. - # In the nonpipeline case, connection for reading always occurs. - ReceiveResponse $token - } -} - -# http::ReceiveResponse -# -# Connects token to its socket for reading. - -proc http::ReceiveResponse {token} { - variable $token - upvar 0 $token state - set tk [namespace tail $token] - set sock $state(sock) - - #Log ---- $state(socketinfo) >> conn to $token for HTTP response - lassign [fconfigure $sock -translation] trRead trWrite - fconfigure $sock -translation [list auto $trWrite] \ - -buffersize $state(-blocksize) - Log ^D$tk begin receiving response - token $token - - coroutine ${token}EventCoroutine http::Event $sock $token - if {[info exists state(-handler)] || [info exists state(-progress)]} { - fileevent $sock readable [list http::EventGateway $sock $token] - } else { - fileevent $sock readable ${token}EventCoroutine - } - return -} - - -# http::EventGateway -# -# Bug [c2dc1da315]. -# - Recursive launch of the coroutine can occur if a -handler or -progress -# callback is used, and the callback command enters the event loop. -# - To prevent this, the fileevent "binding" is disabled while the -# coroutine is in flight. -# - If a recursive call occurs despite these precautions, it is not -# trapped and discarded here, because it is better to report it as a -# bug. -# - Although this solution is believed to be sufficiently general, it is -# used only if -handler or -progress is specified. In other cases, -# the coroutine is called directly. - -proc http::EventGateway {sock token} { - variable $token - upvar 0 $token state - fileevent $sock readable {} - catch {${token}EventCoroutine} res opts - if {[info commands ${token}EventCoroutine] ne {}} { - # The coroutine can be deleted by completion (a non-yield return), by - # http::Finish (when there is a premature end to the transaction), by - # http::reset or http::cleanup, or if the caller set option -channel - # but not option -handler: in the last case reading from the socket is - # now managed by commands ::http::Copy*, http::ReceiveChunked, and - # http::make-transformation-chunked. - # - # Catch in case the coroutine has closed the socket. - catch {fileevent $sock readable [list http::EventGateway $sock $token]} - } - - # If there was an error, re-throw it. - return -options $opts $res -} - - -# http::NextPipelinedWrite -# -# - Connecting a socket to a token for writing is done by this command and by -# command KeepSocket. -# - If another request has a pipelined write scheduled for $token's socket, -# and if the socket is ready to accept it, connect the write and update -# the queue accordingly. -# - This command is called from http::DoneRequest and http::Event, -# IF $state(-pipeline) AND (the current transfer has reached the point at -# which the socket is ready for the next request to be written). -# - This command is called when a token has write access and is pipelined and -# keep-alive, and sets socketWrState to Wready. -# - The command need not consider the case where socketWrState is set to a token -# that does not yet have write access. Such a token is waiting for Rready, -# and the assignment of the connection to the token will be done elsewhere (in -# http::KeepSocket). -# - This command cannot be called after socketWrState has been set to a -# "pending" token value (that is then overwritten by the caller), because that -# value is set by this command when it is called by an earlier token when it -# relinquishes its write access, and the pending token is always the next in -# line to write. - -proc http::NextPipelinedWrite {token} { - variable http - variable socketRdState - variable socketWrState - variable socketWrQueue - variable socketClosing - variable $token - upvar 0 $token state - set connId $state(socketinfo) - - if { [info exists socketClosing($connId)] - && $socketClosing($connId) - } { - # socketClosing(*) is set because the server has sent a - # "Connection: close" header. - # Behave as if the queues are empty - so do nothing. - } elseif { $state(-pipeline) - && [info exists socketWrState($connId)] - && ($socketWrState($connId) eq "Wready") - - && [info exists socketWrQueue($connId)] - && [llength $socketWrQueue($connId)] - && ([set token2 [lindex $socketWrQueue($connId) 0] - set ${token2}(-pipeline) - ] - ) - } { - # - The usual case for a pipelined connection, ready for a new request. - #Log pipelined, GRANT write access to $token2 in NextPipelinedWrite - set conn [set ${token2}(tmpConnArgs)] - set socketWrState($connId) $token2 - set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] - # Connect does its own fconfigure. - fileevent $state(sock) writable [list http::Connect $token2 {*}$conn] - #Log ---- $connId << conn to $token2 for HTTP request (b) - - # In the tests below, the next request will be nonpipeline. - } elseif { $state(-pipeline) - && [info exists socketWrState($connId)] - && ($socketWrState($connId) eq "Wready") - - && [info exists socketWrQueue($connId)] - && [llength $socketWrQueue($connId)] - && (![ set token3 [lindex $socketWrQueue($connId) 0] - set ${token3}(-pipeline) - ] - ) - - && [info exists socketRdState($connId)] - && ($socketRdState($connId) eq "Rready") - } { - # The case in which the next request will be non-pipelined, and the read - # and write queues is ready: which is the condition for a non-pipelined - # write. - variable $token3 - upvar 0 $token3 state3 - set conn [set ${token3}(tmpConnArgs)] - #Log nonpipeline, GRANT r/w access to $token3 in NextPipelinedWrite - set socketRdState($connId) $token3 - set socketWrState($connId) $token3 - set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] - # Connect does its own fconfigure. - fileevent $state(sock) writable [list http::Connect $token3 {*}$conn] - #Log ---- $state(sock) << conn to $token3 for HTTP request (c) - - } elseif { $state(-pipeline) - && [info exists socketWrState($connId)] - && ($socketWrState($connId) eq "Wready") - - && [info exists socketWrQueue($connId)] - && [llength $socketWrQueue($connId)] - && (![set token2 [lindex $socketWrQueue($connId) 0] - set ${token2}(-pipeline) - ] - ) - } { - # - The case in which the next request will be non-pipelined, but the - # read queue is NOT ready. - # - A read is queued or in progress, but not a write. Cannot start the - # nonpipeline transaction, but must set socketWrState to prevent a new - # pipelined request (in http::geturl) jumping the queue. - # - Because socketWrState($connId) is not set to Wready, the assignment - # of the connection to $token2 will be done elsewhere - by command - # http::KeepSocket when $socketRdState($connId) is set to "Rready". - - #Log re-use nonpipeline, GRANT delayed write access to $token in NextP.. - set socketWrState($connId) peNding - } -} - -# http::CancelReadPipeline -# -# Cancel pipelined responses on a closing "Keep-Alive" socket. -# -# - Called by a variable trace on "unset socketRdState($connId)". -# - The variable relates to a Keep-Alive socket, which has been closed. -# - Cancels all pipelined responses. The requests have been sent, -# the responses have not yet been received. -# - This is a hard cancel that ends each transaction with error status, -# and closes the connection. Do not use it if you want to replay failed -# transactions. -# - N.B. Always delete ::http::socketRdState($connId) before deleting -# ::http::socketRdQueue($connId), or this command will do nothing. -# -# Arguments -# As for a trace command on a variable. - -proc http::CancelReadPipeline {name1 connId op} { - variable socketRdQueue - ##Log CancelReadPipeline $name1 $connId $op - if {[info exists socketRdQueue($connId)]} { - set msg {the connection was closed by CancelReadPipeline} - foreach token $socketRdQueue($connId) { - set tk [namespace tail $token] - Log ^X$tk end of response "($msg)" - token $token - set ${token}(status) eof - Finish $token ;#$msg - } - set socketRdQueue($connId) {} - } -} - -# http::CancelWritePipeline -# -# Cancel queued events on a closing "Keep-Alive" socket. -# -# - Called by a variable trace on "unset socketWrState($connId)". -# - The variable relates to a Keep-Alive socket, which has been closed. -# - In pipelined or nonpipeline case: cancels all queued requests. The -# requests have not yet been sent, the responses are not due. -# - This is a hard cancel that ends each transaction with error status, -# and closes the connection. Do not use it if you want to replay failed -# transactions. -# - N.B. Always delete ::http::socketWrState($connId) before deleting -# ::http::socketWrQueue($connId), or this command will do nothing. -# -# Arguments -# As for a trace command on a variable. - -proc http::CancelWritePipeline {name1 connId op} { - variable socketWrQueue - - ##Log CancelWritePipeline $name1 $connId $op - if {[info exists socketWrQueue($connId)]} { - set msg {the connection was closed by CancelWritePipeline} - foreach token $socketWrQueue($connId) { - set tk [namespace tail $token] - Log ^X$tk end of response "($msg)" - token $token - set ${token}(status) eof - Finish $token ;#$msg - } - set socketWrQueue($connId) {} - } -} - -# http::ReplayIfDead -- -# -# - A query on a re-used persistent socket failed at the earliest opportunity, -# because the socket had been closed by the server. Keep the token, tidy up, -# and try to connect on a fresh socket. -# - The connection is monitored for eof by the command http::CheckEof. Thus -# http::ReplayIfDead is needed only when a server event (half-closing an -# apparently idle connection), and a client event (sending a request) occur at -# almost the same time, and neither client nor server detects the other's -# action before performing its own (an "asynchronous close event"). -# - To simplify testing of http::ReplayIfDead, set TEST_EOF 1 in -# http::KeepSocket, and then http::ReplayIfDead will be called if http::geturl -# is called at any time after the server timeout. -# -# Arguments: -# token Connection token. -# -# Side Effects: -# Use the same token, but try to open a new socket. - -proc http::ReplayIfDead {tokenArg doing} { - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketClosing - variable socketPlayCmd - - variable $tokenArg - upvar 0 $tokenArg stateArg - - Log running http::ReplayIfDead for $tokenArg $doing - - # 1. Merge the tokens for transactions in flight, the read (response) queue, - # and the write (request) queue. - - set InFlightR {} - set InFlightW {} - - # Obtain the tokens for transactions in flight. - if {$stateArg(-pipeline)} { - # Two transactions may be in flight. The "read" transaction was first. - # It is unlikely that the server would close the socket if a response - # was pending; however, an earlier request (as well as the present - # request) may have been sent and ignored if the socket was half-closed - # by the server. - - if { [info exists socketRdState($stateArg(socketinfo))] - && ($socketRdState($stateArg(socketinfo)) ne "Rready") - } { - lappend InFlightR $socketRdState($stateArg(socketinfo)) - } elseif {($doing eq "read")} { - lappend InFlightR $tokenArg - } - - if { [info exists socketWrState($stateArg(socketinfo))] - && $socketWrState($stateArg(socketinfo)) ni {Wready peNding} - } { - lappend InFlightW $socketWrState($stateArg(socketinfo)) - } elseif {($doing eq "write")} { - lappend InFlightW $tokenArg - } - - # Report any inconsistency of $tokenArg with socket*state. - if { ($doing eq "read") - && [info exists socketRdState($stateArg(socketinfo))] - && ($tokenArg ne $socketRdState($stateArg(socketinfo))) - } { - Log WARNING - ReplayIfDead pipelined tokenArg $tokenArg $doing \ - ne socketRdState($stateArg(socketinfo)) \ - $socketRdState($stateArg(socketinfo)) - - } elseif { - ($doing eq "write") - && [info exists socketWrState($stateArg(socketinfo))] - && ($tokenArg ne $socketWrState($stateArg(socketinfo))) - } { - Log WARNING - ReplayIfDead pipelined tokenArg $tokenArg $doing \ - ne socketWrState($stateArg(socketinfo)) \ - $socketWrState($stateArg(socketinfo)) - } - } else { - # One transaction should be in flight. - # socketRdState, socketWrQueue are used. - # socketRdQueue should be empty. - - # Report any inconsistency of $tokenArg with socket*state. - if {$tokenArg ne $socketRdState($stateArg(socketinfo))} { - Log WARNING - ReplayIfDead nonpipeline tokenArg $tokenArg $doing \ - ne socketRdState($stateArg(socketinfo)) \ - $socketRdState($stateArg(socketinfo)) - } - - # Report the inconsistency that socketRdQueue is non-empty. - if { [info exists socketRdQueue($stateArg(socketinfo))] - && ($socketRdQueue($stateArg(socketinfo)) ne {}) - } { - Log WARNING - ReplayIfDead nonpipeline tokenArg $tokenArg $doing \ - has read queue socketRdQueue($stateArg(socketinfo)) \ - $socketRdQueue($stateArg(socketinfo)) ne {} - } - - lappend InFlightW $socketRdState($stateArg(socketinfo)) - set socketRdQueue($stateArg(socketinfo)) {} - } - - set newQueue {} - lappend newQueue {*}$InFlightR - lappend newQueue {*}$socketRdQueue($stateArg(socketinfo)) - lappend newQueue {*}$InFlightW - lappend newQueue {*}$socketWrQueue($stateArg(socketinfo)) - - - # 2. Tidy up tokenArg. This is a cut-down form of Finish/CloseSocket. - # Do not change state(status). - # No need to after cancel stateArg(after) - either this is done in - # ReplayCore/ReInit, or Finish is called. - - catch {close $stateArg(sock)} - - # 2a. Tidy the tokens in the queues - this is done in ReplayCore/ReInit. - # - Transactions, if any, that are awaiting responses cannot be completed. - # They are listed for re-sending in newQueue. - # - All tokens are preserved for re-use by ReplayCore, and their variables - # will be re-initialised by calls to ReInit. - # - The relevant element of socketMapping, socketRdState, socketWrState, - # socketRdQueue, socketWrQueue, socketClosing, socketPlayCmd will be set - # to new values in ReplayCore. - - ReplayCore $newQueue -} - -# http::ReplayIfClose -- -# -# A request on a socket that was previously "Connection: keep-alive" has -# received a "Connection: close" response header. The server supplies -# that response correctly, but any later requests already queued on this -# connection will be lost when the socket closes. -# -# This command takes arguments that represent the socketWrState, -# socketRdQueue and socketWrQueue for this connection. The socketRdState -# is not needed because the server responds in full to the request that -# received the "Connection: close" response header. -# -# Existing request tokens $token (::http::$n) are preserved. The caller -# will be unaware that the request was processed this way. - -proc http::ReplayIfClose {Wstate Rqueue Wqueue} { - Log running http::ReplayIfClose for $Wstate $Rqueue $Wqueue - - if {$Wstate in $Rqueue || $Wstate in $Wqueue} { - Log WARNING duplicate token in http::ReplayIfClose - token $Wstate - set Wstate Wready - } - - # 1. Create newQueue - set InFlightW {} - if {$Wstate ni {Wready peNding}} { - lappend InFlightW $Wstate - } - - set newQueue {} - lappend newQueue {*}$Rqueue - lappend newQueue {*}$InFlightW - lappend newQueue {*}$Wqueue - - # 2. Cleanup - none needed, done by the caller. - - ReplayCore $newQueue -} - -# http::ReInit -- -# -# Command to restore a token's state to a condition that -# makes it ready to replay a request. -# -# Command http::geturl stores extra state in state(tmp*) so -# we don't need to do the argument processing again. -# -# The caller must: -# - Set state(reusing) and state(sock) to their new values after calling -# this command. -# - Unset state(tmpState), state(tmpOpenCmd) if future calls to ReplayCore -# or ReInit are inappropriate for this token. Typically only one retry -# is allowed. -# The caller may also unset state(tmpConnArgs) if this value (and the -# token) will be used immediately. The value is needed by tokens that -# will be stored in a queue. -# -# Arguments: -# token Connection token. -# -# Return Value: (boolean) true iff the re-initialisation was successful. - -proc http::ReInit {token} { - variable $token - upvar 0 $token state - - if {!( - [info exists state(tmpState)] - && [info exists state(tmpOpenCmd)] - && [info exists state(tmpConnArgs)] - ) - } { - Log FAILED in http::ReInit via ReplayCore - NO tmp vars for $token - return 0 - } - - if {[info exists state(after)]} { - after cancel $state(after) - unset state(after) - } - - # Don't alter state(status) - this would trigger http::wait if it is in use. - set tmpState $state(tmpState) - set tmpOpenCmd $state(tmpOpenCmd) - set tmpConnArgs $state(tmpConnArgs) - foreach name [array names state] { - if {$name ne "status"} { - unset state($name) - } - } - - # Don't alter state(status). - # Restore state(tmp*) - the caller may decide to unset them. - # Restore state(tmpConnArgs) which is needed for connection. - # state(tmpState), state(tmpOpenCmd) are needed only for retries. - - dict unset tmpState status - array set state $tmpState - set state(tmpState) $tmpState - set state(tmpOpenCmd) $tmpOpenCmd - set state(tmpConnArgs) $tmpConnArgs - - return 1 -} - -# http::ReplayCore -- -# -# Command to replay a list of requests, using existing connection tokens. -# -# Abstracted from http::geturl which stores extra state in state(tmp*) so -# we don't need to do the argument processing again. -# -# Arguments: -# newQueue List of connection tokens. -# -# Side Effects: -# Use existing tokens, but try to open a new socket. - -proc http::ReplayCore {newQueue} { - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketClosing - variable socketPlayCmd - - if {[llength $newQueue] == 0} { - # Nothing to do. - return - } - - ##Log running ReplayCore for {*}$newQueue - set newToken [lindex $newQueue 0] - set newQueue [lrange $newQueue 1 end] - - # 3. Use newToken, and restore its values of state(*). Do not restore - # elements tmp* - we try again only once. - - set token $newToken - variable $token - upvar 0 $token state - - if {![ReInit $token]} { - Log FAILED in http::ReplayCore - NO tmp vars - Finish $token {cannot send this request again} - return - } - - set tmpState $state(tmpState) - set tmpOpenCmd $state(tmpOpenCmd) - set tmpConnArgs $state(tmpConnArgs) - unset state(tmpState) - unset state(tmpOpenCmd) - unset state(tmpConnArgs) - - set state(reusing) 0 - - if {$state(-timeout) > 0} { - set resetCmd [list http::reset $token timeout] - set state(after) [after $state(-timeout) $resetCmd] - } - - set pre [clock milliseconds] - ##Log pre socket opened, - token $token - ##Log $tmpOpenCmd - token $token - # 4. Open a socket. - if {[catch {eval $tmpOpenCmd} sock]} { - # Something went wrong while trying to establish the connection. - Log FAILED - $sock - set state(sock) NONE - Finish $token $sock - return - } - ##Log post socket opened, - token $token - set delay [expr {[clock milliseconds] - $pre}] - if {$delay > 3000} { - Log socket delay $delay - token $token - } - # Command [socket] is called with -async, but takes 5s to 5.1s to return, - # with probability of order 1 in 10,000. This may be a bizarre scheduling - # issue with my (KJN's) system (Fedora Linux). - # This does not cause a problem (unless the request times out when this - # command returns). - - # 5. Configure the persistent socket data. - if {$state(-keepalive)} { - set socketMapping($state(socketinfo)) $sock - - if {![info exists socketRdState($state(socketinfo))]} { - set socketRdState($state(socketinfo)) {} - set varName ::http::socketRdState($state(socketinfo)) - trace add variable $varName unset ::http::CancelReadPipeline - } - - if {![info exists socketWrState($state(socketinfo))]} { - set socketWrState($state(socketinfo)) {} - set varName ::http::socketWrState($state(socketinfo)) - trace add variable $varName unset ::http::CancelWritePipeline - } - - if {$state(-pipeline)} { - #Log new, init for pipelined, GRANT write acc to $token ReplayCore - set socketRdState($state(socketinfo)) $token - set socketWrState($state(socketinfo)) $token - } else { - #Log new, init for nonpipeline, GRANT r/w acc to $token ReplayCore - set socketRdState($state(socketinfo)) $token - set socketWrState($state(socketinfo)) $token - } - - set socketRdQueue($state(socketinfo)) {} - set socketWrQueue($state(socketinfo)) $newQueue - set socketClosing($state(socketinfo)) 0 - set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}} - } - - ##Log pre newQueue ReInit, - token $token - # 6. Configure sockets in the queue. - foreach tok $newQueue { - if {[ReInit $tok]} { - set ${tok}(reusing) 1 - set ${tok}(sock) $sock - } else { - set ${tok}(reusing) 1 - set ${tok}(sock) NONE - Finish $token {cannot send this request again} - } - } - - # 7. Configure the socket for newToken to send a request. - set state(sock) $sock - Log "Using $sock for $state(socketinfo) - token $token" \ - [expr {$state(-keepalive)?"keepalive":""}] - - # Initialisation of a new socket. - ##Log socket opened, now fconfigure - token $token - fconfigure $sock -translation {auto crlf} -buffersize $state(-blocksize) - ##Log socket opened, DONE fconfigure - token $token - - # Connect does its own fconfigure. - fileevent $sock writable [list http::Connect $token {*}$tmpConnArgs] - #Log ---- $sock << conn to $token for HTTP request (e) + } # Data access functions: # Data - the URL data -# Status - the transaction status: ok, reset, eof, timeout, error +# Status - the transaction status: ok, reset, eof, timeout # Code - the HTTP transaction code, e.g., 200 # Size - the size of the URL data proc http::data {token} { variable $token @@ -2346,17 +854,10 @@ # unsets the state array proc http::cleanup {token} { variable $token upvar 0 $token state - if {[info commands ${token}EventCoroutine] ne {}} { - rename ${token}EventCoroutine {} - } - if {[info exists state(after)]} { - after cancel $state(after) - unset state(after) - } if {[info exists state]} { unset state } } @@ -2372,37 +873,21 @@ # the waiting geturl call proc http::Connect {token proto phost srvurl} { variable $token upvar 0 $token state - set tk [namespace tail $token] set err "due to unexpected EOF" if { [eof $state(sock)] || [set err [fconfigure $state(sock) -error]] ne "" - } { - Log "WARNING - if testing, pay special attention to this\ - case (GJ) which is seldom executed - token $token" - if {[info exists state(reusing)] && $state(reusing)} { - # The socket was closed at the server end, and closed at - # this end by http::CheckEof. - if {[TestForReplay $token write $err b]} { - return - } - - # else: - # This is NOT a persistent socket that has been closed since its - # last use. - # If any other requests are in flight or pipelined/queued, they will - # be discarded. - } + } then { Finish $token "connect failed $err" } else { - set state(state) connecting fileevent $state(sock) writable {} ::http::Connected $token $proto $phost $srvurl } + return } # http::Write # # Write POST query data to the socket @@ -2412,22 +897,12 @@ # # Side Effects # Write the socket and handle callbacks. proc http::Write {token} { - variable http - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketClosing - variable socketPlayCmd - variable $token upvar 0 $token state - set tk [namespace tail $token] set sock $state(sock) # Output a block. Tcl will buffer this if the socket blocks set done 0 if {[catch { @@ -2434,25 +909,11 @@ # Catch I/O errors on dead sockets if {[info exists state(-query)]} { # Chop up large query strings so queryprogress callback can give # smooth feedback. - if { $state(queryoffset) + $state(-queryblocksize) - >= $state(querylength) - } { - # This will be the last puts for the request-body. - if { (![catch {fileevent $sock readable} binding]) - && ($binding eq [list http::CheckEof $sock]) - } { - # Remove the "fileevent readable" binding of an idle - # persistent socket to http::CheckEof. We can no longer - # treat bytes received as junk. The server might still time - # out and half-close the socket if it has not yet received - # the first "puts". - fileevent $sock readable {} - } - } + puts -nonewline $sock \ [string range $state(-query) $state(queryoffset) \ [expr {$state(queryoffset) + $state(-queryblocksize) - 1}]] incr state(queryoffset) $state(-queryblocksize) if {$state(queryoffset) >= $state(querylength)} { @@ -2461,44 +922,27 @@ } } else { # Copy blocks from the query channel set outStr [read $state(-querychannel) $state(-queryblocksize)] - if {[eof $state(-querychannel)]} { - # This will be the last puts for the request-body. - if { (![catch {fileevent $sock readable} binding]) - && ($binding eq [list http::CheckEof $sock]) - } { - # Remove the "fileevent readable" binding of an idle - # persistent socket to http::CheckEof. We can no longer - # treat bytes received as junk. The server might still time - # out and half-close the socket if it has not yet received - # the first "puts". - fileevent $sock readable {} - } - } puts -nonewline $sock $outStr incr state(queryoffset) [string length $outStr] if {[eof $state(-querychannel)]} { set done 1 } } - } err]} { + } err]} then { # Do not call Finish here, but instead let the read half of the socket # process whatever server reply there is to get. set state(posterror) $err set done 1 } - if {$done} { catch {flush $sock} fileevent $sock writable {} - Log ^C$tk end sending request - token $token - # End of writing (POST method). The request has been sent. - - DoneRequest $token + fileevent $sock readable [list http::Event $sock $token] } # Callback to the client after we've completely handled everything. if {[string length $state(-queryprogress)]} { @@ -2507,577 +951,215 @@ } } # http::Event # -# Handle input on the socket. This command is the core of -# the coroutine commands ${token}EventCoroutine that are -# bound to "fileevent $sock readable" and process input. +# Handle input on the socket # # Arguments # sock The socket receiving input. # token The token returned from http::geturl # # Side Effects # Read the socket and handle callbacks. proc http::Event {sock token} { - variable http - variable socketMapping - variable socketRdState - variable socketWrState - variable socketRdQueue - variable socketWrQueue - variable socketClosing - variable socketPlayCmd - - variable $token - upvar 0 $token state - set tk [namespace tail $token] - while 1 { - yield - ##Log Event call - token $token - - if {![info exists state]} { - Log "Event $sock with invalid token '$token' - remote close?" - if {![eof $sock]} { - if {[set d [read $sock]] ne ""} { - Log "WARNING: additional data left on closed socket\ - - token $token" - } - } - Log ^X$tk end of response (token error) - token $token - CloseSocket $sock - return - } - if {$state(state) eq "connecting"} { - ##Log - connecting - token $token - if { $state(reusing) - && $state(-pipeline) - && ($state(-timeout) > 0) - && (![info exists state(after)]) - } { - set state(after) [after $state(-timeout) \ - [list http::reset $token timeout]] - } - - if {[catch {gets $sock state(http)} nsl]} { - Log "WARNING - if testing, pay special attention to this\ - case (GK) which is seldom executed - token $token" - if {[info exists state(reusing)] && $state(reusing)} { - # The socket was closed at the server end, and closed at - # this end by http::CheckEof. - - if {[TestForReplay $token read $nsl c]} { - return - } - - # else: - # This is NOT a persistent socket that has been closed since - # its last use. - # If any other requests are in flight or pipelined/queued, - # they will be discarded. - } else { - Log ^X$tk end of response (error) - token $token - Finish $token $nsl - return - } - } elseif {$nsl >= 0} { - ##Log - connecting 1 - token $token - set state(state) "header" - } elseif { [eof $sock] - && [info exists state(reusing)] - && $state(reusing) - } { - # The socket was closed at the server end, and we didn't notice. - # This is the first read - where the closure is usually first - # detected. - - if {[TestForReplay $token read {} d]} { - return - } - - # else: - # This is NOT a persistent socket that has been closed since its - # last use. - # If any other requests are in flight or pipelined/queued, they - # will be discarded. - } - } elseif {$state(state) eq "header"} { - if {[catch {gets $sock line} nhl]} { - ##Log header failed - token $token - Log ^X$tk end of response (error) - token $token - Finish $token $nhl - return - } elseif {$nhl == 0} { - ##Log header done - token $token - Log ^E$tk end of response headers - token $token - # We have now read all headers - # We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3 - if { ($state(http) == "") - || ([regexp {^\S+\s(\d+)} $state(http) {} x] && $x == 100) - } { - set state(state) "connecting" - continue - # This was a "return" in the pre-coroutine code. - } - - if { ([info exists state(connection)]) - && ([info exists socketMapping($state(socketinfo))]) - && ($state(connection) eq "keep-alive") - && ($state(-keepalive)) - && (!$state(reusing)) - && ($state(-pipeline)) - } { - # Response headers received for first request on a - # persistent socket. Now ready for pipelined writes (if - # any). - # Previous value is $token. It cannot be "pending". - set socketWrState($state(socketinfo)) Wready - http::NextPipelinedWrite $token - } - - # Once a "close" has been signaled, the client MUST NOT send any - # more requests on that connection. - # - # If either the client or the server sends the "close" token in - # the Connection header, that request becomes the last one for - # the connection. - - if { ([info exists state(connection)]) - && ([info exists socketMapping($state(socketinfo))]) - && ($state(connection) eq "close") - && ($state(-keepalive)) - } { - # The server warns that it will close the socket after this - # response. - ##Log WARNING - socket will close after response for $token - # Prepare data for a call to ReplayIfClose. - if { ($socketRdQueue($state(socketinfo)) ne {}) - || ($socketWrQueue($state(socketinfo)) ne {}) - || ($socketWrState($state(socketinfo)) ni - [list Wready peNding $token]) - } { - set InFlightW $socketWrState($state(socketinfo)) - if {$InFlightW in [list Wready peNding $token]} { - set InFlightW Wready - } else { - set msg "token ${InFlightW} is InFlightW" - ##Log $msg - token $token - } - - set socketPlayCmd($state(socketinfo)) \ - [list ReplayIfClose $InFlightW \ - $socketRdQueue($state(socketinfo)) \ - $socketWrQueue($state(socketinfo))] - - # - All tokens are preserved for re-use by ReplayCore. - # - Queues are preserved in case of Finish with error, - # but are not used for anything else because - # socketClosing(*) is set below. - # - Cancel the state(after) timeout events. - foreach tokenVal $socketRdQueue($state(socketinfo)) { - if {[info exists ${tokenVal}(after)]} { - after cancel [set ${tokenVal}(after)] - unset ${tokenVal}(after) - } - } - - } else { - set socketPlayCmd($state(socketinfo)) \ - {ReplayIfClose Wready {} {}} - } - - # Do not allow further connections on this socket. - set socketClosing($state(socketinfo)) 1 - } - - set state(state) body - - # If doing a HEAD, then we won't get any body - if {$state(-validate)} { - Log ^F$tk end of response for HEAD request - token $token - set state(state) complete - Eot $token - return - } - - # - For non-chunked transfer we may have no body - in this case - # we may get no further file event if the connection doesn't - # close and no more data is sent. We can tell and must finish - # up now - not later - the alternative would be to wait until - # the server times out. - # - In this case, the server has NOT told the client it will - # close the connection, AND it has NOT indicated the resource - # length EITHER by setting the Content-Length (totalsize) OR - # by using chunked Transfer-Encoding. - # - Do not worry here about the case (Connection: close) because - # the server should close the connection. - # - IF (NOT Connection: close) AND (NOT chunked encoding) AND - # (totalsize == 0). - - if { (!( [info exists state(connection)] - && ($state(connection) eq "close") - ) - ) - && (![info exists state(transfer)]) - && ($state(totalsize) == 0) - } { - set msg {body size is 0 and no events likely - complete} - Log "$msg - token $token" - set msg {(length unknown, set to 0)} - Log ^F$tk end of response body {*}$msg - token $token - set state(state) complete - Eot $token - return - } - - # We have to use binary translation to count bytes properly. - lassign [fconfigure $sock -translation] trRead trWrite - fconfigure $sock -translation [list binary $trWrite] - - if { - $state(-binary) || [IsBinaryContentType $state(type)] - } { - # Turn off conversions for non-text data. - set state(binary) 1 - } - if {[info exists state(-channel)]} { - if {$state(binary) || [llength [ContentEncoding $token]]} { - fconfigure $state(-channel) -translation binary - } - if {![info exists state(-handler)]} { - # Initiate a sequence of background fcopies. - fileevent $sock readable {} - rename ${token}EventCoroutine {} - CopyStart $sock $token - return - } - } - } elseif {$nhl > 0} { - # Process header lines. - ##Log header - token $token - $line - if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} { - switch -- [string tolower $key] { - content-type { - set state(type) [string trim [string tolower $value]] - # Grab the optional charset information. - if {[regexp -nocase \ - {charset\s*=\s*\"((?:[^""]|\\\")*)\"} \ - $state(type) -> cs]} { - set state(charset) [string map {{\"} \"} $cs] - } else { - regexp -nocase {charset\s*=\s*(\S+?);?} \ - $state(type) -> state(charset) - } - } - content-length { - set state(totalsize) [string trim $value] - } - content-encoding { - set state(coding) [string trim $value] - } - transfer-encoding { - set state(transfer) \ - [string trim [string tolower $value]] - } - proxy-connection - - connection { - set tmpHeader [string trim [string tolower $value]] - # RFC 7230 Section 6.1 states that a comma-separated - # list is an acceptable value. According to - # https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Connection - # any comma-separated list implies keep-alive, but I - # don't see this in the RFC so we'll play safe and - # scan any list for "close". - if {$tmpHeader in {close keep-alive}} { - # The common cases, continue. - } elseif {[string first , $tmpHeader] < 0} { - # Not a comma-separated list, not "close", - # therefore "keep-alive". - set tmpHeader keep-alive - } else { - set tmpResult keep-alive - set tmpCsl [split $tmpHeader ,] - # Optional whitespace either side of separator. - foreach el $tmpCsl { - if {[string trim $el] eq {close}} { - set tmpResult close - break - } - } - set tmpHeader $tmpResult - } - set state(connection) $tmpHeader - } - set-cookie { - if {$http(-cookiejar) ne ""} { - ParseCookie $token [string trim $value] - } - } - } - lappend state(meta) $key [string trim $value] - } - } - } else { - # Now reading body - ##Log body - token $token - if {[catch { - if {[info exists state(-handler)]} { - set n [eval $state(-handler) [list $sock $token]] - ##Log handler $n - token $token - # N.B. the protocol has been set to 1.0 because the -handler - # logic is not expected to handle chunked encoding. - # FIXME Allow -handler with 1.1 on dechunked stacked chan. - if {$state(totalsize) == 0} { - # We know the transfer is complete only when the server - # closes the connection - i.e. eof is not an error. - set state(state) complete - } - if {![string is integer -strict $n]} { - if 1 { - # Do not tolerate bad -handler - fail with error - # status. - set msg {the -handler command for http::geturl must\ - return an integer (the number of bytes\ - read)} - Log ^X$tk end of response (handler error) -\ - token $token - Eot $token $msg - } else { - # Tolerate the bad -handler, and continue. The - # penalty: - # (a) Because the handler returns nonsense, we know - # the transfer is complete only when the server - # closes the connection - i.e. eof is not an - # error. - # (b) http::size will not be accurate. - # (c) The transaction is already downgraded to 1.0 - # to avoid chunked transfer encoding. It MUST - # also be forced to "Connection: close" or the - # HTTP/1.0 equivalent; or it MUST fail (as - # above) if the server sends - # "Connection: keep-alive" or the HTTP/1.0 - # equivalent. - set n 0 - set state(state) complete - } - } - } elseif {[info exists state(transfer_final)]} { - # This code forgives EOF in place of the final CRLF. - set line [getTextLine $sock] - set n [string length $line] - set state(state) complete - if {$n > 0} { - # - HTTP trailers (late response headers) are permitted - # by Chunked Transfer-Encoding, and can be safely - # ignored. - # - Do not count these bytes in the total received for - # the response body. - Log "trailer of $n bytes after final chunk -\ - token $token" - append state(transfer_final) $line - set n 0 - } else { - Log ^F$tk end of response body (chunked) - token $token - Log "final chunk part - token $token" - Eot $token - } - } elseif { [info exists state(transfer)] - && ($state(transfer) eq "chunked") - } { - ##Log chunked - token $token - set size 0 - set hexLenChunk [getTextLine $sock] - #set ntl [string length $hexLenChunk] - if {[string trim $hexLenChunk] ne ""} { - scan $hexLenChunk %x size - if {$size != 0} { - ##Log chunk-measure $size - token $token - set chunk [BlockingRead $sock $size] - set n [string length $chunk] - if {$n >= 0} { - append state(body) $chunk - incr state(log_size) [string length $chunk] - ##Log chunk $n cumul $state(log_size) -\ - token $token - } - if {$size != [string length $chunk]} { - Log "WARNING: mis-sized chunk:\ - was [string length $chunk], should be\ - $size - token $token" - set n 0 - set state(connection) close - Log ^X$tk end of response (chunk error) \ - - token $token - set msg {error in chunked encoding - fetch\ - terminated} - Eot $token $msg - } - # CRLF that follows chunk. - # If eof, this is handled at the end of this proc. - getTextLine $sock - } else { - set n 0 - set state(transfer_final) {} - } - } else { - # Line expected to hold chunk length is empty, or eof. - ##Log bad-chunk-measure - token $token - set n 0 - set state(connection) close - Log ^X$tk end of response (chunk error) - token $token - Eot $token {error in chunked encoding -\ - fetch terminated} - } - } else { - ##Log unchunked - token $token - if {$state(totalsize) == 0} { - # We know the transfer is complete only when the server - # closes the connection. - set state(state) complete - set reqSize $state(-blocksize) - } else { - # Ask for the whole of the unserved response-body. - # This works around a problem with a tls::socket - for - # https in keep-alive mode, and a request for - # $state(-blocksize) bytes, the last part of the - # resource does not get read until the server times out. - set reqSize [expr { $state(totalsize) - - $state(currentsize)}] - - # The workaround fails if reqSize is - # capped at $state(-blocksize). - # set reqSize [expr {min($reqSize, $state(-blocksize))}] - } - set c $state(currentsize) - set t $state(totalsize) - ##Log non-chunk currentsize $c of totalsize $t -\ - token $token - set block [read $sock $reqSize] - set n [string length $block] - if {$n >= 0} { - append state(body) $block - ##Log non-chunk [string length $state(body)] -\ - token $token - } - } - # This calculation uses n from the -handler, chunked, or - # unchunked case as appropriate. - if {[info exists state]} { - if {$n >= 0} { - incr state(currentsize) $n - set c $state(currentsize) - set t $state(totalsize) - ##Log another $n currentsize $c totalsize $t -\ - token $token - } - # If Content-Length - check for end of data. - if { - ($state(totalsize) > 0) - && ($state(currentsize) >= $state(totalsize)) - } { - Log ^F$tk end of response body (unchunked) -\ - token $token - set state(state) complete - Eot $token - } - } - } err]} { - Log ^X$tk end of response (error ${err}) - token $token - Finish $token $err - return - } else { - if {[info exists state(-progress)]} { - eval $state(-progress) \ - [list $token $state(totalsize) $state(currentsize)] - } - } - } - - # catch as an Eot above may have closed the socket already - # $state(state) may be connecting, header, body, or complete - if {![set cc [catch {eof $sock} eof]] && $eof} { - ##Log eof - token $token - if {[info exists $token]} { - set state(connection) close - if {$state(state) eq "complete"} { - # This includes all cases in which the transaction - # can be completed by eof. - # The value "complete" is set only in http::Event, and it is - # used only in the test above. - Log ^F$tk end of response body (unchunked, eof) -\ - token $token - Eot $token - } else { - # Premature eof. - Log ^X$tk end of response (unexpected eof) - token $token - Eot $token eof - } - } else { - # open connection closed on a token that has been cleaned up. - Log ^X$tk end of response (token error) - token $token - CloseSocket $sock - } - } elseif {$cc} { - return - } - } -} - -# http::TestForReplay -# -# Command called if eof is discovered when a socket is first used for a -# new transaction. Typically this occurs if a persistent socket is used -# after a period of idleness and the server has half-closed the socket. -# -# token - the connection token returned by http::geturl -# doing - "read" or "write" -# err - error message, if any -# caller - code to identify the caller - used only in logging -# -# Return Value: boolean, true iff the command calls http::ReplayIfDead. - -proc http::TestForReplay {token doing err caller} { - variable http - variable $token - upvar 0 $token state - set tk [namespace tail $token] - if {$doing eq "read"} { - set code Q - set action response - set ing reading - } else { - set code P - set action request - set ing writing - } - - if {$err eq {}} { - set err "detect eof when $ing (server timed out?)" - } - - if {$state(method) eq "POST" && !$http(-repost)} { - # No Replay. - # The present transaction will end when Finish is called. - # That call to Finish will abort any other transactions - # currently in the write queue. - # For calls from http::Event this occurs when execution - # reaches the code block at the end of that proc. - set msg {no retry for POST with http::config -repost 0} - Log reusing socket failed "($caller)" - $msg - token $token - Log error - $err - token $token - Log ^X$tk end of $action (error) - token $token - return 0 - } else { - # Replay. - set msg {try a new socket} - Log reusing socket failed "($caller)" - $msg - token $token - Log error - $err - token $token - Log ^$code$tk Any unfinished (incl this one) failed - token $token - ReplayIfDead $token $doing - return 1 + variable $token + upvar 0 $token state + + if {![info exists state]} { + Log "Event $sock with invalid token '$token' - remote close?" + if {![eof $sock]} { + if {[set d [read $sock]] ne ""} { + Log "WARNING: additional data left on closed socket" + } + } + CloseSocket $sock + return + } + if {$state(state) eq "connecting"} { + if {[catch {gets $sock state(http)} n]} { + return [Finish $token $n] + } elseif {$n >= 0} { + set state(state) "header" + } + } elseif {$state(state) eq "header"} { + if {[catch {gets $sock line} n]} { + return [Finish $token $n] + } elseif {$n == 0} { + # We have now read all headers + # We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3 + if {$state(http) == "" || ([regexp {^\S+\s(\d+)} $state(http) {} x] && $x == 100)} { + return + } + + set state(state) body + + # If doing a HEAD, then we won't get any body + if {$state(-validate)} { + Eof $token + return + } + + # For non-chunked transfer we may have no body - in this case we + # may get no further file event if the connection doesn't close + # and no more data is sent. We can tell and must finish up now - + # not later. + if { + !(([info exists state(connection)] + && ($state(connection) eq "close")) + || [info exists state(transfer)]) + && ($state(totalsize) == 0) + } then { + Log "body size is 0 and no events likely - complete." + Eof $token + return + } + + # We have to use binary translation to count bytes properly. + fconfigure $sock -translation binary + + if { + $state(-binary) || [IsBinaryContentType $state(type)] + } then { + # Turn off conversions for non-text data + set state(binary) 1 + } + if { + $state(binary) || [string match *gzip* $state(coding)] || + [string match *compress* $state(coding)] + } then { + if {[info exists state(-channel)]} { + fconfigure $state(-channel) -translation binary + } + } + if { + [info exists state(-channel)] && + ![info exists state(-handler)] + } then { + # Initiate a sequence of background fcopies + fileevent $sock readable {} + CopyStart $sock $token + return + } + } elseif {$n > 0} { + # Process header lines + if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} { + switch -- [string tolower $key] { + content-type { + set state(type) [string trim [string tolower $value]] + # grab the optional charset information + if {[regexp -nocase \ + {charset\s*=\s*\"((?:[^""]|\\\")*)\"} \ + $state(type) -> cs]} { + set state(charset) [string map {{\"} \"} $cs] + } else { + regexp -nocase {charset\s*=\s*(\S+?);?} \ + $state(type) -> state(charset) + } + } + content-length { + set state(totalsize) [string trim $value] + } + content-encoding { + set state(coding) [string trim $value] + } + transfer-encoding { + set state(transfer) \ + [string trim [string tolower $value]] + } + proxy-connection - + connection { + set state(connection) \ + [string trim [string tolower $value]] + } + } + lappend state(meta) $key [string trim $value] + } + } + } else { + # Now reading body + if {[catch { + if {[info exists state(-handler)]} { + set n [eval $state(-handler) [list $sock $token]] + } elseif {[info exists state(transfer_final)]} { + set line [getTextLine $sock] + set n [string length $line] + if {$n > 0} { + Log "found $n bytes following final chunk" + append state(transfer_final) $line + } else { + Log "final chunk part" + Eof $token + } + } elseif { + [info exists state(transfer)] + && $state(transfer) eq "chunked" + } then { + set size 0 + set chunk [getTextLine $sock] + set n [string length $chunk] + if {[string trim $chunk] ne ""} { + scan $chunk %x size + if {$size != 0} { + set bl [fconfigure $sock -blocking] + fconfigure $sock -blocking 1 + set chunk [read $sock $size] + fconfigure $sock -blocking $bl + set n [string length $chunk] + if {$n >= 0} { + append state(body) $chunk + } + if {$size != [string length $chunk]} { + Log "WARNING: mis-sized chunk:\ + was [string length $chunk], should be $size" + } + getTextLine $sock + } else { + set state(transfer_final) {} + } + } + } else { + #Log "read non-chunk $state(currentsize) of $state(totalsize)" + set block [read $sock $state(-blocksize)] + set n [string length $block] + if {$n >= 0} { + append state(body) $block + } + } + if {[info exists state]} { + if {$n >= 0} { + incr state(currentsize) $n + } + # If Content-Length - check for end of data. + if { + ($state(totalsize) > 0) + && ($state(currentsize) >= $state(totalsize)) + } then { + Eof $token + } + } + } err]} then { + return [Finish $token $err] + } else { + if {[info exists state(-progress)]} { + eval $state(-progress) \ + [list $token $state(totalsize) $state(currentsize)] + } + } + } + + # catch as an Eof above may have closed the socket already + if {![catch {eof $sock} eof] && $eof} { + if {[info exists $token]} { + set state(connection) close + Eof $token + } else { + # open connection closed on a token that has been cleaned up. + CloseSocket $sock + } + return } } # http::IsBinaryContentType -- # @@ -3109,151 +1191,29 @@ return false } return true } -proc http::ParseCookie {token value} { - variable http - variable CookieRE - variable $token - upvar 0 $token state - - if {![regexp $CookieRE $value -> cookiename cookieval opts]} { - # Bad cookie! No biscuit! - return - } - - # Convert the options into a list before feeding into the cookie store; - # ugly, but quite easy. - set realopts {hostonly 1 path / secure 0 httponly 0} - dict set realopts origin $state(host) - dict set realopts domain $state(host) - foreach option [split [regsub -all {;\s+} $opts \u0000] \u0000] { - regexp {^(.*?)(?:=(.*))?$} $option -> optname optval - switch -exact -- [string tolower $optname] { - expires { - if {[catch { - #Sun, 06 Nov 1994 08:49:37 GMT - dict set realopts expires \ - [clock scan $optval -format "%a, %d %b %Y %T %Z"] - }] && [catch { - # Google does this one - #Mon, 01-Jan-1990 00:00:00 GMT - dict set realopts expires \ - [clock scan $optval -format "%a, %d-%b-%Y %T %Z"] - }] && [catch { - # This is in the RFC, but it is also in the original - # Netscape cookie spec, now online at: - # - #Sunday, 06-Nov-94 08:49:37 GMT - dict set realopts expires \ - [clock scan $optval -format "%A, %d-%b-%y %T %Z"] - }]} {catch { - #Sun Nov 6 08:49:37 1994 - dict set realopts expires \ - [clock scan $optval -gmt 1 -format "%a %b %d %T %Y"] - }} - } - max-age { - # Normalize - if {[string is integer -strict $optval]} { - dict set realopts expires [expr {[clock seconds] + $optval}] - } - } - domain { - # From the domain-matches definition [RFC 2109, section 2]: - # Host A's name domain-matches host B's if [...] - # A is a FQDN string and has the form NB, where N is a - # non-empty name string, B has the form .B', and B' is a - # FQDN string. (So, x.y.com domain-matches .y.com but - # not y.com.) - if {$optval ne "" && ![string match *. $optval]} { - dict set realopts domain [string trimleft $optval "."] - dict set realopts hostonly [expr { - ! [string match .* $optval] - }] - } - } - path { - if {[string match /* $optval]} { - dict set realopts path $optval - } - } - secure - httponly { - dict set realopts [string tolower $optname] 1 - } - } - } - dict set realopts key $cookiename - dict set realopts value $cookieval - {*}$http(-cookiejar) storeCookie $realopts -} - # http::getTextLine -- # -# Get one line with the stream in crlf mode. -# Used if Transfer-Encoding is chunked. -# Empty line is not distinguished from eof. The caller must -# be able to handle this. +# Get one line with the stream in blocking crlf mode # # Arguments # sock The socket receiving input. # # Results: # The line of text, without trailing newline proc http::getTextLine {sock} { set tr [fconfigure $sock -translation] - lassign $tr trRead trWrite - fconfigure $sock -translation [list crlf $trWrite] - set r [BlockingGets $sock] - fconfigure $sock -translation $tr + set bl [fconfigure $sock -blocking] + fconfigure $sock -translation crlf -blocking 1 + set r [gets $sock] + fconfigure $sock -translation $tr -blocking $bl return $r } -# http::BlockingRead -# -# Replacement for a blocking read. -# The caller must be a coroutine. - -proc http::BlockingRead {sock size} { - if {$size < 1} { - return - } - set result {} - while 1 { - set need [expr {$size - [string length $result]}] - set block [read $sock $need] - set eof [eof $sock] - append result $block - if {[string length $result] >= $size || $eof} { - return $result - } else { - yield - } - } -} - -# http::BlockingGets -# -# Replacement for a blocking gets. -# The caller must be a coroutine. -# Empty line is not distinguished from eof. The caller must -# be able to handle this. - -proc http::BlockingGets {sock} { - while 1 { - set count [gets $sock line] - set eof [eof $sock] - if {$count >= 0 || $eof} { - return $line - } else { - yield - } - } -} - # http::CopyStart # # Error handling wrapper around fcopy # # Arguments @@ -3261,62 +1221,18 @@ # token The token returned from http::geturl # # Side Effects # This closes the connection upon error -proc http::CopyStart {sock token {initial 1}} { - upvar #0 $token state - if {[info exists state(transfer)] && $state(transfer) eq "chunked"} { - foreach coding [ContentEncoding $token] { - lappend state(zlib) [zlib stream $coding] - } - make-transformation-chunked $sock [namespace code [list CopyChunk $token]] - } else { - if {$initial} { - foreach coding [ContentEncoding $token] { - zlib push $coding $sock - } - } - if {[catch { - # FIXME Keep-Alive on https tls::socket with unchunked transfer - # hangs until the server times out. A workaround is possible, as for - # the case without -channel, but it does not use the neat "fcopy" - # solution. - fcopy $sock $state(-channel) -size $state(-blocksize) -command \ - [list http::CopyDone $token] - } err]} { - Finish $token $err - } - } -} - -proc http::CopyChunk {token chunk} { +proc http::CopyStart {sock token} { + variable $token upvar 0 $token state - if {[set count [string length $chunk]]} { - incr state(currentsize) $count - if {[info exists state(zlib)]} { - foreach stream $state(zlib) { - set chunk [$stream add $chunk] - } - } - puts -nonewline $state(-channel) $chunk - if {[info exists state(-progress)]} { - eval [linsert $state(-progress) end \ - $token $state(totalsize) $state(currentsize)] - } - } else { - Log "CopyChunk Finish - token $token" - if {[info exists state(zlib)]} { - set excess "" - foreach stream $state(zlib) { - catch {set excess [$stream add -finalize $excess]} - } - puts -nonewline $state(-channel) $excess - foreach stream $state(zlib) { $stream close } - unset state(zlib) - } - Eot $token ;# FIX ME: pipelining. + if {[catch { + fcopy $sock $state(-channel) -size $state(-blocksize) -command \ + [list http::CopyDone $token] + } err]} then { + Finish $token $err } } # http::CopyDone # @@ -3336,87 +1252,69 @@ incr state(currentsize) $count if {[info exists state(-progress)]} { eval $state(-progress) \ [list $token $state(totalsize) $state(currentsize)] } - # At this point the token may have been reset. + # At this point the token may have been reset if {[string length $error]} { Finish $token $error } elseif {[catch {eof $sock} iseof] || $iseof} { - Eot $token + Eof $token } else { - CopyStart $sock $token 0 + CopyStart $sock $token } } -# http::Eot -# -# Called when either: -# a. An eof condition is detected on the socket. -# b. The client decides that the response is complete. -# c. The client detects an inconsistency and aborts the transaction. -# -# Does: -# 1. Set state(status) -# 2. Reverse any Content-Encoding -# 3. Convert charset encoding and line ends if necessary -# 4. Call http::Finish +# http::Eof +# +# Handle eof on the socket # # Arguments # token The token returned from http::geturl -# force (previously) optional, has no effect -# reason - "eof" means premature EOF (not EOF as the natural end of -# the response) -# - "" means completion of response, with or without EOF -# - anything else describes an error confition other than -# premature EOF. # # Side Effects # Clean up the socket -proc http::Eot {token {reason {}}} { +proc http::Eof {token {force 0}} { variable $token upvar 0 $token state - if {$reason eq "eof"} { - # Premature eof. + if {$state(state) eq "header"} { + # Premature eof set state(status) eof - set reason {} - } elseif {$reason ne ""} { - # Abort the transaction. - set state(status) $reason } else { - # The response is complete. set state(status) ok } - if {[string length $state(body)] > 0} { - if {[catch { - foreach coding [ContentEncoding $token] { - set state(body) [zlib $coding $state(body)] - } - } err]} { - Log "error doing decompression for token $token: $err" - Finish $token $err - return - } - - if {!$state(binary)} { - # If we are getting text, set the incoming channel's encoding - # correctly. iso8859-1 is the RFC default, but this could be any - # IANA charset. However, we only know how to convert what we have - # encodings for. - - set enc [CharsetToEncoding $state(charset)] - if {$enc ne "binary"} { - set state(body) [encoding convertfrom $enc $state(body)] - } - - # Translate text line endings. - set state(body) [string map {\r\n \n \r \n} $state(body)] - } - } - Finish $token $reason + if {($state(coding) eq "gzip") && [string length $state(body)] > 0} { + if {[catch { + if {[package vsatisfies [package provide Tcl] 8.6]} { + # The zlib integration into 8.6 includes proper gzip support + set state(body) [zlib gunzip $state(body)] + } else { + set state(body) [Gunzip $state(body)] + } + } err]} then { + return [Finish $token $err] + } + } + + if {!$state(binary)} { + # If we are getting text, set the incoming channel's encoding + # correctly. iso8859-1 is the RFC default, but this could be any IANA + # charset. However, we only know how to convert what we have + # encodings for. + + set enc [CharsetToEncoding $state(charset)] + if {$enc ne "binary"} { + set state(body) [encoding convertfrom $enc $state(body)] + } + + # Translate text line endings. + set state(body) [string map {\r\n \n \r \n} $state(body)] + } + + Finish $token } # http::wait -- # # See documentation for details. @@ -3423,11 +1321,11 @@ # # Arguments: # token Connection token. # # Results: -# The status after the wait. +# The status after the wait. proc http::wait {token} { variable $token upvar 0 $token state @@ -3450,16 +1348,10 @@ # # Results: # TODO proc http::formatQuery {args} { - if {[llength $args] % 2} { - return \ - -code error \ - -errorcode [list HTTP BADARGCNT $args] \ - {Incorrect number of arguments, must be an even number.} - } set result "" set sep "" foreach i $args { append result $sep [mapReply $i] if {$sep eq "="} { @@ -3493,18 +1385,17 @@ set string [encoding convertto $http(-urlencoding) $string] return [string map $formMap $string] } set converted [string map $formMap $string] if {[string match "*\[\u0100-\uffff\]*" $converted]} { - regexp "\[\u0100-\uffff\]" $converted badChar + regexp {[\u0100-\uffff]} $converted badChar # Return this error message for maximum compatibility... :^/ return -code error \ "can't read \"formMap($badChar)\": no such element in array" } return $converted } -interp alias {} http::quoteString {} http::mapReply # http::ProxyRequired -- # Default proxy filter. # # Arguments: @@ -3517,11 +1408,11 @@ variable http if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} { if { ![info exists http(-proxyport)] || ![string length $http(-proxyport)] - } { + } then { set http(-proxyport) 8080 } return [list $http(-proxyhost) $http(-proxyport)] } } @@ -3563,63 +1454,63 @@ } else { return "binary" } } -# Return the list of content-encoding transformations we need to do in order. -proc http::ContentEncoding {token} { - upvar 0 $token state - set r {} - if {[info exists state(coding)]} { - foreach coding [split $state(coding) ,] { - switch -exact -- $coding { - deflate { lappend r inflate } - gzip - x-gzip { lappend r gunzip } - compress - x-compress { lappend r decompress } - identity {} - default { - return -code error "unsupported content-encoding \"$coding\"" - } - } - } - } - return $r -} - -proc http::ReceiveChunked {chan command} { - set data "" - set size -1 - yield - while {1} { - chan configure $chan -translation {crlf binary} - while {[gets $chan line] < 1} { yield } - chan configure $chan -translation {binary binary} - if {[scan $line %x size] != 1} { - return -code error "invalid size: \"$line\"" - } - set chunk "" - while {$size && ![chan eof $chan]} { - set part [chan read $chan $size] - incr size -[string length $part] - append chunk $part - } - if {[catch { - uplevel #0 [linsert $command end $chunk] - }]} { - http::Log "Error in callback: $::errorInfo" - } - if {[string length $chunk] == 0} { - # channel might have been closed in the callback - catch {chan event $chan readable {}} - return - } - } -} - -proc http::make-transformation-chunked {chan command} { - coroutine [namespace current]::dechunk$chan ::http::ReceiveChunked $chan $command - chan event $chan readable [namespace current]::dechunk$chan +# http::Gunzip -- +# +# Decompress data transmitted using the gzip transfer coding. +# + +# FIX ME: redo using zlib sinflate +proc http::Gunzip {data} { + binary scan $data Scb5icc magic method flags time xfl os + set pos 10 + if {$magic != 0x1f8b} { + return -code error "invalid data: supplied data is not in gzip format" + } + if {$method != 8} { + return -code error "invalid compression method" + } + + # lassign [split $flags ""] f_text f_crc f_extra f_name f_comment + foreach {f_text f_crc f_extra f_name f_comment} [split $flags ""] break + set extra "" + if {$f_extra} { + binary scan $data @${pos}S xlen + incr pos 2 + set extra [string range $data $pos $xlen] + set pos [incr xlen] + } + + set name "" + if {$f_name} { + set ndx [string first \0 $data $pos] + set name [string range $data $pos $ndx] + set pos [incr ndx] + } + + set comment "" + if {$f_comment} { + set ndx [string first \0 $data $pos] + set comment [string range $data $pos $ndx] + set pos [incr ndx] + } + + set fcrc "" + if {$f_crc} { + set fcrc [string range $data $pos [incr pos]] + incr pos + } + + binary scan [string range $data end-7 end] ii crc size + set inflated [zlib inflate [string range $data $pos end-8]] + set chk [zlib crc32 $inflated] + if {($crc & 0xffffffff) != ($chk & 0xffffffff)} { + return -code error "invalid data: checksum mismatch $crc != $chk" + } + return $inflated } # Local variables: # indent-tabs-mode: t # End: Index: library/http/pkgIndex.tcl ================================================================== --- library/http/pkgIndex.tcl +++ library/http/pkgIndex.tcl @@ -1,2 +1,4 @@ -if {![package vsatisfies [package provide Tcl] 8.6-]} {return} -package ifneeded http 2.10.0a1 [list tclPkgSetup $dir http 2.10.0a1 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] +# Tcl package index file, version 1.1 + +if {![package vsatisfies [package provide Tcl] 8.4]} {return} +package ifneeded http 2.7.15 [list tclPkgSetup $dir http 2.7.15 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] ADDED library/http1.0/http.tcl Index: library/http1.0/http.tcl ================================================================== --- /dev/null +++ library/http1.0/http.tcl @@ -0,0 +1,377 @@ +# 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 http.n man page for documentation + +package provide http 1.0 + +array set http { + -accept */* + -proxyhost {} + -proxyport {} + -useragent {Tcl http client package 1.0} + -proxyfilter httpProxyRequired +} +proc http_config {args} { + global http + set options [lsort [array names http -*]] + set usage [join $options ", "] + if {[llength $args] == 0} { + set result {} + foreach name $options { + lappend result $name $http($name) + } + return $result + } + regsub -all -- - $options {} options + set pat ^-([join $options |])$ + if {[llength $args] == 1} { + set flag [lindex $args 0] + if {[regexp -- $pat $flag]} { + return $http($flag) + } else { + return -code error "Unknown option $flag, must be: $usage" + } + } else { + foreach {flag value} $args { + if {[regexp -- $pat $flag]} { + set http($flag) $value + } else { + return -code error "Unknown option $flag, must be: $usage" + } + } + } +} + + proc httpFinish { token {errormsg ""} } { + upvar #0 $token state + global errorInfo errorCode + if {[string length $errormsg] != 0} { + set state(error) [list $errormsg $errorInfo $errorCode] + set state(status) error + } + catch {close $state(sock)} + catch {after cancel $state(after)} + if {[info exists state(-command)]} { + if {[catch {eval $state(-command) {$token}} err]} { + if {[string length $errormsg] == 0} { + set state(error) [list $err $errorInfo $errorCode] + set state(status) error + } + } + unset state(-command) + } +} +proc http_reset { token {why reset} } { + upvar #0 $token state + set state(status) $why + catch {fileevent $state(sock) readable {}} + httpFinish $token + if {[info exists state(error)]} { + set errorlist $state(error) + unset state(error) + eval error $errorlist + } +} +proc http_get { url args } { + global http + if {![info exists http(uid)]} { + set http(uid) 0 + } + set token http#[incr http(uid)] + upvar #0 $token state + http_reset $token + array set state { + -blocksize 8192 + -validate 0 + -headers {} + -timeout 0 + state header + meta {} + currentsize 0 + totalsize 0 + type text/html + body {} + status "" + } + set options {-blocksize -channel -command -handler -headers \ + -progress -query -validate -timeout} + set usage [join $options ", "] + regsub -all -- - $options {} options + set pat ^-([join $options |])$ + foreach {flag value} $args { + if {[regexp $pat $flag]} { + # Validate numbers + if {[info exists state($flag)] && \ + [regexp {^[0-9]+$} $state($flag)] && \ + ![regexp {^[0-9]+$} $value]} { + return -code error "Bad value for $flag ($value), must be integer" + } + set state($flag) $value + } else { + return -code error "Unknown option $flag, can be: $usage" + } + } + if {! [regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \ + x proto host y port srvurl]} { + error "Unsupported URL: $url" + } + if {[string length $port] == 0} { + set port 80 + } + if {[string length $srvurl] == 0} { + set srvurl / + } + if {[string length $proto] == 0} { + set url http://$url + } + set state(url) $url + if {![catch {$http(-proxyfilter) $host} proxy]} { + set phost [lindex $proxy 0] + set pport [lindex $proxy 1] + } + if {$state(-timeout) > 0} { + set state(after) [after $state(-timeout) [list http_reset $token timeout]] + } + if {[info exists phost] && [string length $phost]} { + set srvurl $url + set s [socket $phost $pport] + } else { + set s [socket $host $port] + } + set state(sock) $s + + # Send data in cr-lf format, but accept any line terminators + + fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize) + + # The following is disallowed in safe interpreters, but the socket + # is already in non-blocking mode in that case. + + catch {fconfigure $s -blocking off} + set len 0 + set how GET + if {[info exists state(-query)]} { + set len [string length $state(-query)] + if {$len > 0} { + set how POST + } + } elseif {$state(-validate)} { + set how HEAD + } + puts $s "$how $srvurl HTTP/1.0" + puts $s "Accept: $http(-accept)" + puts $s "Host: $host" + puts $s "User-Agent: $http(-useragent)" + foreach {key value} $state(-headers) { + regsub -all \[\n\r\] $value {} value + set key [string trim $key] + if {[string length $key]} { + puts $s "$key: $value" + } + } + if {$len > 0} { + puts $s "Content-Length: $len" + puts $s "Content-Type: application/x-www-form-urlencoded" + puts $s "" + fconfigure $s -translation {auto binary} + puts -nonewline $s $state(-query) + } else { + puts $s "" + } + flush $s + fileevent $s readable [list httpEvent $token] + if {! [info exists state(-command)]} { + http_wait $token + } + return $token +} +proc http_data {token} { + upvar #0 $token state + return $state(body) +} +proc http_status {token} { + upvar #0 $token state + return $state(status) +} +proc http_code {token} { + upvar #0 $token state + return $state(http) +} +proc http_size {token} { + upvar #0 $token state + return $state(currentsize) +} + + proc httpEvent {token} { + upvar #0 $token state + set s $state(sock) + + if {[eof $s]} { + httpEof $token + return + } + if {$state(state) == "header"} { + set n [gets $s line] + if {$n == 0} { + set state(state) body + if {![regexp -nocase ^text $state(type)]} { + # Turn off conversions for non-text data + fconfigure $s -translation binary + if {[info exists state(-channel)]} { + fconfigure $state(-channel) -translation binary + } + } + if {[info exists state(-channel)] && + ![info exists state(-handler)]} { + # Initiate a sequence of background fcopies + fileevent $s readable {} + httpCopyStart $s $token + } + } elseif {$n > 0} { + if {[regexp -nocase {^content-type:(.+)$} $line x type]} { + set state(type) [string trim $type] + } + if {[regexp -nocase {^content-length:(.+)$} $line x length]} { + set state(totalsize) [string trim $length] + } + if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} { + lappend state(meta) $key $value + } elseif {[regexp ^HTTP $line]} { + set state(http) $line + } + } + } else { + if {[catch { + if {[info exists state(-handler)]} { + set n [eval $state(-handler) {$s $token}] + } else { + set block [read $s $state(-blocksize)] + set n [string length $block] + if {$n >= 0} { + append state(body) $block + } + } + if {$n >= 0} { + incr state(currentsize) $n + } + } err]} { + httpFinish $token $err + } else { + if {[info exists state(-progress)]} { + eval $state(-progress) {$token $state(totalsize) $state(currentsize)} + } + } + } +} + proc httpCopyStart {s token} { + upvar #0 $token state + if {[catch { + fcopy $s $state(-channel) -size $state(-blocksize) -command \ + [list httpCopyDone $token] + } err]} { + httpFinish $token $err + } +} + proc httpCopyDone {token count {error {}}} { + upvar #0 $token state + set s $state(sock) + incr state(currentsize) $count + if {[info exists state(-progress)]} { + eval $state(-progress) {$token $state(totalsize) $state(currentsize)} + } + if {([string length $error] != 0)} { + httpFinish $token $error + } elseif {[eof $s]} { + httpEof $token + } else { + httpCopyStart $s $token + } +} + proc httpEof {token} { + upvar #0 $token state + if {$state(state) == "header"} { + # Premature eof + set state(status) eof + } else { + set state(status) ok + } + set state(state) eof + httpFinish $token +} +proc http_wait {token} { + upvar #0 $token state + if {![info exists state(status)] || [string length $state(status)] == 0} { + vwait $token\(status) + } + if {[info exists state(error)]} { + set errorlist $state(error) + unset state(error) + eval error $errorlist + } + return $state(status) +} + +# Call http_formatQuery with an even number of arguments, where the first is +# a name, the second is a value, the third is another name, and so on. + +proc http_formatQuery {args} { + set result "" + set sep "" + foreach i $args { + append result $sep [httpMapReply $i] + if {$sep != "="} { + set sep = + } else { + set sep & + } + } + return $result +} + +# do x-www-urlencoded character mapping +# The spec says: "non-alphanumeric characters are replaced by '%HH'" +# 1 leave alphanumerics characters alone +# 2 Convert every other character to an array lookup +# 3 Escape constructs that are "special" to the tcl parser +# 4 "subst" the result, doing all the array substitutions + + proc httpMapReply {string} { + global httpFormMap + set alphanumeric a-zA-Z0-9 + if {![info exists httpFormMap]} { + + for {set i 1} {$i <= 256} {incr i} { + set c [format %c $i] + if {![string match \[$alphanumeric\] $c]} { + set httpFormMap($c) %[format %.2x $i] + } + } + # These are handled specially + array set httpFormMap { + " " + \n %0d%0a + } + } + regsub -all \[^$alphanumeric\] $string {$httpFormMap(&)} string + regsub -all \n $string {\\n} string + regsub -all \t $string {\\t} string + regsub -all {[][{})\\]\)} $string {\\&} string + return [subst $string] +} + +# Default proxy filter. + proc httpProxyRequired {host} { + global http + if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} { + if {![info exists http(-proxyport)] || ![string length $http(-proxyport)]} { + set http(-proxyport) 8080 + } + return [list $http(-proxyhost) $http(-proxyport)] + } else { + return {} + } +} ADDED library/http1.0/pkgIndex.tcl Index: library/http1.0/pkgIndex.tcl ================================================================== --- /dev/null +++ library/http1.0/pkgIndex.tcl @@ -0,0 +1,11 @@ +# Tcl package index file, version 1.0 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +package ifneeded http 1.0 [list tclPkgSetup $dir http 1.0 {{http.tcl source {httpCopyDone httpCopyStart httpEof httpEvent httpFinish httpMapReply httpProxyRequired http_code http_config http_data http_formatQuery http_get http_reset http_size http_status http_wait}}}] Index: library/init.tcl ================================================================== --- library/init.tcl +++ library/init.tcl @@ -4,24 +4,21 @@ # "unknown" procedure and auto-load facilities. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 Scriptics Corporation. -# Copyright (c) 2004 by Kevin B. Kenny. -# Copyright (c) 2018 by Sean Woods -# -# All rights reserved. +# Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # 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 9.0a2 +package require -exact Tcl 8.5.19 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: # # The environment variable TCLLIBPATH @@ -38,55 +35,125 @@ # same architecture as the current executable. # # tcl_pkgPath, which is set by the platform-specific initialization routines # On UNIX it is compiled in # On Windows, it is not used -# -# (Ticket 41c9857bdd) In a safe interpreter, this file does not set -# ::auto_path (other than to {} if it is undefined). The caller, typically -# a Safe Base command, is responsible for setting ::auto_path. if {![info exists auto_path]} { - if {[info exists env(TCLLIBPATH)] && (![interp issafe])} { + if {[info exists env(TCLLIBPATH)]} { set auto_path $env(TCLLIBPATH) } else { set auto_path "" } } namespace eval tcl { - if {![interp issafe]} { - variable Dir - foreach Dir [list $::tcl_library [file dirname $::tcl_library]] { - if {$Dir ni $::auto_path} { - lappend ::auto_path $Dir - } - } - set Dir [file join [file dirname [file dirname \ - [info nameofexecutable]]] lib] - if {$Dir ni $::auto_path} { - lappend ::auto_path $Dir - } - if {[info exists ::tcl_pkgPath]} { catch { - foreach Dir $::tcl_pkgPath { - if {$Dir ni $::auto_path} { - lappend ::auto_path $Dir - } - } - }} - - variable Path [encoding dirs] - set Dir [file join $::tcl_library encoding] - if {$Dir ni $Path} { - lappend Path $Dir - encoding dirs $Path - } - unset Dir Path - } -} - -namespace eval tcl::Pkg {} - + variable Dir + foreach Dir [list $::tcl_library [file dirname $::tcl_library]] { + if {$Dir ni $::auto_path} { + lappend ::auto_path $Dir + } + } + set Dir [file join [file dirname [file dirname \ + [info nameofexecutable]]] lib] + if {$Dir ni $::auto_path} { + lappend ::auto_path $Dir + } + if {[info exists ::tcl_pkgPath]} { catch { + foreach Dir $::tcl_pkgPath { + if {$Dir ni $::auto_path} { + lappend ::auto_path $Dir + } + } + }} + + if {![interp issafe]} { + variable Path [encoding dirs] + set Dir [file join $::tcl_library encoding] + if {$Dir ni $Path} { + lappend Path $Dir + encoding dirs $Path + } + } + + # TIP #255 min and max functions + namespace eval mathfunc { + proc min {args} { + if {![llength $args]} { + return -code error \ + "too few arguments to math function \"min\"" + } + set val Inf + foreach arg $args { + # This will handle forcing the numeric value without + # ruining the internal type of a numeric object + if {[catch {expr {double($arg)}} err]} { + return -code error $err + } + if {$arg < $val} {set val $arg} + } + return $val + } + proc max {args} { + if {![llength $args]} { + return -code error \ + "too few arguments to math function \"max\"" + } + set val -Inf + foreach arg $args { + # This will handle forcing the numeric value without + # ruining the internal type of a numeric object + if {[catch {expr {double($arg)}} err]} { + return -code error $err + } + if {$arg > $val} {set val $arg} + } + return $val + } + namespace export min max + } +} + +# Windows specific end of initialization + +if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} { + namespace eval tcl { + proc EnvTraceProc {lo n1 n2 op} { + global env + set x $env($n2) + set env($lo) $x + set env([string toupper $lo]) $x + } + proc InitWinEnv {} { + global env tcl_platform + foreach p [array names env] { + set u [string toupper $p] + if {$u ne $p} { + switch -- $u { + COMSPEC - + PATH { + set temp $env($p) + unset env($p) + set env($u) $temp + trace add variable env($p) write \ + [namespace code [list EnvTraceProc $p]] + trace add variable env($u) write \ + [namespace code [list EnvTraceProc $p]] + } + } + } + } + if {![info exists env(COMSPEC)]} { + if {$tcl_platform(os) eq "Windows NT"} { + set env(COMSPEC) cmd.exe + } else { + set env(COMSPEC) command.com + } + } + } + InitWinEnv + } +} # Setup the unknown package handler if {[interp issafe]} { @@ -104,24 +171,29 @@ # Set up the 'clock' ensemble namespace eval ::tcl::clock [list variable TclLibDir $::tcl_library] - proc ::tcl::initClock {} { + proc clock args { + namespace eval ::tcl::clock [list namespace ensemble create -command \ + [uplevel 1 [list namespace origin [lindex [info level 0] 0]]] \ + -subcommands { + add clicks format microseconds milliseconds scan seconds + }] + # Auto-loading stubs for 'clock.tcl' foreach cmd {add format scan} { proc ::tcl::clock::$cmd args { variable TclLibDir - source [file join $TclLibDir clock.tcl] + source -encoding utf-8 [file join $TclLibDir clock.tcl] return [uplevel 1 [info level 0]] } } - rename ::tcl::initClock {} + return [uplevel 1 [info level 0]] } - ::tcl::initClock } # Conditionalize for presence of exec. if {[namespace which -command exec] eq ""} { @@ -144,13 +216,15 @@ # unknown -- # This procedure is called when a Tcl command is invoked that doesn't # exist in the interpreter. It takes the following steps to make the # command available: # -# 1. See if the autoload facility can locate the command in a +# 1. See if the command has the form "namespace inscope ns cmd" and +# if so, concatenate its arguments onto the end and evaluate it. +# 2. See if the autoload facility can locate the command in a # Tcl script file. If so, load it and execute it. -# 2. If the command was invoked interactively at top-level: +# 3. If the command was invoked interactively at top-level: # (a) see if the command exists as an executable UNIX program. # If so, "exec" the command. # (b) see if the command requests csh-like history substitution # in one of the common forms !!, !, or ^old^new. If # so, emulate csh's history substitution. @@ -163,18 +237,26 @@ proc unknown args { variable ::tcl::UnknownPending global auto_noexec auto_noload env tcl_interactive errorInfo errorCode - if {[info exists errorInfo]} { - set savedErrorInfo $errorInfo - } - if {[info exists errorCode]} { - set savedErrorCode $errorCode + # If the command word has the form "namespace inscope ns cmd" + # then concatenate its arguments onto the end and evaluate it. + + set cmd [lindex $args 0] + if {[regexp "^:*namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} { + #return -code error "You need an {*}" + set arglist [lrange $args 1 end] + set ret [catch {uplevel 1 ::$cmd $arglist} result opts] + dict unset opts -errorinfo + dict incr opts -level + return -options $opts $result } - set name [lindex $args 0] + catch {set savedErrorInfo $errorInfo} + catch {set savedErrorCode $errorCode} + set name $cmd if {![info exists auto_noload]} { # # Make sure we're not trying to load the same proc twice. # if {[info exists UnknownPending($name)]} { @@ -219,13 +301,18 @@ while {[string bytelength $cinfo] > 150} { set cinfo [string range $cinfo 0 end-1] } append cinfo ... } - set tail "\n (\"uplevel\" body line 1)\n invoked\ - from within\n\"uplevel 1 \$args\"" - set expect "$msg\n while executing\n\"$cinfo\"$tail" + append cinfo "\"\n (\"uplevel\" body line 1)" + append cinfo "\n invoked from within" + append cinfo "\n\"uplevel 1 \$args\"" + # + # Try each possible form of the stack trace + # and trim the extra contribution from the matching case + # + set expect "$msg\n while executing\n\"$cinfo" if {$errInfo eq $expect} { # # The stack has only the eval from the expanded command # Do not generate any stack trace here. # @@ -235,36 +322,25 @@ } # # Stack trace is nested, trim off just the contribution # from the extra "eval" of $args due to the "catch" above. # - set last [string last $tail $errInfo] - if {$last + [string length $tail] != [string length $errInfo]} { - # Very likely cannot happen - return -options $opts $msg - } - set errInfo [string range $errInfo 0 $last-1] - set tail "\"$cinfo\"" - set last [string last $tail $errInfo] - if {$last < 0 || $last + [string length $tail] != [string length $errInfo]} { - return -code error -errorcode $errCode \ - -errorinfo $errInfo $msg - } - set errInfo [string range $errInfo 0 $last-1] - set tail "\n invoked from within\n" - set last [string last $tail $errInfo] - if {$last + [string length $tail] == [string length $errInfo]} { - return -code error -errorcode $errCode \ - -errorinfo [string range $errInfo 0 $last-1] $msg - } - set tail "\n while executing\n" - set last [string last $tail $errInfo] - if {$last + [string length $tail] == [string length $errInfo]} { - return -code error -errorcode $errCode \ - -errorinfo [string range $errInfo 0 $last-1] $msg - } - return -options $opts $msg + set expect "\n invoked from within\n\"$cinfo" + set exlen [string length $expect] + set eilen [string length $errInfo] + set i [expr {$eilen - $exlen - 1}] + set einfo [string range $errInfo 0 $i] + # + # For now verify that $errInfo consists of what we are about + # to return plus what we expected to trim off. + # + if {$errInfo ne "$einfo$expect"} { + error "Tcl bug: unexpected stack trace in \"unknown\"" {} \ + [list CORE UNKNOWN BADTRACE $einfo $expect $errInfo] + } + return -code error -errorcode $errCode \ + -errorinfo $einfo $msg } else { dict incr opts -level return -options $opts $msg } } @@ -334,12 +410,11 @@ } if {[llength $cmds]} { return -code error "ambiguous command name \"$name\": [lsort $cmds]" } } - return -code error -errorcode [list TCL LOOKUP COMMAND $name] \ - "invalid command name \"$name\"" + return -code error "invalid command name \"$name\"" } # auto_load -- # Checks a collection of library directories to see if a procedure # is defined in one of them. If so, it sources the appropriate @@ -393,26 +468,10 @@ } } return 0 } -# ::tcl::Pkg::source -- -# This procedure provides an alternative "source" command, which doesn't -# register the file for the "package files" command. Safe interpreters -# don't have to do anything special. -# -# Arguments: -# filename - -proc ::tcl::Pkg::source {filename} { - if {[interp issafe]} { - uplevel 1 [list ::source $filename] - } else { - uplevel 1 [list ::source -nopkg $filename] - } -} - # auto_load_index -- # Loads the contents of tclIndex files on the auto_path directory # list. This is usually invoked within auto_load to load the index # of available commands. Returns 1 if the index is loaded, and 0 if # the index is already loaded and up to date. @@ -440,11 +499,11 @@ catch {source [file join $dir tclIndex]} } elseif {[catch {set f [open [file join $dir tclIndex]]}]} { continue } else { set error [catch { - fconfigure $f -eofchar \032 + fconfigure $f -eofchar "\032 {}" set id [gets $f] if {$id eq "# Tcl autoload index file, version 2.0"} { eval [read $f] } elseif {$id eq "# Tcl autoload index file: each line identifies a Tcl"} { while {[gets $f line] >= 0} { @@ -452,11 +511,11 @@ || ([llength $line] != 2)} { continue } set name [lindex $line 0] set auto_index($name) \ - "::tcl::Pkg::source [file join $dir [lindex $line 1]]" + "source [file join $dir [lindex $line 1]]" } } else { error "[file join $dir tclIndex] isn't a proper Tcl index file" } } msg opts] @@ -589,11 +648,11 @@ if {[info exists auto_execs($name)]} { return $auto_execs($name) } set auto_execs($name) "" - set shellBuiltins [list assoc cls copy date del dir echo erase ftype \ + set shellBuiltins [list assoc cls copy date del dir echo erase exit ftype \ md mkdir mklink move rd ren rename rmdir start time type ver vol] if {[info exists env(PATHEXT)]} { # Add an initial ; to have the {} extension check first. set execExtensions [split ";$env(PATHEXT)" ";"] } else { @@ -626,11 +685,14 @@ set windir $env(SystemRoot) } elseif {[info exists env(WINDIR)]} { set windir $env(WINDIR) } if {[info exists windir]} { - append path "$windir/system32;$windir/system;$windir;" + if {$tcl_platform(os) eq "Windows NT"} { + append path "$windir/system32;" + } + append path "$windir/system;$windir;" } foreach var {PATH Path path} { if {[info exists env($var)]} { append path ";$env($var)" DELETED library/install.tcl Index: library/install.tcl ================================================================== --- library/install.tcl +++ /dev/null @@ -1,247 +0,0 @@ -### -# Installer actions built into tclsh and invoked -# if the first command line argument is "install" -### -if {[llength $argv] < 2} { - exit 0 -} -namespace eval ::practcl {} -### -# Installer tools -### -proc ::practcl::_isdirectory name { - return [file isdirectory $name] -} -### -# Return true if the pkgindex file contains -# any statement other than "package ifneeded" -# and/or if any package ifneeded loads a DLL -### -proc ::practcl::_pkgindex_directory {path} { - set buffer {} - set pkgidxfile [file join $path pkgIndex.tcl] - if {![file exists $pkgidxfile]} { - # No pkgIndex file, read the source - foreach file [glob -nocomplain $path/*.tm] { - set file [file normalize $file] - set fname [file rootname [file tail $file]] - ### - # We used to be able to ... Assume the package is correct in the filename - # No hunt for a "package provides" - ### - set package [lindex [split $fname -] 0] - set version [lindex [split $fname -] 1] - ### - # Read the file, and override assumptions as needed - ### - set fin [open $file r] - fconfigure $fin -encoding utf-8 -eofchar \032 - set dat [read $fin] - close $fin - # Look for a teapot style Package statement - foreach line [split $dat \n] { - set line [string trim $line] - if { [string range $line 0 9] != "# Package " } continue - set package [lindex $line 2] - set version [lindex $line 3] - break - } - # Look for a package provide statement - foreach line [split $dat \n] { - set line [string trim $line] - if { [string range $line 0 14] != "package provide" } continue - set package [lindex $line 2] - set version [lindex $line 3] - break - } - append buffer "package ifneeded $package $version \[list source \[file join \$dir [file tail $file]\]\]" \n - } - foreach file [glob -nocomplain $path/*.tcl] { - if { [file tail $file] == "version_info.tcl" } continue - set fin [open $file r] - fconfigure $fin -encoding utf-8 -eofchar \032 - set dat [read $fin] - close $fin - if {![regexp "package provide" $dat]} continue - set fname [file rootname [file tail $file]] - # Look for a package provide statement - foreach line [split $dat \n] { - set line [string trim $line] - if { [string range $line 0 14] != "package provide" } continue - set package [lindex $line 2] - set version [lindex $line 3] - if {[string index $package 0] in "\$ \[ @"} continue - if {[string index $version 0] in "\$ \[ @"} continue - append buffer "package ifneeded $package $version \[list source \[file join \$dir [file tail $file]\]\]" \n - break - } - } - return $buffer - } - set fin [open $pkgidxfile r] - fconfigure $fin -encoding utf-8 -eofchar \032 - set dat [read $fin] - close $fin - set trace 0 - #if {[file tail $path] eq "tool"} { - # set trace 1 - #} - set thisline {} - foreach line [split $dat \n] { - append thisline $line \n - if {![info complete $thisline]} continue - set line [string trim $line] - if {[string length $line]==0} { - set thisline {} ; continue - } - if {[string index $line 0] eq "#"} { - set thisline {} ; continue - } - if {[regexp "if.*catch.*package.*Tcl.*return" $thisline]} { - if {$trace} {puts "[file dirname $pkgidxfile] Ignoring $thisline"} - set thisline {} ; continue - } - if {[regexp "if.*package.*vsatisfies.*package.*provide.*return" $thisline]} { - if {$trace} { puts "[file dirname $pkgidxfile] Ignoring $thisline" } - set thisline {} ; continue - } - if {![regexp "package.*ifneeded" $thisline]} { - # This package index contains arbitrary code - # source instead of trying to add it to the main - # package index - if {$trace} { puts "[file dirname $pkgidxfile] Arbitrary code $thisline" } - return {source [file join $dir pkgIndex.tcl]} - } - append buffer $thisline \n - set thisline {} - } - if {$trace} {puts [list [file dirname $pkgidxfile] $buffer]} - return $buffer -} - - -proc ::practcl::_pkgindex_path_subdir {path} { - set result {} - foreach subpath [glob -nocomplain [file join $path *]] { - if {[file isdirectory $subpath]} { - lappend result $subpath {*}[_pkgindex_path_subdir $subpath] - } - } - return $result -} -### -# Index all paths given as though they will end up in the same -# virtual file system -### -proc ::practcl::pkgindex_path args { - set stack {} - set buffer { -lappend ::PATHSTACK $dir - } - foreach base $args { - set base [file normalize $base] - set paths {} - foreach dir [glob -nocomplain [file join $base *]] { - if {[file tail $dir] eq "teapot"} continue - lappend paths $dir {*}[::practcl::_pkgindex_path_subdir $dir] - } - set i [string length $base] - # Build a list of all of the paths - if {[llength $paths]} { - foreach path $paths { - if {$path eq $base} continue - set path_indexed($path) 0 - } - } else { - puts [list WARNING: NO PATHS FOUND IN $base] - } - set path_indexed($base) 1 - set path_indexed([file join $base boot tcl]) 1 - foreach teapath [glob -nocomplain [file join $base teapot *]] { - set pkg [file tail $teapath] - append buffer [list set pkg $pkg] - append buffer { -set pkginstall [file join $::g(HOME) teapot $pkg] -if {![file exists $pkginstall]} { - installDir [file join $dir teapot $pkg] $pkginstall -} -} - } - foreach path $paths { - if {$path_indexed($path)} continue - set thisdir [file_relative $base $path] - set idxbuf [::practcl::_pkgindex_directory $path] - if {[string length $idxbuf]} { - incr path_indexed($path) - append buffer "set dir \[set PKGDIR \[file join \[lindex \$::PATHSTACK end\] $thisdir\]\]" \n - append buffer [string map {$dir $PKGDIR} [string trimright $idxbuf]] \n - } - } - } - append buffer { -set dir [lindex $::PATHSTACK end] -set ::PATHSTACK [lrange $::PATHSTACK 0 end-1] -} - return $buffer -} - -### -# topic: 64319f4600fb63c82b2258d908f9d066 -# description: Script to build the VFS file system -### -proc ::practcl::installDir {d1 d2} { - - puts [format {%*sCreating %s} [expr {4 * [info level]}] {} [file tail $d2]] - file delete -force -- $d2 - file mkdir $d2 - - foreach ftail [glob -directory $d1 -nocomplain -tails *] { - set f [file join $d1 $ftail] - if {[file isdirectory $f] && [string compare CVS $ftail]} { - installDir $f [file join $d2 $ftail] - } elseif {[file isfile $f]} { - file copy -force $f [file join $d2 $ftail] - if {$::tcl_platform(platform) eq {unix}} { - file attributes [file join $d2 $ftail] -permissions 0644 - } else { - file attributes [file join $d2 $ftail] -readonly 1 - } - } - } - - if {$::tcl_platform(platform) eq {unix}} { - file attributes $d2 -permissions 0755 - } else { - file attributes $d2 -readonly 1 - } -} - -proc ::practcl::copyDir {d1 d2 {toplevel 1}} { - #if {$toplevel} { - # puts [list ::practcl::copyDir $d1 -> $d2] - #} - #file delete -force -- $d2 - file mkdir $d2 - - foreach ftail [glob -directory $d1 -nocomplain -tails *] { - set f [file join $d1 $ftail] - if {[file isdirectory $f] && [string compare CVS $ftail]} { - copyDir $f [file join $d2 $ftail] 0 - } elseif {[file isfile $f]} { - file copy -force $f [file join $d2 $ftail] - } - } -} - -switch [lindex $argv 1] { - mkzip { - zipfs mkzip {*}[lrange $argv 2 end] - } - mkzip { - zipfs mkimg {*}[lrange $argv 2 end] - } - default { - ::practcl::[lindex $argv 1] {*}[lrange $argv 2 end] - } -} -exit 0 DELETED library/manifest.txt Index: library/manifest.txt ================================================================== --- library/manifest.txt +++ /dev/null @@ -1,20 +0,0 @@ -### -# Package manifest for all Tcl packages included in the /library file system -### -apply {{dir} { - set ::test [info script] - set isafe [interp issafe] - foreach {safe package version file} { - 0 http 2.10.0a1 {http http.tcl} - 1 msgcat 1.7.1 {msgcat msgcat.tcl} - 1 opt 0.4.8 {opt optparse.tcl} - 0 cookiejar 0.2.0 {cookiejar cookiejar.tcl} - 0 tcl::idna 1.0.1 {cookiejar idna.tcl} - 0 platform 1.0.14 {platform platform.tcl} - 0 platform::shell 1.1.4 {platform shell.tcl} - 1 tcltest 2.5.3 {tcltest tcltest.tcl} - } { - if {$isafe && !$safe} continue - package ifneeded $package $version [list source [file join $dir {*}$file]] - } -}} $dir Index: library/msgcat/msgcat.tcl ================================================================== --- library/msgcat/msgcat.tcl +++ library/msgcat/msgcat.tcl @@ -2,55 +2,39 @@ # # This file defines various procedures which implement a # message catalog facility for Tcl programs. It should be # loaded with the command "package require msgcat". # -# Copyright (c) 2010-2018 by Harald Oehlmann. # Copyright (c) 1998-2000 by Ajuba Solutions. # Copyright (c) 1998 by Mark Harrison. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# We use oo::define::self, which is new in Tcl 8.7 -package require Tcl 8.7- +package require Tcl 8.5 # 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 +package provide msgcat 1.5.2 namespace eval msgcat { - namespace export mc mcn mcexists mcload mclocale mcmax\ - mcmset mcpreferences mcset\ - mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\ - mcpackagenamespaceget mcpackageconfig mcpackagelocale mcutil + namespace export mc mcload mclocale mcmax mcmset mcpreferences mcset \ + mcunknown mcflset mcflmset + + # Records the current locale as passed to mclocale + variable Locale "" # Records the list of locales to search variable Loclist {} - # List of currently loaded locales - variable LoadedLocales {} - # Records the locale of the currently sourced message catalogue file variable FileLocale - # Configuration values per Package (e.g. client namespace). - # The dict key is of the form "